Changeset 623 for WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- Location:
- WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA
- Files:
-
- 76 edited
-
RABUL3.m (modified) (1 diff)
-
RACTOE.m (modified) (2 diffs)
-
RACTOE1.m (modified) (1 diff)
-
RACTOE2.m (modified) (1 diff)
-
RACTOE3.m (modified) (4 diffs)
-
RACTOE4.m (modified) (1 diff)
-
RACTOE5.m (modified) (1 diff)
-
RACTQE.m (modified) (3 diffs)
-
RACTQE1.m (modified) (1 diff)
-
RACTQE2.m (modified) (1 diff)
-
RACTQE3.m (modified) (1 diff)
-
RACTQE4.m (modified) (3 diffs)
-
RACTQE5.m (modified) (3 diffs)
-
RACTRG.m (modified) (1 diff)
-
RACTRG1.m (modified) (1 diff)
-
RACTRG10.m (modified) (1 diff)
-
RACTRG2.m (modified) (2 diffs)
-
RACTRG3.m (modified) (2 diffs)
-
RACTRG4.m (modified) (1 diff)
-
RACTRG5.m (modified) (2 diffs)
-
RACTRG6.m (modified) (2 diffs)
-
RACTRG7.m (modified) (1 diff)
-
RACTRG8.m (modified) (1 diff)
-
RACTRG9.m (modified) (2 diffs)
-
RADD1.m (modified) (1 diff)
-
RADD2.m (modified) (1 diff)
-
RADD3.m (modified) (1 diff)
-
RADD4.m (modified) (1 diff)
-
RADLQ3.m (modified) (1 diff)
-
RADOSTIK.m (modified) (1 diff)
-
RAHLO.m (modified) (1 diff)
-
RAHLO1.m (modified) (1 diff)
-
RAHLO2.m (modified) (1 diff)
-
RAHLO3.m (modified) (1 diff)
-
RAHLO4.m (modified) (1 diff)
-
RAHLR.m (modified) (1 diff)
-
RAHLRPC.m (modified) (1 diff)
-
RAHLRPT.m (modified) (1 diff)
-
RAHLRS1.m (modified) (1 diff)
-
RAHLTCPB.m (modified) (1 diff)
-
RAMAIN.m (modified) (1 diff)
-
RAMAIN2.m (modified) (1 diff)
-
RANMED1.m (modified) (1 diff)
-
RANMUSE2.m (modified) (1 diff)
-
RANMUSE3.m (modified) (1 diff)
-
RANMUTL1.m (modified) (1 diff)
-
RAO7PC1A.m (modified) (1 diff)
-
RAO7PC2.m (modified) (1 diff)
-
RAO7PC3.m (modified) (1 diff)
-
RAO7RO1.m (modified) (1 diff)
-
RAO7RON.m (modified) (1 diff)
-
RAORD1.m (modified) (1 diff)
-
RAORD1A.m (modified) (1 diff)
-
RAPCE.m (modified) (1 diff)
-
RAPROD.m (modified) (1 diff)
-
RAPTLU.m (modified) (1 diff)
-
RAPXRM.m (modified) (1 diff)
-
RART.m (modified) (1 diff)
-
RARTE.m (modified) (1 diff)
-
RARTE1.m (modified) (1 diff)
-
RARTE3.m (modified) (1 diff)
-
RARTE4.m (modified) (1 diff)
-
RARTR.m (modified) (1 diff)
-
RARTR0.m (modified) (1 diff)
-
RARTR1.m (modified) (1 diff)
-
RARTRPV.m (modified) (1 diff)
-
RARTST1.m (modified) (1 diff)
-
RARTUVR.m (modified) (1 diff)
-
RARTUVR1.m (modified) (1 diff)
-
RARTUVR3.m (modified) (1 diff)
-
RARTVER.m (modified) (1 diff)
-
RASTREQ.m (modified) (1 diff)
-
RASTREQN.m (modified) (1 diff)
-
RAUTL1.m (modified) (1 diff)
-
RAWKLU.m (modified) (1 diff)
-
RAWKLU2.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RABUL3.m
r613 r623 1 RABUL3 ;HISC/FPT,GJC-'RAD/NUC MED REPORT DELETION' Bulletin ;3/21/95 13:56 2 ;;5.0;Radiology/Nuclear Medicine;**56**;Mar 16, 1998;Build 3 3 ;Supported IA #10035 ^DPT( 4 ; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 ; The variables DA must be defined. The value of DA must be greater 6 ; than 0. These conditions must exist for the RAD/NUC MED REPORT 7 ; DELETION bulletin to execute. 8 ; Called from: 9 ; ^DD(74,.01,1,2,0-"DT") xref nodes if deletion via Fileman 10 ; routine RARTE7, if deletion via Rad pkg (RA*5*56) 11 ; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 12 ; ***** Variable List ***** 13 ; 'DIFQ' -> Variable used to check if we are installing the 14 ; Radiology Package. If we are, do not fire off 15 ; bulletins. 16 ; 'RADFN' -> IEN of the patient in the PATIENT file (2) 17 ; 'RAEXAM' -> IEN of a record in the Examinations multiple 18 ; of the Radiology/Nuclear Medicine Patient file. (70) 19 ; 'RAEXAM(0)'-> Zero node of a record in the Examinations multiple 20 ; of the Radiology/Nuclear Medicine Patient file. (70) 21 ; 'RARXAM(0)'-> Zero node of a record in the Registered Exam multiple 22 ; of the Radiology/Nuclear Medicine Patient file. (70) 23 ; 'RAFN1' -> internal format of a FM date/time data element 24 ; { internal format pointer value } 25 ; 'RAFN2' -> FM data definition for RAFN1, used in XTERNAL^RAUTL5 26 ; 'A' -> Zero node of the RADIOLOGY/NUCLEAR MEDICINE REPORTS 27 ; file (74) { node: ^RARPT(DA,0) } 28 ; 29 ; Format: Data to be fired;local var name;XMB array representation 30 ; Patient ; RANAME ; XMB(1) <---> Exam Date ; RAXDT ; XMB(4) 31 ; Patient SSN ; RASSN ; XMB(2) <---> Desired Date ; RADDT ; XMB(5) 32 ; Case Number ; RACASE ; XMB(3) <---> Report Status ; RASTAT ; XMB(6) 33 ; Imaging Loc ; RAILOC ; XMB(7) 34 ; 35 EN1 Q:$D(DIFQ)!(+$G(DA)'>0) ; Quit if installing software or invalid IEN 36 N A,RACASE,RACN,RADDT,RADTI,RADFN,RAEXAM,RAFN1,RAFN2,RAILOC,RANAME 37 N RARXAM,RASSN,RASTAT,RAXDT,X,Y 38 S A=$G(^RARPT(DA,0)) 39 S Y=DA D RASET^RAUTL2 ; Derive case/exam data from file 70 40 S RADFN(0)=RADFN 41 S (RADFN,RANAME)=+$P(A,U,2) 42 S RANAME=$S($D(^DPT(RANAME,0)):$P(^(0),U),1:"Unknown") 43 S RASSN=$$SSN^RAUTL() S RADFN=RADFN(0) 44 S RACASE=$S($P(A,U)]"":$P(A,U),1:"Unknown") 45 S RAFN1=$P(A,U,3),RAFN2=$P($G(^DD(74,3,0)),U,2) 46 S RAXDT=$$XTERNAL^RAUTL5(RAFN1,RAFN2) 47 S RAXDT=$S(RAXDT]"":RAXDT,1:"Unknown") 48 S RARXAM(0)=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),0)) 49 S RAEXAM=$O(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P","B",+$G(RACN),0)) 50 S RAEXAM(0)=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",+$G(RAEXAM),0)) 51 S RAFN1=$P(RAEXAM(0),U,21),RAFN2=$P($G(^DD(70.03,21,0)),U,2) 52 S RADDT=$$XTERNAL^RAUTL5(RAFN1,RAFN2) 53 S RADDT=$S(RADDT]"":RADDT,1:"Unknown") 54 S RAFN1=$S($D(RACLOAK)#2:RACLOAK,1:$P(A,U,5)),RAFN2=$P($G(^DD(74,5,0)),U,2) 55 S RASTAT=$$XTERNAL^RAUTL5(RAFN1,RAFN2) 56 S RASTAT=$S(RASTAT]"":RASTAT,1:"Unknown") 57 S RAFN1=$P(RARXAM(0),U,4),RAFN2=$P($G(^DD(70.02,4,0)),U,2) 58 S RAILOC=$$XTERNAL^RAUTL5(RAFN1,RAFN2) 59 S RAILOC=$S(RAILOC]"":RAILOC,1:"Unknown") 60 S XMB(1)=RANAME,XMB(2)=RASSN,XMB(3)=RACASE 61 S XMB(4)=RAXDT,XMB(5)=RADDT,XMB(6)=RASTAT 62 S XMB(7)=RAILOC,XMB="RAD/NUC MED REPORT DELETION" 63 D ^XMB:$D(^XMB(3.6,"B",XMB)) 64 K XMB,XMB0,XMC0,XMDT,XMM,XMMG 65 Q 66 CLOAK ;called from RARTE7 right after report is deleted but cloaked 67 Q:'$D(RAIEN)#2 ;report ien 68 Q:'$D(RAIEN2)#2 ;activity log sub ien 69 S DA=RAIEN 70 S RACLOAK=$P(^RARPT(DA,"L",RAIEN2,0),U,4) ;previous rpt status 71 G EN1 1 RABUL3 ;HISC/FPT,GJC-'RAD/NUC MED REPORT DELETION' Bulletin ;3/21/95 13:56 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 3 ; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 ; The variables DA must be defined. The value of DA must be greater 5 ; than 0. These conditions must exist for the RAD/NUC MED REPORT 6 ; DELETION bulletin to execute. 7 ; Called from: ^DD(74,.01,1,2,0-"DT") xref nodes 8 ; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 9 ; ***** Variable List ***** 10 ; 'DIFQ' -> Variable used to check if we are installing the 11 ; Radiology Package. If we are, do not fire off 12 ; bulletins. 13 ; 'RADFN' -> IEN of the patient in the PATIENT file (2) 14 ; 'RAEXAM' -> IEN of a record in the Examinations multiple 15 ; of the Radiology/Nuclear Medicine Patient file. (70) 16 ; 'RAEXAM(0)'-> Zero node of a record in the Examinations multiple 17 ; of the Radiology/Nuclear Medicine Patient file. (70) 18 ; 'RARXAM(0)'-> Zero node of a record in the Registered Exam multiple 19 ; of the Radiology/Nuclear Medicine Patient file. (70) 20 ; 'RAFN1' -> internal format of a FM date/time data element 21 ; { internal format pointer value } 22 ; 'RAFN2' -> FM data definition for RAFN1, used in XTERNAL^RAUTL5 23 ; 'A' -> Zero node of the RADIOLOGY/NUCLEAR MEDICINE REPORTS 24 ; file (74) { node: ^RARPT(DA,0) } 25 ; 26 ; Format: Data to be fired;local var name;XMB array representation 27 ; Patient ; RANAME ; XMB(1) <---> Exam Date ; RAXDT ; XMB(4) 28 ; Patient SSN ; RASSN ; XMB(2) <---> Desired Date ; RADDT ; XMB(5) 29 ; Case Number ; RACASE ; XMB(3) <---> Report Status ; RASTAT ; XMB(6) 30 ; Imaging Loc ; RAILOC ; XMB(7) 31 ; 32 Q:$D(DIFQ)!(+$G(DA)'>0) ; Quit if installing software or invalid IEN 33 N A,RACASE,RACN,RADDT,RADTI,RADFN,RAEXAM,RAFN1,RAFN2,RAILOC,RANAME 34 N RARXAM,RASSN,RASTAT,RAXDT,X,Y 35 S A=$G(^RARPT(DA,0)) 36 S Y=DA D RASET^RAUTL2 ; Derive case/exam data from file 70 37 S RADFN(0)=RADFN 38 S (RADFN,RANAME)=+$P(A,U,2) 39 S RANAME=$S($D(^DPT(RANAME,0)):$P(^(0),U),1:"Unknown") 40 S RASSN=$$SSN^RAUTL() S RADFN=RADFN(0) 41 S RACASE=$S($P(A,U)]"":$P(A,U),1:"Unknown") 42 S RAFN1=$P(A,U,3),RAFN2=$P($G(^DD(74,3,0)),U,2) 43 S RAXDT=$$XTERNAL^RAUTL5(RAFN1,RAFN2) 44 S RAXDT=$S(RAXDT]"":RAXDT,1:"Unknown") 45 S RARXAM(0)=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),0)) 46 S RAEXAM=$O(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P","B",+$G(RACN),0)) 47 S RAEXAM(0)=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",+$G(RAEXAM),0)) 48 S RAFN1=$P(RAEXAM(0),U,21),RAFN2=$P($G(^DD(70.03,21,0)),U,2) 49 S RADDT=$$XTERNAL^RAUTL5(RAFN1,RAFN2) 50 S RADDT=$S(RADDT]"":RADDT,1:"Unknown") 51 S RAFN1=$P(A,U,5),RAFN2=$P($G(^DD(74,5,0)),U,2) 52 S RASTAT=$$XTERNAL^RAUTL5(RAFN1,RAFN2) 53 S RASTAT=$S(RASTAT]"":RASTAT,1:"Unknown") 54 S RAFN1=$P(RARXAM(0),U,4),RAFN2=$P($G(^DD(70.02,4,0)),U,2) 55 S RAILOC=$$XTERNAL^RAUTL5(RAFN1,RAFN2) 56 S RAILOC=$S(RAILOC]"":RAILOC,1:"Unknown") 57 S XMB(1)=RANAME,XMB(2)=RASSN,XMB(3)=RACASE 58 S XMB(4)=RAXDT,XMB(5)=RADDT,XMB(6)=RASTAT 59 S XMB(7)=RAILOC,XMB="RAD/NUC MED REPORT DELETION" 60 D ^XMB:$D(^XMB(3.6,"B",XMB)) 61 K XMB,XMB0,XMC0,XMDT,XMM,XMMG 62 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE.m
r613 r623 1 RACTOE ; GENERATED FROM 'RA ORDER EXAM' INPUT TEMPLATE(#1087), FILE 75.1; 01/02/091 RACTOE ; GENERATED FROM 'RA ORDER EXAM' INPUT TEMPLATE(#1087), FILE 75.1;12/27/07 2 2 D DE G BEGIN 3 3 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))="" … … 173 173 Q 174 174 31 S DQ=32 ;@10 175 32 S D=0 K DE(1) ;400 176 S Y="CLINICAL HISTORY FOR EXAM^W^^0;1^Q",DG="H",DC="^75.11" D DIEN^DIWE K DE(1) G A 177 ; 178 33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 179 X33 I $D(DIRUT) S Y="@999" 180 Q 181 34 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=34 D X34 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 182 X34 S:+$O(^RAO(75.1,DA,"H",0))=0 Y="@15" 183 Q 184 35 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=35 D X35 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 185 X35 S RAWPFLAG=$$VALWP^RAUTL5("^RAO(75.1,"_DA_",""H"",") 186 Q 187 36 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=36 D X36 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 188 X36 I 'RAWPFLAG W !!?3,$C(7),"Text must be at least two (2) alphanumeric characters in length.",! S Y="@10" 189 Q 190 37 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=37 D X37 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 191 X37 I $P($G(^RAO(75.1,DA,"H",0)),U,3)>350 W ?3,$C(7),"Clinical History cannot exceed 350 lines!" S Y="@10" 192 Q 193 38 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=38 D X38 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 194 X38 I $O(^RAO(75.1,DA,"H",0)) D UPDT^RAUTL3("^RAO(75.1,"_DA_",""H"",") 195 Q 196 39 S DQ=40 ;@15 197 40 D:$D(DG)>9 F^DIE17 G ^RACTOE3 175 32 D:$D(DG)>9 F^DIE17 G ^RACTOE3 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE1.m
r613 r623 1 RACTOE1 ; ; 01/02/091 RACTOE1 ; ;12/27/07 2 2 D DE G BEGIN 3 3 DE S DIE="^RAO(75.1,D0,""M"",",DIC=DIE,DP=75.1125,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RAO(75.1,D0,"M",DA,""))="" -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE2.m
r613 r623 1 RACTOE2 ; ; 01/02/091 RACTOE2 ; ;12/27/07 2 2 D DE G BEGIN 3 3 DE S DIE="^RAO(75.1,D0,""M"",",DIC=DIE,DP=75.1125,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RAO(75.1,D0,"M",DA,""))="" -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE3.m
r613 r623 1 RACTOE3 ; ; 01/02/091 RACTOE3 ; ;12/27/07 2 2 D DE G BEGIN 3 3 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(2)=% S %=$P(%Z,U,5) S:%]"" DE(33)=% S %=$P(%Z,U,9) S:%]"" DE(8)=% S %=$P(%Z,U,12) S:%]"" DE(13)=% S %=$P(%Z,U,13) S:%]"" DE(19)=% S %=$P(%Z,U,14) S:%]"" DE(1)=% S %=$P(%Z,U,17) S:%]"" DE(23)=% 5 I S %=$P(%Z,U,18) S:%]"" DE(34)=% S %=$P(%Z,U,21) S:%]"" DE(26)=%,DE(30)=% S %=$P(%Z,U,22) S:%]"" DE(10)=% 6 I $D(^("R")) S %Z=^("R") S %=$P(%Z,U,1) S:%]"" DE(5)=% 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(11)=%,DE(20)=% S %=$P(%Z,U,9) S:%]"" DE(27)=% S %=$P(%Z,U,14) S:%]"" DE(9)=% S %=$P(%Z,U,22) S:%]"" DE(32)=% 5 I $D(^("R")) S %Z=^("R") S %=$P(%Z,U,1) S:%]"" DE(24)=% 7 6 K %Z Q 8 7 ; … … 52 51 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 53 52 BEGIN S DNM="RACTOE3",DQ=1 54 1 S DW="0;14",DV="R*P200'X",DU="",DLB="REQUESTING PHYSICIAN",DIFLD=14 53 1 S D=0 K DE(1) ;400 54 S Y="CLINICAL HISTORY FOR EXAM^W^^0;1^Q",DG="H",DC="^75.11" D DIEN^DIWE K DE(1) G A 55 ; 56 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 57 X2 I $D(DIRUT) S Y="@999" 58 Q 59 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 60 X3 S:+$O(^RAO(75.1,DA,"H",0))=0 Y="@15" 61 Q 62 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 63 X4 S RAWPFLAG=$$VALWP^RAUTL5("^RAO(75.1,"_DA_",""H"",") 64 Q 65 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 66 X5 I 'RAWPFLAG W !!?3,$C(7),"Text must be at least two (2) alphanumeric characters in length.",! S Y="@10" 67 Q 68 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 69 X6 I $P($G(^RAO(75.1,DA,"H",0)),U,3)>350 W ?3,$C(7),"Clinical History cannot exceed 350 lines!" S Y="@10" 70 Q 71 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 72 X7 I $O(^RAO(75.1,DA,"H",0)) D UPDT^RAUTL3("^RAO(75.1,"_DA_",""H"",") 73 Q 74 8 S DQ=9 ;@15 75 9 S DW="0;14",DV="R*P200'X",DU="",DLB="REQUESTING PHYSICIAN",DIFLD=14 55 76 S DU="VA(200," 56 77 S X=RAPIFN … … 58 79 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 59 80 G RD:X="@",Z 60 X1 Q 61 2 S DW="0;4",DV="SX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4 81 X9 Q 82 10 S DQ=11 ;@20 83 11 S DW="0;4",DV="SX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4 62 84 S DU="I:INPATIENT;O:OUTPATIENT;C:CONTRACT;S:SHARING;E:EMPLOYEE;R:RESEARCH;" 63 85 S X=RACAT 64 86 S Y=X 65 87 G Y 66 X 2Q67 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE1768 X 3 S Y=$E(X),Y=$S(Y="R":"@30",(Y'="")&("CS"[Y):"@40",1:"@50")88 X11 Q 89 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 90 X12 S RAX=$E(X,1),Y=$S(RAX="R":"@30","CS"[RAX:"@40",RAX="I"&($D(RAWARD))!("EO"[RAX&('$D(RAWARD))):"@50",1:"@25") 69 91 Q 70 4 S DQ=5 ;@30 71 5 S DW="R;1",DV="FR",DU="",DLB="RESEARCH SOURCE",DIFLD=9.5 92 13 S DQ=14 ;@25 93 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 94 X14 I $D(RAWARD) W !?3,$C(7),"Please choose 'I' for INPATIENT, 'R' RESEARCH, 'C' CONTRACT,",!?3,"'S' SHARING!" 95 Q 96 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 97 X15 I '$D(RAWARD) W !?3,$C(7),"Please choose 'O' for OUTPATIENT, 'E' EMPLOYEE, 'R' RESEARCH,",!?3,"'C' CONTRACT, 'S' SHARING!" 98 Q 99 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 100 X16 D CS^RAORD1A I $D(RALIFN("OUT")) S Y="@26" 101 Q 102 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 103 X17 I '$D(RALIFN("NO")) S Y="@50" 104 Q 105 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 106 X18 K RALIFN("NO") 107 Q 108 19 S DQ=20 ;@26 109 20 S DW="0;4",DV="SX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4 110 S DU="I:INPATIENT;O:OUTPATIENT;C:CONTRACT;S:SHARING;E:EMPLOYEE;R:RESEARCH;" 111 S Y="@" 112 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 113 G RD 114 X20 Q 115 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 116 X21 K RALIFN("OUT") 117 Q 118 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 119 X22 S Y="@20" 120 Q 121 23 S DQ=24 ;@30 122 24 S DW="R;1",DV="FR",DU="",DLB="RESEARCH SOURCE",DIFLD=9.5 72 123 S X=$S($D(RARSH):RARSH,1:"") 73 124 S Y=X 74 125 G Y 75 X 5K:$L(X)>40!($L(X)<3) X126 X24 K:$L(X)>40!($L(X)<3) X 76 127 I $D(X),X'?.ANP K X 77 128 Q 78 129 ; 79 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE1780 X 6S Y="@50"130 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 131 X25 S Y="@50" 81 132 Q 82 7 S DQ=8;@4083 8S DW="0;9",DV="*P34'R",DU="",DLB="CONTRACT/SHARING SOURCE",DIFLD=9133 26 S DQ=27 ;@40 134 27 S DW="0;9",DV="*P34'R",DU="",DLB="CONTRACT/SHARING SOURCE",DIFLD=9 84 135 S DU="DIC(34," 85 136 S X=$S($D(RASHA):RASHA,1:"") 86 137 S Y=X 87 138 G Y 88 X 8S DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X139 X27 S DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 89 140 Q 90 141 ; 91 9 S DQ=10 ;@50 92 10 S DW="0;22",DV="P44'",DU="",DLB="REQUESTING LOCATION",DIFLD=22 142 28 S DQ=29 ;@50 143 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 144 X29 I RAX="I",($P($G(^SC(+RALIFN,0)),U,3)'="W"),($P($G(^SC(+RALIFN,0)),U,3)'="OR") S RAWHEN=$P($G(^RAO(75.1,DA,0)),U,21),RAWHEN=$S(RAWHEN]"":$P(RAWHEN,".",1),1:DT) D REQLOC1^RAORD1A 145 Q 146 30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 147 X30 I RAX="O",($P($G(^SC(+RALIFN,0)),U,3)'="C"),($P($G(^SC(+RALIFN,0)),U,3)'="OR") D REQLOC1^RAORD1A 148 Q 149 31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 150 X31 I $D(RALIFN("OUT")) K RALIFN("OUT") S Y="@999" 151 Q 152 32 S DW="0;22",DV="P44'a",DU="",DLB="REQUESTING LOCATION",DIFLD=22 153 S DE(DW)="C32^RACTOE3" 93 154 S DU="SC(" 94 155 S X=RALIFN … … 96 157 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 97 158 G RD:X="@",Z 98 X10 Q 99 11 S DQ=12 ;@100 100 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 101 X12 W !,"IS PATIENT SCHEDULED FOR PRE-OP" S %=2 D YN^DICN S:%<0 Y="@999" S:%=2 Y="@120" I '% W !!,"Enter 'YES' if patient is scheduled for pre-op, or 'NO' if not.",! S Y="@100" 159 C32 G C32S:$D(DE(32))[0 K DB 160 D ^RACTOE4 161 C32S S X="" G:DG(DQ)=X C32F1 K DB 162 D ^RACTOE5 163 C32F1 Q 164 X32 Q 165 33 S DQ=34 ;@100 166 34 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=34 D X34 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 167 X34 W !,"IS PATIENT SCHEDULED FOR PRE-OP" S %=2 D YN^DICN S:%<0 Y="@999" S:%=2 Y="@120" I '% W !!,"Enter 'YES' if patient is scheduled for pre-op, or 'NO' if not.",! S Y="@100" 102 168 Q 103 13 S DW="0;12",DV="D",DU="",DLB="PRE-OP SCHEDULED DATE (TIME optional)",DIFLD=12 104 S X="TODAY" 105 S Y=X 106 G Y 107 X13 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 108 Q 109 ; 110 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 111 X14 S:$D(RAEXMUL) RAPREOP1=X 112 Q 113 15 S DQ=16 ;@120 114 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 115 X16 I RASEX="M" S Y="@130" 116 Q 117 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 118 X17 I RASEX'="F" W !,"THE SEX OF THIS PATIENT IS NOT AVAILABLE. IS PATIENT FEMALE" S %=2 D YN^DICN S:%<0 Y="@999" S:%=2 Y="@130" I '% W !!,"Enter 'YES' if patient is female, or 'NO' if patient is male.",! S Y="@120" 119 Q 120 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 121 X18 S RASEX="F" 122 Q 123 19 S DW="0;13",DV="RS",DU="",DLB="PREGNANT",DIFLD=13 124 S DU="y:YES;n:NO;u:UNKNOWN;" 125 S X=$S($D(RAPREG):$$EXTERNAL^DILFD(75.1,13,"",RAPREG),1:"") 126 S Y=X 127 G Y 128 X19 Q 129 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 130 X20 S RAPREG=X 131 Q 132 21 S DQ=22 ;@130 133 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 134 X22 I '$D(RAVSTFLG)!('$D(RAVLEDTI)) S Y="@135" 135 Q 136 23 S DW="0;17",DV="D",DU="",DLB="PAST VISIT DATE/TIME",DIFLD=17 137 S X=9999999.9999-RAVLEDTI 138 S Y=X 139 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 140 G RD 141 X23 S %DT="TXR" D ^%DT S X=Y K:Y<1 X 142 Q 143 ; 144 24 S DQ=25 ;@135 145 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 146 X25 S:$D(RAWHEN)#2 Y="@145" 147 Q 148 26 S DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21 149 S DE(DW)="C26^RACTOE3" 150 G RE 151 C26 G C26S:$D(DE(26))[0 K DB 152 S X=DE(26),DIC=DIE 153 K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA) 154 C26S S X="" G:DG(DQ)=X C26F1 K DB 155 S X=DG(DQ),DIC=DIE 156 S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)="" 157 C26F1 Q 158 X26 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 159 Q 160 ; 161 27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 162 X27 S Y="@150" 163 Q 164 28 S DQ=29 ;@145 165 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 G A 166 30 D:$D(DG)>9 F^DIE17,DE S DQ=30,DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21 167 S DE(DW)="C30^RACTOE3" 168 S X=RAWHEN 169 S Y=X 170 G Y 171 C30 G C30S:$D(DE(30))[0 K DB 172 S X=DE(30),DIC=DIE 173 K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA) 174 C30S S X="" G:DG(DQ)=X C30F1 K DB 175 S X=DG(DQ),DIC=DIE 176 S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)="" 177 C30F1 Q 178 X30 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 179 Q 180 ; 181 31 S DQ=32 ;@150 182 32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 183 X32 S:$D(RAEXMUL)#2 RAWHEN=$$FMTE^XLFDT(X,1) 184 Q 185 33 D:$D(DG)>9 F^DIE17,DE S DQ=33,DW="0;5",DV="SX",DU="",DLB="REQUEST STATUS",DIFLD=5 186 S DE(DW)="C33^RACTOE3" 187 S DU="1:DISCONTINUED;2:COMPLETE;3:HOLD;5:PENDING;6:ACTIVE;8:SCHEDULED;11:UNRELEASED;" 188 S X=$S($D(RAPKG):5,$$ORVR^RAORDU()=2.5:11,1:5) 189 S Y=X 190 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 191 G RD:X="@",Z 192 C33 G C33S:$D(DE(33))[0 K DB 193 S X=DE(33),DIC=DIE 194 K ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA) 195 S X=DE(33),DIC=DIE 196 ; 197 C33S S X="" G:DG(DQ)=X C33F1 K DB 198 S X=DG(DQ),DIC=DIE 199 S ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)="" 200 S X=DG(DQ),DIC=DIE 201 D:$$ORVR^RAORDU()=2.5&((X=1)!(X=3)) CH^RADD2(DA,X) 202 C33F1 Q 203 X33 Q 204 34 D:$D(DG)>9 F^DIE17,DE S DQ=34,DW="0;18",DV="D",DU="",DLB="LAST ACTIVITY DATE/TIME",DIFLD=18 205 S DE(DW)="C34^RACTOE3" 206 S X="NOW" 207 S Y=X 208 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 209 G RD 210 C34 G C34S:$D(DE(34))[0 K DB 211 S X=DE(34),DIC=DIE 212 K ^RAO(75.1,"AO",$E(X,1,30),DA) 213 C34S S X="" G:DG(DQ)=X C34F1 K DB 214 S X=DG(DQ),DIC=DIE 215 S ^RAO(75.1,"AO",$E(X,1,30),DA)="" 216 C34F1 Q 217 X34 S %DT="TXR" D ^%DT S X=Y K:Y<1 X 218 Q 219 ; 220 35 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=35 D X35 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 221 X35 S Y=$S('$D(^RA(79,+RADIV,.1)):"@160",$P(^(.1),"^",19)="y":"@155",1:"@160") 222 Q 223 36 S DQ=37 ;@155 224 37 D:$D(DG)>9 F^DIE17,DE S DQ=37,D=0 K DE(1) ;75 225 S DIFLD=75,DGO="^RACTOE4",DC="4^75.12DA^T^",DV="75.12D",DW="0;1",DOW="STATUS CHANGE DATE/TIME",DLB="Select "_DOW S:D DC=DC_D 226 I $D(DSC(75.12))#2,$P(DSC(75.12),"I $D(^UTILITY(",1)="" X DSC(75.12) S D=$O(^(0)) S:D="" D=-1 G M37 227 S D=$S($D(^RAO(75.1,DA,"T",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 228 M37 I D>0 S DC=DC_D I $D(^RAO(75.1,DA,"T",+D,0)) S DE(37)=$P(^(0),U,1) 229 S X="""NOW""" 230 S Y=X 231 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 232 G RD 233 R37 D DE 234 G A 235 ; 236 38 S DQ=39 ;@160 237 39 D:$D(DG)>9 F^DIE17 G ^RACTOE5 169 35 D:$D(DG)>9 F^DIE17 G ^RACTOE6 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE4.m
r613 r623 1 RACTOE4 ; ;01/02/09 2 D DE G BEGIN 3 DE S DIE="^RAO(75.1,D0,""T"",",DIC=DIE,DP=75.12,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RAO(75.1,D0,"T",DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% 5 K %Z Q 6 ; 7 W W !?DL+DL-2,DLB_": " 8 Q 9 O D W W Y W:$X>45 !?9 10 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 11 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 12 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 13 Q 14 A K DQ(DQ) S DQ=DQ+1 15 B G @DQ 16 RE G PR:$D(DE(DQ)) D W,TR 17 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 18 RD G QS:X?."?" I X["^" D D G ^DIE17 19 I X="@" D D G Z^DIE2 20 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 21 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 22 K DDER G X 23 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 24 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 25 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 26 V D @("X"_DQ) K YS 27 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 28 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 29 S X="?BAD" 30 QS S DZ=X D D,QQ^DIEQ G B 31 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 32 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 33 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 34 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 35 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 36 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 37 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 38 I I DV'["I",DV'["#" G RD 39 D E^DIE0 G RD:$D(X),PR 40 Q 41 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 42 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 43 D ^DIR I 'DDER S %=Y(0),X=Y 44 Q 45 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 46 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 47 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 48 Q 49 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 51 BEGIN S DNM="RACTOE4",DQ=1 52 1 S DW="0;2",DV="S",DU="",DLB="NEW STATUS",DIFLD=2 53 S DU="1:DISCONTINUED;2:COMPLETE;3:HOLD;5:PENDING;6:ACTIVE;8:SCHEDULED;11:UNRELEASED;" 54 S X=$S($D(RAPKG):5,$$ORVR^RAORDU()=2.5:11,1:5) 55 S Y=X 56 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 57 G RD:X="@",Z 58 X1 Q 59 2 S DW="0;3",DV="P200'",DU="",DLB="COMPUTER USER",DIFLD=3 60 S DU="VA(200," 61 S X=DUZ 62 S Y=X 63 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 64 G RD:X="@",Z 65 X2 Q 66 3 G 1^DIE17 1 RACTOE4 ; ;12/27/07 2 S X=DE(32),DIIX=2_U_DIFLD D AUDIT^DIET -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE5.m
r613 r623 1 RACTOE5 ; ;01/02/09 2 D DE G BEGIN 3 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,6) S:%]"" DE(5)=% S %=$P(%Z,U,19) S:%]"" DE(1)=% S %=$P(%Z,U,20) S:%]"" DE(13)=%,DE(17)=% S %=$P(%Z,U,24) S:%]"" DE(3)=% S %=$P(%Z,U,26) S:%]"" DE(8)=% 5 K %Z Q 6 ; 7 W W !?DL+DL-2,DLB_": " 8 Q 9 O D W W Y W:$X>45 !?9 10 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 11 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 12 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 13 Q 14 A K DQ(DQ) S DQ=DQ+1 15 B G @DQ 16 RE G PR:$D(DE(DQ)) D W,TR 17 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 18 RD G QS:X?."?" I X["^" D D G ^DIE17 19 I X="@" D D G Z^DIE2 20 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 21 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 22 K DDER G X 23 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 24 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 25 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 26 V D @("X"_DQ) K YS 27 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 28 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 29 S X="?BAD" 30 QS S DZ=X D D,QQ^DIEQ G B 31 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 32 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 33 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 34 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 35 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 36 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 37 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 38 I I DV'["I",DV'["#" G RD 39 D E^DIE0 G RD:$D(X),PR 40 Q 41 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 42 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 43 D ^DIR I 'DDER S %=Y(0),X=Y 44 Q 45 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 46 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 47 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 48 Q 49 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 51 BEGIN S DNM="RACTOE5",DQ=1 52 1 S DW="0;19",DV="S",DU="",DLB="MODE OF TRANSPORT",DIFLD=19 53 S DU="a:AMBULATORY;p:PORTABLE;s:STRETCHER;w:WHEEL CHAIR;" 54 S X=$S($D(RAMT):$P(RAMT,"^",2),1:"AMBULATORY") 55 S Y=X 56 G Y 57 X1 Q 58 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 59 X2 S:$D(RAEXMUL) RAMT=X 60 Q 61 3 S DW="0;24",DV="S",DU="",DLB="IS PATIENT ON ISOLATION PROCEDURES?",DIFLD=24 62 S DU="y:YES;n:NO;" 63 S X="NO" 64 S Y=X 65 G Y 66 X3 Q 67 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 68 X4 S:$D(RAEXMUL) RAIP=X 69 Q 70 5 S DW="0;6",DV="S",DU="",DLB="REQUEST URGENCY",DIFLD=6 71 S DU="1:STAT;2:URGENT;9:ROUTINE;" 72 S X="ROUTINE" 73 S Y=X 74 G Y 75 X5 Q 76 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 77 X6 S:$D(RAEXMUL) RARU=X 78 Q 79 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 80 X7 S:$$ORVR^RAORDU()<3 Y="@163" 81 Q 82 8 S DW="0;26",DV="S",DU="",DLB="NATURE OF (NEW) ORDER ACTIVITY",DIFLD=26 83 S DU="w:WRITTEN;v:VERBAL;p:TELEPHONED;s:SERVICE CORRECTION;i:POLICY;e:PHYSICIAN ENTERED;" 84 S X="SERVICE CORRECTION" 85 S Y=X 86 G Y 87 X8 Q 88 9 S DQ=10 ;@163 89 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 90 X10 W ! 91 Q 92 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 93 X11 S RAREQLOC=$$ILOC^RAUTL18(RAPRI) 94 Q 95 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 96 X12 I 'RAREQLOC S Y="@165" 97 Q 98 13 S DW="0;20",DV="*P79.1'",DU="",DLB="IMAGING LOCATION",DIFLD=20 99 S DU="RA(79.1," 100 S X=RAREQLOC 101 S Y=X 102 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 103 G RD:X="@",Z 104 X13 Q 105 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 106 X14 S Y="@170" 107 Q 108 15 S DQ=16 ;@165 109 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 110 X16 I '$D(RALOCFLG) S Y="@175" 111 Q 112 17 S DW="0;20",DV="*P79.1'R",DU="",DLB="SUBMIT REQUEST TO",DIFLD=20 113 S DU="RA(79.1," 114 G RE 115 X17 S DIC("S")="I $$SUBMIT^RAUTL13(DA,+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 116 Q 117 ; 118 18 S DQ=19 ;@170 119 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 120 X19 S:$D(RAEXMUL) RAILOC=X 121 Q 122 20 S DQ=21 ;@175 123 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 124 X21 S (RAFIN,RAFIN1)="" 125 Q 126 22 S DQ=23 ;@999 127 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 128 X23 K RAI,RAPRI,RAMOD,RAIMAG,RAWPFLAG,RAREQLOC,RAMODPRO 129 Q 130 24 G 0^DIE17 1 RACTOE5 ; ;12/27/07 2 I $D(DE(32))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE.m
r613 r623 1 RACTQE ; GENERATED FROM 'RA QUICK EXAM ORDER' INPUT TEMPLATE(#1086), FILE 75.1; 01/02/091 RACTQE ; GENERATED FROM 'RA QUICK EXAM ORDER' INPUT TEMPLATE(#1086), FILE 75.1;12/27/07 2 2 D DE G BEGIN 3 3 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(2)=%,DE(9)=% S %=$P(%Z,U,4) S:%]"" DE(26)=% S %=$P(%Z,U,8) S:%]"" DE(14)=% S %=$P(%Z,U,12) S:%]"" DE(28)=% S %=$P(%Z,U,13) S:%]"" DE(31)=% S %=$P(%Z,U,21) S:%]"" DE(38)=% 5 I $D(^(.1)) S %Z=^(.1) S %=$P(%Z,U,1) S:%]"" DE(34)=% 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(2)=%,DE(9)=% S %=$P(%Z,U,4) S:%]"" DE(27)=% S %=$P(%Z,U,8) S:%]"" DE(14)=% 6 5 K %Z Q 7 6 ; … … 154 153 Q 155 154 25 S DQ=26 ;@35 156 26 S DW="0;4",DV="SX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4 155 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 156 X26 I '$D(RACAT) S RACAT="I" 157 Q 158 27 S DW="0;4",DV="SX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4 157 159 S DU="I:INPATIENT;O:OUTPATIENT;C:CONTRACT;S:SHARING;E:EMPLOYEE;R:RESEARCH;" 158 160 S X=$E(RACAT) … … 160 162 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 161 163 G RD:X="@",Z 162 X2 6Q163 2 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17164 X2 7I '$D(RAPREOP1) S Y="@40"164 X27 Q 165 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 166 X28 I '$D(RAPREOP1) S Y="@40" 165 167 Q 166 28 S DW="0;12",DV="D",DU="",DLB="PRE-OP SCHEDULED DATE/TIME",DIFLD=12 167 S X=RAPREOP1 168 S Y=X 169 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 170 G RD 171 X28 S %DT="TX" D ^%DT S X=Y K:Y<1 X 172 Q 173 ; 174 29 S DQ=30 ;@40 175 30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 176 X30 I '$D(RAPREG) S Y="@50" 177 Q 178 31 S DW="0;13",DV="RS",DU="",DLB="PREGNANT",DIFLD=13 179 S DU="y:YES;n:NO;u:UNKNOWN;" 180 S X=RAPREG 181 S Y=X 182 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 183 G RD 184 X31 Q 185 32 S DQ=33 ;@50 186 33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 187 X33 S RACOMENT="reason for study is required, clinical history is not with the release of 75" K RACOMENT 188 Q 189 34 S DW=".1;1",DV="RF",DU="",DLB="REASON FOR STUDY",DIFLD=1.1 190 S X=RAREAST 191 S Y=X 192 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 193 G RD:X="@",Z 194 X34 Q 195 35 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=35 D X35 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 196 X35 I $O(^TMP($J,"RAWP",0)) S ^RAO(75.1,DA,"H",0)=^(0) F RAI=1:1 Q:'$D(^TMP($J,"RAWP",RAI,0)) S ^RAO(75.1,DA,"H",RAI,0)=^(0) 197 Q 198 36 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=36 D X36 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 199 X36 I $O(^RAO(75.1,DA,"H",0)) D UPDT^RAUTL3("^RAO(75.1,"_DA_",""H"",") 200 Q 201 37 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=37 D X37 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 202 X37 S:$D(RAWHEN)#2 Y="@550" 203 Q 204 38 S DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21 205 S DE(DW)="C38^RACTQE" 206 G RE 207 C38 G C38S:$D(DE(38))[0 K DB 208 D ^RACTQE2 209 C38S S X="" G:DG(DQ)=X C38F1 K DB 210 D ^RACTQE3 211 C38F1 Q 212 X38 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 213 Q 214 ; 215 39 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=39 D X39 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 216 X39 S Y="@560" 217 Q 218 40 S DQ=41 ;@550 219 41 D:$D(DG)>9 F^DIE17 G ^RACTQE4 168 29 D:$D(DG)>9 F^DIE17 G ^RACTQE2 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE1.m
r613 r623 1 RACTQE1 ; ; 01/02/091 RACTQE1 ; ;12/27/07 2 2 D DE G BEGIN 3 3 DE S DIE="^RAO(75.1,D0,""M"",",DIC=DIE,DP=75.1125,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RAO(75.1,D0,"M",DA,""))="" -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE2.m
r613 r623 1 RACTQE2 ; ;01/02/09 2 S X=DE(38),DIC=DIE 1 RACTQE2 ; ;12/27/07 2 D DE G BEGIN 3 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,3) S:%]"" DE(31)=% S %=$P(%Z,U,12) S:%]"" DE(1)=% S %=$P(%Z,U,13) S:%]"" DE(4)=% S %=$P(%Z,U,20) S:%]"" DE(18)=%,DE(23)=%,DE(27)=% S %=$P(%Z,U,21) S:%]"" DE(11)=%,DE(15)=% 5 I $D(^(.1)) S %Z=^(.1) S %=$P(%Z,U,1) S:%]"" DE(7)=% 6 K %Z Q 7 ; 8 W W !?DL+DL-2,DLB_": " 9 Q 10 O D W W Y W:$X>45 !?9 11 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 12 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 13 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 14 Q 15 A K DQ(DQ) S DQ=DQ+1 16 B G @DQ 17 RE G PR:$D(DE(DQ)) D W,TR 18 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 19 RD G QS:X?."?" I X["^" D D G ^DIE17 20 I X="@" D D G Z^DIE2 21 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 22 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 23 K DDER G X 24 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 25 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 26 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 27 V D @("X"_DQ) K YS 28 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 29 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 30 S X="?BAD" 31 QS S DZ=X D D,QQ^DIEQ G B 32 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 33 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 34 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 35 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 36 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 37 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 38 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 39 I I DV'["I",DV'["#" G RD 40 D E^DIE0 G RD:$D(X),PR 41 Q 42 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 43 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 44 D ^DIR I 'DDER S %=Y(0),X=Y 45 Q 46 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 47 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 48 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 49 Q 50 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 51 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 52 BEGIN S DNM="RACTQE2",DQ=1 53 1 S DW="0;12",DV="D",DU="",DLB="PRE-OP SCHEDULED DATE/TIME",DIFLD=12 54 S X=RAPREOP1 55 S Y=X 56 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 57 G RD 58 X1 S %DT="TX" D ^%DT S X=Y K:Y<1 X 59 Q 60 ; 61 2 S DQ=3 ;@40 62 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 63 X3 I '$D(RAPREG) S Y="@50" 64 Q 65 4 S DW="0;13",DV="RS",DU="",DLB="PREGNANT",DIFLD=13 66 S DU="y:YES;n:NO;u:UNKNOWN;" 67 S X=RAPREG 68 S Y=X 69 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 70 G RD 71 X4 Q 72 5 S DQ=6 ;@50 73 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 74 X6 S RACOMENT="reason for study is required, clinical history is not with the release of 75" K RACOMENT 75 Q 76 7 S DW=".1;1",DV="RF",DU="",DLB="REASON FOR STUDY",DIFLD=1.1 77 S X=RAREAST 78 S Y=X 79 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 80 G RD:X="@",Z 81 X7 Q 82 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 83 X8 I $O(^TMP($J,"RAWP",0)) S ^RAO(75.1,DA,"H",0)=^(0) F RAI=1:1 Q:'$D(^TMP($J,"RAWP",RAI,0)) S ^RAO(75.1,DA,"H",RAI,0)=^(0) 84 Q 85 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 86 X9 I $O(^RAO(75.1,DA,"H",0)) D UPDT^RAUTL3("^RAO(75.1,"_DA_",""H"",") 87 Q 88 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 89 X10 S:$D(RAWHEN)#2 Y="@550" 90 Q 91 11 S DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21 92 S DE(DW)="C11^RACTQE2" 93 G RE 94 C11 G C11S:$D(DE(11))[0 K DB 95 S X=DE(11),DIC=DIE 3 96 K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA) 97 C11S S X="" G:DG(DQ)=X C11F1 K DB 98 S X=DG(DQ),DIC=DIE 99 S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)="" 100 C11F1 Q 101 X11 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 102 Q 103 ; 104 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 105 X12 S RAWHEN=$$FMTE^XLFDT(X,1) 106 Q 107 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 108 X13 S Y="@560" 109 Q 110 14 S DQ=15 ;@550 111 15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="0;21",DV="D",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21 112 S DE(DW)="C15^RACTQE2" 113 S X=RAWHEN 114 S Y=X 115 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 116 G RD 117 C15 G C15S:$D(DE(15))[0 K DB 118 S X=DE(15),DIC=DIE 119 K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA) 120 C15S S X="" G:DG(DQ)=X C15F1 K DB 121 S X=DG(DQ),DIC=DIE 122 S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)="" 123 C15F1 Q 124 X15 S %DT="TX" D ^%DT S X=Y K:Y<1 X 125 Q 126 ; 127 16 S DQ=17 ;@560 128 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 129 X17 I $S('$D(RAILOC):1,'RAILOC:1,1:0) S Y="@60" 130 Q 131 18 D:$D(DG)>9 F^DIE17,DE S DQ=18,DW="0;20",DV="*P79.1'",DU="",DLB="IMAGING LOCATION",DIFLD=20 132 S DU="RA(79.1," 133 S X=RAILOC 134 S Y=X 135 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 136 G RD:X="@",Z 137 X18 Q 138 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 139 X19 S Y="@70" 140 Q 141 20 S DQ=21 ;@60 142 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 143 X21 S RAREQLOC=$$ILOC^RAUTL18(RAPRI) 144 Q 145 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 146 X22 I 'RAREQLOC S Y="@62" 147 Q 148 23 S DW="0;20",DV="*P79.1'",DU="",DLB="IMAGING LOCATION",DIFLD=20 149 S DU="RA(79.1," 150 S X=RAREQLOC 151 S Y=X 152 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 153 G RD:X="@",Z 154 X23 Q 155 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 156 X24 S Y="@67" 157 Q 158 25 S DQ=26 ;@62 159 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 160 X26 I '$D(RALOCFLG) S Y="@70" 161 Q 162 27 S DW="0;20",DV="*P79.1'R",DU="",DLB="SUBMIT REQUEST TO",DIFLD=20 163 S DU="RA(79.1," 164 G RE 165 X27 S DIC("S")="I $$SUBMIT^RAUTL13(DA,+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 166 Q 167 ; 168 28 S DQ=29 ;@67 169 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 170 X29 S:$D(RAEXMUL) RAILOC=X 171 Q 172 30 S DQ=31 ;@70 173 31 S DW="0;3",DV="P79.2'",DU="",DLB="TYPE OF IMAGING",DIFLD=3 174 S DU="RA(79.2," 175 S X=$P(RAIMAG,U) 176 S Y=X 177 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 178 G RD:X="@",Z 179 X31 Q 180 32 D:$D(DG)>9 F^DIE17 G ^RACTQE3 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE3.m
r613 r623 1 RACTQE3 ; ;01/02/09 1 RACTQE3 ; ;12/27/07 2 D DE G BEGIN 3 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(7)=% S %=$P(%Z,U,6) S:%]"" DE(15)=% S %=$P(%Z,U,14) S:%]"" DE(1)=% S %=$P(%Z,U,18) S:%]"" DE(8)=% S %=$P(%Z,U,19) S:%]"" DE(11)=% S %=$P(%Z,U,22) S:%]"" DE(6)=% S %=$P(%Z,U,24) S:%]"" DE(13)=% 5 I S %=$P(%Z,U,26) S:%]"" DE(17)=% 6 K %Z Q 7 ; 8 W W !?DL+DL-2,DLB_": " 9 Q 10 O D W W Y W:$X>45 !?9 11 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 12 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 13 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 14 Q 15 A K DQ(DQ) S DQ=DQ+1 16 B G @DQ 17 RE G PR:$D(DE(DQ)) D W,TR 18 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 19 RD G QS:X?."?" I X["^" D D G ^DIE17 20 I X="@" D D G Z^DIE2 21 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 22 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 23 K DDER G X 24 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 25 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 26 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 27 V D @("X"_DQ) K YS 28 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 29 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 30 S X="?BAD" 31 QS S DZ=X D D,QQ^DIEQ G B 32 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 33 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 34 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 35 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 36 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 37 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 38 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 39 I I DV'["I",DV'["#" G RD 40 D E^DIE0 G RD:$D(X),PR 41 Q 42 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 43 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 44 D ^DIR I 'DDER S %=Y(0),X=Y 45 Q 46 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 47 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 48 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 49 Q 50 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 51 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 52 BEGIN S DNM="RACTQE3",DQ=1 53 1 S DW="0;14",DV="R*P200'X",DU="",DLB="REQUESTING PHYSICIAN",DIFLD=14 54 S DU="VA(200," 55 S X=RAPIFN 56 S Y=X 57 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 58 G RD:X="@",Z 59 X1 Q 60 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 61 X2 S RAX=$P(^RAO(75.1,DA,0),U,4) 62 Q 63 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 64 X3 I RAX="I",$P($G(^SC(+RALIFN,0)),U,3)'="W",($P($G(^SC(+RALIFN,0)),U,3)'="OR") D REQLOC1^RAORD1A 65 Q 66 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 67 X4 I RAX="O",$P($G(^SC(+RALIFN,0)),U,3)'="C",($P($G(^SC(+RALIFN,0)),U,3)'="OR") D REQLOC1^RAORD1A 68 Q 69 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 70 X5 I $D(RALIFN("OUT")) K RALIFN("OUT") S Y="@99" 71 Q 72 6 S DW="0;22",DV="P44'a",DU="",DLB="REQUESTING LOCATION",DIFLD=22 73 S DE(DW)="C6^RACTQE3" 74 S DU="SC(" 75 S X=RALIFN 76 S Y=X 77 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 78 G RD:X="@",Z 79 C6 G C6S:$D(DE(6))[0 K DB 80 S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET 81 C6S S X="" G:DG(DQ)=X C6F1 K DB 82 I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET 83 C6F1 Q 84 X6 Q 85 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="0;5",DV="SX",DU="",DLB="REQUEST STATUS",DIFLD=5 86 S DE(DW)="C7^RACTQE3" 87 S DU="1:DISCONTINUED;2:COMPLETE;3:HOLD;5:PENDING;6:ACTIVE;8:SCHEDULED;11:UNRELEASED;" 88 S X=$S($D(RAPKG):5,$$ORVR^RAORDU()=2.5:11,1:5) 89 S Y=X 90 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 91 G RD:X="@",Z 92 C7 G C7S:$D(DE(7))[0 K DB 93 S X=DE(7),DIC=DIE 94 K ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA) 95 S X=DE(7),DIC=DIE 96 ; 97 C7S S X="" G:DG(DQ)=X C7F1 K DB 2 98 S X=DG(DQ),DIC=DIE 3 S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)="" 99 S ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)="" 100 S X=DG(DQ),DIC=DIE 101 D:$$ORVR^RAORDU()=2.5&((X=1)!(X=3)) CH^RADD2(DA,X) 102 C7F1 Q 103 X7 Q 104 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;18",DV="D",DU="",DLB="LAST ACTIVITY DATE/TIME",DIFLD=18 105 S DE(DW)="C8^RACTQE3" 106 S X="NOW" 107 S Y=X 108 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 109 G RD 110 C8 G C8S:$D(DE(8))[0 K DB 111 S X=DE(8),DIC=DIE 112 K ^RAO(75.1,"AO",$E(X,1,30),DA) 113 C8S S X="" G:DG(DQ)=X C8F1 K DB 114 S X=DG(DQ),DIC=DIE 115 S ^RAO(75.1,"AO",$E(X,1,30),DA)="" 116 C8F1 Q 117 X8 S %DT="TXR" D ^%DT S X=Y K:Y<1 X 118 Q 119 ; 120 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,D=0 K DE(1) ;75 121 S DIFLD=75,DGO="^RACTQE4",DC="4^75.12DA^T^",DV="75.12D",DW="0;1",DOW="STATUS CHANGE DATE/TIME",DLB="Select "_DOW S:D DC=DC_D 122 I $D(DSC(75.12))#2,$P(DSC(75.12),"I $D(^UTILITY(",1)="" X DSC(75.12) S D=$O(^(0)) S:D="" D=-1 G M9 123 S D=$S($D(^RAO(75.1,DA,"T",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 124 M9 I D>0 S DC=DC_D I $D(^RAO(75.1,DA,"T",+D,0)) S DE(9)=$P(^(0),U,1) 125 S X="""NOW""" 126 S Y=X 127 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 128 G RD 129 R9 D DE 130 G A 131 ; 132 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 133 X10 I '$D(RAMT) S RAMT="a" 134 Q 135 11 S DW="0;19",DV="S",DU="",DLB="MODE OF TRANSPORT",DIFLD=19 136 S DU="a:AMBULATORY;p:PORTABLE;s:STRETCHER;w:WHEEL CHAIR;" 137 S X=$P(RAMT,"^") 138 S Y=X 139 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 140 G RD:X="@",Z 141 X11 Q 142 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 143 X12 I '$D(RAIP) S RAIP="n" 144 Q 145 13 S DW="0;24",DV="S",DU="",DLB="ISOLATION PROCEDURES",DIFLD=24 146 S DU="y:YES;n:NO;" 147 S X=RAIP 148 S Y=X 149 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 150 G RD:X="@",Z 151 X13 Q 152 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 153 X14 I '$D(RARU) S RARU=9 154 Q 155 15 S DW="0;6",DV="S",DU="",DLB="REQUEST URGENCY",DIFLD=6 156 S DU="1:STAT;2:URGENT;9:ROUTINE;" 157 S X=RARU 158 S Y=X 159 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 160 G RD:X="@",Z 161 X15 Q 162 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 163 X16 S:$$ORVR^RAORDU()<3 Y="@80" 164 Q 165 17 S DW="0;26",DV="S",DU="",DLB="NATURE OF (NEW) ORDER ACTIVITY",DIFLD=26 166 S DU="w:WRITTEN;v:VERBAL;p:TELEPHONED;s:SERVICE CORRECTION;i:POLICY;e:PHYSICIAN ENTERED;" 167 S Y="s" 168 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 169 G RD:X="@",Z 170 X17 Q 171 18 S DQ=19 ;@80 172 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 173 X19 S RAFIN=1 174 Q 175 20 S DQ=21 ;@99 176 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 177 X21 K RAI,RAPRI,RAMOD,RAIMAG,RAREQLOC,RAMODPRO 178 Q 179 22 G 0^DIE17 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE4.m
r613 r623 1 RACTQE4 ; ; 01/02/091 RACTQE4 ; ;12/27/07 2 2 D DE G BEGIN 3 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,3) S:%]"" DE(18)=% S %=$P(%Z,U,5) S:%]"" DE(21)=% S %=$P(%Z,U,6) S:%]"" DE(29)=% S %=$P(%Z,U,14) S:%]"" DE(19)=% S %=$P(%Z,U,18) S:%]"" DE(22)=% S %=$P(%Z,U,19) S:%]"" DE(25)=% 5 I S %=$P(%Z,U,20) S:%]"" DE(5)=%,DE(10)=%,DE(14)=% S %=$P(%Z,U,21) S:%]"" DE(1)=% S %=$P(%Z,U,22) S:%]"" DE(20)=% S %=$P(%Z,U,24) S:%]"" DE(27)=% S %=$P(%Z,U,26) S:%]"" DE(31)=% 3 DE S DIE="^RAO(75.1,D0,""T"",",DIC=DIE,DP=75.12,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RAO(75.1,D0,"T",DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% 6 5 K %Z Q 7 6 ; … … 51 50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 52 51 BEGIN S DNM="RACTQE4",DQ=1 53 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21 54 S DE(DW)="C1^RACTQE4" 55 S X=RAWHEN 56 S Y=X 57 G Y 58 C1 G C1S:$D(DE(1))[0 K DB 59 S X=DE(1),DIC=DIE 60 K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA) 61 C1S S X="" G:DG(DQ)=X C1F1 K DB 62 S X=DG(DQ),DIC=DIE 63 S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)="" 64 C1F1 Q 65 X1 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 66 Q 67 ; 68 2 S DQ=3 ;@560 69 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 70 X3 S:$D(RAEXMUL)#2 RAWHEN=$$FMTE^XLFDT(X,1) 71 Q 72 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 73 X4 I $S('$D(RAILOC):1,'RAILOC:1,1:0) S Y="@60" 74 Q 75 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;20",DV="*P79.1'",DU="",DLB="IMAGING LOCATION",DIFLD=20 76 S DU="RA(79.1," 77 S X=RAILOC 78 S Y=X 79 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 80 G RD:X="@",Z 81 X5 Q 82 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 83 X6 S Y="@70" 84 Q 85 7 S DQ=8 ;@60 86 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 87 X8 S RAREQLOC=$$ILOC^RAUTL18(RAPRI) 88 Q 89 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 90 X9 I 'RAREQLOC S Y="@62" 91 Q 92 10 S DW="0;20",DV="*P79.1'",DU="",DLB="IMAGING LOCATION",DIFLD=20 93 S DU="RA(79.1," 94 S X=RAREQLOC 95 S Y=X 96 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 97 G RD:X="@",Z 98 X10 Q 99 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 100 X11 S Y="@67" 101 Q 102 12 S DQ=13 ;@62 103 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 104 X13 I '$D(RALOCFLG) S Y="@70" 105 Q 106 14 S DW="0;20",DV="*P79.1'R",DU="",DLB="SUBMIT REQUEST TO",DIFLD=20 107 S DU="RA(79.1," 108 G RE 109 X14 S DIC("S")="I $$SUBMIT^RAUTL13(DA,+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 110 Q 111 ; 112 15 S DQ=16 ;@67 113 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 114 X16 S:$D(RAEXMUL) RAILOC=X 115 Q 116 17 S DQ=18 ;@70 117 18 S DW="0;3",DV="P79.2'",DU="",DLB="TYPE OF IMAGING",DIFLD=3 118 S DU="RA(79.2," 119 S X=$P(RAIMAG,U) 120 S Y=X 121 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 122 G RD:X="@",Z 123 X18 Q 124 19 S DW="0;14",DV="R*P200'X",DU="",DLB="REQUESTING PHYSICIAN",DIFLD=14 125 S DU="VA(200," 126 S X=RAPIFN 127 S Y=X 128 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 129 G RD:X="@",Z 130 X19 Q 131 20 S DW="0;22",DV="P44'",DU="",DLB="REQUESTING LOCATION",DIFLD=22 132 S DU="SC(" 133 S X=RALIFN 134 S Y=X 135 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 136 G RD:X="@",Z 137 X20 Q 138 21 S DW="0;5",DV="SX",DU="",DLB="REQUEST STATUS",DIFLD=5 139 S DE(DW)="C21^RACTQE4" 52 1 S DW="0;2",DV="S",DU="",DLB="NEW STATUS",DIFLD=2 140 53 S DU="1:DISCONTINUED;2:COMPLETE;3:HOLD;5:PENDING;6:ACTIVE;8:SCHEDULED;11:UNRELEASED;" 141 54 S X=$S($D(RAPKG):5,$$ORVR^RAORDU()=2.5:11,1:5) … … 143 56 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 144 57 G RD:X="@",Z 145 C21 G C21S:$D(DE(21))[0 K DB 146 S X=DE(21),DIC=DIE 147 K ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA) 148 S X=DE(21),DIC=DIE 149 ; 150 C21S S X="" G:DG(DQ)=X C21F1 K DB 151 S X=DG(DQ),DIC=DIE 152 S ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)="" 153 S X=DG(DQ),DIC=DIE 154 D:$$ORVR^RAORDU()=2.5&((X=1)!(X=3)) CH^RADD2(DA,X) 155 C21F1 Q 156 X21 Q 157 22 D:$D(DG)>9 F^DIE17,DE S DQ=22,DW="0;18",DV="D",DU="",DLB="LAST ACTIVITY DATE/TIME",DIFLD=18 158 S DE(DW)="C22^RACTQE4" 159 S X="NOW" 160 S Y=X 161 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 162 G RD 163 C22 G C22S:$D(DE(22))[0 K DB 164 S X=DE(22),DIC=DIE 165 K ^RAO(75.1,"AO",$E(X,1,30),DA) 166 C22S S X="" G:DG(DQ)=X C22F1 K DB 167 S X=DG(DQ),DIC=DIE 168 S ^RAO(75.1,"AO",$E(X,1,30),DA)="" 169 C22F1 Q 170 X22 S %DT="TXR" D ^%DT S X=Y K:Y<1 X 171 Q 172 ; 173 23 D:$D(DG)>9 F^DIE17,DE S DQ=23,D=0 K DE(1) ;75 174 S DIFLD=75,DGO="^RACTQE5",DC="4^75.12DA^T^",DV="75.12D",DW="0;1",DOW="STATUS CHANGE DATE/TIME",DLB="Select "_DOW S:D DC=DC_D 175 I $D(DSC(75.12))#2,$P(DSC(75.12),"I $D(^UTILITY(",1)="" X DSC(75.12) S D=$O(^(0)) S:D="" D=-1 G M23 176 S D=$S($D(^RAO(75.1,DA,"T",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 177 M23 I D>0 S DC=DC_D I $D(^RAO(75.1,DA,"T",+D,0)) S DE(23)=$P(^(0),U,1) 178 S X="""NOW""" 179 S Y=X 180 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 181 G RD 182 R23 D DE 183 G A 184 ; 185 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 186 X24 I '$D(RAMT) S RAMT="a" 187 Q 188 25 S DW="0;19",DV="S",DU="",DLB="MODE OF TRANSPORT",DIFLD=19 189 S DU="a:AMBULATORY;p:PORTABLE;s:STRETCHER;w:WHEEL CHAIR;" 190 S X=$P(RAMT,"^") 58 X1 Q 59 2 S DW="0;3",DV="P200'",DU="",DLB="COMPUTER USER",DIFLD=3 60 S DU="VA(200," 61 S X=DUZ 191 62 S Y=X 192 63 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 193 64 G RD:X="@",Z 194 X25 Q 195 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 196 X26 I '$D(RAIP) S RAIP="n" 197 Q 198 27 S DW="0;24",DV="S",DU="",DLB="ISOLATION PROCEDURES",DIFLD=24 199 S DU="y:YES;n:NO;" 200 S X=RAIP 201 S Y=X 202 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 203 G RD:X="@",Z 204 X27 Q 205 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 206 X28 I '$D(RARU) S RARU=9 207 Q 208 29 S DW="0;6",DV="S",DU="",DLB="REQUEST URGENCY",DIFLD=6 209 S DU="1:STAT;2:URGENT;9:ROUTINE;" 210 S X=RARU 211 S Y=X 212 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 213 G RD:X="@",Z 214 X29 Q 215 30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 216 X30 S:$$ORVR^RAORDU()<3 Y="@80" 217 Q 218 31 S DW="0;26",DV="S",DU="",DLB="NATURE OF (NEW) ORDER ACTIVITY",DIFLD=26 219 S DU="w:WRITTEN;v:VERBAL;p:TELEPHONED;s:SERVICE CORRECTION;i:POLICY;e:PHYSICIAN ENTERED;" 220 S Y="s" 221 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 222 G RD:X="@",Z 223 X31 Q 224 32 S DQ=33 ;@80 225 33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 226 X33 S RAFIN=1 227 Q 228 34 S DQ=35 ;@99 229 35 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=35 D X35 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 230 X35 K RAI,RAPRI,RAMOD,RAIMAG,RAREQLOC,RAMODPRO 231 Q 232 36 G 0^DIE17 65 X2 Q 66 3 G 1^DIE17 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE5.m
r613 r623 1 RACTQE5 ; ; 01/02/091 RACTQE5 ; ;12/10/05 2 2 D DE G BEGIN 3 DE S DIE="^RAO(75.1, D0,""T"",",DIC=DIE,DP=75.12,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RAO(75.1,D0,"T",DA,""))=""4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U, 2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=%3 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(1)=% S %=$P(%Z,U,6) S:%]"" DE(9)=% S %=$P(%Z,U,18) S:%]"" DE(2)=% S %=$P(%Z,U,19) S:%]"" DE(5)=% S %=$P(%Z,U,24) S:%]"" DE(7)=% S %=$P(%Z,U,26) S:%]"" DE(11)=% 5 5 K %Z Q 6 6 ; … … 50 50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 51 51 BEGIN S DNM="RACTQE5",DQ=1 52 1 S DW="0;2",DV="S",DU="",DLB="NEW STATUS",DIFLD=2 52 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;5",DV="SX",DU="",DLB="REQUEST STATUS",DIFLD=5 53 S DE(DW)="C1^RACTQE5" 53 54 S DU="1:DISCONTINUED;2:COMPLETE;3:HOLD;5:PENDING;6:ACTIVE;8:SCHEDULED;11:UNRELEASED;" 54 55 S X=$S($D(RAPKG):5,$$ORVR^RAORDU()=2.5:11,1:5) … … 56 57 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 57 58 G RD:X="@",Z 59 C1 G C1S:$D(DE(1))[0 K DB 60 S X=DE(1),DIC=DIE 61 K ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA) 62 S X=DE(1),DIC=DIE 63 ; 64 C1S S X="" G:DG(DQ)=X C1F1 K DB 65 S X=DG(DQ),DIC=DIE 66 S ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)="" 67 S X=DG(DQ),DIC=DIE 68 D:$$ORVR^RAORDU()=2.5&((X=1)!(X=3)) CH^RADD2(DA,X) 69 C1F1 Q 58 70 X1 Q 59 2 S DW="0;3",DV="P200'",DU="",DLB="COMPUTER USER",DIFLD=3 60 S DU="VA(200," 61 S X=DUZ 71 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;18",DV="D",DU="",DLB="LAST ACTIVITY DATE/TIME",DIFLD=18 72 S DE(DW)="C2^RACTQE5" 73 S X="NOW" 74 S Y=X 75 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 76 G RD 77 C2 G C2S:$D(DE(2))[0 K DB 78 S X=DE(2),DIC=DIE 79 K ^RAO(75.1,"AO",$E(X,1,30),DA) 80 C2S S X="" G:DG(DQ)=X C2F1 K DB 81 S X=DG(DQ),DIC=DIE 82 S ^RAO(75.1,"AO",$E(X,1,30),DA)="" 83 C2F1 Q 84 X2 S %DT="TXR" D ^%DT S X=Y K:Y<1 X 85 Q 86 ; 87 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,D=0 K DE(1) ;75 88 S DIFLD=75,DGO="^RACTQE6",DC="4^75.12DA^T^",DV="75.12D",DW="0;1",DOW="STATUS CHANGE DATE/TIME",DLB="Select "_DOW S:D DC=DC_D 89 I $D(DSC(75.12))#2,$P(DSC(75.12),"I $D(^UTILITY(",1)="" X DSC(75.12) S D=$O(^(0)) S:D="" D=-1 G M3 90 S D=$S($D(^RAO(75.1,DA,"T",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 91 M3 I D>0 S DC=DC_D I $D(^RAO(75.1,DA,"T",+D,0)) S DE(3)=$P(^(0),U,1) 92 S X="""NOW""" 93 S Y=X 94 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 95 G RD 96 R3 D DE 97 G A 98 ; 99 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 100 X4 I '$D(RAMT) S RAMT="a" 101 Q 102 5 S DW="0;19",DV="S",DU="",DLB="MODE OF TRANSPORT",DIFLD=19 103 S DU="a:AMBULATORY;p:PORTABLE;s:STRETCHER;w:WHEEL CHAIR;" 104 S X=$P(RAMT,"^") 62 105 S Y=X 63 106 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 64 107 G RD:X="@",Z 65 X2 Q 66 3 G 1^DIE17 108 X5 Q 109 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 110 X6 I '$D(RAIP) S RAIP="n" 111 Q 112 7 S DW="0;24",DV="S",DU="",DLB="ISOLATION PROCEDURES",DIFLD=24 113 S DU="y:YES;n:NO;" 114 S X=RAIP 115 S Y=X 116 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 117 G RD:X="@",Z 118 X7 Q 119 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 120 X8 I '$D(RARU) S RARU=9 121 Q 122 9 S DW="0;6",DV="S",DU="",DLB="REQUEST URGENCY",DIFLD=6 123 S DU="1:STAT;2:URGENT;9:ROUTINE;" 124 S X=RARU 125 S Y=X 126 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 127 G RD:X="@",Z 128 X9 Q 129 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 130 X10 S:$$ORVR^RAORDU()<3 Y="@80" 131 Q 132 11 S DW="0;26",DV="S",DU="",DLB="NATURE OF (NEW) ORDER ACTIVITY",DIFLD=26 133 S DU="w:WRITTEN;v:VERBAL;p:TELEPHONED;s:SERVICE CORRECTION;i:POLICY;e:PHYSICIAN ENTERED;" 134 S Y="s" 135 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 136 G RD:X="@",Z 137 X11 Q 138 12 S DQ=13 ;@80 139 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 140 X13 S RAFIN=1 141 Q 142 14 S DQ=15 ;@99 143 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 144 X15 K RAI,RAPRI,RAMOD,RAIMAG,RAREQLOC,RAMODPRO 145 Q 146 16 G 0^DIE17 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG.m
r613 r623 1 RACTRG ; GENERATED FROM 'RA REGISTER' INPUT TEMPLATE(#1083), FILE 70; 01/02/091 RACTRG ; GENERATED FROM 'RA REGISTER' INPUT TEMPLATE(#1083), FILE 70;11/06/06 2 2 D DE G BEGIN 3 3 DE S DIE="^RADPT(",DIC=DIE,DP=70,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RADPT(DA,""))="" -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG1.m
r613 r623 1 RACTRG1 ; ; 01/02/091 RACTRG1 ; ;11/06/06 2 2 D DE G BEGIN 3 3 DE S DIE="^RADPT(D0,""DT"",",DIC=DIE,DP=70.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",DA,""))="" -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG10.m
r613 r623 1 RACTRG10 ; ;01/02/09 2 ;; 3 1 N X,X1,X2 S DIXR=490 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X 4 I $G(X(1))]"" D 5 . D KRAD^RAPXRM(.X,.DA) 6 K X M X=X2 I $G(X(1))]"" D 7 . D SRAD^RAPXRM(.X,.DA) 1 RACTRG10 ; ;11/06/06 2 D DE G BEGIN 3 DE S DIE="^RADPT(D0,""DT"",D1,""P"",D2,""L"",",DIC=DIE,DP=70.07,DL=4,DIEL=3,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",D2,"L",DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% 5 I $D(^("TCOM")) S %Z=^("TCOM") S %=$E(%Z,1,245) S:%'?." " DE(4)=%,DE(6)=% 6 K %Z Q 7 ; 8 W W !?DL+DL-2,DLB_": " 8 9 Q 9 X1(DION) K X 10 S X(1)=$G(@DIEZTMP@("V",70.03,DIIENS,2,DION),$P($G(^RADPT(DA(2),"DT",DA(1),"P",DA,0)),U,2)) 11 S X=$G(X(1)) 10 O D W W Y W:$X>45 !?9 11 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 12 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 13 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 12 14 Q 15 A K DQ(DQ) S DQ=DQ+1 16 B G @DQ 17 RE G PR:$D(DE(DQ)) D W,TR 18 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 19 RD G QS:X?."?" I X["^" D D G ^DIE17 20 I X="@" D D G Z^DIE2 21 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 22 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 23 K DDER G X 24 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 25 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 26 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 27 V D @("X"_DQ) K YS 28 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 29 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 30 S X="?BAD" 31 QS S DZ=X D D,QQ^DIEQ G B 32 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 33 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 34 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 35 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 36 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 37 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 38 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 39 I I DV'["I",DV'["#" G RD 40 D E^DIE0 G RD:$D(X),PR 41 Q 42 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 43 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 44 D ^DIR I 'DDER S %=Y(0),X=Y 45 Q 46 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 47 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 48 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 49 Q 50 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 51 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 52 BEGIN S DNM="RACTRG10",DQ=1 53 1 S DW="0;2",DV="RSI",DU="",DLB="TYPE OF ACTION",DIFLD=2 54 S DU="E:EXAM ENTRY;C:EDIT BY CASE NO.;P:EDIT BY PATIENT;D:DIAGNOSIS ENTRY BY CASE NO.;S:EXAM STATUS TRACKING;X:CANCELLED;O:COMPLETE STATUS OVERRIDE;U:UPDATE STATUS;N:NO PURGING SPECIFIED;" 55 S X="E" 56 S Y=X 57 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 58 G RD 59 X1 Q 60 2 S DW="0;3",DV="RP200'I",DU="",DLB="COMPUTER USER",DIFLD=3 61 S DU="VA(200," 62 S X=RADUZ 63 S Y=X 64 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 65 G RD:X="@",Z 66 X2 Q 67 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 68 X3 S RATCXX=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI) 69 Q 70 4 S DW="TCOM;E1,245",DV="F",DU="",DLB="TECHNOLOGIST COMMENT",DIFLD=4 71 S X=RATCXX 72 S Y=X 73 G Y 74 X4 K:$L(X)>245!($L(X)<3)!'(X?1A.ANP) X 75 I $D(X),X'?.ANP K X 76 Q 77 ; 78 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 79 X5 S:RATCXX'=X Y="@18" 80 Q 81 6 S DW="TCOM;E1,245",DV="F",DU="",DLB="TECHNOLOGIST COMMENT",DIFLD=4 82 S Y="@" 83 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 84 G RD 85 X6 K:$L(X)>245!($L(X)<3)!'(X?1A.ANP) X 86 I $D(X),X'?.ANP K X 87 Q 88 ; 89 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 90 X7 K ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",DA,"TCOM") 91 Q 92 8 S DQ=9 ;@18 93 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 94 X9 K RATCXX S RAFIN="" 95 Q 96 10 G 1^DIE17 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG2.m
r613 r623 1 RACTRG2 ; ; 01/02/091 RACTRG2 ; ;11/06/06 2 2 D DE G BEGIN 3 3 DE S DIE="^RADPT(D0,""DT"",D1,""P"",",DIC=DIE,DP=70.03,DL=3,DIEL=2,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",DA,""))="" … … 178 178 X26 S:'$D(^RAMIS(71.2,"AB",+$$ITYPE^RASITE(+$G(RAPRI)),RAI)) Y="@5" 179 179 Q 180 27 D:$D(DG)>9 F^DIE17,DE S DQ=27,D=0 K DE(1) ;125 181 S DIFLD=125,DGO="^RACTRG3",DC="1^70.1P^M^",DV="70.1M*P71.2'X",DW="0;1",DOW="PROCEDURE MODIFIERS",DLB="Select "_DOW S:D DC=DC_D 182 S DU="RAMIS(71.2," 183 G RE:D I $D(DSC(70.1))#2,$P(DSC(70.1),"I $D(^UTILITY(",1)="" X DSC(70.1) S D=$O(^(0)) S:D="" D=-1 G M27 184 S D=$S($D(^RADPT(D0,"DT",D1,"P",DA,"M",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 185 M27 I D>0 S DC=DC_D I $D(^RADPT(D0,"DT",D1,"P",DA,"M",+D,0)) S DE(27)=$P(^(0),U,1) 186 S X=RAMOD 187 S Y=X 188 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 189 G RD 190 R27 D DE 191 G A 192 ; 193 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 194 X28 S Y="@5" 195 Q 196 29 S DQ=30 ;@6 197 30 S D=0 K DE(1) ;125 198 S DIFLD=125,DGO="^RACTRG4",DC="1^70.1P^M^",DV="70.1M*P71.2'X",DW="0;1",DOW="PROCEDURE MODIFIERS",DLB="Select "_DOW S:D DC=DC_D 199 S DU="RAMIS(71.2," 200 G RE:D I $D(DSC(70.1))#2,$P(DSC(70.1),"I $D(^UTILITY(",1)="" X DSC(70.1) S D=$O(^(0)) S:D="" D=-1 G M30 201 S D=$S($D(^RADPT(D0,"DT",D1,"P",DA,"M",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 202 M30 I D>0 S DC=DC_D I $D(^RADPT(D0,"DT",D1,"P",DA,"M",+D,0)) S DE(30)=$P(^(0),U,1) 203 G RE 204 R30 D DE 205 S D=$S($D(^RADPT(D0,"DT",D1,"P",DA,"M",0)):$P(^(0),U,3,4),1:1) G 30+1 206 ; 207 31 S DQ=32 ;@7 208 32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 209 X32 D:$T(SETDEFS^RACPTMSC)]"" SETDEFS^RACPTMSC 210 Q 211 33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 212 X33 S REM="don't ask cpt mods after stuffing" 213 Q 214 34 S DQ=35 ;@8 215 35 D:$D(DG)>9 F^DIE17 G ^RACTRG5 180 27 D:$D(DG)>9 F^DIE17 G ^RACTRG3 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG3.m
r613 r623 1 RACTRG3 ; ; 01/02/091 RACTRG3 ; ;11/06/06 2 2 D DE G BEGIN 3 DE S DIE="^RADPT(D0,""DT"",D1,""P"",D2,""M"",",DIC=DIE,DP=70.1,DL=4,DIEL=3,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",D2,"M",DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% 3 DE S DIE="^RADPT(D0,""DT"",D1,""P"",",DIC=DIE,DP=70.03,DL=3,DIEL=2,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(13)=% S %=$P(%Z,U,8) S:%]"" DE(24)=% S %=$P(%Z,U,9) S:%]"" DE(19)=% S %=$P(%Z,U,11) S:%]"" DE(9)=% S %=$P(%Z,U,14) S:%]"" DE(10)=% S %=$P(%Z,U,18) S:%]"" DE(11)=% 5 I $D(^("R")) S %Z=^("R") S %=$P(%Z,U,1) S:%]"" DE(16)=% 5 6 K %Z Q 6 7 ; … … 49 50 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 50 51 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 51 BEGIN S DNM="RACTRG3",DQ=1 +D G B52 1 S DW="0;1",DV="M*P71.2'X",DU="",DLB="PROCEDURE MODIFIERS",DIFLD=.0153 S D E(DW)="C1^RACTRG3"52 BEGIN S DNM="RACTRG3",DQ=1 53 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,D=0 K DE(1) ;125 54 S DIFLD=125,DGO="^RACTRG4",DC="1^70.1P^M^",DV="70.1M*P71.2'X",DW="0;1",DOW="PROCEDURE MODIFIERS",DLB="Select "_DOW S:D DC=DC_D 54 55 S DU="RAMIS(71.2," 55 G RE:'D S DQ=2 G 2 56 C1 G C1S:$D(DE(1))[0 K DB 57 S X=DE(1),DIC=DIE 58 K ^RADPT(DA(3),"DT",DA(2),"P",DA(1),"M","B",$E(X,1,30),DA) 59 C1S S X="" G:DG(DQ)=X C1F1 K DB 56 G RE:D I $D(DSC(70.1))#2,$P(DSC(70.1),"I $D(^UTILITY(",1)="" X DSC(70.1) S D=$O(^(0)) S:D="" D=-1 G M1 57 S D=$S($D(^RADPT(D0,"DT",D1,"P",DA,"M",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 58 M1 I D>0 S DC=DC_D I $D(^RADPT(D0,"DT",D1,"P",DA,"M",+D,0)) S DE(1)=$P(^(0),U,1) 59 S X=RAMOD 60 S Y=X 61 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 62 G RD 63 R1 D DE 64 G A 65 ; 66 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 67 X2 S Y="@5" 68 Q 69 3 S DQ=4 ;@6 70 4 S D=0 K DE(1) ;125 71 S DIFLD=125,DGO="^RACTRG5",DC="1^70.1P^M^",DV="70.1M*P71.2'X",DW="0;1",DOW="PROCEDURE MODIFIERS",DLB="Select "_DOW S:D DC=DC_D 72 S DU="RAMIS(71.2," 73 G RE:D I $D(DSC(70.1))#2,$P(DSC(70.1),"I $D(^UTILITY(",1)="" X DSC(70.1) S D=$O(^(0)) S:D="" D=-1 G M4 74 S D=$S($D(^RADPT(D0,"DT",D1,"P",DA,"M",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 75 M4 I D>0 S DC=DC_D I $D(^RADPT(D0,"DT",D1,"P",DA,"M",+D,0)) S DE(4)=$P(^(0),U,1) 76 G RE 77 R4 D DE 78 S D=$S($D(^RADPT(D0,"DT",D1,"P",DA,"M",0)):$P(^(0),U,3,4),1:1) G 4+1 79 ; 80 5 S DQ=6 ;@7 81 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 82 X6 D:$T(SETDEFS^RACPTMSC)]"" SETDEFS^RACPTMSC 83 Q 84 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 85 X7 S REM="don't ask cpt mods after stuffing" 86 Q 87 8 S DQ=9 ;@8 88 9 S DW="0;11",DV="P75.1'",DU="",DLB="IMAGING ORDER",DIFLD=11 89 S DE(DW)="C9^RACTRG3" 90 S DU="RAO(75.1," 91 S X=RAOIFN 92 S Y=X 93 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 94 G RD:X="@",Z 95 C9 G C9S:$D(DE(9))[0 K DB 96 S X=DE(9),DIC=DIE 97 K ^RADPT("AO",$E(X,1,30),DA(2),DA(1),DA) 98 C9S S X="" G:DG(DQ)=X C9F1 K DB 60 99 S X=DG(DQ),DIC=DIE 61 S ^RADPT(DA(3),"DT",DA(2),"P",DA(1),"M","B",$E(X,1,30),DA)="" 62 C1F1 Q 63 X1 S DIC("S")="X ^DD(70.1,.01,9.2)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 100 S ^RADPT("AO",$E(X,1,30),DA(2),DA(1),DA)="" 101 C9F1 Q 102 X9 Q 103 10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW="0;14",DV="R*P200'X",DU="",DLB="REQUESTING PHYSICIAN",DIFLD=14 104 S DU="VA(200," 105 S X=$S($D(RAPIFN):RAPIFN,1:"") 106 S Y=X 107 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 108 G RD:X="@",Z 109 X10 Q 110 11 S DW="0;18",DV="*P78.6'",DU="",DLB="PRIMARY CAMERA/EQUIP/RM",DIFLD=18 111 S DU="RA(78.6," 112 S X=$S($P(RAPX(RACNI),U,15)]"":$P(RAPX(RACNI),U,15),1:"") 113 S Y=X 114 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 115 G RD:X="@",Z 116 X11 Q 117 12 S DQ=13 ;@20 118 13 S DW="0;4",DV="RSX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4 119 S DU="I:INPATIENT;O:OUTPATIENT;C:CONTRACT;S:SHARING;E:EMPLOYEE;R:RESEARCH;" 120 S X=RACAT 121 S Y=X 122 G Y 123 X13 I $D(X),$E(X)="I" S DFN=DA(2),VAINDT=9999999.9999-DA(1) D ADM^VADPT2 I 'VADMVT K X W !?3,"Patient not an inpatient at registration time.",! 64 124 Q 65 125 ; 66 2 G 1^DIE17 126 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 127 X14 S RAX=$E(X),Y=$S(RAX="I":"@60",RAX="E":"@45",RAX="R":"@30","CS"[RAX:"@40",1:"@50") K RAX 128 Q 129 15 S DQ=16 ;@30 130 16 S DW="R;1",DV="FR",DU="",DLB="RESEARCH SOURCE",DIFLD=9.5 131 S X=$S($D(RARSH):RARSH,1:"") 132 S Y=X 133 G Y 134 X16 K:$L(X)>40!($L(X)<3) X 135 I $D(X),X'?.ANP K X 136 Q 137 ; 138 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 139 X17 S Y=$S($D(RAWARD):"@60",1:"@50") 140 Q 141 18 S DQ=19 ;@40 142 19 S DW="0;9",DV="*P34'R",DU="",DLB="CONTRACT/SHARING SOURCE",DIFLD=9 143 S DU="DIC(34," 144 S X=$S($D(RASHA):RASHA,1:"") 145 S Y=X 146 G Y 147 X19 S DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 148 Q 149 ; 150 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 151 X20 S Y="@100" 152 Q 153 21 S DQ=22 ;@45 154 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 155 X22 S:$D(RAWARD) Y="@60" 156 Q 157 23 S DQ=24 ;@50 158 24 S DW="0;8",DV="*P44'R",DU="",DLB="PRINCIPAL CLINIC",DIFLD=8 159 S DU="SC(" 160 S X=$S($D(RACLNC):RACLNC,1:"") 161 S Y=X 162 G Y 163 X24 S DIC("S")="I $P(^(0),U,3)=""C""" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 164 Q 165 ; 166 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 167 X25 S RACLNC=$P(^SC(X,0),U) 168 Q 169 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 170 X26 S Y="@100" 171 Q 172 27 S DQ=28 ;@60 173 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 174 X28 S:'$D(RAWARD) RAWARD="Unknown" S:'$D(RASER) RASER="Unknown" S:'$D(RABED) RABED="Unknown" 175 Q 176 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 177 X29 W !?5,"Ward: ",RAWARD," Service: ",RASER," Bedsection: ",RABED 178 Q 179 30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 180 X30 I RAWARD'="Unknown" S Y="@66" 181 Q 182 31 D:$D(DG)>9 F^DIE17 G ^RACTRG6 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG4.m
r613 r623 1 RACTRG4 ; ; 01/02/091 RACTRG4 ; ;11/06/06 2 2 D DE G BEGIN 3 3 DE S DIE="^RADPT(D0,""DT"",D1,""P"",D2,""M"",",DIC=DIE,DP=70.1,DL=4,DIEL=3,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",D2,"M",DA,""))="" -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG5.m
r613 r623 1 RACTRG5 ; ; 01/02/091 RACTRG5 ; ;11/06/06 2 2 D DE G BEGIN 3 DE S DIE="^RADPT(D0,""DT"",D1,""P"",",DIC=DIE,DP=70.03,DL=3,DIEL=2,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(5)=% S %=$P(%Z,U,6) S:%]"" DE(23)=%,DE(26)=% S %=$P(%Z,U,7) S:%]"" DE(29)=%,DE(32)=% S %=$P(%Z,U,8) S:%]"" DE(16)=% S %=$P(%Z,U,9) S:%]"" DE(11)=% S %=$P(%Z,U,11) S:%]"" DE(1)=% 5 I S %=$P(%Z,U,14) S:%]"" DE(2)=% S %=$P(%Z,U,18) S:%]"" DE(3)=% S %=$P(%Z,U,19) S:%]"" DE(35)=%,DE(38)=% S %=$P(%Z,U,21) S:%]"" DE(40)=% S %=$P(%Z,U,22) S:%]"" DE(41)=% 6 I $D(^("R")) S %Z=^("R") S %=$P(%Z,U,1) S:%]"" DE(8)=% 3 DE S DIE="^RADPT(D0,""DT"",D1,""P"",D2,""M"",",DIC=DIE,DP=70.1,DL=4,DIEL=3,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",D2,"M",DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% 7 5 K %Z Q 8 6 ; … … 51 49 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 52 50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 53 BEGIN S DNM="RACTRG5",DQ=1 54 1 S DW="0;1 1",DV="P75.1'",DU="",DLB="IMAGING ORDER",DIFLD=1151 BEGIN S DNM="RACTRG5",DQ=1+D G B 52 1 S DW="0;1",DV="M*P71.2'X",DU="",DLB="PROCEDURE MODIFIERS",DIFLD=.01 55 53 S DE(DW)="C1^RACTRG5" 56 S DU="RAO(75.1," 57 S X=RAOIFN 58 S Y=X 59 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 60 G RD:X="@",Z 54 S DU="RAMIS(71.2," 55 G RE:'D S DQ=2 G 2 61 56 C1 G C1S:$D(DE(1))[0 K DB 62 57 S X=DE(1),DIC=DIE 63 K ^RADPT( "AO",$E(X,1,30),DA(2),DA(1),DA)58 K ^RADPT(DA(3),"DT",DA(2),"P",DA(1),"M","B",$E(X,1,30),DA) 64 59 C1S S X="" G:DG(DQ)=X C1F1 K DB 65 60 S X=DG(DQ),DIC=DIE 66 S ^RADPT( "AO",$E(X,1,30),DA(2),DA(1),DA)=""61 S ^RADPT(DA(3),"DT",DA(2),"P",DA(1),"M","B",$E(X,1,30),DA)="" 67 62 C1F1 Q 68 X1 Q 69 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;14",DV="R*P200'X",DU="",DLB="REQUESTING PHYSICIAN",DIFLD=14 70 S DU="VA(200," 71 S X=$S($D(RAPIFN):RAPIFN,1:"") 72 S Y=X 73 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 74 G RD:X="@",Z 75 X2 Q 76 3 S DW="0;18",DV="*P78.6'",DU="",DLB="PRIMARY CAMERA/EQUIP/RM",DIFLD=18 77 S DU="RA(78.6," 78 S X=$S($P(RAPX(RACNI),U,15)]"":$P(RAPX(RACNI),U,15),1:"") 79 S Y=X 80 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 81 G RD:X="@",Z 82 X3 Q 83 4 S DQ=5 ;@20 84 5 S DW="0;4",DV="RSX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4 85 S DU="I:INPATIENT;O:OUTPATIENT;C:CONTRACT;S:SHARING;E:EMPLOYEE;R:RESEARCH;" 86 S X=RACAT 87 S Y=X 88 G Y 89 X5 I $D(X),$E(X)="I" S DFN=DA(2),VAINDT=9999999.9999-DA(1) D ADM^VADPT2 I 'VADMVT K X W !?3,"Patient not an inpatient at registration time.",! 63 X1 S DIC("S")="X ^DD(70.1,.01,9.2)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 90 64 Q 91 65 ; 92 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 93 X6 S RAX=$E(X),Y=$S(RAX="I":"@60",RAX="E":"@45",RAX="R":"@30","CS"[RAX:"@40",1:"@50") K RAX 94 Q 95 7 S DQ=8 ;@30 96 8 S DW="R;1",DV="FR",DU="",DLB="RESEARCH SOURCE",DIFLD=9.5 97 S X=$S($D(RARSH):RARSH,1:"") 98 S Y=X 99 G Y 100 X8 K:$L(X)>40!($L(X)<3) X 101 I $D(X),X'?.ANP K X 102 Q 103 ; 104 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 105 X9 S Y=$S($D(RAWARD):"@60",1:"@50") 106 Q 107 10 S DQ=11 ;@40 108 11 S DW="0;9",DV="*P34'R",DU="",DLB="CONTRACT/SHARING SOURCE",DIFLD=9 109 S DU="DIC(34," 110 S X=$S($D(RASHA):RASHA,1:"") 111 S Y=X 112 G Y 113 X11 S DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 114 Q 115 ; 116 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 117 X12 S Y="@100" 118 Q 119 13 S DQ=14 ;@45 120 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 121 X14 S:$D(RAWARD) Y="@60" 122 Q 123 15 S DQ=16 ;@50 124 16 S DW="0;8",DV="*P44'R",DU="",DLB="PRINCIPAL CLINIC",DIFLD=8 125 S DU="SC(" 126 S X=$S($D(RACLNC):RACLNC,1:"") 127 S Y=X 128 G Y 129 X16 S DIC("S")="I $P(^(0),U,3)=""C""" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 130 Q 131 ; 132 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 133 X17 S RACLNC=$P(^SC(X,0),U) 134 Q 135 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 136 X18 S Y="@100" 137 Q 138 19 S DQ=20 ;@60 139 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 140 X20 S:'$D(RAWARD) RAWARD="Unknown" S:'$D(RASER) RASER="Unknown" S:'$D(RABED) RABED="Unknown" 141 Q 142 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 143 X21 W !?5,"Ward: ",RAWARD," Service: ",RASER," Bedsection: ",RABED 144 Q 145 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 146 X22 I RAWARD'="Unknown" S Y="@66" 147 Q 148 23 S DW="0;6",DV="P42'R",DU="",DLB="WARD",DIFLD=6 149 S DU="DIC(42," 150 G RE 151 X23 Q 152 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 153 X24 S Y="@68" 154 Q 155 25 S DQ=26 ;@66 156 26 S DW="0;6",DV="P42'",DU="",DLB="WARD",DIFLD=6 157 S DU="DIC(42," 158 S X=RAWARD 159 S Y=X 160 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 161 G RD 162 X26 Q 163 27 S DQ=28 ;@68 164 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 165 X28 I RASER'="Unknown" S Y="@80" 166 Q 167 29 S DW="0;7",DV="P49'R",DU="",DLB="SERVICE",DIFLD=7 168 S DU="DIC(49," 169 G RE 170 X29 Q 171 30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 172 X30 S Y="@85" 173 Q 174 31 S DQ=32 ;@80 175 32 S DW="0;7",DV="P49'",DU="",DLB="SERVICE",DIFLD=7 176 S DU="DIC(49," 177 S X=RASER 178 S Y=X 179 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 180 G RD 181 X32 Q 182 33 S DQ=34 ;@85 183 34 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=34 D X34 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 184 X34 I RABED'="Unknown" S Y="@95" 185 Q 186 35 S DW="0;19",DV="P42.4'R",DU="",DLB="BEDSECTION",DIFLD=19 187 S DU="DIC(42.4," 188 G RE 189 X35 Q 190 36 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=36 D X36 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 191 X36 S Y="@100" 192 Q 193 37 S DQ=38 ;@95 194 38 S DW="0;19",DV="P42.4'",DU="",DLB="BEDSECTION",DIFLD=19 195 S DU="DIC(42.4," 196 S X=RABED 197 S Y=X 198 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 199 G RD 200 X38 Q 201 39 S DQ=40 ;@100 202 40 S DW="0;21",DV="D",DU="",DLB="REQUESTED DATE",DIFLD=21 203 S X=$S($D(RARDTE):RARDTE,1:"") 204 S Y=X 205 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 206 G RD:X="@",Z 207 X40 Q 208 41 S DW="0;22",DV="P44'",DU="",DLB="REQUESTING LOCATION",DIFLD=22 209 S DU="SC(" 210 S X=$S($D(RALIFN):RALIFN,1:"") 211 S Y=X 212 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 213 G RD:X="@",Z 214 X41 Q 215 42 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=42 D X42 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 216 X42 I '$D(^RAMIS(71,RAPRI,"F",0)) S Y="@300" 217 Q 218 43 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=43 D X43 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 219 X43 S RAI=0 220 Q 221 44 S DQ=45 ;@200 222 45 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=45 D X45 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 223 X45 S RAI=$O(^RAMIS(71,RAPRI,"F",RAI)) S:RAI'>0!('$D(^(+RAI,0))) Y="@300" 224 Q 225 46 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=46 D X46 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 226 X46 S RAFM(1)=+^RAMIS(71,RAPRI,"F",RAI,0),RAFM1=+$P(^(0),U,2),RAFM=$S($D(^RA(78.4,RAFM(1),0)):$P(^(0),U),1:-1),RAFM=$S('$D(^("I")):RAFM,'^("I"):RAFM,1:-1) S:RAFM<0 Y="@200" 227 Q 228 47 D:$D(DG)>9 F^DIE17 G ^RACTRG6 66 2 G 1^DIE17 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG6.m
r613 r623 1 RACTRG6 ; ; 01/02/091 RACTRG6 ; ;11/06/06 2 2 D DE G BEGIN 3 3 DE S DIE="^RADPT(D0,""DT"",D1,""P"",",DIC=DIE,DP=70.03,DL=3,DIEL=2,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U, 28) S:%]"" DE(18)=%4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,6) S:%]"" DE(1)=%,DE(4)=% S %=$P(%Z,U,7) S:%]"" DE(7)=%,DE(10)=% S %=$P(%Z,U,19) S:%]"" DE(13)=%,DE(16)=% S %=$P(%Z,U,21) S:%]"" DE(18)=% S %=$P(%Z,U,22) S:%]"" DE(19)=% 5 5 K %Z Q 6 6 ; … … 50 50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 51 51 BEGIN S DNM="RACTRG6",DQ=1 52 1 S D=0 K DE(1) ;50 52 1 S DW="0;6",DV="P42'R",DU="",DLB="WARD",DIFLD=6 53 S DU="DIC(42," 54 G RE 55 X1 Q 56 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 57 X2 S Y="@68" 58 Q 59 3 S DQ=4 ;@66 60 4 S DW="0;6",DV="P42'",DU="",DLB="WARD",DIFLD=6 61 S DU="DIC(42," 62 S X=RAWARD 63 S Y=X 64 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 65 G RD 66 X4 Q 67 5 S DQ=6 ;@68 68 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 69 X6 I RASER'="Unknown" S Y="@80" 70 Q 71 7 S DW="0;7",DV="P49'R",DU="",DLB="SERVICE",DIFLD=7 72 S DU="DIC(49," 73 G RE 74 X7 Q 75 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 76 X8 S Y="@85" 77 Q 78 9 S DQ=10 ;@80 79 10 S DW="0;7",DV="P49'",DU="",DLB="SERVICE",DIFLD=7 80 S DU="DIC(49," 81 S X=RASER 82 S Y=X 83 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 84 G RD 85 X10 Q 86 11 S DQ=12 ;@85 87 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 88 X12 I RABED'="Unknown" S Y="@95" 89 Q 90 13 S DW="0;19",DV="P42.4'R",DU="",DLB="BEDSECTION",DIFLD=19 91 S DU="DIC(42.4," 92 G RE 93 X13 Q 94 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 95 X14 S Y="@100" 96 Q 97 15 S DQ=16 ;@95 98 16 S DW="0;19",DV="P42.4'",DU="",DLB="BEDSECTION",DIFLD=19 99 S DU="DIC(42.4," 100 S X=RABED 101 S Y=X 102 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 103 G RD 104 X16 Q 105 17 S DQ=18 ;@100 106 18 S DW="0;21",DV="D",DU="",DLB="REQUESTED DATE",DIFLD=21 107 S X=$S($D(RARDTE):RARDTE,1:"") 108 S Y=X 109 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 110 G RD:X="@",Z 111 X18 Q 112 19 S DW="0;22",DV="P44'",DU="",DLB="REQUESTING LOCATION",DIFLD=22 113 S DU="SC(" 114 S X=$S($D(RALIFN):RALIFN,1:"") 115 S Y=X 116 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 117 G RD:X="@",Z 118 X19 Q 119 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 120 X20 I '$D(^RAMIS(71,RAPRI,"F",0)) S Y="@300" 121 Q 122 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 123 X21 S RAI=0 124 Q 125 22 S DQ=23 ;@200 126 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 127 X23 S RAI=$O(^RAMIS(71,RAPRI,"F",RAI)) S:RAI'>0!('$D(^(+RAI,0))) Y="@300" 128 Q 129 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 130 X24 S RAFM(1)=+^RAMIS(71,RAPRI,"F",RAI,0),RAFM1=+$P(^(0),U,2),RAFM=$S($D(^RA(78.4,RAFM(1),0)):$P(^(0),U),1:-1),RAFM=$S('$D(^("I")):RAFM,'^("I"):RAFM,1:-1) S:RAFM<0 Y="@200" 131 Q 132 25 S D=0 K DE(1) ;50 53 133 S DIFLD=50,DGO="^RACTRG7",DC="2^70.04PA^F^",DV="70.04M*P78.4'",DW="0;1",DOW="FILM SIZE",DLB="Select "_DOW S:D DC=DC_D 54 134 S DU="RA(78.4," 55 G RE:D I $D(DSC(70.04))#2,$P(DSC(70.04),"I $D(^UTILITY(",1)="" X DSC(70.04) S D=$O(^(0)) S:D="" D=-1 G M 1135 G RE:D I $D(DSC(70.04))#2,$P(DSC(70.04),"I $D(^UTILITY(",1)="" X DSC(70.04) S D=$O(^(0)) S:D="" D=-1 G M25 56 136 S D=$S($D(^RADPT(D0,"DT",D1,"P",DA,"F",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 57 M 1 I D>0 S DC=DC_D I $D(^RADPT(D0,"DT",D1,"P",DA,"F",+D,0)) S DE(1)=$P(^(0),U,1)137 M25 I D>0 S DC=DC_D I $D(^RADPT(D0,"DT",D1,"P",DA,"F",+D,0)) S DE(25)=$P(^(0),U,1) 58 138 S X=RAFM 59 139 S Y=X 60 140 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 61 141 G RD 62 R 1D DE142 R25 D DE 63 143 G A 64 144 ; 65 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE1766 X2 S Y="@200"145 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 146 X26 S Y="@200" 67 147 Q 68 3 S DQ=4;@30069 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE1770 X 4S RAPOP=0 D USER^RAUTL S:RAPOP Y="@999"148 27 S DQ=28 ;@300 149 28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 150 X28 S RAPOP=0 D USER^RAUTL S:RAPOP Y="@999" 71 151 Q 72 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE1773 X 5S:'$P(RAMDV,U,10) Y="@350"152 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 153 X29 S:'$P(RAMDV,U,10) Y="@350" 74 154 Q 75 6S D=0 K DE(1) ;75155 30 S D=0 K DE(1) ;75 76 156 S DIFLD=75,DGO="^RACTRG8",DC="3^70.05DA^T^",DV="70.05DX",DW="0;1",DOW="STATUS CHANGE DATE/TIME",DLB="Select "_DOW S:D DC=DC_D 77 I $D(DSC(70.05))#2,$P(DSC(70.05),"I $D(^UTILITY(",1)="" X DSC(70.05) S D=$O(^(0)) S:D="" D=-1 G M 6157 I $D(DSC(70.05))#2,$P(DSC(70.05),"I $D(^UTILITY(",1)="" X DSC(70.05) S D=$O(^(0)) S:D="" D=-1 G M30 78 158 S D=$S($D(^RADPT(D0,"DT",D1,"P",DA,"T",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 79 M 6 I D>0 S DC=DC_D I $D(^RADPT(D0,"DT",D1,"P",DA,"T",+D,0)) S DE(6)=$P(^(0),U,1)159 M30 I D>0 S DC=DC_D I $D(^RADPT(D0,"DT",D1,"P",DA,"T",+D,0)) S DE(30)=$P(^(0),U,1) 80 160 S X="""NOW""" 81 161 S Y=X 82 162 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 83 163 G RD 84 R 6D DE164 R30 D DE 85 165 G A 86 166 ; 87 7 S DQ=8;@35088 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE1789 X 8S RANMFLG=0167 31 S DQ=32 ;@350 168 32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 169 X32 S RANMFLG=0 90 170 Q 91 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE1792 X 9S:'$D(RAIMGTYI) RAIMGTYI=$O(^RA(79.2,"B",RAIMGTY,0))171 33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 172 X33 S:'$D(RAIMGTYI) RAIMGTYI=$O(^RA(79.2,"B",RAIMGTY,0)) 93 173 Q 94 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE1795 X 10S:$P($G(^RA(79.2,+$G(RAIMGTYI),0)),"^",5)="Y" RANMFLG=1174 34 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=34 D X34 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 175 X34 S:$P($G(^RA(79.2,+$G(RAIMGTYI),0)),"^",5)="Y" RANMFLG=1 96 176 Q 97 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE1798 X 11S:'RANMFLG Y="@450"177 35 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=35 D X35 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 178 X35 S:'RANMFLG Y="@450" 99 179 Q 100 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17101 X 12S:'$O(^RAMIS(71,RAPRI,"NUC",0)) Y="@450"180 36 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=36 D X36 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 181 X36 S:'$O(^RAMIS(71,RAPRI,"NUC",0)) Y="@450" 102 182 Q 103 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17104 X 13S REM="is this proc's ASK RADIOPHARMACEUTICAL = NEVER ?"183 37 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=37 D X37 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 184 X37 S REM="is this proc's ASK RADIOPHARMACEUTICAL = NEVER ?" 105 185 Q 106 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17107 X 14S:$P(^RAMIS(71,RAPRI,0),U,2)=1 Y="@450"186 38 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=38 D X38 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 187 X38 S:$P(^RAMIS(71,RAPRI,0),U,2)=1 Y="@450" 108 188 Q 109 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17110 X 15S REM="en1^ranmpt1 will stuff default radiopharms during registration"189 39 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=39 D X39 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 190 X39 S REM="en1^ranmpt1 will stuff default radiopharms during registration" 111 191 Q 112 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17113 X 16S RAIEN702=$$EN1^RANMPT1(RADFN,RADTE,RACN)192 40 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=40 D X40 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 193 X40 S RAIEN702=$$EN1^RANMPT1(RADFN,RADTE,RACN) 114 194 Q 115 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17116 X 17S:RAIEN702=-1 Y="@450"195 41 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=41 D X41 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 196 X41 S:RAIEN702=-1 Y="@450" 117 197 Q 118 18 S DW="0;28",DV="P70.2'",DU="",DLB="NUCLEAR MED DATA",DIFLD=500 119 S DE(DW)="C18^RACTRG6" 120 S DU="RADPTN(" 121 S X=RAIEN702 122 S Y=X 123 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 124 G RD:X="@",Z 125 C18 G C18S:$D(DE(18))[0 K DB 126 S X=DE(18),DIC=DIE 127 X "Q:$D(RAIEN702) N DA,DIK S DA=X,DIK=""^RADPTN("" D ^DIK" 128 C18S S X="" G:DG(DQ)=X C18F1 K DB 129 S X=DG(DQ),DIC=DIE 130 ; 131 C18F1 Q 132 X18 Q 133 19 S DQ=20 ;@450 134 20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 135 X20 S:'$O(^RAMIS(71,RAPRI,"P",0)) Y="@700" 136 Q 137 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 138 X21 S REM="en2^ranmpt1 will stuff default meds" 139 Q 140 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 141 X22 D EN2^RANMPT1(RADFN,RADTI,RACNI) 142 Q 143 23 S DQ=24 ;@700 144 24 D:$D(DG)>9 F^DIE17,DE S DQ=24,D=0 K DE(1) ;100 145 S DIFLD=100,DGO="^RACTRG9",DC="4^70.07DA^L^",DV="70.07RDI",DW="0;1",DOW="LOG DATE",DLB="Select "_DOW S:D DC=DC_D 146 I $D(DSC(70.07))#2,$P(DSC(70.07),"I $D(^UTILITY(",1)="" X DSC(70.07) S D=$O(^(0)) S:D="" D=-1 G M24 147 S D=$S($D(^RADPT(D0,"DT",D1,"P",DA,"L",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 148 M24 I D>0 S DC=DC_D I $D(^RADPT(D0,"DT",D1,"P",DA,"L",+D,0)) S DE(24)=$P(^(0),U,1) 149 S X="""NOW""" 150 S Y=X 151 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 152 G RD 153 R24 D DE 154 G A 155 ; 156 25 G 1^DIE17 198 42 D:$D(DG)>9 F^DIE17 G ^RACTRG9 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG7.m
r613 r623 1 RACTRG7 ; ; 01/02/091 RACTRG7 ; ;11/06/06 2 2 D DE G BEGIN 3 3 DE S DIE="^RADPT(D0,""DT"",D1,""P"",D2,""F"",",DIC=DIE,DP=70.04,DL=4,DIEL=3,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",D2,"F",DA,""))="" -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG8.m
r613 r623 1 RACTRG8 ; ; 01/02/091 RACTRG8 ; ;11/06/06 2 2 D DE G BEGIN 3 3 DE S DIE="^RADPT(D0,""DT"",D1,""P"",D2,""T"",",DIC=DIE,DP=70.05,DL=4,DIEL=3,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",D2,"T",DA,""))="" -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG9.m
r613 r623 1 RACTRG9 ; ; 01/02/091 RACTRG9 ; ;11/06/06 2 2 D DE G BEGIN 3 DE S DIE="^RADPT(D0,""DT"",D1,""P"",D2,""L"",",DIC=DIE,DP=70.07,DL=4,DIEL=3,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",D2,"L",DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% 5 I $D(^("TCOM")) S %Z=^("TCOM") S %=$E(%Z,1,245) S:%'?." " DE(4)=%,DE(6)=% 3 DE S DIE="^RADPT(D0,""DT"",D1,""P"",",DIC=DIE,DP=70.03,DL=3,DIEL=2,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,28) S:%]"" DE(1)=% 6 5 K %Z Q 7 6 ; … … 51 50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 52 51 BEGIN S DNM="RACTRG9",DQ=1 53 1 S DW="0;2",DV="RSI",DU="",DLB="TYPE OF ACTION",DIFLD=2 54 S DU="E:EXAM ENTRY;C:EDIT BY CASE NO.;P:EDIT BY PATIENT;D:DIAGNOSIS ENTRY BY CASE NO.;S:EXAM STATUS TRACKING;X:CANCELLED;O:COMPLETE STATUS OVERRIDE;U:UPDATE STATUS;N:NO PURGING SPECIFIED;" 55 S X="E" 52 1 S DW="0;28",DV="P70.2'",DU="",DLB="NUCLEAR MED DATA",DIFLD=500 53 S DE(DW)="C1^RACTRG9" 54 S DU="RADPTN(" 55 S X=RAIEN702 56 S Y=X 57 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 58 G RD:X="@",Z 59 C1 G C1S:$D(DE(1))[0 K DB 60 S X=DE(1),DIC=DIE 61 X "Q:$D(RAIEN702) N DA,DIK S DA=X,DIK=""^RADPTN("" D ^DIK" 62 C1S S X="" G:DG(DQ)=X C1F1 K DB 63 S X=DG(DQ),DIC=DIE 64 ; 65 C1F1 Q 66 X1 Q 67 2 S DQ=3 ;@450 68 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 69 X3 S:'$O(^RAMIS(71,RAPRI,"P",0)) Y="@700" 70 Q 71 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 72 X4 S REM="en2^ranmpt1 will stuff default meds" 73 Q 74 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 75 X5 D EN2^RANMPT1(RADFN,RADTI,RACNI) 76 Q 77 6 S DQ=7 ;@700 78 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,D=0 K DE(1) ;100 79 S DIFLD=100,DGO="^RACTRG10",DC="4^70.07DA^L^",DV="70.07RDI",DW="0;1",DOW="LOG DATE",DLB="Select "_DOW S:D DC=DC_D 80 I $D(DSC(70.07))#2,$P(DSC(70.07),"I $D(^UTILITY(",1)="" X DSC(70.07) S D=$O(^(0)) S:D="" D=-1 G M7 81 S D=$S($D(^RADPT(D0,"DT",D1,"P",DA,"L",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 82 M7 I D>0 S DC=DC_D I $D(^RADPT(D0,"DT",D1,"P",DA,"L",+D,0)) S DE(7)=$P(^(0),U,1) 83 S X="""NOW""" 56 84 S Y=X 57 85 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 58 86 G RD 59 X1 Q 60 2 S DW="0;3",DV="RP200'I",DU="",DLB="COMPUTER USER",DIFLD=3 61 S DU="VA(200," 62 S X=RADUZ 63 S Y=X 64 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 65 G RD:X="@",Z 66 X2 Q 67 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 68 X3 S RATCXX=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI) 69 Q 70 4 S DW="TCOM;E1,245",DV="F",DU="",DLB="TECHNOLOGIST COMMENT",DIFLD=4 71 S X=RATCXX 72 S Y=X 73 G Y 74 X4 K:$L(X)>245!($L(X)<3)!'(X?1A.ANP) X 75 I $D(X),X'?.ANP K X 76 Q 87 R7 D DE 88 G A 77 89 ; 78 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 79 X5 S:RATCXX'=X Y="@18" 80 Q 81 6 S DW="TCOM;E1,245",DV="F",DU="",DLB="TECHNOLOGIST COMMENT",DIFLD=4 82 S Y="@" 83 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 84 G RD 85 X6 K:$L(X)>245!($L(X)<3)!'(X?1A.ANP) X 86 I $D(X),X'?.ANP K X 87 Q 88 ; 89 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 90 X7 K ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",DA,"TCOM") 91 Q 92 8 S DQ=9 ;@18 93 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 94 X9 K RATCXX S RAFIN="" 95 Q 96 10 G 1^DIE17 90 8 G 1^DIE17 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD1.m
r613 r623 1 RADD1 ;HISC/FPT-Radiology Utility Routine ;6/2/98 16:17 2 ;;5.0;Radiology/Nuclear Medicine;**1,5,10,65**;Mar 16, 1998;Build 8 3 ; 4 ;Supported IA #10142 reference to EN^DDIOL 5 ;Supported IA #10103 reference to FMADD^XLFDT 6 ; 7 SECXREF ; sets/kills 'ARES' & 'ASTF' x-refs for secondary resident/staff rads 8 ; called from ^DD(74,5 9 ; 10 Q:'$D(^RARPT(DA,0)) S RADFNZ=^(0) 11 S RADTIZ=9999999.9999-$P(RADFNZ,"^",3),RACNIZ=$O(^RADPT(+$P(RADFNZ,"^",2),"DT",RADTIZ,"P","B",+$P(RADFNZ,"^",4),0)),RADFNZ=+$P(RADFNZ,"^",2) 12 I 'RACNIZ D KILL Q 13 I '$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) D KILL Q 14 I '$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,0)) D KILL Q 15 S RASECIEN=0 16 F S RASECIEN=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,RASECIEN)) Q:RASECIEN<1 S RARAD=+$P($G(^(RASECIEN,0)),"^",1) I RARAD>0 D 17 .S:$D(RASET) ^RARPT(RAXREF,RARAD,DA)="" K:$D(RAKILL) ^RARPT(RAXREF,RARAD,DA) 18 D XSEC^RAUTL20 19 KILL K RACNIZ,RADFNZ,RADTIZ,RASECOND,RASECIEN 20 Q 21 SCDTC ; status change date/time check 22 ; called from ^DD(70.05,.01 23 ; if X is a date/time prior to the exam date/time, then set Y=0. 24 ; if X is a over a minute in the future, then set Y=0. 25 ; if X is missing the time portion, then set Y=0. 26 I '($D(X)#2) Q 27 I '$F(X,".") D EN^DDIOL("** Time is Required **","","!!?20") S Y=0 Q 28 N RASTATUS,RAORDNUM,RAPLUS1 29 ; eg. da(3)=1128, da(2)=7028970.8743,da(1)=1,da=1 30 S RASTATUS=$P($G(^RADPT(+$G(DA(3)),"DT",+$G(DA(2)),"P",+$G(DA(1)),0)),U,3) 31 S RAORDNUM=$P($G(^RA(72,+RASTATUS,0)),U,3) 32 I X<(9999999.9999-$G(DA(2))),RAORDNUM>1 S Y=0 Q 33 S RADTHOLD=X 34 D NOW^%DTC 35 ; 2/25/98 allow entry to be at most 1 minute after current time 36 S RAPLUS1=%,RAPLUS1=$$FMADD^XLFDT(RAPLUS1,0,0,1,0) 37 I RADTHOLD>RAPLUS1 S Y=0 38 S X=RADTHOLD 39 K RADTHOLD 40 Q 41 PDC() ; do not enter secondary into primary diagnostic code field 42 ; called from ^DD(70.03,13,0) 43 ; do not select inactive diagnostic code 12/23/96 44 I $P(^RA(78.3,+Y,0),U,5)="Y" Q 0 45 I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"DX","B",+Y)) Q 0 46 Q 1 47 SDC() ; do not enter primary into secondary diagnostic code field 48 ; called from ^DD(70.14,.01,0) 49 ; do not select inactive diagnostic code 12/23/96 50 I $P(^RA(78.3,+Y,0),U,5)="Y" Q 0 51 I '$D(X)!('$D(DA(3))) G SDC2 52 I '$D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0)) G SDC2 53 I $P(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",13)=+Y Q 0 54 Q 1 55 SDC2 ; 56 I '$D(X)!('$D(DA(2))) G SDC3 57 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0 58 I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y Q 0 59 Q 1 60 SDC3 ; 61 I '$D(RADFN) Q 0 62 S DA(2)=RADFN 63 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0 64 I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y Q 0 65 Q 1 66 NODEL ; no deletion of primary dx code, primary resident or staff if there 67 ; is a secondary 68 S RASECCHK=0,RASECCHK=$O(^RADPT(DA(2),"DT",DA(1),"P",DA,RAMULT,RASECCHK)) 69 I RASECCHK W " Required" 70 K RAMULT,RASECCHK 71 Q 72 PRCCPT() ; Displays the procedure type and CPT code if applicable. 73 ; This code is called from ^DD(71,0,"ID","WRITE") and rtn RAPROD 74 N RA,RATXT S RA(0)=$G(^(0)),RA("I")=+$G(^("I")),RATXT="" 75 S RA=$S('RA("I"):0,DT'>RA("I"):0,1:1) 76 S RA(6)=$P(RA(0),U,6),RA(9)=$P(RA(0),U,9) 77 S RA(12)=$P(RA(0),U,12) I 'RA(12) S RA(10)="UNKN " 78 I '$D(RA(10)) S RA(10)=$P(^RA(79.2,+RA(12),0),U,3)_" " 79 I $L(RA(10))<5 F S RA(10)=RA(10)_" " Q:$L(RA(10))>4 80 S RATXT="("_RA(10)_$S(RA:"Inactive",RA(6)="B":"Broad ",RA(6)="D":"Detailed",RA(6)="P":"Parent ",RA(6)="S":"Series ",1:"Unknown ")_")" 81 S:RA(9)]"" RATXT=RATXT_" CPT:"_$P($$NAMCODE^RACPTMSC(RA(9),DT),"^") 82 Q RATXT 83 INDTCHK(RADA) ; Cannot inactivate a procedure if it is a common procedure 84 ; with a valid sequence number. Code resides in ^DD(71,100,0)! 85 ; 'RADA' is the ien of the procedure in file 71. if this procedure is 86 ; a common procedure i.e, $D(^RAMIS(71.3,"B",RADA)) inform the user that 87 ; the sequence number must be deleted. This relies on the "AA" xref in 88 ; the Common Proc. file for the Sequence # fld (#3) 0 node, 4th pce. 89 N RA,RAIEN S RAIEN=+$O(^RAMIS(71.3,"B",RADA,0)) 90 S RA(0)=$G(^RAMIS(71.3,RAIEN,0)) Q:RA(0)']"" 91 S RA(4)=+$P(RA(0),"^",4) ; obtain the sequence number 92 I $D(^RAMIS(71.3,"AA",$$EN3^RAUTL17(RADA),RA(4),RAIEN)) D ; sequence #? 93 . N RATXT S RATXT(1)=" " 94 . S RATXT(2)=" Cannot inactivate - this procedure is currently in the" 95 . S RATXT(3)=" Rad/Nuc Med Common Procedure file with a sequence" 96 . S RATXT(4)=" number. Please remove the sequence number thru the" 97 . S RATXT(5)=" 'Common Procedure Enter/Edit' option before assigning" 98 . S RATXT(6)=" an inactivation date to this procedure." 99 . S RATXT(7)=" " 100 . D EN^DDIOL(.RATXT) K X ; display message, can't input ANY date! 101 . Q 102 Q 103 CPTCHK(RADA) ; Check if the CPT code is inactive nationally. 104 ; 'RADA' assume the value of +Y passed from the input xform, ^DD(71,9,0) 105 ; quit if CPT code is active 106 ; 107 Q:$$ACTCODE^RACPTMSC(RADA,DT) 108 N RATXT S RATXT(1)=" " 109 S RATXT(2)=" Warning - Nationally inactive CPT code." 110 S RATXT(3)=" " D EN^DDIOL(.RATXT) 111 K X 112 Q 113 ; 114 VALADM(RAD0,Y,RADT,RAUTH) ;edit validation 115 ;Used to validate/screen radiopharm dosage administrator, 116 ; radiopharm prescribing phys, person who measured radiopharm dose, 117 ;---------------------------------------------------------------------- 118 ; RAD0 : IEN of entry in question for NUC MED EXAM DATA (70.2) file 119 ; Y : Pointer to the New Person file 120 ; RADT : Xam Date; if not passed, calculate exam date from file 70.2 121 ; RAUTH : 1 - only staff/resid, must be auth'zd to write med orders 122 ; : 0 - staff/resid & tech's 123 ;---------------------------------------------------------------------- 124 ; Output: '1' authorized to write med orders, else '0' 125 ;---------------------------------------------------------------------- 126 Q $$VALADM^RADD4() 127 ; 128 VOL(RAX) ; Validate the format of the value input for volume. 129 ; RAX must be a number followed by a space then text -or- 130 ; a number followed by text 131 ; Input Variable : 'RAX'- user's input 132 ; Output Variable: null if 'RAX' erroneous, formatted version of 'RAX' 133 Q $$VOL^RADD4() 1 RADD1 ;HISC/FPT-Radiology Utility Routine ;6/2/98 16:17 2 ;;5.0;Radiology/Nuclear Medicine;**1,5,10**;Mar 16, 1998 3 SECXREF ; sets/kills 'ARES' & 'ASTF' x-refs for secondary resident/staff rads 4 ; called from ^DD(74,5 5 ; 6 Q:'$D(^RARPT(DA,0)) S RADFNZ=^(0) 7 S RADTIZ=9999999.9999-$P(RADFNZ,"^",3),RACNIZ=$O(^RADPT(+$P(RADFNZ,"^",2),"DT",RADTIZ,"P","B",+$P(RADFNZ,"^",4),0)),RADFNZ=+$P(RADFNZ,"^",2) 8 I 'RACNIZ D KILL Q 9 I '$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) D KILL Q 10 I '$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,0)) D KILL Q 11 S RASECIEN=0 12 F S RASECIEN=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,RASECIEN)) Q:RASECIEN<1 S RARAD=+$P($G(^(RASECIEN,0)),"^",1) I RARAD>0 D 13 .S:$D(RASET) ^RARPT(RAXREF,RARAD,DA)="" K:$D(RAKILL) ^RARPT(RAXREF,RARAD,DA) 14 D XSEC^RAUTL20 15 KILL K RACNIZ,RADFNZ,RADTIZ,RASECOND,RASECIEN 16 Q 17 SCDTC ; status change date/time check 18 ; called from ^DD(70.05,.01 19 ; if X is a date/time prior to the exam date/time, then set Y=0. 20 ; if X is a over a minute in the future, then set Y=0. 21 ; if X is missing the time portion, then set Y=0. 22 I '($D(X)#2) Q 23 I '$F(X,".") D EN^DDIOL("** Time is Required **","","!!?20") S Y=0 Q 24 N RASTATUS,RAORDNUM,RAPLUS1 25 ; eg. da(3)=1128, da(2)=7028970.8743,da(1)=1,da=1 26 S RASTATUS=$P($G(^RADPT(+$G(DA(3)),"DT",+$G(DA(2)),"P",+$G(DA(1)),0)),U,3) 27 S RAORDNUM=$P($G(^RA(72,+RASTATUS,0)),U,3) 28 I X<(9999999.9999-$G(DA(2))),RAORDNUM>1 S Y=0 Q 29 S RADTHOLD=X 30 D NOW^%DTC 31 ; 2/25/98 allow entry to be at most 1 minute after current time 32 S RAPLUS1=%,RAPLUS1=$$FMADD^XLFDT(RAPLUS1,0,0,1,0) 33 I RADTHOLD>RAPLUS1 S Y=0 34 S X=RADTHOLD 35 K RADTHOLD 36 Q 37 PDC() ; do not enter secondary into primary diagnostic code field 38 ; called from ^DD(70.03,13,0) 39 ; do not select inactive diagnostic code 12/23/96 40 I $P(^RA(78.3,+Y,0),U,5)="Y" Q 0 41 I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"DX","B",+Y)) Q 0 42 Q 1 43 SDC() ; do not enter primary into secondary diagnostic code field 44 ; called from ^DD(70.14,.01,0) 45 ; do not select inactive diagnostic code 12/23/96 46 I $P(^RA(78.3,+Y,0),U,5)="Y" Q 0 47 I '$D(X)!('$D(DA(3))) G SDC2 48 I '$D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0)) G SDC2 49 I $P(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",13)=+Y Q 0 50 Q 1 51 SDC2 ; 52 I '$D(X)!('$D(DA(2))) G SDC3 53 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0 54 I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y Q 0 55 Q 1 56 SDC3 ; 57 I '$D(RADFN) Q 0 58 S DA(2)=RADFN 59 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0 60 I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y Q 0 61 Q 1 62 NODEL ; no deletion of primary dx code, primary resident or staff if there 63 ; is a secondary 64 S RASECCHK=0,RASECCHK=$O(^RADPT(DA(2),"DT",DA(1),"P",DA,RAMULT,RASECCHK)) 65 I RASECCHK W " Required" 66 K RAMULT,RASECCHK 67 Q 68 PRCCPT() ; Displays the procedure type and CPT code if applicable. 69 ; This code is called from ^DD(71,0,"ID","WRITE") and rtn RAPROD 70 N RA,RATXT S RA(0)=$G(^(0)),RA("I")=+$G(^("I")),RATXT="" 71 S RA=$S('RA("I"):0,DT'>RA("I"):0,1:1) 72 S RA(6)=$P(RA(0),U,6),RA(9)=$P(RA(0),U,9) 73 S RA(12)=$P(RA(0),U,12) I 'RA(12) S RA(10)="UNKN " 74 I '$D(RA(10)) S RA(10)=$P(^RA(79.2,+RA(12),0),U,3)_" " 75 I $L(RA(10))<5 F S RA(10)=RA(10)_" " Q:$L(RA(10))>4 76 S RATXT="("_RA(10)_$S(RA:"Inactive",RA(6)="B":"Broad ",RA(6)="D":"Detailed",RA(6)="P":"Parent ",RA(6)="S":"Series ",1:"Unknown ")_")" 77 S:RA(9)]"" RATXT=RATXT_" CPT:"_$P($$NAMCODE^RACPTMSC(RA(9),DT),"^") 78 Q RATXT 79 INDTCHK(RADA) ; Cannot inactivate a procedure if it is a common procedure 80 ; with a valid sequence number. Code resides in ^DD(71,100,0)! 81 ; 'RADA' is the ien of the procedure in file 71. if this procedure is 82 ; a common procedure i.e, $D(^RAMIS(71.3,"B",RADA)) inform the user that 83 ; the sequence number must be deleted. This relies on the "AA" xref in 84 ; the Common Proc. file for the Sequence # fld (#3) 0 node, 4th pce. 85 N RA,RAIEN S RAIEN=+$O(^RAMIS(71.3,"B",RADA,0)) 86 S RA(0)=$G(^RAMIS(71.3,RAIEN,0)) Q:RA(0)']"" 87 S RA(4)=+$P(RA(0),"^",4) ; obtain the sequence number 88 I $D(^RAMIS(71.3,"AA",$$EN3^RAUTL17(RADA),RA(4),RAIEN)) D ; sequence #? 89 . N RATXT S RATXT(1)=" " 90 . S RATXT(2)=" Cannot inactivate - this procedure is currently in the" 91 . S RATXT(3)=" Rad/Nuc Med Common Procedure file with a sequence" 92 . S RATXT(4)=" number. Please remove the sequence number thru the" 93 . S RATXT(5)=" 'Common Procedure Enter/Edit' option before assigning" 94 . S RATXT(6)=" an inactivation date to this procedure." 95 . S RATXT(7)=" " 96 . D EN^DDIOL(.RATXT) K X ; display message, can't input ANY date! 97 . Q 98 Q 99 CPTCHK(RADA) ; Check if the CPT code is inactive nationally. 100 ; 'RADA' assume the value of +Y passed from the input xform, ^DD(71,9,0) 101 ; quit if CPT code is active 102 ; 103 Q:$$ACTCODE^RACPTMSC(RADA,DT) 104 N RATXT S RATXT(1)=" " 105 S RATXT(2)=" Warning - Nationally inactive CPT code." 106 S RATXT(3)=" " D EN^DDIOL(.RATXT) 107 K X 108 Q 109 DCHK(RADG,RADT,Y) ; Check if drug if DRUG is active AND a Radiopharmaceu- 110 ; tical. 111 ; 'RASTAT=1' if active AND RADG condition met 112 ; 'RASTAT=0' if inactive OR RADG condition not met 113 ; VERSION 5.0 called from ^DD(70.21,.01,12.1) 114 ; 'Y' is the IEN for the Drug file 115 ; 'RADT' is the cutoff date for drugs in the drug file 116 ; 'RADG':$S(RADG="R":Radiopharm,"P":non-Radioharm,1:non-Radiopharm) 117 Q $$DCHK^RADD4() 118 ; 119 VALADM(RAD0,Y,RADT,RAUTH) ;edit validation 120 ;Used to validate/screen radiopharm dosage administrator, 121 ; radiopharm prescribing phys, person who measured radiopharm dose, 122 ;---------------------------------------------------------------------- 123 ; RAD0 : IEN of entry in question for NUC MED EXAM DATA (70.2) file 124 ; Y : Pointer to the New Person file 125 ; RADT : Xam Date; if not passed, calculate exam date from file 70.2 126 ; RAUTH : 1 - only staff/resid, must be auth'zd to write med orders 127 ; : 0 - staff/resid & tech's 128 ;---------------------------------------------------------------------- 129 ; Output: '1' authorized to write med orders, else '0' 130 ;---------------------------------------------------------------------- 131 Q $$VALADM^RADD4() 132 ; 133 VOL(RAX) ; Validate the format of the value input for volume. 134 ; RAX must be a number followed by a space then text -or- 135 ; a number followed by text 136 ; Input Variable : 'RAX'- user's input 137 ; Output Variable: null if 'RAX' erroneous, formatted version of 'RAX' 138 Q $$VOL^RADD4() -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD2.m
r613 r623 1 RADD2 ;HISC/GJC/CAH-Radiology Data Dictionary Utility Routine ;5/14/97 10:31 2 ;;5.0;Radiology/Nuclear Medicine;**84**;Mar 16, 1998;Build 13 3 ; 4 ;Integration Agreements 5 ;---------------------- 6 ;EN^DDIOL(10142); FILE^DIE(2053);NOTE^ORX3(868);MES^XPDUTL(10141) 7 ; 8 EN1(RAX,RAY) ; Input transform for the .01 field (Procedure) for the Rad/Nuc 9 ; Med Common Procedure file i.e, ^RAMIS(71.3 10 ; Procedure must not have an inactive date before today in file 71 11 ; Procedure in file 71 must have same imaging type as the one 12 ; selected before editing this record in file 71.3 13 ; If 'Parent' type procedure, it must have at least 1 descendent 14 ; 'RAX' is the value of the .01 field in ^RAMIS(71.3, 15 ; 'RAY' are ien's of entries in ^RAMIS(71, 16 I '$G(RAIMGTYI) Q 0 17 I $S('$D(^("I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S(RAIMGTYI=$P($G(^RAMIS(71,+RAY,0)),"^",12):1,1:0),$S($P(^RAMIS(71,+RAY,0),U,6)'="P":1,$O(^RAMIS(71,+RAY,4,0)):1,1:0) 18 Q $T 19 ; 20 CH(RAY,RAX) ; This subroutine will fire off the 'Radiology Request Cancel 21 ; /Hold' notification as defined in the 'OE/RR NOTIFICATIONS' file. 22 ; Only if request is either cancelled or held. Called from the set 23 ; logic of the 'ACHN' xref in ^DD(75.1,5) field definition. 24 ; 25 ; Input variables: 26 ; 'RAX'=Request status of the order, $S(X=1:'discontinued',X=3:'hold') 27 ; 'RAY'=ien of the order in the RAD/NUC MED ORDERS file. 28 ; 29 Q:(RAY'=+RAY) Q:(RAX'=1)&(RAX'=3) 30 N %,C,D,D0,DA,DC,DDER,DE,DG,DH,DI,DIC,DIE,DIEDA,DIEL,DIFLD,DIP,DIW,DIWT 31 N DK,DL,DM,DN,DP,DQ,DR,DU,DV,DW,I,J,N,ORBPMSG,ORBXDATA,ORIFN,ORNOTE,ORVP 32 N RA751,RADFN,RANME,RAOIFN,RAOLP,RAOPTN,RAORDS,RAOREA,RAOSTS,RAPARENT 33 N RAPRC,RAXIT,X,Y 34 S RA751=$G(^RAO(75.1,RAY,0)) Q:RA751']"" 35 S RAOIFN=RAY,RADFN=+$P(RA751,"^") 36 S RAPRC=$P($G(^RAMIS(71,+$P(RA751,"^",2),0)),"^"),ORVP=RADFN_";DPT(" 37 S ORBPMSG=$S(RAX=1:"Discontinued - ",1:"On hold - ")_$E(RAPRC,1,17) 38 S ORBXDATA=RAOIFN_","_RADFN,ORIFN=+$P(RA751,"^",7),ORNOTE(26)=1 39 D NOTE^ORX3 40 Q 41 INACOM(RAD0) ; Check inactive date on the Rad/Nuc Med Procedure file (71) 42 ; for the Common Procedure before setting our inactive procedure to 43 ; active. Called from the 'RA COMMON PROCEDURE EDIT' input template. 44 ; Option: Common Procedure Enter/Edit (13^RAMAIN2) 45 ; Input : RAD0-ien of Rad/Nuc Med Common Procedure 46 ; Output: if Common cannot be re-activated, reset the 'Inactive' field 47 ; to 'yes'. 48 N RAINA S RAINA=$P($G(^RAMIS(71,+$P($G(^RAMIS(71.3,RAD0,0)),"^"),"I")),"^") 49 Q:RAINA=""!(RAINA>DT) "@15" ; we can inactivate the common 50 N RAFDA,RAMSG 51 S RAFDA(71.3,RAD0_",",4)="Y" D FILE^DIE("","RAFDA","") S RAMSG(1)=$C(7) 52 S RAMSG(2)="You cannot add this procedure to the common procedure list" 53 S RAMSG(3)="because it is inactivated in the Rad/Nuc Med Procedures file." 54 S RAMSG(4)="You must first re-activate the procedure through the 'Procedure" 55 S RAMSG(5)="Enter/Edit' option.",RAMSG(6)="" D MES^XPDUTL(.RAMSG) 56 Q "@10" ; reset 'Inactive' to 'yes', re-edit field. 57 ; 58 EN2() ; called from ^DD(74,0,"ID","WRITE") 59 ; display long case #'s in the same print set as current record 60 N RA1,RA2 61 S RA1=0,RA2="" 62 F S RA1=$O(^RARPT(Y,1,"B",RA1)) Q:'RA1 S RA2=RA2_$S(RA2="":"-",1:",-")_$P(RA1,"-",2) 63 Q RA2 64 USUAL(RADA,RAX) ; To insure that the USUAL DOSE value falls between the 65 ; HIGH ADULT DOSE and the LOW ADULT DOSE. 66 ; Input Variables: 67 ; RADA -> top level/sub-file level IEN's 68 ; RAX -> value input by the user 69 ; Output Variable: $S(1: value is accepted, 0: value not accepted) 70 ; 71 Q:RAX="" 0 ; X does not exist 72 N RA7108,RAH,RAL S RA7108=$G(^RAMIS(71,RADA(1),"NUC",RADA,0)) 73 S RAH=$P(RA7108,"^",5),RAL=$P(RA7108,"^",6) 74 S RAH=$S(RAH="":99999.9999,1:RAH),RAL=$S(RAL="":.0001,1:RAL) 75 I (+RAX<RAL)!(+RAX>RAH) D Q 0 ; value is not accepted 76 . N RARRY S RARRY(1)="The 'USUAL DOSE' must fall within the range of: " 77 . S RARRY(1)=RARRY(1)_RAL_" - "_RAH_" " 78 . D EN^DDIOL(.RARRY) 79 . Q 80 E Q 1 ; value accepted 81 ; 82 RANGE(RADA) ; Determine the range in which the 'USUAL DOSE' must fall 83 ; Input Variables: 84 ; RADA -> top level/sub-file level IEN's 85 ; Output Variable: 86 ; RANGE -> the range in which the 'USUAL DOSE' must fall 87 N RA7108,RAH,RAL 88 S RA7108=$G(^RAMIS(71,RADA(1),"NUC",RADA,0)) 89 S RAH=$P(RA7108,"^",5),RAL=$P(RA7108,"^",6) 90 S RAH=$S(RAH="":99999.9999,1:RAH),RAL=$S(RAL="":.0001,1:RAL) 91 Q RAL_"-"_RAH 92 MEDOSE(RAY,RADT) ; Determine if this individual (RAY) is authorized to 93 ; administer medications. Called from ^DD(70.15,4,12.1) 94 ; Input : RAY (pnt to 200) - the individual being checked at the moment 95 ; RADT - Date of the examination 96 ; Output: '1' - user is authorized to administer medications, else '0' 97 ; 98 Q:$D(^VA(200,"ARC","R",RAY)) 1 ; Rad/Nuc Med Class: Resident 99 Q:$D(^VA(200,"ARC","S",RAY)) 1 ; Rad/Nuc Med Class: Staff 100 Q:$D(^VA(200,"ARC","T",RAY)) 1 ; Rad/Nuc Med Class: Technologist 101 Q:$D(^XUSEC("ORES",RAY)) 1 Q:$D(^XUSEC("ORELSE",RAY)) 1 102 N RAUTH S RAUTH=$G(^VA(200,RAY,"PS")) 103 ; If authorized to write med orders ($P(RAUTH,"^")=1) and inactivation 104 ; date null -OR- inactivation date greater than or equal to the exam 105 ; date individual is authorized. 106 Q:+$P(RAUTH,"^")&($S('$P(RAUTH,"^",4):1,$P(RAUTH,"^",4)'<RADT:1,1:0)) 1 107 Q 0 108 ; 109 PRIDXIXK(DA,X) ;This subroutine executes the KILL logic for the 'new style' AD cross- 110 ;reference on the 'PRIMARY DIAGNOSTIC CODE' (data dictionary: 70.03; field: 13) 111 ;Input: DA - an array where DA(2)=RADFN, DA(1)=RADTI, & DA=RACNI 112 ; X - the primary diagnostic code value (this field points to file 78.3) 113 N RACNI,RADFN,RADTI,RAFDA,RAIENS,RAX 114 S RADFN=DA(2),RADTI=DA(1),RACNI=DA,RAX=X ;save the variables just in case 115 S RAIENS=DA_","_DA(1)_","_DA(2)_",",RAFDA(70.03,RAIENS,20)="@" 116 D FILE^DIE(,"RAFDA") ;delete data in 'DIAGNOSTIC PRINT DATE' (DD: 70.03; field: 20) 117 K ^RADPT("AD",RAX,RADFN,RADTI,RACNI) 118 Q 119 ; 1 RADD2 ;HISC/GJC/CAH-Radiology Data Dictionary Utility Routine ;5/14/97 10:31 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 3 EN1(RAX,RAY) ; Input transform for the .01 field (Procedure) for the Rad/Nuc 4 ; Med Common Procedure file i.e, ^RAMIS(71.3 5 ; Procedure must not have an inactive date before today in file 71 6 ; Procedure in file 71 must have same imaging type as the one 7 ; selected before editing this record in file 71.3 8 ; If 'Parent' type procedure, it must have at least 1 descendent 9 ; 'RAX' is the value of the .01 field in ^RAMIS(71.3, 10 ; 'RAY' are ien's of entries in ^RAMIS(71, 11 I '$G(RAIMGTYI) Q 0 12 I $S('$D(^("I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S(RAIMGTYI=$P($G(^RAMIS(71,+RAY,0)),"^",12):1,1:0),$S($P(^RAMIS(71,+RAY,0),U,6)'="P":1,$O(^RAMIS(71,+RAY,4,0)):1,1:0) 13 Q $T 14 ; 15 CH(RAY,RAX) ; This subroutine will fire off the 'Radiology Request Cancel 16 ; /Hold' notification as defined in the 'OE/RR NOTIFICATIONS' file. 17 ; Only if request is either cancelled or held. Called from the set 18 ; logic of the 'ACHN' xref in ^DD(75.1,5) field definition. 19 ; 20 ; Input variables: 21 ; 'RAX'=Request status of the order, $S(X=1:'discontinued',X=3:'hold') 22 ; 'RAY'=ien of the order in the RAD/NUC MED ORDERS file. 23 ; 24 Q:(RAY'=+RAY) Q:(RAX'=1)&(RAX'=3) 25 N %,C,D,D0,DA,DC,DDER,DE,DG,DH,DI,DIC,DIE,DIEDA,DIEL,DIFLD,DIP,DIW,DIWT 26 N DK,DL,DM,DN,DP,DQ,DR,DU,DV,DW,I,J,N,ORBPMSG,ORBXDATA,ORIFN,ORNOTE,ORVP 27 N RA751,RADFN,RANME,RAOIFN,RAOLP,RAOPTN,RAORDS,RAOREA,RAOSTS,RAPARENT 28 N RAPRC,RAXIT,X,Y 29 S RA751=$G(^RAO(75.1,RAY,0)) Q:RA751']"" 30 S RAOIFN=RAY,RADFN=+$P(RA751,"^") 31 S RAPRC=$P($G(^RAMIS(71,+$P(RA751,"^",2),0)),"^"),ORVP=RADFN_";DPT(" 32 S ORBPMSG=$S(RAX=1:"Discontinued - ",1:"On hold - ")_$E(RAPRC,1,17) 33 S ORBXDATA=RAOIFN_","_RADFN,ORIFN=+$P(RA751,"^",7),ORNOTE(26)=1 34 D NOTE^ORX3 35 Q 36 INACOM(RAD0) ; Check inactive date on the Rad/Nuc Med Procedure file (71) 37 ; for the Common Procedure before setting our inactive procedure to 38 ; active. Called from the 'RA COMMON PROCEDURE EDIT' input template. 39 ; Option: Common Procedure Enter/Edit (13^RAMAIN2) 40 ; Input : RAD0-ien of Rad/Nuc Med Common Procedure 41 ; Output: if Common cannot be re-activated, reset the 'Inactive' field 42 ; to 'yes'. 43 N RAINA S RAINA=$P($G(^RAMIS(71,+$P($G(^RAMIS(71.3,RAD0,0)),"^"),"I")),"^") 44 Q:RAINA=""!(RAINA>DT) "@15" ; we can inactivate the common 45 N RAFDA,RAMSG 46 S RAFDA(71.3,RAD0_",",4)="Y" D FILE^DIE("","RAFDA","") S RAMSG(1)=$C(7) 47 S RAMSG(2)="You cannot add this procedure to the common procedure list" 48 S RAMSG(3)="because it is inactivated in the Rad/Nuc Med Procedures file." 49 S RAMSG(4)="You must first re-activate the procedure through the 'Procedure" 50 S RAMSG(5)="Enter/Edit' option.",RAMSG(6)="" D MES^XPDUTL(.RAMSG) 51 Q "@10" ; reset 'Inactive' to 'yes', re-edit field. 52 ; 53 EN2() ; called from ^DD(74,0,"ID","WRITE") 54 ; display long case #'s in the same print set as current record 55 N RA1,RA2 56 S RA1=0,RA2="" 57 F S RA1=$O(^RARPT(Y,1,"B",RA1)) Q:'RA1 S RA2=RA2_$S(RA2="":"-",1:",-")_$P(RA1,"-",2) 58 Q RA2 59 USUAL(RADA,RAX) ; To insure that the USUAL DOSE value falls between the 60 ; HIGH ADULT DOSE and the LOW ADULT DOSE. 61 ; Input Variables: 62 ; RADA -> top level/sub-file level IEN's 63 ; RAX -> value input by the user 64 ; Output Variable: $S(1: value is accepted, 0: value not accepted) 65 ; 66 Q:RAX="" 0 ; X does not exist 67 N RA7108,RAH,RAL S RA7108=$G(^RAMIS(71,RADA(1),"NUC",RADA,0)) 68 S RAH=$P(RA7108,"^",5),RAL=$P(RA7108,"^",6) 69 S RAH=$S(RAH="":99999.9999,1:RAH),RAL=$S(RAL="":.0001,1:RAL) 70 I (+RAX<RAL)!(+RAX>RAH) D Q 0 ; value is not accepted 71 . N RARRY S RARRY(1)="The 'USUAL DOSE' must fall within the range of: " 72 . S RARRY(1)=RARRY(1)_RAL_" - "_RAH_" " 73 . D EN^DDIOL(.RARRY) 74 . Q 75 E Q 1 ; value accepted 76 ; 77 RANGE(RADA) ; Determine the range in which the 'USUAL DOSE' must fall 78 ; Input Variables: 79 ; RADA -> top level/sub-file level IEN's 80 ; Output Variable: 81 ; RANGE -> the range in which the 'USUAL DOSE' must fall 82 N RA7108,RAH,RAL 83 S RA7108=$G(^RAMIS(71,RADA(1),"NUC",RADA,0)) 84 S RAH=$P(RA7108,"^",5),RAL=$P(RA7108,"^",6) 85 S RAH=$S(RAH="":99999.9999,1:RAH),RAL=$S(RAL="":.0001,1:RAL) 86 Q RAL_"-"_RAH 87 MEDOSE(RAY,RADT) ; Determine if this individual (RAY) is authorized to 88 ; administer medications. Called from ^DD(70.15,4,12.1) 89 ; Input : RAY (pnt to 200) - the individual being checked at the moment 90 ; RADT - Date of the examination 91 ; Output: '1' - user is authorized to administer medications, else '0' 92 ; 93 Q:$D(^VA(200,"ARC","R",RAY)) 1 ; Rad/Nuc Med Class: Resident 94 Q:$D(^VA(200,"ARC","S",RAY)) 1 ; Rad/Nuc Med Class: Staff 95 Q:$D(^VA(200,"ARC","T",RAY)) 1 ; Rad/Nuc Med Class: Technologist 96 Q:$D(^XUSEC("ORES",RAY)) 1 Q:$D(^XUSEC("ORELSE",RAY)) 1 97 N RAUTH S RAUTH=$G(^VA(200,RAY,"PS")) 98 ; If authorized to write med orders ($P(RAUTH,"^")=1) and inactivation 99 ; date null -OR- inactivation date greater than or equal to the exam 100 ; date individual is authorized. 101 Q:+$P(RAUTH,"^")&($S('$P(RAUTH,"^",4):1,$P(RAUTH,"^",4)'<RADT:1,1:0)) 1 102 Q 0 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD3.m
r613 r623 1 RADD3 ;HISC/SWM-Radiology Data Dictionary Utility Routine ;9/11/97 16:23 2 ;;5.0;Radiology/Nuclear Medicine;**18,65**;Mar 16, 1998;Build 8 3 ; 4 ;Supported IA #2056 reference to GET1^DIQ 5 ;Supported IA #10142 reference to EN^DDIOL 6 ;Supported IA #2053 reference to UPDATE^DIE, FILE^DIE 7 ;Supported IA #10103 reference to NOW^XLFDT 8 ; 9 PAIR ; 10 ; called from file 71.9's field SOURCE 11 ; SOURCE may be added normally via the "RA NM EDIT LOT" option, 12 ; or it may be added via one of the 3 exam edits when the LOT 13 ; prompt appears for the case's Radiopharm. This LOT prompt 14 ; allows adding new LOT on-the-fly, which causes the LOT's 15 ; associated SOURCE, EXPIRATION DATE, KIT # to be prompted 16 ; and the current case's Radiopharm to be stuffed into the new LOT's 17 ; Radiopharm field. The SOURCE field invokes this subroutine to: 18 ; re-set DR string to stuff matching radiopharm 19 ; not allow spacebar return for radioph 20 ; RA*5*65 removed the Fileman Identifier for file 79.1's RADIOPHARM 21 ; so by default, the DR will just be "2;3;4;" without the "5;". 22 ; 23 N RA1,RA2,RA3 24 I $D(RAOPT("EDITPT"))!($D(RAOPT("EDITCN")))!($D(RAOPT("STATRACK"))) D 25 . S RA1=$$EN1^RAPSAPI(RAPSDRUG,.01) 26 . I $G(DR)'[";5",$G(DIE)="^RAMIS(71.9,",+$G(RAPSDRUG),RA1]"" S DR=DR_"5///"_RA1 K ^DISV(DUZ,"^RAMIS(71.9,") 27 . Q 28 ; check pairing of number/id with source 29 ; called by input transform of file 71.9'S field 2 (source) 30 S (RA1,RA2,RA3)="" 31 Q:$G(DA)="" Q:$G(D)="" 32 F S RA1=$O(^RAMIS(71.9,"B",$P(D,U),RA1)) Q:'RA1 I DA'=RA1 S:$P(^RAMIS(71.9,RA1,0),U,2)=+Y RA2=1 ;found a match so set ra2=1 33 W:RA2 !!,"** There's already a NUMBER/ID=",$P(D,U)," and SOURCE=",$P(Y,U,2)," **",! 34 K:RA2 X 35 Q 36 SCRLOT() ;screen lot # from file 70.2 37 ;lot's exp. dt must be within d/t dose admin, if no admin, use exam dt 38 ; if lot's exp. dt is null, allow as choice (don't check) 39 ;lot's radiopharm must match exam's radiopharm 40 ; if lot's radiopharm is null, don't allow as choice 41 ;Y pointer to lot file 42 ;RA0A date/time dose administered 43 ;RA0E date/time exam 44 ;RALOTEXP lot's expiration date 45 ;RA0RAD exam's radiopharmaceutical 46 ;RALOTRAD lot's radiopharmaceutical 47 ;RARETUR return value of screen, 0=failed, 1=passed 48 I '$D(Y)#2!('$D(DA))!('$D(DA(1))) Q 0 49 N RA0A,RA0E,RALOTEXP,RA0RAD,RALOTRAD,RARETURN 50 S RARETURN=0 51 S RA0E=$P(^RADPTN(DA(1),0),U,2),RA0A=$P(^("NUC",DA,0),U,8),RA0RAD=$P(^(0),U),RALOTEXP=$P(^RAMIS(71.9,+Y,0),U,3),RALOTRAD=$P(^(0),U,5) 52 I $S(RALOTEXP="":1,RA0A:RALOTEXP>RA0A,1:RALOTEXP>RA0E),(RA0RAD=RALOTRAD) S RARETURN=1 53 Q RARETURN 54 ; 55 GETID(Y) ; Pass back a string of data which will be used as an 56 ; identifier when lookups are done on the Imaging Locations (79.1) file 57 ; Input : Y -> ien of entry in 79.1 58 ; Output: string of data relevent to the entry in file 79.1 59 ; Location I-type_"-"_Station # of Rad/Nuc Med Division 60 N RA791 S RA791(0)=$G(^RA(79.1,Y,0)) 61 S RA791("DIV")=$G(^RA(79.1,Y,"DIV")) 62 Q "("_$$GET1^DIQ(79.2,+$P(RA791(0),"^",6),.01)_"-"_$$GET1^DIQ(4,+$P(RA791("DIV"),"^"),99)_")" 63 ; 64 DELDESC(RAIEN) ; This sub-routine will determine if descendents can be 65 ; deleted from parent procedures. If only one descendent exists, and 66 ; the parent is on the common procedure list do not allow the deletion 67 ; of the descendent. 68 ; Input : RAIEN (the DA array for the Rad/Nuc Med Procedure file.) 69 ; Output: 0 if ok to delete, 1 if not ok to delete 70 ; Called from: ^DD(71.05,.01,"DEL",1,0) node 71 N I,RA713,RATTL S (I,RA713,RATTL)=0 72 S:$D(^RAMIS(71.3,"B",RAIEN(1))) RA713=+$O(^RAMIS(71.3,"B",RAIEN(1),0)) 73 S:RA713>0 RA713(0)=$G(^RAMIS(71.3,RA713,0)) 74 F S I=$O(^RAMIS(71,RAIEN(1),4,I)) Q:I'>0 S RATTL=RATTL+1 75 I RA713,($P(RA713(0),"^",5)=""),(RATTL=1) D Q 1 76 . ; don't allow deletion of the last descendent on procedures that are 77 . ; currently active in the common procedure file. 78 . N RATXT S RATXT(1)=" " 79 . S RATXT(2)="You cannot delete the last or only descendent from a" 80 . S RATXT(3)="parent procedure when the parent procedure is an active" 81 . S RATXT(4)="common procedure.",RATXT(5)=$C(7) D EN^DDIOL(.RATXT) 82 . Q 83 Q 0 ; common procedure with more than one descendent, ok to delete 84 ; 85 REACMMN(RADA) ; Check to see if a commom procedure can be re-activated. 86 ; This sub-routine checks if this common is a parent w/o descendents. 87 ; If true, this common procedure cannot be re-activated. 88 ; Input : RADA - ien of the entry in 71.3 89 ; Output: 0 if ok to delete, 1 if not ok to delete 90 ; Called from ^DD(71.3,4,"DEL",1,0) 91 N RA713 S RA713=$G(^RAMIS(71.3,RADA,0)) 92 I $P($G(^RAMIS(71,+RA713,0)),"^",6)="P",('$O(^RAMIS(71,+RA713,4,0))) D Q 1 93 . N RATXT S RATXT(1)=" " 94 . S RATXT(2)="You cannot re-activate a common parent procedure without descendents." 95 . S RATXT(3)=$C(7) D EN^DDIOL(.RATXT) 96 . Q 97 Q 0 ; ok to delete 98 ; 99 X7005(RADFN,RADTI,RACNI,RAMDV,RAQED,RASTI,RAWHO) ;update the EXAM 100 ; STATUS TIMES (70.05) multiple. Called from RASTED (will be 101 ; called from RAUTL1 in the future) 102 ; 103 ; input variables: 104 ; ---------------- 105 ; RADFN=patient dfn, RADTI=exam date/time (inverse) 106 ; RACNI=exam record ien (70.03), RAMDV=division parameters 107 ; RAQED=task queued(1=yes;0=no), RASTI=exam status 108 ; RAWHO=editing person 109 ; 110 N %,D,D0,DA,DIC,DIE,DQ,DR,RAFDA,RAIEN,RAIENS,X,Y 111 S RAQED=+$G(RAQED) ; if tasked 1, else 0 112 S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_"," 113 S RAFDA(70.05,RAIENS,.01)=$$MIDNGHT^RAUTL5($$NOW^XLFDT()) 114 D UPDATE^DIE(,"RAFDA","RAIEN") ; RAIEN(1)=ien of new record 115 K RAFDA,RAIENS Q:'$D(RAIEN(1)) ; record not added 116 I $P(RAMDV,"^",11),('RAQED) D 117 .S DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","_RACNI_",""T""," 118 .S DA=RAIEN(1),DR=".01" D ^DIE 119 S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_"," 120 S RAFDA(70.05,RAIENS,2)=RASTI 121 S RAFDA(70.05,RAIENS,3)=$G(RAWHO) 122 D FILE^DIE(,"RAFDA") 123 Q 124 A7007(RADFN,RADTI,RACNI,RAWHO,RATC) ; update the ACTIVITY LOG (70.07) 125 ; multiple. Called from RASTED (will be called from RAUTL1 in the 126 ; future) 127 ; 128 ; input variables: 129 ; ---------------- 130 ; RADFN=patient dfn, RADTI=exam date/time (inverse) 131 ; RACNI=exam record ien (70.03), RAWHO=editing person 132 ; RATC=technologist comments (optional) 133 ; 134 N %,D,D0,DA,DIC,DIE,DQ,DR,RAFDA,RAIEN,RAIENS,X,Y 135 S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_"," 136 S RAFDA(70.07,RAIENS,.01)="NOW" 137 D UPDATE^DIE("E","RAFDA","RAIEN") ;RAIEN(1)=ien of new record 138 K RAFDA,RAIENS Q:'$D(RAIEN(1)) ; record not added 139 S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_"," 140 S RAFDA(70.07,RAIENS,2)="U" 141 S RAFDA(70.07,RAIENS,3)=$G(RAWHO) 142 S:$G(RATC)]"" RAFDA(70.07,RAIENS,4)=RATC 143 D FILE^DIE(,"RAFDA") 144 Q 145 ; 146 ;updates EXAM STATUS 147 U70033(RA18DFN,RA18DTI,RA18CNI,RA18ST) ; 148 N %,D,D0,DA,DIC,DIE,DQ,DR,RA18FDA,RA18IENS,X,Y 149 S RA18IENS=RA18CNI_","_RA18DTI_","_RA18DFN_"," 150 S RA18FDA(70.03,RA18IENS,3)=RA18ST 151 D FILE^DIE(,"RA18FDA") 152 Q 153 ; 1 RADD3 ;HISC/SWM-Radiology Data Dictionary Utility Routine ;9/11/97 16:23 2 ;;5.0;Radiology/Nuclear Medicine;**18**;Mar 16, 1998 3 PAIR ; 4 ; if editing SOURCE for new (laygo) LOT entry in file 71.9 5 ; then re-set DR string to stuff matching radiopharm 6 ; and don't allow spacebar return for radioph 7 I $D(RAOPT("EDITPT"))!($D(RAOPT("EDITCN")))!($D(RAOPT("STATRACK"))) D 8 . I $G(DR)[";5",$G(DIE)="^RAMIS(71.9,",+$G(RAPSDRUG),$P($G(^PSDRUG(+$G(RAPSDRUG),0)),U)]"" S DR=$P(DR,";5")_";5///"_$P($G(^PSDRUG(+$G(RAPSDRUG),0)),U)_$P(DR,";5",2,99) K ^DISV(DUZ,"^RAMIS(71.9,") 9 . Q 10 ; check pairing of number/id with source 11 ; called by input transform of file 71.9'S field 2 (source) 12 N RA1,RA2,RA3 S (RA1,RA2,RA3)="" 13 Q:$G(DA)="" Q:$G(D)="" 14 F S RA1=$O(^RAMIS(71.9,"B",$P(D,U),RA1)) Q:'RA1 I DA'=RA1 S:$P(^RAMIS(71.9,RA1,0),U,2)=+Y RA2=1 ;found a match so set ra2=1 15 W:RA2 !!,"** There's already a NUMBER/ID=",$P(D,U)," and SOURCE=",$P(Y,U,2)," **",! 16 K:RA2 X 17 Q 18 SCRLOT() ;screen lot # from file 70.2 19 ;lot's exp. dt must be within d/t dose admin, if no admin, use exam dt 20 ; if lot's exp. dt is null, allow as choice (don't check) 21 ;lot's radiopharm must match exam's radiopharm 22 ; if lot's radiopharm is null, don't allow as choice 23 ;Y pointer to lot file 24 ;RA0A date/time dose administered 25 ;RA0E date/time exam 26 ;RALOTEXP lot's expiration date 27 ;RA0RAD exam's radiopharmaceutical 28 ;RALOTRAD lot's radiopharmaceutical 29 ;RARETUR return value of screen, 0=failed, 1=passed 30 I '$D(Y)#2!('$D(DA))!('$D(DA(1))) Q 0 31 N RA0A,RA0E,RALOTEXP,RA0RAD,RALOTRAD,RARETURN 32 S RARETURN=0 33 S RA0E=$P(^RADPTN(DA(1),0),U,2),RA0A=$P(^("NUC",DA,0),U,8),RA0RAD=$P(^(0),U),RALOTEXP=$P(^RAMIS(71.9,+Y,0),U,3),RALOTRAD=$P(^(0),U,5) 34 I $S(RALOTEXP="":1,RA0A:RALOTEXP>RA0A,1:RALOTEXP>RA0E),(RA0RAD=RALOTRAD) S RARETURN=1 35 Q RARETURN 36 ; 37 GETID(Y) ; Pass back a string of data which will be used as an 38 ; identifier when lookups are done on the Imaging Locations (79.1) file 39 ; Input : Y -> ien of entry in 79.1 40 ; Output: string of data relevent to the entry in file 79.1 41 ; Location I-type_"-"_Station # of Rad/Nuc Med Division 42 N RA791 S RA791(0)=$G(^RA(79.1,Y,0)) 43 S RA791("DIV")=$G(^RA(79.1,Y,"DIV")) 44 Q "("_$$GET1^DIQ(79.2,+$P(RA791(0),"^",6),.01)_"-"_$$GET1^DIQ(4,+$P(RA791("DIV"),"^"),99)_")" 45 ; 46 DELDESC(RAIEN) ; This sub-routine will determine if descendents can be 47 ; deleted from parent procedures. If only one descendent exists, and 48 ; the parent is on the common procedure list do not allow the deletion 49 ; of the descendent. 50 ; Input : RAIEN (the DA array for the Rad/Nuc Med Procedure file.) 51 ; Output: 0 if ok to delete, 1 if not ok to delete 52 ; Called from: ^DD(71.05,.01,"DEL",1,0) node 53 N I,RA713,RATTL S (I,RA713,RATTL)=0 54 S:$D(^RAMIS(71.3,"B",RAIEN(1))) RA713=+$O(^RAMIS(71.3,"B",RAIEN(1),0)) 55 S:RA713>0 RA713(0)=$G(^RAMIS(71.3,RA713,0)) 56 F S I=$O(^RAMIS(71,RAIEN(1),4,I)) Q:I'>0 S RATTL=RATTL+1 57 I RA713,($P(RA713(0),"^",5)=""),(RATTL=1) D Q 1 58 . ; don't allow deletion of the last descendent on procedures that are 59 . ; currently active in the common procedure file. 60 . N RATXT S RATXT(1)=" " 61 . S RATXT(2)="You cannot delete the last or only descendent from a" 62 . S RATXT(3)="parent procedure when the parent procedure is an active" 63 . S RATXT(4)="common procedure.",RATXT(5)=$C(7) D EN^DDIOL(.RATXT) 64 . Q 65 Q 0 ; common procedure with more than one descendent, ok to delete 66 ; 67 REACMMN(RADA) ; Check to see if a commom procedure can be re-activated. 68 ; This sub-routine checks if this common is a parent w/o descendents. 69 ; If true, this common procedure cannot be re-activated. 70 ; Input : RADA - ien of the entry in 71.3 71 ; Output: 0 if ok to delete, 1 if not ok to delete 72 ; Called from ^DD(71.3,4,"DEL",1,0) 73 N RA713 S RA713=$G(^RAMIS(71.3,RADA,0)) 74 I $P($G(^RAMIS(71,+RA713,0)),"^",6)="P",('$O(^RAMIS(71,+RA713,4,0))) D Q 1 75 . N RATXT S RATXT(1)=" " 76 . S RATXT(2)="You cannot re-activate a common parent procedure without descendents." 77 . S RATXT(3)=$C(7) D EN^DDIOL(.RATXT) 78 . Q 79 Q 0 ; ok to delete 80 ; 81 X7005(RADFN,RADTI,RACNI,RAMDV,RAQED,RASTI,RAWHO) ;update the EXAM 82 ; STATUS TIMES (70.05) multiple. Called from RASTED (will be 83 ; called from RAUTL1 in the future) 84 ; 85 ; input variables: 86 ; ---------------- 87 ; RADFN=patient dfn, RADTI=exam date/time (inverse) 88 ; RACNI=exam record ien (70.03), RAMDV=division parameters 89 ; RAQED=task queued(1=yes;0=no), RASTI=exam status 90 ; RAWHO=editing person 91 ; 92 N %,D,D0,DA,DIC,DIE,DQ,DR,RAFDA,RAIEN,RAIENS,X,Y 93 S RAQED=+$G(RAQED) ; if tasked 1, else 0 94 S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_"," 95 S RAFDA(70.05,RAIENS,.01)=$$MIDNGHT^RAUTL5($$NOW^XLFDT()) 96 D UPDATE^DIE(,"RAFDA","RAIEN") ; RAIEN(1)=ien of new record 97 K RAFDA,RAIENS Q:'$D(RAIEN(1)) ; record not added 98 I $P(RAMDV,"^",11),('RAQED) D 99 .S DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","_RACNI_",""T""," 100 .S DA=RAIEN(1),DR=".01" D ^DIE 101 S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_"," 102 S RAFDA(70.05,RAIENS,2)=RASTI 103 S RAFDA(70.05,RAIENS,3)=$G(RAWHO) 104 D FILE^DIE(,"RAFDA") 105 Q 106 A7007(RADFN,RADTI,RACNI,RAWHO,RATC) ; update the ACTIVITY LOG (70.07) 107 ; multiple. Called from RASTED (will be called from RAUTL1 in the 108 ; future) 109 ; 110 ; input variables: 111 ; ---------------- 112 ; RADFN=patient dfn, RADTI=exam date/time (inverse) 113 ; RACNI=exam record ien (70.03), RAWHO=editing person 114 ; RATC=technologist comments (optional) 115 ; 116 N %,D,D0,DA,DIC,DIE,DQ,DR,RAFDA,RAIEN,RAIENS,X,Y 117 S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_"," 118 S RAFDA(70.07,RAIENS,.01)="NOW" 119 D UPDATE^DIE("E","RAFDA","RAIEN") ;RAIEN(1)=ien of new record 120 K RAFDA,RAIENS Q:'$D(RAIEN(1)) ; record not added 121 S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_"," 122 S RAFDA(70.07,RAIENS,2)="U" 123 S RAFDA(70.07,RAIENS,3)=$G(RAWHO) 124 S:$G(RATC)]"" RAFDA(70.07,RAIENS,4)=RATC 125 D FILE^DIE(,"RAFDA") 126 Q 127 ; 128 ;updates EXAM STATUS 129 U70033(RA18DFN,RA18DTI,RA18CNI,RA18ST) ; 130 N %,D,D0,DA,DIC,DIE,DQ,DR,RA18FDA,RA18IENS,X,Y 131 S RA18IENS=RA18CNI_","_RA18DTI_","_RA18DFN_"," 132 S RA18FDA(70.03,RA18IENS,3)=RA18ST 133 D FILE^DIE(,"RA18FDA") 134 Q 135 ; -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD4.m
r613 r623 1 RADD4 ;HISC/GJC-Radiology Utility Routine ;11/25/97 12:40 2 ;;5.0;Radiology/Nuclear Medicine;**65**;Mar 16, 1998;Build 8 3 ; 4 ;supported IA #10104 reference to STRIP^XLFSTR and LOW^XLFSTR 5 ; 6 VALADM() ;edit validation 7 ;Used to validate/screen radiopharm dosage administrator, 8 ; radiopharm prescribing phys, person who measured radiopharm dose, 9 ;---------------------------------------------------------------------- 10 ; RAD0 : IEN of entry in question for NUC MED EXAM DATA (70.2) file 11 ; Y : Pointer to the New Person file 12 ; RADT : Xam Date; if not passed, calculate exam date from file 70.2 13 ; RAUTH : 1 - only staff/resid, must be auth'zd to write med orders 14 ; : 0 - staff/resid & tech's 15 ;---------------------------------------------------------------------- 16 ; Output: '1' authorized to write med orders, else '0' 17 ;---------------------------------------------------------------------- 18 N RAPS S RAPS=$G(^VA(200,Y,"PS")) 19 ; $P(RAPS,"^") - authorized to write med orders '1': Yes 20 ; $P(RAPS,"^",4) - person CAN'T write med orders after this date(if any) 21 S:$G(RADT)="" RADT=$P($G(^RADPTN(RAD0,0)),"^",2) 22 I 'RAUTH,($D(^VA(200,"ARC","R",Y))!$D(^VA(200,"ARC","S",Y))!$D(^VA(200,"ARC","T",Y))) Q 1 23 I RAUTH,($D(^VA(200,"ARC","R",Y))!$D(^VA(200,"ARC","S",Y))),(+$P(RAPS,"^")),($S('$P(RAPS,"^",4):1,$P(RAPS,"^",4)'<RADT:1,1:0)) Q 1 24 Q 0 25 ; 26 VOL() ; Validate the format of the value input for volume. 27 ; RAX must be a number followed by a space then text -or- 28 ; a number followed by text 29 ; Input Variable : 'RAX'- user's input 30 ; Output Variable: null if 'RAX' erroneous, formatted version of 'RAX' 31 Q:(RAX'?0.5N0.1"."0.2N1" "1.30A)&(RAX'?0.5N0.1"."0.2N1.30A) "" 32 N RAX1,RAY S RAX1=+RAX,RAY=$P(RAX,RAX1,2) Q:RAX1'>0 "" 33 S RAY=$S($F(RAY," ")>0:$E(RAY,$F(RAY," "),9999),1:RAY) 34 S RAY=$S($F(RAY,".")>0:$E(RAY,$F(RAY,"."),9999),1:RAY) 35 S RAY=$$STRIP^XLFSTR(RAY,"0") 36 S RAY=$$LOW^XLFSTR($E(RAY,1)) 37 I RAY'="c",(RAY'="m") Q "" 38 Q RAX1_" "_RAY 1 RADD4 ;HISC/GJC-Radiology Utility Routine ;11/25/97 12:40 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 3 ; 4 DCHK() ; Check if drug if DRUG is active AND a Radiopharmaceutical. 5 ; 'RASTAT=1' if active AND RADG condition met 6 ; 'RASTAT=0' if inactive OR RADG condition not met 7 ; VERSION 5.0 called from ^DD(70.21,.01,12.1) & DCHK^RADD1 8 ; 'Y' is the IEN for the Drug file 9 ; 'RADT' is the cutoff date for drugs in the drug file 10 ; 'RADG':$S(RADG="R":Radiopharm,"P":non-Radioharm,1:non-Radiopharm) 11 N RACLASS,RADRUG,RASTAT S:RADG']"" RADG="P" 12 S RADRUG(2)=$P($G(^PSDRUG(Y,0)),"^",2) 13 S RACLASS="^DX200^DX201^DX202^" 14 S RASTAT=$$DCHK1() ; is it active '1' yes, '0' no. 15 I RASTAT D ; is active check class 16 . S:RADG="R"&(RACLASS'[("^"_RADRUG(2)_"^")) RASTAT=0 17 . S:RADG="P"&(RACLASS[("^"_RADRUG(2)_"^")) RASTAT=0 18 . Q 19 Q RASTAT 20 ; 21 DCHK1() ; Check if drug if DRUG is an active pharmaceutical 22 ; '1' if active AND Pharm, '0' if inactive 23 ; VERSION 5.0 called from DCHK above 24 ; 'Y' is the IEN for the Drug file 25 ; 'RADT' is the cutoff date for drugs in the drug file 26 ; VERSION 5.0 27 N RAINACT 28 S RAINACT=+$G(^PSDRUG(Y,"I")) 29 Q:'RAINACT 1 ; not inactive 30 I RAINACT,(RAINACT'>RADT) Q 0 ; not active 31 Q 1 ; active 32 ; 33 VALADM() ;edit validation 34 ;Used to validate/screen radiopharm dosage administrator, 35 ; radiopharm prescribing phys, person who measured radiopharm dose, 36 ;---------------------------------------------------------------------- 37 ; RAD0 : IEN of entry in question for NUC MED EXAM DATA (70.2) file 38 ; Y : Pointer to the New Person file 39 ; RADT : Xam Date; if not passed, calculate exam date from file 70.2 40 ; RAUTH : 1 - only staff/resid, must be auth'zd to write med orders 41 ; : 0 - staff/resid & tech's 42 ;---------------------------------------------------------------------- 43 ; Output: '1' authorized to write med orders, else '0' 44 ;---------------------------------------------------------------------- 45 N RAPS S RAPS=$G(^VA(200,Y,"PS")) 46 ; $P(RAPS,"^") - authorized to write med orders '1': Yes 47 ; $P(RAPS,"^",4) - person CAN'T write med orders after this date(if any) 48 S:$G(RADT)="" RADT=$P($G(^RADPTN(RAD0,0)),"^",2) 49 I 'RAUTH,($D(^VA(200,"ARC","R",Y))!$D(^VA(200,"ARC","S",Y))!$D(^VA(200,"ARC","T",Y))) Q 1 50 I RAUTH,($D(^VA(200,"ARC","R",Y))!$D(^VA(200,"ARC","S",Y))),(+$P(RAPS,"^")),($S('$P(RAPS,"^",4):1,$P(RAPS,"^",4)'<RADT:1,1:0)) Q 1 51 Q 0 52 ; 53 VOL() ; Validate the format of the value input for volume. 54 ; RAX must be a number followed by a space then text -or- 55 ; a number followed by text 56 ; Input Variable : 'RAX'- user's input 57 ; Output Variable: null if 'RAX' erroneous, formatted version of 'RAX' 58 Q:(RAX'?0.5N0.1"."0.2N1" "1.30A)&(RAX'?0.5N0.1"."0.2N1.30A) "" 59 N RAX1,RAY S RAX1=+RAX,RAY=$P(RAX,RAX1,2) Q:RAX1'>0 "" 60 S RAY=$S($F(RAY," ")>0:$E(RAY,$F(RAY," "),9999),1:RAY) 61 S RAY=$S($F(RAY,".")>0:$E(RAY,$F(RAY,"."),9999),1:RAY) 62 S RAY=$$STRIP^XLFSTR(RAY,"0") 63 S RAY=$$LOW^XLFSTR($E(RAY,1)) 64 I RAY'="c",(RAY'="m") Q "" 65 Q RAX1_" "_RAY -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADLQ3.m
r613 r623 1 RADLQ3 ;HISC/GJC-Delq Status/Incomplete Rpt's ;5/7/97 15:58 2 ;;5.0;Radiology/Nuclear Medicine;**87**;Mar 16, 1998;Build 2 3 ; 11/15/07 BAY/KAM RA*5*87 Rem Call 217642 change pat ssn to display last four 4 DISPXAM ; Display exam statuses for selected Imaging Types. These exam 5 ; statuses need the 'DELINQUENT STATUS REPORT?' field tripped to 6 ; 'yes' in file 72. 7 N RA,RAHD,UNDRLN,X,Y,Z 8 S RAHD(0)="The entries printed for this report will be based only" 9 S RAHD(1)="on exams that are in one of the following statuses:" 10 I '$D(RALL) D 11 . W !!?(IOM-$L(RAHD(0))\2),RAHD(0) 12 . W !?(IOM-$L(RAHD(1))\2),RAHD(1) 13 . Q 14 S X="" F S X=$O(^TMP($J,"RA I-TYPE",X)) Q:X']"" D Q:RAXIT 15 . I $D(^RA(72,"AA",X)) S Y="" K UNDRLN D 16 .. I '$D(RALL),($Y>(IOSL-4)) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF 17 .. I '$D(RALL) S $P(UNDRLN,"-",($L(X)+1))="" W !!?10,X,!?10,UNDRLN 18 .. F S Y=$O(^RA(72,"AA",X,Y)) Q:Y']"" D Q:RAXIT 19 ... S Z=0 F S Z=+$O(^RA(72,"AA",X,Y,Z)) Q:'Z D Q:RAXIT 20 .... S RA(0)=$G(^RA(72,Z,0)),RA(.3)=$G(^RA(72,Z,.3)) 21 .... S RA(.3,15)=$P(RA(.3),"^",15) 22 .... I RA(0)]"",(RA(.3)]""),(RA(.3,15)]""),("Yy"[RA(.3,15)) D 23 ..... S RACRT(Z)="" 24 ..... I '$D(RALL),($Y>(IOSL-4)) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D 25 ...... W @IOF,!?10,X,!?10,UNDRLN 26 ...... Q 27 ..... W:'$D(RALL) !?15,$P(RA(0),"^") 28 ..... Q 29 .... Q 30 ... Q 31 .. Q 32 . Q 33 Q 34 OUTPUT ; Print out the results 35 N RAEOS I $D(RAVAR(0)),(RAVAR(0)'=RAVAR) S RAEOS=6 36 E S RAEOS=4 37 F I=1:1:$L(RANODE,"^") D 38 . S @$P("RACN^RAPRC^RAST^RADT^RAWHE^RARP^RASSN^RAVRFIED^RAIPHY^RATECH","^",I)=$P(RANODE,"^",I) 39 . Q 40 I $Y>(IOSL-RAEOS) D Q:RAXIT 41 . S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR^RADLQ2 42 . Q 43 I RAEOS=6 D 44 . N RASTR S RASTR="*** OUTPATIENT ***" 45 . S RASTR(0)=$$REPEAT^XLFSTR(" ",((IOM-($L(RASTR)*3))\2)) 46 . S RASTR(1)=RASTR_RASTR(0)_RASTR_RASTR(0)_RASTR 47 . W !!,RASTR(1) 48 . Q 49 ; Note: Inform the user that the following data will be for outpatients. 50 ; Since only inpatient and outpatient is possibly stored, any 51 ; change in the variable RAVAR will be a change to 'outpatient'. 52 ; 11/15/07 BAY/KAM RA*5*87 Rem Call 217642 Added next line 53 S RASSN=$E(RASSN,8,11) 54 I IOM=132 D ;132 column format 55 . W !,RANME,?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT,?RATAB(4) 56 . W $E(RAWHE,1,25),?RATAB(5),RAVRFIED 57 . W !?RATAB(6),$E(RAPRC,1,30),?RATAB(7),$E(RAST,1,30) 58 . W ?RATAB(8),RARP,?RATAB(9),$E(RAIPHY,1,20),?RATAB(10),RATECH 59 . Q 60 E D ;default to 80 column 61 . W !,$E(RANME,1,20),?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT 62 . W ?RATAB(4),$E(RAWHE,1,15),?RATAB(5),RAVRFIED 63 . W !?RATAB(6),$E(RAPRC,1,20),?RATAB(7),$E(RAST,1,11) 64 . W ?RATAB(8),RARP,?RATAB(9),$E(RAIPHY,1,15),?RATAB(10),RATECH 65 . Q 66 W !,RALN1 67 S RAVAR(0)=RAVAR ; track the patient status: inpatient -or- outpatient 68 Q 69 CHECK(DUZ) ; Check for the existence of RACCESS. Pass in user's DUZ! 70 S RAPSTX="" D SETVARS^RAPSET1(0) 71 Q 72 LIST ; List divisions and I-Types 73 N A,B S A="" 74 F S A=$O(^TMP($J,"RADLQ",A)) Q:A']"" D 75 . W !!,"Division: ",$P($G(^DIC(4,A,0)),"^"),!?3,"Imaging Type(s): " 76 . S B="" F S B=$O(^TMP($J,"RADLQ",A,B)) Q:B']"" D Q:RAXIT 77 .. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR^RADLQ2 Q:RAXIT 78 .. W:$X>(IOM-30) !?($X+$L("Imaging Type(s): ")+3) W B,?($X+3) 79 .. Q 80 . Q 81 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR^RADLQ2 Q:RAXIT 82 W !!?RATAB(6),"Total Over All Divisions: ",+$G(^TMP($J,"RADLQ")) 83 Q 84 EXIT ; Kill and quit 85 K %DT,BEGDATE,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,INVMAXDT,RA,RA1,RA2 86 K RABEG,RACN,RACNI,RACRT,RADFN,RADIV,RADIVNM,RADT,RADTE,RADTI,RAEND 87 K RAEXAM,RAFLAG,RAHD,RAHEAD,RAIPHY,RAITYPE,RALN1,RALN2,RAMES,RANME 88 K RANODE,RAPAT,RAPG,RAPOP,RAPRC,RAQUIT,RAREGEX,RARP,RASORT1,RASORT2 89 K RASSN,RAST,RASTI,RASV,RATAB,RATECH,RAVAR,RAVRFIED,RAWHE,RAXIT 90 K X,Y,ZTDESC,ZTRTN,ZTSAVE 91 K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE"),^TMP($J,"RADLQ") 92 K:$D(RAPSTX) RACCESS,RAPSTX D CLOSE^RAUTL 93 K DISYS,I,POP 94 Q 95 ZEROUT(SUB) ; Zero out the ^TMP($J global. 96 N X,Y,Z 97 S X="" F S X=$O(RACCESS(DUZ,"DIV-IMG",X)) Q:X']"" D 98 . Q:'$D(^TMP($J,"RA D-TYPE",X)) S Y=0 99 . F S Y=+$O(^TMP($J,"RA D-TYPE",X,Y)) Q:'Y D 100 .. S ^TMP($J,SUB,Y)=0,Z="" 101 .. F S Z=$O(RACCESS(DUZ,"DIV-IMG",X,Z)) Q:Z']"" D 102 ... Q:'$D(^TMP($J,"RA I-TYPE",Z)) S ^TMP($J,SUB,Y,Z)=0 103 ... I SUB="RADLQ" D 104 .... S:RASORT1'="B" ^TMP($J,SUB,Y,Z,RASORT1)=0 105 .... S:RASORT1="B" ^TMP($J,SUB,Y,Z,"I")=0,^TMP($J,SUB,Y,Z,"O")=0 106 .... Q 107 ... Q 108 .. Q 109 . Q 110 Q 1 RADLQ3 ;HISC/GJC-Delq Status/Incomplete Rpt's ;5/7/97 15:58 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 3 DISPXAM ; Display exam statuses for selected Imaging Types. These exam 4 ; statuses need the 'DELINQUENT STATUS REPORT?' field tripped to 5 ; 'yes' in file 72. 6 N RA,RAHD,UNDRLN,X,Y,Z 7 S RAHD(0)="The entries printed for this report will be based only" 8 S RAHD(1)="on exams that are in one of the following statuses:" 9 I '$D(RALL) D 10 . W !!?(IOM-$L(RAHD(0))\2),RAHD(0) 11 . W !?(IOM-$L(RAHD(1))\2),RAHD(1) 12 . Q 13 S X="" F S X=$O(^TMP($J,"RA I-TYPE",X)) Q:X']"" D Q:RAXIT 14 . I $D(^RA(72,"AA",X)) S Y="" K UNDRLN D 15 .. I '$D(RALL),($Y>(IOSL-4)) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF 16 .. I '$D(RALL) S $P(UNDRLN,"-",($L(X)+1))="" W !!?10,X,!?10,UNDRLN 17 .. F S Y=$O(^RA(72,"AA",X,Y)) Q:Y']"" D Q:RAXIT 18 ... S Z=0 F S Z=+$O(^RA(72,"AA",X,Y,Z)) Q:'Z D Q:RAXIT 19 .... S RA(0)=$G(^RA(72,Z,0)),RA(.3)=$G(^RA(72,Z,.3)) 20 .... S RA(.3,15)=$P(RA(.3),"^",15) 21 .... I RA(0)]"",(RA(.3)]""),(RA(.3,15)]""),("Yy"[RA(.3,15)) D 22 ..... S RACRT(Z)="" 23 ..... I '$D(RALL),($Y>(IOSL-4)) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D 24 ...... W @IOF,!?10,X,!?10,UNDRLN 25 ...... Q 26 ..... W:'$D(RALL) !?15,$P(RA(0),"^") 27 ..... Q 28 .... Q 29 ... Q 30 .. Q 31 . Q 32 Q 33 OUTPUT ; Print out the results 34 N RAEOS I $D(RAVAR(0)),(RAVAR(0)'=RAVAR) S RAEOS=6 35 E S RAEOS=4 36 F I=1:1:$L(RANODE,"^") D 37 . S @$P("RACN^RAPRC^RAST^RADT^RAWHE^RARP^RASSN^RAVRFIED^RAIPHY^RATECH","^",I)=$P(RANODE,"^",I) 38 . Q 39 I $Y>(IOSL-RAEOS) D Q:RAXIT 40 . S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR^RADLQ2 41 . Q 42 I RAEOS=6 D 43 . N RASTR S RASTR="*** OUTPATIENT ***" 44 . S RASTR(0)=$$REPEAT^XLFSTR(" ",((IOM-($L(RASTR)*3))\2)) 45 . S RASTR(1)=RASTR_RASTR(0)_RASTR_RASTR(0)_RASTR 46 . W !!,RASTR(1) 47 . Q 48 ; Note: Inform the user that the following data will be for outpatients. 49 ; Since only inpatient and outpatient is possibly stored, any 50 ; change in the variable RAVAR will be a change to 'outpatient'. 51 I IOM=132 D ;132 column format 52 . W !,RANME,?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT,?RATAB(4) 53 . W $E(RAWHE,1,25),?RATAB(5),RAVRFIED 54 . W !?RATAB(6),$E(RAPRC,1,30),?RATAB(7),$E(RAST,1,30) 55 . W ?RATAB(8),RARP,?RATAB(9),$E(RAIPHY,1,20),?RATAB(10),RATECH 56 . Q 57 E D ;default to 80 column 58 . W !,$E(RANME,1,20),?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT 59 . W ?RATAB(4),$E(RAWHE,1,15),?RATAB(5),RAVRFIED 60 . W !?RATAB(6),$E(RAPRC,1,20),?RATAB(7),$E(RAST,1,11) 61 . W ?RATAB(8),RARP,?RATAB(9),$E(RAIPHY,1,15),?RATAB(10),RATECH 62 . Q 63 W !,RALN1 64 S RAVAR(0)=RAVAR ; track the patient status: inpatient -or- outpatient 65 Q 66 CHECK(DUZ) ; Check for the existence of RACCESS. Pass in user's DUZ! 67 S RAPSTX="" D SETVARS^RAPSET1(0) 68 Q 69 LIST ; List divisions and I-Types 70 N A,B S A="" 71 F S A=$O(^TMP($J,"RADLQ",A)) Q:A']"" D 72 . W !!,"Division: ",$P($G(^DIC(4,A,0)),"^"),!?3,"Imaging Type(s): " 73 . S B="" F S B=$O(^TMP($J,"RADLQ",A,B)) Q:B']"" D Q:RAXIT 74 .. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR^RADLQ2 Q:RAXIT 75 .. W:$X>(IOM-30) !?($X+$L("Imaging Type(s): ")+3) W B,?($X+3) 76 .. Q 77 . Q 78 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR^RADLQ2 Q:RAXIT 79 W !!?RATAB(6),"Total Over All Divisions: ",+$G(^TMP($J,"RADLQ")) 80 Q 81 EXIT ; Kill and quit 82 K %DT,BEGDATE,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,INVMAXDT,RA,RA1,RA2 83 K RABEG,RACN,RACNI,RACRT,RADFN,RADIV,RADIVNM,RADT,RADTE,RADTI,RAEND 84 K RAEXAM,RAFLAG,RAHD,RAHEAD,RAIPHY,RAITYPE,RALN1,RALN2,RAMES,RANME 85 K RANODE,RAPAT,RAPG,RAPOP,RAPRC,RAQUIT,RAREGEX,RARP,RASORT1,RASORT2 86 K RASSN,RAST,RASTI,RASV,RATAB,RATECH,RAVAR,RAVRFIED,RAWHE,RAXIT 87 K X,Y,ZTDESC,ZTRTN,ZTSAVE 88 K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE"),^TMP($J,"RADLQ") 89 K:$D(RAPSTX) RACCESS,RAPSTX D CLOSE^RAUTL 90 K DISYS,I,POP 91 Q 92 ZEROUT(SUB) ; Zero out the ^TMP($J global. 93 N X,Y,Z 94 S X="" F S X=$O(RACCESS(DUZ,"DIV-IMG",X)) Q:X']"" D 95 . Q:'$D(^TMP($J,"RA D-TYPE",X)) S Y=0 96 . F S Y=+$O(^TMP($J,"RA D-TYPE",X,Y)) Q:'Y D 97 .. S ^TMP($J,SUB,Y)=0,Z="" 98 .. F S Z=$O(RACCESS(DUZ,"DIV-IMG",X,Z)) Q:Z']"" D 99 ... Q:'$D(^TMP($J,"RA I-TYPE",Z)) S ^TMP($J,SUB,Y,Z)=0 100 ... I SUB="RADLQ" D 101 .... S:RASORT1'="B" ^TMP($J,SUB,Y,Z,RASORT1)=0 102 .... S:RASORT1="B" ^TMP($J,SUB,Y,Z,"I")=0,^TMP($J,SUB,Y,Z,"O")=0 103 .... Q 104 ... Q 105 .. Q 106 . Q 107 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADOSTIK.m
r613 r623 1 RADOSTIK ;HISC/GJC-Routine to print dosage tickets ;8/1/97 14:07 2 ;;5.0;Radiology/Nuclear Medicine;**65**;Mar 16, 1998;Build 8 3 ; 4 ;Supported IA #2056 reference to GET1^DIQ 5 ;Supported IA #10103 reference to NOW^XLFDT and FMTE^XLFDT 6 ;Supported IA #10104 reference to CJ^XLFSTR and REPEAT^XLFSTR 7 ;Supported IA #2053 reference to FILE^DIE 8 ; 9 EN1(RADFN,RADTI,RACNI) ; the usual suspects 10 N I,RA1,RADTIK,RARDIO,RAY2,RAY3 11 S RAY2=$G(^RADPT(RADFN,"DT",RADTI,0)),RA1=0 12 S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),RARDIO=+$P(RAY3,"^",28) 13 S RADTIK=+$P($G(^RA(79.1,+$P(RAY2,"^",4),0)),"^",23) 14 Q:'RADTIK ; no dosage ticket printer defined for this imaging location 15 Q:'RARDIO ; no Rpharms associated with this exam 16 Q:+$P(RAY3,"^",29) ; quit if dosage ticket has already been printed 17 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE 18 S ZTDESC="Rad/Nuc Med Print dosage ticket or tickets for an Exam" 19 S ZTDTH=$H,ZTIO=$$GET1^DIQ(3.5,RADTIK_",",.01),ZTRTN="PRINT^RADOSTIK" 20 F I="RADFN","RARDIO","RAY2","RAY3" S ZTSAVE(I)="" 21 D ^%ZTLOAD D SETFLG^RADOSTIK(RADFN,RADTI,RACNI) 22 Q 23 EN2 ; Print duplicate dosage ticket 24 D:'$D(RACCESS(DUZ)) SET^RAPSET1 D ^RACNLU Q:X["^" 25 N I,RADOSTIK,RARDIO,RAY2,RAY3 26 S RAY2=$G(^RADPT(RADFN,"DT",RADTI,0)),RADOSTIK="" 27 S RAY3=Y(0),RARDIO=+$P(RAY3,"^",28) ; RAY3 is the zero node of the exam 28 ; RADFN,RADTI & RACNI are all defined! 29 I 'RARDIO D D KILL Q 30 . W !!?3,"Dosage ticket data does not exist!",$C(7) 31 . Q 32 N ZTDESC,ZTRTN,ZTSAVE S ZTRTN="PRINT^RADOSTIK" 33 F I="RADFN","RADOSTIK","RARDIO","RAY2","RAY3" S ZTSAVE(I)="" 34 S ZTDESC="Rad/Nuc Med Print Duplicate Dosage Ticket option." 35 D ZIS^RAUTL I RAPOP D KILL Q 36 D PRINT,KILL 37 Q 38 PRINT ; Print out dosage ticket(s). If more than one rpharm, print one 39 ; dosage ticket per page. 40 U IO S:$D(ZTQUEUED) ZTREQ="@" 41 W:$D(RADOSTIK)&($E(IOST,1,2)="C-") @IOF 42 N RA1,RA702,RA719,RACNST,RANOTE,RAPRTDT,RATTLE,RAX,RAXIT 43 S (RA1,RAXIT)=0 44 S RATTLE="Radiopharmaceutical Dose Computation and Measurement Record" 45 S RAPRTDT=$$NOW^XLFDT() 46 S:$L($P(RAPRTDT,".",2))>4 RAPRTDT=$P(RAPRTDT,".")_"."_$E($P(RAPRTDT,".",2),1,4) ; don't display seconds in printed date 47 S RAPRTDT="Printed: "_$$FMTE^XLFDT(RAPRTDT,"1P"),RACNST=$L(RAPRTDT) 48 F S RA1=$O(^RADPTN(RARDIO,"NUC",RA1)) Q:RA1'>0 D Q:RAXIT 49 . K RANOTE W !,$$CJ^XLFSTR(RATTLE,IOM),!,$$CJ^XLFSTR(RAPRTDT,IOM) 50 . I $D(ZTQUEUED),($D(RADOSTIK)) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 51 . Q:RAXIT 52 . W !!,"Case : ",$P(RAY3,"^")_"@"_$$FMTE^XLFDT($P(RAY2,"^"),"1P") 53 . W !!,"Patient : ",$$GET1^DIQ(2,RADFN_",",.01) 54 . W !,"Patient ID : ",$$SSN^RAUTL() 55 . W !,"Study : ",$E($$GET1^DIQ(71,+$P(RAY3,"^",2)_",",.01),1,50) 56 . S RA702=$G(^RADPTN(RARDIO,"NUC",RA1,0)) 57 . W !!,"Radiopharmaceutical : " 58 . S RAX=$$EN1^RAPSAPI(+$P(RA702,"^"),.01) S:RAX="" RANOTE="" 59 . W $S(RAX]"":RAX,1:"*****") K RAX 60 . W !,"Form : ",$$GET1^DIQ(70.21,RA1_","_RARDIO_",",15) 61 . D GETS^DIQ(71.9,+$P(RA702,"^",13)_",","*","","RA719") 62 . W !,"Lot No. : " S RAX=$G(RA719(71.9,+$P(RA702,"^",13)_",",.01)) 63 . S:RAX="" RANOTE="" W $S(RAX]"":RAX,1:"*****") K RAX 64 . W !,"Kit No. : ",$G(RA719(71.9,+$P(RA702,"^",13)_",",4)) 65 . W !,"Lot Expiration Date : " S RAX=$G(RA719(71.9,+$P(RA702,"^",13)_",",3)) 66 . S:RAX="" RANOTE="" W $S(RAX]"":RAX,1:"*****") K RAX 67 . W !!,"Date/Time of Measurement: " S RAX=$$GET1^DIQ(70.21,RA1_","_RARDIO_",",5) 68 . S:RAX="" RANOTE="" W $S(RAX]"":RAX,1:"*****") K RAX 69 . W !,"Dose Prescribed : " 70 . I $P(RA702,"^",2)]"" W $P(RA702,"^",2)_" mCi" 71 . I $P(RA702,"^",2)']"",(+$O(^RAMIS(71,+$P(RAY3,"^",2),"NUC","B",$P(RA702,"^"),0))) D 72 .. N RA7108 S RA7108=+$O(^RAMIS(71,+$P(RAY3,"^",2),"NUC","B",$P(RA702,"^"),0)) 73 .. S RA7108(0)=$G(^RAMIS(71,+$P(RAY3,"^",2),"NUC",RA7108,0)) 74 .. W:$P(RA7108(0),"^",6)]"" "Low: "_$P(RA7108(0),"^",6)_" mCi " 75 .. W:$P(RA7108(0),"^",5)]"" "High: "_$P(RA7108(0),"^",5)_" mCi" 76 .. Q 77 . W !,"Activity Drawn : ",$S($P(RA702,"^",4)]"":$P(RA702,"^",4)_" mCi",1:"*****") 78 . S:$P(RA702,"^",4)="" RANOTE="" 79 . W !,"Dose Administered : ",$S($P(RA702,"^",7)]"":$P(RA702,"^",7)_" mCi",1:"") 80 . W !,"Time of Administration : ",$$GET1^DIQ(70.21,RA1_","_RARDIO_",",8) 81 . W !!,"Signature of Person Measuring Dose: " 82 . W $$REPEAT^XLFSTR("_",((IOM-3)-$X)) K RA719 83 . W:$D(RANOTE) !!,"NOTE: '*****' indicates that required pieces of information are missing." 84 . S:'$D(ZTQUEUED)&($D(RADOSTIK))&(+$O(^RADPTN(RARDIO,"NUC",RA1))) RAXIT=$$EOS^RAUTL5() Q:RAXIT 85 . W:+$O(^RADPTN(RARDIO,"NUC",RA1)) @IOF ; dosage ticket per page 86 . Q 87 D CLOSE^RAUTL,KILL^RADOSTIK 88 Q 89 KILL ; Kill variables 90 K %,%W,%Y,%Y1,C,RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RANME,RAPOP,RAPRC 91 K RARPT,RASSN,RAST,X,Y 92 K DIC,DIPGM,DISYS,DUOUT,I,RAHEAD,RAI,RAMES,RAEND,RAFL,RAFST,RAHEAD,RAIX 93 K ^TMP($J,"RAEX") 94 Q 95 SETFLG(RADFN,RADTI,RACNI) ; Set the 'Dosage Ticket Printed?' 96 ; ^DD(70.03,29,0) field to 'Yes'. 97 ; Input: RADFN==> Patient ien RADTI==> Inverse Date/Time of Exam 98 ; RACNI==> ien of the examination 99 N RAFDA S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",29)=1 100 D FILE^DIE("","RAFDA") 101 Q 1 RADOSTIK ;HISC/GJC-Routine to print dosage tickets ;8/1/97 14:07 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 3 ; 4 EN1(RADFN,RADTI,RACNI) ; the usual suspects 5 N I,RA1,RADTIK,RARDIO,RAY2,RAY3 6 S RAY2=$G(^RADPT(RADFN,"DT",RADTI,0)),RA1=0 7 S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),RARDIO=+$P(RAY3,"^",28) 8 S RADTIK=+$P($G(^RA(79.1,+$P(RAY2,"^",4),0)),"^",23) 9 Q:'RADTIK ; no dosage ticket printer defined for this imaging location 10 Q:'RARDIO ; no Rpharms associated with this exam 11 Q:+$P(RAY3,"^",29) ; quit if dosage ticket has already been printed 12 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE 13 S ZTDESC="Rad/Nuc Med Print dosage ticket or tickets for an Exam" 14 S ZTDTH=$H,ZTIO=$$GET1^DIQ(3.5,RADTIK_",",.01),ZTRTN="PRINT^RADOSTIK" 15 F I="RADFN","RARDIO","RAY2","RAY3" S ZTSAVE(I)="" 16 D ^%ZTLOAD D SETFLG^RADOSTIK(RADFN,RADTI,RACNI) 17 Q 18 EN2 ; Print duplicate dosage ticket 19 D:'$D(RACCESS(DUZ)) SET^RAPSET1 D ^RACNLU Q:X["^" 20 N I,RADOSTIK,RARDIO,RAY2,RAY3 21 S RAY2=$G(^RADPT(RADFN,"DT",RADTI,0)),RADOSTIK="" 22 S RAY3=Y(0),RARDIO=+$P(RAY3,"^",28) ; RAY3 is the zero node of the exam 23 ; RADFN,RADTI & RACNI are all defined! 24 I 'RARDIO D D KILL Q 25 . W !!?3,"Dosage ticket data does not exist!",$C(7) 26 . Q 27 N ZTDESC,ZTRTN,ZTSAVE S ZTRTN="PRINT^RADOSTIK" 28 F I="RADFN","RADOSTIK","RARDIO","RAY2","RAY3" S ZTSAVE(I)="" 29 S ZTDESC="Rad/Nuc Med Print Duplicate Dosage Ticket option." 30 D ZIS^RAUTL I RAPOP D KILL Q 31 D PRINT,KILL 32 Q 33 PRINT ; Print out dosage ticket(s). If more than one rpharm, print one 34 ; dosage ticket per page. 35 U IO S:$D(ZTQUEUED) ZTREQ="@" 36 W:$D(RADOSTIK)&($E(IOST,1,2)="C-") @IOF 37 N RA1,RA702,RA719,RACNST,RANOTE,RAPRTDT,RATTLE,RAX,RAXIT 38 S (RA1,RAXIT)=0 39 S RATTLE="Radiopharmaceutical Dose Computation and Measurement Record" 40 S RAPRTDT=$$NOW^XLFDT() 41 S:$L($P(RAPRTDT,".",2))>4 RAPRTDT=$P(RAPRTDT,".")_"."_$E($P(RAPRTDT,".",2),1,4) ; don't display seconds in printed date 42 S RAPRTDT="Printed: "_$$FMTE^XLFDT(RAPRTDT,"1P"),RACNST=$L(RAPRTDT) 43 F S RA1=$O(^RADPTN(RARDIO,"NUC",RA1)) Q:RA1'>0 D Q:RAXIT 44 . K RANOTE W !,$$CJ^XLFSTR(RATTLE,IOM),!,$$CJ^XLFSTR(RAPRTDT,IOM) 45 . I $D(ZTQUEUED),($D(RADOSTIK)) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 46 . Q:RAXIT 47 . W !!,"Case : ",$P(RAY3,"^")_"@"_$$FMTE^XLFDT($P(RAY2,"^"),"1P") 48 . W !!,"Patient : ",$$GET1^DIQ(2,RADFN_",",.01) 49 . W !,"Patient ID : ",$$SSN^RAUTL() 50 . W !,"Study : ",$E($$GET1^DIQ(71,+$P(RAY3,"^",2)_",",.01),1,50) 51 . S RA702=$G(^RADPTN(RARDIO,"NUC",RA1,0)) 52 . W !!,"Radiopharmaceutical : " 53 . S RAX=$$GET1^DIQ(50,+$P(RA702,"^")_",",.01) S:RAX="" RANOTE="" 54 . W $S(RAX]"":RAX,1:"*****") K RAX 55 . W !,"Form : ",$$GET1^DIQ(70.21,RA1_","_RARDIO_",",15) 56 . D GETS^DIQ(71.9,+$P(RA702,"^",13)_",","*","","RA719") 57 . W !,"Lot No. : " S RAX=$G(RA719(71.9,+$P(RA702,"^",13)_",",.01)) 58 . S:RAX="" RANOTE="" W $S(RAX]"":RAX,1:"*****") K RAX 59 . W !,"Kit No. : ",$G(RA719(71.9,+$P(RA702,"^",13)_",",4)) 60 . W !,"Lot Expiration Date : " S RAX=$G(RA719(71.9,+$P(RA702,"^",13)_",",3)) 61 . S:RAX="" RANOTE="" W $S(RAX]"":RAX,1:"*****") K RAX 62 . W !!,"Date/Time of Measurement: " S RAX=$$GET1^DIQ(70.21,RA1_","_RARDIO_",",5) 63 . S:RAX="" RANOTE="" W $S(RAX]"":RAX,1:"*****") K RAX 64 . W !,"Dose Prescribed : " 65 . I $P(RA702,"^",2)]"" W $P(RA702,"^",2)_" mCi" 66 . I $P(RA702,"^",2)']"",(+$O(^RAMIS(71,+$P(RAY3,"^",2),"NUC","B",$P(RA702,"^"),0))) D 67 .. N RA7108 S RA7108=+$O(^RAMIS(71,+$P(RAY3,"^",2),"NUC","B",$P(RA702,"^"),0)) 68 .. S RA7108(0)=$G(^RAMIS(71,+$P(RAY3,"^",2),"NUC",RA7108,0)) 69 .. W:$P(RA7108(0),"^",6)]"" "Low: "_$P(RA7108(0),"^",6)_" mCi " 70 .. W:$P(RA7108(0),"^",5)]"" "High: "_$P(RA7108(0),"^",5)_" mCi" 71 .. Q 72 . W !,"Activity Drawn : ",$S($P(RA702,"^",4)]"":$P(RA702,"^",4)_" mCi",1:"*****") 73 . S:$P(RA702,"^",4)="" RANOTE="" 74 . W !,"Dose Administered : ",$S($P(RA702,"^",7)]"":$P(RA702,"^",7)_" mCi",1:"") 75 . W !,"Time of Administration : ",$$GET1^DIQ(70.21,RA1_","_RARDIO_",",8) 76 . W !!,"Signature of Person Measuring Dose: " 77 . W $$REPEAT^XLFSTR("_",((IOM-3)-$X)) K RA719 78 . W:$D(RANOTE) !!,"NOTE: '*****' indicates that required pieces of information are missing." 79 . S:'$D(ZTQUEUED)&($D(RADOSTIK))&(+$O(^RADPTN(RARDIO,"NUC",RA1))) RAXIT=$$EOS^RAUTL5() Q:RAXIT 80 . W:+$O(^RADPTN(RARDIO,"NUC",RA1)) @IOF ; dosage ticket per page 81 . Q 82 D CLOSE^RAUTL,KILL^RADOSTIK 83 Q 84 KILL ; Kill variables 85 K %,%W,%Y,%Y1,C,RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RANME,RAPOP,RAPRC 86 K RARPT,RASSN,RAST,X,Y 87 K DIC,DIPGM,DISYS,DUOUT,I,RAHEAD,RAI,RAMES,RAEND,RAFL,RAFST,RAHEAD,RAIX 88 K ^TMP($J,"RAEX") 89 Q 90 SETFLG(RADFN,RADTI,RACNI) ; Set the 'Dosage Ticket Printed?' 91 ; ^DD(70.03,29,0) field to 'Yes'. 92 ; Input: RADFN==> Patient ien RADTI==> Inverse Date/Time of Exam 93 ; RACNI==> ien of the examination 94 N RAFDA S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",29)=1 95 D FILE^DIE("","RAFDA") 96 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO.m
r613 r623 1 RAHLO ;HIRMFO/GJC-Process data set from the bridge program ;11/18/97 12:13 2 ;;5.0;Radiology/Nuclear Medicine;**4,8,27,55,66,84**;Mar 16, 1998;Build 13 3 ; 09/07/2005 Remedy call 108405 - KAM Allow Radiology to accept dx codes from Talk Technology 4 ; 5 ;Integration Agreements 6 ;---------------------- 7 ;DT^DILF(2054); LOCK^DILF(2054); DEM^VADPT(10061); $$DT^XLFDT(10103) 8 ; 9 EN1 ; Check the validity of the following data globals: 10 ; Example: '^TMP("RARPT-REC",$J,RASUB,' where RASUB is a 11 ; record in file 772. 12 ;**************** Validates (if data present): ************************ 13 ; ^TMP("RARPT-REC",$J,RASUB,"RACNI")=case ien 14 ; ^TMP("RARPT-REC",$J,RASUB,"RADATE")=date reported/entered/verified 15 ; ^TMP("RARPT-REC",$J,RASUB,"RADFN")=patient ien 16 ; ^TMP("RARPT-REC",$J,RASUB,"RADTI")=inverted exam date/time 17 ; ^TMP("RARPT-REC",$J,RASUB,"RADX",#)=Dx codes (could be more than 1) 18 ; ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=Verifier's E-Sig (if present) 19 ; ^TMP("RARPT-REC",$J,RASUB,"RAHIST")=Additional Clinical History 20 ; ^TMP("RARPT-REC",$J,RASUB,"RAIMP",#)=Impression Text 21 ; ^TMP("RARPT-REC",$J,RASUB,"RALONGCN")=Long Case Number 22 ; ^TMP("RARPT-REC",$J,RASUB,"RASSN")=Patient SSN 23 ; ^TMP("RARPT-REC",$J,RASUB,"RASTAT")=A, F or R (amend, final or prelim) 24 ; ^TMP("RARPT-REC",$J,RASUB,"RATXT",#)=Report Text 25 ; ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=vendor 26 ; ^TMP("RARPT-REC",$J,RASUB,"RAVERF")=Verifier ien 27 ; ^TMP("RARPT-REC",$J,RASUB,"RATRANSCRIPT")=transcriptionist (optional) 28 ; ^TMP("RARPT-REC",$J,RASUB,"RASTAFF")=Primary staff 29 ; ^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")=Primary resident 30 ; ^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE")=Who changed status to Verify 31 ;********************************************************************** 32 K RAERR S RAQUIET=1 33 ; Check if the minimum data set exists. 34 I '$D(^TMP("RARPT-REC",$J,RASUB,"RACNI")) S RAERR="Missing Case Number" Q 35 I '$D(^TMP("RARPT-REC",$J,RASUB,"RADFN")) S RAERR="Internal Patient ID Missing" Q 36 I '$D(^TMP("RARPT-REC",$J,RASUB,"RADTI")) S RAERR="Missing Exam Date" Q 37 I '$D(^TMP("RARPT-REC",$J,RASUB,"RALONGCN")) S RAERR="Missing Exam Date and/or Case Number" Q 38 I '$D(^TMP("RARPT-REC",$J,RASUB,"RASSN")) S RAERR="Missing Patient ID" Q 39 D CHECK ; check the validity of our data. 40 XIT ; Kill and quit 41 K A,B,DFN,K,RACNI,RADX,RADENDUM,RADFN,RADTI,RADUZ,RAIMGTY,RALONGCN,RAMDIV,RAMDV,RAMLC,RAQUIET,RADPIECE,RARPT,RARPTSTS,RASSN,RAVLDT,X,Y,RATRANSC 42 Q 43 CHECK ; Check if our data is valid. 44 S RACNI=$G(^TMP("RARPT-REC",$J,RASUB,"RACNI")) 45 S RADATE=$G(^TMP("RARPT-REC",$J,RASUB,"RADATE")) 46 S RADFN=$G(^TMP("RARPT-REC",$J,RASUB,"RADFN")) 47 S RADTI=$G(^TMP("RARPT-REC",$J,RASUB,"RADTI")) 48 S RALONGCN=$G(^TMP("RARPT-REC",$J,RASUB,"RALONGCN")) 49 S RASSN=$G(^TMP("RARPT-REC",$J,RASUB,"RASSN")) 50 S (RAVERF,RADUZ)=$G(^TMP("RARPT-REC",$J,RASUB,"RAVERF")) 51 S RATRANSC=$G(^TMP("RARPT-REC",$J,RASUB,"RATRANSCRIPT")) 52 S RASTAT=$G(^TMP("RARPT-REC",$J,RASUB,"RASTAT")) I RASTAT="A" S RADENDUM="" 53 I $D(^TMP("RARPT-REC",$J,RASUB,"RAESIG")) S RAESIG=$G(^("RAESIG")) 54 I $D(^TMP("RARPT-REC",$J,RASUB,"RAIMP")) D IMPTXT^RAHLO2 55 I RADATE']"" S RAERR="Missing report date" Q 56 I RADFN']"" S RAERR="Missing Internal Patient ID" Q 57 I RACNI']"" S RAERR="Missing Case Number" Q 58 I RADTI']"" S RAERR="Missing Exam Date" Q 59 D DT^DILF("ET",RADATE,.RAVLDT) 60 S:RAVLDT=-1 RAERR="Invalid report date" Q:$D(RAERR) 61 K VA,VADM,VAERR S DFN=RADFN D DEM^VADPT 62 I VADM(1)']"" S RAERR="Unknown Internal patient identifier" K VA,VADM,VAERR Q 63 I RASSN'=$P(VADM(2),"^") S RAERR="Internal patient identifier and SSN don't match" K VA,VADM,VAERR Q 64 I '$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))!(RALONGCN']"") D Q 65 . S RAERR="Invalid Exam Date and/or Case Number" 66 . Q 67 D EDTCHK^RAHLQ ; is user allowed to edit report for a cancelled case? 68 I RARPT=1 S RAERR="Report for CANCELLED case not permitted." Q 69 I RARPT=2 S RAERR="Please use VISTA to edit CANCELLED printset cases." Q 70 S RARPT=+$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17) 71 I '$D(^RARPT(RARPT,0)),($D(RADENDUM)#2) S RAERR="Can't add addendum, no report" Q 72 I $D(^RARPT(RARPT,0)),($P(^(0),"^",5)'="V"),($D(RADENDUM)#2) S RAERR="Can't add addendum to an unverified report" Q 73 I $D(^RARPT(RARPT,0)),$P(^(0),"^",5)="V",('$D(RADENDUM)#2) S RAERR="Report already on file" Q 74 I ($D(RADENDUM)#2),'$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)),'$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0)) S RAERR="Missing addendum report/impression text" Q 75 I $D(^RADPT(RADFN,"DT",RADTI,0)) S RAMDIV=^(0),RAMLC=+$P(RAMDIV,"^",4),RAMDIV=+$P(RAMDIV,"^",3),RAMDV=$S($D(^RA(79,RAMDIV,.1)):^(.1),1:""),RAMDV=$S(RAMDV="":RAMDV,1:$TR(RAMDV,"YyNn",1100)) 76 I '($D(RADENDUM)#2) I $P(RAMDV,"^",16),('$D(^TMP("RARPT-REC",$J,RASUB,"RAIMP"))) S RAERR="Missing Impression Text" Q ; impression req'd for this division 77 I ($D(RADENDUM)#2),($D(^RARPT(RARPT,0))#2),($P(RAMDV,"^",16)),('$O(^RARPT(RARPT,"I",0))),('$D(^TMP("RARPT-REC",$J,RASUB,"RAIMP"))) S RAERR="Impression Text missing for current record." Q ; impression req'd for this division 78 I $D(RADENDUM)#2 D CKDUPA^RAHLO4 I RADUPA S RAERR="Duplicate Addendum" Q 79 ; check resident and staff 80 N X1,X2,X3 S X2=0,X3="" 81 I '$G(RATELE),+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT"))!(+$G(^("RASTAFF"))) D Q:$G(RAERR)]"" 82 . S X1=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")) 83 . I X1 D 84 .. I '$D(^VA(200,"ARC","R",X1)),'$D(^VA(200,"ARC","S",X1)) S X2=1 85 .. I $P($G(^VA(200,X1,"RA")),"^",3),$P(^("RA"),"^",3)'>$$DT^XLFDT S X2=X2+2 86 .. I X2=1 S X3=$E($P($G(^VA(200,X1,0)),"^"),1,20)_" is not class'd as Resident or Staff" 87 .. I X2=2 S X3=$P($G(^VA(200,X1,0)),"^")_"'s INACTIVE DATE is past" 88 .. I X2=3 S X3=$P($G(^VA(200,X1,0)),"^")_" is not class'd as resident and past INACTIVE DATE" 89 .. I X3]"" S RAERR=X3 90 . S X2=0,X3="" S X1=+$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF")) 91 . I X1 D 92 .. I '$D(^VA(200,"ARC","S",X1)) S X2=1 93 .. I $P($G(^VA(200,X1,"RA")),"^",3),$P(^("RA"),"^",3)'>$$DT^XLFDT S X2=X2+2 94 .. I X2=1 S X3=$E($P($G(^VA(200,X1,0)),"^"),1,20)_" is not class'd as staff" 95 .. I X2=2 S X3=$P($G(^VA(200,X1,0)),"^")_"'s INACTIVE DATE is past" 96 .. I X2=3 S X3=$P($G(^VA(200,X1,0)),"^")_" is not class'd as staff and past INACTIVE DATE" 97 .. I X3]"" S RAERR=$S($G(RAERR)]"":RAERR_", ",1:"")_X3 98 . Q 99 ; raesig is in alphanumeric format, so shouldn't use $g of it here 100 I ($G(RAESIG)]"")!($G(RAVERF)) D:'$G(RATELE) VERCHK^RAHLO3 ; check if provider can verify report 101 ; if verifier fails checks, 102 ; quit only if vendor is non-kurzweil, 103 ; if vendor is kurzweil, continue on by deleting raerr, raverf 104 I $D(RAERR) Q:$G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL" K RAERR,RAVERF 105 S RAIMGTY=$$IMGTY^RAUTL12("l",RAMLC) I '$L(RAIMGTY) S RAERR="No Imaging Type for Location where exam was performed" Q 106 K RASECDX ;clear secondary dx array because RAHLO2 may not be called 107 ; 09/07/2005 108405 KAM- Removed ('$D(RADENDUM)#2) from next line 108 I $G(RATELE),'$D(RADENDUM),'$D(^TMP("RARPT-REC",$J,RASUB,"RADX")) D ;Patch 84 109 .I RASTAT="R" S:$D(RATELEDR) ^TMP("RARPT-REC",$J,RASUB,"RADX",1)=RATELEDR Q 110 .S:$D(RATELEDF) ^TMP("RARPT-REC",$J,RASUB,"RADX",1)=RATELEDF 111 D:$D(^TMP("RARPT-REC",$J,RASUB,"RADX")) DIAG^RAHLO2 Q:$D(RAERR) ; DX code check took out - &('$D(RADENDUM)#2) 112 ; edit sec Dx codes if they exist for non-addendums 113 ; 09/07/2005 108405 KAM - Removed ('$D(RADENDUM)#2)from next line 114 I $D(RASECDX) D SECDX^RAHLO2 Q:$D(RAERR) 115 S B=0 F A="I","R" D Q:$D(RAERR) 116 . Q:A="R"&('$D(^TMP("RARPT-REC",$J,RASUB,"RATXT"))) ; no rpt text 117 . Q:A="I"&('$D(^TMP("RARPT-REC",$J,RASUB,"RAIMP"))) ; no imp text 118 . S B=$$TEXT^RAHLO3(A) 119 . S:'B RAERR=$$ERR^RAHLO2(A) 120 . Q 121 I $G(RATELE),$G(RARPT) D Q:$D(RAERR) ;PATCH 84 122 .I $D(^RARPT(RARPT,0)) D LOCK^DILF($NA(^RARPT(RARPT))) E S RAERR="Report: "_$P($G(^RARPT(RARPT,0)),"^")_" Locked on VISTA site" Q 123 .L -^RARPT(RARPT) 124 I $G(RATELE),$L($G(RATELEPI)),RATELEPI'?10N S RAERR="Incorrect Teleradiologist's NPI: "_RATELEPI Q 125 D RPTSTAT^RAHLO3 ; determine the status of the report 126 D FILE^RAHLO1:'$D(RAERR) 127 Q 1 RAHLO ;HIRMFO/GJC-Process data set from the bridge program ;11/18/97 12:13 2 ;;5.0;Radiology/Nuclear Medicine;**4,8,27,55,66**;Mar 16, 1998 3 ; 09/07/2005 Remedy call 108405 - KAM Allow Radiology to accept dx codes from Talk Technology 4 EN1 ; Check the validity of the following data globals: 5 ; Example: '^TMP("RARPT-REC",$J,RASUB,' where RASUB is a 6 ; record in file 772. 7 ;**************** Validates (if data present): ************************ 8 ; ^TMP("RARPT-REC",$J,RASUB,"RACNI")=case ien 9 ; ^TMP("RARPT-REC",$J,RASUB,"RADATE")=date reported/entered/verified 10 ; ^TMP("RARPT-REC",$J,RASUB,"RADFN")=patient ien 11 ; ^TMP("RARPT-REC",$J,RASUB,"RADTI")=inverted exam date/time 12 ; ^TMP("RARPT-REC",$J,RASUB,"RADX",#)=Dx codes (could be more than 1) 13 ; ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=Verifier's E-Sig (if present) 14 ; ^TMP("RARPT-REC",$J,RASUB,"RAHIST")=Additional Clinical History 15 ; ^TMP("RARPT-REC",$J,RASUB,"RAIMP",#)=Impression Text 16 ; ^TMP("RARPT-REC",$J,RASUB,"RALONGCN")=Long Case Number 17 ; ^TMP("RARPT-REC",$J,RASUB,"RASSN")=Patient SSN 18 ; ^TMP("RARPT-REC",$J,RASUB,"RASTAT")=A, F or R (amend, final or prelim) 19 ; ^TMP("RARPT-REC",$J,RASUB,"RATXT",#)=Report Text 20 ; ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=vendor 21 ; ^TMP("RARPT-REC",$J,RASUB,"RAVERF")=Verifier ien 22 ; ^TMP("RARPT-REC",$J,RASUB,"RATRANSCRIPT")=transcriptionist (optional) 23 ; ^TMP("RARPT-REC",$J,RASUB,"RASTAFF")=Primary staff 24 ; ^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")=Primary resident 25 ; ^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE")=Who changed status to Verify 26 ;********************************************************************** 27 K RAERR S RAQUIET=1 28 ; Check if the minimum data set exists. 29 I '$D(^TMP("RARPT-REC",$J,RASUB,"RACNI")) S RAERR="Missing Case Number" Q 30 I '$D(^TMP("RARPT-REC",$J,RASUB,"RADFN")) S RAERR="Internal Patient ID Missing" Q 31 I '$D(^TMP("RARPT-REC",$J,RASUB,"RADTI")) S RAERR="Missing Exam Date" Q 32 I '$D(^TMP("RARPT-REC",$J,RASUB,"RALONGCN")) S RAERR="Missing Exam Date and/or Case Number" Q 33 I '$D(^TMP("RARPT-REC",$J,RASUB,"RASSN")) S RAERR="Missing Patient ID" Q 34 D CHECK ; check the validity of our data. 35 XIT ; Kill and quit 36 K A,B,DFN,K,RACNI,RADX,RADENDUM,RADFN,RADTI,RADUZ,RAIMGTY,RALONGCN,RAMDIV,RAMDV,RAMLC,RAQUIET,RADPIECE,RARPT,RARPTSTS,RASSN,RAVLDT,X,Y,RATRANSC 37 Q 38 CHECK ; Check if our data is valid. 39 S RACNI=$G(^TMP("RARPT-REC",$J,RASUB,"RACNI")) 40 S RADATE=$G(^TMP("RARPT-REC",$J,RASUB,"RADATE")) 41 S RADFN=$G(^TMP("RARPT-REC",$J,RASUB,"RADFN")) 42 S RADTI=$G(^TMP("RARPT-REC",$J,RASUB,"RADTI")) 43 S RALONGCN=$G(^TMP("RARPT-REC",$J,RASUB,"RALONGCN")) 44 S RASSN=$G(^TMP("RARPT-REC",$J,RASUB,"RASSN")) 45 S (RAVERF,RADUZ)=$G(^TMP("RARPT-REC",$J,RASUB,"RAVERF")) 46 S RATRANSC=$G(^TMP("RARPT-REC",$J,RASUB,"RATRANSCRIPT")) 47 S RASTAT=$G(^TMP("RARPT-REC",$J,RASUB,"RASTAT")) I RASTAT="A" S RADENDUM="" 48 I $D(^TMP("RARPT-REC",$J,RASUB,"RAESIG")) S RAESIG=$G(^("RAESIG")) 49 I $D(^TMP("RARPT-REC",$J,RASUB,"RAIMP")) D IMPTXT^RAHLO2 50 I RADATE']"" S RAERR="Missing report date" Q 51 I RADFN']"" S RAERR="Missing Internal Patient ID" Q 52 I RACNI']"" S RAERR="Missing Case Number" Q 53 I RADTI']"" S RAERR="Missing Exam Date" Q 54 D DT^DILF("ET",RADATE,.RAVLDT) 55 S:RAVLDT=-1 RAERR="Invalid report date" Q:$D(RAERR) 56 K VA,VADM,VAERR S DFN=RADFN D DEM^VADPT I VADM(1)']""!(RASSN'=$P(VADM(2),"^")) S RAERR="Internal patient identifier and SSN don't match" K VA,VADM,VAERR Q 57 I '$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))!(RALONGCN']"") D Q 58 . S RAERR="Invalid Exam Date and/or Case Number" 59 . Q 60 D EDTCHK^RAHLQ ; is user allowed to edit report for a cancelled case? 61 I RARPT=1 S RAERR="Report for CANCELLED case not permitted." Q 62 I RARPT=2 S RAERR="Please use VISTA to edit CANCELLED printset cases." Q 63 S RARPT=+$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17) 64 I '$D(^RARPT(RARPT,0)),($D(RADENDUM)#2) S RAERR="Can't add addendum, no report" Q 65 I $D(^RARPT(RARPT,0)),($P(^(0),"^",5)'="V"),($D(RADENDUM)#2) S RAERR="Can't add addendum to an unverified report" Q 66 I $D(^RARPT(RARPT,0)),$P(^(0),"^",5)="V",('$D(RADENDUM)#2) S RAERR="Report already on file" Q 67 I ($D(RADENDUM)#2),'$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)),'$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0)) S RAERR="Missing addendum report/impression text" Q 68 I $D(^RADPT(RADFN,"DT",RADTI,0)) S RAMDIV=^(0),RAMLC=+$P(RAMDIV,"^",4),RAMDIV=+$P(RAMDIV,"^",3),RAMDV=$S($D(^RA(79,RAMDIV,.1)):^(.1),1:""),RAMDV=$S(RAMDV="":RAMDV,1:$TR(RAMDV,"YyNn",1100)) 69 I '($D(RADENDUM)#2) I $P(RAMDV,"^",16),('$D(^TMP("RARPT-REC",$J,RASUB,"RAIMP"))) S RAERR="Missing Impression Text" Q ; impression req'd for this division 70 I ($D(RADENDUM)#2),($D(^RARPT(RARPT,0))#2),($P(RAMDV,"^",16)),('$O(^RARPT(RARPT,"I",0))),('$D(^TMP("RARPT-REC",$J,RASUB,"RAIMP"))) S RAERR="Impression Text missing for current record." Q ; impression req'd for this division 71 I $D(RADENDUM)#2 D CKDUPA^RAHLO4 I RADUPA S RAERR="Duplicate Addendum" Q 72 ; check resident and staff 73 N X1,X2,X3 S X2=0,X3="" 74 I +$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT"))!(+$G(^("RASTAFF"))) D Q:$G(RAERR)]"" 75 . S X1=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")) 76 . I X1 D 77 .. I '$D(^VA(200,"ARC","R",X1)) S X2=1 78 .. I $P($G(^VA(200,X1,"RA")),"^",3),$P(^("RA"),"^",3)'>$$DT^XLFDT S X2=X2+2 79 .. I X2=1 S X3=$E($P($G(^VA(200,X1,0)),"^"),1,20)_" is not class'd as resident" 80 .. I X2=2 S X3=$P($G(^VA(200,X1,0)),"^")_"'s INACTIVE DATE is past" 81 .. I X2=3 S X3=$P($G(^VA(200,X1,0)),"^")_" is not class'd as resident and past INACTIVE DATE" 82 .. I X3]"" S RAERR=X3 83 . S X2=0,X3="" S X1=+$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF")) 84 . I X1 D 85 .. I '$D(^VA(200,"ARC","S",X1)) S X2=1 86 .. I $P($G(^VA(200,X1,"RA")),"^",3),$P(^("RA"),"^",3)'>$$DT^XLFDT S X2=X2+2 87 .. I X2=1 S X3=$E($P($G(^VA(200,X1,0)),"^"),1,20)_" is not class'd as staff" 88 .. I X2=2 S X3=$P($G(^VA(200,X1,0)),"^")_"'s INACTIVE DATE is past" 89 .. I X2=3 S X3=$P($G(^VA(200,X1,0)),"^")_" is not class'd as staff and past INACTIVE DATE" 90 .. I X3]"" S RAERR=$S($G(RAERR)]"":RAERR_", ",1:"")_X3 91 . Q 92 ; raesig is in alphanumeric format, so shouldn't use $g of it here 93 I ($G(RAESIG)]"")!($G(RAVERF)) D VERCHK^RAHLO3 ; check if provider can verify report 94 ; if verifier fails checks, 95 ; quit only if vendor is non-kurzweil, 96 ; if vendor is kurzweil, continue on by deleting raerr, raverf 97 I $D(RAERR) Q:$G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL" K RAERR,RAVERF 98 S RAIMGTY=$$IMGTY^RAUTL12("l",RAMLC) I '$L(RAIMGTY) S RAERR="No Imaging Type for Location where exam was performed" Q 99 K RASECDX ;clear secondary dx array because RAHLO2 may not be called 100 ; 09/07/2005 108405 KAM- Removed ('$D(RADENDUM)#2) from next line 101 D:$D(^TMP("RARPT-REC",$J,RASUB,"RADX")) DIAG^RAHLO2 Q:$D(RAERR) ; DX code check took out - &('$D(RADENDUM)#2) 102 ; edit sec Dx codes if they exist for non-addendums 103 ; 09/07/2005 108405 KAM - Removed ('$D(RADENDUM)#2)from next line 104 I $D(RASECDX) D SECDX^RAHLO2 Q:$D(RAERR) 105 S B=0 F A="I","R" D Q:$D(RAERR) 106 . Q:A="R"&('$D(^TMP("RARPT-REC",$J,RASUB,"RATXT"))) ; no rpt text 107 . Q:A="I"&('$D(^TMP("RARPT-REC",$J,RASUB,"RAIMP"))) ; no imp text 108 . S B=$$TEXT^RAHLO3(A) 109 . S:'B RAERR=$$ERR^RAHLO2(A) 110 . Q 111 D RPTSTAT^RAHLO3 ; determine the status of the report 112 D FILE^RAHLO1:'$D(RAERR) 113 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO1.m
r613 r623 1 RAHLO1 ;HIRMFO/GJC/BNT-File rpt (data from bridge program) ;6/25/04 11:49 2 ;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55,66,87,84**;Mar 16, 1998;Build 13 3 ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Correct UNDEF on null dx code 4 ; 09/07/2005 108405 - KAM/BAY Allow Radiology to accept dx codes from Talk Technology 5 ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx 6 ; 7 ;Integration Agreements 8 ;---------------------- 9 ;DIE(10018); ,FILE^DIE(2053); IX^DIK(10013); CREATE^WVRALINK(4793); $$NOW^XLFDT(10103) 10 ;EN^XUSHSHP(10045) 11 ; 12 FILE ;Create Entry in File 74 and File Data 13 I '$D(ZTQUEUED) N ZTQUEUED S ZTQUEUED="1^dummy to suppress screen displays in UP2^RAUTL1 and elsewhere" 14 I '$D(RAQUIET) N RAQUIET S RAQUIET="1^dummy to suppress screen display in PTR^RARTE2" 15 N RADATIME S RADATIME=$$NOW^XLFDT() I $L($P(RADATIME,".",2))>4 S RADATIME=$P(RADATIME,".",1)_"."_$E($P(RADATIME,".",2),1,4) S RADATIME=+RADATIME 16 S RADPIECE=$S($D(^VA(200,"ARC","S",+$G(RAVERF))):15,$D(^VA(200,"ARC","R",+$G(RAVERF))):12,1:"") 17 N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR 18 D EN2^RAUTL20(.RAMEMARR) ; 04/30/99 always recalculate RAPRTSET 19 ; If the report (stub/real) exists, unverify the existing report... Else create a new report 20 I RARPT,$D(^RARPT(RARPT,0)) S RASAV=RARPT D S RARPT=RASAV K RASAV Q:$D(RAERR) G LOCK1 21 . ; must save off RARPT, RAVERF and other RA* variables because 22 . ; they are being killed off somewhere in the 'Unverify A Report' 23 . ; option. 'Unverify A Report' does lock the the report record in file 74! 24 . N RADFN,RADTI,RACNI,RARPTSTS,RASSN,RADATE,RALONGCN,RAVERF 25 . ; if report isn't a stub report, then consider it being edited 26 . S:'$$STUB^RAEDCN1(RARPT) RAEDIT=1 27 . I $D(RADENDUM)#2,($P(^RARPT(RARPT,0),"^",5)="V") D Q ; edit on current record (for activity log) 28 .. D UNVER^RARTE1(RARPT) 29 .. Q 30 . K ^RARPT(RARPT,"I"),^("R"),^("H") 31 . Q 32 ; New report logic @NEW1 33 NEW1 S I=$P(^RARPT(0),"^",3) 34 ;since this is a new report (not linked to an exam), directly lock the new record *1 lR* 35 LOCK S I=I+1 L +^RARPT(I):1 G:'$T LOCK I ($D(^RARPT(I))#2) L -^RARPT(I) G LOCK 36 S ^RARPT(I,0)=RALONGCN,RARPT=I,^(0)=$P(^RARPT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1) 37 ;if case is member of a print set, then create sub-recs for file #74 38 G:'RAPRTSET LOCK1 39 I '$D(RARPTN) N RARPTN S RARPTN=RALONGCN 40 N RAXIT D PTR^RARTE2 ;create corresponding subrecs in ^RARPT() 41 ; 42 ;if RAERR unlock the report record (locked @LOCK), kill vars, & exit 43 I $D(RAERR) D LOCKR^RAHLTCPU(.RAERR,1) D KVAR Q ; *1 uR* 44 ; 45 LOCK1 I $D(RAESIG) S X=RAESIG,X1=$G(RAVERF),X2=RARPT D EN^XUSHSHP S RAESIG=X 46 K DA,DIE,DQ,DR S DA=RARPT,DIE="^RARPT(" 47 S DR="5////"_RARPTSTS ; rpt status 48 ;Verifier & Verified date will be set if RAVERF exists for new 49 ;reports, edits, and addendums. Date rpt entered and reported date 50 ;will be set for new reports, and not reset for edits and addendums 51 S DR=DR_";6////"_$S($D(RAEDIT):"",1:RADATIME) ; date/time rpt entered 52 S DR=DR_";7////"_$S($G(RAVERF)&(RARPTSTS="V"):RADATIME,1:"") ; v'fied date/time 53 S DR=DR_";8////"_$S($D(RAEDIT):"",1:RADATE) ; reported date 54 S DR=DR_";9////"_$S($G(RAVERF)&(RARPTSTS="V"):RAVERF,1:"") ; v'fying phys 55 S:$L($G(RATELENM)) DR=DR_";9.1////"_RATELENM ;Teleradiologist name - Patch 84 56 S:$L($G(RATELEPI)) DR=DR_";9.2////"_RATELEPI ;Teleradiologist NPI - Patch 84 57 S DR=DR_";11////"_$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") ; transcriptionist 58 I $G(RAVERF),(RARPTSTS="V") S DR=DR_";17////"_$G(^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE")) ;status changed to 'verified' by 59 ; D ^DIE K DA,DR ;BNT- Moved the DIE call down three lines due to a 60 ; problem found at Indy while testing PowerScribe. Site was doing a 61 ; local MUMPS cross reference on one of the nodes that are set below. 62 S $P(^RARPT(RARPT,0),"^",2)=RADFN,$P(^(0),"^",3)=(9999999.9999-RADTI),$P(^(0),"^",4)=$P(RALONGCN,"-",2) ;must set manually due uneditable 63 S $P(^RARPT(RARPT,0),"^",10)=$S($D(RAESIG)&(RARPTSTS="V"):RAESIG,1:"") ; hard set because Elec Sig Code may contain a semi-colon which causes errors in DIE 64 D ^DIE K DA,DR 65 ;don't file a Pri. Dx code for teleradiology reports in the released status (P84v11 bus. rule) 66 S RARELTEL=$S(($D(RATELE)#2)&(RARPTSTS="R"):1,1:"") 67 ; 68 ; 02/08/2008 GJC replaced $G w/($D(RADX)#2) p84 69 ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Changed next line to $G 70 ; 09/07/2005 108405 KAM/BAY Removed('$D(RADENDUM)#2) from next line 71 I ($D(RADX)#2),RARELTEL="" D Q:($D(RAERR))#2 72 .;now a silent FM call w/p84 due to xref being killed when stuffing an identical Dx code 73 .;as the one already on file. 74 .N RAFDA,RAIENS S RAIENS=RACNI_","_RADTI_","_RADFN_"," 75 .S RAFDA(70.03,RAIENS,13)=RADX 76 .;lock the exam record, if the lock fails unlock the report record (locked @LOCK) & quit 77 .D LOCKX^RAHLTCPU(.RAERR) ;*1 lE* 78 .I ($D(RAERR)#2) D LOCKR^RAHLTCPU(.RAERR,1) Q ;*1 uR* 79 .K RAERR D FILE^DIE(,"RAFDA","RAERR") D LOCKX^RAHLTCPU(.RAERR,1) ;*1 uE* 80 .I ($D(RAERR("DIERR"))#2) D Q 81 ..;set the error dialog; unlock the report (locked @LOCK) *1 uR* 82 ..D LOCKR^RAHLTCPU(.RAERR,1) S RAERR=$G(RAERR("DIERR",1,"TEXT",1)) 83 ..Q 84 .S:$P(^RA(78.3,+RADX,0),"^",4)="y" RAAB=1 85 .Q 86 ; 87 K RARELTEL 88 ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx 89 I $D(RASECDX) D 90 . N RAX S RAX=0 91 . F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D 92 .. S:$P(^RA(78.3,+RAX,0),"^",4)="y" RAAB=1 93 ; 94 I '$D(RADENDUM)#2,($G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF"))!$G(^("RARESIDENT"))) D 95 . K DIE,DA S DR="" 96 . S RAPRIMAR=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")) I $D(^VA(200,"ARC","R",RAPRIMAR)) S DR="12////"_RAPRIMAR 97 . S RAPRIMAR=+$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF")) I $D(^VA(200,"ARC","S",RAPRIMAR)) S DR=$S(DR]"":DR_";",1:"")_"15////"_RAPRIMAR 98 . Q:'$G(DR) 99 . S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN 100 . D LOCKX^RAHLTCPU(.RAERR) ;*2 lE* 101 . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," 102 . D ^DIE K DIE,DA,DR 103 . D LOCKX^RAHLTCPU(.RAERR,1) ;*2 uE* 104 . Q 105 ; 106 S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RARPT I $G(RADPIECE),$P(^(0),"^",RADPIECE)="",('$D(RADENDUM)#2) D SETPHYS^RAHLO4 107 ; file impression text if present & not an addendum 108 I '$D(RADENDUM) D 109 . S J=0 I $O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)) S I=0 F J=0:1 S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",I)) Q:I'>0 I $D(^(I)) S ^RARPT(RARPT,"I",(J+1),0)=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",I)) 110 . S:J ^RARPT(RARPT,"I",0)="^^"_J_"^"_J_"^"_RADATE 111 . Q 112 ; file report text if present & not an addendum 113 I '$D(RADENDUM) D 114 . S J=0 I $O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0)) S I=0 F J=0:1 S I=$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",I)) Q:I'>0 I $D(^(I)) S ^RARPT(RARPT,"R",(J+1),0)=$G(^TMP("RARPT-REC",$J,RASUB,"RATXT",I)) 115 . S:J ^RARPT(RARPT,"R",0)="^^"_J_"^"_J_"^"_RADATE 116 . Q 117 ; if addendum, add addendum text to impression or report 118 I $D(RADENDUM),($O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0))!$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0))) D ADENDUM^RAHLO2 ; store new lines at the end of existing text 119 ; 120 ; 121 ; Check for History from Dictation 122 ; If history sent, check if previous history exists. If previous 123 ; history then current history will follow adding 'Addendum:' before 124 ; the text. 125 I $O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0)) D 126 . S RACNT=+$O(^RARPT(RARPT,"H",9999999),-1),RAHSTNDE=RACNT+1 127 . S RANEW=$S(RACNT>0:0,1:1) 128 . S I=0 F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) Q:I'>0 D 129 . . S RACNT=RACNT+1 130 . . S RALN=$G(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) 131 . . S:'RANEW&(I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0))) RALN="Addendum: "_RALN ; if the first line, append 'Addendum:' 132 . . I (RAHSTNDE=RACNT),(RACNT>1) S ^RARPT(RARPT,"H",RACNT,0)=" ",RACNT=RACNT+1 133 . . S ^RARPT(RARPT,"H",RACNT,0)=RALN 134 . . Q 135 . S ^RARPT(RARPT,"H",0)="^^"_RACNT_"^"_RACNT_"^"_RADATE 136 . Q 137 ; 138 ; 139 I $P(^RARPT(RARPT,0),U,5)="V",$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health 140 G:'RAPRTSET UPACT ; the next section is for printsets only 141 ; copy DX (prim & sec), Prim Resid, Prim Staff 142 N RACNISAV,RA7 143 N RA13,RA12,RA15 ;prim dx, prim resid, prim staff, rpt pointer 144 S RACNISAV=RACNI,RA7=0 145 S RA13=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13),RA12=$P(^(0),U,12),RA15=$P(^(0),U,15) 146 F S RA7=$O(RAMEMARR(RA7)) Q:RA7="" I RACNISAV'=RA7 S RACNI=RA7 D UPMEM^RAHLO4 I $D(RASECDX),('$D(RADENDUM)#2) D SECDX^RAHLO2 147 S RACNI=RACNISAV 148 ;Update Activity Log 149 UPACT S DA=RARPT,DIE="^RARPT(",DR="100///""NOW""",DR(2,74.01)="2////"_$S(RARPTSTS="V":"V",$D(RAEDIT):"E",1:"I")_";3////"_$S($G(RAVERF):RAVERF,$G(RATRANSC):RATRANSC,1:"") D ^DIE K DA,DR,DE,DQ,DIE 150 ; use ix^dik to kill before setting xrefs 151 S DA=RARPT,DIK="^RARPT(",RAQUEUED=1 D IX^DIK 152 L -^RARPT(RARPT) ;(1 uR) conventionally unlock the report locked @LOCK 153 ; 154 ;If verified, update report & exam statuses; else, just update exam status 155 ;Note: be careful; exam locks are executed within UP1^RAUTL1! 156 I $D(RAMDV),RAMDV'="" D:RARPTSTS="V" UPSTAT^RAUTL0 D:RARPTSTS'="V" UP1^RAUTL1 157 D:'$D(RAERR)&($G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL") GENACK^RAHLTCPB ; generate 'ACK' message 158 ; 159 PACS ;If there are subscribers to RA RPT xxx events broadcast ORU mesages to those subscribers 160 ;via TASK^RAHLO4. If VOICE DICTATION AUTO-PRINT (#26) field is set to 'Y' print the report to 161 ;the printer defined in the REPORT PRINTER NAME (#10) field via VOICE^RAHLO4. 162 I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D TASK^RAHLO4,VOICE^RAHLO4 163 ; 164 KVAR K RAAB,RAEDIT,RAESIG,RAQUEUED,RARPT,RAHIST 165 Q 166 ; 1 RAHLO1 ;HIRMFO/GJC/BNT-File rpt (data from bridge program) ;6/25/04 11:49 2 ;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55,66**;Mar 16, 1998 3 ; 09/07/2005 108405 - KAM/BAY Allow Radiology to accept dx codes from Talk Technology 4 ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx 5 ; This routine uses the following IA: 6 ; #4793 - ^WVRALINK (private) 7 FILE ;Create Entry in File 74 and File Data 8 I '$D(ZTQUEUED) N ZTQUEUED S ZTQUEUED="1^dummy to suppress screen displays in UP2^RAUTL1 and elsewhere" 9 I '$D(RAQUIET) N RAQUIET S RAQUIET="1^dummy to suppress screen display in PTR^RARTE2" 10 N RADATIME S RADATIME=$$NOW^XLFDT() I $L($P(RADATIME,".",2))>4 S RADATIME=$P(RADATIME,".",1)_"."_$E($P(RADATIME,".",2),1,4) S RADATIME=+RADATIME 11 S RADPIECE=$S($D(^VA(200,"ARC","S",+$G(RAVERF))):15,$D(^VA(200,"ARC","R",+$G(RAVERF))):12,1:"") 12 N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR 13 D EN2^RAUTL20(.RAMEMARR) ; 04/30/99 always recalculate RAPRTSET 14 ; If rpt (either stub or real) exists, skip creating a new file 74 entry 15 I RARPT,$D(^RARPT(RARPT,0)) S RASAV=RARPT D FILETST^RAHLO4 Q:$D(RAERR) D S RARPT=RASAV K RASAV G LOCK1 16 . ; must save off RARPT, RAVERF and other RA* variables because 17 . ; they are being killed off somewhere in the 'Unverify A Report' 18 . ; option. 19 . N RADFN,RADTI,RACNI,RARPTSTS,RASSN,RADATE,RALONGCN,RAVERF 20 . ; if report isn't a stub report, then consider it being edited 21 . S:'$$STUB^RAEDCN1(RARPT) RAEDIT=1 22 . I $D(RADENDUM)#2,($P(^RARPT(RARPT,0),"^",5)="V") D Q ; edit on current record (for activity log) 23 .. D UNVER^RARTE1(RARPT) 24 .. Q 25 . K ^RARPT(RARPT,"I"),^("R"),^("H") 26 . Q 27 I RAPRTSET L +^RADPT(RADFN,"DT",RADTI):0 G:$T NEW1 S RAERR="ANOTHER USER IS CURRENTLY EDITING THIS PRINTSET. TRY LATER." D KVAR Q 28 NEW1 S I=$P(^RARPT(0),"^",3) 29 LOCK S I=I+1 L +^RARPT(I):1 I '$T!($D(^RARPT(I)))!($D(^RARPT("B",I))) L -^RARPT(I) G LOCK 30 S ^RARPT(I,0)=RALONGCN,RARPT=I,^(0)=$P(^RARPT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1) 31 ;if case is member of a print set, then create sub-recs for file #74 32 G:'RAPRTSET LOCK1 33 I '$D(RARPTN) N RARPTN S RARPTN=RALONGCN 34 N RAXIT D PTR^RARTE2 ;create corresponding subrecs in ^RARPT() 35 I $D(RAERR) L -^RADPT(RADFN,"DT",RADTI) D KVAR Q ;unlck & clear vars 36 LOCK1 I $D(RAESIG) S X=RAESIG,X1=$G(RAVERF),X2=RARPT D EN^XUSHSHP S RAESIG=X 37 K DA,DIE,DQ,DR S DA=RARPT,DIE="^RARPT(" 38 S DR="5////"_RARPTSTS ; rpt status 39 ;Verifier & Verified date will be set if RAVERF exists for new 40 ;reports, edits, and addendums. Date rpt entered and reported date 41 ;will be set for new reports, and not reset for edits and addendums 42 S DR=DR_";6////"_$S($D(RAEDIT):"",1:RADATIME) ; date/time rpt entered 43 S DR=DR_";7////"_$S($G(RAVERF)&(RARPTSTS="V"):RADATIME,1:"") ; v'fied date/time 44 S DR=DR_";8////"_$S($D(RAEDIT):"",1:RADATE) ; reported date 45 S DR=DR_";9////"_$S($G(RAVERF)&(RARPTSTS="V"):RAVERF,1:"") ; v'fying phys 46 S DR=DR_";11////"_$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") ; transcriptionist 47 I $G(RAVERF),(RARPTSTS="V") S DR=DR_";17////"_$G(^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE")) ;status changed to 'verified' by 48 ; D ^DIE K DA,DR ;BNT- Moved the DIE call down three lines due to a 49 ; problem found at Indy while testing PowerScribe. Site was doing a 50 ; local MUMPS cross reference on one of the nodes that are set below. 51 S $P(^RARPT(RARPT,0),"^",2)=RADFN,$P(^(0),"^",3)=(9999999.9999-RADTI),$P(^(0),"^",4)=$P(RALONGCN,"-",2) ;must set manually due uneditable 52 S $P(^RARPT(RARPT,0),"^",10)=$S($D(RAESIG)&(RARPTSTS="V"):RAESIG,1:"") ; hard set because Elec Sig Code may contain a semi-colon which causes errors in DIE 53 D ^DIE K DA,DR 54 ; 09/07/2005 108405 KAM/BAY Removed('$D(RADENDUM)#2) from next line 55 I $D(RADX) D 56 . K DIE,DA,DR S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN 57 . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," 58 . S DR="13////"_RADX D ^DIE K DIE,DA,DR 59 . S:$P(^RA(78.3,+RADX,0),"^",4)="y" RAAB=1 60 . Q 61 ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx 62 I $D(RASECDX) D 63 . N RAX S RAX=0 64 . F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D 65 .. S:$P(^RA(78.3,+RAX,0),"^",4)="y" RAAB=1 66 ; 67 I '$D(RADENDUM)#2,($G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF"))!$G(^("RARESIDENT"))) D 68 . K DIE,DA S DR="" 69 . S RAPRIMAR=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")) I $D(^VA(200,"ARC","R",RAPRIMAR)) S DR="12////"_RAPRIMAR 70 . S RAPRIMAR=+$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF")) I $D(^VA(200,"ARC","S",RAPRIMAR)) S DR=$S(DR]"":DR_";",1:"")_"15////"_RAPRIMAR 71 . Q:'$G(DR) 72 . S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN 73 . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," 74 . D ^DIE K DIE,DA,DR 75 . Q 76 ; 77 S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RARPT I $G(RADPIECE),$P(^(0),"^",RADPIECE)="",('$D(RADENDUM)#2) D SETPHYS^RAHLO4 78 ; file impression text if present & not an addendum 79 I '$D(RADENDUM) D 80 . S J=0 I $O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)) S I=0 F J=0:1 S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",I)) Q:I'>0 I $D(^(I)) S ^RARPT(RARPT,"I",(J+1),0)=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",I)) 81 . S:J ^RARPT(RARPT,"I",0)="^^"_J_"^"_J_"^"_RADATE 82 . Q 83 ; file report text if present & not an addendum 84 I '$D(RADENDUM) D 85 . S J=0 I $O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0)) S I=0 F J=0:1 S I=$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",I)) Q:I'>0 I $D(^(I)) S ^RARPT(RARPT,"R",(J+1),0)=$G(^TMP("RARPT-REC",$J,RASUB,"RATXT",I)) 86 . S:J ^RARPT(RARPT,"R",0)="^^"_J_"^"_J_"^"_RADATE 87 . Q 88 ; if addendum, add addendum text to impression or report 89 I $D(RADENDUM),($O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0))!$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0))) D ADENDUM^RAHLO2 ; store new lines at the end of existing text 90 ; 91 ; 92 ; Check for History from Dictation 93 ; If history sent, check if previous history exists. If previous 94 ; history then current history will follow adding 'Addendum:' before 95 ; the text. 96 I $O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0)) D 97 . S RACNT=+$O(^RARPT(RARPT,"H",9999999),-1),RAHSTNDE=RACNT+1 98 . S RANEW=$S(RACNT>0:0,1:1) 99 . S I=0 F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) Q:I'>0 D 100 . . S RACNT=RACNT+1 101 . . S RALN=$G(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) 102 . . S:'RANEW&(I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0))) RALN="Addendum: "_RALN ; if the first line, append 'Addendum:' 103 . . I (RAHSTNDE=RACNT),(RACNT>1) S ^RARPT(RARPT,"H",RACNT,0)=" ",RACNT=RACNT+1 104 . . S ^RARPT(RARPT,"H",RACNT,0)=RALN 105 . . Q 106 . S ^RARPT(RARPT,"H",0)="^^"_RACNT_"^"_RACNT_"^"_RADATE 107 . Q 108 ; 109 ; 110 I $P(^RARPT(RARPT,0),U,5)="V",$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health 111 G:'RAPRTSET UPACT ; the next section is for printsets only 112 ; copy DX (prim & sec), Prim Resid, Prim Staff 113 N RACNISAV,RA7 114 N RA13,RA12,RA15 ;prim dx, prim resid, prim staff, rpt pointer 115 S RACNISAV=RACNI,RA7=0 116 S RA13=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13),RA12=$P(^(0),U,12),RA15=$P(^(0),U,15) 117 F S RA7=$O(RAMEMARR(RA7)) Q:RA7="" I RACNISAV'=RA7 S RACNI=RA7 D UPMEM^RAHLO4 I $D(RASECDX),('$D(RADENDUM)#2) D SECDX^RAHLO2 118 S RACNI=RACNISAV 119 L -^RADPT(RADFN,"DT",RADTI) ;unlock after pce 17 is set in all cases of this printset 120 ;Update Activity Log 121 UPACT S DA=RARPT,DIE="^RARPT(",DR="100///""NOW""",DR(2,74.01)="2////"_$S(RARPTSTS="V":"V",$D(RAEDIT):"E",1:"I")_";3////"_$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") D ^DIE K DA,DR,DE,DQ,DIE 122 ; use ix^dik to kill before setting xrefs 123 S DA=RARPT,DIK="^RARPT(",RAQUEUED=1 D IX^DIK 124 ; if verfd, update rpt & exam statuses; else, just update exam status 125 I $D(RAMDV),RAMDV'="" D:RARPTSTS="V" UPSTAT^RAUTL0 D:RARPTSTS'="V" UP1^RAUTL1 126 L -^RARPT(RARPT) D:'$D(RAERR)&($G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL") GENACK^RAHLTCPB ; generate 'ACK' message 127 ; line pacs is for 2 tasks: hl7 msg'g & voice verified rpt printout 128 PACS I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D TASK^RAHLO4,VOICE^RAHLO4 129 KVAR K RAAB,RAEDIT,RAESIG,RAQUEUED,RARPT,RAHIST 130 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO2.m
r613 r623 1 RAHLO2 ;HIRMFO/GJC-File rpt (data from bridge program) ;10/30/97 09:02 2 ;;5.0;Radiology/Nuclear Medicine;**55,80,84**;Mar 16, 1998;Build 13 3 ; 4 ;Integration Agreements 5 ;---------------------- 6 ;$$FIND1^DIC(2051); UPDATE^DIE(2053); $$DT^XLFDT(10103); $$UP^XLFSTR(10104) 7 ; 8 ADENDUM ; This functions store new lines of text at the end of the existing 9 ;impression and report text. If this report is being amended through the 10 ;teleradiology service, add the addendum text to the IMPRESSION TEXT (#300) 11 ;field only. Note: Only ADENDUM was edited for RA*5.0*84 gjc/09.18.07 12 N A,COUNTER,I,J,NODE,ROOT,SUB,X,Y 13 ;NODE = ^RARPT(RARPT,"I" -or- "R" -> where the data is to be stored... 14 ;ROOT = ^TMP("RARPT-REC",$J,RASUB -> where the addendum data resides... 15 F A="I","R" D K I,J 16 .S SUB=$S(A="I":"RAIMP",1:"RATXT"),ROOT=$NA(^TMP("RARPT-REC",$J,RASUB,SUB)) Q:'$O(@ROOT@(0)) 17 .S NODE=$NA(^RARPT(RARPT,A)) 18 .S COUNTER=+$O(@NODE@($C(32)),-1) ;last record # 19 .; 20 .;if there is existing text, add a null line for space. 21 .I '($D(I)#2),(COUNTER>0) S COUNTER=COUNTER+1,@NODE@(COUNTER,0)=$C(32),I="" 22 .; 23 .S Y=0 F S Y=$O(@ROOT@(Y)) Q:'Y D 24 ..S X=@ROOT@(Y) 25 ..;if addendum text is to be the original text no spacer is needed ('Addendum:' tag applied) 26 ..;if prior report or impression text exist, insert a blank as a spacer 27 ..;^RARPT(RARPT,"I",1,0)="original impression" 28 ..;^RARPT(RARPT,"I",2,0)="" <- insert a null line as a spacer 29 ..;^RARPT(RARPT,"I",3,0)="Addendum: first line of addendum" ** NOTE 'Addendum:' tag ** 30 ..;^RARPT(RARPT,"I",4,0)="second line of addendum" 31 ..;... 32 ..;^RARPT(RARPT,"I",N,0)="Nth and last line of addendum" 33 ..S COUNTER=COUNTER+1 34 ..;set the first line of the addendum w/header: 'Addendum: ' 35 ..I '($D(J)#2) S X="Addendum: "_X,J="" 36 ..S @NODE@(COUNTER,0)=X 37 ..Q 38 .S @NODE@(0)="^^"_COUNTER_"^"_COUNTER_"^"_$$DT^XLFDT() 39 .Q 40 Q 41 ; 42 ERR(A) ; Invalid impression/report text message. 43 ; Input: 'A' - either "I" for impression, or "R" for report 44 ; Output: the appropriate error message 45 Q "Invalid "_$S(A="I":"Impression",1:"Report")_" Text" 46 ; 47 DIAG ; Check if the Diagnostic Codes passed are valid. Set RADX equal 48 ; to primary Dx code pntr value. Set RASECDX(x) to the secondary 49 ; Dx code(s) if any. 50 N RAXFIRST 51 S I=0,RAXFIRST=1 52 K RASECDX 53 F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RADX",I)) Q:I'>0 D Q:$D(RAERR) 54 . S RADIAG=$G(^TMP("RARPT-REC",$J,RASUB,"RADX",I)) 55 . ;S:RADIAG']"" RAERR="Missing Diagnostic Code" Q:$D(RAERR) 56 . Q:RADIAG']"" ;Missing Diagnostic Code Patch 80 57 . ; If RADXIEN is a number, set RADXIEN to what is assumed to be a 58 . ; valid pointer (ien) for file 78.3 59 . I +RADIAG=RADIAG S RADXIEN=RADIAG 60 . ; If RADIAG is in a free text format, convert the external value 61 . ; into the ien for file 78.3 62 . I +RADIAG'=RADIAG S RADXIEN=$$FIND1^DIC(78.3,"","X",RADIAG) 63 . I '$D(^RA(78.3,RADXIEN,0)) S RAERR="Invalid Diagnostic Code" Q 64 . IF RAXFIRST S RADX=RADXIEN,RAXFIRST=0 Q ; RADX=pri. Dx Code 65 . ; are any of the sec. Dx codes equal to our pri. Dx code? 66 . ;S:RADXIEN=RADX RAERR="Secondary Dx codes must differ from the primary Dx code." Q:$D(RAERR) 67 . Q:RADXIEN=RADX ;Secondary Dx codes must differ from the primary Dx code Patch 80 68 . ;S:$D(RASECDX(RADXIEN))#2 RAERR="Duplicate secondary Dx codes." Q:$D(RAERR) 69 . Q:$D(RASECDX(RADXIEN))#2 ;Duplicate secondary Dx codes. Patch 80 70 . S RASECDX(RADXIEN)="" ; set the sec. Dx array 71 . Q 72 K I,RADIAG,RADXIEN 73 Q 74 SECDX ; Kill old sec. Dx nodes, and add the new ones into the 70.14 multiple 75 ; called from RAHLO. Needs RADFN,RADTI & RACNI to function. 76 Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI)) 77 I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) D KILSECDG^RAHLO4 78 ;K RAFDA N RAX S RAX=0,RAFDA(70,"?1,",.01)=RADFN 79 ;S RAFDA(70.02,"?2,?1,",.01)=(9999999.9999-RADTI) 80 ;S RAFDA(70.03,"?3,?2,?1,",.01)=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^") 81 ;F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D 82 ;. S RAFDA(70.14,"?"_RAX_"9,?3,?2,?1,",.01)=RAX 83 ;. Q 84 ;D UPDATE^DIE("","RAFDA",,"RAERR") 85 ;I $D(RAERR) M ^TMP("ERR")=RAERR 86 ; 87 N RAX S RAX=0 88 N RAFDA,RA2 89 K RAFDA 90 ; K ^TMP("RAERR",$J) 91 S RA2=RACNI_","_RADTI_","_RADFN 92 F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D 93 . S RAFDA(70.14,"?+"_RAX_"9,"_RA2_",",.01)=RAX 94 D UPDATE^DIE("","RAFDA",,"RAERR") 95 ; I $D(RAERR) M ^TMP("RAERR",$J)=RAERR 96 ; 97 Q 98 IMPTXT ; Check if the impression text consists only of the string 99 ; 'impression:". If 'impression:' is the only set of characters, 100 ; (spaces are excluded) then delete the "RAIMP" node. 101 N RA1 S RA1=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)) 102 Q:'RA1 N RAIMP S RAIMP=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)) 103 I $$UP^XLFSTR($E(RAIMP,1,11))="IMPRESSION:" D 104 . S $E(RAIMP,1,11)="" ; strip out 'impression:' if it is the first 105 . ; eleven chars of the impression text 106 . ; now strip off leading spaces from the remaining 107 . ; text that led with 'impression:' if present 108 . F I1=1:1 S:$E(RAIMP,I1)'=" " RAIMP=$E(RAIMP,I1,99999) Q:$E(RAIMP)'=" " 109 . S ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)=RAIMP 110 . Q 111 Q:$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)) ; more imp. text follows 112 K:$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1))="" ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1) ; if only "RAIMP" node null, delete "RAIMP" node 113 Q 1 RAHLO2 ;HIRMFO/GJC-File rpt (data from bridge program) ;10/30/97 09:02 2 ;;5.0;Radiology/Nuclear Medicine;**55,80**;Mar 16, 1998;Build 19 3 ADENDUM ; store new lines at the end of existing text 4 F A="I","R" D 5 . I $O(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),0)) D 6 .. S RACNT=+$O(^RARPT(RARPT,A,9999999),-1),RASTRNDE=RACNT+1 7 .. ; Check if the impression an/or report text sent with the addendum 8 .. ; is to be the initial text added to the word processing multiples. 9 .. ; RASTRNDE=the first subscript where impression/report data is to 10 .. ; be stored. If no existing impression/report text data, RASTRNDE 11 .. ; equals one. If one & RACNT equals one, don't add a blank line 12 .. ; before adding addendum text. If RASTRNDE & RACNT both >1, add 13 .. ; the blank line. 14 .. S I=0 F S I=$O(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),I)) Q:I'>0 D 15 ... S RACNT=RACNT+1,L=$G(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),I)) 16 ... S:I=$O(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),0)) L="Addendum: "_L ; if the first line, append 'addendum:' 17 ... I (RASTRNDE=RACNT),(RACNT>1) S ^RARPT(RARPT,A,RACNT,0)=" ",RACNT=RACNT+1 18 ... S ^RARPT(RARPT,A,RACNT,0)=L 19 ... Q 20 .. S ^RARPT(RARPT,A,0)="^^"_RACNT_"^"_RACNT_"^"_RADATE 21 .. Q 22 . Q 23 K A,I,L,RACNT,RASTRNDE 24 Q 25 ERR(A) ; Invalid impression/report text message. 26 ; Input: 'A' - either "I" for impression, or "R" for report 27 ; Output: the appropriate error message 28 Q "Invalid "_$S(A="I":"Impression",1:"Report")_" Text" 29 ; 30 DIAG ; Check if the Diagnostic Codes passed are valid. Set RADX equal 31 ; to primary Dx code pntr value. Set RASECDX(x) to the secondary 32 ; Dx code(s) if any. 33 N RAXFIRST 34 S I=0,RAXFIRST=1 35 K RASECDX 36 F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RADX",I)) Q:I'>0 D Q:$D(RAERR) 37 . S RADIAG=$G(^TMP("RARPT-REC",$J,RASUB,"RADX",I)) 38 . ;S:RADIAG']"" RAERR="Missing Diagnostic Code" Q:$D(RAERR) 39 . Q:RADIAG']"" ;Missing Diagnostic Code Patch 80 40 . ; If RADXIEN is a number, set RADXIEN to what is assumed to be a 41 . ; valid pointer (ien) for file 78.3 42 . I +RADIAG=RADIAG S RADXIEN=RADIAG 43 . ; If RADIAG is in a free text format, convert the external value 44 . ; into the ien for file 78.3 45 . I +RADIAG'=RADIAG S RADXIEN=$$FIND1^DIC(78.3,"","X",RADIAG) 46 . I '$D(^RA(78.3,RADXIEN,0)) S RAERR="Invalid Diagnostic Code" Q 47 . IF RAXFIRST S RADX=RADXIEN,RAXFIRST=0 Q ; RADX=pri. Dx Code 48 . ; are any of the sec. Dx codes equal to our pri. Dx code? 49 . ;S:RADXIEN=RADX RAERR="Secondary Dx codes must differ from the primary Dx code." Q:$D(RAERR) 50 . Q:RADXIEN=RADX ;Secondary Dx codes must differ from the primary Dx code Patch 80 51 . ;S:$D(RASECDX(RADXIEN))#2 RAERR="Duplicate secondary Dx codes." Q:$D(RAERR) 52 . Q:$D(RASECDX(RADXIEN))#2 ;Duplicate secondary Dx codes. Patch 80 53 . S RASECDX(RADXIEN)="" ; set the sec. Dx array 54 . Q 55 K I,RADIAG,RADXIEN 56 Q 57 SECDX ; Kill old sec. Dx nodes, and add the new ones into the 70.14 multiple 58 ; called from RAHLO. Needs RADFN,RADTI & RACNI to function. 59 Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI)) 60 I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) D KILSECDG^RAHLO4 61 ;K RAFDA N RAX S RAX=0,RAFDA(70,"?1,",.01)=RADFN 62 ;S RAFDA(70.02,"?2,?1,",.01)=(9999999.9999-RADTI) 63 ;S RAFDA(70.03,"?3,?2,?1,",.01)=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^") 64 ;F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D 65 ;. S RAFDA(70.14,"?"_RAX_"9,?3,?2,?1,",.01)=RAX 66 ;. Q 67 ;D UPDATE^DIE("","RAFDA",,"RAERR") 68 ;I $D(RAERR) M ^TMP("ERR")=RAERR 69 ; 70 N RAX S RAX=0 71 N RAFDA,RA2 72 K RAFDA 73 ; K ^TMP("RAERR",$J) 74 S RA2=RACNI_","_RADTI_","_RADFN 75 F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D 76 . S RAFDA(70.14,"?+"_RAX_"9,"_RA2_",",.01)=RAX 77 D UPDATE^DIE("","RAFDA",,"RAERR") 78 ; I $D(RAERR) M ^TMP("RAERR",$J)=RAERR 79 ; 80 Q 81 IMPTXT ; Check if the impression text consists only of the string 82 ; 'impression:". If 'impression:' is the only set of characters, 83 ; (spaces are excluded) then delete the "RAIMP" node. 84 N RA1 S RA1=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)) 85 Q:'RA1 N RAIMP S RAIMP=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)) 86 I $$UP^XLFSTR($E(RAIMP,1,11))="IMPRESSION:" D 87 . S $E(RAIMP,1,11)="" ; strip out 'impression:' if it is the first 88 . ; eleven chars of the impression text 89 . ; now strip off leading spaces from the remaining 90 . ; text that led with 'impression:' if present 91 . F I1=1:1 S:$E(RAIMP,I1)'=" " RAIMP=$E(RAIMP,I1,99999) Q:$E(RAIMP)'=" " 92 . S ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)=RAIMP 93 . Q 94 Q:$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)) ; more imp. text follows 95 K:$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1))="" ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1) ; if only "RAIMP" node null, delete "RAIMP" node 96 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO3.m
r613 r623 1 RAHLO3 ;HIRMFO/GJC-Process data set from the bridge program ;11/18/97 12:13 2 ;;5.0;Radiology/Nuclear Medicine;**4,81,84**;Mar 16, 1998;Build 13 3 ; 4 ;Integration Agreements 5 ;----------------------- 6 ;$$GET1^DIQ(2056); $$DT^XLFDT(10103) 7 ; 8 RPTSTAT ; Determine the status to set this report to. 9 K RARPTSTS S:$D(RAESIG) RARPTSTS="V" Q:$D(RARPTSTS) 10 ; $D(RAESIG)=0 now figure out report status 11 N RASTAT S RASTAT=$E($G(^TMP("RARPT-REC",$J,RASUB,"RASTAT"))) 12 I RASTAT="A" S RARPTSTS="V" Q 13 I RASTAT]"",("FR"[RASTAT) D 14 . S:RASTAT="F" RARPTSTS="V" Q:$D(RARPTSTS) 15 . I $G(RATELE) S RARPTSTS="R" Q ;Always allow 'Released/Unverified' reports for teleradiology 16 . ; do we allow 'Released/Unverified' reports for this location? 17 . S RARPTSTS=$S($P($G(^RA(79.1,RAMLC,0)),"^",17)="Y":"R",1:"D") 18 . Q 19 ; if no status, & there's physician data (verifier/primary),set status 20 I '$D(RARPTSTS),($G(RAVERF)!$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF"))!$G(^("RARESIDENT"))) S RARPTSTS=$S($P($G(^RA(79.1,RAMLC,0)),"^",17)="Y":"R",1:"D") 21 ; if still no status, default to draft 22 S:'$D(RARPTSTS) RARPTSTS="D" 23 Q 24 TEXT(X) ; Check if the Impression Text and the Report Text contain 25 ; valid characters. 26 ; Input : X = "I" if Impr Text is being checked, "R" if Rpt Text 27 ; Output: 0=invalid, 1=valid 28 N CNT,DATA,FLAG,I,I1,J,Y S (FLAG,I)=0 29 F S I=$O(^TMP("RARPT-REC",$J,RASUB,$S(X="I":"RAIMP",1:"RATXT"),I)) Q:I'>0 D Q:FLAG 30 . S CNT=0,DATA=$G(^TMP("RARPT-REC",$J,RASUB,$S(X="I":"RAIMP",1:"RATXT"),I)) Q:DATA']"" 31 . F J=1:1:$L(DATA) D Q:FLAG 32 .. S:$E(DATA,J)?1AN CNT=CNT+1 33 .. S:$E(DATA,J)'?1AN&(CNT>0) CNT=0 34 .. S:CNT=2 FLAG=1 35 .. Q 36 . Q 37 Q FLAG 38 ; 39 VERCHK ; Check if our provider can verify reports. 40 ; Examine the following four (4) conditions if $D(RAESIG) 41 ; 1) Does this person have a resident or staff classification? 42 ; 2) If a resident, does the division parameter allow resident 43 ; verification? 44 ; 3) Does this person hold the "RA VERIFY" key? 45 ; 4) Is this person an activate Rad/Nuc Med user? 46 ; 5) Can this person verify reports without staff review? 47 ; If 'No' to any of the above questions, kill RAESIG & set the variable 48 ; RAERR to the appropriate error message. 49 I '$D(^VA(200,"ARC","R",+$G(RAVERF))),('$D(^VA(200,"ARC","S",+$G(RAVERF)))),'$G(RATELE) D Q 50 . ; neither a resident or staff 51 . K RAESIG S RAERR="Provider not classified as resident or staff." 52 . Q 53 I $D(^VA(200,"ARC","R",+$G(RAVERF))),('$P(RAMDV,"^",18)),'$G(RATELE) D Q 54 . ; residents can't verify reports linked to this division 55 . K RAESIG S RAERR="Residents are not permitted to verify reports." 56 . Q 57 I '$D(^XUSEC("RA VERIFY",+$G(RAVERF))),'$G(RATELE) D Q 58 . ; verifier MUST have the RA VERIFY key. 59 . K RAESIG S RAERR="Provider does not meet security requirements to verify report." 60 . Q 61 I '$G(RATELE),$P($G(^VA(200,+$G(RAVERF),"RA")),"^",3),($P(^("RA"),"^",3)'>$$DT^XLFDT()) D 62 . ; Rad/Nuc Med user has been inactivated. 63 . K RAESIG S RAERR="Inactive Rad/Nuc Med Classification for Interpreting Physician." 64 . Q 65 I '$G(RATELE),'$S('$D(^VA(200,+$G(RAVERF),"RA")):1,$P(^("RA"),"^")'="Y":1,1:0) D 66 . K RAESIG S RAERR="Staff review required to verify report." 67 . Q 68 Q 69 VFIER ; Check if the RAVERF string is a partial match to an entry in file 70 ; 200. If if is, check to see that is a partial match to only ONE 71 ; active provider entry in file 200. 72 I '$L(RAVERF) S RAERR="Missing Provider information" Q 73 N RAVCNT,RAVIEN,RAVLGTH,RAVPS 74 S RAVLGTH=$L(RAVERF) ; length of the RAVERF string 75 S RAVCNT=0,RAVS1=RAVERF,RAVIEN="" 76 F S RAVS1=$O(^VA(200,"B",RAVS1)) Q:RAVS1=""!($E(RAVS1,1,RAVLGTH)'=RAVERF) D Q:RAVCNT>1 77 . ; return subscripts that have the RAVERF string as the first 78 . ; 1 - RAVLGTH chars of RAVS1 79 . S RAVIEN=0 80 . F S RAVIEN=$O(^VA(200,"B",RAVS1,RAVIEN)) Q:RAVIEN'>0 D Q:RAVCNT>1 81 .. S RAVPS=$G(^VA(200,RAVIEN,"PS")) 82 .. S:'$P(RAVPS,"^",4)!($P(RAVPS,"^",4)>DT) RAVCNT=RAVCNT+1 83 .. I RAVCNT=1,('$D(RAVIEN(RAVCNT))#2) S RAVIEN(RAVCNT)=RAVIEN ; when 84 .. ; we find the first active provider save the provider ien off 85 .. ; in a local array. 86 .. Q 87 . Q 88 ; Added for PowerScribe 89 I RAVIEN']"" D 90 . ;S RAVIEN=$P(RAVERF,$E(HL("ECH"),4)) 91 . S RAVIEN=+RAVERF 92 . S RAVPS=$G(^VA(200,RAVIEN,"PS")) 93 . S:'$P(RAVPS,"^",4)!($P(RAVPS,"^",4)>DT) RAVCNT=RAVCNT+1 94 . I RAVCNT=1,('$D(RAVIEN(RAVCNT))#2) S RAVIEN(RAVCNT)=RAVIEN 95 . Q 96 I RAVCNT=0 S RAERR="Invalid Provider Name: "_RAVERF Q ; partial match not found 97 I RAVCNT>1 S RAERR="Non-Unique Provider Name: "_RAVERF Q ; >1 partial match 98 ;S RAVERF=$G(RAVIEN(1)) S:'RAVERF RAERR="Provider Name Entry Error" 99 S:'$G(RAVIEN(1)) RAERR="Provider Name Entry Error: "_RAVERF S RAVERF=$G(RAVIEN(1)) 100 Q 101 ESIG ; Added for COTS E-Sig capability 102 ; 103 Q:"FA"'[^TMP(RARRR,$J,RASUB,"RASTAT")!('$D(^("RAVERF")))!($D(^("RAESIG"))) 104 S RADFN=+$G(^TMP(RARRR,$J,RASUB,"RADFN")) 105 S RADTI=+$G(^TMP(RARRR,$J,RASUB,"RADTI")) 106 S RADIV=$P($G(^RADPT(RADFN,"DT",RADTI,0)),"^",3) 107 Q:RADIV="" ; exam has been deleted - will be rejected 108 ; Check division parameters for ALLOW E-SIG ON COTS REPORT in file 79 109 ; for the division that ordered this procedure. 110 I $P(^RA(79,RADIV,.1),"^",27)["Y" D 111 . S RAESIG=$$GET1^DIQ(200,RAVERF,20.2) 112 . S:RAESIG]"" ^TMP(RARRR,$J,RASUB,"RAESIG")=RAESIG 113 . Q 114 Q 1 RAHLO3 ;HIRMFO/GJC-Process data set from the bridge program ;11/18/97 12:13 2 ;;5.0;Radiology/Nuclear Medicine;**4,81**;Mar 16, 1998;Build 12 3 RPTSTAT ; Determine the status to set this report to. 4 K RARPTSTS S:$D(RAESIG) RARPTSTS="V" Q:$D(RARPTSTS) 5 ; $D(RAESIG)=0 now figure out report status 6 S RASTAT=$E($G(^TMP("RARPT-REC",$J,RASUB,"RASTAT"))) 7 I RASTAT="A" S RARPTSTS="V" Q 8 I RASTAT]"",("FR"[RASTAT) D 9 . S:RASTAT="F" RARPTSTS="V" Q:$D(RARPTSTS) 10 . ; do we allow 'Released/Unverified' reports for this location? 11 . S RARPTSTS=$S($P($G(^RA(79.1,RAMLC,0)),"^",17)="Y":"R",1:"D") 12 . Q 13 ; if no status, & there's physician data (verifier/primary),set status 14 I '$D(RARPTSTS),($G(RAVERF)!$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF"))!$G(^("RARESIDENT"))) S RARPTSTS=$S($P($G(^RA(79.1,RAMLC,0)),"^",17)="Y":"R",1:"D") 15 ; if still no status, default to draft 16 S:'$D(RARPTSTS) RARPTSTS="D" 17 K RASTAT 18 Q 19 TEXT(X) ; Check if the Impression Text and the Report Text contain 20 ; valid characters. 21 ; Input : X = "I" if Impr Text is being checked, "R" if Rpt Text 22 ; Output: 0=invalid, 1=valid 23 N CNT,DATA,FLAG,I,I1,J,Y S (FLAG,I)=0 24 F S I=$O(^TMP("RARPT-REC",$J,RASUB,$S(X="I":"RAIMP",1:"RATXT"),I)) Q:I'>0 D Q:FLAG 25 . S CNT=0,DATA=$G(^TMP("RARPT-REC",$J,RASUB,$S(X="I":"RAIMP",1:"RATXT"),I)) Q:DATA']"" 26 . F J=1:1:$L(DATA) D Q:FLAG 27 .. S:$E(DATA,J)?1AN CNT=CNT+1 28 .. S:$E(DATA,J)'?1AN&(CNT>0) CNT=0 29 .. S:CNT=2 FLAG=1 30 .. Q 31 . Q 32 Q FLAG 33 ; 34 VERCHK ; Check if our provider can verify reports. 35 ; Examine the following four (4) conditions if $D(RAESIG) 36 ; 1) Does this person have a resident or staff classification? 37 ; 2) If a resident, does the division parameter allow resident 38 ; verification? 39 ; 3) Does this person hold the "RA VERIFY" key? 40 ; 4) Is this person an activate Rad/Nuc Med user? 41 ; 5) Can this person verify reports without staff review? 42 ; If 'No' to any of the above questions, kill RAESIG & set the variable 43 ; RAERR to the appropriate error message. 44 I '$D(^VA(200,"ARC","R",+$G(RAVERF))),('$D(^VA(200,"ARC","S",+$G(RAVERF)))) D Q 45 . ; neither a resident or staff 46 . K RAESIG S RAERR="Provider not classified as resident or staff." 47 . Q 48 I $D(^VA(200,"ARC","R",+$G(RAVERF))),('$P(RAMDV,"^",18)) D Q 49 . ; residents can't verify reports linked to this division 50 . K RAESIG S RAERR="Residents are not permitted to verify reports." 51 . Q 52 I '$D(^XUSEC("RA VERIFY",+$G(RAVERF))) D Q 53 . ; verifier MUST have the RA VERIFY key. 54 . K RAESIG S RAERR="Provider does not meet security requirements to verify report." 55 . Q 56 I $P($G(^VA(200,+$G(RAVERF),"RA")),"^",3),($P(^("RA"),"^",3)'>$$DT^XLFDT()) D 57 . ; Rad/Nuc Med user has been inactivated. 58 . K RAESIG S RAERR="Inactive Rad/Nuc Med Classification for Interpreting Physician." 59 . Q 60 I '$S('$D(^VA(200,+$G(RAVERF),"RA")):1,$P(^("RA"),"^")'="Y":1,1:0) D 61 . K RAESIG S RAERR="Staff review required to verify report." 62 . Q 63 Q 64 VFIER ; Check if the RAVERF string is a partial match to an entry in file 65 ; 200. If if is, check to see that is a partial match to only ONE 66 ; active provider entry in file 200. 67 I '$L(RAVERF) S RAERR="Missing Provider information" Q 68 N RAVCNT,RAVIEN,RAVLGTH,RAVPS 69 S RAVLGTH=$L(RAVERF) ; length of the RAVERF string 70 S RAVCNT=0,RAVS1=RAVERF,RAVIEN="" 71 F S RAVS1=$O(^VA(200,"B",RAVS1)) Q:RAVS1=""!($E(RAVS1,1,RAVLGTH)'=RAVERF) D Q:RAVCNT>1 72 . ; return subscripts that have the RAVERF string as the first 73 . ; 1 - RAVLGTH chars of RAVS1 74 . S RAVIEN=0 75 . F S RAVIEN=$O(^VA(200,"B",RAVS1,RAVIEN)) Q:RAVIEN'>0 D Q:RAVCNT>1 76 .. S RAVPS=$G(^VA(200,RAVIEN,"PS")) 77 .. S:'$P(RAVPS,"^",4)!($P(RAVPS,"^",4)>DT) RAVCNT=RAVCNT+1 78 .. I RAVCNT=1,('$D(RAVIEN(RAVCNT))#2) S RAVIEN(RAVCNT)=RAVIEN ; when 79 .. ; we find the first active provider save the provider ien off 80 .. ; in a local array. 81 .. Q 82 . Q 83 ; Added for PowerScribe 84 I RAVIEN']"" D 85 . ;S RAVIEN=$P(RAVERF,$E(HL("ECH"),4)) 86 . S RAVIEN=+RAVERF 87 . S RAVPS=$G(^VA(200,RAVIEN,"PS")) 88 . S:'$P(RAVPS,"^",4)!($P(RAVPS,"^",4)>DT) RAVCNT=RAVCNT+1 89 . I RAVCNT=1,('$D(RAVIEN(RAVCNT))#2) S RAVIEN(RAVCNT)=RAVIEN 90 . Q 91 I RAVCNT=0 S RAERR="Invalid Provider Name" Q ; partial match not found 92 I RAVCNT>1 S RAERR="Non-Unique Provider Name" Q ; >1 partial match 93 S RAVERF=$G(RAVIEN(1)) S:'RAVERF RAERR="Provider Name Entry Error" 94 Q 95 ESIG ; Added for COTS E-Sig capability 96 ; 97 Q:"FA"'[^TMP(RARRR,$J,RASUB,"RASTAT")!('$D(^("RAVERF")))!($D(^("RAESIG"))) 98 S RADFN=+$G(^TMP(RARRR,$J,RASUB,"RADFN")) 99 S RADTI=+$G(^TMP(RARRR,$J,RASUB,"RADTI")) 100 S RADIV=$P($G(^RADPT(RADFN,"DT",RADTI,0)),"^",3) 101 Q:RADIV="" ; exam has been deleted - will be rejected 102 ; Check division parameters for ALLOW E-SIG ON COTS REPORT in file 79 103 ; for the division that ordered this procedure. 104 I $P(^RA(79,RADIV,.1),"^",27)["Y" D 105 . S RAESIG=$$GET1^DIQ(200,RAVERF,20.2) 106 . S:RAESIG]"" ^TMP(RARRR,$J,RASUB,"RAESIG")=RAESIG 107 . Q 108 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO4.m
r613 r623 1 RAHLO4 ;HIRMFO/GJC-File rpt (data from bridge program) ;7/21/99 11:45 2 ;;5.0;Radiology/Nuclear Medicine;**4,8,81,84**;Mar 16, 1998;Build 13 3 ; 4 ;Integration Agreements 5 ;---------------------- 6 ;NOW^%DTC(10000); %ZTLOAD(10063); FIND^DIC(2051); ^DIE(10018); ^DIK(10013); $$GET1^DIQ(2056) 7 ;GETS^DIQ(2056); ^XMD(10070) 8 ; 9 TASK ; Task ORU message 10 S ZTDESC="Rad/Nuc Med Compiling HL7 ORU Message",ZTDTH=$H,ZTIO="",ZTRTN="RPT^RAHLRPC",ZTSAVE("RADFN")="",ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTSAVE("RARPT")="" 11 ;Next line of coding will assure that ORU (report) message will be sent after posible ORM message. (10 second) 12 S $P(ZTDTH,",",2)=$P(ZTDTH,",",2)+4 S:$P(ZTDTH,",",2)>86400 ZTDTH=$P(ZTDTH,",")+1_","_($P(ZTDTH,",",2)-86400) 13 S:$L($G(RANOSEND)) ZTSAVE("RANOSEND")="" D ^%ZTLOAD 14 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE 15 Q 16 VOICE ; voice dictation auto-print (background process) 17 Q:$P(^RA(79.1,+$G(RAMLC),0),U,26)'="Y" ; Voice Dictation Auto-Print 18 S ZTIO=$$GET1^DIQ(3.5,+$P(^RA(79.1,+$G(RAMLC),0),U,10),.01) ; dev name 19 Q:ZTIO']"" ; quit if the device does not exist 20 S ZTDTH=$H,ZTRTN="DQ^RARTR",ZTSAVE("RARPT")="" 21 S ZTDESC="Rad/Nuc Med voice dictation auto-print" 22 D ^%ZTLOAD K RAMES,ZTDESC,ZTSK,ZTIO,ZTSAVE,ZTRTN,RASV,ZTDTH 23 Q 24 ; 25 UPMEM ;copy (prim:dx,stf,res),rpt ien to other members of same print set 26 ; first clear those fields 27 K DIE,DA,DR S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN 28 S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," 29 S DR="13///@;12///@;15///@" D ^DIE 30 ; now set those fields based on lead case of printset 31 S DR="13////"_RA13_";12////"_RA12_";15////"_RA15 D ^DIE K DA,DR,DIE 32 ; now set the report pointer (uneditable, thus must hard set) 33 S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RARPT 34 Q 35 SETPHYS ;set Primary Resident or Staff, either piece 12 or piece 15 of case 36 Q:RADPIECE'=15&(RADPIECE'=12) 37 S DR=RADPIECE_"////"_$G(RAVERF) 38 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI 39 S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," 40 D ^DIE K DA,DR 41 Q 42 KILSECDG ;kill secondary diagnoses nodes of this case 43 Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI)) 44 Q:RADFN=""!(RADTI="")!(RACNI="") 45 Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) 46 S DA(3)=RADFN,DA(2)=RADTI,DA(1)=RACNI 47 N RA1 S RA1="" 48 K1 S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RA1)) G:RA1="" KQ 49 S DA=RA1 50 S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""DX""," 51 D ^DIK 52 G K1 53 KQ K DA Q 54 ; 55 PCEXTR(RASUB,RASEG,RAPCE,RADEL) ; extract the right piece of data 56 ; from the right data node 57 ; input: RASUB-data node subscript 58 ; RASEG-HL7 segment (minus the segment header) 59 ; RAPCE-data's piece position 60 ; RADEL-delimiter (field separator) 61 S RAHL70="",RAHL7X=0,RAHL7OFF=$L(RASEG,RADEL) 62 S RAHL7LST=$P(RASEG,RADEL,RAHL7OFF) 63 I RAPCE<RAHL7OFF S RAHL70=$P(RASEG,RADEL,RAPCE) D KILL Q RAHL70 64 I RAHL7OFF=RAPCE D ; check if data wraps to the next node (if any) 65 . S RAHL70=$P(RASEG,RADEL,RAPCE),II1=$O(^TMP("RARPT-HL7",$J,RASUB,0)) 66 . S:'II1 RAHL7X=1 Q:'II1 67 . S RAHL70=RAHL70_$P(^TMP("RARPT-HL7",$J,RASUB,II1),RADEL),RAHL7X=1 68 . Q 69 I RAHL7X D KILL Q RAHL70 70 ; check if this node has descendent data nodes 71 I '$O(^TMP("RARPT-HL7",$J,RASUB,0)) D KILL Q "" ; descendents not found 72 S I=0,RAHL7CNT=RAHL7OFF 73 F S I=$O(^TMP("RARPT-HL7",$J,RASUB,I)) Q:I'>0 D Q:RAHL7X 74 . S RAHL7SUB=$G(^TMP("RARPT-HL7",$J,RASUB,I)) 75 . S RAHL7PRE=$O(^TMP("RARPT-HL7",$J,RASUB,I),-1) 76 . S:RAHL7PRE RAHL7LST=$$LSTPCE(^TMP("RARPT-HL7",$J,RASUB,RAHL7PRE),RADEL) 77 . F II1=1:1:$L(RAHL7SUB,RADEL) D Q:RAHL7X 78 .. ; HL7 may have broken the string on data! 79 .. I II1=1 S RAHL7ARY(RAHL7CNT)=RAHL7LST_$P(RAHL7SUB,RADEL) 80 .. E D ; for the case II1'=1 81 ... S RAHL7CNT=RAHL7CNT+1 82 ... S RAHL7ARY(RAHL7CNT)=$P(RAHL7SUB,RADEL,II1) 83 ... Q 84 .. I RAHL7CNT=RAPCE,(II1'=$L(RAHL7SUB,RADEL)) S RAHL7X=1,RAHL70=RAHL7ARY(RAHL7CNT) 85 .. I RAHL7CNT=RAPCE,(II1=$L(RAHL7SUB,RADEL)) D 86 ... ; grab the 1st piece of the next node (if any) 87 ... S RAHL7X=1,RAHL70=RAHL7ARY(RAHL7CNT) 88 ... S N1=+$O(^TMP("RARPT-HL7",$J,RASUB,I)) Q:'N1 89 ... S RAHL70=RAHL70_$P(^TMP("RARPT-HL7",$J,RASUB,N1),RADEL) 90 ... Q 91 .. K:'RAHL7X RAHL7ARY 92 .. Q 93 . Q 94 D KILL 95 Q RAHL70 96 KILL ; kill the RAHLD* variables 97 K I,II1,N1,RAHL7ARY,RAHL7CNT,RAHL7LST,RAHL7OFF,RAHL7PRE,RAHL7SUB,RAHL7X 98 Q 99 LSTPCE(X,DEL) ; given a string and a delimiter, return the last piece 100 Q $P(X,DEL,$L(X,DEL)) 101 CKDUPA ; if duplicate addendum, send msg to members of unverify rpt mailgroup 102 S RADUPA=0 ; 0 means not a duplicate 103 N I1,I2,X1,X2,X3,X4,X21,R0,R1,R2,MATCH,XMSUB 104 S I1="I",I2="RAIMP" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP ;Q:'RADUPA 105 ; 106 I 'RADUPA S I1="R",I2="RATXT" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP Q:'RADUPA 107 ;S I1="R",I2="RATXT" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP Q:'RADUPA 108 ; 109 S XMSUB="Duplicate addendum being sent to Vista" 110 ; 111 ; check to see if mail message already sent for 112 ; this case no. TODAY only. if so quit - no need to 113 ; re-send to save time backwards $ORDER, duplicate 114 ; most likely to be most recently. 115 S (XMB,XMATCH)="" 116 D NOW^%DTC S RATDY=X K X 117 F S XMB=$O(^XMB(3.9,"B",$E(XMSUB,1,30),XMB),-1) Q:XMB="" D Q:XMATCH'="" 118 .I $P($$GET1^DIQ(3.9,XMB,1.4,"I"),".")'=RATDY S XMATCH=0 Q ;(DBIA2860) 119 .Q:$G(^XMB(3.9,XMB,2,6,0))'[RALONGCN 120 .S XMATCH=1 121 K XMB,RATDY 122 Q:XMATCH=1 123 ; 124 ; send mail to members of unverify bulletin (DBIA2861) 125 ; find ien of unverify bulletin 126 D FIND^DIC(3.6,"","","","RAD/NUC MED REPORT UNVERIFIED",1,"","","","R0") 127 Q:'$D(R0("DILIST",2,1))#2 128 ; find name of mail group linked to that bulletin 129 D GETS^DIQ(3.6,R0("DILIST",2,1),"4*","EI","R1") 130 ; check to see if MailGroup is PUBLIC, otherwise quit 131 S X=$G(R1(3.62,"1,"_R0("DILIST",2,1)_",",.01,"I")) I X="" K X Q 132 I $$GET1^DIQ(3.8,X_",",4,"I")'="PU" K X Q 133 S X=$G(R1(3.62,"1,"_R0("DILIST",2,1)_",",.01,"E")) I X="" K X Q 134 N XMDUZ,XMTEXT,XMY,MSGTXT,XRAVERF,XRATRANS,XRADFN 135 S X="G."_X,XMY(X)="" K X ;recipient mail group 136 ; 137 S XMDUZ=.5 138 S MSGTXT(1)=$G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))_" is sending duplicate addenda to Radiology/Nuclear Medicine." 139 S MSGTXT(2)=" " 140 S MSGTXT(3)="The following radiology report was sent with a duplicate addendum:" 141 S:RADFN'="" XRADFN=$$GET1^DIQ(2,RADFN,.01) 142 S:$G(XRADFN)="" XRADFN="Unknown" 143 S MSGTXT(4)=" 1) Patient : "_XRADFN 144 S MSGTXT(5)=" 2) SSN : "_$$SSN^RAUTL() 145 S MSGTXT(6)=" 3) Case Number : "_RALONGCN 146 S:RAVERF'="" XRAVERF=$$GET1^DIQ(200,RAVERF,.01) 147 S:$G(XRAVERF)="" XRAVERF="Unknown" 148 S MSGTXT(7)=" 4) Verifier : "_XRAVERF 149 S:RATRANSC'="" XRATRANS=$$GET1^DIQ(200,RATRANSC,.01) 150 S:$G(XRATRANS)="" XRATRANS="Unknown" 151 S MSGTXT(8)=" 5) Transcriptionist : "_XRATRANS 152 S MSGTXT(9)=" " 153 S MSGTXT(10)="Please notify IRM." 154 S XMTEXT="MSGTXT(" 155 D ^XMD 156 Q 157 ISITDUP ; X1=last ien ^RARPT, X2=LAST IEN ^TMP, x21=first ien ^TMP 158 Q:'$O(^TMP("RARPT-REC",$J,RASUB,I2,0)) 159 N X1,X2,X21,X3,X4,XX 160 S RADUPA=0 ; Reset to zero otherwise Imp Text match will override 161 S X1=$O(^RARPT(RARPT,I1,""),-1) 162 S XX=$G(^RARPT(RARPT,I1,X1,0)) S XX=$S(XX=""!(XX=" "):0,1:1) 163 S X2=$O(^TMP("RARPT-REC",$J,RASUB,I2,""),-1),X21=$O(^(0)) 164 S X3=X1-X2+XX Q:X3<1 ; begin comparison from ^RARPT(RARPT,I1,X3 165 ; chk 1st line of previous addendum 166 Q:^RARPT(RARPT,I1,X3,0)'["Addendum: " S X4=^(0) 167 S X4=$E(X4,$L("Addendum: ")+1,$L(X4)) ; exclude "Addendum: " from X4 168 Q:X4'=^TMP("RARPT-REC",$J,RASUB,I2,X21) 169 ; chk remaining lines 170 S X21=X21+1 F X1=X21:1:X2 S X3=X3+1 Q:^RARPT(RARPT,I1,X3,0)'=^TMP("RARPT-REC",$J,RASUB,I2,X1) 171 Q:X1<X2 172 S RADUPA=1 173 Q 1 RAHLO4 ;HIRMFO/GJC-File rpt (data from bridge program) ;7/21/99 11:45 2 ;;5.0;Radiology/Nuclear Medicine;**4,8,81**;Mar 16, 1998;Build 12 3 TASK ; Task ORU message 4 S ZTDESC="Rad/Nuc Med Compiling HL7 ORU Message",ZTDTH=$H,ZTIO="",ZTRTN="RPT^RAHLRPC",ZTSAVE("RADFN")="",ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTSAVE("RARPT")="" 5 ;S:$L($G(RANOSEND))&'$O(RAPRSET(RADTI,0)) ZTSAVE("RANOSEND")="" D ^%ZTLOAD 6 S:$L($G(RANOSEND)) ZTSAVE("RANOSEND")="" D ^%ZTLOAD 7 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE 8 Q 9 VOICE ; voice dictation auto-print (background process) 10 Q:$P(^RA(79.1,+$G(RAMLC),0),U,26)'="Y" ; Voice Dictation Auto-Print 11 S ZTIO=$$GET1^DIQ(3.5,+$P(^RA(79.1,+$G(RAMLC),0),U,10),.01) ; dev name 12 Q:ZTIO']"" ; quit if the device does not exist 13 S ZTDTH=$H,ZTRTN="DQ^RARTR",ZTSAVE("RARPT")="" 14 S ZTDESC="Rad/Nuc Med voice dictation auto-print" 15 D ^%ZTLOAD K RAMES,ZTDESC,ZTSK,ZTIO,ZTSAVE,ZTRTN,RASV,ZTDTH 16 Q 17 FILETST ; is anyone else working on this report? 18 L +^RARPT(RARPT):1 19 I '$T S RAERR="This report is being edited by another user" L -^RARPT(RARPT) 20 Q 21 UPMEM ;copy (prim:dx,stf,res),rpt ien to other members of same print set 22 ; first clear those fields 23 K DIE,DA,DR S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN 24 S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," 25 S DR="13///@;12///@;15///@" D ^DIE 26 ; now set those fields based on lead case of printset 27 S DR="13////"_RA13_";12////"_RA12_";15////"_RA15 D ^DIE K DA,DR,DIE 28 ; now set the report pointer (uneditable, thus must hard set) 29 S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RARPT 30 Q 31 SETPHYS ;set Primary Resident or Staff, either piece 12 or piece 15 of case 32 Q:RADPIECE'=15&(RADPIECE'=12) 33 S DR=RADPIECE_"////"_$G(RAVERF) 34 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI 35 S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," 36 D ^DIE K DA,DR 37 Q 38 KILSECDG ;kill secondary diagnoses nodes of this case 39 Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI)) 40 Q:RADFN=""!(RADTI="")!(RACNI="") 41 Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) 42 S DA(3)=RADFN,DA(2)=RADTI,DA(1)=RACNI 43 N RA1 S RA1="" 44 K1 S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RA1)) G:RA1="" KQ 45 S DA=RA1 46 S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""DX""," 47 D ^DIK 48 G K1 49 KQ K DA Q 50 ; 51 PCEXTR(RASUB,RASEG,RAPCE,RADEL) ; extract the right piece of data 52 ; from the right data node 53 ; input: RASUB-data node subscript 54 ; RASEG-HL7 segment (minus the segment header) 55 ; RAPCE-data's piece position 56 ; RADEL-delimiter (field separator) 57 S RAHL70="",RAHL7X=0,RAHL7OFF=$L(RASEG,RADEL) 58 S RAHL7LST=$P(RASEG,RADEL,RAHL7OFF) 59 I RAPCE<RAHL7OFF S RAHL70=$P(RASEG,RADEL,RAPCE) D KILL Q RAHL70 60 I RAHL7OFF=RAPCE D ; check if data wraps to the next node (if any) 61 . S RAHL70=$P(RASEG,RADEL,RAPCE),II1=$O(^TMP("RARPT-HL7",$J,RASUB,0)) 62 . S:'II1 RAHL7X=1 Q:'II1 63 . S RAHL70=RAHL70_$P(^TMP("RARPT-HL7",$J,RASUB,II1),RADEL),RAHL7X=1 64 . Q 65 I RAHL7X D KILL Q RAHL70 66 ; check if this node has descendent data nodes 67 I '$O(^TMP("RARPT-HL7",$J,RASUB,0)) D KILL Q "" ; descendents not found 68 S I=0,RAHL7CNT=RAHL7OFF 69 F S I=$O(^TMP("RARPT-HL7",$J,RASUB,I)) Q:I'>0 D Q:RAHL7X 70 . S RAHL7SUB=$G(^TMP("RARPT-HL7",$J,RASUB,I)) 71 . S RAHL7PRE=$O(^TMP("RARPT-HL7",$J,RASUB,I),-1) 72 . S:RAHL7PRE RAHL7LST=$$LSTPCE(^TMP("RARPT-HL7",$J,RASUB,RAHL7PRE),RADEL) 73 . F II1=1:1:$L(RAHL7SUB,RADEL) D Q:RAHL7X 74 .. ; HL7 may have broken the string on data! 75 .. I II1=1 S RAHL7ARY(RAHL7CNT)=RAHL7LST_$P(RAHL7SUB,RADEL) 76 .. E D ; for the case II1'=1 77 ... S RAHL7CNT=RAHL7CNT+1 78 ... S RAHL7ARY(RAHL7CNT)=$P(RAHL7SUB,RADEL,II1) 79 ... Q 80 .. I RAHL7CNT=RAPCE,(II1'=$L(RAHL7SUB,RADEL)) S RAHL7X=1,RAHL70=RAHL7ARY(RAHL7CNT) 81 .. I RAHL7CNT=RAPCE,(II1=$L(RAHL7SUB,RADEL)) D 82 ... ; grab the 1st piece of the next node (if any) 83 ... S RAHL7X=1,RAHL70=RAHL7ARY(RAHL7CNT) 84 ... S N1=+$O(^TMP("RARPT-HL7",$J,RASUB,I)) Q:'N1 85 ... S RAHL70=RAHL70_$P(^TMP("RARPT-HL7",$J,RASUB,N1),RADEL) 86 ... Q 87 .. K:'RAHL7X RAHL7ARY 88 .. Q 89 . Q 90 D KILL 91 Q RAHL70 92 KILL ; kill the RAHLD* variables 93 K I,II1,N1,RAHL7ARY,RAHL7CNT,RAHL7LST,RAHL7OFF,RAHL7PRE,RAHL7SUB,RAHL7X 94 Q 95 LSTPCE(X,DEL) ; given a string and a delimiter, return the last piece 96 Q $P(X,DEL,$L(X,DEL)) 97 CKDUPA ; if duplicate addendum, send msg to members of unverify rpt mailgroup 98 S RADUPA=0 ; 0 means not a duplicate 99 N I1,I2,X1,X2,X3,X4,X21,R0,R1,R2,MATCH,XMSUB 100 S I1="I",I2="RAIMP" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP ;Q:'RADUPA 101 ; 102 I 'RADUPA S I1="R",I2="RATXT" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP Q:'RADUPA 103 ;S I1="R",I2="RATXT" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP Q:'RADUPA 104 ; 105 S XMSUB="Duplicate addendum being sent to Vista" 106 ; 107 ; check to see if mail message already sent for 108 ; this case no. TODAY only. if so quit - no need to 109 ; re-send to save time backwards $ORDER, duplicate 110 ; most likely to be most recently. 111 S (XMB,XMATCH)="" 112 D NOW^%DTC S RATDY=X K X 113 F S XMB=$O(^XMB(3.9,"B",$E(XMSUB,1,30),XMB),-1) Q:XMB="" D Q:XMATCH'="" 114 .I $P($$GET1^DIQ(3.9,XMB,1.4,"I"),".")'=RATDY S XMATCH=0 Q ;(DBIA2860) 115 .Q:$G(^XMB(3.9,XMB,2,6,0))'[RALONGCN 116 .S XMATCH=1 117 K XMB,RATDY 118 Q:XMATCH=1 119 ; 120 ; send mail to members of unverify bulletin (DBIA2861) 121 ; find ien of unverify bulletin 122 D FIND^DIC(3.6,"","","","RAD/NUC MED REPORT UNVERIFIED",1,"","","","R0") 123 Q:'$D(R0("DILIST",2,1))#2 124 ; find name of mail group linked to that bulletin 125 D GETS^DIQ(3.6,R0("DILIST",2,1),"4*","EI","R1") 126 ; check to see if MailGroup is PUBLIC, otherwise quit 127 S X=$G(R1(3.62,"1,"_R0("DILIST",2,1)_",",.01,"I")) I X="" K X Q 128 I $$GET1^DIQ(3.8,X_",",4,"I")'="PU" K X Q 129 S X=$G(R1(3.62,"1,"_R0("DILIST",2,1)_",",.01,"E")) I X="" K X Q 130 N XMDUZ,XMTEXT,XMY,MSGTXT,XRAVERF,XRATRANS,XRADFN 131 S X="G."_X,XMY(X)="" K X ;recipient mail group 132 ; 133 S XMDUZ=.5 134 S MSGTXT(1)=$G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))_" is sending duplicate addenda to Radiology/Nuclear Medicine." 135 S MSGTXT(2)=" " 136 S MSGTXT(3)="The following radiology report was sent with a duplicate addendum:" 137 S:RADFN'="" XRADFN=$$GET1^DIQ(2,RADFN,.01) 138 S:$G(XRADFN)="" XRADFN="Unknown" 139 S MSGTXT(4)=" 1) Patient : "_XRADFN 140 S MSGTXT(5)=" 2) SSN : "_$$SSN^RAUTL() 141 S MSGTXT(6)=" 3) Case Number : "_RALONGCN 142 S:RAVERF'="" XRAVERF=$$GET1^DIQ(200,RAVERF,.01) 143 S:$G(XRAVERF)="" XRAVERF="Unknown" 144 S MSGTXT(7)=" 4) Verifier : "_XRAVERF 145 S:RATRANSC'="" XRATRANS=$$GET1^DIQ(200,RATRANSC,.01) 146 S:$G(XRATRANS)="" XRATRANS="Unknown" 147 S MSGTXT(8)=" 5) Transcriptionist : "_XRATRANS 148 S MSGTXT(9)=" " 149 S MSGTXT(10)="Please notify IRM." 150 S XMTEXT="MSGTXT(" 151 D ^XMD 152 Q 153 ISITDUP ; X1=last ien ^RARPT, X2=LAST IEN ^TMP, x21=first ien ^TMP 154 Q:'$O(^TMP("RARPT-REC",$J,RASUB,I2,0)) 155 N X1,X2,X21,X3,X4,XX 156 S RADUPA=0 ; Reset to zero otherwise Imp Text match will override 157 S X1=$O(^RARPT(RARPT,I1,""),-1) 158 S XX=$G(^RARPT(RARPT,I1,X1,0)) S XX=$S(XX=""!(XX=" "):0,1:1) 159 S X2=$O(^TMP("RARPT-REC",$J,RASUB,I2,""),-1),X21=$O(^(0)) 160 S X3=X1-X2+XX Q:X3<1 ; begin comparison from ^RARPT(RARPT,I1,X3 161 ; chk 1st line of previous addendum 162 Q:^RARPT(RARPT,I1,X3,0)'["Addendum: " S X4=^(0) 163 S X4=$E(X4,$L("Addendum: ")+1,$L(X4)) ; exclude "Addendum: " from X4 164 Q:X4'=^TMP("RARPT-REC",$J,RASUB,I2,X21) 165 ; chk remaining lines 166 S X21=X21+1 F X1=X21:1:X2 S X3=X3+1 Q:^RARPT(RARPT,I1,X3,0)'=^TMP("RARPT-REC",$J,RASUB,I2,X1) 167 Q:X1<X2 168 S RADUPA=1 169 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLR.m
r613 r623 1 RAHLR ;HISC/CAH/BNT - Generate Common Order (ORM) Message ;11/10/99 10:42 2 ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,71,82,75,80,84**;Mar 16, 1998;Build 13 3 ;Generates msg whenever a case is registered or cancelled or examined 4 ; registered cancelled examined 5 ; Order control : NW CA XO 6 ; Order status : IP CA CM 7 ;02/14/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R 8 ; 9 ;Integration Agreements 10 ;---------------------- 11 ;NOW^%DTC(10000); ^%ZTLOAD(10063); $$GET1^DIQ(2056); ^DIWP(10011) 12 ;$$HLDATE/$$HLNAME/$$M11^HLFNC(10106); INIT^HLFNC2(2161) 13 ;GENERATE^HLMA(2164); DEM^VADPT(10061); $$EN^VAFHLPID(263) 14 ;$$FMTHL7^XLFDT(10103) 15 ; 16 ;IA: 10039 global read .01 field WARD LOCATION (#42) file ^DIC(42, 17 ;IA: 10040 global read .01 field HOSPITAL LOCATION (#44) file ^SC( 18 ; 19 S:$D(HLNDAP) ZTSAVE("HLNDAP")="" S:$D(HLDAP) ZTSAVE("HLDAP")="" S:$D(RAEXMDUN) ZTSAVE("RAEXMDUN")="" 20 S:$D(RAEXEDT) ZTSAVE("RAEXEDT")="" 21 S ZTSAVE("RADFN")="",ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTIO="",ZTDTH=$H,ZTDESC="Rad/Nuc Med Compiling HL7 Common Order",ZTRTN="EN^RAHLR" D ^%ZTLOAD 22 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE Q 23 EN ; Called from the RA REG & RA CANCEL & RA EXAMINED protocols 24 ; Input Variables: 25 ; RADFN=file 2 IEN (DFN) 26 ; RADTI=file 70 Exam subrec IEN (reverse date/time of exam) 27 ; RACNI=file 70 Case subrecord IEN 28 ; RAEID=ien of the event driver protocol (defined in RAHLRPC) 29 ; Output Variables: 30 ; HLA("HLS") array containing HL7 msg 31 ; 32 N EID,HL,INT,HLQ,HLFS,HLECH,HLA,HLCS,HLSCS,HLREP,HLECH 33 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 34 ; 35 D INIT ; initialize some HL7 variables 36 ;RAEXMDUN passed from EXM^RAHLRPC if conditions are met 37 Q:+$G(HL)=15 ;no known client(item) linked to the event driver protocol 38 Q:$O(HL(""))="" ;disabled server appl, or no server appl 39 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 40 I HL("VER")>2.3,($T(^RAHLR1))'="" D EN^RAHLR1(RADFN,RADTI,RACNI,RAEID) Q 41 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 42 S RACN0=$S($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)):^(0),1:"") Q:RACN0']"" 43 ;Generate Message Text 44 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 45 S RAPROCIT=+$P($G(^RAMIS(71,RAPROC,0)),U,12),RAPROCIT=$P(^RA(79.2,RAPROCIT,0),U,1) 46 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) 47 S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9),RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT) 48 ;RA*5*82 RAEXEDT= Override the EXM conditions if Case edited 49 ;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 ?? 50 ;Compile 'PID' Segment 51 K VA,VADM,VAERR,RAVADM S DFN=RADFN D DEM^VADPT I VADM(1)']"" S HLP("ERRTEXT")="Invalid Patient Identifier" G EXIT 52 S RAVADM(3)=$S($E(+VADM(3),6,7)="00":"",1:+VADM(3)) ; NOTE: Check 53 ; for an inexact date of birth. If inexact, pass null for DOB in 54 ; the 'PID' segment. Some COTS systems can't handle inexact DOB's. 55 I HL("VER")']"2.2" D 56 .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") 57 .S:$P(VADM(2),"^")]"" $P(HLA("HLS",1),HLFS,20)=$P(VADM(2),"^") 58 I HL("VER")]"2.2" S HLA("HLS",1)=$$EN^VAFHLPID(DFN,"2,3,5,7,8,19,20") 59 K RAVADM 60 ;Compile 'ORC' Segment 61 S X0="" ;if exam-set or print-set, store parent name if order exists 62 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 63 ; BNT - Added ORC4 Placer Group Number for Printset identification. 64 ; ORC4 is a combination of SSN with the order inverted date/time. 65 S RAORC4="" I $P($G(RACN0),U,25)=2 D 66 . S:$P(VADM(2),"^")]"" RAORC4=$P(VADM(2),"^") 67 . S RAORC4=$G(RAORC4)_RADTI 68 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 69 K RAORC4 70 ;Compile 'OBR' Segment 71 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" 72 ; Replace above with following when Imaging can cope with ESC chars 73 ; 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" 74 I $P(RACPTNDE,U)']"" S $P(RAOBR4,$E(HLECH),1,3)=$P(RAOBR4,$E(HLECH),4,5)_$E(HLECH)_"LOCAL" 75 ;OBR-7 change: from HLDT1 to $$HLDATE^HLFNC(9999999.9999-RADTI) d/t of registration 76 ;Driver of change: CareStream Health PACS. Agfa requires a timestamp down to the second 77 ;POC @ Boston is Maureen Sullivan 78 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) 79 S HLA("HLS",3)=HLA("HLS",3)_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS_HLQ_HLFS_HLFS 80 S RAPRV=$$GET1^DIQ(200,+$P(RACN0,"^",14),.01) 81 S HLA("HLS",3)=HLA("HLS",3)_$S(RAPRV]"":+$P(RACN0,"^",14)_$E(HLECH)_$$HLNAME^HLFNC(RAPRV),1:"") 82 ; 83 N RACN00,RA20 S RACN00=$G(^RADPT(RADFN,"DT",RADTI,0)) 84 ;Seg's fld 20 = pce 21 --> ien file #79.1~name of img loc~stn #~stn name 85 S RA20=+$G(^RA(79.1,+$P(RACN00,U,4),0)) 86 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) 87 S $P(HLA("HLS",3),HLFS,21)=$P(HLA("HLS",3),HLFS,21) 88 ; Replace above with following when Imaging can cope with ESC chars 89 ; S $P(HLA("HLS",3),HLFS,21)=$$ESCAPE^RAHLRU($P(HLA("HLS",3),HLFS,21)) 90 ;Seg's fld 21 = pce 22 --> abbrv I-type~Img type name 91 S RA20=$G(^RA(79.2,+$P(RACN00,U,2),0)) 92 S $P(HLA("HLS",3),HLFS,22)=$P(RA20,U,3)_$E(HLECH)_$P(RA20,U) 93 S $P(HLA("HLS",3),HLFS,22)=$P(HLA("HLS",3),HLFS,22) 94 ; Replace above with following when Imaging can cope with ESC chars 95 ; S $P(HLA("HLS",3),HLFS,22)=$$ESCAPE^RAHLRU($P(HLA("HLS",3),HLFS,22)) 96 ; 97 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") 98 ; 99 ; OBR-31.2 = Reason for Study P75 100 S $P(HLA("HLS",3),HLFS,32)=$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RAO(75.1,+$P(RACN0,"^",11),.1)),U)) 101 ; 102 ; OBR-36 = Exam Date/Time 103 S $P(HLA("HLS",3),HLFS,37)=$$FMTHL7^XLFDT(OBR36) 104 ; 105 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") 106 ; if long str, break so 2nd str begins with separator to avoid abend 107 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)="") 108 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" 109 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 110 OBXPRC ;Compile 'OBX' Segment for Procedure 111 S RAN=4 D OBXPRC^RAHLRU 112 OBXMOD ;Compile 'OBX' Segment for two types of Modifiers 113 S RAN=5 D OBXMOD^RAHLRU 114 OBXHIST ;Compile 'OBX' Segment for Clinical History 115 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_"None Entered" D OBX11^RAHLRU G ALLER 116 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 117 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 118 ALLER ;Compile 'OBX' Segment for Allergies 119 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_", " 120 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 121 OBXTCM ;Compile 'OBX' Segment for Tech Comment 122 D OBXTCM^RAHLRU 123 EXIT ; set HL7 message type & return to protocol 124 K ^UTILITY($J,"W") 125 S HL("MTN")="ORM" 126 N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP 127 S HLEID=EID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I" 128 D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX") 129 D:$D(RASSSX1(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX1") 130 D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP) 131 Q 132 Q ;Entry Point to Process an ORR Message (Just a Quit Since No Processing is Required) 133 Q 134 INIT ; initialize HL7 variables 135 D NOW^%DTC S HLDT=%,HLDT1=$$HLDATE^HLFNC(%) 136 ;Note: HLDT1 is used for HL7 fields: ORC-9 & OBR-22 137 Q:'$G(RAEID) S EID=RAEID 138 S HL="HLS(""HLS"")",INT=1 139 D INIT^HLFNC2(EID,.HL,INT) 140 Q:'$D(HL("Q")) ;no server application defined 141 S HLQ=HL("Q") 142 S HLECH=HL("ECH") 143 S HLFS=HL("FS") 144 S HLCS=$E(HL("ECH")) 145 S HLSCS=$E(HL("ECH"),4) 146 S HLREP=$E(HL("ECH"),2) 147 Q 1 RAHLR ;HISC/CAH/BNT - Generate Common Order (ORM) Message ;11/10/99 10:42 2 ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,71,82,75,80**;Mar 16, 1998;Build 19 3 ;Generates msg whenever a case is registered or cancelled or examined 4 ; registered cancelled examined 5 ; Order control : NW CA XO 6 ; Order status : IP CA CM 7 ;02/14/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R 8 S:$D(HLNDAP) ZTSAVE("HLNDAP")="" S:$D(HLDAP) ZTSAVE("HLDAP")="" S:$D(RAEXMDUN) ZTSAVE("RAEXMDUN")="" 9 S:$D(RAEXEDT) ZTSAVE("RAEXEDT")="" 10 S ZTSAVE("RADFN")="",ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTIO="",ZTDTH=$H,ZTDESC="Rad/Nuc Med Compiling HL7 Common Order",ZTRTN="EN^RAHLR" D ^%ZTLOAD 11 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE Q 12 EN ; Called from the RA REG & RA CANCEL & RA EXAMINED protocols 13 ; Input Variables: 14 ; RADFN=file 2 IEN (DFN) 15 ; RADTI=file 70 Exam subrec IEN (reverse date/time of exam) 16 ; RACNI=file 70 Case subrecord IEN 17 ; RAEID=ien of the event driver protocol (defined in RAHLRPC) 18 ; Output Variables: 19 ; HLA("HLS") array containing HL7 msg 20 ; 21 N EID,HL,INT,HLQ,HLFS,HLECH,HLA,HLCS,HLSCS,HLREP,HLECH 22 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 23 ; 24 D INIT ; initialize some HL7 variables 25 ;RAEXMDUN passed from EXM^RAHLRPC if conditions are met 26 Q:+$G(HL)=15 ;no known client(item) linked to the event driver protocol 27 Q:$O(HL(""))="" ;disabled server appl, or no server appl 28 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 29 ;I HL("VER")]2.3 D EN^RAHLR1(RADFN,RADTI,RACNI,RAEID) Q 30 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 31 S RACN0=$S($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)):^(0),1:"") Q:RACN0']"" 32 ;Generate Message Text 33 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 34 S RAPROCIT=+$P($G(^RAMIS(71,RAPROC,0)),U,12),RAPROCIT=$P(^RA(79.2,RAPROCIT,0),U,1) 35 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) 36 S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9),RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT) 37 ;RA*5*82 RAEXEDT= Override the EXM conditions if Case edited 38 I $G(RAEXMDUN)=1,'$G(RAEXEDT),$P(RACN0,U,30)'="" Q ;last chance to stop exm'd msg if it's already been sent 39 ;Compile 'PID' Segment 40 K VA,VADM,VAERR,RAVADM S DFN=RADFN D DEM^VADPT I VADM(1)']"" S HLP("ERRTEXT")="Invalid Patient Identifier" G EXIT 41 S RAVADM(3)=$S($E(+VADM(3),6,7)="00":"",1:+VADM(3)) ; NOTE: Check 42 ; for an inexact date of birth. If inexact, pass null for DOB in 43 ; the 'PID' segment. Some COTS systems can't handle inexact DOB's. 44 I HL("VER")']"2.2" D 45 .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") 46 .S:$P(VADM(2),"^")]"" $P(HLA("HLS",1),HLFS,20)=$P(VADM(2),"^") 47 I HL("VER")]"2.2" S HLA("HLS",1)=$$EN^VAFHLPID(DFN,"2,3,5,7,8,19,20") 48 K RAVADM 49 ;Compile 'ORC' Segment 50 S X0="" ;if exam-set or print-set, store parent name if order exists 51 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 52 ; BNT - Added ORC4 Placer Group Number for Printset identification. 53 ; ORC4 is a combination of SSN with the order inverted date/time. 54 S RAORC4="" I $P($G(RACN0),U,25)=2 D 55 . S:$P(VADM(2),"^")]"" RAORC4=$P(VADM(2),"^") 56 . S RAORC4=$G(RAORC4)_RADTI 57 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 58 K RAORC4 59 ;Compile 'OBR' Segment 60 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" 61 ; Replace above with following when Imaging can cope with ESC chars 62 ; 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" 63 I $P(RACPTNDE,U)']"" S $P(RAOBR4,$E(HLECH),1,3)=$P(RAOBR4,$E(HLECH),4,5)_$E(HLECH)_"LOCAL" 64 S HLA("HLS",3)="OBR"_HLFS_HLFS_RADTE_HLFS_RADTI_"-"_RACNI_$E(HLECH)_RADTE_$E(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_HLDT1 65 S HLA("HLS",3)=HLA("HLS",3)_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS_HLQ_HLFS_HLFS 66 S RAPRV=$$GET1^DIQ(200,+$P(RACN0,"^",14),.01) 67 S HLA("HLS",3)=HLA("HLS",3)_$S(RAPRV]"":+$P(RACN0,"^",14)_$E(HLECH)_$$HLNAME^HLFNC(RAPRV),1:"") 68 ; 69 N RACN00,RA20 S RACN00=$G(^RADPT(RADFN,"DT",RADTI,0)) 70 ;Seg's fld 20 = pce 21 --> ien file #79.1~name of img loc~stn #~stn name 71 S RA20=+$G(^RA(79.1,+$P(RACN00,U,4),0)) 72 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) 73 S $P(HLA("HLS",3),HLFS,21)=$P(HLA("HLS",3),HLFS,21) 74 ; Replace above with following when Imaging can cope with ESC chars 75 ; S $P(HLA("HLS",3),HLFS,21)=$$ESCAPE^RAHLRU($P(HLA("HLS",3),HLFS,21)) 76 ;Seg's fld 21 = pce 22 --> abbrv I-type~Img type name 77 S RA20=$G(^RA(79.2,+$P(RACN00,U,2),0)) 78 S $P(HLA("HLS",3),HLFS,22)=$P(RA20,U,3)_$E(HLECH)_$P(RA20,U) 79 S $P(HLA("HLS",3),HLFS,22)=$P(HLA("HLS",3),HLFS,22) 80 ; Replace above with following when Imaging can cope with ESC chars 81 ; S $P(HLA("HLS",3),HLFS,22)=$$ESCAPE^RAHLRU($P(HLA("HLS",3),HLFS,22)) 82 ; 83 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") 84 ; 85 ; OBR-31.2 = Reason for Study P75 86 S $P(HLA("HLS",3),HLFS,32)=$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RAO(75.1,+$P(RACN0,"^",11),.1)),U)) 87 ; 88 ; OBR-36 = Exam Date/Time 89 S $P(HLA("HLS",3),HLFS,37)=$$FMTHL7^XLFDT(OBR36) 90 ; 91 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") 92 ; if long str, break so 2nd str begins with separator to avoid abend 93 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)="") 94 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" 95 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 96 OBXPRC ;Compile 'OBX' Segment for Procedure 97 S RAN=4 D OBXPRC^RAHLRU 98 OBXMOD ;Compile 'OBX' Segment for two types of Modifiers 99 S RAN=5 D OBXMOD^RAHLRU 100 OBXHIST ;Compile 'OBX' Segment for Clinical History 101 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_"None Entered" D OBX11^RAHLRU G ALLER 102 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 103 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 104 ALLER ;Compile 'OBX' Segment for Allergies 105 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_", " 106 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 107 OBXTCM ;Compile 'OBX' Segment for Tech Comment 108 D OBXTCM^RAHLRU 109 EXIT ; set HL7 message type & return to protocol 110 K ^UTILITY($J,"W") 111 S HL("MTN")="ORM" 112 N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP 113 S HLEID=EID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I" 114 D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP) 115 D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP) 116 Q 117 Q ;Entry Point to Process an ORR Message (Just a Quit Since No Processing is Required) 118 Q 119 INIT ; initialize HL7 variables 120 D NOW^%DTC S HLDT=%,HLDT1=$$HLDATE^HLFNC(%) 121 Q:'$G(RAEID) S EID=RAEID 122 S HL="HLS(""HLS"")",INT=1 123 D INIT^HLFNC2(EID,.HL,INT) 124 Q:'$D(HL("Q")) ;no server application defined 125 S HLQ=HL("Q"),HLFS=HL("FS") 126 S HLECH=HL("ECH") 127 S HLFS=HL("FS") 128 S HLCS=$E(HL("ECH")) 129 S HLSCS=$E(HL("ECH"),4) 130 S HLREP=$E(HL("ECH"),2) 131 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPC.m
r613 r623 1 RAHLRPC ;HIRMFO/BNT-Rad/NM HL7 Protocol calls ;05/21/99 14:50 2 ;;5.0;Radiology/Nuclear Medicine;**12,25,54,71,82,81,84**;Mar 16, 1998;Build 13 3 ; 03/16/2006 *71 Rem Call 124379 allow exam updates to create HL7 msg 4 ; 5 ;Integration Agreements 6 ;---------------------- 7 ;$$FIND1^DIC(2051); GETS^DIQ(2056) 8 ;all access to ^ORD(101 to maintain application specific protocols(872) 9 ;read w/FileMan HL7 APPLICATION PARAMETER(10136) 10 ; 11 REG ; register exam 12 N X,RA101Z,RAEID 13 S RA101Z="RA REF" ; get all protocols beginning RA REG 14 F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA REG" D 15 .S RAEID=$O(^ORD(101,"B",RA101Z,0)) 16 .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR 17 Q 18 CANCEL ; cancel exam 19 N X,RA101Z,RAEID 20 S RA101Z="RA CANCEK" ; get all protocols beginning RA CANCEL 21 F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA CANCEL" D 22 .S RAEID=$O(^ORD(101,"B",RA101Z,0)) 23 .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR 24 Q 25 ; 26 RPT ; report verified or released/not verified 27 N X,RA101Z,RAEID,RASSS ; RASSS subcriber array to be passed to HLL for GENERATE^HLMA 28 ;S X="^%ET",@^%ZOSF("TRAP") 29 S RA101Z="RA RPS" ; get all protocols beginning RA RPT 30 F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA RPT" D 31 .S RAEID=$O(^ORD(101,"B",RA101Z,0)) K RASSS ; RA*5*81 32 .S:$L($G(RANOSEND)) RAEID=$$GETEID(RAEID,RANOSEND,.RASSS) ;RA*5*81 33 .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLRPT 34 K RANOSEND 35 Q 36 ; 37 EXM ;Examined case; called from RAUTL1 and RASTED after a case has been edited. 38 ; 39 ;Called from RAUTL1 and RASTED after a case's status is upgraded 40 ; and case's 30th piece is null 41 ; 42 ;If this new status is : 43 ; at a status (or higher than a status) where 44 ; GENERATE EXAMINED HL7 MSG = Y, 45 ; then : 46 ; 1. send an HL7 msg re this case having reached EXAMINED status 47 ; 2. set subfile 70.03's HL7 EXAMINED MSG SENT to Y 48 ; 49 ; RALOWER = next lower status 50 ; RANEWST = new status ien 51 ; RAEXEDT = Indication of editing of: proc, proc mod, req phys, CPT mod, Tech comm... 52 ; RAGENHL7 = Indication that sending ORU is due... 53 ; RASSSX1(IENs) = Array of subscribers from 771, the message will be sent (SCIMGE) 54 ; 55 N RAIMGTYI,RAIMGTYJ,RALOWER,RANEWST,RAEXMDUN,RAGENHL7,RASSSX1 56 S RAIMGTYI=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2),RAIMGTYJ=$P(^RA(79.2,RAIMGTYI,0),U),RANEWST=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3) 57 S:$P(^RA(72,RANEWST,0),U,8)="Y" RAGENHL7=1 ;this status has GEN HL7 marked Y 58 ; look thru lower statuses for GEN HL7 marked Y 59 DOWN S RALOWER=$P($G(^RA(72,+RANEWST,0)),U,3) 60 I '$G(RAGENHL7) F S RALOWER=$O(^RA(72,"AA",RAIMGTYJ,RALOWER),-1) Q:RALOWER<1 S:$P(^RA(72,+$O(^RA(72,"AA",RAIMGTYJ,RALOWER,0)),0),U,8)="Y" RAGENHL7=1 61 ;?? none of the lower status levels have GEN HL7 marked Y 62 K:$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y" RAGENHL7 ;already sent 63 ;Q:'$G(RAEXEDT)&'$G(RAGENHL7) 64 ; Business Rule: RA*5*84 sends an examined message to ScImage unconditionally 65 I '$G(RAEXEDT),'$G(RAGENHL7) Q:'$O(^RA(79.7,0)) D Q:'$O(RASSSX1(0)) 66 .N X,RASSS,RASSSL S X=0 F S X=$O(^RA(79.7,X)) Q:'X S:$P(^(X,0),U,2) RASSS(X)="" 67 .D:$D(RASSS) GETSUB^RAHLRS1(.RASSS,.RASSSX1,.RASSSL) 68 1 N RAEXMDUN 69 S RAEXMDUN=1 70 A1 N X,RA101Z,RAEID 71 S RA101Z="RA EXAMINEC" ; get all protocols beginning RA EXAMINED 72 F S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA EXAMINED" D 73 .N RAGENHL7 S RAEID=$O(^ORD(101,"B",RA101Z,0)) 74 .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR 75 S:$G(RAGENHL7) $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y" 76 Q 77 ; 78 GETEID(RAEID,RANOSEND,RASSS) ; RA*5*81 Return RAEID or 0 (zero) = for future use. 79 ; RAEID = IEN of regular Event driver 80 ; RANOSEND Application name or IEN from 771 file.. don't send message to Subcr. with this application. 81 ; RASSS Array of subcribers (IENs) associated with RANOSEND application 82 ; 0 (zero) returned if No subscriber exist or all subscribers associated with RANOSEND application. 83 S RAEID=$G(RAEID) Q:'RAEID!'$L($G(RANOSEND))!'$D(^ORD(101,+RAEID,0)) RAEID 84 N RAXX,ERR,X1,Y1,YY,RAPL,RANEW,RAPIDS,RAIEDS,DIERR,RAERR 85 S RAPL=$S(+RANOSEND:+RANOSEND,1:$$FIND1^DIC(771,"","X",RANOSEND,"","","RAERR")) 86 Q:'RAPL!($D(RAERR)#2) RAEID 87 D GETS^DIQ(101,RAEID_",","**","I","RAXX","ERR") 88 Q:$D(ERR) RAEID ; Was not able get Event driver info... so just pass event driver... 89 Q:'$D(RAXX(101.0775)) 0 ;No subcribers exist for Event driver 90 S X1="",RANEW=0,Y1=0 F S X1=$O(RAXX(101.0775,X1)) Q:'$L(X1) D 91 .S YY=$G(RAXX(101.0775,X1,.01,"I")) 92 .I $P($G(^ORD(101,+YY,770)),U,2)=RAPL D Q 93 ..S Y1=Y1+1,RASSS("EXCLUDE SUBSCRIBER",Y1)=YY ;Y1= 1,2,3... 94 .S RANEW=1 95 Q:'RANEW 0 ;All subscribers are associated with application RANOSEND.. Don't send the message. 96 Q RAEID 1 RAHLRPC ;HIRMFO/BNT-Rad/NM HL7 Protocol calls ;05/21/99 14:50 2 ;;5.0;Radiology/Nuclear Medicine;**12,25,54,71,82,81**;Mar 16, 1998;Build 12 3 ; 03/16/2006 *71 Rem Call 124379 allow exam updates to create HL7 msg 4 REG ; register exam 5 N X,RAPID,RAEID 6 S RAPID="RA REF" ; get all protocols beginning RA REG 7 F S RAPID=$O(^ORD(101,"B",RAPID)) Q:RAPID'["RA REG" D 8 .S RAEID=$O(^ORD(101,"B",RAPID,0)) 9 .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR 10 Q 11 CANCEL ; cancel exam 12 N X,RAPID,RAEID 13 S RAPID="RA CANCEK" ; get all protocols beginning RA CANCEL 14 F S RAPID=$O(^ORD(101,"B",RAPID)) Q:RAPID'["RA CANCEL" D 15 .S RAEID=$O(^ORD(101,"B",RAPID,0)) 16 .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR 17 Q 18 ; 19 RPT ; report verified or released/not verified 20 N X,RAPID,RAEID,RASSS ; RASSS subcriber array to be passed to HLL for GENERATE^HLMA 21 ;S X="^%ET",@^%ZOSF("TRAP") 22 S RAPID="RA RPS" ; get all protocols beginning RA RPT 23 F S RAPID=$O(^ORD(101,"B",RAPID)) Q:RAPID'["RA RPT" D 24 .S RAEID=$O(^ORD(101,"B",RAPID,0)) K RASSS ; RA*5*81 25 .S:$L($G(RANOSEND)) RAEID=$$GETEID(RAEID,RANOSEND,.RASSS) ;RA*5*81 26 .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLRPT 27 K RANOSEND 28 Q 29 ; 30 EXM ;Examined case; called from RAUTL1 and RASTED after a case has been edited. 31 ; 32 ;Called from RAUTL1 and RASTED after a case's status is upgraded 33 ; and case's 30th piece is null 34 ; 35 ;If this new status is : 36 ; at a status (or higher than a status) where 37 ; GENERATE EXAMINED HL7 MSG = Y, 38 ; then : 39 ; 1. send an HL7 msg re this case having reached EXAMINED status 40 ; 2. set subfile 70.03's HL7 EXAMINED MSG SENT to Y 41 ; 42 ; RALOWER = next lower status 43 ; RANEWST = new status ien 44 ; RAEXEDT = Indication of editing of: proc, proc mod, req phys, CPT mod, Tech comm... 45 ; RAGENHL7 = Indication that sending ORU is due... 46 ; 47 N RAIMGTYI,RAIMGTYJ,RALOWER,RANEWST,RAEXMDUN,RAGENHL7 48 S RAIMGTYI=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2),RAIMGTYJ=$P(^RA(79.2,RAIMGTYI,0),U),RANEWST=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3) 49 S:$P(^RA(72,RANEWST,0),U,8)="Y" RAGENHL7=1 ;this status has GEN HL7 marked Y 50 ; look thru lower statuses for GEN HL7 marked Y 51 DOWN S RALOWER=$P($G(^RA(72,+RANEWST,0)),U,3) 52 I '$G(RAGENHL7) F S RALOWER=$O(^RA(72,"AA",RAIMGTYJ,RALOWER),-1) Q:RALOWER<1 S:$P(^RA(72,+$O(^RA(72,"AA",RAIMGTYJ,RALOWER,0)),0),U,8)="Y" RAGENHL7=1 53 ;?? none of the lower status levels have GEN HL7 marked Y 54 K:$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y" RAGENHL7 ;already sent 55 Q:'$G(RAEXEDT)&'$G(RAGENHL7) 56 ; 57 1 N RAEXMDUN 58 S RAEXMDUN=1 59 A1 N X,RAPID,RAEID 60 S RAPID="RA EXAMINEC" ; get all protocols beginning RA EXAMINED 61 F S RAPID=$O(^ORD(101,"B",RAPID)) Q:RAPID'["RA EXAMINED" D 62 .N RAGENHL7 S RAEID=$O(^ORD(101,"B",RAPID,0)) 63 .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR 64 S:$G(RAGENHL7) $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y" 65 Q 66 ; 67 GETEID(RAEID,RANOSEND,RASSS) ; RA*5*81 Return RAEID or 0 (zero) = for future use. 68 ; RAEID = IEN of regular Event driver 69 ; RANOSEND Application name or IEN from 771 file.. don't send message to Subcr. with this application. 70 ; RASSS Array of subcribers (IENs) associated with RANOSEND application 71 ; 0 (zero) returned if No subscriber exist or all subscribers associated with RANOSEND application. 72 S RAEID=$G(RAEID) Q:'RAEID!'$L($G(RANOSEND))!'$D(^ORD(101,+RAEID,0)) RAEID 73 N RAXX,ERR,X1,Y1,YY,RAPL,RANEW,RAPIDS,RAIEDS 74 S RAPL=$S(+RANOSEND:+RANOSEND,1:$O(^HL(771,"B",RANOSEND,0))) Q:'RAPL RAEID 75 D GETS^DIQ(101,RAEID_",","**","I","RAXX","ERR") 76 Q:$D(ERR) RAEID ; Was not able get Event driver info... so just pass event driver... 77 Q:'$D(RAXX(101.0775)) 0 ;No subcribers exist for Event driver 78 S X1="",RANEW=0,Y1=0 F S X1=$O(RAXX(101.0775,X1)) Q:'$L(X1) D 79 .S YY=$G(RAXX(101.0775,X1,.01,"I")) 80 .I $P($G(^ORD(101,+YY,770)),U,2)=RAPL D Q 81 ..S Y1=Y1+1,RASSS("EXCLUDE SUBSCRIBER",Y1)=YY ;Y1= 1,2,3... 82 .S RANEW=1 83 Q:'RANEW 0 ;All subscribers are associated with application RANOSEND.. Don't send the message. 84 Q RAEID -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPT.m
r613 r623 1 RAHLRPT ;HISC/CAH AISC/SAW-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am 2 ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,81,80,84**;Mar 16, 1998;Build 13 3 EN ; Called from RA RPT and RA RPT 2.3 protocol entry action 4 ; Input variables: 5 ; RADFN=file 2 IEN (DFN) 6 ; RADTI=file 70 Exam subrecord IEN (reverse date/time) 7 ; RACNI=file 70 Case subrecord IEN 8 ; RARPT=file 74 Report IEN 9 ; RASSS=List of Subscribers passed into GENERATE^HLMA will be set into HLP array. 10 ; Output variables: 11 ; HLA("HLS", array containing HL7 msg 12 ; RATELREL = 1 Indicates that the text: 'Released for local dictation by National Teleradiology' 13 ; has been included in Impression or Report section 14 ; RATELX = Text used as indication of Release for local dictation... if not set use defauld above... 15 ; RATELE = 1 If RANOSEND is Teleradiology type vendor 16 ; 17 ;Integration Agreements 18 ;---------------------- 19 ;$$GET1^DIQ(2056); ^DIWP(10011); $$HLDATE/$$HLNAME^HLFNC(10106) 20 ;GENERATE^HLMA(2164); DEM^VADPT(10061); $$FMTHL7^XLFDT(10103) 21 ;$$PATCH^XPDUTL(10141); $$VERSION^XPDUTL(10141) 22 ; 23 N RASET,RACN0,RATELE,RATELREL,RATELX 24 D INIT^RAHLRPTT ;Patch 84 25 I +$P(RACN0,U,25)=2 D Q ; printset 26 .; loop through all cases in set and create message 27 .S RASET=1 28 .N RACNI,RAII S RAII=0 29 .F S RAII=$O(^RADPT(RADFN,"DT",RADTI,"P",RAII)) Q:RAII'>0 D 30 .. Q:$P(^RADPT(RADFN,"DT",RADTI,"P",RAII,0),U,25)'=2 31 .. S RACNI=RAII 32 .. D NEW 33 NEW ; new variables 34 S:$D(ZTQUEUED) ZTREQ="@" ; delete task from task global 35 N DFN,DIWF,DIWL,DIWR,RACPT,RACPTNDE,RADTECN,RADTE0,RADTV,RAI,RAN,RAOBR4,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RARPT0 36 N VADM,VAERR,X,X1,X2,XX2,Y,X0,OBR36,EID,HL,INT,HLQ,HLFS,HLECH,HLA,RAN K RAVADM 37 D INIT^RAHLRU ;initialize HL7 variables 38 Q:+$G(HL)=15 ;no known client(item) linked to the event driver protocol 39 Q:$O(HL(""))="" ;failed return from INIT^HLFNC2 (called by INIT^RAHLRU) 40 ; 41 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 42 I HL("VER")>2.3,($T(^RAHLRPT1))'="" D EN^RAHLRPT1(RADFN,RADTI,RACNI,RAEID),EXIT Q 43 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 44 ; 45 S DFN=RADFN D DEM^VADPT 46 I VADM(1)']"" S HLP("ERRTEXT")="Invalid Patient Identifier" G EXIT 47 S RAN=0 48 S RAVADM(3)=$S($E(+VADM(3),6,7)="00":"",1:+VADM(3)) ; NOTE: Check 49 ; for an inexact date of birth. If inexact, pass null for DOB in 50 ; the 'PID' segment. Some COTS systems can't handle inexact DOB's. 51 D SETUP^RAHLRPTT,PID^RAHLRPTT,OBR,OBXPRC,OBXIMP,OBXDIA,OBXRPT,OBXMOD,OBXTCM 52 EXIT ; set HL7 message type & return to RA RPT protocol 53 ;For P84 see if this is a >>Released for local reading<< type report and if yes resend the ORM (^RAHLRS1)... 54 I $G(RATELREL) D RESEND^RAHLRPTT(RADFN,RADTI,RACNI) Q ;P84 resend in the case that report released from Telerad 55 S HL("MTN")="ORU" 56 N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP 57 S HLEID=RAEID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I" 58 M:$D(RASSS) HLP=RASSS 59 D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX") 60 D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP) 61 K RAVADM 62 Q 63 ; 64 OBR ;Compile 'OBR' Segment 65 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" 66 ; Replace above with following when Imaging can cope with ESC chars 67 ; 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" 68 ; Have to use LOCAL code if Broad Procedure - no CPT code 69 I $P(RAOBR4,$E(HLECH))=""!($P(RAOBR4,$E(HLECH),2)="") S $P(RAOBR4,$E(HLECH),1,3)=$P(RAOBR4,$E(HLECH),4,5)_$E(HLECH)_"LOCAL" 70 S X1="OBR"_HLFS_HLFS_HLFS_RADTI_"-"_RACNI_$E(HLECH)_RADTECN_$E(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_RADTE0_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS,Y=$$HLDATE^HLFNC($P(RARPT0,"^",6)) S X1=X1_Y_HLFS_HLFS 71 S RAPRV=$$GET1^DIQ(200,+$P(RACN0,"^",14),.01) 72 S Y=$$HLNAME^HLFNC(RAPRV) S X1=X1_$S(Y]"":+$P(RACN0,"^",14)_$E(HLECH)_Y,1:"") 73 S $P(X1,HLFS,19)=$S($D(^DIC(42,+$P(RACN0,"^",6),0)):$P(^(0),"^"),$D(^SC(+$P(RACN0,"^",8),0)):$P(^(0),"^"),1:"Unknown") 74 ; PCE 21 -> ien file #79.1~name of img loc~stn #~stn name 75 N RACN00,RA20 S RACN00=$G(^RADPT(RADFN,"DT",RADTI,0)) 76 S RA20=+$G(^RA(79.1,+$P(RACN00,U,4),0)) 77 S $P(X1,HLFS,21)=$P(RACN00,"^",4)_$E(HLECH)_$P($G(^SC(RA20,0)),"^")_$E(HLECH)_$P(RACN00,"^",3)_$E(HLECH)_$P($G(^DIC(4,$P(RACN00,U,3),0)),"^") 78 S $P(X1,HLFS,21)=$P(X1,HLFS,21) 79 ; Replace above with following when Imaging can cope with ESC chars 80 ; S $P(X1,HLFS,21)=$$ESCAPE^RAHLRU($P(X1,HLFS,21)) 81 ; 82 S OBR36=9999999.9999-RADTI 83 S $P(X1,HLFS,37)=$$FMTHL7^XLFDT(OBR36) 84 ; 85 S RADTV=HLDT1 I $P(RARPT0,"^",5)="V",$P(RARPT0,"^",7) K RADTV S RADTV=$$HLDATE^HLFNC($P(RARPT0,"^",7)) 86 S $P(X1,HLFS,23)=RADTV,$P(X1,HLFS,26)=$S($P(RARPT0,"^",5)="V":"F",1:"R") 87 ;Principal Result Interpreter = Verifying Physician 88 S $P(X1,HLFS,33)="" I $P(RARPT0,"^",9) D 89 .S X2=$$GET1^DIQ(200,$P(RARPT0,"^",9),.01) Q:X2']"" 90 .S Y=$$HLNAME^HLFNC(X2) Q:Y']"" 91 .S $P(X1,HLFS,33)=$P(RARPT0,"^",9)_$E(HLECH)_Y 92 ;Assistant Result Interpreter = Primary Interpreting Staff OR Resident 93 S $P(X1,HLFS,34)="" I $P(RACN0,"^",15) D 94 .S X2=$$GET1^DIQ(200,$P(RACN0,"^",15),.01) Q:X2']"" 95 .S Y=$$HLNAME^HLFNC(X2) Q:Y']"" 96 .S $P(X1,HLFS,34)=$P(RACN0,"^",15)_$E(HLECH)_Y 97 I $P(RACN0,"^",12) D 98 .S X2=$$GET1^DIQ(200,$P(RACN0,"^",12),.01) Q:X2']"" 99 .S Y=$$HLNAME^HLFNC(X2) Q:Y']"" 100 .S $P(X1,HLFS,34)=$P(RACN0,"^",12)_$E(HLECH)_Y 101 ;Technician = Technologist 102 S $P(X1,HLFS,35)="" I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) D 103 .S X2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) I X2']"" Q 104 .S X2=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",X2,0)),"^",1) I X2']"" Q 105 .S XX2=$$GET1^DIQ(200,X2,.01) Q:XX2']"" 106 .S Y=$$HLNAME^HLFNC(XX2) I Y']"" Q 107 .S $P(X1,HLFS,35)=X2_$E(HLECH)_Y 108 ;Transcriptionist 109 S $P(X1,HLFS,36)="" I $G(^RARPT(RARPT,"T")) D 110 .S X2=$$GET1^DIQ(200,$P(^RARPT(RARPT,"T"),"^",1),.01) I X2']"" Q 111 .S Y=$$HLNAME^HLFNC(X2) I Y']"" Q 112 .S $P(X1,HLFS,36)=^RARPT(RARPT,"T")_$E(HLECH)_Y 113 ; 114 ; if long str, break so 2nd str begins with separator to avoid abend 115 N RAPART I $L(X1)>245 F RAPART=5:1:18 S RAPART(1)=$P(X1,HLFS,1,RAPART),RAPART(2)=$P(X1,HLFS,RAPART+1,99) Q:$L(RAPART(1))<245&($L(RAPART(2))<245)&($P(RAPART(2),HLFS)="") 116 I $D(RAPART) K:RAPART=18 RAPART ;if RAPART reaches 18, then something's wrong, so kill RAPART to allow abend due "string too long" 117 S RAN=RAN+1 118 I $D(RAPART) S HLA("HLS",RAN)=$P(RAPART(1),HLFS)_HLFS,HLA("HLS",RAN,1)=$P(RAPART(1),HLFS,2,99)_HLFS,HLA("HLS",RAN,2)=RAPART(2) K RAPART Q 119 S HLA("HLS",RAN)=X1 120 Q 121 OBXDIA ;Compile 'OBX' Segment for Diagnostic Code 122 S RAI=$P($G(^RA(78.3,+$P(RACN0,"^",13),0)),"^") I RAI]"" D 123 .S RAN=RAN+1 124 .I $$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5) D 125 ..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_+$P(RACN0,"^",13)_$E(HLECH)_RAI_$E(HLECH)_"L" 126 ..; Replace above with following when Imaging can cope with ESC chars 127 ..; S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_+$P(RACN0,"^",13)_$E(HLECH)_$$ESCAPE^RAHLRU(RAI)_$E(HLECH)_"L" 128 .E D 129 ..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"ST"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_RAI 130 .D OBX11^RAHLRU 131 Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) ;any secondary dx 132 S X2=0 133 OBXDIA2 S X2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",X2)) Q:'X2 134 S Y=+^(X2,0),X=$P($G(^RA(78.3,+Y,0)),U) 135 I X]"" D 136 .S RAN=RAN+1 137 .I $$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5) D 138 ..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_Y_$E(HLECH)_X_$E(HLECH)_"L" 139 ..; Replace above with following when Imaging can cope with ESC chars 140 ..; S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_Y_$E(HLECH)_$$ESCAPE^RAHLRU(X)_$E(HLECH)_"L" 141 .E D 142 ..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"ST"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_X 143 .D OBX11^RAHLRU 144 G OBXDIA2 145 ; 146 OBXIMP ;Compile 'OBX' segment for Impression 147 I '$O(^RARPT(RARPT,"I",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L"_HLFS_HLFS_"None Entered" D OBX11^RAHLRU Q 148 K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1 149 F RAI=0:0 S RAI=$O(^RARPT(RARPT,"I",RAI)) Q:'RAI I $D(^(RAI,0)) S X=^(0) D RATELREL,^DIWP 150 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_"I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU 151 Q 152 OBXMOD ;Compile 'OBX' Segment for Modifiers 153 S RAN=RAN+1 D OBXMOD^RAHLRU 154 Q 155 OBXPRC ;Compile 'OBX' Segment for Procedure 156 S RAN=RAN+1 D OBXPRC^RAHLRU 157 Q 158 OBXTCM ;Compile 'OBX' Segment for Tech Comments 159 D OBXTCM^RAHLRU 160 Q 161 OBXRPT ;Compile 'OBX' Segment for Radiology Report Text 162 I '$O(^RARPT(RARPT,"R",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_"None Entered" D OBX11^RAHLRU Q 163 K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1 164 F RAI=0:0 S RAI=$O(^RARPT(RARPT,"R",RAI)) Q:'RAI I $D(^(RAI,0)) S X=^(0) D RATELREL,^DIWP 165 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_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU 166 ; Replace above with following when Imaging can cope with ESC chars 167 ; 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_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_$$ESCAPE^RAHLRU(^(0)) D OBX11^RAHLRU 168 Q 169 RATELREL ;Release the study for local reading 170 I $G(RATELE),X[$G(RATELX) S RATELREL=1 Q 171 ; 1 RAHLRPT ;HISC/CAH AISC/SAW-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am 2 ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,81,80**;Mar 16, 1998;Build 19 3 EN ; Called from RA RPT and RA RPT 2.3 protocol entry action 4 ; Input variables: 5 ; RADFN=file 2 IEN (DFN) 6 ; RADTI=file 70 Exam subrecord IEN (reverse date/time) 7 ; RACNI=file 70 Case subrecord IEN 8 ; RARPT=file 74 Report IEN 9 ; RASSS=List of Subscribers passed into GENERATE^HLMA will be set into HLP array. 10 ; Output variables: 11 ; HLA("HLS", array containing HL7 msg 12 ; 13 N RASET,RACN0 14 S RASET=0 15 S RACN0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) 16 S:'$D(RARPT) RARPT=+$P(RACN0,"^",17) 17 I +$P(RACN0,U,25)=2 D Q ; printset 18 .; loop through all cases in set and create message 19 .S RASET=1 20 .N RACNI,RAII S RAII=0 21 .F S RAII=$O(^RADPT(RADFN,"DT",RADTI,"P",RAII)) Q:RAII'>0 D 22 .. Q:$P(^RADPT(RADFN,"DT",RADTI,"P",RAII,0),U,25)'=2 23 .. S RACNI=RAII 24 .. D NEW 25 NEW ; new variables 26 S:$D(ZTQUEUED) ZTREQ="@" ; delete task from task global 27 N DFN,DIWF,DIWL,DIWR,RACPT,RACPTNDE,RADTECN,RADTE0,RADTV,RAI,RAN,RAOBR4,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RARPT0 28 N VADM,VAERR,X,X1,X2,XX2,Y,X0,OBR36,EID,HL,INT,HLQ,HLFS,HLECH,HLA,RAN K RAVADM 29 D INIT^RAHLRU ;initialize HL7 variables 30 Q:+$G(HL)=15 ;no known client(item) linked to the event driver protocol 31 Q:$O(HL(""))="" ;failed return from init^hlfnc2 32 ; 33 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 34 ;I HL("VER")]2.3 D EN^RAHLRPT1(RADFN,RADTI,RACNI,RAEID),EXIT Q 35 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 36 ; 37 S DFN=RADFN D DEM^VADPT 38 I VADM(1)']"" S HLP("ERRTEXT")="Invalid Patient Identifier" G EXIT 39 S RAN=0 40 S RAVADM(3)=$S($E(+VADM(3),6,7)="00":"",1:+VADM(3)) ; NOTE: Check 41 ; for an inexact date of birth. If inexact, pass null for DOB in 42 ; the 'PID' segment. Some COTS systems can't handle inexact DOB's. 43 D SETUP,PID,OBR,OBXPRC,OBXIMP,OBXDIA,OBXRPT,OBXMOD,OBXTCM 44 EXIT ; set HL7 message type & return to RA RPT protocol 45 S HL("MTN")="ORU" 46 N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP 47 S HLEID=RAEID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I" 48 M:$D(RASSS) HLP=RASSS 49 D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP) 50 D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP) 51 K RAVADM 52 Q 53 ; 54 OBR ;Compile 'OBR' Segment 55 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" 56 ; Replace above with following when Imaging can cope with ESC chars 57 ; 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" 58 ; Have to use LOCAL code if Broad Procedure - no CPT code 59 I $P(RAOBR4,$E(HLECH))=""!($P(RAOBR4,$E(HLECH),2)="") S $P(RAOBR4,$E(HLECH),1,3)=$P(RAOBR4,$E(HLECH),4,5)_$E(HLECH)_"LOCAL" 60 S X1="OBR"_HLFS_HLFS_HLFS_RADTI_"-"_RACNI_$E(HLECH)_RADTECN_$E(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_RADTE0_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS,Y=$$HLDATE^HLFNC($P(RARPT0,"^",6)) S X1=X1_Y_HLFS_HLFS 61 S RAPRV=$$GET1^DIQ(200,+$P(RACN0,"^",14),.01) 62 S Y=$$HLNAME^HLFNC(RAPRV) S X1=X1_$S(Y]"":+$P(RACN0,"^",14)_$E(HLECH)_Y,1:"") 63 S $P(X1,HLFS,19)=$S($D(^DIC(42,+$P(RACN0,"^",6),0)):$P(^(0),"^"),$D(^SC(+$P(RACN0,"^",8),0)):$P(^(0),"^"),1:"Unknown") 64 ; PCE 21 -> ien file #79.1~name of img loc~stn #~stn name 65 N RACN00,RA20 S RACN00=$G(^RADPT(RADFN,"DT",RADTI,0)) 66 S RA20=+$G(^RA(79.1,+$P(RACN00,U,4),0)) 67 S $P(X1,HLFS,21)=$P(RACN00,"^",4)_$E(HLECH)_$P($G(^SC(RA20,0)),"^")_$E(HLECH)_$P(RACN00,"^",3)_$E(HLECH)_$P($G(^DIC(4,$P(RACN00,U,3),0)),"^") 68 S $P(X1,HLFS,21)=$P(X1,HLFS,21) 69 ; Replace above with following when Imaging can cope with ESC chars 70 ; S $P(X1,HLFS,21)=$$ESCAPE^RAHLRU($P(X1,HLFS,21)) 71 ; 72 S OBR36=9999999.9999-RADTI 73 S $P(X1,HLFS,37)=$$FMTHL7^XLFDT(OBR36) 74 ; 75 S RADTV=HLDT1 I $P(RARPT0,"^",5)="V",$P(RARPT0,"^",7) K RADTV S RADTV=$$HLDATE^HLFNC($P(RARPT0,"^",7)) 76 S $P(X1,HLFS,23)=RADTV,$P(X1,HLFS,26)=$S($P(RARPT0,"^",5)="V":"F",1:"R") 77 ;Principal Result Interpreter = Verifying Physician 78 S $P(X1,HLFS,33)="" I $P(RARPT0,"^",9) D 79 .S X2=$$GET1^DIQ(200,$P(RARPT0,"^",9),.01) Q:X2']"" 80 .S Y=$$HLNAME^HLFNC(X2) Q:Y']"" 81 .S $P(X1,HLFS,33)=$P(RARPT0,"^",9)_$E(HLECH)_Y 82 ;Assistant Result Interpreter = Primary Interpreting Staff OR Resident 83 S $P(X1,HLFS,34)="" I $P(RACN0,"^",15) D 84 .S X2=$$GET1^DIQ(200,$P(RACN0,"^",15),.01) Q:X2']"" 85 .S Y=$$HLNAME^HLFNC(X2) Q:Y']"" 86 .S $P(X1,HLFS,34)=$P(RACN0,"^",15)_$E(HLECH)_Y 87 I $P(RACN0,"^",12) D 88 .S X2=$$GET1^DIQ(200,$P(RACN0,"^",12),.01) Q:X2']"" 89 .S Y=$$HLNAME^HLFNC(X2) Q:Y']"" 90 .S $P(X1,HLFS,34)=$P(RACN0,"^",12)_$E(HLECH)_Y 91 ;Technician = Technologist 92 S $P(X1,HLFS,35)="" I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) D 93 .S X2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) I X2']"" Q 94 .S X2=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",X2,0)) I X2']"" Q 95 .S XX2=$$GET1^DIQ(200,X2,.01) Q:XX2']"" 96 .S Y=$$HLNAME^HLFNC(XX2) I Y']"" Q 97 .S $P(X1,HLFS,35)=X2_$E(HLECH)_Y 98 ;Transcriptionist 99 S $P(X1,HLFS,36)="" I $G(^RARPT(RARPT,"T")) D 100 .S X2=$$GET1^DIQ(200,^RARPT(RARPT,"T"),.01) I X2']"" Q 101 .S Y=$$HLNAME^HLFNC(X2) I Y']"" Q 102 .S $P(X1,HLFS,36)=^RARPT(RARPT,"T")_$E(HLECH)_Y 103 ; 104 ; if long str, break so 2nd str begins with separator to avoid abend 105 I $L(X1)>245 N RAPART F RAPART=5:1:18 S RAPART(1)=$P(X1,HLFS,1,RAPART),RAPART(2)=$P(X1,HLFS,RAPART+1,99) Q:$L(RAPART(1))<245&($L(RAPART(2))<245)&($P(RAPART(2),HLFS)="") 106 I $D(RAPART) K:RAPART=18 RAPART ;if RAPART reaches 18, then something's wrong, so kill RAPART to allow abend due "string too long" 107 S RAN=RAN+1 108 I $D(RAPART) S HLA("HLS",RAN)=$P(RAPART(1),HLFS)_HLFS,HLA("HLS",RAN,1)=$P(RAPART(1),HLFS,2,99)_HLFS,HLA("HLS",RAN,2)=RAPART(2) K RAPART Q 109 S HLA("HLS",RAN)=X1 110 Q 111 OBXDIA ;Compile 'OBX' Segment for Diagnostic Code 112 S RAI=$P($G(^RA(78.3,+$P(RACN0,"^",13),0)),"^") I RAI]"" D 113 .S RAN=RAN+1 114 .I $$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5) D 115 ..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_+$P(RACN0,"^",13)_$E(HLECH)_RAI_$E(HLECH)_"L" 116 ..; Replace above with following when Imaging can cope with ESC chars 117 ..; S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_+$P(RACN0,"^",13)_$E(HLECH)_$$ESCAPE^RAHLRU(RAI)_$E(HLECH)_"L" 118 .E D 119 ..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"ST"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_RAI 120 .D OBX11^RAHLRU 121 Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) ;any secondary dx 122 S X2=0 123 OBXDIA2 S X2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",X2)) Q:'X2 124 S Y=+^(X2,0),X=$P($G(^RA(78.3,+Y,0)),U) 125 I X]"" D 126 .S RAN=RAN+1 127 .I $$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5) D 128 ..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_Y_$E(HLECH)_X_$E(HLECH)_"L" 129 ..; Replace above with following when Imaging can cope with ESC chars 130 ..; S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_Y_$E(HLECH)_$$ESCAPE^RAHLRU(X)_$E(HLECH)_"L" 131 .E D 132 ..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"ST"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_X 133 .D OBX11^RAHLRU 134 G OBXDIA2 135 ; 136 OBXIMP ;Compile 'OBX' segment for Impression 137 I '$O(^RARPT(RARPT,"I",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L"_HLFS_HLFS_"None Entered" D OBX11^RAHLRU Q 138 K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1 F RAI=0:0 S RAI=$O(^RARPT(RARPT,"I",RAI)) Q:'RAI I $D(^(RAI,0)) S X=^(0) D ^DIWP 139 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_"I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU 140 Q 141 OBXMOD ;Compile 'OBX' Segment for Modifiers 142 S RAN=RAN+1 D OBXMOD^RAHLRU 143 Q 144 OBXPRC ;Compile 'OBX' Segment for Procedure 145 S RAN=RAN+1 D OBXPRC^RAHLRU 146 Q 147 OBXTCM ; Compile 'OBX' Segment for Tech Comments 148 D OBXTCM^RAHLRU 149 Q 150 OBXRPT ;Compile 'OBX' Segment for Radiology Report Text 151 I '$O(^RARPT(RARPT,"R",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_"None Entered" D OBX11^RAHLRU Q 152 K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1 F RAI=0:0 S RAI=$O(^RARPT(RARPT,"R",RAI)) Q:'RAI I $D(^(RAI,0)) S X=^(0) D ^DIWP 153 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_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU 154 ; Replace above with following when Imaging can cope with ESC chars 155 ; 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_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_$$ESCAPE^RAHLRU(^(0)) D OBX11^RAHLRU 156 Q 157 PID ;Compile 'PID' Segment 158 I HL("VER")']"2.2" D 159 .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 160 .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 161 I HL("VER")]"2.2" S RAN=RAN+1,HLA("HLS",RAN)=$$EN^VAFHLPID(DFN,"2,3,5,7,8,19,20") 162 Q 163 SETUP ; Setup basic examination information 164 S:RASET RACN0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) 165 S RADTE0=9999999.9999-RADTI,RADTECN=$E(RADTE0,4,7)_$E(RADTE0,2,3)_"-"_+RACN0,RARPT0=^RARPT(RARPT,0) 166 S RAPROC=+$P(RACN0,U,2),RAPROCIT=+$P($G(^RAMIS(71,RAPROC,0)),U,12),RAPROCIT=$P(^RA(79.2,RAPROCIT,0),U,1) 167 S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9) 168 S RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT) 169 S Y=$$HLDATE^HLFNC(RADTE0) S RADTE0=$S(Y:Y,1:HLQ),Y=$$M11^HLFNC(RADFN) 170 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRS1.m
r613 r623 1 RAHLRS1 ;HIRMFO/ROB/PAVEL - Resend HL7 messages for selected Timeframe ; 4/2/07 3:42pm 2 ;;5.0;Radiology/Nuclear Medicine;**80,84**;Mar 16, 1998;Build 13 3 ; Utility to RESEND HL7 messages for selected Timeframe 4 ; 5 ;Integration Agreements 6 ;---------------------- 7 ;^%DT(10003); C^%DTC(10000); H^%DTC(10000); ^%ZISC(10089); ^%ZTLOAD(10063); $$GET1^DIQ(2056) 8 ;^DIR(10026); ^XMD(10070) 9 ;all access to ^ORD(101 to maintain application specific protocols(872) 10 ;read w/FileMan HL7 APPLICATION PARAMETER(10136) 11 ; 12 N RACNI,RADFN,RADTI,RARPT,X,RAED,RABD,RASHBD,RASHED,RASHTD,RASHTM,DIC,DA,XX,YY 13 N RALOCK,RASSS,RASSSX,RASSSL,I,X S RALOCK=0 14 CHECK ; 15 D SETVARS Q:$G(RAIMGTY)="" 16 W !!,"This option re-sends HL7 messages for a date range and for designated Recipients.",! 17 W !,"It is strongly recommended you task this to run off hours.",!! 18 S:'$D(U) U="^" S:'$D(DTIME) DTIME=9999 19 1 W ! K %DT S %DT="AEX",%DT("A")="Beginning Date: " D ^%DT 20 G:Y<0!($D(DTOUT))!($D(DUOUT)) STOP 21 S RABD=Y 22 X ^DD("DD") S RASHBD=Y 23 S X1=RABD,X2=-1 D C^%DTC S RABD=X 24 S RABD=RABD_"."_9999 25 ; 26 W ! K %DT S %DT="AEX",%DT("A")="Ending Date: ",%DT("B")="NOW" D ^%DT 27 G:Y<0!($D(DTOUT))!($D(DUOUT)) STOP 28 S RAED=Y 29 X ^DD("DD") S RASHED=Y 30 S RAED=RAED_"."_9999 31 K XX G:'$$GETAP(.XX) STOP 32 W !!,"*** Pick the application in which to send the radiology data ***",!! 33 F I=1:1 Q:'$D(XX(I)) W !," #",I," ",$O(XX(I,"")) 34 2 ;user selects the application 35 S DIR(0)="N^1:"_(I-1) 36 W ! S DIR("?")="Please select an available application from the list." 37 D ^DIR Q:$D(DIRUT) 38 W !!,"The: ",$O(XX(+X,""))," will be the recipient" 39 W !!,"Reviewing exams for selected time period... (This may take a few minutes)... " 40 S Y=$$GETSUM(RABD,RAED) 41 I 'Y W !!,"No exams exist for selected period, change the time frame !!!" H 3 W ! G 1 42 W !!,"During this period of time ",Y," Exams were performed and app Run time= ",Y\5000," Hours." 43 S RASSS(XX(X,$O(XX(+X,""))))="" D GETSUB(.RASSS,.RASSSX,.RASSSL) 44 K ZTSAVE 45 S ZTSAVE("RASSSX(")="",ZTSAVE("RASSSL(")="",ZTSAVE("RABD")="",ZTSAVE("RAED")="",ZTSAVE("RADFN")="" 46 S ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTSAVE("RASHBD")="",ZTSAVE("RASHED")="",ZTIO="" 47 S ZTDESC="Rad/Nuc Med Compiling HL7 Common Order",ZTRTN="TM^RAHLRS1" 48 W ! K %DT S %DT="AEXT",%DT("A")="Scheduled time to run: ",%DT("B")="TODAY@23:59" D ^%DT 49 G:Y<0!($D(DTOUT))!($D(DUOUT)) STOP 50 S X=Y,YY=Y D H^%DTC S ZTDTH=$G(%H)_","_$G(%T) 51 S Y=YY X ^DD("DD") S RASHTM=Y 52 D ^%ZTLOAD 53 W !,"Task ",$S('$D(ZTSK):" Has Not been Tasked !!!",1:"#:"_ZTSK_" Has been Tasked") 54 D:$D(ZTSK) 55 .N RAX,RAMPG,XMSUB,XMY,XMTEXT 56 .S RAX(1)="Task #"_$G(ZTSK)_" is scheduled to run the option: " 57 .S RAX(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<" 58 .S RAX(3)=" Scheduled time to run: "_RASHTM 59 .S RAX(4)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED) 60 .S XMSUB="TASKMAN SCHEDULE NOTIFICATION/INFO" 61 .S RAMPG="G.RAD HL7 MESSAGES" 62 .S XMY(RAMPG)="",XMDUZ=.5 63 .S XMTEXT="RAX(" 64 .D ^XMD 65 Q 66 ; 67 TM ;Taskman Entry... 68 N RASTIME,RASUM7,RASUM7R,RASUM7E 69 S RASTIME=$H,(RASUM7,RASUM7R,RASUM7E)=0 70 F S RABD=$O(^RADPT("AR",RABD)) Q:'RABD!(RABD>RAED) D 71 .S RADFN=0 F S RADFN=$O(^RADPT("AR",RABD,RADFN)) Q:'RADFN D 72 ..S RADTI=0 F S RADTI=$O(^RADPT("AR",RABD,RADFN,RADTI)) Q:'RADTI D 73 ...S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D RESEND(RADFN,RADTI,RACNI) 74 K RAX S RAX(1)="Task #"_$G(ZTSK)_" successfully completed the option: " 75 S RAX(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<" 76 S RAX(3)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED) 77 S RAX(4)="# Of RAD Reports transferred: "_$G(RASUM7R) 78 S RAX(5)="# Of Exams transferred: "_$G(RASUM7) 79 S:$G(RASUM7E) X(6)="# Of Exams not transferred because of ""BAD DATA"": "_$G(RASUM7E) 80 S XMSUB="TASKMAN ""RESEND HL7 OPTION"" COMPLETED/INFO" 81 S RAMPG="G.RAD HL7 MESSAGES" 82 S XMY(RAMPG)="",XMDUZ=.5 83 S XMTEXT="RAX(" 84 D ^XMD 85 G STOP 86 Q 87 ; 88 RESEND(RADFN,RADTI,RACNI) ; re-send exam message(s) to HL7 subscribers 89 ; for every 10 messages sent, make sure queue is not clogged... $$HANG 90 N RAXAMP80 S RAXAMP80=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 91 I '(+$P(RAXAMP80,U))!'($P(RAXAMP80,U,2)) S RASUM7E=RASUM7E+1 Q 92 N RABD,RAEDP80,QUIT 93 ; 94 I '$D(DT) D ^%DT S DT=Y 95 ; 96 S RAEDP80=$$RAED(RADFN,RADTI,RACNI) 97 I '$L(RAEDP80) S RASUM7E=RASUM7E+1 Q 98 D:RAEDP80[",REG," 99 .D CHSUM N RASUM7,RASUM7R,RASUM7E D REG^RAHLRPC 100 D:RAEDP80[",CANCEL," 101 .D CHSUM N RASUM7,RASUM7R,RASUM7E D CANCEL^RAHLRPC 102 D:RAEDP80[",EXAM," 103 .D CHSUM 104 .S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",30)="" ;Reset sent flag 105 .N RASUM7,RAEXMDUN,RASUM7R,RASUM7E D 1^RAHLRPC 106 D:RAEDP80[",RPT," 107 .D CHSUM N RASUM7,RANOSEND,RASUM7R,RASUM7E,RARPT D RPT^RAHLRPC 108 Q 109 ; 110 RAED(RADFN,RADTI,RACNI) ; identify correct ^RAHLRPC entry point(s) 111 ; 112 N RASTAT,RAIMTYP,RAORD,RETURN,RARPT 113 S RASTAT="" 114 ; 115 S RETURN=",REG," 116 ; 117 S RASTAT=$$GET1^DIQ(70.03,RACNI_","_RADTI_","_RADFN,3,"I") 118 S RARPT=$$GET1^DIQ(70.03,RACNI_","_RADTI_","_RADFN,17,"I") 119 ; 120 S RAIMTYP=$$GET1^DIQ(72,+RASTAT,7) Q:'$L(RAIMTYP) "" 121 S RAORD=$$GET1^DIQ(72,+RASTAT,3) 122 ; 123 S:RAORD=0 RETURN=RETURN_"CANCEL," 124 ; 125 S:$$GET1^DIQ(72,+RASTAT,8)="YES" RETURN=RETURN_"EXAM," ; Generate Examined HL7 Message 126 ; 127 D:RETURN'[",EXAM," 128 .; also check previous statuses for 'Generate Examined HL7 Message' 129 .F S RAORD=$O(^RA(72,"AA",RAIMTYP,RAORD),-1) Q:+RAORD<1 D Q:RETURN[",EXAM," 130 ..S RASTAT=$O(^RA(72,"AA",RAIMTYP,RAORD,0)) 131 ..S:$$GET1^DIQ(72,+RASTAT,8)="YES" RETURN=RETURN_"EXAM," 132 ; 133 ; Check if Verified Report exists 134 I RARPT]"",$$GET1^DIQ(74,RARPT_",",5,"I")="V" S RETURN=RETURN_"RPT,",RASUM7R=RASUM7R+1 135 ; 136 Q RETURN 137 ; 138 SETVARS ; Setup key Rad/Nuc Med variables 139 ; 140 I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) 141 Q:'($D(RACCESS(DUZ))\10) ; user does not have location access 142 I $G(RAIMGTY)="" D SETVARS^RAPSET1(1) K:$G(RAIMGTY)="" XQUIT 143 Q 144 STOP ; 145 D ^%ZISC 146 Q 147 ; 148 GETAP(XX) ; 149 ;Get list of Applications in XX 150 N XXX,X11,X1,X2,X3,Z,Z1,J 151 F X11="RA REG","RA EXAMINED","RA CANCEL","RA RPT" D 152 .S X1=$E(X11,1,$L(X11)-1)_$C($A($E(X11,$L(X11)))-1) 153 .F S X1=$O(^ORD(101,"B",X1)) Q:X1'[X11 S X2=$O(^ORD(101,"B",X1,0)) Q:'X2 D 154 ..K Z S X3=0 F S X3=$O(^ORD(101,X2,775,X3)) Q:'X3 S Z(+^(X3,0))="" 155 ..Q:'$D(Z) K Z1 S X3=0 F S X3=$O(Z(X3)) Q:'X3 D 156 ...S Z1=$G(^ORD(101,X3,770)) S:+$P(Z1,U,2) XXX(+$P(Z1,U,2))="" 157 S X1=0 F J=1:1 S X1=$O(XXX(X1)) Q:'X1 D 158 .N DIERR,RAERR,Y 159 .S Y=$$GET1^DIQ(771,X1,.01,"","","RAERR") 160 .Q:Y=""!($D(RAERR)#2) S XX(J,Y)=X1 161 .Q 162 Q $S($D(XXX):1,1:0) 163 ; 164 GETSUB(APL,SUB,LINK) ;Get all subscribers (not associated with application)... To be excluded as receipients.. 165 ; Get all logical links to be in business, so we can control flow of messages 166 ;APL(IEN) = Application 771 IENs Input 167 ;SUB(Event Driver IEN,Subscriber IEN)="" Output 168 ;LINK(IEN of logical link) 169 N XX,X11,X1,X2,X3 170 Q:'$O(APL(0)) 171 F X11="RA REG","RA EXAMINED","RA CANCEL","RA RPT" D 172 .S X1=$E(X11,1,$L(X11)-1)_$C($A($E(X11,$L(X11)))-1) 173 .F S X1=$O(^ORD(101,"B",X1)) Q:X1'[X11 S X2=$O(^ORD(101,"B",X1,0)) Q:'X2 D 174 ..S X3=0 F S X3=$O(^ORD(101,X2,775,X3)) Q:'X3 S XX=+^(X3,0) D 175 ...I '$D(APL(+$P($G(^ORD(101,XX,770)),U,2))) S SUB(X2,XX)=X1 Q 176 ...S XX=+$P($G(^ORD(101,XX,770)),U,7) S:XX LINK(XX)="" 177 Q 178 GETHLP(RAEID,HLP,ADR) ; Get excluded subcribers set into HLP array 179 N I,J,XX,AA S J=$O(HLP("EXCLUDE SUBSCRIBER",99999999),-1) 180 ;XX Set the list of already excluded subscribers, so be sure we don't set it second time 181 S AA=ADR_"("_RAEID_",I)" 182 S I=0 F I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I S XX(HLP("EXCLUDE SUBSCRIBER",I))="" 183 S I=0 F S I=$O(@AA) Q:'I S:'$D(XX(I)) J=J+1,HLP("EXCLUDE SUBSCRIBER",J)=I 184 Q 185 CHSUM ;CHECKSUM 186 S RASUM7=RASUM7+1 I '(RASUM7#50) F Q:'$$HANG H 15 187 Q 188 HANG() ; scan all logical links to see if queue is bigger than 100 189 N I,S,L,QUIT 190 S (QUIT,L)=0 191 F S L=$O(RASSSL(L)) Q:'L S (S,I)=0 D Q:QUIT 192 .F S I=$O(^HLMA("AC","O",L,I)) Q:'I S S=S+1 I S>100 S QUIT=1 Q ;Quit if more than 100 messages waiting in outgoing queue for link... 193 Q QUIT 194 GETSUM(RABD,RAED) ; Get number of exams for period called from RAHLR RAHLR1 RAHLRPT RAHLRPT1 195 N RADFN,RADTI,RACNI,RASUM7 196 S RASUM7=0 197 F S RABD=$O(^RADPT("AR",RABD)) Q:'RABD!(RABD>RAED) D 198 .S RADFN=0 F S RADFN=$O(^RADPT("AR",RABD,RADFN)) Q:'RADFN D 199 ..S RADTI=0 F S RADTI=$O(^RADPT("AR",RABD,RADFN,RADTI)) Q:'RADTI D 200 ...S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI S:^(RACNI,0) RASUM7=RASUM7+1 201 Q RASUM7 202 Q 1 RAHLRS1 ;HIRMFO/ROB/PAVEL - Resend HL7 messages for selected Timeframe ; 4/2/07 3:42pm 2 ;;5.0;Radiology/Nuclear Medicine;**80**;Mar 01, 2007;Build 19 3 ; 4 ; Utility to RESEND HL7 messages for selected Timeframe 5 ; 6 N RACNI,RADFN,RADTI,RARPT,X,RAED,RABD,RASHBD,RASHED,RASHTD,RASHTM,DIC,DA,XX,YY 7 N RALOCK,RASSS,RASSSX,RASSSL,I,X S RALOCK=0 8 CHECK ; 9 D SETVARS Q:$G(RAIMGTY)="" 10 W !!,"This option re-sends HL7 messages for a date range and for designated Recipients.",! 11 W !,"It is strongly recommended you task this to run off hours.",!! 12 S:'$D(U) U="^" S:'$D(DTIME) DTIME=9999 13 1 W ! K %DT S %DT="AEX",%DT("A")="Beginning Date: " D ^%DT 14 G:Y<0!($D(DTOUT))!($D(DUOUT)) STOP 15 S RABD=Y 16 X ^DD("DD") S RASHBD=Y 17 S X1=RABD,X2=-1 D C^%DTC S RABD=X 18 S RABD=RABD_"."_9999 19 ; 20 W ! K %DT S %DT="AEX",%DT("A")="Ending Date: ",%DT("B")="NOW" D ^%DT 21 G:Y<0!($D(DTOUT))!($D(DUOUT)) STOP 22 S RAED=Y 23 X ^DD("DD") S RASHED=Y 24 S RAED=RAED_"."_9999 25 K XX G:'$$GETAP(.XX) STOP 26 W !!,"****Pick the application to send the RAD data to*****",!! 27 F I=1:1 Q:'$D(XX(I)) W !," #",I," ",$O(XX(I,"")) 28 2 S DIR(0)="N" 29 W ! S DIR("?")="Please select an available application from the list" 30 D ^DIR Q:$D(DIRUT) I (X'<1),(X'<I) W "Please select an available application from the list" G 2 31 W !!,"The: ",$O(XX(+X,""))," will be the recipient" 32 W !!,"Reviewing exams for selected time period... (This may take a few minutes)... " 33 S Y=$$GETSUM(RABD,RAED) 34 I 'Y W !!,"No exams exist for selected period, change the time frame !!!" H 3 W ! G 1 35 W !!,"During this period of time ",Y," Exams were performed and app Run time= ",Y\5000," Hours." 36 S RASSS(XX(X,$O(XX(+X,""))))="" D GETSUB(.RASSS,.RASSSX,.RASSSL) 37 K ZTSAVE 38 S ZTSAVE("RASSSX(")="",ZTSAVE("RASSSL(")="",ZTSAVE("RABD")="",ZTSAVE("RAED")="",ZTSAVE("RADFN")="" 39 S ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTSAVE("RASHBD")="",ZTSAVE("RASHED")="",ZTIO="" 40 S ZTDESC="Rad/Nuc Med Compiling HL7 Common Order",ZTRTN="TM^RAHLRS1" 41 W ! K %DT S %DT="AEXT",%DT("A")="Scheduled time to run: ",%DT("B")="TODAY@23:59" D ^%DT 42 G:Y<0!($D(DTOUT))!($D(DUOUT)) STOP 43 S X=Y,YY=Y D H^%DTC S ZTDTH=$G(%H)_","_$G(%T) 44 S Y=YY X ^DD("DD") S RASHTM=Y 45 D ^%ZTLOAD 46 W !,"Task ",$S('$D(ZTSK):" Has Not been Tasked !!!",1:"#:"_ZTSK_" Has been Tasked") 47 D:$D(ZTSK) 48 .N X,RAMPG,XMSUB,XMY,XMTEXT 49 .S X(1)="Task #"_$G(ZTSK)_" is scheduled to run the option: " 50 .S X(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<" 51 .S X(3)=" Scheduled time to run: "_RASHTM 52 .S X(4)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED) 53 .S XMSUB="TASKMAN SCHEDULE NOTIFICATION/INFO" 54 .S RAMPG="G.RAD HL7 MESSAGES" 55 .S XMY(RAMPG)="",XMDUZ=.5 56 .S XMTEXT="X(" 57 .D ^XMD 58 Q 59 ; 60 TM ;Taskman Entry... 61 N RASTIME,RASUM7,RASUM7R,RASUM7E 62 S RASTIME=$H,(RASUM7,RASUM7R,RASUM7E)=0 63 F S RABD=$O(^RADPT("AR",RABD)) Q:'RABD!(RABD>RAED) D 64 .S RADFN=0 F S RADFN=$O(^RADPT("AR",RABD,RADFN)) Q:'RADFN D 65 ..S RADTI=0 F S RADTI=$O(^RADPT("AR",RABD,RADFN,RADTI)) Q:'RADTI D 66 ...S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D RESEND(RADFN,RADTI,RACNI) 67 K X S X(1)="Task #"_$G(ZTSK)_" successfully completed the option: " 68 S X(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<" 69 S X(3)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED) 70 S X(4)="# Of RAD Reports transferred: "_$G(RASUM7R) 71 S X(5)="# Of Exams transferred: "_$G(RASUM7) 72 S:$G(RASUM7E) X(6)="# Of Exams not transferred because of ""BAD DATA"": "_$G(RASUM7E) 73 S XMSUB="TASKMAN ""RESEND HL7 OPTION"" COMPLETED/INFO" 74 S RAMPG="G.RAD HL7 MESSAGES" 75 S XMY(RAMPG)="",XMDUZ=.5 76 S XMTEXT="X(" 77 D ^XMD 78 G STOP 79 Q 80 ; 81 RESEND(RADFN,RADTI,RACNI) ; re-send exam message(s) to HL7 subscribers 82 ; for every 10 messages sent, make sure queue is not clogged... $$HANG 83 I '(+^(RACNI,0)) S RASUM7E=RASUM7E+1 Q 84 I '$P(^(0),U,2) S RASUM7E=RASUM7E+1 Q 85 N RABD,RAED,QUIT 86 ; 87 I '$D(DT) D ^%DT S DT=Y 88 ; 89 S RAED=$$RAED(RADFN,RADTI,RACNI) 90 I '$L(RAED) S RASUM7E=RASUM7E+1 Q 91 D:RAED[",REG," 92 .D CHSUM N RASUM7,RASUM7R,RASUM7E D REG^RAHLRPC 93 D:RAED[",CANCEL," 94 .D CHSUM N RASUM7,RASUM7R,RASUM7E D CANCEL^RAHLRPC 95 D:RAED[",EXAM," 96 .D CHSUM 97 .S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",30)="" ;Reset sent flag 98 .N RASUM7,RAEXMDUN,RASUM7R,RASUM7E D 1^RAHLRPC 99 D:RAED[",RPT," 100 .D CHSUM N RASUM7,RANOSEND,RASUM7R,RASUM7E,RARPT D RPT^RAHLRPC 101 Q 102 ; 103 RAED(RADFN,RADTI,RACNI) ; identify correct ^RAHLRPC entry point(s) 104 ; 105 N RASTAT,RAIMTYP,RAORD,RETURN,RARPT 106 S RASTAT="" 107 ; 108 S RETURN=",REG," 109 ; 110 S RASTAT=$$GET1^DIQ(70.03,RACNI_","_RADTI_","_RADFN,3,"I") 111 S RARPT=$$GET1^DIQ(70.03,RACNI_","_RADTI_","_RADFN,17,"I") 112 ; 113 S RAIMTYP=$$GET1^DIQ(72,+RASTAT,7) Q:'$L(RAIMTYP) "" 114 S RAORD=$$GET1^DIQ(72,+RASTAT,3) 115 ; 116 S:RAORD=0 RETURN=RETURN_"CANCEL," 117 ; 118 S:$$GET1^DIQ(72,+RASTAT,8)="YES" RETURN=RETURN_"EXAM," ; Generate Examined HL7 Message 119 ; 120 D:RETURN'[",EXAM," 121 .; also check previous statuses for 'Generate Examined HL7 Message' 122 .F S RAORD=$O(^RA(72,"AA",RAIMTYP,RAORD),-1) Q:+RAORD<1 D Q:RETURN[",EXAM," 123 ..S RASTAT=$O(^RA(72,"AA",RAIMTYP,RAORD,0)) 124 ..S:$$GET1^DIQ(72,+RASTAT,8)="YES" RETURN=RETURN_"EXAM," 125 ; 126 ; Check if Verified Report exists 127 I RARPT]"",$$GET1^DIQ(74,RARPT_",",5,"I")="V" S RETURN=RETURN_"RPT,",RASUM7R=RASUM7R+1 128 ; 129 Q RETURN 130 ; 131 SETVARS ; Setup key Rad/Nuc Med variables 132 ; 133 I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) 134 Q:'($D(RACCESS(DUZ))\10) ; user does not have location access 135 I $G(RAIMGTY)="" D SETVARS^RAPSET1(1) K:$G(RAIMGTY)="" XQUIT 136 Q 137 STOP ; 138 D ^%ZISC 139 Q 140 ; 141 GETAP(XX) ; 142 ;Get list of Applications in XX 143 N XXX,X11,X1,X2,X3,Z,Z1,J 144 F X11="RA REG","RA EXAMINED","RA CANCEL","RA RPT" D 145 .S X1=$E(X11,1,$L(X11)-1)_$C($A($E(X11,$L(X11)))-1) 146 .F S X1=$O(^ORD(101,"B",X1)) Q:X1'[X11 S X2=$O(^ORD(101,"B",X1,0)) Q:'X2 D 147 ..K Z S X3=0 F S X3=$O(^ORD(101,X2,775,X3)) Q:'X3 S Z(+^(X3,0))="" 148 ..Q:'$D(Z) K Z1 S X3=0 F S X3=$O(Z(X3)) Q:'X3 S XXX(+$P($G(^ORD(101,X3,770)),U,2))="" 149 S X1=0 F J=1:1 S X1=$O(XXX(X1)) Q:'X1 S XX(J,$P(^HL(771,X1,0),U))=X1 150 Q $S($D(XXX):1,1:0) 151 ; 152 GETSUB(APL,SUB,LINK) ;Get all subscribers (not associated with application)... To be excluded as receipients.. 153 ; Get all logical links to be in business, so we can control flow of messages 154 ;APL(IEN) = Application 771 IENs Input 155 ;SUB(Event Driver IEN,Subscriber IEN)="" Output 156 ;LINK(IEN of logical link) 157 N XX,X11,X1,X2,X3 158 Q:'$O(APL(0)) 159 F X11="RA REG","RA EXAMINED","RA CANCEL","RA RPT" D 160 .S X1=$E(X11,1,$L(X11)-1)_$C($A($E(X11,$L(X11)))-1) 161 .F S X1=$O(^ORD(101,"B",X1)) Q:X1'[X11 S X2=$O(^ORD(101,"B",X1,0)) Q:'X2 D 162 ..S X3=0 F S X3=$O(^ORD(101,X2,775,X3)) Q:'X3 S XX=+^(X3,0) D 163 ...I '$D(APL(+$P($G(^ORD(101,XX,770)),U,2))) S SUB(X2,XX)=X1 Q 164 ...S XX=+$P($G(^ORD(101,XX,770)),U,7) S:XX LINK(XX)="" 165 Q 166 GETHLP(RAEID,HLP) ; Get excluded subcribers set into HLP array 167 N I,J,II S II=$O(HLP("EXCLUDE SUBSCRIBER",99999999),-1)+1 168 S I=0 F J=II:1 S I=$O(RASSSX(RAEID,I)) Q:'I S HLP("EXCLUDE SUBSCRIBER",J)=I 169 Q 170 CHSUM ;CHECKSUM 171 S RASUM7=RASUM7+1 I '(RASUM7#50) F Q:'$$HANG H 15 172 Q 173 HANG() ; scan all logical links to see if queue is bigger than 100 174 N I,S,L,QUIT 175 S (QUIT,L)=0 176 F S L=$O(RASSSL(L)) Q:'L S (S,I)=0 D Q:QUIT 177 .F S I=$O(^HLMA("AC","O",L,I)) Q:'I S S=S+1 I S>100 S QUIT=1 Q ;Quit if more than 100 messages waiting in outgoing queue for link... 178 Q QUIT 179 GETSUM(RABD,RAED) ; Get number of exams for period called from RAHLR RAHLR1 RAHLRPT RAHLRPT1 180 N RADFN,RADTI,RACNI,RASUM7 181 S RASUM7=0 182 F S RABD=$O(^RADPT("AR",RABD)) Q:'RABD!(RABD>RAED) D 183 .S RADFN=0 F S RADFN=$O(^RADPT("AR",RABD,RADFN)) Q:'RADFN D 184 ..S RADTI=0 F S RADTI=$O(^RADPT("AR",RABD,RADFN,RADTI)) Q:'RADTI D 185 ...S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI S:^(RACNI,0) RASUM7=RASUM7+1 186 Q RASUM7 187 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLTCPB.m
r613 r623 1 RAHLTCPB ; HIRMFO/REL,GJC,BNT,PAV - Rad/Nuc Med HL7 TCP/IP Bridge;05/21/99 2 ;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81,84**;Mar 16, 1998;Build 13 3 ; 07/05/2006 BAY/KAM Remedy Call 124379 Eliminate unneeded ORM msgs 4 ; 09/01/2006 Acomodate multiple ORC/OBR segments Patch 81 5 ; 6 ;Integration Agreements 7 ;---------------------- 8 ;INIT^HLFNC2(2161); GENACK^HLMA1(2165); $$DT^XLFDT(10103) 9 ; 10 EN1 ; Build the ^TMP("RARPT-REC" global when we receive the 11 ; 07/05/2006 Remedy Call 124379 message from HL7. If RAHLTCPB is defined, do not broadcast ORM messages. As of the writing 12 ; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1 Generic provider: RADIOLOGY,OUTSIDE SERVICE 13 N RATELE,RATELENM,RATELEPI,RATELEKN,RATELEDR,RATELEDF 14 D TELE^RAHLRPTT ;Patch 84 15 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 16 I HL("VER")>2.3,($T(^RAHLTCPX))'="" GOTO EN1^RAHLTCPX 17 S RASUB=HL("MID"),RAHLTCPB=1 K RAERR 18 ;********************************************** 19 ;RACN is Counter - Indication that ORC segment present 20 N RACN,II,L,RAPRSET,RARRR,XX,RAHLD,RARSDNT,RATRSCRP S (RACN,RAPRSET)=0 ; = Address where we go to store data... 21 ;********************************************** 22 K ^TMP("RARPT-HL7",$J) ; clean area that holds data from HL7 23 K ^TMP("RARPT-REC",$J,RASUB) ; kill storage area for new HL7 message id 24 S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT() 25 F I=1:1 X HLNEXT Q:HLQUIT'>0 D 26 .I '$L(HLNODE),$L($G(HLNODE(1))) S HLNODE=HLNODE(1) K HLNODE(1) F J=2:1 Q:'$D(HLNODE(J)) S HLNODE(J-1)=HLNODE(J) K HLNODE(J) 27 .S ^TMP("RARPT-HL7",$J,I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S ^TMP("RARPT-HL7",$J,I,J)=HLNODE(J) 28 S CNT=2,SEGMNT=$G(^TMP("RARPT-HL7",$J,CNT)) 29 S:'$$GETSFLAG^RAHLRU($G(HL("SAN")),$G(HL("MTN")),$G(HL("ETN")),$G(HL("VER"))) RANOSEND=$G(HL("SAN")) 30 S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=$G(HL("SAN")) 31 PID ; Pick data off the 'PID' segment. 32 I $P(SEGMNT,HL("FS"))="PID" D 33 . S SEGMNT=$P(SEGMNT,HL("FS"),2,99999) 34 . I $P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))]"" D 35 .. S (^TMP("RARPT-REC",$J,RASUB,"RADFN"),RADFN)=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH"))) 36 .. Q 37 . I $P(SEGMNT,HL("FS"),19)]"" D 38 .. S ^TMP("RARPT-REC",$J,RASUB,"RASSN")=$P(SEGMNT,HL("FS"),19) 39 .. Q 40 . Q 41 E S RAERR="Missing PID segment" D XIT Q 42 I '(+$G(^TMP("RARPT-REC",$J,RASUB,"RADFN"))) D Q 43 .S RAERR="Invalid Patient ID" 44 .D XIT 45 ; Save off E-Sig information (if it exists) 46 S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG") 47 ;******************************** 48 ORC ; Pick data off the 'ORC' segment. 49 D 50 .N CNT1 S CNT1=CNT,RARRR="" 51 111 .K SEGMNT S CNT1=$O(^TMP("RARPT-HL7",$J,CNT1)) Q:CNT1="" S SEGMNT=$G(^(CNT1)) 52 .I $P(SEGMNT,HL("FS"))="PV1" S CNT=CNT1 G 111 53 .Q:$P(SEGMNT,HL("FS"))'="ORC" 54 .S CNT=CNT1 Q:$P(SEGMNT,HL("FS"),2)'="CN" ; find the 'ORC' segment 55 .S RACN=RACN+1,RARRR="RARPT-REC-"_RACN 56 ;******************************** 57 OBR ; Pick data off the 'OBR' segment. 58 I $L(RARRR) K ^TMP(RARRR,$J) M ^TMP(RARRR,$J)=^TMP("RARPT-REC",$J) ;Merge if OBR without Report 59 S:'$L(RARRR) RARRR="RARPT-REC" 60 K SEGMNT F S CNT=$O(^TMP("RARPT-HL7",$J,CNT)) Q:CNT="" S SEGMNT=$G(^(CNT)) Q:$P(SEGMNT,HL("FS"))="OBR" ; find the 'OBR' segment 61 I $P($G(SEGMNT),HL("FS"))'="OBR" S RAERR="Missing OBR segment" D XIT Q 62 S SEGMNT=$P(SEGMNT,HL("FS"),2,99999) K RADTI,RACNI 63 I $P(SEGMNT,HL("FS"),3)]"" D 64 . N RADTCN S RADTCN=$P(SEGMNT,HL("FS"),3) 65 . S:$P($P(RADTCN,$E(HL("ECH"))),"-")]"" (^TMP(RARRR,$J,RASUB,"RADTI"),RADTI)=$P($P(RADTCN,$E(HL("ECH"))),"-") 66 . S:$P($P(RADTCN,$E(HL("ECH"))),"-",2)]"" (^TMP(RARRR,$J,RASUB,"RACNI"),RACNI)=$P($P(RADTCN,$E(HL("ECH"))),"-",2) 67 . S:$P(RADTCN,$E(HL("ECH")),2)["&L" RADTCN=$TR(RADTCN,"&","^") 68 . S:$P(RADTCN,$E(HL("ECH")),2)]"" ^TMP(RARRR,$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HL("ECH")),2) 69 . Q 70 I $G(RADTI)'>0 S RAERR="Invalid exam registration timestamp" D XIT Q 71 I $G(RACNI)'>0 S RAERR="Invalid exam record IEN" D XIT Q 72 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS")) K RAHL70 73 I RAHLD="" S RAERR="Missing Report Status" D XIT Q 74 I "AFR"'[RAHLD S RAERR="Invalid Report Status: "_RAHLD D XIT Q 75 S ^TMP(RARRR,$J,RASUB,"RASTAT")=RAHLD 76 G:$P(RARRR,"-",3) 112 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS")) K RAHL70 77 I RAHLD']"" S RAERR="Missing Provider ID" D XIT Q 78 S RAVERF=RAHLD 79 ; ----- Check the validity of the provider name ----- 80 I '$D(^VA(200,"B",RAVERF)) D ; check for a partial match in file 200 81 . D VFIER^RAHLO3 ; if one partial match found, return the entry ien 82 E D ; $D(^VA(200,"B",RAVERF)) true, get the entry ien 83 . S RAVERF=$O(^VA(200,"B",RAVERF,0)) 84 . S:'RAVERF RAERR="Invalid Provider Name: "_RAHLD 85 ; can't get resident info from medspeak 86 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,33,HL("FS")),RARSDNT="" K RAHL70 87 I RAHLD]"" D 88 . S RARSDNT=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RARSDNT,0)) S RARSDNT="" 89 S RAHLD="",RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,35,HL("FS")),RATRSCRP="" K RAHL70 90 I RAHLD]"" D 91 . S RATRSCRP=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RATRSCRP,0)) S RATRSCRP="" 92 S ^TMP(RARRR,$J,RASUB,"RAVERF")=RAVERF 93 S ^TMP(RARRR,$J,RASUB,"RATRANSCRIPT")=$S(RATRSCRP]"":RATRSCRP,RARSDNT]"":RARSDNT,1:RAVERF) 94 S:$G(RARSDNT) ^TMP(RARRR,$J,RASUB,"RARESIDENT")=RARSDNT 95 S ^TMP(RARRR,$J,RASUB,"RASTAFF")=RAVERF,^("RAWHOCHANGE")=RAVERF 96 I $D(RAERR) D XIT Q 97 D ESIG^RAHLO3 98 ; 99 ;If last OBR set provider info to all OBRs 100 K XX F I=1:1:RACN S XX=RARRR_"-"_I D:$D(^TMP(XX,$J,RASUB)) 101 .N XXX M XXX=^TMP(XX,$J,RASUB),^TMP(XX,$J,RASUB)=^TMP(RARRR,$J,RASUB),^TMP(XX,$J,RASUB)=XXX 102 112 I $D(RADTI),$D(RACNI),$D(RAPRSET(RADTI,RACNI)) K RAPRSET(RADTI,RACNI),^TMP(RARRR,$J) S RACN=RACN-1 G:$P(RARRR,"-",3) ORC M ^TMP(RARRR,$J)=^TMP("RARPT-REC-"_(RACN+1),$J) K ^TMP("RARPT-REC-"_(RACN+1),$J) G OBX 103 I $D(RADTI),'$D(RAPRSET(RADTI)) D ;Get array of printset for date... 104 .N RAPRTSET,RACN,RASUB,CNT 105 .K XX D EN2^RAUTL20(.XX) M:$D(XX) RAPRSET(RADTI)=XX K RAPRSET(RADTI,RACNI) 106 ; 107 OBX ; Pick data off the 'OBX' segments 108 K SEGMNT F S CNT=$O(^TMP("RARPT-HL7",$J,CNT)) Q:CNT="" S SEGMNT=$G(^(CNT)) D:$P(SEGMNT,HL("FS"))="OBX" Q:$D(RAERR) I $P(SEGMNT,HL("FS"))="ORC" S CNT=CNT-1 G ORC 109 . S SEGMNT=$P(SEGMNT,HL("FS"),2,9999) 110 . Q:SEGMNT?@("1"""_HL("FS")_"""."""_HL("FS")_"""") ;Quit if OBX is something as: OBX|||||||| 111 . I $P(SEGMNT,HL("FS"),3)']"" S RAERR="Missing Observation Identifier" Q 112 . S OBXTYP=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH"))),OBXTYP=$E($P(OBXTYP,"&",2)) 113 . S OBX2CE="" 114 . S:OBXTYP="" OBXTYP=" " 115 . I OBXTYP=" "&($P(SEGMNT,HL("FS"),2)="CE") D 116 . . I $P(SEGMNT,HL("FS"),5)=" " S OBXTYP="F" Q 117 . . S OBX2CE=1,OBXTYP="D" Q 118 . I "IDRF"'[OBXTYP S RAERR="Invalid Observation Identifier" Q 119 . D RPT Q 120 XIT ; RACKYES Indicates that Ack will be sent on the last OBR segment or at Error condition. 121 N RACKYES 122 I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK G XIT1 123 I $D(^TMP("RARPT-REC",$J)) S:'RACN RACKYES=1 D G:$D(RAERR) XIT1 124 .N RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK 125 F II=1:1:RACN S RARRR="RARPT-REC-"_II D:$D(^TMP(RARRR,$J)) Q:$D(RAERR) 126 .K ^TMP("RARPT-REC",$J) M ^TMP("RARPT-REC",$J)=^TMP(RARRR,$J) K ^TMP(RARRR,$J) 127 .S RACKYES=(II=RACN) N II,RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK 128 XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id 129 F II=1:1:RACN S RARRR="RARPT-REC-"_II K:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J) 130 K ^TMP("RARPT-HL7",$J) ; clean up HL7 storage 131 K CNT,OBXTYP,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RAHLTCPB,RANODE,RARCNT 132 K RAVERF,RASUB,SEGMNT,RANOSEND,MSA1,OBX2CE,RADX,RADX1,RADX2,RADX3 133 Q 134 RPT ; Save off Report Text data. 135 N RAXADEDN 136 S RAXADEDN=^TMP("RARPT-REC",$J,RASUB,"RASTAT") 137 S RANODE=$S(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT"),LIN="" 138 I OBX2CE D Q 139 . S X=$P(SEGMNT,HL("FS"),5),RADX1=$P(X,$E(HL("ECH"))) 140 . S LIN=RADX1,L=999 D P2 S LIN=X 141 . Q:X'["~" F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J S X1=^(J),LIN=LIN_X1 Q 142 . S RADX=LIN,RADX2=$P($P(RADX,"~",2),"^") S:RADX2]"" LIN=RADX2 D P2 143 . S RADX3=$P($P(RADX,"~",3),"^") Q:RADX3']"" S LIN=RADX3 D P2 Q 144 S X=$P(SEGMNT,HL("FS"),5) 145 I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT 146 I $G(RATELE),$D(RATELEKN),X[RATELEKN S X=$P(X,RATELEKN,2),RATELENM=$P(X,"-"),RATELEPI=$TR($P(X,"-",2)," ","") ;SFVAMC/DAD/9-7-2007/Comment out the quit Q ;Patch 84 147 D PAR 148 F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J S X1=^(J),X=$E(X1,1,125) D PAR I $L(X1)>125 S X=$E(X1,126,999) D PAR 149 I X=""!(LIN'="") S L=999 D P2 150 Q 151 ; 152 PAR ; Build text paragraph 153 S LIN=LIN_X 154 P1 I $L(LIN)<80 Q 155 F L=80:-1:1 Q:$E(LIN,L)=" " 156 D P2 S LIN=$E(LIN,L+1,999) G P1 157 P2 ; Set node 158 ; If Addendum and Report text is a space don't process 159 I $P(SEGMNT,HL("FS"),1)=1,RAXADEDN="A",RANODE="RATXT",$E(LIN,1,L-1)=" " Q 160 S RARCNT(OBXTYP)=$G(RARCNT(OBXTYP))+1 161 S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1) 162 F I=1:1:RACN S RARRR="RARPT-REC-"_I S:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1) 163 Q 164 ; 165 GENACK ; Compile the 'ACK' segment, generate the 'ACK' message. 166 Q:'$G(RACKYES) 167 S MSA1="AA" 168 Q:$E($G(HL("SAN")),1,3)'="RA-" ; Don't allow non RA namespaced interfaces 169 I $D(RAERR) S MSA1=$S($G(HL("SAN"))="RA-PSCRIBE-TCP"!$G(RATELE):"AE",1:"AR") 170 ; Added next line to support MedSpeak interface. Must re-initialize 171 ; FS and EC's before sending ACK. 172 D:$G(HL("SAN"))="RA-CLIENT-TCP" INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL) 173 S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"") 174 ; 06/22/2006 KAM CHANGED NEXT TWO LINES FOR RA*5*71 175 S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1 176 K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT) 177 Q 178 ; 179 FORMAT ; Format report text for Escape Character delimited codes. 180 S Y=X N T,Q 181 I Y["\S\" S Q=$F(Y,"\S\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"))_$E(Y,Q,$L(X)),Y=X 182 I Y["\R\" S Q=$F(Y,"\R\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),2)_$E(Y,Q,$L(X)),Y=X 183 I Y["\E\" S Q=$F(Y,"\E\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),3)_$E(Y,Q,$L(X)),Y=X 184 I Y["\T\" S Q=$F(Y,"\T\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),4)_$E(Y,Q,$L(X)),Y=X 185 I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT 186 Q 187 ; 1 RAHLTCPB ; HIRMFO/REL,GJC,BNT,PAV - Rad/Nuc Med HL7 TCP/IP Bridge;05/21/99 2 ;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81**;Mar 16, 1998;Build 12 3 ; 07/05/2006 BAY/KAM Remedy Call 124379 Eliminate unneeded ORM msgs 4 ; 09/01/2006 Acomodate multiplr ORC/OBR segments Patch 81 5 EN1 ; Build the ^TMP("RARPT-REC" global when we receive the 6 ; 07/05/2006 Remedy Call 124379 message from HL7. If RAHLTCPB is defined, do not broadcast ORM messages. As of the writing 7 ; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1 8 ;G:$G(HL("VER"))]"2.3" EN1^RAHLTCPX 9 S RASUB=HL("MID"),RAHLTCPB=1 K RAERR 10 ;********************************************** 11 ;RACN is Counter - Indication that ORC segment present 12 N RACN,II,L,RAPRSET,RARRR,XX,RAHLD,RARSDNT,RATRSCRP S (RACN,RAPRSET)=0 ; = Address where we go to store data... 13 ;********************************************** 14 K ^TMP("RARPT-HL7",$J) ; clean area that holds data from HL7 15 K ^TMP("RARPT-REC",$J,RASUB) ; kill storage area for new HL7 message id 16 S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT() 17 F I=1:1 X HLNEXT Q:HLQUIT'>0 D 18 .I '$L(HLNODE),$L($G(HLNODE(1))) S HLNODE=HLNODE(1) K HLNODE(1) F J=2:1 Q:'$D(HLNODE(J)) S HLNODE(J-1)=HLNODE(J) K HLNODE(J) 19 .S ^TMP("RARPT-HL7",$J,I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S ^TMP("RARPT-HL7",$J,I,J)=HLNODE(J) 20 S CNT=2,SEGMNT=$G(^TMP("RARPT-HL7",$J,CNT)) 21 S:'$$GETSFLAG^RAHLRU($G(HL("SAN")),$G(HL("MTN")),$G(HL("ETN")),$G(HL("VER"))) RANOSEND=$G(HL("SAN")) 22 S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=$G(HL("SAN")) 23 PID ; Pick data off the 'PID' segment. 24 I $P(SEGMNT,HL("FS"))="PID" D 25 . S SEGMNT=$P(SEGMNT,HL("FS"),2,99999) 26 . I $P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))]"" D 27 .. S (^TMP("RARPT-REC",$J,RASUB,"RADFN"),RADFN)=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH"))) 28 .. Q 29 . I $P(SEGMNT,HL("FS"),19)]"" D 30 .. S ^TMP("RARPT-REC",$J,RASUB,"RASSN")=$P(SEGMNT,HL("FS"),19) 31 .. Q 32 . Q 33 E S RAERR="Missing PID segment" D XIT Q 34 I '(+$G(^TMP("RARPT-REC",$J,RASUB,"RADFN"))) D Q 35 .S RAERR="Invalid Patient ID" 36 .D XIT 37 ; Save off E-Sig information (if it exists) 38 S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG") 39 ;******************************** 40 ORC ; Pick data off the 'ORC' segment. 41 D 42 .N CNT1 S CNT1=CNT,RARRR="" 43 111 .K SEGMNT S CNT1=$O(^TMP("RARPT-HL7",$J,CNT1)) Q:CNT1="" S SEGMNT=$G(^(CNT1)) 44 .I $P(SEGMNT,HL("FS"))="PV1" S CNT=CNT1 G 111 45 .Q:$P(SEGMNT,HL("FS"))'="ORC" 46 .S CNT=CNT1 Q:$P(SEGMNT,HL("FS"),2)'="CN" ; find the 'ORC' segment 47 .S RACN=RACN+1,RARRR="RARPT-REC-"_RACN 48 ;******************************** 49 OBR ; Pick data off the 'OBR' segment. 50 I $L(RARRR) K ^TMP(RARRR,$J) M ^TMP(RARRR,$J)=^TMP("RARPT-REC",$J) ;Merge if OBR without Report 51 S:'$L(RARRR) RARRR="RARPT-REC" 52 K SEGMNT F S CNT=$O(^TMP("RARPT-HL7",$J,CNT)) Q:CNT="" S SEGMNT=$G(^(CNT)) Q:$P(SEGMNT,HL("FS"))="OBR" ; find the 'OBR' segment 53 I $P($G(SEGMNT),HL("FS"))'="OBR" S RAERR="Missing OBR segment" D XIT Q 54 S SEGMNT=$P(SEGMNT,HL("FS"),2,99999) K RADTI,RACNI 55 I $P(SEGMNT,HL("FS"),3)]"" D 56 . N RADTCN S RADTCN=$P(SEGMNT,HL("FS"),3) 57 . S:$P($P(RADTCN,$E(HL("ECH"))),"-")]"" (^TMP(RARRR,$J,RASUB,"RADTI"),RADTI)=$P($P(RADTCN,$E(HL("ECH"))),"-") 58 . S:$P($P(RADTCN,$E(HL("ECH"))),"-",2)]"" (^TMP(RARRR,$J,RASUB,"RACNI"),RACNI)=$P($P(RADTCN,$E(HL("ECH"))),"-",2) 59 . S:$P(RADTCN,$E(HL("ECH")),2)["&L" RADTCN=$TR(RADTCN,"&","^") 60 . S:$P(RADTCN,$E(HL("ECH")),2)]"" ^TMP(RARRR,$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HL("ECH")),2) 61 . Q 62 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS")) K RAHL70 63 I RAHLD="" S RAERR="Missing Report Status" D XIT Q 64 I "AFR"'[RAHLD S RAERR="Invalid Report Status" D XIT Q 65 S ^TMP(RARRR,$J,RASUB,"RASTAT")=RAHLD 66 G:$P(RARRR,"-",3) 112 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS")) K RAHL70 67 I RAHLD']"" S RAERR="Missing Provider ID" D XIT Q 68 S RAVERF=RAHLD 69 ; ----- Check the validity of the provider name ----- 70 I '$D(^VA(200,"B",RAVERF)) D ; check for a partial match in file 200 71 . D VFIER^RAHLO3 ; if one partial match found, return the entry ien 72 E D ; $D(^VA(200,"B",RAVERF)) true, get the entry ien 73 . S RAVERF=$O(^VA(200,"B",RAVERF,0)) 74 . S:'RAVERF RAERR="Invalid Provider Name" 75 ; can't get resident info from medspeak 76 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,33,HL("FS")),RARSDNT="" K RAHL70 77 I RAHLD]"" D 78 . S RARSDNT=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RARSDNT,0)) S RARSDNT="" 79 S RAHLD="",RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,35,HL("FS")),RATRSCRP="" K RAHL70 80 I RAHLD]"" D 81 . S RATRSCRP=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RATRSCRP,0)) S RATRSCRP="" 82 S ^TMP(RARRR,$J,RASUB,"RAVERF")=RAVERF 83 S ^TMP(RARRR,$J,RASUB,"RATRANSCRIPT")=$S(RATRSCRP]"":RATRSCRP,RARSDNT]"":RARSDNT,1:RAVERF) 84 S:$G(RARSDNT) ^TMP(RARRR,$J,RASUB,"RARESIDENT")=RARSDNT 85 S ^TMP(RARRR,$J,RASUB,"RASTAFF")=RAVERF,^("RAWHOCHANGE")=RAVERF 86 I $D(RAERR) D XIT Q 87 D ESIG^RAHLO3 88 ;If last OBR set provider info to all OBRs 89 K XX F I=1:1:RACN S XX=RARRR_"-"_I D:$D(^TMP(XX,$J,RASUB)) 90 .N XXX M XXX=^TMP(XX,$J,RASUB),^TMP(XX,$J,RASUB)=^TMP(RARRR,$J,RASUB),^TMP(XX,$J,RASUB)=XXX 91 112 I $D(RADTI),$D(RACNI),$D(RAPRSET(RADTI,RACNI)) K RAPRSET(RADTI,RACNI),^TMP(RARRR,$J) S RACN=RACN-1 G:$P(RARRR,"-",3) ORC M ^TMP(RARRR,$J)=^TMP("RARPT-REC-"_(RACN+1),$J) K ^TMP("RARPT-REC-"_(RACN+1),$J) G OBX 92 I $D(RADTI),'$D(RAPRSET(RADTI)) D ;Get array of printset for date... 93 .N RAPRTSET,RACN,RASUB,CNT 94 .K XX D EN2^RAUTL20(.XX) M:$D(XX) RAPRSET(RADTI)=XX K RAPRSET(RADTI,RACNI) 95 ; 96 OBX ; Pick data off the 'OBX' segments 97 K SEGMNT F S CNT=$O(^TMP("RARPT-HL7",$J,CNT)) Q:CNT="" S SEGMNT=$G(^(CNT)) D:$P(SEGMNT,HL("FS"))="OBX" Q:$D(RAERR) I $P(SEGMNT,HL("FS"))="ORC" S CNT=CNT-1 G ORC 98 . S SEGMNT=$P(SEGMNT,HL("FS"),2,9999) 99 . Q:SEGMNT?@("1"""_HL("FS")_"""."""_HL("FS")_"""") ;Quit if OBX is something as: OBX|||||||| 100 . I $P(SEGMNT,HL("FS"),3)']"" S RAERR="Missing Observation Identifier" Q 101 . S OBXTYP=$P(SEGMNT,HL("FS"),3),OBXTYP=$E(OBXTYP,$F(OBXTYP,"&")) 102 . S OBX2CE="" 103 . S:OBXTYP="" OBXTYP=" " 104 . I OBXTYP=" "&($P(SEGMNT,HL("FS"),2)="CE") D 105 . . I $P(SEGMNT,HL("FS"),5)=" " S OBXTYP="F" Q 106 . . S OBX2CE=1,OBXTYP="D" Q 107 . I "IDRF"'[OBXTYP S RAERR="Invalid Observation Identifier" Q 108 . D RPT Q 109 XIT ; RACKYES Indicates that Ack will be sent on the last OBR segment or at Error condition. 110 N RACKYES 111 I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK G XIT1 112 I $D(^TMP("RARPT-REC",$J)) S:'RACN RACKYES=1 D G:$D(RAERR) XIT1 113 .N RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK 114 F II=1:1:RACN S RARRR="RARPT-REC-"_II D:$D(^TMP(RARRR,$J)) Q:$D(RAERR) 115 .K ^TMP("RARPT-REC",$J) M ^TMP("RARPT-REC",$J)=^TMP(RARRR,$J) K ^TMP(RARRR,$J) 116 .S RACKYES=(II=RACN) N II,RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK 117 XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id 118 F II=1:1:RACN S RARRR="RARPT-REC-"_II K:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J) 119 K ^TMP("RARPT-HL7",$J) ; clean up HL7 storage 120 K CNT,OBXTYP,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RAHLTCPB,RANODE,RARCNT 121 K RAVERF,RASUB,SEGMNT,RANOSEND,MSA1,OBX2CE,RADX,RADX1,RADX2,RADX3 122 Q 123 RPT ; Save off Report Text data. 124 N RAXADEDN 125 S RAXADEDN=^TMP("RARPT-REC",$J,RASUB,"RASTAT") 126 S RANODE=$S(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT"),LIN="" 127 I OBX2CE D Q 128 . S X=$P(SEGMNT,HL("FS"),5),RADX1=$P(X,$E(HL("ECH"))) 129 . S LIN=RADX1,L=999 D P2 S LIN=X 130 . Q:X'["~" F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J S X1=^(J),LIN=LIN_X1 Q 131 . S RADX=LIN,RADX2=$P($P(RADX,"~",2),"^") S:RADX2]"" LIN=RADX2 D P2 132 . S RADX3=$P($P(RADX,"~",3),"^") Q:RADX3']"" S LIN=RADX3 D P2 Q 133 S X=$P(SEGMNT,HL("FS"),5) 134 I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT 135 D PAR 136 F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J S X1=^(J),X=$E(X1,1,125) D PAR I $L(X1)>125 S X=$E(X1,126,999) D PAR 137 I X=""!(LIN'="") S L=999 D P2 138 Q 139 FORMAT ; Format report text for Escape Character delimited codes. 140 S Y=X N T,Q 141 I Y["\S\" S Q=$F(Y,"\S\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"))_$E(Y,Q,$L(X)),Y=X 142 I Y["\R\" S Q=$F(Y,"\R\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),2)_$E(Y,Q,$L(X)),Y=X 143 I Y["\E\" S Q=$F(Y,"\E\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),3)_$E(Y,Q,$L(X)),Y=X 144 I Y["\T\" S Q=$F(Y,"\T\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),4)_$E(Y,Q,$L(X)),Y=X 145 I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT 146 Q 147 PAR ; Build text paragraph 148 S LIN=LIN_X 149 P1 I $L(LIN)<80 Q 150 F L=80:-1:1 Q:$E(LIN,L)=" " 151 D P2 S LIN=$E(LIN,L+1,999) G P1 152 P2 ; Set node 153 ; If Addendum and Report text is a space don't process 154 I $P(SEGMNT,HL("FS"),1)=1,RAXADEDN="A",RANODE="RATXT",$E(LIN,1,L-1)=" " Q 155 S RARCNT(OBXTYP)=$G(RARCNT(OBXTYP))+1 156 S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1) 157 F I=1:1:RACN S RARRR="RARPT-REC-"_I S:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1) 158 Q 159 ; 160 GENACK ; Compile the 'ACK' segment, generate the 'ACK' message. 161 Q:'$G(RACKYES) 162 S MSA1="AA" 163 Q:$E($G(HL("SAN")),1,3)'="RA-" ; Don't allow non RA namespaced interfaces 164 I $D(RAERR) S MSA1=$S($G(HL("SAN"))="RA-PSCRIBE-TCP":"AE",1:"AR") 165 ; Added next line to support MedSpeak interface. Must re-initialize 166 ; FS and EC's before sending ACK. 167 D:$G(HL("SAN"))="RA-CLIENT-TCP" INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL) 168 S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"") 169 ; 06/22/2006 KAM CHANGED NEXT TWO LINES FOR RA*5*71 170 S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1 171 K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT) 172 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAMAIN.m
r613 r623 1 RAMAIN ;HISC/FPT,GJC,CAH AISC/MJK,RMO;VMP/PW-Utility File Maintenance ;7/24/02 14:45 2 ;;5.0;Radiology/Nuclear Medicine;**31,43,50,54,87**;Mar 16, 1998;Build 2 3 ; 4 ; 11/15/07 BAY/KAM RA*5*87 Rem Call 205080 Option File Access 5 3 ;;Major AMIS Code Enter/Edit 6 N RAI F RAI=1:1:5 W !?9,$P($T(REMIND+RAI),";;",2) 7 S DIR(0)="Y",DIR("B")="No" 8 S DIR("A")=" add/change any AMIS codes and weight" 9 S DIR("A",1)=" Do you have approval from Radiology Service VACO to" 10 D ^DIR K DIR Q:$D(DIRUT) Q:'Y 11 L3 S DIC="^RAMIS(71.1,",DIC(0)="AEMQ" W ! D ^DIC K DIC I Y<0 K D,X,Y,DDH,I,POP,DISYS Q 12 S DA=+Y,DIE="^RAMIS(71.1,",DR=".01;2" D ^DIE K %,%W,%Y,D0,DA,DE,DQ,DIE,DR,DI,I,POP G L3 13 REMIND ;; 14 ;;+----------------------------------------------------------+ 15 ;;| New entries and modifications to existing entries are | 16 ;;| prohibited without approval from Radiology Service VACO. | 17 ;;+----------------------------------------------------------+ 18 ; 19 4 ;;Film Type Enter/Edit 20 K DD,DIC,DLAYGO,DO 21 S DIC="^RA(78.4,",DIC(0)="AEMQL",DLAYGO=78.4 W ! D ^DIC 22 K DD,DIC,DLAYGO,DO 23 I +Y<0 D D Q4 Q 24 . D DSPLNKS^RAMAIN1 25 . K D,DI,X,Y 26 . Q 27 S DA=+Y,DIE="^RA(78.4,",DR=".01;2;3;4;5;S:+X'=1 Y=""@1"";6;@1" 28 D ^DIE S RA784=$G(^RA(78.4,DA,0)),RA784(1)=$P(RA784,U) 29 S RA784(5)=+$P(RA784,U,4),RA784(6)=$P(RA784,U,5) 30 I RA784(5),(RA784(6)']"") D 31 . N DIE,DR 32 . W !!?5,$C(7),"'"_RA784(1)_"' has been defined as a wasted film size." 33 . W !?5,"If a particular film size is deemed as a wasted piece of" 34 . W !?5,"film, the wasted piece of film must be associated with an" 35 . W !?5,"unwasted piece of film." 36 . W !!?5,"Redefining '"_RA784(1)_"' as an unwasted film size." 37 . S DIE="^RA(78.4,",DR="5///@" D ^DIE W " Done!" 38 . Q 39 K %,D0,DA,DE,DQ,DIE,DR,RA784,X,Y G 4 40 Q4 K I,POP,DISYS,DDH 41 Q 42 ; 43 5 ;;Diagnostic Code Enter/Edit 44 S DIC="^RA(78.3,",DIC(0)="AEMQL",DLAYGO=78.3 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y,POP,I Q 45 S DA=+Y,DIE="^RA(78.3,",DR="2:5" D ^DIE K %,D0,DA,DE,DQ,DIE,DR,I,DI G 5 46 ; 47 6 ;;Flash Card/Label Formatter 48 W:'$D(RAFLH) !!?5,">>> Exam Label/Report Header/Report Footer/Flash Card Formatter <<<" 49 S DIC="^RA(78.2,",DIC(0)="AEMQL",DLAYGO=78.2 W ! D ^DIC K DIC,DLAYGO G Q6:Y<0 S (RAFLH,DA)=+Y,DIE="^RA(78.2,",DR="[RA FLASH CARD EDIT]" D ^DIE K DE,DQ,DIE,DR I '$D(^RA(78.2,RAFLH,0)) G Q6 50 S RAFMT=RAFLH,RAK=0 51 F S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 D SETFLH^RAFLH2(RAK) 52 D CMP^RAFLH1 53 W !!,"<<<<<<----------------------------Column No.------------------------------>>>>>>" 54 W !!,"0--------1---------2---------3---------4---------5---------6---------7---------8" 55 W !,"1 0 0 0 0 0 0 0 0",! S RATEST="",RANUM=1,RAFFLF="!" D PRT^RAFLH K RAFFLF W !! G 6 56 Q6 S RAK=0 F S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 D KILFLH^RAFLH2(RAK) 57 K %,%W,%X,%Y,D,D0,D1,DA,FL,RA787,RATEST,RAII,RAK,RAFLH,RAFMT,RANUM,X,Y 58 K POP,I,DDH,DUOUT,DI,DISYS 59 Q 60 ; 61 7 ;;Complication Type Enter/Edit 62 S DIC="^RA(78.1,",DIC(0)="AEMQL",DLAYGO=78.1 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y G Q7 63 S DA=+Y,DIE="^RA(78.1,",DR=".01;2" D ^DIE K %,D,D0,DA,DE,DQ,DIE,DR D Q7 G 7 64 Q7 K DI,DISYS,I,POP Q 65 ; 66 8 ;;Sharing/Contract Agreement Entry/Edit 67 S DIC="^DIC(34,",DIC(0)="AELMQ",DIC("A")="Select Agreement/Contract: ",DLAYGO=34 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y,I,POP Q 68 S DA=+Y,DIE="^DIC(34,",DR=".01:3" D ^DIE K %,%W,%X,%Y,D,D0,DA,DE,DQ,DIE,DR,X,Y,DI,DISYS G 8 69 ; 70 9 ;;Standard Reports 71 S DIC="^RA(74.1,",DIC(0)="AEMQL",DLAYGO=74.1 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y D Q9 Q 72 S DA=+Y,DIE="^RA(74.1,",DR="[RA STANDARD REPORT ENTRY]" D ^DIE K %,%W,%X,%Y,C,D,D0,DA,DE,DQ,DIE,DR,X,Y D Q9 G 9 73 Q9 K DDH,DI,DISYS,I,J,POP 74 Q 75 ; 76 10 ;;Procedure Modifiers Entry 77 K DD,DO,DLAYGO,DIC,DA,DINUM,X,Y 78 ;S (DIC,DLAYGO)="^RAMIS(71.2,",DIC(0)="AEMQL" 79 ; 11/15/07 BAY/KAM RA*5*87 Rem Call 205080 Changed next line to set DLAYGO equal to the file number instead of the file root 80 S DIC="^RAMIS(71.2,",DLAYGO=71.2,DIC(0)="AEMQL" 81 S DIC("A")="Select Procedure Modifier: ",DIC("W")="D PROHLP^RAMAIN" 82 W ! D ^DIC K DIC,DLAYGO I +Y'>0 K D,X,Y,POP,I,DDH,DG,DISYS,DUOUT Q 83 S DIE="^RAMIS(71.2,",DA=+Y,DR="3;4" D ^DIE 84 K %W,%X,%Y,D,DIE,DO,DD,DLAYGO,DA,DR,X,Y,POP,I,D0,DI,DISYS,DQ,C G 10 85 ; 86 11 ;;Reports Distribution Edit 87 S DIC="^RABTCH(74.3,",DIC(0)="AEMQ" W ! D ^DIC K DIC I Y<0 K D,X,Y,I,POP Q 88 S DA=+Y,DIE="^RABTCH(74.3,",DR="[RA DISTRIBUTION EDIT]" D ^DIE K %,%W,%X,%Y,D,D0,DA,DE,DQ,DIE,DR,X,Y,DI,DISYS,I,POP G 11 89 ; 90 12 ;;Rad/Nuc Med Procedure Message Enter/Edit 91 S DIC="^RAMIS(71.4,",DIC(0)="AELMQ",DLAYGO=71.4 92 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,DTOUT,DUOUT,X,Y Q 93 S DA=+Y 94 L +^RAMIS(71.4,DA):3 I '$T D G 12 ;*54 95 . K DIR S DIR(0)="EA",DIR("A")="Sorry, someone else is editing that entry. <cr> - continue " D ^DIR K DIR 96 K RAMLNA,RAMLNB S RAMSGDA=DA ;*50 97 S RAMLNA=$G(^RAMIS(71.4,DA,0)) ;*50 98 S DIE="^RAMIS(71.4,",DR=.01 D ^DIE 99 S RAMLNB=$G(^RAMIS(71.4,+$G(DA),0)) ;*50 100 I RAMLNB'=RAMLNA S DA=RAMSGDA D ORDITMS^RAMAIN3 ;*50 101 L -^RAMIS(71.4,RAMSGDA) ;*54 102 K %,%W,%X,%Y,D0,DA,DE,DQ,DR,DIE,X,Y,RAMLNA,RAMLNB,RAMSGDA 103 G 12 104 ; 105 13 ;;Cost of Procedure Enter/Edit 106 I '$D(RACCESS(DUZ)) D SET^RAPSET1 I $D(XQUIT) K RACCESS,XQUIT Q 107 ; ask img type 108 K ^TMP($J,"RA I-TYPE") D SELIMG^RAUTL7 G:$G(RAQUIT) 139 109 N RA0,RA1,RA2 S RA0="",RA2="" 110 131 S RA0=$O(^TMP($J,"RA I-TYPE",RA0)) G:RA0="" 133 111 132 S RA1=$O(^TMP($J,"RA I-TYPE",RA0,0)) G:'RA1 131 112 S RA2=RA1_U_RA2 G 131 113 133 G:RA2="" 139 S DIC="^RAMIS(71,",DIC(0)="AEMQ" 114 ; restrict choice of procedure by img type selected 115 S DIC("S")="I RA2[$P(^(0),U,12)" 116 W ! D ^DIC K DIC I Y<0 K %,DTOUT,DUOUT,DIC,X,Y G 139 117 S DA=+Y,DIE="^RAMIS(71,",DR=10 D ^DIE 118 K D,D0,DA,DDH,DI,DIC,DIE,DQ,DR,X 119 G 133 120 139 K ^TMP($J,"RA I-TYPE"),RAQUIT 121 Q 122 ; 123 PROHLP ; Help displays the modifiers and all associated imaging types. 124 D:'$D(IOM) HOME^%ZIS 125 N RAIT,RAIT1,RAIT2,RAIT3 Q:'+$O(^RAMIS(71.2,+Y,1,0)) ; Quit, no data 126 S (RAIT,RAIT3)=0 127 F S RAIT=+$O(^RAMIS(71.2,+Y,1,RAIT)) W:'RAIT ")" Q:'RAIT D 128 . S RAIT1=+$G(^RAMIS(71.2,+Y,1,RAIT,0)) 129 . S RAIT2=$P($G(^RA(79.2,RAIT1,0)),"^",3) 130 . W:($X+5)>IOM !?2 W ?$X+1 W:'RAIT3 "(" W RAIT2 S RAIT3=1 131 . Q 132 Q 1 RAMAIN ;HISC/FPT,GJC,CAH AISC/MJK,RMO;VMP/PW-Utility File Maintenance ;7/24/02 14:45 2 ;;5.0;Radiology/Nuclear Medicine;**31,43,50,54**;Mar 16, 1998 3 ; 4 3 ;;Major AMIS Code Enter/Edit 5 N RAI F RAI=1:1:5 W !?9,$P($T(REMIND+RAI),";;",2) 6 S DIR(0)="Y",DIR("B")="No" 7 S DIR("A")=" add/change any AMIS codes and weight" 8 S DIR("A",1)=" Do you have approval from Radiology Service VACO to" 9 D ^DIR K DIR Q:$D(DIRUT) Q:'Y 10 L3 S DIC="^RAMIS(71.1,",DIC(0)="AEMQ" W ! D ^DIC K DIC I Y<0 K D,X,Y,DDH,I,POP,DISYS Q 11 S DA=+Y,DIE="^RAMIS(71.1,",DR=".01;2" D ^DIE K %,%W,%Y,D0,DA,DE,DQ,DIE,DR,DI,I,POP G L3 12 REMIND ;; 13 ;;+----------------------------------------------------------+ 14 ;;| New entries and modifications to existing entries are | 15 ;;| prohibited without approval from Radiology Service VACO. | 16 ;;+----------------------------------------------------------+ 17 ; 18 4 ;;Film Type Enter/Edit 19 K DD,DIC,DLAYGO,DO 20 S DIC="^RA(78.4,",DIC(0)="AEMQL",DLAYGO=78.4 W ! D ^DIC 21 K DD,DIC,DLAYGO,DO 22 I +Y<0 D D Q4 Q 23 . D DSPLNKS^RAMAIN1 24 . K D,DI,X,Y 25 . Q 26 S DA=+Y,DIE="^RA(78.4,",DR=".01;2;3;4;5;S:+X'=1 Y=""@1"";6;@1" 27 D ^DIE S RA784=$G(^RA(78.4,DA,0)),RA784(1)=$P(RA784,U) 28 S RA784(5)=+$P(RA784,U,4),RA784(6)=$P(RA784,U,5) 29 I RA784(5),(RA784(6)']"") D 30 . N DIE,DR 31 . W !!?5,$C(7),"'"_RA784(1)_"' has been defined as a wasted film size." 32 . W !?5,"If a particular film size is deemed as a wasted piece of" 33 . W !?5,"film, the wasted piece of film must be associated with an" 34 . W !?5,"unwasted piece of film." 35 . W !!?5,"Redefining '"_RA784(1)_"' as an unwasted film size." 36 . S DIE="^RA(78.4,",DR="5///@" D ^DIE W " Done!" 37 . Q 38 K %,D0,DA,DE,DQ,DIE,DR,RA784,X,Y G 4 39 Q4 K I,POP,DISYS,DDH 40 Q 41 ; 42 5 ;;Diagnostic Code Enter/Edit 43 S DIC="^RA(78.3,",DIC(0)="AEMQL",DLAYGO=78.3 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y,POP,I Q 44 S DA=+Y,DIE="^RA(78.3,",DR="2:5" D ^DIE K %,D0,DA,DE,DQ,DIE,DR,I,DI G 5 45 ; 46 6 ;;Flash Card/Label Formatter 47 W:'$D(RAFLH) !!?5,">>> Exam Label/Report Header/Report Footer/Flash Card Formatter <<<" 48 S DIC="^RA(78.2,",DIC(0)="AEMQL",DLAYGO=78.2 W ! D ^DIC K DIC,DLAYGO G Q6:Y<0 S (RAFLH,DA)=+Y,DIE="^RA(78.2,",DR="[RA FLASH CARD EDIT]" D ^DIE K DE,DQ,DIE,DR I '$D(^RA(78.2,RAFLH,0)) G Q6 49 S RAFMT=RAFLH,RAK=0 50 F S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 D SETFLH^RAFLH2(RAK) 51 D CMP^RAFLH1 52 W !!,"<<<<<<----------------------------Column No.------------------------------>>>>>>" 53 W !!,"0--------1---------2---------3---------4---------5---------6---------7---------8" 54 W !,"1 0 0 0 0 0 0 0 0",! S RATEST="",RANUM=1,RAFFLF="!" D PRT^RAFLH K RAFFLF W !! G 6 55 Q6 S RAK=0 F S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 D KILFLH^RAFLH2(RAK) 56 K %,%W,%X,%Y,D,D0,D1,DA,FL,RA787,RATEST,RAII,RAK,RAFLH,RAFMT,RANUM,X,Y 57 K POP,I,DDH,DUOUT,DI,DISYS 58 Q 59 ; 60 7 ;;Complication Type Enter/Edit 61 S DIC="^RA(78.1,",DIC(0)="AEMQL",DLAYGO=78.1 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y G Q7 62 S DA=+Y,DIE="^RA(78.1,",DR=".01;2" D ^DIE K %,D,D0,DA,DE,DQ,DIE,DR D Q7 G 7 63 Q7 K DI,DISYS,I,POP Q 64 ; 65 8 ;;Sharing/Contract Agreement Entry/Edit 66 S DIC="^DIC(34,",DIC(0)="AELMQ",DIC("A")="Select Agreement/Contract: ",DLAYGO=34 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y,I,POP Q 67 S DA=+Y,DIE="^DIC(34,",DR=".01:3" D ^DIE K %,%W,%X,%Y,D,D0,DA,DE,DQ,DIE,DR,X,Y,DI,DISYS G 8 68 ; 69 9 ;;Standard Reports 70 S DIC="^RA(74.1,",DIC(0)="AEMQL",DLAYGO=74.1 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y D Q9 Q 71 S DA=+Y,DIE="^RA(74.1,",DR="[RA STANDARD REPORT ENTRY]" D ^DIE K %,%W,%X,%Y,C,D,D0,DA,DE,DQ,DIE,DR,X,Y D Q9 G 9 72 Q9 K DDH,DI,DISYS,I,J,POP 73 Q 74 ; 75 10 ;;Procedure Modifiers Entry 76 K DD,DO,DLAYGO,DIC,DA,DINUM,X,Y 77 S (DIC,DLAYGO)="^RAMIS(71.2,",DIC(0)="AEMQL" 78 S DIC("A")="Select Procedure Modifier: ",DIC("W")="D PROHLP^RAMAIN" 79 W ! D ^DIC K DIC,DLAYGO I +Y'>0 K D,X,Y,POP,I,DDH,DG,DISYS,DUOUT Q 80 S DIE="^RAMIS(71.2,",DA=+Y,DR="3;4" D ^DIE 81 K %W,%X,%Y,D,DIE,DO,DD,DLAYGO,DA,DR,X,Y,POP,I,D0,DI,DISYS,DQ,C G 10 82 ; 83 11 ;;Reports Distribution Edit 84 S DIC="^RABTCH(74.3,",DIC(0)="AEMQ" W ! D ^DIC K DIC I Y<0 K D,X,Y,I,POP Q 85 S DA=+Y,DIE="^RABTCH(74.3,",DR="[RA DISTRIBUTION EDIT]" D ^DIE K %,%W,%X,%Y,D,D0,DA,DE,DQ,DIE,DR,X,Y,DI,DISYS,I,POP G 11 86 ; 87 12 ;;Rad/Nuc Med Procedure Message Enter/Edit 88 S DIC="^RAMIS(71.4,",DIC(0)="AELMQ",DLAYGO=71.4 89 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,DTOUT,DUOUT,X,Y Q 90 S DA=+Y 91 L +^RAMIS(71.4,DA):3 I '$T D G 12 ;*54 92 . K DIR S DIR(0)="EA",DIR("A")="Sorry, someone else is editing that entry. <cr> - continue " D ^DIR K DIR 93 K RAMLNA,RAMLNB S RAMSGDA=DA ;*50 94 S RAMLNA=$G(^RAMIS(71.4,DA,0)) ;*50 95 S DIE="^RAMIS(71.4,",DR=.01 D ^DIE 96 S RAMLNB=$G(^RAMIS(71.4,+$G(DA),0)) ;*50 97 I RAMLNB'=RAMLNA S DA=RAMSGDA D ORDITMS^RAMAIN3 ;*50 98 L -^RAMIS(71.4,RAMSGDA) ;*54 99 K %,%W,%X,%Y,D0,DA,DE,DQ,DR,DIE,X,Y,RAMLNA,RAMLNB,RAMSGDA 100 G 12 101 ; 102 13 ;;Cost of Procedure Enter/Edit 103 I '$D(RACCESS(DUZ)) D SET^RAPSET1 I $D(XQUIT) K RACCESS,XQUIT Q 104 ; ask img type 105 K ^TMP($J,"RA I-TYPE") D SELIMG^RAUTL7 G:$G(RAQUIT) 139 106 N RA0,RA1,RA2 S RA0="",RA2="" 107 131 S RA0=$O(^TMP($J,"RA I-TYPE",RA0)) G:RA0="" 133 108 132 S RA1=$O(^TMP($J,"RA I-TYPE",RA0,0)) G:'RA1 131 109 S RA2=RA1_U_RA2 G 131 110 133 G:RA2="" 139 S DIC="^RAMIS(71,",DIC(0)="AEMQ" 111 ; restrict choice of procedure by img type selected 112 S DIC("S")="I RA2[$P(^(0),U,12)" 113 W ! D ^DIC K DIC I Y<0 K %,DTOUT,DUOUT,DIC,X,Y G 139 114 S DA=+Y,DIE="^RAMIS(71,",DR=10 D ^DIE 115 K D,D0,DA,DDH,DI,DIC,DIE,DQ,DR,X 116 G 133 117 139 K ^TMP($J,"RA I-TYPE"),RAQUIT 118 Q 119 ; 120 PROHLP ; Help displays the modifiers and all associated imaging types. 121 D:'$D(IOM) HOME^%ZIS 122 N RAIT,RAIT1,RAIT2,RAIT3 Q:'+$O(^RAMIS(71.2,+Y,1,0)) ; Quit, no data 123 S (RAIT,RAIT3)=0 124 F S RAIT=+$O(^RAMIS(71.2,+Y,1,RAIT)) W:'RAIT ")" Q:'RAIT D 125 . S RAIT1=+$G(^RAMIS(71.2,+Y,1,RAIT,0)) 126 . S RAIT2=$P($G(^RA(79.2,RAIT1,0)),"^",3) 127 . W:($X+5)>IOM !?2 W ?$X+1 W:'RAIT3 "(" W RAIT2 S RAIT3=1 128 . Q 129 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAMAIN2.m
r613 r623 1 RAMAIN2 ;HISC/GJC-Radiology Utility File Maintenance (Part Two) ;8/15/05 10:07am 2 ;;5.0;Radiology/Nuclear Medicine;**45,62,71,65**;Mar 16, 1998;Build 8 3 ; 08/12/2005 bay/kam Remedy Call 104630 Patch 62 4 ; 03/02/2006 BAY/KAM Remedy Call 131482 Patch RA*5*71 5 ; 6 ;Supported IA #10141 reference to MES^XPDUTL 7 ;Supported IA #10142 reference to EN^DDIOL 8 ;Supported IA #10103 reference to DT^XLFDT 9 ; 10 2 ;;Procedure Enter/Edit 11 ; *** This subroutine once resided in RAMAIN i.e, '2^RAMAIN'. *** 12 ; RA PROCEDURE option 13 N RACTIVE,RAENALL,RAY,RAFILE,RASTAT,RAXIT 14 S (RAENALL,RANEW71,RAXIT)=0 15 N RADIO,RAPTY,RAASK,RAROUTE ;used by the edit template 16 F D Q:$G(RAXIT) 17 . K DA,DD,DIC,DINUM,DLAYGO,DO,RACMDIFF,RATRKCMA,RATRKCMB 18 . S DIC="^RAMIS(71,",DIC(0)="QEAMLZ",DLAYGO=71,DIC("DR")=6 19 . W ! D ^DIC K D,DD,DIC,DINUM,DLAYGO,DO 20 . S:+Y<0 RAXIT=1 I $G(RAXIT) K D,X,Y Q 21 . S (DA,RADA)=+Y,RAY=Y,RAFILE=71 22 . ;RA*5*71 changed next line for Remedy Call 131482 23 . S RANEW71=$S($P(Y,U,3)=1:1,1:0) ;used in template, edit CPT Code if new rec. 24 . L +^RAMIS(RAFILE,RADA):5 25 . I '$T D Q 26 .. W !?5,"This record is currently being edited by another user." 27 .. W !?5,"Try again later!",$C(7) S RAXIT=1 28 .. Q 29 . S RAPNM=$P($G(Y(0)),U) ;proc. name for display purposes in template 30 . S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^") 31 . S RASTAT=$S(RACTIVE="":1,RACTIVE>DT:1,1:0) 32 . D TRKCMB^RAMAINU(DA,.RATRKCMB) ;tracks existing 33 . ; CM definition before editing. RATRKCMB ids the before CM values 34 . S DIE="^RAMIS(71,",DR="[RA PROCEDURE EDIT]" D ^DIE 35 . K RAPNM S RAPROC(0)=$G(^RAMIS(71,RADA,0)) 36 . ; 37 . ;check for data consistency between the 'CONTRAST MEDIA USED' & 38 . ;'CONTRAST MEDIA' fields. 39 . D CMINTEG^RAMAINU1(RADA,RAPROC(0)) 40 . ; 41 . D TRKCMA^RAMAINU(RADA,RATRKCMB,.RATRKCMA,.RACMDIFF) 42 . I $O(^RAMIS(71,RADA,"NUC",0)),($P(RAPROC(0),"^",2)=1) D DELRADE(RADA) 43 . S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^") 44 . S RASTAT=RASTAT_"^"_$S(RACTIVE="":1,RACTIVE>DT:1,1:0) 45 . ; 08/12/2005 104630 KAM - added '$G(RANEW71) to next line 46 . I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)),'+$G(RANEW71) D 47 .. K %,C,D0,DE,DI,DIE,DQ,DR 48 .. W !?5,$C(7),"...no CPT code entered..." 49 .. W !?5,"...will change type to a 'broad' procedure.",! 50 .. S DA=RADA,DIE="^RAMIS(71,",DR="6///B" D ^DIE 51 .. Q 52 . ;08/12/2005 104630 - KAM added next 5 lines 53 . I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)),+$G(RANEW71) D 54 .. K %,C,D0,DE,DI,DIK,DQ,DR 55 .. W !?5,$C(7),"...no CPT code entered..." 56 .. W !?5,"...will delete the record at this time.",! 57 .. S DIK="^RAMIS(71,",DA=RADA D ^DIK K DIK 58 . ;if an active parent w/o descendants, inactivate the parent 59 . I $P(RASTAT,U,2),($P(RAPROC(0),U,6)="P"),('$O(^RAMIS(71,RADA,4,0))) D 60 .. K D,D0,D1,DA,DI,DIC,DIE,DQ,DR 61 .. W !!?5,"Inactivating this parent procedure - no descendents.",!,$C(7) 62 .. S DA=RADA,DIE="^RAMIS(71,",DR="100///"_$S($D(DT):DT,1:$$DT^XLFDT()) 63 .. D ^DIE K D,D0,D1,DA,DI,DIC,DIE,DQ,DR S $P(RASTAT,U,2)=0 ;inactive 64 .. Q 65 . I $P($G(^RA(79.2,+$P(RAPROC(0),U,12),0)),U,5)="Y",(+$O(^RAMIS(71,RADA,"NUC",0))) D VRDIO(RADA) 66 . I "^B^P^"[(U_$P(RAPROC(0),U,6)_U),($P(RAPROC(0),U,9)]"") D 67 .. K %,D,D0,DA,DE,DIC,DIE,DQ,DR 68 .. S DA=RADA,DIE="^RAMIS(71,",DR="9///@" D ^DIE 69 .. W !!?5,"...CPT code deleted because "_$S($P(RAPROC(0),U,6)="B":"Broad",1:"Parent")_" procedures",!?5,"should not have CPT codes.",!,$C(7) 70 .. Q 71 . K %,%X,%Y,C,D,D0,D1,DA,DE,DI,DIE,DQ,DR,RAIMAG,RAMIS,RAPROC,X,Y 72 .;send Orderable Item HL7 msg to CPRS if the ORDER DIALOG (#101.41) 73 .;file exists unconditionally 74 .D:$$ORQUIK^RAORDU()=1 PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY) 75 .; 76 . L -^RAMIS(RAFILE,RADA) K RADA 77 .;unconditionally update the parent procedure if the descendent 78 .I $O(^RAMIS(71,"ADESC",+RAY,0)) D UPDATP^RAO7UTL(RAY) 79 .;has been edited 80 . Q 81 K DIR,RACMDIFF,RATRKCMA,RATRKCMB 82 S DIR(0)="YA",DIR("B")="NO" 83 S DIR("A")="Want to run a validity check on CPT and stop codes? " 84 S DIR("?",1)="Answer 'YES' to print a list of Radiology/Nuclear Medicine Procedures" 85 S DIR("?",2)="with missing or invalid CPT's and/or Credit Clinic Stop Code(s)." 86 S DIR("?",3)="Broad procedures with invalid codes are included for information" 87 S DIR("?",4)="only. Inactive procedures are not required to have valid codes." 88 S DIR("?",5)="To be valid, Stop Codes must be in the Imaging Stop Codes file 71.5;" 89 S DIR("?",6)="CPT's must be nationally active." 90 S DIR("?")="Please answer 'YES' or 'NO'." 91 W ! D ^DIR K DIR G:$D(DIRUT) EXIT 92 D:Y ^RAPERR 93 EXIT K RADA,RANEW71,X,Y 94 Q 95 13 ;;Rad/Nuc Med Common Procedure File Enter/Edit 96 ; RA COMMON PROCEDURE option 97 N RADA,RAENALL,RAY,RAFILE,RALOW,RAMIS713,RASTAT,RAIMGTYI S RAENALL=0 98 W ! D EN1^RAUTL17 G:Y'>0 Q13 S RAIMGTYI=Y 99 131 S DIC="^RAMIS(71.3,",DIC(0)="AELMQZ",DLAYGO=71.3 100 S DIC("S")="N RA S RA=+$P(^(0),U) I RAIMGTYI=$P($G(^RAMIS(71,RA,0)),U,12)" 101 S DIC("W")="N RA4 S RA4=$P($G(^(0)),""^"",4) W:RA4]"""" "" (""_RA4_"")"" W:RA4']"""" "" (no sequence number)""" 102 W ! D ^DIC K DIC,DLAYGO,D,X 103 I Y<0 D Q13 G RESEQ 104 ; If a sequence # exists, the Common Proc. is active 105 S RADA=+Y,RAY=Y,RAFILE=71.3 L +^RAMIS(RAFILE,RADA):5 106 I '$T D G Q13 107 . W !?5,"This record is currently being edited by another user." 108 . W !?5,"Try again later!",$C(7) 109 . Q 110 S RASTAT=$S($P(Y(0),"^",4)]"":1,1:0)_"^" 111 I '+$P(RASTAT,"^") S RALOW=$$LOW(RAIMGTYI) 112 S DA=RADA,DIE="^RAMIS(71.3,",DR="[RA COMMON PROCEDURE EDIT]" D ^DIE 113 S RAMIS713(0)=$G(^RAMIS(71.3,RADA,0)) 114 ; If the procedure is different than the one originally selected and 115 ; the CPRS Order Dialog file exists, send the Orderable Item Update 116 ; message to CPRS. 117 I $P(RAMIS713(0),"^")'=$P(RAY,"^",2),($$ORQUIK^RAORDU()=1) D 118 . S RASTAT=RASTAT_0 D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY) 119 . S RAY=RADA_"^"_$P($G(^RAMIS(71.3,RADA,0)),"^")_"^"_1,RASTAT=0_"^" 120 . Q 121 K %,%X,%Y,C,D,D0,DA,DE,DI,DIE,DQ,DR,X,Y 122 S RASTAT=RASTAT_$S($P($G(^RAMIS(71.3,+RAY,0)),"^",4)]"":1,1:0) 123 ; If before & after statuses differ, and the CPRS Order Dialog file 124 ; exists, send the Orderable Item Update message to CPRS. 125 I $$ORQUIK^RAORDU()=1,(($P(RASTAT,"^")+$P(RASTAT,"^",2))=1) D 126 . D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY) 127 . Q 128 L -^RAMIS(RAFILE,RADA) 129 G 131 130 Q13 K DDC,DDH,DISYS,I,POP,RA713 131 Q 132 RESEQ ;Resequence the common procedure list 133 N D,D0,DI,DQ,H,I,J,CNT,DIC,DIE,DR,DA,TXT,X 134 I $D(XPDNM) D ; if called during package install 135 . S TXT(1)=" " 136 . S TXT(2)="Resequencing the Rad/Nuc Med Common Procedure List." 137 . Q 138 E W !!?5,"Resequencing the Rad/Nuc Med Common Procedure List" 139 S DIE="^RAMIS(71.3,",(I,CNT)=0 140 F S I=$O(^RAMIS(71.3,"AA",RAIMGTYI,I)) Q:I'>0 D 141 . S J=0 142 . F S J=$O(^RAMIS(71.3,"AA",RAIMGTYI,I,J)) Q:J'>0 I $D(^RAMIS(71.3,J,0)) D 143 .. S DA=J,CNT=CNT+1 N I,J 144 .. S DR="3////^S X=CNT" D ^DIE W:'$D(XPDNM) "." 145 .. Q 146 . Q 147 I $D(XPDNM) D ; if called during package install 148 . S TXT(2)=$G(TXT(2))_" Done!" 149 . D MES^XPDUTL(.TXT) 150 . Q 151 E W " Done!" 152 Q 153 LOW(X) ; Find the lowest available sequence number for a procedure within 154 ; a specific Imaging Type. Seq. #'s range from 1 to 40. If the 155 ; range changes in the DD i.e, ^DD(71.3,3, this code as well as the 156 ; code if EN3^RAUTL18 must also be altered. 157 ; If RAHIT is passed back as "", there is no available sequence number. 158 N RA,RAHIT S RAHIT="" 159 F RA=1:1:40 D Q:RAHIT 160 . Q:$D(^RAMIS(71.3,"AA",X,RA)) 161 . S:RAHIT="" RAHIT=RA 162 . Q 163 Q RAHIT 164 VRDIO(RADA) ; Validate the 'Usual Dose' field within the 'Default Radiopha- 165 ; rmaceuticals' multiple. 'Usual Dose' must fall within the 'Low Adult 166 ; Dose' & 'High Adult Dose' range. This subroutine will display the 167 ; Radiopharmaceutical in question along with the values in question if 168 ; inconsistencies are found. 169 ; 170 ; Input Variable: 'RADA' the ien of the Procedure 171 N RANUC S RADA(1)=RADA,RADA=0 D EN^DDIOL("","","!") 172 F S RADA=$O(^RAMIS(71,RADA(1),"NUC",RADA)) Q:RADA'>0 D 173 . S RANUC(0)=$G(^RAMIS(71,RADA(1),"NUC",RADA,0)) 174 . Q:$P(RANUC(0),"^",2)="" ; no need to validate, nothing input 175 . I '$$USUAL^RADD2(.RADA,$P(RANUC(0),"^",2)) D 176 .. N RARRY S RARRY(1)="For Radiopharmaceutical: " 177 .. S RARRY(1)=RARRY(1)_$$EN1^RAPSAPI(+$P(RANUC(0),"^"),.01)_$C(7) 178 .. S RARRY(2)="" D EN^DDIOL(.RARRY,"") 179 .. Q 180 . Q 181 Q 182 DELRADE(RADA) ; Delete the Default Radiopharmaceuticals multiple 183 N RADA1 S RADA1=0 184 W !!?3,"Deleting default radiopharmaceuticals for this procedure...",! 185 F S RADA1=$O(^RAMIS(71,RADA,"NUC",RADA1)) Q:RADA1'>0 D 186 . K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y 187 . S DA(1)=RADA,DA=RADA1,DIE="^RAMIS(71,"_RADA_",""NUC""," 188 . S DR=".01///@" D ^DIE 189 . Q 190 K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y 191 Q 192 ; 1 RAMAIN2 ;HISC/GJC-Radiology Utility File Maintenance (Part Two) ;8/15/05 10:07am 2 ;;5.0;Radiology/Nuclear Medicine;**45,62,71**;Mar 16, 1998;Build 10 3 ; 08/12/2005 bay/kam Remedy Call 104630 Patch 62 4 ; 03/02/2006 BAY/KAM Remedy Call 131482 Patch RA*5*71 5 2 ;;Procedure Enter/Edit 6 ; *** This subroutine once resided in RAMAIN i.e, '2^RAMAIN'. *** 7 ; RA PROCEDURE option 8 N RACTIVE,RAENALL,RAY,RAFILE,RASTAT,RAXIT 9 S (RAENALL,RANEW71,RAXIT)=0 10 N RADIO,RAPTY,RAASK,RAROUTE ;used by the edit template 11 F D Q:$G(RAXIT) 12 . K DA,DD,DIC,DINUM,DLAYGO,DO,RACMDIFF,RATRKCMA,RATRKCMB 13 . S DIC="^RAMIS(71,",DIC(0)="QEAMLZ",DLAYGO=71,DIC("DR")=6 14 . W ! D ^DIC K D,DD,DIC,DINUM,DLAYGO,DO 15 . S:+Y<0 RAXIT=1 I $G(RAXIT) K D,X,Y Q 16 . S (DA,RADA)=+Y,RAY=Y,RAFILE=71 17 . ;RA*5*71 changed next line for Remedy Call 131482 18 . S RANEW71=$S($P(Y,U,3)=1:1,1:0) ;used in template, edit CPT Code if new rec. 19 . L +^RAMIS(RAFILE,RADA):5 20 . I '$T D Q 21 .. W !?5,"This record is currently being edited by another user." 22 .. W !?5,"Try again later!",$C(7) S RAXIT=1 23 .. Q 24 . S RAPNM=$P($G(Y(0)),U) ;proc. name for display purposes in template 25 . S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^") 26 . S RASTAT=$S(RACTIVE="":1,RACTIVE>DT:1,1:0) 27 . D TRKCMB^RAMAINU(DA,.RATRKCMB) ;tracks existing 28 . ; CM definition before editing. RATRKCMB ids the before CM values 29 . S DIE="^RAMIS(71,",DR="[RA PROCEDURE EDIT]" D ^DIE 30 . K RAPNM S RAPROC(0)=$G(^RAMIS(71,RADA,0)) 31 . ; 32 . ;check for data consistency between the 'CONTRAST MEDIA USED' & 33 . ;'CONTRAST MEDIA' fields. 34 . D CMINTEG^RAMAINU1(RADA,RAPROC(0)) 35 . ; 36 . D TRKCMA^RAMAINU(RADA,RATRKCMB,.RATRKCMA,.RACMDIFF) 37 . I $O(^RAMIS(71,RADA,"NUC",0)),($P(RAPROC(0),"^",2)=1) D DELRADE(RADA) 38 . S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^") 39 . S RASTAT=RASTAT_"^"_$S(RACTIVE="":1,RACTIVE>DT:1,1:0) 40 . ; 08/12/2005 104630 KAM - added '$G(RANEW71) to next line 41 . I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)),'+$G(RANEW71) D 42 .. K %,C,D0,DE,DI,DIE,DQ,DR 43 .. W !?5,$C(7),"...no CPT code entered..." 44 .. W !?5,"...will change type to a 'broad' procedure.",! 45 .. S DA=RADA,DIE="^RAMIS(71,",DR="6///B" D ^DIE 46 .. Q 47 . ;08/12/2005 104630 - KAM added next 5 lines 48 . I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)),+$G(RANEW71) D 49 .. K %,C,D0,DE,DI,DIK,DQ,DR 50 .. W !?5,$C(7),"...no CPT code entered..." 51 .. W !?5,"...will delete the record at this time.",! 52 .. S DIK="^RAMIS(71,",DA=RADA D ^DIK K DIK 53 . ;if an active parent w/o descendants, inactivate the parent 54 . I $P(RASTAT,U,2),($P(RAPROC(0),U,6)="P"),('$O(^RAMIS(71,RADA,4,0))) D 55 .. K D,D0,D1,DA,DI,DIC,DIE,DQ,DR 56 .. W !!?5,"Inactivating this parent procedure - no descendents.",!,$C(7) 57 .. S DA=RADA,DIE="^RAMIS(71,",DR="100///"_$S($D(DT):DT,1:$$DT^XLFDT()) 58 .. D ^DIE K D,D0,D1,DA,DI,DIC,DIE,DQ,DR S $P(RASTAT,U,2)=0 ;inactive 59 .. Q 60 . I $P($G(^RA(79.2,+$P(RAPROC(0),U,12),0)),U,5)="Y",(+$O(^RAMIS(71,RADA,"NUC",0))) D VRDIO(RADA) 61 . I "^B^P^"[(U_$P(RAPROC(0),U,6)_U),($P(RAPROC(0),U,9)]"") D 62 .. K %,D,D0,DA,DE,DIC,DIE,DQ,DR 63 .. S DA=RADA,DIE="^RAMIS(71,",DR="9///@" D ^DIE 64 .. W !!?5,"...CPT code deleted because "_$S($P(RAPROC(0),U,6)="B":"Broad",1:"Parent")_" procedures",!?5,"should not have CPT codes.",!,$C(7) 65 .. Q 66 . K %,%X,%Y,C,D,D0,D1,DA,DE,DI,DIE,DQ,DR,RAIMAG,RAMIS,RAPROC,X,Y 67 .;send Orderable Item HL7 msg to CPRS if the ORDER DIALOG (#101.41) 68 .;file exists unconditionally 69 .D:$$ORQUIK^RAORDU()=1 PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY) 70 .; 71 . L -^RAMIS(RAFILE,RADA) K RADA 72 .;unconditionally update the parent procedure if the descendent 73 .I $O(^RAMIS(71,"ADESC",+RAY,0)) D UPDATP^RAO7UTL(RAY) 74 .;has been edited 75 . Q 76 K DIR,RACMDIFF,RATRKCMA,RATRKCMB 77 S DIR(0)="YA",DIR("B")="NO" 78 S DIR("A")="Want to run a validity check on CPT and stop codes? " 79 S DIR("?",1)="Answer 'YES' to print a list of Radiology/Nuclear Medicine Procedures" 80 S DIR("?",2)="with missing or invalid CPT's and/or Credit Clinic Stop Code(s)." 81 S DIR("?",3)="Broad procedures with invalid codes are included for information" 82 S DIR("?",4)="only. Inactive procedures are not required to have valid codes." 83 S DIR("?",5)="To be valid, Stop Codes must be in the Imaging Stop Codes file 71.5;" 84 S DIR("?",6)="CPT's must be nationally active." 85 S DIR("?")="Please answer 'YES' or 'NO'." 86 W ! D ^DIR K DIR G:$D(DIRUT) EXIT 87 D:Y ^RAPERR 88 EXIT K RADA,RANEW71,X,Y 89 Q 90 13 ;;Rad/Nuc Med Common Procedure File Enter/Edit 91 ; RA COMMON PROCEDURE option 92 N RADA,RAENALL,RAY,RAFILE,RALOW,RAMIS713,RASTAT,RAIMGTYI S RAENALL=0 93 W ! D EN1^RAUTL17 G:Y'>0 Q13 S RAIMGTYI=Y 94 131 S DIC="^RAMIS(71.3,",DIC(0)="AELMQZ",DLAYGO=71.3 95 S DIC("S")="N RA S RA=+$P(^(0),U) I RAIMGTYI=$P($G(^RAMIS(71,RA,0)),U,12)" 96 S DIC("W")="N RA4 S RA4=$P($G(^(0)),""^"",4) W:RA4]"""" "" (""_RA4_"")"" W:RA4']"""" "" (no sequence number)""" 97 W ! D ^DIC K DIC,DLAYGO,D,X 98 I Y<0 D Q13 G RESEQ 99 ; If a sequence # exists, the Common Proc. is active 100 S RADA=+Y,RAY=Y,RAFILE=71.3 L +^RAMIS(RAFILE,RADA):5 101 I '$T D G Q13 102 . W !?5,"This record is currently being edited by another user." 103 . W !?5,"Try again later!",$C(7) 104 . Q 105 S RASTAT=$S($P(Y(0),"^",4)]"":1,1:0)_"^" 106 I '+$P(RASTAT,"^") S RALOW=$$LOW(RAIMGTYI) 107 S DA=RADA,DIE="^RAMIS(71.3,",DR="[RA COMMON PROCEDURE EDIT]" D ^DIE 108 S RAMIS713(0)=$G(^RAMIS(71.3,RADA,0)) 109 ; If the procedure is different than the one originally selected and 110 ; the CPRS Order Dialog file exists, send the Orderable Item Update 111 ; message to CPRS. 112 I $P(RAMIS713(0),"^")'=$P(RAY,"^",2),($$ORQUIK^RAORDU()=1) D 113 . S RASTAT=RASTAT_0 D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY) 114 . S RAY=RADA_"^"_$P($G(^RAMIS(71.3,RADA,0)),"^")_"^"_1,RASTAT=0_"^" 115 . Q 116 K %,%X,%Y,C,D,D0,DA,DE,DI,DIE,DQ,DR,X,Y 117 S RASTAT=RASTAT_$S($P($G(^RAMIS(71.3,+RAY,0)),"^",4)]"":1,1:0) 118 ; If before & after statuses differ, and the CPRS Order Dialog file 119 ; exists, send the Orderable Item Update message to CPRS. 120 I $$ORQUIK^RAORDU()=1,(($P(RASTAT,"^")+$P(RASTAT,"^",2))=1) D 121 . D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY) 122 . Q 123 L -^RAMIS(RAFILE,RADA) 124 G 131 125 Q13 K DDC,DDH,DISYS,I,POP,RA713 126 Q 127 RESEQ ;Resequence the common procedure list 128 N D,D0,DI,DQ,H,I,J,CNT,DIC,DIE,DR,DA,TXT,X 129 I $D(XPDNM) D ; if called during package install 130 . S TXT(1)=" " 131 . S TXT(2)="Resequencing the Rad/Nuc Med Common Procedure List." 132 . Q 133 E W !!?5,"Resequencing the Rad/Nuc Med Common Procedure List" 134 S DIE="^RAMIS(71.3,",(I,CNT)=0 135 F S I=$O(^RAMIS(71.3,"AA",RAIMGTYI,I)) Q:I'>0 D 136 . S J=0 137 . F S J=$O(^RAMIS(71.3,"AA",RAIMGTYI,I,J)) Q:J'>0 I $D(^RAMIS(71.3,J,0)) D 138 .. S DA=J,CNT=CNT+1 N I,J 139 .. S DR="3////^S X=CNT" D ^DIE W:'$D(XPDNM) "." 140 .. Q 141 . Q 142 I $D(XPDNM) D ; if called during package install 143 . S TXT(2)=$G(TXT(2))_" Done!" 144 . D MES^XPDUTL(.TXT) 145 . Q 146 E W " Done!" 147 Q 148 LOW(X) ; Find the lowest available sequence number for a procedure within 149 ; a specific Imaging Type. Seq. #'s range from 1 to 40. If the 150 ; range changes in the DD i.e, ^DD(71.3,3, this code as well as the 151 ; code if EN3^RAUTL18 must also be altered. 152 ; If RAHIT is passed back as "", there is no available sequence number. 153 N RA,RAHIT S RAHIT="" 154 F RA=1:1:40 D Q:RAHIT 155 . Q:$D(^RAMIS(71.3,"AA",X,RA)) 156 . S:RAHIT="" RAHIT=RA 157 . Q 158 Q RAHIT 159 VRDIO(RADA) ; Validate the 'Usual Dose' field within the 'Default Radiopha- 160 ; rmaceuticals' multiple. 'Usual Dose' must fall within the 'Low Adult 161 ; Dose' & 'High Adult Dose' range. This subroutine will display the 162 ; Radiopharmaceutical in question along with the values in question if 163 ; inconsistencies are found. 164 ; 165 ; Input Variable: 'RADA' the ien of the Procedure 166 N RANUC S RADA(1)=RADA,RADA=0 D EN^DDIOL("","","!") 167 F S RADA=$O(^RAMIS(71,RADA(1),"NUC",RADA)) Q:RADA'>0 D 168 . S RANUC(0)=$G(^RAMIS(71,RADA(1),"NUC",RADA,0)) 169 . Q:$P(RANUC(0),"^",2)="" ; no need to validate, nothing input 170 . I '$$USUAL^RADD2(.RADA,$P(RANUC(0),"^",2)) D 171 .. N RARRY S RARRY(1)="For Radiopharmaceutical: " 172 .. S RARRY(1)=RARRY(1)_$$GET1^DIQ(50,+$P(RANUC(0),"^")_",",.01)_$C(7) 173 .. S RARRY(2)="" D EN^DDIOL(.RARRY,"") 174 .. Q 175 . Q 176 Q 177 DELRADE(RADA) ; Delete the Default Radiopharmaceuticals multiple 178 N RADA1 S RADA1=0 179 W !!?3,"Deleting default radiopharmaceuticals for this procedure...",! 180 F S RADA1=$O(^RAMIS(71,RADA,"NUC",RADA1)) Q:RADA1'>0 D 181 . K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y 182 . S DA(1)=RADA,DA=RADA1,DIE="^RAMIS(71,"_RADA_",""NUC""," 183 . S DR=".01///@" D ^DIE 184 . Q 185 K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y 186 Q 187 ; -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RANMED1.m
r613 r623 1 RANMED1 ;HISC/SWM-Nuclear Medicine Enter/Edit Routine ;1/21/97 11:07 2 ;;5.0;Radiology/Nuclear Medicine;**65**;Mar 16, 1998;Build 8 3 ; 4 ;Supported IA #10142 reference to EN^DDIOL 5 ;DBIA: 4551 DIC^PSSDI looks up & screens records from file #50 6 ROUTE ; Enter/Edit file 71.6 7 W ! N RA1,RA2 S RA1=0 8 S DIC="^RAMIS(71.6,",DIC(0)="AEQLMZ" D ^DIC 9 G:+Y<1 EXIT S DA=+Y,DIE=DIC,DR=".01;100" D ^DIE 10 W !!?5,"Current parameters for entry of sites for this route :" 11 W !!?5,"PROMPT FOR FREE TEXT SITE? = ",$P(^RAMIS(71.6,DA,0),U,3) 12 W !?5,"VALID SITES OF ADMINISTRATION = " F S RA1=$O(^RAMIS(71.6,DA,"SITE",RA1)) Q:'RA1 I +^(RA1,0) S RA2=$P(^RAMIS(71.7,+^(0),0),U) W:($L(RA2)+2+$X)>80 !?10 W RA2 W:$O(^RAMIS(71.6,DA,"SITE",RA1)) ";" W " " 13 W !!?21,"-- NOTE -- ",!?10,"If 'PROMPT FOR FREE TEXT SITE?' is 'Y',",!?10,"then users will not be given a selection",!?10,"of predefined 'VALID SITES'" 14 S DIR(0)="SO^P:PROMPT FOR FREE TEXT SITE?;V:VALID SITES OF ADMINISTRATION" 15 S DIR("A")="Edit which field" 16 D ^DIR 17 G:$G(DIRUT) ROUTE 18 S DR=$S(X="V":2,X="P":3,1:"") G:'DR ROUTE 19 D ^DIE 20 G ROUTE 21 SITE ; Enter/Edit file 71.7 22 W ! 23 S DIC="^RAMIS(71.7,",DIC(0)="AEQLMZ" D ^DIC 24 G:+Y<1 EXIT S DA=+Y S DIE=DIC,DR=".01:999" D ^DIE 25 G SITE 26 SOURCE ; Enter/Edit file 71.8 27 W ! 28 S DIC="^RAMIS(71.8,",DIC(0)="AEQLMZ" D ^DIC 29 G:+Y<1 EXIT S DA=+Y S DIE=DIC,DR=".01:999" D ^DIE 30 G SOURCE 31 LOT ; Enter/Edit file 71.9 32 ;RA*5*65 SG 33 N DA,DIC,DIDEL,DIE,DINUM,DLAYGO,DR,DTOUT,DUOUT,EXIT,TMP,X,Y 34 S EXIT=0 35 F D Q:EXIT 36 . ;--- Select a record 37 . S DIC="^RAMIS(71.9,",DIC(0)="AEQLMSZ" 38 . W ! D ^DIC 39 . I Y'>0 S EXIT=1 Q 40 . ;--- Edit the record 41 . S DA=+Y,DIE=DIC 42 . S DR=".01:4;5///^S X=$$RXEDIT^RAPSAPI3(""R"","""_DA_","",71.9,5,DT);6" 43 . D ^DIE 44 Q 45 WARN ; Warn if dose is out-of-range, called from [RA EXAM EDIT] 46 Q:'$D(RADTI)!('$D(RADFN)) 47 N RA1,RAXDIV,RADOT S RA1=0 ; RAXDIV=exam's division 48 S $P(RADOT,"o ",40)="" 49 S RAXDIV=+$P(^RADPT(RADFN,"DT",RADTI,0),U,3) 50 I '$O(^RA(79,RAXDIV,"RWARN",0)) W !!,RADOT,!?14,"This dose level requires a written, dated and signed",!?27,"directive by a physician.",!,RADOT,! Q 51 W !,RADOT 52 F S RA1=$O(^RA(79,RAXDIV,"RWARN",RA1)) Q:'RA1 W !?((80-$L(^(RA1,0)))/2),^(0) 53 W !,RADOT,! 54 Q 55 EXIT K DIC,DIE,DIR,DA,DR,DIRUT 56 K C,D,D0,DDH,DG,DI,DISYS,DQ,DST,DUOUT,I,POP 57 K RA719IEN,RAFDA,DIE,DA,DR,RAVACL,RAYN,RAENTRY,RA50IEN,RANODEL,RASTUFF 58 K RAHLP3,RAFIN 59 Q 60 DUPL ;check for duplicate entry into file 71.9 61 Q:'$O(^RAMIS(71.9,"B",X,0)) 62 Q:'$D(RAOPT("NM EDIT LOT")) ;prevent msg appearing in other options 63 N RA 64 S RA(1)="**WARNING** An entry already exists for LOT NUMBER/ID = "_X 65 S RA(1,"F")="!!?7,*7" 66 S RA(2)="If you want to add another LOT NUMBER/ID with the same value" 67 S RA(2,"F")="!!?7" 68 S RA(3)="then put "" "" around the value, eg. """_X_"""" 69 S RA(3,"F")="!?7" 70 S RA(4)="" 71 S RA(4,"F")="!!" 72 D EN^DDIOL(.RA) 73 Q 1 RANMED1 ;HISC/SWM-Nuclear Medicine Enter/Edit Routine ;1/21/97 11:07 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 3 ROUTE ; Enter/Edit file 71.6 4 W ! N RA1,RA2 S RA1=0 5 S DIC="^RAMIS(71.6,",DIC(0)="AEQLMZ" D ^DIC 6 G:+Y<1 EXIT S DA=+Y,DIE=DIC,DR=".01;100" D ^DIE 7 W !!?5,"Current parameters for entry of sites for this route :" 8 W !!?5,"PROMPT FOR FREE TEXT SITE? = ",$P(^RAMIS(71.6,DA,0),U,3) 9 W !?5,"VALID SITES OF ADMINISTRATION = " F S RA1=$O(^RAMIS(71.6,DA,"SITE",RA1)) Q:'RA1 I +^(RA1,0) S RA2=$P(^RAMIS(71.7,+^(0),0),U) W:($L(RA2)+2+$X)>80 !?10 W RA2 W:$O(^RAMIS(71.6,DA,"SITE",RA1)) ";" W " " 10 W !!?21,"-- NOTE -- ",!?10,"If 'PROMPT FOR FREE TEXT SITE?' is 'Y',",!?10,"then users will not be given a selection",!?10,"of predefined 'VALID SITES'" 11 S DIR(0)="SO^P:PROMPT FOR FREE TEXT SITE?;V:VALID SITES OF ADMINISTRATION" 12 S DIR("A")="Edit which field" 13 D ^DIR 14 G:$G(DIRUT) ROUTE 15 S DR=$S(X="V":2,X="P":3,1:"") G:'DR ROUTE 16 D ^DIE 17 G ROUTE 18 SITE ; Enter/Edit file 71.7 19 W ! 20 S DIC="^RAMIS(71.7,",DIC(0)="AEQLMZ" D ^DIC 21 G:+Y<1 EXIT S DA=+Y S DIE=DIC,DR=".01:999" D ^DIE 22 G SITE 23 SOURCE ; Enter/Edit file 71.8 24 W ! 25 S DIC="^RAMIS(71.8,",DIC(0)="AEQLMZ" D ^DIC 26 G:+Y<1 EXIT S DA=+Y S DIE=DIC,DR=".01:999" D ^DIE 27 G SOURCE 28 LOT ; Enter/Edit file 71.9 29 W ! 30 S DIC="^RAMIS(71.9,",DIC(0)="AEQLMSZ" D ^DIC 31 G:+Y<1 EXIT S DA=+Y S DIE=DIC,DR=".01:999" D ^DIE 32 G LOT 33 WARN ; Warn if dose is out-of-range, called from [RA EXAM EDIT] 34 Q:'$D(RADTI)!('$D(RADFN)) 35 N RA1,RAXDIV,RADOT S RA1=0 ; RAXDIV=exam's division 36 S $P(RADOT,"o ",40)="" 37 S RAXDIV=+$P(^RADPT(RADFN,"DT",RADTI,0),U,3) 38 I '$O(^RA(79,RAXDIV,"RWARN",0)) W !!,RADOT,!?14,"This dose level requires a written, dated and signed",!?27,"directive by a physician.",!,RADOT,! Q 39 W !,RADOT 40 F S RA1=$O(^RA(79,RAXDIV,"RWARN",RA1)) Q:'RA1 W !?((80-$L(^(RA1,0)))/2),^(0) 41 W !,RADOT,! 42 Q 43 EXIT K DIC,DIE,DIR,DA,DR,DIRUT 44 K C,D,D0,DDH,DG,DI,DISYS,DQ,DST,DUOUT,I,POP 45 Q 46 DUPL ;check for duplicate entry into file 71.9 47 Q:'$O(^RAMIS(71.9,"B",X,0)) 48 Q:'$D(RAOPT("NM EDIT LOT")) ;prevent msg appearing in other options 49 N RA 50 S RA(1)="**WARNING** An entry already exists for LOT NUMBER/ID = "_X 51 S RA(1,"F")="!!?7,*7" 52 S RA(2)="If you want to add another LOT NUMBER/ID with the same value" 53 S RA(2,"F")="!!?7" 54 S RA(3)="then put "" "" around the value, eg. """_X_"""" 55 S RA(3,"F")="!?7" 56 S RA(4)="" 57 S RA(4,"F")="!!" 58 D EN^DDIOL(.RA) 59 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RANMUSE2.m
r613 r623 1 RANMUSE2 ;HISC/SWM-Nuclear Medicine Usage reports ;9/3/97 14:37 2 ;;5.0;Radiology/Nuclear Medicine;**65**;Mar 16, 1998;Build 8 3 ; 4 ;Supported IA #10061 reference to DEM^VADPT 5 ; 6 SET ; There are 2 parts: set local arrays and ^tmp() 7 ; 8 ; part 1 -- raseqd(),raseqi(),ranumd(),ranumi() so to reduce 9 ; div and img-typ names to a single number, and so to reduce 10 ; the length of the ^tmp() string 11 ; raseqd("division name")=sequence number for alpha sort order 12 ; raseqi("imaging type name")=sequence number for alpha sort order 13 ; ranumd(sequence number for alpha sort order)="division name" 14 ; ranumi(sequence number for alpha sort order)="imaging type name" 15 ; 16 S RA1=0 F S RA1=$O(^RA(79,RA1)) Q:'RA1 S RA2=$P($G(^(RA1,0)),U) S:RA2 RASEQD($P($G(^DIC(4,+RA2,0)),U))="" 17 S RA1="",RA2=1 F S RA1=$O(RASEQD(RA1)) Q:RA1="" S RASEQD(RA1)=RA2,RANUMD(RA2)=RA1,RA2=RA2+1 18 ; 19 S RA1=0 F S RA1=$O(^RA(79.2,RA1)) Q:'RA1 S RA2=$P($G(^(RA1,0)),U) S:RA2]"" RASEQI(RA2)="" 20 S RA1="",RA2=1 F S RA1=$O(RASEQI(RA1)) Q:RA1="" S RASEQI(RA1)=RA2,RANUMI(RA2)=RA1,RA2=RA2+1 21 ; 22 ; part 2 -- ^TMP($J,"RA",div,imgtyp,S3,S4,patnam,caseno) 23 ; S3 = sort field 3, either radiopharm/whoadmin or examdttm 24 ; S4 = sort field 4, either examdttm or radiopharm/whoadmin 25 ; 26 ; Loop thru ^RADPTN("AB" to select recs within requested date range 27 ; 28 S RA0=RADTBEG-.0001 29 S1 S RA0=$O(^RADPTN("AB",RA0)) Q:RA0="" Q:RA0>RADTEND S RA1=0 30 S2 S RA1=$O(^RADPTN("AB",RA0,RA1)) G:RA1="" S1 31 S RAN0=$G(^RADPTN(RA1,0)) G:RAN0="" S2 32 S RADFN=$P(RAN0,U) G:RADFN="" S2 33 S RADTI=9999999.9999-$P(RAN0,U,2) G:RADTI="" S2 34 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",$P(RAN0,U,3),0)) G:RACNI="" S2 35 D EXTRACT 36 G S2 37 EXTRACT ; 38 S P02=$G(^RADPT(RADFN,"DT",RADTI,0)) Q:P02="" 39 S P03=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q:P03="" 40 S RADIVNAM=$P($G(^DIC(4,+$P(P02,U,3),0)),U) 41 Q:'$D(^TMP($J,"RA D-TYPE",RADIVNAM)) ; div not selected 42 S RAIMGNAM=$P($G(^RA(79.2,+$P(P02,U,2),0)),U) 43 Q:'$D(^TMP($J,"RA I-TYPE",RAIMGNAM)) ; img typ not selected 44 S RA2=0 45 F1 S RA2=$O(^RADPTN(RA1,"NUC",RA2)) Q:RA2'=+RA2 46 S RANUC=^RADPTN(RA1,"NUC",RA2,0) 47 S RACN=$P(RAN0,U,3) 48 S RADIOPH=$$EN1^RAPSAPI(+$P(RANUC,U),.01) ; Radiopharm Name 49 I 'RAINPUT,RATITLE["Usage",'$D(^TMP($J,"RA EITHER",RADIOPH)) G F1 ;radioph not selectd 50 S RAWHO=$P($G(^VA(200,+$P(RANUC,U,9),0)),U) ; who administered dose 51 I RATITLE["Admin",RAWHO="" G F1 ;who admin dose is unknown 52 I 'RAINPUT,RATITLE["Admin",'$D(^TMP($J,"RA EITHER",RAWHO)) G F1 ;who not selectd 53 S RAXMDTM=$P(RAN0,U,2) ; exam date/time 54 S RAPRC0=$G(^RAMIS(71,+$P(P03,U,2),0)) ; procedure 0-node 55 S RAPRCNAM=$P(RAPRC0,U) ; procedure name 56 S DFN=RADFN D DEM^VADPT 57 S RAPATNAM=$P(VADM(1),U) ; patient name 58 S RASSN=$P(VADM(2),U,2) ; ssn 59 K VADM 60 S RADOSE=$P(RANUC,U,7) ; dose administered 61 S RADRAWN=$P(RANUC,U,4) ; activity drawn 62 I 'RADOSE,'RADRAWN G F1 ; dose admin and drawn both null/zero 63 ; ien of procedure sub-record with matching radiopharm 64 ; if user changes default radiopharm entry, or 65 ; adds a radiopharm that's not defined in file 71 default radiopharm, 66 ; the high and low values would be unknown 67 S RANUC1=$O(^RAMIS(71,+$P(P03,U,2),"NUC","B",+$P(RANUC,U),0)) 68 ; 0-node of procedure sub-record with matching radiopharm 69 S:RANUC1 RANUC1=^RAMIS(71,+$P(P03,U,2),"NUC",+RANUC1,0) 70 S RAHIGH=$P(RANUC1,U,5) ; high adult dose 71 S RALOW=$P(RANUC1,U,6) ; low adult dose 72 S RASTERSK="" 73 I RADOSE>0,RALOW>0,RADOSE<RALOW S RASTERSK="*" 74 I RADOSE>0,RAHIGH>0,RADOSE>RAHIGH S RASTERSK="*" 75 D S3S4 76 S ^TMP($J,"RA",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),S3,S4,$E(RAPATNAM,1,15),RACN,RADIOPH)=RASSN_U_RADRAWN_U_RADOSE_U_RAHIGH_U_RALOW_U_RAWHO_U_RASTERSK_U_RAPRCNAM 77 I '$D(^TMP($J,"RASUM",$S(RASORT:S3,1:S4),RACN,RASSN)) S ^(RASEQI(RAIMGNAM))=$G(^TMP($J,"RATUNIQ",RASEQD(RADIVNAM),RASEQI(RAIMGNAM)))+1,^(RASEQD(RADIVNAM))=$G(^TMP($J,"RATUNIQ",RASEQD(RADIVNAM)))+1 78 S RAEITHER=$S(RATITLE["Usage":RADIOPH,1:RAWHO) 79 I '$D(^TMP($J,"RASUM",$S(RASORT:S3,1:S4),RACN,RASSN,RAEITHER)) S ^(RAEITHER)=$G(^TMP($J,"RATUNIQ",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+1,^(RAEITHER)=$G(^TMP($J,"RATUNIQ",RASEQD(RADIVNAM),RAEITHER))+1 80 S ^(RASSN)=$G(^TMP($J,"RASUM",$S(RASORT:S3,1:S4),RACN,RASSN))+1 81 S ^(RAEITHER)=$G(^TMP($J,"RASUM",$S(RASORT:S3,1:S4),RACN,RASSN,RAEITHER))+1 82 ; img typ totals 83 S:RASTERSK="*" ^(RAEITHER)=$G(^TMP($J,"RATOUTSD",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+1 84 S ^(RAEITHER)=$G(^TMP($J,"RATDRAWN",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+RADRAWN 85 S ^(RAEITHER)=$G(^TMP($J,"RATDOSE",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+RADOSE 86 ; "ratradio" is used for either radiopharm or who-admin-dose 87 S ^(RAEITHER)=$G(^TMP($J,"RATRADIO",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+1 88 ; division totals 89 S:RASTERSK="*" ^(RAEITHER)=$G(^TMP($J,"RATOUTSD",RASEQD(RADIVNAM),RAEITHER))+1 90 S ^(RAEITHER)=$G(^TMP($J,"RATDRAWN",RASEQD(RADIVNAM),RAEITHER))+RADRAWN 91 S ^(RAEITHER)=$G(^TMP($J,"RATDOSE",RASEQD(RADIVNAM),RAEITHER))+RADOSE 92 S ^(RAEITHER)=$G(^TMP($J,"RATRADIO",RASEQD(RADIVNAM),RAEITHER))+1 93 G F1 94 WRT S RASEQD="" 95 W1 S RASEQD=$O(^TMP($J,"RA",RASEQD)) Q:RASEQD="" S RASEQI="" 96 W2 S RASEQI=$O(^TMP($J,"RA",RASEQD,RASEQI)) G:RASEQI="" W1 S S3="" 97 S:RAPG>0 RAXIT=$$EOS^RAUTL5 Q:$G(RAXIT) D PGHD^RANMUSE3,COLHD^RANMUSE3 98 W3 S S3=$O(^TMP($J,"RA",RASEQD,RASEQI,S3)) G:S3="" W2 S S4="" 99 W4 S S4=$O(^TMP($J,"RA",RASEQD,RASEQI,S3,S4)) G:S4="" W3 S RAPATNAM="" 100 W5 S RAPATNAM=$O(^TMP($J,"RA",RASEQD,RASEQI,S3,S4,RAPATNAM)) G:RAPATNAM="" W4 S RACN="" 101 W6 S RACN=$O(^TMP($J,"RA",RASEQD,RASEQI,S3,S4,RAPATNAM,RACN)) G:RACN="" W5 S RADIOPH="" 102 W7 S RADIOPH=$O(^TMP($J,"RA",RASEQD,RASEQI,S3,S4,RAPATNAM,RACN,RADIOPH)) G:RADIOPH="" W6 S RA1=^(RADIOPH) 103 S RALONGCN=$S(RASORT:S3,1:S4),RALONGCN=$E(RALONGCN,4,7)_$E(RALONGCN,2,3)_"-"_RACN_"@"_$E($P(RALONGCN,".",2)_"000",1,4) 104 S RASSN=$P(RA1,U),RADRAWN=$P(RA1,U,2),RADOSE=$P(RA1,U,3),RAHIGH=$P(RA1,U,4),RALOW=$P(RA1,U,5),RAWHO=$P(RA1,U,6),RASTERSK=$P(RA1,U,7) 105 S RAPRCNAM=$P(RA1,U,8) 106 I ($Y+4)>IOSL!(RAPG=0) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D PGHD^RANMUSE3,COLHD^RANMUSE3 107 W !,RALONGCN,?16,$E(RAPATNAM,1,15),?32,RASSN,?44,$E(RADIOPH,1,15),?59,$J(RADRAWN,10,4),?69,$J(RADOSE,10,4),?79,$J(RALOW,10,4),?89,$J(RAHIGH,10,4),?100,$E(RAPRCNAM,1,15),?116,$E(RAWHO,1,15),?131,RASTERSK 108 G W7 109 S3S4 ; set subscripts 3 and 4 110 I RATITLE["Usage" D Q 111 . I RASORT S S4=$E(RADIOPH,1,15),S3=RAXMDTM 112 . I 'RASORT S S3=$E(RADIOPH,1,15),S4=RAXMDTM 113 . Q 114 I RATITLE["Admin" D Q 115 . I RASORT S S4=$E(RAWHO,1,15),S3=RAXMDTM 116 . I 'RASORT S S3=$E(RAWHO,1,15),S4=RAXMDTM 117 . Q 118 Q 1 RANMUSE2 ;HISC/SWM-Nuclear Medicine Usage reports ;9/3/97 14:37 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 3 SET ; There are 2 parts: set local arrays and ^tmp() 4 ; 5 ; part 1 -- raseqd(),raseqi(),ranumd(),ranumi() so to reduce 6 ; div and img-typ names to a single number, and so to reduce 7 ; the length of the ^tmp() string 8 ; raseqd("division name")=sequence number for alpha sort order 9 ; raseqi("imaging type name")=sequence number for alpha sort order 10 ; ranumd(sequence number for alpha sort order)="division name" 11 ; ranumi(sequence number for alpha sort order)="imaging type name" 12 ; 13 S RA1=0 F S RA1=$O(^RA(79,RA1)) Q:'RA1 S RA2=$P($G(^(RA1,0)),U) S:RA2 RASEQD($P($G(^DIC(4,+RA2,0)),U))="" 14 S RA1="",RA2=1 F S RA1=$O(RASEQD(RA1)) Q:RA1="" S RASEQD(RA1)=RA2,RANUMD(RA2)=RA1,RA2=RA2+1 15 ; 16 S RA1=0 F S RA1=$O(^RA(79.2,RA1)) Q:'RA1 S RA2=$P($G(^(RA1,0)),U) S:RA2]"" RASEQI(RA2)="" 17 S RA1="",RA2=1 F S RA1=$O(RASEQI(RA1)) Q:RA1="" S RASEQI(RA1)=RA2,RANUMI(RA2)=RA1,RA2=RA2+1 18 ; 19 ; part 2 -- ^TMP($J,"RA",div,imgtyp,S3,S4,patnam,caseno) 20 ; S3 = sort field 3, either radiopharm/whoadmin or examdttm 21 ; S4 = sort field 4, either examdttm or radiopharm/whoadmin 22 ; 23 ; Loop thru ^RADPTN("AB" to select recs within requested date range 24 ; 25 S RA0=RADTBEG-.0001 26 S1 S RA0=$O(^RADPTN("AB",RA0)) Q:RA0="" Q:RA0>RADTEND S RA1=0 27 S2 S RA1=$O(^RADPTN("AB",RA0,RA1)) G:RA1="" S1 28 S RAN0=$G(^RADPTN(RA1,0)) G:RAN0="" S2 29 S RADFN=$P(RAN0,U) G:RADFN="" S2 30 S RADTI=9999999.9999-$P(RAN0,U,2) G:RADTI="" S2 31 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",$P(RAN0,U,3),0)) G:RACNI="" S2 32 D EXTRACT 33 G S2 34 EXTRACT ; 35 S P02=$G(^RADPT(RADFN,"DT",RADTI,0)) Q:P02="" 36 S P03=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q:P03="" 37 S RADIVNAM=$P($G(^DIC(4,+$P(P02,U,3),0)),U) 38 Q:'$D(^TMP($J,"RA D-TYPE",RADIVNAM)) ; div not selected 39 S RAIMGNAM=$P($G(^RA(79.2,+$P(P02,U,2),0)),U) 40 Q:'$D(^TMP($J,"RA I-TYPE",RAIMGNAM)) ; img typ not selected 41 S RA2=0 42 F1 S RA2=$O(^RADPTN(RA1,"NUC",RA2)) Q:RA2'=+RA2 43 S RANUC=^RADPTN(RA1,"NUC",RA2,0) 44 S RACN=$P(RAN0,U,3) 45 S RADIOPH=$P($G(^PSDRUG(+$P(RANUC,U),0)),U) ; Radiopharm Name 46 I 'RAINPUT,RATITLE["Usage",'$D(^TMP($J,"RA EITHER",RADIOPH)) G F1 ;radioph not selectd 47 S RAWHO=$P($G(^VA(200,+$P(RANUC,U,9),0)),U) ; who administered dose 48 I RATITLE["Admin",RAWHO="" G F1 ;who admin dose is unknown 49 I 'RAINPUT,RATITLE["Admin",'$D(^TMP($J,"RA EITHER",RAWHO)) G F1 ;who not selectd 50 S RAXMDTM=$P(RAN0,U,2) ; exam date/time 51 S RAPRC0=$G(^RAMIS(71,+$P(P03,U,2),0)) ; procedure 0-node 52 S RAPRCNAM=$P(RAPRC0,U) ; procedure name 53 S DFN=RADFN D DEM^VADPT 54 S RAPATNAM=$P(VADM(1),U) ; patient name 55 S RASSN=$P(VADM(2),U,2) ; ssn 56 K VADM 57 S RADOSE=$P(RANUC,U,7) ; dose administered 58 S RADRAWN=$P(RANUC,U,4) ; activity drawn 59 I 'RADOSE,'RADRAWN G F1 ; dose admin and drawn both null/zero 60 ; ien of procedure sub-record with matching radiopharm 61 ; if user changes default radiopharm entry, or 62 ; adds a radiopharm that's not defined in file 71 default radiopharm, 63 ; the high and low values would be unknown 64 S RANUC1=$O(^RAMIS(71,+$P(P03,U,2),"NUC","B",+$P(RANUC,U),0)) 65 ; 0-node of procedure sub-record with matching radiopharm 66 S:RANUC1 RANUC1=^RAMIS(71,+$P(P03,U,2),"NUC",+RANUC1,0) 67 S RAHIGH=$P(RANUC1,U,5) ; high adult dose 68 S RALOW=$P(RANUC1,U,6) ; low adult dose 69 S RASTERSK="" 70 I RADOSE>0,RALOW>0,RADOSE<RALOW S RASTERSK="*" 71 I RADOSE>0,RAHIGH>0,RADOSE>RAHIGH S RASTERSK="*" 72 D S3S4 73 S ^TMP($J,"RA",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),S3,S4,$E(RAPATNAM,1,15),RACN,RADIOPH)=RASSN_U_RADRAWN_U_RADOSE_U_RAHIGH_U_RALOW_U_RAWHO_U_RASTERSK_U_RAPRCNAM 74 I '$D(^TMP($J,"RASUM",$S(RASORT:S3,1:S4),RACN,RASSN)) S ^(RASEQI(RAIMGNAM))=$G(^TMP($J,"RATUNIQ",RASEQD(RADIVNAM),RASEQI(RAIMGNAM)))+1,^(RASEQD(RADIVNAM))=$G(^TMP($J,"RATUNIQ",RASEQD(RADIVNAM)))+1 75 S RAEITHER=$S(RATITLE["Usage":RADIOPH,1:RAWHO) 76 I '$D(^TMP($J,"RASUM",$S(RASORT:S3,1:S4),RACN,RASSN,RAEITHER)) S ^(RAEITHER)=$G(^TMP($J,"RATUNIQ",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+1,^(RAEITHER)=$G(^TMP($J,"RATUNIQ",RASEQD(RADIVNAM),RAEITHER))+1 77 S ^(RASSN)=$G(^TMP($J,"RASUM",$S(RASORT:S3,1:S4),RACN,RASSN))+1 78 S ^(RAEITHER)=$G(^TMP($J,"RASUM",$S(RASORT:S3,1:S4),RACN,RASSN,RAEITHER))+1 79 ; img typ totals 80 S:RASTERSK="*" ^(RAEITHER)=$G(^TMP($J,"RATOUTSD",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+1 81 S ^(RAEITHER)=$G(^TMP($J,"RATDRAWN",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+RADRAWN 82 S ^(RAEITHER)=$G(^TMP($J,"RATDOSE",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+RADOSE 83 ; "ratradio" is used for either radiopharm or who-admin-dose 84 S ^(RAEITHER)=$G(^TMP($J,"RATRADIO",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+1 85 ; division totals 86 S:RASTERSK="*" ^(RAEITHER)=$G(^TMP($J,"RATOUTSD",RASEQD(RADIVNAM),RAEITHER))+1 87 S ^(RAEITHER)=$G(^TMP($J,"RATDRAWN",RASEQD(RADIVNAM),RAEITHER))+RADRAWN 88 S ^(RAEITHER)=$G(^TMP($J,"RATDOSE",RASEQD(RADIVNAM),RAEITHER))+RADOSE 89 S ^(RAEITHER)=$G(^TMP($J,"RATRADIO",RASEQD(RADIVNAM),RAEITHER))+1 90 G F1 91 WRT S RASEQD="" 92 W1 S RASEQD=$O(^TMP($J,"RA",RASEQD)) Q:RASEQD="" S RASEQI="" 93 W2 S RASEQI=$O(^TMP($J,"RA",RASEQD,RASEQI)) G:RASEQI="" W1 S S3="" 94 S:RAPG>0 RAXIT=$$EOS^RAUTL5 Q:$G(RAXIT) D PGHD^RANMUSE3,COLHD^RANMUSE3 95 W3 S S3=$O(^TMP($J,"RA",RASEQD,RASEQI,S3)) G:S3="" W2 S S4="" 96 W4 S S4=$O(^TMP($J,"RA",RASEQD,RASEQI,S3,S4)) G:S4="" W3 S RAPATNAM="" 97 W5 S RAPATNAM=$O(^TMP($J,"RA",RASEQD,RASEQI,S3,S4,RAPATNAM)) G:RAPATNAM="" W4 S RACN="" 98 W6 S RACN=$O(^TMP($J,"RA",RASEQD,RASEQI,S3,S4,RAPATNAM,RACN)) G:RACN="" W5 S RADIOPH="" 99 W7 S RADIOPH=$O(^TMP($J,"RA",RASEQD,RASEQI,S3,S4,RAPATNAM,RACN,RADIOPH)) G:RADIOPH="" W6 S RA1=^(RADIOPH) 100 S RALONGCN=$S(RASORT:S3,1:S4),RALONGCN=$E(RALONGCN,4,7)_$E(RALONGCN,2,3)_"-"_RACN_"@"_$E($P(RALONGCN,".",2)_"000",1,4) 101 S RASSN=$P(RA1,U),RADRAWN=$P(RA1,U,2),RADOSE=$P(RA1,U,3),RAHIGH=$P(RA1,U,4),RALOW=$P(RA1,U,5),RAWHO=$P(RA1,U,6),RASTERSK=$P(RA1,U,7) 102 S RAPRCNAM=$P(RA1,U,8) 103 I ($Y+4)>IOSL!(RAPG=0) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D PGHD^RANMUSE3,COLHD^RANMUSE3 104 W !,RALONGCN,?16,$E(RAPATNAM,1,15),?32,RASSN,?44,$E(RADIOPH,1,15),?59,$J(RADRAWN,10,4),?69,$J(RADOSE,10,4),?79,$J(RALOW,10,4),?89,$J(RAHIGH,10,4),?100,$E(RAPRCNAM,1,15),?116,$E(RAWHO,1,15),?131,RASTERSK 105 G W7 106 S3S4 ; set subscripts 3 and 4 107 I RATITLE["Usage" D Q 108 . I RASORT S S4=$E(RADIOPH,1,15),S3=RAXMDTM 109 . I 'RASORT S S3=$E(RADIOPH,1,15),S4=RAXMDTM 110 . Q 111 I RATITLE["Admin" D Q 112 . I RASORT S S4=$E(RAWHO,1,15),S3=RAXMDTM 113 . I 'RASORT S S3=$E(RAWHO,1,15),S4=RAXMDTM 114 . Q 115 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RANMUSE3.m
r613 r623 1 RANMUSE3 ;HISC/SWM-Nuclear Medicine Usage reports ;10/20/97 11:09 2 ;;5.0;Radiology/Nuclear Medicine;**65**;Mar 16, 1998;Build 8 3 PGHD ; Page Header 4 I RAPG!($E(IOST,1,2)="C-") W:$Y>0 @IOF 5 S RAPG=RAPG+1 6 W !?35,">>> "_RATITLE_" Report <<<",?90,"Run Date: ",RATDY 7 W ?121,"Page: ",RAPG 8 W !?50,$S($G(RAHDTYP)="D":"(Division",$G(RAHDTYP)="I":"(Imaging",1:"") W:$G(RAHDTYP)]"" " Summary)" 9 W ?85,"For: ",RADTBEG("X")," - ",RADTEND("X") 10 W !,"Division: ",RANUMD(RASEQD) W:$G(RAHDTYP)'="D" ?45,"Imaging Type: ",RANUMI(RASEQI) 11 Q 12 COLHD ; Column Header for detailed report 13 W !!,"Long-Case@Time",?16,"Patient Name",?35,"SSN",?44,"Radiopharm",?59,"Act.Drawn",?69,"Dose Adm'd",?83,"Low",?93,"High",?100,"Procedure",?116,"Who Adm'd" 14 W !,RALN 15 Q 16 COLHDS ; Column Header for summary report 17 W !!,$S(RATITLE["Usage":"Radiopharm",1:"Who Admin Dose"),?35,"Total Drawn",?50,"Total Adm'd",?64,"No. cases",?79,"(%)",?90,"No. outside range" 18 W !,RALN 19 Q 20 SUM S RAXIT=$$EOS^RAUTL5 Q:RAXIT 21 S RA0=0 22 SM0 S RA0=$O(^TMP($J,"RATUNIQ",RA0)) Q:'RA0 S RA1=0 23 SM2 S RA1=$O(^TMP($J,"RATUNIQ",RA0,RA1)) I RA1'=+RA1 D DIVSUM Q:RAXIT G SM0 24 ; if RA1 is alpha, then node is for division summary 25 ; if RA1 is numeric, then node is for imaging summary 26 S RASEQD=RA0,RASEQI=RA1 27 S RAHDTYP="I" D PGHD,COLHDS 28 SM3 S RA2=$O(^TMP($J,"RATUNIQ",RA0,RA1,RA2)) I RA2="" D FOOTIMG S RAXIT=$$EOS^RAUTL5 Q:RAXIT G SM2 29 W !,$E(RA2,1,30) 30 W ?30,$J($G(^TMP($J,"RATDRAWN",RA0,RA1,RA2)),15,4) 31 W ?45,$J($G(^TMP($J,"RATDOSE",RA0,RA1,RA2)),15,4) 32 W ?64,$J($G(^TMP($J,"RATUNIQ",RA0,RA1,RA2)),7) 33 W ?78,$J(100*$S(+$G(^TMP($J,"RATUNIQ",RA0,RA1))=0:0,1:$G(^TMP($J,"RATUNIQ",RA0,RA1,RA2))/^TMP($J,"RATUNIQ",RA0,RA1)),5,2) 34 W ?90,$J($G(^TMP($J,"RATOUTSD",RA0,RA1,RA2)),7) 35 I ($Y+4)>IOSL!(RAPG=0) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D PGHD,COLHDS 36 G SM3 37 DIVSUM ; 38 ; skip div summary page if div has only 1 img typ 39 Q:$O(^TMP($J,"RATUNIQ",RA0,0))=$O(^TMP($J,"RATUNIQ",RA0,"A"),-1) 40 S RAHDTYP="D",RA2="A" 41 D PGHD,COLHDS 42 DV1 S RA2=$O(^TMP($J,"RATUNIQ",RA0,RA2)) 43 I RA2="" D FOOTDIV S RAXIT=$$EOS^RAUTL5 Q 44 W !,$E(RA2,1,30) 45 W ?30,$J($G(^TMP($J,"RATDRAWN",RA0,RA2)),15,4) 46 W ?45,$J($G(^TMP($J,"RATDOSE",RA0,RA2)),15,4) 47 W ?64,$J($G(^TMP($J,"RATUNIQ",RA0,RA2)),7) 48 W ?78,$J(100*$S(+$G(^TMP($J,"RATUNIQ",RA0))=0:0,1:$G(^TMP($J,"RATUNIQ",RA0,RA2))/^TMP($J,"RATUNIQ",RA0)),5,2) 49 W ?90,$J($G(^TMP($J,"RATOUTSD",RA0,RA2)),7) 50 I ($Y+4)>IOSL!(RAPG=0) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D PGHD,COLHDS 51 G DV1 52 FOOTDIV ; footnotes division 53 W !!,RANUMD(RASEQD),"'s Total number of unique cases: ",^TMP($J,"RATUNIQ",RA0) 54 D FOOT Q 55 FOOTIMG ; footnotes img type 56 W !!,RANUMI(RASEQI),"'s Total number of unique cases: ",^TMP($J,"RATUNIQ",RA0,RA1) 57 D FOOT Q 58 FOOT W !!,"Notes: A case may have more than 1 radiopharm, so total no. unique cases may be less than total no. radiopharms listed." 59 W !," * denotes administered dosage outside of normal range." 60 Q:RAINPUT 61 W !!,$S(RATITLE["Usage":"Radiopharm",1:"Dose administerers")," selected for this report :" W !?6 62 S RA2=0 F S RA2=$O(^TMP($J,"RA EITHER",RA2)) Q:RA2="" W:$X+$L(RA2)>(IOM+2) !?6 W RA2 W:$O(^(RA2))]"" ", " 63 Q 64 ZERO ; zero out total for imaging type(s) and associated division(s) w/o data 65 S RA0="" 66 Z1 S RA0=$O(^TMP($J,"RA D-TYPE",RA0)) Q:RA0']"" S RA1="" 67 Z2 S RA1=$O(RACCESS(DUZ,"DIV-IMG",RA0,RA1)) G:RA1']"" Z1 68 G:'$D(^TMP($J,"RA I-TYPE",RA1)) Z2 69 S:'$D(^TMP($J,"RATUNIQ",RASEQD(RA0),RASEQI(RA1))) ^TMP($J,"RATUNIQ",RASEQD(RA0),RASEQI(RA1))=0 70 S:'($D(^TMP($J,"RATUNIQ",RASEQD(RA0)))#2) ^TMP($J,"RATUNIQ",RASEQD(RA0))=0 71 G Z2 1 RANMUSE3 ;HISC/SWM-Nuclear Medicine Usage reports ;10/20/97 11:09 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 3 PGHD ; Page Header 4 I RAPG!($E(IOST,1,2)="C-") W:$Y>0 @IOF 5 S RAPG=RAPG+1 6 W !?35,">>> "_RATITLE_" Report <<<",?90,"Run Date: ",RATDY 7 W ?121,"Page: ",RAPG 8 W !?50,$S($G(RAHDTYP)="D":"(Division",$G(RAHDTYP)="I":"(Imaging",1:"") W:$G(RAHDTYP)]"" " Summary)" 9 W ?85,"For: ",RADTBEG("X")," - ",RADTEND("X") 10 W !,"Division: ",RANUMD(RASEQD) W:$G(RAHDTYP)'="D" ?45,"Imaging Type: ",RANUMI(RASEQI) 11 Q 12 COLHD ; Column Header for detailed report 13 W !!,"Long-Case@Time",?16,"Patient Name",?35,"SSN",?44,"Radiopharm",?59,"Act.Drawn",?69,"Dose Adm'd",?83,"Low",?93,"High",?100,"Procedure",?116,"Who Adm'd" 14 W !,RALN 15 Q 16 COLHDS ; Column Header for summary report 17 W !!,$S(RATITLE["Usage":"Radiopharm",1:"Who Admin Dose"),?35,"Total Drawn",?50,"Total Adm'd",?64,"No. cases",?79,"(%)",?90,"No. outside range" 18 W !,RALN 19 Q 20 SUM S RAXIT=$$EOS^RAUTL5 Q:RAXIT 21 S RA0=0 22 SM0 S RA0=$O(^TMP($J,"RATUNIQ",RA0)) Q:'RA0 S RA1=0 23 SM2 S RA1=$O(^TMP($J,"RATUNIQ",RA0,RA1)) I RA1'=+RA1 D DIVSUM Q:RAXIT G SM0 24 ; if RA1 is alpha, then node is for division summary 25 ; if RA1 is numeric, then node is for imaging summary 26 S RASEQD=RA0,RASEQI=RA1 27 S RAHDTYP="I" D PGHD,COLHDS 28 SM3 S RA2=$O(^TMP($J,"RATUNIQ",RA0,RA1,RA2)) I RA2="" D FOOTIMG S RAXIT=$$EOS^RAUTL5 Q:RAXIT G SM2 29 W !,$E(RA2,1,30) 30 W ?30,$J($G(^TMP($J,"RATDRAWN",RA0,RA1,RA2)),15,4) 31 W ?45,$J($G(^TMP($J,"RATDOSE",RA0,RA1,RA2)),15,4) 32 W ?64,$J($G(^TMP($J,"RATUNIQ",RA0,RA1,RA2)),7) 33 W ?78,$J(100*$S(+$G(^TMP($J,"RATUNIQ",RA0,RA1))=0:0,1:$G(^TMP($J,"RATUNIQ",RA0,RA1,RA2))/^TMP($J,"RATUNIQ",RA0,RA1)),5,2) 34 W ?90,$J($G(^TMP($J,"RATOUTSD",RA0,RA1,RA2)),7) 35 I ($Y+4)>IOSL!(RAPG=0) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D PGHD,COLHDS 36 G SM3 37 DIVSUM ; 38 ; skip div summary page if div has only 1 img typ 39 Q:$O(^TMP($J,"RATUNIQ",RA0,0))=$O(^TMP($J,"RATUNIQ",RA0,"A"),-1) 40 S RAHDTYP="D",RA2="A" 41 D PGHD,COLHDS 42 DV1 S RA2=$O(^TMP($J,"RATUNIQ",RA0,RA2)) 43 I RA2="" D FOOTDIV S RAXIT=$$EOS^RAUTL5 Q 44 W !,$E(RA2,1,30) 45 W ?30,$J($G(^TMP($J,"RATDRAWN",RA0,RA2)),15,4) 46 W ?45,$J($G(^TMP($J,"RATDOSE",RA0,RA2)),15,4) 47 W ?64,$J($G(^TMP($J,"RATUNIQ",RA0,RA2)),7) 48 W ?78,$J(100*$S(+$G(^TMP($J,"RATUNIQ",RA0))=0:0,1:$G(^TMP($J,"RATUNIQ",RA0,RA2))/^TMP($J,"RATUNIQ",RA0)),5,2) 49 W ?90,$J($G(^TMP($J,"RATOUTSD",RA0,RA2)),7) 50 I ($Y+4)>IOSL!(RAPG=0) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D PGHD,COLHDS 51 G DV1 52 FOOTDIV ; footnotes division 53 W !!,RANUMD(RASEQD),"'s Total number of unique cases: ",^TMP($J,"RATUNIQ",RA0) 54 D FOOT Q 55 FOOTIMG ; footnotes img type 56 W !!,RANUMI(RASEQI),"'s Total number of unique cases: ",^TMP($J,"RATUNIQ",RA0,RA1) 57 D FOOT Q 58 FOOT W !!,"Notes: A case may have more than 1 radiopharm, so total no. unique cases may be less than total no. radiopharms listed." 59 W !," * denotes administered dosage outside of normal range." 60 Q:RAINPUT 61 W !!,$S(RATITLE["Usage":"Radiopharm",1:"Dose administerers")," selected for this report :" W !?6 62 S RA2=0 F S RA2=$O(^TMP($J,"RA EITHER",RA2)) Q:RA2="" W:$X+$L(RA2)>(IOM+2) !?6 W RA2 W:$O(^(RA2))]"" ", " 63 Q 64 ZERO ; zero out total for imaging type(s) that has no data 65 S RA0="" 66 Z1 S RA0=$O(^TMP($J,"RA D-TYPE",RA0)) Q:RA0']"" S RA1="" 67 Z2 S RA1=$O(RACCESS(DUZ,"DIV-IMG",RA0,RA1)) G:RA1']"" Z1 68 G:'$D(^TMP($J,"RA I-TYPE",RA1)) Z2 69 S:'$D(^TMP($J,"RATUNIQ",RASEQD(RA0),RASEQI(RA1))) ^TMP($J,"RATUNIQ",RASEQD(RA0),RASEQI(RA1))=0 70 G Z2 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RANMUTL1.m
r613 r623 1 RANMUTL1 ;HISC/SWM-Nuclear Medicine utilites ;8/6/97 08:48 2 ;;5.0;Radiology/Nuclear Medicine;**65**;Mar 16, 1998;Build 8 3 ; 4 ;Supported IA #10103 reference to FMTE^XLFDT 5 ; 6 SELIMG ; Select Imaging Type, if exists; code is from RAUTL7 7 ; Prompts user to select Imaging Type(s). 8 ; Creates ^TMP($J,"RA I-TYPE",Imaging Type name,Imaging Type IEN)="" 9 N RA,RAIMGNUM,RAONE S RA="",RAONE=$$IMG1^RAUTL7() 10 ; .... chk if only 1 img type is available 11 I $P(RAONE,"^")]"",('$D(^TMP($J,"RA D-TYPE"))) S RAQUIT=0 D Q 12 . S ^TMP($J,"RA I-TYPE",$P(RAONE,"^"),$P(RAONE,"^",2))="" 13 . Q 14 ; .... chk if only 1 img type within selectable division is available 15 ; raimgnum = number of selectable img types 16 I $D(^TMP($J,"RA D-TYPE")) D 17 . D SETUP1 S RAIMGNUM=$$IMGNUM^RAUTL7A() 18 . Q 19 I $D(^TMP($J,"RA D-TYPE")),(RAIMGNUM=1) D S RAQUIT=0 Q 20 . N RA0,RA1 21 . S RA1=+$O(^TMP($J,"DIV-IMG",0)),RA0=$P($G(^RA(79.2,RA1,0)),"^") 22 . S ^TMP($J,"RA I-TYPE",RA0,RA1)="" 23 . Q 24 S RADIC="^RA(79.2,",RADIC(0)="QEAMZ",RAUTIL="RA I-TYPE" 25 S RADIC("A")="Select Imaging Type: ",RADIC("B")="All" 26 I $D(^TMP($J,"RA D-TYPE")) D 27 . S RADIC("S")="I $D(^TMP($J,""DIV-IMG"",+Y)),($D(RACCESS(DUZ,""IMG"",+Y)))" 28 . Q 29 ; why do we need to check the alternative ? DIVLOC+3 prevents this 30 ; alternative from occurring. 31 E S RADIC("S")="I $D(RACCESS(DUZ,""IMG"",+Y))" 32 W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y 33 Q 34 SELRADIO ; Setup ^TMP($J,"RA EITHER",ien file 50) 35 S RAINPUT="" 36 K DIR,X,Y S DIR(0)="YA",DIR("B")="Yes" 37 S DIR("A")="Do you wish to include all Radiopharms ? " 38 S DIR("?",1)="Enter 'Yes' to select all Radiopharms." 39 S DIR("?")="Enter 'No' to select a subset of Radiopharms." 40 W ! D ^DIR K DIR Q:$D(DIRUT) 41 S RAINPUT=+Y K DIROUT,DIRUT,DTOUT,DUOUT,X,Y 42 Q:RAINPUT 43 S RADIC="^PSDRUG(",RADIC(0)="QEAMZ" 44 S RADIC("A")="Select Radiopharm: " 45 W !! D EN2^RAPSAPI(.RADIC,"RA EITHER") K %W,%Y1,DIC,RADIC,RAUTIL,X,Y 46 Q 47 SELADMIN ; Setup ^TMP($J,"RA EITHER",ien file 50) 48 S RAINPUT="" 49 K DIR,X,Y S DIR(0)="YA",DIR("B")="Yes" 50 S DIR("A")="Do you wish to include all who administered dose ? " 51 S DIR("?",1)="Enter 'Yes' to select all who administered dose." 52 S DIR("?")="Enter 'No' to select some who administered dose." 53 W ! D ^DIR K DIR Q:$D(DIRUT) 54 S RAINPUT=+Y K DIROUT,DIRUT,DTOUT,DUOUT,X,Y 55 Q:RAINPUT 56 S RADIC="^VA(200,",RADIC(0)="QEAMZ",RAUTIL="RA EITHER" 57 S RADIC("A")="Select Person Who Admin Dose: " 58 ; passed parameters to circumvent person's inactive date 59 ; only the 4th param, 0, is really used to choose staff/resid/tech 60 S RADIC("S")="I $$VALADM^RADD1(1,+Y,1,0)" ; 61 W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y 62 Q 63 SELDATES ; Define RADTBEG and RADTEND 64 S RAPOP=0 W !!,"**** Date Range Selection ****" 65 W ! S %DT="APEXT" 66 S %DT("A")=" Beginning DATE : " 67 S %DT("B")="T-1" 68 D ^%DT S:Y<0 RAPOP=1 Q:Y<0 S (%DT(0),RADTBEG)=Y 69 W ! S %DT="APEXT" 70 S %DT("A")=" Ending DATE : " 71 S %DT("B")="T-1@24:00" 72 D ^%DT K %DT S:Y<0 RAPOP=1 Q:Y<0 S RADTEND=Y 73 S RADTBEG("X")=$$FMTE^XLFDT(RADTBEG,1) ; for display in header 74 S RADTEND("X")=$$FMTE^XLFDT(RADTEND,1) 75 S:$P(RADTEND,".",2)="" RADTEND=RADTEND_".9999" 76 Q 77 SELSORT ; select sort order 78 W ! S RAPOP=0,RASORT=0 79 S DIR("A")="Sort Exam Date/Time before "_$S(RATITLE["Usage":"Radiopharm",1:"Who Admin Dose")_" ? : " 80 S DIR(0)="YAO",DIR("B")="NO" D ^DIR 81 I $D(DIRUT)!($D(DUOUT)) S RAPOP=1 Q 82 S RASORT=Y ; 1=YES, 0=NO 83 Q 84 SETUP1 ; Setup ^TMP($J,"DIV-IMG",Imaging Type IEN)="" 85 ; based upon ^TMP($J,"RA D-TYPE",Division name) 86 ; RACCESS "DIV-IMG" 87 ; elements. 88 N RAX,RAY,RAZ S RAX="" 89 F S RAX=$O(^TMP($J,"RA D-TYPE",RAX)) Q:RAX']"" D 90 . I $D(RACCESS(DUZ,"DIV-IMG",RAX)) D 91 .. S RAY="" F S RAY=$O(RACCESS(DUZ,"DIV-IMG",RAX,RAY)) Q:RAY']"" D 92 ... Q:$P($G(^RA(79.2,+$O(^RA(79.2,"B",RAY,0)),0)),U,5)'="Y" ;file 79.2's RADIOPHARM..USED 93 ... S RAZ=+$O(^RA(79.2,"B",RAY,0)),^TMP($J,"DIV-IMG",RAZ)="" 94 ... Q 95 .. Q 96 . Q 97 Q 1 RANMUTL1 ;HISC/SWM-Nuclear Medicine utilites ;8/6/97 08:48 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 3 SELIMG ; Select Imaging Type, if exists; code is from RAUTL7 4 ; Prompts user to select Imaging Type(s). 5 ; Creates ^TMP($J,"RA I-TYPE",Imaging Type name,Imaging Type IEN)="" 6 N RA,RAIMGNUM,RAONE S RA="",RAONE=$$IMG1^RAUTL7() 7 ; .... chk if only 1 img type is available 8 I $P(RAONE,"^")]"",('$D(^TMP($J,"RA D-TYPE"))) S RAQUIT=0 D Q 9 . S ^TMP($J,"RA I-TYPE",$P(RAONE,"^"),$P(RAONE,"^",2))="" 10 . Q 11 ; .... chk if only 1 img type within selectable division is available 12 ; raimgnum = number of selectable img types 13 I $D(^TMP($J,"RA D-TYPE")) D 14 . D SETUP1 S RAIMGNUM=$$IMGNUM^RAUTL7A() 15 . Q 16 I $D(^TMP($J,"RA D-TYPE")),(RAIMGNUM=1) D S RAQUIT=0 Q 17 . N RA0,RA1 18 . S RA1=+$O(^TMP($J,"DIV-IMG",0)),RA0=$P($G(^RA(79.2,RA1,0)),"^") 19 . S ^TMP($J,"RA I-TYPE",RA0,RA1)="" 20 . Q 21 S RADIC="^RA(79.2,",RADIC(0)="QEAMZ",RAUTIL="RA I-TYPE" 22 S RADIC("A")="Select Imaging Type: ",RADIC("B")="All" 23 I $D(^TMP($J,"RA D-TYPE")) D 24 . S RADIC("S")="I $D(^TMP($J,""DIV-IMG"",+Y)),($D(RACCESS(DUZ,""IMG"",+Y)))" 25 . Q 26 ; why do we need to check the alternative ? DIVLOC+3 prevents this 27 ; alternative from occurring. 28 E S RADIC("S")="I $D(RACCESS(DUZ,""IMG"",+Y))" 29 W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y 30 Q 31 SELRADIO ; Setup ^TMP($J,"RA EITHER",ien file 50) 32 S RAINPUT="" 33 K DIR,X,Y S DIR(0)="YA",DIR("B")="Yes" 34 S DIR("A")="Do you wish to include all Radiopharms ? " 35 S DIR("?",1)="Enter 'Yes' to select all Radiopharms." 36 S DIR("?")="Enter 'No' to select a subset of Radiopharms." 37 W ! D ^DIR K DIR Q:$D(DIRUT) 38 S RAINPUT=+Y K DIROUT,DIRUT,DTOUT,DUOUT,X,Y 39 Q:RAINPUT 40 S RADIC="^PSDRUG(",RADIC(0)="QEAMZ",RAUTIL="RA EITHER" 41 S RADIC("A")="Select Radiopharm: " 42 S RADIC("S")="I $$DCHK^RADD1(""R"",0,+Y)" ; dt=0, only radiopharms 43 W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y 44 Q 45 SELADMIN ; Setup ^TMP($J,"RA EITHER",ien file 50) 46 S RAINPUT="" 47 K DIR,X,Y S DIR(0)="YA",DIR("B")="Yes" 48 S DIR("A")="Do you wish to include all who administered dose ? " 49 S DIR("?",1)="Enter 'Yes' to select all who administered dose." 50 S DIR("?")="Enter 'No' to select some who administered dose." 51 W ! D ^DIR K DIR Q:$D(DIRUT) 52 S RAINPUT=+Y K DIROUT,DIRUT,DTOUT,DUOUT,X,Y 53 Q:RAINPUT 54 S RADIC="^VA(200,",RADIC(0)="QEAMZ",RAUTIL="RA EITHER" 55 S RADIC("A")="Select Person Who Admin Dose: " 56 ; passed parameters to circumvent person's inactive date 57 ; only the 4th param, 0, is really used to choose staff/resid/tech 58 S RADIC("S")="I $$VALADM^RADD1(1,+Y,1,0)" ; 59 W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y 60 Q 61 SELDATES ; Define RADTBEG and RADTEND 62 S RAPOP=0 W !!,"**** Date Range Selection ****" 63 W ! S %DT="APEXT" 64 S %DT("A")=" Beginning DATE : " 65 S %DT("B")="T-1" 66 D ^%DT S:Y<0 RAPOP=1 Q:Y<0 S (%DT(0),RADTBEG)=Y 67 W ! S %DT="APEXT" 68 S %DT("A")=" Ending DATE : " 69 S %DT("B")="T-1@24:00" 70 D ^%DT K %DT S:Y<0 RAPOP=1 Q:Y<0 S RADTEND=Y 71 S RADTBEG("X")=$$FMTE^XLFDT(RADTBEG,1) ; for display in header 72 S RADTEND("X")=$$FMTE^XLFDT(RADTEND,1) 73 S:$P(RADTEND,".",2)="" RADTEND=RADTEND_".9999" 74 Q 75 SELSORT ; select sort order 76 W ! S RAPOP=0,RASORT=0 77 S DIR("A")="Sort Exam Date/Time before "_$S(RATITLE["Usage":"Radiopharm",1:"Who Admin Dose")_" ? : " 78 S DIR(0)="YAO",DIR("B")="NO" D ^DIR 79 I $D(DIRUT)!($D(DUOUT)) S RAPOP=1 Q 80 S RASORT=Y ; 1=YES, 0=NO 81 Q 82 SETUP1 ; Setup ^TMP($J,"DIV-IMG",Imaging Type IEN)="" 83 ; based upon ^TMP($J,"RA D-TYPE",Division name) 84 ; RACCESS "DIV-IMG" 85 ; elements. 86 N RAX,RAY,RAZ S RAX="" 87 F S RAX=$O(^TMP($J,"RA D-TYPE",RAX)) Q:RAX']"" D 88 . I $D(RACCESS(DUZ,"DIV-IMG",RAX)) D 89 .. S RAY="" F S RAY=$O(RACCESS(DUZ,"DIV-IMG",RAX,RAY)) Q:RAY']"" D 90 ... Q:$P($G(^RA(79.2,+$O(^RA(79.2,"B",RAY,0)),0)),U,5)'="Y" ;file 79.2's RADIOPHARM..USED 91 ... S RAZ=+$O(^RA(79.2,"B",RAY,0)),^TMP($J,"DIV-IMG",RAZ)="" 92 ... Q 93 .. Q 94 . Q 95 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7PC1A.m
r613 r623 1 RAO7PC1A ;HISC/GJC-Procedure Call utilities (cont) ;1/22/03 12:41 2 ;;5.0;Radiology/Nuclear Medicine;**1,10,26,31,36,45,56**;Mar 16, 1998;Build 3 3 ;Supported IA #10040 ^SC( 4 ;Supported IA #10103 DT^XLFDT, FMADD^XLFDT 5 ;Supported IA #2056 GET1^DIQ 6 ;Supported IA #10104 LOW^XLFSTR, UP^XLFSTR 7 SETDATA ; Called from within the EN1 subroutine of RAO7PC1 8 ; Sets the ^TMP($J,"RAE1",patient ien,Exam ID) node. 9 ; See EN1^RAO7PC1 for further explanation. 10 ; 11 ; Output (new) : 12 ; ^TMP($J,"RAE1",Patient IEN,Exam ID,"CMOD",1)=cptmod^cptmodname 13 ; ,2)=cptmod^cptmodname 14 N RA,RA1,RA2,RA3 15 S RANO=0,RAREX(0)=$G(^RADPT(RADFN,"DT",RAIBDT,0)) 16 S RAITY=+$P(RAREX(0),"^",2),RAILOC=+$P(RAREX(0),"^",4) 17 S RAILOC=$P($G(^SC(+$P($G(^RA(79.1,RAILOC,0)),"^"),0)),"^") 18 S RAITY(0)=$G(^RA(79.2,RAITY,0)) 19 F S RANO=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO)) Q:RANO'>0 D Q:RAXIT 20 . S RAXAM(0)=$G(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,0)) 21 . Q:RAXAM(0)="" 22 . S RAORDER=+$P(RAXAM(0),"^",11) 23 . ; quit if exam is WAITING and its order status isn't ACTIVE 24 . ; because this means exam hasn't finished being registered 25 . I $P($G(^RA(72,+$P(RAXAM(0),U,3),0)),U,3)=1,$P($G(^RAO(75.1,RAORDER,0)),U,5)'=6 Q 26 . S RAORDER(7)=$P($G(^RAO(75.1,RAORDER,0)),"^",7) ; CPRS order ien 27 . S RAXSTAT=+$P(RAXAM(0),"^",3),RAXSTAT(0)=$G(^RA(72,RAXSTAT,0)) 28 . S RAXID=RAIBDT_"-"_RANO 29 . S RACSE=$S($P(RAXAM(0),U)]"":$P(RAXAM(0),U),1:"Unknown") 30 . S RAPRC=$G(^RAMIS(71,+$P(RAXAM(0),U,2),0)) 31 . S RACPT=+$P(RAPRC,"^",9) ; pntr to 81 32 . S RACPT=$$NAMCODE^RACPTMSC(RACPT,DT) 33 . S RACPT=$S($P(RACPT,"^",2)]"":$P(RACPT,"^"),1:"") 34 . S RAPRC=$S($P(RAPRC,U)]"":$P(RAPRC,U),1:"Unknown") 35 . ; quit if cancelled exam, and cancelled exams not requested 36 . I ('$G(RACINC)),($P($G(^RA(72,+$P(RAXAM(0),"^",3),0)),"^",3)=0) Q 37 . S RADIAG=+$P(RAXAM(0),U,13),RARPT=+$P(RAXAM(0),U,17) 38 .; E3R 17541, 15507 39 .; if want cancel'd cases returned, and this case is cancelled, then 40 .; also require div param ALLOW RPTS ON CANCELLED CASES? = Y and 41 .; presence of report, else skip this case 42 . I $G(RACINC),($P($G(^RA(72,+$P(RAXAM(0),"^",3),0)),"^",3)=0) D Q:RASHOCAN=0 43 .. S RASHOCAN=0 44 .. I $P($G(^RA(79,+$P(RAREX(0),"^",3),.1)),"^",22)="Y",RARPT S RASHOCAN=1 45 .. Q 46 . S RABNOR=$$UP^XLFSTR($P($G(^RA(78.3,RADIAG,0)),U,4)) 47 . S:RABNOR'="Y" RABNOR="" 48 . S RABNORMR=$$UP^XLFSTR($P($G(^RA(78.3,RADIAG,0)),U,3)) 49 . S:RABNORMR'="Y" RABNORMR="" 50 . S RARPTST=$$RSTAT(),RARPTST=$$UL(RARPTST) 51 . S ^TMP($J,"RAE1",RADFN,RAXID)=RAPRC_U_RACSE_U_RARPTST_U_RABNOR_U_$S(RARPT=0:"",1:RARPT)_U_$P(RAXSTAT(0),"^",3)_"~"_$P(RAXSTAT(0),"^")_U_RAILOC_U_$P(RAITY(0),"^",3)_"~"_$P(RAITY(0),"^")_U_RABNORMR_U_RACPT_U_$G(RAORDER(7)) 52 . S ^TMP($J,"RAE1",RADFN,RAXID)=^TMP($J,"RAE1",RADFN,RAXID)_U_$S($O(^RARPT(RARPT,2005,0)):"Y",1:"N") 53 . D CPTMOD 54 . S RACNT=RACNT+1 55 .; 56 .; Condensed Radiology Display in CPRS GUI: 57 .; subtract from count if counting parent; count only 1 case from printset 58 .; and 59 .; store values of MEMBER OF SET and ordered parent procedure name 60 . I $D(RAEXNP),$E(RAEXNP,$L(RAEXNP))="P" D 61 .. I $P(RAXAM(0),U,25)="2",$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO),-1) S RACNT=RACNT-1 62 .. I $P(RAXAM(0),U,25) D 63 ... S RA3=$S('RAORDER:"",1:$P($G(^RAMIS(71,+$P($G(^RAO(75.1,+RAORDER,0)),U,2),0)),U)) 64 ... S RA3=$S(RA3'="":RA3,1:"PARENT PROCEDURE") 65 ... S ^TMP($J,"RAE1",RADFN,RAXID,"CPRS")=$P(RAXAM(0),U,25)_U_RA3 66 ... Q 67 .. Q 68 . S:RACNT=RAEXN RAXIT=1 69 .; Condensed Radiology Display in CPRS GUI: 70 .; do not exit until all cases of printset have been stored 71 . I $D(RAEXNP),$E(RAEXNP,$L(RAEXNP))="P",$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO)) S RAXIT=0 72 . K RAXSTAT,RAORDER 73 . Q 74 K RAILOC,RAITY 75 Q 76 CASE ; Return the case numbers and the total number of case numbers 77 ; associated with a particular order. Called from CASE^RAO7PC1. 78 ; Sets RARRAY(case #)="" for all cases associated with an order. 79 ; Sets first piece of RATTL to the number of cases found for an 80 ; order, and the second piece is PRINTSET if the report covers 81 ; multiple cases. See CASE^RAO7PC1 for more information. 82 I '$D(^RAO(75.1,RAOIFN,0))#2 S RATTL="-1^invalid order ien" Q 83 I '$D(^RADPT("AO",RAOIFN)) D Q ; case has yet to be registered 84 . S RATTL="-2^no case registered to date" 85 . Q 86 N RACNI,RADFN,RADTI,RAEXAM S RADFN=0 87 F S RADFN=$O(^RADPT("AO",RAOIFN,RADFN)) Q:RADFN'>0 D 88 . S RADTI=0 89 . F S RADTI=$O(^RADPT("AO",RAOIFN,RADFN,RADTI)) Q:RADTI'>0 D 90 .. S RACNI=0 91 .. F S RACNI=$O(^RADPT("AO",RAOIFN,RADFN,RADTI,RACNI)) Q:RACNI'>0 D 92 ... S RAEXAM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 93 ... Q:$P($G(^RA(72,+$P(RAEXAM,"^",3),0)),"^",3)=0 ; xam cancelled 94 ... S RATTL=+$G(RATTL)+1,@(RARRAY_"("_+RAEXAM_")")="" 95 ... Q 96 .. Q 97 . Q 98 I 'RATTL S RATTL="-2^cases cancelled" Q 99 S:$P(RAEXAM,"^",25)=2 RATTL=RATTL_"^PRINTSET" ; combined reports 100 Q 101 ; 102 EN2 ; IA: 2012, Return last 7 days of non-cancelled exams 103 ; Required: RADFN (valid patient ien) called from EN2^RAO7PC1 104 ; Output: 105 ; ^TMP($J,"RAE7",Patient IEN,Exam ID)=procedure name^case number^ 106 ; report status^imaging location IEN^imaging location name^ 107 ; contrast medium or media used 108 ; Note: Single characters in parenthesis indicate contrast 109 ; involvement: (I)=Iodinated ionic; (N)=Iodinated non-ionic; 110 ; (L)=Gadolinium; (C)=Oral Cholecystographic; (G)=Gastrografin; 111 ; (B)=Barium; (M)=unspecified contrast media 112 ; 113 ; Exam ID: exam date/time (inverse) concatenated with the case IEN 114 ; 115 Q:'$D(RADFN) Q:'RADFN K ^TMP($J,"RAE7") 116 N I,RABDT,RACNST,RACSE,RADT,RAEDT,RAIBDT,RAIEDT,RALOC,RACMEDIA,RANO 117 N RAPRC,RAREX,RARPT,RARPTST,RAXAM,RAXID,RAXSTAT 118 S RADT=$S($D(DT)#2:DT,1:$$DT^XLFDT()),RACNST=9999999.9999 119 S RABDT=$$FMADD^XLFDT(RADT,-7,0,0,0),RAEDT=RADT 120 S RAIBDT=RACNST-(RAEDT+.9999),RAIEDT=RACNST-(RABDT-.0001) 121 F S RAIBDT=$O(^RADPT(RADFN,"DT",RAIBDT)) Q:RAIBDT'>0!(RAIBDT>RAIEDT) D 122 . S RANO=0,RAREX(0)=$G(^RADPT(RADFN,"DT",RAIBDT,0)) 123 . S RALOC=+$P(RAREX(0),U,4),RALOC(0)=$G(^RA(79.1,RALOC,0)) 124 . S RALOC=$P($G(^SC(+RALOC(0),0)),"^") 125 . F S RANO=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO)) Q:RANO'>0 D 126 .. S RAXAM(0)=$G(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,0)) 127 .. S RAXID=RAIBDT_"-"_RANO 128 .. S RACSE=$S($P(RAXAM(0),U)]"":$P(RAXAM(0),U),1:"Unknown") 129 .. S RAPRC=$G(^RAMIS(71,+$P(RAXAM(0),U,2),0)) 130 .. S RAPRC=$S($P(RAPRC,U)]"":$P(RAPRC,U),1:"Unknown") 131 .. Q:$P($G(^RA(72,+$P(RAXAM(0),"^",3),0)),"^",3)=0 ; cancelled xam 132 .. S I=0,RACMEDIA="" F S I=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CM",I)) Q:'I S RACMEDIA=RACMEDIA_$P(^(I,0),U) ;RA*5*45 133 .. S RARPT=+$P(RAXAM(0),U,17) 134 .. S RARPTST=$$RSTAT(),RARPTST=$$UL(RARPTST) 135 .. S ^TMP($J,"RAE7",RADFN,RAXID)=RAPRC_U_RACSE_U_RARPTST_U_+RALOC(0)_U_RALOC_U_RACMEDIA 136 .. Q 137 . Q 138 Q 139 CPTMOD ;extract cpt modifiers if any 140 ;RA loop var, RA1 counter, RA2 intermed vars 141 Q:'$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CMOD",0)) 142 S RA=0,RA1=1 143 F S RA=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CMOD",RA)) Q:'RA I $D(^(RA,0)) D 144 . S RA2=$P(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CMOD",RA,0),"^") 145 . S RA2=$$BASICMOD^RACPTMSC(RA2,+RAREX(0)) Q:+RA2<0 146 . S ^TMP($J,"RAE1",RADFN,RAXID,"CMOD",RA1)=$P(RA2,"^",2)_"^"_$P(RA2,"^",3),RA1=RA1+1 147 Q 148 RSTAT() ; Get report status name from GET1^DIQ 149 ; RARPT is IEN of file 74 150 N R,DIERR 151 S R=$S($G(RARPT)>0:$$GET1^DIQ(74,+RARPT,5),1:"") 152 S:R="" R="NO REPORT" 153 Q R 154 UL(R) ;Upper and Lower case 155 ;First convert all chars to lower case, then 156 ;capitalize 1st char AND (char after / OR char after blank) 157 N L,R2 158 S R2=$E(R,1)_$$LOW^XLFSTR($E(R,2,$L(R))) ; 1st char must be in caps 159 S L=$F(R2,"/") ; If str has /, cap char after / but not char after blank 160 I L S R2=$E(R2,1,L-1)_$$UP^XLFSTR($E(R2,L))_$E(R2,L+1,$L(R2)) G UPQ 161 S L=$F(R2," ") ; If str has one blank, then cap the char after the blank 162 I L S R2=$E(R2,1,L-1)_$$UP^XLFSTR($E(R2,L))_$E(R2,L+1,$L(R2)) 163 UPQ Q R2 1 RAO7PC1A ;HISC/GJC-Procedure Call utilities (cont) ;1/22/03 12:41 2 ;;5.0;Radiology/Nuclear Medicine;**1,10,26,31,36,45**;Mar 16, 1998 3 SETDATA ; Called from within the EN1 subroutine of RAO7PC1 4 ; Sets the ^TMP($J,"RAE1",patient ien,Exam ID) node. 5 ; See EN1^RAO7PC1 for further explanation. 6 ; 7 ; Output (new) : 8 ; ^TMP($J,"RAE1",Patient IEN,Exam ID,"CMOD",1)=cptmod^cptmodname 9 ; ,2)=cptmod^cptmodname 10 N RA,RA1,RA2,RA3 11 S RANO=0,RAREX(0)=$G(^RADPT(RADFN,"DT",RAIBDT,0)) 12 S RAITY=+$P(RAREX(0),"^",2),RAILOC=+$P(RAREX(0),"^",4) 13 S RAILOC=$P($G(^SC(+$P($G(^RA(79.1,RAILOC,0)),"^"),0)),"^") 14 S RAITY(0)=$G(^RA(79.2,RAITY,0)) 15 F S RANO=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO)) Q:RANO'>0 D Q:RAXIT 16 . S RAXAM(0)=$G(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,0)) 17 . Q:RAXAM(0)="" 18 . S RAORDER=+$P(RAXAM(0),"^",11) 19 . ; quit if exam is WAITING and its order status isn't ACTIVE 20 . ; because this means exam hasn't finished being registered 21 . I $P($G(^RA(72,+$P(RAXAM(0),U,3),0)),U,3)=1,$P($G(^RAO(75.1,RAORDER,0)),U,5)'=6 Q 22 . S RAORDER(7)=$P($G(^RAO(75.1,RAORDER,0)),"^",7) ; CPRS order ien 23 . S RAXSTAT=+$P(RAXAM(0),"^",3),RAXSTAT(0)=$G(^RA(72,RAXSTAT,0)) 24 . S RAXID=RAIBDT_"-"_RANO 25 . S RACSE=$S($P(RAXAM(0),U)]"":$P(RAXAM(0),U),1:"Unknown") 26 . S RAPRC=$G(^RAMIS(71,+$P(RAXAM(0),U,2),0)) 27 . S RACPT=+$P(RAPRC,"^",9) ; pntr to 81 28 . S RACPT=$$NAMCODE^RACPTMSC(RACPT,DT) 29 . S RACPT=$S($P(RACPT,"^",2)]"":$P(RACPT,"^"),1:"") 30 . S RAPRC=$S($P(RAPRC,U)]"":$P(RAPRC,U),1:"Unknown") 31 . ; quit if cancelled exam, and cancelled exams not requested 32 . I ('$G(RACINC)),($P($G(^RA(72,+$P(RAXAM(0),"^",3),0)),"^",3)=0) Q 33 . S RADIAG=+$P(RAXAM(0),U,13),RARPT=+$P(RAXAM(0),U,17) 34 .; E3R 17541, 15507 35 .; if want cancel'd cases returned, and this case is cancelled, then 36 .; also require div param ALLOW RPTS ON CANCELLED CASES? = Y and 37 .; presence of report, else skip this case 38 . I $G(RACINC),($P($G(^RA(72,+$P(RAXAM(0),"^",3),0)),"^",3)=0) D Q:RASHOCAN=0 39 .. S RASHOCAN=0 40 .. I $P($G(^RA(79,+$P(RAREX(0),"^",3),.1)),"^",22)="Y",RARPT S RASHOCAN=1 41 .. Q 42 . S RABNOR=$$UP^XLFSTR($P($G(^RA(78.3,RADIAG,0)),U,4)) 43 . S:RABNOR'="Y" RABNOR="" 44 . S RABNORMR=$$UP^XLFSTR($P($G(^RA(78.3,RADIAG,0)),U,3)) 45 . S:RABNORMR'="Y" RABNORMR="" 46 . S RARPTST=$P($G(^RARPT(RARPT,0)),U,5) 47 . S RARPTST=$S(RARPTST="V":"Verified",RARPTST="R":"Released/Not verified",RARPTST="D":"Draft",RARPTST="PD":"Problem Draft",1:"No Report") 48 . S ^TMP($J,"RAE1",RADFN,RAXID)=RAPRC_U_RACSE_U_RARPTST_U_RABNOR_U_$S(RARPT=0:"",1:RARPT)_U_$P(RAXSTAT(0),"^",3)_"~"_$P(RAXSTAT(0),"^")_U_RAILOC_U_$P(RAITY(0),"^",3)_"~"_$P(RAITY(0),"^")_U_RABNORMR_U_RACPT_U_$G(RAORDER(7)) 49 . S ^TMP($J,"RAE1",RADFN,RAXID)=^TMP($J,"RAE1",RADFN,RAXID)_U_$S($O(^RARPT(RARPT,2005,0)):"Y",1:"N") 50 . D CPTMOD 51 . S RACNT=RACNT+1 52 .; 53 .; Condensed Radiology Display in CPRS GUI: 54 .; subtract from count if counting parent; count only 1 case from printset 55 .; and 56 .; store values of MEMBER OF SET and ordered parent procedure name 57 . I $D(RAEXNP),$E(RAEXNP,$L(RAEXNP))="P" D 58 .. I $P(RAXAM(0),U,25)="2",$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO),-1) S RACNT=RACNT-1 59 .. I $P(RAXAM(0),U,25) D 60 ... S RA3=$S('RAORDER:"",1:$P($G(^RAMIS(71,+$P($G(^RAO(75.1,+RAORDER,0)),U,2),0)),U)) 61 ... S RA3=$S(RA3'="":RA3,1:"PARENT PROCEDURE") 62 ... S ^TMP($J,"RAE1",RADFN,RAXID,"CPRS")=$P(RAXAM(0),U,25)_U_RA3 63 ... Q 64 .. Q 65 . S:RACNT=RAEXN RAXIT=1 66 .; Condensed Radiology Display in CPRS GUI: 67 .; do not exit until all cases of printset have been stored 68 . I $D(RAEXNP),$E(RAEXNP,$L(RAEXNP))="P",$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO)) S RAXIT=0 69 . K RAXSTAT,RAORDER 70 . Q 71 K RAILOC,RAITY 72 Q 73 CASE ; Return the case numbers and the total number of case numbers 74 ; associated with a particular order. Called from CASE^RAO7PC1. 75 ; Sets RARRAY(case #)="" for all cases associated with an order. 76 ; Sets first piece of RATTL to the number of cases found for an 77 ; order, and the second piece is PRINTSET if the report covers 78 ; multiple cases. See CASE^RAO7PC1 for more information. 79 I '$D(^RAO(75.1,RAOIFN,0))#2 S RATTL="-1^invalid order ien" Q 80 I '$D(^RADPT("AO",RAOIFN)) D Q ; case has yet to be registered 81 . S RATTL="-2^no case registered to date" 82 . Q 83 N RACNI,RADFN,RADTI,RAEXAM S RADFN=0 84 F S RADFN=$O(^RADPT("AO",RAOIFN,RADFN)) Q:RADFN'>0 D 85 . S RADTI=0 86 . F S RADTI=$O(^RADPT("AO",RAOIFN,RADFN,RADTI)) Q:RADTI'>0 D 87 .. S RACNI=0 88 .. F S RACNI=$O(^RADPT("AO",RAOIFN,RADFN,RADTI,RACNI)) Q:RACNI'>0 D 89 ... S RAEXAM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 90 ... Q:$P($G(^RA(72,+$P(RAEXAM,"^",3),0)),"^",3)=0 ; xam cancelled 91 ... S RATTL=+$G(RATTL)+1,@(RARRAY_"("_+RAEXAM_")")="" 92 ... Q 93 .. Q 94 . Q 95 I 'RATTL S RATTL="-2^cases cancelled" Q 96 S:$P(RAEXAM,"^",25)=2 RATTL=RATTL_"^PRINTSET" ; combined reports 97 Q 98 ; 99 EN2 ; IA: 2012, Return last 7 days of non-cancelled exams 100 ; Required: RADFN (valid patient ien) called from EN2^RAO7PC1 101 ; Output: 102 ; ^TMP($J,"RAE7",Patient IEN,Exam ID)=procedure name^case number^ 103 ; report status^imaging location IEN^imaging location name^ 104 ; contrast medium or media used 105 ; Note: Single characters in parenthesis indicate contrast 106 ; involvement: (I)=Iodinated ionic; (N)=Iodinated non-ionic; 107 ; (L)=Gadolinium; (C)=Oral Cholecystographic; (G)=Gastrografin; 108 ; (B)=Barium; (M)=unspecified contrast media 109 ; 110 ; Exam ID: exam date/time (inverse) concatenated with the case IEN 111 ; 112 Q:'$D(RADFN) Q:'RADFN K ^TMP($J,"RAE7") 113 N I,RABDT,RACNST,RACSE,RADT,RAEDT,RAIBDT,RAIEDT,RALOC,RACMEDIA,RANO 114 N RAPRC,RAREX,RARPT,RARPTST,RAXAM,RAXID,RAXSTAT 115 S RADT=$S($D(DT)#2:DT,1:$$DT^XLFDT()),RACNST=9999999.9999 116 S RABDT=$$FMADD^XLFDT(RADT,-7,0,0,0),RAEDT=RADT 117 S RAIBDT=RACNST-(RAEDT+.9999),RAIEDT=RACNST-(RABDT-.0001) 118 F S RAIBDT=$O(^RADPT(RADFN,"DT",RAIBDT)) Q:RAIBDT'>0!(RAIBDT>RAIEDT) D 119 . S RANO=0,RAREX(0)=$G(^RADPT(RADFN,"DT",RAIBDT,0)) 120 . S RALOC=+$P(RAREX(0),U,4),RALOC(0)=$G(^RA(79.1,RALOC,0)) 121 . S RALOC=$P($G(^SC(+RALOC(0),0)),"^") 122 . F S RANO=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO)) Q:RANO'>0 D 123 .. S RAXAM(0)=$G(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,0)) 124 .. S RAXID=RAIBDT_"-"_RANO 125 .. S RACSE=$S($P(RAXAM(0),U)]"":$P(RAXAM(0),U),1:"Unknown") 126 .. S RAPRC=$G(^RAMIS(71,+$P(RAXAM(0),U,2),0)) 127 .. S RAPRC=$S($P(RAPRC,U)]"":$P(RAPRC,U),1:"Unknown") 128 .. Q:$P($G(^RA(72,+$P(RAXAM(0),"^",3),0)),"^",3)=0 ; cancelled xam 129 .. S I=0,RACMEDIA="" F S I=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CM",I)) Q:'I S RACMEDIA=RACMEDIA_$P(^(I,0),U) ;RA*5*45 130 .. S RARPT=+$P(RAXAM(0),U,17) 131 .. S RARPTST=$P($G(^RARPT(RARPT,0)),U,5) 132 .. S RARPTST=$S(RARPTST="V":"Verified",RARPTST="R":"Released/Not verified",RARPTST="D":"Draft",RARPTST="PD":"Problem Draft",1:"No Report") 133 .. S ^TMP($J,"RAE7",RADFN,RAXID)=RAPRC_U_RACSE_U_RARPTST_U_+RALOC(0)_U_RALOC_U_RACMEDIA 134 .. Q 135 . Q 136 Q 137 CPTMOD ;extract cpt modifiers if any 138 ;RA loop var, RA1 counter, RA2 intermed vars 139 Q:'$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CMOD",0)) 140 S RA=0,RA1=1 141 F S RA=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CMOD",RA)) Q:'RA I $D(^(RA,0)) D 142 . S RA2=$P(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CMOD",RA,0),"^") 143 . S RA2=$$BASICMOD^RACPTMSC(RA2,+RAREX(0)) Q:+RA2<0 144 . S ^TMP($J,"RAE1",RADFN,RAXID,"CMOD",RA1)=$P(RA2,"^",2)_"^"_$P(RA2,"^",3),RA1=RA1+1 145 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7PC2.m
r613 r623 1 RAO7PC2 ;HISC/GJC-Part two for Return Narrative (EN3^RAO7PC1);1/17/95 ;9/13/01 10:39 2 ;;5.0;Radiology/Nuclear Medicine;**1,11,14,16,22,27,45,75,56**;Mar 16, 1998;Build 3 3 ;Supported IA #10104 UP^XLFSTR 4 ;Supported IA #2055 EXTERNAL^DILFD 5 ;Supported IA #10060 ^VA(200 6 CASE(Y) ; Retrieve exam data for specified inverse exam date range. 7 ; 'Y'-> Exam node IEN 8 N RABNOR,RACNT,RAEXAM,RAI,RAIMPRES,RAINCLUD,RAOPRC,RAORD,RAPDIAG 9 N RAPIST,RAPIRE,RAPROC,RARDE,RADTI,RACNI,RADUPHX,RAREASDY 10 N RARPT,RARPTST,RARPTXT,RASBN,RASDIAG,RAVER,RAERRFLG,Z,Z1,Z2 11 S RACNT=1 12 S RAEXAM(0)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,0)) Q:RAEXAM(0)']"" 13 S:$P(RAEXAM(0),"^",25)=2 RAPSET=1 14 S:RAPSET=1 ^TMP($J,"RAE2",RADFN,"PRINT_SET")="" ; xam set with same rpt 15 S RAPROC(0)=$G(^RAMIS(71,+$P(RAEXAM(0),"^",2),0)) 16 S RAPROC=$S($P(RAPROC(0),"^")]"":$P(RAPROC(0),"^"),1:"Unknown") 17 S RAORD(0)=$G(^RAO(75.1,+$P(RAEXAM(0),"^",11),0)) 18 S RAORD(7)=$P(RAORD(0),"^",7) ; CPRS order ien 19 S RAREASDY=$P($G(^RAO(75.1,+$P(RAEXAM(0),"^",11),.1)),"^") ;REASON FOR STUDY 20 S RAOPRC(0)=$G(^RAMIS(71,+$P(RAORD(0),"^",2),0)) 21 S RAOPRC=$S($P(RAOPRC(0),"^")]"":$P(RAOPRC(0),"^"),1:"Unknown") 22 S RAPDIAG(0)=$G(^RA(78.3,+$P(RAEXAM(0),"^",13),0)) 23 S RAPDIAG=$P(RAPDIAG(0),"^"),RARPT=+$P(RAEXAM(0),"^",17) 24 S RARPT(0)=$G(^RARPT(RARPT,0)),RARPTST=$$UL^RAO7PC1A($$RSTAT^RAO7PC1A()) 25 ; set the following flag variable: RAINCLUD 26 ; RAINCLUD=$S(RPT STATUS=verif'd or released/unverif'd:1,1:0) 27 S RAINCLUD=$S("RV"[$E(RARPTST):1,1:0) 28 I $E(RARPTST)="V",(RAPSET'<0) D 29 . S RAVER=$P(RARPT(0),"^",9),RASBN=$P($G(^VA(200,+RAVER,20)),"^",2) 30 . S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"V")=RAVER_"^"_RASBN 31 . Q 32 S RABNOR=$$UP^XLFSTR($P(RAPDIAG(0),"^",4)) S:RABNOR'="Y" RABNOR="" 33 I RAPDIAG]"",(RAINCLUD),(RAPSET'<0) D ; if diag & verif'd or released/unverif'd & first pass if part of xam set (many xams - one rpt) 34 . S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"D",RACNT)=RAPDIAG 35 . Q 36 S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"RFS")=RAREASDY ;REASON FOR STUDY 37 ; 1st, get clnhist from file70. 2nd, get addl clnhist form file74 38 ; 1st: 39 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",0)) D 40 . N RAI S (RAI,Z)=0 41 . F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",Z)) Q:Z'>0 D 42 .. S RAI=RAI+1 43 .. S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"H",RAI)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",Z,0)) 44 .. Q 45 . Q 46 ;2nd: 47 S RADTI=RAINVXDT,RACNI=Y D CHKDUPHX^RART1 ;chk if file74 clnhist is dupl 48 I 'RADUPHX,$O(^RARPT(RARPT,"H",0)) S Z="H" D RPTXT(RARPT,Z) 49 ; 50 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",0)) D ; save modifiers 51 . N RAI S (RAI,Z)=0 52 . F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",Z)) Q:Z'>0 D 53 .. S RAI=RAI+1 54 .. S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"M",RAI)=$P($G(^RAMIS(71.2,+$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",Z,0)),0)),"^") 55 .. Q 56 . Q 57 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",0)),(RAPSET'<0) D 58 . S Z=0 F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",Z)) Q:Z'>0 D 59 .. S RASDIAG=+$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",Z,0)) 60 .. S RASDIAG(0)=$G(^RA(78.3,RASDIAG,0)),RASDIAG(1)=$P(RASDIAG(0),"^") 61 .. I RASDIAG(1)]"",(RAINCLUD) D 62 ... S RACNT=RACNT+1,^TMP($J,"RAE2",RADFN,Y,RAPROC,"D",RACNT)=RASDIAG(1) 63 ... I RABNOR'="Y" D 64 .... S RABNOR=$$UP^XLFSTR($P(RASDIAG(0),"^",4)) S:RABNOR'="Y" RABNOR="" 65 .... Q 66 ... Q 67 .. Q 68 . Q 69 I RAINCLUD,(RAPSET'<0) D 70 . I +$O(^RARPT(RARPT,"I",0)) S Z="I" D RPTXT(RARPT,Z) 71 . I +$O(^RARPT(RARPT,"R",0)) S Z="R" D RPTXT(RARPT,Z) 72 . Q 73 I $P(RAEXAM(0),"^",25) S ^TMP($J,"RAE2",RADFN,"ORD")=RAOPRC 74 I '$P(RAEXAM(0),"^",25) S ^TMP($J,"RAE2",RADFN,"ORD",Y)=RAOPRC 75 ; 76 ; Check to see if amended report 77 I RAPSET'<0,+$O(^RARPT(RARPT,"ERR",0)) S RAERRFLG="A" 78 ; 79 S:RAPSET'<0 ^TMP($J,"RAE2",RADFN,Y,RAPROC)=RARPTST_"^"_$G(RABNOR)_"^"_$G(RAORD(7))_"^"_$G(RAERRFLG) 80 S:RAPSET<0 ^TMP($J,"RAE2",RADFN,Y,RAPROC)="" 81 S:RAPSET=1 RAPSET=-1 82 ; 83 I RARPTST'="No Report" D 84 .; Add Prim Int Staff, Prim Int Resident & Reported Date 85 .S RAPIST=$P(RAEXAM(0),"^",15) 86 .S RAPIRE=$P(RAEXAM(0),"^",12) 87 .S RARDE=$P(RARPT(0),"^",8) 88 .S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"P")=RAPIST_"^"_RAPIRE_"^"_RARDE 89 ;If contrast media was involved in the exam pass that information. 90 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",0)) S (RACNT,RAI)=0 D 91 .F S RAI=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",RAI)) Q:'RAI D 92 ..S RACNT=RACNT+1 93 ..S RAI(0)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",RAI,0)) 94 ..S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"CM",RACNT)=$P(RAI(0),U)_"^"_$$EXTERNAL^DILFD(70.3225,.01,"",$P(RAI(0),U)) 95 ..Q 96 Q 97 ; 98 RPTXT(RARPT,Z) ; Retrieve report text & store in ^TMP 99 ; 'RARPT' -> Report IEN 100 ; 'Z' -> "I":Impression Text <> "R":Report Text 101 S (Z1,Z2)=0 102 ;file 74's "H" nodes are now additional clinical history 103 I Z="H" S Z2=$O(^TMP($J,"RAE2",RADFN,Y,RAPROC,Z,""),-1) I $O(^RARPT(RARPT,Z,Z1)) S Z2=Z2+1,^TMP($J,"RAE2",RADFN,Y,RAPROC,Z,Z2)="Additional Clinical History:" 104 F S Z1=$O(^RARPT(RARPT,Z,Z1)) Q:Z1'>0 D 105 . S Z1(0)=$G(^RARPT(RARPT,Z,Z1,0)),Z2=Z2+1 106 . S ^TMP($J,"RAE2",RADFN,Y,RAPROC,Z,Z2)=Z1(0) 107 . Q 108 Q 109 ; 110 CLIN(DFN,PROCLIST) ;Radiology and Clinical Reminders API 111 ; 112 ; Created by Cameron Taylor March 1999 113 ; 114 ; This API recieves a patient and a list of procedures. For each 115 ; Procedure, the details of the last 'complete' procedure and/or the 116 ; last 'cancelled' & 'in progress' procedure details and returns them 117 ; in ^TMP($J,"RADPROC" 118 N XX,PROC,DATE,STATUS,PROVIDER,EXAM,X,Y,EXAMIEN,RADPTIEN,ORDER,SUCCESS 119 ; 120 S DFN=$G(DFN) ; Patient Name 121 S PROCLIST=$G(PROCLIST) ; List of Procedures (separated by '^') 122 K ^TMP($J,"RADPROC") 123 ; 124 S RADPTIEN=$O(^RADPT("B",DFN,"")) 125 I (RADPTIEN="")!(RADPTIEN=0) D Q 126 .S ^TMP($J,"RADPROC")="Invalid/Unknown Radiology Patient" 127 ; 128 F XX=1:1 S PROC=$P(PROCLIST,U,XX) Q:PROC="" D 129 .S SUCCESS=0 ; Quit searching if SUCCESS=3 (comp, canc & in prog) 130 .S DATE=0 F S DATE=$O(^RADPT(RADPTIEN,"DT",DATE)) Q:DATE'?7N1".".N!(SUCCESS=3) D 131 ..S EXAMIEN=0 F S EXAMIEN=$O(^RADPT(RADPTIEN,"DT",DATE,"P",EXAMIEN)) Q:'EXAMIEN!(SUCCESS=3) D 132 ...S EXAM=$G(^RADPT(RADPTIEN,"DT",DATE,"P",EXAMIEN,0)) 133 ...Q:$P(EXAM,U,2)'=PROC 134 ...; 135 ...; Continue, get STATUS and ORDER 136 ...; (0 is cancelled, 1-8 in progress & 9 is COMPLETE) 137 ...; (ignore if null) 138 ...; 139 ...S STATUS=$P(EXAM,U,3) 140 ...I STATUS'="" D 141 ....S ORDER=$P(^RA(72,STATUS,0),U,3) 142 ....S STATUS=$P(^RA(72,STATUS,0),U) ; description 143 ...; 144 ...; Only one of each type (ORDER) 145 ...; 146 ...Q:ORDER="" 147 ...I ORDER=0 Q:$D(^TMP($J,"RADPROC",RADPTIEN,PROC,"CANCELLED")) S ORDER="CANCELLED" 148 ...I ORDER=9 Q:$D(^TMP($J,"RADPROC",RADPTIEN,PROC,"COMPLETE")) S ORDER="COMPLETE" 149 ...I ORDER<9,ORDER>0 Q:$D(^TMP($J,"RADPROC",RADPTIEN,PROC,"IN PROGRESS")) S ORDER="IN PROGRESS" 150 ...; 151 ...; Now for the PROVIDER. Check PRIMARY INTERPRETING STAFF 152 ...; if none, then default to PRIMARY INTERPRETING RESIDENT. 153 ...; 154 ...S PROVIDER=$P(EXAM,U,15) 155 ...S:PROVIDER="" PROVIDER=$P(EXAM,U,12) 156 ...S:PROVIDER'="" PROVIDER=$P($G(^VA(200,PROVIDER,0)),U,1) ; description 157 ...; 158 ...; Create return info. on ^TMP (1st manipulate DATE) 159 ...; 160 ...S Y=9999999.9999-DATE 161 ...S ^TMP($J,"RADPROC",RADPTIEN,PROC,ORDER)=Y_U_STATUS_U_PROVIDER 162 ...S SUCCESS=SUCCESS+1 163 .; 164 .; Finished searching Patient file. Any Procedures with no activity? 165 .; 166 .I '$D(^TMP($J,"RADPROC",RADPTIEN,PROC)) S ^TMP($J,"RADPROC",RADPTIEN,PROC,"NONE")="" 167 Q 168 ; 1 RAO7PC2 ;HISC/GJC-Part two for Return Narrative (EN3^RAO7PC1);1/17/95 ;9/13/01 10:39 2 ;;5.0;Radiology/Nuclear Medicine;**1,11,14,16,22,27,45,75**;Mar 16, 1998;Build 4 3 CASE(Y) ; Retrieve exam data for specified inverse exam date range. 4 ; 'Y'-> Exam node IEN 5 N RABNOR,RACNT,RAEXAM,RAI,RAIMPRES,RAINCLUD,RAOPRC,RAORD,RAPDIAG 6 N RAPIST,RAPIRE,RAPROC,RARDE,RADTI,RACNI,RADUPHX,RAREASDY 7 N RARPT,RARPTST,RARPTXT,RASBN,RASDIAG,RAVER,RAERRFLG,Z,Z1,Z2 8 S RACNT=1 9 S RAEXAM(0)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,0)) Q:RAEXAM(0)']"" 10 S:$P(RAEXAM(0),"^",25)=2 RAPSET=1 11 S:RAPSET=1 ^TMP($J,"RAE2",RADFN,"PRINT_SET")="" ; xam set with same rpt 12 S RAPROC(0)=$G(^RAMIS(71,+$P(RAEXAM(0),"^",2),0)) 13 S RAPROC=$S($P(RAPROC(0),"^")]"":$P(RAPROC(0),"^"),1:"Unknown") 14 S RAORD(0)=$G(^RAO(75.1,+$P(RAEXAM(0),"^",11),0)) 15 S RAORD(7)=$P(RAORD(0),"^",7) ; CPRS order ien 16 S RAREASDY=$P($G(^RAO(75.1,+$P(RAEXAM(0),"^",11),.1)),"^") ;REASON FOR STUDY 17 S RAOPRC(0)=$G(^RAMIS(71,+$P(RAORD(0),"^",2),0)) 18 S RAOPRC=$S($P(RAOPRC(0),"^")]"":$P(RAOPRC(0),"^"),1:"Unknown") 19 S RAPDIAG(0)=$G(^RA(78.3,+$P(RAEXAM(0),"^",13),0)) 20 S RAPDIAG=$P(RAPDIAG(0),"^"),RARPT=+$P(RAEXAM(0),"^",17) 21 S RARPT(0)=$G(^RARPT(RARPT,0)),RARPTST=$P(RARPT(0),"^",5) 22 S RARPTST=$S(RARPTST="V":"Verified",RARPTST="R":"Released/Not verified",RARPTST="D":"Draft",RARPTST="PD":"Problem Draft",1:"No Report") 23 ; set the following flag variable: RAINCLUD 24 ; RAINCLUD=$S(RPT STATUS=verif'd or released/unverif'd:1,1:0) 25 S RAINCLUD=$S("RV"[$E(RARPTST):1,1:0) 26 I $E(RARPTST)="V",(RAPSET'<0) D 27 . S RAVER=$P(RARPT(0),"^",9),RASBN=$P($G(^VA(200,+RAVER,20)),"^",2) 28 . S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"V")=RAVER_"^"_RASBN 29 . Q 30 S RABNOR=$$UP^XLFSTR($P(RAPDIAG(0),"^",4)) S:RABNOR'="Y" RABNOR="" 31 I RAPDIAG]"",(RAINCLUD),(RAPSET'<0) D ; if diag & verif'd or released/unverif'd & first pass if part of xam set (many xams - one rpt) 32 . S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"D",RACNT)=RAPDIAG 33 . Q 34 S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"RFS")=RAREASDY ;REASON FOR STUDY 35 ; 1st, get clnhist from file70. 2nd, get addl clnhist form file74 36 ; 1st: 37 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",0)) D 38 . N RAI S (RAI,Z)=0 39 . F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",Z)) Q:Z'>0 D 40 .. S RAI=RAI+1 41 .. S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"H",RAI)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",Z,0)) 42 .. Q 43 . Q 44 ;2nd: 45 S RADTI=RAINVXDT,RACNI=Y D CHKDUPHX^RART1 ;chk if file74 clnhist is dupl 46 I 'RADUPHX,$O(^RARPT(RARPT,"H",0)) S Z="H" D RPTXT(RARPT,Z) 47 ; 48 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",0)) D ; save modifiers 49 . N RAI S (RAI,Z)=0 50 . F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",Z)) Q:Z'>0 D 51 .. S RAI=RAI+1 52 .. S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"M",RAI)=$P($G(^RAMIS(71.2,+$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",Z,0)),0)),"^") 53 .. Q 54 . Q 55 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",0)),(RAPSET'<0) D 56 . S Z=0 F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",Z)) Q:Z'>0 D 57 .. S RASDIAG=+$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",Z,0)) 58 .. S RASDIAG(0)=$G(^RA(78.3,RASDIAG,0)),RASDIAG(1)=$P(RASDIAG(0),"^") 59 .. I RASDIAG(1)]"",(RAINCLUD) D 60 ... S RACNT=RACNT+1,^TMP($J,"RAE2",RADFN,Y,RAPROC,"D",RACNT)=RASDIAG(1) 61 ... I RABNOR'="Y" D 62 .... S RABNOR=$$UP^XLFSTR($P(RASDIAG(0),"^",4)) S:RABNOR'="Y" RABNOR="" 63 .... Q 64 ... Q 65 .. Q 66 . Q 67 I RAINCLUD,(RAPSET'<0) D 68 . I +$O(^RARPT(RARPT,"I",0)) S Z="I" D RPTXT(RARPT,Z) 69 . I +$O(^RARPT(RARPT,"R",0)) S Z="R" D RPTXT(RARPT,Z) 70 . Q 71 I $P(RAEXAM(0),"^",25) S ^TMP($J,"RAE2",RADFN,"ORD")=RAOPRC 72 I '$P(RAEXAM(0),"^",25) S ^TMP($J,"RAE2",RADFN,"ORD",Y)=RAOPRC 73 ; 74 ; Check to see if amended report 75 I RAPSET'<0,+$O(^RARPT(RARPT,"ERR",0)) S RAERRFLG="A" 76 ; 77 S:RAPSET'<0 ^TMP($J,"RAE2",RADFN,Y,RAPROC)=RARPTST_"^"_$G(RABNOR)_"^"_$G(RAORD(7))_"^"_$G(RAERRFLG) 78 S:RAPSET<0 ^TMP($J,"RAE2",RADFN,Y,RAPROC)="" 79 S:RAPSET=1 RAPSET=-1 80 ; 81 I RARPTST'="No Report" D 82 .; Add Prim Int Staff, Prim Int Resident & Reported Date 83 .S RAPIST=$P(RAEXAM(0),"^",15) 84 .S RAPIRE=$P(RAEXAM(0),"^",12) 85 .S RARDE=$P(RARPT(0),"^",8) 86 .S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"P")=RAPIST_"^"_RAPIRE_"^"_RARDE 87 ;If contrast media was involved in the exam pass that information. 88 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",0)) S (RACNT,RAI)=0 D 89 .F S RAI=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",RAI)) Q:'RAI D 90 ..S RACNT=RACNT+1 91 ..S RAI(0)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",RAI,0)) 92 ..S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"CM",RACNT)=$P(RAI(0),U)_"^"_$$EXTERNAL^DILFD(70.3225,.01,"",$P(RAI(0),U)) 93 ..Q 94 Q 95 ; 96 RPTXT(RARPT,Z) ; Retrieve report text & store in ^TMP 97 ; 'RARPT' -> Report IEN 98 ; 'Z' -> "I":Impression Text <> "R":Report Text 99 S (Z1,Z2)=0 100 ;file 74's "H" nodes are now additional clinical history 101 I Z="H" S Z2=$O(^TMP($J,"RAE2",RADFN,Y,RAPROC,Z,""),-1) I $O(^RARPT(RARPT,Z,Z1)) S Z2=Z2+1,^TMP($J,"RAE2",RADFN,Y,RAPROC,Z,Z2)="Additional Clinical History:" 102 F S Z1=$O(^RARPT(RARPT,Z,Z1)) Q:Z1'>0 D 103 . S Z1(0)=$G(^RARPT(RARPT,Z,Z1,0)),Z2=Z2+1 104 . S ^TMP($J,"RAE2",RADFN,Y,RAPROC,Z,Z2)=Z1(0) 105 . Q 106 Q 107 ; 108 CLIN(DFN,PROCLIST) ;Radiology and Clinical Reminders API 109 ; 110 ; Created by Cameron Taylor March 1999 111 ; 112 ; This API recieves a patient and a list of procedures. For each 113 ; Procedure, the details of the last 'complete' procedure and/or the 114 ; last 'cancelled' & 'in progress' procedure details and returns them 115 ; in ^TMP($J,"RADPROC" 116 N XX,PROC,DATE,STATUS,PROVIDER,EXAM,X,Y,EXAMIEN,RADPTIEN,ORDER,SUCCESS 117 ; 118 S DFN=$G(DFN) ; Patient Name 119 S PROCLIST=$G(PROCLIST) ; List of Procedures (separated by '^') 120 K ^TMP($J,"RADPROC") 121 ; 122 S RADPTIEN=$O(^RADPT("B",DFN,"")) 123 I (RADPTIEN="")!(RADPTIEN=0) D Q 124 .S ^TMP($J,"RADPROC")="Invalid/Unknown Radiology Patient" 125 ; 126 F XX=1:1 S PROC=$P(PROCLIST,U,XX) Q:PROC="" D 127 .S SUCCESS=0 ; Quit searching if SUCCESS=3 (comp, canc & in prog) 128 .S DATE=0 F S DATE=$O(^RADPT(RADPTIEN,"DT",DATE)) Q:DATE'?7N1".".N!(SUCCESS=3) D 129 ..S EXAMIEN=0 F S EXAMIEN=$O(^RADPT(RADPTIEN,"DT",DATE,"P",EXAMIEN)) Q:'EXAMIEN!(SUCCESS=3) D 130 ...S EXAM=$G(^RADPT(RADPTIEN,"DT",DATE,"P",EXAMIEN,0)) 131 ...Q:$P(EXAM,U,2)'=PROC 132 ...; 133 ...; Continue, get STATUS and ORDER 134 ...; (0 is cancelled, 1-8 in progress & 9 is COMPLETE) 135 ...; (ignore if null) 136 ...; 137 ...S STATUS=$P(EXAM,U,3) 138 ...I STATUS'="" D 139 ....S ORDER=$P(^RA(72,STATUS,0),U,3) 140 ....S STATUS=$P(^RA(72,STATUS,0),U) ; description 141 ...; 142 ...; Only one of each type (ORDER) 143 ...; 144 ...Q:ORDER="" 145 ...I ORDER=0 Q:$D(^TMP($J,"RADPROC",RADPTIEN,PROC,"CANCELLED")) S ORDER="CANCELLED" 146 ...I ORDER=9 Q:$D(^TMP($J,"RADPROC",RADPTIEN,PROC,"COMPLETE")) S ORDER="COMPLETE" 147 ...I ORDER<9,ORDER>0 Q:$D(^TMP($J,"RADPROC",RADPTIEN,PROC,"IN PROGRESS")) S ORDER="IN PROGRESS" 148 ...; 149 ...; Now for the PROVIDER. Check PRIMARY INTERPRETING STAFF 150 ...; if none, then default to PRIMARY INTERPRETING RESIDENT. 151 ...; 152 ...S PROVIDER=$P(EXAM,U,15) 153 ...S:PROVIDER="" PROVIDER=$P(EXAM,U,12) 154 ...S:PROVIDER'="" PROVIDER=$P($G(^VA(200,PROVIDER,0)),U,1) ; description 155 ...; 156 ...; Create return info. on ^TMP (1st manipulate DATE) 157 ...; 158 ...S Y=9999999.9999-DATE 159 ...S ^TMP($J,"RADPROC",RADPTIEN,PROC,ORDER)=Y_U_STATUS_U_PROVIDER 160 ...S SUCCESS=SUCCESS+1 161 .; 162 .; Finished searching Patient file. Any Procedures with no activity? 163 .; 164 .I '$D(^TMP($J,"RADPROC",RADPTIEN,PROC)) S ^TMP($J,"RADPROC",RADPTIEN,PROC,"NONE")="" 165 Q 166 ; -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7PC3.m
r613 r623 1 RAO7PC3 ;HISC/SWM&CRT-Procedure Call utilities. ;7/30/01 10:28 2 ;;5.0;Radiology/Nuclear Medicine;**16,26,27,56**;Mar 16, 1998;Build 3 3 ;Supported IA #2056 GET1^DIQ 4 ;Supported IA 10104 UP^XLFSTR 5 ;; api to return entire report (same as auto e-mail's) 6 EN3(X) ; Return narrative text for exam(s) 7 ; Input: 8 ; X-> Exam id in one of two forms: 9 ; 1) Pat. DFN^inv. exam date^Case IEN 10 ; Retrieves a single report for a single exam 11 ; 2) Pat. DFN^inv. exam date^ 12 ; Retrieves all reports for a set of exams ordered on one order 13 ; 14 ; Note: Input delimiter can be any of the following: ^~\&;- 15 ; a delimiter may be a single space i.e, " " 16 ; 17 ; Output: 18 ; ^TMP($J,"RAE3",Patient IEN,case IEN,procedure name)=report status^ 19 ; abnormal alert^CPRS Order ien 20 ; ^TMP($J,"RAE3",Patient IEN,case IEN,procedure name,n)=line n of rpt 21 ; ^TMP($J,"RAE3",Patient IEN,"PRINT_SET")=null (IF this is a printset) 22 ; ^TMP($J,"RAE3",Patient IEN,"ORD")=name of ordered procedure for 23 ; examsets and printsets 24 ; ^TMP($J,"RAE3",Patient IEN,"ORD",case IEN)=name of ordered procedure 25 ; for that case; not part of an examset or printset 26 ; 27 ; 28 K ^TMP($J,"RAE3"),^TMP($J,"RA AUTOE") 29 K RAU S RAU=$$DEL^RAO7PC1(X) I RAU="" K RAU Q 30 Q:'$P(X,RAU)!('$P(X,RAU,2)) ; Quit if no Pat. DFN -or- no inv. exam DT 31 N RACIEN,RADFN,RAINVXDT,RAPSET,RAUTOE,Y S RAPSET=0 32 S RADFN=$P(X,RAU),RAINVXDT=$P(X,RAU,2),RACIEN=+$P(X,RAU,3) 33 K RAU Q:'($D(^RADPT(RADFN,"DT",RAINVXDT,0))#2) 34 I RACIEN D CASE(RACIEN) Q 35 S Y=0 36 F S Y=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y)) Q:Y'>0 D 37 . D CASE(Y) S RAPSET=0 38 . Q 39 Q 40 EN30(RAOIFN) ; Return narrative text for exam(s). 41 ; To be used with the EN3 entry point above. 42 ; 43 ; Input: RAOIFN -> the ien of Rad/Nuc Med Order 44 ; 45 Q:'RAOIFN ; order passed in as 0 or null 46 Q:'$D(^RAO(75.1,RAOIFN,0)) ; no such order 47 Q:'$D(^RADPT("AO",RAOIFN)) ; no exam associated with this order 48 N RADFN,RADTI,RACNI,RAXSET 49 S RADFN=+$O(^RADPT("AO",RAOIFN,0)) Q:'RADFN 50 S RADTI=+$O(^RADPT("AO",RAOIFN,RADFN,0)) Q:'RADTI 51 S RAXSET=+$P($G(^RADPT(RADFN,"DT",RADTI,0)),"^",5) ; set if RAXSET=1 52 I RAXSET D EN3(RADFN_"^"_RADTI_"^") Q ; exam set, hit EN3 code 53 ; the following code is executed for non-exam set examinations 54 S RACNI=+$O(^RADPT("AO",RAOIFN,RADFN,RADTI,0)) Q:'RACNI 55 D EN3(RADFN_"^"_RADTI_"^"_RACNI) 56 Q 57 CASE(Y) ; 58 N N,RABNOR,RACASE,RACIEN,RADIAG,RAEXAM,RAINCLUD,RAOPRC,RAORD,BLANK 59 N RAMSG,RAPDIAG,RAPROC,RARDE,RARPT,RARPTST,RASPACE,SKIP,X,ZZRADFN,X0,X1,X2,RASIGVES,RARPTST2 60 ; 61 S RACIEN=Y,$P(BLANK," ",80)="" 62 S RAEXAM(0)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",RACIEN,0)) Q:RAEXAM(0)']"" 63 S RACASE=$P(RAEXAM(0),"^") 64 S:$P(RAEXAM(0),"^",25)=2 RAPSET=1 65 S:RAPSET=1 ^TMP($J,"RAE3",RADFN,"PRINT_SET")="" 66 S RAPROC(0)=$G(^RAMIS(71,+$P(RAEXAM(0),"^",2),0)) 67 S RAPROC=$S($P(RAPROC(0),"^")]"":$P(RAPROC(0),"^"),1:"Unknown") 68 S RAORD(0)=$G(^RAO(75.1,+$P(RAEXAM(0),"^",11),0)) 69 S RAORD(7)=$P(RAORD(0),"^",7) 70 S RAOPRC(0)=$G(^RAMIS(71,+$P(RAORD(0),"^",2),0)) 71 S RAOPRC=$S($P(RAOPRC(0),"^")]"":$P(RAOPRC(0),"^"),1:"Unknown") 72 S RAPDIAG(0)=$G(^RA(78.3,+$P(RAEXAM(0),"^",13),0)) 73 S RARPT=+$P(RAEXAM(0),"^",17),RARPTST2=$$UL^RAO7PC1A($$RSTAT^RAO7PC1A()) 74 S RARPT(0)=$G(^RARPT(RARPT,0)),RARPTST=$P(RARPT(0),"^",5) 75 S RASIGVES="" I RARPTST="V",$P(RARPT(0),U,10)]"",$P(RARPT(0),U,9)]"" S X2=RARPT,X1=$P(RARPT(0),U,9),X=$P(RARPT(0),U,10) D DE^XUSHSHP S:X]"" RASIGVES="/ES/"_X 76 S RARDE=$$GET1^DIQ(74,RARPT_",",8,"E") 77 ; View whole report if Rad User or status is R or V. 78 D CHKUSR^RAUTL2 S RAINCLUD=RAMSG 79 S RAINCLUD=$S(RAMSG:1,RARPTST="V":1,RARPTST="R":1,1:0) 80 S RABNOR=$$UP^XLFSTR($P(RAPDIAG(0),"^",4)) S:RABNOR'="Y" RABNOR="" 81 ; 82 I $P(RAEXAM(0),"^",25) S ^TMP($J,"RAE3",RADFN,"ORD")=RAOPRC 83 I '$P(RAEXAM(0),"^",25) S ^TMP($J,"RAE3",RADFN,"ORD",RACIEN)=RAOPRC 84 ; 85 I RAPSET'<0 D 86 .S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC)="^"_RABNOR_"^"_RAORD(7) 87 .S $P(^TMP($J,"RAE3",RADFN,RACIEN,RAPROC),"^")=RARPTST2 88 S:RAPSET<0 ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC)="" 89 S:RAPSET=1 RAPSET=-1 90 ; 91 ; Setup variables then call ^RARTR to create Rad Report on ^TMP nodes 92 ; 2 stages: INIT^RARTR creates header info, PRT1^RARTR for the report 93 ; (save RADFN as RARTR kills it at the end) 94 ; 95 S RAUTOE=1,ZZRADFN=RADFN,RAACNT=0 96 S X="^"_RADFN_"^"_(9999999.9999-RAINVXDT)_"^"_RACASE_"^"_RARPTST 97 ; 98 D INIT^RARTR 99 S (RAFFLF,RAORIOF)=$G(IOF) 100 I RAY0<0!(RAY1<0)!(RAY2<0)!(RAY3<0) K RAFFLF Q 101 ; 102 S RAVERF=0 103 I RARPTST2="No Report" D 104 .S:'$D(RAMDIV) RAMDIV=+$P(^RADPT(RADFN,"DT",RAINVXDT,0),"^",3) 105 .S:'$D(RAMDV) RAMDV=$S($D(^RA(79,RAMDIV,.1)):^(.1),1:""),RAMDV=$TR(RAMDV,"YNyn","1010") 106 D PRT1^RARTR 107 S RADFN=ZZRADFN 108 Q:'$D(^TMP($J,"RA AUTOE")) 109 ; 110 ; Now manipulate ^TMP($J,"RA AUTOE" and save as ^TMP($J,"RAE3" 111 ; Step 1: Change Case Number to Exam Date 112 ; Step 2: Remove Impression, Report & Diagnostic Codes if not 113 ; Released or Verified 114 ; Also remove "Att Phys" and "Pri Phys" 115 ; Step 3: Change Status to Report Status & add Reported Date 116 ; Step 4: If No Report then get Clin History from file #70. 117 ; ** WITH PATCH 27 - NO LONGER NEED TO DO STEP 4 ** 118 ; 119 STEP1 S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,1)=$P(^TMP($J,"RA AUTOE",1),"Case: ") 120 S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,1.5)="Exm Date: "_$$GET1^DIQ(70.02,RAINVXDT_","_RADFN_",",.01,"E") 121 ; 122 STEP2 K SKIP S N=1 F S N=$O(^TMP($J,"RA AUTOE",N)) Q:N="" D 123 . S X0=^TMP($J,"RA AUTOE",N),X1=$E(X0,1,10) 124 . I (X1="Att Phys: ")!(X1="Pri Phys: ") D 125 .. S ^TMP($J,"RA AUTOE",N)=$E(BLANK,1,41)_$E(X0,42,$L(X0)) 126 .. Q 127 .;I RARPTST2="No Report",($E(^TMP($J,"RA AUTOE",N),1,21)=" Clinical History:") D STEP4 128 .I $E(^TMP($J,"RA AUTOE",N),1,12)=" Report: " D STEP3 Q:RARPTST2="No Report" 129 .I 'RAINCLUD,$E(^TMP($J,"RA AUTOE",N),1,15)=" Impression:" D 130 ..S SKIP=1,^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N+0.1)="" 131 .I 'RAINCLUD,$E(^TMP($J,"RA AUTOE",N),1,28)=" Primary Diagnostic Code:" D 132 ..S SKIP=1 S ^TMP($J,"RA AUTOE",N)=$E(^TMP($J,"RA AUTOE",N),1,28) 133 .I 'RAINCLUD,$E(^TMP($J,"RA AUTOE",N),1,31)=" Secondary Diagnostic Codes:" D 134 ..S SKIP=1,^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N+0.1)="" 135 .I $E(^TMP($J,"RA AUTOE",N),1,27)="Primary Interpreting Staff:" K SKIP 136 .I $D(SKIP) S SKIP=SKIP+1 137 .I $G(SKIP)<3 S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N)=^TMP($J,"RA AUTOE",N) 138 .Q 139 ; 140 XIT K ^TMP($J,"RA AUTOE") 141 Q 142 ; 143 STEP3 S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N-0.4)=" Report Status: "_RARPTST2 144 I RARPTST2="No Report" S N="^" Q 145 S $P(RASPACE," ",46)="" 146 S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N-0.4)=^(N-0.4)_$E(RASPACE,1,46-$L(^(N-0.4)))_"Date Reported: "_RARDE 147 I RARPTST="V" D 148 . S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N-0.3)=RASPACE_" Date Verified: "_$P($$GET1^DIQ(74,+$P(RAEXAM(0),"^",17),7),"@") 149 . S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N-0.2)=" Verifier E-Sig:"_RASIGVES 150 . Q 151 S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N-0.1)="" 152 S ^TMP($J,"RA AUTOE",N)=" Report:" 153 I 'RAINCLUD S SKIP=1,^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N+0.1)="" 154 Q 155 ; 156 STEP4 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",RACIEN,"H",0)) D 157 .N RAI,RAIN,Z S (RAI,Z)=0,RAIN=N_".000" 158 .F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",RACIEN,"H",Z)) Q:Z'>0 D 159 ..S RAI=RAI+1 160 ..S RAIN=$E(RAIN,1,$L(RAIN)-$L(RAI))_RAI 161 ..S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,RAIN)=" "_$G(^RADPT(RADFN,"DT",RAINVXDT,"P",RACIEN,"H",Z,0)) 162 Q 1 RAO7PC3 ;HISC/SWM&CRT-Procedure Call utilities. ;7/30/01 10:28 2 ;;5.0;Radiology/Nuclear Medicine;**16,26,27**;Mar 16, 1998 3 ;; api to return entire report (same as auto e-mail's) 4 EN3(X) ; Return narrative text for exam(s) 5 ; Input: 6 ; X-> Exam id in one of two forms: 7 ; 1) Pat. DFN^inv. exam date^Case IEN 8 ; Retrieves a single report for a single exam 9 ; 2) Pat. DFN^inv. exam date^ 10 ; Retrieves all reports for a set of exams ordered on one order 11 ; 12 ; Note: Input delimiter can be any of the following: ^~\&;- 13 ; a delimiter may be a single space i.e, " " 14 ; 15 ; Output: 16 ; ^TMP($J,"RAE3",Patient IEN,case IEN,procedure name)=report status^ 17 ; abnormal alert^CPRS Order ien 18 ; ^TMP($J,"RAE3",Patient IEN,case IEN,procedure name,n)=line n of rpt 19 ; ^TMP($J,"RAE3",Patient IEN,"PRINT_SET")=null (IF this is a printset) 20 ; ^TMP($J,"RAE3",Patient IEN,"ORD")=name of ordered procedure for 21 ; examsets and printsets 22 ; ^TMP($J,"RAE3",Patient IEN,"ORD",case IEN)=name of ordered procedure 23 ; for that case; not part of an examset or printset 24 ; 25 ; 26 K ^TMP($J,"RAE3"),^TMP($J,"RA AUTOE") 27 K RAU S RAU=$$DEL^RAO7PC1(X) I RAU="" K RAU Q 28 Q:'$P(X,RAU)!('$P(X,RAU,2)) ; Quit if no Pat. DFN -or- no inv. exam DT 29 N RACIEN,RADFN,RAINVXDT,RAPSET,RAUTOE,Y S RAPSET=0 30 S RADFN=$P(X,RAU),RAINVXDT=$P(X,RAU,2),RACIEN=+$P(X,RAU,3) 31 K RAU Q:'($D(^RADPT(RADFN,"DT",RAINVXDT,0))#2) 32 I RACIEN D CASE(RACIEN) Q 33 S Y=0 34 F S Y=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y)) Q:Y'>0 D 35 . D CASE(Y) S RAPSET=0 36 . Q 37 Q 38 EN30(RAOIFN) ; Return narrative text for exam(s). 39 ; To be used with the EN3 entry point above. 40 ; 41 ; Input: RAOIFN -> the ien of Rad/Nuc Med Order 42 ; 43 Q:'RAOIFN ; order passed in as 0 or null 44 Q:'$D(^RAO(75.1,RAOIFN,0)) ; no such order 45 Q:'$D(^RADPT("AO",RAOIFN)) ; no exam associated with this order 46 N RADFN,RADTI,RACNI,RAXSET 47 S RADFN=+$O(^RADPT("AO",RAOIFN,0)) Q:'RADFN 48 S RADTI=+$O(^RADPT("AO",RAOIFN,RADFN,0)) Q:'RADTI 49 S RAXSET=+$P($G(^RADPT(RADFN,"DT",RADTI,0)),"^",5) ; set if RAXSET=1 50 I RAXSET D EN3(RADFN_"^"_RADTI_"^") Q ; exam set, hit EN3 code 51 ; the following code is executed for non-exam set examinations 52 S RACNI=+$O(^RADPT("AO",RAOIFN,RADFN,RADTI,0)) Q:'RACNI 53 D EN3(RADFN_"^"_RADTI_"^"_RACNI) 54 Q 55 CASE(Y) ; 56 N N,RABNOR,RACASE,RACIEN,RADIAG,RAEXAM,RAINCLUD,RAOPRC,RAORD,BLANK 57 N RAMSG,RAPDIAG,RAPROC,RARDE,RARPT,RARPTST,RASPACE,SKIP,X,ZZRADFN,X0,X1,X2,RASIGVES 58 ; 59 S RACIEN=Y,$P(BLANK," ",80)="" 60 S RAEXAM(0)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",RACIEN,0)) Q:RAEXAM(0)']"" 61 S RACASE=$P(RAEXAM(0),"^") 62 S:$P(RAEXAM(0),"^",25)=2 RAPSET=1 63 S:RAPSET=1 ^TMP($J,"RAE3",RADFN,"PRINT_SET")="" 64 S RAPROC(0)=$G(^RAMIS(71,+$P(RAEXAM(0),"^",2),0)) 65 S RAPROC=$S($P(RAPROC(0),"^")]"":$P(RAPROC(0),"^"),1:"Unknown") 66 S RAORD(0)=$G(^RAO(75.1,+$P(RAEXAM(0),"^",11),0)) 67 S RAORD(7)=$P(RAORD(0),"^",7) 68 S RAOPRC(0)=$G(^RAMIS(71,+$P(RAORD(0),"^",2),0)) 69 S RAOPRC=$S($P(RAOPRC(0),"^")]"":$P(RAOPRC(0),"^"),1:"Unknown") 70 S RAPDIAG(0)=$G(^RA(78.3,+$P(RAEXAM(0),"^",13),0)) 71 S RARPT=+$P(RAEXAM(0),"^",17) 72 S RARPT(0)=$G(^RARPT(RARPT,0)),RARPTST=$P(RARPT(0),"^",5) 73 S RASIGVES="" I RARPTST="V",$P(RARPT(0),U,10)]"",$P(RARPT(0),U,9)]"" S X2=RARPT,X1=$P(RARPT(0),U,9),X=$P(RARPT(0),U,10) D DE^XUSHSHP S:X]"" RASIGVES="/ES/"_X 74 S RARDE=$$GET1^DIQ(74,RARPT_",",8,"E") 75 ; View whole report if Rad User or status is R or V. 76 D CHKUSR^RAUTL2 S RAINCLUD=RAMSG 77 S RAINCLUD=$S(RAMSG:1,RARPTST="V":1,RARPTST="R":1,1:0) 78 S RABNOR=$$UP^XLFSTR($P(RAPDIAG(0),"^",4)) S:RABNOR'="Y" RABNOR="" 79 ; 80 I $P(RAEXAM(0),"^",25) S ^TMP($J,"RAE3",RADFN,"ORD")=RAOPRC 81 I '$P(RAEXAM(0),"^",25) S ^TMP($J,"RAE3",RADFN,"ORD",RACIEN)=RAOPRC 82 ; 83 I RAPSET'<0 D 84 .S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC)="^"_RABNOR_"^"_RAORD(7) 85 .S $P(^TMP($J,"RAE3",RADFN,RACIEN,RAPROC),"^")=$$RPTST 86 S:RAPSET<0 ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC)="" 87 S:RAPSET=1 RAPSET=-1 88 ; 89 ; Setup variables then call ^RARTR to create Rad Report on ^TMP nodes 90 ; 2 stages: INIT^RARTR creates header info, PRT1^RARTR for the report 91 ; (save RADFN as RARTR kills it at the end) 92 ; 93 S RAUTOE=1,ZZRADFN=RADFN,RAACNT=0 94 S X="^"_RADFN_"^"_(9999999.9999-RAINVXDT)_"^"_RACASE_"^"_RARPTST 95 ; 96 D INIT^RARTR 97 S (RAFFLF,RAORIOF)=$G(IOF) 98 I RAY0<0!(RAY1<0)!(RAY2<0)!(RAY3<0) K RAFFLF Q 99 ; 100 S RAVERF=0 101 I $$RPTST="No Report" D 102 .S:'$D(RAMDIV) RAMDIV=+$P(^RADPT(RADFN,"DT",RAINVXDT,0),"^",3) 103 .S:'$D(RAMDV) RAMDV=$S($D(^RA(79,RAMDIV,.1)):^(.1),1:"") 104 D PRT1^RARTR 105 S RADFN=ZZRADFN 106 Q:'$D(^TMP($J,"RA AUTOE")) 107 ; 108 ; Now manipulate ^TMP($J,"RA AUTOE" and save as ^TMP($J,"RAE3" 109 ; Step 1: Change Case Number to Exam Date 110 ; Step 2: Remove Impression, Report & Diagnostic Codes if not 111 ; Released or Verified 112 ; Also remove "Att Phys" and "Pri Phys" 113 ; Step 3: Change Status to Report Status & add Reported Date 114 ; Step 4: If No Report then get Clin History from file #70. 115 ; ** WITH PATCH 27 - NO LONGER NEED TO DO STEP 4 ** 116 ; 117 STEP1 S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,1)=$P(^TMP($J,"RA AUTOE",1),"Case: ") 118 S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,1.5)="Exm Date: "_$$GET1^DIQ(70.02,RAINVXDT_","_RADFN_",",.01,"E") 119 ; 120 STEP2 K SKIP S N=1 F S N=$O(^TMP($J,"RA AUTOE",N)) Q:N="" D 121 . S X0=^TMP($J,"RA AUTOE",N),X1=$E(X0,1,10) 122 . I (X1="Att Phys: ")!(X1="Pri Phys: ") D 123 .. S ^TMP($J,"RA AUTOE",N)=$E(BLANK,1,41)_$E(X0,42,$L(X0)) 124 .. Q 125 .;I $$RPTST="No Report",($E(^TMP($J,"RA AUTOE",N),1,21)=" Clinical History:") D STEP4 126 .I $E(^TMP($J,"RA AUTOE",N),1,12)=" Report: " D STEP3 Q:$$RPTST="No Report" 127 .I 'RAINCLUD,$E(^TMP($J,"RA AUTOE",N),1,15)=" Impression:" D 128 ..S SKIP=1,^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N+0.1)="" 129 .I 'RAINCLUD,$E(^TMP($J,"RA AUTOE",N),1,28)=" Primary Diagnostic Code:" D 130 ..S SKIP=1 S ^TMP($J,"RA AUTOE",N)=$E(^TMP($J,"RA AUTOE",N),1,28) 131 .I 'RAINCLUD,$E(^TMP($J,"RA AUTOE",N),1,31)=" Secondary Diagnostic Codes:" D 132 ..S SKIP=1,^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N+0.1)="" 133 .I $E(^TMP($J,"RA AUTOE",N),1,27)="Primary Interpreting Staff:" K SKIP 134 .I $D(SKIP) S SKIP=SKIP+1 135 .I $G(SKIP)<3 S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N)=^TMP($J,"RA AUTOE",N) 136 .Q 137 ; 138 XIT K ^TMP($J,"RA AUTOE") 139 Q 140 ; 141 STEP3 S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N-0.4)=" Report Status: "_$$RPTST 142 I $$RPTST="No Report" S N="^" Q 143 S $P(RASPACE," ",46)="" 144 S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N-0.4)=^(N-0.4)_$E(RASPACE,1,46-$L(^(N-0.4)))_"Date Reported: "_RARDE 145 I RARPTST="V" D 146 . S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N-0.3)=RASPACE_" Date Verified: "_$P($$GET1^DIQ(74,+$P(RAEXAM(0),"^",17),7),"@") 147 . S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N-0.2)=" Verifier E-Sig:"_RASIGVES 148 . Q 149 S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N-0.1)="" 150 S ^TMP($J,"RA AUTOE",N)=" Report:" 151 I 'RAINCLUD S SKIP=1,^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,N+0.1)="" 152 Q 153 ; 154 STEP4 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",RACIEN,"H",0)) D 155 .N RAI,RAIN,Z S (RAI,Z)=0,RAIN=N_".000" 156 .F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",RACIEN,"H",Z)) Q:Z'>0 D 157 ..S RAI=RAI+1 158 ..S RAIN=$E(RAIN,1,$L(RAIN)-$L(RAI))_RAI 159 ..S ^TMP($J,"RAE3",RADFN,RACIEN,RAPROC,RAIN)=" "_$G(^RADPT(RADFN,"DT",RAINVXDT,"P",RACIEN,"H",Z,0)) 160 Q 161 ; 162 RPTST() ; Return Full Report Status 163 Q $S(RARPTST="V":"Verified",RARPTST="R":"Released/Not Verified",RARPTST="D":"Draft",RARPTST="PD":"Problem Draft",1:"No Report") 164 ; -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RO1.m
r613 r623 1 RAO7RO1 ;HISC/FPT-RAD/NM Error Messages ;8/28/97 14:16 2 ;;5.0;Radiology/Nuclear Medicine;**2,75,86**;Mar 16, 1998;Build 7 3 ; 4 EN1(RAERR) ; errors encountered with OE v3.0 back & frontdoor transmission 5 S RAEMSG=$P($T(MSG+RAERR),";",4) 6 I RAEMSG]"" Q RAEMSG 7 Q "Error # "_RAERR_" does not exist" 8 ; 9 ;Note: Error code nine (9) disappears with the release of CPRS GUI V27. P86 10 ; 11 MSG ; error messages 12 ;;1;Missing/Invalid Order Control 13 ;;2;Missing/Invalid Patient ID 14 ;;3;Missing/Invalid Patient Location 15 ;;4;Missing/Invalid User DUZ 16 ;;5;Missing/Invalid REQUEST URGENCY 17 ;;6;Missing/Invalid REQUESTING PHYSICIAN 18 ;;7;Entered Date/Time is in the Future 19 ;;8;Invalid Procedure, Inactive, no Imaging Type or no Procedure Type 20 ;;9;Patient Class disagrees with Patient Location 21 ;;10;Invalid ISOLATION PROCEDURES 22 ;;11;Invalid MODIFIER(s) 23 ;;12;Missing/Invalid IMAGING LOCATION or not the same as procedure's 24 ;;13;Missing/Invalid MODE OF TRANSPORT 25 ;;14;Missing/Invalid PREGNANT value 26 ;;15;Missing/Invalid CLINICAL HISTORY FOR EXAM 27 ;;16;Missing/Invalid Placer Number 28 ;;17;Missing/Invalid OBX Value Type 29 ;;18;Missing/Invalid CONTRACT/SHARING SOURCE 30 ;;19;Missing/Invalid RESEARCH SOURCE 31 ;;20;Missing/Invalid PRE-OP SCHEDULED DATE/TIME 32 ;;21;Error Filing New Entry 33 ;;22;Missing/Invalid Filler Number 34 ;;23;Missing/Invalid Cancel or Hold Reason 35 ;;24; 36 ;;25;Current status will not permit request to be put in DISCONTINUED status 37 ;;26;Error filing Placer Number 38 ;;27;Missing/Invalid CATEGORY OF EXAM 39 ;;28;Invalid REQUEST DATE (TIME optional) 40 ;;29;CATEGORY OF EXAM cannot be Research AND Contract/Sharing 41 ;;30;Error Filing New Entry in Request Status Times multiple 42 ;;31;Imaging Type mismatch between the Procedure and Imaging Location 43 ;;32;Parent procedure does not have descendents 44 ;;33;Imaging Type mismatch between the Procedure and MODIFIER(s) 45 ;;34;Invalid MODFIERS(s) for a series procedure 46 ;;35;FileMan rejected date/time 47 ;;36;Invalid Approving Rad/Nuc Med physician 48 ;;37;Rad/Nuc Med order not placed in a DISCONTINUED status 49 ;;38;Missing REASON FOR STUDY value 50 ;;39;Invalid REASON FOR STUDY value 1 RAO7RO1 ;HISC/FPT-RAD/NM Error Messages ;8/28/97 14:16 2 ;;5.0;Radiology/Nuclear Medicine;**2,75**;Mar 16, 1998;Build 4 3 ; 4 EN1(RAERR) ; errors encountered with OE v3.0 back & frontdoor transmission 5 S RAEMSG=$P($T(MSG+RAERR),";",4) 6 I RAEMSG]"" Q RAEMSG 7 Q "Error # "_RAERR_" does not exist" 8 ; 9 MSG ; error messages 10 ;;1;Missing/Invalid Order Control 11 ;;2;Missing/Invalid Patient ID 12 ;;3;Missing/Invalid Patient Location 13 ;;4;Missing/Invalid User DUZ 14 ;;5;Missing/Invalid REQUEST URGENCY 15 ;;6;Missing/Invalid REQUESTING PHYSICIAN 16 ;;7;Entered Date/Time is in the Future 17 ;;8;Invalid Procedure, Inactive, no Imaging Type or no Procedure Type 18 ;;9;Patient Class disagrees with Patient Location 19 ;;10;Invalid ISOLATION PROCEDURES 20 ;;11;Invalid MODIFIER(s) 21 ;;12;Missing/Invalid IMAGING LOCATION or not the same as procedure's 22 ;;13;Missing/Invalid MODE OF TRANSPORT 23 ;;14;Missing/Invalid PREGNANT value 24 ;;15;Missing/Invalid CLINICAL HISTORY FOR EXAM 25 ;;16;Missing/Invalid Placer Number 26 ;;17;Missing/Invalid OBX Value Type 27 ;;18;Missing/Invalid CONTRACT/SHARING SOURCE 28 ;;19;Missing/Invalid RESEARCH SOURCE 29 ;;20;Missing/Invalid PRE-OP SCHEDULED DATE/TIME 30 ;;21;Error Filing New Entry 31 ;;22;Missing/Invalid Filler Number 32 ;;23;Missing/Invalid Cancel or Hold Reason 33 ;;24; 34 ;;25;Current status will not permit request to be put in DISCONTINUED status 35 ;;26;Error filing Placer Number 36 ;;27;Missing/Invalid CATEGORY OF EXAM 37 ;;28;Invalid REQUEST DATE (TIME optional) 38 ;;29;CATEGORY OF EXAM cannot be Research AND Contract/Sharing 39 ;;30;Error Filing New Entry in Request Status Times multiple 40 ;;31;Imaging Type mismatch between the Procedure and Imaging Location 41 ;;32;Parent procedure does not have descendents 42 ;;33;Imaging Type mismatch between the Procedure and MODIFIER(s) 43 ;;34;Invalid MODFIERS(s) for a series procedure 44 ;;35;FileMan rejected date/time 45 ;;36;Invalid Approving Rad/Nuc Med physician 46 ;;37;Rad/Nuc Med order not placed in a DISCONTINUED status 47 ;;38;Missing REASON FOR STUDY value 48 ;;39;Invalid REASON FOR STUDY value -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RON.m
r613 r623 1 RAO7RON ;HISC/GJC- Request message from OE/RR. (frontdoor) ;2/2/98 12:34 2 ;;5.0;Radiology/Nuclear Medicine;**41,75,86**;Mar 16, 1998;Build 7 3 ; 4 ;Supported IA #10040 reference to ^SC 5 ;Supported IA #2187 reference to EN^ORERR 6 ;Supported IA #10103 reference to ^XLFDT 7 ;Supported IA #10141 reference to ^XPDUTL 8 ;Supported IA #10106 reference to $$FMDATE^HLFNC 9 ; 10 ;------------------------- Variable List ------------------------------- 11 ; RADATA=HL7 data minus seg. hdr RAHDR=Segment header 12 ; RAHLFS="|" RAMSG=HL7 message passed in 13 ; RAOBR12=danger code RAOBR18=modifier 14 ; RAOBR19=hosp. loc. pntr (44) RAOBR30=trans. mode 15 ; RAOBR4=univ. trans. mode RAOBX2=format of observ. value 16 ; RAOBX3=observ. ID RAOBX5=observ. value 17 ; RAORC1=order control RAORC10=entered by (200) 18 ; RAORC11=approving rad/nm phys (for some procedures only) 19 ; RAORC12=ordering provider (200) RAORC15=order effective D/T 20 ; RAORC16=order control reason RAORC2=placer order #_"^OR" 21 ; RAORC3=filler order #_"^RA" RAORC7=start dt/freq. of service 22 ; RAPID3=patient ID RAPID5=patient name (2) 23 ; RAPV119=visit # RAPV12=patient class 24 ; RAPV13=patient location (44) RASEG=message seg. including header 25 ; ---------------------------------------------------------------------- 26 EN1(RAMSG) ; Pass in the message from RAO7RO. Decipher information. 27 D BRKOUT^RAO7UTL1 28 ; defines RAORC2, RAORC3, RAPID3, RAPID5, RAMSH3 & RADIV(.119) 29 S (RAERR,RAWP,RALINEX)=0,RACLIN="^" K ^TMP("RAWP",$J) 30 F S RALINEX=$O(RAMSG(RALINEX)) Q:RALINEX'>0 D Q:RAERR 31 . S RASEG=$G(RAMSG(RALINEX)) Q:$P(RASEG,RAHLFS)="MSH" ; quit if MSH segment 32 . S RAHDR=$P(RASEG,RAHLFS),RADATA=$P(RASEG,RAHLFS,2,999) 33 . D @$S(RAHDR="PID":"PID",RAHDR="PV1":"PV1",RAHDR="ORC":"ORC",RAHDR="OBR":"OBR^RAO7RON1",RAHDR="OBX":"OBX^RAO7RON1",RAHDR="DG1":"GETCPRS^RABWORD1",RAHDR="ZCL":"GETCPRS^RABWORD1",1:"ERR") 34 . Q 35 S RANEW(75.1,"+1,",18)=RALDT 36 Q 37 PID ; breakdown the 'PID' segment 38 S RAERR=$$EN2^RAO7VLD(2,RAPID3,RAPID5) S:RAERR RAERR=2 39 I 'RAERR S RANEW(75.1,"+1,",.01)=RAPID3 40 Q 41 PV1 ; breakdown the 'PV1' segment 42 S RAPV12=$P(RADATA,RAHLFS,2) 43 S RAERR=$$EN1^RAO7VLD(75.1,4,"E",RAPV12,"RASULT","") S:RAERR RAERR=27 Q:RAERR 44 S RANEW(75.1,"+1,",4)=RAPV12 45 S RAPV13=$P(RADATA,RAHLFS,3) 46 S RAERR=$$EN3^RAO7VLD(44,+RAPV13) S:RAERR RAERR=3 Q:RAERR 47 S RANEW(75.1,"+1,",22)=+RAPV13 48 ;check the GUI version of CPRS at this facility: 49 ;$$PATCH^XPDUTL("OR*3.0*243")=1 CPRS V27, else CPRS V26. 50 I '$$PATCH^XPDUTL("OR*3.0*243") D Q:RAERR ;P86 51 .I RAPV12="I",$P(^SC($P(RAPV13,U,1),0),U,3)'="W" S RAERR=9 Q 52 .I RAPV12="O",$P(^SC($P(RAPV13,U,1),0),U,3)="W" S RAERR=9 53 .Q 54 S RAPV119=$P(RADATA,RAHLFS,19) 55 Q 56 ORC ; breakdown the 'ORC' segment 57 ; RAORC7D is: timestamp HL7 format 58 ; RAORC7P is: priority/urgency 59 S:+RAORC2'>0 RAERR=16 Q:RAERR 60 S RANEW(75.1,"+1,",7)=+RAORC2 61 S RANEW(75.1,"+1,",5)=5 62 S RAORC7=$P(RADATA,RAHLFS,7) 63 S RAORC7D=$P(RAORC7,RAECH(1),4) 64 S RAORC7D=$$FMDATE^HLFNC(RAORC7D) 65 S RAERR=$$EN1^RAO7VLD(75.1,21,"E",RAORC7D,"RASULT","") S:RAERR RAERR=28 Q:RAERR 66 S RANEW(75.1,"+1,",21)=RAORC7D 67 S X=$P(RAORC7,RAECH(1),6) 68 S RAORC7P=$S(X="S":1,X="A":2,X="R":9,1:"") I +RAORC7P'>0 S RAERR=5 Q 69 S RANEW(75.1,"+1,",6)=RAORC7P 70 S RAORC10=$P(RADATA,RAHLFS,10) 71 S RAERR=$$EN3^RAO7VLD(200,RAORC10) S:RAERR RAERR=4 Q:RAERR 72 S RANEW(75.1,"+1,",15)=RAORC10 73 S RAORC11=$P(RADATA,RAHLFS,11) ;approving rad/nm phys for some proc's 74 I $G(RAORC11) S RAERR=$$EN3^RAO7VLD(200,RAORC11) S:RAERR RAERR=36 Q:RAERR 75 I $G(RAORC11) S RANEW(75.1,"+1,",8)=RAORC11 76 S RAORC12=$P(RADATA,RAHLFS,12) 77 S RAERR=$$EN3^RAO7VLD(200,RAORC12) S:RAERR RAERR=6 Q:RAERR 78 S RANEW(75.1,"+1,",14)=RAORC12 79 S RAORC15=$P(RADATA,RAHLFS,15) 80 S RAORC15=$$FMDATE^HLFNC(RAORC15) 81 ;The order entered dt/time validity ck results are ignored because we 82 ;have never been able to determine why FileMan erroneously rejects 83 ;some date/times in a Silent FM call. We now assume this date is OK. 84 S RAERR=$$EN1^RAO7VLD(75.1,16,"E",RAORC15,"RASULT","") S:RAERR RAERR=35 85 ;Q:RAERR 86 I RAERR D S RAERR=0 87 . N I,RAX,RAVARS,RAERRDT 88 . S RAX=$G(^TMP("DIERR",$J,1,"TEXT",1)) 89 . S RAERRDT=$$NOW^XLFDT() 90 . F I="RAX","RAORC15","RAERRDT","RAERR" S RAVARS(I)="" 91 . S:$D(X) RAVARS("X")="" S:$D(%DT) RAVARS("%DT")="" 92 . S:$D(%DT(0)) RAVARS("%DT(0)")="" 93 . ;S RAVARS("RAX")="",RAVARS("RAORC15")="",RAVARS("RAERRDT")="",RAVARS("RAERR")="" 94 . D EN^ORERR("RAD MYSTERY ERROR",.RAMSG,.RAVARS) 95 . Q 96 S RANOW=$$NOW^XLFDT() I RANOW<RAORC15 S RAERR=7 Q 97 S RANEW(75.1,"+1,",16)=RAORC15 98 Q 99 ERR ; error control - file 'soft' errors with CPRS 100 N RAVAR S RAVAR("XQY0")="" 101 D ERR^RAO7UTL("HL7 message with unknown segment header",.RAMSG,.RAVAR) 102 Q 1 RAO7RON ;HISC/GJC- Request message from OE/RR. (frontdoor) ;2/2/98 12:34 2 ;;5.0;Radiology/Nuclear Medicine;**41,75**;Mar 16, 1998;Build 4 3 ; 4 ;------------------------- Variable List ------------------------------- 5 ; RADATA=HL7 data minus seg. hdr RAHDR=Segment header 6 ; RAHLFS="|" RAMSG=HL7 message passed in 7 ; RAOBR12=danger code RAOBR18=modifier 8 ; RAOBR19=hosp. loc. pntr (44) RAOBR30=trans. mode 9 ; RAOBR4=univ. trans. mode RAOBX2=format of observ. value 10 ; RAOBX3=observ. ID RAOBX5=observ. value 11 ; RAORC1=order control RAORC10=entered by (200) 12 ; RAORC11=approving rad/nm phys (for some procedures only) 13 ; RAORC12=ordering provider (200) RAORC15=order effective D/T 14 ; RAORC16=order control reason RAORC2=placer order #_"^OR" 15 ; RAORC3=filler order #_"^RA" RAORC7=start dt/freq. of service 16 ; RAPID3=patient ID RAPID5=patient name (2) 17 ; RAPV119=visit # RAPV12=patient class 18 ; RAPV13=patient location (44) RASEG=message seg. including header 19 ; ---------------------------------------------------------------------- 20 EN1(RAMSG) ; Pass in the message from RAO7RO. Decipher information. 21 D BRKOUT^RAO7UTL1 22 ; defines RAORC2, RAORC3, RAPID3, RAPID5, RAMSH3 & RADIV(.119) 23 S (RAERR,RAWP,RALINEX)=0,RACLIN="^" K ^TMP("RAWP",$J) 24 F S RALINEX=$O(RAMSG(RALINEX)) Q:RALINEX'>0 D Q:RAERR 25 . S RASEG=$G(RAMSG(RALINEX)) Q:$P(RASEG,RAHLFS)="MSH" ; quit if MSH segment 26 . S RAHDR=$P(RASEG,RAHLFS),RADATA=$P(RASEG,RAHLFS,2,999) 27 . D @$S(RAHDR="PID":"PID",RAHDR="PV1":"PV1",RAHDR="ORC":"ORC",RAHDR="OBR":"OBR^RAO7RON1",RAHDR="OBX":"OBX^RAO7RON1",RAHDR="DG1":"GETCPRS^RABWORD1",RAHDR="ZCL":"GETCPRS^RABWORD1",1:"ERR") 28 . Q 29 S RANEW(75.1,"+1,",18)=RALDT 30 Q 31 PID ; breakdown the 'PID' segment 32 S RAERR=$$EN2^RAO7VLD(2,RAPID3,RAPID5) S:RAERR RAERR=2 33 I 'RAERR S RANEW(75.1,"+1,",.01)=RAPID3 34 Q 35 PV1 ; breakdown the 'PV1' segment 36 S RAPV12=$P(RADATA,RAHLFS,2) 37 S RAERR=$$EN1^RAO7VLD(75.1,4,"E",RAPV12,"RASULT","") S:RAERR RAERR=27 Q:RAERR 38 S RANEW(75.1,"+1,",4)=RAPV12 39 S RAPV13=$P(RADATA,RAHLFS,3) 40 S RAERR=$$EN3^RAO7VLD(44,+RAPV13) S:RAERR RAERR=3 Q:RAERR 41 S RANEW(75.1,"+1,",22)=+RAPV13 42 I RAPV12="I",$P(^SC($P(RAPV13,U,1),0),U,3)'="W" S RAERR=9 Q:RAERR 43 I RAPV12="O",$P(^SC($P(RAPV13,U,1),0),U,3)="W" S RAERR=9 Q:RAERR 44 S RAPV119=$P(RADATA,RAHLFS,19) 45 Q 46 ORC ; breakdown the 'ORC' segment 47 ; RAORC7D is: timestamp HL7 format 48 ; RAORC7P is: priority/urgency 49 S:+RAORC2'>0 RAERR=16 Q:RAERR 50 S RANEW(75.1,"+1,",7)=+RAORC2 51 S RANEW(75.1,"+1,",5)=5 52 S RAORC7=$P(RADATA,RAHLFS,7) 53 S RAORC7D=$P(RAORC7,RAECH(1),4) 54 S RAORC7D=$$FMDATE^HLFNC(RAORC7D) 55 S RAERR=$$EN1^RAO7VLD(75.1,21,"E",RAORC7D,"RASULT","") S:RAERR RAERR=28 Q:RAERR 56 S RANEW(75.1,"+1,",21)=RAORC7D 57 S X=$P(RAORC7,RAECH(1),6) 58 S RAORC7P=$S(X="S":1,X="A":2,X="R":9,1:"") I +RAORC7P'>0 S RAERR=5 Q 59 S RANEW(75.1,"+1,",6)=RAORC7P 60 S RAORC10=$P(RADATA,RAHLFS,10) 61 S RAERR=$$EN3^RAO7VLD(200,RAORC10) S:RAERR RAERR=4 Q:RAERR 62 S RANEW(75.1,"+1,",15)=RAORC10 63 S RAORC11=$P(RADATA,RAHLFS,11) ;approving rad/nm phys for some proc's 64 I $G(RAORC11) S RAERR=$$EN3^RAO7VLD(200,RAORC11) S:RAERR RAERR=36 Q:RAERR 65 I $G(RAORC11) S RANEW(75.1,"+1,",8)=RAORC11 66 S RAORC12=$P(RADATA,RAHLFS,12) 67 S RAERR=$$EN3^RAO7VLD(200,RAORC12) S:RAERR RAERR=6 Q:RAERR 68 S RANEW(75.1,"+1,",14)=RAORC12 69 S RAORC15=$P(RADATA,RAHLFS,15) 70 S RAORC15=$$FMDATE^HLFNC(RAORC15) 71 ;The order entered dt/time validity ck results are ignored because we 72 ;have never been able to determine why FileMan erroneously rejects 73 ;some date/times in a Silent FM call. We now assume this date is OK. 74 S RAERR=$$EN1^RAO7VLD(75.1,16,"E",RAORC15,"RASULT","") S:RAERR RAERR=35 75 ;Q:RAERR 76 I RAERR D S RAERR=0 77 . N I,RAX,RAVARS,RAERRDT 78 . S RAX=$G(^TMP("DIERR",$J,1,"TEXT",1)) 79 . S RAERRDT=$$NOW^XLFDT() 80 . F I="RAX","RAORC15","RAERRDT","RAERR" S RAVARS(I)="" 81 . S:$D(X) RAVARS("X")="" S:$D(%DT) RAVARS("%DT")="" 82 . S:$D(%DT(0)) RAVARS("%DT(0)")="" 83 . ;S RAVARS("RAX")="",RAVARS("RAORC15")="",RAVARS("RAERRDT")="",RAVARS("RAERR")="" 84 . D EN^ORERR("RAD MYSTERY ERROR",.RAMSG,.RAVARS) 85 . Q 86 S RANOW=$$NOW^XLFDT() I RANOW<RAORC15 S RAERR=7 Q 87 S RANEW(75.1,"+1,",16)=RAORC15 88 Q 89 ERR ; error control - file 'soft' errors with CPRS 90 N RAVAR S RAVAR("XQY0")="" 91 D ERR^RAO7UTL("HL7 message with unknown segment header",.RAMSG,.RAVAR) 92 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1.m
r613 r623 1 RAORD1 ;HISC/CAH - AISC/RMO-Request An Exam ; 06/27/07 07:22am 2 ;;5.0;Radiology/Nuclear Medicine;**10,45,41,75,86**;Mar 16, 1998;Build 7 3 ; 4 ;Supported IA #10035 reference to ^DPT( 5 ;Supported IA #10040 reference to ^SC( 6 ;Supported IA #10060 reference to ^VA(200 7 ;Supported IA #2055 reference to $$EXTERNAL^DILFD 8 ;Supported IA #2378 reference to ORCHK^GMRAOR 9 ;Supported IA #10061 reference to ^VADPT 10 ;Supported IA #10112 reference to ^VASITE 11 ;Supported IA #10103 reference to ^XLFDT 12 ;Supported IA #10141 reference to ^XPDUTL 13 ;Supported IA #10009 reference to FILE^DICN 14 ;Supported IA #10018 reference to ^DIE 15 ; 16 ;*Billing Awareness Project: 17 ; RABWDX Array: ICD Diagnosis^SC^AO^IR^EC^MST^HNC 18 ; RABWDX is used in RABWORD* and RABWPCE*. 19 K RABWDX 20 ;* 21 S RAPKG="" N RAPTLKUP,RAGMTS,RACOPYOR 22 G ADDORD:$D(RAVSTFLG)&($D(RALIFN))&($D(RAPIFN)) 23 ; 24 I '$D(RAREGFLG),'$D(RAVSTFLG) N RAPTLOCK K RAWARD D G:'RAPTLKUP Q 25 PAT .S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC 26 .I Y<0 S RAPTLKUP=0 Q 27 .S RAPTLOCK=$$LK^RAUTL19(+Y_";DPT(") G:'RAPTLOCK PAT 28 .S (DFN,RADFN)=+Y,(VA200,RAPTLKUP)=1 29 .W ! D IN5^VADPT S:VAIP(1) RAWARD=$P(VAIP(5),"^",2) 30 .D ELIG^RABWORD2 31 .Q 32 ; 33 PL ;Ask for the patient location (REQ. LOCATION file: 75.1, field: #22) 34 N RACPRS27 S RACPRS27=$$PATCH^XPDUTL("OR*3.0*243") 35 S DIC("A")="Patient Location: ",DIC("B")=$S($D(RAWARD)#2:RAWARD,1:"") 36 S DIC="^SC(",DIC(0)="AEMQ" 37 ; 38 ;With the installation of RA*5.0*86 and after the implementation of 39 ;CPRS v27 all active locations are eligible for selection regardless 40 ;of patient type. 41 ; 42 ;If RAWARD is defined it is set to the name of the ward; pass either a 0 43 ;or 1. 44 ;Pass either a 0 or 1 as a value for RACPRS27. If 1 then CPRS GUI v27 45 ;(OR*3.0*243) is installed at this facility. 46 S DIC("S")="I $$SCREEN^RAORD1A("_($D(RAWARD)#2)_","_(RACPRS27)_")" 47 ; 48 D ^DIC K DIC K:'$D(RAREGFLG) RAWARD G Q:Y<0 S RALIFN=+Y 49 S DIC("A")="Person Requesting Order: " 50 ;*Billing Awareness Project: 51 S DIC("S")="I $$PROV^RABWORD()" 52 ;Display Service Connected prompts if user is a Provider. 53 S DIC="^VA(200,",DIC(0)="AEMQ",Y=DUZ S:$$PROV^RABWORD DIC("B")=$P(^VA(200,DUZ,0),"^",1) 54 D ^DIC K DIC G Q:Y<0 S RAPIFN=+Y K DD,DO,VA200,VAERR,VAIP G ADDORD:$D(RAVSTFLG) 55 ; 56 ENADD ;OE/RR Entry Point for the ACTION Option 57 K ORSTOP,ORTO,ORCOST,ORPURG 58 I '$D(RAPKG) G Q:'$D(ORVP)!('$D(ORL))!('$D(ORNP)) S (DFN,RADFN)=+ORVP,RALIFN=+ORL,RAPIFN=$S(+ORNP:+ORNP,$D(RAPIFN):RAPIFN,1:+ORNP),RAFOERR="" 59 ; RAFOERR is used as a flag to track when a user enters this option 60 ; from OE/RR (frontdoor). If this variable exists when a request is 61 ; being printed, exam information is omitted from the request. 62 S RANME=^DPT(RADFN,0),RASEX=$P(RANME,"^",2),RANME=$P(RANME,"^") D EXAM^RADEM1:'$D(RAREGFLG)&($D(RAPKG)) I '$D(RAREGFLG) S VA200=1 D IN5^VADPT S:VAIP(1) RAWARD=$P(VAIP(5),"^",2) 63 D SAVE ; save off original value of RAMDV! 64 S RAL0=$S($D(^SC(RALIFN,0)):^(0),1:0) 65 S RADIV=+$$SITE^VASITE(DT,+$P(RAL0,"^",15)) S:RADIV<0 RADIV=0 66 S RADIV=$S($D(^RA(79,RADIV,0)):RADIV,1:$O(^RA(79,0))) 67 S RAMDV=$TR($G(^RA(79,+RADIV,.1)),"YyNn","1100") 68 D:'$D(RACAT)#2 ;if not defined, define the variable RACAT 69 .I $D(RAWARD)#2 S RACAT="INPATIENT" Q 70 .N Y S Y=$G(^RADPT(RADFN,0)) I Y="" S RACAT="OUTPATIENT" Q 71 .S RACAT=$$EXTERNAL^DILFD(70,.04,"",$P(Y,U,4)) 72 .S:RACAT="" RACAT="OUTPATIENT" 73 .Q 74 ; clear clin hist if: 75 ; rad backdoor, or 76 ; oe/rr's first order (quick or not) 77 I $D(RAPKG) K ^TMP($J,"RAWP") 78 I '$D(RAPKG),$G(XQORS)>1,$G(^TMP("XQORS",$J,XQORS-1,"ITM"))=1 K ^TMP($J,"RAWP") 79 ; 80 ADDORD I $D(RADR1) D ALLERGY,CREATE1 G Q 81 ; Set flag variable 'RASTOP' to track if procedure messages (if any) 82 ; have been displayed. Value altered in EN2+1^RAPRI & DISP+12^RAORDU1. 83 D:'$D(VAEL) ELIG^VADPT 84 I $D(^RAO(75.1,"B",RADFN)) D 85 .I '$D(RAVSTFLG) D PREV^RABWORD2 Q 86 .D ADDEXAM^RABWORD2 87 D DISP^RAPRI G:RAIMGTYI'>0 Q 88 ADDORD1 W !,"Select Procedure",$S(RACNT:" (1-"_RACNT_") ",1:" "),"or enter '?' for help: " 89 R RARX:DTIME 90 S:'$T RARX="^" G Q:RARX=""!($E(RARX)="^") 91 S:RARX=" " RARX=$S($D(RASX):RASX,1:RARX) 92 I $E(RARX)="?"!(RARX=0)!(RARX=" ")!(RARX?.E1N1"-"1N.E)!(RARX?.E1".".E) D HELP^RAPRI G Q:Y'=1 D DISP1^RAPRI G ADDORD1 93 S RAEXMUL=1 K RAHSMULT 94 F RAJ=1:1 S X=$P(RARX,",",RAJ) Q:X="" S RASTOP=0 W !!!,"Processing procedure: ",$S(+X&(+X'>RACNT):$P($G(RAPRC(X)),"^"),$E(X)'="`":X,1:"") D LOOKUP^RAPRI Q:$D(RAOUT) S:RAPRI>0 RASX="`"_RAPRI D:RAPRI>0 ALLERGY,CREATE Q:$D(RAOUT) K RAPRI 95 I $D(RAREASK),'$D(RAOUT) K RAREASK D DISP1^RAPRI G ADDORD1 96 Q ; Kill, unlock if locked, and quit 97 D KILL^RAORD 98 D SAVE ; reset RAMDV to its original value! 99 I $$ORVR^RAORDU()'<3,(+$G(RAPTLOCK)),(+$G(RADFN)) D 100 . D ULK^RAUTL19(RADFN_";DPT(") 101 K:'$D(RAREGFLG)&('$D(RAVSTFLG)) RACAT,RADFN,RANME,RAWARD 102 I '$D(RAPKG) K RAMDIV,RAMDV,RAMLC 103 I $D(RAPKG) K ORIFN,ORIT,ORL,ORNP,ORNS,ORPCL,ORPK,ORPV,ORPURG,ORSTS,ORTX,ORVP,RAPKG 104 K RAHSMULT,RAPOP,RAIMAG,RAREAST,RAREQLOC 105 K C,DI,DIG,DIH,DISYS,DIU,DIW,DIWF,DIWL,DIWR,DIWT,DN,I,ORCHART,POP,RAMDVZZ,RASCI,RASERIES 106 Q 107 CREATE S RACT=0 D MODS Q:$D(RAOUT) 108 CREATE1 ;ask for the 'Date Desired' req'd P75 109 S RAWHEN=$$DESDT^RAUTL12(RAPRI) S:RAWHEN=-1 RAOUT=1 Q:$D(RAOUT)#2 110 S RAWHEN=$$FMTE^XLFDT(RAWHEN,1) ;convert to external format 111 ; Ask pregnant if age is between 12 & 55. Ask once for mult requests 112 ; RASKPREG is the variable used to track if the pregnant prompt has 113 ; been asked. Ask only once for multiple requests. 114 S:'$D(RASKPREG) RAPREG=$$PREG^RAORD1A(RADFN,$G(DT)),RASKPREG="" Q:$D(RAOUT) 115 ;Reason for Study (req'd) & Clinical History (optional) asked in CH^RAUTL5 P75 116 D CH^RAUTL5 Q:$D(RAOUT) ;RAOUT: defined if Reason for Study is nonexistent 117 BAQUES ;*Billing Awareness Project 118 ; Ask Ordering ICD-9 Diagnosis and Related SC/EI/MST/HNC questions. 119 N RADTM D NOW^%DTC S RADTM=% 120 D ASK^RABWORD(RADFN,RADTM) 121 I '$D(RADR1) D DISP^RAORDU1 Q:$D(RAOUT) ; Display Order Responses. 122 S X=RADFN,DIC="^RAO(75.1,",DIC(0)="L",DLAYGO=75.1 123 D FILE^DICN K DIC Q:Y<0 S RAOIFN=+Y K DLAYGO 124 I $D(RAREGFLG)!($D(RAVSTFLG)) S RANUM=$S('$D(RANUM):1,1:RANUM+1),RAORDS(RANUM)=RAOIFN 125 I $D(^RA(79,+RADIV,.1)),$P(^(.1),"^",21)="y" S RALOCFLG="" 126 W ! S DA=RAOIFN,DIE="^RAO(75.1,",DIE("NO^")="OUTOK" 127 S DR=$S($D(RADR1):"[RA QUICK EXAM ORDER]",$D(RADR2):"[RA ORDER EXAM]",$D(RAEXMUL)&($D(RAFIN1)):"[RA QUICK EXAM ORDER]",1:"[RA ORDER EXAM]") 128 ;*Billing Awareness Project 129 ; If Order questions are being Re-Asked then Re-Ask ICD-9 Dx questions 130 I DR="[RA ORDER EXAM]" D ASK^RABWORD(RADFN,RADTM) W !! 131 D ^DIE 132 K DIE("NO^"),DE,DQ,DIE,DR,RADR1,RADR2 133 I $D(RAFIN),$D(^RAO(75.1,RAOIFN,0)) S RAORD0=^(0) D FILEDX^RABWORD(RADFN,RAOIFN) Q:'$D(RAFIN) D SETORD^RAORDU D OERR^RAORDU:'$D(RAPKG) D ^RAORDQ:$D(RAPKG) K RAORD0 134 I '$D(RAFIN) W !?3,$C(7),"Request not complete. Must Delete..." S DA=RAOIFN,DIK="^RAO(75.1," D ^DIK W "...deletion complete!" I $D(RAREGFLG)!($D(RAVSTFLG)) K RAORDS(RANUM) 135 I '$D(RAFIN),('$D(^RAO(75.1,RAOIFN,0))#2) Q ; record deleted! 136 K RAFIN 137 ; check if the 'stat' or 'urgent' alert is to be sent. 138 N RALOC,RAORD0 139 S RAORD0=$G(^RAO(75.1,RAOIFN,0)),RALOC=+$P(RAORD0,"^",20) 140 Q:'RALOC ; if no 'SUBMIT TO' location, can't send stat/urgent alerts 141 I $P(RAORD0,"^",6)=1!(($P(RAORD0,"^",6)=2)&($P(^RA(79.1,RALOC,0),"^",20)="Y")) D 142 .; If 6th piece of RAORD0=1 *stat*, =2 *urgent* 143 .Q:$$ORVR^RAORDU()<3 144 .; needs OE/RR 3.0 or greater for stat/urgent alerts to fire 145 .D OENO^RAUTL19(RAOIFN) 146 .Q 147 Q 148 ; 149 MODS ;RAPRI= Procedure IEN, RAIMAG=Imaging Type for the procedure. 150 ;Edited 4/19/94, Type of Imaging is now a multiple in file 71.2. CEW 151 S RAIMAG=+$$ITYPE^RASITE(RAPRI),DIC(0)="AEQMZ",DIC="^RAMIS(71.2,",DIC("A")="Select "_$P($G(^DIC(71.2,0)),"^")_": " 152 S DIC("S")="I +$D(^RAMIS(71.2,""AB"",RAIMAG,+Y)),$S('$G(RASERIES):1,$P(^RAMIS(71.2,+Y,0),U,2)="""":1,1:0),$$INIMOD^RAORD1A($P($G(^RAMIS(71.2,+Y,0)),""^""))" 153 D ^DIC K DIC,RAIMAG S:$D(DTOUT)!($D(DUOUT)) RAOUT=1 Q:$D(RAOUT)!(X="^")!(X="") I Y<1 W $C(7)," ??" G MODS 154 S RACT=RACT+1,RAMOD(RACT)=$P(Y,"^",2) G MODS 155 Q 156 ; 157 ALLERGY ; If patient has had a previous contrast media allergic reaction 158 ; check procedure RAPRI for specific contrast media associations 159 ; (new with RA*5*45) 160 Q:'$$ORCHK^GMRAOR(RADFN,"CM") 161 S RAPRI(0)=$G(^RAMIS(71,RAPRI,0)) 162 I $P(RAPRI(0),U,6)'="P" D ;not a parent check lone procedure 163 .D CONTRAST^RAUTL2(RAPRI) 164 .Q 165 E S I=0 D ;check descendent procedures for CM 166 .F S I=$O(^RAMIS(71,RAPRI,4,I)) Q:'I D CONTRAST^RAUTL2(+$G(^(I,0))) 167 .K I 168 .Q 169 K RAPRI(0) 170 Q 171 SAVE ; Save original value of RAMDV before it is altered in the ENADD sub- 172 ; routine. This code will also reset RAMDV to the sign-on value. 173 Q:'$D(RAPKG) ; entered through OE/RR (RAMDV will not be set) 174 Q:'$D(RAMDV)&('$D(RAMDVZZ)) ;entered through 'Request an Exam' option used stand-alone outside of Rad/NM pkg 175 I '$D(RAMDVZZ) S RAMDVZZ=RAMDV 176 E S RAMDV=RAMDVZZ 177 Q 1 RAORD1 ;HISC/CAH - AISC/RMO-Request An Exam ; 01/21/05 11:25am 2 ;;5.0;Radiology/Nuclear Medicine;**10,45,41,75**;Mar 16, 1998;Build 4 3 ;*Billing Awareness Project: 4 ; RABWDX Array: ICD Diagnosis^SC^AO^IR^EC^MST^HNC 5 ; RABWDX is used in RABWORD* and RABWPCE*. 6 K RABWDX 7 ;* 8 S RAPKG="" N RAPTLKUP,RAGMTS,RACOPYOR 9 G ADDORD:$D(RAVSTFLG)&($D(RALIFN))&($D(RAPIFN)) 10 I '$D(RAREGFLG),'$D(RAVSTFLG) N RAPTLOCK K RAWARD D G:'RAPTLKUP Q 11 PAT .S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC 12 .I Y<0 S RAPTLKUP=0 Q 13 .I $$ORVR^RAORDU()'<3 D G:'RAPTLOCK PAT 14 ..S RAPTLOCK=$$LK^RAUTL19(+Y_";DPT(") 15 ..Q 16 .S (DFN,RADFN)=+Y,(VA200,RAPTLKUP)=1 17 .W ! D IN5^VADPT S:VAIP(1) RAWARD=$P(VAIP(5),"^",2) 18 .D ELIG^RABWORD2 19 .Q 20 PL S DIC("A")="Patient Location: ",DIC("B")=$S($D(RAWARD):RAWARD,1:""),DIC="^SC(",DIC(0)="AEMQ",DIC("S")="I $$SCREEN^RAORD1A()" 21 D ^DIC K DIC K:'$D(RAREGFLG) RAWARD G Q:Y<0 S RALIFN=+Y 22 S DIC("A")="Person Requesting Order: " 23 ;*Billing Awareness Project: 24 S DIC("S")="I $$PROV^RABWORD()" 25 ;Display Service Connected prompts if user is a Provider. 26 S DIC="^VA(200,",DIC(0)="AEMQ",Y=DUZ S:$$PROV^RABWORD DIC("B")=$P(^VA(200,DUZ,0),"^",1) 27 D ^DIC K DIC G Q:Y<0 S RAPIFN=+Y K DD,DO,VA200,VAERR,VAIP G ADDORD:$D(RAVSTFLG) 28 ; 29 ENADD ;OE/RR Entry Point for the ACTION Option 30 K ORSTOP,ORTO,ORCOST,ORPURG 31 I '$D(RAPKG) G Q:'$D(ORVP)!('$D(ORL))!('$D(ORNP)) S (DFN,RADFN)=+ORVP,RALIFN=+ORL,RAPIFN=$S(+ORNP:+ORNP,$D(RAPIFN):RAPIFN,1:+ORNP),RAFOERR="" 32 ; RAFOERR is used as a flag to track when a user enters this option 33 ; from OE/RR (frontdoor). If this variable exists when a request is 34 ; being printed, exam information is omitted from the request. 35 S RANME=^DPT(RADFN,0),RASEX=$P(RANME,"^",2),RANME=$P(RANME,"^") D EXAM^RADEM1:'$D(RAREGFLG)&($D(RAPKG)) I '$D(RAREGFLG) S VA200=1 D IN5^VADPT S:VAIP(1) RAWARD=$P(VAIP(5),"^",2) 36 D SAVE ; save off original value of RAMDV! 37 S RAL0=$S($D(^SC(RALIFN,0)):^(0),1:0) 38 S RADIV=+$$SITE^VASITE(DT,+$P(RAL0,"^",15)) S:RADIV<0 RADIV=0 39 S RADIV=$S($D(^RA(79,RADIV,0)):RADIV,1:$O(^RA(79,0))) 40 S RAMDV=$TR($G(^RA(79,+RADIV,.1)),"YyNn","1100") 41 S RACAT=$S($D(RACAT):RACAT,$D(RAWARD):"INPATIENT",$P(RAL0,"^",2)="PERSONNEL HEALTH":"EMPLOYEE",'$D(^RADPT(RADFN,0)):"OUTPATIENT",$P(^(0),"^",4)]"":$P($P(^DD(70,.04,0),$P(^RADPT(RADFN,0),"^",4)_":",2),";"),1:"OUTPATIENT") 42 I "IO"[$E(RACAT,1) D 43 .S RASTRNG=$$MATCH^RAORD1A(RACAT,RALIFN) 44 .;if necessary, change category of exam to match type of requesting 45 .;location and display msg to user 46 .S RACAT=$P(RASTRNG,"^"),RAWARD=$P(RASTRNG,"^",2) 47 .Q 48 K:$D(RAWARD)&($E(RACAT,1)="O") RAWARD 49 K RASTRNG 50 ; clear clin hist if: 51 ; rad backdoor, or 52 ; oe/rr's first order (quick or not) 53 I $D(RAPKG) K ^TMP($J,"RAWP") 54 I '$D(RAPKG),$G(XQORS)>1,$G(^TMP("XQORS",$J,XQORS-1,"ITM"))=1 K ^TMP($J,"RAWP") 55 ; 56 ADDORD I $D(RADR1) D ALLERGY,CREATE1 G Q 57 ; Set flag variable 'RASTOP' to track if procedure messages (if any) 58 ; have been displayed. Value altered in EN2+1^RAPRI & DISP+12^RAORDU1. 59 D:'$D(VAEL) ELIG^VADPT 60 I $D(^RAO(75.1,"B",RADFN)) D 61 .I '$D(RAVSTFLG) D PREV^RABWORD2 Q 62 .D ADDEXAM^RABWORD2 63 D DISP^RAPRI G:RAIMGTYI'>0 Q 64 ADDORD1 W !,"Select Procedure",$S(RACNT:" (1-"_RACNT_") ",1:" "),"or enter '?' for help: " 65 R RARX:DTIME 66 S:'$T RARX="^" G Q:RARX=""!($E(RARX)="^") 67 S:RARX=" " RARX=$S($D(RASX):RASX,1:RARX) 68 I $E(RARX)="?"!(RARX=0)!(RARX=" ")!(RARX?.E1N1"-"1N.E)!(RARX?.E1".".E) D HELP^RAPRI G Q:Y'=1 D DISP1^RAPRI G ADDORD1 69 S RAEXMUL=1 K RAHSMULT 70 F RAJ=1:1 S X=$P(RARX,",",RAJ) Q:X="" S RASTOP=0 W !!!,"Processing procedure: ",$S(+X&(+X'>RACNT):$P($G(RAPRC(X)),"^"),$E(X)'="`":X,1:"") D LOOKUP^RAPRI Q:$D(RAOUT) S:RAPRI>0 RASX="`"_RAPRI D:RAPRI>0 ALLERGY,CREATE Q:$D(RAOUT) K RAPRI 71 I $D(RAREASK),'$D(RAOUT) K RAREASK D DISP1^RAPRI G ADDORD1 72 Q ; Kill, unlock if locked, and quit 73 D KILL^RAORD 74 D SAVE ; reset RAMDV to its original value! 75 I $$ORVR^RAORDU()'<3,(+$G(RAPTLOCK)),(+$G(RADFN)) D 76 . D ULK^RAUTL19(RADFN_";DPT(") 77 K:'$D(RAREGFLG)&('$D(RAVSTFLG)) RACAT,RADFN,RANME,RAWARD 78 I '$D(RAPKG) K RAMDIV,RAMDV,RAMLC 79 I $D(RAPKG) K ORIFN,ORIT,ORL,ORNP,ORNS,ORPCL,ORPK,ORPV,ORPURG,ORSTS,ORTX,ORVP,RAPKG 80 K RAHSMULT,RAPOP,RAIMAG,RAREAST,RAREQLOC 81 K C,DI,DIG,DIH,DISYS,DIU,DIW,DIWF,DIWL,DIWR,DIWT,DN,I,ORCHART,POP,RAMDVZZ,RASCI,RASERIES 82 Q 83 CREATE S RACT=0 D MODS Q:$D(RAOUT) 84 CREATE1 ;ask for the 'Date Desired' req'd P75 85 S RAWHEN=$$DESDT^RAUTL12(RAPRI) S:RAWHEN=-1 RAOUT=1 Q:$D(RAOUT)#2 86 S RAWHEN=$$FMTE^XLFDT(RAWHEN,1) ;convert to external format 87 ; Ask pregnant if age is between 12 & 55. Ask once for mult requests 88 ; RASKPREG is the variable used to track if the pregnant prompt has 89 ; been asked. Ask only once for multiple requests. 90 S:'$D(RASKPREG) RAPREG=$$PREG^RAORD1A(RADFN,$G(DT)),RASKPREG="" Q:$D(RAOUT) 91 ;Reason for Study (req'd) & Clinical History (optional) asked in CH^RAUTL5 P75 92 D CH^RAUTL5 Q:$D(RAOUT) ;RAOUT: defined if Reason for Study is nonexistent 93 BAQUES ;*Billing Awareness Project 94 ; Ask Ordering ICD-9 Diagnosis and Related SC/EI/MST/HNC questions. 95 N RADTM D NOW^%DTC S RADTM=% 96 D ASK^RABWORD(RADFN,RADTM) 97 I '$D(RADR1) D DISP^RAORDU1 Q:$D(RAOUT) ; Display Order Responses. 98 S X=RADFN,DIC="^RAO(75.1,",DIC(0)="L",DLAYGO=75.1 99 D FILE^DICN K DIC Q:Y<0 S RAOIFN=+Y K DLAYGO 100 I $D(RAREGFLG)!($D(RAVSTFLG)) S RANUM=$S('$D(RANUM):1,1:RANUM+1),RAORDS(RANUM)=RAOIFN 101 I $D(^RA(79,+RADIV,.1)),$P(^(.1),"^",21)="y" S RALOCFLG="" 102 W ! S DA=RAOIFN,DIE="^RAO(75.1,",DIE("NO^")="OUTOK" 103 S DR=$S($D(RADR1):"[RA QUICK EXAM ORDER]",$D(RADR2):"[RA ORDER EXAM]",$D(RAEXMUL)&($D(RAFIN1)):"[RA QUICK EXAM ORDER]",1:"[RA ORDER EXAM]") 104 ;*Billing Awareness Project 105 ; If Order questions are being Re-Asked then Re-Ask ICD-9 Dx questions 106 I DR="[RA ORDER EXAM]" D ASK^RABWORD(RADFN,RADTM) W !! 107 D ^DIE 108 K DIE("NO^"),DE,DQ,DIE,DR,RADR1,RADR2 109 I $D(RAFIN),$D(^RAO(75.1,RAOIFN,0)) S RAORD0=^(0) D FILEDX^RABWORD(RADFN,RAOIFN) Q:'$D(RAFIN) D SETORD^RAORDU D OERR^RAORDU:'$D(RAPKG) D ^RAORDQ:$D(RAPKG) K RAORD0 110 I '$D(RAFIN) W !?3,$C(7),"Request not complete. Must Delete..." S DA=RAOIFN,DIK="^RAO(75.1," D ^DIK W "...deletion complete!" I $D(RAREGFLG)!($D(RAVSTFLG)) K RAORDS(RANUM) 111 I '$D(RAFIN),('$D(^RAO(75.1,RAOIFN,0))#2) Q ; record deleted! 112 K RAFIN 113 ; check if the 'stat' or 'urgent' alert is to be sent. 114 N RALOC,RAORD0 115 S RAORD0=$G(^RAO(75.1,RAOIFN,0)),RALOC=+$P(RAORD0,"^",20) 116 Q:'RALOC ; if no 'SUBMIT TO' location, can't send stat/urgent alerts 117 I $P(RAORD0,"^",6)=1!(($P(RAORD0,"^",6)=2)&($P(^RA(79.1,RALOC,0),"^",20)="Y")) D 118 .; If 6th piece of RAORD0=1 *stat*, =2 *urgent* 119 .Q:$$ORVR^RAORDU()<3 120 .; needs OE/RR 3.0 or greater for stat/urgent alerts to fire 121 .D OENO^RAUTL19(RAOIFN) 122 .Q 123 Q 124 ; 125 MODS ;RAPRI= Procedure IEN, RAIMAG=Imaging Type for the procedure. 126 ;Edited 4/19/94, Type of Imaging is now a multiple in file 71.2. CEW 127 S RAIMAG=+$$ITYPE^RASITE(RAPRI),DIC(0)="AEQMZ",DIC="^RAMIS(71.2,",DIC("A")="Select "_$P($G(^DIC(71.2,0)),"^")_": " 128 S DIC("S")="I +$D(^RAMIS(71.2,""AB"",RAIMAG,+Y)),$S('$G(RASERIES):1,$P(^RAMIS(71.2,+Y,0),U,2)="""":1,1:0),$$INIMOD^RAORD1A($P($G(^RAMIS(71.2,+Y,0)),""^""))" 129 D ^DIC K DIC,RAIMAG S:$D(DTOUT)!($D(DUOUT)) RAOUT=1 Q:$D(RAOUT)!(X="^")!(X="") I Y<1 W $C(7)," ??" G MODS 130 S RACT=RACT+1,RAMOD(RACT)=$P(Y,"^",2) G MODS 131 Q 132 ; 133 ALLERGY ; If patient has had a previous contrast media allergic reaction 134 ; check procedure RAPRI for specific contrast media associations 135 ; (new with RA*5*45) 136 Q:'$$ORCHK^GMRAOR(RADFN,"CM") 137 S RAPRI(0)=$G(^RAMIS(71,RAPRI,0)) 138 I $P(RAPRI(0),U,6)'="P" D ;not a parent check lone procedure 139 .D CONTRAST^RAUTL2(RAPRI) 140 .Q 141 E S I=0 D ;check descendent procedures for CM 142 .F S I=$O(^RAMIS(71,RAPRI,4,I)) Q:'I D CONTRAST^RAUTL2(+$G(^(I,0))) 143 .K I 144 .Q 145 K RAPRI(0) 146 Q 147 SAVE ; Save original value of RAMDV before it is altered in the ENADD sub- 148 ; routine. This code will also reset RAMDV to the sign-on value. 149 Q:'$D(RAPKG) ; entered through OE/RR (RAMDV will not be set) 150 Q:'$D(RAMDV)&('$D(RAMDVZZ)) ;entered through 'Request an Exam' option used stand-alone outside of Rad/NM pkg 151 I '$D(RAMDVZZ) S RAMDVZZ=RAMDV 152 E S RAMDV=RAMDVZZ 153 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1A.m
r613 r623 1 RAORD1A ;HISC/FPT-Request an Exam ;7/27/07 08:00 2 ;;5.0;Radiology/Nuclear Medicine;**1,86**;Mar 16, 1998;Build 7 3 ; 4 ;Call to WIN^DGPMDDCF (Supported IA #1246) from the SCREENW function 5 ;Supported IA #10039 reference to ^DIC(42 6 ;Supported IA #10040 reference to ^SC 7 ;Supported IA #10061 reference to ^VADPT 8 ;Supported IA #10103 reference to ^XLFDT 9 ; 10 SCREEN(RAINPAT,RACPRS27) ; screen for active clinics/wards 11 ; This code is also called from RAORD1 (screen for the Patient Location 12 ; prompt which is a pointer to the HOSPITAL LOCATION (#44) file.) 13 ; We want to EXCLUDE from our selection the following types of 14 ; hospital locations: 15 ; 16 ; 1) Occasion of Service (OOS) locations (fld: 50.01) 'OOS' node 17 ; 2) File Area ("F") or Imaging ("I") locations (fld: 2) 18 ; 3) Inactivate Date (fld: 2505) 'I' node 19 ; 20 ; input: RAINPAT=1 if the patient is an inpatient located on a ward, else 0. 21 ; RACPRS27=1 if the environment is running CPRS GUI v27, else 0. 22 ; 23 Q:$D(^SC(+Y,"OOS"))#2 0 ; #1 24 N RA44 S RA44=$G(^SC(+Y,0)),RA44(42)=$P($G(^SC(+Y,42)),U) 25 Q:"^F^I^"[(U_$P(RA44,U,3)_U) 0 ; #2 26 ; 27 ; if the hospital location is defined as a ward set RAWARD to 1, else 0 28 N RAWARD S RAWARD=0 29 ;check the pointer to the WARD LOCATION file. 30 I RA44(42)>0 D Q:RAWARD=-1 0 31 .;Error; the HOSPITAL LOCATION cannot be of TYPE 'Clinic' & point to a ward 32 .I $P(RA44,U,3)="C" S RAWARD=-1 Q 33 .;Error; bad pointers between files 42 & 44 34 .I $P($G(^DIC(42,RA44(42),44)),U)'=+Y S RAWARD=-1 Q 35 .;ok, set ward flag... 36 .S RAWARD=1 37 .Q 38 ; 39 ; 1) if the hospital location is a ward check if we should screen by ward 40 ; 2) the hosp location=ward, facility is running v26, and we have an 41 ; outpatient quit zero (default of the $S) 42 I RAWARD Q $S(RACPRS27!RAINPAT:$$SCREENW(+Y),1:0) 43 ; 44 ; if the hospital location is a clinic, we have an inpatient, and the 45 ; facility is not running CPRS v27 return 0 46 I 'RACPRS27,(RAINPAT) Q 0 47 ; 48 ; Check INACTIVATE DATE against REACTIVATE DATE 49 ; inactivate date = reactivate date (allow) 50 ; inactivate date > reactivate date (disallow) 51 ; inactivate date < reactivate date (allow) 52 ; 53 N RASCA,RASCI,RASCINDE S RASCINDE=$G(^SC(+Y,"I")) 54 S RASCI=+$P(RASCINDE,U),RASCA=+$P(RASCINDE,U,2) 55 ; 56 Q $S(RASCI'>0:1,RASCI>DT:1,1:RASCI'>RASCA) 57 ; 58 SCREENW(Y) ; check the out-of-service field of the WARD LOCATION (#42) record. 59 ;input Y: ien of the HOSPITAL LOCATION record 60 ; RAWHEN: DATE DESIRED (Not guaranteed) (file: 75.1, fld: 21) optional 61 ;output : '0' if not valid, else '1' if valid 62 N D0,DGPMOS,X 63 S D0=+$G(^SC(Y,42)) 64 Q:'D0 0 65 Q:'($D(^DIC(42,D0,0))#2) 0 66 ; 67 ;WIN^DGPMDDCF (Supported IA #1246) Is the ward active? 68 ; Input 69 ; D0 "Dee zero" (req): IEN of WARD LOCATION file. 70 ; DGPMOS (opt): defaults to DT. Is the ward in service on this date? 71 ; Output 72 ; X: 1 if out of service, 0 if in service, or -1 if input variables 73 ; not defined properly. Be careful; note the difference in their 74 ; boolean definition ('0'=success) and ours ('0'=failure) 75 ; 76 S:$D(RAWHEN)#2 DGPMOS=$P(RAWHEN,".",1) 77 D WIN^DGPMDDCF 78 Q 'X ;alter 'X' (the WIN^DGPMDDCF output value) to meet our ($$SCREENW) output definition 79 ; 80 PREG(RADFN,RADT) ; Subroutine will display the pregnancy prompt to the 81 ; user if the patient is between the ages of 12 - 55 inclusive. 82 ; Called from CREATE1^RAORD1. 83 ; Input : RADFN - Patient, RADT - Today's date 84 ; Output: Patient Pregnant? (yes, no, unknown or no default) 85 ; Note: (may set RAOUT if the user times out or '^' out) 86 Q:RASEX'="F" "" ; not a female 87 S:RADT="" RADT=$$DT^XLFDT() 88 N RADAYS,VADM D DEM^VADPT ; $P(VADM(3),"^") DOB of patient, internal 89 S RADAYS=$$FMDIFF^XLFDT(RAWHEN,$P(VADM(3),"^"),3) 90 Q:((RADAYS\365.25)<12) "" ; too young 91 Q:((RADAYS\365.25)>55) "" ; too old 92 N DIR,DIROUT,DIRUT,DUOUT,DTOUT S DIR(0)="75.1,13" D ^DIR 93 S:$D(DIRUT) RAOUT="^" Q:$D(RAOUT) "" 94 Q $P(Y,"^") 95 ; 96 INIMOD(Y) ; check if the user has selected the same 97 ; modifier more than once when the order is requested. 98 ; The 'Request an Exam' option. Called from MODS^RAORD1 99 ; Input: 'Y' the name of the procedure modifier 100 ; Output: 'X' if the user has not entered this modifier in 101 ; the past return one (1). Else return zero (0). 102 Q:'$D(RAMOD) 1 ; must allow the selection of the first modifier 103 ; after this, it is assumed that the RAMOD array is defined. 104 N RACNT,X S X=1,RACNT=99999 105 F S RACNT=$O(RAMOD(RACNT),-1) Q:RACNT=""!(X=0) S:RAMOD(RACNT)=Y X=0 106 Q X 107 ; 1 RAORD1A ;HISC/FPT-Request an Exam ;9/29/97 10:40 2 ;;5.0;Radiology/Nuclear Medicine;**1**;Mar 16, 1998 3 ; 4 CS ; Category of exam switch. Called from [RA ORDER EXAM] input template 5 ; when requesting an exam. User can change category of exam from 6 ; (1) inpatient to outpatient and select a clinic patient location OR 7 ; (2) outpatient to inpatient and select a ward patient location. 8 ; 9 N RAA,RAB,X,Y K DIR 10 S RAA=$S($E(RACAT)="I":"INPATIENT",1:"OUTPATIENT") 11 S RAB=$S($E(RAA)="I":"OUTPATIENT",1:"INPATIENT") 12 W ! S DIR("A",1)="CATEGORY OF EXAM is currently "_RAA 13 S DIR("A",2)=" " 14 S DIR("A")="Want to change CATEGORY OF EXAM to "_RAB 15 S DIR(0)="Y" 16 D ^DIR K DIR 17 I $D(DIRUT) S RALIFN("OUT")="" Q 18 I Y=0 S RALIFN("NO")="" Q 19 REQLOC ; select patient location 20 N DIC,RAHL,RAHLWD,RASCI W ! 21 ASK S DIC("A")="Patient Location: ",DIC="^SC(",DIC(0)="AEMQ" 22 I $E(RAB)="O" S DIC("S")="I $$TYPE^RAORD1A(RAB,+Y),$$SCREEN^RAORD1A" I '$D(RAOERRFG) S:$P($G(^SC(+RALIFN,0)),U,3)="C" DIC("B")=$P(^SC(+RALIFN,0),U,1) 23 I $E(RAB)="I" S DIC("S")="I $$TYPE^RAORD1A(RAB,+Y),$$SCREEN^RAORD1A" I '$D(RAOERRFG) S:$P($G(^SC(+RALIFN,0)),U,3)="W" DIC("B")=$P(^SC(+RALIFN,0),U,1) 24 D ^DIC K DIC 25 I +Y'>0 S RALIFN("OUT")="" Q 26 I $E(RAB)="I" S RAHLWD=+$G(^SC(+Y,42)) I RAHLWD S RAHL=+$G(^DIC(42,RAHLWD,44)) I RAHL,RAHL'=+Y W !!,*7,"This Hospital Location points to ",$P($G(^DIC(42,+Y,0)),U,1) G ASK 27 S RALIFN=+Y,RACAT=RAB 28 Q:$D(RAOERFLG) ;quit if REQLOC was called from REQLOC1 29 K:$E(RAB)="O" RAWARD 30 S:$E(RAB)="I" RAWARD=$P(^SC(+Y,0),U,1) 31 Q 32 SCREEN() ; screen for active clinics/wards 33 ; This code is also called from RAORD1 (screen for the Patient Location 34 ; prompt) 35 Q:$D(^SC(+Y,"OOS")) 0 ; don't want Occasion Of Service (OOS) locations 36 N RA44 S RA44=$G(^SC(+Y,0)) 37 Q:"FI"[$P(RA44,"^",3) 0 ; File areas & Imaging Types are not selectable 38 I $P(RA44,"^",3)="W" G SCREENW ; ward check 39 ; check inactivation & reactivation dates of clinic/operating 40 ; room in file #44 41 I '$D(^SC(+Y,"I")) Q 1 42 ; This Hospital Location has an "I" node. We have to check INACTIVATE 43 ; DATE & REACTIVATE DATE fields to determine if the Hosp. Location is 44 ; active. 45 N RASCA S RASCI=$G(^SC(+Y,"I")),RASCA=+$P(RASCI,"^",2) 46 ; RASCA is the REACTIVATE DATE 47 ; Not selectable if REACTIVATE DATE is beyond DT or null (0). 48 S RASCA=$S(RASCA=0:0,RASCA>DT:0,1:RASCA) 49 I +RASCI=0 Q 1 ; no INACTIVATE DATE 50 I +RASCI>DT Q 1 ; INACTIVATE DATE exceeds today's date 51 ; Check INACTIVATE DATE against REACTIVATE DATE 52 ; if REACTIVATE DATE exists and is not after (or is equal to) the 53 ; INACTIVATE DATE the location is not active. 54 I RASCA,(+RASCI<RASCA) Q 1 55 Q 0 56 SCREENW ; check currently out-of-service field of ward file (#42) 57 N D0,DGPMOS,X 58 S D0=+$G(^SC(+Y,42)) I 'D0 Q 0 59 I '$D(^DIC(42,D0,0)) Q 0 60 S:$D(RAWHEN) DGPMOS=$P(RAWHEN,".",1) 61 D WIN^DGPMDDCF 62 S X=$S(X=0:1,1:0) 63 Q X 64 ; 65 REQLOC1 ; Requesting Location does not go with Category of Exam 66 ; Category of Exam = Inpatient -> Requesting Location = Ward 67 ; Category of Exam = Outpatient -> Requesting Location = Clinic 68 ; Called from [RA OERR EDIT] and [RA QUICK EXAM ORDER] input templates 69 W !!?5,*7,"When the CATEGORY OF EXAM is "_$S(RAX="I":"Inpatient",1:"Outpatient")_" the REQUESTING LOCATION",!?5,"must be a "_$S(RAX="I":"Ward",1:"Clinic")_" or OR.",! 70 W !?5,"The current REQUESTING LOCATION is ",$S($P($G(^SC(+RALIFN,0)),U,1)]"":$P($G(^SC(+RALIFN,0)),U,1),1:"Unknown"),! 71 N RAB,X,Y 72 S RAX=$S(RAX="I":"INPATIENT",1:"OUTPATIENT"),RAB=RAX,RAOERRFG="" 73 D REQLOC 74 K RAOERRFG 75 Q 76 TYPE(RACAT,Y) ; Indicates whether a Hospital Location is a valid selection. 77 ; If the patient is an inpatient, all operating room location types & 78 ; all wards are valid selections. If the patient is an outpatient, all 79 ; operating room location types & all clinics are valid selections. 80 ; Input Variables: RACAT=$S(Inpatient:"I",1:"O") "O" for outpatient 81 ; Input Variables: Y=IEN of entries in the Hospital Location file 82 ; This fuction returns 1 if valid, 0 if not valid 83 N RAX S RAX=0 84 I $E(RACAT,1)="I" D 85 . I $P(^SC(+Y,0),U,3)="W"!($P(^SC(+Y,0),U,3)="OR") S RAX=1 86 . Q 87 E D 88 . I $P(^SC(+Y,0),U,3)="C"!($P(^SC(+Y,0),U,3)="OR") S RAX=1 89 . Q 90 Q RAX 91 MATCH(RACAT,RALOC) ; Detect mismatched req loc type and cat. of exam 92 ; and return code for correct category of exam 93 ; Input Variable: 'RACAT' - the value for the 'Category Of Exam' field. 94 ; Only passed in if either 'I' or 'O'. 95 ; 'RALOC' - The ien of the 'Requesting Location' 96 ; Output: correct category (I or O)_"^"_$S(Category='I':ward,1:"") 97 ; 98 N RA44 S RA44=$G(^SC(+RALOC,0)) 99 I $E(RACAT,1)'="I",$E(RACAT,1)'="O" Q RACAT 100 I $E(RACAT,1)="O",$P(RA44,U,3)'="C",($P(RA44,U,3)'="OR") S RACAT="INPATIENT" 101 I $E(RACAT,1)="I",$P(RA44,U,3)'="W",($P(RA44,U,3)'="OR") S RACAT="OUTPATIENT" 102 Q RACAT_"^"_$S($E(RACAT,1)="I":$P(RA44,"^"),1:"") 103 ; 104 PREG(RADFN,RADT) ; Subroutine will display the pregnancy prompt to the 105 ; user if the patient is between the ages of 12 - 55 inclusive. 106 ; Called from CREATE1^RAORD1. 107 ; Input : RADFN - Patient, RADT - Today's date 108 ; Output: Patient Pregnant? (yes, no, unknown or no default) 109 ; Note: (may set RAOUT if the user times out or '^' out) 110 Q:RASEX'="F" "" ; not a female 111 S:RADT="" RADT=$$DT^XLFDT() 112 N RADAYS,VADM D DEM^VADPT ; $P(VADM(3),"^") DOB of patient, internal 113 S RADAYS=$$FMDIFF^XLFDT(RAWHEN,$P(VADM(3),"^"),3) 114 Q:((RADAYS\365.25)<12) "" ; too young 115 Q:((RADAYS\365.25)>55) "" ; too old 116 N DIR,DIROUT,DIRUT,DUOUT,DTOUT S DIR(0)="75.1,13" D ^DIR 117 S:$D(DIRUT) RAOUT="^" Q:$D(RAOUT) "" 118 Q $P(Y,"^") 119 ; 120 INIMOD(Y) ; check if the user has selected the same 121 ; modifier more than once when the order is requested. 122 ; The 'Request an Exam' option. Called from MODS^RAORD1 123 ; Input: 'Y' the name of the procedure modifier 124 ; Output: 'X' if the user has not entered this modifier in 125 ; the past return one (1). Else return zero (0). 126 Q:'$D(RAMOD) 1 ; must allow the selection of the first modifier 127 ; after this, it is assumed that the RAMOD array is defined. 128 N RACNT,X S X=1,RACNT=99999 129 F S RACNT=$O(RAMOD(RACNT),-1) Q:RACNT=""!(X=0) S:RAMOD(RACNT)=Y X=0 130 Q X -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPCE.m
r613 r623 1 RAPCE ;HIRMFO/GJC-Interface with PCE APIs for wrkload, visits ;9/7/04 12:36pm 2 ;;5.0;Radiology/Nuclear Medicine;**10,17,21,26,41,57,56**;Mar 16, 1998;Build 3 3 ;Supported IA #2053 FILE^DIE 4 ;Supported IA #4663 SWSTAT^IBBAPI 5 ;Controlled IA #1889 DATA2PCE^PXAPI 6 Q 7 COMPLETE(RADFN,RADTI,RACNI) ; When an exam status changes to 'complete' 8 ; Input: RADFN-> Patient DFN, RADTI-> Exam Timestamp, RACNI-> Case IEN 9 ; NOTE: RACNI input param is ignored for exam sets (all cases under 10 ; an exam set are processed at once when order is complete) 11 ; $$DATA2PCE^PXAPI returns: 1 if no errors, else error condition 12 ; 13 K ^TMP("DIERR",$J),^TMP("RAPXAPI",$J) 14 N RA7002,RA7003,RA71,RA791,RACNT,RADTE,RAEARRY,RAPKG,RAVSIT,RABAD,RASTAT,RACPTM,RA,RA1,RARECMPL,RACNISAV 15 N RADUPRC,RACOMIEN,RASENT,RALCKFAL 16 S RALCKFAL=0 ; >0 if lock fails when : 17 ; 1= complt'g exam that's unique to other cases same dt/tm, if any 18 ; 2= complt'g exam that's a dupl of another cmplt'd exam (RESEND^RAPCE1) 19 ; 3= UNcompleting exam before deleting credit+visit pointers same dt/tm 20 S RAPKG=$O(^DIC(9.4,"B","RADIOLOGY/NUCLEAR MEDICINE",0)) 21 S RADTE=9999999.9999-RADTI,RACNT=0 22 S RA7002=$G(^RADPT(RADFN,"DT",RADTI,0)) 23 S RAXAMSET=+$P(RA7002,"^",5) ; is this part of an exam set? 1=YES 24 EN2 S RA791=$G(^RA(79.1,+$P(RA7002,"^",4),0)) 25 ; Initialize variables required for PFSS 1B project and check the switch status. 26 N RAPFSW,RACCOUNT S RAPFSW=$$SWSTAT^IBBAPI ; Requirement 12 27 Q:+$P(RA791,"^",21)=2 ; no credit, quit 28 S RAEARRY="RAERROR" N @RAEARRY 29 LON ; lock at P level 30 L +^RADPT(RADFN,"DT",RADTI,"P",RACNI):30 I '$T S RALCKFAL=1 D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ)) Q 31 I 'RAXAMSET G NONSET 32 ; exam set, grab all the completed records! 33 S RACNISAV=RACNI 34 S RACNI=0 35 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0!($G(RABAD)) D 36 . S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) I $P($G(^RA(72,+$P(RA7003,U,3),0)),U,3)'=9 Q ;check code instead of name 37 . S RACNT=RACNT+1 D SETUP I $G(RABAD) Q 38 . D:'$D(^TMP("RAPXAPI",$J,"ENCOUNTER")) ENC(RACNT) 39 . D DX^RABWPCE($P(RA7003,U,11)) ; Ordering ICD Dx and related data. 40 . D PROC(RACNT) 41 . Q 42 S RACNI=RACNISAV ;restore value so unlock would work 012601 43 I '$G(RABAD),$D(^TMP("RAPXAPI",$J)) D PCE(RADFN,RADTI,RACNI) 44 ;Missing data, send failure bulletin for ea case in set, don't attempt to send data to PCE 45 I $G(RABAD) W:'$D(ZTQUEUED)&('$D(RARECMPL)) !,"Unable to credit Exam set" D 46 . S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ)) 47 G KOUT 48 NONSET ; non-exam sets 49 S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 50 D CKDUP^RAPCE1 ; chk for duplicate procedure(s) non-examset 51 I $G(RADUPRC) D RESEND^RAPCE1 G KOUT ; branch off to re-send rec(s) this dt/tm 52 S RACNT=RACNT+1 53 D SETUP 54 D:'$G(RABAD) ENC(RACNT) D:'$G(RABAD) DX^RABWPCE($P(RA7003,U,11)) D:'$G(RABAD) PROC(RACNT) D:'$G(RABAD) PCE(RADFN,RADTI,RACNI) 55 I $G(RABAD) W:'$D(ZTQUEUED)&('$D(RARECMPL)) !,"Unable to credit exam" D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ)) ;Missing data, send failure bulletin for single case, don't attempt to pass data to PCE 56 ; 57 KOUT K ^TMP("RAPXAPI",$J) 58 L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) 59 Q 60 ENC(X) ; Set up the '"RAPXAPI",$J,"ENCOUNTER"' nodes 61 N RAIMGLOC,RA17,RARPTLOC 62 S RA17=+$P(RA7003,U,17) 63 S RARPTLOC=$P($G(^RARPT(RA17,"BA")),U,1) 64 S RAIMGLOC=$P($G(^RA(79.1,+RARPTLOC,0)),"^") 65 S:'RAIMGLOC RAIMGLOC=$P($G(^RA(79.1,+$P(RA7002,"^",4),0)),"^") 66 I RAIMGLOC="" S RABAD=1 Q ; needs imaging location 67 S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"PATIENT")=RADFN 68 S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"ENC D/T")=RADTE 69 S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"HOS LOC")=RAIMGLOC 70 S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"SERVICE CATEGORY")="X" 71 S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"ENCOUNTER TYPE")="A" 72 Q 73 PCE(RADFN,RADTI,RACNI) ; Pass on the information to the PCE software 74 N RASULT 75 ; If the PFSS switch is not active then do not pass RACCOUNT parameter to DATA2PCE call. 76 I 'RAPFSW S RASULT=$$DATA2PCE^PXAPI("^TMP(""RAPXAPI"",$J)",RAPKG,"RAD/NUC MED",.RAVSIT,"","","","",.@RAEARRY) 77 ; If the PFSS switch is active then use RACCOUNT parameter in DATA2PCE call. 78 I RAPFSW D 79 . ; PFSS Requirement 6, 11 80 . S RASULT=$$DATA2PCE^PXAPI("^TMP(""RAPXAPI"",$J)",RAPKG,"RAD/NUC MED",.RAVSIT,"","","","",.@RAEARRY,.RACCOUNT) 81 . Q 82 I (RASULT=1)!(RASULT=-1) D ;Visit file pointer, set 'Credit recorded' to yes. 83 . W:'$D(ZTQUEUED)&('$D(RARECMPL)) !?5,"Visit credited.",! 84 . D:'RAXAMSET VISIT(RADFN,RADTI,RACNI,RAVSIT) 85 . D:'RAXAMSET RECDCS(RADFN,RADTI,RACNI) ; only one exam, not a set 86 . D:RAXAMSET MULCS(RADFN,RADTI) ; set, update all exams! 87 . S RASENT=1 ; sent to PCE was okay 88 . Q 89 E D 90 . N RAWHOERR S RAWHOERR="" 91 . W:'$D(ZTQUEUED)&('$D(RARECMPL)) !?5,$C(7),"Unable to credit.",! 92 . I '$G(RAXAMSET) D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ)) 93 . I $G(RAXAMSET) D 94 .. S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ)) 95 .. Q 96 . Q 97 Q 98 MULCS(RADFN,RADTI) ; Update the 'Credit recorded' field and the Visit 99 ;pointer for each case that is complete 100 N RACNI S RACNI=0 101 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D 102 . Q:$P($G(^RA(72,+$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3),0)),U,3)'=9 103 . D RECDCS(RADFN,RADTI,RACNI) 104 . D VISIT(RADFN,RADTI,RACNI,RAVSIT) 105 . Q 106 Q 107 PROC(X) ; Set up the other '"RAPXAPI",$J,"PROCEDURE"' nodes for this case 108 ; If same procedure repeated in exam set, add to qty of existing 109 ; 'procedure' node. Else, if different provider, create new 110 ; separate 'procedure' nodes 111 N X1,X2,X3,RADUP F X1=1:1:X S X2=$G(^TMP("RAPXAPI",$J,"PROCEDURE",X1,"PROCEDURE")) I X2=$P(RA71,"^",9),^("ENC PROVIDER")=$S(RA7003(15)]"":RA7003(15),1:RA7003(12)) D Q 112 . S ^TMP("RAPXAPI",$J,"PROCEDURE",X1,"QTY")=^("QTY")+1 113 . D CPTMOD(X1) 114 . S RADUP=1 115 . Q 116 I $D(RADUP) Q 117 S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"QTY")=1 118 S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"PROCEDURE")=$P(RA71,"^",9) 119 S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"NARRATIVE")=$P(RA71,"^") 120 S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"ENC PROVIDER")=$S(RA7003(15)]"":RA7003(15),1:RA7003(12)) ; Pri. Int Staff if exists, else Pri Int Resident 121 S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"ORD PROVIDER")=RA7003(14) ; Requesting Physician. 122 S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"EVENT D/T")=RADTE 123 ; if the PFSS switch is active Get both Dept. Code and Account Reference Number (RACCOUNT) 124 I RAPFSW D GETDEPT^RABWIBB ; Requirement 9 125 D CPTMOD(X) 126 D PROCDX^RABWPCE(X) ; Add Ordering ICD Dx to each Procedure. 127 Q 128 RECDCS(RADFN,RADTI,RACNI) ; Set 'Clinic Stop Recorded' to yes 129 ; (70.03, fld 23) 130 N RAFDA S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",23)="Y" 131 D FILE^DIE("K","RAFDA") 132 Q 133 SETUP ; Setup examination data node information 134 ; If no provider, or inactive CPT, fail 135 S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 136 S RA7003(12)=$P(RA7003,"^",12) ; Pri. Inter. Resident 137 S RA7003(14)=$P(RA7003,"^",14) ; Requesting Physician. 138 S RA7003(15)=$P(RA7003,"^",15) ; Pri. Inter. Staff 139 ; OK to send if missing resident/staff ONLY if report Elec. Filed 140 I (RA7003(12)="")&(RA7003(15)=""),$P($G(^RARPT(+$P(RA7003,U,17),0)),U,5)'="EF" S RABAD=1 Q 141 S RA71=$G(^RAMIS(71,+$P(RA7003,"^",2),0)) 142 ; store CPT Modifiers' .01 value 143 K RACPTM S RA=0 F S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RA)) Q:'RA S RA1=$$BASICMOD^RACPTMSC($P($G(^(RA,0)),"^"),+$P(RA7002,"^")) S:+RA1>0 RACPTM(RA)=$P(RA1,"^",2) ;only valid cpt mods 144 ; find out if CPT code is active 145 I '$$ACTCODE^RACPTMSC(+$P(RA71,"^",9),$P(RA7002,"^")) S RABAD=1 146 Q 147 VISIT(RADFN,RADTI,RACNI,RAVSIT) ; Stuff the Visit file pointer passed back 148 ; from $$DATA2PCE^PXAPI() into the Visit field (70.02, fld 6) 149 N RAFDA S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",27)=RAVSIT 150 D FILE^DIE("K","RAFDA") 151 Q 152 CPTMOD(X3) ;CPT Modifiers 153 ; CPT Mods for dupl. procedure+provider will be accounted for 154 ; however, same CPT Mod will overwrite previous CPT Mod 155 S ^TMP("RAPXAPI",$J,"PROCEDURE",X3,"MODIFIERS")="" ;prevent abend 156 S RA=0 157 F S RA=$O(RACPTM(RA)) Q:'RA S ^TMP("RAPXAPI",$J,"PROCEDURE",X3,"MODIFIERS",RACPTM(RA))="" 158 Q 1 RAPCE ;HIRMFO/GJC-Interface with PCE APIs for wrkload, visits ;9/7/04 12:36pm 2 ;;5.0;Radiology/Nuclear Medicine;**10,17,21,26,41,57**;Mar 16, 1998 3 Q 4 COMPLETE(RADFN,RADTI,RACNI) ; When an exam status changes to 'complete' 5 ; Input: RADFN-> Patient DFN, RADTI-> Exam Timestamp, RACNI-> Case IEN 6 ; NOTE: RACNI input param is ignored for exam sets (all cases under 7 ; an exam set are processed at once when order is complete) 8 ; $$DATA2PCE^PXAPI returns: 1 if no errors, else error condition 9 ; 10 K ^TMP("DIERR",$J),^TMP("RAPXAPI",$J) 11 N RA7002,RA7003,RA71,RA791,RACNT,RADTE,RAEARRY,RAPKG,RAVSIT,RABAD,RASTAT,RACPTM,RA,RA1,RARECMPL,RACNISAV 12 N RADUPRC,RACOMIEN,RASENT,RALCKFAL 13 S RALCKFAL=0 ; >0 if lock fails when : 14 ; 1= complt'g exam that's unique to other cases same dt/tm, if any 15 ; 2= complt'g exam that's a dupl of another cmplt'd exam (RESEND^RAPCE1) 16 ; 3= UNcompleting exam before deleting credit+visit pointers same dt/tm 17 S RAPKG=$O(^DIC(9.4,"B","RADIOLOGY/NUCLEAR MEDICINE",0)) 18 S RADTE=9999999.9999-RADTI,RACNT=0 19 S RA7002=$G(^RADPT(RADFN,"DT",RADTI,0)) 20 S RAXAMSET=+$P(RA7002,"^",5) ; is this part of an exam set? 1=YES 21 EN2 S RA791=$G(^RA(79.1,+$P(RA7002,"^",4),0)) 22 ; Initialize variables required for PFSS 1B project and check the switch status. 23 N RAPFSW,RACCOUNT S RAPFSW=$$SWSTAT^IBBAPI ; Requirement 12 24 Q:+$P(RA791,"^",21)=2 ; no credit, quit 25 S RAEARRY="RAERROR" N @RAEARRY 26 LON ; lock at P level 27 L +^RADPT(RADFN,"DT",RADTI,"P",RACNI):30 I '$T S RALCKFAL=1 D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ)) Q 28 I 'RAXAMSET G NONSET 29 ; exam set, grab all the completed records! 30 S RACNISAV=RACNI 31 S RACNI=0 32 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0!($G(RABAD)) D 33 . S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) I $P($G(^RA(72,+$P(RA7003,U,3),0)),U,3)'=9 Q ;check code instead of name 34 . S RACNT=RACNT+1 D SETUP I $G(RABAD) Q 35 . D:'$D(^TMP("RAPXAPI",$J,"ENCOUNTER")) ENC(RACNT) 36 . D DX^RABWPCE($P(RA7003,U,11)) ; Ordering ICD Dx and related data. 37 . D PROC(RACNT) 38 . Q 39 S RACNI=RACNISAV ;restore value so unlock would work 012601 40 I '$G(RABAD),$D(^TMP("RAPXAPI",$J)) D PCE(RADFN,RADTI,RACNI) 41 ;Missing data, send failure bulletin for ea case in set, don't attempt to send data to PCE 42 I $G(RABAD) W:'$D(ZTQUEUED)&('$D(RARECMPL)) !,"Unable to credit Exam set" D 43 . S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ)) 44 G KOUT 45 NONSET ; non-exam sets 46 S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 47 D CKDUP^RAPCE1 ; chk for duplicate procedure(s) non-examset 48 I $G(RADUPRC) D RESEND^RAPCE1 G KOUT ; branch off to re-send rec(s) this dt/tm 49 S RACNT=RACNT+1 50 D SETUP 51 D:'$G(RABAD) ENC(RACNT) D:'$G(RABAD) DX^RABWPCE($P(RA7003,U,11)) D:'$G(RABAD) PROC(RACNT) D:'$G(RABAD) PCE(RADFN,RADTI,RACNI) 52 I $G(RABAD) W:'$D(ZTQUEUED)&('$D(RARECMPL)) !,"Unable to credit exam" D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ)) ;Missing data, send failure bulletin for single case, don't attempt to pass data to PCE 53 ; 54 KOUT K ^TMP("RAPXAPI",$J) 55 L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) 56 Q 57 ENC(X) ; Set up the '"RAPXAPI",$J,"ENCOUNTER"' nodes 58 N RAIMGLOC,RA17,RARPTLOC 59 S RA17=+$P(RA7003,U,17) 60 S RARPTLOC=$P($G(^RARPT(RA17,"BA")),U,1) 61 S RAIMGLOC=$P($G(^RA(79.1,+RARPTLOC,0)),"^") 62 S:'RAIMGLOC RAIMGLOC=$P($G(^RA(79.1,+$P(RA7002,"^",4),0)),"^") 63 I RAIMGLOC="" S RABAD=1 Q ; needs imaging location 64 S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"PATIENT")=RADFN 65 S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"ENC D/T")=RADTE 66 S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"HOS LOC")=RAIMGLOC 67 S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"SERVICE CATEGORY")="X" 68 S ^TMP("RAPXAPI",$J,"ENCOUNTER",X,"ENCOUNTER TYPE")="A" 69 Q 70 PCE(RADFN,RADTI,RACNI) ; Pass on the information to the PCE software 71 N RASULT 72 ; If the PFSS switch is not active then do not pass RACCOUNT parameter to DATA2PCE call. 73 I 'RAPFSW S RASULT=$$DATA2PCE^PXAPI("^TMP(""RAPXAPI"",$J)",RAPKG,"RAD/NUC MED",.RAVSIT,"","","","",.@RAEARRY) 74 ; If the PFSS switch is active then use RACCOUNT parameter in DATA2PCE call. 75 I RAPFSW D 76 . ; PFSS Requirement 6, 11 77 . S RASULT=$$DATA2PCE^PXAPI("^TMP(""RAPXAPI"",$J)",RAPKG,"RAD/NUC MED",.RAVSIT,"","","","",.@RAEARRY,.RACCOUNT) 78 . Q 79 I (RASULT=1)!(RASULT=-1) D ;Visit file pointer, set 'Credit recorded' to yes. 80 . W:'$D(ZTQUEUED)&('$D(RARECMPL)) !?5,"Visit credited.",! 81 . D:'RAXAMSET VISIT(RADFN,RADTI,RACNI,RAVSIT) 82 . D:'RAXAMSET RECDCS(RADFN,RADTI,RACNI) ; only one exam, not a set 83 . D:RAXAMSET MULCS(RADFN,RADTI) ; set, update all exams! 84 . S RASENT=1 ; sent to PCE was okay 85 . Q 86 E D 87 . N RAWHOERR S RAWHOERR="" 88 . W:'$D(ZTQUEUED)&('$D(RARECMPL)) !?5,$C(7),"Unable to credit.",! 89 . I '$G(RAXAMSET) D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ)) 90 . I $G(RAXAMSET) D 91 .. S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D FAILBUL^RAPCE2(RADFN,RADTI,RACNI,$S($G(RADUZ):RADUZ,1:DUZ)) 92 .. Q 93 . Q 94 Q 95 MULCS(RADFN,RADTI) ; Update the 'Credit recorded' field and the Visit 96 ;pointer for each case that is complete 97 N RACNI S RACNI=0 98 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D 99 . Q:$P($G(^RA(72,+$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3),0)),U,3)'=9 100 . D RECDCS(RADFN,RADTI,RACNI) 101 . D VISIT(RADFN,RADTI,RACNI,RAVSIT) 102 . Q 103 Q 104 PROC(X) ; Set up the other '"RAPXAPI",$J,"PROCEDURE"' nodes for this case 105 ; If same procedure repeated in exam set, add to qty of existing 106 ; 'procedure' node. Else, if different provider, create new 107 ; separate 'procedure' nodes 108 N X1,X2,X3,RADUP F X1=1:1:X S X2=$G(^TMP("RAPXAPI",$J,"PROCEDURE",X1,"PROCEDURE")) I X2=$P(RA71,"^",9),^("ENC PROVIDER")=$S(RA7003(15)]"":RA7003(15),1:RA7003(12)) D Q 109 . S ^TMP("RAPXAPI",$J,"PROCEDURE",X1,"QTY")=^("QTY")+1 110 . D CPTMOD(X1) 111 . S RADUP=1 112 . Q 113 I $D(RADUP) Q 114 S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"QTY")=1 115 S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"PROCEDURE")=$P(RA71,"^",9) 116 S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"NARRATIVE")=$P(RA71,"^") 117 S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"ENC PROVIDER")=$S(RA7003(15)]"":RA7003(15),1:RA7003(12)) ; Pri. Int Staff if exists, else Pri Int Resident 118 S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"ORD PROVIDER")=RA7003(14) ; Requesting Physician. 119 S ^TMP("RAPXAPI",$J,"PROCEDURE",X,"EVENT D/T")=RADTE 120 ; if the PFSS switch is active Get both Dept. Code and Account Reference Number (RACCOUNT) 121 I RAPFSW D GETDEPT^RABWIBB ; Requirement 9 122 D CPTMOD(X) 123 D PROCDX^RABWPCE(X) ; Add Ordering ICD Dx to each Procedure. 124 Q 125 RECDCS(RADFN,RADTI,RACNI) ; Set 'Clinic Stop Recorded' to yes 126 ; (70.03, fld 23) 127 N RAFDA S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",23)="Y" 128 D FILE^DIE("K","RAFDA") 129 Q 130 SETUP ; Setup examination data node information 131 ; If no provider, or inactive CPT, fail 132 S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 133 S RA7003(12)=$P(RA7003,"^",12) ; Pri. Inter. Resident 134 S RA7003(14)=$P(RA7003,"^",14) ; Requesting Physician. 135 S RA7003(15)=$P(RA7003,"^",15) ; Pri. Inter. Staff 136 I (RA7003(12)="")&(RA7003(15)="") S RABAD=1 Q 137 S RA71=$G(^RAMIS(71,+$P(RA7003,"^",2),0)) 138 ; store CPT Modifiers' .01 value 139 K RACPTM S RA=0 F S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RA)) Q:'RA S RA1=$$BASICMOD^RACPTMSC($P($G(^(RA,0)),"^"),+$P(RA7002,"^")) S:+RA1>0 RACPTM(RA)=$P(RA1,"^",2) ;only valid cpt mods 140 ; find out if CPT code is active 141 I '$$ACTCODE^RACPTMSC(+$P(RA71,"^",9),$P(RA7002,"^")) S RABAD=1 142 Q 143 VISIT(RADFN,RADTI,RACNI,RAVSIT) ; Stuff the Visit file pointer passed back 144 ; from $$DATA2PCE^PXAPI() into the Visit field (70.02, fld 6) 145 N RAFDA S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",27)=RAVSIT 146 D FILE^DIE("K","RAFDA") 147 Q 148 CPTMOD(X3) ;CPT Modifiers 149 ; CPT Mods for dupl. procedure+provider will be accounted for 150 ; however, same CPT Mod will overwrite previous CPT Mod 151 S ^TMP("RAPXAPI",$J,"PROCEDURE",X3,"MODIFIERS")="" ;prevent abend 152 S RA=0 153 F S RA=$O(RACPTM(RA)) Q:'RA S ^TMP("RAPXAPI",$J,"PROCEDURE",X3,"MODIFIERS",RACPTM(RA))="" 154 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPROD.m
r613 r623 1 RAPROD ;HISC/FPT,GJC AISC/MJK-Detailed Exam View ;8/1/97 11:13 2 ;;5.0;Radiology/Nuclear Medicine;**10,35,45,56**;Mar 16, 1998;Build 3 3 ;Supported IA #2056 GET1^DIQ 4 ;Supported IA #2053 UPDATE^DIE 5 ;Supported IA #10040 ^SC( 6 ;Supported IA #10060 ^VA(200 7 START S RADI=^RADPT(RADFN,"DT",RADTI,0) S:$D(^("P",RACNI,"COMP")) RA("COMP")=^("COMP") S RA("REA")=$S($D(^("R")):^("R"),1:"") 8 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:"") 9 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") 10 S RA("RST")=$$RSTAT^RAO7PC1A 11 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:"") 12 ; 13 N RAOPRC ; this will be the Requested Procedure defined only if it 14 ; differs from the Registered Procedure 15 I +$P(Y(0),U,11),($$DPROC^RAUTL15(RADFN,RADTI,RACNI,+$P(Y(0),U,11))]"") D 16 . S RAOPRC=$$GET1^DIQ(75.1,+$P(Y(0),"^",11)_",",2) 17 . Q 18 VIEW W @IOF S X="",$P(X,"=",80)="" W X K X 19 W !?2,"Name : ",RANME," ",RASSN 20 W !?2,"Division : ",$E(RA("DIV"),1,20),?40,"Category : ",RA("CAT") 21 W !?2,"Location : ",$S($D(^SC(+RA("LOC"),0)):$P(^(0),"^"),1:"Unknown"),?40,"Ward : ",$E(RA("WRD"),1,24) 22 W !?2,"Exam Date : ",RADATE,?40,"Service : ",$E(RA("SERV"),1,24) 23 W !?2,"Case No. : ",RACN W ?40,"Bedsection : ",$E(RA("BED"),1,24) 24 W !?40,"Clinic : ",$E(RA("CL"),1,24) 25 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) 26 W:$X>1 ! S X="",$P(X,"-",80)="" W X K X 27 W !?2,"Registered : ",$E(RAPRC,1,60) D PRCCPT 28 W:$G(RAOPRC)]"" !?2,"Requested : ",$E(RAOPRC,1,60) 29 W !?2,"Requesting Phy: ",$E(RA("PHY"),1,20),?40,"Exam Status : ",$S($D(^RA(72,RAST,0)):$E($P(^(0),"^"),1,24),1:"") 30 W !?2,"Int'g Resident: ",$E(RA("RES"),1,20),?40,"Report Status: ",$E(RA("RST"),1,21) 31 S RAPREVER=+$P($G(^RARPT(RARPT,0)),"^",13) 32 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 33 W !?2,"Int'g Staff : ",$E(RA("STAFF"),1,20),?40,"Diagnosis : ",$E(RA("DIA"),1,24) 34 W !?2,"Technologist : ",$E(RA("TECH"),1,20),?40,"Complication : ",$E(RA("CMP"),1,24) 35 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),! 36 W:$X>1 ! 37 K RAFL W ?40,"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),! 38 W:$X>1 ! S X="",$P(X,"-",34)="" W X 39 W "Modifiers" W $E(X,1,32) K X 40 W !?2,"Proc Modifiers:" D MODS^RAUTL2 F I=1:1 Q:$P(Y,", ",I)']"" W ?18,$P(Y,", ",I),! 41 N J 42 W !?2,"CPT Modifiers : " W:Y(1)="None" Y(1),! 43 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 ! 44 Q:+$G(RAXIT) 45 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W ! 46 Q:+$G(RAXIT) 47 ; 48 ;check for Contrast Media data, print it if it exists. 49 I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0)) D 50 .W !?2,"Contrast Media: " S RACM=1 51 .N DIWF,DIWL,DIWR,DIWT,X,Z 52 .S X=$$CM^RADEM1(RADFN,RADTI,RACNI),DIWL=20,DIWF="C50" 53 .D ^DIWP S Z=0 54 .F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:'Z D 55 ..W ?18,^UTILITY($J,"W",DIWL,Z,0) 56 ..W:+$O(^UTILITY($J,"W",DIWL,Z)) ! 57 ..Q 58 .K ^UTILITY($J,"W") 59 .Q 60 ; 61 I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) D PHARM^RAPROD2(RACNI_","_RADTI_","_RADFN_",") W ! ; display pharmaceutical data 62 I +$G(RAXIT) K RAXIT Q 63 I +$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",28) D RDIO^RAPROD2(+$P(^(0),"^",28)) W ! ; display radiopharm data 64 I +$G(RAXIT) K RAXIT Q 65 W:$X>1 ! S X="",$P(X,"=",80)="" W X K X 66 G ^RAPROD1 67 ; 68 PRCCPT ; display Proc's abbrv, proc type, CPT 69 Q:$G(RADTI)="" Q:$G(RACNI)="" 70 ; 71 N RADISPLY 72 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 73 S RADISPLY=$$PRCCPT^RADD1() 74 W ?54,RADISPLY 75 Q 76 SETL ;Set long display preference 77 N RA1,RA2,DIR 78 S RA1=$O(^RA(79,0)) Q:'RA1 79 S RA2=$O(^RA(79,RA1,"LDIS","B",DUZ,0)) 80 I RA2 D Q 81 . W !!,"Your preference for Long Display of Procedures has already been set." 82 . S DIR(0)="Y",DIR("A")="Do you want to delete your preference ",DIR("B")="No" 83 . S DIR("?",1)="If you answer 'Yes', then all Radiology reports requested by you will" 84 . S DIR("?",2)="will default to the condensed display, which means that repeated procedures" 85 . S DIR("?")="and associated modifiers will only be listed once." 86 . D ^DIR 87 . Q:'Y 88 . D DEL150 89 . Q 90 W ! 91 S DIR(0)="Y",DIR("A",1)="Do you want to set your preference for Long Display of Procedures" 92 S DIR("A")="in all Radiology reports ",DIR("B")="No" 93 S DIR("?",1)="If you answer 'Yes', then all Radiology reports requested by you will" 94 S DIR("?",2)="list all repeated procedures and associated modifiers instead of" 95 S DIR("?")="listing repeated procedures only once, which is the condensed (default) format." 96 D ^DIR 97 Q:'Y 98 D STUF150 99 Q 100 DEL150 ;Delete user ien from 1st record in file 79's field 150 101 ; note: DIK utility looks for DA(1) here 102 Q:'$D(DUZ)#2 103 S DA(1)=$O(^RA(79,0)) Q:'DA(1) 104 S DIK="^RA(79,"_DA(1)_",""LDIS""," 105 S DA=$O(^RA(79,DA(1),"LDIS","B",DUZ,0)) 106 Q:'DA 107 D ^DIK 108 K DIK,DA 109 W !!,"Your preference for Long Display of Procedures has been removed.",! 110 Q 111 STUF150 ;Stuff user ien into 1st record in file 79's field 150 112 Q:'$D(DUZ)#2 113 S RA1=$O(^RA(79,0)) Q:'RA1 114 K RAFDA,RAIEN,RAMSG 115 S RAFDA(79.03,"?+2,"_RA1_",",.01)=DUZ 116 D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") 117 W !!,"Your preference for Long Display of Procedures has been set.",! 118 Q 119 CDIS ; set up RACDIS array to store 1st non-duplicate proc+pmod+cptmod 120 N N1,N2,R1,RA71,Y 121 K RACDIS 122 D LDIS 123 S N1=0 124 F S N1=$O(^RADPT(RADFN,"DT",RADTI,"P",N1)) Q:'N1 S R1=$G(^(N1,0)) D:R1]"" 125 . S RA71=$P(R1,U,2),RACNI=N1 126 . D MODS^RAUTL2 127 . S RACDIS("B",RA71,Y,Y(1),N1)="" 128 . S N2=$O(RACDIS("B",RA71,Y,Y(1),0)) 129 . S RACDIS(N2)=$G(RACDIS(N2))+1 ;increment lowest ien of same proc+pmod+cptmod 130 . S:RACDIS(N2)>1 RACDIS("RAFLDUP")=1 ;>1 same proc+pmod+cptmod 131 . Q 132 Q 133 LDIS ; See if user prefers Long Display of Procedures 134 N RA1 135 S RA1=$O(^RA(79,0)) Q:'RA1 136 S:$O(^RA(79,RA1,"LDIS","B",DUZ,0)) RALDIS=1 137 Q 138 LIST ; 139 ;;RA("DIV");^DIC(4,;RADI;3 140 ;;RA("LOC");^RA(79.1,;RADI;4 141 ;;RA("WRD");^DIC(42,;Y(0);6 142 ;;RA("SERV");^DIC(49,;Y(0);7 143 ;;RA("CL");^SC(;Y(0);8 144 ;;RA("CONT");^DIC(34,;Y(0);9 145 ;;RA("RES");^VA(200,;Y(0);12 146 ;;RA("DIA");^RA(78.3,;Y(0);13 147 ;;RA("PHY");^VA(200,;Y(0);14 148 ;;RA("STAFF");^VA(200,;Y(0);15 149 ;;RA("CMP");^RA(78.1,;Y(0);16 150 ;;RA("RM");^RA(78.6,;Y(0);18 151 ;;RA("BED");^DIC(42.4,;Y(0);19 1 RAPROD ;HISC/FPT,GJC AISC/MJK-Detailed Exam View ;8/1/97 11:13 2 ;;5.0;Radiology/Nuclear Medicine;**10,35,45**;Mar 16, 1998 3 START S RADI=^RADPT(RADFN,"DT",RADTI,0) S:$D(^("P",RACNI,"COMP")) RA("COMP")=^("COMP") S RA("REA")=$S($D(^("R")):^("R"),1:"") 4 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:"") 5 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") 6 S X=$S($D(^RARPT(+RARPT,0)):$P(^(0),"^",5),1:""),RA("RST")=$S(X="D":"DRAFT",X="V":"VERIFIED",X="R":"RELEASED/NOT VERIFIED",X="PD":"PROBLEM DRAFT",1:"NO REPORT") 7 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:"") 8 ; 9 N RAOPRC ; this will be the Requested Procedure defined only if it 10 ; differs from the Registered Procedure 11 I +$P(Y(0),U,11),($$DPROC^RAUTL15(RADFN,RADTI,RACNI,+$P(Y(0),U,11))]"") D 12 . S RAOPRC=$$GET1^DIQ(75.1,+$P(Y(0),"^",11)_",",2) 13 . Q 14 VIEW W @IOF S X="",$P(X,"=",80)="" W X K X 15 W !?2,"Name : ",RANME," ",RASSN 16 W !?2,"Division : ",$E(RA("DIV"),1,20),?40,"Category : ",RA("CAT") 17 W !?2,"Location : ",$S($D(^SC(+RA("LOC"),0)):$P(^(0),"^"),1:"Unknown"),?40,"Ward : ",$E(RA("WRD"),1,24) 18 W !?2,"Exam Date : ",RADATE,?40,"Service : ",$E(RA("SERV"),1,24) 19 W !?2,"Case No. : ",RACN W ?40,"Bedsection : ",$E(RA("BED"),1,24) 20 W !?40,"Clinic : ",$E(RA("CL"),1,24) 21 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) 22 W:$X>1 ! S X="",$P(X,"-",80)="" W X K X 23 W !?2,"Registered : ",$E(RAPRC,1,60) D PRCCPT 24 W:$G(RAOPRC)]"" !?2,"Requested : ",$E(RAOPRC,1,60) 25 W !?2,"Requesting Phy: ",$E(RA("PHY"),1,20),?40,"Exam Status : ",$S($D(^RA(72,RAST,0)):$E($P(^(0),"^"),1,24),1:"") 26 W !?2,"Int'g Resident: ",$E(RA("RES"),1,20),?40,"Report Status: ",$E(RA("RST"),1,21) 27 S RAPREVER=+$P($G(^RARPT(RARPT,0)),"^",13) 28 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 29 W !?2,"Int'g Staff : ",$E(RA("STAFF"),1,20),?40,"Diagnosis : ",$E(RA("DIA"),1,24) 30 W !?2,"Technologist : ",$E(RA("TECH"),1,20),?40,"Complication : ",$E(RA("CMP"),1,24) 31 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),! 32 W:$X>1 ! 33 K RAFL W ?40,"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),! 34 W:$X>1 ! S X="",$P(X,"-",34)="" W X 35 W "Modifiers" W $E(X,1,32) K X 36 W !?2,"Proc Modifiers:" D MODS^RAUTL2 F I=1:1 Q:$P(Y,", ",I)']"" W ?18,$P(Y,", ",I),! 37 N J 38 W !?2,"CPT Modifiers : " W:Y(1)="None" Y(1),! 39 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 ! 40 Q:+$G(RAXIT) 41 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W ! 42 Q:+$G(RAXIT) 43 ; 44 ;check for Contrast Media data, print it if it exists. 45 I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0)) D 46 .W !?2,"Contrast Media: " S RACM=1 47 .N DIWF,DIWL,DIWR,DIWT,X,Z 48 .S X=$$CM^RADEM1(RADFN,RADTI,RACNI),DIWL=20,DIWF="C50" 49 .D ^DIWP S Z=0 50 .F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:'Z D 51 ..W ?18,^UTILITY($J,"W",DIWL,Z,0) 52 ..W:+$O(^UTILITY($J,"W",DIWL,Z)) ! 53 ..Q 54 .K ^UTILITY($J,"W") 55 .Q 56 ; 57 I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) D PHARM^RAPROD2(RACNI_","_RADTI_","_RADFN_",") W ! ; display pharmaceutical data 58 I +$G(RAXIT) K RAXIT Q 59 I +$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",28) D RDIO^RAPROD2(+$P(^(0),"^",28)) W ! ; display radiopharm data 60 I +$G(RAXIT) K RAXIT Q 61 W:$X>1 ! S X="",$P(X,"=",80)="" W X K X 62 G ^RAPROD1 63 ; 64 PRCCPT ; display Proc's abbrv, proc type, CPT 65 Q:$G(RADTI)="" Q:$G(RACNI)="" 66 ; 67 N RADISPLY 68 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 69 S RADISPLY=$$PRCCPT^RADD1() 70 W ?54,RADISPLY 71 Q 72 SETL ;Set long display preference 73 N RA1,RA2,DIR 74 S RA1=$O(^RA(79,0)) Q:'RA1 75 S RA2=$O(^RA(79,RA1,"LDIS","B",DUZ,0)) 76 I RA2 D Q 77 . W !!,"Your preference for Long Display of Procedures has already been set." 78 . S DIR(0)="Y",DIR("A")="Do you want to delete your preference ",DIR("B")="No" 79 . S DIR("?",1)="If you answer 'Yes', then all Radiology reports requested by you will" 80 . S DIR("?",2)="will default to the condensed display, which means that repeated procedures" 81 . S DIR("?")="and associated modifiers will only be listed once." 82 . D ^DIR 83 . Q:'Y 84 . D DEL150 85 . Q 86 W ! 87 S DIR(0)="Y",DIR("A",1)="Do you want to set your preference for Long Display of Procedures" 88 S DIR("A")="in all Radiology reports ",DIR("B")="No" 89 S DIR("?",1)="If you answer 'Yes', then all Radiology reports requested by you will" 90 S DIR("?",2)="list all repeated procedures and associated modifiers instead of" 91 S DIR("?")="listing repeated procedures only once, which is the condensed (default) format." 92 D ^DIR 93 Q:'Y 94 D STUF150 95 Q 96 DEL150 ;Delete user ien from 1st record in file 79's field 150 97 ; note: DIK utility looks for DA(1) here 98 Q:'$D(DUZ)#2 99 S DA(1)=$O(^RA(79,0)) Q:'DA(1) 100 S DIK="^RA(79,"_DA(1)_",""LDIS""," 101 S DA=$O(^RA(79,DA(1),"LDIS","B",DUZ,0)) 102 Q:'DA 103 D ^DIK 104 K DIK,DA 105 W !!,"Your preference for Long Display of Procedures has been removed.",! 106 Q 107 STUF150 ;Stuff user ien into 1st record in file 79's field 150 108 Q:'$D(DUZ)#2 109 S RA1=$O(^RA(79,0)) Q:'RA1 110 K RAFDA,RAIEN,RAMSG 111 S RAFDA(79.03,"?+2,"_RA1_",",.01)=DUZ 112 D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") 113 W !!,"Your preference for Long Display of Procedures has been set.",! 114 Q 115 CDIS ; set up RACDIS array to store 1st non-duplicate proc+pmod+cptmod 116 N N1,N2,R1,RA71,Y 117 K RACDIS 118 D LDIS 119 S N1=0 120 F S N1=$O(^RADPT(RADFN,"DT",RADTI,"P",N1)) Q:'N1 S R1=$G(^(N1,0)) D:R1]"" 121 . S RA71=$P(R1,U,2),RACNI=N1 122 . D MODS^RAUTL2 123 . S RACDIS("B",RA71,Y,Y(1),N1)="" 124 . S N2=$O(RACDIS("B",RA71,Y,Y(1),0)) 125 . S RACDIS(N2)=$G(RACDIS(N2))+1 ;increment lowest ien of same proc+pmod+cptmod 126 . S:RACDIS(N2)>1 RACDIS("RAFLDUP")=1 ;>1 same proc+pmod+cptmod 127 . Q 128 Q 129 LDIS ; See if user prefers Long Display of Procedures 130 N RA1 131 S RA1=$O(^RA(79,0)) Q:'RA1 132 S:$O(^RA(79,RA1,"LDIS","B",DUZ,0)) RALDIS=1 133 Q 134 LIST ; 135 ;;RA("DIV");^DIC(4,;RADI;3 136 ;;RA("LOC");^RA(79.1,;RADI;4 137 ;;RA("WRD");^DIC(42,;Y(0);6 138 ;;RA("SERV");^DIC(49,;Y(0);7 139 ;;RA("CL");^SC(;Y(0);8 140 ;;RA("CONT");^DIC(34,;Y(0);9 141 ;;RA("RES");^VA(200,;Y(0);12 142 ;;RA("DIA");^RA(78.3,;Y(0);13 143 ;;RA("PHY");^VA(200,;Y(0);14 144 ;;RA("STAFF");^VA(200,;Y(0);15 145 ;;RA("CMP");^RA(78.1,;Y(0);16 146 ;;RA("RM");^RA(78.6,;Y(0);18 147 ;;RA("BED");^DIC(42.4,;Y(0);19 -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPTLU.m
r613 r623 1 RAPTLU ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Patient's Exam Lookup ;11/13/00 09:13 2 ;;5.0;Radiology/Nuclear Medicine;**2,8,15,23,56**;Mar 16, 1998;Build 3 3 ;Supported EA #10001 DT^DIO2 4 ;Supported IA #2378 ORCHK^GMRAOR 5 ;Supported IA #10035 ^DPT( 6 ;Supported IA #10040 ^SC( 7 ;Private IA #1123 RACHK^GMRARAD, RADD^GMRARAD 8 ;*********************************************************************** 9 ; <<< NOTE >>> 10 ; 'RANOSCRN' is set in the entry actions of various options. 11 ; If the variable exists, the screen is ignored. Code is in line 12 ; label PRT+0. 13 ;*********************************************************************** 14 CASE D SEL S:'RACNT X="^" G Q:X="^"!($D(RAF1)) F I=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",I)=$P(Y,"^",I) 15 S ^DISV($S($D(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI,Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) 16 Q K RTESC,RTFL,RACNT,RAERR,RASTP,RAELOC,RADTPRT,^TMP("MAG",$J,"COL"),^TMP("MAG",$J,"ROW") Q 17 ; 18 SEL Q:'$D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$P(RANME,"^") K ^TMP($J,"RAEX") D HOME^%ZIS D HD S X="",RACNT=0 19 ;I $$IMAGE^RARIC1 D MED^MAGSET3,ERASE^MAGSET3 ;don't call MAG 111300 20 S X="" 21 F RADTI=0:0 Q:X="^"!(X>0) S RADTI=$O(^RADPT(RADFN,"DT",RADTI)) Q:RADTI'>0 I $D(^(RADTI,0)) S RANODE=^(0),RADTE=+^(0) D SEL2 ;swm080398 22 Q:X="^"!(X>0) I 'RACNT W !?3,$C(7),"No matches found!" Q 23 ;**Next line commented out - was causing selection screen to disappear 24 ; and automatically go on to detailed screen if there was only one 25 ; case for the patient 26 D ASK^RAUTL4 S:X="" X="^" 27 Q 28 SEL2 ; per RACNLU, check loc access, need split For Loop,swm080398 29 S RADIV=+$P(RANODE,"^",3),RAIMAGE=+$P(RANODE,"^",2) 30 S RADIV=+$G(^RA(79,RADIV,0)),RADIV=$P($G(^DIC(4,RADIV,0)),"^") 31 S:RADIV']"" RADIV="Unknown" 32 S RAIMAGE=$P($G(^RA(79.2,RAIMAGE,0)),"^") 33 S:RAIMAGE']"" RAIMAGE="Unknown" 34 I '$D(ORVP),($D(RANOSCRN)),('$D(RADUPSCN)) I $D(^TMP($J,"RA D-TYPE"))!($D(^TMP($J,"RA I-TYPE"))) Q:'$D(^TMP($J,"RA D-TYPE",RADIV))!('$D(^TMP($J,"RA I-TYPE",RAIMAGE))) ;this stmt taken from RACNLU 35 ; continue, since user has loc access 36 F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 I $D(^(RACNI,0)) S RACN=^(0) D PRT Q:X="^"!(X>0) 37 Q 38 PRT ; Screen only if entered through Rad/Nuc Med 39 I '$D(ORVP),'$D(RANOSCRN),'$D(RAOPT("DOSAGE TICKET")),'$D(RAOPT("UNCORRECTED REPORTS")) Q:$$IMGTY^RAUTL12("e",RADFN,RADTI)'=RAIMGTY 40 ; "Duplicate Dosage Ticket" option has its own screen 41 I $D(RAOPT("DOSAGE TICKET")) Q:$P($G(^RA(79.2,+$P(^RADPT(RADFN,"DT",RADTI,0),U,2),0)),U,5)'="Y" 42 S RARPT=+$P(RACN,"^",17) 43 Q:$D(RAOPT("UNCORRECTED REPORTS"))&('$O(^RARPT(RARPT,"ERR",0))) 44 S RAST=+$P(RACN,"^",3),RAPRC=$S($D(^RAMIS(71,+$P(RACN,"^",2),0)):$P(^(0),"^"),1:"Unknown"),RACN=+RACN S (RADTPRT,Y)=RADTE D D^RAUTL S RADATE=Y 45 S RAELOC=$P($G(^SC(+$P($G(^RA(79.1,+$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,4),0)),U),0)),U),RADTPRT=$E(RADTPRT,4,5)_"/"_$E(RADTPRT,6,7)_"/"_$E(RADTPRT,2,3) 46 S:RAELOC="" RAELOC="* MISSING *" 47 S RACNT=RACNT+1,^TMP($J,"RAEX",RACNT)=RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADATE_"^"_RADTE_"^"_RACN_"^"_RAPRC_"^"_RARPT_"^"_RAST 48 I $D(RAREPORT) D 49 . S RAIMGTYI=$$IMGTY^RAUTL12("e",RADFN,RADTI) 50 . S RASTP=$E($$GET1^DIQ(74,+RARPT,5),1,16) ;get all possible Rpt Statuss 51 . I RASTP="",RAIMGTYI'="" S RASTP=RASTP_$S($D(^RA(72,"AA",RAIMGTYI,0,+RAST)):" (Exam Dc'd)",1:"") 52 . Q 53 I '$D(RAREPORT) S RASTP=$S($D(^RA(72,RAST,0)):$P(^(0),"^"),1:"Unknown") 54 ; D:$$IMAGE^RARIC1 DISPA^MAGRIC ;don't call MAG 111300 55 N RAPRTSET,RAMEMLOW D EN1^RAUTL20 56 W !,RACNT,?5,$S(RAMEMLOW:"+",RAPRTSET:".",1:" "),?6,RACN,?11,$$IMGDISP(RARPT),?13,$E(RAPRC,1,26),?41,RADTPRT,?52,$E(RASTP,1,16),?69,$E(RAELOC,1,11) 57 I (($Y+6)>IOSL),($O(^RADPT(RADFN,"DT",RADTI,"P",RACNI))!($O(^RADPT(RADFN,"DT",RADTI)))) D ASK^RAUTL4 W @IOF 58 Q 59 ; 60 HD I '$D(RTFL) W @IOF,?25,RAHEAD,!!,"Patient's Name: ",$E(RANME,1,20)," ",RASSN,?55,"Run Date: " S Y=DT D DT^DIO2 61 I $D(RTFL) D ESC^RTRD:($Y+6)>IOSL Q:$D(RTESC) W !!,"============================ Exam Procedure Profile ==========================" 62 W !!?3,"Case No.",?13,"Procedure",?41,"Exam Date",?52,"Status of " W $S($D(RAREPORT):"Report",1:"Exam"),?69,"Imaging Loc" 63 W !?3,"--------",?13,"-------------",?41,"---------",?52,"----------------",?69,"-----------" Q 64 ; 65 PTUPD ;Update Patient Info 66 S DIC(0)="AEMQL" D ^RADPA K DIC,RAIC Q:Y<0 S DIE="^RADPT(",DA=+Y,DR=".04;1" D ^DIE 67 PTUPD0 K DIR S DIR(0)="SOMA^Y:YES;N:NO;",DIR("A")="CONTRAST MEDIUM ALLERGY: " 68 S ALLERGY=$$ORCHK^GMRAOR(DA,"CM") 69 I ALLERGY]"" S DIR("B")=$S(ALLERGY=1:"YES",1:"NO") 70 S DIR("?")="^D PTUPDH1^RAPTLU",DIR("??")="^D PTUPDH2^RAPTLU" 71 D ^DIR K DIR I $D(DIRUT) G PTUPDX 72 I ALLERGY'=$TR(Y,"YN","10") S X=0 D G:'X PTUPDX W " ??",$C(7) G PTUPD0 73 . I Y="N" S X=$$RACHK^GMRARAD(DA,Y) 74 . I Y="Y" S X=($$RADD^GMRARAD(DA,"p",Y)'>0) 75 . Q 76 PTUPDX K %,%Y,ALLERGY,C,D,D0,DA,DE,DQ,DIE,DIR,DR,RAPTFL,DIC,X,Y 77 Q 78 PTUPDH1 W !?5,"If this patient has had an allergic reaction to contrast medium, enter 'Y'" 79 W !?5,"for YES at this prompt. If not, enter 'N' for NO." 80 D PTUPDH3 81 Q 82 PTUPDH2 ; 83 W !?5,"The value in this field is used to indicate if this Radiology" 84 W !?5,"/Nuclear Medicine patient has had an allergic reaction to the contrast" 85 W !?5,"medium during a Radiology/Nuclear Medicine procedure. It may contain a" 86 W !?5,"'Y' for YES, or 'N' for NO. If YES, then a warning message is" 87 W !?5,"displayed to the receptionist whenever this patient is" 88 W !?5,"registered for a procedure that may involve contrast material." 89 D PTUPDH3 90 Q 91 PTUPDH3 W !?5,"CHOOSE FROM:" 92 W !?5," Y YES" 93 W !?5," N NO" 94 Q 95 IMGDISP(RARPT) ; Display "i" if an image is associated with the Rad/Nuc Med 96 ; Report. Called from RAPROS - Exam Profile (Selected Sort) 97 ; Input : RARPT - ien of the report 98 ; Output: "i" if an image exists, else null ("") 99 Q $S(+$O(^RARPT(RARPT,2005,0)):"i",1:"") 1 RAPTLU ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Patient's Exam Lookup ;11/13/00 09:13 2 ;;5.0;Radiology/Nuclear Medicine;**2,8,15,23**;Mar 16, 1998 3 ;*********************************************************************** 4 ; <<< NOTE >>> 5 ; 'RANOSCRN' is set in the entry actions of various options. 6 ; If the variable exists, the screen is ignored. Code is in line 7 ; label PRT+0. 8 ;*********************************************************************** 9 CASE D SEL S:'RACNT X="^" G Q:X="^"!($D(RAF1)) F I=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",I)=$P(Y,"^",I) 10 S ^DISV($S($D(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI,Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) 11 Q K RTESC,RTFL,RACNT,RAERR,RASTP,RAELOC,RADTPRT,^TMP("MAG",$J,"COL"),^TMP("MAG",$J,"ROW") Q 12 ; 13 SEL Q:'$D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$P(RANME,"^") K ^TMP($J,"RAEX") D HOME^%ZIS D HD S X="",RACNT=0 14 ;I $$IMAGE^RARIC1 D MED^MAGSET3,ERASE^MAGSET3 ;don't call MAG 111300 15 S X="" 16 F RADTI=0:0 Q:X="^"!(X>0) S RADTI=$O(^RADPT(RADFN,"DT",RADTI)) Q:RADTI'>0 I $D(^(RADTI,0)) S RANODE=^(0),RADTE=+^(0) D SEL2 ;swm080398 17 Q:X="^"!(X>0) I 'RACNT W !?3,*7,"No matches found!" Q 18 ;**Next line commented out - was causing selection screen to disappear 19 ; and automatically go on to detailed screen if there was only one 20 ; case for the patient 21 D ASK^RAUTL4 S:X="" X="^" 22 Q 23 SEL2 ; per RACNLU, check loc access, need split For Loop,swm080398 24 S RADIV=+$P(RANODE,"^",3),RAIMAGE=+$P(RANODE,"^",2) 25 S RADIV=+$G(^RA(79,RADIV,0)),RADIV=$P($G(^DIC(4,RADIV,0)),"^") 26 S:RADIV']"" RADIV="Unknown" 27 S RAIMAGE=$P($G(^RA(79.2,RAIMAGE,0)),"^") 28 S:RAIMAGE']"" RAIMAGE="Unknown" 29 I '$D(ORVP),($D(RANOSCRN)),('$D(RADUPSCN)) I $D(^TMP($J,"RA D-TYPE"))!($D(^TMP($J,"RA I-TYPE"))) Q:'$D(^TMP($J,"RA D-TYPE",RADIV))!('$D(^TMP($J,"RA I-TYPE",RAIMAGE))) ;this stmt taken from RACNLU 30 ; continue, since user has loc access 31 F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 I $D(^(RACNI,0)) S RACN=^(0) D PRT Q:X="^"!(X>0) 32 Q 33 PRT ; Screen only if entered through Rad/Nuc Med 34 I '$D(ORVP),'$D(RANOSCRN),'$D(RAOPT("DOSAGE TICKET")),'$D(RAOPT("UNCORRECTED REPORTS")) Q:$$IMGTY^RAUTL12("e",RADFN,RADTI)'=RAIMGTY 35 ; "Duplicate Dosage Ticket" option has its own screen 36 I $D(RAOPT("DOSAGE TICKET")) Q:$P($G(^RA(79.2,+$P(^RADPT(RADFN,"DT",RADTI,0),U,2),0)),U,5)'="Y" 37 S RARPT=+$P(RACN,"^",17) 38 Q:$D(RAOPT("UNCORRECTED REPORTS"))&('$O(^RARPT(RARPT,"ERR",0))) 39 S RAST=+$P(RACN,"^",3),RAPRC=$S($D(^RAMIS(71,+$P(RACN,"^",2),0)):$P(^(0),"^"),1:"Unknown"),RACN=+RACN S (RADTPRT,Y)=RADTE D D^RAUTL S RADATE=Y 40 S RAELOC=$P($G(^SC(+$P($G(^RA(79.1,+$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,4),0)),U),0)),U),RADTPRT=$E(RADTPRT,4,5)_"/"_$E(RADTPRT,6,7)_"/"_$E(RADTPRT,2,3) 41 S:RAELOC="" RAELOC="* MISSING *" 42 S RACNT=RACNT+1,^TMP($J,"RAEX",RACNT)=RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADATE_"^"_RADTE_"^"_RACN_"^"_RAPRC_"^"_RARPT_"^"_RAST 43 I $D(RAREPORT) D 44 . S RASTP=$S($D(^RARPT(RARPT,0)):$P(^(0),"^",5),1:"") 45 . S RAIMGTYI=$$IMGTY^RAUTL12("e",RADFN,RADTI) 46 . S RASTP=$S(RASTP="V":"VERIFIED",RASTP="PD":"PROBLEM DRAFT",RASTP="D":"DRAFT",RASTP="R":"RELEASED/NOT VERIFIED",1:"None") 47 . I RASTP="None",RAIMGTYI'="" S RASTP=RASTP_$S($D(^RA(72,"AA",RAIMGTYI,0,+RAST)):" (Exam Dc'd)",1:"") 48 . Q 49 I '$D(RAREPORT) S RASTP=$S($D(^RA(72,RAST,0)):$P(^(0),"^"),1:"Unknown") 50 ; D:$$IMAGE^RARIC1 DISPA^MAGRIC ;don't call MAG 111300 51 N RAPRTSET,RAMEMLOW D EN1^RAUTL20 52 W !,RACNT,?5,$S(RAMEMLOW:"+",RAPRTSET:".",1:" "),?6,RACN,?11,$$IMGDISP(RARPT),?13,$E(RAPRC,1,26),?41,RADTPRT,?52,$E(RASTP,1,16),?69,$E(RAELOC,1,11) 53 I (($Y+6)>IOSL),($O(^RADPT(RADFN,"DT",RADTI,"P",RACNI))!($O(^RADPT(RADFN,"DT",RADTI)))) D ASK^RAUTL4 W @IOF 54 Q 55 ; 56 HD I '$D(RTFL) W @IOF,?25,RAHEAD,!!,"Patient's Name: ",$E(RANME,1,20)," ",RASSN,?55,"Run Date: " S Y=DT D DT^DIO2 57 I $D(RTFL) D ESC^RTRD:($Y+6)>IOSL Q:$D(RTESC) W !!,"============================ Exam Procedure Profile ==========================" 58 W !!?3,"Case No.",?13,"Procedure",?41,"Exam Date",?52,"Status of " W $S($D(RAREPORT):"Report",1:"Exam"),?69,"Imaging Loc" 59 W !?3,"--------",?13,"-------------",?41,"---------",?52,"----------------",?69,"-----------" Q 60 ; 61 PTUPD ;Update Patient Info 62 S DIC(0)="AEMQL" D ^RADPA K DIC,RAIC Q:Y<0 S DIE="^RADPT(",DA=+Y,DR=".04;1" D ^DIE 63 PTUPD0 K DIR S DIR(0)="SOMA^Y:YES;N:NO;",DIR("A")="CONTRAST MEDIUM ALLERGY: " 64 S ALLERGY=$$ORCHK^GMRAOR(DA,"CM") 65 I ALLERGY]"" S DIR("B")=$S(ALLERGY=1:"YES",1:"NO") 66 S DIR("?")="^D PTUPDH1^RAPTLU",DIR("??")="^D PTUPDH2^RAPTLU" 67 D ^DIR K DIR I $D(DIRUT) G PTUPDX 68 I ALLERGY'=$TR(Y,"YN","10") S X=0 D G:'X PTUPDX W " ??",$C(7) G PTUPD0 69 . I Y="N" S X=$$RACHK^GMRARAD(DA,Y) 70 . I Y="Y" S X=($$RADD^GMRARAD(DA,"p",Y)'>0) 71 . Q 72 PTUPDX K %,%Y,ALLERGY,C,D,D0,DA,DE,DQ,DIE,DIR,DR,RAPTFL,DIC,X,Y 73 Q 74 PTUPDH1 W !?5,"If this patient has had an allergic reaction to contrast medium, enter 'Y'" 75 W !?5,"for YES at this prompt. If not, enter 'N' for NO." 76 D PTUPDH3 77 Q 78 PTUPDH2 ; 79 W !?5,"The value in this field is used to indicate if this Radiology" 80 W !?5,"/Nuclear Medicine patient has had an allergic reaction to the contrast" 81 W !?5,"medium during a Radiology/Nuclear Medicine procedure. It may contain a" 82 W !?5,"'Y' for YES, or 'N' for NO. If YES, then a warning message is" 83 W !?5,"displayed to the receptionist whenever this patient is" 84 W !?5,"registered for a procedure that may involve contrast material." 85 D PTUPDH3 86 Q 87 PTUPDH3 W !?5,"CHOOSE FROM:" 88 W !?5," Y YES" 89 W !?5," N NO" 90 Q 91 IMGDISP(RARPT) ; Display "i" if an image is associated with the Rad/Nuc Med 92 ; Report. Called from RAPROS - Exam Profile (Selected Sort) 93 ; Input : RARPT - ien of the report 94 ; Output: "i" if an image exists, else null ("") 95 Q $S(+$O(^RARPT(RARPT,2005,0)):"i",1:"") -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPXRM.m
r613 r623 1 RAPXRM ;HOIFO/SWM - API for Clinical Reminders ;10/1/03 09:33 2 ;;5.0;Radiology/Nuclear Medicine;**33,56**;Mar 16, 1998;Build 3 3 ; IA #3731 documents entry point EN1 4 ; IA #4113 grants use of rtn PXRMSXRM 5 ; IA #4114 grants use of direct Set and Kill, use of ^PXRMINDX(70 6 ;Supported IA #2056 GET1^DIQ 7 ;Supported IA #2052 GET1^DID 8 ;Supported IA #10141 BMES^XPDUTL, MES^XPDUTL 9 ;Supported IA #10103 NOW^XLFDT 10 EN1(RADAS,RARM) ;retrieve data from Clin. Rem.'s new style index "ACR" 11 ; Input: 12 ; RADAS = last subscript of (required), for example: 13 ; ^PXRMINDX(70,"IP",43,1,2,2920720.1049,"2;DT;7079279.895;P;3;0") 14 ; ^PXRMINDX(70,"PI",9,3,45,2921204.155,"9;DT;7078795.8449;P;1;0") 15 ; RARM = array name passed by reference (required) 16 ; Output: 17 ; RARM("aaa") = external value, eg.: 18 ; RARM("EXAM D/T") = Exam Date and time in yyymmdd.hhmm format 19 ; RARM("EXAM STATUS") = Exam Status name 20 ; RARM("PROCEDURE") = Procedure name 21 ; RARM("INTERPRETING PHYSICIAN") = Primary Staff; else Primary Resident 22 ; If exam node doesn't exist, then RARM is undefined 23 ; RARM("RPT STATUS") = Report status name 24 ; 25 K RARM ; clear output var 26 ; validate RADAS string 27 Q:$P(RADAS,";",2)'="DT" Q:$P(RADAS,";",4)'="P" Q:$P(RADAS,";",6)'="0" 28 N RA0,RADFN,RADTI,RACNI,X,I,J,RARPT 29 S RADFN=$P(RADAS,";"),RADTI=$P(RADAS,";",3),RACNI=$P(RADAS,";",5) 30 S RA0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 31 Q:RA0="" 32 S RARM("EXAM D/T")=9999999.9999-RADTI 33 S RARM("EXAM STATUS")=$P($G(^RA(72,+$P(RA0,U,3),0)),U) 34 S RARM("PROCEDURE")=$P($G(^RAMIS(71,+$P(RA0,U,2),0)),U) 35 S X=$S($P(RA0,U,15):+$P(RA0,U,15),$P(RA0,U,12):+$P(RA0,U,12),1:"") 36 S:X'="" X=$$GET1^DIQ(200,X,.01) 37 S RARM("INTERPRETING PHYSICIAN")=X 38 ; 39 ; RARM("PDX")=Primary DX text 40 ; this node won't exist if there's no data for Prim DX 41 ; RARM("SDX",n)=Secondary DX text at ^RADPT(-,"DT",-,"P",-,"DX",n,0) 42 ; the n may have gaps if a Secondary DX was deleted 43 ; 44 S RARPT=$P(RA0,U,17) S RARM("RPT STATUS")=$$UL^RAO7PC1A($$RSTAT^RAO7PC1A()) 45 S:$P(RA0,U,13)'="" RARM("PDX")=$P($G(^RA(78.3,+$P(RA0,U,13),0)),U) 46 S I=0 47 F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",I)) Q:'I I $D(^(I,0)) S J=+$G(^(0)) I J S RARM("SDX",I)=$P($G(^RA(78.3,J,0)),U) 48 Q 49 ;=============================================================== 50 ; RAD section copied from former location RAD^PXRMSXRO 51 RAD ;Build the index for RAD/NUC MED PATIENT. 52 N D0,D1,D2,DA,DAS,DFN,END,ENTRIES,GLOBAL,IND,NE,NERROR,PROC 53 N START,TEMP,TENP,TEXT 54 ;Don't leave any old stuff around. 55 K ^PXRMINDX(70) 56 S GLOBAL=$$GET1^DID(70,"","","GLOBAL NAME") 57 S ENTRIES=$P(^RADPT(0),U,4) 58 S TENP=ENTRIES/10 59 S TENP=+$P(TENP,".",1) 60 I TENP<1 S TENP=1 61 D BMES^XPDUTL("Building index for RAD DATA") 62 S TEXT="There are "_ENTRIES_" entries to process." 63 D MES^XPDUTL(TEXT) 64 S START=$H 65 S (D0,IND,NE,NERROR)=0 66 F S D0=+$O(^RADPT(D0)) Q:D0=0 D 67 . S IND=IND+1 68 . I IND#TENP=0 D 69 .. S TEXT="Processing entry "_IND 70 .. D MES^XPDUTL(TEXT) 71 . I IND#10000=0 W "." 72 . S DFN=$P($G(^RADPT(D0,0)),U,1) 73 . I DFN="" D Q 74 .. S ETEXT=D0_" no patient" 75 .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q 76 . S D1=0 77 . F S D1=+$O(^RADPT(D0,"DT",D1)) Q:D1=0 D 78 .. S DATE=$P($G(^RADPT(D0,"DT",D1,0)),U,1) 79 .. S DA=D0_";DT;"_D1 80 .. I DATE="" D Q 81 ... S ETEXT=DA_" no date" 82 ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q 83 .. S D2=0 84 .. F S D2=+$O(^RADPT(D0,"DT",D1,"P",D2)) Q:D2=0 D 85 ... S TEMP=$G(^RADPT(D0,"DT",D1,"P",D2,0)) 86 ... S DAS=DA_";P;"_D2_";0" 87 ... S PROC=$P(TEMP,U,2) 88 ... I PROC="" D Q 89 .... S ETEXT=DAS_" no procedure" 90 .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q 91 ... S ^PXRMINDX(70,"IP",PROC,DFN,DATE,DAS)="" 92 ... S ^PXRMINDX(70,"PI",DFN,PROC,DATE,DAS)="" 93 ... S NE=NE+1 94 S END=$H 95 S TEXT=NE_" RAD/NUC MED PATIENT results indexed." 96 D MES^XPDUTL(TEXT) 97 D DETIME^PXRMSXRM(START,END) 98 ;If there were errors send a message. 99 I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) 100 ;Send a MailMan message with the results. 101 D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR) 102 S ^PXRMINDX(70,"GLOBAL NAME")=$$GET1^DID(70,"","","GLOBAL NAME") 103 S ^PXRMINDX(70,"BUILT BY")=DUZ 104 S ^PXRMINDX(70,"DATE BUILT")=$$NOW^XLFDT 105 Q 106 ; 107 ;=============================================================== 108 KRAD(X,DA) ;Delete index for RAD/NUC MED PATIENT file. 109 N DAS,DATE 110 S DATE=9999999.9999-DA(1) 111 S DAS=DA(2)_";DT;"_DA(1)_";P;"_DA_";0" 112 K ^PXRMINDX(70,"IP",X(1),DA(2),DATE,DAS) 113 K ^PXRMINDX(70,"PI",DA(2),X(1),DATE,DAS) 114 Q 115 ; 116 ;=============================================================== 117 SRAD(X,DA) ;Set index for RAD/NUC MED PATIENT file. 118 ;DA(2)=DFN, DA(1)=EXAM DATE (inverse date), DA=Examinations Entry 119 ;X(1)=PROCEDURE 120 N DAS,DATE 121 S DATE=9999999.9999-DA(1) 122 S DAS=DA(2)_";DT;"_DA(1)_";P;"_DA_";0" 123 S ^PXRMINDX(70,"IP",X(1),DA(2),DATE,DAS)="" 124 S ^PXRMINDX(70,"PI",DA(2),X(1),DATE,DAS)="" 125 Q 126 ; 1 RAPXRM ;HOIFO/SWM - API for Clinical Reminders ;10/1/03 09:33 2 ;;5.0;Radiology/Nuclear Medicine;*33**;Mar 16, 1998 3 ; IA #3731 documents entry point EN1 4 ; IA #4113 grants use of rtn PXRMSXRM 5 ; IA #4114 grants use of direct Set and Kill, use of ^PXRMINDX(70 6 EN1(RADAS,RARM) ;retrieve data from Clin. Rem.'s new style index "ACR" 7 ; Input: 8 ; RADAS = last subscript of (required), for example: 9 ; ^PXRMINDX(70,"IP",43,1,2,2920720.1049,"2;DT;7079279.895;P;3;0") 10 ; ^PXRMINDX(70,"PI",9,3,45,2921204.155,"9;DT;7078795.8449;P;1;0") 11 ; RARM = array name passed by reference (required) 12 ; Output: 13 ; RARM("aaa") = external value, eg.: 14 ; RARM("EXAM D/T") = Exam Date and time in yyymmdd.hhmm format 15 ; RARM("EXAM STATUS") = Exam Status name 16 ; RARM("PROCEDURE") = Procedure name 17 ; RARM("INTERPRETING PHYSICIAN") = Primary Staff; else Primary Resident 18 ; If exam node doesn't exist, then RARM is undefined 19 ; 20 K RARM ; clear output var 21 ; validate RADAS string 22 Q:$P(RADAS,";",2)'="DT" Q:$P(RADAS,";",4)'="P" Q:$P(RADAS,";",6)'="0" 23 N RA0,RADFN,RADTI,RACNI,X,I,J 24 S RADFN=$P(RADAS,";"),RADTI=$P(RADAS,";",3),RACNI=$P(RADAS,";",5) 25 S RA0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 26 Q:RA0="" 27 S RARM("EXAM D/T")=9999999.9999-RADTI 28 S RARM("EXAM STATUS")=$P($G(^RA(72,+$P(RA0,U,3),0)),U) 29 S RARM("PROCEDURE")=$P($G(^RAMIS(71,+$P(RA0,U,2),0)),U) 30 S X=$S($P(RA0,U,15):+$P(RA0,U,15),$P(RA0,U,12):+$P(RA0,U,12),1:"") 31 S:X'="" X=$$GET1^DIQ(200,X,.01) 32 S RARM("INTERPRETING PHYSICIAN")=X 33 ; 34 ; RARM("PDX")=Primary DX text 35 ; this node won't exist if there's no data for Prim DX 36 ; RARM("SDX",n)=Secondary DX text at ^RADPT(-,"DT",-,"P",-,"DX",n,0) 37 ; the n may have gaps if a Secondary DX was deleted 38 ; 39 S:$P(RA0,U,13)'="" RARM("PDX")=$P($G(^RA(78.3,+$P(RA0,U,13),0)),U) 40 S I=0 41 F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",I)) Q:'I I $D(^(I,0)) S J=+$G(^(0)) I J S RARM("SDX",I)=$P($G(^RA(78.3,J,0)),U) 42 Q 43 ;=============================================================== 44 ; RAD section copied from former location RAD^PXRMSXRO 45 RAD ;Build the index for RAD/NUC MED PATIENT. 46 N D0,D1,D2,DA,DAS,DFN,END,ENTRIES,GLOBAL,IND,NE,NERROR,PROC 47 N START,TEMP,TENP,TEXT 48 ;Don't leave any old stuff around. 49 K ^PXRMINDX(70) 50 S GLOBAL=$$GET1^DID(70,"","","GLOBAL NAME") 51 S ENTRIES=$P(^RADPT(0),U,4) 52 S TENP=ENTRIES/10 53 S TENP=+$P(TENP,".",1) 54 I TENP<1 S TENP=1 55 D BMES^XPDUTL("Building index for RAD DATA") 56 S TEXT="There are "_ENTRIES_" entries to process." 57 D MES^XPDUTL(TEXT) 58 S START=$H 59 S (D0,IND,NE,NERROR)=0 60 F S D0=+$O(^RADPT(D0)) Q:D0=0 D 61 . S IND=IND+1 62 . I IND#TENP=0 D 63 .. S TEXT="Processing entry "_IND 64 .. D MES^XPDUTL(TEXT) 65 . I IND#10000=0 W "." 66 . S DFN=$P($G(^RADPT(D0,0)),U,1) 67 . I DFN="" D Q 68 .. S ETEXT=D0_" no patient" 69 .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q 70 . S D1=0 71 . F S D1=+$O(^RADPT(D0,"DT",D1)) Q:D1=0 D 72 .. S DATE=$P($G(^RADPT(D0,"DT",D1,0)),U,1) 73 .. S DA=D0_";DT;"_D1 74 .. I DATE="" D Q 75 ... S ETEXT=DA_" no date" 76 ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q 77 .. S D2=0 78 .. F S D2=+$O(^RADPT(D0,"DT",D1,"P",D2)) Q:D2=0 D 79 ... S TEMP=$G(^RADPT(D0,"DT",D1,"P",D2,0)) 80 ... S DAS=DA_";P;"_D2_";0" 81 ... S PROC=$P(TEMP,U,2) 82 ... I PROC="" D Q 83 .... S ETEXT=DAS_" no procedure" 84 .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q 85 ... S ^PXRMINDX(70,"IP",PROC,DFN,DATE,DAS)="" 86 ... S ^PXRMINDX(70,"PI",DFN,PROC,DATE,DAS)="" 87 ... S NE=NE+1 88 S END=$H 89 S TEXT=NE_" RAD/NUC MED PATIENT results indexed." 90 D MES^XPDUTL(TEXT) 91 D DETIME^PXRMSXRM(START,END) 92 ;If there were errors send a message. 93 I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) 94 ;Send a MailMan message with the results. 95 D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR) 96 S ^PXRMINDX(70,"GLOBAL NAME")=$$GET1^DID(70,"","","GLOBAL NAME") 97 S ^PXRMINDX(70,"BUILT BY")=DUZ 98 S ^PXRMINDX(70,"DATE BUILT")=$$NOW^XLFDT 99 Q 100 ; 101 ;=============================================================== 102 KRAD(X,DA) ;Delete index for RAD/NUC MED PATIENT file. 103 N DAS,DATE 104 S DATE=9999999.9999-DA(1) 105 S DAS=DA(2)_";DT;"_DA(1)_";P;"_DA_";0" 106 K ^PXRMINDX(70,"IP",X(1),DA(2),DATE,DAS) 107 K ^PXRMINDX(70,"PI",DA(2),X(1),DATE,DAS) 108 Q 109 ; 110 ;=============================================================== 111 SRAD(X,DA) ;Set index for RAD/NUC MED PATIENT file. 112 ;DA(2)=DFN, DA(1)=EXAM DATE (inverse date), DA=Examinations Entry 113 ;X(1)=PROCEDURE 114 N DAS,DATE 115 S DATE=9999999.9999-DA(1) 116 S DAS=DA(2)_";DT;"_DA(1)_";P;"_DA_";0" 117 S ^PXRMINDX(70,"IP",X(1),DA(2),DATE,DAS)="" 118 S ^PXRMINDX(70,"PI",DA(2),X(1),DATE,DAS)="" 119 Q 120 ; -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RART.m
r613 r623 1 RART ;HISC/CAH,FPT,GJC AISC/MJK,TMP,RMO-Reporting Menu ;11/16/98 15:02 2 ;;5.0;Radiology/Nuclear Medicine;**2,5,15,18,43,82,56**;Mar 16, 1998;Build 3 3 ;Private IA #4793 CREATE^WVRALINK 4 ;Supoprted IA #3544 ^VA(200,"ARC" 5 ;;last modification by SS for P18 June 15, 2000 6 3 ;;Verify a Report 7 N I5 8 D SET^RAPSET1 I $D(XQUIT) K XQUIT Q 9 I $D(RANOSCRN) S X=$$DIVLOC^RAUTL7() I X D Q QUIT 10 G:$D(^VA(200,"ARC","S",DUZ))!($D(^XUSEC("RA VERIFY",DUZ))) 30 11 G:$P(RAMDV,"^",18)=1 30 12 G:'$D(^VA(200,"ARC","R",DUZ)) 30 13 I $P(RAMDV,"^",18)'=1 W !!,$C(7),"Interpreting Residents are not allowed to verify reports." G Q 14 30 K RAUP S RAPGM=30,RAREPORT=1 D ^RACNLU G Q:X="^" I '$D(^RARPT(+RARPT,0)) W !!?2,$C(7),"No report available!" G 30 15 S I5=$P(^RARPT(+RARPT,0),"^",5) I "^V^EF^"[("^"_I5_"^") W !!?2,$C(7),"Report already ",$S(I5="V":"verified",1:"electronically filed") G 30 16 SS1 Q:$$VERONLY^RAUTL11=-1 ;P18 case info 17 31 S DIE("NO^")="",DA=RARPT,DR="[RA VERIFY REPORT ONLY]",DIE="^RARPT(" 18 S RAIMGTYI=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U) 19 I RAIMGTYJ']"" W !,"Error: Cannot determine imaging type of exam.",! K RAIMGTYI,RAIMGTYJ G @RAPGM 20 ; must lock both report AND case together, so to ensure 21 ; that a verified report has the correct diagnostic codes 22 S RAXIT=$$LOCK^RAUTL12(DIE,DA) ; lock Report 23 I RAXIT K RAXIT G @RAPGM 24 S RASAVDIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"",",RASAVDA(2)=RADFN,RASAVDA(1)=RADTI,RASAVDA=RACNI 25 ; rpt exists & locked, thus no need to lock at "DT" level because users 26 ; can only use 'report entry/edit' option to enter dx's for printsets 27 S RAXIT=$$LOCK^RAUTL12(RASAVDIE,.RASAVDA) ; lock case before asking REPORT STATUS 28 I RAXIT K RAXIT G @RAPGM 29 D ^DIE K DE,DQ,DR D UNLOCK^RAUTL12(DIE,DA) ; unlock Report 30 K DIE,RAXIT 31 S X=+$O(^RA(72,"AA",RAIMGTYJ,9,0)),DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," 32 S DR=13_$S(RACT'="V":"",'$D(^RA(72,X,.1)):"",$P(^(.1),"^",5)'="Y":"",1:"R")_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1 " 33 I RACT="V",($P($G(^RA(72,+X,.1)),"^",5)="Y") S DIE("NO^")="BACK" 34 D ^DIE 35 K DA,DE,DQ,DIE,DR 36 I $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)="" G UNL31 37 S DR="50///"_RACN 38 S DR(2,70.03)=13.1 39 S DR(3,70.14)=.01_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1" 40 S DA(1)=RADFN,DA=RADTI,DIE="^RADPT("_DA(1)_",""DT""," 41 D ^DIE 42 UNL31 ; copy then unlock 43 N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR 44 D EN2^RAUTL20(.RAMEMARR) 45 I RAPRTSET S RADRS=1,RAXIT=0 D COPY^RARTE2 ; copy diagnoses 46 D UNLOCK^RAUTL12(RASAVDIE,.RASAVDA) ; use params from PrimDiag's lock 47 K RASAVDIE,RASAVDA 48 K DA,DE,DQ,DIE,DR 49 32 K RAXIT 50 I $G(RAPGM)="GETRPT^RARTVER" I $E(RACT'="V"),($P(^RARPT(RARPT,0),U,14)]"") D RETURN^RARTVER2 51 PACS I (RACT="V")!(RACT="R") D TASK^RAHLO4 52 I "^V^EF^"[("^"_RACT_"^"),$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ;women's health 53 ; 54 I RAPGM="NXT^RABTCH1" G @RAPGM 55 TIME D:RACT="V" 56 .N RAHLTCPB S RAHLTCPB=1 D UPSTAT^RAUTL0 K RAAB 57 I $G(RARDX)="S" D 58 . D SAVE^RARTVER2 59 . I $G(RAPGM)="GETRPT^RARTVER" D 60 .. ; for 'On-line Verifying of Reports' default device selection is the 61 .. ; "REPORT PRINTER NAME" 62 .. S %ZIS("B")=$P($G(RAMLC),"^",10) K:%ZIS("B")']"" %ZIS("B") 63 .. Q 64 . D Q^RARTR,RESTORE^RARTVER2 65 . K:$D(%ZIS("B")) %ZIS("B") 66 . Q 67 G @RAPGM 68 Q K %,%DT,%X,C,D,D0,D1,DA,DIC,RACN,RACNI,RACT,RADATE,RADFN,RADTE,RADTI,RADUZ,RAHEAD,RAI,RAIMGTYI,RAIMGTYJ,RANME,RANUM,RAOR,RAPGM,RAPRC,RAQUIT,RAREPORT,RARPT,RASET,RASN,RASSN,RAST,RASTI,RAUP,RAVER,X,Y,^TMP($J,"RAEX") 69 K %W,%Y,%Y1,DDER,DI,DIROUT,DIRUT,DLAYGO,DTOUT,DUOUT,RACI,ZTSK,POP,DDH 70 Q 71 OERR1 ; Jump to 'OERR1^RART1' This is necessary to support the reference to 72 ; this line label in the OE/RR Notifications file. 73 G OERR1^RART1 Q 74 ; 75 PRTDX ; print dx codes on report display (called from RART1) 76 K RAFLG D WAIT^RART1:($Y+6)>IOSL&('$D(RARTVERF)) 77 Q:X="^"!(X="T")!(X="P") 78 S RADXCODE=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13) 79 W !?3,"Primary Diagnostic Code: ",!?2,$S($D(^RA(78.3,+RADXCODE,0)):$P(^(0),U,1),1:"") K RAFLG 80 D WAIT^RART1:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="T")!(X="P") 81 I '$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) W ! Q 82 W !!?3,"Secondary Diagnostic Codes: " 83 S RADXCODE=0 84 F S RADXCODE=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX","B",RADXCODE)) Q:RADXCODE'>0!('$D(^RA(78.3,+RADXCODE,0)))!($D(RAOOUT)) K RAFLG D WAIT^RART1:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="T")!(X="P") W !?2,$P(^RA(78.3,RADXCODE,0),U,1) 85 W ! 86 Q 87 EXIT ; Kill variables created when user prints 'Abnormal Rad/Nuc Med Report 88 ; Alert'. Variables are created when 'PRT^RARTR' is called. 89 K %X,%XX,%Y,%YY,A,DDER,DFN,DI,DIR,DIW,DIWI,DIWT,DIWTC,DIWX,DLAYGO 90 K DN,RACI,RACN0,RACPT,RACPTNDE,RADTE0,RADTV,RAN,RAOBR4,RAPRCNDE 91 K RAPROC,RAPROCIT,RAPRV,RARPT0,VA,VADM,VAERR,X2,ZTSK 92 Q 1 RART ;HISC/CAH,FPT,GJC AISC/MJK,TMP,RMO-Reporting Menu ;11/16/98 15:02 2 ;;5.0;Radiology/Nuclear Medicine;**2,5,15,18,43,82**;Mar 16, 1998;Build 8 3 ;;last modification by SS for P18 June 15, 2000 4 3 ;;Verify a Report 5 D SET^RAPSET1 I $D(XQUIT) K XQUIT Q 6 I $D(RANOSCRN) S X=$$DIVLOC^RAUTL7() I X D Q QUIT 7 G:$D(^VA(200,"ARC","S",DUZ))!($D(^XUSEC("RA VERIFY",DUZ))) 30 8 G:$P(RAMDV,"^",18)=1 30 9 G:'$D(^VA(200,"ARC","R",DUZ)) 30 10 I $P(RAMDV,"^",18)'=1 W !!,$C(7),"Interpreting Residents are not allowed to verify reports." G Q 11 30 K RAUP S RAPGM=30,RAREPORT=1 D ^RACNLU G Q:X="^" I '$D(^RARPT(+RARPT,0)) W !!?2,$C(7),"No report available!" G 30 12 I $P(^RARPT(+RARPT,0),"^",5)="V" W !!?2,$C(7),"Report already verified!" G 30 13 SS1 Q:$$VERONLY^RAUTL11=-1 ;P18 case info 14 31 S DIE("NO^")="",DA=RARPT,DR="[RA VERIFY REPORT ONLY]",DIE="^RARPT(" 15 S RAIMGTYI=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U) 16 I RAIMGTYJ']"" W !,"Error: Cannot determine imaging type of exam.",! K RAIMGTYI,RAIMGTYJ G @RAPGM 17 ; must lock both report AND case together, so to ensure 18 ; that a verified report has the correct diagnostic codes 19 S RAXIT=$$LOCK^RAUTL12(DIE,DA) ; lock Report 20 I RAXIT K RAXIT G @RAPGM 21 S RASAVDIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"",",RASAVDA(2)=RADFN,RASAVDA(1)=RADTI,RASAVDA=RACNI 22 ; rpt exists & locked, thus no need to lock at "DT" level because users 23 ; can only use 'report entry/edit' option to enter dx's for printsets 24 S RAXIT=$$LOCK^RAUTL12(RASAVDIE,.RASAVDA) ; lock case before asking REPORT STATUS 25 I RAXIT K RAXIT G @RAPGM 26 D ^DIE K DE,DQ,DR D UNLOCK^RAUTL12(DIE,DA) ; unlock Report 27 K DIE,RAXIT 28 S X=+$O(^RA(72,"AA",RAIMGTYJ,9,0)),DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," 29 S DR=13_$S(RACT'="V":"",'$D(^RA(72,X,.1)):"",$P(^(.1),"^",5)'="Y":"",1:"R")_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1 " 30 I RACT="V",($P($G(^RA(72,+X,.1)),"^",5)="Y") S DIE("NO^")="BACK" 31 D ^DIE 32 K DA,DE,DQ,DIE,DR 33 I $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)="" G UNL31 34 S DR="50///"_RACN 35 S DR(2,70.03)=13.1 36 S DR(3,70.14)=.01_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1" 37 S DA(1)=RADFN,DA=RADTI,DIE="^RADPT("_DA(1)_",""DT""," 38 D ^DIE 39 UNL31 ; copy then unlock 40 N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR 41 D EN2^RAUTL20(.RAMEMARR) 42 I RAPRTSET S RADRS=1,RAXIT=0 D COPY^RARTE2 ; copy diagnoses 43 D UNLOCK^RAUTL12(RASAVDIE,.RASAVDA) ; use params from PrimDiag's lock 44 K RASAVDIE,RASAVDA 45 K DA,DE,DQ,DIE,DR 46 32 K RAXIT 47 I $G(RAPGM)="GETRPT^RARTVER" I $E(RACT'="V"),($P(^RARPT(RARPT,0),U,14)]"") D RETURN^RARTVER2 48 PACS I (RACT="V")!(RACT="R") D TASK^RAHLO4 49 I RACT="V",$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ;women's health 50 ; 51 I RAPGM="NXT^RABTCH1" G @RAPGM 52 TIME D:RACT="V" 53 .N RAHLTCPB S RAHLTCPB=1 D UPSTAT^RAUTL0 K RAAB 54 I $G(RARDX)="S" D 55 . D SAVE^RARTVER2 56 . I $G(RAPGM)="GETRPT^RARTVER" D 57 .. ; for 'On-line Verifying of Reports' default device selection is the 58 .. ; "REPORT PRINTER NAME" 59 .. S %ZIS("B")=$P($G(RAMLC),"^",10) K:%ZIS("B")']"" %ZIS("B") 60 .. Q 61 . D Q^RARTR,RESTORE^RARTVER2 62 . K:$D(%ZIS("B")) %ZIS("B") 63 . Q 64 G @RAPGM 65 Q K %,%DT,%X,C,D,D0,D1,DA,DIC,RACN,RACNI,RACT,RADATE,RADFN,RADTE,RADTI,RADUZ,RAHEAD,RAI,RAIMGTYI,RAIMGTYJ,RANME,RANUM,RAOR,RAPGM,RAPRC,RAQUIT,RAREPORT,RARPT,RASET,RASN,RASSN,RAST,RASTI,RAUP,RAVER,X,Y,^TMP($J,"RAEX") 66 K %W,%Y,%Y1,DDER,DI,DIROUT,DIRUT,DLAYGO,DTOUT,DUOUT,RACI,ZTSK,POP,DDH 67 Q 68 OERR1 ; Jump to 'OERR1^RART1' This is necessary to support the reference to 69 ; this line label in the OE/RR Notifications file. 70 G OERR1^RART1 Q 71 ; 72 PRTDX ; print dx codes on report display (called from RART1) 73 K RAFLG D WAIT^RART1:($Y+6)>IOSL&('$D(RARTVERF)) 74 Q:X="^"!(X="T")!(X="P") 75 S RADXCODE=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13) 76 W !?3,"Primary Diagnostic Code: ",!?2,$S($D(^RA(78.3,+RADXCODE,0)):$P(^(0),U,1),1:"") K RAFLG 77 D WAIT^RART1:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="T")!(X="P") 78 I '$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) W ! Q 79 W !!?3,"Secondary Diagnostic Codes: " 80 S RADXCODE=0 81 F S RADXCODE=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX","B",RADXCODE)) Q:RADXCODE'>0!('$D(^RA(78.3,+RADXCODE,0)))!($D(RAOOUT)) K RAFLG D WAIT^RART1:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="T")!(X="P") W !?2,$P(^RA(78.3,RADXCODE,0),U,1) 82 W ! 83 Q 84 EXIT ; Kill variables created when user prints 'Abnormal Rad/Nuc Med Report 85 ; Alert'. Variables are created when 'PRT^RARTR' is called. 86 K %X,%XX,%Y,%YY,A,DDER,DFN,DI,DIR,DIW,DIWI,DIWT,DIWTC,DIWX,DLAYGO 87 K DN,RACI,RACN0,RACPT,RACPTNDE,RADTE0,RADTV,RAN,RAOBR4,RAPRCNDE 88 K RAPROC,RAPROCIT,RAPRV,RARPT0,VA,VADM,VAERR,X2,ZTSK 89 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTE.m
r613 r623 1 RARTE ;HISC/FPT,GJC AISC/MJK,RMO-Edit/Delete Reports ;8/4/97 09:09 2 ;;5.0;Radiology/Nuclear Medicine;**18,34,45,56**;Mar 16, 1998;Build 3 3 ;Supported IA #3544 ^VA(200,"ARC" 4 ;Supported IA #10076 ^XUSEC( 5 ;Supported IA #2056 ^GET1^DIQ 6 ;Supported IA #10009 YN^DICN 7 ; last modification by SS for P18 June 14,2000 8 D SET^RAPSET1 I $D(XQUIT) K XQUIT Q 9 W !!?3,"Note: To enter receipt of OUTSIDE INTERPRETED REPORTS,",!?3,"please use the 'Outside Report/Entry Edit' option.",! 10 N RAXIT,RADRS,RASUBY0 S RAXIT=0 ;RADRS=copy (1=diag, 2=resid,staff) 11 I $D(RANOSCRN) S X=$$DIVLOC^RAUTL7() I X D Q^RARTE4 QUIT 12 ; 13 ;1. DO NOT KILL the RASIG variable; the RASIG() array is needed in 14 ; the edit template [RA REPORT EDIT] later 15 ;2. The RAELESIG canNOT store file 74's ien, as no rpt has been picked 16 ; from this call to ES^RASIGU 17 ; 18 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) 19 . W ! D ES^RASIGU S:%=1 RAELESIG="" 20 . K:'$D(RAELESIG) %,%W,%Y,%Y1,C,X,X1,X2 21 . Q 22 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",! 23 START K RAVER S RAVW="",RAREPORT=1 D ^RACNLU G Q^RARTE4:"^"[X 24 S RASUBY0=Y(0) ; save value of y(0) 25 G:$P(^RA(72,+RAST,0),"^",3)>0 DISPLAY 26 I $D(^XUSEC("RA MGR",DUZ)) G DISPLAY 27 G:$P(RAMDV,"^",22)=1 DISPLAY 28 W $C(7),!!,"The STATUS for this case is CANCELLED. You may not enter a report.",!! D INCRPT^RARTE4 G START 29 ; 30 DISPLAY ; Display exam specific info, edit/enter the report 31 N RA18EX S RA18EX=0 ;P18 for quit if uparrow inside PUTTCOM 32 I '($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))#2) D D Q^RARTE4 QUIT 33 . W !!?2,"Case #: ",RACN," for ",RANME S RAXIT=1 34 . W !?2,"Procedure: '",$E(RAPRC,1,45),"' has been deleted" 35 . W !?2,"by another user!",$C(7) 36 . Q 37 ;Lock case node so no one else can edit rpt pointer during this session 38 S RAPNODE="^RADPT("_RADFN_",""DT"","_RADTI_",""P""," 39 S RAXIT=$$LOCK^RAUTL12(RAPNODE,RACNI) I RAXIT D INCRPT^RARTE4 G START 40 S RAI="",$P(RAI,"-",80)="" W !,RAI 41 W !?1,"Name : ",$E(RANME,1,25),?40,"Pt ID : ",RASSN 42 W !?1,"Case No. : ",RACN,?18,"Exm. St: ",$E($P($G(^RA(72,+RAST,0)),"^"),1,12),?40,"Procedure : ",$E(RAPRC,1,25) 43 ;check for contrast media; display if CM data exists (patch 45) 44 S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI) 45 D:$L(RACMDATA) CMEDIA(RACMDATA) 46 K RACMDATA 47 S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,RACN," Tech.Comment: ",15,70,-1,0) ;P18 48 I RA18EX=-1 Q ;P18 49 N RAPRTSET,RAMEMARR,RA1 50 D EN2^RAUTL20(.RAMEMARR) 51 I RAPRTSET D 52 . S RA1="" 53 . F S RA1=$O(RAMEMARR(RA1)) Q:RA1=""!(RA18EX=-1) I RA1'=RACNI D 54 .. W !,?1,"Case No. : ",+RAMEMARR(RA1) 55 .. W:$P(RAMEMARR(RA1),"^",4)]"" ?18,"Exm. St: ",$E($P($G(^RA(72,$P(RAMEMARR(RA1),"^",4),0)),"^"),1,12) 56 .. W ?40,"Procedure : ",$E($P($G(^RAMIS(71,+$P(RAMEMARR(RA1),"^",2),0)),"^"),1,26) 57 ..;check printset for contrast media; display if CM data exists 58 ..S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RA1) 59 ..D:$L(RACMDATA) CMEDIA(RACMDATA) 60 ..K RACMDATA 61 .. S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,+RAMEMARR(RA1)," Tech.Comment: ",15,70,-1,0) Q:RA18EX=-1 ;P18 62 .. Q 63 . Q 64 SS1 I RA18EX=-1 Q ;P18 65 S Y(0)=RASUBY0 66 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) 67 W !?40,"Req Phys : ",$E($S($D(^VA(200,+$P(Y(0),"^",14),0)):$P(^(0),"^"),1:""),1,25),!,RAI 68 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 69 ;Create new rpt, or skip to IN to edit existing report 70 G IN^RARTE4:$D(^RARPT(+RARPT,0)) 71 G:'RAPRTSET NEW G:$P(^RA(72,+RAST,0),"^",3)>0 NEW 72 ; case is part of a print set, AND is cancelled 73 N RA2 S (RA1,RA2)="" 74 F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" S:$P(RAMEMARR(RA1),"^",3)]"" RA2=$P(RAMEMARR(RA1),"^",3) 75 G:RA2="" NEW 76 W !!,$C(7),"Other cases of this cancelled case ",RACN,"'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." 77 W !!,"Do you want to include this cancelled case in the same report",!,"as the others in the print set ?" 78 S %=2 D YN^DICN 79 W:%>0 "...",$S(%=1:"Include",1:"Skip")," this case" 80 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 81 D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT^RARTE4 G START 82 NEW G:'RAPRTSET NEW1 83 L +^RADPT(RADFN,"DT",RADTI):0 G:$T NEW1 84 W !!?10,$C(7),"** This case belongs to a printset,",?68,"**",!?10,"** and someone else is currently doing REPORT ENTRY/EDIT",?68,"**" 85 W !?10,"** on another case for this same printset,",?68,"**",!?10,"** so you may not enter a new report.",?68,"**" 86 H 2 D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT^RARTE4 G START 87 NEW1 S RARPTN=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN 88 W !?3,"...report not entered for this exam...",!?10,"...will now initialize report entry..." 89 S I=+$P(^RARPT(0),"^",3) 90 G LOCK^RARTE4 91 Q 92 ; 93 CMEDIA(X) ;check if contrast media is associated with the report (exam) 94 ;variables assumed to exist X: the string of contrast media used 95 ;delimited by the comma. 96 N Y W !," Contrast :" 97 F Y=1:1 Q:$P(X,", ",Y)="" W ?12,$P(X,", ",Y) W:$P(X,", ",Y+1)'="" ! 98 Q 1 RARTE ;HISC/FPT,GJC AISC/MJK,RMO-Edit/Delete Reports ;8/4/97 09:09 2 ;;5.0;Radiology/Nuclear Medicine;**18,34,45**;Mar 16, 1998 3 ; last modification by SS for P18 June 14,2000 4 D SET^RAPSET1 I $D(XQUIT) K XQUIT Q 5 N RAXIT,RADRS,RASUBY0 S RAXIT=0 ;RADRS=copy (1=diag, 2=resid,staff) 6 I $D(RANOSCRN) S X=$$DIVLOC^RAUTL7() I X D Q^RARTE4 QUIT 7 ; 8 ;1. DO NOT KILL the RASIG variable; the RASIG() array is needed in 9 ; the edit template [RA REPORT EDIT] later 10 ;2. The RAELESIG canNOT store file 74's ien, as no rpt has been picked 11 ; from this call to ES^RASIGU 12 ; 13 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) 14 . W ! D ES^RASIGU S:%=1 RAELESIG="" 15 . K:'$D(RAELESIG) %,%W,%Y,%Y1,C,X,X1,X2 16 . Q 17 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",! 18 START K RAVER S RAVW="",RAREPORT=1 D ^RACNLU G Q^RARTE4:"^"[X 19 S RASUBY0=Y(0) ; save value of y(0) 20 G:$P(^RA(72,+RAST,0),"^",3)>0 DISPLAY 21 I $D(^XUSEC("RA MGR",DUZ)) G DISPLAY 22 G:$P(RAMDV,"^",22)=1 DISPLAY 23 W $C(7),!!,"The STATUS for this case is CANCELLED. You may not enter a report.",!! D INCRPT^RARTE4 G START 24 ; 25 DISPLAY ; Display exam specific info, edit/enter the report 26 N RA18EX S RA18EX=0 ;P18 for quit if uparrow inside PUTTCOM 27 I '($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))#2) D D Q^RARTE4 QUIT 28 . W !!?2,"Case #: ",RACN," for ",RANME S RAXIT=1 29 . W !?2,"Procedure: '",$E(RAPRC,1,45),"' has been deleted" 30 . W !?2,"by another user!",$C(7) 31 . Q 32 ;Lock case node so no one else can edit rpt pointer during this session 33 S RAPNODE="^RADPT("_RADFN_",""DT"","_RADTI_",""P""," 34 S RAXIT=$$LOCK^RAUTL12(RAPNODE,RACNI) I RAXIT D INCRPT^RARTE4 G START 35 S RAI="",$P(RAI,"-",80)="" W !,RAI 36 W !?1,"Name : ",$E(RANME,1,25),?40,"Pt ID : ",RASSN 37 W !?1,"Case No. : ",RACN,?18,"Exm. St: ",$E($P($G(^RA(72,+RAST,0)),"^"),1,12),?40,"Procedure : ",$E(RAPRC,1,25) 38 ;check for contrast media; display if CM data exists (patch 45) 39 S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI) 40 D:$L(RACMDATA) CMEDIA(RACMDATA) 41 K RACMDATA 42 S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,RACN," Tech.Comment: ",15,70,-1,0) ;P18 43 I RA18EX=-1 Q ;P18 44 N RAPRTSET,RAMEMARR,RA1 45 D EN2^RAUTL20(.RAMEMARR) 46 I RAPRTSET D 47 . S RA1="" 48 . F S RA1=$O(RAMEMARR(RA1)) Q:RA1=""!(RA18EX=-1) I RA1'=RACNI D 49 .. W !,?1,"Case No. : ",+RAMEMARR(RA1) 50 .. W:$P(RAMEMARR(RA1),"^",4)]"" ?18,"Exm. St: ",$E($P($G(^RA(72,$P(RAMEMARR(RA1),"^",4),0)),"^"),1,12) 51 .. W ?40,"Procedure : ",$E($P($G(^RAMIS(71,+$P(RAMEMARR(RA1),"^",2),0)),"^"),1,26) 52 ..;check printset for contrast media; display if CM data exists 53 ..S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RA1) 54 ..D:$L(RACMDATA) CMEDIA(RACMDATA) 55 ..K RACMDATA 56 .. S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,+RAMEMARR(RA1)," Tech.Comment: ",15,70,-1,0) Q:RA18EX=-1 ;P18 57 .. Q 58 . Q 59 SS1 I RA18EX=-1 Q ;P18 60 S Y(0)=RASUBY0 61 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) 62 W !?40,"Req Phys : ",$E($S($D(^VA(200,+$P(Y(0),"^",14),0)):$P(^(0),"^"),1:""),1,25),!,RAI 63 I $D(^RARPT(+RARPT,0)),$P(^(0),"^",5)="V" W !?3,$C(7),"Report has already been verified!",! D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT^RARTE4 G START 64 ;Create new rpt, or skip to IN to edit existing report 65 G IN^RARTE4:$D(^RARPT(+RARPT,0)) 66 G:'RAPRTSET NEW G:$P(^RA(72,+RAST,0),"^",3)>0 NEW 67 ; case is part of a print set, AND is cancelled 68 N RA2 S (RA1,RA2)="" 69 F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" S:$P(RAMEMARR(RA1),"^",3)]"" RA2=$P(RAMEMARR(RA1),"^",3) 70 G:RA2="" NEW 71 W !!,$C(7),"Other cases of this cancelled case ",RACN,"'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." 72 W !!,"Do you want to include this cancelled case in the same report",!,"as the others in the print set ?" 73 S %=2 D YN^DICN 74 W:%>0 "...",$S(%=1:"Include",1:"Skip")," this case" 75 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 76 D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT^RARTE4 G START 77 NEW G:'RAPRTSET NEW1 78 L +^RADPT(RADFN,"DT",RADTI):0 G:$T NEW1 79 W !!?10,$C(7),"** This case belongs to a printset,",?68,"**",!?10,"** and someone else is currently doing REPORT ENTRY/EDIT",?68,"**" 80 W !?10,"** on another case for this same printset,",?68,"**",!?10,"** so you may not enter a new report.",?68,"**" 81 H 2 D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT^RARTE4 G START 82 NEW1 S RARPTN=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN 83 W !?3,"...report not entered for this exam...",!?10,"...will now initialize report entry..." 84 S I=+$P(^RARPT(0),"^",3) 85 G LOCK^RARTE4 86 Q 87 ; 88 CMEDIA(X) ;check if contrast media is associated with the report (exam) 89 ;variables assumed to exist X: the string of contrast media used 90 ;delimited by the comma. 91 N Y W !," Contrast :" 92 F Y=1:1 Q:$P(X,", ",Y)="" W ?12,$P(X,", ",Y) W:$P(X,", ",Y+1)'="" ! 93 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTE1.m
r613 r623 1 RARTE1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Edit/Delete a Report ;6/10/98 16:08 2 ;;5.0;Radiology/Nuclear Medicine;**2,15,17,23,31,68,56**;Mar 16, 1998;Build 3 3 ;Private IA #4793 DELETE^WVRALINK, CREATE^WVRALINK 4 ;Supported IA #10035 5 ;Supported IA #10007 6 ;11/07/2005 KAM/BAY 110020 - Correct DUZ ID from Talk Technology 7 ; During the Unverify process 8 DEL D SET^RAPSET1 I $D(XQUIT) K XQUIT Q 9 S (RAPRG74,RAXIT)=0 10 S DIC("A")="Select Report Day-Case#: " 11 S DIC("W")="S RA0=^(0) W "" "",$S($D(^DPT(+$P(RA0,""^"",2),0)):$P(^(0),""^""),1:""Unknown"") K RA0 W "" "",$$FLD^RARTFLDS(+Y,""PROC"")" 12 S DIC("S")="I $P(^(0),U,5)'=""X""" ;select only non-deleted reports 13 S DIC="^RARPT(",DIC(0)="AEMQZ" D ^DIC K DIC G END:Y<0 14 S RA0=Y(0),(DA,RAIEN)=+Y 15 I $O(^RARPT(RAIEN,2005,0)) D D END Q 16 . W !!?5,"Cannot delete a report that is associated with an image." 17 . W !?5,"Contact your Imaging Coordinator for further assistance.",! 18 . S DIR(0)="E",DIR("A")="Press RETURN to continue" 19 . D ^DIR K DIR,DIRUT,DUOUT 20 . Q ;08/23/00 21 D CHK17^RARTE3 ;see this subroutine for values of RAOK 22 G:RAOK=1 END ;can't del rpt w/o RACN or RACNI so avoid err at UP1^RAUTL1 23 S RAXIT=$$LOCK^RAUTL12("^RARPT(",RAIEN) 24 I RAXIT K RAXIT D END Q ; record locked by another 25 ASKDEL ; ask if deletion is appropriate 26 R !!,"Do you wish to delete this report? NO// ",X:DTIME 27 S:'$T!(X="")!(X["^") X="N" 28 I "Nn"[$E(X) D UNLOCK^RAUTL12("^RARPT(",RAIEN) G DEL 29 I "Yy"'[$E(X) D G ASKDEL 30 . W:X'["?" $C(7) 31 . W !!?3,"Enter 'YES' to delete this report, or 'NO' not to." 32 . Q 33 ; comment out next line, these 3 vars are already set by CHK17^RARTE3 34 ;S RADFN=+$P(RA0,"^",2),RADTI=9999999.9999-$P(RA0,"^",3),RACN=$P(RA0,"^",4) 35 G:RAOK=2 AD2 ;don't remove piece 17 if rpt doesn't match exm's rpt ptr 36 ; del other member's REPORT TEXT xrefs, and set pointer to #74 as null 37 D DEL17^RARTE2(RAIEN) ;del ptrs to file 74 excluding lead case of prtset 38 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) 39 G:'$D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0))#2 AD2 40 ; kill any xrefs for file #70's REPORT TEXT 41 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI D ENKILL^RAXREF(70.03,17,RAIEN,.DA) 42 ; set REPORT TEXT to null 43 S $P(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0),"^",17)="" 44 AD2 K RAXIT S RAPRG74=1 ;RAPRG74 used in kill logic file 74 fld .01 45 D MARKDEL^RARTE7 ; mark report deleted, save DXs, remov DXs fm case(s) 46 W !?10,"...report deletion complete." 47 D:RAOK'=2 UP1^RAUTL1 ;skip update status if report doesn't belong to exm 48 D UPDTPNT^RAUTL9(RAIEN) ; Update pointers in 74.2, and 74.4! 49 D UNLOCK^RAUTL12("^RARPT(",RAIEN) ; unlock report 50 I RAOK'=2,$T(DELETE^WVRALINK)]"" D DELETE^WVRALINK(RADFN,RADTI,RACNI) ; women's health, skip if report doesn't belong to exm 51 END K %,%Y,D0,DA,DIC,DIE,RAJ1,DIK,RADFN,RADTI,RACN,RACNI,RA0,RAIEN,RAOR 52 K RADUZ,RAORDIFN,RAPRG74,RASN,RASTI,Y 53 K RADATE,RADTE,X 54 K RA791,RACANC,RACN0,RACPT,RACPTNDE,RAI,RAN,RAOBR4,RAPKG,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RASULT,RAXIT 55 K C,D,D1,DDER,DDH,DFN,DI,DISYS,DIWF,DIWL,DIWR,DQ,DR,GMRAL,HLN,HLRESLT,HLSAN,I,VA,VADM,VAERR,X0 56 Q 57 ; 58 UNVER(RAXRPT) ; unverify a report 59 ; Input: if RAXRPT>0 then we know the report we wish to delete 60 ; this requires no user interaction. 61 ; RAXRPT=0 user is prompted for the report they wish to 62 ; delete (interactive) 63 ; 64 I 'RAXRPT D SET^RAPSET1 G Q:$D(XQUIT) 65 I RAXRPT N X S X=RAXRPT 66 S RAXIT=0,DIC="^RARPT(",DIC("S")="I $P(^(0),U,5)=""V""" 67 S DIC(0)=$S('RAXRPT:"AEMQZ",1:"NZ") 68 D DICW,^DIC K DIC I Y<0 D Q Q 69 S RA74B4=$G(Y(0)) 70 S (RARPT,DA)=+Y,RADFN=$P(Y(0),U,2) 71 S RADTI=9999999.9999-$P(Y(0),"^",3),RACN=$P(Y(0),"^",4) 72 I 'RAXRPT S DR="D EN1^RAUTL9 I $D(DIRUT) S Y=""@99"";S:RASTATX'=""PD"" Y=""@10"";25;@10;5////^S X=RASTATX;S:X=""V"" Y=""@99"";9///@;17///@;100///NOW;@99" 73 S:RAXRPT DR="5////^S X=""D"";9///@;17///@;100///NOW" 74 ;11/07/2005 KAM/BAY 110020 Modified next line to look for voice recognition 75 S DIE="^RARPT(",DR(2,74.01)="2////U;3////"_$S(($D(RAQUIET)#2)&($D(RASUB)#2):$G(^TMP("RARPT-REC",$J,RASUB,"RAVERF")),1:DUZ) 76 S RAXIT=$$LOCK^RAUTL12("^RARPT(",RARPT) 77 I RAXIT D Q QUIT 78 D ^DIE K DE,DQ,DIE,DR D UNLOCK^RAUTL12("^RARPT(",RARPT) 79 N RA1,RA2,RA3,RA4 S RA1=RADFN,RA2=RADTI,RA3=RACN,RA4=RARPT 80 S RA(0)=$G(^RARPT(RARPT,0)),RA(5)=$P(^RARPT(RARPT,0),"^",5) 81 S RA(7)=$P(^RARPT(RARPT,0),"^",7),RA(10)=$P(^RARPT(RARPT,0),"^",10) 82 I RA(5)'="V" D 83 . I RA(7)]"" D ENKILL^RAXREF(74,7,RA(7),RARPT) S $P(^RARPT(RARPT,0),"^",7)="" 84 . I RA(10)]"" D ENKILL^RAXREF(74,10,RA(10),RARPT) S $P(^RARPT(RARPT,0),"^",10)="" 85 . N RADDEN,RAUTOE S (RADDEN,RAUTOE)="" D ^RARTR,EN1^RARTE3(RA4) 86 . Q 87 S RADFN=RA1,RADTI=RA2,RACN=RA3,RARPT=RA4 88 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) I $D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0)) D UP1^RAUTL1 I $D(^RABTCH(74.4,"B",RARPT)) D 89 .S DA=0 F S DA=$O(^RABTCH(74.4,"B",RARPT,DA)) Q:'DA D 90 ..S DIK="^RABTCH(74.4," D ^DIK 91 ..Q 92 .Q 93 I "^V^EF^"'[("^"_$P($G(^RARPT(RARPT,0)),"^",5)_"^"),$T(DELETE^WVRALINK)]"" D DELETE^WVRALINK(RADFN,RADTI,RACNI) ; women's health 94 ; 95 Q ; Kill and quit 96 K DFN,DI,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,RAACNT,RANUM,RAST,RAWHOVER 97 K %,%DT,%W,%Y,%Y1,C,D,D0,D1,DA,DIC,DIE,DIK,DR,RA,RACN,RACNI,RADATE 98 K RADFN,RADIV,RADTE,RADTI,RAJ,RAOR,RAORDIFN,RARPT,RASET,RASN,RASTATX 99 K RASTI,RAXIT,X,XQUIT,Y,RA74B4,DDH,DIPGM,DISYS,I,RADUZ 100 Q 101 ; 102 STD S (RALR,RALI)=1 103 STD1 S DIC="^RA(74.1,",DIC("A")="Select 'Standard' Report to Copy: ",DIC(0)="AEMQ" D ^DIC K DIC("A") Q:Y<0 104 ASKSEL W:$$IMPRPT(RARPT) !!,"Report already exists. This will over-write it." 105 W !,"Are you sure you want the '",$P(Y,"^",2),"' standard report? No// " R X:DTIME G STD1:'$T!(X="")!(X["^")!("Nn"[$E(X)) 106 I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to select the '",$P(Y,"^",2),"' standard report, or 'NO' not to." G ASKSEL 107 I RALR=1,RALI=1 K ^RARPT(RARPT,"R"),^("I") 108 F I=1:1 Q:'$D(^RA(74.1,+Y,"R",I,0)) S ^RARPT(RARPT,"R",RALR,0)=^(0),RALR=RALR+1 109 F I=1:1 Q:'$D(^RA(74.1,+Y,"I",I,0)) S ^RARPT(RARPT,"I",RALI,0)=^(0),RALI=RALI+1 110 ASKADD R !!,"Do you want to add another standard to this report? No// ",X:DTIME Q:'$T!(X="")!(X["^")!("Nn"[$E(X)) I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to add another standard to this report, or 'NO' not to." G ASKADD 111 S (^RARPT(RARPT,"R",RALR,0),^RARPT(RARPT,"I",RALI,0))="",RALR=RALR+1,RALI=RALI+1 W ! G STD1 112 ; 113 EDTRPT ; Called from 'RARTE4' and 'RARTVER'. 114 S RACT=$S('+$G(^RARPT(RARPT,"T")):"I",1:"E") 115 S:'$D(^RARPT(RARPT,"T")) ^("T")="" 116 S DA=RARPT,DR="[RA REPORT EDIT]",DIE="^RARPT(" D ^DIE K DE,DQ ;,RAFLAGK 117 I $D(Y),RACT="V",'$P(^RARPT(RARPT,0),"^",9) W !,$C(7),"You must enter a verifying Interpreting Physician to 'VERIFY' a report.",!?3,"...report status will now be changed to 'DRAFT'." S DA=RARPT,DR="5///D" D ^DIE K DE,DQ ;Q 118 Q:$D(RAONLINE)&($G(RARDX)="E") 119 ; move PACS line to its own subroutine 120 ;I $D(RAFLAGK) K RAFLAGK Q 121 G:$D(Y) PACS 122 ;Since report editing is not necessarily screened by sign-on imaging 123 ;type, use the imaging type on the exam record ;ch 124 S RAIMGTYI=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U) 125 S X=+$O(^RA(72,"AA",RAIMGTYJ,9,0)),DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," K RAIMGTYI,RAIMGTYJ 126 S DR=13_$S(RACT'="V":"",'$D(^RA(72,X,.1)):"",$P(^(.1),"^",5)'="Y":"",1:"R")_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1" 127 S RAXIT=$$LOCK^RAUTL12(DIE,.DA) 128 I RACT="V",$P($G(^RA(72,X,.1)),"^",5)="Y" S DIE("NO^")="BACK" 129 I 'RAXIT D ^DIE D UNLOCK^RAUTL12(DIE,.DA) K DA,DE,DQ,DIE,DR 130 I RAXIT!($P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)="")!($D(Y)) K RAXIT G PACS 131 S DR="50///"_RACN 132 S DR(2,70.03)=13.1 133 S DR(3,70.14)=.01_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1" 134 S DA(1)=RADFN,DA=RADTI,DIE="^RADPT("_DA(1)_",""DT""," 135 S RAXIT=$$LOCK^RAUTL12("^RADPT("_RADFN_",""DT"","_RADTI_",""P"",",.RACNI) ;lock at P level 136 I 'RAXIT D ^DIE D UNLOCK^RAUTL12("^RADPT("_RADFN_",""DT"","_RADTI_",""P"",",.RACNI) K DA,DE,DQ,DIE,DR ;unlock at P level 137 K RAXIT 138 PACS I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D RPT^RAHLRPC 139 I "^V^EF"[("^"_$P(^RARPT(RARPT,0),U,5)_"^"),$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health 140 Q 141 ; 142 ASKBTCH R !!,"Do you want to batch print reports? Yes// ",X:DTIME S:'$T X="^" S:X="" X="Y" Q:X["^" I "Nn"'[$E(X),"Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to batch print reports, or 'NO' not to." G ASKBTCH 143 Q 144 ; 145 ASKPRT R !!,"Do you want to print batch now? No// ",X:DTIME S:'$T!(X="")!(X["^") X="N" I "Nn"'[$E(X),"Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to print this batch, or 'NO' not to." G ASKPRT 146 Q 147 DICW ; Build DIC("W") string 148 N DO D DO^DIC1 149 S DIC("W")=$S($G(DIC("W"))]"":DIC("W")_" ",1:"")_"W "" "",$$FLD^RARTFLDS(+Y,""PROC"")" 150 Q 151 IMPRPT(Y) ; Does the report we are currently editing have either Report 152 ; or Impression Text? 153 ; Input : 'Y' - the ien of the report being edited 154 ; Output: '1' - either impression or report text exists, '0' - neither 155 ; report or impression text exists. 156 Q $S(+$O(^RARPT(Y,"I",0)):1,+$O(^RARPT(Y,"R",0)):1,1:0) 1 RARTE1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Edit/Delete a Report ;6/10/98 16:08 2 ;;5.0;Radiology/Nuclear Medicine;**2,15,17,23,31,68**;Mar 16, 1998 3 ;11/07/2005 KAM/BAY 110020 - Correct DUZ ID from Talk Technology 4 ; During the Unverify process 5 DEL D SET^RAPSET1 I $D(XQUIT) K XQUIT Q 6 S (RAPRG74,RAXIT)=0 7 S DIC("A")="Select Report Day-Case#: " 8 S DIC("W")="S RA0=^(0) W "" "",$S($D(^DPT(+$P(RA0,""^"",2),0)):$P(^(0),""^""),1:""Unknown"") K RA0 W "" "",$$FLD^RARTFLDS(+Y,""PROC"")" 9 S DIC="^RARPT(",DIC(0)="AEMQZ" D ^DIC K DIC G END:Y<0 10 S RA0=Y(0),(DA,RAIEN)=+Y 11 I $O(^RARPT(RAIEN,2005,0)) D D END Q 12 . W !!?5,"Cannot delete a report that is associated with an image." 13 . W !?5,"Contact your Imaging Coordinator for further assistance.",! 14 . S DIR(0)="E",DIR("A")="Press RETURN to continue" 15 . D ^DIR K DIR,DIRUT,DUOUT 16 . Q ;08/23/00 17 D CHK17^RARTE3 18 G:RAOK=1 END ;can't del rpt w/o RACN or RACNI so avoid err at UP1^RAUTL1 19 S RAXIT=$$LOCK^RAUTL12("^RARPT(",RAIEN) 20 I RAXIT K RAXIT D END Q ; record locked by another 21 ASKDEL ; ask if deletion is appropriate 22 R !!,"Do you wish to delete this report? NO// ",X:DTIME 23 S:'$T!(X="")!(X["^") X="N" 24 I "Nn"[$E(X) D UNLOCK^RAUTL12("^RARPT(",RAIEN) G DEL 25 I "Yy"'[$E(X) D G ASKDEL 26 . W:X'["?" $C(7) 27 . W !!?3,"Enter 'YES' to delete this report, or 'NO' not to." 28 . Q 29 ; comment out next line, these 3 vars are already set by CHK17^RARTE3 30 ;S RADFN=+$P(RA0,"^",2),RADTI=9999999.9999-$P(RA0,"^",3),RACN=$P(RA0,"^",4) 31 G:RAOK=2 AD2 ;don't remove piece 17 if rpt doesn't match exm's rpt ptr 32 ; del other member's REPORT TEXT xrefs, and set pointer to #74 as null 33 D DEL17^RARTE2(RAIEN) 34 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) 35 G:'$D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0))#2 AD2 36 ; kill any xrefs for file #70's REPORT TEXT 37 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI D ENKILL^RAXREF(70.03,17,RAIEN,.DA) 38 ; set REPORT TEXT to null 39 S $P(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0),"^",17)="" 40 AD2 K RAXIT S DIK="^RARPT(",RAPRG74=1 41 S DA=RAIEN D ^DIK 42 W !?10,"...report deletion complete." 43 D:RAOK'=2 UP1^RAUTL1 ;skip update status if report doesn't belong to exm 44 D UPDTPNT^RAUTL9(RAIEN) ; Update pointers in 74.2, and 74.4! 45 D UNLOCK^RAUTL12("^RARPT(",RAIEN) ; unlock report 46 I RAOK'=2,$T(DELETE^WVRALINK)]"" D DELETE^WVRALINK(RADFN,RADTI,RACNI) ; women's health, skip if report doesn't belong to exm 47 END K %,%Y,D0,DA,DIC,DIE,RAJ1,DIK,RADFN,RADTI,RACN,RACNI,RA0,RAIEN,RAOR 48 K RADUZ,RAORDIFN,RAPRG74,RASN,RASTI,Y 49 K RADATE,RADTE,X 50 K RA791,RACANC,RACN0,RACPT,RACPTNDE,RAI,RAN,RAOBR4,RAPKG,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RASULT,RAXIT 51 K C,D,D1,DDER,DDH,DFN,DI,DISYS,DIWF,DIWL,DIWR,DQ,DR,GMRAL,HLN,HLRESLT,HLSAN,I,VA,VADM,VAERR,X0 52 Q 53 ; 54 UNVER(RAXRPT) ; unverify a report 55 ; Input: if RAXRPT>0 then we know the report we wish to delete 56 ; this requires no user interaction. 57 ; RAXRPT=0 user is prompted for the report they wish to 58 ; delete (interactive) 59 ; 60 I 'RAXRPT D SET^RAPSET1 G Q:$D(XQUIT) 61 I RAXRPT N X S X=RAXRPT 62 S RAXIT=0,DIC="^RARPT(",DIC("S")="I $P(^(0),U,5)=""V""" 63 S DIC(0)=$S('RAXRPT:"AEMQZ",1:"NZ") 64 D DICW,^DIC K DIC I Y<0 D Q Q 65 S RA74B4=$G(Y(0)) 66 S (RARPT,DA)=+Y,RADFN=$P(Y(0),U,2) 67 S RADTI=9999999.9999-$P(Y(0),"^",3),RACN=$P(Y(0),"^",4) 68 I 'RAXRPT S DR="D EN1^RAUTL9 I $D(DIRUT) S Y=""@99"";S:RASTATX'=""PD"" Y=""@10"";25;@10;5////^S X=RASTATX;S:X=""V"" Y=""@99"";9///@;17///@;100///NOW;@99" 69 S:RAXRPT DR="5////^S X=""D"";9///@;17///@;100///NOW" 70 ;11/07/2005 KAM/BAY 110020 Modified next line to look for voice recognition 71 S DIE="^RARPT(",DR(2,74.01)="2////U;3////"_$S(($D(RAQUIET)#2)&($D(RASUB)#2):$G(^TMP("RARPT-REC",$J,RASUB,"RAVERF")),1:DUZ) 72 S RAXIT=$$LOCK^RAUTL12("^RARPT(",RARPT) 73 I RAXIT D Q QUIT 74 D ^DIE K DE,DQ,DIE,DR D UNLOCK^RAUTL12("^RARPT(",RARPT) 75 N RA1,RA2,RA3,RA4 S RA1=RADFN,RA2=RADTI,RA3=RACN,RA4=RARPT 76 S RA(0)=$G(^RARPT(RARPT,0)),RA(5)=$P(^RARPT(RARPT,0),"^",5) 77 S RA(7)=$P(^RARPT(RARPT,0),"^",7),RA(10)=$P(^RARPT(RARPT,0),"^",10) 78 I RA(5)'="V" D 79 . I RA(7)]"" D ENKILL^RAXREF(74,7,RA(7),RARPT) S $P(^RARPT(RARPT,0),"^",7)="" 80 . I RA(10)]"" D ENKILL^RAXREF(74,10,RA(10),RARPT) S $P(^RARPT(RARPT,0),"^",10)="" 81 . N RADDEN,RAUTOE S (RADDEN,RAUTOE)="" D ^RARTR,EN1^RARTE3(RA4) 82 . Q 83 S RADFN=RA1,RADTI=RA2,RACN=RA3,RARPT=RA4 84 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) I $D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0)) D UP1^RAUTL1 I $D(^RABTCH(74.4,"B",RARPT)) D 85 .S DA=0 F S DA=$O(^RABTCH(74.4,"B",RARPT,DA)) Q:'DA D 86 ..S DIK="^RABTCH(74.4," D ^DIK 87 ..Q 88 .Q 89 I $P($G(^RARPT(RARPT,0)),"^",5)'="V",$T(DELETE^WVRALINK)]"" D DELETE^WVRALINK(RADFN,RADTI,RACNI) ; women's health 90 ; 91 Q ; Kill and quit 92 K DFN,DI,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,RAACNT,RANUM,RAST,RAWHOVER 93 K %,%DT,%W,%Y,%Y1,C,D,D0,D1,DA,DIC,DIE,DIK,DR,RA,RACN,RACNI,RADATE 94 K RADFN,RADIV,RADTE,RADTI,RAJ,RAOR,RAORDIFN,RARPT,RASET,RASN,RASTATX 95 K RASTI,RAXIT,X,XQUIT,Y,RA74B4,DDH,DIPGM,DISYS,I,RADUZ 96 Q 97 ; 98 STD S (RALR,RALI)=1 99 STD1 S DIC="^RA(74.1,",DIC("A")="Select 'Standard' Report to Copy: ",DIC(0)="AEMQ" D ^DIC K DIC("A") Q:Y<0 100 ASKSEL W:$$IMPRPT(RARPT) !!,"Report already exists. This will over-write it." 101 W !,"Are you sure you want the '",$P(Y,"^",2),"' standard report? No// " R X:DTIME G STD1:'$T!(X="")!(X["^")!("Nn"[$E(X)) 102 I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to select the '",$P(Y,"^",2),"' standard report, or 'NO' not to." G ASKSEL 103 I RALR=1,RALI=1 K ^RARPT(RARPT,"R"),^("I") 104 F I=1:1 Q:'$D(^RA(74.1,+Y,"R",I,0)) S ^RARPT(RARPT,"R",RALR,0)=^(0),RALR=RALR+1 105 F I=1:1 Q:'$D(^RA(74.1,+Y,"I",I,0)) S ^RARPT(RARPT,"I",RALI,0)=^(0),RALI=RALI+1 106 ASKADD R !!,"Do you want to add another standard to this report? No// ",X:DTIME Q:'$T!(X="")!(X["^")!("Nn"[$E(X)) I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to add another standard to this report, or 'NO' not to." G ASKADD 107 S (^RARPT(RARPT,"R",RALR,0),^RARPT(RARPT,"I",RALI,0))="",RALR=RALR+1,RALI=RALI+1 W ! G STD1 108 ; 109 EDTRPT ; Called from 'RARTE4' and 'RARTVER'. 110 S RACT=$S('+$G(^RARPT(RARPT,"T")):"I",1:"E") 111 S:'$D(^RARPT(RARPT,"T")) ^("T")="" 112 S DA=RARPT,DR="[RA REPORT EDIT]",DIE="^RARPT(" D ^DIE K DE,DQ ;,RAFLAGK 113 I $D(Y),RACT="V",'$P(^RARPT(RARPT,0),"^",9) W !,$C(7),"You must enter a verifying Interpreting Physician to 'VERIFY' a report.",!?3,"...report status will now be changed to 'DRAFT'." S DA=RARPT,DR="5///D" D ^DIE K DE,DQ ;Q 114 Q:$D(RAONLINE)&($G(RARDX)="E") 115 ; move PACS line to its own subroutine 116 ;I $D(RAFLAGK) K RAFLAGK Q 117 G:$D(Y) PACS 118 ;Since report editing is not necessarily screened by sign-on imaging 119 ;type, use the imaging type on the exam record ;ch 120 S RAIMGTYI=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U) 121 S X=+$O(^RA(72,"AA",RAIMGTYJ,9,0)),DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," K RAIMGTYI,RAIMGTYJ 122 S DR=13_$S(RACT'="V":"",'$D(^RA(72,X,.1)):"",$P(^(.1),"^",5)'="Y":"",1:"R")_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1" 123 S RAXIT=$$LOCK^RAUTL12(DIE,.DA) 124 I RACT="V",$P($G(^RA(72,X,.1)),"^",5)="Y" S DIE("NO^")="BACK" 125 I 'RAXIT D ^DIE D UNLOCK^RAUTL12(DIE,.DA) K DA,DE,DQ,DIE,DR 126 I RAXIT!($P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)="")!($D(Y)) K RAXIT G PACS 127 S DR="50///"_RACN 128 S DR(2,70.03)=13.1 129 S DR(3,70.14)=.01_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1" 130 S DA(1)=RADFN,DA=RADTI,DIE="^RADPT("_DA(1)_",""DT""," 131 S RAXIT=$$LOCK^RAUTL12("^RADPT("_RADFN_",""DT"","_RADTI_",""P"",",.RACNI) ;lock at P level 132 I 'RAXIT D ^DIE D UNLOCK^RAUTL12("^RADPT("_RADFN_",""DT"","_RADTI_",""P"",",.RACNI) K DA,DE,DQ,DIE,DR ;unlock at P level 133 K RAXIT 134 PACS I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D RPT^RAHLRPC 135 I $P(^RARPT(RARPT,0),U,5)="V",$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health 136 Q 137 ; 138 ASKBTCH R !!,"Do you want to batch print reports? Yes// ",X:DTIME S:'$T X="^" S:X="" X="Y" Q:X["^" I "Nn"'[$E(X),"Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to batch print reports, or 'NO' not to." G ASKBTCH 139 Q 140 ; 141 ASKPRT R !!,"Do you want to print batch now? No// ",X:DTIME S:'$T!(X="")!(X["^") X="N" I "Nn"'[$E(X),"Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to print this batch, or 'NO' not to." G ASKPRT 142 Q 143 DICW ; Build DIC("W") string 144 N DO D DO^DIC1 145 S DIC("W")=$S($G(DIC("W"))]"":DIC("W")_" ",1:"")_"W "" "",$$FLD^RARTFLDS(+Y,""PROC"")" 146 Q 147 IMPRPT(Y) ; Does the report we are currently editing have either Report 148 ; or Impression Text? 149 ; Input : 'Y' - the ien of the report being edited 150 ; Output: '1' - either impression or report text exists, '0' - neither 151 ; report or impression text exists. 152 Q $S(+$O(^RARPT(Y,"I",0)):1,+$O(^RARPT(Y,"R",0)):1,1:0) -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTE3.m
r613 r623 1 RARTE3 ;HISC/GJC-Create a skeletal report, store in Error Reports multiple ;2/4/97 09:39 2 ;;5.0;Radiology/Nuclear Medicine;**31,56**;Mar 16, 1998;Build 3 3 ;Supported IA #10103 NOW^XLFDT 4 ;Supported IA #2053 UPDATE^DIE 5 ; This routine will be accessed when the user unverifies a report. 6 ; At this time, a skeletal copy of the report will be stored off 7 ; in the 'Error Reports' multiple. This will keep track of report 8 ; addendums. 9 EN1(RADA) ; Create the 'Error Reports' sub-record. 10 ; Input: 'RADA': IEN of the report in file 74. 11 ; Create the record, enter when the report was unverified. 12 Q:'($D(^TMP($J,"RA AUTOE"))\10) 13 N RACNT,RAIEN,RANEW,RANOW,X S RANOW=$$NOW^XLFDT() 14 S RANEW(74.06,"+1,"_RADA_",",.01)=RANOW 15 D UPDATE^DIE("","RANEW","RAIEN","") 16 ; Error Report date/time field created, now the skeletal report text 17 S RADA(1)=RADA,RADA=+$G(RAIEN(1)) Q:'RADA ; sub-file ien not created 18 S RACNT=+$O(^TMP($J,"RA AUTOE",999999999999),-1) 19 D ZERO K ^TMP($J,"RA AUTOE") 20 Q 21 ZERO ; setup the ^TMP($J,"RA AUTOE" global with a zero node 22 S ^RARPT(RADA(1),"ERR",RADA,"RPT",0)="^^"_RACNT_"^"_RACNT_"^"_(RANOW\1)_"^" 23 N I S I=0 24 F S I=$O(^TMP($J,"RA AUTOE",I)) Q:I'>0 D 25 . S ^RARPT(RADA(1),"ERR",RADA,"RPT",I,0)=$G(^TMP($J,"RA AUTOE",I)) 26 . Q 27 Q 28 CHK17 ; called from routine RARTE1 29 ; check 17th piece of exam with same pat/dttm/longcn 30 ; values of RAOK: 31 ; 1 = unknown case no. or unknown case ien, CAN'T DELETE REPORT 32 ; 2 = exm doesn't point to this rpt, CAN DELETE BUT NOT UPGRADE EXM STAT 33 ; 3 = all okay 34 S RAOK=3 35 S RADFN=+$P(RA0,"^",2),RADTI=9999999.9999-$P(RA0,"^",3) 36 S RACN=$P($P(RA0,"^"),"-",2) ;get from longcase no.'s 2nd part 37 I RACN="" D WARN1,PRESS Q 38 S RACNI=+$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) 39 I 'RACNI D WARN1,PRESS Q 40 I $P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",17)'=RAIEN D WARN2,PRESS 41 Q 42 WARN1 W !!?3,"** Cannot determine internal or external case number. **" 43 W !!?3,"** You may NOT delete this report. **" 44 S RAOK=1 45 Q 46 WARN2 W !!?3,"** This report refers to an exam that isn't pointing back to this report. **" 47 S RAOK=2 48 WARNQ W !!?3,"** You may delete this report if it is indeed the report you don't want. **" 49 W !?3,"** Or call IRM for help. **" 50 Q 51 PRESS R !!?5,"Press RETURN to continue. ",X:DTIME 52 Q 1 RARTE3 ;HISC/GJC-Create a skeletal report, store in Error Reports multiple ;2/4/97 09:39 2 ;;5.0;Radiology/Nuclear Medicine;**31**;Mar 16, 1998 3 ; This routine will be accessed when the user unverifies a report. 4 ; At this time, a skeletal copy of the report will be stored off 5 ; in the 'Error Reports' multiple. This will keep track of report 6 ; addendums. 7 EN1(RADA) ; Create the 'Error Reports' sub-record. 8 ; Input: 'RADA': IEN of the report in file 74. 9 ; Create the record, enter when the report was unverified. 10 Q:'($D(^TMP($J,"RA AUTOE"))\10) 11 N RACNT,RAIEN,RANEW,RANOW,X S RANOW=$$NOW^XLFDT() 12 S RANEW(74.06,"+1,"_RADA_",",.01)=RANOW 13 D UPDATE^DIE("","RANEW","RAIEN","") 14 ; Error Report date/time field created, now the skeletal report text 15 S RADA(1)=RADA,RADA=+$G(RAIEN(1)) Q:'RADA ; sub-file ien not created 16 S RACNT=+$O(^TMP($J,"RA AUTOE",999999999999),-1) 17 D ZERO K ^TMP($J,"RA AUTOE") 18 Q 19 ZERO ; setup the ^TMP($J,"RA AUTOE" global with a zero node 20 S ^RARPT(RADA(1),"ERR",RADA,"RPT",0)="^^"_RACNT_"^"_RACNT_"^"_(RANOW\1)_"^" 21 N I S I=0 22 F S I=$O(^TMP($J,"RA AUTOE",I)) Q:I'>0 D 23 . S ^RARPT(RADA(1),"ERR",RADA,"RPT",I,0)=$G(^TMP($J,"RA AUTOE",I)) 24 . Q 25 Q 26 CHK17 ; called from routine RARTE1 27 ; check 17th piece of exam with same pat/dttm/longcn 28 ; values of RAOK: 29 ; 1 = unknown case no. or unknown case ien, CAN'T DELETE REPORT 30 ; 2 = exm doesn't point to this rpt, CAN DELETE BUT NOT UPGRADE EXM STAT 31 ; 3 = all okay 32 S RAOK=3 33 S RADFN=+$P(RA0,"^",2),RADTI=9999999.9999-$P(RA0,"^",3),RACN=$P(RA0,"^",4) 34 S:RACN="" RACN=$P($P(RA0,"^"),"-",2) ;get from longcase no.'s 2nd part 35 I RACN="" D WARN1,PRESS Q 36 S RACNI=+$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) 37 I 'RACNI D WARN1,PRESS Q 38 I $P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",17)'=RAIEN D WARN2,PRESS 39 Q 40 WARN1 W !!?3,"** Cannot determine internal or external case number. **" 41 W !!?3,"** You may NOT delete this report. **" 42 S RAOK=1 43 Q 44 WARN2 W !!?3,"** This report refers to an exam that isn't pointing back to this report. **" 45 S RAOK=2 46 WARNQ W !!?3,"** You may delete this report if it is indeed the report you don't want. **" 47 W !?3,"** Or call IRM for help. **" 48 Q 49 PRESS R !!?5,"Press RETURN to continue. ",X:DTIME 50 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTE4.m
r613 r623 1 RARTE4 ;HISC/GJC - Edit/Delete Reports (cont) ;11/4/97 08:02 2 ;;5.0;Radiology/Nuclear Medicine;**15,27,41,82,56**;Mar 16, 1998;Build 3 3 ;Supported IA #10060 ^VA(200 4 ;Supported IA #10007 DO^DIC1 5 LOCK ;Try to lock next avail IEN, if locked - fail, if used - increment again 6 S I=I+1 S RAXIT=$$LOCK^RAUTL12("^RARPT(",I) I RAXIT D UNLOCK2 D INCRPT G START^RARTE 7 I $D(^RARPT(I))!($D(^RARPT("B",I))) D UNLOCK^RAUTL12("^RARPT(",I) G LOCK 8 S ^RARPT(I,0)=RARPTN,RARPT=I,^(0)=$P(^RARPT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1),^DISV($S($D(DUZ)#2:DUZ,1:0),"^RARPT(")=I S:'$D(^RARPT(RARPT,"T")) ^("T")="" 9 S ^RARPT(RARPT,0)=RARPTN_"^"_RADFN_"^"_RADTE_"^"_RACN_"^D",DIK="^RARPT(",DA=RARPT D IX1^DIK 10 K %,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y 11 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI 12 S DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P""," 13 S DR="17////"_RARPT D ^DIE 14 K %,D,D0,DA,DI,DIC,DIE,DQ,DR,RAY1,X,Y 15 I RAPRTSET D PTR^RARTE2 16 I RAXIT D UNLOCK2,UNLOCK^RAUTL12("^RARPT(",RARPT) Q 17 G IN0 18 IN ;lock rpt for the 1st time if editing existing rpt 19 S RAXIT=$$LOCK^RAUTL12("^RARPT(",RARPT) I RAXIT D UNLOCK2,Q Q 20 IN0 ;skip to here if rpt created in this session and already locked 21 G IN1:'$P(RAMDV,"^",14) K RACOPY 22 S DIC("S")="I RARPT'=+Y,$P(^(0),U,5)'=""X""" ;omit same & deleted rpt 23 ; Remedy ticket #245679, remove multi-index lookup 24 S DIC("A")="Select Report to Copy: ",DIC(0)="AEQ",DIC="^RARPT(" 25 D DICW,^DIC K DIC("S"),DIC("A") S RAY1=Y 26 I X="^" D UNLOCK^RAUTL12("^RARPT(",RARPT),UNLOCK2 S RAXIT=$$EN3^RAUTL15(RARPT) D INCRPT G START^RARTE 27 G IN1:RAY1<0 28 F J="H","R","I" K ^RARPT(RARPT,J) 29 F J="R","I" F I=1:1 Q:'$D(^RARPT(+Y,J,I,0)) S ^RARPT(RARPT,J,I,0)=^(0) 30 ;F I=1:1 Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",1,"H",I,0)) S ^RARPT(RARPT,"H",I,0)=^RADPT(RADFN,"DT",RADTI,"P",1,"H",I,0) 31 S RACOPY="" 32 IN1 ;skip to here if div param disallows rpt copying 33 I $P(RAMDV,"^",14) W !,RAI 34 K RAFIN 35 S DR="50///"_RACN 36 S DR(2,70.03)="12//^S X=$S($D(RARES)&($D(RABTCH)):RARES,1:"""");S:$D(^VA(200,+X,0)) RARES=$P(^(0),U);I X'>0 S Y=""@15"";70;@15;15" 37 I $P(RAMDV,"^",28) S DR(2,70.03)=DR(2,70.03)_"R" ; req'd for DIVISION 38 S DR(2,70.03)=DR(2,70.03)_"//^S X=$S($D(RASTFF)&($D(RABTCH)):RASTFF,1:"""");S:$D(^VA(200,+X,0)) RASTFF=$P(^(0),U);I X'>0 S Y=""@1"";60;@1;S RAFIN=""""" 39 S DA(1)=RADFN,DA=RADTI,DIE="^RADPT("_DA(1)_",""DT""," D ^DIE K DE,DQ 40 D ELOC^RABWRTE ; Billing Aware -- ask Inter. Img Loc 41 I RAPRTSET S RADRS=2 D COPY^RARTE2 ; copy resid and staff 42 G PRT:'$D(RAFIN) W !,RAI 43 ; 44 ; **BNT - Commented out to stop copying history from file 70 to 74 45 ; in patch RA*5*27. The history is now referenced directly from file 70. 46 ; I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H")),'$D(^RARPT(RARPT,"H")) F I=1:1 Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",I,0)) S ^RARPT(RARPT,"H",I,0)=^(0) 47 ; ** 48 I '$D(RACOPY),$P(RAMDV,"^",12) D STD^RARTE1 I X="^" G PRT 49 W !,RAI D EDTRPT^RARTE1 50 PRT D UNLOCK^RAUTL12(RAPNODE,RACNI) 51 ; --- copy diags to other cases of print set 52 I RAPRTSET S RADRS=1,RAXIT=0 D COPY^RARTE2 L -^RADPT(RADFN,"DT",RADTI) ;unlock dt level only after copying is done 53 ; wait til report has been checked for completeness before unlocking it 54 S RAXIT=$$EN3^RAUTL15(RARPT) D UNLOCK^RAUTL12("^RARPT(",RARPT) 55 I RAXIT S RAXIT=0 D UNLOCK2 D INCRPT G START^RARTE 56 ; --- 57 D K RAAB G PRT1:'$D(RABTCH),PRT1:'$D(^RABTCH(74.2,+RABTCH,0)) 58 .; RAHLTCPB flag is inactive 59 .N RAHLTCPB S RAHLTCPB=1 D:$S('$D(RACT):0,RACT="V":1,1:0) UPSTAT^RAUTL0 60 .D:$S('$D(RACT):1,RACT'="V":1,1:0) UP1^RAUTL1 61 ASKREP W !!,"Do you want to place this report in the batch ",RABTCHN,"? Yes// " R X:DTIME S:'$T!(X["^") X="N" S:X="" X="Y" G PRT1:"Nn"[$E(X) 62 I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to place this report in the batch, or 'NO' not to." G ASKREP 63 I $D(^RABTCH(74.2,"D",RARPT,RABTCH)) W !?5,"...report is already part of the '",RABTCHN,"' batch" D INCRPT G START^RARTE 64 W !?5,"...will now place report in the '",RABTCHN,"' batch" S DIE="^RABTCH(74.2,",DA=RABTCH,DR="25///"_$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN,DR(2,74.21)="2////N" D ^DIE K DQ,DE D INCRPT G START^RARTE 65 PRT1 R !!,"Do you wish to print this report? No// ",X:DTIME S:'$T!(X["^") X="N" S:X="" X="N" ;030497 66 I "Nn"[$E(X) D INCRPT G START^RARTE 67 I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to print this report, or 'NO' not to." G PRT1 68 S ION=$P(RAMLC,"^",10),IOP=$S(ION]"":"Q;"_ION,1:"Q") 69 S RAMES="W !!?3,""Report has been queued for printing on device "",ION,"".""" 70 D Q^RARTR D INCRPT G START^RARTE 71 ; 72 Q I $D(RABTCH),$D(^RABTCH(74.2,+RABTCH,"R",0)) D ASKPRT^RARTE1,BTCH^RABTCH:"Yy"[$E(X) 73 Q1 K %,%DT,%W,%Y,%Y1,C,D0,D1,DA,DIC,DIE,DR,OREND,RABTCH,RABTCHN,RACN,RACNI,RACOPY,RACS,RACT,RADATE,RADFN,RADTE,RADTI,RADUZ,RAELESIG,RAFIN,RAHEAD,RAI,RAJ1 74 K RALI,RALR,RANME,RANUM,RAOR,RAORDIFN,RAPNODE,RAPRC,RAPRIT,RAQUIT,RAREPORT,RARES,RARPDT,RARPT,RARPTN,RARPTZ,RARTPN,RASET,RASI,RASIG,RASN,RASSN,RAST,RAST1,RASTI,RASTFF,RAVW,XQUIT,W,X,Y 75 K D,D2,DDER,DI,DIPGM,DLAYGO,J,RAEND,RAF5,RAFL,RAFST,RAIX,RAPOP,RAY1 76 K ^TMP($J,"RAEX") 77 K POP,DUOUT 78 Q 79 DICW ; Build DIC("W") string 80 N DO D DO^DIC1 81 S DIC("W")=$S($G(DIC("W"))]"":DIC("W")_" ",1:"")_"W "" "",$$FLD^RARTFLDS(+Y,""PROC"")" 82 Q 83 INCRPT ; Kill extraneous variables to avoid collisions. 84 ; Incomplete report information, select another case #. 85 K %,%DT,D,D0,D1,D2,DI,DIC,DIWT,DN,I,J,RACN,RACNI,RACT,RADATE,RADTE 86 K RADTI,RAFIN,RAI,RALI,RALR,RANME,RAPRC,RARPT,RARPTN,RASSN,RAST,RAVW,X 87 Q 88 UNLOCK2 D UNLOCK^RAUTL12(RAPNODE,RACNI) L -^RADPT(RADFN,"DT",RADTI) 89 Q 1 RARTE4 ;HISC/GJC - Edit/Delete Reports (cont) ;11/4/97 08:02 2 ;;5.0;Radiology/Nuclear Medicine;**15,27,41,82**;Mar 16, 1998;Build 8 3 LOCK ;Try to lock next avail IEN, if locked - fail, if used - increment again 4 S I=I+1 S RAXIT=$$LOCK^RAUTL12("^RARPT(",I) I RAXIT D UNLOCK2 D INCRPT G START^RARTE 5 I $D(^RARPT(I))!($D(^RARPT("B",I))) D UNLOCK^RAUTL12("^RARPT(",I) G LOCK 6 S ^RARPT(I,0)=RARPTN,RARPT=I,^(0)=$P(^RARPT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1),^DISV($S($D(DUZ)#2:DUZ,1:0),"^RARPT(")=I S:'$D(^RARPT(RARPT,"T")) ^("T")="" 7 S ^RARPT(RARPT,0)=RARPTN_"^"_RADFN_"^"_RADTE_"^"_RACN_"^D",DIK="^RARPT(",DA=RARPT D IX1^DIK 8 K %,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y 9 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI 10 S DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P""," 11 S DR="17////"_RARPT D ^DIE 12 K %,D,D0,DA,DI,DIC,DIE,DQ,DR,RAY1,X,Y 13 I RAPRTSET D PTR^RARTE2 14 I RAXIT D UNLOCK2,UNLOCK^RAUTL12("^RARPT(",RARPT) Q 15 G IN0 16 IN ;lock rpt for the 1st time if editing existing rpt 17 S RAXIT=$$LOCK^RAUTL12("^RARPT(",RARPT) I RAXIT D UNLOCK2,Q Q 18 IN0 ;skip to here if rpt created in this session and already locked 19 G IN1:'$P(RAMDV,"^",14) K RACOPY S DIC("S")="I RARPT'=+Y",DIC("A")="Select Report to Copy: ",DIC(0)="AMEQ",DIC="^RARPT(" D DICW,^DIC K DIC("S"),DIC("A") S RAY1=Y 20 I X="^" D UNLOCK^RAUTL12("^RARPT(",RARPT),UNLOCK2 S RAXIT=$$EN3^RAUTL15(RARPT) D INCRPT G START^RARTE 21 G IN1:RAY1<0 22 F J="H","R","I" K ^RARPT(RARPT,J) 23 F J="R","I" F I=1:1 Q:'$D(^RARPT(+Y,J,I,0)) S ^RARPT(RARPT,J,I,0)=^(0) 24 ;F I=1:1 Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",1,"H",I,0)) S ^RARPT(RARPT,"H",I,0)=^RADPT(RADFN,"DT",RADTI,"P",1,"H",I,0) 25 S RACOPY="" 26 IN1 ;skip to here if div param disallows rpt copying 27 I $P(RAMDV,"^",14) W !,RAI 28 K RAFIN 29 S DR="50///"_RACN 30 S DR(2,70.03)="12//^S X=$S($D(RARES)&($D(RABTCH)):RARES,1:"""");S:$D(^VA(200,+X,0)) RARES=$P(^(0),U);I X'>0 S Y=""@15"";70;@15;15" 31 I $P(RAMDV,"^",28) S DR(2,70.03)=DR(2,70.03)_"R" ; req'd for DIVISION 32 S DR(2,70.03)=DR(2,70.03)_"//^S X=$S($D(RASTFF)&($D(RABTCH)):RASTFF,1:"""");S:$D(^VA(200,+X,0)) RASTFF=$P(^(0),U);I X'>0 S Y=""@1"";60;@1;S RAFIN=""""" 33 S DA(1)=RADFN,DA=RADTI,DIE="^RADPT("_DA(1)_",""DT""," D ^DIE K DE,DQ 34 D ELOC^RABWRTE ; Billing Aware -- ask Inter. Img Loc 35 I RAPRTSET S RADRS=2 D COPY^RARTE2 ; copy resid and staff 36 G PRT:'$D(RAFIN) W !,RAI 37 ; 38 ; **BNT - Commented out to stop copying history from file 70 to 74 39 ; in patch RA*5*27. The history is now referenced directly from file 70. 40 ; I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H")),'$D(^RARPT(RARPT,"H")) F I=1:1 Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",I,0)) S ^RARPT(RARPT,"H",I,0)=^(0) 41 ; ** 42 I '$D(RACOPY),$P(RAMDV,"^",12) D STD^RARTE1 I X="^" G PRT 43 W !,RAI D EDTRPT^RARTE1 44 PRT D UNLOCK^RAUTL12(RAPNODE,RACNI) 45 ; --- copy diags to other cases of print set 46 I RAPRTSET S RADRS=1,RAXIT=0 D COPY^RARTE2 L -^RADPT(RADFN,"DT",RADTI) ;unlock dt level only after copying is done 47 ; wait til report has been checked for completeness before unlocking it 48 S RAXIT=$$EN3^RAUTL15(RARPT) D UNLOCK^RAUTL12("^RARPT(",RARPT) 49 I RAXIT S RAXIT=0 D UNLOCK2 D INCRPT G START^RARTE 50 ; --- 51 D K RAAB G PRT1:'$D(RABTCH),PRT1:'$D(^RABTCH(74.2,+RABTCH,0)) 52 .; RAHLTCPB flag is inactive 53 .N RAHLTCPB S RAHLTCPB=1 D:$S('$D(RACT):0,RACT="V":1,1:0) UPSTAT^RAUTL0 54 .D:$S('$D(RACT):1,RACT'="V":1,1:0) UP1^RAUTL1 55 ASKREP W !!,"Do you want to place this report in the batch ",RABTCHN,"? Yes// " R X:DTIME S:'$T!(X["^") X="N" S:X="" X="Y" G PRT1:"Nn"[$E(X) 56 I "Yy"'[$E(X) W:X'["?" *7 W !!?3,"Enter 'YES' to place this report in the batch, or 'NO' not to." G ASKREP 57 I $D(^RABTCH(74.2,"D",RARPT,RABTCH)) W !?5,"...report is already part of the '",RABTCHN,"' batch" D INCRPT G START^RARTE 58 W !?5,"...will now place report in the '",RABTCHN,"' batch" S DIE="^RABTCH(74.2,",DA=RABTCH,DR="25///"_$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN,DR(2,74.21)="2////N" D ^DIE K DQ,DE D INCRPT G START^RARTE 59 PRT1 R !!,"Do you wish to print this report? No// ",X:DTIME S:'$T!(X["^") X="N" S:X="" X="N" ;030497 60 I "Nn"[$E(X) D INCRPT G START^RARTE 61 I "Yy"'[$E(X) W:X'["?" *7 W !!?3,"Enter 'YES' to print this report, or 'NO' not to." G PRT1 62 S ION=$P(RAMLC,"^",10),IOP=$S(ION]"":"Q;"_ION,1:"Q") 63 S RAMES="W !!?3,""Report has been queued for printing on device "",ION,"".""" 64 D Q^RARTR D INCRPT G START^RARTE 65 ; 66 Q I $D(RABTCH),$D(^RABTCH(74.2,+RABTCH,"R",0)) D ASKPRT^RARTE1,BTCH^RABTCH:"Yy"[$E(X) 67 Q1 K %,%DT,%W,%Y,%Y1,C,D0,D1,DA,DIC,DIE,DR,OREND,RABTCH,RABTCHN,RACN,RACNI,RACOPY,RACS,RACT,RADATE,RADFN,RADTE,RADTI,RADUZ,RAELESIG,RAFIN,RAHEAD,RAI,RAJ1 68 K RALI,RALR,RANME,RANUM,RAOR,RAORDIFN,RAPNODE,RAPRC,RAPRIT,RAQUIT,RAREPORT,RARES,RARPDT,RARPT,RARPTN,RARPTZ,RARTPN,RASET,RASI,RASIG,RASN,RASSN,RAST,RAST1,RASTI,RASTFF,RAVW,XQUIT,W,X,Y 69 K D,D2,DDER,DI,DIPGM,DLAYGO,J,RAEND,RAF5,RAFL,RAFST,RAIX,RAPOP,RAY1 70 K ^TMP($J,"RAEX") 71 K POP,DUOUT 72 Q 73 DICW ; Build DIC("W") string 74 N DO D DO^DIC1 75 S DIC("W")=$S($G(DIC("W"))]"":DIC("W")_" ",1:"")_"W "" "",$$FLD^RARTFLDS(+Y,""PROC"")" 76 Q 77 INCRPT ; Kill extraneous variables to avoid collisions. 78 ; Incomplete report information, select another case #. 79 K %,%DT,D,D0,D1,D2,DI,DIC,DIWT,DN,I,J,RACN,RACNI,RACT,RADATE,RADTE 80 K RADTI,RAFIN,RAI,RALI,RALR,RANME,RAPRC,RARPT,RARPTN,RASSN,RAST,RAVW,X 81 Q 82 UNLOCK2 D UNLOCK^RAUTL12(RAPNODE,RACNI) L -^RADPT(RADFN,"DT",RADTI) 83 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR.m
r613 r623 1 RARTR ;HISC/CAH COLUMBIA/REB AISC/MJK,RMO-Queue/print Reports ;11/27/98 09:05 2 ;;5.0;Radiology/Nuclear Medicine;**5,13,16,27,43,55,75,92**;Mar 16, 1998;Build 4 3 PRT ; Begin print/build of e-mail message 4 ; 5 ; ** NOTE: If the layout of this output is changed ** 6 ; ** please check that routine RAO7PC3 is ** 7 ; ** not affected. It assumes fixed format of ** 8 ; ** the following headings: ** 9 ; ** Clinical History: ** 10 ; ** Report: ** 11 ; ** Impression: ** 12 ; ** Primary Diagnostic Code: ** 13 ; ** Secondary Diagnostic Codes: ** 14 ; ** Primary Interpreting Staff: ** 15 ; 16 Q:'$D(^RARPT(+$G(RARPT),0)) 17 ; Use and Set if running in the foreground and Writing to the device 18 I '$D(RAUTOE) D 19 . U IO 20 . S RAFFLF=IOF 21 . S RAORIOF=RAFFLF 22 ; 23 W:$Y>0&('$D(RAUTOE)) @RAFFLF ; If RAUTOE defined build mail msg 24 S X=$G(^RARPT(+$G(RARPT),0)) ; RAORIOF=RAFFLF 25 ; 26 ;S RAFFLF=$S('$D(ORACTION):RAFFLF,ORACTION'=8:RAFFLF,1:"!") 27 D INIT ; setup exam/report variables 28 I RAY0<0!(RAY1<0)!(RAY2<0)!(RAY3<0) K RAFFLF Q ; data nodes missing 29 ; 30 PRT1 I $D(RAUTOE) D 31 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" " 32 . I $D(RADDEN) D 33 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Unverified by: "_$P($G(^VA(200,$S($G(RADUZ):RADUZ,1:DUZ),0)),"^") 34 .. Q 35 . Q 36 I +$O(^RARPT(RARPT,"ERR",0)) D 37 . S RAERRFLG="" ; set for future reference (display AMENRPT^RARTR text) 38 . W:'$D(RAUTOE) !!?10,$$AMENRPT^RARTR2(),! 39 . I $D(RAUTOE) D 40 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" " 41 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2() 42 .. Q 43 . Q 44 I $P(RAY3,"^",25)<2 D G END:$D(RAOOUT) 45 . D MODS^RAUTL2,OUT1^RARTR3 46 . D:+$P(RAY3,"^",28) RDIO^RARTUTL(+$P(RAY3,"^",28)) Q:$D(RAOOUT) 47 . D:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",") 48 . ;W:'$D(RAUTOE) ! 49 . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 50 . Q 51 I $P(RAY3,"^",25)>1 D 52 . D MEMS1^RARTR3 53 . W:'$D(RAUTOE) ! 54 . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 55 . Q 56 G END:$D(RAOOUT) 57 ; Check for duplicate history in file 70 and 74. 58 D CHKDUPHX^RART1 ; Sets RADUPHX to 1 for duplicate or 0 if different. 59 F RAP="H","AH","R","I" K ^UTILITY($J,"W"),^(1) D G END:$D(RAOOUT) 60 . S RAP("P")=$S(RAP="H":"Clinical History:",RAP="AH":"Additional Clinical History:",RAP="R":"Report:",1:"Impression:") 61 . ; Don't continue if printing Additional Clinical History and it is a 62 . ; duplicate of Clinical History. 63 . Q:RAP="AH"&(RADUPHX>0) 64 . W:'$D(RAUTOE) !?RATAB,RAP("P") 65 . I $D(RAUTOE),($D(RADDEN)),(RAP="R") D 66 .. N RABAN1,RABAN2,RASPCE S $P(RASPCE," ",46)="" 67 .. S RABAN1="*** Uncorrected Version ***" 68 .. S RABAN2="*** Refer to final report ***" 69 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 70 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN1 71 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN2 72 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 73 .. Q 74 . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_RAP("P") 75 . W:$D(RASTFL)&(RAP="R")&('$D(RAUTOE)) ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),"^",2)) 76 . I RAP="R",($D(RAUTOE)) D 77 .. S $P(RAP("S")," ",(46-$L(^TMP($J,"RA AUTOE",RAACNT))))="" 78 .. I '$D(RADDEN) S ^TMP($J,"RA AUTOE",RAACNT)=^(RAACNT)_RAP("S")_"Status: "_$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),"^",2)) 79 .. Q 80 . D:$D(RAUTOE) SET^RARTR2 81 . D:'$D(RAUTOE) WRITE^RARTR2 Q:$D(RAOOUT) 82 . K ^UTILITY($J,"W") 83 . Q 84 I $D(RADDEN),($G(^RARPT(RARPT,"PURGE"))) D 85 . ; when the report is unverified and purge data exists (rpt adden) 86 . N RAPRGE S RAPRGE=+$G(^RARPT(RARPT,"PURGE")) 87 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 88 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Purged: "_$$FMTE^XLFDT(RAPRGE,"1P") 89 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 90 . Q 91 I $P($G(^RA(79.1,+$P(RAY2,U,4),0)),U,18)="Y" D PRTDX^RARTR1 G:$D(RAOOUT) END ;print dx codes 92 D EN1^RARTR0 G:$D(RAOOUT) END 93 I '$D(RAVERFND) D G END:$D(RAOOUT) 94 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD:($Y+RAFOOT+4)>IOSL 95 . N RADFTSBN,RADFTSBT S:$D(RADDEN) RAVERF=+$P(RA74B4,"^",9) 96 . S RADFTSBN=$E($P($G(^VA(200,RAVERF,20)),"^",2),1,25) 97 . S:RADFTSBN']"" RADFTSBN=$E($P($G(^VA(200,RAVERF,0)),"^"),1,25) 98 . S RADFTSBT=$E($P($G(^VA(200,RAVERF,20)),"^",3),1,30) 99 . I RADFTSBT']"" S RADFTSBT=$$TITLE^RARTR0(RAVERF) 100 . W:'$D(RAUTOE) !!,"VERIFIED BY:",!?2,$S(RADFTSBN]"":RADFTSBN,1:"") 101 . W:RADFTSBT]""&('$D(RAUTOE)) ", "_RADFTSBT 102 . I $D(RAUTOE) D 103 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="VERIFIED BY:" 104 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RADFTSBN]"":RADFTSBN,1:"")_$S(RADFTSBT]"":", "_RADFTSBT,1:"") 105 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 106 .. Q 107 . Q 108 K RASBPN,RASBT,RASECIEN,RASECOND,RASECSS 109 I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 G END:$D(RAOOUT) D HD:($Y+RAFOOT+4)>IOSL 110 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) 111 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:"") 112 S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 113 D HANG^RARTR2 G END:$D(RAOOUT) 114 I RAST'="V" D:'$D(RAMDV) SETDIV^RARTR2 I $P(RAMDV,U,25) D WARNING^RARTR1 115 G PEND:RAST'="PD" 116 S $P(RASTRSK,"*",80)="" 117 I '$D(RAUTOE) D 118 . D HD:($Y+RAFOOT+9)>IOSL 119 . 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) 120 . W !!,$S($D(^RARPT(RARPT,"P")):^("P"),1:"None entered.") W !!,RASTRSK 121 . Q 122 E D 123 . 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) 124 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$S($D(^RARPT(RARPT,"P")):^("P"),1:"None entered.") 125 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 126 . Q 127 PEND D FOOT^RARTR2,HANG^RARTR2 D:'$D(RAMIE)&('$D(RAUTOE)) Q^RAFLH1 128 END K:$D(RAOOUT) XQAID,XQAKILL 129 K %I,%W,%Y1,C,DN,I,RADXCODE,RARTMES,RAVERF,RAVERFND,RAPVERF 130 K RAVERS,RAFOOT,RAY0,RAY1,RAY2,RAY3,RALOC,RAFMT,RAMOD,RASTFL,RALB,RALBR 131 K RALBRT,RALBS,RALBST,RAV,RAP,RATAB,RAXX,VAL,VAR,RADFN,RADTI,RACN,RADTE 132 K RARPT,RAHDFM,RAFTFM,RAV,RAIOF,RABTCH,RAOOUT,RAPIR,RAPIS,VAERR,Z 133 ; K RASTRSK S RAFFLF=RAORIOF K RAORIOF,RAFFLF,RAERRFLG 134 ; 05/15/08 BAY/KAM Patch RA*5*92 Added Conditional Kill to next line 135 ; to support an AMIE interface (IA 708) 136 K RASTRSK,RAORIOF,RAFFLF,RAERRFLG K:'($D(RAMIE)#2) DFN 137 ;the next kill line corrects the CPRS V27 report display issue when repeated 138 ;on same patient P92 139 K %,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,RAACNT,RADUPHX,RANUM,RAREZON,RAST 140 Q 141 Q ; Queue the report 142 S ZTDTH=$H,ZTRTN="DQ^RARTR",ZTSAVE("RARPT")="" S:$D(RARTMES) ZTSAVE("RARTMES")="" 143 D ZIS^RAUTL Q:RAPOP 144 ; 145 DQ S U="^",X="T",%DT="" D ^%DT K %DT S DT=Y G PRT 146 ; 147 INIT ; initialize exam/report variables 148 ; main variables set: 149 ; RAY0: zero node data from the Patient File (2) 150 ; RAY1: zero node data from the Rad/Nuc Med Patient File (70) 151 ; RAY2: Registered Exams (70.02) zero node data 152 ; RAY3: Examinations (70.03) zero node data 153 S (RAY0,RAY1,RAY2,RAY3)=-1 ; error condition, if no data nodes 154 S RADFN=+$P(X,"^",2),RADTE=+$P(X,"^",3),RADTI=(9999999.9999-RADTE) 155 S RACN=+$P(X,"^",4),RAST=$P(X,"^",5),RATAB=5 156 S:'$D(RABTCH) RABTCH=0 S (DIWL,DIWF)=0 157 Q:'$D(^RADPT(RADFN,0)) S RANUM=1,RAY1=^(0) 158 Q:'$D(^DPT(RADFN,0)) S RAY0=^(0) 159 Q:'$D(^RADPT(RADFN,"DT",RADTI,0)) S RAY2=^(0) 160 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) 161 S (RAY3,RALB)=$S($D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0)):^(0),1:-1) 162 Q:RAY3<0 ; examinations data missing 163 ; 164 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) 165 S:'DIWL DIWL=5 S:'DIWF DIWF=70 S DIWF="WC"_(DIWF-DIWL) 166 G @$S($D(RAUTOE):"HEAD^RARTR0",1:"HD1") 167 Q 168 ; 169 HD D FOOT^RARTR2:$E(IOST,1,2)'="C-" 170 HD1 S RAFMT=RAHDFM I $D(RARTMES) W:$Y>0 @RAFFLF W !,?((80-$L(RARTMES))/2),RARTMES,! S RAIOF=RAFFLF,RAFFLF="!" 171 I '$D(RARTMES) W:$Y>0 @RAFFLF 172 D PRT^RAFLH S:$D(RARTMES) RAFFLF=RAIOF 173 W:$D(RAERRFLG) !!?10,$$AMENRPT^RARTR2(),!! 174 Q 1 RARTR ;HISC/CAH COLUMBIA/REB AISC/MJK,RMO-Queue/print Reports ;11/27/98 09:05 2 ;;5.0;Radiology/Nuclear Medicine;**5,13,16,27,43,55,75**;Mar 16, 1998;Build 4 3 PRT ; Begin print/build of e-mail message 4 ; 5 ; ** NOTE: If the layout of this output is changed ** 6 ; ** please check that routine RAO7PC3 is ** 7 ; ** not affected. It assumes fixed format of ** 8 ; ** the following headings: ** 9 ; ** Clinical History: ** 10 ; ** Report: ** 11 ; ** Impression: ** 12 ; ** Primary Diagnostic Code: ** 13 ; ** Secondary Diagnostic Codes: ** 14 ; ** Primary Interpreting Staff: ** 15 ; 16 Q:'$D(^RARPT(+$G(RARPT),0)) 17 ; Use and Set if running in the foreground and Writing to the device 18 I '$D(RAUTOE) D 19 . U IO 20 . S RAFFLF=IOF 21 . S RAORIOF=RAFFLF 22 ; 23 W:$Y>0&('$D(RAUTOE)) @RAFFLF ; If RAUTOE defined build mail msg 24 S X=$G(^RARPT(+$G(RARPT),0)) ; RAORIOF=RAFFLF 25 ; 26 ;S RAFFLF=$S('$D(ORACTION):RAFFLF,ORACTION'=8:RAFFLF,1:"!") 27 D INIT ; setup exam/report variables 28 I RAY0<0!(RAY1<0)!(RAY2<0)!(RAY3<0) K RAFFLF Q ; data nodes missing 29 ; 30 PRT1 I $D(RAUTOE) D 31 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" " 32 . I $D(RADDEN) D 33 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Unverified by: "_$P($G(^VA(200,$S($G(RADUZ):RADUZ,1:DUZ),0)),"^") 34 .. Q 35 . Q 36 I +$O(^RARPT(RARPT,"ERR",0)) D 37 . S RAERRFLG="" ; set for future reference (display AMENRPT^RARTR text) 38 . W:'$D(RAUTOE) !!?10,$$AMENRPT^RARTR2(),! 39 . I $D(RAUTOE) D 40 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" " 41 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2() 42 .. Q 43 . Q 44 I $P(RAY3,"^",25)<2 D G END:$D(RAOOUT) 45 . D MODS^RAUTL2,OUT1^RARTR3 46 . D:+$P(RAY3,"^",28) RDIO^RARTUTL(+$P(RAY3,"^",28)) Q:$D(RAOOUT) 47 . D:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",") 48 . ;W:'$D(RAUTOE) ! 49 . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 50 . Q 51 I $P(RAY3,"^",25)>1 D 52 . D MEMS1^RARTR3 53 . W:'$D(RAUTOE) ! 54 . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 55 . Q 56 G END:$D(RAOOUT) 57 ; Check for duplicate history in file 70 and 74. 58 D CHKDUPHX^RART1 ; Sets RADUPHX to 1 for duplicate or 0 if different. 59 F RAP="H","AH","R","I" K ^UTILITY($J,"W"),^(1) D G END:$D(RAOOUT) 60 . S RAP("P")=$S(RAP="H":"Clinical History:",RAP="AH":"Additional Clinical History:",RAP="R":"Report:",1:"Impression:") 61 . ; Don't continue if printing Additional Clinical History and it is a 62 . ; duplicate of Clinical History. 63 . Q:RAP="AH"&(RADUPHX>0) 64 . W:'$D(RAUTOE) !?RATAB,RAP("P") 65 . I $D(RAUTOE),($D(RADDEN)),(RAP="R") D 66 .. N RABAN1,RABAN2,RASPCE S $P(RASPCE," ",46)="" 67 .. S RABAN1="*** Uncorrected Version ***" 68 .. S RABAN2="*** Refer to final report ***" 69 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 70 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN1 71 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN2 72 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 73 .. Q 74 . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_RAP("P") 75 . W:$D(RASTFL)&(RAP="R")&('$D(RAUTOE)) ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),"^",2)) 76 . I RAP="R",($D(RAUTOE)) D 77 .. S $P(RAP("S")," ",(46-$L(^TMP($J,"RA AUTOE",RAACNT))))="" 78 .. I '$D(RADDEN) S ^TMP($J,"RA AUTOE",RAACNT)=^(RAACNT)_RAP("S")_"Status: "_$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),"^",2)) 79 .. Q 80 . D:$D(RAUTOE) SET^RARTR2 81 . D:'$D(RAUTOE) WRITE^RARTR2 Q:$D(RAOOUT) 82 . K ^UTILITY($J,"W") 83 . Q 84 I $D(RADDEN),($G(^RARPT(RARPT,"PURGE"))) D 85 . ; when the report is unverified and purge data exists (rpt adden) 86 . N RAPRGE S RAPRGE=+$G(^RARPT(RARPT,"PURGE")) 87 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 88 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Purged: "_$$FMTE^XLFDT(RAPRGE,"1P") 89 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 90 . Q 91 I $P($G(^RA(79.1,+$P(RAY2,U,4),0)),U,18)="Y" D PRTDX^RARTR1 G:$D(RAOOUT) END ;print dx codes 92 D EN1^RARTR0 G:$D(RAOOUT) END 93 I '$D(RAVERFND) D G END:$D(RAOOUT) 94 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD:($Y+RAFOOT+4)>IOSL 95 . N RADFTSBN,RADFTSBT S:$D(RADDEN) RAVERF=+$P(RA74B4,"^",9) 96 . S RADFTSBN=$E($P($G(^VA(200,RAVERF,20)),"^",2),1,25) 97 . S:RADFTSBN']"" RADFTSBN=$E($P($G(^VA(200,RAVERF,0)),"^"),1,25) 98 . S RADFTSBT=$E($P($G(^VA(200,RAVERF,20)),"^",3),1,30) 99 . I RADFTSBT']"" S RADFTSBT=$$TITLE^RARTR0(RAVERF) 100 . W:'$D(RAUTOE) !!,"VERIFIED BY:",!?2,$S(RADFTSBN]"":RADFTSBN,1:"") 101 . W:RADFTSBT]""&('$D(RAUTOE)) ", "_RADFTSBT 102 . I $D(RAUTOE) D 103 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="VERIFIED BY:" 104 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RADFTSBN]"":RADFTSBN,1:"")_$S(RADFTSBT]"":", "_RADFTSBT,1:"") 105 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 106 .. Q 107 . Q 108 K RASBPN,RASBT,RASECIEN,RASECOND,RASECSS 109 I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 G END:$D(RAOOUT) D HD:($Y+RAFOOT+4)>IOSL 110 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) 111 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:"") 112 S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 113 D HANG^RARTR2 G END:$D(RAOOUT) 114 I RAST'="V" D:'$D(RAMDV) SETDIV^RARTR2 I $P(RAMDV,U,25) D WARNING^RARTR1 115 G PEND:RAST'="PD" 116 S $P(RASTRSK,"*",80)="" 117 I '$D(RAUTOE) D 118 . D HD:($Y+RAFOOT+9)>IOSL 119 . 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) 120 . W !!,$S($D(^RARPT(RARPT,"P")):^("P"),1:"None entered.") W !!,RASTRSK 121 . Q 122 E D 123 . 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) 124 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$S($D(^RARPT(RARPT,"P")):^("P"),1:"None entered.") 125 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 126 . Q 127 PEND D FOOT^RARTR2,HANG^RARTR2 D:'$D(RAMIE)&('$D(RAUTOE)) Q^RAFLH1 128 END K:$D(RAOOUT) XQAID,XQAKILL 129 K %I,%W,%Y1,C,DN,I,RADXCODE,RARTMES,RAVERF,RAVERFND,RAPVERF 130 K RAVERS,RAFOOT,RAY0,RAY1,RAY2,RAY3,RALOC,RAFMT,RAMOD,RASTFL,RALB,RALBR 131 K RALBRT,RALBS,RALBST,RAV,RAP,RATAB,RAXX,VAL,VAR,RADFN,RADTI,RACN,RADTE 132 K RARPT,RAHDFM,RAFTFM,RAV,RAIOF,RABTCH,RAOOUT,RAPIR,RAPIS,VAERR,Z 133 ; K RASTRSK S RAFFLF=RAORIOF K RAORIOF,RAFFLF,RAERRFLG 134 K RASTRSK,RAORIOF,RAFFLF,RAERRFLG 135 Q 136 Q ; Queue the report 137 S ZTDTH=$H,ZTRTN="DQ^RARTR",ZTSAVE("RARPT")="" S:$D(RARTMES) ZTSAVE("RARTMES")="" 138 D ZIS^RAUTL Q:RAPOP 139 ; 140 DQ S U="^",X="T",%DT="" D ^%DT K %DT S DT=Y G PRT 141 ; 142 INIT ; initialize exam/report variables 143 ; main variables set: 144 ; RAY0: zero node data from the Patient File (2) 145 ; RAY1: zero node data from the Rad/Nuc Med Patient File (70) 146 ; RAY2: Registered Exams (70.02) zero node data 147 ; RAY3: Examinations (70.03) zero node data 148 S (RAY0,RAY1,RAY2,RAY3)=-1 ; error condition, if no data nodes 149 S RADFN=+$P(X,"^",2),RADTE=+$P(X,"^",3),RADTI=(9999999.9999-RADTE) 150 S RACN=+$P(X,"^",4),RAST=$P(X,"^",5),RATAB=5 151 S:'$D(RABTCH) RABTCH=0 S (DIWL,DIWF)=0 152 Q:'$D(^RADPT(RADFN,0)) S RANUM=1,RAY1=^(0) 153 Q:'$D(^DPT(RADFN,0)) S RAY0=^(0) 154 Q:'$D(^RADPT(RADFN,"DT",RADTI,0)) S RAY2=^(0) 155 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) 156 S (RAY3,RALB)=$S($D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0)):^(0),1:-1) 157 Q:RAY3<0 ; examinations data missing 158 ; 159 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) 160 S:'DIWL DIWL=5 S:'DIWF DIWF=70 S DIWF="WC"_(DIWF-DIWL) 161 G @$S($D(RAUTOE):"HEAD^RARTR0",1:"HD1") 162 Q 163 ; 164 HD D FOOT^RARTR2:$E(IOST,1,2)'="C-" 165 HD1 S RAFMT=RAHDFM I $D(RARTMES) W:$Y>0 @RAFFLF W !,?((80-$L(RARTMES))/2),RARTMES,! S RAIOF=RAFFLF,RAFFLF="!" 166 I '$D(RARTMES) W:$Y>0 @RAFFLF 167 D PRT^RAFLH S:$D(RARTMES) RAFFLF=RAIOF 168 W:$D(RAERRFLG) !!?10,$$AMENRPT^RARTR2(),!! 169 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR0.m
r613 r623 1 RARTR0 ;HISC/GJC-Queue/Print Radiology Rpts utility routine. ;1/8/97 08:07 2 ;;5.0;Radiology/Nuclear Medicine;**8,26,74,84**;Mar 16, 1998;Build 13 3 ; 06/28/2006 BAY/KAM Remedy Call 146291 - Change Patient Age to DOB 4 ; 5 ;Integration Agreements 6 ;---------------------- 7 ;DT^DILF(2054); GETS^DIQ(2056); $$FMTE^XLFDT(10103); $$UP^XLFSTR(10104) 8 ;NEW PERSON file read w/FM (10060) 9 ; 10 EN1 ; Called from RARTR ;P84 GETS^DIQ added... 11 S RARPT(0)=$G(^RARPT(+$G(RARPT),0)) Q:RARPT(0)']"" 12 S RARPT(10)=$P(RARPT(0),"^",10) 13 S RAVERF=+$P(RARPT(0),U,9),RAPVERF=+$P(RARPT(0),U,13) 14 K RAPIR,RAPIS S RAPIR=+$P(RALB,"^",12),RAPIS=+$P(RALB,"^",15) 15 ;format of the RAPIR/RAPIS arrays: P84 logic 16 ;RAPI*=IEN file 200 17 ;RAPI*(200,RAPI*,.01)= NAME (required) 18 ;RAPI*(200,RAPI*,20.2) = SIGNATURE BLOCK PRINTED NAME (if any) 19 ;RAPI*(200,RAPI*,20.3) = SIGNATURE BLOCK TITLE (if any) 20 I RAPIR D GETS^DIQ(200,RAPIR,".01;20.2;20.3","","RAPIR") S RAPIR("IENS")=RAPIR_"," 21 I RAPIS D GETS^DIQ(200,RAPIS,".01;20.2;20.3","","RAPIS") S RAPIS("IENS")=RAPIS_"," 22 S RAWHOVER=+$P(RARPT(0),"^",17) 23 I RAVERF,((RAPIR=RAVERF)!(RAPIS=RAVERF)) D 24 . S RAVERFND="" ; Set verifier found flag 25 . Q 26 I RAPIS D Q:$D(RAOOUT) 27 . ;get signature block name if defined 28 . S RALBS=$E(RAPIS(200,RAPIS("IENS"),20.2),1,25) 29 . S:RALBS="" RALBS=$E(RAPIS(200,RAPIS("IENS"),.01),1,25) ;default to NAME 30 . ; 31 . ;get signature block title if defined 32 . S RALBST=$G(RAPIS(200,RAPIS("IENS"),20.3)) ; max: 50 chars 33 . S:RALBST="" RALBST=$$TITLE^RARTR0(RAPIS) 34 . ; 35 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) 36 . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL 37 . I '$D(RAUTOE) D 38 .. W !,"Primary Interpreting Staff:",!?2,$S(RALBS]"":RALBS,1:"Unknown") 39 .. W:$L(RALBST) ", "_$E(RALBST,1,((IOM-$X)-16)) 40 .. ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING 41 .. Q 42 . E D 43 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Staff:" 44 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RALBS]"":RALBS,1:"Unknown") 45 .. Q:'$L(RALBST) N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT)) 46 .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBST,1,((80-RALEN)-16)) 47 .. Q 48 . I $D(RAVERFND)&(RAPIS=RAVERF),(RAPIS(200,RAPIS("IENS"),.01)'="RADIOLOGY,OUTSIDE SERVICE") D 49 .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q 50 ... W:RAWHOVER=RAPIS !?10,"(Verifier, no e-sig)" 51 ... W:RAWHOVER'=RAPIS !?10,"Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D." 52 ... Q 53 .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q 54 ... S:RAWHOVER=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)" 55 ... S:RAWHOVER'=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D." 56 ... Q 57 .. W:'$D(RAUTOE) " (Verifier)" 58 .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)" 59 .. Q 60 . I RAPIS=RAPVERF,'$D(RAUTOE) W " (Pre-Verifier)" 61 . I RAPIS=RAPVERF,$D(RAUTOE) S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)" 62 . Q 63 D SECSTF^RARTR1 Q:$D(RAOOUT) ; Print secondary interp'ting staff now 64 ;now for primary resident definitions... 65 I RAPIR D Q:$D(RAOOUT) 66 . ;get signature block name if defined 67 . S RALBR=$E(RAPIR(200,RAPIR("IENS"),20.2),1,25) 68 . S:RALBR="" RALBR=$E(RAPIR(200,RAPIR("IENS"),.01),1,25) ;default to NAME 69 . ; 70 . ;get signature block title if defined 71 . S RALBRT=$G(RAPIR(200,RAPIR("IENS"),20.3)) ; max: 50 chars 72 . S:RALBRT="" RALBRT=$$TITLE^RARTR0(RAPIR) 73 . ; 74 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) 75 . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL 76 . I '$D(RAUTOE) D 77 .. W !,"Primary Interpreting Resident:",!?2,$S(RALBR]"":RALBR,1:"Unknown") 78 .. W:$L(RALBRT) ", "_$E(RALBRT,1,((IOM-$X)-16)) 79 .. Q 80 . I $D(RAUTOE) D 81 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Resident:" 82 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RALBR]"":RALBR,1:"Unknown") 83 .. Q:'$L(RALBRT) N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT)) 84 .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBRT,1,((80-RALEN)-16)) 85 .. Q 86 . I $D(RAVERFND)&(RAPIR=RAVERF) D 87 .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q 88 ... W:RAWHOVER=RAPIR !?10,"(Verifier, no e-sig)" 89 ... W:RAWHOVER'=RAPIR !?10,"Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D." 90 ... Q 91 .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q 92 ... S:RAWHOVER=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)" 93 ... S:RAWHOVER'=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D." 94 ... Q 95 .. W:'$D(RAUTOE) " (Verifier)" 96 .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)" 97 .. Q 98 . I RAPIR=RAPVERF,('$D(RAUTOE)) W " (Pre-Verifier)" 99 . I RAPIR=RAPVERF,($D(RAUTOE)) S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)" 100 . Q 101 D SECRES^RARTR1 ; Print out secondary interp'ting resident now 102 K RAPIR,RAPIS ;P84 kills added 103 Q 104 ; 105 TITLE(X) ;Return the radiology classification in lieu of the signature block title 106 ; 'X' is the IEN of the Primary Interpreting Resident i.e, ^DD(70.03,12 107 ; -OR- 108 ; 'X' is the IEN of the Primary Interpreting Staff i.e, ^DD(70.03,15 109 Q $S($D(^VA(200,"ARC","R",X)):"Resident Physician",$D(^VA(200,"ARC","S",X)):"Staff Physician",1:"") 110 ; 111 HEAD ; Set up header info for e-mail message (called from INIT^RARTR) 112 ; 06/28/2006 BAY/KAM Remedy Call 146291 Change Patient Age to DOB 113 N RAGE,RATPHY,RACSE,RAILOC,RANME,RAPRIPHY,RAPTLOC,RAREQPHY,RASERV,RASEX,RADOB 114 N RASPACE,RASSN,X1,X2 S:'$D(RAACNT) RAACNT=0 115 ;Added next line for Remedy Call 146291 116 D DT^DILF("E",$P(RAY0,"^",3),.RADOB) ;Get Date of Birth/External Fmt 117 ; 118 S RANME=$P(RAY0,"^"),RASSN=$P(RAY0,"^",9) 119 S RASEX=$$UP^XLFSTR($P(RAY0,"^",2)) 120 S RACSE=$P($G(^RARPT(RARPT,0)),"^")_"@"_$P($$FMTE^XLFDT($P(RAY2,"^")),"@",2) 121 ; Remedy Call 146291 Removed line calculating age 122 S RAREQPHY=$$XTERNAL^RAUTL5($P(RAY3,"^",14),$P($G(^DD(70.03,14,0)),"^",2)) 123 S RAPTLOC=$$PTLOC^RAUTL12() S:RAREQPHY']"" RAREQPHY="Unknown" 124 S RASERV=$$XTERNAL^RAUTL5($P(RAY3,"^",7),$P($G(^DD(70.03,7,0)),"^",2)) 125 S RATPHY=$$ATND^RAUTL5(RADFN,DT),RAPRIPHY=$$PRIM^RAUTL5(RADFN,DT) 126 S RAILOC=$$XTERNAL^RAUTL5($P(RAY2,"^",4),$P($G(^DD(70.02,4,0)),"^",2)) 127 S:RAILOC']"" RAILOC="Unknown" S:RASERV']"" RASERV="Unknown" 128 S RANME=$E(RANME,1,20)_" " 129 S RASSN=$E(RASSN,1,3)_"-"_$E(RASSN,4,5)_"-"_$E(RASSN,6,9)_" " 130 ; Remedy Call 146291 Changed next line to use RADOB(0) 131 S RAGE="DOB-"_RADOB(0)_" "_$S(RASEX="F":"F",RASEX="M":"M",1:"UNK") 132 S $P(RASPACE," ",(22-$L(RAGE)))="" 133 S RAGE=RAGE_RASPACE,RACSE="Case: "_RACSE 134 S RAREQPHY="Req Phys: "_$E(RAREQPHY,1,28) 135 S RASPACE="",$P(RASPACE," ",(42-$L(RAREQPHY)))="" 136 S RAREQPHY=RAREQPHY_RASPACE 137 S RAPTLOC="Pat Loc: "_$S(RAPTLOC]"":$E(RAPTLOC,1,30),1:"Unknown") 138 S RATPHY="Att Phys: "_$E(RATPHY,1,28) 139 S RASPACE="",$P(RASPACE," ",(42-$L(RATPHY)))="" 140 S RATPHY=RATPHY_RASPACE 141 S RAILOC="Img Loc: "_$E(RAILOC,1,30) 142 S RAPRIPHY="Pri Phys: "_$E(RAPRIPHY,1,28) 143 S RASPACE="",$P(RASPACE," ",(42-$L(RAPRIPHY)))="" 144 S RAPRIPHY=RAPRIPHY_RASPACE 145 S RASERV="Service: "_$E(RASERV,1,30) 146 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RANME_RASSN_RAGE_RACSE 147 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAREQPHY_RAPTLOC 148 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RATPHY_RAILOC 149 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAPRIPHY_RASERV 150 S:$D(RAERRFLG) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2() 151 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 152 Q 1 RARTR0 ;HISC/GJC-Queue/Print Radiology Rpts utility routine. ;1/8/97 08:07 2 ;;5.0;Radiology/Nuclear Medicine;**8,26,74**;Mar 16, 1998;Build 2 3 ; 06/28/2006 BAY/KAM Remedy Call 146291 - Change Patient Age to DOB 4 EN1 ; Called from RARTR 5 S RARPT(0)=$G(^RARPT(+$G(RARPT),0)) Q:RARPT(0)']"" 6 S RARPT(10)=$P(RARPT(0),"^",10) 7 S RAVERF=+$P(RARPT(0),U,9),RAPVERF=+$P(RARPT(0),U,13) 8 S RAPIR=+$P(RALB,"^",12),RAPIS=+$P(RALB,"^",15) 9 S RAWHOVER=+$P(RARPT(0),"^",17) 10 I RAVERF,((RAPIR=RAVERF)!(RAPIS=RAVERF)) D 11 . S RAVERFND="" ; Set verifier found flag 12 . Q 13 I RAPIS D Q:$D(RAOOUT) 14 . S RALBS=$E($P($G(^VA(200,RAPIS,20)),"^",2),1,25) 15 . S:RALBS']"" RALBS=$E($P($G(VA(200,RAPIS,0)),"^"),1,25) 16 . S RALBST=$P($G(^VA(200,RAPIS,20)),"^",3) ; max: 50 chars 17 . I RALBST']"" S RALBST=$$TITLE^RARTR0(RAPIS) 18 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) 19 . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL 20 . I '$D(RAUTOE) D 21 .. W !,"Primary Interpreting Staff:" 22 .. W !?2,$S(RALBS]"":RALBS,1:"Unknown"),", ",$E(RALBST,1,((IOM-$X)-16)) 23 .. ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING 24 .. Q 25 . E D 26 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Staff:" 27 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RALBS]"":RALBS,1:"Unknown") 28 .. N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT)) 29 .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBST,1,((80-RALEN)-16)) 30 .. Q 31 . I $D(RAVERFND)&(RAPIS=RAVERF) D 32 .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q 33 ... W:RAWHOVER=RAPIS !?10,"(Verifier, no e-sig)" 34 ... W:RAWHOVER'=RAPIS !?10,"Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D." 35 ... Q 36 .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q 37 ... S:RAWHOVER=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)" 38 ... S:RAWHOVER'=RAPIS ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBS ;Removed RA*5*8 _", M.D." 39 ... Q 40 .. W:'$D(RAUTOE) " (Verifier)" 41 .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)" 42 .. Q 43 . I RAPIS=RAPVERF,'$D(RAUTOE) W " (Pre-Verifier)" 44 . I RAPIS=RAPVERF,$D(RAUTOE) S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)" 45 . Q 46 D SECSTF^RARTR1 Q:$D(RAOOUT) ; Print secondary interp'ting staff now 47 I RAPIR D Q:$D(RAOOUT) 48 . S RALBR=$E($P($G(^VA(200,RAPIR,20)),"^",2),1,25) 49 . S:RALBR']"" RALBR=$E($P($G(VA(200,RAPIR,0)),"^"),1,25) 50 . S RALBRT=$P($G(^VA(200,RAPIR,20)),"^",3) ; max: 50 chars 51 . I RALBRT']"" S RALBRT=$$TITLE^RARTR0(RAPIR) 52 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) 53 . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL 54 . W:'$D(RAUTOE) !,"Primary Interpreting Resident:" 55 . W:'$D(RAUTOE) !?2,$S(RALBR]"":RALBR,1:"Unknown")_", ",$E(RALBRT,1,((IOM-$X)-16)) 56 . ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING 57 . I $D(RAUTOE) D 58 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Resident:" 59 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RALBR]"":RALBR,1:"Unknown") 60 .. N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT)) 61 .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBRT,1,((80-RALEN)-16)) 62 .. Q 63 . I $D(RAVERFND)&(RAPIR=RAVERF) D 64 .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q 65 ... W:RAWHOVER=RAPIR !?10,"(Verifier, no e-sig)" 66 ... W:RAWHOVER'=RAPIR !?10,"Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D." 67 ... Q 68 .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q 69 ... S:RAWHOVER=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)" 70 ... S:RAWHOVER'=RAPIR ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RALBR ;Removed RA*5*8 _", M.D." 71 ... Q 72 .. W:'$D(RAUTOE) " (Verifier)" 73 .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)" 74 .. Q 75 . I RAPIR=RAPVERF,('$D(RAUTOE)) W " (Pre-Verifier)" 76 . I RAPIR=RAPVERF,($D(RAUTOE)) S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)" 77 . Q 78 D SECRES^RARTR1 ; Print out secondary interp'ting resident now 79 Q 80 TITLE(X) ; Determine an individuals title 81 ; 'X' is the IEN of the Primary Interpreting Resident i.e, ^DD(70.03,12 82 ; -OR- 83 ; 'X' is the IEN of the Primary Interpreting Staff i.e, ^DD(70.03,15 84 N Y 85 I $D(^VA(200,"ARC","R",X)) S Y="Resident Physician" Q Y 86 I $D(^VA(200,"ARC","S",X)) S Y="Staff Physician" Q Y 87 S Y="" 88 Q Y 89 HEAD ; Set up header info for e-mail message (called from INIT^RARTR) 90 ; 06/28/2006 BAY/KAM Remedy Call 146291 Change Patient Age to DOB 91 N RAGE,RATPHY,RACSE,RAILOC,RANME,RAPRIPHY,RAPTLOC,RAREQPHY,RASERV,RASEX,RADOB 92 N RASPACE,RASSN,X1,X2 S:'$D(RAACNT) RAACNT=0 93 ;Added next line for Remedy Call 146291 94 D DT^DILF("E",$P(RAY0,"^",3),.RADOB) ;Get Date of Birth/External Fmt 95 ; 96 S RANME=$P(RAY0,"^"),RASSN=$P(RAY0,"^",9) 97 S RASEX=$$UP^XLFSTR($P(RAY0,"^",2)) 98 S RACSE=$P($G(^RARPT(RARPT,0)),"^")_"@"_$P($$FMTE^XLFDT($P(RAY2,"^")),"@",2) 99 ; Remedy Call 146291 Removed line calculating age 100 S RAREQPHY=$$XTERNAL^RAUTL5($P(RAY3,"^",14),$P($G(^DD(70.03,14,0)),"^",2)) 101 S RAPTLOC=$$PTLOC^RAUTL12() S:RAREQPHY']"" RAREQPHY="Unknown" 102 S RASERV=$$XTERNAL^RAUTL5($P(RAY3,"^",7),$P($G(^DD(70.03,7,0)),"^",2)) 103 S RATPHY=$$ATND^RAUTL5(RADFN,DT),RAPRIPHY=$$PRIM^RAUTL5(RADFN,DT) 104 S RAILOC=$$XTERNAL^RAUTL5($P(RAY2,"^",4),$P($G(^DD(70.02,4,0)),"^",2)) 105 S:RAILOC']"" RAILOC="Unknown" S:RASERV']"" RASERV="Unknown" 106 S RANME=$E(RANME,1,20)_" " 107 S RASSN=$E(RASSN,1,3)_"-"_$E(RASSN,4,5)_"-"_$E(RASSN,6,9)_" " 108 ; Remedy Call 146291 Changed next line to use RADOB(0) 109 S RAGE="DOB-"_RADOB(0)_" "_$S(RASEX="F":"F",RASEX="M":"M",1:"UNK") 110 S $P(RASPACE," ",(22-$L(RAGE)))="" 111 S RAGE=RAGE_RASPACE,RACSE="Case: "_RACSE 112 S RAREQPHY="Req Phys: "_$E(RAREQPHY,1,28) 113 S RASPACE="",$P(RASPACE," ",(42-$L(RAREQPHY)))="" 114 S RAREQPHY=RAREQPHY_RASPACE 115 S RAPTLOC="Pat Loc: "_$S(RAPTLOC]"":$E(RAPTLOC,1,30),1:"Unknown") 116 S RATPHY="Att Phys: "_$E(RATPHY,1,28) 117 S RASPACE="",$P(RASPACE," ",(42-$L(RATPHY)))="" 118 S RATPHY=RATPHY_RASPACE 119 S RAILOC="Img Loc: "_$E(RAILOC,1,30) 120 S RAPRIPHY="Pri Phys: "_$E(RAPRIPHY,1,28) 121 S RASPACE="",$P(RASPACE," ",(42-$L(RAPRIPHY)))="" 122 S RAPRIPHY=RAPRIPHY_RASPACE 123 S RASERV="Service: "_$E(RASERV,1,30) 124 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RANME_RASSN_RAGE_RACSE 125 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAREQPHY_RAPTLOC 126 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RATPHY_RAILOC 127 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAPRIPHY_RASERV 128 S:$D(RAERRFLG) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2() 129 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 130 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR1.m
r613 r623 1 RARTR1 ;HISC/FPT,GJC-Queue/print Radiology Reports (cont.) ;1/8/97 08:08 2 ;;5.0;Radiology/Nuclear Medicine;**8,18,56**;Mar 16, 1998;Build 3 3 ;Supported IA #10104 REPEAT^XLFSTR 4 ;Supported IA #10060 and #2056 $$GET1^DIQ for file 200 5 ;last modification by SS for P18 JUNE 29,00 6 PRTDX ; print dx codes on report 7 I '$D(RAUTOE) D HANG^RARTR2:($Y+RAFOOT+4)>IOSL Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL 8 S RADXCODE=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13) 9 I '$D(RAUTOE) W !?RATAB,"Primary Diagnostic Code: ",!?RATAB+4,$S($D(^RA(78.3,+RADXCODE,0)):$P(^(0),U,1),1:"") 10 I $D(RAUTOE) D 11 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Primary Diagnostic Code: "_$S($D(^RA(78.3,+RADXCODE,0)):$P(^(0),U,1),1:"") 12 . Q 13 I '$D(RAUTOE) D HANG^RARTR2:($Y+RAFOOT+4)>IOSL Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL 14 I '$D(RAUTOE),('$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))) W ! Q 15 I '$D(RAUTOE),($O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))) D Q 16 . W !!?RATAB,"Secondary Diagnostic Codes: " 17 . S RADXCODE=0 18 . F S RADXCODE=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX","B",RADXCODE)) Q:RADXCODE'>0!('$D(^RA(78.3,+RADXCODE,0)))!($D(RAOOUT)) D 19 .. D HANG^RARTR2:($Y+RAFOOT+4)>IOSL Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL W !?RATAB+4,$P(^RA(78.3,RADXCODE,0),U,1) 20 .. Q 21 . K RADXCODE W ! 22 . Q 23 I $D(RAUTOE),('$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))) D Q 24 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 25 . Q 26 I $D(RAUTOE),($O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))) D 27 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Secondary Diagnostic Codes: " 28 . S RADXCODE=0 29 . F S RADXCODE=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX","B",RADXCODE)) Q:RADXCODE'>0 D 30 .. Q:'$D(^RA(78.3,+$G(RADXCODE),0))#2 31 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$P(^RA(78.3,+$G(RADXCODE),0),U) 32 .. Q 33 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 34 . Q 35 Q 36 WARNING ; this printed report should not be used for charting 37 S RARPTSTT=$$RSTAT^RAO7PC1A() 38 S:RARPTSTT="NO REPORT" RARPTSTT="REPORT STATUS UNKNOWN" 39 S:RAST="R" RARPTSTT="("_RARPTSTT_")" 40 S RAPOSITN=(80-$L(RARPTSTT)\2) 41 I '$D(RAUTOE) D ;P18 modif 42 . W !?RAPOSITN-1,$$REPEAT^XLFSTR("*",$L(RARPTSTT)+2) 43 . W:RAST="R" !?(80-$L(RARPTSTT)\2)-1,"* PRELIMINARY REPORT *" ;P18 44 . W !?(80-$L(RARPTSTT)\2)-1,"*"_RARPTSTT_"*",!?RAPOSITN-1,$$REPEAT^XLFSTR("*",$L(RARPTSTT)+2) 45 . Q 46 I $D(RAUTOE) D 47 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$$REPEAT^XLFSTR("*",$L(RARPTSTT)+2) 48 . I RAST="R" S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="* PRELIMINARY REPORT *" ;P18 49 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="*"_RARPTSTT_"*" ;P18 50 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$$REPEAT^XLFSTR("*",$L(RARPTSTT)+2) 51 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 52 . Q 53 K RAPOSITN,RARPTSTT 54 Q 55 SECRES ; Print from the secondary resident multiple 56 Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",0)) ; no data, quit 57 N RASR,RASRSBN,RASRSBT,DIERR,RAZ 58 I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL 59 W:'$D(RAUTOE) !,"Secondary Interpreting Resident:" 60 S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Secondary Interpreting Resident:" 61 S RASR=0 62 F S RASR=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RASR)) Q:RASR'>0 D 63 . S RASR(0)=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RASR,0)) 64 . S RAZ=$$GET1^DIQ(200,+RASR(0)_",",.01) 65 . Q:RAZ="" 66 . S RASRSBN=$E($$GET1^DIQ(200,+RASR(0)_",",20.2),1,25) 67 . S:RASRSBN']"" RASRSBN=$E(RAZ,1,25) 68 . S RASRSBT=$$GET1^DIQ(200,+RASR(0)_",",20.3) ; max:; 50 chars 69 . I RASRSBT']"" S RASRSBT=$$TITLE^RARTR0(+RASR(0)) 70 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL 71 . W:'$D(RAUTOE) !?2,$S(RASRSBN]"":RASRSBN,1:"Unknown"),", ",$E(RASRSBT,1,((IOM-$X)-16)) 72 . ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING 73 . I $D(RAUTOE) D 74 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RASRSBN]"":RASRSBN,1:"Unknown") 75 .. N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT)) 76 .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RASRSBT,1,((80-RALEN)-16)) 77 .. Q 78 . I '$D(RAVERFND),(RAVERF=+RASR(0)) D 79 .. S RAVERFND="" 80 .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q 81 ... W:RAWHOVER=+RASR(0) !?10,"(Verifier, no e-sig)" 82 ... W:RAWHOVER'=+RASR(0) !?10,"Verified by transcriptionist for "_RASRSBN ;Removed RA*5*8 _", M.D." 83 ... Q 84 .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q 85 ... S:RAWHOVER=+RASR(0) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)" 86 ... S:RAWHOVER'=+RASR(0) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RASRSBN ;Removed RA*5*8 _", M.D." 87 ... Q 88 .. W:'$D(RAUTOE) " (Verifier)" 89 .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)" 90 .. Q 91 . I RAPVERF=+RASR(0) W:'$D(RAUTOE) " (Pre-Verifier)" S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)" 92 . Q 93 Q 94 SECSTF ; Print from the secondary staff multiple 95 Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",0)) ; no data, quit 96 N RASS,RASSSBN,RASSSBT,DIERR,RAZ 97 I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL 98 W:'$D(RAUTOE) !,"Secondary Interpreting Staff:" 99 S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Secondary Interpreting Staff:" 100 S RASS=0 101 F S RASS=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RASS)) Q:RASS'>0 D 102 . S RASS(0)=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RASS,0)) 103 . S RAZ=$$GET1^DIQ(200,+RASS(0)_",",.01) 104 . Q:RAZ="" 105 . S RASSSBN=$E($$GET1^DIQ(200,+RASS(0)_",",20.2),1,25) 106 . S:RASSSBN="" RASSSBN=$E(RAZ,1,25) 107 . S RASSSBT=$$GET1^DIQ(200,+RASS(0)_",",20.3) ; max: 50 chars 108 . I RASSSBT']"" S RASSSBT=$$TITLE^RARTR0(+RASS(0)) 109 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL 110 . W:'$D(RAUTOE) !?2,$S(RASSSBN]"":RASSSBN,1:"Unknown"),", ",$E(RASSSBT,1,((IOM-$X)-16)) 111 . ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING 112 . I $D(RAUTOE) D 113 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RASSSBN]"":RASSSBN,1:"Unknown") 114 .. N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT)) 115 .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RASSSBT,1,((80-RALEN)-16)) 116 .. Q 117 . I '$D(RAVERFND),(RAVERF=+RASS(0)) D 118 .. S RAVERFND="" 119 .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q 120 ... W:RAWHOVER=+RASS(0) !?10,"(Verifier, no e-sig)" 121 ... W:RAWHOVER'=+RASS(0) !?10,"Verified by transcriptionist for "_RASSSBN ;Removed RA*5*8 _", M.D." 122 ... Q 123 .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q 124 ... S:RAWHOVER=+RASS(0) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)" 125 ... S:RAWHOVER'=+RASS(0) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RASSSBN ;Removed RA*5*8 _", M.D." 126 ... Q 127 .. W:'$D(RAUTOE) " (Verifier)" 128 .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)" 129 .. Q 130 . I RAPVERF=+RASS(0) W:'$D(RAUTOE) " (Pre-Verifier)" S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)" 131 . Q 132 Q 1 RARTR1 ;HISC/FPT,GJC-Queue/print Radiology Reports (cont.) ;1/8/97 08:08 2 ;;5.0;Radiology/Nuclear Medicine;**8,18**;Mar 16, 1998 3 ;last modification by SS for P18 JUNE 29,00 4 PRTDX ; print dx codes on report 5 I '$D(RAUTOE) D HANG^RARTR2:($Y+RAFOOT+4)>IOSL Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL 6 S RADXCODE=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13) 7 I '$D(RAUTOE) W !?RATAB,"Primary Diagnostic Code: ",!?RATAB+4,$S($D(^RA(78.3,+RADXCODE,0)):$P(^(0),U,1),1:"") 8 I $D(RAUTOE) D 9 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Primary Diagnostic Code: "_$S($D(^RA(78.3,+RADXCODE,0)):$P(^(0),U,1),1:"") 10 . Q 11 I '$D(RAUTOE) D HANG^RARTR2:($Y+RAFOOT+4)>IOSL Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL 12 I '$D(RAUTOE),('$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))) W ! Q 13 I '$D(RAUTOE),($O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))) D Q 14 . W !!?RATAB,"Secondary Diagnostic Codes: " 15 . S RADXCODE=0 16 . F S RADXCODE=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX","B",RADXCODE)) Q:RADXCODE'>0!('$D(^RA(78.3,+RADXCODE,0)))!($D(RAOOUT)) D 17 .. D HANG^RARTR2:($Y+RAFOOT+4)>IOSL Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL W !?RATAB+4,$P(^RA(78.3,RADXCODE,0),U,1) 18 .. Q 19 . K RADXCODE W ! 20 . Q 21 I $D(RAUTOE),('$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))) D Q 22 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 23 . Q 24 I $D(RAUTOE),($O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))) D 25 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Secondary Diagnostic Codes: " 26 . S RADXCODE=0 27 . F S RADXCODE=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX","B",RADXCODE)) Q:RADXCODE'>0 D 28 .. Q:'$D(^RA(78.3,+$G(RADXCODE),0))#2 29 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$P(^RA(78.3,+$G(RADXCODE),0),U) 30 .. Q 31 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 32 . Q 33 Q 34 WARNING ; this printed report should not be used for charting 35 S RARPTSTT=$S(RAST="D":"DRAFT",RAST="PD":"PROBLEM DRAFT",RAST="R":"(RELEASED/NOT VERIFIED)",1:"REPORT STATUS UNKNOWN") 36 S RAPOSITN=(80-$L(RARPTSTT)\2) 37 I '$D(RAUTOE) D ;P18 modif 38 . W !?RAPOSITN-1,$$REPEAT^XLFSTR("*",$L(RARPTSTT)+2) 39 . W:RAST="R" !?(80-$L(RARPTSTT)\2)-1,"* PRELIMINARY REPORT *" ;P18 40 . W !?(80-$L(RARPTSTT)\2)-1,"*"_RARPTSTT_"*",!?RAPOSITN-1,$$REPEAT^XLFSTR("*",$L(RARPTSTT)+2) 41 . Q 42 I $D(RAUTOE) D 43 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$$REPEAT^XLFSTR("*",$L(RARPTSTT)+2) 44 . I RAST="R" S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="* PRELIMINARY REPORT *" ;P18 45 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="*"_RARPTSTT_"*" ;P18 46 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$$REPEAT^XLFSTR("*",$L(RARPTSTT)+2) 47 . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" 48 . Q 49 K RAPOSITN,RARPTSTT 50 Q 51 SECRES ; Print from the secondary resident multiple 52 Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",0)) ; no data, quit 53 N RASR,RASRSBN,RASRSBT 54 I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL 55 W:'$D(RAUTOE) !,"Secondary Interpreting Resident:" 56 S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Secondary Interpreting Resident:" 57 S RASR=0 58 F S RASR=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RASR)) Q:RASR'>0 D 59 . S RASR(0)=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RASR,0)) 60 . Q:'$D(^VA(200,+RASR(0),0)) 61 . S RASRSBN=$E($P($G(^VA(200,+RASR(0),20)),"^",2),1,25) 62 . S:RASRSBN']"" RASRSBN=$E($P($G(^VA(200,+RASR(0),0)),"^"),1,25) 63 . S RASRSBT=$P($G(^VA(200,+RASR(0),20)),"^",3) ; max: 50 chars 64 . I RASRSBT']"" S RASRSBT=$$TITLE^RARTR0(+RASR(0)) 65 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL 66 . W:'$D(RAUTOE) !?2,$S(RASRSBN]"":RASRSBN,1:"Unknown"),", ",$E(RASRSBT,1,((IOM-$X)-16)) 67 . ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING 68 . I $D(RAUTOE) D 69 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RASRSBN]"":RASRSBN,1:"Unknown") 70 .. N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT)) 71 .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RASRSBT,1,((80-RALEN)-16)) 72 .. Q 73 . I '$D(RAVERFND),(RAVERF=+RASR(0)) D 74 .. S RAVERFND="" 75 .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q 76 ... W:RAWHOVER=+RASR(0) !?10,"(Verifier, no e-sig)" 77 ... W:RAWHOVER'=+RASR(0) !?10,"Verified by transcriptionist for "_RASRSBN ;Removed RA*5*8 _", M.D." 78 ... Q 79 .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q 80 ... S:RAWHOVER=+RASR(0) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)" 81 ... S:RAWHOVER'=+RASR(0) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RASRSBN ;Removed RA*5*8 _", M.D." 82 ... Q 83 .. W:'$D(RAUTOE) " (Verifier)" 84 .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)" 85 .. Q 86 . I RAPVERF=+RASR(0) W:'$D(RAUTOE) " (Pre-Verifier)" S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)" 87 . Q 88 Q 89 SECSTF ; Print from the secondary staff multiple 90 Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",0)) ; no data, quit 91 N RASS,RASSSBN,RASSSBT 92 I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL 93 W:'$D(RAUTOE) !,"Secondary Interpreting Staff:" 94 S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Secondary Interpreting Staff:" 95 S RASS=0 96 F S RASS=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RASS)) Q:RASS'>0 D 97 . S RASS(0)=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RASS,0)) 98 . Q:'$D(^VA(200,+RASS(0),0)) 99 . S RASSSBN=$E($P($G(^VA(200,+RASS(0),20)),"^",2),1,25) 100 . S:RASSSBN']"" RASSSBN=$E($P($G(^VA(200,+RASS(0),0)),"^"),1,25) 101 . S RASSSBT=$P($G(^VA(200,+RASS(0),20)),"^",3) ; max: 50 chars 102 . I RASSSBT']"" S RASSSBT=$$TITLE^RARTR0(+RASS(0)) 103 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD^RARTR:($Y+RAFOOT+4)>IOSL 104 . W:'$D(RAUTOE) !?2,$S(RASSSBN]"":RASSSBN,1:"Unknown"),", ",$E(RASSSBT,1,((IOM-$X)-16)) 105 . ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING 106 . I $D(RAUTOE) D 107 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RASSSBN]"":RASSSBN,1:"Unknown") 108 .. N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT)) 109 .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RASSSBT,1,((80-RALEN)-16)) 110 .. Q 111 . I '$D(RAVERFND),(RAVERF=+RASS(0)) D 112 .. S RAVERFND="" 113 .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q 114 ... W:RAWHOVER=+RASS(0) !?10,"(Verifier, no e-sig)" 115 ... W:RAWHOVER'=+RASS(0) !?10,"Verified by transcriptionist for "_RASSSBN ;Removed RA*5*8 _", M.D." 116 ... Q 117 .. I $G(RARPT(10))']"",($D(RAUTOE)) D Q 118 ... S:RAWHOVER=+RASS(0) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" (Verifier, no e-sig)" 119 ... S:RAWHOVER'=+RASS(0) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Verified by transcriptionist for "_RASSSBN ;Removed RA*5*8 _", M.D." 120 ... Q 121 .. W:'$D(RAUTOE) " (Verifier)" 122 .. S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Verifier)" 123 .. Q 124 . I RAPVERF=+RASS(0) W:'$D(RAUTOE) " (Pre-Verifier)" S:$D(RAUTOE) ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_" (Pre-Verifier)" 125 . Q 126 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTRPV.m
r613 r623 1 RARTRPV ;HISC/FPT-Resident Pre-Verify Report ;10/3/97 15:54 2 ;;5.0;Radiology/Nuclear Medicine;**26,56**;Mar 16, 1998;Build 3 3 ;Supported IA #10104 REPEAT^XLFSTR 4 ;Supported IA #10035 ^DPT( 5 ;Supported IA #10060 and 2056 GET1^DIQ of file 200 6 ;Supported IA #10076 ^XUSEC 7 N DIERR 8 D SET^RAPSET1 I $D(XQUIT) K XQUIT Q 9 K RAVER S:$D(^VA(200,DUZ,0)) RAVER=$P(^(0),"^") I '$D(RAVER) W !!,$C(7),"Your name must be defined in the NEW PERSON File to continue." G Q 10 I '$D(^VA(200,"ARC","R",DUZ)) W !!,$C(7),"You are not classified as a Rad/Nuc Med Interpreting Resident." G Q 11 S RAINACT=$$GET1^DIQ(200,DUZ_",",53.4,"I") ; grab Inactive Date (if any) 12 I RAINACT,(RAINACT'>DT) W !!,$C(7),"You are not classified as an active Rad/Nuc Med Interpreting Resident." K RAINACT G Q 13 K RAINACT S RAONLINE="" W ! D ES^RASIGU G Q:'% 14 S RARAD=DUZ,RAD="ARES" 15 ; 16 SRTRPT K RA,RARPTX,^TMP($J,"RA") S (RATOT,RARPT)=0 17 F S RARPT=$O(^RARPT(RAD,RARAD,RARPT)) Q:'RARPT I $D(^RARPT(RARPT,0)) S RARTDT=$S($P(^(0),"^",6)="":9999999.9999,1:$P(^(0),"^",6)) I $P(^RARPT(RARPT,0),U,12)="" D 18 .Q:$$STUB^RAEDCN1(RARPT) ;skip stub report 031501 19 .Q:"^V^EF^"[("^"_$P($G(^RARPT(+RARPT,0)),"^",5)_"^") ;skip if V or EF 20 .S ^TMP($J,"RA","DT",RARTDT,RARPT)="" 21 .S RATOT=RATOT+1 22 I 'RATOT W !!,"You have no Unverified Reports." G Q 23 ; 24 SELRPT S RARD("A")="Do you wish to review "_$S(RATOT=1:"this one report",1:"all "_RATOT_" reports")_"? ",RARD(1)="Yes^review all reports",RARD(2)="No^choose which reports to review",RARD("B")=1,RARD(0)="S" 25 D SET^RARD K RARD S X=$E(X) G Q:X["^"!(X="N"&(RATOT=1)),RPTLP:X="Y" D ^RARTVER1 G Q:$D(RAOUT)!('$D(RARPTX)) 26 ; 27 RPTLP S DIR(0)="S^P:PAGE AT A TIME;E:ENTIRE REPORT",DIR("B")="P",DIR("A")="How would you like to view the reports?" 28 S DIR("?",1)="If you would like to pause after each page of the report enter 'P'.",DIR("?")="Otherwise enter 'E' to view an entire report at one time." 29 D ^DIR K DIR G Q:$D(DIRUT) I Y="E" S RARTVERF=1 30 I $D(^TMP($J,"RA","DT")) S RARPT=0 F RARTDT=0:0 S RARTDT=$O(^TMP($J,"RA","DT",RARTDT)) Q:'RARTDT S RARDX="" D GETRPT Q:RARDX="^" 31 I $D(^TMP($J,"RA","XREF")) S (RPTX,RARPT)=0 D GETRPT 32 ; 33 Q K %,%DT,%W,%Y1,DA,DGO,DI,DIC,DIWF,DIWR,I,OREND,POP,RA,RACN,RACNI,RACS,RACT,RAD,RADATE,RADFN,RADIV,RADTE,RADTI,RADUP,RADUZ,RAERR,RAFLG,RAIMGTYJ,RAJ1,RAPRIT,RANM,RANME,RANUM,RAONLINE,RAOR,RAOUT,RAPRC,RARAD,RARDX,RARPDT,RARPT 34 K RARPTX,RARTDT,RARTVER,RARTVERF,RASET,RASIG,RASN,RASTI,RATOT,RAVER,RAVNB,RAXIT,RAXX,RPTX,X,Y,^TMP($J,"RA") 35 K %X,D,D0,D1,DDER,DDH,DLAYGO 36 K C,DIRUT,DUOUT,HLN,HLRESLT,HLSAN,J,RADFLDS,RAPRTSET,X1 37 Q 38 ; 39 GETRPT I $G(RARPT) L -^RARPT(RARPT) 40 S:$D(^TMP($J,"RA","XREF")) RPTX=RPTX+1 S RARPT=$S($D(^TMP($J,"RA","DT")):$O(^TMP($J,"RA","DT",RARTDT,RARPT)),$D(^TMP($J,"RA","XREF")):+$G(RARPTX(RPTX)),1:0) Q:'RARPT L +^RARPT(RARPT):2 G:'$T LOCK G:$P($G(^RARPT(RARPT,0)),U,5)="V" VER 41 D DISRPT 42 I RAIMGTYJ']"" D Q 43 . I $G(RARPT) L -^RARPT(RARPT) 44 . Q 45 ASK W !,$$REPEAT^XLFSTR("=",80) 46 S RARD(1)="Print^print this report for editing",RARD(2)="Edit^edit this report",RARD(3)="Top^display the report from the beginning",RARD(4)="Continue^continue normal processing" 47 S RARD(5)="Status & Print^edit Status, then print report",RARD("B")=4,RARD(0)="S" 48 D SET^RARD K RARD S RARDX=$E(X) I RARDX="^" L -^RARPT(RARPT) Q 49 I "PT"[RARDX D PRTRPT:RARDX="P",DISRPT:RARDX="T" G ASK 50 I RARDX="E" D EDTCHK I RARDX="E" D G ASK 51 .W !!,"EDITING REPORT",!,"--------------",! 52 .D EDTRPT^RARTRPV1 53 .D:RACT'="V" UP1^RAUTL1 54 .I $D(DTOUT) K ^TMP($J,"RA") 55 .Q 56 G NOEDIT^RARTRPV1 ;pre-verify report, no report text edit 57 ; 58 DISRPT S (RAIMGTYJ,RARTVER)="" D RASET Q:'Y!(RAIMGTYJ']"") D DISP^RART1 K RARTVER 59 Q 60 PRTRPT D SAVE^RARTVER2 61 S ION=$P(RAMLC,"^",10),IOP=$S(ION]"":"Q;"_ION,1:"Q") 62 S RAMES="W !!,""Report has been queued for printing on device "",ION,"".""" D Q^RARTR 63 D RESTORE^RARTVER2 64 Q 65 ; 66 RASET S Y=RARPT D RASET^RAUTL2 Q:'Y 67 S Y(0)=Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"UNKNOWN") 68 S RAPRC=$S($D(^RAMIS(71,+$P(Y(0),"^",2),0)):$P(^(0),"^"),1:"UNKNOWN") 69 S RAIMGTYJ=$$IMGTY^RAUTL12("e",RADFN,RADTI) 70 I RAIMGTYJ']"" D 71 . W !?5,"Imaging Type data appears to be missing for this exam.",$C(7) 72 . Q 73 Q 74 LOCK S RACN=+$P(^RARPT(RARPT,0),"^",4) 75 W !!,$C(7),"Another user is editing this report",$S($G(RACN)]"":" (Case # "_RACN_")",1:""),". Please try again later." H 4 K RACN G GETRPT 76 Q 77 VER ; report was verified since tmp global was built 78 S RACN=$G(^RARPT(RARPT,0)) 79 S RACN("CASE")=+$P(RACN,U,4) 80 S RACN("PAT")=+$P(RACN,U,2) 81 S RACN("VER")=+$P(RACN,U,9) 82 W !!,$C(7),$$GET1^DIQ(200,+RACN("VER")_",",.01)_" verified report for "_$P(^DPT(RACN("PAT"),0),U) 83 W !,"(Case # "_RACN("CASE")_") since you began this option." 84 H 4 K RACN G GETRPT 85 Q 86 EDTCHK ; is user permitted to edit report 87 S RASTATUS=+$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",3) 88 I $P($G(^RA(72,RASTATUS,0)),"^",3)>0 K RASTATUS Q 89 K RASTATUS 90 I $D(^XUSEC("RA MGR",DUZ)) Q 91 I $P(RAMDV,"^",22)=1 Q 92 W $C(7),!!,"The STATUS for this case is CANCELLED. You may not enter a report.",!! 93 S RARDX="C" ;Reset RARDX so user can only verify. 94 Q 1 RARTRPV ;HISC/FPT-Resident Pre-Verify Report ;10/3/97 15:54 2 ;;5.0;Radiology/Nuclear Medicine;**26**;Mar 16, 1998 3 D SET^RAPSET1 I $D(XQUIT) K XQUIT Q 4 K RAVER S:$D(^VA(200,DUZ,0)) RAVER=$P(^(0),"^") I '$D(RAVER) W !!,*7,"Your name must be defined in the NEW PERSON File to continue." G Q 5 I '$D(^VA(200,"ARC","R",DUZ)) W !!,*7,"You are not classified as a Rad/Nuc Med Interpreting Resident." G Q 6 S RAINACT=$P($G(^VA(200,DUZ,"PS")),"^",4) ; grab Inactive Date (if any) 7 I RAINACT,(RAINACT'>DT) W !!,$C(7),"You are not classified as an active Rad/Nuc Med Interpreting Resident." K RAINACT G Q 8 K RAINACT S RAONLINE="" W ! D ES^RASIGU G Q:'% 9 S RARAD=DUZ,RAD="ARES" 10 ; 11 SRTRPT K RA,RARPTX,^TMP($J,"RA") S (RATOT,RARPT)=0 12 F S RARPT=$O(^RARPT(RAD,RARAD,RARPT)) Q:'RARPT I $D(^RARPT(RARPT,0)) S RARTDT=$S($P(^(0),"^",6)="":9999999.9999,1:$P(^(0),"^",6)) I $P(^RARPT(RARPT,0),U,12)="" D 13 .Q:$$STUB^RAEDCN1(RARPT) ;skip stub report 031501 14 .Q:$P($G(^RARPT(+RARPT,0)),"^",5)="V" ;skip if already verified 031501 15 .S ^TMP($J,"RA","DT",RARTDT,RARPT)="" 16 .S RATOT=RATOT+1 17 I 'RATOT W !!,"You have no Unverified Reports." G Q 18 ; 19 SELRPT S RARD("A")="Do you wish to review "_$S(RATOT=1:"this one report",1:"all "_RATOT_" reports")_"? ",RARD(1)="Yes^review all reports",RARD(2)="No^choose which reports to review",RARD("B")=1,RARD(0)="S" 20 D SET^RARD K RARD S X=$E(X) G Q:X["^"!(X="N"&(RATOT=1)),RPTLP:X="Y" D ^RARTVER1 G Q:$D(RAOUT)!('$D(RARPTX)) 21 ; 22 RPTLP S DIR(0)="S^P:PAGE AT A TIME;E:ENTIRE REPORT",DIR("B")="P",DIR("A")="How would you like to view the reports?" 23 S DIR("?",1)="If you would like to pause after each page of the report enter 'P'.",DIR("?")="Otherwise enter 'E' to view an entire report at one time." 24 D ^DIR K DIR G Q:$D(DIRUT) I Y="E" S RARTVERF=1 25 I $D(^TMP($J,"RA","DT")) S RARPT=0 F RARTDT=0:0 S RARTDT=$O(^TMP($J,"RA","DT",RARTDT)) Q:'RARTDT S RARDX="" D GETRPT Q:RARDX="^" 26 I $D(^TMP($J,"RA","XREF")) S (RPTX,RARPT)=0 D GETRPT 27 ; 28 Q K %,%DT,%W,%Y1,DA,DGO,DI,DIC,DIWF,DIWR,I,OREND,POP,RA,RACN,RACNI,RACS,RACT,RAD,RADATE,RADFN,RADIV,RADTE,RADTI,RADUP,RADUZ,RAERR,RAFLG,RAIMGTYJ,RAJ1,RAPRIT,RANM,RANME,RANUM,RAONLINE,RAOR,RAOUT,RAPRC,RARAD,RARDX,RARPDT,RARPT 29 K RARPTX,RARTDT,RARTVER,RARTVERF,RASET,RASIG,RASN,RASTI,RATOT,RAVER,RAVNB,RAXIT,RAXX,RPTX,X,Y,^TMP($J,"RA") 30 K %X,D,D0,D1,DDER,DDH,DLAYGO 31 K C,DIRUT,DUOUT,HLN,HLRESLT,HLSAN,J,RADFLDS,RAPRTSET,X1 32 Q 33 ; 34 GETRPT I $G(RARPT) L -^RARPT(RARPT) 35 S:$D(^TMP($J,"RA","XREF")) RPTX=RPTX+1 S RARPT=$S($D(^TMP($J,"RA","DT")):$O(^TMP($J,"RA","DT",RARTDT,RARPT)),$D(^TMP($J,"RA","XREF")):+$G(RARPTX(RPTX)),1:0) Q:'RARPT L +^RARPT(RARPT):2 G:'$T LOCK G:$P($G(^RARPT(RARPT,0)),U,5)="V" VER 36 D DISRPT 37 I RAIMGTYJ']"" D Q 38 . I $G(RARPT) L -^RARPT(RARPT) 39 . Q 40 ASK W !,$$REPEAT^XLFSTR("=",80) 41 S RARD(1)="Print^print this report for editing",RARD(2)="Edit^edit this report",RARD(3)="Top^display the report from the beginning",RARD(4)="Continue^continue normal processing" 42 S RARD(5)="Status & Print^edit Status, then print report",RARD("B")=4,RARD(0)="S" 43 D SET^RARD K RARD S RARDX=$E(X) I RARDX="^" L -^RARPT(RARPT) Q 44 I "PT"[RARDX D PRTRPT:RARDX="P",DISRPT:RARDX="T" G ASK 45 I RARDX="E" D EDTCHK I RARDX="E" D G ASK 46 .W !!,"EDITING REPORT",!,"--------------",! 47 .D EDTRPT^RARTRPV1 48 .D:RACT'="V" UP1^RAUTL1 49 .I $D(DTOUT) K ^TMP($J,"RA") 50 .Q 51 G NOEDIT^RARTRPV1 ;pre-verify report, no report text edit 52 ; 53 DISRPT S (RAIMGTYJ,RARTVER)="" D RASET Q:'Y!(RAIMGTYJ']"") D DISP^RART1 K RARTVER 54 Q 55 PRTRPT D SAVE^RARTVER2 56 S ION=$P(RAMLC,"^",10),IOP=$S(ION]"":"Q;"_ION,1:"Q") 57 S RAMES="W !!,""Report has been queued for printing on device "",ION,"".""" D Q^RARTR 58 D RESTORE^RARTVER2 59 Q 60 ; 61 RASET S Y=RARPT D RASET^RAUTL2 Q:'Y 62 S Y(0)=Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"UNKNOWN") 63 S RAPRC=$S($D(^RAMIS(71,+$P(Y(0),"^",2),0)):$P(^(0),"^"),1:"UNKNOWN") 64 S RAIMGTYJ=$$IMGTY^RAUTL12("e",RADFN,RADTI) 65 I RAIMGTYJ']"" D 66 . W !?5,"Imaging Type data appears to be missing for this exam.",$C(7) 67 . Q 68 Q 69 LOCK S RACN=+$P(^RARPT(RARPT,0),"^",4) 70 W !!,*7,"Another user is editing this report",$S($G(RACN)]"":" (Case # "_RACN_")",1:""),". Please try again later." H 4 K RACN G GETRPT 71 Q 72 VER ; report was verified since tmp global was built 73 S RACN=$G(^RARPT(RARPT,0)) 74 S RACN("CASE")=+$P(RACN,U,4) 75 S RACN("PAT")=+$P(RACN,U,2) 76 S RACN("VER")=+$P(RACN,U,9) 77 W !!,*7,$P($G(^VA(200,+RACN("VER"),0)),U)_" verified report for "_$P(^DPT(RACN("PAT"),0),U) 78 W !,"(Case # "_RACN("CASE")_") since you began this option." 79 H 4 K RACN G GETRPT 80 Q 81 EDTCHK ; is user permitted to edit report 82 S RASTATUS=+$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",3) 83 I $P($G(^RA(72,RASTATUS,0)),"^",3)>0 K RASTATUS Q 84 K RASTATUS 85 I $D(^XUSEC("RA MGR",DUZ)) Q 86 I $P(RAMDV,"^",22)=1 Q 87 W *7,!!,"The STATUS for this case is CANCELLED. You may not enter a report.",!! 88 S RARDX="C" ;Reset RARDX so user can only verify. 89 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTST1.m
r613 r623 1 RARTST1 ;HISC/CAH,FPT,GJC,DAD AISC/MJK,RMO-Reports Distribution ;7/23/97 12:44 2 ;;5.0;Radiology/Nuclear Medicine;**56**;Mar 16, 1998;Build 3 3 ;Supported IA #10040 ^SC( 4 ;Supported IA #10060 and #2056 GET1^DIQ of file 200 5 ;Supported IA #10007 DO^DIC1 6 1 ;;Routing Queue 7 N RAOMA S RAOMA="",DIC(0)="AEMQZ" 8 S DIC("A")="Select Routing Queue: ",DIC("B")="WARD REPORTS" 9 S DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)" 10 S DIC="^RABTCH(74.3," D ^DIC K DIC G:Y<1 Q 11 S RAB=+Y,RARTST1=$S(Y(0,0)="REQUESTING PHYSICIAN":0,1:1) 12 D DIV^RARTST2A G:'$D(RADIV)!('$D(RAIMAG))!('$D(RASRT))!('$D(RAPRT)) Q 13 G DIP K RA4,RAF408 14 ; 15 2 ;;Individual Ward Distribution 16 N RAOMA S RAOMA="" 17 S Y=$O(^RABTCH(74.3,"B","WARD REPORTS",0)) Q:'Y S RAB=Y 18 D DIV^RARTST2A G:'$D(RADIV)!('$D(RAIMAG))!('$D(RASRT))!('$D(RAPRT)) Q 19 S RADIC(0)="AEMQ",RADIC="^DIC(42,",RADIC("A")="Select Ward: " 20 S RADIC("S")="I $P(^(0),U,11)=RA4(RADIV)" 21 D EN1^RASELCT(.RADIC,"WARD/CLIN") K RADIC I RAQUIT G Q 22 K RA4,RAF408,RAQUIT S RANGE="^^6" G DIP 23 ; 24 3 ;;Single Clinic Distribution 25 N RAOMA S RAOMA="" 26 S Y=$O(^RABTCH(74.3,"B","CLINIC REPORTS",0)) Q:'Y S RAB=Y 27 D DIV^RARTST2A G:'$D(RADIV)!('$D(RAIMAG))!('$D(RASRT))!('$D(RAPRT)) Q 28 S RADIC(0)="AEMQ",RADIC="^SC(",RADIC("A")="Select Clinic: " 29 S RADIC("S")="N RA44 S RA44=$G(^(0)) I $P(RA44,U,3)'=""W"",($P(RA44,U,15)=RA4(RADIV))" 30 D EN1^RASELCT(.RADIC,"WARD/CLIN") K RADIC I RAQUIT G Q 31 K RA4,RAF408,RAQUIT S RANGE="^^8" G DIP 32 ; 33 4 ;;Distribution File Activity 34 S DIC="^RABTCH(74.3,",DIC(0)="AEMQ",DIC("A")="Select Routing Queue: ",DIC("B")="WARD REPORTS" D ^DIC K DIC G:Y<0 Q41 S RAB=+Y,RABN=$P(Y,"^",2) 35 S ZTRTN="S4^RARTST1",ZTSAVE("RAB")="",ZTSAVE("RABN")="" D ZIS^RAUTL G Q4:RAPOP 36 S4 U IO D HD4 F RADTI=0:0 S RADTI=$O(^RABTCH(74.3,RAB,"L",RADTI)) Q:'RADTI I $D(^(RADTI,0)) S X=^(0),RADTE=$P(X,"^"),RACT=$P(X,"^",2),RADUZ=+$P(X,"^",3),RARTMES=$P(X,"^",4),RARTCNT=+$P(X,"^",5) D P4 Q:"^"[X 37 Q4 K DIC,RAPOP,RADTI,RAPAGE,RARTCNT,RABN,RAIOM,RAIOSL,RAB,RADTE,RADATE,RADUZ,RACT,RARTMES,X,Y D CLOSE^RAUTL 38 Q41 K POP,DUOUT,I,RAMES,ZTDESC,ZTRTN,ZTSAVE 39 Q 40 P4 N DIERR 41 S Y=RADTE D D^RAUTL S RADATE=Y,RACT=$S(RACT="P":"PRINT",RACT="R":"RE-PRINT",1:"UNKNOWN"),RADUZ=$$GET1^DIQ(200,RADUZ_",",.01) S:RADUZ="" RADUZ="UNKNOWN" 42 D HD4:($Y+4)>IOSL Q:"^"[X W !,RADATE,?20,RACT,?30,$E(RADUZ,1,15),?50,$E(RARTMES,1,20),?72,RARTCNT 43 Q 44 HD4 S RAPAGE=$S($D(RAPAGE):RAPAGE+1,1:1) 45 I RAPAGE>1 R !!,"Press RETURN to continue or '^' to stop",X:DTIME I X["^" S X="^" Q 46 W @IOF,!,RABN_" Distribution Activity Log",?70,"Page: ",RAPAGE,!,"Run Date: " S X="NOW",%DT="TX" D ^%DT K %DT D D^RAUTL W Y 47 W !!,"Log Date",?20,"Activity",?30,"User",?50,"Comment",?72,"Qty",!,"--------",?20,"--------",?30,"----",?50,"-------",?72,"---" Q 48 ; 49 5 ;;Unprinted Reports List 50 S DHD="Unprinted Reports List",FLDS="[RA ALL UNPRINTED REPORTS]",BY="[RA ALL UNPRINTED]",RARPTFLG="" 51 S DIS(0)="S Y=$G(^RABTCH(74.4,D0,0)) I Y S RARPT=+Y,RAB=$P(Y,U,11),RARDIFN=D0,RAY3=$G(^RABTCH(74.4,RARDIFN,0)) I RAY3]"""" S RADFN=+$P($G(^RARPT(RARPT,0)),U,2) D UPDLOC^RAUTL10 I $D(RAPRTOK)" D DIP^RARTST3 52 K DISH,F,O,RARPTFLG,W,I,POP 53 Q 54 6 ;;Clinic Distribution List 55 S DIC="^SC(",RAWC="Clinic",Y=$O(^RABTCH(74.3,"B","CLINIC REPORTS",0)) Q:'Y S RAB=+Y G SELECT^RARTST3 56 ; 57 7 ;;Ward Distribution List 58 S RAWC="Ward",DIC="^DIC(42,",Y=$O(^RABTCH(74.3,"B","WARD REPORTS",0)) I 'Y K I,POP Q 59 S RAB=+Y G SELECT^RARTST3 60 ; 61 8 ;;Report's Print Status 62 S DIC("A")="Select Report: ",DIC="^RARPT(",DIC(0)="AEMQZ" 63 S DIC("S")="I $P(^(0),U,5)'=""X""" 64 D DICW,^DIC K DIC I Y<0 D 81 Q 65 I $P(Y(0),"^",5)'="V" W !!,$C(7),"Report has not been 'verified'." W ! D 81 G 8 66 I '$D(^RABTCH(74.4,"B",+Y)) W !!,$C(7),"Report is not in any distribution queue." W ! D 81 G 8 67 S RADFN=+$P(Y(0),U,2),(D0,RARPT)=+Y F RAD0=0:0 S RAD0=$O(^RABTCH(74.4,"B",D0,RAD0)) Q:RAD0'>0 S RAB=$S($D(^RABTCH(74.4,RAD0,0)):$P(^(0),"^",11),1:""),RARDIFN=RAD0,RAY3=$G(^RABTCH(74.4,RARDIFN,0)) I RAY3]"" D UPDLOC^RAUTL10 68 K DXS D RPTST^RARTST2A(RARPT) 69 81 K %,C,D,D0,DDH,DILCT,DIPGM,DISTP,DN,DISYS,POP,RASSN,RAY3 70 K %,DIXX,DXS,I,RAB,RABTY,RACN,RAD0,RADFN,RAPRTOK,RARDIFN,RARPT,X,X1,Y 71 Q 72 DIP ;RANGE defined only if prt'g via 'Individual Ward' or 'Single Clinic' 73 ;D DIV^RARTST2A G:'$D(RADIV)!('$D(RAIMAG))!('$D(RASRT))!('$D(RAPRT)) Q 74 I $D(RANGE) S RANGE=$TR(RANGE,"^","~") 75 ;**** NEXT LINE FOR TESTING ONLY *** 76 ;D ^%ZIS D START^RARTST2 77 W ! S ZTRTN="START^RARTST2",ZTSAVE("RADIV")="",ZTSAVE("RAIMAG(")="",ZTSAVE("RASRT")="",ZTSAVE("RAB")="",ZTSAVE("RALOCSRT")="",IOP="Q" 78 S:$D(RABEG) ZTSAVE("RABEG")="",ZTSAVE("RAEND")="" 79 S:$D(RA4) ZTSAVE("RA4(")="" S:$D(RAF408) ZTSAVE("RAF408(")="" 80 I $D(RANGE) S ZTSAVE("RANGE")="",ZTSAVE("^TMP($J,""WARD/CLIN"",")="" 81 D ZIS^RAUTL K IOP 82 Q K %,%DT,D,D0,D1,DA,DDH,DIC,DIE,DIR,DIRUT,DIXX,J,POP,RAB,RABEG,RACN,RADIV,RAEND,RAIMAG,RANGE,RAPOP,RAPRT,RAQUIT,RARD,RARTST1,RALOCSRT,RASRT,X,X1,Y,^TMP($J,"WARD/CLIN") 83 D CLOSE^RAUTL K DISYS,DUOUT,I,POP,RA4,RAF408,RAMES,ZTDESC,ZTRTN,ZTSAVE 84 Q 85 DICW ; Build DIC("W") string 86 N DO D DO^DIC1 87 S DIC("W")=$S($G(DIC("W"))]"":DIC("W")_" ",1:"")_"W "" "",$$FLD^RARTFLDS(+Y,""PROC"")" 88 Q 1 RARTST1 ;HISC/CAH,FPT,GJC,DAD AISC/MJK,RMO-Reports Distribution ;7/23/97 12:44 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 3 1 ;;Routing Queue 4 N RAOMA S RAOMA="",DIC(0)="AEMQZ" 5 S DIC("A")="Select Routing Queue: ",DIC("B")="WARD REPORTS" 6 S DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)" 7 S DIC="^RABTCH(74.3," D ^DIC K DIC G:Y<1 Q 8 S RAB=+Y,RARTST1=$S(Y(0,0)="REQUESTING PHYSICIAN":0,1:1) 9 D DIV^RARTST2A G:'$D(RADIV)!('$D(RAIMAG))!('$D(RASRT))!('$D(RAPRT)) Q 10 G DIP K RA4,RAF408 11 ; 12 2 ;;Individual Ward Distribution 13 N RAOMA S RAOMA="" 14 S Y=$O(^RABTCH(74.3,"B","WARD REPORTS",0)) Q:'Y S RAB=Y 15 D DIV^RARTST2A G:'$D(RADIV)!('$D(RAIMAG))!('$D(RASRT))!('$D(RAPRT)) Q 16 S RADIC(0)="AEMQ",RADIC="^DIC(42,",RADIC("A")="Select Ward: " 17 S RADIC("S")="I $P(^(0),U,11)=RA4(RADIV)" 18 D EN1^RASELCT(.RADIC,"WARD/CLIN") K RADIC I RAQUIT G Q 19 K RA4,RAF408,RAQUIT S RANGE="^^6" G DIP 20 ; 21 3 ;;Single Clinic Distribution 22 N RAOMA S RAOMA="" 23 S Y=$O(^RABTCH(74.3,"B","CLINIC REPORTS",0)) Q:'Y S RAB=Y 24 D DIV^RARTST2A G:'$D(RADIV)!('$D(RAIMAG))!('$D(RASRT))!('$D(RAPRT)) Q 25 S RADIC(0)="AEMQ",RADIC="^SC(",RADIC("A")="Select Clinic: " 26 S RADIC("S")="N RA44 S RA44=$G(^(0)) I $P(RA44,U,3)'=""W"",($P(RA44,U,15)=RA4(RADIV))" 27 D EN1^RASELCT(.RADIC,"WARD/CLIN") K RADIC I RAQUIT G Q 28 K RA4,RAF408,RAQUIT S RANGE="^^8" G DIP 29 ; 30 4 ;;Distribution File Activity 31 S DIC="^RABTCH(74.3,",DIC(0)="AEMQ",DIC("A")="Select Routing Queue: ",DIC("B")="WARD REPORTS" D ^DIC K DIC G:Y<0 Q41 S RAB=+Y,RABN=$P(Y,"^",2) 32 S ZTRTN="S4^RARTST1",ZTSAVE("RAB")="",ZTSAVE("RABN")="" D ZIS^RAUTL G Q4:RAPOP 33 S4 U IO D HD4 F RADTI=0:0 S RADTI=$O(^RABTCH(74.3,RAB,"L",RADTI)) Q:'RADTI I $D(^(RADTI,0)) S X=^(0),RADTE=$P(X,"^"),RACT=$P(X,"^",2),RADUZ=+$P(X,"^",3),RARTMES=$P(X,"^",4),RARTCNT=+$P(X,"^",5) D P4 Q:"^"[X 34 Q4 K DIC,RAPOP,RADTI,RAPAGE,RARTCNT,RABN,RAIOM,RAIOSL,RAB,RADTE,RADATE,RADUZ,RACT,RARTMES,X,Y D CLOSE^RAUTL 35 Q41 K POP,DUOUT,I,RAMES,ZTDESC,ZTRTN,ZTSAVE 36 Q 37 P4 S Y=RADTE D D^RAUTL S RADATE=Y,RACT=$S(RACT="P":"PRINT",RACT="R":"RE-PRINT",1:"UNKNOWN"),RADUZ=$S($D(^VA(200,RADUZ,0)):$P(^(0),"^"),1:"UNKNOWN") 38 D HD4:($Y+4)>IOSL Q:"^"[X W !,RADATE,?20,RACT,?30,$E(RADUZ,1,15),?50,$E(RARTMES,1,20),?72,RARTCNT 39 Q 40 HD4 S RAPAGE=$S($D(RAPAGE):RAPAGE+1,1:1) 41 I RAPAGE>1 R !!,"Press RETURN to continue or '^' to stop",X:DTIME I X["^" S X="^" Q 42 W @IOF,!,RABN_" Distribution Activity Log",?70,"Page: ",RAPAGE,!,"Run Date: " S X="NOW",%DT="TX" D ^%DT K %DT D D^RAUTL W Y 43 W !!,"Log Date",?20,"Activity",?30,"User",?50,"Comment",?72,"Qty",!,"--------",?20,"--------",?30,"----",?50,"-------",?72,"---" Q 44 ; 45 5 ;;Unprinted Reports List 46 S DHD="Unprinted Reports List",FLDS="[RA ALL UNPRINTED REPORTS]",BY="[RA ALL UNPRINTED]",RARPTFLG="" 47 S DIS(0)="S Y=$G(^RABTCH(74.4,D0,0)) I Y S RARPT=+Y,RAB=$P(Y,U,11),RARDIFN=D0,RAY3=$G(^RABTCH(74.4,RARDIFN,0)) I RAY3]"""" S RADFN=+$P($G(^RARPT(RARPT,0)),U,2) D UPDLOC^RAUTL10 I $D(RAPRTOK)" D DIP^RARTST3 48 K DISH,F,O,RARPTFLG,W,I,POP 49 Q 50 6 ;;Clinic Distribution List 51 S DIC="^SC(",RAWC="Clinic",Y=$O(^RABTCH(74.3,"B","CLINIC REPORTS",0)) Q:'Y S RAB=+Y G SELECT^RARTST3 52 ; 53 7 ;;Ward Distribution List 54 S RAWC="Ward",DIC="^DIC(42,",Y=$O(^RABTCH(74.3,"B","WARD REPORTS",0)) I 'Y K I,POP Q 55 S RAB=+Y G SELECT^RARTST3 56 ; 57 8 ;;Report's Print Status 58 S DIC("A")="Select Report: ",DIC="^RARPT(",DIC(0)="AEMQZ" D DICW,^DIC K DIC I Y<0 D 81 Q 59 I $P(Y(0),"^",5)'="V" W !!,*7,"Report has not been 'verified'." W ! D 81 G 8 60 I '$D(^RABTCH(74.4,"B",+Y)) W !!,*7,"Report is not in any distribution queue." W ! D 81 G 8 61 S RADFN=+$P(Y(0),U,2),(D0,RARPT)=+Y F RAD0=0:0 S RAD0=$O(^RABTCH(74.4,"B",D0,RAD0)) Q:RAD0'>0 S RAB=$S($D(^RABTCH(74.4,RAD0,0)):$P(^(0),"^",11),1:""),RARDIFN=RAD0,RAY3=$G(^RABTCH(74.4,RARDIFN,0)) I RAY3]"" D UPDLOC^RAUTL10 62 K DXS D RPTST^RARTST2A(RARPT) 63 81 K %,C,D,D0,DDH,DILCT,DIPGM,DISTP,DN,DISYS,POP,RASSN,RAY3 64 K %,DIXX,DXS,I,RAB,RABTY,RACN,RAD0,RADFN,RAPRTOK,RARDIFN,RARPT,X,X1,Y 65 Q 66 DIP ;RANGE defined only if prt'g via 'Individual Ward' or 'Single Clinic' 67 ;D DIV^RARTST2A G:'$D(RADIV)!('$D(RAIMAG))!('$D(RASRT))!('$D(RAPRT)) Q 68 I $D(RANGE) S RANGE=$TR(RANGE,"^","~") 69 ;**** NEXT LINE FOR TESTING ONLY *** 70 ;D ^%ZIS D START^RARTST2 71 W ! S ZTRTN="START^RARTST2",ZTSAVE("RADIV")="",ZTSAVE("RAIMAG(")="",ZTSAVE("RASRT")="",ZTSAVE("RAB")="",ZTSAVE("RALOCSRT")="",IOP="Q" 72 S:$D(RABEG) ZTSAVE("RABEG")="",ZTSAVE("RAEND")="" 73 S:$D(RA4) ZTSAVE("RA4(")="" S:$D(RAF408) ZTSAVE("RAF408(")="" 74 I $D(RANGE) S ZTSAVE("RANGE")="",ZTSAVE("^TMP($J,""WARD/CLIN"",")="" 75 D ZIS^RAUTL K IOP 76 Q K %,%DT,D,D0,D1,DA,DDH,DIC,DIE,DIR,DIRUT,DIXX,J,POP,RAB,RABEG,RACN,RADIV,RAEND,RAIMAG,RANGE,RAPOP,RAPRT,RAQUIT,RARD,RARTST1,RALOCSRT,RASRT,X,X1,Y,^TMP($J,"WARD/CLIN") 77 D CLOSE^RAUTL K DISYS,DUOUT,I,POP,RA4,RAF408,RAMES,ZTDESC,ZTRTN,ZTSAVE 78 Q 79 DICW ; Build DIC("W") string 80 N DO D DO^DIC1 81 S DIC("W")=$S($G(DIC("W"))]"":DIC("W")_" ",1:"")_"W "" "",$$FLD^RARTFLDS(+Y,""PROC"")" 82 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTUVR.m
r613 r623 1 RARTUVR ;HISC/FPT,SWM AISC/RMO-Unverified Reports ;8/19/97 11:01 2 ;;5.0;Radiology/Nuclear Medicine;**29,56**;Mar 16, 1998;Build 3 3 ; 4 ; This routine displays the total number of reports that have a status 5 ; other than V(erify) and the report is linked to a Resident, Staff or 6 ; unknown physician. It builds the report by using the 'ASTAT' cross 7 ; reference on File 74. It displays the report by division and imaging 8 ; type. Within division/imaging type, it displays the number of reports 9 ; by category (Resident and Staff). It displays the number of unverified 10 ; reports by Interpreting Physician within a category. 11 ; The routine checks the PRIMARY INTERPRETING RESIDENT and PRIMARY 12 ; INTERPRETING STAFF fields (File 70) associated with a report. 13 ; If a primary Resident is associated with the report, then the report 14 ; is counted towards that Resident. 15 ; If a primary Staff physician is associated with the report, then the 16 ; report is counted towards that Interpreting Staff. 17 ; If neither of the above are true the report is counted toward unknown. 18 ; 19 EN ; unverified reports report 20 K ^TMP($J) 21 I '$D(^RARPT("ASTAT")) W !!,*7,?5,"There are no Unverified Reports." Q 22 ; 23 ; Select Imaging Type, if exists 24 I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX="" 25 S RAXIT=$$SETUPDI^RAUTL7() I RAXIT K RAXIT Q 26 S X=$$DIVLOC^RAUTL7() I X D KILL Q 27 S RACNT=0,X="" F S X=$O(RACCESS(DUZ,"DIV-IMG",X)) Q:X']"" D 28 . Q:'$D(^TMP($J,"RA D-TYPE",X)) S Y="" 29 . F S Y=$O(RACCESS(DUZ,"DIV-IMG",X,Y)) Q:Y']"" D 30 .. S:$D(^TMP($J,"RA I-TYPE",Y)) ^TMP($J,"RAUVR",X,Y)=0,RACNT=RACNT+1 31 .. Q 32 . Q 33 W ! 34 ASKBD K DIR S DIR("B")="b" 35 S DIR("?",1)="Enter 'b' for a brief format, 'd' for a detailed format, " 36 S DIR("?",2)="'e' for a format sorted by exam date, 's' for a format" 37 S DIR("?",3)="sorted by Primary Interpreting Staff." 38 S DIR("?")="This is mandatory." 39 S DIR(0)="S^b:Brief;d:Detailed;e:Exam Date, Itemized List;s:Staff, Itemized List" 40 D ^DIR G:$D(DIRUT) KILL 41 S RABD=$$UP^XLFSTR(Y) K DIR,DIROUT,DIRUT,DUOUT,DTOUT 42 I RABD="S"!(RABD="E") D 43 . W ! D 132^RAMAINP S RAFILE="EXAM REGISTERED" 44 . Q 45 E S RAFILE="REPORT ENTERED" 46 ; 47 ASKTHRU S RASKTIME=1 W !!,"(The date range refers to DATE "_RAFILE_")" 48 D DATE^RAUTL K RAFILE,RASKTIME ;allow time of day input 49 G:X="^" KILL G:'$D(ENDDATE)!('$D(BEGDATE)) KILL 50 S:$L(ENDDATE)=7 ENDDATE=ENDDATE_".2359" 51 G:"^E^S^"[("^"_RABD_"^") DEVICE ; skip date/time cut-off 52 ; 53 ASKCUT S RACUT(1)=24,RACUT(2)=48,RACUT(3)=96 54 W !!,"Default cut-off limits (in hours) for aging of reports are :" 55 W !!?35 F RA1=1:1:3 W RACUT(RA1)," " 56 K DIR S DIR("A")="Do you want to enter different cut-off limits",DIR("B")="N",DIR("?")="Enter Y only if you want to change the above limits",DIR("??")="This is optional",DIR(0)="Y" 57 W ! D ^DIR K DIR G:X="^" KILL G:+Y<1 DEVICE 58 S DIR("?")="Enter number of hours as the cut-off limit" 59 F RA1=1:1:3 S DIR(0)="N^"_$S(RA1=1:0,1:RACUT(RA1-1))_":87660",DIR("A")="Enter the "_$S(RA1=1:"first",RA1=2:"second",1:"third")_" cutoff hours" D ^DIR Q:+Y<1 S RACUT(RA1)=Y 60 K DIR I +Y<1 W !!,"Try again " G ASKCUT 61 ; 62 DEVICE ; select device 63 S ZTRTN="START^RARTUVR",ZTSAVE("^TMP($J,""RA D-TYPE"",")="",ZTSAVE("^TMP($J,""RA I-TYPE"",")="",ZTSAVE("^TMP($J,""RAUVR"",")="",ZTSAVE("RACNT")="",ZTSAVE("BEGDATE")="",ZTSAVE("ENDDATE")="",ZTSAVE("RACUT*")="",ZTSAVE("RABD")="" 64 W ! D ZIS^RAUTL I RAPOP D KILL Q 65 START ; start processing 66 U IO S:$D(ZTQUEUED) ZTREQ="@" 67 I "^E^S^"[("^"_RABD_"^") D EN1^RARTUVR3 D KILL Q 68 S RADIVNME="" 69 F S RADIVNME=$O(^TMP($J,"RAUVR",RADIVNME)) Q:RADIVNME']"" S RAITNAME="" F S RAITNAME=$O(^TMP($J,"RAUVR",RADIVNME,RAITNAME)) Q:RAITNAME']"" D 70 . S ^TMP($J,RADIVNME,RAITNAME,"RESCNT")=0 71 . S ^TMP($J,RADIVNME,RAITNAME,"STFCNT")=0 72 . S ^TMP($J,RADIVNME,RAITNAME,"UNKCNT")=0 73 . Q 74 ; 75 ; 76 S RASTATUS="",RAOUT=0 77 F S RASTATUS=$O(^RARPT("ASTAT",RASTATUS)) Q:RASTATUS=""!(RAOUT) D 78 . S RARPT=0,RAOUT=0 79 . F S RARPT=$O(^RARPT("ASTAT",RASTATUS,RARPT)) Q:RARPT'>0!(RAOUT) D 80 ..;use Report Status to exclude, as Verf'd rpt may have leftover "ASTAT" 81 ..;exclude Verified, Deleted, and Electronically Filed reports 82 .. Q:"^V^X^EF^"[("^"_$P($G(^RARPT(RARPT,0)),U,5)_"^") 83 .. S RARPTENT=$P($G(^RARPT(RARPT,0)),U,6) 84 .. Q:RARPTENT<BEGDATE!(RARPTENT>ENDDATE) 85 .. I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 Q:RAOUT=1 86 .. S Y=RARPT D RASET^RAUTL2 Q:'Y S RAX=Y 87 .. S RAPRES=$P(RAX,"^",12),RAPSTF=$P(RAX,"^",15) 88 .. ; Check if Staff & Resident the same, if so, use Staff only 89 .. I (RAPSTF>0),(RAPRES=RAPSTF) S RAPRES="" 90 .. S RAIP="" 91 .. S:RAPRES>0 RAIP=RAIP_"R" 92 .. S:RAPSTF>0 RAIP=RAIP_"S" 93 .. S:RAIP="" RAIP="U" 94 .. D BTG^RARTUVR1 95 .. Q 96 . Q 97 DIV ; walk through tmp global, start with 'division' 98 S (RACNT(0),RAOUT,RAPAGE)=0,RADIVNME="" 99 S X="NOW",%DT="T" D ^%DT K %DT D D^RAUTL S RARUNDAT=Y 100 S $P(RADASH,"-",IOM)="",$P(RAEQUAL,"=",IOM+1)="" 101 F S RADIVNME=$O(^TMP($J,"RAUVR",RADIVNME)) Q:RADIVNME=""!(RAOUT) D IT Q:RAOUT D DIVSUM^RARTUVR1 Q:RAOUT 102 KILL ; kill variables & close device 103 K ^TMP($J),POP,RAPOP,RACN,RACNI,RACNT,RAD,RADATE,RADFN,RADIVNME,RADIVNUM,RADTI,RADTE,RAFL,RAFLG,RAIP,RAIPNAME,RAITNAME,RAITNUM,RAOUT,RAPAGE,RAQUIT,RAPRES,RAPSTF,RARAD,RARE,RARPT,RARS,RASTATUS,RASTRING,RAX,RAXIT,X,Y,ZTQUEUED,ZTSTOP 104 K RA1,RA2,RA3,RA4,RABD,RACUT,RADASH,RAEQUAL,RAHOURS,RARPTENT,RARUNDAT,RASSN 105 K:$D(RAPSTX) RACCESS,RAPSTX 106 K BEGDATE,DIR,DIRUT,DUOUT,ENDDATE,I,RAMES,ZTDESC,ZTRTN,ZTSAVE 107 D CLOSE^RAUTL 108 Q 109 IT ; imaging type 110 S RAITNAME="" 111 F S RAITNAME=$O(^TMP($J,"RAUVR",RADIVNME,RAITNAME)) Q:RAITNAME=""!(RAOUT) D PRINT^RARTUVR2 Q:RAOUT 112 Q 113 ; 1 RARTUVR ;HISC/FPT,SWM AISC/RMO-Unverified Reports ;8/19/97 11:01 2 ;;5.0;Radiology/Nuclear Medicine;**29**;Mar 16, 1998 3 ; 4 ; This routine displays the total number of reports that have a status 5 ; other than V(erify) and the report is linked to a Resident, Staff or 6 ; unknown physician. It builds the report by using the 'ASTAT' cross 7 ; reference on File 74. It displays the report by division and imaging 8 ; type. Within division/imaging type, it displays the number of reports 9 ; by category (Resident and Staff). It displays the number of unverified 10 ; reports by Interpreting Physician within a category. 11 ; The routine checks the PRIMARY INTERPRETING RESIDENT and PRIMARY 12 ; INTERPRETING STAFF fields (File 70) associated with a report. 13 ; If a primary Resident is associated with the report, then the report 14 ; is counted towards that Resident. 15 ; If a primary Staff physician is associated with the report, then the 16 ; report is counted towards that Interpreting Staff. 17 ; If neither of the above are true the report is counted toward unknown. 18 ; 19 EN ; unverified reports report 20 K ^TMP($J) 21 I '$D(^RARPT("ASTAT")) W !!,*7,?5,"There are no Unverified Reports." Q 22 ; 23 ; Select Imaging Type, if exists 24 I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX="" 25 S RAXIT=$$SETUPDI^RAUTL7() I RAXIT K RAXIT Q 26 S X=$$DIVLOC^RAUTL7() I X D KILL Q 27 S RACNT=0,X="" F S X=$O(RACCESS(DUZ,"DIV-IMG",X)) Q:X']"" D 28 . Q:'$D(^TMP($J,"RA D-TYPE",X)) S Y="" 29 . F S Y=$O(RACCESS(DUZ,"DIV-IMG",X,Y)) Q:Y']"" D 30 .. S:$D(^TMP($J,"RA I-TYPE",Y)) ^TMP($J,"RAUVR",X,Y)=0,RACNT=RACNT+1 31 .. Q 32 . Q 33 W ! 34 ASKBD K DIR S DIR("B")="b" 35 S DIR("?",1)="Enter 'b' for a brief format, 'd' for a detailed format, " 36 S DIR("?",2)="'e' for a format sorted by exam date, 's' for a format" 37 S DIR("?",3)="sorted by Primary Interpreting Staff." 38 S DIR("?")="This is mandatory." 39 S DIR(0)="S^b:Brief;d:Detailed;e:Exam Date, Itemized List;s:Staff, Itemized List" 40 D ^DIR G:$D(DIRUT) KILL 41 S RABD=$$UP^XLFSTR(Y) K DIR,DIROUT,DIRUT,DUOUT,DTOUT 42 I RABD="S"!(RABD="E") D 43 . W ! D 132^RAMAINP S RAFILE="EXAM REGISTERED" 44 . Q 45 E S RAFILE="REPORT ENTERED" 46 ; 47 ASKTHRU S RASKTIME=1 W !!,"(The date range refers to DATE "_RAFILE_")" 48 D DATE^RAUTL K RAFILE,RASKTIME ;allow time of day input 49 G:X="^" KILL G:'$D(ENDDATE)!('$D(BEGDATE)) KILL 50 S:$L(ENDDATE)=7 ENDDATE=ENDDATE_".2359" 51 G:"^E^S^"[("^"_RABD_"^") DEVICE ; skip date/time cut-off 52 ; 53 ASKCUT S RACUT(1)=24,RACUT(2)=48,RACUT(3)=96 54 W !!,"Default cut-off limits (in hours) for aging of reports are :" 55 W !!?35 F RA1=1:1:3 W RACUT(RA1)," " 56 K DIR S DIR("A")="Do you want to enter different cut-off limits",DIR("B")="N",DIR("?")="Enter Y only if you want to change the above limits",DIR("??")="This is optional",DIR(0)="Y" 57 W ! D ^DIR K DIR G:X="^" KILL G:+Y<1 DEVICE 58 S DIR("?")="Enter number of hours as the cut-off limit" 59 F RA1=1:1:3 S DIR(0)="N^"_$S(RA1=1:0,1:RACUT(RA1-1))_":87660",DIR("A")="Enter the "_$S(RA1=1:"first",RA1=2:"second",1:"third")_" cutoff hours" D ^DIR Q:+Y<1 S RACUT(RA1)=Y 60 K DIR I +Y<1 W !!,"Try again " G ASKCUT 61 ; 62 DEVICE ; select device 63 S ZTRTN="START^RARTUVR",ZTSAVE("^TMP($J,""RA D-TYPE"",")="",ZTSAVE("^TMP($J,""RA I-TYPE"",")="",ZTSAVE("^TMP($J,""RAUVR"",")="",ZTSAVE("RACNT")="",ZTSAVE("BEGDATE")="",ZTSAVE("ENDDATE")="",ZTSAVE("RACUT*")="",ZTSAVE("RABD")="" 64 W ! D ZIS^RAUTL I RAPOP D KILL Q 65 START ; start processing 66 U IO S:$D(ZTQUEUED) ZTREQ="@" 67 I "^E^S^"[("^"_RABD_"^") D EN1^RARTUVR3 D KILL Q 68 S RADIVNME="" 69 F S RADIVNME=$O(^TMP($J,"RAUVR",RADIVNME)) Q:RADIVNME']"" S RAITNAME="" F S RAITNAME=$O(^TMP($J,"RAUVR",RADIVNME,RAITNAME)) Q:RAITNAME']"" D 70 . S ^TMP($J,RADIVNME,RAITNAME,"RESCNT")=0 71 . S ^TMP($J,RADIVNME,RAITNAME,"STFCNT")=0 72 . S ^TMP($J,RADIVNME,RAITNAME,"UNKCNT")=0 73 . Q 74 ; 75 ; 76 S RASTATUS="",RAOUT=0 77 F S RASTATUS=$O(^RARPT("ASTAT",RASTATUS)) Q:RASTATUS=""!(RAOUT) D 78 . Q:RASTATUS="V" 79 . S RARPT=0,RAOUT=0 80 . F S RARPT=$O(^RARPT("ASTAT",RASTATUS,RARPT)) Q:RARPT'>0!(RAOUT) D 81 .. S RARPTENT=$P($G(^RARPT(RARPT,0)),U,6) 82 .. Q:RARPTENT<BEGDATE!(RARPTENT>ENDDATE) 83 .. I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 Q:RAOUT=1 84 .. S Y=RARPT D RASET^RAUTL2 Q:'Y S RAX=Y 85 .. S RAPRES=$P(RAX,"^",12),RAPSTF=$P(RAX,"^",15) 86 .. ; Check if Staff & Resident the same, if so, use Staff only 87 .. I (RAPSTF>0),(RAPRES=RAPSTF) S RAPRES="" 88 .. S RAIP="" 89 .. S:RAPRES>0 RAIP=RAIP_"R" 90 .. S:RAPSTF>0 RAIP=RAIP_"S" 91 .. S:RAIP="" RAIP="U" 92 .. D BTG^RARTUVR1 93 .. Q 94 . Q 95 DIV ; walk through tmp global, start with 'division' 96 S (RACNT(0),RAOUT,RAPAGE)=0,RADIVNME="" 97 S X="NOW",%DT="T" D ^%DT K %DT D D^RAUTL S RARUNDAT=Y 98 S $P(RADASH,"-",IOM)="",$P(RAEQUAL,"=",IOM+1)="" 99 F S RADIVNME=$O(^TMP($J,"RAUVR",RADIVNME)) Q:RADIVNME=""!(RAOUT) D IT Q:RAOUT D DIVSUM^RARTUVR1 Q:RAOUT 100 KILL ; kill variables & close device 101 K ^TMP($J),POP,RAPOP,RACN,RACNI,RACNT,RAD,RADATE,RADFN,RADIVNME,RADIVNUM,RADTI,RADTE,RAFL,RAFLG,RAIP,RAIPNAME,RAITNAME,RAITNUM,RAOUT,RAPAGE,RAQUIT,RAPRES,RAPSTF,RARAD,RARE,RARPT,RARS,RASTATUS,RASTRING,RAX,RAXIT,X,Y,ZTQUEUED,ZTSTOP 102 K RA1,RA2,RA3,RA4,RABD,RACUT,RADASH,RAEQUAL,RAHOURS,RARPTENT,RARUNDAT,RASSN 103 K:$D(RAPSTX) RACCESS,RAPSTX 104 K BEGDATE,DIR,DIRUT,DUOUT,ENDDATE,I,RAMES,ZTDESC,ZTRTN,ZTSAVE 105 D CLOSE^RAUTL 106 Q 107 IT ; imaging type 108 S RAITNAME="" 109 F S RAITNAME=$O(^TMP($J,"RAUVR",RADIVNME,RAITNAME)) Q:RAITNAME=""!(RAOUT) D PRINT^RARTUVR2 Q:RAOUT 110 Q 111 ; -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTUVR1.m
r613 r623 1 RARTUVR1 ;HISC/FPT,SWM AISC/RMO-Unverified Reports ;8/19/97 11:16 2 ;;5.0;Radiology/Nuclear Medicine;**29,56**;Mar 16, 1998;Build 3 3 ; 4 ;Supported IA #2056 GET1^DIQ 5 ; RAHOURS=hours diffce btw DT and RARPTENT, also used in RACUT(rahours) 6 BTG ; build tmp global 7 N RAQT 8 S RARE(0)=$G(^RADPT(RADFN,"DT",RADTI,0)) 9 S RADIVNUM=+$P(RARE(0),U,3),RADIVNME=$P($G(^DIC(4,RADIVNUM,0)),U) 10 I RADIVNME]"",('$D(^TMP($J,"RA D-TYPE",RADIVNME))) Q 11 S RADIVNME=$S(RADIVNME]"":RADIVNME,1:"Unknown") 12 S RAITNUM=+$P(RARE(0),U,2),RAITNAME=$P($G(^RA(79.2,RAITNUM,0)),U) 13 I RAITNAME]"",('$D(^TMP($J,"RA I-TYPE",RAITNAME))) Q 14 S RAITNAME=$S(RAITNAME]"":RAITNAME,1:"Unknown") 15 K RARE(0) 16 Q:'$D(^TMP($J,"RAUVR",RADIVNME,RAITNAME)) 17 S RAQT=0 ; RAQT set to 1 if this report has already been counted 18 I RAIP["R" D INC("R") Q:RAQT 19 I RAIP["S" D INC("S") Q:RAQT 20 I RAIP="U" D INC("U") Q:RAQT 21 S ^TMP($J,"RAUVR",RADIVNME,RAITNAME)=$G(^TMP($J,"RAUVR",RADIVNME,RAITNAME))+1 22 Q 23 INC(RATYP) ; Increment count for Resident, Staff or Unknown 24 ; 25 N RA1 26 S RATYP=$E($G(RATYP)) 27 S RAIPNAME=$S(RATYP="R":RAPRES,RATYP="S":RAPSTF,1:"") 28 S:RAIPNAME'="" RAIPNAME=$$GET1^DIQ(200,RAIPNAME_",",.01) 29 S:RAIPNAME="" RAIPNAME="UNKNOWN" 30 ; If report on ASTAT x-ref for 2 report statuses, then it will be 31 ; counted twice. Check if dealt with already. If so, QUIT 32 I $D(^TMP($J,RADIVNME,RAITNAME,RATYP,RAIPNAME,RARPT)) S RAQT=1 Q 33 S ^TMP($J,RADIVNME,RAITNAME,RATYP,RAIPNAME,RARPT)=$G(RADFN)_U_$G(RADTI)_U_$G(RACNI) 34 S ^TMP($J,RADIVNME,RAITNAME,RATYP,RAIPNAME)=$G(^TMP($J,RADIVNME,RAITNAME,RATYP,RAIPNAME))+1 35 S RA1=$S(RATYP="R":"RESCNT",RATYP="S":"STFCNT",1:"UNKCNT") 36 S ^TMP($J,RADIVNME,RAITNAME,RA1)=$G(^TMP($J,RADIVNME,RAITNAME,RA1))+1 37 Q:'$D(RARPTENT) 38 S RAHOURS=$$FMDIFF^XLFDT(DT,RARPTENT,2)/3600 39 S RAHOURS=$S(RAHOURS<RACUT(1):1,RAHOURS<RACUT(2):2,RAHOURS<RACUT(3):3,1:4) 40 S ^TMP($J,RADIVNME,RAITNAME,RATYP,RAIPNAME,"H",RAHOURS)=$G(^TMP($J,RADIVNME,RAITNAME,RATYP,RAIPNAME,"H",RAHOURS))+1 41 S ^TMP($J,RADIVNME,RAITNAME,"H",RAHOURS,RARPT)=$G(^TMP($J,RADIVNME,RAITNAME,"H",RAHOURS,RARPT))+1 42 Q 43 ; 44 PHYS ;print other staff and residents 45 N RA2ND,R1,R2,RASTR 46 S (R1,R2)=0 F S R2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",R2)) Q:'R2 S:+$G(^(R2,0)) R1=R1+1,RA2ND("SRR",R1)=+^(0),RA2ND("SRR",R1)=$E($$GET1^DIQ(200,RA2ND("SRR",R1)_",",.01),1,20) 47 S (R1,R2)=0 F S R2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",R2)) Q:'R2 S:+$G(^(R2,0)) R1=R1+1,RA2ND("SSR",R1)=+^(0),RA2ND("SSR",R1)=$E($$GET1^DIQ(200,RA2ND("SSR",R1)_",",.01),1,20) 48 S R1=$E($$GET1^DIQ(200,+$P(Y(0),"^",15)_",",.01),1,15) ; prim staff 49 S RASTR="Other Att/Res: " 50 S:RAIPNAME'[R1 RASTR=RASTR_R1 51 PHYS1 I '$O(RA2ND("SSR",0)) G PHYS2 52 S R1=0 53 PHYS11 S R1=$O(RA2ND("SSR",R1)) G:R1="" PHYS2 54 G:RAIPNAME[RA2ND("SSR",R1) PHYS11 ;omit if name matches current staff/resid/unkn 55 I $L(RASTR)+$L(RA2ND("SSR",R1))>IOM W !,RASTR,"; " S RASTR=" " 56 S:RASTR]" " RASTR=RASTR_"; " S RASTR=RASTR_RA2ND("SSR",R1) G PHYS11 57 PHYS2 S R1=$E($$GET1^DIQ(200,+$P(Y(0),"^",12)_",",.01),1,15) ;prim resid 58 I RAIPNAME[R1 G PHYS20 ;omit if name matches current staff/resid/unk 59 I $L(RASTR)+$L(R1)>IOM W !,RASTR,"; " S RASTR=" " 60 S:RASTR]" " RASTR=RASTR_"; " S RASTR=RASTR_R1 61 PHYS20 I '$O(RA2ND("SRR",0)) W !,RASTR Q 62 S R1=0 63 PHYS21 S R1=$O(RA2ND("SRR",R1)) G:R1="" PHYS29 64 G:RAIPNAME[RA2ND("SRR",R1) PHYS21 ;omit if name matches current staff/resident/unkn 65 I $L(RASTR)+$L(RA2ND("SRR",R1))>IOM W !,RASTR,"; " S RASTR=" " 66 S:RASTR]" " RASTR=RASTR_"; " S RASTR=RASTR_RA2ND("SRR",R1) G PHYS21 67 PHYS29 W:RASTR]" " !,RASTR 68 Q 69 DIVSUM ;division summary -- skip if only one imaging type chosen for this div 70 Q:$O(^TMP($J,"RAUVR",RADIVNME,0))=$O(^TMP($J,"RAUVR",RADIVNME,""),-1) 71 N RA2ND ;reuse this local array 72 I RACNT(0)'<RACNT S RAOUT=$$EOS^RAUTL5() Q:RAOUT ;before last screen 73 W:$Y>0 @IOF W !?$S(IOM<81:20,1:IOM-90),">>>>> Unverified Reports (",$S(RABD="B":"brief",1:"detailed"),") <<<<<" S RAPAGE=RAPAGE+1 W ?$S(IOM<81:70,1:IOM-10),"Page: ",RAPAGE 74 W !,"Division: ",?10,RADIVNME,?$S(IOM<81:43,1:IOM-37),"Report Date Range:",?$S(IOM<81:62,1:IOM-18),$$FMTE^XLFDT(BEGDATE),!?$S(IOM<81:62,1:IOM-18),$$FMTE^XLFDT(ENDDATE) 75 W !,"Imaging Type(s): " 76 S RA1="" F S RA1=$O(^TMP($J,"RAUVR",RADIVNME,RA1)) Q:RA1="" W:($L(RA1)+3+$X)>IOM !?17 W RA1," " 77 W !!,"Run Date: ",RARUNDAT 78 W !!!?26,"Division Summary",!?26,$E(RADASH,1,16) 79 D HOURAGE^RARTUVR2 80 S RA1=0 F S RA1=$O(^TMP($J,RADIVNME,RA1)) Q:RA1="" D 81 .S RA2="" F S RA2=$O(^TMP($J,RADIVNME,RA1,"H",RA2)) Q:RA2="" D 82 ..S RA3="" F S RA3=$O(^TMP($J,RADIVNME,RA1,"H",RA2,RA3)) Q:RA3="" D 83 ...S RA2ND(RA2)=$G(RA2ND(RA2))+1 84 W !!,"Total Unverified Reports: " 85 W ?29,$S($G(RA2ND(1)):$J(RA2ND(1),$L(RACUT(3))),1:$J(0,$L(RACUT(3)))),?39,$S($G(RA2ND(2)):$J(RA2ND(2),$L(RACUT(3))),1:$J(0,$L(RACUT(3)))) 86 W ?49,$S($G(RA2ND(3)):$J(RA2ND(3),$L(RACUT(3))),1:$J(0,$L(RACUT(3)))),?59,$S($G(RA2ND(4)):$J(RA2ND(4),$L(RACUT(3))+2),1:$J(0,$L(RACUT(3))+2)) 87 S RA1=0 F RA4=1:1:4 S RA1=RA1+$G(RA2ND(RA4)) 88 W !!,"Division Total: ",RA1,!! 89 S RAOUT=$$EOS^RAUTL5() 1 RARTUVR1 ;HISC/FPT,SWM AISC/RMO-Unverified Reports ;8/19/97 11:16 2 ;;5.0;Radiology/Nuclear Medicine;**29**;Mar 16, 1998 3 ; 4 ; RAHOURS=hours diffce btw DT and RARPTENT, also used in RACUT(rahours) 5 BTG ; build tmp global 6 N RAQT 7 S RARE(0)=$G(^RADPT(RADFN,"DT",RADTI,0)) 8 S RADIVNUM=+$P(RARE(0),U,3),RADIVNME=$P($G(^DIC(4,RADIVNUM,0)),U) 9 I RADIVNME]"",('$D(^TMP($J,"RA D-TYPE",RADIVNME))) Q 10 S RADIVNME=$S(RADIVNME]"":RADIVNME,1:"Unknown") 11 S RAITNUM=+$P(RARE(0),U,2),RAITNAME=$P($G(^RA(79.2,RAITNUM,0)),U) 12 I RAITNAME]"",('$D(^TMP($J,"RA I-TYPE",RAITNAME))) Q 13 S RAITNAME=$S(RAITNAME]"":RAITNAME,1:"Unknown") 14 K RARE(0) 15 Q:'$D(^TMP($J,"RAUVR",RADIVNME,RAITNAME)) 16 S RAQT=0 ; RAQT set to 1 if this report has already been counted 17 I RAIP["R" D INC("R") Q:RAQT 18 I RAIP["S" D INC("S") Q:RAQT 19 I RAIP="U" D INC("U") Q:RAQT 20 S ^TMP($J,"RAUVR",RADIVNME,RAITNAME)=$G(^TMP($J,"RAUVR",RADIVNME,RAITNAME))+1 21 Q 22 INC(RATYP) ; Increment count for Resident, Staff or Unknown 23 ; 24 N RA1 25 S RATYP=$E($G(RATYP)) 26 S RAIPNAME=$P($G(^VA(200,$S(RATYP="R":RAPRES,RATYP="S":RAPSTF,1:U),0)),U,1) 27 S:RAIPNAME="" RAIPNAME="UNKNOWN" 28 ; If report on ASTAT x-ref for 2 report statuses, then it will be 29 ; counted twice. Check if dealt with already. If so, QUIT 30 I $D(^TMP($J,RADIVNME,RAITNAME,RATYP,RAIPNAME,RARPT)) S RAQT=1 Q 31 S ^TMP($J,RADIVNME,RAITNAME,RATYP,RAIPNAME,RARPT)=$G(RADFN)_U_$G(RADTI)_U_$G(RACNI) 32 S ^TMP($J,RADIVNME,RAITNAME,RATYP,RAIPNAME)=$G(^TMP($J,RADIVNME,RAITNAME,RATYP,RAIPNAME))+1 33 S RA1=$S(RATYP="R":"RESCNT",RATYP="S":"STFCNT",1:"UNKCNT") 34 S ^TMP($J,RADIVNME,RAITNAME,RA1)=$G(^TMP($J,RADIVNME,RAITNAME,RA1))+1 35 Q:'$D(RARPTENT) 36 S RAHOURS=$$FMDIFF^XLFDT(DT,RARPTENT,2)/3600 37 S RAHOURS=$S(RAHOURS<RACUT(1):1,RAHOURS<RACUT(2):2,RAHOURS<RACUT(3):3,1:4) 38 S ^TMP($J,RADIVNME,RAITNAME,RATYP,RAIPNAME,"H",RAHOURS)=$G(^TMP($J,RADIVNME,RAITNAME,RATYP,RAIPNAME,"H",RAHOURS))+1 39 S ^TMP($J,RADIVNME,RAITNAME,"H",RAHOURS,RARPT)=$G(^TMP($J,RADIVNME,RAITNAME,"H",RAHOURS,RARPT))+1 40 Q 41 ; 42 PHYS ;print other staff and residents 43 N RA2ND,R1,R2,RASTR 44 S (R1,R2)=0 F S R2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",R2)) Q:'R2 S:+$G(^(R2,0)) R1=R1+1,RA2ND("SRR",R1)=+^(0),RA2ND("SRR",R1)=$E($P($G(^VA(200,RA2ND("SRR",R1),0)),"^"),1,20) 45 S (R1,R2)=0 F S R2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",R2)) Q:'R2 S:+$G(^(R2,0)) R1=R1+1,RA2ND("SSR",R1)=+^(0),RA2ND("SSR",R1)=$E($P($G(^VA(200,RA2ND("SSR",R1),0)),"^"),1,20) 46 S R1=$E($P($G(^VA(200,+$P(Y(0),"^",15),0)),"^"),1,15) ; prim staff 47 S RASTR="Other Att/Res: " 48 S:RAIPNAME'[R1 RASTR=RASTR_R1 49 PHYS1 I '$O(RA2ND("SSR",0)) G PHYS2 50 S R1=0 51 PHYS11 S R1=$O(RA2ND("SSR",R1)) G:R1="" PHYS2 52 G:RAIPNAME[RA2ND("SSR",R1) PHYS11 ;omit if name matches current staff/resid/unkn 53 I $L(RASTR)+$L(RA2ND("SSR",R1))>IOM W !,RASTR,"; " S RASTR=" " 54 S:RASTR]" " RASTR=RASTR_"; " S RASTR=RASTR_RA2ND("SSR",R1) G PHYS11 55 PHYS2 S R1=$E($P($G(^VA(200,+$P(Y(0),"^",12),0)),"^"),1,15) ;prim resid 56 I RAIPNAME[R1 G PHYS20 ;omit if name matches current staff/resid/unk 57 I $L(RASTR)+$L(R1)>IOM W !,RASTR,"; " S RASTR=" " 58 S:RASTR]" " RASTR=RASTR_"; " S RASTR=RASTR_R1 59 PHYS20 I '$O(RA2ND("SRR",0)) W !,RASTR Q 60 S R1=0 61 PHYS21 S R1=$O(RA2ND("SRR",R1)) G:R1="" PHYS29 62 G:RAIPNAME[RA2ND("SRR",R1) PHYS21 ;omit if name matches current staff/resident/unkn 63 I $L(RASTR)+$L(RA2ND("SRR",R1))>IOM W !,RASTR,"; " S RASTR=" " 64 S:RASTR]" " RASTR=RASTR_"; " S RASTR=RASTR_RA2ND("SRR",R1) G PHYS21 65 PHYS29 W:RASTR]" " !,RASTR 66 Q 67 DIVSUM ;division summary -- skip if only one imaging type chosen for this div 68 Q:$O(^TMP($J,"RAUVR",RADIVNME,0))=$O(^TMP($J,"RAUVR",RADIVNME,""),-1) 69 N RA2ND ;reuse this local array 70 I RACNT(0)'<RACNT S RAOUT=$$EOS^RAUTL5() Q:RAOUT ;before last screen 71 W:$Y>0 @IOF W !?$S(IOM<81:20,1:IOM-90),">>>>> Unverified Reports (",$S(RABD="B":"brief",1:"detailed"),") <<<<<" S RAPAGE=RAPAGE+1 W ?$S(IOM<81:70,1:IOM-10),"Page: ",RAPAGE 72 W !,"Division: ",?10,RADIVNME,?$S(IOM<81:43,1:IOM-37),"Report Date Range:",?$S(IOM<81:62,1:IOM-18),$$FMTE^XLFDT(BEGDATE),!?$S(IOM<81:62,1:IOM-18),$$FMTE^XLFDT(ENDDATE) 73 W !,"Imaging Type(s): " 74 S RA1="" F S RA1=$O(^TMP($J,"RAUVR",RADIVNME,RA1)) Q:RA1="" W:($L(RA1)+3+$X)>IOM !?17 W RA1," " 75 W !!,"Run Date: ",RARUNDAT 76 W !!!?26,"Division Summary",!?26,$E(RADASH,1,16) 77 D HOURAGE^RARTUVR2 78 S RA1=0 F S RA1=$O(^TMP($J,RADIVNME,RA1)) Q:RA1="" D 79 .S RA2="" F S RA2=$O(^TMP($J,RADIVNME,RA1,"H",RA2)) Q:RA2="" D 80 ..S RA3="" F S RA3=$O(^TMP($J,RADIVNME,RA1,"H",RA2,RA3)) Q:RA3="" D 81 ...S RA2ND(RA2)=$G(RA2ND(RA2))+1 82 W !!,"Total Unverified Reports: " 83 W ?29,$S($G(RA2ND(1)):$J(RA2ND(1),$L(RACUT(3))),1:$J(0,$L(RACUT(3)))),?39,$S($G(RA2ND(2)):$J(RA2ND(2),$L(RACUT(3))),1:$J(0,$L(RACUT(3)))) 84 W ?49,$S($G(RA2ND(3)):$J(RA2ND(3),$L(RACUT(3))),1:$J(0,$L(RACUT(3)))),?59,$S($G(RA2ND(4)):$J(RA2ND(4),$L(RACUT(3))+2),1:$J(0,$L(RACUT(3))+2)) 85 S RA1=0 F RA4=1:1:4 S RA1=RA1+$G(RA2ND(RA4)) 86 W !!,"Division Total: ",RA1,!! 87 S RAOUT=$$EOS^RAUTL5() -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTUVR3.m
r613 r623 1 RARTUVR3 ;HISC/GJC-Unverified Reports ;8/19/97 11:28 2 ;;5.0;Radiology/Nuclear Medicine;**56**;Mar 16, 1998;Build 3 3 ;Supported IA #2056 GET1^DIQ 4 EN1 ; Entry point for unverified reports option when sort is on 5 ; Exam Date or Pri. Inter. Staff 6 ; Data Storage: 7 ; RABD="E": 8 ; ^TMP($J,"RAUVR",Division,Xam Date/Time,Patient,Case #)=print set? (1:yes, 0:no)_^_Pat ID_^_0 node of exam 9 ; RABD="S": 10 ; ^TMP($J,"RAUVR",Pri. Staff,Xam Date/Time,Patient,Case #)=print set? (1:yes, 0:no)_^_Pat ID_^_0 node of exam 11 K ^TMP($J,"RAUVR") S (RAOUT,RAPAGE)=0,RASTATUS="" 12 D:RABD="E" ZERO ; zero out totals for division data 13 S RADTE=BEGDATE-.0001 14 F S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>ENDDATE)!(RAOUT) D 15 . S RADFN=0 16 . F S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0!(RAOUT) D 17 .. S RADTI=0 18 .. F S RADTI=$O(^RADPT("AR",RADTE,RADFN,RADTI)) Q:RADTI'>0!(RAOUT) D 19 ... S RACN=0 20 ... F S RACN=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN)) Q:RACN'>0!(RAOUT) D 21 .... S RACNI=+$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) Q:'RACNI 22 .... S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 23 .... Q:'+$P(RA7003,"^",17) ; no report 24 .... S RA74=$G(^RARPT(+$P(RA7003,"^",17),0)) 25 .... Q:$P(RA74,"^",5)="" ; no status, skeletal rpt created by imaging 26 .... Q:"^V^X^EF^"[("^"_$P(RA74,"^",5)_"^") ;Skip Verified, Deleted, E-filed rpts 27 .... I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 Q:RAOUT 28 .... ; ***** check if user selected this division & imaging type **** 29 .... S RA7002=$G(^RADPT(RADFN,"DT",RADTI,0)) ; 0 node Reg. Exams sub-file 30 .... S RADIVNME=$P($G(^DIC(4,+$P(RA7002,"^",3),0)),"^") ; dinum to file 4! 31 .... S:RADIVNME="" RADIVNME="Unknown" 32 .... Q:'$D(^TMP($J,"RA D-TYPE",RADIVNME)) 33 .... Q:'$D(^TMP($J,"RA I-TYPE",$P($G(^RA(79.2,+$P(RA7002,"^",2),0)),"^"))) 34 .... ;***************************************************************** 35 .... S (RAMEMLOW,RAPRTSET,RAPSET)=0 D EN1^RAUTL20 ; mem of a printset? 36 .... S:RAPRTSET RAPSET="1." S:RAMEMLOW RAPSET="1+" 37 .... S RAPIS=$$GET1^DIQ(200,+$P(RA7003,"^",15)_",",.01) 38 .... S:RAPIS="" RAPIS="Unknown" 39 .... S RAPAT=$G(^DPT(RADFN,0)) 40 .... S RASSN=$$SSN^RAUTL() S:RASSN="" RASSN="Unknown" 41 .... S RAPAT=$P(RAPAT,"^") S:RAPAT="" RAPAT="Unknown" 42 .... ;***************************************************************** 43 .... ; Store off the data into our TMP global. First subscript is $J. 44 .... ; Second subscript is: RABD="E", exam date. I RABD="S", second 45 .... ; subscript is Pri. Int'g Staff. Other Subscripts: sub3-exam date, 46 .... ; sub4-patient name, sub5-case number 47 .... S:RABD="E" ^TMP($J,"RAUVR",RADIVNME,($P(RA7002,"^")\1),RAPAT,+$P(RA7003,"^"))=RAPSET_"^"_RASSN_"^"_RA7003 48 .... S:RABD="S" ^TMP($J,"RAUVR",RAPIS,($P(RA7002,"^")\1),RAPAT,+$P(RA7003,"^"))=RAPSET_"^"_RASSN_"^"_RA7003 49 .... S:RABD="E" ^TMP($J,"RAUVR",RADIVNME)=+$G(^TMP($J,"RAUVR",RADIVNME))+1 50 .... ;***************************************************************** 51 .... Q 52 ... Q 53 .. Q 54 . Q 55 S:RABD="S" RAHD="UNVERIFIED IMAGING REPORTS BY PRIMARY INTERPRETING STAFF" 56 S:RABD="E" RAHD="UNVERIFIED IMAGING REPORTS BY DIVISION" 57 S $P(RADASH,"-",(IOM+1))="" 58 I '$D(^TMP($J,"RAUVR")) D Q 59 . N RA1,RANODATA S RANODATA="*** No Unverified Reports ***",RA1="" 60 . I RABD="S" D HDR W !!?(IOM-$L(RANODATA)\2),RANODATA 61 . I RABD="E" D 62 .. N RA1 63 .. S RA1="" F S RA=$O(^TMP($J,"RA D-TYPE",RA1)) Q:RA1="" D Q:RAOUT 64 ... D HDR 65 ... S RANODATA="*** No Unverified Reports for division: "_RA1_" ***" 66 ... W !!?(IOM-$L(RANODATA)\2),RANODATA 67 ... S:$O(^TMP($J,"RA D-TYPE",RA1))]"" RAOUT=$$EOS^RAUTL5() 68 ... Q 69 .. Q 70 . Q 71 D GETDATA 72 KILL ; cleanup symbol table 73 K RA7002,RA7003,RA74,RACSE,RAEXDT,RAHD,RAMEMLOW,RANODE,RAPAT,RAPIS 74 K RAPRC,RAPRTSET,RAPSET,RAXSTAT 75 Q 76 HDR ; header code 77 W:$Y @IOF ; clear screen if not at top-of-page 78 S RAPAGE=RAPAGE+1 W !?(IOM-$L(RAHD)\2),RAHD 79 W !,$S(RABD="S":"Primary Interpreting Staff: ",1:"Division: "),RA1 80 W ?94,$$FMTE^XLFDT(DT,"1P")_" Page: "_RAPAGE 81 W !,?87,"Exam",?96,"Report",!,"Patient",?21,"Patient ID",?38,"Exam Date",?48,"Case",?55,"Procedure",?87,"Status",?96,"Entered",?106,"Pri. Int'g Staff" 82 W !,RADASH 83 Q 84 GETDATA ; get to the data 85 S RA1="",(RAPAGE,RAOUT)=0 86 F S RA1=$O(^TMP($J,"RAUVR",RA1)) Q:RA1="" D Q:RAOUT 87 . D HDR S RAEXDT=0 88 . I RABD="E",$G(^TMP($J,"RAUVR",RA1))=0 D Q 89 .. S X="*** No Unverified Reports for division ***" 90 .. W !!?(IOM-$L(X)\2),X 91 .. S:$O(^TMP($J,"RAUVR",RA1))]"" RAOUT=$$EOS^RAUTL5() 92 .. Q 93 . F S RAEXDT=$O(^TMP($J,"RAUVR",RA1,RAEXDT)) Q:RAEXDT'>0 D Q:RAOUT 94 .. S RAPAT="" 95 .. F S RAPAT=$O(^TMP($J,"RAUVR",RA1,RAEXDT,RAPAT)) Q:RAPAT="" D Q:RAOUT 96 ... S RACSE=0 97 ... F S RACSE=$O(^TMP($J,"RAUVR",RA1,RAEXDT,RAPAT,RACSE)) Q:RACSE'>0 D Q:RAOUT 98 .... I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 Q:RAOUT 99 .... S RANODE=$G(^TMP($J,"RAUVR",RA1,RAEXDT,RAPAT,RACSE)) 100 .... D PRTDATA 101 .... Q 102 ... Q 103 .. Q 104 . S:$O(^TMP($J,"RAUVR",RA1))]"" RAOUT=$$EOS^RAUTL5() 105 . Q 106 Q 107 PRTDATA ; print the data 108 S RAPRC=$E($S($P(^RAMIS(71,+$P(RANODE,"^",4),0),"^")]"":$P(^(0),"^"),1:"Unknown"),1,30) 109 S:+$P(RANODE,"^") RAPRC=$TR($P(RANODE,"^"),"1","")_RAPRC 110 S RAXSTAT=$E($S($P(^RA(72,+$P(RANODE,"^",5),0),"^")]"":$P(^(0),"^"),1:"Unknown"),1,7) 111 S RARPTENT=$$FMTE^XLFDT(($P($G(^RARPT(+$P(RANODE,"^",19),0)),"^",6)\1),"2P") 112 S:RABD="S" RAPIS=RA1 113 S:RABD="E" RAPIS=$$GET1^DIQ(200,+$P(RANODE,"^",17)_",",.01) 114 S:RAPIS="" RAPIS="Unknown" 115 W !,$E(RAPAT,1,20),?21,$P(RANODE,"^",2),?38,$$FMTE^XLFDT(RAEXDT,"2P"),?48,RACSE,?55,RAPRC,?87,RAXSTAT,?96,RARPTENT,?106,$E(RAPIS,1,25) 116 I $Y>(IOSL-4) S RAOUT=$$EOS^RAUTL5() D:'RAOUT HDR 117 Q 118 ZERO ; set division totals to zero 119 S X="" F S X=$O(^TMP($J,"RA D-TYPE",X)) Q:X="" S ^TMP($J,"RAUVR",X)=0 120 Q 1 RARTUVR3 ;HISC/GJC-Unverified Reports ;8/19/97 11:28 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 3 EN1 ; Entry point for unverified reports option when sort is on 4 ; Exam Date or Pri. Inter. Staff 5 ; Data Storage: 6 ; RABD="E": 7 ; ^TMP($J,"RAUVR",Division,Xam Date/Time,Patient,Case #)=print set? (1:yes, 0:no)_^_Pat ID_^_0 node of exam 8 ; RABD="S": 9 ; ^TMP($J,"RAUVR",Pri. Staff,Xam Date/Time,Patient,Case #)=print set? (1:yes, 0:no)_^_Pat ID_^_0 node of exam 10 K ^TMP($J,"RAUVR") S (RAOUT,RAPAGE)=0,RASTATUS="" 11 D:RABD="E" ZERO ; zero out totals for division data 12 S RADTE=BEGDATE-.0001 13 F S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>ENDDATE)!(RAOUT) D 14 . S RADFN=0 15 . F S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0!(RAOUT) D 16 .. S RADTI=0 17 .. F S RADTI=$O(^RADPT("AR",RADTE,RADFN,RADTI)) Q:RADTI'>0!(RAOUT) D 18 ... S RACN=0 19 ... F S RACN=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN)) Q:RACN'>0!(RAOUT) D 20 .... S RACNI=+$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) Q:'RACNI 21 .... S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 22 .... Q:'+$P(RA7003,"^",17) ; no report 23 .... S RA74=$G(^RARPT(+$P(RA7003,"^",17),0)) 24 .... Q:$P(RA74,"^",5)="" ; no status, skeletal rpt created by imaging 25 .... Q:$P(RA74,"^",5)="V" ; verified, quit 26 .... I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 Q:RAOUT 27 .... ; ***** check if user selected this division & imaging type **** 28 .... S RA7002=$G(^RADPT(RADFN,"DT",RADTI,0)) ; 0 node Reg. Exams sub-file 29 .... S RADIVNME=$P($G(^DIC(4,+$P(RA7002,"^",3),0)),"^") ; dinum to file 4! 30 .... S:RADIVNME="" RADIVNME="Unknown" 31 .... Q:'$D(^TMP($J,"RA D-TYPE",RADIVNME)) 32 .... Q:'$D(^TMP($J,"RA I-TYPE",$P($G(^RA(79.2,+$P(RA7002,"^",2),0)),"^"))) 33 .... ;***************************************************************** 34 .... S (RAMEMLOW,RAPRTSET,RAPSET)=0 D EN1^RAUTL20 ; mem of a printset? 35 .... S:RAPRTSET RAPSET="1." S:RAMEMLOW RAPSET="1+" 36 .... S RAPIS=$P($G(^VA(200,+$P(RA7003,"^",15),0)),"^") 37 .... S:RAPIS="" RAPIS="Unknown" 38 .... S RAPAT=$G(^DPT(RADFN,0)) 39 .... S RASSN=$$SSN^RAUTL() S:RASSN="" RASSN="Unknown" 40 .... S RAPAT=$P(RAPAT,"^") S:RAPAT="" RAPAT="Unknown" 41 .... ;***************************************************************** 42 .... ; Store off the data into our TMP global. First subscript is $J. 43 .... ; Second subscript is: RABD="E", exam date. I RABD="S", second 44 .... ; subscript is Pri. Int'g Staff. Other Subscripts: sub3-exam date, 45 .... ; sub4-patient name, sub5-case number 46 .... S:RABD="E" ^TMP($J,"RAUVR",RADIVNME,($P(RA7002,"^")\1),RAPAT,+$P(RA7003,"^"))=RAPSET_"^"_RASSN_"^"_RA7003 47 .... S:RABD="S" ^TMP($J,"RAUVR",RAPIS,($P(RA7002,"^")\1),RAPAT,+$P(RA7003,"^"))=RAPSET_"^"_RASSN_"^"_RA7003 48 .... S:RABD="E" ^TMP($J,"RAUVR",RADIVNME)=+$G(^TMP($J,"RAUVR",RADIVNME))+1 49 .... ;***************************************************************** 50 .... Q 51 ... Q 52 .. Q 53 . Q 54 S:RABD="S" RAHD="UNVERIFIED IMAGING REPORTS BY PRIMARY INTERPRETING STAFF" 55 S:RABD="E" RAHD="UNVERIFIED IMAGING REPORTS BY DIVISION" 56 S $P(RADASH,"-",(IOM+1))="" 57 I '$D(^TMP($J,"RAUVR")) D Q 58 . N RA1,RANODATA S RANODATA="*** No Unverified Reports ***",RA1="" 59 . I RABD="S" D HDR W !!?(IOM-$L(RANODATA)\2),RANODATA 60 . I RABD="E" D 61 .. N RA1 62 .. S RA1="" F S RA=$O(^TMP($J,"RA D-TYPE",RA1)) Q:RA1="" D Q:RAOUT 63 ... D HDR 64 ... S RANODATA="*** No Unverified Reports for division: "_RA1_" ***" 65 ... W !!?(IOM-$L(RANODATA)\2),RANODATA 66 ... S:$O(^TMP($J,"RA D-TYPE",RA1))]"" RAOUT=$$EOS^RAUTL5() 67 ... Q 68 .. Q 69 . Q 70 D GETDATA 71 KILL ; cleanup symbol table 72 K RA7002,RA7003,RA74,RACSE,RAEXDT,RAHD,RAMEMLOW,RANODE,RAPAT,RAPIS 73 K RAPRC,RAPRTSET,RAPSET,RAXSTAT 74 Q 75 HDR ; header code 76 W:$Y @IOF ; clear screen if not at top-of-page 77 S RAPAGE=RAPAGE+1 W !?(IOM-$L(RAHD)\2),RAHD 78 W !,$S(RABD="S":"Primary Interpreting Staff: ",1:"Division: "),RA1 79 W ?94,$$FMTE^XLFDT(DT,"1P")_" Page: "_RAPAGE 80 W !,?87,"Exam",?96,"Report",!,"Patient",?21,"Patient ID",?38,"Exam Date",?48,"Case",?55,"Procedure",?87,"Status",?96,"Entered",?106,"Pri. Int'g Staff" 81 W !,RADASH 82 Q 83 GETDATA ; get to the data 84 S RA1="",(RAPAGE,RAOUT)=0 85 F S RA1=$O(^TMP($J,"RAUVR",RA1)) Q:RA1="" D Q:RAOUT 86 . D HDR S RAEXDT=0 87 . I RABD="E",$G(^TMP($J,"RAUVR",RA1))=0 D Q 88 .. S X="*** No Unverified Reports for division ***" 89 .. W !!?(IOM-$L(X)\2),X 90 .. S:$O(^TMP($J,"RAUVR",RA1))]"" RAOUT=$$EOS^RAUTL5() 91 .. Q 92 . F S RAEXDT=$O(^TMP($J,"RAUVR",RA1,RAEXDT)) Q:RAEXDT'>0 D Q:RAOUT 93 .. S RAPAT="" 94 .. F S RAPAT=$O(^TMP($J,"RAUVR",RA1,RAEXDT,RAPAT)) Q:RAPAT="" D Q:RAOUT 95 ... S RACSE=0 96 ... F S RACSE=$O(^TMP($J,"RAUVR",RA1,RAEXDT,RAPAT,RACSE)) Q:RACSE'>0 D Q:RAOUT 97 .... I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 Q:RAOUT 98 .... S RANODE=$G(^TMP($J,"RAUVR",RA1,RAEXDT,RAPAT,RACSE)) 99 .... D PRTDATA 100 .... Q 101 ... Q 102 .. Q 103 . S:$O(^TMP($J,"RAUVR",RA1))]"" RAOUT=$$EOS^RAUTL5() 104 . Q 105 Q 106 PRTDATA ; print the data 107 S RAPRC=$E($S($P(^RAMIS(71,+$P(RANODE,"^",4),0),"^")]"":$P(^(0),"^"),1:"Unknown"),1,30) 108 S:+$P(RANODE,"^") RAPRC=$TR($P(RANODE,"^"),"1","")_RAPRC 109 S RAXSTAT=$E($S($P(^RA(72,+$P(RANODE,"^",5),0),"^")]"":$P(^(0),"^"),1:"Unknown"),1,7) 110 S RARPTENT=$$FMTE^XLFDT(($P($G(^RARPT(+$P(RANODE,"^",19),0)),"^",6)\1),"2P") 111 S:RABD="S" RAPIS=RA1 112 S:RABD="E" RAPIS=$P($G(^VA(200,+$P(RANODE,"^",17),0)),"^") 113 S:RAPIS="" RAPIS="Unknown" 114 W !,$E(RAPAT,1,20),?21,$P(RANODE,"^",2),?38,$$FMTE^XLFDT(RAEXDT,"2P"),?48,RACSE,?55,RAPRC,?87,RAXSTAT,?96,RARPTENT,?106,$E(RAPIS,1,25) 115 I $Y>(IOSL-4) S RAOUT=$$EOS^RAUTL5() D:'RAOUT HDR 116 Q 117 ZERO ; set division totals to zero 118 S X="" F S X=$O(^TMP($J,"RA D-TYPE",X)) Q:X="" S ^TMP($J,"RAUVR",X)=0 119 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTVER.m
r613 r623 1 RARTVER ;HISC/FPT,CAH AISC/MJK,RMO-On-line Verify Reports ;11/19/97 13:52 2 ;;5.0;Radiology/Nuclear Medicine;**8,23,26,82,56**;Mar 16, 1998;Build 3 3 ;Supported IA #10035 ^DPT( 4 ;Supported IA #10060 ^VA(200 5 D SET^RAPSET1 I $D(XQUIT) K XQUIT Q 6 N RAVFIED,RAXIT S RAXIT=0 7 K RAVER S:$D(^VA(200,DUZ,0)) RAVER=$P(^(0),"^") I '$D(RAVER) W !!,$C(7),"Your name must be defined in the NEW PERSON File to continue." G Q 8 I '$D(^VA(200,"ARC","R",DUZ)),'$D(^VA(200,"ARC","S",DUZ)) W !!,$C(7),"This option is only available for Rad/Nuc Med Interpreting Physicians." G Q 9 I '$$CHKUSR^RAO7UTL(DUZ) D ERR^RARTVER2(DUZ) D Q QUIT 10 I $D(^VA(200,"ARC","S",DUZ)) S RASTAFF=1 G 1 11 I $P(RAMDV,"^",18)'=1 W !!,$C(7),"Interpreting Residents are not allowed to verify reports.",!! G Q 12 1 S RAONLINE="" W ! D ES^RASIGU G Q:'% 13 I $D(RASTAFF),$P($G(^VA(200,DUZ,"RA")),U,2)'="y" S RARAD=DUZ,RAD="ASTF",RARESFLG="" G SRTRPT ;selected USER does NOT have ALLOW VERIFYING OF OTHERS 14 I '$D(^VA(200,"ARC","S",DUZ)),$S('$P(RAMDV,"^",18):1,'$D(^VA(200,"ARC","R",DUZ)):1,'$D(^VA(200,DUZ,"RA")):1,$P(^VA(200,DUZ,"RA"),"^",2)'="y":1,1:0) S RARAD=DUZ,RAD="ARES",RARESFLG="" G SRTRPT 15 ASKRAD W ! S DIC("B")=RAVER,DIC("S")="I $D(^VA(200,""ARC"",""R"",Y))!($D(^VA(200,""ARC"",""S"",Y)))",DIC("A")="Select Interpreting Physician: ",DIC="^VA(200,",DIC(0)="AEMQ" D ^DIC K DIC G Q:Y<0 S RARAD=+Y 16 S RAD=$S($D(^VA(200,"ARC","R",RARAD)):"ARES",1:"ASTF") 17 ; 18 SRTRPT K ^TMP($J,"RA"),RA,RARPTX 19 S RARADHLD=RARAD,RATOT=0,RARPT=0 20 ;tmp($j,"ra","dt",-,-) = 21 ;^rpt status at start of selection^/long CN^Pat.ien^Proc.ien 22 F S RARPT=$O(^RARPT(RAD,RARAD,RARPT)) Q:'RARPT I $D(^RARPT(RARPT,0)) S RARTDT=$S($P(^(0),"^",6)="":9999999.9999,1:$P(^(0),"^",6)) D 23 .Q:$$STUB^RAEDCN1(RARPT) ;skip stub report 081500 24 .Q:"^V^EF^"[("^"_$P($G(^RARPT(+RARPT,0)),"^",5)_"^") ;skip 'V' & "EF' 25 .S Y=RARPT D RASET^RAUTL2 ;returns Y=radpt(radfn,"dt",radti,"p",-,0) 26 .Q:'Y ;record must be corrupt no zero node for ADC x-ref!! 27 .S ^TMP($J,"RA","DT",RARTDT,RARPT)="^"_$P($G(^RARPT(+RARPT,0)),"^",5)_"^/"_$P(^(0),"^",1,2)_"^"_+$P(Y,U,2) 28 .S RATOT=RATOT+1 29 .Q 30 I 'RATOT S RANM=$S($D(^VA(200,RARAD,0)):$P(^(0),"^"),1:"UNKNOWN"),RANM=$S(RANM=RAVER:"You have",1:"Interpreting Physician "_RANM_" has") W !!,RANM," no Unverified Reports." G Q:$D(RARESFLG),ASKRAD 31 N RATOTORI S RATOTORI=RATOT ; save original value of RATOT 32 ; 33 SELRPT I RATOT=1 D ONERPT^RARTVER1 G:'$D(^TMP($J,"RA")) Q S RACHOICE=5,RACHOICE("1RPT")="" G RPTLP 34 D TALLY^RARTVER1,SELRPT^RARTVER1 G Q:Y=0 S RACHOICE=+Y 35 I Y=1 D PV^RARTVER1 G:RATOT'>0 SRTRPT G RPTLP 36 I Y=2 S RASTATUS="R" D DPDRNV^RARTVER1 G:RATOT'>0 SRTRPT G RPTLP 37 I Y=3 S RASTATUS="D" D DPDRNV^RARTVER1 G:RATOT'>0 SRTRPT G RPTLP 38 I Y=4 S RASTATUS="PD" D DPDRNV^RARTVER1 G:RATOT'>0 SRTRPT G RPTLP 39 I Y=5 G RPTLP 40 I Y=7 D STAT^RARTVER1 G:RATOT'>0 SRTRPT G RPTLP 41 ; if none of the above, then defaults to Y=6 SELECTED 42 S RASTATFG="" D ^RARTVER1 K RASTATFG G Q:$D(RAOUT)!('$D(RARPTX)) 43 ; 44 RPTLP S DIR(0)="S^P:PAGE AT A TIME;E:ENTIRE REPORT",DIR("B")="P",DIR("A")="How would you like to view the reports?" 45 S DIR("?",1)="If you would like to pause after each page of the report enter 'P'.",DIR("?")="Otherwise enter 'E' to view an entire report at one time." 46 D ^DIR K DIR G Q:$D(DIRUT) I Y="E" S RARTVERF=1 47 S RACHOICE("NAME")=$S(RACHOICE=6:"SELECTED",RACHOICE=5:"ALL",RACHOICE=4:"PROBLEM DRAFT",RACHOICE=3:"DRAFT",RACHOICE=2:"RELEASED/NOT VERIFIED",1:"PREVERIFIED") 48 RPTLP1 I $D(^TMP($J,"RA","DT")) S RARPT=0,RARTDT=0 F S RARTDT=$O(^TMP($J,"RA","DT",RARTDT)) Q:'RARTDT S RARDX="" D GETRPT Q:RARDX="^" I $D(RARLTV),$G(RARLTV)=0 D ADDLRPT^RARTVER2 Q:RATOT=0 S RARLTV=RATOT G RPTLP1 49 I $D(^TMP($J,"RA","XREF")) S (RPTX,RARPT)=0 D GETRPT 50 ; RARESFLG is used to flag that VERIFYING OF OTHERS is allowed 51 ; Before looping back, RARESFLG is set, so that if there are no reports, 52 ; the logic will goto Q instead of to ASKRAD 53 I RATOTORI>1 S RARAD=RARADHLD,RARESFLG="" K RARLTV,RARTVERF G SRTRPT ; go another round 54 ; also dis-allow re-asking another USER when all reports 55 ; become verified by current USER 56 ; 57 Q D CU^RARTVER2 58 Q 59 ; 60 GETRPT I $G(RARPT) L -^RARPT(RARPT) 61 S:$D(^TMP($J,"RA","XREF")) RPTX=RPTX+1 S RARPT=$S($D(^TMP($J,"RA","DT")):$O(^TMP($J,"RA","DT",RARTDT,RARPT)),$D(^TMP($J,"RA","XREF")):+$G(RARPTX(RPTX)),1:0) Q:'RARPT 62 I $D(^TMP($J,"RA","DT")) G:$P(^TMP($J,"RA","DT",RARTDT,RARPT),"^")="V" GETRPT S $P(^TMP($J,"RA","DT",RARTDT,RARPT),"^")="V" ;here, V = viewed already 63 I '$D(^RARPT(RARPT)) D MSG1 G GETRPT ;rpt disappeared 64 L +^RARPT(RARPT):2 I '$T G LOCK^RARTVER2 65 S RAXIT=0 D DISRPT^RARTVER2 I $G(X)="^" S RARDX="^" Q ;display whole report 66 I +$G(RAVFIED) S RAVFIED=0 G GETRPT 67 N RASTBEF S RASTBEF=$S($D(^TMP($J,"RA","DT",+$G(RARTDT),+$G(RARPT))):$P(^(RARPT),"^",2),$D(^TMP($J,"RA","XREF")):$P($G(RARPTX(RPTX)),U,2),1:"") 68 ASK Q:RAXIT W ! S I="",$P(I,"=",80)="" W I K I 69 I "12345"[$E(RACHOICE) D:'$D(RARLTVFL) RLTV^RARTVER1 D:$D(RARLTVFL) RLTV1^RARTVER1 70 S RARD("A")="",RARD(1)="Print^print this report for editing",RARD(2)="Edit^edit this report",RARD(3)="Top^display the report from the beginning",RARD(4)="continue^continue normal processing" 71 S RARD(5)="Status & Print^edit Status, then print report",RARD(0)="S",RARD("B")=4 72 S:$G(RARLTV) RARLTV=RARLTV-1 73 I $G(RARLTV)>0 S RARD("A")="("_$G(RARLTV)_" left to review) " 74 I $G(RARLTV)=0 I '$D(RACHOICE("1RPT")) S RARD("A")="(No more "_RACHOICE("NAME")_") " S:RACHOICE=5 RARD("A")="(ALL gone) " 75 S RARD("A")=RARD("A")_"Type '?' for action list, 'Enter' to " ;12/30/96 76 I RASTBEF'=$P(^RARPT(RARPT,0),U,5) D MSG2 77 D SET^RARD K RARD S RARDX=$E(X) I RARDX="^" L -^RARPT(RARPT) Q 78 ; if user chose "T"op, the report will be displayed again from the top 79 I "PT"[RARDX D PRTRPT^RARTVER2:RARDX="P",DISRPT^RARTVER2:RARDX="T" G ASK 80 I RARDX="E" D EDTCHK^RARTVER2 I RARDX="E" W !!,"EDITING REPORT",!,"--------------",! D EDTRPT^RARTE1 D K RAAB G ASK 81 .; RAHLTCPB flag is inactive 82 .N RAHLTCPB S RAHLTCPB=1 D:RACT="V" UPSTAT^RAUTL0 D:RACT'="V" UP1^RAUTL1 83 S RAPGM="GETRPT^RARTVER" G 31^RART ;goto Verify Report Only template 84 ; 85 MSG1 N I,J1,J2,J3 S I=$S($D(^TMP($J,"RA","DT",+$G(RARTDT),+$G(RARPT))):^(RARPT),$D(^TMP($J,"RA","XREF")):$G(RARPTX(RPTX)),1:"") 86 S J1=$P(I,"/",2),J2=$P(J1,"^",2),J3=$P(J1,"^",3),J1=$P(J1,"^") 87 W !!!?15,$C(7),"Since the time you selected this group of reports,",!?15,"another user has deleted this report for",!?15,$P($G(^DPT(J2,0)),"^")," case ",J1,!?15,"Procedure ",$P($G(^RAMIS(71,+J3,0)),U),".",!! G CONT Q 88 MSG2 N I,J S I=";"_$P(^RARPT(RARPT,0),"^",5)_":" 89 S J=";"_$P(^DD(74,5,0),U,3) 90 W !!!?15,$C(7),"Since the time you selected this group of reports,",!?15,"another user has changed this report's status to '",$P($P(J,I,2),";"),"'.",!! Q 91 CONT W !! S DIR(0)="FO",DIR("A")="Press return key to continue " D ^DIR 92 Q 1 RARTVER ;HISC/FPT,CAH AISC/MJK,RMO-On-line Verify Reports ;11/19/97 13:52 2 ;;5.0;Radiology/Nuclear Medicine;**8,23,26,82**;Mar 16, 1998;Build 8 3 D SET^RAPSET1 I $D(XQUIT) K XQUIT Q 4 N RAVFIED,RAXIT S RAXIT=0 5 K RAVER S:$D(^VA(200,DUZ,0)) RAVER=$P(^(0),"^") I '$D(RAVER) W !!,*7,"Your name must be defined in the NEW PERSON File to continue." G Q 6 I '$D(^VA(200,"ARC","R",DUZ)),'$D(^VA(200,"ARC","S",DUZ)) W !!,*7,"This option is only available for Rad/Nuc Med Interpreting Physicians." G Q 7 I '$$CHKUSR^RAO7UTL(DUZ) D ERR^RARTVER2(DUZ) D Q QUIT 8 I $D(^VA(200,"ARC","S",DUZ)) S RASTAFF=1 G 1 9 I $P(RAMDV,"^",18)'=1 W !!,*7,"Interpreting Residents are not allowed to verify reports.",!! G Q 10 1 S RAONLINE="" W ! D ES^RASIGU G Q:'% 11 I $D(RASTAFF),$P($G(^VA(200,DUZ,"RA")),U,2)'="y" S RARAD=DUZ,RAD="ASTF",RARESFLG="" G SRTRPT ;selected USER does NOT have ALLOW VERIFYING OF OTHERS 12 I '$D(^VA(200,"ARC","S",DUZ)),$S('$P(RAMDV,"^",18):1,'$D(^VA(200,"ARC","R",DUZ)):1,'$D(^VA(200,DUZ,"RA")):1,$P(^VA(200,DUZ,"RA"),"^",2)'="y":1,1:0) S RARAD=DUZ,RAD="ARES",RARESFLG="" G SRTRPT 13 ASKRAD W ! S DIC("B")=RAVER,DIC("S")="I $D(^VA(200,""ARC"",""R"",Y))!($D(^VA(200,""ARC"",""S"",Y)))",DIC("A")="Select Interpreting Physician: ",DIC="^VA(200,",DIC(0)="AEMQ" D ^DIC K DIC G Q:Y<0 S RARAD=+Y 14 S RAD=$S($D(^VA(200,"ARC","R",RARAD)):"ARES",1:"ASTF") 15 ; 16 SRTRPT K ^TMP($J,"RA"),RA,RARPTX 17 S RARADHLD=RARAD,RATOT=0,RARPT=0 18 ;tmp($j,"ra","dt",-,-) = 19 ;^rpt status at start of selection^/long CN^Pat.ien^Proc.ien 20 F S RARPT=$O(^RARPT(RAD,RARAD,RARPT)) Q:'RARPT I $D(^RARPT(RARPT,0)) S RARTDT=$S($P(^(0),"^",6)="":9999999.9999,1:$P(^(0),"^",6)) D 21 .Q:$$STUB^RAEDCN1(RARPT) ;skip stub report 081500 22 .Q:$P($G(^RARPT(+RARPT,0)),"^",5)="V" ; skip if already verified 23 .S Y=RARPT D RASET^RAUTL2 ;returns Y=radpt(radfn,"dt",radti,"p",-,0) 24 .Q:'Y ;record must be corrupt no zero node for ADC x-ref!! 25 .S ^TMP($J,"RA","DT",RARTDT,RARPT)="^"_$P($G(^RARPT(+RARPT,0)),"^",5)_"^/"_$P(^(0),"^",1,2)_"^"_+$P(Y,U,2) 26 .S RATOT=RATOT+1 27 .Q 28 I 'RATOT S RANM=$S($D(^VA(200,RARAD,0)):$P(^(0),"^"),1:"UNKNOWN"),RANM=$S(RANM=RAVER:"You have",1:"Interpreting Physician "_RANM_" has") W !!,RANM," no Unverified Reports." G Q:$D(RARESFLG),ASKRAD 29 N RATOTORI S RATOTORI=RATOT ; save original value of RATOT 30 ; 31 SELRPT I RATOT=1 D ONERPT^RARTVER1 G:'$D(^TMP($J,"RA")) Q S RACHOICE=5,RACHOICE("1RPT")="" G RPTLP 32 D TALLY^RARTVER1,SELRPT^RARTVER1 G Q:Y=0 S RACHOICE=+Y 33 I Y=1 D PV^RARTVER1 G:RATOT'>0 SRTRPT G RPTLP 34 I Y=2 S RASTATUS="R" D DPDRNV^RARTVER1 G:RATOT'>0 SRTRPT G RPTLP 35 I Y=3 S RASTATUS="D" D DPDRNV^RARTVER1 G:RATOT'>0 SRTRPT G RPTLP 36 I Y=4 S RASTATUS="PD" D DPDRNV^RARTVER1 G:RATOT'>0 SRTRPT G RPTLP 37 I Y=5 G RPTLP 38 I Y=7 D STAT^RARTVER1 G:RATOT'>0 SRTRPT G RPTLP 39 ; if none of the above, then defaults to Y=6 SELECTED 40 S RASTATFG="" D ^RARTVER1 K RASTATFG G Q:$D(RAOUT)!('$D(RARPTX)) 41 ; 42 RPTLP S DIR(0)="S^P:PAGE AT A TIME;E:ENTIRE REPORT",DIR("B")="P",DIR("A")="How would you like to view the reports?" 43 S DIR("?",1)="If you would like to pause after each page of the report enter 'P'.",DIR("?")="Otherwise enter 'E' to view an entire report at one time." 44 D ^DIR K DIR G Q:$D(DIRUT) I Y="E" S RARTVERF=1 45 S RACHOICE("NAME")=$S(RACHOICE=6:"SELECTED",RACHOICE=5:"ALL",RACHOICE=4:"PROBLEM DRAFT",RACHOICE=3:"DRAFT",RACHOICE=2:"RELEASED/NOT VERIFIED",1:"PREVERIFIED") 46 RPTLP1 I $D(^TMP($J,"RA","DT")) S RARPT=0,RARTDT=0 F S RARTDT=$O(^TMP($J,"RA","DT",RARTDT)) Q:'RARTDT S RARDX="" D GETRPT Q:RARDX="^" I $D(RARLTV),$G(RARLTV)=0 D ADDLRPT^RARTVER2 Q:RATOT=0 S RARLTV=RATOT G RPTLP1 47 I $D(^TMP($J,"RA","XREF")) S (RPTX,RARPT)=0 D GETRPT 48 ; RARESFLG is used to flag that VERIFYING OF OTHERS is allowed 49 ; Before looping back, RARESFLG is set, so that if there are no reports, 50 ; the logic will goto Q instead of to ASKRAD 51 I RATOTORI>1 S RARAD=RARADHLD,RARESFLG="" K RARLTV,RARTVERF G SRTRPT ; go another round 52 ; also dis-allow re-asking another USER when all reports 53 ; become verified by current USER 54 ; 55 Q D CU^RARTVER2 56 Q 57 ; 58 GETRPT I $G(RARPT) L -^RARPT(RARPT) 59 S:$D(^TMP($J,"RA","XREF")) RPTX=RPTX+1 S RARPT=$S($D(^TMP($J,"RA","DT")):$O(^TMP($J,"RA","DT",RARTDT,RARPT)),$D(^TMP($J,"RA","XREF")):+$G(RARPTX(RPTX)),1:0) Q:'RARPT 60 I $D(^TMP($J,"RA","DT")) G:$P(^TMP($J,"RA","DT",RARTDT,RARPT),"^")="V" GETRPT S $P(^TMP($J,"RA","DT",RARTDT,RARPT),"^")="V" ;here, V = viewed already 61 I '$D(^RARPT(RARPT)) D MSG1 G GETRPT ;rpt disappeared 62 L +^RARPT(RARPT):2 I '$T G LOCK^RARTVER2 63 S RAXIT=0 D DISRPT^RARTVER2 I $G(X)="^" S RARDX="^" Q ;display whole report 64 I +$G(RAVFIED) S RAVFIED=0 G GETRPT 65 N RASTBEF S RASTBEF=$S($D(^TMP($J,"RA","DT",+$G(RARTDT),+$G(RARPT))):$P(^(RARPT),"^",2),$D(^TMP($J,"RA","XREF")):$P($G(RARPTX(RPTX)),U,2),1:"") 66 ASK Q:RAXIT W ! S I="",$P(I,"=",80)="" W I K I 67 I "12345"[$E(RACHOICE) D:'$D(RARLTVFL) RLTV^RARTVER1 D:$D(RARLTVFL) RLTV1^RARTVER1 68 S RARD("A")="",RARD(1)="Print^print this report for editing",RARD(2)="Edit^edit this report",RARD(3)="Top^display the report from the beginning",RARD(4)="continue^continue normal processing" 69 S RARD(5)="Status & Print^edit Status, then print report",RARD(0)="S",RARD("B")=4 70 S:$G(RARLTV) RARLTV=RARLTV-1 71 I $G(RARLTV)>0 S RARD("A")="("_$G(RARLTV)_" left to review) " 72 I $G(RARLTV)=0 I '$D(RACHOICE("1RPT")) S RARD("A")="(No more "_RACHOICE("NAME")_") " S:RACHOICE=5 RARD("A")="(ALL gone) " 73 S RARD("A")=RARD("A")_"Type '?' for action list, 'Enter' to " ;12/30/96 74 I RASTBEF'=$P(^RARPT(RARPT,0),U,5) D MSG2 75 D SET^RARD K RARD S RARDX=$E(X) I RARDX="^" L -^RARPT(RARPT) Q 76 ; if user chose "T"op, the report will be displayed again from the top 77 I "PT"[RARDX D PRTRPT^RARTVER2:RARDX="P",DISRPT^RARTVER2:RARDX="T" G ASK 78 I RARDX="E" D EDTCHK^RARTVER2 I RARDX="E" W !!,"EDITING REPORT",!,"--------------",! D EDTRPT^RARTE1 D K RAAB G ASK 79 .; RAHLTCPB flag is inactive 80 .N RAHLTCPB S RAHLTCPB=1 D:RACT="V" UPSTAT^RAUTL0 D:RACT'="V" UP1^RAUTL1 81 S RAPGM="GETRPT^RARTVER" G 31^RART ;goto Verify Report Only template 82 ; 83 MSG1 N I,J1,J2,J3 S I=$S($D(^TMP($J,"RA","DT",+$G(RARTDT),+$G(RARPT))):^(RARPT),$D(^TMP($J,"RA","XREF")):$G(RARPTX(RPTX)),1:"") 84 S J1=$P(I,"/",2),J2=$P(J1,"^",2),J3=$P(J1,"^",3),J1=$P(J1,"^") 85 W !!!?15,*7,"Since the time you selected this group of reports,",!?15,"another user has deleted this report for",!?15,$P($G(^DPT(J2,0)),"^")," case ",J1,!?15,"Procedure ",$P($G(^RAMIS(71,+J3,0)),U),".",!! G CONT Q 86 MSG2 N I,J S I=";"_$P(^RARPT(RARPT,0),"^",5)_":" 87 S J=";"_$P(^DD(74,5,0),U,3) 88 W !!!?15,*7,"Since the time you selected this group of reports,",!?15,"another user has changed this report's status to '",$P($P(J,I,2),";"),"'.",!! Q 89 CONT W !! S DIR(0)="FO",DIR("A")="Press return key to continue " D ^DIR 90 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RASTREQ.m
r613 r623 1 RASTREQ ;HISC/CAH,GJC AISC/MJK-Status Requirements Check Routine ;6/3/98 09:56 2 ;;5.0;Radiology/Nuclear Medicine;**1,10,23,40,56**;Mar 16, 1998;Build 3 3 ;Supported IA #10104 UP^XLFSTR 4 ;Supported IA #1367 LKUP^XPDKEY 5 ;Supported IA #10060 ^VA(200 6 ;Supported IA #10076 ^XUSEC( 7 ; Called by 8 ; (1) Stat Track's [RA STATUS CHANGE]'s fld EXAM STATUS' input transform 9 ; (2) ASK+22^RASTED, if user "^" out of stat trk editing 10 ; (3) Cancel an Exam's [RA CANCEL]'s fld EXAM STATUS' input transform 11 ; (4) Enter Last Past Visit Before DHCP's [RA LAST PAST VISIT]'s "" 12 ; 13 ; Instead of using RAIMGTY, recalculate 14 ; the imaging type using the imaging type on the exam node because 15 ; status updating through report entry/edit, batch verify, and several 16 ; other options is NOT screened by sign-on imaging type, so does not 17 ; stay the same through a user's session. 18 ; 19 ; 'RAMES1' is used to display which Exam Status required fields are 20 ; not populated. This only applies to the 'Status Tracking Of Exams' 21 ; option. 22 ; 23 ; If tracking ^-out, this rtn would be called outside of edt tmpl, 24 ; and thus the DA vars would not be defined, so we need to set them here 25 ; 26 S:'$D(DA)#2 DA=RACNI S:'$D(DA(1))#2 DA(1)=RADTI S:'$D(DA(2))#2 DA(2)=RADFN 27 ; If Fileman enter/edit, we need to define RADFN, RADTI, RACNI so the 28 ; nuc med checks won't bomb 29 S:'$D(RACNI)#2 RACNI=DA S:'$D(RADTI)#2 RADTI=DA(1) S:'$D(RADFN)#2 RADFN=DA(2) 30 ; 31 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 32 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 33 S RAXX=+$G(X) 34 I '$D(^RA(72,RAXX,0))!(RAIMGTYJ']"") D Q 35 . K X W:'$D(ZTQUEUED)#2 !?3,"Error: cannot determine Imaging Type of exam. Contact IRM." 36 . K RAMES1,RAXX 37 . Q 38 N RA,RASN,RASTI,RADES,RAOKAY,RA3 39 ; RADES = order seq. desired, RAOKAY= actual order seq. okay'd 40 S X1=$G(^RA(72,RAXX,0)),RADES=$P(X1,U,3) 41 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" Q 42 S RAJ=^RADPT(DA(2),"DT",DA(1),"P",DA,0),RAOR=-1 43 S RABEFORE=$P($G(^RA(72,+$P(RAJ,U,3),0)),U,3) ; current order seq 44 ; Don't need to set RAORDIFN,RACS,RAPRIT,RAF5 45 I '$D(^RA(72,"AA",RAIMGTYJ,0,RAXX)) D LOOP^RASTREQ1 S RAIMGTYJ=RASAVTYJ 46 I $D(^RA(72,"AA",RAIMGTYJ,0,RAXX)) D CANCEL^RASTREQ1 47 S RAIMGTYJ=RASAVTYJ 48 ; Can't use X to determine if status change to next was successful 49 ; due to looping thru all status levels for this img type 50 ; chk if calculated order is at NEXT or higher level 51 ; RAAFTER is set in rastreq1; it has 2 meanings : 52 ; upon return from rastreq1, RAAFTER means highest seq order qualified 53 ; upon exit from this rtn, RAAFTER means actual seq order used 54 I RABEFORE<RAAFTER D G MSG 55 . I RADES<RAAFTER S RAOKAY=RADES 56 . E S RAOKAY=RAAFTER 57 . Q 58 I RAAFTER<RABEFORE D G MSG 59 . I RADES<RAAFTER S RAOKAY=RADES 60 . E S RAOKAY=RAAFTER 61 . Q 62 ; at this point RAAFTER=RABEFORE 63 I RADES<RAAFTER S RAOKAY=RADES 64 E S RAOKAY=RABEFORE 65 MSG I RAOKAY=RABEFORE K X W:'$D(ZTQUEUED)#2 !?5," ...exam status not changed" G KOUT2 66 S X=$O(^RA(72,"AA",RAIMGTYJ,RAOKAY,0)) 67 S:$D(RANEXT) RANEXT=^RA(72,+X,0) ;set existing RANEXT to ok'd status 68 I RAOKAY<RABEFORE W:'$D(ZTQUEUED)#2 !?5," ...exam status backed down to '",$P($G(^RA(72,+X,0)),U),"'" G KOUT2 69 I RAOKAY<RADES W:'$D(ZTQUEUED)#2 !!?5," ...though upgraded, new status level (",$P($G(^RA(72,+$O(^RA(72,"AA",RAIMGTYJ,RAOKAY,0)),0)),U),")",!?5,"is not as high as the desired level (",$P($G(^RA(72,+$O(^RA(72,"AA",RAIMGTYJ,RADES,0)),0)),U),")",! 70 KOUT1 ; check for higher qualifying status(es) 71 G:RAOKAY'<RAAFTER!(RAOKAY=9) KOUT2 S RA3=RAOKAY 72 W !!,"This case also qualifies for higher status(es) :",! 73 F S RA3=$O(^RA(72,"AA",RAIMGTYJ,RA3)) Q:RA3="" Q:RA3>RAAFTER W:'$D(ZTQUEUED)#2 ?$X+4,$P($G(^RA(72,$O(^(RA3,0)),0)),U) 74 W:'$D(ZTQUEUED)#2 !!,"Since Status Tracking can only upgrade one status at a time,",!,"please edit this exam again.",! 75 KOUT2 S RAAFTER=RAOKAY ;return as actual seq order used, not nec. highest 76 K RAIMGTYI,RAIMGTYJ,RAMES1,RAZ,RAXX,RAJ,RAS,RAK,RAE,X1,RASAVTYJ 77 Q 78 ; 79 1 ;Technologist Check 80 N DIERR 81 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) 82 I RA("TECH")']"" K X S RAZ="technologist" X:$D(RAMES1) RAMES1 83 K RA("TECH") Q 84 ; 85 2 ;Interpreting Physician Check 86 N DIERR 87 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 88 Q 89 ; 90 3 ;Detailed Procedure Check 91 S RAZ="detailed procedure" I '$D(^RAMIS(71,+$P(RAJ,"^",2),0)) K X X:$D(RAMES1) RAMES1 Q 92 S RAJ1=$G(^RAMIS(71,+$P(RAJ,"^",2),0)) I "DS"'[$P(RAJ1,"^",6) K X X:$D(RAMES1) RAMES1 Q 93 S RAZ="detailed procedure (no CPT code)" I $P(RAJ1,"^",9)']"" K X X:$D(RAMES1) RAMES1 Q 94 Q 95 ; 96 4 ;Film Data Check 97 I '$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"F",0)) K X S RAZ="film data" X:$D(RAMES1) RAMES1 98 Q 99 ; 100 5 ;Diagnostic Code Check 101 I '$D(^RA(78.3,+$P(RAJ,"^",13),0)) K X S RAZ="diagnostic code" X:$D(RAMES1) RAMES1 102 Q 103 ; 104 6 ;Camera/Equipment/Room Check 105 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 106 Q 107 ; 108 11 ;Report Entered and not just a stub rec for Img/PACS Check 109 I '$D(^RARPT(+$P(RAJ,"^",17),0)) G NORPT 110 ; since there's a rpt ptr, must check if the rpt is just a stub rpt 111 N RA17,RA0 ; use logic from RAREG 112 S RA17=+$P(RAJ,"^",17) 113 I $$STUB^RAEDCN1(RA17) G NORPT ; rpt is an image stub 114 Q 115 NORPT ; either no report yet, or report is stub 116 K X S RAZ="report" X:$D(RAMES1) RAMES1 117 Q 118 ; 119 12 ;Report Verified Check 120 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 121 Q 122 ; 123 16 ;Impression Entry Check 124 ; In Phase 1, for Elec. filed rpts, skip this even if div. param requires it 125 I $D(^RARPT(+$P(RAJ,"^",17),0)),$P(^(0),"^",5)="EF" Q 126 I $O(^RARPT(+$P(RAJ,"^",17),"I",0))'>0 K X S RAZ="impression" X:$D(RAMES1) RAMES1 127 Q 128 13 ;Procedure Modifers Check 129 I '$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"M",0)) K X S RAZ="procedure modifier" X:$D(RAMES1) RAMES1 130 Q 131 14 ;CPT Modifiers Check 132 I '$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"CMOD",0)) K X S RAZ="CPT modifiers" X:$D(RAMES1) RAMES1 133 Q 134 ; 135 HELP ; Called from 'Help Text' node in DD(70.03,3,4). 136 N E,RA 137 S RAJ=$G(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) 138 S RAIMGTYI=+$P($G(^RADPT(DA(2),"DT",DA(1),0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U,1) 139 I RAIMGTYJ']"" W !,"ERROR: Cannot determine imaging type of exam!" K FL,K,N,RAIMGTYI,RAIMGTYJ,RAS,RAJ Q 140 W !,"This exam meets the requirements for the following statuses:" 141 F K=0:0 S K=$O(^RA(72,"AA",RAIMGTYJ,K)) Q:K'>0 D 142 . S X="",E=+$O(^RA(72,"AA",RAIMGTYJ,K,0)) Q:E'>0 143 . I $D(^RA(72,E,0)) D 144 .. S RA(0)=$G(^RA(72,E,0)),N=$P(RA(0),U),RAS=$G(^RA(72,E,.1)) 145 .. I $L(RAS) D HELP1 I $D(X) W !?10,N S FL="" ;removed D 3, done inside HELP1 146 .. Q 147 . Q 148 W:'$D(FL) !?10,"Does not meet the requirements of any status." 149 W ! K RAS,RAJ,N,K,FL,RAIMGTYI,RAIMGTYJ 150 Q 151 HELP1 ; Called from 'HELP' above and 'STUFF^RASTREQ1' 152 ; 'RAJ' -> 0 node of the examination 153 ; 'E' -> ien of the examination status 154 ; Both 'RAJ' & 'E' set in 'HELP' & 'STUFF^RASTREQ1' 155 N RADIO,RADIOUZD,RAS5 S RADIO=$S($G(^RA(72,E,.5))]"":$G(^(.5)),1:"N") 156 S:$P($G(^RA(79.2,+RAIMGTYI,0)),"^",5)="Y" RADIOUZD="" 157 ; 158 ; Phase 1 Outside Reporting 100% outside work, skip all except Diag. Code 159 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 160 ; 161 F RAK=1:1 Q:$P(RAS,"^",RAK,99)']"" D:$P(RAS,"^",RAK)="Y" @RAK 162 I $D(X),$P(RAS,"^",3)'="Y",$D(^RA(72,"AA",RAIMGTYJ,9,E)) D 3 163 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 164 I $D(RADIOUZD) D ;if Radiopharm Used, then check req'd NucMed flds 165 . D EN1^RASTREQN(RADIO,RAJ) 166 . I $D(X),($$UP^XLFSTR($P($G(^RA(72,E,.6)),"^",11)="Y")) D EN1^RADOSTIK(RADFN,RADTI,RACNI) 167 . Q 168 Q 1 RASTREQ ;HISC/CAH,GJC AISC/MJK-Status Requirements Check Routine ;6/3/98 09:56 2 ;;5.0;Radiology/Nuclear Medicine;**1,10,23,40**;Mar 16, 1998 3 ; Called by 4 ; (1) Stat Track's [RA STATUS CHANGE]'s fld EXAM STATUS' input transform 5 ; (2) ASK+22^RASTED, if user "^" out of stat trk editing 6 ; (3) Cancel an Exam's [RA CANCEL]'s fld EXAM STATUS' input transform 7 ; (4) Enter Last Past Visit Before DHCP's [RA LAST PAST VISIT]'s "" 8 ; 9 ; Instead of using RAIMGTY, recalculate 10 ; the imaging type using the imaging type on the exam node because 11 ; status updating through report entry/edit, batch verify, and several 12 ; other options is NOT screened by sign-on imaging type, so does not 13 ; stay the same through a user's session. 14 ; 15 ; 'RAMES1' is used to display which Exam Status required fields are 16 ; not populated. This only applies to the 'Status Tracking Of Exams' 17 ; option. 18 ; 19 ; If tracking ^-out, this rtn would be called outside of edt tmpl, 20 ; and thus the DA vars would not be defined, so we need to set them here 21 ; 22 S:'$D(DA)#2 DA=RACNI S:'$D(DA(1))#2 DA(1)=RADTI S:'$D(DA(2))#2 DA(2)=RADFN 23 ; If Fileman enter/edit, we need to define RADFN, RADTI, RACNI so the 24 ; nuc med checks won't bomb 25 S:'$D(RACNI)#2 RACNI=DA S:'$D(RADTI)#2 RADTI=DA(1) S:'$D(RADFN)#2 RADFN=DA(2) 26 ; 27 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 28 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 29 S RAXX=+$G(X) 30 I '$D(^RA(72,RAXX,0))!(RAIMGTYJ']"") D Q 31 . K X W:'$D(ZTQUEUED)#2 !?3,"Error: cannot determine Imaging Type of exam. Contact IRM." 32 . K RAMES1,RAXX 33 . Q 34 N RA,RASN,RASTI,RADES,RAOKAY,RA3 35 ; RADES = order seq. desired, RAOKAY= actual order seq. okay'd 36 S X1=$G(^RA(72,RAXX,0)),RADES=$P(X1,U,3) 37 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" Q 38 S RAJ=^RADPT(DA(2),"DT",DA(1),"P",DA,0),RAOR=-1 39 S RABEFORE=$P($G(^RA(72,+$P(RAJ,U,3),0)),U,3) ; current order seq 40 ; Don't need to set RAORDIFN,RACS,RAPRIT,RAF5 41 I '$D(^RA(72,"AA",RAIMGTYJ,0,RAXX)) D LOOP^RASTREQ1 S RAIMGTYJ=RASAVTYJ 42 I $D(^RA(72,"AA",RAIMGTYJ,0,RAXX)) D CANCEL^RASTREQ1 43 S RAIMGTYJ=RASAVTYJ 44 ; Can't use X to determine if status change to next was successful 45 ; due to looping thru all status levels for this img type 46 ; chk if calculated order is at NEXT or higher level 47 ; RAAFTER is set in rastreq1; it has 2 meanings : 48 ; upon return from rastreq1, RAAFTER means highest seq order qualified 49 ; upon exit from this rtn, RAAFTER means actual seq order used 50 I RABEFORE<RAAFTER D G MSG 51 . I RADES<RAAFTER S RAOKAY=RADES 52 . E S RAOKAY=RAAFTER 53 . Q 54 I RAAFTER<RABEFORE D G MSG 55 . I RADES<RAAFTER S RAOKAY=RADES 56 . E S RAOKAY=RAAFTER 57 . Q 58 ; at this point RAAFTER=RABEFORE 59 I RADES<RAAFTER S RAOKAY=RADES 60 E S RAOKAY=RABEFORE 61 MSG I RAOKAY=RABEFORE K X W:'$D(ZTQUEUED)#2 !?5," ...exam status not changed" G KOUT2 62 S X=$O(^RA(72,"AA",RAIMGTYJ,RAOKAY,0)) 63 S:$D(RANEXT) RANEXT=^RA(72,+X,0) ;set existing RANEXT to ok'd status 64 I RAOKAY<RABEFORE W:'$D(ZTQUEUED)#2 !?5," ...exam status backed down to '",$P($G(^RA(72,+X,0)),U),"'" G KOUT2 65 I RAOKAY<RADES W:'$D(ZTQUEUED)#2 !!?5," ...though upgraded, new status level (",$P($G(^RA(72,+$O(^RA(72,"AA",RAIMGTYJ,RAOKAY,0)),0)),U),")",!?5,"is not as high as the desired level (",$P($G(^RA(72,+$O(^RA(72,"AA",RAIMGTYJ,RADES,0)),0)),U),")",! 66 KOUT1 ; check for higher qualifying status(es) 67 G:RAOKAY'<RAAFTER!(RAOKAY=9) KOUT2 S RA3=RAOKAY 68 W !!,"This case also qualifies for higher status(es) :",! 69 F S RA3=$O(^RA(72,"AA",RAIMGTYJ,RA3)) Q:RA3="" Q:RA3>RAAFTER W:'$D(ZTQUEUED)#2 ?$X+4,$P($G(^RA(72,$O(^(RA3,0)),0)),U) 70 W:'$D(ZTQUEUED)#2 !!,"Since Status Tracking can only upgrade one status at a time,",!,"please edit this exam again.",! 71 KOUT2 S RAAFTER=RAOKAY ;return as actual seq order used, not nec. highest 72 K RAIMGTYI,RAIMGTYJ,RAMES1,RAZ,RAXX,RAJ,RAS,RAK,RAE,X1,RASAVTYJ 73 Q 74 ; 75 1 ;Technologist Check 76 S RA("TECH")="" I $O(^RADPT(DA(2),"DT",DA(1),"P",DA,"TC",0))>0,$D(^VA(200,+^($O(^(0)),0),0)) S RA("TECH")=$P(^(0),"^") 77 I RA("TECH")']"" K X S RAZ="technologist" X:$D(RAMES1) RAMES1 78 K RA("TECH") Q 79 ; 80 2 ;Interpreting Physician Check 81 I '$D(^VA(200,+$P(RAJ,"^",12),0)),'$D(^VA(200,+$P(RAJ,"^",15),0)) K X S RAZ="interpreting staff or resident" X:$D(RAMES1) RAMES1 82 Q 83 ; 84 3 ;Detailed Procedure Check 85 S RAZ="detailed procedure" I '$D(^RAMIS(71,+$P(RAJ,"^",2),0)) K X X:$D(RAMES1) RAMES1 Q 86 S RAJ1=$G(^RAMIS(71,+$P(RAJ,"^",2),0)) I "DS"'[$P(RAJ1,"^",6) K X X:$D(RAMES1) RAMES1 Q 87 S RAZ="detailed procedure (no CPT code)" I $P(RAJ1,"^",9)']"" K X X:$D(RAMES1) RAMES1 Q 88 Q 89 ; 90 4 ;Film Data Check 91 I '$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"F",0)) K X S RAZ="film data" X:$D(RAMES1) RAMES1 92 Q 93 ; 94 5 ;Diagnostic Code Check 95 I '$D(^RA(78.3,+$P(RAJ,"^",13),0)) K X S RAZ="diagnostic code" X:$D(RAMES1) RAMES1 96 Q 97 ; 98 6 ;Camera/Equipment/Room Check 99 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 100 Q 101 ; 102 11 ;Report Entered and not just a stub rec for Img/PACS Check 103 I '$D(^RARPT(+$P(RAJ,"^",17),0)) G NORPT 104 ; since there's a rpt ptr, must check if the rpt is just a stub rpt 105 N RA17,RA0 ; use logic from RAREG 106 S RA17=+$P(RAJ,"^",17) 107 I $$STUB^RAEDCN1(RA17) G NORPT ; rpt is an image stub 108 Q 109 NORPT ; either no report yet, or report is stub 110 K X S RAZ="report" X:$D(RAMES1) RAMES1 111 Q 112 ; 113 12 ;Report Verified Check 114 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 115 Q 116 ; 117 16 ;Impression Entry Check 118 I $O(^RARPT(+$P(RAJ,"^",17),"I",0))'>0 K X S RAZ="impression" X:$D(RAMES1) RAMES1 119 Q 120 13 ;Procedure Modifers Check 121 I '$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"M",0)) K X S RAX="procedure modifier" X:$D(RAMES1) RAMES1 122 Q 123 14 ;CPT Modifiers Check 124 I '$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"CMOD",0)) K X S RAZ="CPT modifiers" X:$D(RAMES1) RAMES1 125 Q 126 ; 127 HELP ; Called from 'Help Text' node in DD(70.03,3,4). 128 N E,RA 129 S RAJ=$G(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) 130 S RAIMGTYI=+$P($G(^RADPT(DA(2),"DT",DA(1),0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U,1) 131 I RAIMGTYJ']"" W !,"ERROR: Cannot determine imaging type of exam!" K FL,K,N,RAIMGTYI,RAIMGTYJ,RAS,RAJ Q 132 W !,"This exam meets the requirements for the following statuses:" 133 F K=0:0 S K=$O(^RA(72,"AA",RAIMGTYJ,K)) Q:K'>0 D 134 . S X="",E=+$O(^RA(72,"AA",RAIMGTYJ,K,0)) Q:E'>0 135 . I $D(^RA(72,E,0)) D 136 .. S RA(0)=$G(^RA(72,E,0)),N=$P(RA(0),U),RAS=$G(^RA(72,E,.1)) 137 .. I $L(RAS) D HELP1 D:$D(X)&($P(RAS,"^",3)'="Y")&($D(^RA(72,"AA",RAIMGTYJ,9,E))) 3 I $D(X) W !?10,N S FL="" 138 .. Q 139 . Q 140 W:'$D(FL) !?10,"Does not meet the requirements of any status." 141 W ! K RAS,RAJ,N,K,FL,RAIMGTYI,RAIMGTYJ 142 Q 143 HELP1 ; Called from 'HELP' above and 'STUFF^RASTREQ1' 144 ; 'RAJ' -> 0 node of the examination 145 ; 'E' -> ien of the examination status 146 ; Both 'RAJ' & 'E' set in 'HELP' & 'STUFF^RASTREQ1' 147 N RADIO,RADIOUZD S RADIO=$S($G(^RA(72,E,.5))]"":$G(^(.5)),1:"N") 148 S:$P($G(^RA(79.2,+RAIMGTYI,0)),"^",5)="Y" RADIOUZD="" 149 F RAK=1:1 Q:$P(RAS,"^",RAK,99)']"" D:$P(RAS,"^",RAK)="Y" @RAK 150 I $D(X),$P(RAS,"^",3)'="Y",$D(^RA(72,"AA",RAIMGTYJ,9,E)) D 3 151 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 152 I $D(RADIOUZD),($D(X)) D 153 . D EN1^RASTREQN(RADIO,RAJ) 154 . I $D(X),($$UP^XLFSTR($P($G(^RA(72,E,.6)),"^",11)="Y")) D EN1^RADOSTIK(RADFN,RADTI,RACNI) 155 . Q 156 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RASTREQN.m
r613 r623 1 RASTREQN ;HIRMFO/GJC-Status Requirement check for Radiopharms ;11/18/97 15:13 2 ;;5.0;Radiology/Nuclear Medicine;**40,65**;Mar 16, 1998;Build 8 3 ; 4 ;supported IA #10104 reference to UP^XLFSTR and REPEAT^XLFSTR 5 ;Supported IA #2056 refernce to GETS^DIQ 6 ; 7 ; *** 'RASTREQN' is called from routine: 'RASTREQ' *** 8 EN1(RADIO,RAJ) ; Check if all the required radiopharmaceutical data has 9 ; been entered for this particular Examination Status. 10 ; *=*=*= Kills 'X' if the status cannot be updated =*=*=* 11 ; Input: 'RADIO' -> .5 node of the examination status (Radiopharms req) 12 ; 'RAJ' -> 0 node of the examination 13 ; 14 ; NOTE: RAMES1 is set in RASTREQ^RASTREQ subroutine. Only the 'Status 15 ; Tracking Of Exams' option displays which required fields are not 16 ; populated for the next available Exam Status. 17 ; 18 ;---------------------------------------------------------------------- 19 ; Determine if 'Radiopharmaceutical' is required 20 ; RAPRI defined in [RA STATUS CHANGE] & [RA EXAM EDIT] 21 ; 22 Q:"N"[$P(RADIO,"^") ; Rpharms & Dosages NOT Req'd (either 'no' or null) 23 N RAPROC S RAPROC(0)=$G(^RAMIS(71,+$P(RAJ,"^",2),0)) 24 Q:$P(RAPROC(0),"^",2)=1 ; Never ask Rpharms & Dosages 25 ;---------------------------------------------------------------------- 26 N RA702 S RA702=+$P(RAJ,"^",28) ; ien in NUC MED EXAM DATA (70.2) file 27 N RA7021,RACNT,RAI,RAMES2,RAREQ,RAZ S RAI=0 28 I 'RA702,($P(RADIO,"^")="Y") D Q 29 . K X S RAZ="Radiopharmaceutical" X:$D(RAMES1) RAMES1 30 . Q 31 F S RAI=$O(^RADPTN(RA702,"NUC",RAI)) Q:RAI'>0 D 32 . S RA7021=$G(^RADPTN(RA702,"NUC",RAI,0)),RACNT=0 33 . S RAMES2="W:$G(K)=$P($G(^RA(72,+$G(RANXT72),0)),U,3)&('$D(ZTQUEUED)#2) !,""Radiopharmaceutical: "",$$EN1^RAPSAPI(+$P(RA7021,""^""),.01)" 34 . I $P(RADIO,"^")="Y",($P(RA7021,"^")=""!($P(RA7021,"^",7)="")) D 35 .. K X S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 36 .. I $P(RA7021,"^")="" S RAZ="Radiopharmaceutical" X:$D(RAMES1) RAMES1 37 .. I $P(RA7021,"^",7)="" S RAZ="Dosage" X:$D(RAMES1) RAMES1 38 .. Q 39 . I $P(RADIO,"^",3)="Y",($P(RA7021,"^",4)="") D 40 .. S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 41 .. S RAZ="Activity Drawn" X:$D(RAMES1) RAMES1 K X 42 .. Q 43 . I $P(RADIO,"^",4)="Y",($P(RA7021,"^",5)=""!($P(RA7021,"^",6)="")) D 44 .. K X S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 45 .. I $P(RA7021,"^",5)="" S RAZ="Date/Time Drawn" X:$D(RAMES1) RAMES1 46 .. I $P(RA7021,"^",6)="" S RAZ="Person Who Measured Dose" X:$D(RAMES1) RAMES1 47 .. Q 48 . I $P(RADIO,"^",5)="Y",($P(RA7021,"^",8)=""!($P(RA7021,"^",9)="")) D 49 .. K X S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 50 .. I $P(RA7021,"^",8)="" S RAZ="Date/Time Dose Administered" X:$D(RAMES1) RAMES1 51 .. I $P(RA7021,"^",9)="" S RAZ="Person Who Administered Dose" X:$D(RAMES1) RAMES1 52 .. Q 53 . I $P(RADIO,"^",7)="Y",($P(RA7021,"^",11)=""!($P(RA7021,"^",12)="")) D 54 .. K X S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 55 .. I $P(RA7021,"^",11)="" S RAZ="Route Of Administration" X:$D(RAMES1) RAMES1 56 .. I $P(RA7021,"^",12)="" S RAZ="Site Of Administration" X:$D(RAMES1) RAMES1 57 .. Q 58 . I $P(RADIO,"^",8)="Y",($P(RA7021,"^",13)="") D 59 .. S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 60 .. S RAZ="Lot No." X:$D(RAMES1) RAMES1 K X 61 .. Q 62 . I $P(RADIO,"^",9)="Y",($P(RA7021,"^",14)=""!($P(RA7021,"^",15)="")) D 63 .. K X S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 64 .. I $P(RA7021,"^",14)="" S RAZ="Volume" X:$D(RAMES1) RAMES1 65 .. I $P(RA7021,"^",15)="" S RAZ="Form" X:$D(RAMES1) RAMES1 66 .. Q 67 . Q 68 Q 69 NORADIO(RAPRI,RANXT72) ; This function will determine if Rpharm 70 ; fields from the 'Nuc Med Exam Data' file [ ^RADPTN( ] will be asked. 71 ; Input : 'RANXT72' -> .6 node of the 'Next' Exam Status 72 ; : 'RAPRI' -> IEN of the procedure for this exam 73 ; Output: '1' bypass Rpharm questions, else (0) ask 74 Q:$TR($$UP^XLFSTR(RANXT72(.6)),"^","")="" 1 ; null or '^'s 75 ; ------------------- Variable Definitions ---------------------------- 76 ; 'RAPROC(2)': ask Rpharm & Dosages parameter for this procedure 77 ;---------------------------------------------------------------------- 78 N RAPROC S RAPROC(2)=$P($G(^RAMIS(71,RAPRI,0)),"^",2) 79 ;---------------------------------------------------------------------- 80 ; * following conditions apply for descendants exams & single exams * 81 ; * Number 1: Suppress Rpharm = 1 even if 'Rpharms/Dose' Req'd * 82 ; * Number 2: Suppress Rpharm = null or 0, 'Rpharm/Dose' not req'd * 83 Q:RAPROC(2)=1 1 84 Q:"N"[$P(RANXT72(.6),"^") 1 85 ;---------------------------------------------------------------------- 86 Q 0 ; ask Rpharm & Dosage fields 87 DISDEF(RADA) ; Display Radiopharmaceutical default data 88 ; called from input templs: [RASTATUS CHANGE] and [RA EXAM EDIT] 89 ; Input: RADA -> ien of the Nuc Med Exam Data record 90 Q:'$O(^RADPTN(RADA,"NUC",0)) ; Radiopharms missing, no data 91 N RADARY,RADEUC,RAFLDS,RAIENS,RAOPUT,X,Y W ! 92 S RAIENS="" D GETS^DIQ(70.2,RADA_",","**","NE","RADARY") 93 F S RAIENS=$O(RADARY(70.21,RAIENS)) Q:RAIENS="" D 94 . Q:$P(RAIENS,",",2)="" ; top-level of the file 95 . S (RADEUC,RAFLDS)=0 96 . F S RAFLDS=$O(RADARY(70.21,RAIENS,RAFLDS)) Q:RAFLDS'>0 D Q:$D(DIRUT) 97 .. I RAFLDS=.01 D 98 ... S RADEUC=0 W !,$G(RADARY(70.21,RAIENS,RAFLDS,"E")) 99 ... W !,$$REPEAT^XLFSTR("-",$L($G(RADARY(70.21,RAIENS,RAFLDS,"E")))),! 100 ... Q 101 .. E D 102 ... S RADEUC=RADEUC+1 103 ... S RAOPUT=$$TRAN(RAFLDS)_$G(RADARY(70.21,RAIENS,RAFLDS,"E"))_$S(RAFLDS=2:" mCi",RAFLDS=4:" mCi",RAFLDS=7:" mCi",1:"") 104 ... W:RADEUC=1 $E(RAOPUT,1,38) W:RADEUC=2 ?39,$E(RAOPUT,1,39) 105 ... Q 106 .. W:RADEUC'=2&($O(RADARY(70.21,RAIENS,RAFLDS))="") ! 107 .. W:RADEUC=2 ! S:RADEUC=2 RADEUC=0 108 .. Q 109 . Q 110 Q 111 TRAN(X) ; Translate field name to a shorter length. 112 Q:X=2 "Dose (MD Override): " Q:X=3 "Prescriber: " 113 Q:X=4 "Activity Drawn: " Q:X=5 "Drawn: " Q:X=6 "Measured By: " 114 Q:X=7 "Dose Adm'd: " Q:X=8 "Date Adm'd: " Q:X=9 "Adm'd By: " 115 Q:X=10 "Witness: " Q:X=11 "Route: " Q:X=12 "Site: " 116 Q:X=12.5 "Site Text: " Q:X=13 "Lot #: " Q:X=14 "Volume: " 117 Q:X=15 "Form: " 118 VALDOS(RALOW,RAHI,X,RABACKTO,RAGOTO,RALASTAG,RAWARN) ;validate drawn/dose 119 ; Called from [RA STATUS CHANGE] and [RA EXAM EDIT] input templates. 120 ; Validate the value for either : 121 ; ACTIVITY DRAWN (fld 4, DD: 70.21) 122 ; DOSE (fld 7, DD: 70.21) 123 ; If there are limits on the Dosage, validate. 124 ; If validate fails, ask user if the invalid value is to be accepted. 125 ; If yes, proceed. 126 ; If no, re-ask DOSE. 127 ; Input: RAHI = Upper limit on dosage 128 ; RALOW = Lower limit on dosage 129 ; X = Value user input 130 ; RABACKTO = Previous Line tag to loop back to if need re-ask 131 ; RAGOTO = Default linetag to proceed to if within range 132 ; RALASTAG = Last linetag in this edit template if early out 133 ; RAWARN = display/not the warning msg -- 0=no, 1=yes 134 ; 135 ; Output: RAY = linetag to proceed to after exiting this check 136 ; 137 N RAY,RAYN S RAY="" I X']"" S RAY=RAGOTO G KVAL 138 S:RALOW=""&(RAHI="") RAY=RAGOTO 139 S:RALOW]""&(RAHI="")&(X'<RALOW) RAY=RAGOTO 140 S:RALOW=""&(RAHI]"")&(X'>RAHI) RAY=RAGOTO 141 S:RALOW]""&(RAHI]"")&(X'<RALOW)&(X'>RAHI) RAY=RAGOTO 142 I RAY="" D 143 . F D Q:RAY]"" 144 .. I $O(^RA(79,RAMDIV,"RWARN",0)) D:RAWARN 145 ... N I S I=0 146 ... F S I=$O(^RA(79,RAMDIV,"RWARN",I)) Q:I'>0 W !,$G(^(I,0)) 147 ... Q 148 .. E D:RAWARN 149 ... W !,"This dose requires a written, dated and signed directive by" 150 ... W !,"a physician." 151 ... Q 152 .. W !!?3,"Are you sure (Y/N)?: N//" R RAYN:DTIME 153 .. I '$T!(RAYN["^") S RAY=RALASTAG Q 154 .. S RAYN=$S(RAYN']"":"N",1:$$UP^XLFSTR($E(RAYN))) 155 .. S RAY=$S(RAYN="N":RABACKTO,RAYN="Y":RAGOTO,1:"") 156 .. I RAY="" W !!?3,"Enter 'Yes' if this value is acceptable, or 'No' if this field is to be",!?3,"re-edited.",$C(7) 157 .. Q 158 . Q 159 KVAL K RABACKTO,RAGOTO,RALASTAG,RAWARN 160 Q RAY 1 RASTREQN ;HIRMFO/GJC-Status Requirement check for Radiopharms ;11/18/97 15:13 2 ;;5.0;Radiology/Nuclear Medicine;**40**;Mar 16, 1998 3 ; 4 ; *** 'RASTREQN' is called from routine: 'RASTREQ' *** 5 EN1(RADIO,RAJ) ; Check if all the required radiopharmaceutical data has 6 ; been entered for this particular Examination Status. 7 ; *=*=*= Kills 'X' if the status cannot be updated =*=*=* 8 ; Input: 'RADIO' -> .5 node of the examination status (Radiopharms req) 9 ; 'RAJ' -> 0 node of the examination 10 ; 11 ; NOTE: RAMES1 is set in RASTREQ^RASTREQ subroutine. Only the 'Status 12 ; Tracking Of Exams' option displays which required fields are not 13 ; populated for the next available Exam Status. 14 ; 15 ;---------------------------------------------------------------------- 16 ; Determine if 'Radiopharmaceutical' is required 17 ; RAPRI defined in [RA STATUS CHANGE] & [RA EXAM EDIT] 18 ; 19 Q:"N"[$P(RADIO,"^") ; Rpharms & Dosages NOT Req'd (either 'no' or null) 20 N RAPROC S RAPROC(0)=$G(^RAMIS(71,+$P(RAJ,"^",2),0)) 21 Q:$P(RAPROC(0),"^",2)=1 ; Never ask Rpharms & Dosages 22 ;---------------------------------------------------------------------- 23 N RA702 S RA702=+$P(RAJ,"^",28) ; ien in NUC MED EXAM DATA (70.2) file 24 N RA7021,RACNT,RAI,RAMES2,RAREQ,RAZ S RAI=0 W:'$D(ZTQUEUED)#2 ! 25 I 'RA702,($P(RADIO,"^")="Y") D Q 26 . K X S RAZ="Radiopharmaceutical" X:$D(RAMES1) RAMES1 27 . Q 28 F S RAI=$O(^RADPTN(RA702,"NUC",RAI)) Q:RAI'>0 D 29 . S RA7021=$G(^RADPTN(RA702,"NUC",RAI,0)),RACNT=0 30 . S RAMES2="W:$G(K)=$P($G(^RA(72,+$G(RANXT72),0)),U,3)&('$D(ZTQUEUED)#2) !,""Radiopharmaceutical: "",$$GET1^DIQ(50,+$P(RA7021,""^"")_"","",.01)" 31 . I $P(RADIO,"^")="Y",($P(RA7021,"^")=""!($P(RA7021,"^",7)="")) D 32 .. K X S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 33 .. I $P(RA7021,"^")="" S RAZ="Radiopharmaceutical" X:$D(RAMES1) RAMES1 34 .. I $P(RA7021,"^",7)="" S RAZ="Dosage" X:$D(RAMES1) RAMES1 35 .. Q 36 . I $P(RADIO,"^",3)="Y",($P(RA7021,"^",4)="") D 37 .. S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 38 .. S RAZ="Activity Drawn" X:$D(RAMES1) RAMES1 K X 39 .. Q 40 . I $P(RADIO,"^",4)="Y",($P(RA7021,"^",5)=""!($P(RA7021,"^",6)="")) D 41 .. K X S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 42 .. I $P(RA7021,"^",5)="" S RAZ="Date/Time Drawn" X:$D(RAMES1) RAMES1 43 .. I $P(RA7021,"^",6)="" S RAZ="Person Who Measured Dose" X:$D(RAMES1) RAMES1 44 .. Q 45 . I $P(RADIO,"^",5)="Y",($P(RA7021,"^",8)=""!($P(RA7021,"^",9)="")) D 46 .. K X S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 47 .. I $P(RA7021,"^",8)="" S RAZ="Date/Time Dose Administered" X:$D(RAMES1) RAMES1 48 .. I $P(RA7021,"^",9)="" S RAZ="Person Who Administered Dose" X:$D(RAMES1) RAMES1 49 .. Q 50 . I $P(RADIO,"^",7)="Y",($P(RA7021,"^",11)=""!($P(RA7021,"^",12)="")) D 51 .. K X S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 52 .. I $P(RA7021,"^",11)="" S RAZ="Route Of Administration" X:$D(RAMES1) RAMES1 53 .. I $P(RA7021,"^",12)="" S RAZ="Site Of Administration" X:$D(RAMES1) RAMES1 54 .. Q 55 . I $P(RADIO,"^",8)="Y",($P(RA7021,"^",13)="") D 56 .. S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 57 .. S RAZ="Lot No." X:$D(RAMES1) RAMES1 K X 58 .. Q 59 . I $P(RADIO,"^",9)="Y",($P(RA7021,"^",14)=""!($P(RA7021,"^",15)="")) D 60 .. K X S RACNT=RACNT+1 X:$D(RAMES1)&(RACNT=1) RAMES2 61 .. I $P(RA7021,"^",14)="" S RAZ="Volume" X:$D(RAMES1) RAMES1 62 .. I $P(RA7021,"^",15)="" S RAZ="Form" X:$D(RAMES1) RAMES1 63 .. Q 64 . W:'$D(ZTQUEUED)#2 ! ; spacing 65 . Q 66 Q 67 NORADIO(RAPRI,RANXT72) ; This function will determine if Rpharm 68 ; fields from the 'Nuc Med Exam Data' file [ ^RADPTN( ] will be asked. 69 ; Input : 'RANXT72' -> .6 node of the 'Next' Exam Status 70 ; : 'RAPRI' -> IEN of the procedure for this exam 71 ; Output: '1' bypass Rpharm questions, else (0) ask 72 Q:$TR($$UP^XLFSTR(RANXT72(.6)),"^","")="" 1 ; null or '^'s 73 ; ------------------- Variable Definitions ---------------------------- 74 ; 'RAPROC(2)': ask Rpharm & Dosages parameter for this procedure 75 ;---------------------------------------------------------------------- 76 N RAPROC S RAPROC(2)=$P($G(^RAMIS(71,RAPRI,0)),"^",2) 77 ;---------------------------------------------------------------------- 78 ; * following conditions apply for descendants exams & single exams * 79 ; * Number 1: Suppress Rpharm = 1 even if 'Rpharms/Dose' Req'd * 80 ; * Number 2: Suppress Rpharm = null or 0, 'Rpharm/Dose' not req'd * 81 Q:RAPROC(2)=1 1 82 Q:"N"[$P(RANXT72(.6),"^") 1 83 ;---------------------------------------------------------------------- 84 Q 0 ; ask Rpharm & Dosage fields 85 DISDEF(RADA) ; Display Radiopharmaceutical default data 86 ; Input: RADA -> ien of the Nuc Med Exam Data record 87 Q:'$O(^RADPTN(RADA,"NUC",0)) ; Radiopharms missing, no data 88 N RADARY,RADEUC,RAFLDS,RAIENS,RAOPUT,X,Y W ! 89 S RAIENS="" D GETS^DIQ(70.2,RADA_",","**","NE","RADARY") 90 F S RAIENS=$O(RADARY(70.21,RAIENS)) Q:RAIENS="" D 91 . Q:$P(RAIENS,",",2)="" ; top-level of the file 92 . S (RADEUC,RAFLDS)=0 93 . F S RAFLDS=$O(RADARY(70.21,RAIENS,RAFLDS)) Q:RAFLDS'>0 D Q:$D(DIRUT) 94 .. I RAFLDS=.01 D 95 ... S RADEUC=0 W !,$G(RADARY(70.21,RAIENS,RAFLDS,"E")) 96 ... W !,$$REPEAT^XLFSTR("-",$L($G(RADARY(70.21,RAIENS,RAFLDS,"E")))),! 97 ... Q 98 .. E D 99 ... S RADEUC=RADEUC+1 100 ... S RAOPUT=$$TRAN(RAFLDS)_$G(RADARY(70.21,RAIENS,RAFLDS,"E"))_$S(RAFLDS=2:" mCi",RAFLDS=4:" mCi",RAFLDS=7:" mCi",1:"") 101 ... W:RADEUC=1 $E(RAOPUT,1,38) W:RADEUC=2 ?39,$E(RAOPUT,1,39) 102 ... Q 103 .. W:RADEUC'=2&($O(RADARY(70.21,RAIENS,RAFLDS))="") ! 104 .. W:RADEUC=2 ! S:RADEUC=2 RADEUC=0 105 .. Q 106 . Q 107 Q 108 TRAN(X) ; Translate field name to a shorter length. 109 Q:X=2 "Dose (MD Override): " Q:X=3 "Prescriber: " 110 Q:X=4 "Activity Drawn: " Q:X=5 "Drawn: " Q:X=6 "Measured By: " 111 Q:X=7 "Dose Adm'd: " Q:X=8 "Date Adm'd: " Q:X=9 "Adm'd By: " 112 Q:X=10 "Witness: " Q:X=11 "Route: " Q:X=12 "Site: " 113 Q:X=12.5 "Site Text: " Q:X=13 "Lot #: " Q:X=14 "Volume: " 114 Q:X=15 "Form: " 115 VALDOS(RALOW,RAHI,X,RABACKTO,RAGOTO,RALASTAG,RAWARN) ;validate drawn/dose 116 ; Called from [RA STATUS CHANGE] and [RA EXAM EDIT] input templates. 117 ; Validate the value for either : 118 ; ACTIVITY DRAWN (fld 4, DD: 70.21) 119 ; DOSE (fld 7, DD: 70.21) 120 ; If there are limits on the Dosage, validate. 121 ; If validate fails, ask user if the invalid value is to be accepted. 122 ; If yes, proceed. 123 ; If no, re-ask DOSE. 124 ; Input: RAHI = Upper limit on dosage 125 ; RALOW = Lower limit on dosage 126 ; X = Value user input 127 ; RABACKTO = Previous Line tag to loop back to if need re-ask 128 ; RAGOTO = Default linetag to proceed to if within range 129 ; RALASTAG = Last linetag in this edit template if early out 130 ; RAWARN = display/not the warning msg -- 0=no, 1=yes 131 ; 132 ; Output: RAY = linetag to proceed to after exiting this check 133 ; 134 N RAY,RAYN S RAY="" I X']"" S RAY=RAGOTO G KVAL 135 S:RALOW=""&(RAHI="") RAY=RAGOTO 136 S:RALOW]""&(RAHI="")&(X'<RALOW) RAY=RAGOTO 137 S:RALOW=""&(RAHI]"")&(X'>RAHI) RAY=RAGOTO 138 S:RALOW]""&(RAHI]"")&(X'<RALOW)&(X'>RAHI) RAY=RAGOTO 139 I RAY="" D 140 . F D Q:RAY]"" 141 .. I $O(^RA(79,RAMDIV,"RWARN",0)) D:RAWARN 142 ... N I S I=0 143 ... F S I=$O(^RA(79,RAMDIV,"RWARN",I)) Q:I'>0 W !,$G(^(I,0)) 144 ... Q 145 .. E D:RAWARN 146 ... W !,"This dose requires a written, dated and signed directive by" 147 ... W !,"a physician." 148 ... Q 149 .. W !!?3,"Are you sure (Y/N)?: N//" R RAYN:DTIME 150 .. I '$T!(RAYN["^") S RAY=RALASTAG Q 151 .. S RAYN=$S(RAYN']"":"N",1:$$UP^XLFSTR($E(RAYN))) 152 .. S RAY=$S(RAYN="N":RABACKTO,RAYN="Y":RAGOTO,1:"") 153 .. I RAY="" W !!?3,"Enter 'Yes' if this value is acceptable, or 'No' if this field is to be",!?3,"re-edited.",$C(7) 154 .. Q 155 . Q 156 KVAL K RABACKTO,RAGOTO,RALASTAG,RAWARN 157 Q RAY -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL1.m
r613 r623 1 RAUTL1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;10/22/97 13:54 2 ;;5.0;Radiology/Nuclear Medicine;**5,9,18,71,82,81,84**;Mar 16, 1998;Build 13 3 ;last modification by SS for P18 June 19,00 4 ;02/10/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R 5 ; 6 ;Integration Agreements 7 ;---------------------- 8 ;DIC(10006); DIE(10018); FILE^DIE(2053); UPDATE^DIE(2053); EN^ORB3(1362); NOTE^ORX3(868) 9 ; 10 I "IOSCR"'[X!(X="") S X="Unknown" Q 11 G @($E(X)) 12 ;Set X=Inpatient Location 13 I S X=$S($D(^DIC(42,+$P(^RADPT(D0,"DT",D1,"P",D2,0),"^",6),0)):$P(^(0),"^"),1:"Unknown") 14 Q 15 ; 16 ;Set X=Outpatient Location 17 O S X=$S($D(^SC(+$P(^RADPT(D0,"DT",D1,"P",D2,0),"^",8),0)):$P(^(0),"^"),1:"Unknown") 18 Q 19 ; 20 ;Set X=Contract/Sharing Agreement patient location 21 S ; 22 C S X=$S($D(^DIC(34,+$P(^RADPT(D0,"DT",D1,"P",D2,0),"^",9),0)):$P(^(0),"^"),1:"Unknown") 23 Q 24 ; 25 ;Set X=Research patient location 26 R S X=$S($D(^RADPT(D0,"DT",D1,"P",D2,"R")):$P(^("R"),"^"),1:"Unknown") Q 27 ; 28 ;Set X=time of day in external format (ex: 2:28 PM) 29 NOW S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) D TIME 30 Q 31 ;Input X=FM date/time, Output X=time (external format) 32 TIME S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M" S:$P(X,":")=0 X=12_":"_$P(X,":",2) 33 Q 34 ; 35 ELAPSED ;Pass parameters X (from date) and X1 (to date) 36 ;Variable Y is returned as either an elapsed time in the form DD:HH:MM where DD=days, HH=hours, MM=minutes or as the string 'Neg. Time' indicating a negative elapsed time 37 ;Variable Y1 is returned as the # of minutes of elapsed time 38 I '$D(RAMTIME) S DIC="^DD(""FUNC"",",DIC(0)="FX",RAX=X,X="MINUTES" D ^DIC K DIC S X=RAX S:$D(^DD("FUNC",+Y,1)) RAMTIME=^(1) I '$D(RAMTIME) W $C(7),!!,"Can't continue --- No 'MINUTES' function found in File Manager" K Y,Y1 G Q 39 X RAMTIME S Y1=X I X<0 S Y="Neg. Time" G Q 40 MINUTS S X(1)=X\1440,X=X-(1440*X(1)),X(2)=X\60,X(3)=X-(60*X(2)),Y=$E(100+X(1),2,3)_":"_$E(100+X(2),2,3)_":"_$E(100+X(3),2,3) 41 Q K RAX,X Q 42 ; 43 UPDATE ;Entry point for Update Rad/Nuc Med Exam Status option 44 I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) 45 I $G(RAIMGTY)="" D SETVARS^RAPSET1(1) 46 I $G(RAIMGTY)="" K XQUIT Q ; didn't sign-on to an imaging location 47 D ^RACNLU G UPQ:"^"[X 48 I $D(^RA(72,"AA",RAIMGTY,9,+RAST)),'$D(^XUSEC("RA MGR",DUZ)) W !!?3,$C(7),"You do not have the appropriate access privileges to act on completed exams." G UPDATE 49 I $D(^RA(72,"AA",RAIMGTY,0,+RAST)) W !!?3,$C(7),"Exam has been 'cancelled' therefore the status cannot be changed." G UPDATE 50 ;D UP1 I RAOR>0 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"",",DR="100///""NOW""",DR(2,70.07)="2///U;3////"_$S($G(RADUZ):RADUZ,1:DUZ) D ^DIE 51 D UP1 I RAOR>0 D 52 .L +^RADPT(RADFN,"DT",RADTI,"P",RACNI):$G(DILOCKTM,3) 53 .N RAIEN 54 .S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_"," 55 .S RAFDA(70.07,RAIENS,.01)="NOW" 56 .K RAERR D UPDATE^DIE("E","RAFDA","RAIEN","RAERR") 57 .K RAFDA,RAIENS 58 .I $D(RAERR) S RAERR="Error in update of 70.07, .01 "_$G(RAERR("DIERR",1,"TEXT",1)) K RAERR("DIERR") L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) K RAIEN Q 59 .S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_"," 60 .S RAFDA(70.07,RAIENS,2)="U" 61 .S RAFDA(70.07,RAIENS,3)=$S($G(RADUZ):RADUZ,1:DUZ) 62 .D FILE^DIE(,"RAFDA","RAERR") 63 .L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) 64 .I $D(RAERR) S RAERR="Error in update of 70.07, 2,3 "_$G(RAERR("DIERR",1,"TEXT",1)) K RAERR("DIERR") 65 UPQ K RAFDA,RAIENS 66 K %,D,DA,DE,DIC,DIE,DQ,DR,I,J,POP,RACS,RAEND,RAF5,RAFL,RAFST,RAI,RAIX,RAJ1,RAORDIFN,RAPRIT,RAHEAD,RASN,RAOR,RASTI,RASSN,RADATE,RAST,RACN,RACNI,RADFN,RADTE,RADTI,RANME,RAPRC,RARPT,X,Y,Z,^TMP($J,"RAEX"),C,DIPGM Q 67 ; 68 ;Exam status updating and accompanying updates to status log, oe/rr 69 UP1 N RA8,RAEXEDT S RA8=0 ;use this to flag when one alert has been sent 70 ;Line change for RA*5*82 71 S RAEXEDT=$$CMPAFTR^RAO7XX(1) ;P18 if procedure changed in RAEDCN or RAEDPT sends XX message to CPRS if needed 72 ; RA EDITCN and RA EDITPT should process this case only 73 I $D(RAOPT("EDITCN"))!($D(RAOPT("EDITPT"))) D UP2,UPK Q 74 ; see if this case belongs to a printset 75 N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR 76 D EN2^RAUTL20(.RAMEMARR) ;043099 always recalculate RAPRTSET 77 ; if not print set, then just process this case only 78 I 'RAPRTSET D UP2,UPK Q 79 ;case belongs to print set, so process all members of same print set 80 N RACNISAV,RA7 81 S RACNISAV=RACNI,RA7=0 82 F S RA7=$O(RAMEMARR(RA7)) Q:RA7="" S RACNI=RA7 D UP2 83 S RACNI=RACNISAV 84 G UPK 85 UP2 ;Remedy Call 124379 Patch *71 BAY/KAM Added next line 86 ;Patch RA*5*82 next line commented out 87 ;D:$G(RAHLTCPB)'=1 EXM^RAHLRPC 88 ; 89 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," 90 N RAAFTER,RABEFORE 91 D STUFF^RASTREQ1 I RAOR<0,$D(RASN) W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?5,"...exam status remains '",RASN,"'." K DIE,RACS,RAPRIT D Q 92 .D:$G(RAEXEDT) EXM^RAHLRPC ; DO statement added by RA*5*82 93 W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?3,"...will now designate exam status as '",RASN,"'... for case no. ",$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U) 94 ; S DR="3////"_RASTI_$S($P(RAMDV,"^",10):";75///^S X=$$MIDNGHT^RAUTL5($$NOW^XLFDT())",1:"") 95 ; user duz could be in RADUZ, if session is from the Voice recognition 96 ;S DR(2,70.05)=$S($P(RAMDV,"^",11)&('$D(ZTQUEUED)):".01;",1:"")_"2////"_RASTI_";3////"_$S($G(RADUZ):RADUZ,1:DUZ) 97 ;D ^DIE 98 L +^RADPT(RADFN,"DT",RADTI,"P",RACNI):$G(DILOCKTM,3) 99 N RAIEN 100 S RAIENS=RACNI_","_RADTI_","_RADFN_"," 101 S RAFDA(70.03,RAIENS,3)=RASTI 102 K RAERR D FILE^DIE(,"RAFDA","RAERR") 103 I $D(RAERR) S RAERR="Error in update of 70.03 "_$G(RAERR("DIERR",1,"TEXT",1)) K RAERR("DIERR") L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) G UP2K ;L - P18 104 I $P(RAMDV,"^",10) D 105 .N RAERR2 106 .S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_"," 107 .S RAFDA(70.05,RAIENS,.01)=$$MIDNGHT^RAUTL5($$NOW^XLFDT()) 108 .D UPDATE^DIE(,"RAFDA","RAIEN","RAERR") 109 .K RAFDA,RAIENS 110 .I $D(RAERR) S RAERR="Error in update of 70.05, .01 "_$G(RAERR("DIERR",1,"TEXT",1)) K RAERR("DIERR") 111 .Q:'$D(RAIEN(1)) 112 .I $P(RAMDV,"^",11),('$D(ZTQUEUED)) D 113 ..S DIE=DIE_RACNI_",""T"",",DA=RAIEN(1) 114 ..S DR=".01" 115 ..D ^DIE 116 .S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_"," 117 .S RAFDA(70.05,RAIENS,2)=RASTI 118 .S RAFDA(70.05,RAIENS,3)=$S($G(RADUZ):RADUZ,1:DUZ) 119 .K RAERR2 D FILE^DIE(,"RAFDA","RAERR2") 120 .I $D(RAERR2) S RAERR2="Error in update of 70.05 2,3 "_$G(RAERR2("DIERR",1,"TEXT",1)),RAERR=$S($D(RAERR):RAERR_";"_RAERR2,1:RAERR2) 121 ;Patch RA*5*82 added next line send EXM message after status update, not before the update 122 D:'$D(RAERR) EXM^RAHLRPC 123 L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) 124 ; 125 UP2K K DE,DQ,DIE,DR,RAFDA,RAIENS K:$D(RAERR) RACS,RAPRIT Q:$D(RAERR) W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?10,"...exam status ",$S($G(RABEFORE)>$G(RAAFTER):"backed down",1:"successfully updated"),"." D ^RAORDC 126 I RA8=0,$D(^RA(72,RASTI,"ALERT")),$P(^("ALERT"),"^")="y" D:$$ORVR^RAORDU()=2.5 OERR D:$$ORVR^RAORDU()'<3 OERR3 S RA8=1 127 I $D(^RA(72,RASTI,0)),$P(^(0),"^",3)>1,RACS'="Y",$S('$D(RAF5):1,$P(^DIC(42,+RAF5,0),U,3)="D":1,1:0) D EN^RAUTL0 128 K RACS,RAORDIFN,RAPRIT,RAF5 129 Q 130 UPK K ORIFN,ORVP,ORNOTE,ORBPMSG,RACS,RAORDIFN,RAPRIT,RAF5 131 Q 132 OERR ;Send Alert to OERR after pt examined 133 S ORVP=RADFN_";DPT(",ORBPMSG="Rad Pt Examined - "_$S($D(^RAMIS(71,RAPRIT,0)):$E($P(^(0),"^"),1,24),1:"Unknown") S:$D(^RAO(75.1,+RAORDIFN,0)) ORIFN=+$P(^(0),"^",7) S ORNOTE(21)=$S($D(ORIFN):1,1:"") D NOTE^ORX3 134 Q 135 OERR3 ; Send RADIOLOGY PATIENT EXAMINED notification via oe/rr v3 136 ; Called from UP1 137 ; 138 ; RADFN,RADTI,RACNI,RAPRIT must be defined 139 Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))!('$D(RAPRIT)) 140 ; 141 N RAIENS,RAMSG,RAOIFN,RAOSTS,RAONODE,RADPTNDE,RAREQPHY 142 S RADPTNDE=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 143 S RAOIFN=$P(RADPTNDE,U,11) Q:'RAOIFN ;file 75.1 ien 144 S RAONODE=$G(^RAO(75.1,+RAOIFN,0)) 145 S RAOSTS=$P(RAONODE,U,5) Q:RAOSTS'=6 ;active exams only 146 S RAOIFN=$P(RAONODE,U,7) ;file 100 ien 147 S RAREQPHY=+$P(RADPTNDE,U,14) ;ordering provider 148 S RAREQPHY(RAREQPHY)="" 149 S RAMSG="Imaging Pt Examined - "_$S($D(^RAMIS(71,RAPRIT,0)):$E($P(^(0),U),1,24),1:"Unknown"),RAMSG=$E(RAMSG,1,51) 150 S RAIENS=RADTI_"~"_RACNI 151 ; 152 ; oe parameters: 153 ; ORN: notification id (#100.9 ien) 154 ; | ORBDFN: patient id (#2 ien) 155 ; | | ORNUM: order number (#100 ien) 156 ; | | | ORBADUZ: recipient array 157 ; | | | | ORBPMSG: message text 158 ; | | | | | ORBPDATA exam dt~case iens 159 ; | | | | | | 160 D EN^ORB3(21,RADFN,RAOIFN,.RAREQPHY,RAMSG,RAIENS) 161 Q 162 ; 163 ;Called by many report programs. Sets RACRT() array containing all 164 ;exam statuses that are to be included on the report. RACRT is set 165 ;to the piece of the Exam Status File #72 record that corresponds 166 ;to the report being generated. 167 CRIT F I=0:0 S I=$O(^RA(72,I)) Q:'I I $D(^(I,.3)),$P(^(.3),"^",RACRT)="y" S RACRT(I)="" 168 Q 1 RAUTL1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;10/22/97 13:54 2 ;;5.0;Radiology/Nuclear Medicine;**5,9,18,71,82**;Mar 16, 1998;Build 8 3 ;last modification by SS for P18 June 19,00 4 ;02/10/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R 5 I "IOSCR"'[X!(X="") S X="Unknown" Q 6 G @($E(X)) 7 ;Set X=Inpatient Location 8 I S X=$S($D(^DIC(42,+$P(^RADPT(D0,"DT",D1,"P",D2,0),"^",6),0)):$P(^(0),"^"),1:"Unknown") 9 Q 10 ; 11 ;Set X=Outpatient Location 12 O S X=$S($D(^SC(+$P(^RADPT(D0,"DT",D1,"P",D2,0),"^",8),0)):$P(^(0),"^"),1:"Unknown") 13 Q 14 ; 15 ;Set X=Contract/Sharing Agreement patient location 16 S ; 17 C S X=$S($D(^DIC(34,+$P(^RADPT(D0,"DT",D1,"P",D2,0),"^",9),0)):$P(^(0),"^"),1:"Unknown") 18 Q 19 ; 20 ;Set X=Research patient location 21 R S X=$S($D(^RADPT(D0,"DT",D1,"P",D2,"R")):$P(^("R"),"^"),1:"Unknown") Q 22 ; 23 ;Set X=time of day in external format (ex: 2:28 PM) 24 NOW S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) D TIME 25 Q 26 ;Input X=FM date/time, Output X=time (external format) 27 TIME S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M" S:$P(X,":")=0 X=12_":"_$P(X,":",2) 28 Q 29 ; 30 ELAPSED ;Pass parameters X (from date) and X1 (to date) 31 ;Variable Y is returned as either an elapsed time in the form DD:HH:MM where DD=days, HH=hours, MM=minutes or as the string 'Neg. Time' indicating a negative elapsed time 32 ;Variable Y1 is returned as the # of minutes of elapsed time 33 I '$D(RAMTIME) S DIC="^DD(""FUNC"",",DIC(0)="FX",RAX=X,X="MINUTES" D ^DIC K DIC S X=RAX S:$D(^DD("FUNC",+Y,1)) RAMTIME=^(1) I '$D(RAMTIME) W *7,!!,"Can't continue --- No 'MINUTES' function found in File Manager" K Y,Y1 G Q 34 X RAMTIME S Y1=X I X<0 S Y="Neg. Time" G Q 35 MINUTS S X(1)=X\1440,X=X-(1440*X(1)),X(2)=X\60,X(3)=X-(60*X(2)),Y=$E(100+X(1),2,3)_":"_$E(100+X(2),2,3)_":"_$E(100+X(3),2,3) 36 Q K RAX,X Q 37 ; 38 UPDATE ;Entry point for Update Rad/Nuc Med Exam Status option 39 I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) 40 I $G(RAIMGTY)="" D SETVARS^RAPSET1(1) 41 I $G(RAIMGTY)="" K XQUIT Q ; didn't sign-on to an imaging location 42 D ^RACNLU G UPQ:"^"[X 43 I $D(^RA(72,"AA",RAIMGTY,9,+RAST)),'$D(^XUSEC("RA MGR",DUZ)) W !!?3,*7,"You do not have the appropriate access privileges to act on completed exams." G UPDATE 44 I $D(^RA(72,"AA",RAIMGTY,0,+RAST)) W !!?3,*7,"Exam has been 'cancelled' therefore the status cannot be changed." G UPDATE 45 ;D UP1 I RAOR>0 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"",",DR="100///""NOW""",DR(2,70.07)="2///U;3////"_$S($G(RADUZ):RADUZ,1:DUZ) D ^DIE 46 D UP1 I RAOR>0 D 47 .L +^RADPT(RADFN,"DT",RADTI,"P",RACNI) 48 .N RAIEN 49 .S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_"," 50 .S RAFDA(70.07,RAIENS,.01)="NOW" 51 .K RAERR D UPDATE^DIE("E","RAFDA","RAIEN","RAERR") 52 .K RAFDA,RAIENS 53 .I $D(RAERR) L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) K RAIEN Q 54 .S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_"," 55 .S RAFDA(70.07,RAIENS,2)="U" 56 .S RAFDA(70.07,RAIENS,3)=$S($G(RADUZ):RADUZ,1:DUZ) 57 .D FILE^DIE(,"RAFDA") 58 .L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) 59 UPQ K RAFDA,RAIENS 60 K %,D,DA,DE,DIC,DIE,DQ,DR,I,J,POP,RACS,RAEND,RAF5,RAFL,RAFST,RAI,RAIX,RAJ1,RAORDIFN,RAPRIT,RAHEAD,RASN,RAOR,RASTI,RASSN,RADATE,RAST,RACN,RACNI,RADFN,RADTE,RADTI,RANME,RAPRC,RARPT,X,Y,Z,^TMP($J,"RAEX"),C,DIPGM Q 61 ; 62 ;Exam status updating and accompanying updates to status log, oe/rr 63 UP1 N RA8,RAEXEDT S RA8=0 ;use this to flag when one alert has been sent 64 ;Line change for RA*5*82 65 S RAEXEDT=$$CMPAFTR^RAO7XX(1) ;P18 if procedure changed in RAEDCN or RAEDPT sends XX message to CPRS if needed 66 ; RA EDITCN and RA EDITPT should process this case only 67 I $D(RAOPT("EDITCN"))!($D(RAOPT("EDITPT"))) D UP2,UPK Q 68 ; see if this case belongs to a printset 69 N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR 70 D EN2^RAUTL20(.RAMEMARR) ;043099 always recalculate RAPRTSET 71 ; if not print set, then just process this case only 72 I 'RAPRTSET D UP2,UPK Q 73 ;case belongs to print set, so process all members of same print set 74 N RACNISAV,RA7 75 S RACNISAV=RACNI,RA7=0 76 F S RA7=$O(RAMEMARR(RA7)) Q:RA7="" S RACNI=RA7 D UP2 77 S RACNI=RACNISAV 78 G UPK 79 UP2 ;Remedy Call 124379 Patch *71 BAY/KAM Added next line 80 ;Patch RA*5*82 next line commented out 81 ;D:$G(RAHLTCPB)'=1 EXM^RAHLRPC 82 ; 83 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," 84 N RAAFTER,RABEFORE 85 D STUFF^RASTREQ1 I RAOR<0,$D(RASN) W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?5,"...exam status remains '",RASN,"'." K DIE,RACS,RAPRIT D Q 86 .D:$G(RAEXEDT) EXM^RAHLRPC ; DO statement added by RA*5*82 87 W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?3,"...will now designate exam status as '",RASN,"'... for case no. ",$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U) 88 ; S DR="3////"_RASTI_$S($P(RAMDV,"^",10):";75///^S X=$$MIDNGHT^RAUTL5($$NOW^XLFDT())",1:"") 89 ; user duz could be in RADUZ, if session is from the Voice recognition 90 ;S DR(2,70.05)=$S($P(RAMDV,"^",11)&('$D(ZTQUEUED)):".01;",1:"")_"2////"_RASTI_";3////"_$S($G(RADUZ):RADUZ,1:DUZ) 91 ;D ^DIE 92 L +^RADPT(RADFN,"DT",RADTI,"P",RACNI) 93 N RAIEN 94 S RAIENS=RACNI_","_RADTI_","_RADFN_"," 95 S RAFDA(70.03,RAIENS,3)=RASTI 96 K RAERR D FILE^DIE(,"RAFDA","RAERR") 97 I $D(RAERR) L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) G UP2K ;L - P18 98 I $P(RAMDV,"^",10) D 99 .S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_"," 100 .S RAFDA(70.05,RAIENS,.01)=$$MIDNGHT^RAUTL5($$NOW^XLFDT()) 101 .D UPDATE^DIE(,"RAFDA","RAIEN") 102 .K RAFDA,RAIENS 103 .Q:'$D(RAIEN(1)) 104 .I $P(RAMDV,"^",11),('$D(ZTQUEUED)) D 105 ..S DIE=DIE_RACNI_",""T"",",DA=RAIEN(1) 106 ..S DR=".01" 107 ..D ^DIE 108 .S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_"," 109 .S RAFDA(70.05,RAIENS,2)=RASTI 110 .S RAFDA(70.05,RAIENS,3)=$S($G(RADUZ):RADUZ,1:DUZ) 111 .K RAERR2 D FILE^DIE(,"RAFDA") 112 ;Patch RA*5*82 added next line send EXM message after status update, not before the update 113 D EXM^RAHLRPC 114 L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) 115 ; 116 UP2K K DE,DQ,DIE,DR,RAFDA,RAIENS K:$D(RAERR) RACS,RAPRIT Q:$D(RAERR) W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?10,"...exam status ",$S($G(RABEFORE)>$G(RAAFTER):"backed down",1:"successfully updated"),"." D ^RAORDC 117 I RA8=0,$D(^RA(72,RASTI,"ALERT")),$P(^("ALERT"),"^")="y" D:$$ORVR^RAORDU()=2.5 OERR D:$$ORVR^RAORDU()'<3 OERR3 S RA8=1 118 I $D(^RA(72,RASTI,0)),$P(^(0),"^",3)>1,RACS'="Y",$S('$D(RAF5):1,$P(^DIC(42,+RAF5,0),U,3)="D":1,1:0) D EN^RAUTL0 119 K RACS,RAORDIFN,RAPRIT,RAF5 120 Q 121 UPK K ORIFN,ORVP,ORNOTE,ORBPMSG,RACS,RAORDIFN,RAPRIT,RAF5 122 Q 123 OERR ;Send Alert to OERR after pt examined 124 S ORVP=RADFN_";DPT(",ORBPMSG="Rad Pt Examined - "_$S($D(^RAMIS(71,RAPRIT,0)):$E($P(^(0),"^"),1,24),1:"Unknown") S:$D(^RAO(75.1,+RAORDIFN,0)) ORIFN=+$P(^(0),"^",7) S ORNOTE(21)=$S($D(ORIFN):1,1:"") D NOTE^ORX3 125 Q 126 OERR3 ; Send RADIOLOGY PATIENT EXAMINED notification via oe/rr v3 127 ; Called from UP1 128 ; 129 ; RADFN,RADTI,RACNI,RAPRIT must be defined 130 Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))!('$D(RAPRIT)) 131 ; 132 N RAIENS,RAMSG,RAOIFN,RAOSTS,RAONODE,RADPTNDE,RAREQPHY 133 S RADPTNDE=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) 134 S RAOIFN=$P(RADPTNDE,U,11) Q:'RAOIFN ;file 75.1 ien 135 S RAONODE=$G(^RAO(75.1,+RAOIFN,0)) 136 S RAOSTS=$P(RAONODE,U,5) Q:RAOSTS'=6 ;active exams only 137 S RAOIFN=$P(RAONODE,U,7) ;file 100 ien 138 S RAREQPHY=+$P(RADPTNDE,U,14) ;ordering provider 139 S RAREQPHY(RAREQPHY)="" 140 S RAMSG="Imaging Pt Examined - "_$S($D(^RAMIS(71,RAPRIT,0)):$E($P(^(0),U),1,24),1:"Unknown"),RAMSG=$E(RAMSG,1,51) 141 S RAIENS=RADTI_"~"_RACNI 142 ; 143 ; oe parameters: 144 ; ORN: notification id (#100.9 ien) 145 ; | ORBDFN: patient id (#2 ien) 146 ; | | ORNUM: order number (#100 ien) 147 ; | | | ORBADUZ: recipient array 148 ; | | | | ORBPMSG: message text 149 ; | | | | | ORBPDATA exam dt~case iens 150 ; | | | | | | 151 D EN^ORB3(21,RADFN,RAOIFN,.RAREQPHY,RAMSG,RAIENS) 152 Q 153 ; 154 ;Called by many report programs. Sets RACRT() array containing all 155 ;exam statuses that are to be included on the report. RACRT is set 156 ;to the piece of the Exam Status File #72 record that corresponds 157 ;to the report being generated. 158 CRIT F I=0:0 S I=$O(^RA(72,I)) Q:'I I $D(^(I,.3)),$P(^(.3),"^",RACRT)="y" S RACRT(I)="" 159 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAWKLU.m
r613 r623 1 RAWKLU ;HISC/GJC-physician workload statistics by wRVU or CPT ;10/26/05 14:57 2 ;;5.0;Radiology/Nuclear Medicine;**64,77,91**;Mar 16, 1998;Build 1 3 ;01/23/08 BAY/KAM Remedy Call 227583 Patch *91 Change RVU Reports to 4 ; use Report End Date instead of Current date when setting 5 ; the flag to determine if necessary to use last year's RVU 6 ; data and retrieve RVU data by Verified date instead of 7 ; Exam date 8 ;09/25/06 KAM/BAY Remedy Call 154793 PATCH *77 RVU with 0 value 9 ; and changed CPT calls from ^ICPTCOD to ^RACPTMSC 10 ; eliminating the need for IA's 1995 amd 1996 11 ;03/28/07 KAM/BAY Remedy Call 179232 Patch RA*5*77 12 ; Add check to see if current RVU data is available and if 13 ; not use previous year RVU data 14 ; 15 ;DBIA#:4799 ($$RVU^FBRVU) return wRVU value for CPT, CPT Mod, & exam 16 ; date/time 17 ;DBIA#:10060 EN1^RASELCT enacts 10060 which allows lookups on the NEW 18 ; PERSON (#200) file 19 ;DBIA#:10063 ($$S^%ZTLOAD) 20 ;DBIA#:10103 ($$FMTE^XLFDT) & ($$NOW^XLFDT) 21 ;DBIA#:10104 ($$CJ^XLFSTR) 22 ;DBIA#:1519 ($$EN^XUTMDEVQ) 23 ; 24 EN(RARPTYP,RASCLD) ;Identifies the option that the user wishes to execute. 25 ;input: RARPTYP="CPT" for the CPT workload report -or- "RVU" for 26 ; wRVU workload report. Exit if the value is neither 'CPT' 27 ; or 'RVU'. 28 ; RASCLD=null for the CPT report, zero for non-scaled wRVU, & one 29 ; for the scaled wRVU report. 30 ; 31 I RARPTYP'="CPT",(RARPTYP'="RVU") Q 32 I RARPTYP="CPT",(RASCLD'="") Q 33 K ^TMP($J,"RA STFPHYS"),^TMP("RA STFPHYS-IEN",$J) 34 I RARPTYP="RVU" W !!,"Please note that this report is best suited for display on a 132 column device." 35 ; 36 PHYST ;allow the user to select one/many/all physicians 37 ;(w/ staff classification) ;DBIA#: 10060 38 S RADIC="^VA(200,",RADIC(0)="QEAMZ",RAUTIL="RA STFPHYS" 39 S RADIC("A")="Select Physician: ",RADIC("B")="All" 40 S RADIC("S")="I $D(^VA(200,""ARC"",""S"",+Y))\10" 41 W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAQUIT,RAUTIL,X,Y 42 ;did the user select physicians to compile data on? if not, quit 43 I $O(^TMP($J,"RA STFPHYS",""))="" D Q 44 .W !!?3,$C(7),"Staff Physician data was not selected." 45 .Q 46 ; 47 ;build a new staff physician array (the other array is subscripted by 48 ;physician name then IEN) subscripting by staff physician IEN this 49 ;allows us to check the IEN of the staff physician selected by the 50 ;user against the IEN of the staff physician on the exam record 51 S X="" F S X=$O(^TMP($J,"RA STFPHYS",X)) Q:X="" D 52 .S Y=0 53 .F S Y=$O(^TMP($J,"RA STFPHYS",X,Y)) Q:'Y S ^TMP("RA STFPHYS-IEN",$J,Y)="" 54 .Q 55 ; 56 K ^TMP($J,"RA STFPHYS") S RADATE=$$FMTE^XLFDT($$NOW^XLFDT\1,1) 57 ; 58 STRTDT ;Prompt the user for a starting date (VERIFIED DATE) 59 S RASTART=$$STRTDT^RAWKLU1(RADATE,2110101) 60 I RASTART=-1 D XIT Q 61 S RABGDTI=$P(RASTART,U),RABGDTX=$P(RASTART,U,2),RAMBGDT=RABGDTI-.0001 62 ;need inv. verified date to search ^RARPT("AA", 63 S RAMBGDT=9999999.9999-RAMBGDT 64 K RASTART 65 ; 66 ENDDT ;Prompt the user for an ending date (VERIFIED DATE) 67 S RAEND=$$ENDDT^RAWKLU1(RABGDTI,RABGDTX) 68 I RAEND=-1 D XIT Q 69 S RAENDTI=$P(RAEND,U),RAENDTX=$P(RAEND,U,2),RAMENDT=RAENDTI+.9999 70 ;need inv. verified date to search ^RARPT("AA", 71 S RAMENDT=9999999.9999-RAMENDT 72 K RAEND 73 ; 74 F I="RARPTYP","^TMP(""RA STFPHYS-IEN"",$J,","RADATE","RAB*","RAM*","RAE*","RASCLD" S ZTSAVE(I)="" 75 S I="RA print "_$S(RARPTYP="CPT":"CPTs",1:"wRVUs")_" totals for physicians within imaging type" 76 D EN^XUTMDEVQ("START^RAWKLU",I,.ZTSAVE,,1) 77 I +$G(ZTSK)>0 W !!,"Task Number: "_ZTSK,! 78 K I,ZTSAVE,ZTSK 79 Q 80 ; 81 START ;check exams based on criteria input by user; physician & exam D/T 82 ;eliminate the exam record is one of the following conditions is true: 83 ;1-the status of the exam is 'Cancelled' 84 ;2-the physician(s) selected are not the primary staff for the exam 85 ; 86 ;03/28/07 KAM/BAY Remedy Call 179232 Added next line 87 S RACYFLG=0 88 ;03/28/07 KAM/BAY RA*5*77/179232 Added Fee Basis Data Check 89 D CHKCY^RAWKLU2 90 S:$D(ZTQUEUED)#2 ZTREQ="@" 91 K ^TMP($J,"RA BY STFPHYS"),^TMP($J,"RA BY I-TYPE") 92 S ^TMP($J,"RA BY I-TYPE")="0^0^0^0^0^0^0^0^0",CNT=0 93 ;define where the totals for imaging type will reside on the globals 94 F RAI="RAD","MRI","CT","US","NM","VAS","ANI","CARD","MAM" S CNT=CNT+1,RAIAB(RAI)=CNT 95 K RAI,CNT S RARPTVDT=RAMBGDT,(RACNT,RAXIT)=0 96 F S RARPTVDT=$O(^RARPT("AA",RARPTVDT),-1) Q:'RARPTVDT!(RARPTVDT<RAMENDT) D Q:RAXIT 97 .S RARPTIEN=0 98 .F S RARPTIEN=$O(^RARPT("AA",RARPTVDT,RARPTIEN)) Q:'RARPTIEN D Q:RAXIT 99 ..S RARPT=$G(^RARPT(RARPTIEN,0)),RADFN=+$P(RARPT,U,2),RADTE=+$P(RARPT,U,3) 100 ..S RADTI=9999999.9999-RADTE,RA7002=$G(^RADPT(RADFN,"DT",RADTI,0)) 101 ..Q:$P(RA7002,U,2)="" ;no imaging type defined 102 ..S RAITYP=$P($G(^RA(79.2,$P(RA7002,U,2),0)),U,3) ;abbreviation 103 ..Q:'($D(RAIAB(RAITYP))#2) 104 ..S RACNI=0 105 ..F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D Q:RAXIT 106 ...S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q:RA7003="" ;missing exam node 107 ...Q:$P(RA7003,U,17)'=RARPTIEN ;exam references a different report! 108 ...S RACNT=RACNT+1 109 ...; 110 ...;did the user stop the task? Check every five hundred records... 111 ...S:RACNT#500=0 (RAXIT,ZTSTOP)=$$S^%ZTLOAD() Q:RAXIT 112 ...; 113 ...;1-begin exam status check 114 ...Q:$P($G(^RA(72,+$P(RA7003,U,3),0)),U,3)=0 ;cancelled... 115 ...;end exam status check 116 ...; 117 ...;2-begin physician check 118 ...Q:'$P(RA7003,U,15) ;no physician, quit check 119 ...Q:'$D(^TMP("RA STFPHYS-IEN",$J,$P(RA7003,U,15)))#2 120 ...;end physician check 121 ...; 122 ...S RASTAFF=$$EXTERNAL^DILFD(70.03,15,,$P(RA7003,U,15)) 123 ...I RARPTYP="CPT" D Q 124 ....;Total the # of CPTs performed by a physician within an i-type; 125 ....;the # on CPTs performed within i-type; the # of procedures 126 ....;performed by physician. all exams are either detailed or series 127 ....;(CPT codes defined) types of procedures. 128 ....D ARY(1) 129 ....Q 130 ...D RVU 131 ...Q 132 ..Q 133 .Q 134 D EN^RAWKLU1 ;output the report 135 D XIT 136 Q 137 ; 138 ARY(Y) ;increment the array by one in the case of CPT or by the wRVU 139 ;value 140 ;input: Y=either one when adding the number of CPTs performed by a 141 ; physician, within an i-type or by physician within i-type 142 ; -or- the WRVU value when totaling for the aforementioned criteria 143 ; 144 S $P(^TMP($J,"RA BY STFPHYS",RASTAFF),U,RAIAB(RAITYP))=+$P($G(^TMP($J,"RA BY STFPHYS",RASTAFF)),U,RAIAB(RAITYP))+Y 145 S $P(^TMP($J,"RA BY I-TYPE"),U,RAIAB(RAITYP))=$P(^TMP($J,"RA BY I-TYPE"),U,RAIAB(RAITYP))+Y 146 Q 147 ; 148 RVU ;Total the # of wRVUs performed by a physician within an i-type; all 149 ;exams are either detailed or series types of procedures. By definition 150 ;these procedure types MUST have CPT code defined. 151 ;Pass the exam date, CPT, & CPT modifiers into the FEE BASIS function 152 ;to derive the wRVU 153 ; 154 ;get exam date/time 155 N RAXAMDT S RAXAMDT=$P(RA7002,U) 156 ;get the CPT code value 157 S RACPT=$P($G(^RAMIS(71,+$P(RA7003,U,2),0)),U,9) ;pointer to file #81 158 ; 09/27/2006 KAM/BAY Patch RA*5*77 Changed next line to use ^RACPTMSC 159 S RACPT=$P($$NAMCODE^RACPTMSC(RACPT,RAXAMDT),U,1) ;CPT code is 1st pc 160 ; 161 ;get CPT code modifier string 162 S RACPTMOD="",RABILAT=0 163 I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0))>0 S RAI=0 D 164 .F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI)) Q:'RAI D 165 ..S RACPTMOD(0)=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI,0)) 166 ..;09/27/2006 KAM/BAY RA*5*77 Changed next line to use ^RACPTMSC 167 ..S RA813(0)=$$BASICMOD^RACPTMSC(RACPTMOD(0),RAXAMDT) 168 ..I 'RABILAT,$P(RA813(0),U,2)=50 S RABILAT=1 ;bilateral multiplier=2 169 ..S RACPTMOD=RACPTMOD_$P(RA813(0),U,2)_"," 170 ..Q 171 .Q 172 ;get wRVU value from FEE BASIS; returns a string: status^value^message 173 ;where status'=1 means "in error". All exams prior to 1/1/1999 will 174 ;use 1999 wRVU values for their calculations. 175 ;03/28/2007 KAM/BAY Rem Call 179232 Added RACYFLG to $S in next line 176 ;01/23/2008 KAM/BAY RA*5*91 Remedy Call 227583 Changed the next line 177 ; to use the Verified date of the exam date 178 S RAWRVU=$$RVU^FBRVU(RACPT,RACPTMOD,$S((9999999.9999-RARPTVDT)<2990101:2990101,RACYFLG:(9999999.9999-RARPTVDT)-10000,1:(9999999.9999-RARPTVDT))) 179 ; 09/25/2006 KAM/BAY Remedy Call 154793 Correct 0 RVUs 180 I $P(RAWRVU,U,2)=0,RACPTMOD="" D 181 . ;01/23/2008 KAM/BAY RA*5*91 Remedy Call 227583 Changed the next lin 182 . ; to use the Verified date of the exam date 183 . S RAWRVU=$$RVU^FBRVU(RACPT,26,$S((9999999.9999-RARPTVDT)<2990101:2990101,RACYFLG:(9999999.9999-RARPTVDT)-10000,1:(9999999.9999-RARPTVDT))) 184 ; 185 I $P(RAWRVU,U)=1 D 186 .;apply bilateral multiplier if appropriate 187 .S:RABILAT RAWRVU=$P(RAWRVU,U,2)*2 188 .;or not... 189 .S:'RABILAT RAWRVU=$P(RAWRVU,U,2) 190 .I RASCLD S RAWRVU=RAWRVU*$$SFCTR^RAWRVUP($P(RA7002,U,2),RAXAMDT) 191 .Q 192 ; 193 E S RAWRVU=0 ;status some other value than 1; "in error" 194 S:RAWRVU>0 RAWRVU=$J(RAWRVU,1,2) ;do not round the value... 195 D ARY(RAWRVU) 196 K RA813,RABILAT,RACPT,RACPTMOD,RAI,RAWRVU 197 Q 198 ; 199 XIT ;kill variables and exit 200 W:$G(ZTSTOP)=1 !,$$CJ^XLFSTR("USER STOPPED PROCESS THROUGH TASKMAN",IOM) 201 K DIRUT,DTOUT,DUOUT,RA7002,RA7003,RABGDTI,RABGDTX,RACNI,RADATE 202 K RADFN,RADTE,RADTI,RAENDTI,RAENDTX,RAIAB,RAITYP,RAMBGDT,RAMENDT 203 K RARPT,RARPTIEN,RARPTVDT,RASTAFF,RAXIT,X,Y,^TMP("RA STFPHYS-IEN",$J) 204 K ^TMP($J,"RA BY STFPHYS"),^TMP($J,"RA BY I-TYPE"),RACYFLG 205 Q 1 RAWKLU ;HISC/GJC-physician workload statistics by wRVU or CPT ;10/26/05 14:57 2 ;;5.0;Radiology/Nuclear Medicine;**64,77**;Mar 16, 1998;Build 7 3 ;09/25/06 KAM/BAY Remedy Call 154793 PATCH *77 RVU with 0 value 4 ; and changed CPT calls from ^ICPTCOD to ^RACPTMSC 5 ; eliminating the need for IA's 1995 amd 1996 6 ;03/28/07 KAM/BAY Remedy Call 179232 Patch RA*5*77 7 ; Add check to see if current RVU data is available and if 8 ; not use previous year RVU data 9 ; 10 ;DBIA#:4799 ($$RVU^FBRVU) return wRVU value for CPT, CPT Mod, & exam 11 ; date/time 12 ;DBIA#:10060 EN1^RASELCT enacts 10060 which allows lookups on the NEW 13 ; PERSON (#200) file 14 ;DBIA#:10063 ($$S^%ZTLOAD) 15 ;DBIA#:10103 ($$FMTE^XLFDT) & ($$NOW^XLFDT) 16 ;DBIA#:10104 ($$CJ^XLFSTR) 17 ;DBIA#:1519 ($$EN^XUTMDEVQ) 18 ; 19 EN(RARPTYP,RASCLD) ;Identifies the option that the user wishes to execute. 20 ;input: RARPTYP="CPT" for the CPT workload report -or- "RVU" for 21 ; wRVU workload report. Exit if the value is neither 'CPT' 22 ; or 'RVU'. 23 ; RASCLD=null for the CPT report, zero for non-scaled wRVU, & one 24 ; for the scaled wRVU report. 25 ; 26 I RARPTYP'="CPT",(RARPTYP'="RVU") Q 27 I RARPTYP="CPT",(RASCLD'="") Q 28 K ^TMP($J,"RA STFPHYS"),^TMP("RA STFPHYS-IEN",$J) 29 I RARPTYP="RVU" W !!,"Please note that this report is best suited for display on a 132 column device." 30 ; 31 PHYST ;allow the user to select one/many/all physicians 32 ;(w/ staff classification) ;DBIA#: 10060 33 S RADIC="^VA(200,",RADIC(0)="QEAMZ",RAUTIL="RA STFPHYS" 34 S RADIC("A")="Select Physician: ",RADIC("B")="All" 35 S RADIC("S")="I $D(^VA(200,""ARC"",""S"",+Y))\10" 36 W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAQUIT,RAUTIL,X,Y 37 ;did the user select physicians to compile data on? if not, quit 38 I $O(^TMP($J,"RA STFPHYS",""))="" D Q 39 .W !!?3,$C(7),"Staff Physician data was not selected." 40 .Q 41 ; 42 ;build a new staff physician array (the other array is subscripted by 43 ;physician name then IEN) subscripting by staff physician IEN this 44 ;allows us to check the IEN of the staff physician selected by the 45 ;user against the IEN of the staff physician on the exam record 46 S X="" F S X=$O(^TMP($J,"RA STFPHYS",X)) Q:X="" D 47 .S Y=0 48 .F S Y=$O(^TMP($J,"RA STFPHYS",X,Y)) Q:'Y S ^TMP("RA STFPHYS-IEN",$J,Y)="" 49 .Q 50 ; 51 K ^TMP($J,"RA STFPHYS") S RADATE=$$FMTE^XLFDT($$NOW^XLFDT\1,1) 52 ; 53 STRTDT ;Prompt the user for a starting date (VERIFIED DATE) 54 S RASTART=$$STRTDT^RAWKLU1(RADATE,2110101) 55 I RASTART=-1 D XIT Q 56 S RABGDTI=$P(RASTART,U),RABGDTX=$P(RASTART,U,2),RAMBGDT=RABGDTI-.0001 57 ;need inv. verified date to search ^RARPT("AA", 58 S RAMBGDT=9999999.9999-RAMBGDT 59 K RASTART 60 ; 61 ENDDT ;Prompt the user for an ending date (VERIFIED DATE) 62 S RAEND=$$ENDDT^RAWKLU1(RABGDTI,RABGDTX) 63 I RAEND=-1 D XIT Q 64 S RAENDTI=$P(RAEND,U),RAENDTX=$P(RAEND,U,2),RAMENDT=RAENDTI+.9999 65 ;need inv. verified date to search ^RARPT("AA", 66 S RAMENDT=9999999.9999-RAMENDT 67 K RAEND 68 ; 69 F I="RARPTYP","^TMP(""RA STFPHYS-IEN"",$J,","RADATE","RAB*","RAM*","RAE*","RASCLD" S ZTSAVE(I)="" 70 S I="RA print "_$S(RARPTYP="CPT":"CPTs",1:"wRVUs")_" totals for physicians within imaging type" 71 D EN^XUTMDEVQ("START^RAWKLU",I,.ZTSAVE,,1) 72 I +$G(ZTSK)>0 W !!,"Task Number: "_ZTSK,! 73 K I,ZTSAVE,ZTSK 74 Q 75 ; 76 START ;check exams based on criteria input by user; physician & exam D/T 77 ;eliminate the exam record is one of the following conditions is true: 78 ;1-the status of the exam is 'Cancelled' 79 ;2-the physician(s) selected are not the primary staff for the exam 80 ; 81 ;03/28/07 KAM/BAY Remedy Call 179232 Added next line 82 S RACYFLG=0 83 ;03/28/07 KAM/BAY RA*5*77/179232 Added Fee Basis Data Check 84 D CHKCY^RAWKLU2 85 S:$D(ZTQUEUED)#2 ZTREQ="@" 86 K ^TMP($J,"RA BY STFPHYS"),^TMP($J,"RA BY I-TYPE") 87 S ^TMP($J,"RA BY I-TYPE")="0^0^0^0^0^0^0^0^0",CNT=0 88 ;define where the totals for imaging type will reside on the globals 89 F RAI="RAD","MRI","CT","US","NM","VAS","ANI","CARD","MAM" S CNT=CNT+1,RAIAB(RAI)=CNT 90 K RAI,CNT S RARPTVDT=RAMBGDT,(RACNT,RAXIT)=0 91 F S RARPTVDT=$O(^RARPT("AA",RARPTVDT),-1) Q:'RARPTVDT!(RARPTVDT<RAMENDT) D Q:RAXIT 92 .S RARPTIEN=0 93 .F S RARPTIEN=$O(^RARPT("AA",RARPTVDT,RARPTIEN)) Q:'RARPTIEN D Q:RAXIT 94 ..S RARPT=$G(^RARPT(RARPTIEN,0)),RADFN=+$P(RARPT,U,2),RADTE=+$P(RARPT,U,3) 95 ..S RADTI=9999999.9999-RADTE,RA7002=$G(^RADPT(RADFN,"DT",RADTI,0)) 96 ..Q:$P(RA7002,U,2)="" ;no imaging type defined 97 ..S RAITYP=$P($G(^RA(79.2,$P(RA7002,U,2),0)),U,3) ;abbreviation 98 ..Q:'($D(RAIAB(RAITYP))#2) 99 ..S RACNI=0 100 ..F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D Q:RAXIT 101 ...S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q:RA7003="" ;missing exam node 102 ...Q:$P(RA7003,U,17)'=RARPTIEN ;exam references a different report! 103 ...S RACNT=RACNT+1 104 ...; 105 ...;did the user stop the task? Check every five hundred records... 106 ...S:RACNT#500=0 (RAXIT,ZTSTOP)=$$S^%ZTLOAD() Q:RAXIT 107 ...; 108 ...;1-begin exam status check 109 ...Q:$P($G(^RA(72,+$P(RA7003,U,3),0)),U,3)=0 ;cancelled... 110 ...;end exam status check 111 ...; 112 ...;2-begin physician check 113 ...Q:'$P(RA7003,U,15) ;no physician, quit check 114 ...Q:'$D(^TMP("RA STFPHYS-IEN",$J,$P(RA7003,U,15)))#2 115 ...;end physician check 116 ...; 117 ...S RASTAFF=$$EXTERNAL^DILFD(70.03,15,,$P(RA7003,U,15)) 118 ...I RARPTYP="CPT" D Q 119 ....;Total the # of CPTs performed by a physician within an i-type; 120 ....;the # on CPTs performed within i-type; the # of procedures 121 ....;performed by physician. all exams are either detailed or series 122 ....;(CPT codes defined) types of procedures. 123 ....D ARY(1) 124 ....Q 125 ...D RVU 126 ...Q 127 ..Q 128 .Q 129 D EN^RAWKLU1 ;output the report 130 D XIT 131 Q 132 ; 133 ARY(Y) ;increment the array by one in the case of CPT or by the wRVU 134 ;value 135 ;input: Y=either one when adding the number of CPTs performed by a 136 ; physician, within an i-type or by physician within i-type 137 ; -or- the WRVU value when totaling for the aforementioned criteria 138 ; 139 S $P(^TMP($J,"RA BY STFPHYS",RASTAFF),U,RAIAB(RAITYP))=+$P($G(^TMP($J,"RA BY STFPHYS",RASTAFF)),U,RAIAB(RAITYP))+Y 140 S $P(^TMP($J,"RA BY I-TYPE"),U,RAIAB(RAITYP))=$P(^TMP($J,"RA BY I-TYPE"),U,RAIAB(RAITYP))+Y 141 Q 142 ; 143 RVU ;Total the # of wRVUs performed by a physician within an i-type; all 144 ;exams are either detailed or series types of procedures. By definition 145 ;these procedure types MUST have CPT code defined. 146 ;Pass the exam date, CPT, & CPT modifiers into the FEE BASIS function 147 ;to derive the wRVU 148 ; 149 ;get exam date/time 150 N RAXAMDT S RAXAMDT=$P(RA7002,U) 151 ;get the CPT code value 152 S RACPT=$P($G(^RAMIS(71,+$P(RA7003,U,2),0)),U,9) ;pointer to file #81 153 ; 09/27/2006 KAM/BAY Patch RA*5*77 Changed next line to use ^RACPTMSC 154 S RACPT=$P($$NAMCODE^RACPTMSC(RACPT,RAXAMDT),U,1) ;CPT code is 1st pc 155 ; 156 ;get CPT code modifier string 157 S RACPTMOD="",RABILAT=0 158 I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0))>0 S RAI=0 D 159 .F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI)) Q:'RAI D 160 ..S RACPTMOD(0)=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI,0)) 161 ..;09/27/2006 KAM/BAY RA*5*77 Changed next line to use ^RACPTMSC 162 ..S RA813(0)=$$BASICMOD^RACPTMSC(RACPTMOD(0),RAXAMDT) 163 ..I 'RABILAT,$P(RA813(0),U,2)=50 S RABILAT=1 ;bilateral multiplier=2 164 ..S RACPTMOD=RACPTMOD_$P(RA813(0),U,2)_"," 165 ..Q 166 .Q 167 ;get wRVU value from FEE BASIS; returns a string: status^value^message 168 ;where status'=1 means "in error". All exams prior to 1/1/1999 will 169 ;use 1999 wRVU values for their calculations. 170 ;03/28/2007 KAM/BAY Rem Call 179232 Added RACYFLG to $S in next line 171 S RAWRVU=$$RVU^FBRVU(RACPT,RACPTMOD,$S(RAXAMDT<2990101:2990101,RACYFLG:RAXAMDT-10000,1:RAXAMDT)) 172 ; 09/25/2006 KAM/BAY Remedy Call 154793 Correct 0 RVUs 173 I $P(RAWRVU,U,2)=0,RACPTMOD="" D 174 . S RAWRVU=$$RVU^FBRVU(RACPT,26,$S(RAXAMDT<2990101:2990101,RACYFLG:RAXAMDT-10000,1:RAXAMDT)) 175 ; 176 I $P(RAWRVU,U)=1 D 177 .;apply bilateral multiplier if appropriate 178 .S:RABILAT RAWRVU=$P(RAWRVU,U,2)*2 179 .;or not... 180 .S:'RABILAT RAWRVU=$P(RAWRVU,U,2) 181 .I RASCLD S RAWRVU=RAWRVU*$$SFCTR^RAWRVUP($P(RA7002,U,2),RAXAMDT) 182 .Q 183 ; 184 E S RAWRVU=0 ;status some other value than 1; "in error" 185 S:RAWRVU>0 RAWRVU=$J(RAWRVU,1,2) ;do not round the value... 186 D ARY(RAWRVU) 187 K RA813,RABILAT,RACPT,RACPTMOD,RAI,RAWRVU 188 Q 189 ; 190 XIT ;kill variables and exit 191 W:$G(ZTSTOP)=1 !,$$CJ^XLFSTR("USER STOPPED PROCESS THROUGH TASKMAN",IOM) 192 K DIRUT,DTOUT,DUOUT,RA7002,RA7003,RABGDTI,RABGDTX,RACNI,RADATE 193 K RADFN,RADTE,RADTI,RAENDTI,RAENDTX,RAIAB,RAITYP,RAMBGDT,RAMENDT 194 K RARPT,RARPTIEN,RARPTVDT,RASTAFF,RAXIT,X,Y,^TMP("RA STFPHYS-IEN",$J) 195 K ^TMP($J,"RA BY STFPHYS"),^TMP($J,"RA BY I-TYPE"),RACYFLG 196 Q -
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAWKLU2.m
r613 r623 1 RAWKLU2 ;HISC/GJC-physician wRVU (scaled too) by procedure ;10/26/05 14:57 2 ;;5.0;Radiology/Nuclear Medicine;**64,77,91**;Mar 16, 1998;Build 1 3 ;01/23/08 BAY/KAM Remedy Call 227583 Patch *91 Change RVU Reports to 4 ; use Report End Date instead of Current date when setting 5 ; the flag to determine if necessary to use last year's RVU 6 ; data and retrieve RVU data by Verified date instead of 7 ; Exam date 8 ; 9 ;03/28/07 KAM/BAY Remedy Call 179232 Patch RA*5*77 10 ; Add check to see if current RVU data is available and if 11 ; not use previous year RVU data 12 ; 13 ;09/25/06 KAM/BAY Remedy Call 154793 PATCH *77 RVU with 0 value 14 ; and changed CPT calls from ^ICPTCOD to ^RACPTMSC 15 ; eliminating the need for IA's 1995 and 1996 16 ; 17 ;DBIA#:4799 ($$RVU^FBRVU) return wRVU value for CPT, CPT Mod, & exam 18 ; date/time 19 ;DBIA#:10060 EN1^RASELCT enacts 10060 which allows lookups on the NEW 20 ; PERSON (#200) file 21 ;DBIA#:10063 ($$S^%ZTLOAD) 22 ;DBIA#:10103 ($$FMTE^XLFDT) & ($$NOW^XLFDT) 23 ;DBIA#:10104 ($$CJ^XLFSTR) 24 ;DBIA#:1519 ($$EN^XUTMDEVQ) 25 ;DBIA#:4432 (LASTCY^FBAAFSR) return last calendar year file 26 ; 162.99 was updated 27 ; 28 EN(RASCLD) ;Identifies the option that the user wishes to execute. 29 ;input: RASCLD=zero for non-scaled wRVU, & one for the scaled wRVU 30 ; report. 31 ; 32 K ^TMP($J,"RA STFPHYS"),^TMP("RA STFPHYS-IEN",$J) 33 ; 34 PHYST ;allow the user to select one/many/all physicians 35 ;(w/ staff classification) ;DBIA#: 10060 36 S RADIC="^VA(200,",RADIC(0)="QEAMZ",RAUTIL="RA STFPHYS" 37 S RADIC("A")="Select Physician: ",RADIC("B")="All" 38 S RADIC("S")="I $D(^VA(200,""ARC"",""S"",+Y))\10" 39 W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y 40 ;did the user select physicians to compile data on? if not, quit 41 I $O(^TMP($J,"RA STFPHYS",""))="" D Q 42 .W !!?3,$C(7),"Staff Physician data was not selected." 43 .Q 44 ; 45 ;build a new staff physician array (the other array is subscripted by 46 ;physician name then IEN) subscripting by staff physician IEN this 47 ;allows us to check the IEN of the staff physician selected by the 48 ;user against the IEN of the staff physician on the exam record 49 S X="" F S X=$O(^TMP($J,"RA STFPHYS",X)) Q:X="" D 50 .S Y=0 51 .F S Y=$O(^TMP($J,"RA STFPHYS",X,Y)) Q:'Y S ^TMP("RA STFPHYS-IEN",$J,Y)="" 52 .Q 53 ; 54 K ^TMP($J,"RA STFPHYS") S RADATE=$$FMTE^XLFDT($$NOW^XLFDT\1,1) 55 ; 56 STRTDT ;Prompt the user for the starting verified date 57 S RASTART=$$STRTDT^RAWKLU1(RADATE,2110101) 58 I RASTART=-1 D XIT Q 59 S RABGDTI=$P(RASTART,U),RABGDTX=$P(RASTART,U,2),RAMBGDT=RABGDTI-.0001 60 ;need inv. verified date to search ^RARPT("AA", 61 S RAMBGDT=9999999.9999-RABGDTI 62 K RASTART 63 ; 64 ENDDT ;Prompt the user for the ending verified date 65 S RAEND=$$ENDDT^RAWKLU1(RABGDTI,RABGDTX) 66 I RAEND=-1 D XIT Q 67 S RAENDTI=$P(RAEND,U),RAENDTX=$P(RAEND,U,2),RAMENDT=RAENDTI+.9999 68 ;need inv. verified date to search ^RARPT("AA", 69 S RAMENDT=9999999.9999-RAMENDT 70 K RAEND 71 ; 72 F I="^TMP(""RA STFPHYS-IEN"",$J,","RADATE","RAB*","RAM*","RAE*","RASCLD" S ZTSAVE(I)="" 73 S I="RA print procedures, wRVUs, and their totals for a physician" 74 D EN^XUTMDEVQ("START^RAWKLU2",I,.ZTSAVE,,1) 75 I +$G(ZTSK)>0 W !!,"Task Number: "_ZTSK,! 76 K I,ZTSAVE,ZTSK 77 Q 78 ; 79 START ;check exams based on criteria input by user; physician & exam D/T 80 ;eliminate the exam record is one of the following conditions is true: 81 ;1-the status of the exam is 'Cancelled' 82 ;2-the physician(s) selected are not the primary staff for the exam 83 ; 84 S:$D(ZTQUEUED)#2 ZTREQ="@" 85 K ^TMP($J,"RA BY STFPHYS") 86 ;03/28/07 KAM/BAY Remedy Call 179232 Added RACYFLG to next line 87 S RARPTVDT=RAMBGDT,(RACNT,RAXIT,RACYFLG)=0 88 ;03/28/07 KAM/BAY RA*5*77/179232 Added Fee Basis Data Check 89 D CHKCY 90 F S RARPTVDT=$O(^RARPT("AA",RARPTVDT),-1) Q:'RARPTVDT!(RARPTVDT<RAMENDT) D Q:RAXIT 91 .S RARPTIEN=0 92 .F S RARPTIEN=$O(^RARPT("AA",RARPTVDT,RARPTIEN)) Q:'RARPTIEN D Q:RAXIT 93 ..S RARPT=$G(^RARPT(RARPTIEN,0)),RADFN=+$P(RARPT,U,2),RADTE=+$P(RARPT,U,3) 94 ..S RADTI=9999999.9999-RADTE,RA7002=$G(^RADPT(RADFN,"DT",RADTI,0)) 95 ..S RAXAMDT=+$P(RA7002,U) Q:'RAXAMDT 96 ..;must check every exam registered for this exam date/time; we might have a printset 97 ..S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D XAM 98 ..Q 99 .Q 100 D EN^RAWKLU3 ;output the report 101 D XIT 102 Q 103 ; 104 XAM ; get exam information; procedure name, exam status order #, int. staff phys... 105 S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q:'RA7003 106 Q:$P(RA7003,U,17)'=RARPTIEN ;exam references a different report! 107 S RAPRCIEN=+$P(RA7003,U,2) Q:'RAPRCIEN 108 S RAPRCIEN(0)=$P($G(^RAMIS(71,RAPRCIEN,0)),U) Q:RAPRCIEN(0)="" 109 S RACNT=RACNT+1 110 ; 111 ;did the user stop the task? Check every five hundred records... 112 S:RACNT#500=0 (RAXIT,ZTSTOP)=$$S^%ZTLOAD() Q:RAXIT 113 ; 114 ;1-begin exam status check 115 Q:$P($G(^RA(72,+$P(RA7003,U,3),0)),U,3)=0 ;cancelled... 116 ;end exam status check 117 ; 118 ;2-begin physician check 119 Q:'$P(RA7003,U,15) ;no physician, quit check 120 Q:'$D(^TMP("RA STFPHYS-IEN",$J,$P(RA7003,U,15)))#2 121 ;end physician check 122 ; 123 S RACPT=$P($G(^RAMIS(71,+$P(RA7003,U,2),0)),U,9) Q:'RACPT ;ptr to file #81 124 ; 125 ; 09/27/2006 KAM/BAY Patch RA*5*77 Changed next line to use ^RACPTMSC 126 S RACPT=$P($$NAMCODE^RACPTMSC(RACPT,RAXAMDT),U,1) ;CPT code is 1st pc 127 ; 128 S RASTF=$$EXTERNAL^DILFD(70.03,15,,$P(RA7003,U,15)) 129 D SETARRY K RA7003,RACPT,RAPRCIEN,RASTF 130 Q 131 ; 132 SETARRY ;find the wRVU value (either un-scaled or scaled) for a particular CPT 133 ;or CPT code/CPT modifier combination. The case identifiers, CPT code 134 ;(RACPT), & exam date (RAXAMDT) are known. 135 ; 136 ;get CPT code modifier string 137 S RACPTMOD="",RABILAT=0 138 I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0))>0 S RAI=0 D 139 .F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI)) Q:'RAI D 140 ..S RACPTMOD(0)=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI,0)) 141 ..;09/27/2006 KAM/BAY RA*5*77 Changed next line to use ^RACPTMSC 142 ..S RA813(0)=$$BASICMOD^RACPTMSC(RACPTMOD(0),RAXAMDT) 143 ..I 'RABILAT,$P(RA813(0),U,2)=50 S RABILAT=1 ;bilateral multiplier=2 144 ..S RACPTMOD=RACPTMOD_$P(RA813(0),U,2)_"," 145 ..Q 146 .Q 147 ;get wRVU value from FEE BASIS; returns a string: status^value^message 148 ;where status'=1 means "in error". All exams prior to 1/1/1999 will use 149 ;1999 wRVU values for their calculations. 150 ;03/28/2007 KAM/BAY Rem Call 179232 Added RACYFLG to $S in next line 151 ;01/23/2008 KAM/BAY RA*5*91 Remedy Call 227583 Changed the next line 152 ; to use the Verified date instead of the exam date 153 S RAWRVU=$$RVU^FBRVU(RACPT,RACPTMOD,$S((9999999.9999-RARPTVDT)<2990101:2990101,RACYFLG:(9999999.9999-RARPTVDT)-10000,1:(9999999.9999-RARPTVDT))) 154 ;09/27/2006 KAM/BAY RA*5*77 Remedy Call 154793 155 I $P(RAWRVU,U,2)=0,RACPTMOD="" D 156 . ;01/23/2008 KAM/BAY RA*5*91 Remedy Call 227583 Changed next line 157 . ; to use the Verified date instead of the exam date 158 . S RAWRVU=$$RVU^FBRVU(RACPT,26,$S((9999999.9999-RARPTVDT)<2990101:2990101,RACYFLG:(9999999.9999-RARPTVDT)-10000,1:(9999999.9999-RARPTVDT))) 159 I $P(RAWRVU,U)=1 D 160 .;apply bilateral multiplier if appropriate 161 .S:RABILAT RAWRVU=$P(RAWRVU,U,2)*2 162 .;or not... 163 .S:'RABILAT RAWRVU=$P(RAWRVU,U,2) 164 .I RASCLD S RAWRVU=RAWRVU*$$SFCTR^RAWRVUP($P(RA7002,U,2),RAXAMDT) 165 .Q 166 ; 167 E S RAWRVU=0 ;status some other value than 1; "in error" 168 S:RAWRVU>0 RAWRVU=$J(RAWRVU,1,2) ;do not round the value... 169 ; 170 ;^TMP($J,"RA BY STFPHYS",RASTF)=total # procedures^wRVU total(all proc) 171 ;^TMP($J,"RA BY STFPHYS",RASTF,RACPT,RAWRVU,RAPRCIEN(0))=^total # RACPT^ 172 ; total # RAWRVU 173 ; 174 S:'$D(^TMP($J,"RA BY STFPHYS",RASTF))#2 ^(RASTF)="0^0" 175 S $P(^TMP($J,"RA BY STFPHYS",RASTF),U)=$P(^TMP($J,"RA BY STFPHYS",RASTF),U)+1 176 S $P(^TMP($J,"RA BY STFPHYS",RASTF),U,2)=$P(^TMP($J,"RA BY STFPHYS",RASTF),U,2)+RAWRVU 177 S:'$D(^TMP($J,"RA BY STFPHYS",RASTF,RACPT,RAWRVU,RAPRCIEN(0)))#2 ^(RAPRCIEN(0))="^0^0" 178 S $P(^TMP($J,"RA BY STFPHYS",RASTF,RACPT,RAWRVU,RAPRCIEN(0)),U,2)=+$P($G(^TMP($J,"RA BY STFPHYS",RASTF,RACPT,RAWRVU,RAPRCIEN(0))),U,2)+1 179 S $P(^TMP($J,"RA BY STFPHYS",RASTF,RACPT,RAWRVU,RAPRCIEN(0)),U,3)=RAWRVU*(+$P(^TMP($J,"RA BY STFPHYS",RASTF,RACPT,RAWRVU,RAPRCIEN(0)),U,2)) 180 ; 181 K RA813,RABILAT,RACPTMOD,RAI,RAWRVU 182 Q 183 ; 184 XIT ;kill variables and exit 185 W:$G(ZTSTOP)=1 !,$$CJ^XLFSTR("USER STOPPED PROCESS THROUGH TASKMAN",IOM) 186 K DIR,DIROUT,DIRUT,DTOUT,DUOUT,RA7002,RABGDTI,RABGDTX,RACNI,RACNT,RADATE 187 K RADFN,RADTE,RADTI,RAENDTI,RAENDTX,RAMBGDT,RAMENDT,RAQUIT,RARPT,RARPTIEN 188 K RARPTVDT,RAXAMDT,RAXIT,X,Y,RACYFLG 189 K ^TMP("RA STFPHYS-IEN",$J),^TMP($J,"RA BY STFPHYS") 190 Q 191 ; 192 CHKCY ;03/28/2007 KAM/BAY RA*5*77 Remedy Call 179232 Check for latest RVU 193 ; data from Fee Basis 194 S RACYFLG=0 195 ;01/23/2008 BAY/KAM RA*5*91 Rem 227593 Changed next line to use the 196 ; Report end date when setting variable RACYFLG 197 I $$LASTCY^FBAAFSR()<+$P(RAENDTX,",",2) S RACYFLG=1 198 Q 1 RAWKLU2 ;HISC/GJC-physician wRVU (scaled too) by procedure ;10/26/05 14:57 2 ;;5.0;Radiology/Nuclear Medicine;**64,77**;Mar 16, 1998;Build 7 3 ;09/25/06 KAM/BAY Remedy Call 154793 PATCH *77 RVU with 0 value 4 ; and changed CPT calls from ^ICPTCOD to ^RACPTMSC 5 ; eliminating the need for IA's 1995 amd 1996 6 ;03/28/07 KAM/BAY Remedy Call 179232 Patch RA*5*77 7 ; Add check to see if current RVU data is available and if 8 ; not use previous year RVU data 9 ; 10 ;DBIA#:4799 ($$RVU^FBRVU) return wRVU value for CPT, CPT Mod, & exam 11 ; date/time 12 ;DBIA#:10060 EN1^RASELCT enacts 10060 which allows lookups on the NEW 13 ; PERSON (#200) file 14 ;DBIA#:10063 ($$S^%ZTLOAD) 15 ;DBIA#:10103 ($$FMTE^XLFDT) & ($$NOW^XLFDT) 16 ;DBIA#:10104 ($$CJ^XLFSTR) 17 ;DBIA#:1519 ($$EN^XUTMDEVQ) 18 ;DBIA#:4432 (LASTCY^FBAAFSR) return last calendar year file 19 ; 162.99 was updated 20 ; 21 EN(RASCLD) ;Identifies the option that the user wishes to execute. 22 ;input: RASCLD=zero for non-scaled wRVU, & one for the scaled wRVU 23 ; report. 24 ; 25 K ^TMP($J,"RA STFPHYS"),^TMP("RA STFPHYS-IEN",$J) 26 ; 27 PHYST ;allow the user to select one/many/all physicians 28 ;(w/ staff classification) ;DBIA#: 10060 29 S RADIC="^VA(200,",RADIC(0)="QEAMZ",RAUTIL="RA STFPHYS" 30 S RADIC("A")="Select Physician: ",RADIC("B")="All" 31 S RADIC("S")="I $D(^VA(200,""ARC"",""S"",+Y))\10" 32 W !! D EN1^RASELCT(.RADIC,RAUTIL) K %W,%Y1,DIC,RADIC,RAUTIL,X,Y 33 ;did the user select physicians to compile data on? if not, quit 34 I $O(^TMP($J,"RA STFPHYS",""))="" D Q 35 .W !!?3,$C(7),"Staff Physician data was not selected." 36 .Q 37 ; 38 ;build a new staff physician array (the other array is subscripted by 39 ;physician name then IEN) subscripting by staff physician IEN this 40 ;allows us to check the IEN of the staff physician selected by the 41 ;user against the IEN of the staff physician on the exam record 42 S X="" F S X=$O(^TMP($J,"RA STFPHYS",X)) Q:X="" D 43 .S Y=0 44 .F S Y=$O(^TMP($J,"RA STFPHYS",X,Y)) Q:'Y S ^TMP("RA STFPHYS-IEN",$J,Y)="" 45 .Q 46 ; 47 K ^TMP($J,"RA STFPHYS") S RADATE=$$FMTE^XLFDT($$NOW^XLFDT\1,1) 48 ; 49 STRTDT ;Prompt the user for the starting verified date 50 S RASTART=$$STRTDT^RAWKLU1(RADATE,2110101) 51 I RASTART=-1 D XIT Q 52 S RABGDTI=$P(RASTART,U),RABGDTX=$P(RASTART,U,2),RAMBGDT=RABGDTI-.0001 53 ;need inv. verified date to search ^RARPT("AA", 54 S RAMBGDT=9999999.9999-RABGDTI 55 K RASTART 56 ; 57 ENDDT ;Prompt the user for the ending verified date 58 S RAEND=$$ENDDT^RAWKLU1(RABGDTI,RABGDTX) 59 I RAEND=-1 D XIT Q 60 S RAENDTI=$P(RAEND,U),RAENDTX=$P(RAEND,U,2),RAMENDT=RAENDTI+.9999 61 ;need inv. verified date to search ^RARPT("AA", 62 S RAMENDT=9999999.9999-RAMENDT 63 K RAEND 64 ; 65 F I="^TMP(""RA STFPHYS-IEN"",$J,","RADATE","RAB*","RAM*","RAE*","RASCLD" S ZTSAVE(I)="" 66 S I="RA print procedures, wRVUs, and their totals for a physician" 67 D EN^XUTMDEVQ("START^RAWKLU2",I,.ZTSAVE,,1) 68 I +$G(ZTSK)>0 W !!,"Task Number: "_ZTSK,! 69 K I,ZTSAVE,ZTSK 70 Q 71 ; 72 START ;check exams based on criteria input by user; physician & exam D/T 73 ;eliminate the exam record is one of the following conditions is true: 74 ;1-the status of the exam is 'Cancelled' 75 ;2-the physician(s) selected are not the primary staff for the exam 76 ; 77 S:$D(ZTQUEUED)#2 ZTREQ="@" 78 K ^TMP($J,"RA BY STFPHYS") 79 ;03/28/07 KAM/BAY Remedy Call 179232 Added RACYFLG to next line 80 S RARPTVDT=RAMBGDT,(RACNT,RAXIT,RACYFLG)=0 81 ;03/28/07 KAM/BAY RA*5*77/179232 Added Fee Basis Data Check 82 D CHKCY 83 F S RARPTVDT=$O(^RARPT("AA",RARPTVDT),-1) Q:'RARPTVDT!(RARPTVDT<RAMENDT) D Q:RAXIT 84 .S RARPTIEN=0 85 .F S RARPTIEN=$O(^RARPT("AA",RARPTVDT,RARPTIEN)) Q:'RARPTIEN D Q:RAXIT 86 ..S RARPT=$G(^RARPT(RARPTIEN,0)),RADFN=+$P(RARPT,U,2),RADTE=+$P(RARPT,U,3) 87 ..S RADTI=9999999.9999-RADTE,RA7002=$G(^RADPT(RADFN,"DT",RADTI,0)) 88 ..S RAXAMDT=+$P(RA7002,U) Q:'RAXAMDT 89 ..;must check every exam registered for this exam date/time; we might have a printset 90 ..S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D XAM 91 ..Q 92 .Q 93 D EN^RAWKLU3 ;output the report 94 D XIT 95 Q 96 ; 97 XAM ; get exam information; procedure name, exam status order #, int. staff phys... 98 S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q:'RA7003 99 Q:$P(RA7003,U,17)'=RARPTIEN ;exam references a different report! 100 S RAPRCIEN=+$P(RA7003,U,2) Q:'RAPRCIEN 101 S RAPRCIEN(0)=$P($G(^RAMIS(71,RAPRCIEN,0)),U) Q:RAPRCIEN(0)="" 102 S RACNT=RACNT+1 103 ; 104 ;did the user stop the task? Check every five hundred records... 105 S:RACNT#500=0 (RAXIT,ZTSTOP)=$$S^%ZTLOAD() Q:RAXIT 106 ; 107 ;1-begin exam status check 108 Q:$P($G(^RA(72,+$P(RA7003,U,3),0)),U,3)=0 ;cancelled... 109 ;end exam status check 110 ; 111 ;2-begin physician check 112 Q:'$P(RA7003,U,15) ;no physician, quit check 113 Q:'$D(^TMP("RA STFPHYS-IEN",$J,$P(RA7003,U,15)))#2 114 ;end physician check 115 ; 116 S RACPT=$P($G(^RAMIS(71,+$P(RA7003,U,2),0)),U,9) Q:'RACPT ;ptr to file #81 117 ; 118 ; 09/27/2006 KAM/BAY Patch RA*5*77 Changed next line to use ^RACPTMSC 119 S RACPT=$P($$NAMCODE^RACPTMSC(RACPT,RAXAMDT),U,1) ;CPT code is 1st pc 120 ; 121 S RASTF=$$EXTERNAL^DILFD(70.03,15,,$P(RA7003,U,15)) 122 D SETARRY K RA7003,RACPT,RAPRCIEN,RASTF 123 Q 124 ; 125 SETARRY ;find the wRVU value (either un-scaled or scaled) for a particular CPT 126 ;or CPT code/CPT modifier combination. The case identifiers, CPT code 127 ;(RACPT), & exam date (RAXAMDT) are known. 128 ; 129 ;get CPT code modifier string 130 S RACPTMOD="",RABILAT=0 131 I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0))>0 S RAI=0 D 132 .F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI)) Q:'RAI D 133 ..S RACPTMOD(0)=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI,0)) 134 ..;09/27/2006 KAM/BAY RA*5*77 Changed next line to use ^RACPTMSC 135 ..S RA813(0)=$$BASICMOD^RACPTMSC(RACPTMOD(0),RAXAMDT) 136 ..I 'RABILAT,$P(RA813(0),U,2)=50 S RABILAT=1 ;bilateral multiplier=2 137 ..S RACPTMOD=RACPTMOD_$P(RA813(0),U,2)_"," 138 ..Q 139 .Q 140 ;get wRVU value from FEE BASIS; returns a string: status^value^message 141 ;where status'=1 means "in error". All exams prior to 1/1/1999 will use 142 ;1999 wRVU values for their calculations. 143 ;03/28/2007 KAM/BAY Rem Call 179232 Added RACYFLG to $S in next line 144 S RAWRVU=$$RVU^FBRVU(RACPT,RACPTMOD,$S(RAXAMDT<2990101:2990101,RACYFLG:RAXAMDT-10000,1:RAXAMDT)) 145 ;09/27/2006 KAM/BAY RA*5*77 Remedy Call 154793 146 I $P(RAWRVU,U,2)=0,RACPTMOD="" D 147 . S RAWRVU=$$RVU^FBRVU(RACPT,26,$S(RAXAMDT<2990101:2990101,RACYFLG:RAXAMDT-10000,1:RAXAMDT)) 148 I $P(RAWRVU,U)=1 D 149 .;apply bilateral multiplier if appropriate 150 .S:RABILAT RAWRVU=$P(RAWRVU,U,2)*2 151 .;or not... 152 .S:'RABILAT RAWRVU=$P(RAWRVU,U,2) 153 .I RASCLD S RAWRVU=RAWRVU*$$SFCTR^RAWRVUP($P(RA7002,U,2),RAXAMDT) 154 .Q 155 ; 156 E S RAWRVU=0 ;status some other value than 1; "in error" 157 S:RAWRVU>0 RAWRVU=$J(RAWRVU,1,2) ;do not round the value... 158 ; 159 ;^TMP($J,"RA BY STFPHYS",RASTF)=total # procedures^wRVU total(all proc) 160 ;^TMP($J,"RA BY STFPHYS",RASTF,RACPT,RAWRVU,RAPRCIEN(0))=^total # RACPT^ 161 ; total # RAWRVU 162 ; 163 S:'$D(^TMP($J,"RA BY STFPHYS",RASTF))#2 ^(RASTF)="0^0" 164 S $P(^TMP($J,"RA BY STFPHYS",RASTF),U)=$P(^TMP($J,"RA BY STFPHYS",RASTF),U)+1 165 S $P(^TMP($J,"RA BY STFPHYS",RASTF),U,2)=$P(^TMP($J,"RA BY STFPHYS",RASTF),U,2)+RAWRVU 166 S:'$D(^TMP($J,"RA BY STFPHYS",RASTF,RACPT,RAWRVU,RAPRCIEN(0)))#2 ^(RAPRCIEN(0))="^0^0" 167 S $P(^TMP($J,"RA BY STFPHYS",RASTF,RACPT,RAWRVU,RAPRCIEN(0)),U,2)=+$P($G(^TMP($J,"RA BY STFPHYS",RASTF,RACPT,RAWRVU,RAPRCIEN(0))),U,2)+1 168 S $P(^TMP($J,"RA BY STFPHYS",RASTF,RACPT,RAWRVU,RAPRCIEN(0)),U,3)=RAWRVU*(+$P(^TMP($J,"RA BY STFPHYS",RASTF,RACPT,RAWRVU,RAPRCIEN(0)),U,2)) 169 ; 170 K RA813,RABILAT,RACPTMOD,RAI,RAWRVU 171 Q 172 ; 173 XIT ;kill variables and exit 174 W:$G(ZTSTOP)=1 !,$$CJ^XLFSTR("USER STOPPED PROCESS THROUGH TASKMAN",IOM) 175 K DIR,DIROUT,DIRUT,DTOUT,DUOUT,RA7002,RABGDTI,RABGDTX,RACNI,RACNT,RADATE 176 K RADFN,RADTE,RADTI,RAENDTI,RAENDTX,RAMBGDT,RAMENDT,RAQUIT,RARPT,RARPTIEN 177 K RARPTVDT,RAXAMDT,RAXIT,X,Y,RACYFLG 178 K ^TMP("RA STFPHYS-IEN",$J),^TMP($J,"RA BY STFPHYS") 179 Q 180 ; 181 CHKCY ;03/28/2007 KAM/BAY RA*5*77 Remedy Call 179232 Check for latest RVU 182 ;data from Fee Basis 183 ; 184 S RACYFLG=0,Y=$G(DT) D DD^%DT 185 I $$LASTCY^FBAAFSR()<$P(Y," ",3) S RACYFLG=1 186 Q
Note:
See TracChangeset
for help on using the changeset viewer.
