KIDS Distribution saved on Oct 06, 2013@11:12:11 Radiology 5.0 Patch 1005 **KIDS**:RA*5.0*1005^ **INSTALL NAME** RA*5.0*1005 "BLD",4066,0) RA*5.0*1005^^0^3131006^n "BLD",4066,4,0) ^9.64PA^^0 "BLD",4066,6.3) 13 "BLD",4066,"KRN",0) ^9.67PA^9002226^21 "BLD",4066,"KRN",.4,0) .4 "BLD",4066,"KRN",.401,0) .401 "BLD",4066,"KRN",.402,0) .402 "BLD",4066,"KRN",.402,"NM",0) ^9.68A^1^1 "BLD",4066,"KRN",.402,"NM",1,0) RA EXAM EDIT FILE #70^70^0 "BLD",4066,"KRN",.402,"NM","B","RA EXAM EDIT FILE #70",1) "BLD",4066,"KRN",.403,0) .403 "BLD",4066,"KRN",.5,0) .5 "BLD",4066,"KRN",.84,0) .84 "BLD",4066,"KRN",3.6,0) 3.6 "BLD",4066,"KRN",3.8,0) 3.8 "BLD",4066,"KRN",9.2,0) 9.2 "BLD",4066,"KRN",9.8,0) 9.8 "BLD",4066,"KRN",9.8,"NM",0) ^9.68A^20^20 "BLD",4066,"KRN",9.8,"NM",1,0) RACMP1^^0^B28449673 "BLD",4066,"KRN",9.8,"NM",2,0) RAMAG03C^^0^B29412190 "BLD",4066,"KRN",9.8,"NM",3,0) RAORD1A^^0^B11426666 "BLD",4066,"KRN",9.8,"NM",4,0) RAORD3^^0^B27371696 "BLD",4066,"KRN",9.8,"NM",5,0) RAORD6^^0^B60885097 "BLD",4066,"KRN",9.8,"NM",6,0) RAPROD^^0^B46236144 "BLD",4066,"KRN",9.8,"NM",7,0) RAREG2^^0^B68906151 "BLD",4066,"KRN",9.8,"NM",8,0) RART1^^0^B64654453 "BLD",4066,"KRN",9.8,"NM",9,0) RARTE^^0^B45301421 "BLD",4066,"KRN",9.8,"NM",10,0) RARTE6^^0^B146173116 "BLD",4066,"KRN",9.8,"NM",11,0) RARTR^^0^B65349154 "BLD",4066,"KRN",9.8,"NM",12,0) RARTR0^^0^B73964399 "BLD",4066,"KRN",9.8,"NM",13,0) RASTED^^0^B56315958 "BLD",4066,"KRN",9.8,"NM",14,0) RASTREQ^^0^B56495066 "BLD",4066,"KRN",9.8,"NM",15,0) RAUTL8^^0^B76092917 "BLD",4066,"KRN",9.8,"NM",16,0) RAHLQ1^^0^B11208965 "BLD",4066,"KRN",9.8,"NM",17,0) RAHLR^^0^B62394344 "BLD",4066,"KRN",9.8,"NM",18,0) RAHLRPTT^^0^B20277165 "BLD",4066,"KRN",9.8,"NM",19,0) RAMAG02A^^0^B42486101 "BLD",4066,"KRN",9.8,"NM",20,0) RAO7NEW^^0^B43392466 "BLD",4066,"KRN",9.8,"NM","B","RACMP1",1) "BLD",4066,"KRN",9.8,"NM","B","RAHLQ1",16) "BLD",4066,"KRN",9.8,"NM","B","RAHLR",17) "BLD",4066,"KRN",9.8,"NM","B","RAHLRPTT",18) "BLD",4066,"KRN",9.8,"NM","B","RAMAG02A",19) "BLD",4066,"KRN",9.8,"NM","B","RAMAG03C",2) "BLD",4066,"KRN",9.8,"NM","B","RAO7NEW",20) "BLD",4066,"KRN",9.8,"NM","B","RAORD1A",3) "BLD",4066,"KRN",9.8,"NM","B","RAORD3",4) "BLD",4066,"KRN",9.8,"NM","B","RAORD6",5) "BLD",4066,"KRN",9.8,"NM","B","RAPROD",6) "BLD",4066,"KRN",9.8,"NM","B","RAREG2",7) "BLD",4066,"KRN",9.8,"NM","B","RART1",8) "BLD",4066,"KRN",9.8,"NM","B","RARTE",9) "BLD",4066,"KRN",9.8,"NM","B","RARTE6",10) "BLD",4066,"KRN",9.8,"NM","B","RARTR",11) "BLD",4066,"KRN",9.8,"NM","B","RARTR0",12) "BLD",4066,"KRN",9.8,"NM","B","RASTED",13) "BLD",4066,"KRN",9.8,"NM","B","RASTREQ",14) "BLD",4066,"KRN",9.8,"NM","B","RAUTL8",15) "BLD",4066,"KRN",19,0) 19 "BLD",4066,"KRN",19.1,0) 19.1 "BLD",4066,"KRN",101,0) 101 "BLD",4066,"KRN",409.61,0) 409.61 "BLD",4066,"KRN",771,0) 771 "BLD",4066,"KRN",779.2,0) 779.2 "BLD",4066,"KRN",870,0) 870 "BLD",4066,"KRN",8989.51,0) 8989.51 "BLD",4066,"KRN",8989.52,0) 8989.52 "BLD",4066,"KRN",8994,0) 8994 "BLD",4066,"KRN",9002226,0) 9002226 "BLD",4066,"KRN","B",.4,.4) "BLD",4066,"KRN","B",.401,.401) "BLD",4066,"KRN","B",.402,.402) "BLD",4066,"KRN","B",.403,.403) "BLD",4066,"KRN","B",.5,.5) "BLD",4066,"KRN","B",.84,.84) "BLD",4066,"KRN","B",3.6,3.6) "BLD",4066,"KRN","B",3.8,3.8) "BLD",4066,"KRN","B",9.2,9.2) "BLD",4066,"KRN","B",9.8,9.8) "BLD",4066,"KRN","B",19,19) "BLD",4066,"KRN","B",19.1,19.1) "BLD",4066,"KRN","B",101,101) "BLD",4066,"KRN","B",409.61,409.61) "BLD",4066,"KRN","B",771,771) "BLD",4066,"KRN","B",779.2,779.2) "BLD",4066,"KRN","B",870,870) "BLD",4066,"KRN","B",8989.51,8989.51) "BLD",4066,"KRN","B",8989.52,8989.52) "BLD",4066,"KRN","B",8994,8994) "BLD",4066,"KRN","B",9002226,9002226) "BLD",4066,"QDEF") ^^^^NO^^^^NO^^NO "BLD",4066,"QUES",0) ^9.62^^ "KRN",.402,1487,-1) 0^1 "KRN",.402,1487,0) RA EXAM EDIT^3130621.0533^^70^^^3131006 "KRN",.402,1487,"%D",0) ^.4021^1^1^3090722^^^^ "KRN",.402,1487,"%D",1,0) This template is used to edit exams. "KRN",.402,1487,"AR",70.03,164) 1^RACTEX13 "KRN",.402,1487,"DIAB",1,2,70.03,12) NUCLEAR MED DATA: "KRN",.402,1487,"DIAB",1,3,70.1,0) ALL "KRN",.402,1487,"DIAB",1,3,70.12,0) ALL "KRN",.402,1487,"DIAB",1,3,70.3135,0) ALL "KRN",.402,1487,"DIAB",1,3,70.3225,0) ALL "KRN",.402,1487,"DIAB",1,4,70.21,5) DOSE ADMINISTERED//^S X=RADRAWN;T "KRN",.402,1487,"DIAB",2,2,70.03,9) 32;REQ "KRN",.402,1487,"DIAB",2,4,70.21,3) ACTIVITY DRAWN (in mCi);T "KRN",.402,1487,"DIAB",3,2,70.03,1) 2;REQ "KRN",.402,1487,"DIAB",3,2,70.03,8) CONTRACT/SHARING SOURCE;REQ "KRN",.402,1487,"DIAB",4,2,70.03,9) 80;REQ "KRN",.402,1487,"DIAB",6,2,70.03,7) WARD;REQ "KRN",.402,1487,"DIAB",6,2,70.03,8) PRINCIPAL CLINIC;REQ "KRN",.402,1487,"DIAB",6,4,70.21,6) PRESCRIBED DOSE BY MD OVERRIDE;T "KRN",.402,1487,"DIAB",7,2,70.03,7) SERVICE;REQ "KRN",.402,1487,"DIAB",8,2,70.03,7) BEDSECTION;REQ "KRN",.402,1487,"DIAB",11,2,70.03,7) RESEARCH SOURCE;REQ "KRN",.402,1487,"DR",1,70) I '$D(RADTE)!('$D(RACN))!('$D(RAQUICK))!('$D(RAMDV)) W !?3,$C(7),"You must have the variables for 'Case Number','Exam Date' and",!?3,"'Rad/Nuc Med Division' defined to continue!" S Y="@999";S RAPOP=0 D USER^RAUTL S:RAPOP Y="@999"; "KRN",.402,1487,"DR",1,70,1) 2///^S X=RADTE;@999;K RAOIFN,RAY,RAR,RA0,RACAT,RAI,RAIEN702,RANUZD1; "KRN",.402,1487,"DR",2,70.02) I $P(^DPT(RADFN,0),U,2)="M" S Y="@498";S X1=DT,X2=$P(^DPT(RADFN,0),U,3) D ^%DTC S RAGE=X/365.25 I RAGE<13!(RAGE>50) S Y="@498";498;499;500;@498;50///^S X=RACN;@800; "KRN",.402,1487,"DR",3,70.03) S RAREM="RANUZD1 = case's Img typ's 'Radiopharm Used'";S:$P($G(^RA(79.2,+$P($G(^RADPT(DA(2),"DT",DA(1),0)),"^",2),0)),"^",5)="Y" RANUZD1="";S RAY=^RADPT(DA(2),"DT",DA(1),"P",DA,0) F RAI=1:1:18 S RA0(RAI)=$P(RAY,U,RAI); "KRN",.402,1487,"DR",3,70.03,1) S RAR=$S($D(^RADPT(DA(2),"DT",DA(1),"P",DA,"R")):^("R"),1:"");@20;2R~;S RAPRI=+X;S RAREM="did user change the procedure ?";I RAPRI=RA0(2) S Y="@19";S RAREM="if procedures change, make sure CM associations are preserved..."; "KRN",.402,1487,"DR",3,70.03,2) D CHGPRC^RAUTL21(RA0(2),RAPRI,.DA);D WARNPRC^RAUTL;I RAWHICH=0 S Y="@19";I RAWHICH=2 S Y="@17";W !,"... Deleting radiopharms ...",!;500///@;@17;I RAWHICH=1 S Y="@19";W !,"... Deleting Medications ...",!; "KRN",.402,1487,"DR",3,70.03,3) K ^RADPT(DA(2),"DT",DA(1),"P",DA,"RX");@19;I '$P(RAMDV,U,7)!($P(^RAMIS(71,+RAPRI,0),U,6)'="B") S Y="@21";W !?3,$C(7),"A 'detailed' procedure or a 'series' of procedures is required!";2///@;S Y="@20";@21;S:'$$FUTC^RACPTCSV Y="@20"; "KRN",.402,1487,"DR",3,70.03,4) S RAREM="determine if CM is used for this procedure";S RAZCM=$O(^RAMIS(71,RAPRI,"CM","B",""));10//^S X=$S(RAZCM'="":"YES",1:"NO");S RAZCM(0)=X;S:$E(RAZCM(0))="N" Y=$$PRGCM^RAMAINU(.DA); "KRN",.402,1487,"DR",3,70.03,5) D:$E(RAZCM(0))="Y"&('+$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"CM",0))) STUFCM70^RAMAINU(.DA,RAPRI);S X=X;225;D:+$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"CM",0))=0 UPXCM^RAMAINU(.DA,"N");@225;125;@37;D:$T(DISCMOD^RACPTMSC)]"" DISCMOD^RACPTMSC; "KRN",.402,1487,"DR",3,70.03,6) 135;S:'$$FUTCMOD^RACPTCSV Y="@37";4;S RACAT=X;S:RA0(4)=RACAT Y="@4";S:RA0(8)']"" Y="@1";8///@;@1;S:RA0(9)']"" Y="@2";9///@;@2;S:RA0(6)']"" Y="@10";6///@;@10;S:RA0(7)']"" Y="@11";7///@;@11;S:$P(RAY,"^",19)']"" Y="@3";19///@;@3; "KRN",.402,1487,"DR",3,70.03,7) S:RAR']"" Y="@4";9.5///@;@4;S Y=$S(RACAT="I":"@5",RACAT="E":"@12",RACAT="R":"@6","CS"[RACAT:"@7",1:"@8");@5;6R~;7R~;19R~;S Y="@100";@6;9.5R~;@12;I '$D(VADMVT) S DFN=DA(2),VAINDT=9999999.9999-DA(1) D ADM^VADPT2; "KRN",.402,1487,"DR",3,70.03,8) S Y=$S(VADMVT:"@5",1:"@8");@7;9R~;S Y="@100";@8;8R~;@100;14;175;S RATCXX=$$TCPROMPT^RAO7XX;S Y=$$ASKPREG^RAUTL8();S RAOIFN=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,11); "KRN",.402,1487,"DR",3,70.03,9) W !," PREGNANT AT TIME OF ORDER ENTRY: ",$$GET1^DIQ(75.1,$G(RAOIFN)_",",13);32R~;S RAPRSCR=$$PRSCR^RAUTL8(RADFN,RADTI,RACNI,"I") K:RAPRSCR="n" ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCOMM") S:RAPRSCR="n" Y="@8001" K RAPRSCR;80R~; "KRN",.402,1487,"DR",3,70.03,10) @8001;16//^S X=$S($D(^RA(78.1,"B","NO COMPLICATION")):"NO COMPLICATION",1:"");S:'$D(^RA(78.1,+X,0)) Y="@130";S:$P(^RA(78.1,+X,0),U)="NO COMPLICATION" Y="@130";16.5;@130;S:'$P(RAMDV,U,9) Y="@140";18;@140;50;@99; "KRN",.402,1487,"DR",3,70.03,11) S:'$D(RANUZD1) Y="@700";S RAREM="skip radio section if case' Img Typ's 'RADIO...USED' is NEVER";S:$P(^RAMIS(71,+RAPRI,0),U,2)=1 Y="@700";S RAIEN702=$$EN1^RANMPT1(RADFN,RADTE,RACN);S:RAIEN702=-1 Y="@700";500////^S X=RAIEN702; "KRN",.402,1487,"DR",3,70.03,12) ^70.2^RADPTN(^^S I(2,0)=D2 S I(1,0)=D1 S I(0,0)=D0 S Y(1)=$S($D(^RADPT(D0,"DT",D1,"P",D2,0)):^(0),1:"") S X=$P(Y(1),U,28),X=X S D(0)=+X S X=$S(D(0)>0:D(0),1:"");@700;S RA00=$O(^RADPTN("AA",RADFN,RADTE,RACN,0));S:'RA00 Y="@710"; "KRN",.402,1487,"DR",3,70.03,13) S:$O(^RADPTN(RA00,"NUC",0)) Y="@710";K RAIEN702;500///@;@710;S RACT=$S(RAQUICK:"C",1:"P");100///^S X="""NOW""";S RAREM="here, DIE is ^RADPT(-,'DT',-,'P',";S RA00=$O(@(DIE_DA_",""RX"","_"0)")); "KRN",.402,1487,"DR",3,70.03,14) S RA00=$G(@(DIE_DA_",""RX"","_+RA00_",0)"));S:RA00]"" Y="@720";S RASKMEDS=$P(^RAMIS(71,+RAPRI,0),U,5) S:RASKMEDS=""!("Yy"'[RASKMEDS) Y="@790";@720;200;S:$G(RA65("RESULT"))'="" Y="MEDICATIONS";@790;K RA65; "KRN",.402,1487,"DR",4,70.04) .01;2; "KRN",.402,1487,"DR",4,70.07) 2///^S X=RACT;3////^S X=RADUZ;4///^S X=RATCXX;S:RATCXX'="" Y="@18";4///@;K ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",DA,"TCOM");@18;K RATCXX; "KRN",.402,1487,"DR",4,70.1) .01 "KRN",.402,1487,"DR",4,70.12) .01 "KRN",.402,1487,"DR",4,70.15) .01;2;S:$P(RA00,U,3)="" Y="@740";3//^S X="NOW";@740;S:$P(RA00,U,4)="" Y="@750";4//^S X=$P($G(^VA(200,DUZ,0)),"^");@750; "KRN",.402,1487,"DR",4,70.2) D DISDEF^RASTREQN(RAIEN702);100; "KRN",.402,1487,"DR",4,70.3135) .01 "KRN",.402,1487,"DR",4,70.3225) .01 "KRN",.402,1487,"DR",5,70.21) .01;S RAPSDRUG=X;S:'$G(D0) Y="@500";S RAREM="NOTE: here, DIE is ^RADPTN(D0,'NUC',";S:DIE'[",""NUC""" Y="@500";S RA00=$G(@(DIE_DA_",0)"));S:RA00="" Y="@500";@210; "KRN",.402,1487,"DR",5,70.21,1) S RADIOPH=$O(^RAMIS(71,$G(RAPRI),"NUC","B",+$G(RAPSDRUG),0)),(RALOW,RAHI,RADRAWN,RADOSE,RASKMEDS)="";S:'RADIOPH Y="@220";S RADIOPH=$G(^RAMIS(71,$G(RAPRI),"NUC",RADIOPH,0)),RALOW=$P(RADIOPH,U,6),RAHI=$P(RADIOPH,U,5);@220; "KRN",.402,1487,"DR",5,70.21,2) S:$P(RA00,U,4)="" Y="@230";@225;W:RAHI]""!(RALOW]"")!($P(RADIOPH,U,2)]"") !! W:RAHI]"" "High Dose :",RAHI_" mCi" W:RALOW]"" ?27,"Low Dose :",RALOW_" mCi" W:$P(RADIOPH,U,2)]"" ?53,"Usual Dose :",$P(RADIOPH,U,2)_" mCi"; "KRN",.402,1487,"DR",5,70.21,3) W:RAHI]""!(RALOW]"")!($P(RADIOPH,U,2)]"") !;4T~;S RADRAWN=X;S Y=$$VALDOS^RASTREQN(RALOW,RAHI,RADRAWN,"@225","@230","@999",0);@230;S:$P(RA00,U,5)="" Y="@240";5;@240;S:$P(RA00,U,6)="" Y="@250";6;@250; "KRN",.402,1487,"DR",5,70.21,4) W:RAHI]""!(RALOW]"")!($P(RADIOPH,U,2)]"") !! W:RAHI]"" "High Dose: ",RAHI_" mCi" W:RALOW]"" ?27,"Low Dose: ",RALOW_" mCi" W:$P(RADIOPH,U,2)]"" ?53,"Usual Dose: ",$P(RADIOPH,U,2)," mCi";W:RAHI]""!(RALOW]"")!($P(RADIOPH,U,2)]"") !; "KRN",.402,1487,"DR",5,70.21,5) 7T~//^S X=RADRAWN;S RADOSE=X;S:RALOW]""&(XRAHI) Y="@255";S Y="@258";@255;D WARN^RANMED1;R !!,"OK to continue (Y/N) ?: N//",RAASK;W !;S RAASK=$E(RAASK);S:"Yy"'[RAASK!(RAASK="") Y="@250"; "KRN",.402,1487,"DR",5,70.21,6) S RAREM="is fil 71's PROMPT FOR RADIOPHARM RX yes ?";@258;S RAASK=$P($G(^RAMIS(71,+RAPRI,0)),U,19) S:RAASK=""!("Yy"'[RAASK) Y="@270";@260;3;2T~;@270;8//^S X=$S($P($G(^RADPTN(DA(1),"NUC",DA,0)),"^",5)]"":$P(^(0),"^",5),1:"NOW"); "KRN",.402,1487,"DR",5,70.21,7) 9//^S X=$P(^VA(200,+$G(DUZ),0),U);@290;S:$P(RA00,U,6)="" Y="@310";6;@310;S RAREM="Note: 'RAASK' may not be defined, hit global for 'Prompt For Radiopharm RX'";S:$P($G(^RAMIS(71,RAPRI,0)),"^",19)'="y" Y="@320";10;@320; "KRN",.402,1487,"DR",5,70.21,8) S:$P(RA00,U,11)="" Y="@330";11;@330;S:$P(RA00,U,12)="" Y="@335";12;@335;S:'$D(@(DIE_DA_",""SITX"")")) Y="@340";12.5;@340;S:$P(RA00,U,13)="" Y="@350";13;@350;S:$P(RA00,U,14)="" Y="@360";14;@360;S:$P(RA00,U,15)="" Y="@500";15;@500; "KRN",.402,1487,"ROU") ^RACTEX "KRN",.402,1487,"ROUOLD") RACTEX "MBREQ") 0 "ORD",7,.402) .402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%) "ORD",7,.402,0) INPUT TEMPLATE "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 20 "RTN","RACMP1") 0^1^B28449673 "RTN","RACMP1",1,0) RACMP1 ;HISC/GJC,RVD-Complication Report (Part 2 of 3) ; 06 Oct 2013 11:02 AM "RTN","RACMP1",2,0) ;;5.0;Radiology/Nuclear Medicine;**99,1005**;Mar 16, 1998;Build 13 "RTN","RACMP1",3,0) ;Supported IA #10103 reference to ^XLFDT "RTN","RACMP1",4,0) ;Supported IA #2056 reference to ^DIQ "RTN","RACMP1",5,0) ;Supported IA #10060 reference to ^VA(200 "RTN","RACMP1",6,0) PRINT ; Output subroutine part one "RTN","RACMP1",7,0) N I,J,RADATE,RAINVDT,RALBL,RALN1,RATECH "RTN","RACMP1",8,0) S RA1="",RALBL="Description: ",RALN1=$TR(RALN,$E(RALN),"=") "RTN","RACMP1",9,0) F S RA1=$O(^TMP($J,"RACMP",RA1)) Q:RA1']"" D Q:RAXIT "RTN","RACMP1",10,0) . S RADIV=RA1,RADIV("X")=$P($G(^DIC(4,RADIV,0)),"^"),RA2="" "RTN","RACMP1",11,0) . F S RA2=$O(^TMP($J,"RACMP",RA1,RA2)) Q:RA2']"" D Q:RAXIT "RTN","RACMP1",12,0) .. S RAITYPE=RA2,RA3="" "RTN","RACMP1",13,0) .. F S RA3=$O(^TMP($J,"RACMP",RA1,RA2,RA3)) Q:RA3']"" D Q:RAXIT "RTN","RACMP1",14,0) ... S RA4=0 "RTN","RACMP1",15,0) ... F S RA4=$O(^TMP($J,"RACMP",RA1,RA2,RA3,RA4)) Q:'RA4 D Q:RAXIT "RTN","RACMP1",16,0) .... S RA5=0 "RTN","RACMP1",17,0) .... F S RA5=$O(^TMP($J,"RACMP",RA1,RA2,RA3,RA4,RA5)) Q:'RA5 D Q:RAXIT "RTN","RACMP1",18,0) ..... S RA0=$G(^TMP($J,"RACMP",RA1,RA2,RA3,RA4,RA5)) "RTN","RACMP1",19,0) ..... D:RA0]"" PRT1 "RTN","RACMP1",20,0) ..... Q "RTN","RACMP1",21,0) .... Q "RTN","RACMP1",22,0) ... Q "RTN","RACMP1",23,0) .. D:'RAXIT IMGCHK "RTN","RACMP1",24,0) .. Q "RTN","RACMP1",25,0) . D:'RAXIT DIVCHK "RTN","RACMP1",26,0) . Q "RTN","RACMP1",27,0) Q "RTN","RACMP1",28,0) PRT1 ; Output subroutine two "RTN","RACMP1",29,0) F I=1:1:9 D "RTN","RACMP1",30,0) . S @$P("RAPRC^RATME^RAPHY^RARES^RASTF^RACMPTX^RACOMP^RASSN^RADFN","^",I)=$P(RA0,"^",I) "RTN","RACMP1",31,0) . Q "RTN","RACMP1",32,0) S RADATE=$$FMTE^XLFDT(RA4,"2D"),RAINVDT=9999999.9999-RA4 "RTN","RACMP1",33,0) I $Y>(IOSL-4) D Q:RAXIT "RTN","RACMP1",34,0) . S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2 "RTN","RACMP1",35,0) . Q "RTN","RACMP1",36,0) I IOM=132 D "RTN","RACMP1",37,0) . W !,RA3,?RATAB(2),RASSN,?RATAB(3),RADATE,?RATAB(4),RAPRC "RTN","RACMP1",38,0) . W ?RATAB(5),"Physician: ",RAPHY,!?RATAB(3),RATME,?RATAB(4),RACOMP "RTN","RACMP1",39,0) . W ?RATAB(5),"Interpreting Res. : ",RARES "RTN","RACMP1",40,0) . W !?RATAB(5),"Staff Imaging Phys. : ",RASTF "RTN","RACMP1",41,0) . I +$O(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",0)) S I=0 D Q:RAXIT "RTN","RACMP1",42,0) .. F S I=$O(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",I)) Q:'I D Q:RAXIT "RTN","RACMP1",43,0) ... S J=$G(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",I,0)) "RTN","RACMP1",44,0) ... S RATECH=$E($P($G(^VA(200,+J,0)),"^"),1,20) "RTN","RACMP1",45,0) ... I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2 "RTN","RACMP1",46,0) ... W:'RAXIT !?RATAB(5),"Tech: ",RATECH "RTN","RACMP1",47,0) ... Q "RTN","RACMP1",48,0) .. Q "RTN","RACMP1",49,0) . D PRSC "RTN","RACMP1",50,0) . W:'RAXIT !,RALBL,RACMPTX,!,RALN1 "RTN","RACMP1",51,0) . Q "RTN","RACMP1",52,0) E D ; Assume 80 "RTN","RACMP1",53,0) . W !,RA3,?RATAB(3),RADATE,?RATAB(4),RAPRC,!,RASSN,?RATAB(3),RATME "RTN","RACMP1",54,0) . W ?RATAB(4),RACOMP "RTN","RACMP1",55,0) . W !?RATAB(1),"Physician: ",RAPHY "RTN","RACMP1",56,0) . W !?RATAB(1),"Interpreting Res. : ",RARES "RTN","RACMP1",57,0) . W !?RATAB(1),"Staff Imaging Phys. : ",RASTF "RTN","RACMP1",58,0) . I +$O(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",0)) S I=0 D "RTN","RACMP1",59,0) .. F S I=$O(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",I)) Q:'I S J=^(I,0) D "RTN","RACMP1",60,0) ... S RATECH=$E($P($G(^VA(200,+J,0)),"^"),1,20) "RTN","RACMP1",61,0) ... W !?RATAB(1),"Tech: ",RATECH "RTN","RACMP1",62,0) ... Q "RTN","RACMP1",63,0) .. Q "RTN","RACMP1",64,0) . D PRSC "RTN","RACMP1",65,0) . W !,RALBL,$E(RACMPTX,1,65) "RTN","RACMP1",66,0) . W:$E(RALBL,66,100)]"" !?$L(RALBL),$E(RALBL,66,100) W !,RALN1 "RTN","RACMP1",67,0) . Q "RTN","RACMP1",68,0) Q "RTN","RACMP1",69,0) PRSC ;DISPLAY pregnancy screen and comment, patch 99 "RTN","RACMP1",70,0) ; "RTN","RACMP1",71,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RACMP1",72,0) ;I $$PTSEX^RAUTL8(RADFN)="F" D "RTN","RACMP1",73,0) I $$PTSEX^RAUTL8(RADFN)'="M" D "RTN","RACMP1",74,0) .; "RTN","RACMP1",75,0) .N RAOR751 S RAOR751=$P($G(^RADPT(RADFN,"DT",$G(RAINVDT),"P",$G(RA5),0)),U,11) "RTN","RACMP1",76,0) .W !,"Pregnant at time of order entry: ",$$GET1^DIQ(75.1,$G(RAOR751)_",",13) "RTN","RACMP1",77,0) .N R3,RAPCOMM S R3=$G(^RADPT(RADFN,"DT",$G(RAINVDT),"P",$G(RA5),0)) "RTN","RACMP1",78,0) .S RAPCOMM=$G(^RADPT(RADFN,"DT",+$G(RAINVDT),"P",+$G(RA5),"PCOMM")) "RTN","RACMP1",79,0) .W:$P(R3,U,32)'="" !,"Pregnancy Screen: ",$S($P(R3,"^",32)="y":"Patient answered yes",$P(R3,"^",32)="n":"Patient answered no",$P(R3,"^",32)="u":"Patient is unable to answer or is unsure",1:"") "RTN","RACMP1",80,0) .W:$P(R3,U,32)'="n"&$L(RAPCOMM) !,"Pregnancy Screen Comment: ",RAPCOMM "RTN","RACMP1",81,0) Q "RTN","RACMP1",82,0) ; "RTN","RACMP1",83,0) DIVCHK ; Output statistics within division, check for EOS on division "RTN","RACMP1",84,0) N RA6 "RTN","RACMP1",85,0) I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2 Q:RAXIT "RTN","RACMP1",86,0) W !!?5,"Division: "_RADIV("X") "RTN","RACMP1",87,0) W !,"Complications: ",+$G(^TMP($J,"RACOMP",RADIV)) "RTN","RACMP1",88,0) W " Exams: ",+$G(^TMP($J,"RAEXAM",RADIV))," % Complications: " "RTN","RACMP1",89,0) I +$G(^TMP($J,"RAEXAM",RADIV))=0 W "0" "RTN","RACMP1",90,0) E W $J((+$G(^TMP($J,"RACOMP",RADIV))/+$G(^TMP($J,"RAEXAM",RADIV)))*100,6,2) "RTN","RACMP1",91,0) I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2 Q:RAXIT "RTN","RACMP1",92,0) W !,"Contrast Media Complications: ",+$G(^TMP($J,"RACMRE",RADIV)) "RTN","RACMP1",93,0) W " C.M. Exams: ",+$G(^TMP($J,"RACOMP",RADIV)) "RTN","RACMP1",94,0) W " % C.M. Comp.: " "RTN","RACMP1",95,0) I +$G(^TMP($J,"RACOMP",RADIV))=0 W "0" "RTN","RACMP1",96,0) E W $J((+$G(^TMP($J,"RACMRE",RADIV))/+$G(^TMP($J,"RACOMP",RADIV)))*100,6,2) "RTN","RACMP1",97,0) S RA6=+$O(^TMP($J,"RACMP",RA1)) "RTN","RACMP1",98,0) I RA6 S RADIV=RA6,RADIV("X")=$P($G(^DIC(4,RADIV,0)),"^") D "RTN","RACMP1",99,0) . N RA7 S RA7=$O(^TMP($J,"RACMP",RADIV,"")) S:RA7]"" RAITYPE=RA7 "RTN","RACMP1",100,0) . S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2 "RTN","RACMP1",101,0) . Q "RTN","RACMP1",102,0) Q "RTN","RACMP1",103,0) IMGCHK ; Check for EOS on I-Type "RTN","RACMP1",104,0) N RA10 "RTN","RACMP1",105,0) I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2 Q:RAXIT "RTN","RACMP1",106,0) W !,"Complications: ",+$G(^TMP($J,"RACOMP",RADIV,RAITYPE)) "RTN","RACMP1",107,0) W " Exams: ",+$G(^TMP($J,"RAEXAM",RADIV,RAITYPE)) "RTN","RACMP1",108,0) W " % Complications: " "RTN","RACMP1",109,0) I +$G(^TMP($J,"RAEXAM",RADIV,RAITYPE))=0 W "0" "RTN","RACMP1",110,0) E W $J((+$G(^TMP($J,"RACOMP",RADIV,RAITYPE))/+$G(^TMP($J,"RAEXAM",RADIV,RAITYPE)))*100,6,2) "RTN","RACMP1",111,0) I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2 Q:RAXIT "RTN","RACMP1",112,0) W !,"Contrast Media Complications: ",+$G(^TMP($J,"RACMRE",RADIV,RAITYPE)) "RTN","RACMP1",113,0) W " C.M. Exams: ",+$G(^TMP($J,"RACOMP",RADIV,RAITYPE)) "RTN","RACMP1",114,0) W " % C.M. Comp.: " "RTN","RACMP1",115,0) I +$G(^TMP($J,"RACOMP",RADIV,RAITYPE))=0 W "0" "RTN","RACMP1",116,0) E W $J((+$G(^TMP($J,"RACMRE",RADIV,RAITYPE))/+$G(^TMP($J,"RACOMP",RADIV,RAITYPE)))*100,6,2) "RTN","RACMP1",117,0) S RA10=$O(^TMP($J,"RACMP",RA1,RA2)) "RTN","RACMP1",118,0) I RA10]"" S RAITYPE=RA10 D "RTN","RACMP1",119,0) . S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2 "RTN","RACMP1",120,0) . Q "RTN","RACMP1",121,0) Q "RTN","RAHLQ1") 0^16^B11208965 "RTN","RAHLQ1",1,0) RAHLQ1 ;HISC/CAH AISC/SAW-Compiles HL7 'ORF' Message Type ; 06 Oct 2013 11:07 AM "RTN","RAHLQ1",2,0) ;;5.0;Radiology/Nuclear Medicine;**1005**;Mar 16, 1998;Build 13 "RTN","RAHLQ1",3,0) ; Set the ^TMP("RARPT-QBAK",$J,RARECNT,... global to the following: "RTN","RAHLQ1",4,0) ; ^TMP("RARPT-QBAK",$J,RARECNT,"PID3")=Patient ID & checksum "RTN","RAHLQ1",5,0) ; "PID5" Patient name "RTN","RAHLQ1",6,0) ; "PID7" Patient DOB "RTN","RAHLQ1",7,0) ; "PID8" sex of the patient "RTN","RAHLQ1",8,0) ; "PID19" Patient SSN (if any) "RTN","RAHLQ1",9,0) ; "OBR4A" inverse date/time exam "-" case ien (radti-racni) "RTN","RAHLQ1",10,0) ; "OBR4B" date/time exam (radte) "RTN","RAHLQ1",11,0) ; "OBR16A" ien requesting physician "RTN","RAHLQ1",12,0) ; "OBR16B" name of requesting physician "RTN","RAHLQ1",13,0) ; "OBR20" name of ward location or principal clinic "RTN","RAHLQ1",14,0) ; "LAN-A" LANIER ONLY --> $p(racn0,"^",2) "RTN","RAHLQ1",15,0) ; "LAN-B" LANIER ONLY --> $p(^ramis(71,+$p(racn0,"^",2),0),"^") "RTN","RAHLQ1",16,0) ; "OBX5" radisp_$p(^ramis(71,+$p(racn0,"^",2),0),"^") "RTN","RAHLQ1",17,0) ; radisp_"Unknown" if no procedure "RTN","RAHLQ1",18,0) ; where radisp is + or . for printset "RTN","RAHLQ1",19,0) ; "OBX5-MOD" string of modifiers "RTN","RAHLQ1",20,0) ; "OBX-HIST-NONE" "None Entered" if no clinical history "RTN","RAHLQ1",21,0) ; "OBX5-ALLE" string of allergies "RTN","RAHLQ1",22,0) ; "RTN","RAHLQ1",23,0) ; "RADFN" RADFN "RTN","RAHLQ1",24,0) ; "VADM(1)" VADM(1) "RTN","RAHLQ1",25,0) ; "VADM(3)" VADM(3) "RTN","RAHLQ1",26,0) ; "RAPRV" RAPRV "RTN","RAHLQ1",27,0) ; "RADTE0" RADTE0 "RTN","RAHLQ1",28,0) ; "RTN","RAHLQ1",29,0) ; RACN0 = Examinations 0 node (70.03 sub-file) "RTN","RAHLQ1",30,0) EN1 S RADTE0=$S($D(^RADPT(RADFN,"DT",RADTI,0)):+^(0),1:"") "RTN","RAHLQ1",31,0) S RADTE=$S(RADTE0:$E(RADTE0,4,7)_$E(RADTE0,2,3)_"-"_+RACN0,1:+RACN0) "RTN","RAHLQ1",32,0) ; "RTN","RAHLQ1",33,0) ;Compile 'PID' Segment "RTN","RAHLQ1",34,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"RADFN")=RADFN "RTN","RAHLQ1",35,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"VADM(1)")=VADM(1) "RTN","RAHLQ1",36,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"VADM(3)")=VADM(3) "RTN","RAHLQ1",37,0) ; "RTN","RAHLQ1",38,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAHLQ1",39,0) ;S ^TMP("RARPT-QBAK",$J,RARECNT,"PID8")=$S(VADM(5)]"":$S("MF"[$P(VADM(5),"^"):$P(VADM(5),"^"),1:"O"),1:"U") "RTN","RAHLQ1",40,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"PID8")=$S(VADM(5)]"":$S("MFU"[$P(VADM(5),"^"):$P(VADM(5),"^"),1:"O"),1:"U") "RTN","RAHLQ1",41,0) ; "RTN","RAHLQ1",42,0) S:$P(VADM(2),"^")]"" ^TMP("RARPT-QBAK",$J,RARECNT,"PID19")=$P(VADM(2),"^") "RTN","RAHLQ1",43,0) ; "RTN","RAHLQ1",44,0) ;Compile 'OBR' Segment "RTN","RAHLQ1",45,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR4A")=RADTI_"-"_RACNI "RTN","RAHLQ1",46,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR4B")=RADTE "RTN","RAHLQ1",47,0) S RAPRV=$P($G(^VA(200,+$P(RACN0,"^",14),0)),"^") "RTN","RAHLQ1",48,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR16A")=$S(RAPRV]"":+$P(RACN0,"^",14),1:"") "RTN","RAHLQ1",49,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"RAPRV")=RAPRV "RTN","RAHLQ1",50,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"RADTE0")=RADTE0 "RTN","RAHLQ1",51,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR20")=$S($D(^DIC(42,+$P(RACN0,"^",6),0)):$P(^(0),"^"),$D(^SC(+$P(RACN0,"^",8),0)):$P(^(0),"^"),1:"Unknown") "RTN","RAHLQ1",52,0) ; "RTN","RAHLQ1",53,0) ;Compile 'OBX' Segment for Procedure "RTN","RAHLQ1",54,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"LAN-A")=$P(RACN0,"^",2) "RTN","RAHLQ1",55,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"LAN-B")=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):$P(^(0),"^"),1:"") "RTN","RAHLQ1",56,0) ; "RTN","RAHLQ1",57,0) ; set flags if print set and/or lowest case of print set "RTN","RAHLQ1",58,0) N RACN,RAPRTSET,RAMEMLOW,RADISP "RTN","RAHLQ1",59,0) S RACN=+RACN0,RAPRTSET=0,RAMEMLOW=0,RADISP=" " "RTN","RAHLQ1",60,0) D EN1^RAUTL20 "RTN","RAHLQ1",61,0) I RAPRTSET S RADISP="." S:RAMEMLOW RADISP="+" "RTN","RAHLQ1",62,0) ;For Lanier units, comment out next line "RTN","RAHLQ1",63,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"OBX5")=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):RADISP_$P(^(0),"^"),1:"Unknown") "RTN","RAHLQ1",64,0) ; "RTN","RAHLQ1",65,0) ;Compile 'OBX' Segment for Modifiers "RTN","RAHLQ1",66,0) D MODS^RAUTL2 "RTN","RAHLQ1",67,0) S ^TMP("RARPT-QBAK",$J,RARECNT,"OBX5-MOD")=Y "RTN","RAHLQ1",68,0) ; "RTN","RAHLQ1",69,0) ;Compile 'OBX' Segment for Clinical History "RTN","RAHLQ1",70,0) I '$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) S ^TMP("RARPT-QBAK",$J,RARECNT,"OBX-HIST-NONE")="None Entered" "RTN","RAHLQ1",71,0) K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1 F RAI=0:0 S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAI)) Q:'RAI I $D(^(RAI,0)) S X=^(0) D ^DIWP "RTN","RAHLQ1",72,0) ; save ^UTILITY($J,"W") for bridge routine "RTN","RAHLQ1",73,0) ; "RTN","RAHLQ1",74,0) ;Compile 'OBX' Segment for Allergies "RTN","RAHLQ1",75,0) S DFN=RADFN D ALLERGY^RADEM S X="" I $D(GMRAL) S I=0 F S I=$O(PI(I)) Q:I'>0 S X0=PI(I) I X0]"" Q:($L(X)+$L(X0))>200 S X=X_X0_", " "RTN","RAHLQ1",76,0) I $L(X) S ^TMP("RARPT-QBAK",$J,RARECNT,"OBX5-ALLE")=X "RTN","RAHLQ1",77,0) K DIWF,DIWL,DIWR,GMRAL,I,PI,RAI,RAPRV,RADTE,RADTE0 "RTN","RAHLQ1",78,0) Q "RTN","RAHLR") 0^17^B62394344 "RTN","RAHLR",1,0) RAHLR ;HISC/CAH/BNT - Generate Common Order (ORM) Message ; 06 Oct 2013 11:08 AM "RTN","RAHLR",2,0) ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,71,82,75,80,84,94,1005**;Mar 16, 1998;Build 13 "RTN","RAHLR",3,0) ;Generates msg whenever a case is registered or cancelled or examined "RTN","RAHLR",4,0) ; registered cancelled examined "RTN","RAHLR",5,0) ; Order control : NW CA XO "RTN","RAHLR",6,0) ; Order status : IP CA CM "RTN","RAHLR",7,0) ;07/28/2008 BAY/KAM RA*5*94 Remove GMT offset from OBR-7 & add Reason for Study to OBX segment "RTN","RAHLR",8,0) ;02/14/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R "RTN","RAHLR",9,0) ; "RTN","RAHLR",10,0) ;Integration Agreements "RTN","RAHLR",11,0) ;---------------------- "RTN","RAHLR",12,0) ;NOW^%DTC(10000); ^%ZTLOAD(10063); $$GET1^DIQ(2056); ^DIWP(10011) "RTN","RAHLR",13,0) ;$$HLDATE/$$HLNAME/$$M11^HLFNC(10106); INIT^HLFNC2(2161) "RTN","RAHLR",14,0) ;GENERATE^HLMA(2164); DEM^VADPT(10061); $$EN^VAFHLPID(263) "RTN","RAHLR",15,0) ;$$FMTHL7^XLFDT(10103) "RTN","RAHLR",16,0) ; "RTN","RAHLR",17,0) ;IA: 10039 global read .01 field WARD LOCATION (#42) file ^DIC(42, "RTN","RAHLR",18,0) ;IA: 10040 global read .01 field HOSPITAL LOCATION (#44) file ^SC( "RTN","RAHLR",19,0) ; "RTN","RAHLR",20,0) S:$D(HLNDAP) ZTSAVE("HLNDAP")="" S:$D(HLDAP) ZTSAVE("HLDAP")="" S:$D(RAEXMDUN) ZTSAVE("RAEXMDUN")="" "RTN","RAHLR",21,0) S:$D(RAEXEDT) ZTSAVE("RAEXEDT")="" "RTN","RAHLR",22,0) S ZTSAVE("RADFN")="",ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTIO="",ZTDTH=$H,ZTDESC="Rad/Nuc Med Compiling HL7 Common Order",ZTRTN="EN^RAHLR" D ^%ZTLOAD "RTN","RAHLR",23,0) K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE Q "RTN","RAHLR",24,0) EN ; Called from the RA REG & RA CANCEL & RA EXAMINED protocols "RTN","RAHLR",25,0) ; Input Variables: "RTN","RAHLR",26,0) ; RADFN=file 2 IEN (DFN) "RTN","RAHLR",27,0) ; RADTI=file 70 Exam subrec IEN (reverse date/time of exam) "RTN","RAHLR",28,0) ; RACNI=file 70 Case subrecord IEN "RTN","RAHLR",29,0) ; RAEID=ien of the event driver protocol (defined in RAHLRPC) "RTN","RAHLR",30,0) ; Output Variables: "RTN","RAHLR",31,0) ; HLA("HLS") array containing HL7 msg "RTN","RAHLR",32,0) ; "RTN","RAHLR",33,0) N EID,HL,INT,HLQ,HLFS,HLECH,HLA,HLCS,HLSCS,HLREP,HLECH "RTN","RAHLR",34,0) N DFN,DIWF,DIWL,DIWR,GMRAL,PI,RACANC,RACN0,RACPT,RACPTNDE,RADTE,RAI,RAN,RAOBR4,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RAX0,VA,VADM,VAERR,X,X0,Y,X1,OBR36 "RTN","RAHLR",35,0) ; "RTN","RAHLR",36,0) D INIT ; initialize some HL7 variables "RTN","RAHLR",37,0) ;RAEXMDUN passed from EXM^RAHLRPC if conditions are met "RTN","RAHLR",38,0) Q:+$G(HL)=15 ;no known client(item) linked to the event driver protocol "RTN","RAHLR",39,0) Q:$O(HL(""))="" ;disabled server appl, or no server appl "RTN","RAHLR",40,0) ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** "RTN","RAHLR",41,0) I HL("VER")>2.3,($T(^RAHLR1))'="" D EN^RAHLR1(RADFN,RADTI,RACNI,RAEID) Q "RTN","RAHLR",42,0) ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** "RTN","RAHLR",43,0) S RACN0=$S($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)):^(0),1:"") Q:RACN0']"" "RTN","RAHLR",44,0) ;Generate Message Text "RTN","RAHLR",45,0) S RAPROC=+$P(RACN0,U,2) I 'RAPROC Q ;If case entered via 'Enter Last Past Visit before DHCP option, and procedure 'OTHER' is inactive, RAPROC will be null and will cause bomb-out unless we quit here "RTN","RAHLR",46,0) S RAPROCIT=+$P($G(^RAMIS(71,RAPROC,0)),U,12),RAPROCIT=$P(^RA(79.2,RAPROCIT,0),U,1) "RTN","RAHLR",47,0) S (RADTE,OBR36)=9999999.9999-RADTI,RADTE=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_+RACN0,RACANC=$S($D(^RA(72,"AA",RAPROCIT,0,+$P(RACN0,"^",3))):1,1:0) "RTN","RAHLR",48,0) S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9),RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT) "RTN","RAHLR",49,0) ;RA*5*82 RAEXEDT= Override the EXM conditions if Case edited "RTN","RAHLR",50,0) ;I $G(RAEXMDUN)=1,'$G(RAEXEDT),$P(RACN0,U,30)'="",'$G(RATELE) Q ;last chance to stop exm'd msg if it's already been sent RA*5*84 Is TELERAD ?? "RTN","RAHLR",51,0) ;Compile 'PID' Segment "RTN","RAHLR",52,0) K VA,VADM,VAERR,RAVADM S DFN=RADFN D DEM^VADPT I VADM(1)']"" S HLP("ERRTEXT")="Invalid Patient Identifier" G EXIT "RTN","RAHLR",53,0) S RAVADM(3)=$S($E(+VADM(3),6,7)="00":"",1:+VADM(3)) ; NOTE: Check "RTN","RAHLR",54,0) ; for an inexact date of birth. If inexact, pass null for DOB in "RTN","RAHLR",55,0) ; the 'PID' segment. Some COTS systems can't handle inexact DOB's. "RTN","RAHLR",56,0) I HL("VER")']"2.2" D "RTN","RAHLR",57,0) .; "RTN","RAHLR",58,0) .;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAHLR",59,0) .;S HLA("HLS",1)="PID"_HLFS_HLFS_$G(VA("PID"))_HLFS_$$M11^HLFNC(RADFN)_HLFS_HLFS_$$HLNAME^HLFNC(VADM(1))_HLFS_HLFS_$$HLDATE^HLFNC(RAVADM(3))_HLFS_$S(VADM(5)]"":$S("MF"[$P(VADM(5),"^"):$P(VADM(5),"^"),1:"O"),1:"U") "RTN","RAHLR",60,0) .S HLA("HLS",1)="PID"_HLFS_HLFS_$G(VA("PID"))_HLFS_$$M11^HLFNC(RADFN)_HLFS_HLFS_$$HLNAME^HLFNC(VADM(1))_HLFS_HLFS_$$HLDATE^HLFNC(RAVADM(3))_HLFS_$S(VADM(5)]"":$S("MFU"[$P(VADM(5),"^"):$P(VADM(5),"^"),1:"O"),1:"U") "RTN","RAHLR",61,0) .; "RTN","RAHLR",62,0) .S:$P(VADM(2),"^")]"" $P(HLA("HLS",1),HLFS,20)=$P(VADM(2),"^") "RTN","RAHLR",63,0) I HL("VER")]"2.2" S HLA("HLS",1)=$$EN^VAFHLPID(DFN,"2,3,5,7,8,19,20") "RTN","RAHLR",64,0) K RAVADM "RTN","RAHLR",65,0) ;Compile 'ORC' Segment "RTN","RAHLR",66,0) S X0="" ;if exam-set or print-set, store parent name if order exists "RTN","RAHLR",67,0) I $P(RACN0,U,25) S X0=$P(RACN0,U,11),X0=$P($G(^RAO(75.1,+X0,0)),U,2),X0=$P($G(^RAMIS(71,+X0,0)),U),X0=$S(X0="":"ORIGINAL ORDER PURGED",1:X0),X0=$S($P(RACN0,U,25)=1:"EXAM",1:"PRINT")_"SET: "_X0 "RTN","RAHLR",68,0) ; BNT - Added ORC4 Placer Group Number for Printset identification. "RTN","RAHLR",69,0) ; ORC4 is a combination of SSN with the order inverted date/time. "RTN","RAHLR",70,0) S RAORC4="" I $P($G(RACN0),U,25)=2 D "RTN","RAHLR",71,0) . S:$P(VADM(2),"^")]"" RAORC4=$P(VADM(2),"^") "RTN","RAHLR",72,0) . S RAORC4=$G(RAORC4)_RADTI "RTN","RAHLR",73,0) S HLA("HLS",2)="ORC"_HLFS_$S(RACANC:"CA",$G(RAEXMDUN)=1:"XO",1:"NW")_HLFS_HLFS_HLFS_RAORC4_HLFS_$S(RACANC:"CA",$G(RAEXMDUN)=1:"CM",1:"IP")_HLFS_HLFS_HLFS_X0_HLFS_HLDT1 "RTN","RAHLR",74,0) K RAORC4 "RTN","RAHLR",75,0) ;Compile 'OBR' Segment "RTN","RAHLR",76,0) S RAOBR4=$P(RACPTNDE,U)_$E(HLECH)_$P(RACPTNDE,U,2)_$E(HLECH)_"C4"_$E(HLECH)_+RAPROC_$E(HLECH)_$P(RAPRCNDE,U)_$E(HLECH)_"99RAP" "RTN","RAHLR",77,0) ; Replace above with following when Imaging can cope with ESC chars "RTN","RAHLR",78,0) ; S RAOBR4=$P(RACPTNDE,U)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RACPTNDE,U,2))_$E(HLECH)_"C4"_$E(HLECH)_+RAPROC_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAPRCNDE,U))_$E(HLECH)_"99RAP" "RTN","RAHLR",79,0) I $P(RACPTNDE,U)']"" S $P(RAOBR4,$E(HLECH),1,3)=$P(RAOBR4,$E(HLECH),4,5)_$E(HLECH)_"LOCAL" "RTN","RAHLR",80,0) ;OBR-7 change: from HLDT1 to $$HLDATE^HLFNC(9999999.9999-RADTI) d/t of registration "RTN","RAHLR",81,0) ;Driver of change: CareStream Health PACS. Agfa requires a timestamp down to the second "RTN","RAHLR",82,0) ;POC @ Boston is Maureen Sullivan "RTN","RAHLR",83,0) ;S HLA("HLS",3)="OBR"_HLFS_HLFS_RADTE_HLFS_RADTI_"-"_RACNI_$E(HLECH)_RADTE_$E(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_$$HLDATE^HLFNC(9999999.9999-RADTI) "RTN","RAHLR",84,0) ; "RTN","RAHLR",85,0) ;07/28/2008 BAY/KAM RA*5*94 Remove GMT offset from OBR-7 in next line "RTN","RAHLR",86,0) S HLA("HLS",3)="OBR"_HLFS_HLFS_RADTE_HLFS_RADTI_"-"_RACNI_$E(HLECH)_RADTE_$E(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_$P($$HLDATE^HLFNC(9999999.9999-RADTI),"-",1) "RTN","RAHLR",87,0) ; "RTN","RAHLR",88,0) S HLA("HLS",3)=HLA("HLS",3)_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS_HLQ_HLFS_HLFS "RTN","RAHLR",89,0) S RAPRV=$$GET1^DIQ(200,+$P(RACN0,"^",14),.01) "RTN","RAHLR",90,0) S HLA("HLS",3)=HLA("HLS",3)_$S(RAPRV]"":+$P(RACN0,"^",14)_$E(HLECH)_$$HLNAME^HLFNC(RAPRV),1:"") "RTN","RAHLR",91,0) ; "RTN","RAHLR",92,0) N RACN00,RA20 S RACN00=$G(^RADPT(RADFN,"DT",RADTI,0)) "RTN","RAHLR",93,0) ;Seg's fld 20 = pce 21 --> ien file #79.1~name of img loc~stn #~stn name "RTN","RAHLR",94,0) S RA20=+$G(^RA(79.1,+$P(RACN00,U,4),0)) "RTN","RAHLR",95,0) S $P(HLA("HLS",3),HLFS,21)=$P(RACN00,U,4)_$E(HLECH)_$P($G(^SC(RA20,0)),U)_$E(HLECH)_$P(RACN00,U,3)_$E(HLECH)_$P($G(^DIC(4,+$P(RACN00,U,3),0)),U) "RTN","RAHLR",96,0) S $P(HLA("HLS",3),HLFS,21)=$P(HLA("HLS",3),HLFS,21) "RTN","RAHLR",97,0) ; Replace above with following when Imaging can cope with ESC chars "RTN","RAHLR",98,0) ; S $P(HLA("HLS",3),HLFS,21)=$$ESCAPE^RAHLRU($P(HLA("HLS",3),HLFS,21)) "RTN","RAHLR",99,0) ;Seg's fld 21 = pce 22 --> abbrv I-type~Img type name "RTN","RAHLR",100,0) S RA20=$G(^RA(79.2,+$P(RACN00,U,2),0)) "RTN","RAHLR",101,0) S $P(HLA("HLS",3),HLFS,22)=$P(RA20,U,3)_$E(HLECH)_$P(RA20,U) "RTN","RAHLR",102,0) S $P(HLA("HLS",3),HLFS,22)=$P(HLA("HLS",3),HLFS,22) "RTN","RAHLR",103,0) ; Replace above with following when Imaging can cope with ESC chars "RTN","RAHLR",104,0) ; S $P(HLA("HLS",3),HLFS,22)=$$ESCAPE^RAHLRU($P(HLA("HLS",3),HLFS,22)) "RTN","RAHLR",105,0) ; "RTN","RAHLR",106,0) S $P(HLA("HLS",3),HLFS,23)=HLDT1,$P(HLA("HLS",3),HLFS,19)=$S($D(^DIC(42,+$P(RACN0,"^",6),0)):$P(^(0),"^"),$D(^SC(+$P(RACN0,"^",8),0)):$P(^(0),"^"),1:"Unknown") "RTN","RAHLR",107,0) ; "RTN","RAHLR",108,0) ; OBR-31.2 = Reason for Study P75 "RTN","RAHLR",109,0) S $P(HLA("HLS",3),HLFS,32)=$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RAO(75.1,+$P(RACN0,"^",11),.1)),U)) "RTN","RAHLR",110,0) ; "RTN","RAHLR",111,0) ; OBR-36 = Exam Date/Time "RTN","RAHLR",112,0) S $P(HLA("HLS",3),HLFS,37)=$$FMTHL7^XLFDT(OBR36) "RTN","RAHLR",113,0) ; "RTN","RAHLR",114,0) I 'RACANC S X=$P($G(^RAO(75.1,+$P(RACN0,"^",11),0)),"^",6),$P(HLA("HLS",3),HLFS,28)=$E(HLECH)_$E(HLECH)_$E(HLECH)_$E(HLECH)_$E(HLECH)_$TR(X,"129","SAR") "RTN","RAHLR",115,0) ; if long str, break so 2nd str begins with separator to avoid abend "RTN","RAHLR",116,0) I $L(HLA("HLS",3))>245 N RAPART,RA1 S RA1=HLA("HLS",3) F RAPART=5:1:15 S RAPART(1)=$P(RA1,HLFS,1,RAPART),RAPART(2)=$P(RA1,HLFS,RAPART+1,99) Q:$L(RAPART(1))<245&($L(RAPART(2))<245)&($P(RAPART(2),HLFS)="") "RTN","RAHLR",117,0) I $D(RAPART) K:RAPART=15 RAPART ;if RAPART reaches 15, then something's wrong so kill RAPART to allow abend due "string too long" "RTN","RAHLR",118,0) I $D(RAPART) S HLA("HLS",3)=$P(RAPART(1),HLFS)_HLFS,HLA("HLS",3,1)=$P(RAPART(1),HLFS,2,99)_HLFS,HLA("HLS",3,2)=RAPART(2) K RAPART,RA1 "RTN","RAHLR",119,0) OBXPRC ;Compile 'OBX' Segment for Procedure "RTN","RAHLR",120,0) S RAN=4 D OBXPRC^RAHLRU "RTN","RAHLR",121,0) OBXMOD ;Compile 'OBX' Segment for two types of Modifiers "RTN","RAHLR",122,0) S RAN=5 D OBXMOD^RAHLRU "RTN","RAHLR",123,0) OBXHIST ;Compile 'OBX' Segment for Clinical History and Reason for Study (added as prefix). "RTN","RAHLR",124,0) I $D(^RAO(75.1,+$P(RACN0,"^",11),.1)) D "RTN","RAHLR",125,0) .S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L"_HLFS_HLFS_"Reason for Study: "_$$ESCAPE^RAHLRU($P($G(^RAO(75.1,+$P(RACN0,"^",11),.1)),U)) D OBX11^RAHLRU "RTN","RAHLR",126,0) I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L"_HLFS_HLFS_" " D OBX11^RAHLRU ;blank line "RTN","RAHLR",127,0) K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1 F RAI=0:0 S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAI)) Q:'RAI I $D(^(RAI,0)) S X=^(0) D ^DIWP "RTN","RAHLR",128,0) F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU "RTN","RAHLR",129,0) ALLER ;Compile 'OBX' Segment for Allergies "RTN","RAHLR",130,0) S DFN=RADFN D ALLERGY^RADEM S X="" I $D(GMRAL) S RAI=0 F S RAI=$O(PI(RAI)) Q:RAI'>0 S X0=PI(RAI) I X0]"" Q:($L(X)+$L(X0))>200 S X=X_X0_", " "RTN","RAHLR",131,0) I $L(X) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"A"_$E(HLECH)_"ALLERGIES"_$E(HLECH)_"L"_HLFS_HLFS_X D OBX11^RAHLRU "RTN","RAHLR",132,0) OBXTCM ;Compile 'OBX' Segment for Tech Comment "RTN","RAHLR",133,0) D OBXTCM^RAHLRU "RTN","RAHLR",134,0) ; "RTN","RAHLR",135,0) EXIT ; set HL7 message type & return to protocol "RTN","RAHLR",136,0) K ^UTILITY($J,"W") "RTN","RAHLR",137,0) S HL("MTN")="ORM" "RTN","RAHLR",138,0) N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP "RTN","RAHLR",139,0) S HLEID=EID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I" "RTN","RAHLR",140,0) D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX") "RTN","RAHLR",141,0) D:$D(RASSSX1(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX1") "RTN","RAHLR",142,0) D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP) "RTN","RAHLR",143,0) Q "RTN","RAHLR",144,0) Q ;Entry Point to Process an ORR Message (Just a Quit Since No Processing is Required) "RTN","RAHLR",145,0) Q "RTN","RAHLR",146,0) INIT ; initialize HL7 variables "RTN","RAHLR",147,0) D NOW^%DTC S HLDT=%,HLDT1=$$HLDATE^HLFNC(%) "RTN","RAHLR",148,0) ;Note: HLDT1 is used for HL7 fields: ORC-9 & OBR-22 "RTN","RAHLR",149,0) Q:'$G(RAEID) S EID=RAEID "RTN","RAHLR",150,0) S HL="HLS(""HLS"")",INT=1 "RTN","RAHLR",151,0) D INIT^HLFNC2(EID,.HL,INT) "RTN","RAHLR",152,0) Q:'$D(HL("Q")) ;no server application defined "RTN","RAHLR",153,0) S HLQ=HL("Q") "RTN","RAHLR",154,0) S HLECH=HL("ECH") "RTN","RAHLR",155,0) S HLFS=HL("FS") "RTN","RAHLR",156,0) S HLCS=$E(HL("ECH")) "RTN","RAHLR",157,0) S HLSCS=$E(HL("ECH"),4) "RTN","RAHLR",158,0) S HLREP=$E(HL("ECH"),2) "RTN","RAHLR",159,0) Q "RTN","RAHLRPTT") 0^18^B20277165 "RTN","RAHLRPTT",1,0) RAHLRPTT ;HISC/CAH AISC/SAW-Compiles HL7 'ORU' Message Type ; 06 Oct 2013 11:10 AM "RTN","RAHLRPTT",2,0) ;;5.0;Radiology/Nuclear Medicine;**84,94,1005**;Mar 16, 1998;Build 13 "RTN","RAHLRPTT",3,0) EN ; Continuation from RAHLRPT which has been split because the 10 k size problem "RTN","RAHLRPTT",4,0) ; & other inbound patch 84 utility "RTN","RAHLRPTT",5,0) ; "RTN","RAHLRPTT",6,0) ;Integration Agreements "RTN","RAHLRPTT",7,0) ;---------------------- "RTN","RAHLRPTT",8,0) ;^%DT(10003); $$FIND1^DIC(2051); $$GET1^DIQ(2056); $$HLDATE^HLFNC(10106); $$HLNAME^HLFNC(10106) "RTN","RAHLRPTT",9,0) ;$$M11^HLFNC(10106); $$EN^VAFHLPID(263) "RTN","RAHLRPTT",10,0) ;read w/FileMan HL7 APPLICATION PARAMETER(10136) "RTN","RAHLRPTT",11,0) ; "RTN","RAHLRPTT",12,0) INIT ; "RTN","RAHLRPTT",13,0) D:$D(RANOSEND) ;Patch 84 "RTN","RAHLRPTT",14,0) .N RATIEN,DIERR,RAERR "RTN","RAHLRPTT",15,0) .S RATIEN=$S(+RANOSEND:+RANOSEND,1:$$FIND1^DIC(771,"","X",RANOSEND,"","","RAERR")) "RTN","RAHLRPTT",16,0) .Q:'RATIEN!($D(RAERR)#2) "RTN","RAHLRPTT",17,0) .;RATELE is set to the value of the 'TELERADIOLOGY APPLICATION' (#1) field 0:No; 1:Yes "RTN","RAHLRPTT",18,0) .S RATELE=$P($G(^RA(79.7,RATIEN,0)),U,2) I 'RATELE K RATELE Q "RTN","RAHLRPTT",19,0) .;RATELX is set to the value of the 'RELEASE STUDY KEYWORD' (#1.2) field "RTN","RAHLRPTT",20,0) .S RATELX=$P($G(^RA(79.7,RATIEN,0)),U,4) "RTN","RAHLRPTT",21,0) .S:'$L(RATELX) RATELX="Released for local dictation by National Teleradiology" "RTN","RAHLRPTT",22,0) S RASET=0,RACN0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RAHLRPTT",23,0) S:'$D(RARPT) RARPT=+$P(RACN0,"^",17) "RTN","RAHLRPTT",24,0) Q "RTN","RAHLRPTT",25,0) SETUP ; Setup basic examination information "RTN","RAHLRPTT",26,0) S:RASET RACN0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) "RTN","RAHLRPTT",27,0) S RADTE0=9999999.9999-RADTI,RADTECN=$E(RADTE0,4,7)_$E(RADTE0,2,3)_"-"_+RACN0,RARPT0=^RARPT(RARPT,0) "RTN","RAHLRPTT",28,0) S RAPROC=+$P(RACN0,U,2),RAPROCIT=+$P($G(^RAMIS(71,RAPROC,0)),U,12),RAPROCIT=$P(^RA(79.2,RAPROCIT,0),U,1) "RTN","RAHLRPTT",29,0) S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9) "RTN","RAHLRPTT",30,0) S RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT) "RTN","RAHLRPTT",31,0) S Y=$$HLDATE^HLFNC(RADTE0) S RADTE0=$S(Y:Y,1:HLQ),Y=$$M11^HLFNC(RADFN) "RTN","RAHLRPTT",32,0) Q "RTN","RAHLRPTT",33,0) TELE ;Setting TELERAD info for RAHLTCPB "RTN","RAHLRPTT",34,0) ;RATELEKN = Keyword to get the name and NPI of teleradiologist "RTN","RAHLRPTT",35,0) ;RATELENM = Teleradiologist Name "RTN","RAHLRPTT",36,0) ;RATELEPI = Teleradiologist NPI "RTN","RAHLRPTT",37,0) ;RATELEDR = Default DX for terad 'R' report "RTN","RAHLRPTT",38,0) ;RATELEDF = Default DX for terad 'F' report "RTN","RAHLRPTT",39,0) N RATIEN,DIERR,RAERR "RTN","RAHLRPTT",40,0) S RATIEN=$$FIND1^DIC(771,"","X",$G(HL("SAN")),"","","RAERR") "RTN","RAHLRPTT",41,0) Q:'RATIEN!($D(RAERR)#2) "RTN","RAHLRPTT",42,0) S RATELE=$P($G(^RA(79.7,RATIEN,0)),U,2) ;Patch 84 "RTN","RAHLRPTT",43,0) I 'RATELE K RATELE Q ;Q:'RATELE original; changed w/P94 Remedy 259432 "RTN","RAHLRPTT",44,0) S RATELEKN=$P($G(^RA(79.7,RATIEN,0)),U,3) S:'$L(RATELEKN) RATELEKN="Report dictated by Teleradiologist: " "RTN","RAHLRPTT",45,0) S RATELEDR=$P($G(^RA(79.7,RATIEN,2)),U) K:'$L(RATELEDR) RATELEDR "RTN","RAHLRPTT",46,0) S RATELEDF=$P($G(^RA(79.7,RATIEN,2)),U,2) K:'$L(RATELEDF) RATELEDF "RTN","RAHLRPTT",47,0) Q "RTN","RAHLRPTT",48,0) PID ;Compile 'PID' Segment "RTN","RAHLRPTT",49,0) I HL("VER")']"2.2" D "RTN","RAHLRPTT",50,0) .S X1="",X1="PID"_HLFS_HLFS_$G(VA("PID"))_HLFS_Y_HLFS_HLFS S X=VADM(1),Y=$$HLNAME^HLFNC(X) S X1=X1_Y_HLFS_HLFS "RTN","RAHLRPTT",51,0) .; "RTN","RAHLRPTT",52,0) .;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAHLRPTT",53,0) .;S X=RAVADM(3),Y=$$HLDATE^HLFNC(X) S X1=X1_Y_HLFS_$S(VADM(5)]"":$S("MF"[$P(VADM(5),"^"):$P(VADM(5),"^"),1:"O"),1:"U") S:$P(VADM(2),"^")]"" $P(X1,HLFS,20)=$P(VADM(2),"^") S RAN=RAN+1,HLA("HLS",RAN)=X1 "RTN","RAHLRPTT",54,0) .S X=RAVADM(3),Y=$$HLDATE^HLFNC(X) S X1=X1_Y_HLFS_$S(VADM(5)]"":$S("MFU"[$P(VADM(5),"^"):$P(VADM(5),"^"),1:"O"),1:"U") S:$P(VADM(2),"^")]"" $P(X1,HLFS,20)=$P(VADM(2),"^") S RAN=RAN+1,HLA("HLS",RAN)=X1 "RTN","RAHLRPTT",55,0) .; "RTN","RAHLRPTT",56,0) I HL("VER")]"2.2" S RAN=RAN+1,HLA("HLS",RAN)=$$EN^VAFHLPID(DFN,"2,3,5,7,8,19,20") "RTN","RAHLRPTT",57,0) Q "RTN","RAHLRPTT",58,0) RESEND(RADFN,RADTI,RACNI) ; re-send exam message(s) to HL7 subscribers "RTN","RAHLRPTT",59,0) ; "RTN","RAHLRPTT",60,0) Q:'$G(RADFN)!'$G(RADTI)!'$G(RACNI) "RTN","RAHLRPTT",61,0) Q:'$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q:'$P(^(0),U,2) "RTN","RAHLRPTT",62,0) N RABD,RAEDTT,QUIT "RTN","RAHLRPTT",63,0) ; "RTN","RAHLRPTT",64,0) I '$D(DT) D ^%DT S DT=Y "RTN","RAHLRPTT",65,0) ; "RTN","RAHLRPTT",66,0) S RAEDTT=$$RAED(RADFN,RADTI,RACNI) "RTN","RAHLRPTT",67,0) Q:'$L(RAEDTT) "RTN","RAHLRPTT",68,0) D:RAEDTT[",REG," REG^RAHLRPC "RTN","RAHLRPTT",69,0) D:RAEDTT[",CANCEL," CANCEL^RAHLRPC "RTN","RAHLRPTT",70,0) D:RAEDTT[",EXAM," "RTN","RAHLRPTT",71,0) .S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",30)="" ;Reset sent flag "RTN","RAHLRPTT",72,0) .N RAEXMDUN D 1^RAHLRPC "RTN","RAHLRPTT",73,0) D:RAEDTT[",RPT," "RTN","RAHLRPTT",74,0) .N RANOSEND,RARPT D RPT^RAHLRPC "RTN","RAHLRPTT",75,0) Q "RTN","RAHLRPTT",76,0) ; "RTN","RAHLRPTT",77,0) RAED(RADFN,RADTI,RACNI) ; identify correct ^RAHLRPC entry point(s) "RTN","RAHLRPTT",78,0) ; "RTN","RAHLRPTT",79,0) N RASTAT,RAIMTYP,RAORD,RETURN,RARPT "RTN","RAHLRPTT",80,0) S RASTAT="" "RTN","RAHLRPTT",81,0) ; "RTN","RAHLRPTT",82,0) S RETURN=",REG," "RTN","RAHLRPTT",83,0) ; "RTN","RAHLRPTT",84,0) S RASTAT=$$GET1^DIQ(70.03,RACNI_","_RADTI_","_RADFN,3,"I") "RTN","RAHLRPTT",85,0) S RARPT=$$GET1^DIQ(70.03,RACNI_","_RADTI_","_RADFN,17,"I") "RTN","RAHLRPTT",86,0) ; "RTN","RAHLRPTT",87,0) S RAIMTYP=$$GET1^DIQ(72,+RASTAT,7) Q:'$L(RAIMTYP) "" "RTN","RAHLRPTT",88,0) S RAORD=$$GET1^DIQ(72,+RASTAT,3) "RTN","RAHLRPTT",89,0) ; "RTN","RAHLRPTT",90,0) S:RAORD=0 RETURN=RETURN_"CANCEL," "RTN","RAHLRPTT",91,0) ; "RTN","RAHLRPTT",92,0) S:$$GET1^DIQ(72,+RASTAT,8)="YES" RETURN=RETURN_"EXAM," ; Generate Examined HL7 Message "RTN","RAHLRPTT",93,0) ; "RTN","RAHLRPTT",94,0) D:RETURN'[",EXAM," "RTN","RAHLRPTT",95,0) .; also check previous statuses for 'Generate Examined HL7 Message' "RTN","RAHLRPTT",96,0) .F S RAORD=$O(^RA(72,"AA",RAIMTYP,RAORD),-1) Q:+RAORD<1 D Q:RETURN[",EXAM," "RTN","RAHLRPTT",97,0) ..S RASTAT=$O(^RA(72,"AA",RAIMTYP,RAORD,0)) "RTN","RAHLRPTT",98,0) ..S:$$GET1^DIQ(72,+RASTAT,8)="YES" RETURN=RETURN_"EXAM," "RTN","RAHLRPTT",99,0) ; "RTN","RAHLRPTT",100,0) ; Check if Verified Report exists "RTN","RAHLRPTT",101,0) I RARPT]"",$$GET1^DIQ(74,RARPT_",",5,"I")="V" S RETURN=RETURN_"RPT," "RTN","RAHLRPTT",102,0) ; "RTN","RAHLRPTT",103,0) Q RETURN "RTN","RAMAG02A") 0^19^B42486101 "RTN","RAMAG02A",1,0) RAMAG02A ;HCIOFO/SG - ORDERS/EXAMS API (REQUEST UTILITIES) ; 06 Oct 2013 11:10 AM "RTN","RAMAG02A",2,0) ;;5.0;Radiology/Nuclear Medicine;**90,1005**;Mar 16, 1998;Build 13 "RTN","RAMAG02A",3,0) ; "RTN","RAMAG02A",4,0) Q "RTN","RAMAG02A",5,0) ; "RTN","RAMAG02A",6,0) ;+++++ CREATES AN ORDER IN THE RAD/NUC MED ORDERS FILE (#75.1) "RTN","RAMAG02A",7,0) ; "RTN","RAMAG02A",8,0) ; Input variables: "RTN","RAMAG02A",9,0) ; RACAT, RADFN, RADTE, RAIMGTYI, RAMDIV, RAMISC, RAMLC, RAPROC, "RTN","RAMAG02A",10,0) ; RAREASON, REQLOC, REQPHYS "RTN","RAMAG02A",11,0) ; "RTN","RAMAG02A",12,0) ; Return values: "RTN","RAMAG02A",13,0) ; <0 Error descriptor (see $$ERROR^RAERR) "RTN","RAMAG02A",14,0) ; >0 IEN of the order in the file #75.1 "RTN","RAMAG02A",15,0) ; "RTN","RAMAG02A",16,0) ; NOTE: This is an internal entry point. Do not call it from "RTN","RAMAG02A",17,0) ; routines other than the ^RAMAG02. "RTN","RAMAG02A",18,0) ; "RTN","RAMAG02A",19,0) ORD() ; "RTN","RAMAG02A",20,0) N IENS,RABUF,RAFDA,RAIENS,RALOCK,RAMSG,RAOIFN,RARC,TMP "RTN","RAMAG02A",21,0) S RARC=0 "RTN","RAMAG02A",22,0) ; "RTN","RAMAG02A",23,0) ;=== Create the new order "RTN","RAMAG02A",24,0) S IENS="+1," "RTN","RAMAG02A",25,0) S RAFDA(75.1,IENS,.01)=RADFN ; NAME "RTN","RAMAG02A",26,0) S RAFDA(75.1,IENS,2)=+RAPROC ; PROCEDURE "RTN","RAMAG02A",27,0) S RAFDA(75.1,IENS,21)=RADTE ; DATE DESIRED "RTN","RAMAG02A",28,0) D UPDATE^DIE(,"RAFDA","RAIENS","RAMSG") "RTN","RAMAG02A",29,0) Q:$G(DIERR) $$DBS^RAERR("RAMSG",-9,75.1,IENS) "RTN","RAMAG02A",30,0) S RAOIFN=RAIENS(1) "RTN","RAMAG02A",31,0) ; "RTN","RAMAG02A",32,0) ;=== Store remaining fields of the order "RTN","RAMAG02A",33,0) D "RTN","RAMAG02A",34,0) . ;--- Setup the error processing "RTN","RAMAG02A",35,0) . N $ESTACK,$ETRAP D SETDEFEH^RAERR("RARC") "RTN","RAMAG02A",36,0) . ; "RTN","RAMAG02A",37,0) . ;--- Lock the record "RTN","RAMAG02A",38,0) . K TMP S TMP(75.1,RAOIFN_",")="" "RTN","RAMAG02A",39,0) . S RARC=$$LOCKFM^RALOCK(.TMP) "RTN","RAMAG02A",40,0) . I RARC S RARC=$$LOCKERR^RAERR(RARC,"order") Q "RTN","RAMAG02A",41,0) . M RALOCK=TMP "RTN","RAMAG02A",42,0) . ; "RTN","RAMAG02A",43,0) . ;--- Prepare required fields "RTN","RAMAG02A",44,0) . S IENS=RAOIFN_"," "RTN","RAMAG02A",45,0) . S RAFDA(75.1,IENS,1.1)=RAREASON ; REASON FOR STUDY "RTN","RAMAG02A",46,0) . S RAFDA(75.1,IENS,3)="`"_RAIMGTYI ; TYPE OF IMAGING "RTN","RAMAG02A",47,0) . D ZSET(IENS,4,RACAT) ; CATEGORY OF EXAM "RTN","RAMAG02A",48,0) . S RAFDA(75.1,IENS,14)="`"_REQPHYS ; REQUESTING PHYSICIAN "RTN","RAMAG02A",49,0) . S RAFDA(75.1,IENS,20)="`"_RAMLC ; IMAGING LOCATION "RTN","RAMAG02A",50,0) . S RAFDA(75.1,IENS,22)="`"_REQLOC ; REQUESTING LOCATION "RTN","RAMAG02A",51,0) . ; "RTN","RAMAG02A",52,0) . ;--- Prepare miscellaneous/optional fields "RTN","RAMAG02A",53,0) . D ZSET(IENS,6,$G(RAMISC("REQURG"))) ; REQUEST URGENCY "RTN","RAMAG02A",54,0) . D ZSET(IENS,13,$G(RAMISC("PREGNANT"))) ; PREGNANT "RTN","RAMAG02A",55,0) . D ZSET(IENS,19,$G(RAMISC("TRANSPMODE"))) ; MODE OF TRANSPORT "RTN","RAMAG02A",56,0) . D ZSET(IENS,24,$G(RAMISC("ISOLPROC"))) ; ISOLATION PROCEDURES "RTN","RAMAG02A",57,0) . D ZSET(IENS,26,$G(RAMISC("REQNATURE"))) ; NATURE OF (NEW) ORDER... "RTN","RAMAG02A",58,0) . ; "RTN","RAMAG02A",59,0) . ;--- PRE-OP SCHEDULED DATE/TIME "RTN","RAMAG02A",60,0) . S TMP=$G(RAMISC("PREOPDT")) "RTN","RAMAG02A",61,0) . S:TMP>0 RAFDA(75.1,IENS,12)=$$FMTE^XLFDT(TMP) "RTN","RAMAG02A",62,0) . ; "RTN","RAMAG02A",63,0) . ;--- CLINICAL HISTORY FOR EXAM "RTN","RAMAG02A",64,0) . S TMP=$NA(RAMISC("CLINHIST")) "RTN","RAMAG02A",65,0) . S:$D(@TMP)>1 RAFDA(75.1,IENS,400)=TMP "RTN","RAMAG02A",66,0) . ; "RTN","RAMAG02A",67,0) . ;--- Update the record "RTN","RAMAG02A",68,0) . D FILE^DIE("ET","RAFDA","RAMSG") "RTN","RAMAG02A",69,0) . I $G(DIERR) S RARC=$$DBS^RAERR("RAMSG",-9,75.1,IENS) Q "RTN","RAMAG02A",70,0) . ; "RTN","RAMAG02A",71,0) . ;--- Store procedure modifiers "RTN","RAMAG02A",72,0) . S RARC=$$PROCMOD(RAOIFN,RAPROC) Q:RARC<0 "RTN","RAMAG02A",73,0) . ; "RTN","RAMAG02A",74,0) . ;--- Update status of the order "RTN","RAMAG02A",75,0) . S RARC=$$UPDORDST^RAMAGU02(RAOIFN,5) Q:RARC<0 "RTN","RAMAG02A",76,0) ; "RTN","RAMAG02A",77,0) ;=== Error handling and cleanup "RTN","RAMAG02A",78,0) D:RARC<0 "RTN","RAMAG02A",79,0) . ;--- Delete incomplete record "RTN","RAMAG02A",80,0) . N DA,DIK S DA=RAOIFN,DIK="^RAO(75.1," D ^DIK "RTN","RAMAG02A",81,0) ;--- Unlock the record "RTN","RAMAG02A",82,0) D UNLOCKFM^RALOCK(.RALOCK) "RTN","RAMAG02A",83,0) ;--- "RTN","RAMAG02A",84,0) Q $S(RARC<0:RARC,1:RAOIFN) "RTN","RAMAG02A",85,0) ; "RTN","RAMAG02A",86,0) ;+++++ STORES PROCEDURE MODIFIERS "RTN","RAMAG02A",87,0) ; "RTN","RAMAG02A",88,0) ; RAOIFN IEN of the order in the file #75.1 "RTN","RAMAG02A",89,0) ; "RTN","RAMAG02A",90,0) ; RAPROC Radiology procedure and modifiers "RTN","RAMAG02A",91,0) ; ^01: Procedure IEN in file #71 "RTN","RAMAG02A",92,0) ; ^02: Optional procedure modifiers (IENs in "RTN","RAMAG02A",93,0) ; ... the PROCEDURE MODIFIERS file (#71.2)) "RTN","RAMAG02A",94,0) ; ^nn: "RTN","RAMAG02A",95,0) ; "RTN","RAMAG02A",96,0) ; Return values: "RTN","RAMAG02A",97,0) ; <0 Error descriptor (see $$ERROR^RAERR) "RTN","RAMAG02A",98,0) ; 0 Success "RTN","RAMAG02A",99,0) ; "RTN","RAMAG02A",100,0) ; NOTE: This is an internal entry point. Do not call it from "RTN","RAMAG02A",101,0) ; outside of this routine. "RTN","RAMAG02A",102,0) ; "RTN","RAMAG02A",103,0) PROCMOD(RAOIFN,RAPROC) ; "RTN","RAMAG02A",104,0) N I,IENS,LP,PMCNT,RAFDA,RAMSG,RC,TMP "RTN","RAMAG02A",105,0) S (PMCNT,RC)=0 "RTN","RAMAG02A",106,0) ;--- Prepare the data "RTN","RAMAG02A",107,0) S LP=$L(RAPROC,U) "RTN","RAMAG02A",108,0) F I=2:1:LP S TMP=$P(RAPROC,U,I) D:TMP'="" "RTN","RAMAG02A",109,0) . S PMCNT=PMCNT+1,IENS="+"_PMCNT_","_(+RAOIFN)_"," "RTN","RAMAG02A",110,0) . S RAFDA(75.1125,IENS,.01)="`"_TMP "RTN","RAMAG02A",111,0) ;--- Store procedure modifiers "RTN","RAMAG02A",112,0) D:PMCNT>0 "RTN","RAMAG02A",113,0) . D UPDATE^DIE("E","RAFDA",,"RAMSG") "RTN","RAMAG02A",114,0) . S:$G(DIERR) RC=$$DBS^RAERR("RAMSG",-9,75.1125) "RTN","RAMAG02A",115,0) ;--- "RTN","RAMAG02A",116,0) Q RC "RTN","RAMAG02A",117,0) ; "RTN","RAMAG02A",118,0) ;+++++ VALIDATES ORDER PARAMETERS AND INITIALIZES RELATED VARIABLES "RTN","RAMAG02A",119,0) ; "RTN","RAMAG02A",120,0) ; Input variables: "RTN","RAMAG02A",121,0) ; RACAT, RADFN, RADTE, RAMISC, RAMLC, RAPROC, RAREASON, REQLOC, "RTN","RAMAG02A",122,0) ; REQPHYS "RTN","RAMAG02A",123,0) ; "RTN","RAMAG02A",124,0) ; Output variables: "RTN","RAMAG02A",125,0) ; RAIMGTYI, RAMDIV, VA, VADM "RTN","RAMAG02A",126,0) ; "RTN","RAMAG02A",127,0) ; Return values: "RTN","RAMAG02A",128,0) ; <0 Error descriptor (see $$ERROR^RAERR) "RTN","RAMAG02A",129,0) ; 0 Success "RTN","RAMAG02A",130,0) ; "RTN","RAMAG02A",131,0) ; NOTE: This is an internal entry point. Do not call it from "RTN","RAMAG02A",132,0) ; routines other than the ^RAMAG02. "RTN","RAMAG02A",133,0) ; "RTN","RAMAG02A",134,0) VALIDATE() ; "RTN","RAMAG02A",135,0) N ERRCNT,I,IENS,L,RABUF,RAMSG,RC,TMP,X "RTN","RAMAG02A",136,0) S ERRCNT=0 "RTN","RAMAG02A",137,0) ;=== Check required variables "RTN","RAMAG02A",138,0) S X="RACAT,RADFN,RADTE,RAMLC,RAPROC,RAREASON,REQLOC,REQPHYS" "RTN","RAMAG02A",139,0) S RC=$$CHKREQ^RAUTL22(X) Q:RC<0 RC "RTN","RAMAG02A",140,0) ; "RTN","RAMAG02A",141,0) ;=== Patient IEN (DFN) "RTN","RAMAG02A",142,0) S RC=$$VADEM^RAMAGU07(RADFN) "RTN","RAMAG02A",143,0) I RC'<0 S:$G(VADM(1))="" RC=$$IPVE^RAERR("RADFN") "RTN","RAMAG02A",144,0) S:RC<0 ERRCNT=ERRCNT+1,RADFN=0 "RTN","RAMAG02A",145,0) ; "RTN","RAMAG02A",146,0) ;=== Requesting physician "RTN","RAMAG02A",147,0) I REQPHYS>0 D I X "RTN","RAMAG02A",148,0) . N RACRE,Y S Y=REQPHYS S X=$$PROV^RABWORD() "RTN","RAMAG02A",149,0) E D "RTN","RAMAG02A",150,0) . D IPVE^RAERR("REQPHYS") "RTN","RAMAG02A",151,0) . S ERRCNT=ERRCNT+1,REQPHYS=0 "RTN","RAMAG02A",152,0) ; "RTN","RAMAG02A",153,0) ;=== Requesting location "RTN","RAMAG02A",154,0) S RC=0 D "RTN","RAMAG02A",155,0) . S TMP=$$GET1^DIQ(44,REQLOC_",",.01,,,"RAMSG") "RTN","RAMAG02A",156,0) . I $G(DIERR) S RC=$$DBS^RAERR("RAMSG",-9,44,REQLOC_",") Q "RTN","RAMAG02A",157,0) . ;--- Missing .01 field "RTN","RAMAG02A",158,0) . I TMP="" S RC=$$IPVE^RAERR("REQLOC") Q "RTN","RAMAG02A",159,0) S:RC<0 ERRCNT=ERRCNT+1,REQLOC=0 "RTN","RAMAG02A",160,0) K RAMSG "RTN","RAMAG02A",161,0) ; "RTN","RAMAG02A",162,0) ;=== Desired date "RTN","RAMAG02A",163,0) I ($$ISEXCTDT^RAUTL22(RADTE)'>0)!($$FMTE^XLFDT(RADTE)=RADTE) D "RTN","RAMAG02A",164,0) . D IPVE^RAERR("RADTE") "RTN","RAMAG02A",165,0) . S ERRCNT=ERRCNT+1,RADTE="" "RTN","RAMAG02A",166,0) E S RADTE=RADTE\1 ; Strip the time "RTN","RAMAG02A",167,0) ; "RTN","RAMAG02A",168,0) ;=== Imaging location IEN "RTN","RAMAG02A",169,0) S RC=0 D "RTN","RAMAG02A",170,0) . S IENS=RAMLC_",",(RAIMGTYI,RAMDIV)=0 "RTN","RAMAG02A",171,0) . D GETS^DIQ(79.1,IENS,"6;25","I","RABUF","RAMSG") "RTN","RAMAG02A",172,0) . I $G(DIERR) S RC=$$DBS^RAERR("RAMSG",-9,79.1,IENS) Q "RTN","RAMAG02A",173,0) . ;--- Check required fields "RTN","RAMAG02A",174,0) . S RAIMGTYI=+$G(RABUF(79.1,IENS,6,"I")) ; Imaging type IEN "RTN","RAMAG02A",175,0) . S RAMDIV=+$G(RABUF(79.1,IENS,25,"I")) ; Division IEN "RTN","RAMAG02A",176,0) . I (RAIMGTYI'>0)!(RAMDIV'>0) D Q "RTN","RAMAG02A",177,0) . . S RC=$$IPVE^RAERR("RAMLC") "RTN","RAMAG02A",178,0) S:RC<0 ERRCNT=ERRCNT+1,RAMLC=0 "RTN","RAMAG02A",179,0) K RABUF,RAMSG "RTN","RAMAG02A",180,0) ; "RTN","RAMAG02A",181,0) ;=== Radiology procedure and modifiers "RTN","RAMAG02A",182,0) S RC=0 D "RTN","RAMAG02A",183,0) . I RAPROC'>0 S RC=$$IPVE^RAERR("RAPROC") Q "RTN","RAMAG02A",184,0) . ;=== Additional checks only if related parameters are valid "RTN","RAMAG02A",185,0) . Q:(RADTE'>0)!(RAIMGTYI'>0) "RTN","RAMAG02A",186,0) . S RC=$$CHKPROC^RAMAGU03(RAPROC,RAIMGTYI,RADTE) "RTN","RAMAG02A",187,0) S:RC<0 ERRCNT=ERRCNT+1,RAPROC="" "RTN","RAMAG02A",188,0) ; "RTN","RAMAG02A",189,0) ;=== Miscellaneous parameters "RTN","RAMAG02A",190,0) S:$G(RAMISC("ISOLPROC"))="" RAMISC("ISOLPROC")="n" "RTN","RAMAG02A",191,0) S:$G(RAMISC("REQNATURE"))="" RAMISC("REQNATURE")="s" "RTN","RAMAG02A",192,0) S:$G(RAMISC("REQURG"))="" RAMISC("REQURG")="9" "RTN","RAMAG02A",193,0) ;--- MODE OF TRANSPORT (Default value: WHEEL CHAIR for "RTN","RAMAG02A",194,0) ;--- inpatient exam category, AMBULATORY otherwise) "RTN","RAMAG02A",195,0) D:$G(RAMISC("TRANSPMODE"))="" "RTN","RAMAG02A",196,0) . S RAMISC("TRANSPMODE")=$S(RACAT="I":"w",1:"a") "RTN","RAMAG02A",197,0) ;--- PRE-OP SCHEDULED DATE/TIME "RTN","RAMAG02A",198,0) S TMP=$G(RAMISC("PREOPDT")) "RTN","RAMAG02A",199,0) D:TMP'="" "RTN","RAMAG02A",200,0) . I ($$ISEXCTDT^RAUTL22(TMP)'>0)!($$FMTE^XLFDT(TMP)=TMP) D Q "RTN","RAMAG02A",201,0) . . D IPVE^RAERR($NA(RAMISC("PREOPDT"))) S ERRCNT=ERRCNT+1 "RTN","RAMAG02A",202,0) . S RAMISC("PREOPDT")=+$E(TMP,1,12) ; Strip the seconds "RTN","RAMAG02A",203,0) ;--- PREGNANT "RTN","RAMAG02A",204,0) ; "RTN","RAMAG02A",205,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAMAG02A",206,0) ;I $G(RAMISC("PREGNANT"))="" D "RTN","RAMAG02A",207,0) ;. S:$P($G(VADM(5)),U)="F" RAMISC("PREGNANT")="u" "RTN","RAMAG02A",208,0) ;E I $P($G(VADM(5)),U)="M" D "RTN","RAMAG02A",209,0) ;. D ERROR^RAERR(-27) S ERRCNT=ERRCNT+1 "RTN","RAMAG02A",210,0) ; "RTN","RAMAG02A",211,0) I $G(RAMISC("PREGNANT"))="",$P($G(VADM(5)),U)'="M" S RAMISC("PREGNANT")="u" "RTN","RAMAG02A",212,0) I $G(RAMISC("PREGNANT"))["y",$P($G(VADM(5)),U)="M" D ERROR^RAERR(-27) S ERRCNT=ERRCNT+1 "RTN","RAMAG02A",213,0) I $G(RAMISC("PREGNANT"))["Y",$P($G(VADM(5)),U)="M" D ERROR^RAERR(-27) S ERRCNT=ERRCNT+1 "RTN","RAMAG02A",214,0) ; "RTN","RAMAG02A",215,0) ;=== "RTN","RAMAG02A",216,0) Q $S(ERRCNT>0:$$ERROR^RAERR(-11),1:0) "RTN","RAMAG02A",217,0) ; "RTN","RAMAG02A",218,0) ;+++++ STORES THE EXTERNAL FIELD VALUE INTO THE RAFDA "RTN","RAMAG02A",219,0) ZSET(IENS,FIELD,VALUE) ; "RTN","RAMAG02A",220,0) Q:VALUE="" "RTN","RAMAG02A",221,0) N RAMSG,TMP "RTN","RAMAG02A",222,0) S TMP=$$EXTERNAL^DILFD(75.1,FIELD,,VALUE,"RAMSG") "RTN","RAMAG02A",223,0) S RAFDA(75.1,IENS,FIELD)=$S(TMP'="":TMP,1:VALUE) "RTN","RAMAG02A",224,0) Q "RTN","RAMAG03C") 0^2^B29412190 "RTN","RAMAG03C",1,0) RAMAG03C ;HCIOFO/SG - ORDERS/EXAMS API (REGISTR. UTILS) ; 06 Oct 2013 11:03 AM "RTN","RAMAG03C",2,0) ;;5.0;Radiology/Nuclear Medicine;**90,47,1005**;Mar 16, 1998;Build 13 "RTN","RAMAG03C",3,0) ; "RTN","RAMAG03C",4,0) Q "RTN","RAMAG03C",5,0) ; "RTN","RAMAG03C",6,0) ;+++++ CREATES AN EXAM IN THE RAD/NUC MED PATIENT (#70) "RTN","RAMAG03C",7,0) ; "RTN","RAMAG03C",8,0) ; Input variables: "RTN","RAMAG03C",9,0) ; RADFN, RADTE, RADTI, RAEXMVAL, RAIMGTYI, RALOCK, RAMDIV, "RTN","RAMAG03C",10,0) ; RAMISC, RAMLC, RAOIFN, RAPARENT, RAPRLST, RASACN31 "RTN","RAMAG03C",11,0) ; "RTN","RAMAG03C",12,0) ; Output variables: "RTN","RAMAG03C",13,0) ; ^TMP($J,"RAREG1",...), RALOCK "RTN","RAMAG03C",14,0) ; "RTN","RAMAG03C",15,0) ; Return values: "RTN","RAMAG03C",16,0) ; <0 Error descriptor (see $$ERROR^RAERR) "RTN","RAMAG03C",17,0) ; 0 Success "RTN","RAMAG03C",18,0) ; "RTN","RAMAG03C",19,0) ; NOTE: This is an internal entry point. Do not call it from "RTN","RAMAG03C",20,0) ; routines other than the ^RAMAG03. "RTN","RAMAG03C",21,0) ; "RTN","RAMAG03C",22,0) EXAM() ; "RTN","RAMAG03C",23,0) Q:$D(RAPRLST)<10 0 "RTN","RAMAG03C",24,0) N IENS,RACN,RACASE,RACRM,RAFDA,RAIENS,RAIP,RAMOS,RAMSG,RAPROC,RARC,TMP "RTN","RAMAG03C",25,0) K ^TMP($J,"RAREG1") S RARC=0 "RTN","RAMAG03C",26,0) S RAMOS=$S('$G(RAPARENT):"",$G(RAMISC("SINGLERPT")):2,1:1) "RTN","RAMAG03C",27,0) ; "RTN","RAMAG03C",28,0) ;=== Create the date/time record if necessary "RTN","RAMAG03C",29,0) S TMP=$$ROOT^DILFD(70.02,","_RADFN_",",1) "RTN","RAMAG03C",30,0) I '$D(@TMP@(RADTI)) D Q:RARC<0 RARC "RTN","RAMAG03C",31,0) . S IENS="+1,"_RADFN_"," "RTN","RAMAG03C",32,0) . S RAFDA(70.02,IENS,.01)=RADTE ; EXAM DATE "RTN","RAMAG03C",33,0) . S RAFDA(70.02,IENS,2)=RAIMGTYI ; TYPE OF IMAGING "RTN","RAMAG03C",34,0) . S RAFDA(70.02,IENS,3)=RAMDIV ; HOSPITAL DIVISION "RTN","RAMAG03C",35,0) . S RAFDA(70.02,IENS,4)=+RAMLC ; IMAGING LOCATION "RTN","RAMAG03C",36,0) . S:$G(RAPARENT) RAFDA(70.02,IENS,5)=1 ; EXAM SET "RTN","RAMAG03C",37,0) . S RAIENS(1)=RADTI "RTN","RAMAG03C",38,0) . D UPDATE^DIE(,"RAFDA","RAIENS","RAMSG") "RTN","RAMAG03C",39,0) . S:$G(DIERR) RARC=$$DBS^RAERR("RAMSG",-9,70.02,IENS) "RTN","RAMAG03C",40,0) ; "RTN","RAMAG03C",41,0) ;=== Get the credit method from the imaging location "RTN","RAMAG03C",42,0) S RACRM=$$GET1^DIQ(79.1,+RAMLC_",",21,"I",,"RAMSG") "RTN","RAMAG03C",43,0) Q:$G(DIERR) $$DBS^RAERR("RAMSG",-9,79.1,+RAMLC_",") "RTN","RAMAG03C",44,0) ; "RTN","RAMAG03C",45,0) ;=== Register individual case(s) "RTN","RAMAG03C",46,0) S RAIP=0 "RTN","RAMAG03C",47,0) F S RAIP=$O(RAPRLST(RAIP)) Q:RAIP'>0 D Q:RARC<0 "RTN","RAMAG03C",48,0) . S RAPROC=RAPRLST(RAIP) K RAFDA,RAIENS,RAMSG "RTN","RAMAG03C",49,0) . ;--- Generate a case number "RTN","RAMAG03C",50,0) . S RACN=$$CASENUM^RAMAG03D(RADTE) "RTN","RAMAG03C",51,0) . I RACN<0 S RARC=RACN Q "RTN","RAMAG03C",52,0) . ;--- Prepare the data "RTN","RAMAG03C",53,0) . S IENS="+1,"_RADTI_","_RADFN_"," "RTN","RAMAG03C",54,0) . S RAFDA(70.03,IENS,.01)=RACN ; CASE NUMBER "RTN","RAMAG03C",55,0) . S RAFDA(70.03,IENS,2)=+RAPROC ; PROCEDURE "RTN","RAMAG03C",56,0) . S RAFDA(70.03,IENS,4)=RAMISC("EXAMCAT") ; CATEGORY OF EXAM "RTN","RAMAG03C",57,0) . S RAFDA(70.03,IENS,6)=$G(RAMISC("WARD")) ; WARD "RTN","RAMAG03C",58,0) . S RAFDA(70.03,IENS,7)=$G(RAMISC("SERVICE")) ; SERVICE "RTN","RAMAG03C",59,0) . S RAFDA(70.03,IENS,8)=$G(RAMISC("PRINCLIN")) ; PRINCIPAL CLINIC "RTN","RAMAG03C",60,0) . S RAFDA(70.03,IENS,11)=RAOIFN ; IMAGING ORDER "RTN","RAMAG03C",61,0) . S RAFDA(70.03,IENS,19)=$G(RAMISC("BEDSECT")) ; BEDSECTION "RTN","RAMAG03C",62,0) . S RAFDA(70.03,IENS,25)=RAMOS ; MEMBER OF SET "RTN","RAMAG03C",63,0) . S RAFDA(70.03,IENS,26)=RACRM ; CREDIT METHOD "RTN","RAMAG03C",64,0) . ;---Pregnancy Screen and Pregnancy Screen Comment for female pt ages 12-55 "RTN","RAMAG03C",65,0) . ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAMAG03C",66,0) . ;I $$PTSEX^RAUTL8(RADFN)="F",(($$PTAGE^RAUTL8(RADFN,"")>11)!($$PTAGE^RAUTL8(RADFN,"")<56)) D "RTN","RAMAG03C",67,0) . I $$PTSEX^RAUTL8(RADFN)'="M",$$PTAGE^RAUTL8(RADFN,"")>11,$$PTAGE^RAUTL8(RADFN,"")<56 D "RTN","RAMAG03C",68,0) .. ; "RTN","RAMAG03C",69,0) .. S RAFDA(70.03,IENS,32)="u" "RTN","RAMAG03C",70,0) .. S RAFDA(70.03,IENS,80)="OUTSIDE STUDY" "RTN","RAMAG03C",71,0) . ;--- SITE ACCESSION NUMBER "RTN","RAMAG03C",72,0) . S:$G(RASACN31) RAFDA(70.03,IENS,31)=$$ACCNUM^RAMAGU04(RADTE,RACN) "RTN","RAMAG03C",73,0) . ;--- CLINICAL HISTORY FOR EXAM "RTN","RAMAG03C",74,0) . S TMP=$NA(RAMISC("CLINHIST")) "RTN","RAMAG03C",75,0) . S:$D(@TMP)>1 RAFDA(70.03,IENS,400)=TMP "RTN","RAMAG03C",76,0) . ;--- Values from the order "RTN","RAMAG03C",77,0) . M RAFDA(70.03,IENS)=RAEXMVAL "RTN","RAMAG03C",78,0) . ;--- Add the record "RTN","RAMAG03C",79,0) . D UPDATE^DIE(,"RAFDA","RAIENS","RAMSG") "RTN","RAMAG03C",80,0) . I $G(DIERR) S RARC=$$DBS^RAERR("RAMSG",-9,70.03,IENS) Q "RTN","RAMAG03C",81,0) . S RACASE=RADFN_U_RADTI_U_RAIENS(1) "RTN","RAMAG03C",82,0) . ;--- Add to the list "RTN","RAMAG03C",83,0) . S ^TMP($J,"RAREG1",RAIP)=RACASE_U_RAOIFN "RTN","RAMAG03C",84,0) . ;--- Procedure modifiers "RTN","RAMAG03C",85,0) . S $P(IENS,",")=RAIENS(1) "RTN","RAMAG03C",86,0) . S RARC=$$PROCMOD(IENS,RAPROC) Q:RARC<0 "RTN","RAMAG03C",87,0) . ;---Study Instance UID (70.03; 81) "RTN","RAMAG03C",88,0) . D SIUID($P(IENS,",")) ;where IENS is RACNI,RADTI,RADFN, "RTN","RAMAG03C",89,0) . I $G(DIERR) S RARC=$$DBS^RAERR("RAMSG",-9,70.03,IENS) Q "RTN","RAMAG03C",90,0) . ;--- Exam status "RTN","RAMAG03C",91,0) . S RARC=$$UPDEXMST^RAMAGU05(RACASE,"^^1") Q:RARC<0 "RTN","RAMAG03C",92,0) . ;--- Activity log "RTN","RAMAG03C",93,0) . S TMP=$G(RAMISC("TECHCOMM")) "RTN","RAMAG03C",94,0) . S RARC=$$UPDEXMAL^RAMAGU05(RACASE,"E",TMP) Q:RARC<0 "RTN","RAMAG03C",95,0) ; "RTN","RAMAG03C",96,0) ;=== "RTN","RAMAG03C",97,0) Q $S(RARC<0:RARC,1:0) "RTN","RAMAG03C",98,0) ; "RTN","RAMAG03C",99,0) ;+++++ PERFORMS EXAM POST-PROCESSING "RTN","RAMAG03C",100,0) ; "RTN","RAMAG03C",101,0) ; .RAEXAMS Reference to a local array where identifiers of "RTN","RAMAG03C",102,0) ; registered examination(s) are returned to. "RTN","RAMAG03C",103,0) ; "RTN","RAMAG03C",104,0) ; RADTE Actual date/time of the exam (FileMan) "RTN","RAMAG03C",105,0) ; "RTN","RAMAG03C",106,0) ; Input variables: "RTN","RAMAG03C",107,0) ; RASACN31, ^TMP($J,"RAREG1",...) "RTN","RAMAG03C",108,0) ; "RTN","RAMAG03C",109,0) ; Return values: "RTN","RAMAG03C",110,0) ; <0 Error descriptor (see $$ERROR^RAERR) "RTN","RAMAG03C",111,0) ; '<0 Number of registered examinations "RTN","RAMAG03C",112,0) ; (number of elements in the RAEXAMS array) "RTN","RAMAG03C",113,0) ; "RTN","RAMAG03C",114,0) POSTPROC(RAEXAMS,RADTE) ; "RTN","RAMAG03C",115,0) N IENS,RABUF,RACASE,RACN,RACNI,RADFN,RADTI,RAEXMCNT,RAI,RAMSG,RAOIFN "RTN","RAMAG03C",116,0) S RAEXMCNT=0 K RAEXAMS "RTN","RAMAG03C",117,0) ;=== "RTN","RAMAG03C",118,0) S RAI=0 "RTN","RAMAG03C",119,0) F S RAI=$O(^TMP($J,"RAREG1",RAI)) Q:RAI'>0 D "RTN","RAMAG03C",120,0) . S RACASE=^TMP($J,"RAREG1",RAI) K RABUF,RAMSG "RTN","RAMAG03C",121,0) . S RADFN=$P(RACASE,U),RADTI=$P(RACASE,U,2) "RTN","RAMAG03C",122,0) . S RACNI=$P(RACASE,U,3),RAOIFN=$P(RACASE,U,4) "RTN","RAMAG03C",123,0) . S IENS=$$EXAMIENS^RAMAGU04(RACASE) "RTN","RAMAG03C",124,0) . ;--- Exam identifiers "RTN","RAMAG03C",125,0) . S RACN=$$GET1^DIQ(70.03,IENS,.01,"I",,"RAMSG") "RTN","RAMAG03C",126,0) . S $P(RACASE,U,4)=RACN ; Case number "RTN","RAMAG03C",127,0) . I $G(RASACN31) D ; Accession number "RTN","RAMAG03C",128,0) . . S $P(RACASE,U,5)=$$GET1^DIQ(70.03,IENS,31,"I",,"RAMSG") "RTN","RAMAG03C",129,0) . E S $P(RACASE,U,5)=$$ACCNUM^RAMAGU04(RADTE,RACN,"S") "RTN","RAMAG03C",130,0) . S $P(RACASE,U,6)=RADTE ; Exam date/time "RTN","RAMAG03C",131,0) . S RAEXMCNT=RAEXMCNT+1,RAEXAMS(RAEXMCNT)=RACASE "RTN","RAMAG03C",132,0) . ;--- Execute RA REG* protocols "RTN","RAMAG03C",133,0) . D REG^RAHLRPC "RTN","RAMAG03C",134,0) . ;--- Remove from the list "RTN","RAMAG03C",135,0) . K ^TMP($J,"RAREG1",RAI) "RTN","RAMAG03C",136,0) ;=== "RTN","RAMAG03C",137,0) Q RAEXMCNT "RTN","RAMAG03C",138,0) ; "RTN","RAMAG03C",139,0) ;+++++ STORES PROCEDURE MODIFIERS "RTN","RAMAG03C",140,0) ; "RTN","RAMAG03C",141,0) ; IENS7003 IENS of the exam in the sub-file #70.03 "RTN","RAMAG03C",142,0) ; "RTN","RAMAG03C",143,0) ; RAPROC Radiology procedure and modifiers "RTN","RAMAG03C",144,0) ; ^01: Procedure IEN in file #71 "RTN","RAMAG03C",145,0) ; ^02: Optional procedure modifiers (IENs in "RTN","RAMAG03C",146,0) ; ... the PROCEDURE MODIFIERS file (#71.2)) "RTN","RAMAG03C",147,0) ; ^nn: "RTN","RAMAG03C",148,0) ; "RTN","RAMAG03C",149,0) ; Return values: "RTN","RAMAG03C",150,0) ; <0 Error descriptor (see $$ERROR^RAERR) "RTN","RAMAG03C",151,0) ; 0 Success "RTN","RAMAG03C",152,0) ; "RTN","RAMAG03C",153,0) ; NOTE: This is an internal entry point. Do not call it from "RTN","RAMAG03C",154,0) ; outside of this routine. "RTN","RAMAG03C",155,0) ; "RTN","RAMAG03C",156,0) PROCMOD(IENS7003,RAPROC) ; "RTN","RAMAG03C",157,0) N I,IENS,LP,RAFDA,RAMSG,RAPMCNT,RARC,TMP "RTN","RAMAG03C",158,0) S (RAPMCNT,RARC)=0 "RTN","RAMAG03C",159,0) ;--- Prepare the data "RTN","RAMAG03C",160,0) S LP=$L(RAPROC,U) "RTN","RAMAG03C",161,0) F I=2:1:LP S TMP=$P(RAPROC,U,I) D:TMP'="" "RTN","RAMAG03C",162,0) . S RAPMCNT=RAPMCNT+1,IENS="+"_RAPMCNT_","_IENS7003 "RTN","RAMAG03C",163,0) . S RAFDA(70.1,IENS,.01)="`"_TMP "RTN","RAMAG03C",164,0) ;--- Store procedure modifiers "RTN","RAMAG03C",165,0) D:RAPMCNT>0 "RTN","RAMAG03C",166,0) . D UPDATE^DIE("E","RAFDA",,"RAMSG") "RTN","RAMAG03C",167,0) . S:$G(DIERR) RARC=$$DBS^RAERR("RAMSG",-9,70.1) "RTN","RAMAG03C",168,0) ;--- "RTN","RAMAG03C",169,0) Q RARC "RTN","RAMAG03C",170,0) ; "RTN","RAMAG03C",171,0) SIUID(RACNI) ; "RTN","RAMAG03C",172,0) ;sets field 81 IN 70.03 "RTN","RAMAG03C",173,0) ;IENS, RADFN & RADTI are global "RTN","RAMAG03C",174,0) N RAFDA S RAFDA(70.03,IENS,81)=$$SIUID^RAAPI "RTN","RAMAG03C",175,0) D FILE^DIE("","RAFDA") "RTN","RAMAG03C",176,0) Q "RTN","RAO7NEW") 0^20^B43392466 "RTN","RAO7NEW",1,0) RAO7NEW ;HISC/FPT - Create entry in OE/RR Order file (100) ; 06 Oct 2013 11:11 AM "RTN","RAO7NEW",2,0) ;;5.0;Radiology/Nuclear Medicine;**5,10,18,41,75,1005**;Mar 16, 1998 ;Build 13 "RTN","RAO7NEW",3,0) ; "RTN","RAO7NEW",4,0) ; This routine invokes IA #1300-A, #2083, #10082 "RTN","RAO7NEW",5,0) ;last modification for P18 by SS July 5,2000 "RTN","RAO7NEW",6,0) EN1(RAOIFN) ; 'RAOIFN' is the ien in file 75.1 "RTN","RAO7NEW",7,0) ; In RA*5.0*18 this call is used when procedure CHANGED during registration, adding to visit and editing "RTN","RAO7NEW",8,0) ; New vars & define the following variables: RAECH, RAECH array & RAHLFS "RTN","RAO7NEW",9,0) N A,B,DFN,RA,RA0,RACNT,RACPT,RADFN,RAECH,RAHL7DT,RAHLFS,RALOC,RANATURE "RTN","RAO7NEW",10,0) N RAPRIOR,RAPROC,RAR,RARMBED,RATAB,RAVAR,RAWARD,RAXIT "RTN","RAO7NEW",11,0) N RAORORDN,RAD70SB,RAORDCTR ;P18, OR Order No, "DT" of #70, Orderctrl,subscr of 70 "RTN","RAO7NEW",12,0) N RABWDX,RABWDX1 ; Billing Awareness Project. "RTN","RAO7NEW",13,0) S RAORORDN="",RAD70SB=0,RAORDCTR="SN" ;P18, these sets mean that it's request mode (not the case, when procedure changed during registering or editing) "RTN","RAO7NEW",14,0) I $D(RAREGMOD) S RAORORDN=$P(^RAO(75.1,RAOIFN,0),"^",7)_"^OR",RAORDCTR="XX" ;P18,if register mode (see RAREG2 for EN1^RAO7XX) "RTN","RAO7NEW",15,0) S RATAB=1 D EN1^RAO7UTL "RTN","RAO7NEW",16,0) S RA0=$G(^RAO(75.1,RAOIFN,0)) Q:RA0']"" "RTN","RAO7NEW",17,0) SS2 I RAORDCTR="XX" D UPDTRA0^RAO7XX ;P18, update RA0 with #70 inf, sets RAD70SB, that provide D2^D3 of #70 "RTN","RAO7NEW",18,0) S RADFN=+RA0,RAR=$G(^RAO(75.1,RAOIFN,"R")) "RTN","RAO7NEW",19,0) SS3 I RAORDCTR="XX",RAD70SB'=0 S RAR=$G(^RADPT(+RA0,"DT",$P(RAD70SB,"^",1),"P",$P(RAD70SB,"^",2),"R")) ;P18 "RTN","RAO7NEW",20,0) ; "RTN","RAO7NEW",21,0) ;*Billing Awarenes Project: "RTN","RAO7NEW",22,0) ; Retrieve Ordering ICD Dx data to Send to CPRS. "RTN","RAO7NEW",23,0) D SENDCPRS^RABWORD1(RAOIFN) "RTN","RAO7NEW",24,0) ;* "RTN","RAO7NEW",25,0) S RAVAR="RATMP(",RAVARBLE="RATMP" "RTN","RAO7NEW",26,0) ; msh "RTN","RAO7NEW",27,0) S @(RAVAR_RATAB_")")=$$MSH^RAO7UTL("ORM^O01") ;P18 "RTN","RAO7NEW",28,0) ; pid "RTN","RAO7NEW",29,0) S RATAB=RATAB+1,@(RAVAR_RATAB_")")=$$PID^RAO7UTL(RA0) "RTN","RAO7NEW",30,0) ; pv1 "RTN","RAO7NEW",31,0) S RATAB=RATAB+1,@(RAVAR_RATAB_")")=$$PV1^RAO7UTL(RA0) "RTN","RAO7NEW",32,0) K RA("PV1"),VAIP,RABWVSIT "RTN","RAO7NEW",33,0) ; orc "RTN","RAO7NEW",34,0) S RAHL7DT=$$HLDATE^HLFNC($P(RA0,U,21),"TS"),RAPRIOR=$P(RA0,U,6) "RTN","RAO7NEW",35,0) S RAPRIOR=$S(RAPRIOR=1:"S",RAPRIOR=2:"A",RAPRIOR=9:"R",1:"") "RTN","RAO7NEW",36,0) S RA("ORC",7)="^^^"_RAHL7DT_"^^"_RAPRIOR "RTN","RAO7NEW",37,0) S RA("ORC",10)=$P(RA0,U,15),RA("ORC",12)=$P(RA0,U,14) "RTN","RAO7NEW",38,0) S RA("ORC",11)=$P(RA0,U,8) ;approving radiologist "RTN","RAO7NEW",39,0) S RA("ORC",15)=$$HLDATE^HLFNC($P(RA0,"^",16),"TS") "RTN","RAO7NEW",40,0) S RANATURE="" I $L($P(RA0,"^",26)) S RANATURE=$$UP^XLFSTR($P(RA0,"^",26))_RAECH(1)_$$EXTERNAL^DILFD(75.1,26,"",$P(RA0,"^",26)) "RTN","RAO7NEW",41,0) F I=1,2 I '$L($P(RANATURE,"^",I)) S RANATURE="S"_RAECH(1)_"SERVICE CORRECTION" "RTN","RAO7NEW",42,0) K I S RA("ORC",16)=RANATURE_RAECH(1)_"99ORN"_RAECH(1)_RAECH(1)_RAECH(1) "RTN","RAO7NEW",43,0) S RATAB=RATAB+1 "RTN","RAO7NEW",44,0) ;P18, next line was modified "RTN","RAO7NEW",45,0) SS4 S @(RAVAR_RATAB_")")="ORC"_RAHLFS_RAORDCTR_RAHLFS_RAORORDN_RAHLFS_RAOIFN_RAECH(1)_"RA"_$$STR^RAO7UTL(4)_RA("ORC",7)_$$STR^RAO7UTL(3)_RA("ORC",10)_RAHLFS_RA("ORC",11)_RAHLFS_RA("ORC",12)_$$STR^RAO7UTL(3)_RA("ORC",15)_RAHLFS_RA("ORC",16) "RTN","RAO7NEW",46,0) K RA("ORC") "RTN","RAO7NEW",47,0) ; obr "RTN","RAO7NEW",48,0) S RAPROC(0)=$G(^RAMIS(71,+$P(RA0,U,2),0)),RAPROC(9)=+$P(RAPROC(0),U,9) "RTN","RAO7NEW",49,0) S RACPT(0)=$$NAMCODE^RACPTMSC(RAPROC(9),DT) "RTN","RAO7NEW",50,0) S RA("OBR",4)=$P(RACPT(0),U)_U_$P(RACPT(0),U,2)_U_"CPT4"_U_+$P(RA0,U,2)_U_$P(RAPROC(0),U)_"^99RAP" "RTN","RAO7NEW",51,0) S RA("OBR",12)="" "RTN","RAO7NEW",52,0) S:$P(RA0,U,24)]""&("Yy"[$P(RA0,U,24)) RA("OBR",12)="isolation" "RTN","RAO7NEW",53,0) S RA("OBR",18)="" "RTN","RAO7NEW",54,0) SS5 I RAORDCTR="XX",RAD70SB'=0 D MODIF70^RAO7XX($P(RAD70SB,"^",1),$P(RAD70SB,"^",2)) G CONTIN ;P18 by SS "RTN","RAO7NEW",55,0) I $O(^RAO(75.1,RAOIFN,"M",0)) D "RTN","RAO7NEW",56,0) . S (A,RAXIT)=0 "RTN","RAO7NEW",57,0) . F S A=$O(^RAO(75.1,RAOIFN,"M",A)) Q:A'>0 D Q:RAXIT "RTN","RAO7NEW",58,0) .. S B(0)=$G(^RAO(75.1,RAOIFN,"M",A,0)) "RTN","RAO7NEW",59,0) .. S B(1)=$P($G(^RAMIS(71.2,+B(0),0)),U) "RTN","RAO7NEW",60,0) .. I $L(RA("OBR",18))+$L(B(1))>60 S RAXIT=1 Q "RTN","RAO7NEW",61,0) .. S RA("OBR",18)=$G(RA("OBR",18))_B(1)_RAECH(2) "RTN","RAO7NEW",62,0) .. Q "RTN","RAO7NEW",63,0) . S RA("OBR",18)=$P(RA("OBR",18),RAECH(2),1,$L(RA("OBR",18),RAECH(2))-1) "RTN","RAO7NEW",64,0) . Q "RTN","RAO7NEW",65,0) CONTIN S RALOC(0)=$G(^RA(79.1,+$P(RA0,U,20),0)) "RTN","RAO7NEW",66,0) S RA("OBR",19)=+$P(RA0,U,20)_U_$P($G(^SC(+RALOC(0),0)),U) "RTN","RAO7NEW",67,0) S:+RA("OBR",19)'>0 RA("OBR",19)="" "RTN","RAO7NEW",68,0) S RA("OBR",30)=$S($P(RA0,U,19)="":"","Aa"[$P(RA0,U,19):"WALK","Pp"[$P(RA0,U,19):"PORT","Ss"[$P(RA0,U,19):"CART","Ww"[$P(RA0,U,19):"WHLC",1:"") "RTN","RAO7NEW",69,0) ;----- P75 REASON FOR STUDY OBR-31.2 ----- "RTN","RAO7NEW",70,0) S (RAREASDY,RA("OBR",31))=RAECH(1)_$P($G(^RAO(75.1,RAOIFN,.1)),U) "RTN","RAO7NEW",71,0) S RA("OBRZ")="OBR"_$$STR^RAO7UTL(4)_RA("OBR",4)_$$STR^RAO7UTL(8)_RA("OBR",12)_$$STR^RAO7UTL(6) "RTN","RAO7NEW",72,0) S RA("OBRZ")=RA("OBRZ")_RA("OBR",18)_RAHLFS_RA("OBR",19)_$$STR^RAO7UTL(11)_RA("OBR",30)_RAHLFS_RA("OBR",31) "RTN","RAO7NEW",73,0) S RATAB=RATAB+1,@(RAVAR_RATAB_")")=RA("OBRZ") "RTN","RAO7NEW",74,0) K RA("OBR"),RA("OBRZ") "RTN","RAO7NEW",75,0) ; nte "RTN","RAO7NEW",76,0) SS1 I RAORDCTR="XX",RAD70SB'=0 D ;P18 nte segment "RTN","RAO7NEW",77,0) . N RA18Z S RA18Z=$$GETTCOM^RAUTL11(+RA0,$P(RAD70SB,"^",1),$P(RAD70SB,"^",2)) "RTN","RAO7NEW",78,0) . I RA18Z="" K RA18Z Q "RTN","RAO7NEW",79,0) . S RATAB=RATAB+1,@(RAVAR_RATAB_")")="NTE"_RAHLFS_"16"_RAHLFS_"L"_RAHLFS_$E(RA18Z,1,245) "RTN","RAO7NEW",80,0) . K RA18Z Q "RTN","RAO7NEW",81,0) ; obx "RTN","RAO7NEW",82,0) ;P18 next line was modified - Clinical History capture "RTN","RAO7NEW",83,0) ;----- P75 modifications ----- "RTN","RAO7NEW",84,0) I '$$PATCH^XPDUTL("OR*3.0*243") D ;Reason for Study captured & passed as Clinical History "RTN","RAO7NEW",85,0) . S RACNT=1,RATAB=RATAB+1 ;set Set ID (RACNT) value at one (denotes Reason for Study) "RTN","RAO7NEW",86,0) . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"2000.02^Clinical History^AS4"_RAHLFS_"1"_RAHLFS_"REASON FOR STUDY: "_RAREASDY "RTN","RAO7NEW",87,0) . S RACNT=RACNT+1,RATAB=RATAB+1,$P(RABREAK,"-",($L("REASON FOR STUDY: "_RAREASDY)+1))="" "RTN","RAO7NEW",88,0) . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"2000.02^Clinical History^AS4"_RAHLFS_"1"_RAHLFS_RABREAK "RTN","RAO7NEW",89,0) . K RABREAK "RTN","RAO7NEW",90,0) . Q "RTN","RAO7NEW",91,0) E S RACNT=0 ;OR*3.0*243 is installed, Reason for Study captured in OBR-31.2 "RTN","RAO7NEW",92,0) ;capture only clinical history data. Set ID starts at zero "RTN","RAO7NEW",93,0) SS6 S A=0 F S A=$S(RAORDCTR="XX"&(RAD70SB'=0):$O(^RADPT(+RA0,"DT",$P(RAD70SB,"^",1),"P",$P(RAD70SB,"^",2),"H",A)),1:$O(^RAO(75.1,RAOIFN,"H",A))) Q:A'>0 D "RTN","RAO7NEW",94,0) SS7 . S RACNT=RACNT+1,RATAB=RATAB+1 "RTN","RAO7NEW",95,0) . ;P18 next line was modified "RTN","RAO7NEW",96,0) . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"2000.02^Clinical History^AS4"_RAHLFS_"1"_RAHLFS_$S(RAORDCTR="XX"&(RAD70SB'=0):$G(^RADPT(+RA0,"DT",$P(RAD70SB,"^",1),"P",$P(RAD70SB,"^",2),"H",A,0)),1:$G(^RAO(75.1,RAOIFN,"H",A,0))) "RTN","RAO7NEW",97,0) . Q "RTN","RAO7NEW",98,0) S DFN=RADFN D DEM^VADPT "RTN","RAO7NEW",99,0) ; "RTN","RAO7NEW",100,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAO7NEW",101,0) ;I $P(VADM(5),U)]"",("Ff"[$P(VADM(5),U)) D "RTN","RAO7NEW",102,0) I $P(VADM(5),U)]"",$P(VADM(5),U)'="M" D "RTN","RAO7NEW",103,0) .; "RTN","RAO7NEW",104,0) . S RATAB=RATAB+1,RACNT=RACNT+1 "RTN","RAO7NEW",105,0) . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"2000.33^Pregnant^AS4"_$$STR^RAO7UTL(2)_$S($P(RA0,U,13)="":"","Yy"[$P(RA0,U,13):"Y","Nn"[$P(RA0,U,13):"N",1:"U") "RTN","RAO7NEW",106,0) . Q "RTN","RAO7NEW",107,0) I +$P(RA0,U,9) D "RTN","RAO7NEW",108,0) . S RATAB=RATAB+1,RACNT=RACNT+1 "RTN","RAO7NEW",109,0) . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"CE"_RAHLFS_"34^Contract Sharing/Source^99DD"_$$STR^RAO7UTL(2)_$P(RA0,U,9)_RAECH(1)_$P($G(^DIC(34,+$P(RA0,U,9),0)),U) "RTN","RAO7NEW",110,0) . Q "RTN","RAO7NEW",111,0) I RAR]"" D "RTN","RAO7NEW",112,0) . S RATAB=RATAB+1,RACNT=RACNT+1 "RTN","RAO7NEW",113,0) . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"^Research Source^"_$$STR^RAO7UTL(2)_RAR "RTN","RAO7NEW",114,0) . Q "RTN","RAO7NEW",115,0) I +$P(RA0,U,12) D "RTN","RAO7NEW",116,0) . S RATAB=RATAB+1,RACNT=RACNT+1 "RTN","RAO7NEW",117,0) . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TS"_RAHLFS_"^Pre Op Scheduled Date/Time^"_$$STR^RAO7UTL(2)_$$HLDATE^HLFNC($P(RA0,U,12),"TS") "RTN","RAO7NEW",118,0) . Q "RTN","RAO7NEW",119,0) ; DG1 Segment "RTN","RAO7NEW",120,0) ;*Billing Awareness Project: "RTN","RAO7NEW",121,0) ; Send Ordering ICD Dx data to CPRS: DG1 and related ZCL segments. "RTN","RAO7NEW",122,0) I $D(RABWDX1) D "RTN","RAO7NEW",123,0) . N RA1 S RA1="" "RTN","RAO7NEW",124,0) . F S RA1=$O(RABWDX1(RA1)) Q:RA1="" D "RTN","RAO7NEW",125,0) .. S RATAB=RATAB+1,RACNT=RACNT+1 "RTN","RAO7NEW",126,0) .. S @(RAVAR_RATAB_")")=RABWDX1(RA1) "RTN","RAO7NEW",127,0) . Q "RTN","RAO7NEW",128,0) ;* "RTN","RAO7NEW",129,0) K RAREASDY,VA,VADM,VAERR D MSG^RAO7UTL("RA EVSEND OR",.@RAVARBLE) "RTN","RAO7NEW",130,0) Q "RTN","RAORD1A") 0^3^B11426666 "RTN","RAORD1A",1,0) RAORD1A ;HISC/FPT-Request an Exam ; 06 Oct 2013 11:03 AM "RTN","RAORD1A",2,0) ;;5.0;Radiology/Nuclear Medicine;**1,86,99,1005**;Mar 16, 1998;Build 13 "RTN","RAORD1A",3,0) ; "RTN","RAORD1A",4,0) ;Call to WIN^DGPMDDCF (Supported IA #1246) from the SCREENW function "RTN","RAORD1A",5,0) ;Supported IA #10039 reference to ^DIC(42 "RTN","RAORD1A",6,0) ;Supported IA #10040 reference to ^SC "RTN","RAORD1A",7,0) ;Supported IA #10061 reference to ^VADPT "RTN","RAORD1A",8,0) ;Supported IA #10103 reference to ^XLFDT "RTN","RAORD1A",9,0) ;Supported IA #2056 reference to ^DIQ "RTN","RAORD1A",10,0) ; "RTN","RAORD1A",11,0) SCREEN(RAINPAT,RACPRS27) ; screen for active clinics/wards "RTN","RAORD1A",12,0) ; This code is also called from RAORD1 (screen for the Patient Location "RTN","RAORD1A",13,0) ; prompt which is a pointer to the HOSPITAL LOCATION (#44) file.) "RTN","RAORD1A",14,0) ; We want to EXCLUDE from our selection the following types of "RTN","RAORD1A",15,0) ; hospital locations: "RTN","RAORD1A",16,0) ; "RTN","RAORD1A",17,0) ; 1) Occasion of Service (OOS) locations (fld: 50.01) 'OOS' node "RTN","RAORD1A",18,0) ; 2) File Area ("F") or Imaging ("I") locations (fld: 2) "RTN","RAORD1A",19,0) ; 3) Inactivate Date (fld: 2505) 'I' node "RTN","RAORD1A",20,0) ; "RTN","RAORD1A",21,0) ; input: RAINPAT=1 if the patient is an inpatient located on a ward, else 0. "RTN","RAORD1A",22,0) ; RACPRS27=1 if the environment is running CPRS GUI v27, else 0. "RTN","RAORD1A",23,0) ; "RTN","RAORD1A",24,0) Q:$D(^SC(+Y,"OOS"))#2 0 ; #1 "RTN","RAORD1A",25,0) N RA44 S RA44=$G(^SC(+Y,0)),RA44(42)=$P($G(^SC(+Y,42)),U) "RTN","RAORD1A",26,0) Q:"^F^I^"[(U_$P(RA44,U,3)_U) 0 ; #2 "RTN","RAORD1A",27,0) ; "RTN","RAORD1A",28,0) ; if the hospital location is defined as a ward set RAWARD to 1, else 0 "RTN","RAORD1A",29,0) N RAWARD S RAWARD=0 "RTN","RAORD1A",30,0) ;check the pointer to the WARD LOCATION file. "RTN","RAORD1A",31,0) I RA44(42)>0 D Q:RAWARD=-1 0 "RTN","RAORD1A",32,0) .;Error; the HOSPITAL LOCATION cannot be of TYPE 'Clinic' & point to a ward "RTN","RAORD1A",33,0) .I $P(RA44,U,3)="C" S RAWARD=-1 Q "RTN","RAORD1A",34,0) .;Error; bad pointers between files 42 & 44 "RTN","RAORD1A",35,0) .I $P($G(^DIC(42,RA44(42),44)),U)'=+Y S RAWARD=-1 Q "RTN","RAORD1A",36,0) .;ok, set ward flag... "RTN","RAORD1A",37,0) .S RAWARD=1 "RTN","RAORD1A",38,0) .Q "RTN","RAORD1A",39,0) ; "RTN","RAORD1A",40,0) ; 1) if the hospital location is a ward check if we should screen by ward "RTN","RAORD1A",41,0) ; 2) the hosp location=ward, facility is running v26, and we have an "RTN","RAORD1A",42,0) ; outpatient quit zero (default of the $S) "RTN","RAORD1A",43,0) I RAWARD Q $S(RACPRS27!RAINPAT:$$SCREENW(+Y),1:0) "RTN","RAORD1A",44,0) ; "RTN","RAORD1A",45,0) ; if the hospital location is a clinic, we have an inpatient, and the "RTN","RAORD1A",46,0) ; facility is not running CPRS v27 return 0 "RTN","RAORD1A",47,0) I 'RACPRS27,(RAINPAT) Q 0 "RTN","RAORD1A",48,0) ; "RTN","RAORD1A",49,0) ; Check INACTIVATE DATE against REACTIVATE DATE "RTN","RAORD1A",50,0) ; inactivate date = reactivate date (allow) "RTN","RAORD1A",51,0) ; inactivate date > reactivate date (disallow) "RTN","RAORD1A",52,0) ; inactivate date < reactivate date (allow) "RTN","RAORD1A",53,0) ; "RTN","RAORD1A",54,0) N RASCA,RASCI,RASCINDE S RASCINDE=$G(^SC(+Y,"I")) "RTN","RAORD1A",55,0) S RASCI=+$P(RASCINDE,U),RASCA=+$P(RASCINDE,U,2) "RTN","RAORD1A",56,0) ; "RTN","RAORD1A",57,0) Q $S(RASCI'>0:1,RASCI>DT:1,1:RASCI'>RASCA) "RTN","RAORD1A",58,0) ; "RTN","RAORD1A",59,0) SCREENW(Y) ; check the out-of-service field of the WARD LOCATION (#42) record. "RTN","RAORD1A",60,0) ;input Y: ien of the HOSPITAL LOCATION record "RTN","RAORD1A",61,0) ; RAWHEN: DATE DESIRED (Not guaranteed) (file: 75.1, fld: 21) optional "RTN","RAORD1A",62,0) ;output : '0' if not valid, else '1' if valid "RTN","RAORD1A",63,0) N D0,DGPMOS,X "RTN","RAORD1A",64,0) S D0=+$G(^SC(Y,42)) "RTN","RAORD1A",65,0) Q:'D0 0 "RTN","RAORD1A",66,0) Q:'($D(^DIC(42,D0,0))#2) 0 "RTN","RAORD1A",67,0) ; "RTN","RAORD1A",68,0) ;WIN^DGPMDDCF (Supported IA #1246) Is the ward active? "RTN","RAORD1A",69,0) ; Input "RTN","RAORD1A",70,0) ; D0 "Dee zero" (req): IEN of WARD LOCATION file. "RTN","RAORD1A",71,0) ; DGPMOS (opt): defaults to DT. Is the ward in service on this date? "RTN","RAORD1A",72,0) ; Output "RTN","RAORD1A",73,0) ; X: 1 if out of service, 0 if in service, or -1 if input variables "RTN","RAORD1A",74,0) ; not defined properly. Be careful; note the difference in their "RTN","RAORD1A",75,0) ; boolean definition ('0'=success) and ours ('0'=failure) "RTN","RAORD1A",76,0) ; "RTN","RAORD1A",77,0) S:$D(RAWHEN)#2 DGPMOS=$P(RAWHEN,".",1) "RTN","RAORD1A",78,0) D WIN^DGPMDDCF "RTN","RAORD1A",79,0) Q 'X ;alter 'X' (the WIN^DGPMDDCF output value) to meet our ($$SCREENW) output definition "RTN","RAORD1A",80,0) ; "RTN","RAORD1A",81,0) PREG(RADFN,RADT) ; Subroutine will display the pregnancy prompt to the "RTN","RAORD1A",82,0) ; user if the patient is between the ages of 12 - 55 inclusive. "RTN","RAORD1A",83,0) ; Called from CREATE1^RAORD1. "RTN","RAORD1A",84,0) ; Input : RADFN - Patient, RADT - Today's date "RTN","RAORD1A",85,0) ; Output: Patient Pregnant? (yes, no, unknown or no default) "RTN","RAORD1A",86,0) ; Note: (may set RAOUT if the user times out or '^' out) "RTN","RAORD1A",87,0) ; "RTN","RAORD1A",88,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAORD1A",89,0) ;Q:RASEX'="F" "" ; not a female "RTN","RAORD1A",90,0) Q:RASEX="M" "" "RTN","RAORD1A",91,0) ; "RTN","RAORD1A",92,0) S:RADT="" RADT=$$DT^XLFDT() "RTN","RAORD1A",93,0) N RADAYS,VADM D DEM^VADPT ; $P(VADM(3),"^") DOB of patient, internal "RTN","RAORD1A",94,0) S RADAYS=$$FMDIFF^XLFDT(RADT,$P(VADM(3),"^"),3) ;P#99 correct/replace variable RAWHEN to RADT "RTN","RAORD1A",95,0) Q:((RADAYS\365.25)<12) "" ; too young "RTN","RAORD1A",96,0) Q:((RADAYS\365.25)>55) "" ; too old "RTN","RAORD1A",97,0) ;if RA ADDEXAM option, display and copy pregnany status from previous active order "RTN","RAORD1A",98,0) I $D(RAOPT("ADDEXAM")) W !,"PREGNANT AT TIME OF ORDER ENTRY: ",$$GET1^DIQ(75.1,$$PRACTO^RAUTL8(RADFN),13) Q $$GET1^DIQ(75.1,$$PRACTO^RAUTL8(RADFN),13,"I") "RTN","RAORD1A",99,0) N DIR,DIROUT,DIRUT,DUOUT,DTOUT S DIR(0)="75.1,13",DIR("A")="PREGNANT AT TIME OF ORDER ENTRY" D ^DIR "RTN","RAORD1A",100,0) S:$D(DIRUT) RAOUT="^" Q:$D(RAOUT) "" "RTN","RAORD1A",101,0) Q $P(Y,"^") "RTN","RAORD1A",102,0) ; "RTN","RAORD1A",103,0) INIMOD(Y) ; check if the user has selected the same "RTN","RAORD1A",104,0) ; modifier more than once when the order is requested. "RTN","RAORD1A",105,0) ; The 'Request an Exam' option. Called from MODS^RAORD1 "RTN","RAORD1A",106,0) ; Input: 'Y' the name of the procedure modifier "RTN","RAORD1A",107,0) ; Output: 'X' if the user has not entered this modifier in "RTN","RAORD1A",108,0) ; the past return one (1). Else return zero (0). "RTN","RAORD1A",109,0) Q:'$D(RAMOD) 1 ; must allow the selection of the first modifier "RTN","RAORD1A",110,0) ; after this, it is assumed that the RAMOD array is defined. "RTN","RAORD1A",111,0) N RACNT,X S X=1,RACNT=99999 "RTN","RAORD1A",112,0) F S RACNT=$O(RAMOD(RACNT),-1) Q:RACNT=""!(X=0) S:RAMOD(RACNT)=Y X=0 "RTN","RAORD1A",113,0) Q X "RTN","RAORD1A",114,0) ; "RTN","RAORD3") 0^4^B27371696 "RTN","RAORD3",1,0) RAORD3 ;HISC/CAH - AISC/RMO-Detailed Request Display Cont. ; 06 Oct 2013 11:04 AM "RTN","RAORD3",2,0) ;;5.0;Radiology/Nuclear Medicine;**5,15,21,27,45,41,75,99,1005**;Mar 16, 1998;Build 13 "RTN","RAORD3",3,0) ;Supported IA #2056 reference to ^DIQ "RTN","RAORD3",4,0) ;Supported IA #10103 reference to ^XLFDT "RTN","RAORD3",5,0) ; "RTN","RAORD3",6,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAORD3",7,0) ;I $$PTSEX^RAUTL8(RADFN)="F" D ;display pregnancy status for females ptch 45, P#99 changed Pregnancy title.'Pregnancy Screen:' field. This field shall be a display-only field "RTN","RAORD3",8,0) I $$PTSEX^RAUTL8(RADFN)'="M" D "RTN","RAORD3",9,0) .; "RTN","RAORD3",10,0) .W !,"Pregnant at time of order entry: ",?22,$S($P(RAORD0,"^",13)="y":"YES",$P(RAORD0,"^",13)="n":"NO",1:"UNKNOWN") "RTN","RAORD3",11,0) .N RA700332,RA700380 "RTN","RAORD3",12,0) .S RA700332=$$GET1^DIQ(70.03,$G(RACNI)_","_$G(RADTI)_","_$G(RADFN),32) "RTN","RAORD3",13,0) .S RA700380=$$GET1^DIQ(70.03,$G(RACNI)_","_$G(RADTI)_","_$G(RADFN),80) "RTN","RAORD3",14,0) .I RA700332'="" W !,"Pregnancy Screen: ",RA700332 "RTN","RAORD3",15,0) .I RA700380'="" W !,"Pregnancy Screen Comment: ",RA700380 "RTN","RAORD3",16,0) W:$P(RAORD0,"^",24)="y" !?12,"*** Universal Isolation Precautions ***" W:$D(RA("VDT")) !?8,$C(7),"** Note: Request Associated with Visit on ",RA("VDT")," **" "RTN","RAORD3",17,0) W:$D(RA("RDT"))&($D(RAPKG)) !,"Desired Date:",?22,RA("RDT") W:$D(RA("PDT")) !,"Pre-op Scheduled:",?22,RA("PDT") S RAOSTS=$P(RAORD0,"^",5) I RAOSTS=8,$D(RA("SDT")) W !,"Exam Scheduled:",?22,RA("SDT") "RTN","RAORD3",18,0) I RAOSTS=1 D USERCAN "RTN","RAORD3",19,0) W !,"Transport:",?22,RA("TRAN") "RTN","RAORD3",20,0) I $L(RA("STY_REA")) D DIWP^RAUTL5(1,68,"Reason for Study: "_RA("STY_REA")) ;P75 "RTN","RAORD3",21,0) D ODX^RABWUTL(RAOIFN) ;display Ordering DX and Clin Inds, Billing Aware "RTN","RAORD3",22,0) I $O(^RAO(75.1,RAOIFN,"H",0)) D Q:$G(OREND)=1!($G(RAX)="^") "RTN","RAORD3",23,0) . D CHIST(RAOIFN) "RTN","RAORD3",24,0) . Q "RTN","RAORD3",25,0) I RAOSTS=1!(RAOSTS=3) W !,"Reason ",$S(RAOSTS=1:"Cancelled",1:"Held"),":",?22,$S($D(^RA(75.2,+$P(RAORD0,"^",10),0)):$E($P(^(0),"^"),1,50),$P(RAORD0,"^",27)]"":$E($P(RAORD0,"^",27),1,50),1:"UNKNOWN") D TEXT:RAOSTS=3 "RTN","RAORD3",26,0) W:$D(RA("ST")) !,"Exam Status:",?22,RA("ST") W:$D(RA("ILC")) !,"Request Submitted to: ",RA("ILC") "RTN","RAORD3",27,0) G A:$P(RAORD0,"^",11)'="y",A:'$D(RADTI)!('$D(RACNI)) "RTN","RAORD3",28,0) W !!?7,$C(7),"** Note: Request has been changed by the Imaging Service **" "RTN","RAORD3",29,0) A I $D(^RAO(75.1,RAOIFN,"T")) D ASK:$E(IOST,1,2)="C-" I $D(DIRUT) S RAX="^" K DIRUT "RTN","RAORD3",30,0) Q:Y'=1 I $D(RAPKG),RAX'="^" R !!,"Press return to continue or ""^"" to escape ",X:DTIME S RAX=$E(X) "RTN","RAORD3",31,0) Q "RTN","RAORD3",32,0) ; "RTN","RAORD3",33,0) ASK W ! S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to display request status tracking log",DIR("?")="Enter 'YES' if status tracking log should be displayed, or 'NO' if not." D ^DIR K DIR S:$D(DIRUT) OREND=1 Q:$D(DIRUT)!(Y=0) "RTN","RAORD3",34,0) W !!?20,"*** Request Status Tracking Log ***",!,"Date/Time",?18,"Status",?31,"User",?44,"Reason",!,"-----------------",?18,"------------",?31,"-----------",?44,"------------------------------------" "RTN","RAORD3",35,0) F RALNB=0:0 S RALNB=$O(^RAO(75.1,RAOIFN,"T",RALNB)) Q:'RALNB I $D(^(RALNB,0)) S RATORD0=^(0) D PRTLOG "RTN","RAORD3",36,0) Q K RALNB,RATORD0,RATODT,RATOST,RATREA,RATUSR Q "RTN","RAORD3",37,0) ; "RTN","RAORD3",38,0) PRTLOG S (X,RATODT)=$P(RATORD0,"^") I X S RATODT=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) I $P(X,".",2) D TIME^RAUTL1 S RATODT=RATODT_" "_X "RTN","RAORD3",39,0) S RATOST=$P($P(^DD(75.12,2,0),$P(RATORD0,"^",2)_":",2),";"),RATUSR=$S($D(^VA(200,+$P(RATORD0,"^",3),0)):$P(^(0),"^"),1:"") "RTN","RAORD3",40,0) S RATREA=$S($D(^RA(75.2,+$P(RATORD0,"^",4),0)):$P(^(0),"^"),1:"") "RTN","RAORD3",41,0) W !,RATODT,?18,$E(RATOST,1,12),?31,$E(RATUSR,1,11),?44,$E(RATREA,1,35) I $E(RATREA,36,70)'="" W !,?44,$E(RATREA,36,70) "RTN","RAORD3",42,0) Q "RTN","RAORD3",43,0) TEXT ; display Hold Description text "RTN","RAORD3",44,0) Q:'$O(^RAO(75.1,RAOIFN,1,0)) "RTN","RAORD3",45,0) W !,"Hold Description:",! "RTN","RAORD3",46,0) K ^UTILITY($J,"W"),^(1) S DIWL=22,DIWR=75,DIWF="W" "RTN","RAORD3",47,0) F RARR=0:0 S RARR=$O(^RAO(75.1,RAOIFN,1,RARR)) Q:RARR'>0 S X=^(RARR,0) D ^DIWP "RTN","RAORD3",48,0) D ^DIWW "RTN","RAORD3",49,0) Q "RTN","RAORD3",50,0) CHIST(RAY) ; display Clinical History (if applicable) "RTN","RAORD3",51,0) Q:RAY'?1N.N Q:'$O(^RAO(75.1,RAY,"H",0)) "RTN","RAORD3",52,0) N DIWF,DIWL,DIWR,RABAN,RARR,RAXIT "RTN","RAORD3",53,0) K ^UTILITY($J,"W") S DIWL=22,DIWR=75,DIWF="",RARR=0 "RTN","RAORD3",54,0) F S RARR=$O(^RAO(75.1,RAY,"H",RARR)) Q:RARR'>0 D "RTN","RAORD3",55,0) . ; store into ^UTILITY($J,"W") "RTN","RAORD3",56,0) . S X=$G(^RAO(75.1,RAY,"H",RARR,0)) D ^DIWP "RTN","RAORD3",57,0) . Q "RTN","RAORD3",58,0) S (RARR,RAXIT)=0,RABAN="Clinical History: " "RTN","RAORD3",59,0) I $Y>(IOSL-4) D "RTN","RAORD3",60,0) . S RAXIT=$$EOS() "RTN","RAORD3",61,0) . I 'RAXIT,('$D(RAPKG)) W @IOF "RTN","RAORD3",62,0) . I 'RAXIT,($D(RAPKG)) D HDR^RAORD2 "RTN","RAORD3",63,0) . Q "RTN","RAORD3",64,0) I RAXIT S:$D(RAPKG) RAX="^" K ^UTILITY($J,"W") Q "RTN","RAORD3",65,0) W !,RABAN "RTN","RAORD3",66,0) F S RARR=$O(^UTILITY($J,"W",DIWL,RARR)) Q:RARR'>0 D Q:RAXIT "RTN","RAORD3",67,0) . S X=$G(^UTILITY($J,"W",DIWL,RARR,0)) W ?22,X,! "RTN","RAORD3",68,0) . I $Y>(IOSL-4) D "RTN","RAORD3",69,0) .. S RAXIT=$$EOS() "RTN","RAORD3",70,0) .. I 'RAXIT,('$D(RAPKG)) W @IOF "RTN","RAORD3",71,0) .. I 'RAXIT,($D(RAPKG)) D HDR^RAORD2 W ! "RTN","RAORD3",72,0) .. Q "RTN","RAORD3",73,0) . Q "RTN","RAORD3",74,0) S:RAXIT&($D(RAPKG)) RAX="^" K ^UTILITY($J,"W") ; kill global "RTN","RAORD3",75,0) Q "RTN","RAORD3",76,0) EOS() ; End of screen check for both OE/RR & Rad/Nuc Med "RTN","RAORD3",77,0) ; Var List: $D(RAPKG) entry through Rad/Nuc Med, else through OE/RR "RTN","RAORD3",78,0) ; Passes back 'Y', Y=1 do not continue, Y=0 continue "RTN","RAORD3",79,0) ; NOTE: Sets OREND if code entered through OE/RR. This code may be "RTN","RAORD3",80,0) ; hit when the user accesses the 'Act On Existing Orders' through "RTN","RAORD3",81,0) ; OE/RR. 'Detailed Order Display' (8^RAORR) hits ENDIS^RAORD2 "RTN","RAORD3",82,0) ; which mimics (hits same code) the Rad/Nuc Med 'Detailed Request "RTN","RAORD3",83,0) ; Display' option. The old PGBRK^ORUHDR code set OREND to 0 "RTN","RAORD3",84,0) ; initially, (even though it is set to 0 upon entering this "RTN","RAORD3",85,0) ; sub-routine) and re-set it to 1 if the user enters an '^' at "RTN","RAORD3",86,0) ; the "Enter RETURN to continue or '^' to exit:" prompt. "RTN","RAORD3",87,0) S Y=$$EOS^RAUTL5() S:'$D(RAPKG) OREND=Y "RTN","RAORD3",88,0) Q Y "RTN","RAORD3",89,0) USERCAN ;user who cancelled this request "RTN","RAORD3",90,0) Q:$P($G(^RAO(75.1,RAOIFN,0)),U,5)'=1 ;only look at 'discontinued' "RTN","RAORD3",91,0) N RA8,RA9 S RA8=0 "RTN","RAORD3",92,0) F S RA8=$O(^RAO(75.1,RAOIFN,"T",RA8)) Q:'RA8 I $G(^(RA8,0))]"",$P(^(0),U,2)=1 S RA9=RA8 ; find latest ien of 'discontinued' "RTN","RAORD3",93,0) S RA("ODT")="",RA("USR")="" "RTN","RAORD3",94,0) I $G(RA9) D USERCAN1 "RTN","RAORD3",95,0) E D USERCAN2 "RTN","RAORD3",96,0) W !,"Cancelled:",?22,RA("ODT") W:RA("USR")]"" " by ",RA("USR") "RTN","RAORD3",97,0) K RA("ODT"),RA("USR") "RTN","RAORD3",98,0) Q "RTN","RAORD3",99,0) USERCAN1 ;use request track times to get when and who cancelled "RTN","RAORD3",100,0) S X=$P(^RAO(75.1,RAOIFN,"T",RA9,0),U) D:X TRDT "RTN","RAORD3",101,0) S RA("USR")=$P($G(^VA(200,+$P(^RAO(75.1,RAOIFN,"T",RA9,0),U,3),0)),U) "RTN","RAORD3",102,0) Q "RTN","RAORD3",103,0) USERCAN2 ;use vars DUZ and RAORD0 to get "who" and "when" cancelled "RTN","RAORD3",104,0) S X=$P($G(RAORD0),U,18) D:X TRDT "RTN","RAORD3",105,0) ; don't use duz if within any one of 3 rad request options "RTN","RAORD3",106,0) Q:$D(RASCREEN) Q:$D(RAOPT("ORDERPRINTS")) Q:$D(RAOPT("ORDERPRINTPAT")) "RTN","RAORD3",107,0) S RA("USR")=$P($G(^VA(200,$G(DUZ),0)),U) "RTN","RAORD3",108,0) Q "RTN","RAORD3",109,0) TRDT S:$P(X,".",2) X=$P(X,".")_"."_$$NOSECNDS($P(X,".",2)) "RTN","RAORD3",110,0) S RA("ODT")=$$FMTE^XLFDT(X,"1P") "RTN","RAORD3",111,0) Q "RTN","RAORD3",112,0) NOSECNDS(X) ; If a timestamp is associated with a date, strip off seconds. "RTN","RAORD3",113,0) ; Input : X-timestamp (153048) "RTN","RAORD3",114,0) ; Output: (1530) "RTN","RAORD3",115,0) Q $E(X,1,4) "RTN","RAORD6") 0^5^B60885097 "RTN","RAORD6",1,0) RAORD6 ;HISC/CAH - AISC/RMO-Print A Request Cont. ; 06 Oct 2013 10:47 AM "RTN","RAORD6",2,0) ;;5.0;Radiology/Nuclear Medicine;**5,10,15,18,27,45,41,75,85,99,1003**;Nov 01, 2010;Build 13 "RTN","RAORD6",3,0) ; 3-p75 10/12/2006 GJC RA*5*75 print Reason for Study "RTN","RAORD6",4,0) ; 4-p75 10/12/2006 KAM RA*5*75 display the request print date in the header "RTN","RAORD6",5,0) ; 5-p75 10/12/2006 KAM RA*5*75 update header "Age" to "Age at req" "RTN","RAORD6",6,0) ; 6-p85 06/20/2007 KAM RA*5*85 Reason for Study/Bar Code print issue "RTN","RAORD6",7,0) ; Remedy Call - 193859 "RTN","RAORD6",8,0) ;Supported IA #10104 reference to ^XLFSTR "RTN","RAORD6",9,0) ;Supported IA #10060 reference to ^VA(200 "RTN","RAORD6",10,0) D HD Q:RAX["^" "RTN","RAORD6",11,0) ; "RTN","RAORD6",12,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAORD6",13,0) ;I $$PTSEX^RAUTL8(RADFN)="F" D ;display pregnancy status for females ptch 45 "RTN","RAORD6",14,0) I $$PTSEX^RAUTL8(RADFN)'="M" D "RTN","RAORD6",15,0) .; "RTN","RAORD6",16,0) .W !,"Pregnant at time of order entry: ",?22,$S($P(RAORD0,"^",13)="y":"YES",$P(RAORD0,"^",13)="n":"NO",1:"UNKNOWN") "RTN","RAORD6",17,0) .Q:'$D(RAOIFN) "RTN","RAORD6",18,0) .Q:'$D(^RADPT("AO",$G(RAOIFN),RADFN)) "RTN","RAORD6",19,0) .N RAINVDT,RA5 "RTN","RAORD6",20,0) .S RAINVDT=$O(^RADPT("AO",RAOIFN,RADFN,0)) "RTN","RAORD6",21,0) .Q:'$G(RAINVDT) "RTN","RAORD6",22,0) .S RA5=$O(^RADPT("AO",RAOIFN,RADFN,RAINVDT,0)) "RTN","RAORD6",23,0) .Q:'$G(RA5) "RTN","RAORD6",24,0) .N R3,RAPCOMM S R3=$G(^RADPT(RADFN,"DT",$G(RAINVDT),"P",$G(RA5),0)) "RTN","RAORD6",25,0) .S RAPCOMM=$G(^RADPT(RADFN,"DT",+$G(RAINVDT),"P",+$G(RA5),"PCOMM")) "RTN","RAORD6",26,0) .W:$P(R3,U,32)'="" !,"Pregnancy Screen: ",$S($P(R3,"^",32)="y":"Patient answered yes",$P(R3,"^",32)="n":"Patient answered no",$P(R3,"^",32)="u":"Patient is unable to answer or is unsure",1:"") "RTN","RAORD6",27,0) .W:$P(R3,U,32)'="n"&$L(RAPCOMM) !,"Pregnancy Screen Comment: ",RAPCOMM "RTN","RAORD6",28,0) .Q "RTN","RAORD6",29,0) W:$P(RAORD0,"^",24)="y" !!?12,"*** Universal Isolation Precautions ***" "RTN","RAORD6",30,0) W:$D(RA("VDT")) !!?8,"** Note Request Associated with Visit on ",RA("VDT")," **" "RTN","RAORD6",31,0) W !!,"Requested:",?18,RA("PRC INFO") "RTN","RAORD6",32,0) ; "RTN","RAORD6",33,0) I $D(^TMP($J,"RA DIFF PRC")),('$D(RAFOERR)),('$D(RAOPT("REG"))),('$D(RAOPT("ORDEREXAM"))),('$D(RAOPT("ADDEXAM"))) D Q:RAX["^" "RTN","RAORD6",34,0) . ; don't print registered procedure info (CPT, Proc Type, Imaging "RTN","RAORD6",35,0) . ; Type) if entering through 'Request An Exam', 'Register Patient "RTN","RAORD6",36,0) . ; for Exams' or 'Add Exams To Last Visit'. Don't print if ordered "RTN","RAORD6",37,0) . ; through ANY version of OE/RR. If ordered through OE/RR, RAFOERR "RTN","RAORD6",38,0) . ; will be defined. (Set in RAORD1 & RAO7RO) "RTN","RAORD6",39,0) . N RAT,RA18NLIN S RAT="",RA18NLIN=0 W !,"Registered:" "RTN","RAORD6",40,0) . F S RAT=$O(^TMP($J,"RA DIFF PRC",RAT)) Q:RAT="" D Q:RAX["^" "RTN","RAORD6",41,0) .. D HD:($Y+6)>IOSL Q:RAX["^" "RTN","RAORD6",42,0) .. W:RA18NLIN ! W ?12,RAT "RTN","RAORD6",43,0) .. S RA18NLIN=1 "RTN","RAORD6",44,0) .. Q "RTN","RAORD6",45,0) . Q "RTN","RAORD6",46,0) I $G(RACMFLG("O"))'="" W !?12,"** The requested procedure has contrast media assigned **" "RTN","RAORD6",47,0) I $G(RACMFLG("R"))'="" W !?12,"** A registered procedure uses contrast media **" "RTN","RAORD6",48,0) W:$D(RA("MOD")) !,"Procedure Modifiers:",?22,RA("MOD") "RTN","RAORD6",49,0) I RA("PRC MSG") D Q:RAX["^" "RTN","RAORD6",50,0) . N A,B,C,X S (A,C)=0 W !,"Procedure Message: ",! "RTN","RAORD6",51,0) . F S A=$O(^RAMIS(71,+$P(RAORD0,"^",2),3,A)) Q:A'>0!(RAX["^") D "RTN","RAORD6",52,0) .. S B=+$G(^RAMIS(71,+$P(RAORD0,"^",2),3,A,0)) "RTN","RAORD6",53,0) .. S X=$G(^RAMIS(71.4,B,0)) "RTN","RAORD6",54,0) .. W:'C ?3,"-" W:C !?3,"-" "RTN","RAORD6",55,0) .. D OUTTEXT^RAUTL9(X,"",5,80,4,"","!") "RTN","RAORD6",56,0) .. D HD:($Y+6)>IOSL S C=C+1 "RTN","RAORD6",57,0) .. Q "RTN","RAORD6",58,0) . Q "RTN","RAORD6",59,0) W !,"Request Status:",?22,$E(RA("OST"),1,24) "RTN","RAORD6",60,0) I $P(RAORD0,"^",5)=1!($P(RAORD0,"^",5)=3) D Q:RAX["^" "RTN","RAORD6",61,0) . W !,"Reason ",$S($P(RAORD0,"^",5)=1:"Cancelled",1:"Held"),":" "RTN","RAORD6",62,0) . W ?22,$S($D(^RA(75.2,+$P(RAORD0,"^",10),0)):$E($P(^(0),"^"),1,50),$P(RAORD0,"^",27)]"":$E($P(RAORD0,"^",27),1,50),1:"UNKNOWN") "RTN","RAORD6",63,0) . D HD:($Y+6)>IOSL Q:RAX["X" "RTN","RAORD6",64,0) . I $D(^RAO(75.1,RAOIFN,1)) D Q:RAX["^" "RTN","RAORD6",65,0) .. N X,I,RAXX "RTN","RAORD6",66,0) .. K ^UTILITY($J,"W") "RTN","RAORD6",67,0) .. W !,"Hold Description:",! "RTN","RAORD6",68,0) .. S I=0 F S I=$O(^RAO(75.1,RAOIFN,1,I)) Q:'I S (RAXX,X)=^(I,0) D HD:($Y+6)>IOSL Q:RAX["^" S X=RAXX D ^DIWP "RTN","RAORD6",69,0) .. Q:RAX["^" "RTN","RAORD6",70,0) .. D HD:($Y+6)>IOSL Q:RAX["X" "RTN","RAORD6",71,0) .. D ^DIWW:$D(RAXX) "RTN","RAORD6",72,0) .. D HD:($Y+6)>IOSL Q:RAX["X" "RTN","RAORD6",73,0) . I $P(RAORD0,"^",5)=1 D "RTN","RAORD6",74,0) .. W !!,?(IOM-(IOM/2+15)),"*********************",!,?(IOM-(IOM/2+15)),"* C A N C E L L E D *",!,?(IOM-(IOM/2+15)),"*********************" "RTN","RAORD6",75,0) W:$P(RAORD0,"^",5)=6&($D(RA("ST"))) !,"Exam Status:",?22,RA("ST") "RTN","RAORD6",76,0) W:$P(RAORD0,"^",5)=8&($D(RA("SDT"))) !,"Exam Scheduled:",?22,RA("SDT") "RTN","RAORD6",77,0) D HD:($Y+6)>IOSL Q:RAX["^" "RTN","RAORD6",78,0) W !!,"Requester:",?22,$E(RA("PHY"),1,20) "RTN","RAORD6",79,0) W:RA("PHY")'="UNKNOWN" !?1,"Tel/Page/Dig Page: ",$G(RA("RPHOINFO")) "RTN","RAORD6",80,0) D HD:($Y+6)>IOSL Q:RAX["^" "RTN","RAORD6",81,0) W !,"Attend Phy Current:",?22,$E(RA("ATTEN"),1,20) "RTN","RAORD6",82,0) W:RA("ATTEN")'="UNKNOWN" !?1,"Tel/Page/Dig Page: ",$G(RA("APHOINFO")) "RTN","RAORD6",83,0) D HD:($Y+6)>IOSL Q:RAX["^" "RTN","RAORD6",84,0) W !,"Prim Phy Current:",?22,$E(RA("PRIM"),1,20) "RTN","RAORD6",85,0) W:RA("PRIM")'="UNKNOWN" !?1,"Tel/Page/Dig Page: ",$G(RA("PPHOINFO")) "RTN","RAORD6",86,0) K RAPASS1,RAPASS2 "RTN","RAORD6",87,0) S RAPASS1=RA("ATTEN"),RAPASS2=RA("OATTEN") "RTN","RAORD6",88,0) D HD:($Y+6)>IOSL Q:RAX["^" "RTN","RAORD6",89,0) I $$ID^RAORD6(RAPASS1,RAPASS2) D "RTN","RAORD6",90,0) . W !,"Attend Phy At Order:",?22,$E(RA("OATTEN"),1,20) "RTN","RAORD6",91,0) . W:RA("OATTEN")'="UNKNOWN" !?1,"Tel/Page/Dig Page: ",$G(RA("OAPHOINFO")) "RTN","RAORD6",92,0) . Q "RTN","RAORD6",93,0) S RAPASS1=RA("PRIM"),RAPASS2=RA("OPRIM") "RTN","RAORD6",94,0) I $$ID^RAORD6(RAPASS1,RAPASS2) D "RTN","RAORD6",95,0) . W !,"Prim Phy At Order:",?22,$E(RA("OPRIM"),1,20) "RTN","RAORD6",96,0) . W:RA("OPRIM")'="UNKNOWN" !?1,"Tel/Page/Dig Page: ",$G(RA("OPPHOINFO")) "RTN","RAORD6",97,0) . Q "RTN","RAORD6",98,0) K RAPASS1,RAPASS2 "RTN","RAORD6",99,0) I +$P(RAORD0,"^",8) D "RTN","RAORD6",100,0) . N RAPPRAD S RAPPRAD=+$P(RAORD0,"^",8) "RTN","RAORD6",101,0) . S:$P($G(^VA(200,RAPPRAD,20)),"^",2)]"" RAPPRAD=$P(^(20),"^",2) "RTN","RAORD6",102,0) . S:RAPPRAD=+RAPPRAD RAPPRAD=$P(^VA(200,RAPPRAD,0),"^") "RTN","RAORD6",103,0) . W !,"Approved by: ",?22,RAPPRAD "RTN","RAORD6",104,0) . Q "RTN","RAORD6",105,0) D HD:($Y+6)>IOSL Q:RAX["^" "RTN","RAORD6",106,0) W !,"Date/Time Ordered:",?22,$S($D(RA("ODT")):RA("ODT"),1:"")," by ",$E(RA("USR"),1,20) "RTN","RAORD6",107,0) W:$D(RA("RDT")) !,"Date Desired:",?22,RA("RDT") "RTN","RAORD6",108,0) D:$P(RAORD0,"^",5)=1 USERCAN^RAORD3 "RTN","RAORD6",109,0) D HD:($Y+6)>IOSL Q:RAX["^" "RTN","RAORD6",110,0) W:$D(RA("PDT")) !,"Pre-op Date/Time:",?22,RA("PDT"),!!?26,"**** P R E - O P ****",! "RTN","RAORD6",111,0) BAR ;Print bar-coded SSN on request form if term type has bar code setup "RTN","RAORD6",112,0) I $G(RASSN)'?3N1"-"2N1"-".E G CONT "RTN","RAORD6",113,0) S X3=$E(RASSN,1,3)_$E(RASSN,5,6)_$E(RASSN,8,11) "RTN","RAORD6",114,0) ; 06/20/2007 KAM/BAY RA*5*85 Added 2 line feeds "RTN","RAORD6",115,0) D PSET^%ZISP I IOBARON]"",(IOBAROFF]"") W !!!?49,@IOBARON,X3,@IOBAROFF,! "RTN","RAORD6",116,0) D PKILL^%ZISP "RTN","RAORD6",117,0) ; "RTN","RAORD6",118,0) CONT D HD:($Y+6)>IOSL Q:RAX["^" D ODX^RABWUTL(RAOIFN) ; * Billing Aware * "RTN","RAORD6",119,0) D HD:($Y+6)>IOSL Q:RAX["^" "RTN","RAORD6",120,0) ; 06/20/2007 KAM/BAY RA*5*85 Added line feed to the next line "RTN","RAORD6",121,0) I $L(RA("STY_REA")) W ! D DIWP^RAUTL5(1,68,"Reason for Study: "_RA("STY_REA")) ;3-p75 "RTN","RAORD6",122,0) D HD:($Y+6)>IOSL Q:RAX["^" K ^UTILITY($J,"W"),^(1) W !,"Clinical History:",! K RAXX F RAV=0:0 S RAV=$O(^RAO(75.1,RAOIFN,"H",RAV)) Q:'RAV I $D(^(RAV,0)) S RAXX=^(0) D HD:($Y+6)>IOSL Q:RAX["^" S X=RAXX D ^DIWP "RTN","RAORD6",123,0) Q:RAX["^" D HD:($Y+6)>IOSL Q:RAX["^" D ^DIWW:$D(RAXX),HD:($Y+6)>IOSL Q:RAX["^" D WORK ;always print bottom section of form 012601 "RTN","RAORD6",124,0) W ! S BOT=IOSL-($Y+4) S:($E(IOST,1,6)="P-BROW"&($D(DDBRZIS))) BOT=5 F BT=1:1:BOT W ! "RTN","RAORD6",125,0) K BOT,BT "RTN","RAORD6",126,0) ;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler patch from 2004 "RTN","RAORD6",127,0) ;Comment out VA form name "RTN","RAORD6",128,0) ;W !,"VA Form 519a-ADP" "RTN","RAORD6",129,0) ;End Patch "RTN","RAORD6",130,0) Q "RTN","RAORD6",131,0) ; "RTN","RAORD6",132,0) WORK W !,RALNE,!,"Date Performed: ________________________",?46 "RTN","RAORD6",133,0) I $O(^RADPT("AO",RAOIFN,0))="" W "Case No.: ______________________" "RTN","RAORD6",134,0) E W "Case No.: ______see above_______" "RTN","RAORD6",135,0) D HD:($Y+6)>IOSL Q:RAX["^" "RTN","RAORD6",136,0) W !,"Technologist Initials: _________________" "RTN","RAORD6",137,0) D HD:($Y+6)>IOSL Q:RAX["^" "RTN","RAORD6",138,0) W !?46,"Number/Size Films: _____________",!,"Interpreting Phys. Initials: ___________",?65,"_____________",!?65,"_____________",! "RTN","RAORD6",139,0) D HD:($Y+6)>IOSL Q:RAX["^" "RTN","RAORD6",140,0) W !,"Comments:" "RTN","RAORD6",141,0) ; "RTN","RAORD6",142,0) TC D EN30^RAO7PC1(RAOIFN),TC^RAORD61 Q:RAX["^" "RTN","RAORD6",143,0) ; "RTN","RAORD6",144,0) DASHLN W ! F I=1:1:5 D HD:($Y+6)>IOSL Q:RAX["^" W !,RALNE ;P18 "RTN","RAORD6",145,0) ;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler patch from 2004 "RTN","RAORD6",146,0) ;Add display of last 5 exams/orders "RTN","RAORD6",147,0) W:($Y+6)'>IOSL !!,RALNE1 S RACONT="" D HD:($Y+8)>IOSL Q:RAX["^" D EXAM^RADEM1 K RACONT W !,RALNE1 "RTN","RAORD6",148,0) ;End Patch "RTN","RAORD6",149,0) Q "RTN","RAORD6",150,0) ; "RTN","RAORD6",151,0) HD S:'$D(RAPGE) RAPGE=0 D CRCHK Q:$G(RAX)["^" S RATAB=$S($D(RA("ILC")):1,1:16) "RTN","RAORD6",152,0) ;10/12/2006 KAM Remedy tk 162508 Changed next line added "Printed:" "RTN","RAORD6",153,0) W:$Y @IOF W !?RATAB,">>"_$S($D(RACRHD):"Discontinued ",1:"")_"Rad/NM Consultation" W:$D(RA("ILC")) " for ",$E(RA("ILC"),1,17) W "< Attending/Primary Phy. Current "RTN","RAORD6",175,0) ; 'Y'-> Attending/Primary Phy. At Order "RTN","RAORD6",176,0) I X']""!(Y']"") Q 0 "RTN","RAORD6",177,0) I $$UP^XLFSTR(X)="UNKNOWN",($$UP^XLFSTR(Y)="UNKNOWN") Q 0 "RTN","RAORD6",178,0) N A,B,Z S A=+$O(^VA(200,"B",X,"")),B=+$O(^VA(200,"B",Y,"")) "RTN","RAORD6",179,0) I A>0,(B>0),(A=B) S Z=0 "RTN","RAORD6",180,0) E S Z=1 "RTN","RAORD6",181,0) Q Z ; $S(Z=1:"different physician",Z=0:"same physician") "RTN","RAPROD") 0^6^B46236144 "RTN","RAPROD",1,0) RAPROD ;HISC/FPT,GJC AISC/MJK-Detailed Exam View ; 06 Oct 2013 11:04 AM "RTN","RAPROD",2,0) ;;5.0;Radiology/Nuclear Medicine;**10,35,45,56,99,47,1005**;Mar 16, 1998;Build 13 "RTN","RAPROD",3,0) ;Supported IA #2056 GET1^DIQ "RTN","RAPROD",4,0) ;Supported IA #2053 UPDATE^DIE "RTN","RAPROD",5,0) ;Supported IA #10040 ^SC( "RTN","RAPROD",6,0) ;Supported IA #10060 ^VA(200 "RTN","RAPROD",7,0) START S RADI=^RADPT(RADFN,"DT",RADTI,0) S:$D(^("P",RACNI,"COMP")) RA("COMP")=^("COMP") S RA("REA")=$S($D(^("R")):^("R"),1:"") "RTN","RAPROD",8,0) S RA("TECH")=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) I RA("TECH") S RA("TECH")=$S($D(^VA(200,+^(RA("TECH"),0),0)):$P(^(0),"^"),1:"") "RTN","RAPROD",9,0) S X=$P(Y(0),"^",4),RA("CAT")=$S(X="I":"INPATIENT",X="O":"OUTPATIENT",X="S":"SHARING",X="C":"CONTRACT",X="R":"RESEARCH",X="E":"EMPLOYEE",1:"UNKNOWN") "RTN","RAPROD",10,0) S RA("RST")=$$RSTAT^RAO7PC1A "RTN","RAPROD",11,0) F I=1:1:13 S Y=$T(LIST+I),@$P(Y,";",3)=$S($D(@($P(Y,";",4)_+$P(@$P(Y,";",5),"^",$P(Y,";",6))_",0)")):$P(^(0),"^"),1:"") "RTN","RAPROD",12,0) ; "RTN","RAPROD",13,0) N RAOPRC ; this will be the Requested Procedure defined only if it "RTN","RAPROD",14,0) ; differs from the Registered Procedure "RTN","RAPROD",15,0) I +$P(Y(0),U,11),($$DPROC^RAUTL15(RADFN,RADTI,RACNI,+$P(Y(0),U,11))]"") D "RTN","RAPROD",16,0) . S RAOPRC=$$GET1^DIQ(75.1,+$P(Y(0),"^",11)_",",2) "RTN","RAPROD",17,0) . Q "RTN","RAPROD",18,0) VIEW W @IOF S X="",$P(X,"=",80)="" W X K X "RTN","RAPROD",19,0) W !?2,"Name : ",RANME," ",RASSN "RTN","RAPROD",20,0) W !?2,"Division : ",$E(RA("DIV"),1,20),?40,"Category : ",RA("CAT") "RTN","RAPROD",21,0) W !?2,"Location : ",$S($D(^SC(+RA("LOC"),0)):$P(^(0),"^"),1:"Unknown"),?40,"Ward : ",$E(RA("WRD"),1,24) "RTN","RAPROD",22,0) W !?2,"Exam Date : ",RADATE,?40,"Service : ",$E(RA("SERV"),1,24) "RTN","RAPROD",23,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RAPROD",24,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RAPROD",25,0) I $$USESSAN^RAHLRU1() W !?2,"Case No. : ",RACNDSP W ?40,"Bedsection : ",$E(RA("BED"),1,24) "RTN","RAPROD",26,0) I '$$USESSAN^RAHLRU1() W !?2,"Case No. : ",RACN W ?40,"Bedsection : ",$E(RA("BED"),1,24) "RTN","RAPROD",27,0) W !?40,"Clinic : ",$E(RA("CL"),1,24) "RTN","RAPROD",28,0) S Y=$E(RA("CAT")) I "CSR"[Y W !?40,$E($S("C"=Y:"Contract : "_RA("CONT"),"S"=Y:"Sharing : "_RA("CONT"),"R"=Y:"Research : "_RA("REA"),1:""),1,38) "RTN","RAPROD",29,0) W:$X>1 ! S X="",$P(X,"-",80)="" W X K X "RTN","RAPROD",30,0) W !?2,"Registered : ",$E(RAPRC,1,60) D PRCCPT "RTN","RAPROD",31,0) ; "RTN","RAPROD",32,0) W:$G(RAOPRC)]"" !?2,"Requested : ",$E(RAOPRC,1,60) "RTN","RAPROD",33,0) W !?2,"Requesting Phy: ",$E(RA("PHY"),1,20),?40,"Exam Status : ",$S($D(^RA(72,RAST,0)):$E($P(^(0),"^"),1,24),1:"") "RTN","RAPROD",34,0) W !?2,"Int'g Resident: ",$E(RA("RES"),1,20),?40,"Report Status: ",$E(RA("RST"),1,21) "RTN","RAPROD",35,0) S RAPREVER=+$P($G(^RARPT(RARPT,0)),"^",13) "RTN","RAPROD",36,0) W !?2,"Pre-Verified : ",$E($S($D(^VA(200,RAPREVER,0)):$P(^(0),"^",1),1:"NO"),1,20),?40,"Cam/Equip/Rm : ",$E(RA("RM"),1,20) K RAPREVER "RTN","RAPROD",37,0) W !?2,"Int'g Staff : ",$E(RA("STAFF"),1,20),?40,"Diagnosis : ",$E(RA("DIA"),1,24) "RTN","RAPROD",38,0) W !?2,"Technologist : ",$E(RA("TECH"),1,20),?40,"Complication : ",$E(RA("CMP"),1,24) "RTN","RAPROD",39,0) I $D(RA("COMP")) W !?2,"Comment : " F I=1:60 Q:$E(RA("COMP"),I,I+59)']"" W ?18,$E(RA("COMP"),I,I+59) "RTN","RAPROD",40,0) ;W:$X>1 ! "RTN","RAPROD",41,0) W ! "RTN","RAPROD",42,0) ; "RTN","RAPROD",43,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAPROD",44,0) ;I $$PTSEX^RAUTL8(RADFN)="F" D ;get pt sex and display pregnancy status for females, ptch #99 "RTN","RAPROD",45,0) I $$PTSEX^RAUTL8(RADFN)'="M" D "RTN","RAPROD",46,0) .; "RTN","RAPROD",47,0) .N RAOR751 S RAOR751=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,11) "RTN","RAPROD",48,0) .W ?2,"Pregnant at time of order entry: ",$$GET1^DIQ(75.1,$G(RAOR751)_",",13) "RTN","RAPROD",49,0) K RAFL W ?47,"Films :" F I=0:0 S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",I)) Q:I'>0 I $D(^(I,0)) S X=^(0) W ?55,$S($D(^RA(78.4,+$P(X,"^"),0)):$P(^(0),"^"),1:"Unknown")," - ",+$P(X,"^",2),! "RTN","RAPROD",50,0) W:$X>1 ! S X="",$P(X,"-",34)="" W X "RTN","RAPROD",51,0) W "Modifiers" W $E(X,1,32) K X "RTN","RAPROD",52,0) W !?2,"Proc Modifiers:" D MODS^RAUTL2 F I=1:1 Q:$P(Y,", ",I)']"" W ?18,$P(Y,", ",I),! "RTN","RAPROD",53,0) N J "RTN","RAPROD",54,0) W !?2,"CPT Modifiers : " W:Y(1)="None" Y(1),! "RTN","RAPROD",55,0) I Y(1)'="None" F I=1:1 Q:$P(Y(2),", ",I)']"" S J=$P(Y(2),", ",I),J=$$BASICMOD^RACPTMSC(J,DT) W ?18,$P(J,"^",2)," ",$P(J,"^",3),! I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W ! "RTN","RAPROD",56,0) Q:+$G(RAXIT) "RTN","RAPROD",57,0) I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W ! "RTN","RAPROD",58,0) Q:+$G(RAXIT) "RTN","RAPROD",59,0) ; "RTN","RAPROD",60,0) ;check for Contrast Media data, print it if it exists. "RTN","RAPROD",61,0) I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0)) D "RTN","RAPROD",62,0) .W !?2,"Contrast Media: " S RACM=1 "RTN","RAPROD",63,0) .N DIWF,DIWL,DIWR,DIWT,X,Z "RTN","RAPROD",64,0) .S X=$$CM^RADEM1(RADFN,RADTI,RACNI),DIWL=20,DIWF="C50" "RTN","RAPROD",65,0) .D ^DIWP S Z=0 "RTN","RAPROD",66,0) .F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:'Z D "RTN","RAPROD",67,0) ..W ?18,^UTILITY($J,"W",DIWL,Z,0) "RTN","RAPROD",68,0) ..W:+$O(^UTILITY($J,"W",DIWL,Z)) ! "RTN","RAPROD",69,0) ..Q "RTN","RAPROD",70,0) .K ^UTILITY($J,"W") "RTN","RAPROD",71,0) .Q "RTN","RAPROD",72,0) ; "RTN","RAPROD",73,0) I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) D PHARM^RAPROD2(RACNI_","_RADTI_","_RADFN_",") W ! ; display pharmaceutical data "RTN","RAPROD",74,0) I +$G(RAXIT) K RAXIT Q "RTN","RAPROD",75,0) I +$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",28) D RDIO^RAPROD2(+$P(^(0),"^",28)) W ! ; display radiopharm data "RTN","RAPROD",76,0) I +$G(RAXIT) K RAXIT Q "RTN","RAPROD",77,0) W:$X>1 ! S X="",$P(X,"=",80)="" W X K X "RTN","RAPROD",78,0) G ^RAPROD1 "RTN","RAPROD",79,0) ; "RTN","RAPROD",80,0) PRCCPT ; display Proc's abbrv, proc type, CPT "RTN","RAPROD",81,0) Q:$G(RADTI)="" Q:$G(RACNI)="" "RTN","RAPROD",82,0) ; "RTN","RAPROD",83,0) N RADISPLY "RTN","RAPROD",84,0) S RADISPLY=$G(^RAMIS(71,+$P($G(^RADPT(+RADFN,"DT",+RADTI,"P",+RACNI,0)),U,2),0)) ; set $ZR to file 71 before calling prccpt^radd1 "RTN","RAPROD",85,0) S RADISPLY=$$PRCCPT^RADD1() "RTN","RAPROD",86,0) W ?54,RADISPLY "RTN","RAPROD",87,0) Q "RTN","RAPROD",88,0) SETL ;Set long display preference "RTN","RAPROD",89,0) N RA1,RA2,DIR "RTN","RAPROD",90,0) S RA1=$O(^RA(79,0)) Q:'RA1 "RTN","RAPROD",91,0) S RA2=$O(^RA(79,RA1,"LDIS","B",DUZ,0)) "RTN","RAPROD",92,0) I RA2 D Q "RTN","RAPROD",93,0) . W !!,"Your preference for Long Display of Procedures has already been set." "RTN","RAPROD",94,0) . S DIR(0)="Y",DIR("A")="Do you want to delete your preference ",DIR("B")="No" "RTN","RAPROD",95,0) . S DIR("?",1)="If you answer 'Yes', then all Radiology reports requested by you will" "RTN","RAPROD",96,0) . S DIR("?",2)="will default to the condensed display, which means that repeated procedures" "RTN","RAPROD",97,0) . S DIR("?")="and associated modifiers will only be listed once." "RTN","RAPROD",98,0) . D ^DIR "RTN","RAPROD",99,0) . Q:'Y "RTN","RAPROD",100,0) . D DEL150 "RTN","RAPROD",101,0) . Q "RTN","RAPROD",102,0) W ! "RTN","RAPROD",103,0) S DIR(0)="Y",DIR("A",1)="Do you want to set your preference for Long Display of Procedures" "RTN","RAPROD",104,0) S DIR("A")="in all Radiology reports ",DIR("B")="No" "RTN","RAPROD",105,0) S DIR("?",1)="If you answer 'Yes', then all Radiology reports requested by you will" "RTN","RAPROD",106,0) S DIR("?",2)="list all repeated procedures and associated modifiers instead of" "RTN","RAPROD",107,0) S DIR("?")="listing repeated procedures only once, which is the condensed (default) format." "RTN","RAPROD",108,0) D ^DIR "RTN","RAPROD",109,0) Q:'Y "RTN","RAPROD",110,0) D STUF150 "RTN","RAPROD",111,0) Q "RTN","RAPROD",112,0) DEL150 ;Delete user ien from 1st record in file 79's field 150 "RTN","RAPROD",113,0) ; note: DIK utility looks for DA(1) here "RTN","RAPROD",114,0) Q:'$D(DUZ)#2 "RTN","RAPROD",115,0) S DA(1)=$O(^RA(79,0)) Q:'DA(1) "RTN","RAPROD",116,0) S DIK="^RA(79,"_DA(1)_",""LDIS""," "RTN","RAPROD",117,0) S DA=$O(^RA(79,DA(1),"LDIS","B",DUZ,0)) "RTN","RAPROD",118,0) Q:'DA "RTN","RAPROD",119,0) D ^DIK "RTN","RAPROD",120,0) K DIK,DA "RTN","RAPROD",121,0) W !!,"Your preference for Long Display of Procedures has been removed.",! "RTN","RAPROD",122,0) Q "RTN","RAPROD",123,0) STUF150 ;Stuff user ien into 1st record in file 79's field 150 "RTN","RAPROD",124,0) Q:'$D(DUZ)#2 "RTN","RAPROD",125,0) S RA1=$O(^RA(79,0)) Q:'RA1 "RTN","RAPROD",126,0) K RAFDA,RAIEN,RAMSG "RTN","RAPROD",127,0) S RAFDA(79.03,"?+2,"_RA1_",",.01)=DUZ "RTN","RAPROD",128,0) D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") "RTN","RAPROD",129,0) W !!,"Your preference for Long Display of Procedures has been set.",! "RTN","RAPROD",130,0) Q "RTN","RAPROD",131,0) CDIS ; set up RACDIS array to store 1st non-duplicate proc+pmod+cptmod "RTN","RAPROD",132,0) N N1,N2,R1,RA71,Y "RTN","RAPROD",133,0) K RACDIS "RTN","RAPROD",134,0) D LDIS "RTN","RAPROD",135,0) S N1=0 "RTN","RAPROD",136,0) F S N1=$O(^RADPT(RADFN,"DT",RADTI,"P",N1)) Q:'N1 S R1=$G(^(N1,0)) D:R1]"" "RTN","RAPROD",137,0) . S RA71=$P(R1,U,2),RACNI=N1 "RTN","RAPROD",138,0) . D MODS^RAUTL2 "RTN","RAPROD",139,0) . S RACDIS("B",RA71,Y,Y(1),N1)="" "RTN","RAPROD",140,0) . S N2=$O(RACDIS("B",RA71,Y,Y(1),0)) "RTN","RAPROD",141,0) . S RACDIS(N2)=$G(RACDIS(N2))+1 ;increment lowest ien of same proc+pmod+cptmod "RTN","RAPROD",142,0) . S:RACDIS(N2)>1 RACDIS("RAFLDUP")=1 ;>1 same proc+pmod+cptmod "RTN","RAPROD",143,0) . Q "RTN","RAPROD",144,0) Q "RTN","RAPROD",145,0) LDIS ; See if user prefers Long Display of Procedures "RTN","RAPROD",146,0) N RA1 "RTN","RAPROD",147,0) S RA1=$O(^RA(79,0)) Q:'RA1 "RTN","RAPROD",148,0) S:$O(^RA(79,RA1,"LDIS","B",DUZ,0)) RALDIS=1 "RTN","RAPROD",149,0) Q "RTN","RAPROD",150,0) LIST ; "RTN","RAPROD",151,0) ;;RA("DIV");^DIC(4,;RADI;3 "RTN","RAPROD",152,0) ;;RA("LOC");^RA(79.1,;RADI;4 "RTN","RAPROD",153,0) ;;RA("WRD");^DIC(42,;Y(0);6 "RTN","RAPROD",154,0) ;;RA("SERV");^DIC(49,;Y(0);7 "RTN","RAPROD",155,0) ;;RA("CL");^SC(;Y(0);8 "RTN","RAPROD",156,0) ;;RA("CONT");^DIC(34,;Y(0);9 "RTN","RAPROD",157,0) ;;RA("RES");^VA(200,;Y(0);12 "RTN","RAPROD",158,0) ;;RA("DIA");^RA(78.3,;Y(0);13 "RTN","RAPROD",159,0) ;;RA("PHY");^VA(200,;Y(0);14 "RTN","RAPROD",160,0) ;;RA("STAFF");^VA(200,;Y(0);15 "RTN","RAPROD",161,0) ;;RA("CMP");^RA(78.1,;Y(0);16 "RTN","RAPROD",162,0) ;;RA("RM");^RA(78.6,;Y(0);18 "RTN","RAPROD",163,0) ;;RA("BED");^DIC(42.4,;Y(0);19 "RTN","RAREG2") 0^7^B68906151 "RTN","RAREG2",1,0) RAREG2 ;HISC/CAH,FPT,DAD,SS AISC/MJK,RMO-Register Patient ; 06 Oct 2013 11:04 AM "RTN","RAREG2",2,0) ;;5.0;Radiology/Nuclear Medicine;**13,18,93,99,1003,1005**;Nov 01, 2010;Build 13 "RTN","RAREG2",3,0) ;last modif. JULY 5,00 by SS "RTN","RAREG2",4,0) ; 07/15/2008 BAY/KAM rem call 249750 RA*5*93 Correct DIK Calls "RTN","RAREG2",5,0) ; 06/04/09 rvd - display pregnancy screen and pregnancy screen comment only in Add Exams to Last visit option. "RTN","RAREG2",6,0) ; Supported IA #2053 reference to ^DIE "RTN","RAREG2",7,0) ; Supported IA #10013 reference to ^DIK "RTN","RAREG2",8,0) ORDER ; Get data from ordered procedure for registration "RTN","RAREG2",9,0) K RACLNC,RALIFN,RALOC,RAPIFN,RAPRC,RARDTE,RARSH,RASHA "RTN","RAREG2",10,0) S Y=^RAO(75.1,+RAOIFN,0),RAPRC=$S($D(^RAMIS(71,+$P(Y,"^",2),0)):$P(^(0),"^"),1:"") S:$D(RADPARFL) RAPRC=RADPARPR ;may not need to redefine raprc ? "RTN","RAREG2",11,0) S RACAT=$S('$D(RAWARD):$P($P(^DD(75.1,4,0),$P(Y,"^",4)_":",2),";"),1:RACAT) "RTN","RAREG2",12,0) D SL^RAREG3 Q:RAQUIT "RTN","RAREG2",13,0) S:"CS"[$E(RACAT)&($D(^DIC(34,+$P(Y,"^",9),0))) RASHA=$P(^(0),"^") S:"R"[$E(RACAT)&($D(^RAO(75.1,+RAOIFN,"R"))) RARSH=^("R") "RTN","RAREG2",14,0) S:$D(^VA(200,+$P(Y,"^",14),0)) RAPIFN=+$P(Y,"^",14) S:$P(Y,"^",21) RARDTE=$P(Y,"^",21) S:$D(^SC(+$P(Y,"^",22),0)) RALIFN=+$P(Y,"^",22) "RTN","RAREG2",15,0) I '$D(RAWARD),$D(RALIFN),$P(^SC(RALIFN,0),"^",3)="C" S RALOC=$P(^(0),"^") S RACLNC=$S('$D(^("SL")):RALOC,$D(^SC(+$P(^("SL"),"^",5),0)):$P(^(0),"^"),1:RALOC) "RTN","RAREG2",16,0) ;check nodes ahead 6/18/96 "RTN","RAREG2",17,0) N RAAHEAD "RTN","RAREG2",18,0) S RAAHEAD=$O(^RADPT(RADFN,"DT","B",RADTE)) "RTN","RAREG2",19,0) I RAAHEAD[RADTE W $C(7),!!?5,"Someone else has already started editing a record for this",!?5,"patient at this time, please try a few minutes later." S RAQUIT=1 R !!,"Press RETURN to continue :",RAAHEAD:DTIME "RTN","RAREG2",20,0) Q "RTN","RAREG2",21,0) EXAMLOOP ; register the exam "RTN","RAREG2",22,0) N REM ;this is used by the edit template "RTN","RAREG2",23,0) ;P99; keep previous pregnancy screen data before adding new exam "RTN","RAREG2",24,0) ; "RTN","RAREG2",25,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAREG2",26,0) ;I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)="F" S RA703DAT=$$PRCEXA^RAUTL8(RADFN) ;ra703dat holds the previous entry "RTN","RAREG2",27,0) I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)'="M" S RA703DAT=$$PRCEXA^RAUTL8(RADFN) ;ra703dat holds the previous entry "RTN","RAREG2",28,0) ; "RTN","RAREG2",29,0) S DA=RADFN,RACN="N",DIE("NO^")="OUTOK",DR="[RA REGISTER]",DIE="^RADPT(" D ^DIE K DIE("NO^"),DE,DQ "RTN","RAREG2",30,0) ; "RTN","RAREG2",31,0) ;IHS/BJI/DAY - Patch 1005 - Default Pregnancy Status to Unknown "RTN","RAREG2",32,0) ;Controlled by site parameter "RTN","RAREG2",33,0) I +$G(RAMDIV),$P($G(^RA(79,+RAMDIV,9999999)),"^",2)=1 D "RTN","RAREG2",34,0) .I $G(RADFN)="" Q "RTN","RAREG2",35,0) .I $G(RADTI)="" Q "RTN","RAREG2",36,0) .I $G(RACNI)="" Q "RTN","RAREG2",37,0) .I $$PTSEX^RAUTL8(RADFN)="M" Q "RTN","RAREG2",38,0) .I $$PTAGE^RAUTL8(RADFN,"")>55 Q "RTN","RAREG2",39,0) .I $$PTAGE^RAUTL8(RADFN,"")<12 Q "RTN","RAREG2",40,0) .I '$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q "RTN","RAREG2",41,0) .I $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,32)]"" Q "RTN","RAREG2",42,0) .S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,32)="u" "RTN","RAREG2",43,0) ;End Patch "RTN","RAREG2",44,0) ; "RTN","RAREG2",45,0) K RAPOP,RAFM,RAFM1,RAI,RAMOD,RASTI,RACMTHOD,RANMFLG,RAIEN702 ;moved from edit template "RTN","RAREG2",46,0) S RACNICNT=RACNICNT+1 "RTN","RAREG2",47,0) S ^TMP($J,"RAREG1",RACNICNT)=RADFN_U_RADTI_U_RACNI_U_RAOIFN "RTN","RAREG2",48,0) I '$D(RAFIN) D Q "RTN","RAREG2",49,0) . W !?3,$C(7),"Exam entry not complete. Must delete..." "RTN","RAREG2",50,0) . S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI "RTN","RAREG2",51,0) . ; Modified the next line for rem call 249750 "RTN","RAREG2",52,0) . S DIK="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," D ^DIK "RTN","RAREG2",53,0) . K ^TMP($J,"RAREG1",RACNICNT) "RTN","RAREG2",54,0) . K RAPX ; added in RA*5*13 to stop labels & flash cards in RAREG1 "RTN","RAREG2",55,0) . Q "RTN","RAREG2",56,0) ;start of p99, display and SET pregnancy screen and pregnancy screen comment "RTN","RAREG2",57,0) ;value defaulted from previous case exam (regardless of case exam status) "RTN","RAREG2",58,0) ; "RTN","RAREG2",59,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAREG2",60,0) ;I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)="F" D "RTN","RAREG2",61,0) I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)'="M" D "RTN","RAREG2",62,0) .; "RTN","RAREG2",63,0) .Q:'$D(RA703DAT) "RTN","RAREG2",64,0) .N RA3,RADTIEN,RACNIEN,RAPCOMM "RTN","RAREG2",65,0) .S RADTIEN=$P(RA703DAT,U),RACNIEN=$P(RA703DAT,U,2) "RTN","RAREG2",66,0) .S RA3=$G(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,0)) "RTN","RAREG2",67,0) .S RAPCOMM=$G(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,"PCOMM")) "RTN","RAREG2",68,0) .W:$P(RA3,U,32)'="" !," PREGNANCY SCREEN: ",$S($P(RA3,U,32)="y":"Patient answered yes",$P(RA3,U,32)="n":"Patient answered no",$P(RA3,U,32)="u":"Patient is unable to answer or is unsure",1:"") "RTN","RAREG2",69,0) .W:$P(RA3,U,32)'="n"&$L(RAPCOMM) !," PREGNANCY SCREEN COMMENT: ",RAPCOMM "RTN","RAREG2",70,0) .N RAPTAGE S RAPTAGE=$$PTAGE^RAUTL8(RADFN,"") "RTN","RAREG2",71,0) .Q:RAPTAGE<12!(RAPTAGE>55) "RTN","RAREG2",72,0) .I $P(RA3,U,32)'="" D "RTN","RAREG2",73,0) ..N RAFDA "RTN","RAREG2",74,0) ..S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",32)=$P(RA3,U,32) "RTN","RAREG2",75,0) ..D FILE^DIE("","RAFDA") "RTN","RAREG2",76,0) .I $D(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,"PCOMM")) D "RTN","RAREG2",77,0) ..N RAFDA "RTN","RAREG2",78,0) ..S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",80)=^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,"PCOMM") "RTN","RAREG2",79,0) ..D FILE^DIE("","RAFDA") "RTN","RAREG2",80,0) ;end of p99 "RTN","RAREG2",81,0) S RAPARENT=$S($G(RAPARENT):RAPARENT,$P($G(^RAMIS(71,RAPROC,0)),U,6)="P":1,1:+$G(RAPARENT)) "RTN","RAREG2",82,0) I $D(^RAO(75.1,+RAOIFN,"H")) S:$D(^("H",0)) ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)=^(0) F I=1:1 Q:'$D(^RAO(75.1,+RAOIFN,"H",I,0)) S ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",I,0)=^(0) "RTN","RAREG2",83,0) ;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler 2005 Patch "RTN","RAREG2",84,0) ;Add set of Exam Date for PCC "RTN","RAREG2",85,0) S ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC")=$P(RADTE,".") "RTN","RAREG2",86,0) ;End Patch "RTN","RAREG2",87,0) S ^DISV($S($D(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI,RAREC="" "RTN","RAREG2",88,0) S:$D(RADPARFL) ^TMP($J,"PRO-REG",RAPROCI,RAOIFN)="" "RTN","RAREG2",89,0) K RAFIN,DR,RA703DAT "RTN","RAREG2",90,0) K RACLNC,RALIFN,RALOC,RAOSTS,RAPHY,RAPRC,RARDTE,RARSH,RASHA "RTN","RAREG2",91,0) Q "RTN","RAREG2",92,0) EXAMDEL ; Delete examset if incomplete "RTN","RAREG2",93,0) W !!?3,$C(7),"Exam entry not complete. Must delete all descendent exams..." "RTN","RAREG2",94,0) S RATMP=0 "RTN","RAREG2",95,0) F S RATMP=$O(^TMP($J,"RAREG1",RATMP)) Q:RATMP'>0 D "RTN","RAREG2",96,0) . S RA=^TMP($J,"RAREG1",RATMP) "RTN","RAREG2",97,0) . S RAOIFN=$P(RA,U,4),(RADFN,DA(2))=$P(RA,U) "RTN","RAREG2",98,0) . S (RADTI,DA(1))=$P(RA,U,2),(RACNI,DA)=$P(RA,U,3) "RTN","RAREG2",99,0) . ; Modified the next line for rem call 249750 "RTN","RAREG2",100,0) . S DIK="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," D ^DIK "RTN","RAREG2",101,0) . K ^TMP($J,"RAREG1",RATMP),RAPX(RATMP) "RTN","RAREG2",102,0) . K DIE,DR S DIE="^RAO(75.1,",DA=RAOIFN,DR="5///5" D ^DIE K DIE,DR "RTN","RAREG2",103,0) . Q "RTN","RAREG2",104,0) W !?3,"Deletion complete!",! "RTN","RAREG2",105,0) Q "RTN","RAREG2",106,0) XTRADESC ; Ask extra descendent procedures for a parent "RTN","RAREG2",107,0) N RASKIPIT S RASKIPIT=0 "RTN","RAREG2",108,0) F D Q:RASKIPIT!RAEXIT!RAQUIT "RTN","RAREG2",109,0) . N DIR S DIR(0)="Y" "RTN","RAREG2",110,0) . S DIR("A")="Register another descendent exam for "_RANME_" (Y/N)" "RTN","RAREG2",111,0) . W ! D ^DIR "RTN","RAREG2",112,0) . S RAEXIT=$S($D(DTOUT)!$D(DUOUT):1,1:0),RASKIPIT='Y "RTN","RAREG2",113,0) . I RASKIPIT!RAEXIT Q "RTN","RAREG2",114,0) . D ORDER K RAPRC Q:RAQUIT "RTN","RAREG2",115,0) . D EXAMLOOP,MEMSET(RADFN,RADTI,RACNI) "RTN","RAREG2",116,0) . Q "RTN","RAREG2",117,0) Q "RTN","RAREG2",118,0) EXAMSET ; Set the EXAM SET field if a parent is registered "RTN","RAREG2",119,0) N DA,DIE,DR,Y "RTN","RAREG2",120,0) S DIE="^RADPT("_RADFN_",""DT""," "RTN","RAREG2",121,0) S DA(1)=RADFN,DA=RADTI "RTN","RAREG2",122,0) S DR="5///^S X=$S($G(RAPARENT):''RAPARENT,1:""@"")" "RTN","RAREG2",123,0) D ^DIE "RTN","RAREG2",124,0) Q "RTN","RAREG2",125,0) MEMSET(RAX,RAY,RAZ) ; Set 'MEMBER OF SET' field on the exam node "RTN","RAREG2",126,0) ; if the procedure is a descendant procedure. "RTN","RAREG2",127,0) ; Var List: RAX <-> RADFN : RAY <-> RADTI : RAZ <-> RACNI "RTN","RAREG2",128,0) Q:$G(^RADPT(RAX,"DT",RAY,"P",RAZ,0))']"" "RTN","RAREG2",129,0) N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y "RTN","RAREG2",130,0) S DIE="^RADPT("_RAX_",""DT"","_RAY_",""P""," "RTN","RAREG2",131,0) S DA(2)=RAX,DA(1)=RAY,DA=RAZ,DR="25///"_$S($P($G(^RAMIS(71,+RAPROC,0)),"^",18)="Y":2,1:1) D ^DIE ;2=combined report, 1=separate reports "RTN","RAREG2",132,0) Q "RTN","RAREG2",133,0) SET17(RAX,RAY,RAZ) ; Set piece 17 on exam node "RTN","RAREG2",134,0) Q:$G(^RADPT(RAX,"DT",RAY,"P",RAZ,0))']"" "RTN","RAREG2",135,0) N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y "RTN","RAREG2",136,0) S DIE="^RADPT("_RAX_",""DT"","_RAY_",""P""," "RTN","RAREG2",137,0) S DA(2)=RAX,DA(1)=RAY,DA=RAZ,DR="17///"_RA17 D ^DIE "RTN","RAREG2",138,0) Q "RTN","RAREG2",139,0) UOSM ; called from RAREG1 "RTN","RAREG2",140,0) ; update order status and send OE v3.0 message "RTN","RAREG2",141,0) ; This code will $O through the ^TMP($J,"RAREG1" global and make "RTN","RAREG2",142,0) ; just one call per order/request number to ^RAORDU to update the "RTN","RAREG2",143,0) ; status in File 75.1. One call to ^RAORDU per order/request number "RTN","RAREG2",144,0) ; means only one HL7 type message per order/request will be sent to "RTN","RAREG2",145,0) ; OE v3.0. "RTN","RAREG2",146,0) ; "RTN","RAREG2",147,0) Q:'$D(^TMP($J,"RAREG1")) "RTN","RAREG2",148,0) N RACNT,RAORDNUM,RATMPNDE "RTN","RAREG2",149,0) S RACNT=0 "RTN","RAREG2",150,0) F S RACNT=$O(^TMP($J,"RAREG1",RACNT)) Q:RACNT'>0 D "RTN","RAREG2",151,0) .S RATMPNDE=$G(^TMP($J,"RAREG1",RACNT)) "RTN","RAREG2",152,0) .S RAOIFN=$P(RATMPNDE,U,4) I RAOIFN D "RTN","RAREG2",153,0) ..Q:$D(RAORDNUM(RAOIFN)) "RTN","RAREG2",154,0) ..S RAPROC=$P(^RAO(75.1,+RAOIFN,0),U,2) "RTN","RAREG2",155,0) ..N RA18PCHG S RA18PCHG=$$EN1^RAO7XX(RAOIFN) ;P18 - if the proc changed, sends XX mess, sets RA18PCHG=1 for RAORDU "RTN","RAREG2",156,0) ..S RAOSTS=6 D ^RAORDU "RTN","RAREG2",157,0) ..S RAORDNUM(RAOIFN)="" "RTN","RAREG2",158,0) ..Q "RTN","RAREG2",159,0) .Q "RTN","RAREG2",160,0) Q "RTN","RAREG2",161,0) CKDUPORD ; ck for dupl procedures in outstanding orders "RTN","RAREG2",162,0) S RA6="",RA8=0 "RTN","RAREG2",163,0) CKD1 S RA6=$O(^TMP($J,"PRO-REG",RA6)) Q:'RA6 "RTN","RAREG2",164,0) S RA7=$O(^TMP($J,"PRO-REG",RA6,0)) G:'RA7 CKD1 "RTN","RAREG2",165,0) K ^TMP($J,"PRO-ORD",RA6,RA7) ; kill hook for order of regist'd proc "RTN","RAREG2",166,0) G:'$O(^TMP($J,"PRO-ORD",RA6,0)) CKD1 "RTN","RAREG2",167,0) W:'RA8 !!?5,"Of the procedures you just registered,",!?5,"the following procedure(s) are still in outstanding order(s) :",$C(7),! "RTN","RAREG2",168,0) S RA8=1 "RTN","RAREG2",169,0) S RA7="" "RTN","RAREG2",170,0) F S RA7=$O(^TMP($J,"PRO-ORD",RA6,RA7)) Q:'RA7 W !?5,$P(^RAMIS(71,RA6,0),U) W:^TMP($J,"PRO-ORD",RA6,RA7)="DESC" ?35,"(parent=",$P(^RAMIS(71,$P($G(^RAO(75.1,RA7,0)),U,2),0),U),")" "RTN","RAREG2",171,0) G CKD1 "RTN","RAREG2",172,0) COPYFROM(RAZ) ;called by RAREG1 if add exam shd copy dx/staff/resident "RTN","RAREG2",173,0) ;RAZ is "P"-node's ien of newly added case of set "RTN","RAREG2",174,0) Q:'$D(RAFIRST)#2 ;RAFIRST is "P"-node's ien of first case of set "RTN","RAREG2",175,0) Q:$G(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0))']"" "RTN","RAREG2",176,0) Q:$G(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0))']"" "RTN","RAREG2",177,0) N RA,RA2,RA3,RA5 S RA5=0 "RTN","RAREG2",178,0) ; RA is a dummy var "RTN","RAREG2",179,0) ; RA2 is used by data server call in RARTE2 "RTN","RAREG2",180,0) ; RA3 is used by COPYn^RARTE2 as a dummy var "RTN","RAREG2",181,0) ; RA5=1 if any data got copied over to the new case "RTN","RAREG2",182,0) N RA1PR,RA1PS ; prim res/staff "RTN","RAREG2",183,0) N RA1SR,RA1SS ; sec res/staff arrays "RTN","RAREG2",184,0) N RA1PD,RA1SD ; prim diag, then sec diags arrays "RTN","RAREG2",185,0) N RAFDA,RAIEN,RAMSG,RAXIT "RTN","RAREG2",186,0) S RAXIT=0 "RTN","RAREG2",187,0) S RA2=RAZ_","_RADTI_","_RADFN "RTN","RAREG2",188,0) ; get data from first case of set "RTN","RAREG2",189,0) S RA1PR=$P(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0),U,12),RA1PS=$P(^(0),U,15),RA1PD=$P(^(0),U,13) "RTN","RAREG2",190,0) I $D(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SRR",0)) S RA=0 F S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SRR",RA)) Q:+RA'=RA S RA1SR(RA)=+(^(RA,0)) "RTN","RAREG2",191,0) I $D(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SSR",0)) S RA=0 F S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SSR",RA)) Q:+RA'=RA S RA1SS(RA)=+(^(RA,0)) "RTN","RAREG2",192,0) I $D(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"DX",0)) S RA=0 F S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"DX",RA)) Q:+RA'=RA S RA1SD(RA)=+(^(RA,0)) "RTN","RAREG2",193,0) ; copy data from first case of set to new case "RTN","RAREG2",194,0) S:RA1PR $P(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,12)=RA1PR,RA5=1 "RTN","RAREG2",195,0) S:RA1PS $P(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,15)=RA1PS,RA5=1 "RTN","RAREG2",196,0) S:RA1PD $P(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,13)=RA1PD,RA5=1 "RTN","RAREG2",197,0) I $O(RA1SR("")) S RA3="" D COPY3^RARTE2 S RA5=1 "RTN","RAREG2",198,0) I $O(RA1SS("")) S RA3="" D COPY4^RARTE2 S RA5=1 "RTN","RAREG2",199,0) I $O(RA1SD("")) S RA3="" D COPY5^RARTE2 S RA5=1 "RTN","RAREG2",200,0) Q:'RA5 "RTN","RAREG2",201,0) ; set xref for this new case only "RTN","RAREG2",202,0) S DIK="^RADPT("_RADFN_",""DT"","_RADTI_",""P""," "RTN","RAREG2",203,0) S DA(2)=RADFN,DA(1)=RADTI,DA=RAZ "RTN","RAREG2",204,0) D IX1^DIK "RTN","RAREG2",205,0) Q "RTN","RART1") 0^8^B64654453 "RTN","RART1",1,0) RART1 ;HISC/GJC,SWM-Reporting Menu (Part 2) ; 06 Oct 2013 11:05 AM "RTN","RART1",2,0) ;;5.0;Radiology/Nuclear Medicine;**8,16,15,21,23,27,34,99,47,1005**;Mar 16, 1998;Build 13 "RTN","RART1",3,0) ;Print Report By Patient has been moved to 4^RART2! "RTN","RART1",4,0) ;these sections are moved to ^RART3 : QRPT, PHYS, MODSET, OUT1 "RTN","RART1",5,0) ;RVD P99, add pregnancy screen and commment if populated for female pt. "RTN","RART1",6,0) CHK I 'RARPT!('$D(^RARPT(+RARPT,0))) W !?3,$C(7),"No report filed for case number ",RACN,"." K RARPT Q "RTN","RART1",7,0) I $D(RADFT),$P(^RARPT(+RARPT,0),"^",5)'["D" W !?3,$C(7),"Report for case number ",RACN," is not in a 'draft' status." K RARPT Q "RTN","RART1",8,0) I '$D(RADFT),$P(^RARPT(+RARPT,0),"^",5)["D" W !?3,$C(7),"Report filed for case number ",RACN," but not available for printing." K RARPT Q "RTN","RART1",9,0) Q "RTN","RART1",10,0) ; "RTN","RART1",11,0) 5 ;;Draft Report (Reprint) "RTN","RART1",12,0) D SETVARS Q:'($D(RACCESS(DUZ))\10)!('$D(RAIMGTY)) S RADFT="" G 4^RART2 "RTN","RART1",13,0) ; "RTN","RART1",14,0) 6 ;;Display a Report By Patient "RTN","RART1",15,0) W ! S DIC(0)="AEMQ" D ^RADPA G Q6:Y<0 S RADFN=+Y,RAHEAD="**** Patient's Exams ****",RAF1=1,RAREPORT=1 D ^RAPTLU G Q6:X="^" G 6:'$D(RADUP) "RTN","RART1",16,0) I X=1 R X:3 "RTN","RART1",17,0) OERR ;entry from RA OERR PROFILE protocol "RTN","RART1",18,0) F RAI=0:0 S RAI=$O(RADUP(RAI)) Q:RAI'>0 S Y=^TMP($J,"RAEX",RAI) D 61,DISP Q:X="^" "RTN","RART1",19,0) K RADUP,RAI,RAJ,X,^TMP($J,"RAEX") Q:$D(ORVP) G 6 "RTN","RART1",20,0) 61 F RAJ=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",RAJ)=$P(Y,"^",RAJ) "RTN","RART1",21,0) S Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) Q "RTN","RART1",22,0) ; "RTN","RART1",23,0) OERR1 ;Entry Point for Alert Follow-Up Action for OE/RR "RTN","RART1",24,0) Q:'$D(XQADATA)!('$D(XQAID)) S (RARPT,Y)=XQADATA D RASET^RAUTL2 "RTN","RART1",25,0) S:Y Y(0)=Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"Unknown"),RAPRC=$S($D(^RAMIS(71,+$P(Y(0),"^",2),0)):$P(^(0),"^"),1:"Unknown") "RTN","RART1",26,0) S RALERTS="" D DISP K:X="^" XQAID,XQAKILL "RTN","RART1",27,0) I $D(XQAID) S DFN=$P(XQAID,",",2) D DELETE^XQALERT "RTN","RART1",28,0) K RALERTS "RTN","RART1",29,0) Q "RTN","RART1",30,0) ; "RTN","RART1",31,0) DISP I RARPT,($D(RAPBRPT)),($P($G(^RARPT(+RARPT,0)),"^",5)="V") D Q "RTN","RART1",32,0) . ; This code will not allow a user to re-edit a verified report. "RTN","RART1",33,0) . ; In this case, two or more possible users signed on to the same "RTN","RART1",34,0) . ; Imaging location, asked to verify the reports of the same "RTN","RART1",35,0) . ; Interpreting Radiology/Nuclear Medicine Physician. "RTN","RART1",36,0) . ; For the 'On-line Verifying of Reports' option only! "RTN","RART1",37,0) . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y "RTN","RART1",38,0) . ; removed X from N so rtn RARTVER would quit if caret entered "RTN","RART1",39,0) . W !!?10,"Since the time you selected this group of reports,",!?10,$P($G(^VA(200,+$P(^RARPT(+RARPT,0),"^",9),0)),U)," has verified the report for " "RTN","RART1",40,0) . W !?10,$P($G(^DPT(+$P(^RARPT(+RARPT,0),"^",2),0)),U)," case #",$P(^RARPT(+RARPT,0),"^"),".",$C(7) "RTN","RART1",41,0) . S Y=$S($D(^TMP($J,"RA","DT",+$G(RARTDT),+$G(RARPT))):$P($P(^(RARPT),"/",2),U,3),$D(RARPTX(+$G(RPTX))):$P($P(RARPTX(+$G(RPTX)),"/",2),U,3),1:"") "RTN","RART1",42,0) . I $D(^RAMIS(71,+Y,0)) W !?10,"Procedure ",$P(^(0),U) "RTN","RART1",43,0) . W ! K DIR S DIR(0)="E" D ^DIR S RAVFIED=1 "RTN","RART1",44,0) . Q "RTN","RART1",45,0) D HOME^%ZIS S OREND=1 "RTN","RART1",46,0) I 'RARPT!('$D(^RARPT(+RARPT,0))) D G Q6 "RTN","RART1",47,0) . W !?3,$C(7),"No report filed for case number",$S($D(RACN):" "_RACN,1:""),"." "RTN","RART1",48,0) . R X:3 ; D:$$IMAGE^RARIC1 DISPF^MAGRIC ;don't call MAG 111300 "RTN","RART1",49,0) . Q "RTN","RART1",50,0) S RAST=$P(^RARPT(+RARPT,0),"^",5) "RTN","RART1",51,0) I '$D(RARTVER),(RAST=""!(RAST["D")) D G Q6 "RTN","RART1",52,0) . W !?3,$C(7),"Report filed for case number ",RACN," but not available for display." "RTN","RART1",53,0) . R X:3 ; D:$$IMAGE^RARIC1 DISPF^MAGRIC ;don't call MAG 111300 "RTN","RART1",54,0) . Q "RTN","RART1",55,0) DISP1 I $S('$D(ORACTION):1,ORACTION'=8:1,'$D(X):0,X="T":1,1:0) W @IOF "RTN","RART1",56,0) W !,RANME," (",$$SSN^RAUTL,")",?39,"Case No. ",?55,": ",$P($G(^RARPT(RARPT,0)),"^")," @",$E(RADATE,$L(RADATE)-4,$L(RADATE)) "RTN","RART1",57,0) W !,$E(RAPRC,1,40) I +$G(^RARPT(RARPT,"T")) W ?39,"Transcriptionist",?55,": ",$E($P($G(^VA(200,+^RARPT(RARPT,"T"),0)),"^"),1,20) "RTN","RART1",58,0) N R3 S R3=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",+$G(RACNI),0)) "RTN","RART1",59,0) W !,"Req. Phys : ",$E($P($G(^VA(200,+$P(R3,"^",14),0)),"^"),1,25) "RTN","RART1",60,0) S RAPREVER=+$P($G(^RARPT(RARPT,0)),"^",13) W ?39,"Pre-verified",?55,": ",$S($D(^VA(200,RAPREVER,0)):$E($P($G(^VA(200,RAPREVER,0)),"^"),1,24),1:"NO") K RAPREVER "RTN","RART1",61,0) D PHYS^RART3 "RTN","RART1",62,0) ;Display Pregnancy Screen and Comments if respective field is filled and pt is female, patch #99 "RTN","RART1",63,0) ; "RTN","RART1",64,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RART1",65,0) ;I $$PTSEX^RAUTL8(RADFN)="F" D "RTN","RART1",66,0) I $$PTSEX^RAUTL8(RADFN)'="M" D "RTN","RART1",67,0) .; "RTN","RART1",68,0) .W:$P(R3,U,32)'="" !,"Pregnancy Screen: ",$S($P(R3,"^",32)="y":"Patient answered yes",$P(R3,"^",32)="n":"Patient answered no",$P(R3,"^",32)="u":"Patient is unable to answer or is unsure",1:"") "RTN","RART1",69,0) .N RAPCOMM S RAPCOMM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCOMM")) "RTN","RART1",70,0) .W:$P(R3,U,32)'=""&$L(RAPCOMM) !,"Pregnancy Screen Comment: ",RAPCOMM "RTN","RART1",71,0) I $D(RAPBRPT),(RAST="PD") D "RTN","RART1",72,0) . W !,"**Prob Text: " "RTN","RART1",73,0) . I $G(^RARPT(+RARPT,"P"))]"" D "RTN","RART1",74,0) .. S X=$G(^RARPT(+RARPT,"P")) "RTN","RART1",75,0) .. D OUTTEXT^RAUTL9(X,"",10,70,13,"","!") "RTN","RART1",76,0) .. Q "RTN","RART1",77,0) . Q "RTN","RART1",78,0) W !,$$REPEAT^XLFSTR("=",79) "RTN","RART1",79,0) I $O(^RARPT(RARPT,1,0)) D MODSET^RART3 "RTN","RART1",80,0) I '$O(^RARPT(RARPT,1,0)) D "RTN","RART1",81,0) . D MODS^RAUTL2,OUT1^RART3 "RTN","RART1",82,0) . I +$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",28) S X=$$RDIO1^RARTUTL1(+$P(^(0),"^",28)) "RTN","RART1",83,0) . Q:$L($G(X)) ; 'X' should be 'null' to continue "RTN","RART1",84,0) . S:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) X=$$PHARM1^RARTUTL(RACNI_","_RADTI_","_RADFN_",") "RTN","RART1",85,0) . Q "RTN","RART1",86,0) Q:$G(X)="P" G DISP1:$G(X)="T",Q6:$G(X)="^" "RTN","RART1",87,0) I +$O(^RARPT(RARPT,"ERR",0)) W !?10,$$AMENRPT^RARTR2(),! "RTN","RART1",88,0) ; "RTN","RART1",89,0) ; Print the clinical history from file 70 "RTN","RART1",90,0) I +$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) D "RTN","RART1",91,0) . K ^UTILITY($J,"W"),^(1) S X="",DIWL=3,DIWF="|WC75" "RTN","RART1",92,0) . W !?3,"Clinical History:" "RTN","RART1",93,0) . S RAP="H" D WRITEHX(RAP) "RTN","RART1",94,0) . Q "RTN","RART1",95,0) Q:$G(X)="P" G DISP1:$G(X)="T",Q6:$G(X)="^" "RTN","RART1",96,0) ; "RTN","RART1",97,0) ; Print the additional report clinical history if defined and "RTN","RART1",98,0) ; different than the order clinical history. "RTN","RART1",99,0) I +$O(^RARPT(RARPT,"H",0)) D "RTN","RART1",100,0) . D CHKDUPHX Q:RADUPHX ; Duplicate history "RTN","RART1",101,0) . K ^UTILITY($J,"W"),^(1) S X="",DIWL=3,DIWF="|WC75" "RTN","RART1",102,0) . W !?3,"Additional Clinical History:" "RTN","RART1",103,0) . S RAP="AH" D WRITEHX(RAP) "RTN","RART1",104,0) ; "RTN","RART1",105,0) ; Print Report and Impression text "RTN","RART1",106,0) F RAP="R","I" D Q:X="^"!(X="P")!(X="T") "RTN","RART1",107,0) . K ^UTILITY($J,"W"),^(1) S X="",DIWL=3,DIWF="|WC75" "RTN","RART1",108,0) . W !?3,$S(RAP="R":"Report:",1:"Impression:") W:RAP="R" ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),U,2)) "RTN","RART1",109,0) . W:RAP="R"&($E(RAST)="P") $C(7) "RTN","RART1",110,0) . D WRITE "RTN","RART1",111,0) . Q "RTN","RART1",112,0) Q:X="P" G DISP1:X="T",Q6:X="^" "RTN","RART1",113,0) ; I $$IMAGE^RARIC1() D DISPF^MAGRIC ;don't call MAG 111300 "RTN","RART1",114,0) I $P($G(^RA(79.1,+$P(^RADPT(RADFN,"DT",RADTI,0),U,4),0)),U,18)="Y" D PRTDX^RART K RADXCODE "RTN","RART1",115,0) Q:X="P" G DISP1:X="T",Q6:X="^" "RTN","RART1",116,0) ; "RTN","RART1",117,0) I $D(ORVP) D "RTN","RART1",118,0) .S RAVERF=+$P($G(^RARPT(+RARPT,0)),"^",9) "RTN","RART1",119,0) .S RADFTSBN=$E($P($G(^VA(200,RAVERF,20)),"^",2),1,25) "RTN","RART1",120,0) .S:RADFTSBN']"" RADFTSBN=$E($P($G(^VA(200,RAVERF,0)),"^"),1,25) "RTN","RART1",121,0) .S RADFTSBT=$E($P($G(^VA(200,RAVERF,20)),"^",3),1,30) "RTN","RART1",122,0) .S:RADFTSBT']"" RADFTSBT=$$TITLE^RARTR0(RAVERF) "RTN","RART1",123,0) .W !!,"VERIFIED BY:",!?2,$S(RADFTSBN]"":RADFTSBN,1:"") "RTN","RART1",124,0) .W:RADFTSBT]"" ", "_RADFTSBT "RTN","RART1",125,0) Q:X="P" G DISP1:X="T",Q6:X="^" "RTN","RART1",126,0) ; "RTN","RART1",127,0) K RAP I '$D(RARTVER) D WAIT Q:X="P" G DISP1:X="T" "RTN","RART1",128,0) Q6 K %,DIC,DIWF,DIWL,DIWR,I,J,OREND,POP,RABTCH,RAF1,RAHEAD,RALOC,RANME,RAPAR,RAPRC,RAREPORT,RASEL,RASSN,RAST,RAV,RAXX,Y,X1,Z "RTN","RART1",129,0) K RAVERF,RADFTSBN,RADFTSBT "RTN","RART1",130,0) K DIW,DIWT,DN "RTN","RART1",131,0) K C,DIPGM,DISYS,R1,RAIMGTYI,RAP "RTN","RART1",132,0) K:'$D(RARTVER) RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RARPT Q "RTN","RART1",133,0) ; "RTN","RART1",134,0) WRITE K RAXX N Y "RTN","RART1",135,0) F RAV=0:0 S RAV=$O(^RARPT(RARPT,RAP,RAV)) Q:RAV'>0 D Q:X="^"!(X="P")!(X="T") "RTN","RART1",136,0) . S RAXX=^RARPT(RARPT,RAP,RAV,0) S X="" "RTN","RART1",137,0) . D WAIT:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="P")!(X="T") "RTN","RART1",138,0) . S X=RAXX D ^DIWP S X="" "RTN","RART1",139,0) . Q "RTN","RART1",140,0) Q:X="^" D ^DIWW:$D(RAXX) Q "RTN","RART1",141,0) ; "RTN","RART1",142,0) WRITEHX(RAP) ; Get and write the clinical history "RTN","RART1",143,0) ; "RTN","RART1",144,0) ;Input: RAP H = Clinical History from file 70 "RTN","RART1",145,0) ; AH = Additional Clinical History from file 74 "RTN","RART1",146,0) ; "RTN","RART1",147,0) K RAXX N Y "RTN","RART1",148,0) S RAV=0 "RTN","RART1",149,0) I RAP="H" D "RTN","RART1",150,0) . F S RAV=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV)) Q:RAV'>0 D Q:X="^"!(X="P")!(X="T") "RTN","RART1",151,0) . . S RAXX=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV,0),X="" "RTN","RART1",152,0) . . D WAIT:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="P")!(X="T") "RTN","RART1",153,0) . . S X=RAXX D ^DIWP S X="" "RTN","RART1",154,0) . . Q "RTN","RART1",155,0) I RAP="AH" D "RTN","RART1",156,0) . F S RAV=$O(^RARPT(RARPT,"H",RAV)) Q:RAV'>0 D Q:X="^"!(X="P")!(X="T") "RTN","RART1",157,0) . . S RAXX=^RARPT(RARPT,"H",RAV,0),X="" "RTN","RART1",158,0) . . D WAIT:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="P")!(X="T") "RTN","RART1",159,0) . . S X=RAXX D ^DIWP S X="" "RTN","RART1",160,0) . . Q "RTN","RART1",161,0) Q:X="^" D ^DIWW:$D(RAXX) Q "RTN","RART1",162,0) ; "RTN","RART1",163,0) CHKDUPHX ; Check Duplicate History in file 70 and 74. "RTN","RART1",164,0) ; Returns RADUPHX 1 = Duplicate "RTN","RART1",165,0) ; 0 = Different "RTN","RART1",166,0) N RAX,RA74,RA70,RAOK,RAX1 "RTN","RART1",167,0) ; Initialize to Different "RTN","RART1",168,0) S RADUPHX=0 "RTN","RART1",169,0) ; Quit if H node does not exist. Could have been purged. "RTN","RART1",170,0) I '$D(^RARPT(RARPT,"H")) S RADUPHX=1 Q "RTN","RART1",171,0) S RA74=$O(^RARPT(RARPT,"H",""),-1) "RTN","RART1",172,0) S RA70=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",""),-1),RA701=$O(^(0)) "RTN","RART1",173,0) S RAX=RA74-RA70+1 Q:RAX'=1 ; begin comparison "RTN","RART1",174,0) ; Check line by line of each file "RTN","RART1",175,0) ; RAOK 1 = all lines match "RTN","RART1",176,0) ; 0 = at least 1 difference "RTN","RART1",177,0) S RAOK=1 "RTN","RART1",178,0) F RAX1=RA701:1:RA70 I ^RARPT(RARPT,"H",RAX1,0)'=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAX1,0) S RAOK=0 Q ;can exit loop on 1st difference "RTN","RART1",179,0) I 'RAOK Q "RTN","RART1",180,0) S RADUPHX=1 "RTN","RART1",181,0) Q "RTN","RART1",182,0) ; "RTN","RART1",183,0) WAIT ; user input, goto top, print, or continue "RTN","RART1",184,0) S RARD(1)="Continue^continue normal processing" "RTN","RART1",185,0) S:$D(RALERTS) RARD(2)="Print^print the entire report" "RTN","RART1",186,0) S RARD(3)="Top^display the report from the beginning" "RTN","RART1",187,0) S (RARD("B"),RARD("DTOUT"))=1 "RTN","RART1",188,0) S:$D(RALERTS) RARD("A")="Enter 'Top', 'Print' or 'Continue': " "RTN","RART1",189,0) S:'$D(RALERTS) RARD("A")="Enter 'Top' or 'Continue': " "RTN","RART1",190,0) S RARD(0)="S" D SET^RARD K RARD S X=$E(X) "RTN","RART1",191,0) I $D(RALERTS),(X="P") D QRPT^RART3 "RTN","RART1",192,0) Q:X="^"!(X="P") W:X="C"&($D(RAP)) @IOF "RTN","RART1",193,0) Q "RTN","RART1",194,0) ; "RTN","RART1",195,0) LOCK(X,Y) ; Lock an entry "RTN","RART1",196,0) W !!,$C(7),"Another user is editing this ",$S(X="R":"report (Case # "_Y_")",1:"exam (diagnostic code)"),". Please try again later." H 4 Q "RTN","RART1",197,0) ; "RTN","RART1",198,0) SETVARS ; Setup Rad/Nuc Med required variables "RTN","RART1",199,0) I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) "RTN","RART1",200,0) Q:'($D(RACCESS(DUZ))\10) "RTN","RART1",201,0) I $G(RAIMGTY)="" D SETVARS^RAPSET1(1) "RTN","RART1",202,0) Q "RTN","RARTE") 0^9^B45301421 "RTN","RARTE",1,0) RARTE ;HISC/FPT,GJC AISC/MJK,RMO-Edit/Delete Reports ; 06 Oct 2013 11:05 AM "RTN","RARTE",2,0) ;;5.0;Radiology/Nuclear Medicine;**18,34,45,56,99,47,1005**;Mar 16, 1998;Build 13 "RTN","RARTE",3,0) ;Supported IA #3544 ^VA(200,"ARC" "RTN","RARTE",4,0) ;Supported IA #10076 ^XUSEC( "RTN","RARTE",5,0) ;Supported IA #2056 ^GET1^DIQ "RTN","RARTE",6,0) ;Supported IA #10009 YN^DICN "RTN","RARTE",7,0) ; last modification by SS for P18 June 14,2000 "RTN","RARTE",8,0) ; "RTN","RARTE",9,0) D SET^RAPSET1 I $D(XQUIT) K XQUIT Q "RTN","RARTE",10,0) W !!?3,"Note: To enter receipt of OUTSIDE INTERPRETED REPORTS,",!?3,"please use the 'Outside Report/Entry Edit' option.",! "RTN","RARTE",11,0) N RAXIT,RADRS,RASUBY0 S RAXIT=0 ;RADRS=copy (1=diag, 2=resid,staff) "RTN","RARTE",12,0) I $D(RANOSCRN) S X=$$DIVLOC^RAUTL7() I X D Q^RARTE4 QUIT "RTN","RARTE",13,0) ; "RTN","RARTE",14,0) ;1. DO NOT KILL the RASIG variable; the RASIG() array is needed in "RTN","RARTE",15,0) ; the edit template [RA REPORT EDIT] later "RTN","RARTE",16,0) ;2. The RAELESIG canNOT store file 74's ien, as no rpt has been picked "RTN","RARTE",17,0) ; from this call to ES^RASIGU "RTN","RARTE",18,0) ; "RTN","RARTE",19,0) I $D(^XUSEC("RA VERIFY",DUZ)),($$GET1^DIQ(200,DUZ_",",20.4)]""),($D(^VA(200,"ARC","R",DUZ))!($D(^VA(200,"ARC","S",DUZ)))) D Q:'$D(RAELESIG) "RTN","RARTE",20,0) . W ! D ES^RASIGU S:%=1 RAELESIG="" "RTN","RARTE",21,0) . K:'$D(RAELESIG) %,%W,%Y,%Y1,C,X,X1,X2 "RTN","RARTE",22,0) . Q "RTN","RARTE",23,0) K RABTCH I $P(RAMDV,"^",13) D ASKBTCH^RARTE1 G Q1^RARTE4:X["^" D 1^RABTCH:"Yy"[$E(X) I '$D(RABTCH) W " ...no batch selected",! "RTN","RARTE",24,0) START K RAVER S RAVW="",RAREPORT=1 D ^RACNLU G Q^RARTE4:"^"[X "RTN","RARTE",25,0) S RASUBY0=Y(0) ; save value of y(0) "RTN","RARTE",26,0) G:$P(^RA(72,+RAST,0),"^",3)>0 DISPLAY "RTN","RARTE",27,0) I $D(^XUSEC("RA MGR",DUZ)) G DISPLAY "RTN","RARTE",28,0) G:$P(RAMDV,"^",22)=1 DISPLAY "RTN","RARTE",29,0) W $C(7),!!,"The STATUS for this case is CANCELLED. You may not enter a report.",!! D INCRPT^RARTE4 G START "RTN","RARTE",30,0) ; "RTN","RARTE",31,0) DISPLAY ; Display exam specific info, edit/enter the report "RTN","RARTE",32,0) N RA18EX S RA18EX=0 ;P18 for quit if uparrow inside PUTTCOM "RTN","RARTE",33,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RARTE",34,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RARTE",35,0) I '($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))#2) D D Q^RARTE4 QUIT "RTN","RARTE",36,0) . I $$USESSAN^RAHLRU1() W !!?2,"Case #: ",RACNDSP," for ",RANME S RAXIT=1 "RTN","RARTE",37,0) . I '$$USESSAN^RAHLRU1() W !!?2,"Case #: ",RACN," for ",RANME S RAXIT=1 "RTN","RARTE",38,0) . W !?2,"Procedure: '",$E(RAPRC,1,45),"' has been deleted" "RTN","RARTE",39,0) . W !?2,"by another user!",$C(7) "RTN","RARTE",40,0) . Q "RTN","RARTE",41,0) ;Lock case node so no one else can edit rpt pointer during this session "RTN","RARTE",42,0) S RAPNODE="^RADPT("_RADFN_",""DT"","_RADTI_",""P""," "RTN","RARTE",43,0) S RAXIT=$$LOCK^RAUTL12(RAPNODE,RACNI) I RAXIT D INCRPT^RARTE4 G START "RTN","RARTE",44,0) S RAI="",$P(RAI,"-",80)="" W !,RAI "RTN","RARTE",45,0) W !?1,"Name : ",$E(RANME,1,25),?40,"Pt ID : ",RASSN "RTN","RARTE",46,0) I $$USESSAN^RAHLRU1() W !?1,"Case No. : ",RACNDSP,?40,"Exm. St : ",$E($P($G(^RA(72,+RAST,0)),"^"),1,22),!?1,"Procedure: ",$E(RAPRC,1,45) "RTN","RARTE",47,0) I '$$USESSAN^RAHLRU1() W !?1,"Case No. : ",RACN,?18,"Exm. St: ",$E($P($G(^RA(72,+RAST,0)),"^"),1,12),?40,"Procedure : ",$E(RAPRC,1,25) "RTN","RARTE",48,0) ;check for contrast media; display if CM data exists (patch 45) "RTN","RARTE",49,0) S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI) "RTN","RARTE",50,0) D:$L(RACMDATA) CMEDIA(RACMDATA) "RTN","RARTE",51,0) K RACMDATA "RTN","RARTE",52,0) S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,RACN," Tech.Comment: ",15,70,-1,0) ;P18 "RTN","RARTE",53,0) I RA18EX=-1 Q ;P18 "RTN","RARTE",54,0) N RAPRTSET,RAMEMARR,RA1 "RTN","RARTE",55,0) D EN2^RAUTL20(.RAMEMARR) "RTN","RARTE",56,0) I RAPRTSET D "RTN","RARTE",57,0) . S RA1="" "RTN","RARTE",58,0) . F S RA1=$O(RAMEMARR(RA1)) Q:RA1=""!(RA18EX=-1) I RA1'=RACNI D "RTN","RARTE",59,0) .. I $$USESSAN^RAHLRU1() W !,?1,"Case No. : ",$P(RAMEMARR(RA1),U) "RTN","RARTE",60,0) .. I '$$USESSAN^RAHLRU1() W !,?1,"Case No. : ",+RAMEMARR(RA1) "RTN","RARTE",61,0) .. I $$USESSAN^RAHLRU1() W:$P(RAMEMARR(RA1),"^",4)]"" ?40,"Exm. St : ",$E($P($G(^RA(72,$P(RAMEMARR(RA1),"^",4),0)),"^"),1,22) W !?1,"Procedure: ",$E($P($G(^RAMIS(71,+$P(RAMEMARR(RA1),"^",2),0)),"^"),1,45) "RTN","RARTE",62,0) .. I '$$USESSAN^RAHLRU1() W:$P(RAMEMARR(RA1),"^",4)]"" ?18,"Exm. St: ",$E($P($G(^RA(72,$P(RAMEMARR(RA1),"^",4),0)),"^"),1,12) W ?40,"Procedure : ",$E($P($G(^RAMIS(71,+$P(RAMEMARR(RA1),"^",2),0)),"^"),1,26) "RTN","RARTE",63,0) ..;check printset for contrast media; display if CM data exists "RTN","RARTE",64,0) ..S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RA1) "RTN","RARTE",65,0) ..D:$L(RACMDATA) CMEDIA(RACMDATA) "RTN","RARTE",66,0) ..K RACMDATA "RTN","RARTE",67,0) ..I $P(RAMEMARR(RA1),"^")["-" S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,$P($P(RAMEMARR(RA1),"^"),"-",3)," Tech.Comment: ",15,70,-1,0) Q:RA18EX=-1 "RTN","RARTE",68,0) ..I $P(RAMEMARR(RA1),"^")'["-" S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,+RAMEMARR(RA1)," Tech.Comment: ",15,70,-1,0) Q:RA18EX=-1 ;P18 "RTN","RARTE",69,0) .. Q "RTN","RARTE",70,0) . Q "RTN","RARTE",71,0) SS1 I RA18EX=-1 Q ;P18 "RTN","RARTE",72,0) W !?1,"Exam Date: ",RADATE,?40,"Technologist: " I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))>0,$D(^VA(200,+^($O(^(0)),0),0)) W $E($P(^(0),"^"),1,25) "RTN","RARTE",73,0) W !?1,"Req Phys : ",$E($S($D(^VA(200,+$P(Y(0),"^",14),0)):$P(^(0),"^"),1:""),1,25) "RTN","RARTE",74,0) ; p99: get pt sex and display pregnancy data "RTN","RARTE",75,0) ; "RTN","RARTE",76,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RARTE",77,0) ;I $$PTSEX^RAUTL8(RADFN)="F" D "RTN","RARTE",78,0) I $$PTSEX^RAUTL8(RADFN)'="M" D "RTN","RARTE",79,0) .; "RTN","RARTE",80,0) .N RA3,RAPCOMM S RA3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RARTE",81,0) .S RAPCOMM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCOMM")) "RTN","RARTE",82,0) .W:$P(RA3,U,32)'="" !?1,"Pregnancy Screen: ",$S($P(RA3,"^",32)="y":"Patient answered yes",$P(RA3,"^",32)="n":"Patient answered no",$P(RA3,"^",32)="u":"Patient is unable to answer or is unsure",1:"") "RTN","RARTE",83,0) .W:$P(RA3,U,32)'="n"&$L(RAPCOMM) !?1,"Pregnancy Screen Comment: ",RAPCOMM "RTN","RARTE",84,0) S Y(0)=RASUBY0 "RTN","RARTE",85,0) W !,RAI "RTN","RARTE",86,0) ;end p99 "RTN","RARTE",87,0) I $D(^RARPT(+RARPT,0)) S RA1=$P(^(0),"^",5) I "^V^EF^"[("^"_RA1_"^") W !?3,$C(7),"Report has already been ",$S(RA1="V":"verified",1:"electronically filed"),! D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT^RARTE4 G START "RTN","RARTE",88,0) ;Create new rpt, or skip to IN to edit existing report "RTN","RARTE",89,0) G IN^RARTE4:$D(^RARPT(+RARPT,0)) "RTN","RARTE",90,0) G:'RAPRTSET NEW G:$P(^RA(72,+RAST,0),"^",3)>0 NEW "RTN","RARTE",91,0) ; case is part of a print set, AND is cancelled "RTN","RARTE",92,0) N RA2 S (RA1,RA2)="" "RTN","RARTE",93,0) F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" S:$P(RAMEMARR(RA1),"^",3)]"" RA2=$P(RAMEMARR(RA1),"^",3) "RTN","RARTE",94,0) G:RA2="" NEW "RTN","RARTE",95,0) W !!,$C(7),"Other cases of this cancelled case ",RACNDSP,"'s print set are entered in a report already",!!,"You may NOT create a new report for this cancelled case,",!,"but you may include this cancelled case in the existing report." "RTN","RARTE",96,0) W !!,"Do you want to include this cancelled case in the same report",!,"as the others in the print set ?" "RTN","RARTE",97,0) S %=2 D YN^DICN "RTN","RARTE",98,0) W:%>0 "...",$S(%=1:"Include",1:"Skip")," this case" "RTN","RARTE",99,0) I %=1 S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RA2,RARPT=RA2,RARPTN=$P(^RARPT(RARPT,0),"^"),RA1=RACN D INSERT^RARTE2 "RTN","RARTE",100,0) D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT^RARTE4 G START "RTN","RARTE",101,0) NEW G:'RAPRTSET NEW1 "RTN","RARTE",102,0) L +^RADPT(RADFN,"DT",RADTI):0 G:$T NEW1 "RTN","RARTE",103,0) W !!?10,$C(7),"** This case belongs to a printset,",?68,"**",!?10,"** and someone else is currently doing REPORT ENTRY/EDIT",?68,"**" "RTN","RARTE",104,0) W !?10,"** on another case for this same printset,",?68,"**",!?10,"** so you may not enter a new report.",?68,"**" "RTN","RARTE",105,0) H 2 D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT^RARTE4 G START "RTN","RARTE",106,0) NEW1 ; "RTN","RARTE",107,0) I $L(RACNDSP,"-")>1 S RARPTN=RACNDSP "RTN","RARTE",108,0) I $L(RACNDSP,"-")<2 S RARPTN=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN "RTN","RARTE",109,0) W !?3,"...report not entered for this exam...",!?10,"...will now initialize report entry..." "RTN","RARTE",110,0) S I=+$P(^RARPT(0),"^",3) "RTN","RARTE",111,0) G LOCK^RARTE4 "RTN","RARTE",112,0) Q "RTN","RARTE",113,0) ; "RTN","RARTE",114,0) CMEDIA(X) ;check if contrast media is associated with the report (exam) "RTN","RARTE",115,0) ;variables assumed to exist X: the string of contrast media used "RTN","RARTE",116,0) ;delimited by the comma. "RTN","RARTE",117,0) N Y W !," Contrast :" "RTN","RARTE",118,0) F Y=1:1 Q:$P(X,", ",Y)="" W ?12,$P(X,", ",Y) W:$P(X,", ",Y+1)'="" ! "RTN","RARTE",119,0) Q "RTN","RARTE6") 0^10^B146173116 "RTN","RARTE6",1,0) RARTE6 ;HISC/SM Restore deleted report ; 06 Oct 2013 11:05 AM "RTN","RARTE6",2,0) ;;5.0;Radiology/Nuclear Medicine;**56,95,99,47,1004,1005**;Mar 16, 1998;Build 13 "RTN","RARTE6",3,0) ;Supported IA #10060 ^VA(200 "RTN","RARTE6",4,0) ;Supported IA #2053 FILE^DIE, UPDATE^DIE "RTN","RARTE6",5,0) ;Supported IA #2052 GET1^DID "RTN","RARTE6",6,0) ;Supported IA #2056 GET1^DIQ "RTN","RARTE6",7,0) ;Supported IA #10103 NOW^XLFDT "RTN","RARTE6",8,0) ;Supported IA #2055 ROOT^DILFD "RTN","RARTE6",9,0) ;Supported IA #10060 GETS^DIQ "RTN","RARTE6",10,0) ;P99, added pregnancy screen and pregnancy screen comment "RTN","RARTE6",11,0) Q "RTN","RARTE6",12,0) RSTR ;restore deleted report "RTN","RARTE6",13,0) F I=1:1:5 W !?4,$P($T(INTRO+I),";;",2) "RTN","RARTE6",14,0) W ! "RTN","RARTE6",15,0) S RAXIT=0 ; =0 exit normally, =1 exit early "RTN","RARTE6",16,0) I '$D(^XUSEC("RA MGR",DUZ)) W !!,"Supervisory key RA MGR is needed for this option." Q "RTN","RARTE6",17,0) S DIC("S")="I $P(^(0),""^"",5)=""X""" ;only select deleted reports "RTN","RARTE6",18,0) S DIC("A")="Select Deleted Report to restore: " "RTN","RARTE6",19,0) S DIC="^RARPT(",DIC(0)="AEMQZ" "RTN","RARTE6",20,0) D DICW^RARTST1,^DIC K DIC I Y<0 G FINISH "RTN","RARTE6",21,0) S RARPT=+Y "RTN","RARTE6",22,0) W ! "RTN","RARTE6",23,0) D CHECK G:RAXIT NOTDONE ;check if case has rpt & DX codes "RTN","RARTE6",24,0) D ASK1 G:RAXIT NOTDONE ;ask if want restore deleted report "RTN","RARTE6",25,0) D ASSOC G:RAXIT NOTDONE ;display associated case(s) & ask user again if want continue "RTN","RARTE6",26,0) D RESTORE ;restore rpt status, link rpt to case(s) "RTN","RARTE6",27,0) D FINISH "RTN","RARTE6",28,0) Q "RTN","RARTE6",29,0) CHECK ; check if associated case(s) has rpt and DX codes "RTN","RARTE6",30,0) S RA74=^RARPT(RARPT,0) "RTN","RARTE6",31,0) S RADFN=+$P(RA74,U,2),RADTI=9999999.9999-$P(RA74,U,3),RACN=+$P($P(RA74,U,1),"-",$L($P(RA74,U,1),"-")) "RTN","RARTE6",32,0) S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) "RTN","RARTE6",33,0) S RA70=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RARTE6",34,0) I 'RADFN!('RADTI)!('RACNI)!(RA70="") D ERR0 Q "RTN","RARTE6",35,0) S RANME=$$GET1^DIQ(2,RADFN,.01),RAST=+$P(RA70,U,3) "RTN","RARTE6",36,0) S RAPRC=$S($D(^RAMIS(71,+$P(RA70,U,2),0)):$P(^(0),U),1:"Unknown") "RTN","RARTE6",37,0) S RASSN=$$SSN^RAUTL,RASUBY0=RA70 "RTN","RARTE6",38,0) S RANODE=$G(^RADPT(RADFN,"DT",RADTI,0)) "RTN","RARTE6",39,0) ; check if case(s) already have a report "RTN","RARTE6",40,0) D EN2^RAUTL20(.RAMEMARR) "RTN","RARTE6",41,0) I RAPRTSET D "RTN","RARTE6",42,0) .S RA1=0 "RTN","RARTE6",43,0) .F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" D "RTN","RARTE6",44,0) ..I $P(^RADPT(RADFN,"DT",RADTI,"P",RA1,0),U,17)'="" D ERR3($P(RAMEMARR(RA1),"^")) "RTN","RARTE6",45,0) ..Q "RTN","RARTE6",46,0) .Q "RTN","RARTE6",47,0) E I $P(RA70,U,17) D ERR3($P(RA74,U,1)) Q "RTN","RARTE6",48,0) ; check if case(s) already have DX codes, staff, resident "RTN","RARTE6",49,0) ; don't use IF ELSE here due to outside calls "RTN","RARTE6",50,0) ; "RTN","RARTE6",51,0) ; Printset cases "RTN","RARTE6",52,0) I RAPRTSET D Q "RTN","RARTE6",53,0) .S RA1=0 "RTN","RARTE6",54,0) .F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" D "RTN","RARTE6",55,0) ..; check primary "RTN","RARTE6",56,0) ..F RA2=13,15,12 I $P(^RADPT(RADFN,"DT",RADTI,"P",RA1,0),U,RA2)'="" D ERR2($P(RAMEMARR(RA1),"^"),70.03,RA2) "RTN","RARTE6",57,0) ..; check secondary "RTN","RARTE6",58,0) ..S RAIENS=1_","_RA1_","_RADTI_","_RADFN_"," "RTN","RARTE6",59,0) ..F RA2=70.14,70.11,70.09 S RAROOT=$$ROOT^DILFD(RA2,RAIENS) I $O(@(RAROOT_"0)")) D ERR2($P(RAMEMARR(RA1),"^"),RA2,.01) "RTN","RARTE6",60,0) ..Q "RTN","RARTE6",61,0) .Q "RTN","RARTE6",62,0) ; single case "RTN","RARTE6",63,0) F RA2=13,15,12 I $P(RA70,U,RA2) D ERR2($P(RA74,U,1),70.03,RA2) "RTN","RARTE6",64,0) S RAIENS=1_","_RACNI_","_RADTI_","_RADFN_"," "RTN","RARTE6",65,0) F RA2=70.14,70.11,70.09 S RAROOT=$$ROOT^DILFD(RA2,RAIENS) I $O(@(RAROOT_"0)")) D ERR2($P(RA74,U,1),RA2,.01) "RTN","RARTE6",66,0) Q "RTN","RARTE6",67,0) ASK1 ; ask if want to restore report "RTN","RARTE6",68,0) ; RAPRVIEN last Activity Log rec in subfile 74.01 "RTN","RARTE6",69,0) ; RAPRVST previous report status logged in latest activity log rec "RTN","RARTE6",70,0) ; RALAST last activity log record "RTN","RARTE6",71,0) S RAPRVIEN=$O(^RARPT(RARPT,"L",""),-1) "RTN","RARTE6",72,0) I 'RAPRVIEN D ERR1 Q "RTN","RARTE6",73,0) S RALAST=$G(^RARPT(RARPT,"L",+RAPRVIEN,0)) "RTN","RARTE6",74,0) I RALAST="" D ERR1 Q "RTN","RARTE6",75,0) S RAPRVST=$P(RALAST,U,4) ;previous rpt status "RTN","RARTE6",76,0) K DIR "RTN","RARTE6",77,0) S DIR(0)="Y",DIR("B")="NO" "RTN","RARTE6",78,0) S DIR("A")="Do you want to restore this deleted report" "RTN","RARTE6",79,0) S DIR("?")="Answer ""Y"" to assign the previous report status, "_$$GET1^DIQ(74.01,RAPRVIEN_","_RARPT_",",4)_", to this report." "RTN","RARTE6",80,0) D ^DIR K DIR "RTN","RARTE6",81,0) S:$D(DIRUT) RAXIT=1 "RTN","RARTE6",82,0) S:'Y RAXIT=1 "RTN","RARTE6",83,0) Q "RTN","RARTE6",84,0) ASSOC ; "RTN","RARTE6",85,0) ; list case(s) for this report "RTN","RARTE6",86,0) S (Y,RADTE)=+$P(RANODE,U) "RTN","RARTE6",87,0) D D^RAUTL S RADATE=Y "RTN","RARTE6",88,0) D DISPLAY "RTN","RARTE6",89,0) W ! "RTN","RARTE6",90,0) K DIR "RTN","RARTE6",91,0) S DIR(0)="Y",DIR("B")="NO" "RTN","RARTE6",92,0) S DIR("A")="Are you sure you want to link this report back to the case"_$S(RAPRTSET:"s",1:"") "RTN","RARTE6",93,0) S DIR("?")="Answer ""Y"" to link this report back to the case(s) shown above." "RTN","RARTE6",94,0) D ^DIR K DIR "RTN","RARTE6",95,0) S:$D(DIRUT) RAXIT=1 "RTN","RARTE6",96,0) S:'Y RAXIT=1 "RTN","RARTE6",97,0) Q "RTN","RARTE6",98,0) RESTORE ; set Report Status to "before delete" value, link to case(s) "RTN","RARTE6",99,0) D SETFF(74,5,RARPT,RAPRVST) "RTN","RARTE6",100,0) W !!?3,"... Restored ",$P(RA74,U,1),"'s report status to: ",$$GET1^DIQ(74,+RARPT,5),"." "RTN","RARTE6",101,0) ; "RTN","RARTE6",102,0) ; set activity log record "RTN","RARTE6",103,0) S RAIENL="+1,"_RARPT_"," "RTN","RARTE6",104,0) D SETALOG(RAIENL,"R","") "RTN","RARTE6",105,0) ; "RTN","RARTE6",106,0) ; link report to single case or all cases of a printset "RTN","RARTE6",107,0) I RAPRTSET D "RTN","RARTE6",108,0) .S RA1="" "RTN","RARTE6",109,0) .F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" S $P(^RADPT(RADFN,"DT",RADTI,"P",RA1,0),U,17)=RARPT D MSG1($P(RAMEMARR(RA1),"^")) "RTN","RARTE6",110,0) .Q "RTN","RARTE6",111,0) E S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,17)=RARPT D MSG1($P(RA74,U,1)) "RTN","RARTE6",112,0) ; "RTN","RARTE6",113,0) ;Restore Primary and Secondary DX codes, Staff and Residents "RTN","RARTE6",114,0) ; "RTN","RARTE6",115,0) F RAFLD=5,7,9 S RAPREV=$P(RALAST,U,RAFLD) D:RAPREV SET70(RAFLD) "RTN","RARTE6",116,0) W !!!?3,"** You need to edit the case"_$S(RAPRTSET:"s",1:"")_" to update the exam status. **" "RTN","RARTE6",117,0) Q "RTN","RARTE6",118,0) SET70(X) ; put back previous DX codes, Staff, Residents into case record "RTN","RARTE6",119,0) ; assumes if no primary then no secondaries "RTN","RARTE6",120,0) K RAFDA,RAA "RTN","RARTE6",121,0) N RA1 "RTN","RARTE6",122,0) S RAIENS=1_","_RAPRVIEN_","_RARPT_"," "RTN","RARTE6",123,0) ; "RTN","RARTE6",124,0) ; X is the field number from subfile 74.01: "RTN","RARTE6",125,0) ; 5 = BEFORE DELETION PRIM. DX CODE "RTN","RARTE6",126,0) ; 7 = BEFORE DELETION PRIM. STAFF "RTN","RARTE6",127,0) ; 9 = BEFORE DELETION PRIM. RESIDENT "RTN","RARTE6",128,0) ; "RTN","RARTE6",129,0) ; RAF1 = subfile number from file 74's activity log "RTN","RARTE6",130,0) ; RAF2 = subfile number from file 70's secondaries "RTN","RARTE6",131,0) ; RAF3 = subfile number pointed to from file 70's secondaries "RTN","RARTE6",132,0) ; RAPIECE = piece in 70.03's 0 node "RTN","RARTE6",133,0) S RAF1=$S(X=5:74.16,X=7:74.18,X=9:74.19,1:"") Q:RAF1="" "RTN","RARTE6",134,0) S RAF2=$S(X=5:70.14,X=7:70.11,X=9:70.09,1:"") Q:RAF2="" "RTN","RARTE6",135,0) S RAF3=$$GET1^DID(RAF2,.01,"","POINTER") "RTN","RARTE6",136,0) ; extract file number from RAF3 "RTN","RARTE6",137,0) S RAF3=$TR(RAF3,$TR(RAF3,"0123456789.")) "RTN","RARTE6",138,0) ;piece number for Primary DX/Staff/Resident in 70.03 "RTN","RARTE6",139,0) S RAPIECE=$S(X=5:13,X=7:15,X=9:12,1:"") Q:RAPIECE="" "RTN","RARTE6",140,0) S RAROOT=$$ROOT^DILFD(RAF1,RAIENS,1) ;closed root under file 74's Activity Log "RTN","RARTE6",141,0) ;copy secondaries into RAA() "RTN","RARTE6",142,0) M RAA=@RAROOT "RTN","RARTE6",143,0) ; "RTN","RARTE6",144,0) G:RAPRTSET PSET "RTN","RARTE6",145,0) ; "RTN","RARTE6",146,0) ; single case "RTN","RARTE6",147,0) ; "RTN","RARTE6",148,0) ; copy Primary into single case "RTN","RARTE6",149,0) S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",RAPIECE)=RAPREV "RTN","RARTE6",150,0) D FILE^DIE("","RAFDA","RAMSG") "RTN","RARTE6",151,0) I $D(RAMSG("DIERR")) D ERR4($P(RA74,U,1),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01)) "RTN","RARTE6",152,0) E D MSG2($P(RA74,U,1),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01)) "RTN","RARTE6",153,0) K RAFDA,RAMSG "RTN","RARTE6",154,0) ; "RTN","RARTE6",155,0) Q:$O(RAA(0))'>0 ; no secondaries "RTN","RARTE6",156,0) ; "RTN","RARTE6",157,0) ;copy secondary items into single case "RTN","RARTE6",158,0) S RA1=0 "RTN","RARTE6",159,0) F S RA1=$O(RAA(RA1)) Q:'RA1 S RAX=$G(RAA(RA1,0)) D:RAX "RTN","RARTE6",160,0) .S RAFDA(RAF2,"+2,"_RACNI_","_RADTI_","_RADFN_",",.01)=RAX "RTN","RARTE6",161,0) .D UPDATE^DIE(,"RAFDA",,"RAMSG") "RTN","RARTE6",162,0) .I $D(RAMSG("DIERR")) D ERR4($P(RA74,U,1),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01)) "RTN","RARTE6",163,0) .E D MSG2($P(RA74,U,1),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01)) "RTN","RARTE6",164,0) .K RAFDA,RAMSG "RTN","RARTE6",165,0) .Q "RTN","RARTE6",166,0) Q "RTN","RARTE6",167,0) ; "RTN","RARTE6",168,0) ; cases from printset "RTN","RARTE6",169,0) ; "RTN","RARTE6",170,0) PSET ; copy Primary into cases of a printset "RTN","RARTE6",171,0) S RA1=0 "RTN","RARTE6",172,0) F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" D "RTN","RARTE6",173,0) .S RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",RAPIECE)=RAPREV "RTN","RARTE6",174,0) .D FILE^DIE("","RAFDA","RAMSG") "RTN","RARTE6",175,0) .I $D(RAMSG("DIERR")) D ERR4($P(RAMEMARR(RA1),"^"),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01)) "RTN","RARTE6",176,0) .;E D MSG2(+RAMEMARR(RA1),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01)) "RTN","RARTE6",177,0) .E D MSG2($P(RAMEMARR(RA1),"^"),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01)) "RTN","RARTE6",178,0) .K RAFDA,RAMSG "RTN","RARTE6",179,0) .Q:$O(RAA(0))'>0 ; no secondary DXs "RTN","RARTE6",180,0) .; copy secondaries into cases of a printset "RTN","RARTE6",181,0) .S RA2=0 "RTN","RARTE6",182,0) .F S RA2=$O(RAA(RA2)) Q:'RA2 S RAX=$G(RAA(RA2,0)) D:RAX "RTN","RARTE6",183,0) ..S RAFDA(RAF2,"+2,"_RA1_","_RADTI_","_RADFN_",",.01)=RAX "RTN","RARTE6",184,0) ..D UPDATE^DIE(,"RAFDA",,"RAMSG") "RTN","RARTE6",185,0) ..I $D(RAMSG("DIERR")) D ERR4($P(RAMEMARR(RA1),"^"),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01)) "RTN","RARTE6",186,0) ..;E D MSG2(+RAMEMARR(RA1),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01)) "RTN","RARTE6",187,0) ..E D MSG2($P(RAMEMARR(RA1),"^"),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01)) "RTN","RARTE6",188,0) ..K RAFDA,RAMSG "RTN","RARTE6",189,0) ..Q "RTN","RARTE6",190,0) .Q "RTN","RARTE6",191,0) Q "RTN","RARTE6",192,0) SETFF(RA1,RA2,RA3,RA4,RA5) ;reset file's field value "RTN","RARTE6",193,0) ;RA1 file number "RTN","RARTE6",194,0) ;RA2 field number "RTN","RARTE6",195,0) ;RA3 IEN in file "RTN","RARTE6",196,0) ;RA4 field value to set in record IEN "RTN","RARTE6",197,0) ;RA5 (optional), set to "E" for external "RTN","RARTE6",198,0) N RAFDA "RTN","RARTE6",199,0) S RAFDA(RA1,RA3_",",RA2)=RA4 "RTN","RARTE6",200,0) I $G(RA5)="E" D FILE^DIE("E","RAFDA") "RTN","RARTE6",201,0) E D FILE^DIE("","RAFDA") "RTN","RARTE6",202,0) Q "RTN","RARTE6",203,0) SETALOG(RA1,RA2,RA3) ;set new record in Activity log 74.01 "RTN","RARTE6",204,0) ;RA1 ien string, eg., "+1,"_RARPT_"," "RTN","RARTE6",205,0) ;RA2 type of action "RTN","RARTE6",206,0) ;RA3 current report status code "RTN","RARTE6",207,0) ; "RTN","RARTE6",208,0) N RAFDA "RTN","RARTE6",209,0) S RAFDA(74.01,RA1,.01)=+$E($$NOW^XLFDT(),1,12) "RTN","RARTE6",210,0) S RAFDA(74.01,RA1,2)=RA2 "RTN","RARTE6",211,0) S RAFDA(74.01,RA1,3)=$G(DUZ) "RTN","RARTE6",212,0) S:$G(RA3)]"" RAFDA(74.01,RA1,4)=RA3 ;only del rpt would have data here "RTN","RARTE6",213,0) D UPDATE^DIE(,"RAFDA") "RTN","RARTE6",214,0) Q "RTN","RARTE6",215,0) MSG1(X) ; "RTN","RARTE6",216,0) W !?3,"... Linked restored report to case no. ",X "RTN","RARTE6",217,0) Q "RTN","RARTE6",218,0) MSG2(X,Y,Z) ; "RTN","RARTE6",219,0) W !?3,"... Restored case ",X,"'s ",Y," to: ",Z "RTN","RARTE6",220,0) Q "RTN","RARTE6",221,0) ERR0 ; "RTN","RARTE6",222,0) W !,"Unable to determine case previously associated with this report." "RTN","RARTE6",223,0) S RAXIT=1 "RTN","RARTE6",224,0) Q "RTN","RARTE6",225,0) ERR1 W !!,"Cannot determine previous report status.",! "RTN","RARTE6",226,0) S RAXIT=1 "RTN","RARTE6",227,0) Q "RTN","RARTE6",228,0) ERR2(X,Y,Z) ;X=External short case No, Y=File no., Z=Field no. "RTN","RARTE6",229,0) W !,"Case #",X," already has ",$$GET1^DID(Y,Z,"","LABEL") "RTN","RARTE6",230,0) S RAXIT=1 "RTN","RARTE6",231,0) Q "RTN","RARTE6",232,0) ERR3(X) ; "RTN","RARTE6",233,0) W !,"Case #",X," is already associated with a report!" "RTN","RARTE6",234,0) S RAXIT=1 "RTN","RARTE6",235,0) Q "RTN","RARTE6",236,0) ERR4(X,Y,Z) ; "RTN","RARTE6",237,0) W !!?3,"Cannot restore case ",X,"'s ",Y," to: ",Z "RTN","RARTE6",238,0) Q "RTN","RARTE6",239,0) NOTDONE ; "RTN","RARTE6",240,0) W !!?3,"Restoration was not done." "RTN","RARTE6",241,0) ; continue to clean up "RTN","RARTE6",242,0) FINISH ; clean up and exit "RTN","RARTE6",243,0) R !!!,"Press RETURN to exit. ",X:DTIME "RTN","RARTE6",244,0) K DIRUT,I "RTN","RARTE6",245,0) K RA1,RA2,RA3,RA4,RA5,RA18EX,RA70,RA74,RAA,RACMDATA "RTN","RARTE6",246,0) K RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RADUZ,RAFDA,RAF1,RAF2,RAF3 "RTN","RARTE6",247,0) K RAI,RAIENL,RAIENS,RAIENSUB,RALAST,RALCKFLG,RAMEMARR,RANME,RANODE "RTN","RARTE6",248,0) K RAOUT,RAPIECE,RAPRC,RAPRTSET,RAPRVIEN,RAPREV,RAPRVST,RAROOT,RARPT "RTN","RARTE6",249,0) K RASSN,RAST,RASUB70,RASUBY0,RAX,RAXIT,X,XY,Y,Z "RTN","RARTE6",250,0) Q "RTN","RARTE6",251,0) DISPLAY ; Display exam specific info, edit/enter the report "RTN","RARTE6",252,0) ; adapted from routine RARTE "RTN","RARTE6",253,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RARTE6",254,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RARTE6",255,0) S RA18EX=0 ;P18 for quit if uparrow inside PUTTCOM "RTN","RARTE6",256,0) I '($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))#2) D D Q1^RARTE5 QUIT "RTN","RARTE6",257,0) . I $$USESSAN^RAHLRU1() W !!?2,"Case #: ",RACNDSP," for ",RANME S RAXIT=1 "RTN","RARTE6",258,0) . I '$$USESSAN^RAHLRU1() W !!?2,"Case #: ",RACN," for ",RANME S RAXIT=1 "RTN","RARTE6",259,0) . W !?2,"Procedure: '",$E(RAPRC,1,45),"' has been deleted" "RTN","RARTE6",260,0) . W !?2,"by another user!",$C(7) "RTN","RARTE6",261,0) . Q "RTN","RARTE6",262,0) ; "RTN","RARTE6",263,0) S RAI="",$P(RAI,"-",80)="" W !,RAI "RTN","RARTE6",264,0) W !?1,"Name : ",$E(RANME,1,25),?40,"Pt ID : ",RASSN "RTN","RARTE6",265,0) I $$USESSAN^RAHLRU1() W !?1,"Case No. : ",RACNDSP,?40,"Exm. St : ",$E($P($G(^RA(72,+RAST,0)),"^"),1,22),!?1,"Procedure: ",$E(RAPRC,1,45) "RTN","RARTE6",266,0) I '$$USESSAN^RAHLRU1() W !?1,"Case No. : ",RACN,?18,"Exm. St: ",$E($P($G(^RA(72,+RAST,0)),"^"),1,12),?40,"Procedure : ",$E(RAPRC,1,25) "RTN","RARTE6",267,0) ;check for contrast media; display if CM data exists (patch 45) "RTN","RARTE6",268,0) S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI) "RTN","RARTE6",269,0) D:$L(RACMDATA) CMEDIA^RARTE(RACMDATA) "RTN","RARTE6",270,0) K RACMDATA "RTN","RARTE6",271,0) S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,RACN," Tech.Comment: ",15,70,-1,0) ;P18 "RTN","RARTE6",272,0) I RA18EX=-1 Q ;P18 "RTN","RARTE6",273,0) ; "RTN","RARTE6",274,0) K RAMEMARR D EN2^RAUTL20(.RAMEMARR) ;recalculate RAPRTSET "RTN","RARTE6",275,0) ; if printset, display cases and continue on to display Exam Date "RTN","RARTE6",276,0) I RAPRTSET D "RTN","RARTE6",277,0) . S RA1="" "RTN","RARTE6",278,0) . F S RA1=$O(RAMEMARR(RA1)) Q:RA1=""!(RA18EX=-1) I RA1'=RACNI D "RTN","RARTE6",279,0) .. I $$USESSAN^RAHLRU1() W !,?1,"Case No. : ",$P(RAMEMARR(RA1),U) "RTN","RARTE6",280,0) .. I '$$USESSAN^RAHLRU1() W !,?1,"Case No. : ",+RAMEMARR(RA1) "RTN","RARTE6",281,0) .. I $$USESSAN^RAHLRU1() W:$P(RAMEMARR(RA1),"^",4)]"" ?40,"Exm. St : ",$E($P($G(^RA(72,$P(RAMEMARR(RA1),"^",4),0)),"^"),1,22) W !?1,"Procedure: ",$E($P($G(^RAMIS(71,+$P(RAMEMARR(RA1),"^",2),0)),"^"),1,45) "RTN","RARTE6",282,0) .. I '$$USESSAN^RAHLRU1() W:$P(RAMEMARR(RA1),"^",4)]"" ?18,"Exm. St: ",$E($P($G(^RA(72,$P(RAMEMARR(RA1),"^",4),0)),"^"),1,12) W ?40,"Procedure : ",$E($P($G(^RAMIS(71,+$P(RAMEMARR(RA1),"^",2),0)),"^"),1,26) "RTN","RARTE6",283,0) .. ;check printset for contrast media; display if CM data exists "RTN","RARTE6",284,0) .. S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RA1) "RTN","RARTE6",285,0) .. D:$L(RACMDATA) CMEDIA^RARTE(RACMDATA) "RTN","RARTE6",286,0) .. K RACMDATA "RTN","RARTE6",287,0) .. I $P(RAMEMARR(RA1),"^")["-" S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,$P($P(RAMEMARR(RA1),"^"),"-",3)," Tech.Comment: ",15,70,-1,0) Q:RA18EX=-1 "RTN","RARTE6",288,0) .. I $P(RAMEMARR(RA1),"^")'["-" S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,+RAMEMARR(RA1)," Tech.Comment: ",15,70,-1,0) Q:RA18EX=-1 ;P18 "RTN","RARTE6",289,0) .. Q "RTN","RARTE6",290,0) . Q "RTN","RARTE6",291,0) ;continue display "RTN","RARTE6",292,0) I RA18EX=-1 Q ;P18 "RTN","RARTE6",293,0) S Y(0)=RASUBY0 "RTN","RARTE6",294,0) S RAIENS=RACNI_","_RADTI_","_RADFN_"," "RTN","RARTE6",295,0) D GETS^DIQ(70.03,RAIENS,"14;175*","E","RAOUT") "RTN","RARTE6",296,0) W !?1,"Exam Date: ",RADATE,?40,"Technologist: " "RTN","RARTE6",297,0) S RAIENSUB=$O(RAOUT(70.12,0)) "RTN","RARTE6",298,0) W:RAIENSUB]"" $E($G(RAOUT(70.12,RAIENSUB,.01,"E")),1,25) "RTN","RARTE6",299,0) ;p99 begins "RTN","RARTE6",300,0) W !?1,"Req Phys : ",$E($G(RAOUT(70.03,RAIENS,14,"E")),1,25) "RTN","RARTE6",301,0) ; "RTN","RARTE6",302,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RARTE6",303,0) ;I $$PTSEX^RAUTL8(RADFN)="F" D "RTN","RARTE6",304,0) I $$PTSEX^RAUTL8(RADFN)'="M" D "RTN","RARTE6",305,0) .; "RTN","RARTE6",306,0) .D GETS^DIQ(70.03,RAIENS,"32;80","I","RAOUT") "RTN","RARTE6",307,0) .N RA3 S RA3=$G(RAOUT(70.03,RAIENS,32,"I")) "RTN","RARTE6",308,0) .W:RA3'="" !?1,"Pregnancy Screen: ",$S(RA3="y":"Patient answered yes",RA3="n":"Patient answered no",RA3="u":"Patient is unable to answer or is unsure",1:"") "RTN","RARTE6",309,0) .W:(RA3'="n")&($G(RAOUT(70.03,RAIENS,80,"I"))'="") !?1,"Pregnancy Screen Comment: ",$G(RAOUT(70.03,RAIENS,80,"I")) "RTN","RARTE6",310,0) ;p99 ends "RTN","RARTE6",311,0) W !,RAI "RTN","RARTE6",312,0) Q "RTN","RARTE6",313,0) LOCK(X,Y) ; Lock the data global "RTN","RARTE6",314,0) ; uses var DILOCKTM, code taken from rtn RAUTL12 "RTN","RARTE6",315,0) ; 'X' is the global root "RTN","RARTE6",316,0) ; 'Y' is the record number "RTN","RARTE6",317,0) N RALCKFLG,XY "RTN","RARTE6",318,0) S RADUZ=+$G(DUZ),RALCKFLG=0,XY=X_Y "RTN","RARTE6",319,0) ; "RTN","RARTE6",320,0) ;IHS/CMI/DAY - Patch 1004 - DILOCKTM not always defined "RTN","RARTE6",321,0) ;L +@(XY_")"):DILOCKTM "RTN","RARTE6",322,0) L +@(XY_")"):$G(DILOCKTM,3) "RTN","RARTE6",323,0) ;End Patch "RTN","RARTE6",324,0) ; "RTN","RARTE6",325,0) I '$T S RALCKFLG=1 D "RTN","RARTE6",326,0) . W !?5,"This record is being edited by another user." "RTN","RARTE6",327,0) . W !?5,"Try again later!",$C(7) "RTN","RARTE6",328,0) . Q "RTN","RARTE6",329,0) E D "RTN","RARTE6",330,0) . S ^TMP("RAD LOCKS",$J,RADUZ,X,Y)="" "RTN","RARTE6",331,0) . Q "RTN","RARTE6",332,0) Q RALCKFLG "RTN","RARTE6",333,0) INTRO ; "RTN","RARTE6",334,0) ;; +--------------------------------------------------------+ "RTN","RARTE6",335,0) I '$T S RALCKFLG=1 D "RTN","RARTE6",336,0) . W !?5,"This record is being edited by another user." "RTN","RARTE6",337,0) . W !?5,"Try again later!",$C(7) "RTN","RARTE6",338,0) . Q "RTN","RARTE6",339,0) E D "RTN","RARTE6",340,0) . S ^TMP("RAD LOCKS",$J,RADUZ,X,Y)="" "RTN","RARTE6",341,0) . Q "RTN","RARTE6",342,0) Q RALCKFLG "RTN","RARTE6",343,0) INTRO ; "RTN","RARTE6",344,0) ;; +--------------------------------------------------------+ "RTN","RARTE6",345,0) ;; | | "RTN","RARTE6",346,0) ;; | This option is for restoring a deleted report. | "RTN","RARTE6",347,0) ;; | | "RTN","RARTE6",348,0) ;; +--------------------------------------------------------+ "RTN","RARTR") 0^11^B65349154 "RTN","RARTR",1,0) RARTR ;HISC/CAH COLUMBIA/REB AISC/MJK,RMO-Queue/print Reports ; 06 Oct 2013 11:06 AM "RTN","RARTR",2,0) ;;5.0;Radiology/Nuclear Medicine;**5,13,16,27,43,55,75,92,99,1005**;Mar 16, 1998;Build 13 "RTN","RARTR",3,0) ;Supported IA #2056 reference to GET1^DIQ "RTN","RARTR",4,0) PRT ; Begin print/build of e-mail message "RTN","RARTR",5,0) ; "RTN","RARTR",6,0) ; ** NOTE: If the layout of this output is changed ** "RTN","RARTR",7,0) ; ** please check that routine RAO7PC3 is ** "RTN","RARTR",8,0) ; ** not affected. It assumes fixed format of ** "RTN","RARTR",9,0) ; ** the following headings: ** "RTN","RARTR",10,0) ; ** Clinical History: ** "RTN","RARTR",11,0) ; ** Report: ** "RTN","RARTR",12,0) ; ** Impression: ** "RTN","RARTR",13,0) ; ** Primary Diagnostic Code: ** "RTN","RARTR",14,0) ; ** Secondary Diagnostic Codes: ** "RTN","RARTR",15,0) ; ** Primary Interpreting Staff: ** "RTN","RARTR",16,0) ; "RTN","RARTR",17,0) Q:'$D(^RARPT(+$G(RARPT),0)) "RTN","RARTR",18,0) ; Use and Set if running in the foreground and Writing to the device "RTN","RARTR",19,0) I '$D(RAUTOE) D "RTN","RARTR",20,0) . U IO "RTN","RARTR",21,0) . S RAFFLF=IOF "RTN","RARTR",22,0) . S RAORIOF=RAFFLF "RTN","RARTR",23,0) ; "RTN","RARTR",24,0) W:$Y>0&('$D(RAUTOE)) @RAFFLF ; If RAUTOE defined build mail msg "RTN","RARTR",25,0) S X=$G(^RARPT(+$G(RARPT),0)) ; RAORIOF=RAFFLF "RTN","RARTR",26,0) ; "RTN","RARTR",27,0) ;S RAFFLF=$S('$D(ORACTION):RAFFLF,ORACTION'=8:RAFFLF,1:"!") "RTN","RARTR",28,0) D INIT ; setup exam/report variables "RTN","RARTR",29,0) ;start p99 "RTN","RARTR",30,0) ; "RTN","RARTR",31,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RARTR",32,0) ;I $$PTSEX^RAUTL8(RADFN)="F",'$D(RAUTOE) D "RTN","RARTR",33,0) I $$PTSEX^RAUTL8(RADFN)'="M",'$D(RAUTOE) D "RTN","RARTR",34,0) .; "RTN","RARTR",35,0) .N RA700332,RA700380 S RA700332=$$GET1^DIQ(70.03,$G(RACNI)_","_$G(RADTI)_","_$G(RADFN),32) "RTN","RARTR",36,0) .W:RA700332'="" !,"Pregnancy Screen: ",RA700332 "RTN","RARTR",37,0) .S RA700380=$$GET1^DIQ(70.03,$G(RACNI)_","_$G(RADTI)_","_$G(RADFN),80) "RTN","RARTR",38,0) .I (RA700332'="Patient answered no"),(RA700380'="") S RA700380="Pregnancy Screen Comment: "_RA700380 D OUTTEXT^RAUTL9(RA700380,"",1,75,"","!","") "RTN","RARTR",39,0) .W ! "RTN","RARTR",40,0) ;end of p99 "RTN","RARTR",41,0) I RAY0<0!(RAY1<0)!(RAY2<0)!(RAY3<0) K RAFFLF Q ; data nodes missing "RTN","RARTR",42,0) ; "RTN","RARTR",43,0) PRT1 I $D(RAUTOE) D "RTN","RARTR",44,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" " "RTN","RARTR",45,0) . I $D(RADDEN) D "RTN","RARTR",46,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Unverified by: "_$P($G(^VA(200,$S($G(RADUZ):RADUZ,1:DUZ),0)),"^") "RTN","RARTR",47,0) .. Q "RTN","RARTR",48,0) . Q "RTN","RARTR",49,0) I +$O(^RARPT(RARPT,"ERR",0)) D "RTN","RARTR",50,0) . S RAERRFLG="" ; set for future reference (display AMENRPT^RARTR text) "RTN","RARTR",51,0) . W:'$D(RAUTOE) !!?10,$$AMENRPT^RARTR2(),! "RTN","RARTR",52,0) . I $D(RAUTOE) D "RTN","RARTR",53,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" " "RTN","RARTR",54,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2() "RTN","RARTR",55,0) .. Q "RTN","RARTR",56,0) . Q "RTN","RARTR",57,0) I $P(RAY3,"^",25)<2 D G END:$D(RAOOUT) "RTN","RARTR",58,0) . D MODS^RAUTL2,OUT1^RARTR3 "RTN","RARTR",59,0) . D:+$P(RAY3,"^",28) RDIO^RARTUTL(+$P(RAY3,"^",28)) Q:$D(RAOOUT) "RTN","RARTR",60,0) . D:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",") "RTN","RARTR",61,0) . ;W:'$D(RAUTOE) ! "RTN","RARTR",62,0) . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",63,0) . Q "RTN","RARTR",64,0) I $P(RAY3,"^",25)>1 D "RTN","RARTR",65,0) . D MEMS1^RARTR3 "RTN","RARTR",66,0) . W:'$D(RAUTOE) ! "RTN","RARTR",67,0) . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",68,0) . Q "RTN","RARTR",69,0) G END:$D(RAOOUT) "RTN","RARTR",70,0) ; Check for duplicate history in file 70 and 74. "RTN","RARTR",71,0) D CHKDUPHX^RART1 ; Sets RADUPHX to 1 for duplicate or 0 if different. "RTN","RARTR",72,0) F RAP="H","AH","R","I" K ^UTILITY($J,"W"),^(1) D G END:$D(RAOOUT) "RTN","RARTR",73,0) . S RAP("P")=$S(RAP="H":"Clinical History:",RAP="AH":"Additional Clinical History:",RAP="R":"Report:",1:"Impression:") "RTN","RARTR",74,0) . ; Don't continue if printing Additional Clinical History and it is a "RTN","RARTR",75,0) . ; duplicate of Clinical History. "RTN","RARTR",76,0) . Q:RAP="AH"&(RADUPHX>0) "RTN","RARTR",77,0) . W:'$D(RAUTOE) !?RATAB,RAP("P") "RTN","RARTR",78,0) . I $D(RAUTOE),($D(RADDEN)),(RAP="R") D "RTN","RARTR",79,0) .. N RABAN1,RABAN2,RASPCE S $P(RASPCE," ",46)="" "RTN","RARTR",80,0) .. S RABAN1="*** Uncorrected Version ***" "RTN","RARTR",81,0) .. S RABAN2="*** Refer to final report ***" "RTN","RARTR",82,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",83,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN1 "RTN","RARTR",84,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN2 "RTN","RARTR",85,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",86,0) .. Q "RTN","RARTR",87,0) . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_RAP("P") "RTN","RARTR",88,0) . W:$D(RASTFL)&(RAP="R")&('$D(RAUTOE)) ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),"^",2)) "RTN","RARTR",89,0) . I RAP="R",($D(RAUTOE)) D "RTN","RARTR",90,0) .. S $P(RAP("S")," ",(46-$L(^TMP($J,"RA AUTOE",RAACNT))))="" "RTN","RARTR",91,0) .. I '$D(RADDEN) S ^TMP($J,"RA AUTOE",RAACNT)=^(RAACNT)_RAP("S")_"Status: "_$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),"^",2)) "RTN","RARTR",92,0) .. Q "RTN","RARTR",93,0) . D:$D(RAUTOE) SET^RARTR2 "RTN","RARTR",94,0) . D:'$D(RAUTOE) WRITE^RARTR2 Q:$D(RAOOUT) "RTN","RARTR",95,0) . K ^UTILITY($J,"W") "RTN","RARTR",96,0) . Q "RTN","RARTR",97,0) I $D(RADDEN),($G(^RARPT(RARPT,"PURGE"))) D "RTN","RARTR",98,0) . ; when the report is unverified and purge data exists (rpt adden) "RTN","RARTR",99,0) . N RAPRGE S RAPRGE=+$G(^RARPT(RARPT,"PURGE")) "RTN","RARTR",100,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",101,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Purged: "_$$FMTE^XLFDT(RAPRGE,"1P") "RTN","RARTR",102,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",103,0) . Q "RTN","RARTR",104,0) I $P($G(^RA(79.1,+$P(RAY2,U,4),0)),U,18)="Y" D PRTDX^RARTR1 G:$D(RAOOUT) END ;print dx codes "RTN","RARTR",105,0) D EN1^RARTR0 G:$D(RAOOUT) END "RTN","RARTR",106,0) I '$D(RAVERFND) D G END:$D(RAOOUT) "RTN","RARTR",107,0) . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD:($Y+RAFOOT+4)>IOSL "RTN","RARTR",108,0) . N RADFTSBN,RADFTSBT S:$D(RADDEN) RAVERF=+$P(RA74B4,"^",9) "RTN","RARTR",109,0) . S RADFTSBN=$E($P($G(^VA(200,RAVERF,20)),"^",2),1,25) "RTN","RARTR",110,0) . S:RADFTSBN']"" RADFTSBN=$E($P($G(^VA(200,RAVERF,0)),"^"),1,25) "RTN","RARTR",111,0) . S RADFTSBT=$E($P($G(^VA(200,RAVERF,20)),"^",3),1,30) "RTN","RARTR",112,0) . I RADFTSBT']"" S RADFTSBT=$$TITLE^RARTR0(RAVERF) "RTN","RARTR",113,0) . W:'$D(RAUTOE) !!,"VERIFIED BY:",!?2,$S(RADFTSBN]"":RADFTSBN,1:"") "RTN","RARTR",114,0) . W:RADFTSBT]""&('$D(RAUTOE)) ", "_RADFTSBT "RTN","RARTR",115,0) . I $D(RAUTOE) D "RTN","RARTR",116,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="VERIFIED BY:" "RTN","RARTR",117,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RADFTSBN]"":RADFTSBN,1:"")_$S(RADFTSBT]"":", "_RADFTSBT,1:"") "RTN","RARTR",118,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",119,0) .. Q "RTN","RARTR",120,0) . Q "RTN","RARTR",121,0) K RASBPN,RASBT,RASECIEN,RASECOND,RASECSS "RTN","RARTR",122,0) I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 G END:$D(RAOOUT) D HD:($Y+RAFOOT+4)>IOSL "RTN","RARTR",123,0) W:'$D(RAUTOE) !!,$S($D(^RABTCH(74.2,+RABTCH,0)):$P(^(0),"^"),1:""),"/" I +$G(^RARPT(RARPT,"T")),$D(^VA(200,+$P(^RARPT(RARPT,"T"),"^"),0)) W:'$D(RAUTOE) $P(^(0),"^",2) "RTN","RARTR",124,0) S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$P($G(^RABTCH(74.2,+RABTCH,0)),"^")_"/"_$S(+$G(^RARPT(RARPT,"T"))&($D(^VA(200,+$P($G(^RARPT(RARPT,"T")),"^"),0))):$P(^(0),"^",2),1:"") "RTN","RARTR",125,0) S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",126,0) D HANG^RARTR2 G END:$D(RAOOUT) "RTN","RARTR",127,0) I RAST'="V" D:'$D(RAMDV) SETDIV^RARTR2 I $P(RAMDV,U,25) D WARNING^RARTR1 "RTN","RARTR",128,0) G PEND:RAST'="PD" "RTN","RARTR",129,0) S $P(RASTRSK,"*",80)="" "RTN","RARTR",130,0) I '$D(RAUTOE) D "RTN","RARTR",131,0) . D HD:($Y+RAFOOT+9)>IOSL "RTN","RARTR",132,0) . W !,$E(RASTRSK,1,22)," P R O B L E M S T A T E M E N T ",$E(RASTRSK,1,22) "RTN","RARTR",133,0) . W !!,$S($D(^RARPT(RARPT,"P")):^("P"),1:"None entered.") W !!,RASTRSK "RTN","RARTR",134,0) . Q "RTN","RARTR",135,0) E D "RTN","RARTR",136,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$E(RASTRSK,1,22)_" P R O B L E M S T A T E M E N T "_$E(RASTRSK,1,22) "RTN","RARTR",137,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$S($D(^RARPT(RARPT,"P")):^("P"),1:"None entered.") "RTN","RARTR",138,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",139,0) . Q "RTN","RARTR",140,0) PEND D FOOT^RARTR2,HANG^RARTR2 D:'$D(RAMIE)&('$D(RAUTOE)) Q^RAFLH1 "RTN","RARTR",141,0) END K:$D(RAOOUT) XQAID,XQAKILL "RTN","RARTR",142,0) K %I,%W,%Y1,C,DN,I,RADXCODE,RARTMES,RAVERF,RAVERFND,RAPVERF "RTN","RARTR",143,0) K RAVERS,RAFOOT,RAY0,RAY1,RAY2,RAY3,RALOC,RAFMT,RAMOD,RASTFL,RALB,RALBR "RTN","RARTR",144,0) K RALBRT,RALBS,RALBST,RAV,RAP,RATAB,RAXX,VAL,VAR,RADFN,RADTI,RACN,RADTE "RTN","RARTR",145,0) K RARPT,RAHDFM,RAFTFM,RAV,RAIOF,RABTCH,RAOOUT,RAPIR,RAPIS,VAERR,Z "RTN","RARTR",146,0) ; K RASTRSK S RAFFLF=RAORIOF K RAORIOF,RAFFLF,RAERRFLG "RTN","RARTR",147,0) ; 05/15/08 BAY/KAM Patch RA*5*92 Added Conditional Kill to next line "RTN","RARTR",148,0) ; to support an AMIE interface (IA 708) "RTN","RARTR",149,0) K RASTRSK,RAORIOF,RAFFLF,RAERRFLG K:'($D(RAMIE)#2) DFN "RTN","RARTR",150,0) ;the next kill line corrects the CPRS V27 report display issue when repeated "RTN","RARTR",151,0) ;on same patient P92 "RTN","RARTR",152,0) K %,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,RAACNT,RADUPHX,RANUM,RAREZON,RAST "RTN","RARTR",153,0) Q "RTN","RARTR",154,0) Q ; Queue the report "RTN","RARTR",155,0) S ZTDTH=$H,ZTRTN="DQ^RARTR",ZTSAVE("RARPT")="" S:$D(RARTMES) ZTSAVE("RARTMES")="" "RTN","RARTR",156,0) D ZIS^RAUTL Q:RAPOP "RTN","RARTR",157,0) ; "RTN","RARTR",158,0) DQ S U="^",X="T",%DT="" D ^%DT K %DT S DT=Y G PRT "RTN","RARTR",159,0) ; "RTN","RARTR",160,0) INIT ; initialize exam/report variables "RTN","RARTR",161,0) ; main variables set: "RTN","RARTR",162,0) ; RAY0: zero node data from the Patient File (2) "RTN","RARTR",163,0) ; RAY1: zero node data from the Rad/Nuc Med Patient File (70) "RTN","RARTR",164,0) ; RAY2: Registered Exams (70.02) zero node data "RTN","RARTR",165,0) ; RAY3: Examinations (70.03) zero node data "RTN","RARTR",166,0) S (RAY0,RAY1,RAY2,RAY3)=-1 ; error condition, if no data nodes "RTN","RARTR",167,0) S RADFN=+$P(X,"^",2),RADTE=+$P(X,"^",3),RADTI=(9999999.9999-RADTE) "RTN","RARTR",168,0) S RACN=+$P(X,"^",4),RAST=$P(X,"^",5),RATAB=5 "RTN","RARTR",169,0) S:'$D(RABTCH) RABTCH=0 S (DIWL,DIWF)=0 "RTN","RARTR",170,0) Q:'$D(^RADPT(RADFN,0)) S RANUM=1,RAY1=^(0) "RTN","RARTR",171,0) Q:'$D(^DPT(RADFN,0)) S RAY0=^(0) "RTN","RARTR",172,0) Q:'$D(^RADPT(RADFN,"DT",RADTI,0)) S RAY2=^(0) "RTN","RARTR",173,0) S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) "RTN","RARTR",174,0) S (RAY3,RALB)=$S($D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0)):^(0),1:-1) "RTN","RARTR",175,0) Q:RAY3<0 ; examinations data missing "RTN","RARTR",176,0) ; "RTN","RARTR",177,0) S (RAHDFM,RAFTFM)=1 S:$D(^RA(79.1,+$P(RAY2,"^",4),0)) RAHDFM=^(0),RAFTFM=+$P(RAHDFM,"^",13),DIWL=$P(RAHDFM,"^",14),DIWF=$P(RAHDFM,"^",15),RAHDFM=+$P(RAHDFM,"^",12) S RAFOOT=$S($D(^RA(78.2,RAFTFM,0)):+$P(^(0),"^",2),1:0) "RTN","RARTR",178,0) S:'DIWL DIWL=5 S:'DIWF DIWF=70 S DIWF="WC"_(DIWF-DIWL) "RTN","RARTR",179,0) G @$S($D(RAUTOE):"HEAD^RARTR0",1:"HD1") "RTN","RARTR",180,0) Q "RTN","RARTR",181,0) ; "RTN","RARTR",182,0) HD D FOOT^RARTR2:$E(IOST,1,2)'="C-" "RTN","RARTR",183,0) HD1 S RAFMT=RAHDFM I $D(RARTMES) W:$Y>0 @RAFFLF W !,?((80-$L(RARTMES))/2),RARTMES,! S RAIOF=RAFFLF,RAFFLF="!" "RTN","RARTR",184,0) I '$D(RARTMES) W:$Y>0 @RAFFLF "RTN","RARTR",185,0) D PRT^RAFLH S:$D(RARTMES) RAFFLF=RAIOF "RTN","RARTR",186,0) W:$D(RAERRFLG) !!?10,$$AMENRPT^RARTR2(),!! "RTN","RARTR",187,0) Q "RTN","RARTR0") 0^12^B73964399 "RTN","RARTR0",1,0) RARTR0 ;HISC/GJC-Queue/Print Radiology Rpts utility routine. ; 06 Oct 2013 11:06 AM "RTN","RARTR0",2,0) ;;5.0;Radiology/Nuclear Medicine;**8,26,74,84,99,1003,1005**;Nov 01, 2010;Build 13 "RTN","RARTR0",3,0) ; 06/28/2006 BAY/KAM Remedy Call 146291 - Change Patient Age to DOB "RTN","RARTR0",4,0) ; "RTN","RARTR0",5,0) ;Integration Agreements "RTN","RARTR0",6,0) ;---------------------- "RTN","RARTR0",7,0) ;DT^DILF(2054); GETS^DIQ(2056); $$FMTE^XLFDT(10103); $$UP^XLFSTR(10104); ^DIWP(10011) "RTN","RARTR0",8,0) ;NEW PERSON file read w/FM (10060) "RTN","RARTR0",9,0) ; "RTN","RARTR0",10,0) EN1 ; Called from RARTR ;P84 GETS^DIQ added... "RTN","RARTR0",11,0) S RARPT(0)=$G(^RARPT(+$G(RARPT),0)) Q:RARPT(0)']"" "RTN","RARTR0",12,0) S RARPT(10)=$P(RARPT(0),"^",10) "RTN","RARTR0",13,0) S RAVERF=+$P(RARPT(0),U,9),RAPVERF=+$P(RARPT(0),U,13) "RTN","RARTR0",14,0) K RAPIR,RAPIS S RAPIR=+$P(RALB,"^",12),RAPIS=+$P(RALB,"^",15) "RTN","RARTR0",15,0) ;format of the RAPIR/RAPIS arrays: P84 logic "RTN","RARTR0",16,0) ;RAPI*=IEN file 200 "RTN","RARTR0",17,0) ;RAPI*(200,RAPI*,.01)= NAME (required) "RTN","RARTR0",18,0) ;RAPI*(200,RAPI*,20.2) = SIGNATURE BLOCK PRINTED NAME (if any) "RTN","RARTR0",19,0) ;RAPI*(200,RAPI*,20.3) = SIGNATURE BLOCK TITLE (if any) "RTN","RARTR0",20,0) I RAPIR D GETS^DIQ(200,RAPIR,".01;20.2;20.3","","RAPIR") S RAPIR("IENS")=RAPIR_"," "RTN","RARTR0",21,0) I RAPIS D GETS^DIQ(200,RAPIS,".01;20.2;20.3","","RAPIS") S RAPIS("IENS")=RAPIS_"," "RTN","RARTR0",22,0) S RAWHOVER=+$P(RARPT(0),"^",17) "RTN","RARTR0",23,0) I RAVERF,((RAPIR=RAVERF)!(RAPIS=RAVERF)) D "RTN","RARTR0",24,0) . S RAVERFND="" ; Set verifier found flag "RTN","RARTR0",25,0) . Q "RTN","RARTR0",26,0) I RAPIS D Q:$D(RAOOUT) "RTN","RARTR0",27,0) . ;get signature block name if defined "RTN","RARTR0",28,0) . S RALBS=$E(RAPIS(200,RAPIS("IENS"),20.2),1,25) "RTN","RARTR0",29,0) . S:RALBS="" RALBS=$E(RAPIS(200,RAPIS("IENS"),.01),1,25) ;default to NAME "RTN","RARTR0",30,0) . ; "RTN","RARTR0",31,0) . ;get signature block title if defined "RTN","RARTR0",32,0) . S RALBST=$G(RAPIS(200,RAPIS("IENS"),20.3)) ; max: 50 chars "RTN","RARTR0",33,0) . S:RALBST="" RALBST=$$TITLE^RARTR0(RAPIS) "RTN","RARTR0",34,0) . ; "RTN","RARTR0",35,0) . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) "RTN","RARTR0",36,0) . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL "RTN","RARTR0",37,0) . I '$D(RAUTOE) D "RTN","RARTR0",38,0) .. W !,"Primary Interpreting Staff:",!?2,$S(RALBS]"":RALBS,1:"Unknown") "RTN","RARTR0",39,0) .. W:$L(RALBST) ", "_$E(RALBST,1,((IOM-$X)-16)) "RTN","RARTR0",40,0) .. ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING "RTN","RARTR0",41,0) .. Q "RTN","RARTR0",42,0) . E D "RTN","RARTR0",43,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Staff:" "RTN","RARTR0",44,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RALBS]"":RALBS,1:"Unknown") "RTN","RARTR0",45,0) .. Q:'$L(RALBST) N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT)) "RTN","RARTR0",46,0) .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBST,1,((80-RALEN)-16)) "RTN","RARTR0",47,0) .. Q "RTN","RARTR0",48,0) . I $D(RAVERFND)&(RAPIS=RAVERF),(RAPIS(200,RAPIS("IENS"),.01)'="RADIOLOGY,OUTSIDE SERVICE") D "RTN","RARTR0",49,0) .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q "RTN","RARTR0",50,0) ... W:RAWHOVER=RAPIS !?10,"(Verifier, no e-sig)" "RTN","RARTR0",51,0) ... ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist "RTN","RARTR0",52,0) ... ;Other verifier may not be a transcriptionist "RTN","RARTR0",53,0) ... ;W:RAWHOVER'=RAPIS !?10,"Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D." "RTN","RARTR0",54,0) ... W:RAWHOVER'=RAPIS !?5,"Verified by ",$$GET1^DIQ(200,+RAWHOVER,.01)," for "_RALBS ;Removed RA*5*8 _", M.D." "RTN","RARTR0",55,0) ... ;End Patch "RTN","RARTR0",56,0) ... Q "RTN","RARTR0",57,0) .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q "RTN","RARTR0",58,0) ... S:RAWHOVER=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)" "RTN","RARTR0",59,0) ... ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist "RTN","RARTR0",60,0) ... ;Other verifier may not be a transcriptionist "RTN","RARTR0",61,0) ... ;S:RAWHOVER'=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D." "RTN","RARTR0",62,0) ... S:RAWHOVER'=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by "_$$GET1^DIQ(200,+RAWHOVER,.01)_" for "_RALBS ;Removed RA*5*8 _", M.D." "RTN","RARTR0",63,0) ... ;End Patch "RTN","RARTR0",64,0) ... Q "RTN","RARTR0",65,0) .. W:'$D(RAUTOE) " (Verifier)" "RTN","RARTR0",66,0) .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)" "RTN","RARTR0",67,0) .. Q "RTN","RARTR0",68,0) . I RAPIS=RAPVERF,'$D(RAUTOE) W " (Pre-Verifier)" "RTN","RARTR0",69,0) . I RAPIS=RAPVERF,$D(RAUTOE) S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)" "RTN","RARTR0",70,0) . Q "RTN","RARTR0",71,0) D SECSTF^RARTR1 Q:$D(RAOOUT) ; Print secondary interp'ting staff now "RTN","RARTR0",72,0) ;now for primary resident definitions... "RTN","RARTR0",73,0) I RAPIR D Q:$D(RAOOUT) "RTN","RARTR0",74,0) . ;get signature block name if defined "RTN","RARTR0",75,0) . S RALBR=$E(RAPIR(200,RAPIR("IENS"),20.2),1,25) "RTN","RARTR0",76,0) . S:RALBR="" RALBR=$E(RAPIR(200,RAPIR("IENS"),.01),1,25) ;default to NAME "RTN","RARTR0",77,0) . ; "RTN","RARTR0",78,0) . ;get signature block title if defined "RTN","RARTR0",79,0) . S RALBRT=$G(RAPIR(200,RAPIR("IENS"),20.3)) ; max: 50 chars "RTN","RARTR0",80,0) . S:RALBRT="" RALBRT=$$TITLE^RARTR0(RAPIR) "RTN","RARTR0",81,0) . ; "RTN","RARTR0",82,0) . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) "RTN","RARTR0",83,0) . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL "RTN","RARTR0",84,0) . I '$D(RAUTOE) D "RTN","RARTR0",85,0) .. W !,"Primary Interpreting Resident:",!?2,$S(RALBR]"":RALBR,1:"Unknown") "RTN","RARTR0",86,0) .. W:$L(RALBRT) ", "_$E(RALBRT,1,((IOM-$X)-16)) "RTN","RARTR0",87,0) .. Q "RTN","RARTR0",88,0) . I $D(RAUTOE) D "RTN","RARTR0",89,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Resident:" "RTN","RARTR0",90,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RALBR]"":RALBR,1:"Unknown") "RTN","RARTR0",91,0) .. Q:'$L(RALBRT) N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT)) "RTN","RARTR0",92,0) .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBRT,1,((80-RALEN)-16)) "RTN","RARTR0",93,0) .. Q "RTN","RARTR0",94,0) . I $D(RAVERFND)&(RAPIR=RAVERF) D "RTN","RARTR0",95,0) .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q "RTN","RARTR0",96,0) ... W:RAWHOVER=RAPIR !?10,"(Verifier, no e-sig)" "RTN","RARTR0",97,0) ... ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist "RTN","RARTR0",98,0) ... ;Other verifier may not be a transcriptionist "RTN","RARTR0",99,0) ... ;W:RAWHOVER'=RAPIR !?10,"Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D." "RTN","RARTR0",100,0) ... W:RAWHOVER'=RAPIR !?5,"Verified by ",$$GET1^DIQ(200,+RAWHOVER,.01)," for "_RALBR ;Removed RA*5*8 _", M.D." "RTN","RARTR0",101,0) ... ;End Patch "RTN","RARTR0",102,0) ... Q "RTN","RARTR0",103,0) .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q "RTN","RARTR0",104,0) ... S:RAWHOVER=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)" "RTN","RARTR0",105,0) ... ;IHS/BJI/DAY - Patch 1003 - display verifier if not Radiologist "RTN","RARTR0",106,0) ... ;Other verifier may not be a transcriptionist "RTN","RARTR0",107,0) ... ;S:RAWHOVER'=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D." "RTN","RARTR0",108,0) ... S:RAWHOVER'=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by "_$$GET1^DIQ(200,+RAWHOVER,.01)_" for "_RALBR ;Removed RA*5*8 _", M.D." "RTN","RARTR0",109,0) ... ;End Patch "RTN","RARTR0",110,0) ... Q "RTN","RARTR0",111,0) .. W:'$D(RAUTOE) " (Verifier)" "RTN","RARTR0",112,0) .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)" "RTN","RARTR0",113,0) .. Q "RTN","RARTR0",114,0) . I RAPIR=RAPVERF,('$D(RAUTOE)) W " (Pre-Verifier)" "RTN","RARTR0",115,0) . I RAPIR=RAPVERF,($D(RAUTOE)) S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)" "RTN","RARTR0",116,0) . Q "RTN","RARTR0",117,0) D SECRES^RARTR1 ; Print out secondary interp'ting resident now "RTN","RARTR0",118,0) K RAPIR,RAPIS ;P84 kills added "RTN","RARTR0",119,0) Q "RTN","RARTR0",120,0) ; "RTN","RARTR0",121,0) TITLE(X) ;Return the radiology classification in lieu of the signature block title "RTN","RARTR0",122,0) ; 'X' is the IEN of the Primary Interpreting Resident i.e, ^DD(70.03,12 "RTN","RARTR0",123,0) ; -OR- "RTN","RARTR0",124,0) ; 'X' is the IEN of the Primary Interpreting Staff i.e, ^DD(70.03,15 "RTN","RARTR0",125,0) Q $S($D(^VA(200,"ARC","R",X)):"Resident Physician",$D(^VA(200,"ARC","S",X)):"Staff Physician",1:"") "RTN","RARTR0",126,0) ; "RTN","RARTR0",127,0) HEAD ; Set up header info for e-mail message (called from INIT^RARTR) "RTN","RARTR0",128,0) ; 06/28/2006 BAY/KAM Remedy Call 146291 Change Patient Age to DOB "RTN","RARTR0",129,0) N RAGE,RATPHY,RACSE,RAILOC,RANME,RAPRIPHY,RAPTLOC,RAREQPHY,RASERV,RASEX,RADOB "RTN","RARTR0",130,0) N RASPACE,RASSN,X1,X2 S:'$D(RAACNT) RAACNT=0 "RTN","RARTR0",131,0) ;Added next line for Remedy Call 146291 "RTN","RARTR0",132,0) D DT^DILF("E",$P(RAY0,"^",3),.RADOB) ;Get Date of Birth/External Fmt "RTN","RARTR0",133,0) ; "RTN","RARTR0",134,0) S RANME=$P(RAY0,"^"),RASSN=$P(RAY0,"^",9) "RTN","RARTR0",135,0) S RASEX=$$UP^XLFSTR($P(RAY0,"^",2)) "RTN","RARTR0",136,0) S RACSE=$P($G(^RARPT(RARPT,0)),"^")_"@"_$P($$FMTE^XLFDT($P(RAY2,"^")),"@",2) "RTN","RARTR0",137,0) ; Remedy Call 146291 Removed line calculating age "RTN","RARTR0",138,0) S RAREQPHY=$$XTERNAL^RAUTL5($P(RAY3,"^",14),$P($G(^DD(70.03,14,0)),"^",2)) "RTN","RARTR0",139,0) S RAPTLOC=$$PTLOC^RAUTL12() S:RAREQPHY']"" RAREQPHY="Unknown" "RTN","RARTR0",140,0) S RASERV=$$XTERNAL^RAUTL5($P(RAY3,"^",7),$P($G(^DD(70.03,7,0)),"^",2)) "RTN","RARTR0",141,0) S RATPHY=$$ATND^RAUTL5(RADFN,DT),RAPRIPHY=$$PRIM^RAUTL5(RADFN,DT) "RTN","RARTR0",142,0) S RAILOC=$$XTERNAL^RAUTL5($P(RAY2,"^",4),$P($G(^DD(70.02,4,0)),"^",2)) "RTN","RARTR0",143,0) S:RAILOC']"" RAILOC="Unknown" S:RASERV']"" RASERV="Unknown" "RTN","RARTR0",144,0) S RANME=$E(RANME,1,20)_" " "RTN","RARTR0",145,0) ;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler 2003 patch "RTN","RARTR0",146,0) ;Use standard call for SSN, and remove SSN formatting "RTN","RARTR0",147,0) ;S RASSN=$E(RASSN,1,3)_"-"_$E(RASSN,4,5)_"-"_$E(RASSN,6,9)_" " "RTN","RARTR0",148,0) S RASSN=$$SSN^RAUTL,RASSN=RASSN_" " "RTN","RARTR0",149,0) ;End Patch "RTN","RARTR0",150,0) ; Remedy Call 146291 Changed next line to use RADOB(0) "RTN","RARTR0",151,0) S RAGE="DOB-"_$G(RADOB(0))_" "_$S(RASEX="F":"F",RASEX="M":"M",1:"UNK") "RTN","RARTR0",152,0) S $P(RASPACE," ",(22-$L(RAGE)))="" "RTN","RARTR0",153,0) S RAGE=RAGE_RASPACE,RACSE="Case: "_RACSE "RTN","RARTR0",154,0) S RAREQPHY="Req Phys: "_$E(RAREQPHY,1,28) "RTN","RARTR0",155,0) S RASPACE="",$P(RASPACE," ",(42-$L(RAREQPHY)))="" "RTN","RARTR0",156,0) S RAREQPHY=RAREQPHY_RASPACE "RTN","RARTR0",157,0) S RAPTLOC="Pat Loc: "_$S(RAPTLOC]"":$E(RAPTLOC,1,30),1:"Unknown") "RTN","RARTR0",158,0) S RATPHY="Att Phys: "_$E(RATPHY,1,28) "RTN","RARTR0",159,0) S RASPACE="",$P(RASPACE," ",(42-$L(RATPHY)))="" "RTN","RARTR0",160,0) S RATPHY=RATPHY_RASPACE "RTN","RARTR0",161,0) S RAILOC="Img Loc: "_$E(RAILOC,1,30) "RTN","RARTR0",162,0) S RAPRIPHY="Pri Phys: "_$E(RAPRIPHY,1,28) "RTN","RARTR0",163,0) S RASPACE="",$P(RASPACE," ",(42-$L(RAPRIPHY)))="" "RTN","RARTR0",164,0) S RAPRIPHY=RAPRIPHY_RASPACE "RTN","RARTR0",165,0) S RASERV="Service: "_$E(RASERV,1,30) "RTN","RARTR0",166,0) S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RANME_RASSN_RAGE_RACSE "RTN","RARTR0",167,0) S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAREQPHY_RAPTLOC "RTN","RARTR0",168,0) S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RATPHY_RAILOC "RTN","RARTR0",169,0) S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAPRIPHY_RASERV "RTN","RARTR0",170,0) ;p99: get pt sex, add pregnancy screen and pregnancy screen comment "RTN","RARTR0",171,0) ; "RTN","RARTR0",172,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RARTR0",173,0) ;I $$PTSEX^RAUTL8(RADFN)="F",$D(RAY3) D "RTN","RARTR0",174,0) I $$PTSEX^RAUTL8(RADFN)'="M",$D(RAY3) D "RTN","RARTR0",175,0) .; "RTN","RARTR0",176,0) .Q:RAY3<0 "RTN","RARTR0",177,0) .N RAPCOMM,RA32PSC,DIWF,DIWL,DIWR,X S RAPCOMM=$G(^RADPT(RADFN,"DT",+$G(RADTI),"P",+$G(RACNI),"PCOMM")) "RTN","RARTR0",178,0) .S:$P(RAY3,U,32)'="" ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Pregnancy Screen: "_$S($P(RAY3,"^",32)="y":"Patient answered yes",$P(RAY3,"^",32)="n":"Patient answered no",$P(RAY3,"^",32)="u":"Patient is unable to answer or is unsure",1:"") "RTN","RARTR0",179,0) .I ($P(RAY3,U,32)'="n"),$L(RAPCOMM) D "RTN","RARTR0",180,0) ..S DIWF="",DIWL=3,DIWR=75,X="Pregnancy Screen Comment: "_RAPCOMM K ^UTILITY($J,"W") D ^DIWP "RTN","RARTR0",181,0) ..F RA32PSC=0:0 S RA32PSC=$O(^UTILITY($J,"W",3,RA32PSC)) Q:RA32PSC'>0 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=^UTILITY($J,"W",3,RA32PSC,0) "RTN","RARTR0",182,0) ..K ^UTILITY($J,"W") "RTN","RARTR0",183,0) S:$D(RAERRFLG) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2() "RTN","RARTR0",184,0) S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR0",185,0) Q "RTN","RASTED") 0^13^B56315958 "RTN","RASTED",1,0) RASTED ;HISC/CAH,FPT,GJC,SS AISC/TMP,TAC,RMO-Edits for status tracking ; 06 Oct 2013 11:06 AM "RTN","RASTED",2,0) ;;5.0;Radiology/Nuclear Medicine;**1,10,18,28,45,71,82,99,1005**;Mar 16, 1998;Build 13 "RTN","RASTED",3,0) ;last modif by SS for P18 JUN 19,2000 "RTN","RASTED",4,0) ;02/10/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R "RTN","RASTED",5,0) ; *** 'RASTED' is called from the routine; 'CASE^RASTEXT1'. *** "RTN","RASTED",6,0) ;last modification by SS May 12,2000 "RTN","RASTED",7,0) ; "RTN","RASTED",8,0) ;Supported IA #10040 reference to ^SC "RTN","RASTED",9,0) ;Supported IA #1367 reference to LKUP^XPDKEY "RTN","RASTED",10,0) ;Supported IA #2056 reference to GET1^DIQ "RTN","RASTED",11,0) ;Supported IA #10060 reference to ^VA(200 "RTN","RASTED",12,0) S RAL=X F I2=1:1 S X=$P(RAL,",",I2) Q:X="" S RAVW="" W !!,"Case # being tracked: ",X D SEL^RACNLU D:'RACNT KEY D START:RACNT&((X'="^")&(X'="")) "RTN","RASTED",13,0) K RAL,RAI,RAPRI,I2,I3,RAVW,RAEND,RANME,RAPRC,RARPT,RADTE,RADT0,RANEXT,RANXT72,RASK,RACN,RACN0,RADFN,RADUZ,RAPOP,RAST,RAST0,RAFL,RAFST,RAIX,RASSN,RACOMP,X Q "RTN","RASTED",14,0) ;RACOMP defined if [RA STATUS CHANGE] was processed completely "RTN","RASTED",15,0) START F I3=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",I3)=$P(Y,"^",I3) "RTN","RASTED",16,0) I '$D(^RA(72,+RAST,0)) W $C(7),"Invalid status for case #: ",RACN R X:3 Q "RTN","RASTED",17,0) S RAST0=^RA(72,+RAST,0) I $P(RAST0,"^",3)=9 W $C(7),!,"Exam is already complete!!" R X:3 Q "RTN","RASTED",18,0) S X1="" "RTN","RASTED",19,0) I $D(^RA(72,+$P(RAST0,"^",2),0)) S RANEXT=^(0),RASK=$S($D(^(.2)):^(.2),1:""),RANXT72=+$P(RAST0,"^",2) "RTN","RASTED",20,0) NEXT I '$D(RANEXT) S DIC("A")="Enter Next Status: ",DIC="^RA(72,",DIC(0)="AEFQZ",DIC("S")="I $P(^(0),U,3),$P(^(0),U,7)=$O(^RA(79.2,""B"",RAIMGTY,0))" D ^DIC K DIC Q:Y'>0 S RANEXT=Y(0),RASK=$S($D(^RA(72,+Y,.2)):^(.2),1:""),RANXT72=+Y "RTN","RASTED",21,0) I $P(RANEXT,"^")=$P(RAST0,"^") W $C(7),!,"Status has already been set to ",$P(RANEXT,"^") R X:3 Q "RTN","RASTED",22,0) I $$LKUP^XPDKEY(+$P(RANEXT,"^",4))]"",'$D(^XUSEC($$LKUP^XPDKEY(+$P(RANEXT,"^",4)),DUZ)) W $C(7),!,"You are not authorized to change to this status" R X:3 Q "RTN","RASTED",23,0) ; check if next status has order field filled in "RTN","RASTED",24,0) G:$P(RANEXT,U,3)]"" OK2 "RTN","RASTED",25,0) N RANXTIEN,RALINE S RANXTIEN=$P(RAST0,U,2),$P(RALINE,"_",50)="" "RTN","RASTED",26,0) W !!?15,$C(7),RALINE "RTN","RASTED",27,0) W !!?15,$C(7),"Default Next Status (",$P(RANEXT,U),") is *NOT* active.",!?15,$C(7),RALINE,! "RTN","RASTED",28,0) NXT S RANXTIEN=$P(^RA(72,RANXTIEN,0),U,2) "RTN","RASTED",29,0) G:$P($G(^RA(72,+RANXTIEN,0)),U,3)=9 OK0 ;next default status is COMPLETE "RTN","RASTED",30,0) G:RANXTIEN="" BAD ;no next default status pointer "RTN","RASTED",31,0) G:'$D(^RA(72,RANXTIEN,0)) BAD ;no next default status record "RTN","RASTED",32,0) G:$P($G(^RA(72,RANXTIEN,0)),U,3)="" NXT ;no order data, so loop back "RTN","RASTED",33,0) G OK0 "RTN","RASTED",34,0) BAD W !?15,$C(7),RALINE "RTN","RASTED",35,0) W !!?18,$C(7),"There is no valid higher status to advance to.",!?15,$C(7),RALINE "RTN","RASTED",36,0) KEY W !! K DIR S DIR(0)="E",DIR("A")="Press Return key to continue " D ^DIR "RTN","RASTED",37,0) K DIR,DIRUT,DUOUT Q "RTN","RASTED",38,0) OK0 S RANEXT=$G(^RA(72,RANXTIEN,0)),RANXT72=RANXTIEN "RTN","RASTED",39,0) OK1 W !?15,$C(7),RALINE,!!?18,"Next valid status is : ",$P(RANEXT,U),!?15,$C(7),RALINE "RTN","RASTED",40,0) OK2 S RADT0=^RADPT(RADFN,"DT",RADTI,0),RACN0=^("P",RACNI,0),RACS=$P(RACN0,"^",24),RAPRIT=$P(RACN0,"^",2) "RTN","RASTED",41,0) CHANGE W !!,"Name: ",RANME,?40,"Case # : ",RACN,!,"Division : ",$S($D(^DIC(4,+$P(RADT0,"^",3),0)):$P(^(0),"^"),1:"") "RTN","RASTED",42,0) W ?40,"Location: ",$S('$D(^RA(79.1,+$P(RADT0,"^",4),0)):"",$D(^SC(+^(0),0)):$P(^(0),"^"),1:"") "RTN","RASTED",43,0) W !,"Procedure: ",RAPRC "RTN","RASTED",44,0) D PRCCPT^RAPROD "RTN","RASTED",45,0) ; "RTN","RASTED",46,0) ;p99: get sex and display pregnancy data if available for female pt. "RTN","RASTED",47,0) ; "RTN","RASTED",48,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RASTED",49,0) ;I $$PTSEX^RAUTL8(RADFN)="F" D "RTN","RASTED",50,0) I $$PTSEX^RAUTL8(RADFN)'="M" D "RTN","RASTED",51,0) .; "RTN","RASTED",52,0) .N RAORD0,RAPCOMM S RAORD0=$P(RACN0,U,11) "RTN","RASTED",53,0) .S RAPCOMM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCOMM")) "RTN","RASTED",54,0) .W !,"PREGNANT AT TIME OF ORDER ENTRY: ",?22,$$GET1^DIQ(75.1,RAORD0_",",13) "RTN","RASTED",55,0) .W:$P(RACN0,U,32)'="" !,"PREGNANCY SCREEN: ",$S($P(RACN0,"^",32)="y":"Patient answered yes",$P(RACN0,"^",32)="n":"Patient answered no",$P(RACN0,"^",32)="u":"Patient is unable to answer or is unsure",1:"") "RTN","RASTED",56,0) .W:$P(RACN0,U,32)'="n"&$L(RAPCOMM) !,"PREGNANCY SCREEN COMMENT: ",RAPCOMM "RTN","RASTED",57,0) ;end p99 "RTN","RASTED",58,0) W !," ***** Old Status: ",$P(RAST0,"^"),!," ***** New Status: ",$P(RANEXT,"^") "RTN","RASTED",59,0) I RAPRC="Unknown" W !!?5,$C(7),"This record is corrupted -- the procedure is missing,",!?5,"please contact your ADPAC or IRM",! K DIR S DIR(0)="E",DIR("A")="Press RETURN to Continue" D ^DIR K DIR,DIROUT,DIRUT,DTOUT,DUOUT Q "RTN","RASTED",60,0) ASK R !,"Do you wish to continue? YES// ",X1:DTIME S:X1="" X1="Y" Q:'$T!(X1["^")!("nN"[X1) "RTN","RASTED",61,0) I X1["?" W !!,"Answer 'Yes' or 'No'.",! G ASK "RTN","RASTED",62,0) S RADUZ=DUZ I '$P(RAMDV,"^",6)!($P(RASK,"^",11)["Y") S RAPOP=0 D USER Q:RAPOP "RTN","RASTED",63,0) N RAPRTSET,RAMEMARR D EN2^RAUTL20(.RAMEMARR) ;is this a print set ? "RTN","RASTED",64,0) N RAWHICH,RAREM,RABEFORE,RAAFTER "RTN","RASTED",65,0) S DIE("NO^")="BACKOUTOK",DR="[RA STATUS CHANGE]" "RTN","RASTED",66,0) S DA=RADFN,RADADA=RADTI,DIE="^RADPT(",RADIE="^RADPT("_RADFN_",""DT""," "RTN","RASTED",67,0) S RAXIT=$$LOCK^RAUTL12(RADIE,RADADA) Q:RAXIT "RTN","RASTED",68,0) ; "RTN","RASTED",69,0) ;save 'before' CM data value to compare against the possible 'after' "RTN","RASTED",70,0) ;value "RTN","RASTED",71,0) D TRK70CMB^RAMAINU(RADFN,RADTI,RACNI,.RATRKCMB) ;RA*5*45 "RTN","RASTED",72,0) ; "RTN","RASTED",73,0) D SVBEFOR^RAO7XX(RADFN,RADTI,RACNI) ;P18 save before edit to compare later "RTN","RASTED",74,0) K RACOMP D ^DIE "RTN","RASTED",75,0) ;P18. $D(RABEFORE)=0 means that RASTREQ was not run - the user has interrupted input or timeout happened. So we must call it, then check result (is status changed) and if so - update 70.03 #3 and set RA70033=X "RTN","RASTED",76,0) I '$D(RABEFORE) K DA S X=RANXT72 D:X ^RASTREQ I $D(X)#2 S RA70033=X D U70033^RADD3(RADFN,RADTI,RACNI,X) "RTN","RASTED",77,0) ; "RTN","RASTED",78,0) ;1) check data consistency between 'CONTRAST MEDIA USED' & 'CONTRAST "RTN","RASTED",79,0) ;MEDIA' "RTN","RASTED",80,0) ;2) check 'before' CM data against 'after' CM data, file in audit log "RTN","RASTED",81,0) ;if necessary. Remember, contrast media asked when in input template: "RTN","RASTED",82,0) ;RA EXAM EDIT (RA*5*45) "RTN","RASTED",83,0) S RACMDA=RACNI,RACMDA(1)=RADTI,RACMDA(2)=RADFN "RTN","RASTED",84,0) D XCMINTEG^RAMAINU1(.RACMDA) ;1 "RTN","RASTED",85,0) D TRK70CMA^RAMAINU(RADFN,RADTI,RACNI,RATRKCMB) ;2 "RTN","RASTED",86,0) K RACMDA,RAOPRC "RTN","RASTED",87,0) ; "RTN","RASTED",88,0) K DIE("NO^"),DQ,DE,RATRKCMB,RAZCM "RTN","RASTED",89,0) K RANM702,RADIOPH,RADOSE,RAIEN702,RAHI,RALOW,RAPRI,RAMIS,RAI,RAPSDRUG,RAR1 "RTN","RASTED",90,0) ; "RTN","RASTED",91,0) ; if EXAM STATUS didn't process, still go thru status-change-logic "RTN","RASTED",92,0) ; variables "RTN","RASTED",93,0) ; --------- "RTN","RASTED",94,0) ; RA70033: is set in the RA STATUS CHANGE input template after the "RTN","RASTED",95,0) ; update to the EXAMINATION STATUS field (70.03;3) "RTN","RASTED",96,0) ; RATCXX: are technologist comments (if any) input by the user "RTN","RASTED",97,0) ; RAMDV: division parameters, piece 10; store the date/time "RTN","RASTED",98,0) ; of an exam status change (1 for yes, 0 for no) "RTN","RASTED",99,0) ; "RTN","RASTED",100,0) D:$D(RA70033)&($P(RAMDV,"^",10)) X7005^RADD3(RADFN,RADTI,RACNI,RAMDV,"",RA70033,$S($D(RADUZ):RADUZ,1:DUZ)) "RTN","RASTED",101,0) D A7007^RADD3(RADFN,RADTI,RACNI,$S($D(RADUZ):RADUZ,1:DUZ),$G(RATCXX)) "RTN","RASTED",102,0) D UNLOCK^RAUTL12(RADIE,RADADA) K RADADA,RADIE "RTN","RASTED",103,0) K RA70033,RADUZ,RATCXX "RTN","RASTED",104,0) N RACN0A ; updated version of the exam node after status updates "RTN","RASTED",105,0) W !,"...Status ",$S($D(RAAFTER)&($G(RABEFORE)=$G(RAAFTER)):"unchanged",$G(RABEFORE)>$G(RAAFTER):"backed down",1:"successfully changed")," for case #: ",RACN "RTN","RASTED",106,0) ; "RTN","RASTED",107,0) ;02/10/2006 BAY/KAM RA*5*71 ,modified in RA*5*82... "RTN","RASTED",108,0) I $D(RAAFTER),$G(RABEFORE)=$G(RAAFTER) R X:3 D Q ;exit if no change "RTN","RASTED",109,0) .;Modified for RA*5*82 "RTN","RASTED",110,0) .N RAEXEDT S RAEXEDT=$$CMPAFTR^RAO7XX(1) ;;P18 compares if procedure was changed sends XX message "RTN","RASTED",111,0) .D:RAEXEDT EXM^RAHLRPC ;P18 compares if procedure was changed sends XX message "RTN","RASTED",112,0) ; "RTN","RASTED",113,0) ; if status got backed down, RANEXT is re-defined inside rtn RASTREQ "RTN","RASTED",114,0) ; when the above edit template gets to the EXAM STATUS field "RTN","RASTED",115,0) ; "RTN","RASTED",116,0) D ^RAORDC I +$P(RANEXT,"^",3)>1,RACS'="Y",$S($P(RACN0,"^",6)']"":1,$P(^DIC(42,+$P(RACN0,"^",6),0),U,3)="D":1,1:0) D EN^RAUTL0 "RTN","RASTED",117,0) S RACN0A=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) ; updated 0 node! "RTN","RASTED",118,0) ; Do we need to 'Generate Exam Alert' based on the exam status? "RTN","RASTED",119,0) I $D(^RA(72,+$P(RACN0A,"^",3),"ALERT")),($P(^("ALERT"),"^")="y") D "RTN","RASTED",120,0) . ; fire off the 'Rad Patient Examined' alert. "RTN","RASTED",121,0) . N RAPRIT,RAORDIFN "RTN","RASTED",122,0) . S RAPRIT=+$P(RACN0A,"^",2) ; possible call to OERR3^RAORDU1 "RTN","RASTED",123,0) . S RAORDIFN=+$P(RACN0A,"^",11) ; possible call to OERR^RAORDU1 "RTN","RASTED",124,0) . D:$$ORVR^RAORDU()=2.5 OERR^RAUTL1 "RTN","RASTED",125,0) . D:$$ORVR^RAORDU()'<3 OERR3^RAUTL1 "RTN","RASTED",126,0) . Q "RTN","RASTED",127,0) ; "RTN","RASTED",128,0) R X:3 D "RTN","RASTED",129,0) .N RAEXEDT S RAEXEDT=$$CMPAFTR^RAO7XX(1) "RTN","RASTED",130,0) .D EXM^RAHLRPC "RTN","RASTED",131,0) ;P18 compares -if procedure was changed - sends XX message "RTN","RASTED",132,0) Q "RTN","RASTED",133,0) USER S %="A",%DUZ=DUZ W ! D ^XUVERIFY G USERQ:%=-1 I %'=1 W $C(7)," ??" G USER "RTN","RASTED",134,0) Q "RTN","RASTED",135,0) USERQ K RADUZ S RAPOP=1 Q "RTN","RASTED",136,0) WHY1 ;explain why prim/sec resid/staff, diagnoses prompts are skipped "RTN","RASTED",137,0) Q:$G(DA)<1!($G(DA(1))<1)!($G(DA(2))<1) "RTN","RASTED",138,0) N RA0,RA1,RA2,RA5 N:'$D(RA3)#2 RA3 N:'$D(RA4)#2 RA4 "RTN","RASTED",139,0) S RA0=$G(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q:'RA0 S RA2=0 "RTN","RASTED",140,0) I $G(RA3)=13 D WHY11 G WHYMSG ;diagnoses "RTN","RASTED",141,0) S RA3=12,RA4=70 D WHY11 ;residents "RTN","RASTED",142,0) S RA3=15,RA4=60 D WHY11 ;staff "RTN","RASTED",143,0) WHYMSG W:'RA2 !!?12,"No data have been entered for ",$S(RA3'=13:"residents/staff",1:"diagnoses")," yet.",! "RTN","RASTED",144,0) WHYMSG2 W !?12,$C(7),"The selected case belongs to a print set,",!?12,"Please use the 'Report Enter/Edit' option",!?12,"to enter data for ",$S(RA3=99:"residents/staff/diagnoses",RA3'=13:"residents/staff",1:"diagnoses"),".",!! "RTN","RASTED",145,0) Q "RTN","RASTED",146,0) WHY11 Q:'+$P(RA0,"^",RA3) "RTN","RASTED",147,0) S RA2=1 W !!?2,$P(^DD(70.03,RA3,0),"^")," :",?35 "RTN","RASTED",148,0) W:RA3'=13 $P(^VA(200,+$P(RA0,"^",RA3),0),"^") W:RA3=13 $P(^RA(78.3,+$P(RA0,"^",RA3),0),"^") W ! "RTN","RASTED",149,0) S RA5=$P($P(^DD(70.03,RA4,0),"^",4),";") Q:'$O(^RADPT(DA(2),"DT",DA(1),"P",DA,RA5,0)) "RTN","RASTED",150,0) S RA1=0 W !?4,$P(^DD(70.03,RA4,0),"^")," :" "RTN","RASTED",151,0) F S RA1=$O(^RADPT(DA(2),"DT",DA(1),"P",DA,RA5,RA1)) Q:'RA1 I +^(RA1,0) W ?37 W:RA3'=13 $P($G(^VA(200,+^(0),0)),"^") W:RA3=13 $P($G(^RA(78.3,+^(0),0)),"^") W ! "RTN","RASTED",152,0) Q "RTN","RASTED",153,0) WHY2 ;explain why diags prompts are skipped "RTN","RASTED",154,0) N RA3 S RA3=13,RA4=13.1 G WHY1 "RTN","RASTREQ") 0^14^B56495066 "RTN","RASTREQ",1,0) RASTREQ ;HISC/CAH,GJC AISC/MJK-Status Requirements Check Routine ; 06 Oct 2013 11:07 AM "RTN","RASTREQ",2,0) ;;5.0;Radiology/Nuclear Medicine;**1,10,23,40,56,99,90,1005**;Mar 16, 1998;Build 13 "RTN","RASTREQ",3,0) ;Supported IA #10104 UP^XLFSTR "RTN","RASTREQ",4,0) ;Supported IA #1367 LKUP^XPDKEY "RTN","RASTREQ",5,0) ;Supported IA #10060 ^VA(200 "RTN","RASTREQ",6,0) ;Supported IA #10076 ^XUSEC( "RTN","RASTREQ",7,0) ;Supported IA #2056 GET1^DIQ and GETS^DIQ "RTN","RASTREQ",8,0) ; Called by "RTN","RASTREQ",9,0) ; (1) Stat Track's [RA STATUS CHANGE]'s fld EXAM STATUS' input transform "RTN","RASTREQ",10,0) ; (2) ASK+22^RASTED, if user "^" out of stat trk editing "RTN","RASTREQ",11,0) ; (3) Cancel an Exam's [RA CANCEL]'s fld EXAM STATUS' input transform "RTN","RASTREQ",12,0) ; (4) Enter Last Past Visit Before DHCP's [RA LAST PAST VISIT]'s "" "RTN","RASTREQ",13,0) ; "RTN","RASTREQ",14,0) ; Instead of using RAIMGTY, recalculate "RTN","RASTREQ",15,0) ; the imaging type using the imaging type on the exam node because "RTN","RASTREQ",16,0) ; status updating through report entry/edit, batch verify, and several "RTN","RASTREQ",17,0) ; other options is NOT screened by sign-on imaging type, so does not "RTN","RASTREQ",18,0) ; stay the same through a user's session. "RTN","RASTREQ",19,0) ; "RTN","RASTREQ",20,0) ; 'RAMES1' is used to display which Exam Status required fields are "RTN","RASTREQ",21,0) ; not populated. This only applies to the 'Status Tracking Of Exams' "RTN","RASTREQ",22,0) ; option. "RTN","RASTREQ",23,0) ; "RTN","RASTREQ",24,0) ; If tracking ^-out, this rtn would be called outside of edt tmpl, "RTN","RASTREQ",25,0) ; and thus the DA vars would not be defined, so we need to set them here "RTN","RASTREQ",26,0) ; "RTN","RASTREQ",27,0) N RASAVY M RASAVY=Y ;save the value of Y, patch #90 "RTN","RASTREQ",28,0) S:'$D(DA)#2 DA=RACNI S:'$D(DA(1))#2 DA(1)=RADTI S:'$D(DA(2))#2 DA(2)=RADFN "RTN","RASTREQ",29,0) ; If Fileman enter/edit, we need to define RADFN, RADTI, RACNI so the "RTN","RASTREQ",30,0) ; nuc med checks won't bomb "RTN","RASTREQ",31,0) S:'$D(RACNI)#2 RACNI=DA S:'$D(RADTI)#2 RADTI=DA(1) S:'$D(RADFN)#2 RADFN=DA(2) "RTN","RASTREQ",32,0) ; "RTN","RASTREQ",33,0) S RAIMGTYI=+$P($G(^RADPT(DA(2),"DT",DA(1),0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U,1),RASAVTYJ=RAIMGTYJ "RTN","RASTREQ",34,0) S RAMES1="W:$G(K)=$P($G(^RA(72,+$G(RANXT72),0)),U,3)&('$D(ZTQUEUED)#2) !?3,""No '"",RAZ,""'"",?35,"" entered for this exam.""" ; display if at the ranext exm stat level "RTN","RASTREQ",35,0) S RAXX=+$G(X) "RTN","RASTREQ",36,0) I '$D(^RA(72,RAXX,0))!(RAIMGTYJ']"") D M Y=RASAVY Q "RTN","RASTREQ",37,0) . K X W:'$D(ZTQUEUED)#2 !?3,"Error: cannot determine Imaging Type of exam. Contact IRM." "RTN","RASTREQ",38,0) . K RAMES1,RAXX "RTN","RASTREQ",39,0) . Q "RTN","RASTREQ",40,0) N RA,RASN,RASTI,RADES,RAOKAY,RA3 "RTN","RASTREQ",41,0) ; RADES = order seq. desired, RAOKAY= actual order seq. okay'd "RTN","RASTREQ",42,0) S X1=$G(^RA(72,RAXX,0)),RADES=$P(X1,U,3) "RTN","RASTREQ",43,0) I $$LKUP^XPDKEY(+$P(X1,"^",4))]"",'$D(^XUSEC($$LKUP^XPDKEY(+$P(X1,"^",4)),DUZ)) K X W:'$D(ZTQUEUED)#2 !?3,"You do not have the proper access privileges to ",!?3,"change this exam to this status" M Y=RASAVY Q "RTN","RASTREQ",44,0) S RAJ=^RADPT(DA(2),"DT",DA(1),"P",DA,0),RAOR=-1 "RTN","RASTREQ",45,0) S RABEFORE=$P($G(^RA(72,+$P(RAJ,U,3),0)),U,3) ; current order seq "RTN","RASTREQ",46,0) ; Don't need to set RAORDIFN,RACS,RAPRIT,RAF5 "RTN","RASTREQ",47,0) I '$D(^RA(72,"AA",RAIMGTYJ,0,RAXX)) D LOOP^RASTREQ1 S RAIMGTYJ=RASAVTYJ "RTN","RASTREQ",48,0) I $D(^RA(72,"AA",RAIMGTYJ,0,RAXX)) D CANCEL^RASTREQ1 "RTN","RASTREQ",49,0) S RAIMGTYJ=RASAVTYJ "RTN","RASTREQ",50,0) ; Can't use X to determine if status change to next was successful "RTN","RASTREQ",51,0) ; due to looping thru all status levels for this img type "RTN","RASTREQ",52,0) ; chk if calculated order is at NEXT or higher level "RTN","RASTREQ",53,0) ; RAAFTER is set in rastreq1; it has 2 meanings : "RTN","RASTREQ",54,0) ; upon return from rastreq1, RAAFTER means highest seq order qualified "RTN","RASTREQ",55,0) ; upon exit from this rtn, RAAFTER means actual seq order used "RTN","RASTREQ",56,0) I RABEFORERAAFTER W:'$D(ZTQUEUED)#2 ?$X+4,$P($G(^RA(72,$O(^(RA3,0)),0)),U) "RTN","RASTREQ",76,0) W:'$D(ZTQUEUED)#2 !!,"Since Status Tracking can only upgrade one status at a time,",!,"please edit this exam again.",! "RTN","RASTREQ",77,0) KOUT2 S RAAFTER=RAOKAY ;return as actual seq order used, not nec. highest "RTN","RASTREQ",78,0) K RAIMGTYI,RAIMGTYJ,RAMES1,RAZ,RAXX,RAJ,RAS,RAK,RAE,X1,RASAVTYJ "RTN","RASTREQ",79,0) M Y=RASAVY "RTN","RASTREQ",80,0) Q "RTN","RASTREQ",81,0) ; "RTN","RASTREQ",82,0) 1 ;Technologist Check "RTN","RASTREQ",83,0) N DIERR "RTN","RASTREQ",84,0) S RA("TECH")="" I $O(^RADPT(DA(2),"DT",DA(1),"P",DA,"TC",0))>0 S RA("TECH")=+^($O(^(0)),0) S RA("TECH")=$$GET1^DIQ(200,RA("TECH")_",",.01) "RTN","RASTREQ",85,0) I RA("TECH")']"" K X S RAZ="technologist" X:$D(RAMES1) RAMES1 "RTN","RASTREQ",86,0) K RA("TECH") Q "RTN","RASTREQ",87,0) ; "RTN","RASTREQ",88,0) 2 ;Interpreting Physician Check "RTN","RASTREQ",89,0) N DIERR "RTN","RASTREQ",90,0) I $$GET1^DIQ(200,$P(RAJ,"^",12)_",",.01)="",$$GET1^DIQ(200,$P(RAJ,"^",15)_",",.01)="" K X S RAZ="interpreting staff or resident" X:$D(RAMES1) RAMES1 "RTN","RASTREQ",91,0) Q "RTN","RASTREQ",92,0) ; "RTN","RASTREQ",93,0) 3 ;Detailed Procedure Check "RTN","RASTREQ",94,0) S RAZ="detailed procedure" I '$D(^RAMIS(71,+$P(RAJ,"^",2),0)) K X X:$D(RAMES1) RAMES1 Q "RTN","RASTREQ",95,0) S RAJ1=$G(^RAMIS(71,+$P(RAJ,"^",2),0)) I "DS"'[$P(RAJ1,"^",6) K X X:$D(RAMES1) RAMES1 Q "RTN","RASTREQ",96,0) S RAZ="detailed procedure (no CPT code)" I $P(RAJ1,"^",9)']"" K X X:$D(RAMES1) RAMES1 Q "RTN","RASTREQ",97,0) Q "RTN","RASTREQ",98,0) ; "RTN","RASTREQ",99,0) 4 ;Film Data Check "RTN","RASTREQ",100,0) I '$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"F",0)) K X S RAZ="film data" X:$D(RAMES1) RAMES1 "RTN","RASTREQ",101,0) Q "RTN","RASTREQ",102,0) ; "RTN","RASTREQ",103,0) 5 ;Diagnostic Code Check "RTN","RASTREQ",104,0) I '$D(^RA(78.3,+$P(RAJ,"^",13),0)) K X S RAZ="diagnostic code" X:$D(RAMES1) RAMES1 "RTN","RASTREQ",105,0) Q "RTN","RASTREQ",106,0) ; "RTN","RASTREQ",107,0) 6 ;Camera/Equipment/Room Check "RTN","RASTREQ",108,0) S RAE=$S($D(RAMDV):$P(RAMDV,"^",9),1:1) I RAE,'$D(^RA(78.6,+$P(RAJ,"^",18),0)) K X S RAZ="camera/equip/room" X:$D(RAMES1) RAMES1 "RTN","RASTREQ",109,0) Q "RTN","RASTREQ",110,0) ; "RTN","RASTREQ",111,0) 11 ;Report Entered and not just a stub rec for Img/PACS Check "RTN","RASTREQ",112,0) I '$D(^RARPT(+$P(RAJ,"^",17),0)) G NORPT "RTN","RASTREQ",113,0) ; since there's a rpt ptr, must check if the rpt is just a stub rpt "RTN","RASTREQ",114,0) N RA17,RA0 ; use logic from RAREG "RTN","RASTREQ",115,0) S RA17=+$P(RAJ,"^",17) "RTN","RASTREQ",116,0) I $$STUB^RAEDCN1(RA17) G NORPT ; rpt is an image stub "RTN","RASTREQ",117,0) Q "RTN","RASTREQ",118,0) NORPT ; either no report yet, or report is stub "RTN","RASTREQ",119,0) K X S RAZ="report" X:$D(RAMES1) RAMES1 "RTN","RASTREQ",120,0) Q "RTN","RASTREQ",121,0) ; "RTN","RASTREQ",122,0) 12 ;Report Verified Check "RTN","RASTREQ",123,0) D 11:$P(RAS,"^",11)'="Y" I $D(^RARPT(+$P(RAJ,"^",17),0)),$P(^(0),"^",5)'="V" K X S RAZ="report verification" X:$D(RAMES1) RAMES1 "RTN","RASTREQ",124,0) Q "RTN","RASTREQ",125,0) ; "RTN","RASTREQ",126,0) 16 ;Impression Entry Check "RTN","RASTREQ",127,0) ; In Phase 1, for Elec. filed rpts, skip this even if div. param requires it "RTN","RASTREQ",128,0) I $D(^RARPT(+$P(RAJ,"^",17),0)),$P(^(0),"^",5)="EF" Q "RTN","RASTREQ",129,0) I $O(^RARPT(+$P(RAJ,"^",17),"I",0))'>0 K X S RAZ="impression" X:$D(RAMES1) RAMES1 "RTN","RASTREQ",130,0) Q "RTN","RASTREQ",131,0) 13 ;Procedure Modifers Check "RTN","RASTREQ",132,0) I '$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"M",0)) K X S RAZ="procedure modifier" X:$D(RAMES1) RAMES1 "RTN","RASTREQ",133,0) Q "RTN","RASTREQ",134,0) 14 ;CPT Modifiers Check "RTN","RASTREQ",135,0) I '$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"CMOD",0)) K X S RAZ="CPT modifiers" X:$D(RAMES1) RAMES1 "RTN","RASTREQ",136,0) Q "RTN","RASTREQ",137,0) ; "RTN","RASTREQ",138,0) HELP ; Called from 'Help Text' node in DD(70.03,3,4). "RTN","RASTREQ",139,0) N E,RA "RTN","RASTREQ",140,0) S RAJ=$G(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) "RTN","RASTREQ",141,0) S RAIMGTYI=+$P($G(^RADPT(DA(2),"DT",DA(1),0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U,1) "RTN","RASTREQ",142,0) I RAIMGTYJ']"" W !,"ERROR: Cannot determine imaging type of exam!" K FL,K,N,RAIMGTYI,RAIMGTYJ,RAS,RAJ Q "RTN","RASTREQ",143,0) W !,"This exam meets the requirements for the following statuses:" "RTN","RASTREQ",144,0) F K=0:0 S K=$O(^RA(72,"AA",RAIMGTYJ,K)) Q:K'>0 D "RTN","RASTREQ",145,0) . S X="",E=+$O(^RA(72,"AA",RAIMGTYJ,K,0)) Q:E'>0 "RTN","RASTREQ",146,0) . I $D(^RA(72,E,0)) D "RTN","RASTREQ",147,0) .. S RA(0)=$G(^RA(72,E,0)),N=$P(RA(0),U),RAS=$G(^RA(72,E,.1)) "RTN","RASTREQ",148,0) .. I $L(RAS) D HELP1 I $D(X) W !?10,N S FL="" ;removed D 3, done inside HELP1 "RTN","RASTREQ",149,0) .. Q "RTN","RASTREQ",150,0) . Q "RTN","RASTREQ",151,0) W:'$D(FL) !?10,"Does not meet the requirements of any status." "RTN","RASTREQ",152,0) W ! K RAS,RAJ,N,K,FL,RAIMGTYI,RAIMGTYJ "RTN","RASTREQ",153,0) Q "RTN","RASTREQ",154,0) HELP1 ; Called from 'HELP' above and 'STUFF^RASTREQ1' "RTN","RASTREQ",155,0) ; 'RAJ' -> 0 node of the examination "RTN","RASTREQ",156,0) ; 'E' -> ien of the examination status "RTN","RASTREQ",157,0) ; Both 'RAJ' & 'E' set in 'HELP' & 'STUFF^RASTREQ1' "RTN","RASTREQ",158,0) ; "RTN","RASTREQ",159,0) ;start of p99, exam status UNCHANGED if pregnancy screen is not answered for female pt bet ages 12-55 "RTN","RASTREQ",160,0) N RAPTAGE,RASAVE "RTN","RASTREQ",161,0) S RASAVE=X ;save the value of X, since it's being replaced in DIQ call. "RTN","RASTREQ",162,0) S RAPTAGE=$$PTAGE^RAUTL8(DA(2),"") "RTN","RASTREQ",163,0) ; "RTN","RASTREQ",164,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RASTREQ",165,0) ;I $$PTSEX^RAUTL8(DA(2))="F",((RAPTAGE>11)&(RAPTAGE<56)),$$GET1^DIQ(70.03,DA_","_DA(1)_","_DA(2),32)="" S E=$P(RAJ,U,3),(N,X)="" S:$G(E) (N,X)=$P($G(^RA(72,E,0)),U) Q "RTN","RASTREQ",166,0) I $$PTSEX^RAUTL8(DA(2))'="M",((RAPTAGE>11)&(RAPTAGE<56)),$$GET1^DIQ(70.03,DA_","_DA(1)_","_DA(2),32)="" S E=$P(RAJ,U,3),(N,X)="" S:$G(E) (N,X)=$P($G(^RA(72,E,0)),U) Q "RTN","RASTREQ",167,0) ; "RTN","RASTREQ",168,0) S X=RASAVE "RTN","RASTREQ",169,0) ;end p99 "RTN","RASTREQ",170,0) N RADIO,RADIOUZD,RAS5 S RADIO=$S($G(^RA(72,E,.5))]"":$G(^(.5)),1:"N") "RTN","RASTREQ",171,0) S:$P($G(^RA(79.2,+RAIMGTYI,0)),"^",5)="Y" RADIOUZD="" "RTN","RASTREQ",172,0) ; "RTN","RASTREQ",173,0) ; Phase 1 Outside Reporting 100% outside work, skip all except Diag. Code "RTN","RASTREQ",174,0) I $D(^RARPT(+$P(RAJ,"^",17),0)),$P(^(0),"^",5)="EF" S RAS5=$P(RAS,U,5),RAS="",$P(RAS,U,5)=RAS5 K RADIOUZD "RTN","RASTREQ",175,0) ; "RTN","RASTREQ",176,0) F RAK=1:1 Q:$P(RAS,"^",RAK,99)']"" D:$P(RAS,"^",RAK)="Y" @RAK "RTN","RASTREQ",177,0) I $D(X),$P(RAS,"^",3)'="Y",$D(^RA(72,"AA",RAIMGTYJ,9,E)) D 3 "RTN","RASTREQ",178,0) I $D(X),$P(RAS,"^",16)'="Y",$D(^RA(72,"AA",RAIMGTYJ,9,E)),$D(^RA(79,+$P(^RADPT(DA(2),"DT",DA(1),0),"^",3),.1)),$P(^(.1),"^",16)="Y" D 16 "RTN","RASTREQ",179,0) I $D(RADIOUZD) D ;if Radiopharm Used, then check req'd NucMed flds "RTN","RASTREQ",180,0) . D EN1^RASTREQN(RADIO,RAJ) "RTN","RASTREQ",181,0) . I $D(X),($$UP^XLFSTR($P($G(^RA(72,E,.6)),"^",11)="Y")) D EN1^RADOSTIK(RADFN,RADTI,RACNI) "RTN","RASTREQ",182,0) . Q "RTN","RASTREQ",183,0) Q "RTN","RAUTL8") 0^15^B76092917 "RTN","RAUTL8",1,0) RAUTL8 ;HISC/CAH-Utility routines ; 06 Oct 2013 11:07 AM "RTN","RAUTL8",2,0) ;;5.0;Radiology/Nuclear Medicine;**45,72,99,90,1003,1005**;Nov 01, 2010;Build 13 "RTN","RAUTL8",3,0) ; "RTN","RAUTL8",4,0) ;Called by File 70, Exam subfile, Procedure Fld 2 Input transform "RTN","RAUTL8",5,0) ;RA*5*45: modified - logic in PRC1, ASK, ASK1, & MES1 subroutines "RTN","RAUTL8",6,0) ; removed - MES subroutine "RTN","RAUTL8",7,0) ;RA*5*72 03/23/2006 BAY/GJC/KAM Remedy Call 136200 Correct UNDEF issue "RTN","RAUTL8",8,0) ;RA*5.0*99 added utility for pt age and pt sex "RTN","RAUTL8",9,0) ; "RTN","RAUTL8",10,0) ;Supported IA #10061 reference to ^VADPT "RTN","RAUTL8",11,0) ;Supported IA #10103 reference to ^XLFDT "RTN","RAUTL8",12,0) ;Supported IA #10142 reference to EN^DDIOL "RTN","RAUTL8",13,0) ;Supported IA #2056 reference to GET1^DIQ and GETS^DIQ "RTN","RAUTL8",14,0) ;Supported IA #10104 reference to UP^XLFSTR "RTN","RAUTL8",15,0) ;Supported IA #10076 reference to ^XUSEC "RTN","RAUTL8",16,0) ;Supported IA #2055 reference to EXTERNAL^DILFD "RTN","RAUTL8",17,0) ;Supported IA #2378 reference to ORCHK^GMRAOR "RTN","RAUTL8",18,0) ; "RTN","RAUTL8",19,0) PRC G PRC1:'$D(^RADPT(DA(2),"DT","AP",X)) ; check for C.M. reaction "RTN","RAUTL8",20,0) N RADUP S RADUP=+$$DPDT^RAUTL8(X,.DA) "RTN","RAUTL8",21,0) I RADUP D ASK Q:'$D(X) "RTN","RAUTL8",22,0) PRC1 ; Check for C.M. reaction on this patient "RTN","RAUTL8",23,0) ; +X is the IEN of the Rad/Nuc Med Procedure in file 71 "RTN","RAUTL8",24,0) ; RA*5*72 - Changed next line to preserve variables "RTN","RAUTL8",25,0) N RAGMRAOR S RAGMRAOR=$$GMRAOR(DA(2)) Q:RAGMRAOR'=1 "RTN","RAUTL8",26,0) D CONTRAST^RAUTL2(+X) ;displays contrast(s) associated with procedure "RTN","RAUTL8",27,0) ;use RAPMSG for CONTRAST REACTION MESSAGE field 25, file 79 "RTN","RAUTL8",28,0) S RAPMSG=$G(^RA(79,+$P(^RADPT(DA(2),"DT",DA(1),0),"^",3),"CON")) "RTN","RAUTL8",29,0) D:RAPMSG'="" EN^DDIOL("..."_RAPMSG_"...","","!?3") "RTN","RAUTL8",30,0) D EN^DDIOL("","","!") ;line feed "RTN","RAUTL8",31,0) K RAPMSG "RTN","RAUTL8",32,0) D:$P($G(^RAMIS(71,+X,0)),U,20)="Y" MES1 ;message only if CM used "RTN","RAUTL8",33,0) Q "RTN","RAUTL8",34,0) ASK ; Prompt user for yes/no response "RTN","RAUTL8",35,0) N RAX D EN^DDIOL("Procedure is already entered for this date. Is it ok to continue? No// ","","!!?3") "RTN","RAUTL8",36,0) ASK1 R RAX:DTIME "RTN","RAUTL8",37,0) S:'$T!(RAX="")!(RAX["^")!("Nn"[$E(RAX)) RAX="N" "RTN","RAUTL8",38,0) K:RAX="N" X Q:'$D(X) "RTN","RAUTL8",39,0) I "Yy"'[$E(RAX) S RAPMSG(1)="Enter 'YES' to register patient for this procedure, or 'NO' to edit the",RAPMSG(2)="above procedure. No// ",RAPMSG(1,"F")="!!?3",RAPMSG(2,"F")="!?3" D EN^DDIOL(.RAPMSG) K RAPMSG G ASK1 "RTN","RAUTL8",40,0) Q "RTN","RAUTL8",41,0) ; "RTN","RAUTL8",42,0) MES1 ; display procedure acceptance message "RTN","RAUTL8",43,0) R !?5,"...Type 'OK' to acknowledge or '^' to select another procedure ==> ",RAX:DTIME "RTN","RAUTL8",44,0) S RAX=$$UP^XLFSTR(RAX) "RTN","RAUTL8",45,0) I '$T!(RAX["^")!(RAX="OK") K:RAX'="OK" X K RAX,RAI Q "RTN","RAUTL8",46,0) G MES1 "RTN","RAUTL8",47,0) ; "RTN","RAUTL8",48,0) STATSEL ;Select one or more order statuses "RTN","RAUTL8",49,0) ;INPUT VARIABLES: "RTN","RAUTL8",50,0) ; RANO() array contains status codes prohibited from selection "RTN","RAUTL8",51,0) ;OUTPUT VARIABLES: "RTN","RAUTL8",52,0) ; RAST is a string of status codes selected (ex: 1^3^8) "RTN","RAUTL8",53,0) ; RAORST() is an array of selected status codes and status names "RTN","RAUTL8",54,0) ; (ex: RAORST(1)="DISCONTINUED", RAORST(3)="HOLD", ... ) "RTN","RAUTL8",55,0) K RAST,RAORST W ! S RAORSTS=$P(^DD(75.1,5,0),U,3) F I=1:1 S X=$P(RAORSTS,";",I) Q:X="" S X1=$P(X,":",1) I '$D(RANO(X1)) S X2=$P(X,":",2),RAORST(X1)=X2 "RTN","RAUTL8",56,0) W !!,"Select statuses to include on report.",! S X1="" F S X1=$O(RAORST(X1)) Q:X1="" W !?5,$J(X1,2,0)_" "_RAORST(X1) "RTN","RAUTL8",57,0) STAT W ! K DIR S DIR(0)="L" D ^DIR Q:'$D(Y(0)) "RTN","RAUTL8",58,0) S RAST="" F I=1:1 S RASTX=$P(Y(0),",",I) Q:RASTX="" I $D(RAORST(RASTX)) S RAST=RAST_"^"_RASTX "RTN","RAUTL8",59,0) S RAST=$E(RAST,2,99) I RAST="" W !," ?? Sorry, invalid status selection. Please try again.",! G STAT "RTN","RAUTL8",60,0) S I="" F S I=$O(RAORST(I)) Q:I="" I RAST'[I K RAORST(I) "RTN","RAUTL8",61,0) K RASTX,I,X,X1,X2 Q "RTN","RAUTL8",62,0) ; "RTN","RAUTL8",63,0) ;INPUT TRANSFORM FOR SECONDARY INTERPRETING RESIDENT "RTN","RAUTL8",64,0) S() ; do not enter primary OR SAME SEC in secondary interpreting resident "RTN","RAUTL8",65,0) I '$D(X)!('$D(DA(3))) G S2 "RTN","RAUTL8",66,0) I '$D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0)) G S2 "RTN","RAUTL8",67,0) I $D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),"SRR","B",+Y)) Q 0 ;SAME SEC RES "RTN","RAUTL8",68,0) I $P(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",12)=+Y Q 0 "RTN","RAUTL8",69,0) Q 1 "RTN","RAUTL8",70,0) S2 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0 "RTN","RAUTL8",71,0) I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"SRR","B",+Y)) Q 0 ;SAME SEC RES "RTN","RAUTL8",72,0) I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",12)=+Y Q 0 "RTN","RAUTL8",73,0) Q 1 "RTN","RAUTL8",74,0) ;INPUT TRANSFORM FOR SECONDARY INTERPRETING STAFF "RTN","RAUTL8",75,0) SSR() ; do not enter primary OR SAME SEC in secondary interpreting staff "RTN","RAUTL8",76,0) I '$D(X)!('$D(DA(3))) G SSR2 "RTN","RAUTL8",77,0) I '$D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0)) G SSR2 "RTN","RAUTL8",78,0) I $D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),"SSR","B",+Y)) Q 0 ;SAME SEC STF "RTN","RAUTL8",79,0) I $P(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",15)=+Y Q 0 "RTN","RAUTL8",80,0) Q 1 "RTN","RAUTL8",81,0) SSR2 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0 "RTN","RAUTL8",82,0) I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"SSR","B",+Y)) Q 0 ;SAME SEC STF "RTN","RAUTL8",83,0) I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",15)=+Y Q 0 "RTN","RAUTL8",84,0) Q 1 "RTN","RAUTL8",85,0) ;INPUT TRANSFORM FOR PRIMARY INTERPRETING RESIDENT "RTN","RAUTL8",86,0) ; *** NOT USED - See EN *** "RTN","RAUTL8",87,0) PRRS() ; do not enter secondary into primary interpreting resident screen "RTN","RAUTL8",88,0) ; called from input transform ^DD(70.03,12,0) "RTN","RAUTL8",89,0) I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"SRR","B",+Y)) Q 0 "RTN","RAUTL8",90,0) Q 1 "RTN","RAUTL8",91,0) ;INPUT TRANSFORM FOR PRIMARY INTERPRETING STAFF "RTN","RAUTL8",92,0) ; *** NOT USED - See EN *** "RTN","RAUTL8",93,0) PSRS() ; do not enter secondary into primary interpreting staff screen "RTN","RAUTL8",94,0) ; called from input transform ^DD(70.03,15,0) "RTN","RAUTL8",95,0) I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"SSR","B",+Y)) Q 0 "RTN","RAUTL8",96,0) Q 1 "RTN","RAUTL8",97,0) EN(X,FLD,RA) ;Input transform screen for Primary Staff, Primary Res "RTN","RAUTL8",98,0) ;Used by fields 70.03,12 & 70.03,15. If 'Primary' is found in "RTN","RAUTL8",99,0) ; the 'Secondary' multiple then delete the 'Secondary' entry. "RTN","RAUTL8",100,0) ; X = 'Primary' IEN, FLD = 'Secondary' mult. to check, RA = DA array "RTN","RAUTL8",101,0) N DA,DEL,HDR,IEN,NODE,SAVEX,SUBDD,XREF "RTN","RAUTL8",102,0) S NODE=$S(FLD=60:"SSR",FLD=70:"SRR",1:""),SAVEX=X "RTN","RAUTL8",103,0) S SUBDD=$S(FLD=60:70.11,FLD=70:70.09,1:""),(IEN,DEL)=0 "RTN","RAUTL8",104,0) I (NODE="")!(X'>0)!(FLD'>0)!(SUBDD'>0) Q "RTN","RAUTL8",105,0) F S IEN=$O(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,"B",X,IEN)) Q:IEN'>0 D "RTN","RAUTL8",106,0) . S XREF=0 "RTN","RAUTL8",107,0) . F S XREF=$O(^DD(SUBDD,.01,1,XREF)) Q:XREF'>0 D "RTN","RAUTL8",108,0) .. S (D0,DA(3))=RA(2),(D1,DA(2))=RA(1),(D2,DA(1))=RA,(D3,DA)=IEN,X=SAVEX "RTN","RAUTL8",109,0) .. I $G(^DD(SUBDD,.01,1,XREF,2))]"" X ^(2) "RTN","RAUTL8",110,0) .. Q "RTN","RAUTL8",111,0) . K ^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,IEN,0) S DEL=DEL+1 "RTN","RAUTL8",112,0) . Q "RTN","RAUTL8",113,0) I DEL D "RTN","RAUTL8",114,0) . S HDR=$G(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,0)) Q:HDR="" "RTN","RAUTL8",115,0) . S HDR(3)=+$O(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,0)) "RTN","RAUTL8",116,0) . S HDR(4)=$P(HDR,U,4)-DEL "RTN","RAUTL8",117,0) . S:HDR(3)'>0 HDR(3)="" S:HDR(4)'>0 HDR(4)="" "RTN","RAUTL8",118,0) . S $P(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,0),U,3,4)=HDR(3)_U_HDR(4) "RTN","RAUTL8",119,0) . Q "RTN","RAUTL8",120,0) S X=SAVEX "RTN","RAUTL8",121,0) Q "RTN","RAUTL8",122,0) DPDT(RAPRC,RAY) ; Check for registration of duplicate procedures on the same "RTN","RAUTL8",123,0) ; date/time. Called from PRC above. "RTN","RAUTL8",124,0) ; INPUT VARIABLES "RTN","RAUTL8",125,0) ; 'RAPRC' --> IEN of the procedure (71) "RTN","RAUTL8",126,0) ; 'RAY' --> DA array i.e, DA, DA(1), & DA(2) "RTN","RAUTL8",127,0) ; OUTPUT VARIABLES "RTN","RAUTL8",128,0) ; 'RAFLG' --> RAFLG=1 procedure registered for this date/time "RTN","RAUTL8",129,0) ; --> RAFLG=0 initial registration for procedure@date/time "RTN","RAUTL8",130,0) N RA72,RABDT,RACIEN,RAEDT,RAFLG,RAI S RAFLG=0 "RTN","RAUTL8",131,0) S RABDT=RAY(1)\1,RAEDT=RABDT_".9999",RAI=RABDT-.0000001 "RTN","RAUTL8",132,0) F S RAI=$O(^RADPT(RAY(2),"DT","AP",RAPRC,RAI)) Q:RAI'>0!(RAI>RAEDT) D Q:RAFLG "RTN","RAUTL8",133,0) . Q:RAI=RAY(1) ; At this point our exam status is 'WAITING FOR EXAM' "RTN","RAUTL8",134,0) . S RACIEN=$O(^RADPT(RAY(2),"DT","AP",RAPRC,RAI,0)) Q:'RACIEN "RTN","RAUTL8",135,0) . S RA72=+$P($G(^RADPT(RAY(2),"DT",RAI,"P",RACIEN,0)),U,3) ;xam stat "RTN","RAUTL8",136,0) . S RA72(3)=$P($G(^RA(72,RA72,0)),U,3) "RTN","RAUTL8",137,0) . I RA72(3)'=0 S RAFLG=1 ; cancelled exams are not taken into account "RTN","RAUTL8",138,0) . Q "RTN","RAUTL8",139,0) Q RAFLG "RTN","RAUTL8",140,0) SCRN(RADA,RARS,Y,RALVL) ; check if the primary or secondary int'ng staff "RTN","RAUTL8",141,0) ; or resident has access to a location or locations which have "RTN","RAUTL8",142,0) ; an imaging type which match the imaging type of the examination. "RTN","RAUTL8",143,0) ; This screen will also check the classification of the individual to "RTN","RAUTL8",144,0) ; ensure that they are active and valid for the field being edited. "RTN","RAUTL8",145,0) ; "RTN","RAUTL8",146,0) ; Called from DD's: ^DD(70.03,12 - ^DD(70.03,15 - ^DD(70.03,60 "RTN","RAUTL8",147,0) ; ^DD(70.03,70 - ^DD(70.09,.01 - ^DD(70.11,.01 "RTN","RAUTL8",148,0) ; "RTN","RAUTL8",149,0) ; Input variables: RADA-> DA array, maps to RADFN, RADTI & RACNI "RTN","RAUTL8",150,0) ; RARS-> Classification: Resident("R") or Staff("S") "RTN","RAUTL8",151,0) ; Y-> selected resident/staff "RTN","RAUTL8",152,0) ; RALVL-> "PRI"=Primary physician, "SEC"=Secondary "RTN","RAUTL8",153,0) ; "RTN","RAUTL8",154,0) ; Output variable: $S(1:I-Types & classification match, resident/staff "RTN","RAUTL8",155,0) ; ok,0:no match re-select resident/staff) "RTN","RAUTL8",156,0) ; "RTN","RAUTL8",157,0) I $S('$D(^VA(200,+Y,"RA")):1,'$P(^("RA"),U,3):1,DT'>$P(^("RA"),U,3):1,1:0),($D(^VA(200,"ARC",RARS,+Y))) "RTN","RAUTL8",158,0) Q:'$T 0 ; failed the classification part of the screen "RTN","RAUTL8",159,0) Q:$D(^XUSEC("RA ALLOC",+Y)) 1 ; Resident/Staff has access to all loc's! "RTN","RAUTL8",160,0) N RA7002,RACCESS "RTN","RAUTL8",161,0) ; adjust RADA() due Fileman's unpredictable retention of DA() levels "RTN","RAUTL8",162,0) I RALVL="SEC" D "RTN","RAUTL8",163,0) . I '$D(RADA(3)) S RA7002=$G(^RADPT(RADA(2),"DT",RADA(1),0)) "RTN","RAUTL8",164,0) . I $D(RADA(3)),(RADA(2)'=RADA(3)) S RA7002=$G(^RADPT(RADA(3),"DT",RADA(2),0)) "RTN","RAUTL8",165,0) . I $D(RADA(3)),(RADA(2)=RADA(3)) S RA7002=$G(^RADPT(RADA(2),"DT",RADA(1),0)) "RTN","RAUTL8",166,0) I RALVL="PRI" S RA7002=$G(^RADPT(RADA(2),"DT",RADA(1),0)) "RTN","RAUTL8",167,0) D VARACC^RAUTL6(+Y) ; set-up access array for selected resident/staff "RTN","RAUTL8",168,0) Q:'$D(RACCESS(+Y,"IMG",+$P(RA7002,"^",2))) 0 ; no i-type match "RTN","RAUTL8",169,0) Q 1 "RTN","RAUTL8",170,0) ; "RTN","RAUTL8",171,0) CMEDIA(RADFN,RADTI,RACNI) ;return the CM used with an exam "RTN","RAUTL8",172,0) ;input: RADFN=patient DFN, RADTI=inv. date/time of exam, RACNI=exam IEN "RTN","RAUTL8",173,0) ;return: contrast media administered to the patient during an exam "RTN","RAUTL8",174,0) N RAI,RAS S RAI=0,RAS="" "RTN","RAUTL8",175,0) F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",RAI)) Q:'RAI D "RTN","RAUTL8",176,0) .S RAI(0)=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",RAI,0)),U) "RTN","RAUTL8",177,0) .S RAS=RAS_$$EXTERNAL^DILFD(70.3225,.01,"",RAI(0))_", " "RTN","RAUTL8",178,0) Q $P(RAS,", ",1,($L(RAS,", ")-1)) "RTN","RAUTL8",179,0) ; "RTN","RAUTL8",180,0) GMRAOR(RADA2) ;look for a contrast media reaction "RTN","RAUTL8",181,0) N D,D0,D1,D2,D3,DA,DC,DD,DFN,DG,DH,DI,DIC,DIE,DIEDA,DIEL,DIETMP,DIEXREF,DIFLD,DIIENS,DIOV,DIP,DK,DL,DLAYGO,DM,DN,DOV,DP,DQ,DR,X,Y "RTN","RAUTL8",182,0) Q $$ORCHK^GMRAOR(RADA2,"CM") "RTN","RAUTL8",183,0) ; "RTN","RAUTL8",184,0) PTAGE(DFN,RADTST) ;return pt age, added by p#99 "RTN","RAUTL8",185,0) ;input = DFN pt ien "RTN","RAUTL8",186,0) ; = RADTST date to process pt age from; if blank, use today's date "RTN","RAUTL8",187,0) ;output = pt age "RTN","RAUTL8",188,0) N RADAYS,VADM,VA,VAERR,%,RAYSAVE,RAXSAVE "RTN","RAUTL8",189,0) M RAYSAVE=Y,RAXSAVE=X ;save value of Y and X, patch #90 "RTN","RAUTL8",190,0) S:RADTST="" RADTST=$$DT^XLFDT() "RTN","RAUTL8",191,0) D DEM^VADPT ; $P(VADM(3),"^") DOB of patient, internal "RTN","RAUTL8",192,0) S RADAYS=$$FMDIFF^XLFDT(RADTST,$P(VADM(3),"^"),3) "RTN","RAUTL8",193,0) M X=RAXSAVE,Y=RAYSAVE "RTN","RAUTL8",194,0) Q RADAYS\365.25 "RTN","RAUTL8",195,0) ; "RTN","RAUTL8",196,0) PTSEX(DFN) ;return pt sex, added by p#99 "RTN","RAUTL8",197,0) ;input = pt dfn "RTN","RAUTL8",198,0) ;output = pt sex (M=for MALE, F=for FEMALE) "RTN","RAUTL8",199,0) ;save value of Y and X; patch #90 "RTN","RAUTL8",200,0) N VADM,VA,VAERR,%,RAYSAVE,RAXSAVE M RAYSAVE=Y,RAXSAVE=X D DEM^VADPT "RTN","RAUTL8",201,0) M Y=RAYSAVE,X=RAXSAVE "RTN","RAUTL8",202,0) Q $P(VADM(5),U) "RTN","RAUTL8",203,0) PRSCR(RADFN,RADTI,RACNI,RAFRMT) ;return pregnancy screen "RTN","RAUTL8",204,0) ;input: radfn = pt dfn "RTN","RAUTL8",205,0) ; radti = inverse dt "RTN","RAUTL8",206,0) ; racni = ien of exam sub "RTN","RAUTL8",207,0) ; rafrmt = E for External format or I for Internal format "RTN","RAUTL8",208,0) ;return = pregnancy screen "RTN","RAUTL8",209,0) N RAIENS,RAOUT "RTN","RAUTL8",210,0) S RAIENS=RACNI_","_RADTI_","_RADFN_"," "RTN","RAUTL8",211,0) D GETS^DIQ(70.03,RAIENS,"32",RAFRMT,"RAOUT") "RTN","RAUTL8",212,0) Q $G(RAOUT(70.03,RAIENS,32,RAFRMT)) "RTN","RAUTL8",213,0) PRSCOM(RADFN,RADTI,RACNI) ;return pregnancy screen comment "RTN","RAUTL8",214,0) ;input: radfn = pt dfn "RTN","RAUTL8",215,0) ; radti = inverse dt "RTN","RAUTL8",216,0) ; racni = ien of exam sub "RTN","RAUTL8",217,0) ;return = pregnancy screen comment "RTN","RAUTL8",218,0) N RAIENS,RAOUT "RTN","RAUTL8",219,0) S RAIENS=RACNI_","_RADTI_","_RADFN_"," "RTN","RAUTL8",220,0) D GETS^DIQ(70.03,RAIENS,"80","E","RAOUT") "RTN","RAUTL8",221,0) Q $G(RAOUT(70.03,RAIENS,80,"E")) "RTN","RAUTL8",222,0) PRCEXA(RADFN) ;return a previous case exam "RTN","RAUTL8",223,0) ;input: radfn = pt dfn "RTN","RAUTL8",224,0) ; "RTN","RAUTL8",225,0) ;output: racexa(0) =radti^racni, where radti=inverse date ien and racni=record ien "RTN","RAUTL8",226,0) N RADTIEN,RACNIEN "RTN","RAUTL8",227,0) S RADTIEN=$O(^RADPT(RADFN,"DT",0)),RACNIEN=9999,RACNIEN=$O(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN),-1) "RTN","RAUTL8",228,0) Q RADTIEN_U_RACNIEN "RTN","RAUTL8",229,0) PRACTO(RADFN) ;returns previous active order IEN of file #75.1 or null if no previous order "RTN","RAUTL8",230,0) ;input radfn = pt dfn "RTN","RAUTL8",231,0) ;output = ien of #75.1 "RTN","RAUTL8",232,0) N RA751IEN,RA751PR "RTN","RAUTL8",233,0) S RA751PR="" "RTN","RAUTL8",234,0) S RA751IEN=" " F S RA751IEN=$O(^RAO(75.1,"B",RADFN,RA751IEN),-1) Q:RA751IEN'>0!$G(RA751PR) D "RTN","RAUTL8",235,0) .I $$GET1^DIQ(75.1,RA751IEN,5)="ACTIVE" S RA751PR=RA751IEN "RTN","RAUTL8",236,0) Q RA751PR "RTN","RAUTL8",237,0) PAOE() ;Entry point to enter Pregnancy field of file 75.1. This label is being called from "RTN","RAUTL8",238,0) ;RA ORDER EXAM input template. "RTN","RAUTL8",239,0) ;RETURN value: 0 if unsuccessful (up arrow, timeout or problem occured), 1 if successful. "RTN","RAUTL8",240,0) N DIR,DIROUT,DIRUT,DUOUT,DTOUT,Y,X S DIR(0)="75.1,13" "RTN","RAUTL8",241,0) S DIR("B")=$S($G(RAPREG)="y":"YES",$G(RAPREG)="n":"NO",$G(RAPREG)="u":"UNKNOWN",1:"") "RTN","RAUTL8",242,0) S DIR("A")="PREGNANT AT TIME OF ORDER ENTRY" D ^DIR "RTN","RAUTL8",243,0) Q:$D(DIRUT)!$D(DUOUT)!$D(DTOUT)!$D(DIROUT) 0 "RTN","RAUTL8",244,0) S RAPREG=$P(Y,"^") "RTN","RAUTL8",245,0) Q 1 "RTN","RAUTL8",246,0) ; "RTN","RAUTL8",247,0) ASKSEX() ;RA*5.0*99 - Determine the sex of the patient by asking the user. "RTN","RAUTL8",248,0) ;Called from the RA ORDER EXAM compiled input template. "RTN","RAUTL8",249,0) ; "RTN","RAUTL8",250,0) ;Question: "THE SEX OF THIS PATIENT IS NOT AVAILABLE. IS PATIENT FEMALE" "RTN","RAUTL8",251,0) ;If 'Yes' Y=1; if 'No' Y=0 "RTN","RAUTL8",252,0) ;The default presented to the user: 'No' "RTN","RAUTL8",253,0) ; "RTN","RAUTL8",254,0) ;Return: the place holder value ('Y' is reset in the RA ORDER EXAM input template) "RTN","RAUTL8",255,0) ;necessary for branching within that template. "RTN","RAUTL8",256,0) ; "RTN","RAUTL8",257,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAUTL8",258,0) ;RA ORDER EXAM already screens out Males, and we want to treat any "RTN","RAUTL8",259,0) ;non-males as if they are female, so don't even ask the question "RTN","RAUTL8",260,0) S RAY=Y "RTN","RAUTL8",261,0) Q Y "RTN","RAUTL8",262,0) ; "RTN","RAUTL8",263,0) N DIR,DTOUT,DUOUT,DIROUT,DIRUT,RAY,X S RAY=Y S DIR(0)="Y",DIR("B")="No" "RTN","RAUTL8",264,0) S DIR("A")="THE SEX OF THIS PATIENT IS NOT AVAILABLE. IS PATIENT FEMALE" "RTN","RAUTL8",265,0) S DIR("?")="Enter 'YES' if patient is female, or 'NO' if patient is male." "RTN","RAUTL8",266,0) D ^DIR "RTN","RAUTL8",267,0) Q $S($D(DIRUT):"@999",Y=0:"@130",1:RAY) "RTN","RAUTL8",268,0) ; "RTN","RAUTL8",269,0) ASKPREG() ;RA*5.0*99 - Evaluate the conditions to present the PREGNANCY "RTN","RAUTL8",270,0) ;SCREENING (70.03 ; 32) prompt to the user. Called from the RA EXAM EDIT "RTN","RAUTL8",271,0) ;input template & the RA REGISTER compiled input template. "RTN","RAUTL8",272,0) ; "RTN","RAUTL8",273,0) ;Input: RA0(17) (global) The IEN of the report associated with this exam. "RTN","RAUTL8",274,0) ; Note: no IEN will exist when the case is being registered. "RTN","RAUTL8",275,0) ; RADFN (global) the IEN of the patient "RTN","RAUTL8",276,0) ; Y (global) the place holder for the RA EXAM EDIT input template. "RTN","RAUTL8",277,0) ; "RTN","RAUTL8",278,0) ;Return: the place holder value (Y = $$ASKPREG^RAUTL8) necessary for "RTN","RAUTL8",279,0) ;branching within these templates. "RTN","RAUTL8",280,0) ; "RTN","RAUTL8",281,0) N %,DIERR,RAERR,RAGE,RAST,VAERR,X,RAY S RAY=Y "RTN","RAUTL8",282,0) S RAGE=$$PTAGE^RAUTL8(RADFN,""),Y=$G(RA0(17))_"," "RTN","RAUTL8",283,0) D:+Y GETS^DIQ(74,Y,5,"I","RAST","RAERR") "RTN","RAUTL8",284,0) S RAST=$G(RAST(74,Y,5,"I"),"") "RTN","RAUTL8",285,0) ; "RTN","RAUTL8",286,0) ;IHS/BJI/DAY - Patch 1005 - Allow Pregnancy Edit of Verified Reports "RTN","RAUTL8",287,0) ;Controlled by a site parameter "RTN","RAUTL8",288,0) I +$G(RAMDIV),$P($G(^RA(79,+RAMDIV,9999999)),U,3)=1,$$PTSEX^RAUTL8(RADFN)'="M",(RAGE<56),(RAGE>11) Q RAY "RTN","RAUTL8",289,0) ;End patch "RTN","RAUTL8",290,0) ; "RTN","RAUTL8",291,0) ;IHS/BJI/DAY - Patch 1005 - Gender Fix "RTN","RAUTL8",292,0) ;I $$PTSEX^RAUTL8(RADFN)'="F"!((RAGE>55)!(RAGE<12))!(RAST="V")!(RAST="EF") S RAY="@8001" "RTN","RAUTL8",293,0) I $$PTSEX^RAUTL8(RADFN)="M"!(RAGE>55)!(RAGE<12)!(RAST="V")!(RAST="EF") S RAY="@8001" "RTN","RAUTL8",294,0) ; "RTN","RAUTL8",295,0) Q RAY "RTN","RAUTL8",296,0) ; "VER") 8.0^22.0 **END** **END**