Changeset 636 for FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA
- Timestamp:
- Dec 4, 2009, 8:26:01 PM (14 years ago)
- Location:
- FOIAVistA/tag/r
- Files:
-
- 44 edited
- 1 copied
-
. (copied) (copied from FOIAVistA/trunk/r )
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE1.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE2.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE3.m (modified) (3 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE4.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE5.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE6.m (modified) (2 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE.m (modified) (3 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE1.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE2.m (modified) (2 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE3.m (modified) (7 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE4.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG1.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG10.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG11.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG2.m (modified) (3 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG3.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG4.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG5.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG6.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG7.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG8.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG9.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD2.m (modified) (2 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RADLQ3.m (modified) (2 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO.m (modified) (6 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO1.m (modified) (8 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO2.m (modified) (1 diff)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO3.m (modified) (4 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO4.m (modified) (2 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLR.m (modified) (7 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPC.m (modified) (4 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPT.m (modified) (8 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRS1.m (modified) (7 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLTCPB.m (modified) (8 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAMAIN.m (modified) (2 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RO1.m (modified) (2 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RON.m (modified) (2 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1.m (modified) (3 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1A.m (modified) (2 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR.m (modified) (2 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR0.m (modified) (5 diffs)
-
RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL1.m (modified) (6 diffs)
Legend:
- Unmodified
- Added
- Removed
-
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE.m
r628 r636 1 RACTOE ; GENERATED FROM 'RA ORDER EXAM' INPUT TEMPLATE(#1087), FILE 75.1; 05/26/081 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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE1.m
r628 r636 1 RACTOE1 ; ; 05/26/081 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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE2.m
r628 r636 1 RACTOE2 ; ; 05/26/081 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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE3.m
r628 r636 1 RACTOE3 ; ; 05/26/081 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(1 0)=% S %=$P(%Z,U,9) S:%]"" DE(16)=% S %=$P(%Z,U,12) S:%]"" DE(21)=% S %=$P(%Z,U,13) S:%]"" DE(27)=% S %=$P(%Z,U,14) S:%]"" DE(9)=% S %=$P(%Z,U,17) S:%]"" DE(31)=% S %=$P(%Z,U,22) S:%]"" DE(18)=%5 I $D(^("R")) S %Z=^("R") S %=$P(%Z,U,1) S:%]"" DE( 13)=%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)=% 6 6 K %Z Q 7 7 ; … … 80 80 G RD:X="@",Z 81 81 X9 Q 82 10 S DW="0;4",DV="SX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4 82 10 S DQ=11 ;@20 83 11 S DW="0;4",DV="SX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4 83 84 S DU="I:INPATIENT;O:OUTPATIENT;C:CONTRACT;S:SHARING;E:EMPLOYEE;R:RESEARCH;" 84 85 S X=RACAT 85 86 S Y=X 86 87 G Y 87 X1 0Q88 1 1 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^DIE1789 X1 1 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") 90 91 Q 91 12 S DQ=13 ;@30 92 13 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 93 123 S X=$S($D(RARSH):RARSH,1:"") 94 124 S Y=X 95 125 G Y 96 X 13K:$L(X)>40!($L(X)<3) X126 X24 K:$L(X)>40!($L(X)<3) X 97 127 I $D(X),X'?.ANP K X 98 128 Q 99 129 ; 100 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^DIE17101 X 14S 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" 102 132 Q 103 15 S DQ=16;@40104 16S 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 105 135 S DU="DIC(34," 106 136 S X=$S($D(RASHA):RASHA,1:"") 107 137 S Y=X 108 138 G Y 109 X 16S 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 110 140 Q 111 141 ; 112 17 S DQ=18 ;@50 113 18 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" 114 154 S DU="SC(" 115 155 S X=RALIFN … … 117 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) 118 158 G RD:X="@",Z 119 X18 Q 120 19 S DQ=20 ;@100 121 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 122 X20 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" 123 168 Q 124 21 S DW="0;12",DV="D",DU="",DLB="PRE-OP SCHEDULED DATE (TIME optional)",DIFLD=12 125 S X="TODAY" 126 S Y=X 127 G Y 128 X21 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 129 Q 130 ; 131 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 132 X22 S:$D(RAEXMUL) RAPREOP1=X 133 Q 134 23 S DQ=24 ;@120 135 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 136 X24 I RASEX="M" S Y="@130" 137 Q 138 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 139 X25 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" 140 Q 141 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 142 X26 S RASEX="F" 143 Q 144 27 S DW="0;13",DV="RS",DU="",DLB="PREGNANT",DIFLD=13 145 S DU="y:YES;n:NO;u:UNKNOWN;" 146 S X=$S($D(RAPREG):$$EXTERNAL^DILFD(75.1,13,"",RAPREG),1:"") 147 S Y=X 148 G Y 149 X27 Q 150 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 151 X28 S RAPREG=X 152 Q 153 29 S DQ=30 ;@130 154 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 155 X30 I '$D(RAVSTFLG)!('$D(RAVLEDTI)) S Y="@135" 156 Q 157 31 S DW="0;17",DV="D",DU="",DLB="PAST VISIT DATE/TIME",DIFLD=17 158 S X=9999999.9999-RAVLEDTI 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 X31 S %DT="TXR" D ^%DT S X=Y K:Y<1 X 163 Q 164 ; 165 32 S DQ=33 ;@135 166 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 167 X33 S:$D(RAWHEN)#2 Y="@145" 168 Q 169 34 D:$D(DG)>9 F^DIE17 G ^RACTOE4 169 35 D:$D(DG)>9 F^DIE17 G ^RACTOE6 -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE4.m
r628 r636 1 RACTOE4 ; ;05/26/08 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(8)=% S %=$P(%Z,U,6) S:%]"" DE(18)=% S %=$P(%Z,U,18) S:%]"" DE(9)=% S %=$P(%Z,U,19) S:%]"" DE(14)=% S %=$P(%Z,U,20) S:%]"" DE(26)=% S %=$P(%Z,U,21) S:%]"" DE(1)=%,DE(5)=% 5 I S %=$P(%Z,U,24) S:%]"" DE(16)=% S %=$P(%Z,U,26) S:%]"" DE(21)=% 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="RACTOE4",DQ=1 53 1 S DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21 54 S DE(DW)="C1^RACTOE4" 55 G RE 56 C1 G C1S:$D(DE(1))[0 K DB 57 S X=DE(1),DIC=DIE 58 K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA) 59 C1S S X="" G:DG(DQ)=X C1F1 K DB 60 S X=DG(DQ),DIC=DIE 61 S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)="" 62 C1F1 Q 63 X1 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 64 Q 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="@150" 68 Q 69 3 S DQ=4 ;@145 70 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 G A 71 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21 72 S DE(DW)="C5^RACTOE4" 73 S X=RAWHEN 74 S Y=X 75 G Y 76 C5 G C5S:$D(DE(5))[0 K DB 77 S X=DE(5),DIC=DIE 78 K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA) 79 C5S S X="" G:DG(DQ)=X C5F1 K DB 80 S X=DG(DQ),DIC=DIE 81 S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)="" 82 C5F1 Q 83 X5 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 84 Q 85 ; 86 6 S DQ=7 ;@150 87 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 88 X7 S:$D(RAEXMUL)#2 RAWHEN=$$FMTE^XLFDT(X,1) 89 Q 90 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;5",DV="SX",DU="",DLB="REQUEST STATUS",DIFLD=5 91 S DE(DW)="C8^RACTOE4" 92 S DU="1:DISCONTINUED;2:COMPLETE;3:HOLD;5:PENDING;6:ACTIVE;8:SCHEDULED;11:UNRELEASED;" 93 S X=$S($D(RAPKG):5,$$ORVR^RAORDU()=2.5:11,1:5) 94 S Y=X 95 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) 96 G RD:X="@",Z 97 C8 G C8S:$D(DE(8))[0 K DB 98 S X=DE(8),DIC=DIE 99 K ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA) 100 S X=DE(8),DIC=DIE 101 ; 102 C8S S X="" G:DG(DQ)=X C8F1 K DB 103 S X=DG(DQ),DIC=DIE 104 S ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)="" 105 S X=DG(DQ),DIC=DIE 106 D:$$ORVR^RAORDU()=2.5&((X=1)!(X=3)) CH^RADD2(DA,X) 107 C8F1 Q 108 X8 Q 109 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;18",DV="D",DU="",DLB="LAST ACTIVITY DATE/TIME",DIFLD=18 110 S DE(DW)="C9^RACTOE4" 111 S X="NOW" 112 S Y=X 113 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) 114 G RD 115 C9 G C9S:$D(DE(9))[0 K DB 116 S X=DE(9),DIC=DIE 117 K ^RAO(75.1,"AO",$E(X,1,30),DA) 118 C9S S X="" G:DG(DQ)=X C9F1 K DB 119 S X=DG(DQ),DIC=DIE 120 S ^RAO(75.1,"AO",$E(X,1,30),DA)="" 121 C9F1 Q 122 X9 S %DT="TXR" D ^%DT S X=Y K:Y<1 X 123 Q 124 ; 125 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 126 X10 S Y=$S('$D(^RA(79,+RADIV,.1)):"@160",$P(^(.1),"^",19)="y":"@155",1:"@160") 127 Q 128 11 S DQ=12 ;@155 129 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,D=0 K DE(1) ;75 130 S DIFLD=75,DGO="^RACTOE5",DC="4^75.12DA^T^",DV="75.12D",DW="0;1",DOW="STATUS CHANGE DATE/TIME",DLB="Select "_DOW S:D DC=DC_D 131 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 M12 132 S D=$S($D(^RAO(75.1,DA,"T",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 133 M12 I D>0 S DC=DC_D I $D(^RAO(75.1,DA,"T",+D,0)) S DE(12)=$P(^(0),U,1) 134 S X="""NOW""" 135 S Y=X 136 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) 137 G RD 138 R12 D DE 139 G A 140 ; 141 13 S DQ=14 ;@160 142 14 S DW="0;19",DV="S",DU="",DLB="MODE OF TRANSPORT",DIFLD=19 143 S DU="a:AMBULATORY;p:PORTABLE;s:STRETCHER;w:WHEEL CHAIR;" 144 S X=$S($D(RAMT):$P(RAMT,"^",2),1:"AMBULATORY") 145 S Y=X 146 G Y 147 X14 Q 148 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 149 X15 S:$D(RAEXMUL) RAMT=X 150 Q 151 16 S DW="0;24",DV="S",DU="",DLB="IS PATIENT ON ISOLATION PROCEDURES?",DIFLD=24 152 S DU="y:YES;n:NO;" 153 S X="NO" 154 S Y=X 155 G Y 156 X16 Q 157 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 158 X17 S:$D(RAEXMUL) RAIP=X 159 Q 160 18 S DW="0;6",DV="S",DU="",DLB="REQUEST URGENCY",DIFLD=6 161 S DU="1:STAT;2:URGENT;9:ROUTINE;" 162 S X="ROUTINE" 163 S Y=X 164 G Y 165 X18 Q 166 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 167 X19 S:$D(RAEXMUL) RARU=X 168 Q 169 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 170 X20 S:$$ORVR^RAORDU()<3 Y="@163" 171 Q 172 21 S DW="0;26",DV="S",DU="",DLB="NATURE OF (NEW) ORDER ACTIVITY",DIFLD=26 173 S DU="w:WRITTEN;v:VERBAL;p:TELEPHONED;s:SERVICE CORRECTION;i:POLICY;e:PHYSICIAN ENTERED;" 174 S X="SERVICE CORRECTION" 175 S Y=X 176 G Y 177 X21 Q 178 22 S DQ=23 ;@163 179 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 180 X23 W ! 181 Q 182 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 183 X24 S RAREQLOC=$$ILOC^RAUTL18(RAPRI) 184 Q 185 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 186 X25 I 'RAREQLOC S Y="@165" 187 Q 188 26 S DW="0;20",DV="*P79.1'",DU="",DLB="IMAGING LOCATION",DIFLD=20 189 S DU="RA(79.1," 190 S X=RAREQLOC 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 X26 Q 195 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 196 X27 S Y="@170" 197 Q 198 28 S DQ=29 ;@165 199 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 200 X29 I '$D(RALOCFLG) S Y="@175" 201 Q 202 30 D:$D(DG)>9 F^DIE17 G ^RACTOE6 1 RACTOE4 ; ;12/27/07 2 S X=DE(32),DIIX=2_U_DIFLD D AUDIT^DIET -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE5.m
r628 r636 1 RACTOE5 ; ;05/26/08 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="RACTOE5",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 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 -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE6.m
r628 r636 1 RACTOE6 ; ; 05/26/081 RACTOE6 ; ;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, 20) S:%]"" DE(1)=%4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(21)=% S %=$P(%Z,U,12) S:%]"" DE(1)=% S %=$P(%Z,U,13) S:%]"" DE(7)=% S %=$P(%Z,U,17) S:%]"" DE(11)=% S %=$P(%Z,U,18) S:%]"" DE(22)=% S %=$P(%Z,U,21) S:%]"" DE(15)=%,DE(18)=% 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="RACTOE6",DQ=1 52 1 S DW="0;20",DV="*P79.1'R",DU="",DLB="SUBMIT REQUEST TO",DIFLD=20 53 S DU="RA(79.1," 54 G RE 55 X1 S DIC("S")="I $$SUBMIT^RAUTL13(DA,+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 52 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;12",DV="D",DU="",DLB="PRE-OP SCHEDULED DATE (TIME optional)",DIFLD=12 53 S X="TODAY" 54 S Y=X 55 G Y 56 X1 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 56 57 Q 57 58 ; 58 2 S DQ=3 ;@170 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:$D(RAEXMUL) RAILOC=X 59 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 60 X2 S:$D(RAEXMUL) RAPREOP1=X 61 61 Q 62 4 S DQ=5 ;@175 62 3 S DQ=4 ;@120 63 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 64 X4 I RASEX="M" S Y="@130" 65 Q 63 66 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 64 X5 S (RAFIN,RAFIN1)=""67 X5 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" 65 68 Q 66 6 S DQ=7 ;@999 67 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 68 X7 K RAI,RAPRI,RAMOD,RAIMAG,RAWPFLAG,RAREQLOC,RAMODPRO 69 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 70 X6 S RASEX="F" 69 71 Q 70 8 G 0^DIE17 72 7 S DW="0;13",DV="RS",DU="",DLB="PREGNANT",DIFLD=13 73 S DU="y:YES;n:NO;u:UNKNOWN;" 74 S X=$S($D(RAPREG):$$EXTERNAL^DILFD(75.1,13,"",RAPREG),1:"") 75 S Y=X 76 G Y 77 X7 Q 78 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 79 X8 S RAPREG=X 80 Q 81 9 S DQ=10 ;@130 82 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 83 X10 I '$D(RAVSTFLG)!('$D(RAVLEDTI)) S Y="@135" 84 Q 85 11 S DW="0;17",DV="D",DU="",DLB="PAST VISIT DATE/TIME",DIFLD=17 86 S X=9999999.9999-RAVLEDTI 87 S Y=X 88 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) 89 G RD 90 X11 S %DT="TXR" D ^%DT S X=Y K:Y<1 X 91 Q 92 ; 93 12 S DQ=13 ;@135 94 13 S DQ=14 ;@140 95 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 96 X14 S:$D(RAWHEN)#2 Y="@145" 97 Q 98 15 S DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21 99 S DE(DW)="C15^RACTOE6" 100 G RE 101 C15 G C15S:$D(DE(15))[0 K DB 102 S X=DE(15),DIC=DIE 103 K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA) 104 C15S S X="" G:DG(DQ)=X C15F1 K DB 105 S X=DG(DQ),DIC=DIE 106 S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)="" 107 C15F1 Q 108 X15 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 109 Q 110 ; 111 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 112 X16 S Y="@150" 113 Q 114 17 S DQ=18 ;@145 115 18 D:$D(DG)>9 F^DIE17,DE S DQ=18,DW="0;21",DV="D",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21 116 S DE(DW)="C18^RACTOE6" 117 S X=RAWHEN 118 S Y=X 119 G Y 120 C18 G C18S:$D(DE(18))[0 K DB 121 S X=DE(18),DIC=DIE 122 K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA) 123 C18S S X="" G:DG(DQ)=X C18F1 K DB 124 S X=DG(DQ),DIC=DIE 125 S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)="" 126 C18F1 Q 127 X18 S %DT="ETX" D ^%DT S X=Y K:Y<1 X 128 Q 129 ; 130 19 S DQ=20 ;@150 131 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 132 X20 S:$D(RAEXMUL)#2 RAWHEN=$$FMTE^XLFDT(X,1) 133 Q 134 21 D:$D(DG)>9 F^DIE17,DE S DQ=21,DW="0;5",DV="SX",DU="",DLB="REQUEST STATUS",DIFLD=5 135 S DE(DW)="C21^RACTOE6" 136 S DU="1:DISCONTINUED;2:COMPLETE;3:HOLD;5:PENDING;6:ACTIVE;8:SCHEDULED;11:UNRELEASED;" 137 S X=$S($D(RAPKG):5,$$ORVR^RAORDU()=2.5:11,1:5) 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 C21 G C21S:$D(DE(21))[0 K DB 142 S X=DE(21),DIC=DIE 143 K ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA) 144 S X=DE(21),DIC=DIE 145 ; 146 C21S S X="" G:DG(DQ)=X C21F1 K DB 147 S X=DG(DQ),DIC=DIE 148 S ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)="" 149 S X=DG(DQ),DIC=DIE 150 D:$$ORVR^RAORDU()=2.5&((X=1)!(X=3)) CH^RADD2(DA,X) 151 C21F1 Q 152 X21 Q 153 22 D:$D(DG)>9 F^DIE17,DE S DQ=22,DW="0;18",DV="D",DU="",DLB="LAST ACTIVITY DATE/TIME",DIFLD=18 154 S DE(DW)="C22^RACTOE6" 155 S X="NOW" 156 S Y=X 157 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) 158 G RD 159 C22 G C22S:$D(DE(22))[0 K DB 160 S X=DE(22),DIC=DIE 161 K ^RAO(75.1,"AO",$E(X,1,30),DA) 162 C22S S X="" G:DG(DQ)=X C22F1 K DB 163 S X=DG(DQ),DIC=DIE 164 S ^RAO(75.1,"AO",$E(X,1,30),DA)="" 165 C22F1 Q 166 X22 S %DT="TXR" D ^%DT S X=Y K:Y<1 X 167 Q 168 ; 169 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 170 X23 S Y=$S('$D(^RA(79,+RADIV,.1)):"@160",$P(^(.1),"^",19)="y":"@155",1:"@160") 171 Q 172 24 S DQ=25 ;@155 173 25 D:$D(DG)>9 F^DIE17,DE S DQ=25,D=0 K DE(1) ;75 174 S DIFLD=75,DGO="^RACTOE7",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 M25 176 S D=$S($D(^RAO(75.1,DA,"T",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 177 M25 I D>0 S DC=DC_D I $D(^RAO(75.1,DA,"T",+D,0)) S DE(25)=$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 R25 D DE 183 G A 184 ; 185 26 S DQ=27 ;@160 186 27 D:$D(DG)>9 F^DIE17 G ^RACTOE8 -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE.m
r628 r636 1 RACTQE ; GENERATED FROM 'RA QUICK EXAM ORDER' INPUT TEMPLATE(#1086), FILE 75.1; 05/26/081 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(2 6)=% S %=$P(%Z,U,8) S:%]"" DE(14)=%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)=% 5 5 K %Z Q 6 6 ; … … 153 153 Q 154 154 25 S DQ=26 ;@35 155 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 156 159 S DU="I:INPATIENT;O:OUTPATIENT;C:CONTRACT;S:SHARING;E:EMPLOYEE;R:RESEARCH;" 157 160 S X=$E(RACAT) … … 159 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) 160 163 G RD:X="@",Z 161 X2 6Q162 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^DIE17163 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" 164 167 Q 165 2 8D:$D(DG)>9 F^DIE17 G ^RACTQE2168 29 D:$D(DG)>9 F^DIE17 G ^RACTQE2 -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE1.m
r628 r636 1 RACTQE1 ; ; 05/26/081 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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE2.m
r628 r636 1 RACTQE2 ; ; 05/26/081 RACTQE2 ; ;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,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(1 4)=%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 5 I $D(^(.1)) S %Z=^(.1) S %=$P(%Z,U,1) S:%]"" DE(7)=% 6 6 K %Z Q … … 103 103 ; 104 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 Y="@560"105 X12 S RAWHEN=$$FMTE^XLFDT(X,1) 106 106 Q 107 13 S DQ=14 ;@550 108 14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21 109 S DE(DW)="C14^RACTQE2" 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" 110 113 S X=RAWHEN 111 114 S Y=X 112 G Y 113 C14 G C14S:$D(DE(14))[0 K DB 114 S X=DE(14),DIC=DIE 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 115 119 K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA) 116 C1 4S S X="" G:DG(DQ)=X C14F1 K DB120 C15S S X="" G:DG(DQ)=X C15F1 K DB 117 121 S X=DG(DQ),DIC=DIE 118 122 S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)="" 119 C1 4F1 Q120 X1 4 S %DT="ETX" D ^%DT S X=Y K:Y<1 X123 C15F1 Q 124 X15 S %DT="TX" D ^%DT S X=Y K:Y<1 X 121 125 Q 122 126 ; 123 15 S DQ=16 ;@560 124 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 125 X16 S:$D(RAEXMUL)#2 RAWHEN=$$FMTE^XLFDT(X,1) 126 Q 127 16 S DQ=17 ;@560 127 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 128 129 X17 I $S('$D(RAILOC):1,'RAILOC:1,1:0) S Y="@60" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE3.m
r628 r636 1 RACTQE3 ; ; 05/26/081 RACTQE3 ; ;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,5) S:%]"" DE( 3)=% S %=$P(%Z,U,6) S:%]"" DE(11)=% S %=$P(%Z,U,14) S:%]"" DE(1)=% S %=$P(%Z,U,18) S:%]"" DE(4)=% S %=$P(%Z,U,19) S:%]"" DE(7)=% S %=$P(%Z,U,22) S:%]"" DE(2)=% S %=$P(%Z,U,24) S:%]"" DE(9)=%5 I S %=$P(%Z,U,26) S:%]"" DE(1 3)=%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 6 K %Z Q 7 7 ; … … 58 58 G RD:X="@",Z 59 59 X1 Q 60 2 S DW="0;22",DV="P44'",DU="",DLB="REQUESTING LOCATION",DIFLD=22 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" 61 74 S DU="SC(" 62 75 S X=RALIFN … … 64 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) 65 78 G RD:X="@",Z 66 X2 Q 67 3 S DW="0;5",DV="SX",DU="",DLB="REQUEST STATUS",DIFLD=5 68 S DE(DW)="C3^RACTQE3" 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" 69 87 S DU="1:DISCONTINUED;2:COMPLETE;3:HOLD;5:PENDING;6:ACTIVE;8:SCHEDULED;11:UNRELEASED;" 70 88 S X=$S($D(RAPKG):5,$$ORVR^RAORDU()=2.5:11,1:5) … … 72 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) 73 91 G RD:X="@",Z 74 C 3 G C3S:$D(DE(3))[0 K DB75 S X=DE( 3),DIC=DIE92 C7 G C7S:$D(DE(7))[0 K DB 93 S X=DE(7),DIC=DIE 76 94 K ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA) 77 S X=DE( 3),DIC=DIE95 S X=DE(7),DIC=DIE 78 96 ; 79 C 3S S X="" G:DG(DQ)=X C3F1 K DB97 C7S S X="" G:DG(DQ)=X C7F1 K DB 80 98 S X=DG(DQ),DIC=DIE 81 99 S ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)="" 82 100 S X=DG(DQ),DIC=DIE 83 101 D:$$ORVR^RAORDU()=2.5&((X=1)!(X=3)) CH^RADD2(DA,X) 84 C 3F1 Q85 X 3Q86 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;18",DV="D",DU="",DLB="LAST ACTIVITY DATE/TIME",DIFLD=1887 S DE(DW)="C 4^RACTQE3"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" 88 106 S X="NOW" 89 107 S Y=X 90 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) 91 109 G RD 92 C 4 G C4S:$D(DE(4))[0 K DB93 S X=DE( 4),DIC=DIE110 C8 G C8S:$D(DE(8))[0 K DB 111 S X=DE(8),DIC=DIE 94 112 K ^RAO(75.1,"AO",$E(X,1,30),DA) 95 C 4S S X="" G:DG(DQ)=X C4F1 K DB113 C8S S X="" G:DG(DQ)=X C8F1 K DB 96 114 S X=DG(DQ),DIC=DIE 97 115 S ^RAO(75.1,"AO",$E(X,1,30),DA)="" 98 C 4F1 Q99 X 4S %DT="TXR" D ^%DT S X=Y K:Y<1 X116 C8F1 Q 117 X8 S %DT="TXR" D ^%DT S X=Y K:Y<1 X 100 118 Q 101 119 ; 102 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,D=0 K DE(1) ;75120 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,D=0 K DE(1) ;75 103 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 104 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 M 5122 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 105 123 S D=$S($D(^RAO(75.1,DA,"T",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) 106 M 5 I D>0 S DC=DC_D I $D(^RAO(75.1,DA,"T",+D,0)) S DE(5)=$P(^(0),U,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) 107 125 S X="""NOW""" 108 126 S Y=X 109 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) 110 128 G RD 111 R 5D DE129 R9 D DE 112 130 G A 113 131 ; 114 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^DIE17115 X 6I '$D(RAMT) S RAMT="a"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" 116 134 Q 117 7S DW="0;19",DV="S",DU="",DLB="MODE OF TRANSPORT",DIFLD=19135 11 S DW="0;19",DV="S",DU="",DLB="MODE OF TRANSPORT",DIFLD=19 118 136 S DU="a:AMBULATORY;p:PORTABLE;s:STRETCHER;w:WHEEL CHAIR;" 119 137 S X=$P(RAMT,"^") … … 121 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) 122 140 G RD:X="@",Z 123 X 7Q124 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^DIE17125 X 8I '$D(RAIP) S RAIP="n"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" 126 144 Q 127 9S DW="0;24",DV="S",DU="",DLB="ISOLATION PROCEDURES",DIFLD=24145 13 S DW="0;24",DV="S",DU="",DLB="ISOLATION PROCEDURES",DIFLD=24 128 146 S DU="y:YES;n:NO;" 129 147 S X=RAIP … … 131 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) 132 150 G RD:X="@",Z 133 X 9Q134 1 0 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^DIE17135 X1 0I '$D(RARU) S RARU=9151 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 136 154 Q 137 1 1S DW="0;6",DV="S",DU="",DLB="REQUEST URGENCY",DIFLD=6155 15 S DW="0;6",DV="S",DU="",DLB="REQUEST URGENCY",DIFLD=6 138 156 S DU="1:STAT;2:URGENT;9:ROUTINE;" 139 157 S X=RARU … … 141 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) 142 160 G RD:X="@",Z 143 X1 1Q144 1 2 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^DIE17145 X1 2S:$$ORVR^RAORDU()<3 Y="@80"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" 146 164 Q 147 1 3S DW="0;26",DV="S",DU="",DLB="NATURE OF (NEW) ORDER ACTIVITY",DIFLD=26165 17 S DW="0;26",DV="S",DU="",DLB="NATURE OF (NEW) ORDER ACTIVITY",DIFLD=26 148 166 S DU="w:WRITTEN;v:VERBAL;p:TELEPHONED;s:SERVICE CORRECTION;i:POLICY;e:PHYSICIAN ENTERED;" 149 167 S Y="s" 150 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) 151 169 G RD:X="@",Z 152 X1 3Q153 1 4 S DQ=15;@80154 1 5 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^DIE17155 X1 5S RAFIN=1170 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 156 174 Q 157 16 S DQ=17;@99158 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^DIE17159 X 17K RAI,RAPRI,RAMOD,RAIMAG,RAREQLOC,RAMODPRO175 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 160 178 Q 161 18G 0^DIE17179 22 G 0^DIE17 -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE4.m
r628 r636 1 RACTQE4 ; ; 05/26/081 RACTQE4 ; ;12/27/07 2 2 D DE G BEGIN 3 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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG.m
r628 r636 1 RACTRG ; GENERATED FROM 'RA REGISTER' INPUT TEMPLATE(#1083), FILE 70; 05/26/081 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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG1.m
r628 r636 1 RACTRG1 ; ; 05/26/081 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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG10.m
r628 r636 1 RACTRG10 ; ; 05/26/081 RACTRG10 ; ;11/06/06 2 2 D DE G BEGIN 3 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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG11.m
r628 r636 1 RACTRG11 ; ; 05/26/081 RACTRG11 ; ;11/06/06 2 2 ;; 3 1 N X,X1,X2 S DIXR=4 75D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X3 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 4 I $G(X(1))]"" D 5 5 . D KRAD^RAPXRM(.X,.DA) -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG2.m
r628 r636 1 RACTRG2 ; ; 05/26/081 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,""))="" … … 106 106 ; 107 107 C8F1 S DIEZRXR(70.03,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) 108 F DIXR=4 75S DIEZRXR(70.03,DIXR)=""108 F DIXR=490 S DIEZRXR(70.03,DIXR)="" 109 109 Q 110 110 X8 S DIC("S")="I $$ACTC^RACPTCSV" X ^DD(70.03,2,9.2) … … 144 144 ; 145 145 C15F1 S DIEZRXR(70.03,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) 146 F DIXR=4 75S DIEZRXR(70.03,DIXR)=""146 F DIXR=490 S DIEZRXR(70.03,DIXR)="" 147 147 Q 148 148 X15 S DIC("S")="I $$ACTC^RACPTCSV" X ^DD(70.03,2,9.2) -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG3.m
r628 r636 1 RACTRG3 ; ; 05/26/081 RACTRG3 ; ;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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG4.m
r628 r636 1 RACTRG4 ; ; 05/26/081 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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG5.m
r628 r636 1 RACTRG5 ; ; 05/26/081 RACTRG5 ; ;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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG6.m
r628 r636 1 RACTRG6 ; ; 05/26/081 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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG7.m
r628 r636 1 RACTRG7 ; ; 05/26/081 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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG8.m
r628 r636 1 RACTRG8 ; ; 05/26/081 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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG9.m
r628 r636 1 RACTRG9 ; ; 05/26/081 RACTRG9 ; ;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,""))="" -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD2.m
r628 r636 1 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 ; 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 8 3 EN1(RAX,RAY) ; Input transform for the .01 field (Procedure) for the Rad/Nuc 9 4 ; Med Common Procedure file i.e, ^RAMIS(71.3 … … 106 101 Q:+$P(RAUTH,"^")&($S('$P(RAUTH,"^",4):1,$P(RAUTH,"^",4)'<RADT:1,1:0)) 1 107 102 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=RACNI112 ; X - the primary diagnostic code value (this field points to file 78.3)113 N RACNI,RADFN,RADTI,RAFDA,RAIENS,RAX114 S RADFN=DA(2),RADTI=DA(1),RACNI=DA,RAX=X ;save the variables just in case115 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 Q119 ; -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADLQ3.m
r628 r636 1 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 2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998 4 3 DISPXAM ; Display exam statuses for selected Imaging Types. These exam 5 4 ; statuses need the 'DELINQUENT STATUS REPORT?' field tripped to … … 50 49 ; Since only inpatient and outpatient is possibly stored, any 51 50 ; 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 line53 S RASSN=$E(RASSN,8,11)54 51 I IOM=132 D ;132 column format 55 52 . W !,RANME,?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT,?RATAB(4) -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO.m
r628 r636 1 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 132 ;;5.0;Radiology/Nuclear Medicine;**4,8,27,55,66**;Mar 16, 1998 3 3 ; 09/07/2005 Remedy call 108405 - KAM Allow Radiology to accept dx codes from Talk Technology 4 ;5 ;Integration Agreements6 ;----------------------7 ;DT^DILF(2054); LOCK^DILF(2054); DEM^VADPT(10061); $$DT^XLFDT(10103)8 ;9 4 EN1 ; Check the validity of the following data globals: 10 5 ; Example: '^TMP("RARPT-REC",$J,RASUB,' where RASUB is a … … 59 54 D DT^DILF("ET",RADATE,.RAVLDT) 60 55 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 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 64 57 I '$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))!(RALONGCN']"") D Q 65 58 . S RAERR="Invalid Exam Date and/or Case Number" … … 79 72 ; check resident and staff 80 73 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)]""74 I +$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT"))!(+$G(^("RASTAFF"))) D Q:$G(RAERR)]"" 82 75 . S X1=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")) 83 76 . I X1 D 84 .. I '$D(^VA(200,"ARC","R",X1)) ,'$D(^VA(200,"ARC","S",X1))S X2=177 .. I '$D(^VA(200,"ARC","R",X1)) S X2=1 85 78 .. 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"79 .. I X2=1 S X3=$E($P($G(^VA(200,X1,0)),"^"),1,20)_" is not class'd as resident" 87 80 .. I X2=2 S X3=$P($G(^VA(200,X1,0)),"^")_"'s INACTIVE DATE is past" 88 81 .. I X2=3 S X3=$P($G(^VA(200,X1,0)),"^")_" is not class'd as resident and past INACTIVE DATE" … … 98 91 . Q 99 92 ; 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 report93 I ($G(RAESIG)]"")!($G(RAVERF)) D VERCHK^RAHLO3 ; check if provider can verify report 101 94 ; if verifier fails checks, 102 95 ; quit only if vendor is non-kurzweil, … … 106 99 K RASECDX ;clear secondary dx array because RAHLO2 may not be called 107 100 ; 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 84109 .I RASTAT="R" S:$D(RATELEDR) ^TMP("RARPT-REC",$J,RASUB,"RADX",1)=RATELEDR Q110 .S:$D(RATELEDF) ^TMP("RARPT-REC",$J,RASUB,"RADX",1)=RATELEDF111 101 D:$D(^TMP("RARPT-REC",$J,RASUB,"RADX")) DIAG^RAHLO2 Q:$D(RAERR) ; DX code check took out - &('$D(RADENDUM)#2) 112 102 ; edit sec Dx codes if they exist for non-addendums … … 119 109 . S:'B RAERR=$$ERR^RAHLO2(A) 120 110 . Q 121 I $G(RATELE),$G(RARPT) D Q:$D(RAERR) ;PATCH 84122 .I $D(^RARPT(RARPT,0)) D LOCK^DILF($NA(^RARPT(RARPT))) E S RAERR="Report: "_$P($G(^RARPT(RARPT,0)),"^")_" Locked on VISTA site" Q123 .L -^RARPT(RARPT)124 I $G(RATELE),$L($G(RATELEPI)),RATELEPI'?10N S RAERR="Incorrect Teleradiologist's NPI: "_RATELEPI Q125 111 D RPTSTAT^RAHLO3 ; determine the status of the report 126 112 D FILE^RAHLO1:'$D(RAERR) -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO1.m
r628 r636 1 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 2 ;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55,66**;Mar 16, 1998 4 3 ; 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 ; 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) 12 7 FILE ;Create Entry in File 74 and File Data 13 8 I '$D(ZTQUEUED) N ZTQUEUED S ZTQUEUED="1^dummy to suppress screen displays in UP2^RAUTL1 and elsewhere" … … 17 12 N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR 18 13 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 report20 I RARPT,$D(^RARPT(RARPT,0)) S RASAV=RARPT D S RARPT=RASAV K RASAV Q:$D(RAERR)G LOCK114 ; 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 21 16 . ; must save off RARPT, RAVERF and other RA* variables because 22 17 . ; 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!18 . ; option. 24 19 . N RADFN,RADTI,RACNI,RARPTSTS,RASSN,RADATE,RALONGCN,RAVERF 25 20 . ; if report isn't a stub report, then consider it being edited … … 30 25 . K ^RARPT(RARPT,"I"),^("R"),^("H") 31 26 . Q 32 ; New report logic @NEW127 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 33 28 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 29 LOCK S I=I+1 L +^RARPT(I):1 I '$T!($D(^RARPT(I)))!($D(^RARPT("B",I))) L -^RARPT(I) G LOCK 36 30 S ^RARPT(I,0)=RALONGCN,RARPT=I,^(0)=$P(^RARPT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1) 37 31 ;if case is member of a print set, then create sub-recs for file #74 … … 39 33 I '$D(RARPTN) N RARPTN S RARPTN=RALONGCN 40 34 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 ; 35 I $D(RAERR) L -^RADPT(RADFN,"DT",RADTI) D KVAR Q ;unlck & clear vars 45 36 LOCK1 I $D(RAESIG) S X=RAESIG,X1=$G(RAVERF),X2=RARPT D EN^XUSHSHP S RAESIG=X 46 37 K DA,DIE,DQ,DR S DA=RARPT,DIE="^RARPT(" … … 53 44 S DR=DR_";8////"_$S($D(RAEDIT):"",1:RADATE) ; reported date 54 45 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 8456 S:$L($G(RATELEPI)) DR=DR_";9.2////"_RATELEPI ;Teleradiologist NPI - Patch 8457 46 S DR=DR_";11////"_$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") ; transcriptionist 58 47 I $G(RAVERF),(RARPTSTS="V") S DR=DR_";17////"_$G(^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE")) ;status changed to 'verified' by … … 63 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 64 53 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) p8469 ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Changed next line to $G70 54 ; 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 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 88 61 ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx 89 62 I $D(RASECDX) D … … 98 71 . Q:'$G(DR) 99 72 . S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN 100 . D LOCKX^RAHLTCPU(.RAERR) ;*2 lE*101 73 . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," 102 74 . D ^DIE K DIE,DA,DR 103 . D LOCKX^RAHLTCPU(.RAERR,1) ;*2 uE*104 75 . Q 105 76 ; … … 146 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 147 118 S RACNI=RACNISAV 119 L -^RADPT(RADFN,"DT",RADTI) ;unlock after pce 17 is set in all cases of this printset 148 120 ;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(RA VERF):RAVERF,$G(RATRANSC):RATRANSC,1:"") D ^DIE K DA,DR,DE,DQ,DIE121 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 150 122 ; use ix^dik to kill before setting xrefs 151 123 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! 124 ; if verfd, update rpt & exam statuses; else, just update exam status 156 125 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 ; 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 164 129 KVAR K RAAB,RAEDIT,RAESIG,RAQUEUED,RARPT,RAHIST 165 130 Q 166 ; -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO2.m
r628 r636 1 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 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 40 24 Q 41 ;42 25 ERR(A) ; Invalid impression/report text message. 43 26 ; Input: 'A' - either "I" for impression, or "R" for report -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO3.m
r628 r636 1 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 ; 2 ;;5.0;Radiology/Nuclear Medicine;**4,81**;Mar 16, 1998;Build 12 8 3 RPTSTAT ; Determine the status to set this report to. 9 4 K RARPTSTS S:$D(RAESIG) RARPTSTS="V" Q:$D(RARPTSTS) 10 5 ; $D(RAESIG)=0 now figure out report status 11 N RASTATS RASTAT=$E($G(^TMP("RARPT-REC",$J,RASUB,"RASTAT")))6 S RASTAT=$E($G(^TMP("RARPT-REC",$J,RASUB,"RASTAT"))) 12 7 I RASTAT="A" S RARPTSTS="V" Q 13 8 I RASTAT]"",("FR"[RASTAT) D 14 9 . S:RASTAT="F" RARPTSTS="V" Q:$D(RARPTSTS) 15 . I $G(RATELE) S RARPTSTS="R" Q ;Always allow 'Released/Unverified' reports for teleradiology16 10 . ; do we allow 'Released/Unverified' reports for this location? 17 11 . S RARPTSTS=$S($P($G(^RA(79.1,RAMLC,0)),"^",17)="Y":"R",1:"D") … … 21 15 ; if still no status, default to draft 22 16 S:'$D(RARPTSTS) RARPTSTS="D" 17 K RASTAT 23 18 Q 24 19 TEXT(X) ; Check if the Impression Text and the Report Text contain … … 47 42 ; If 'No' to any of the above questions, kill RAESIG & set the variable 48 43 ; 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 Q44 I '$D(^VA(200,"ARC","R",+$G(RAVERF))),('$D(^VA(200,"ARC","S",+$G(RAVERF)))) D Q 50 45 . ; neither a resident or staff 51 46 . K RAESIG S RAERR="Provider not classified as resident or staff." 52 47 . Q 53 I $D(^VA(200,"ARC","R",+$G(RAVERF))),('$P(RAMDV,"^",18)) ,'$G(RATELE)D Q48 I $D(^VA(200,"ARC","R",+$G(RAVERF))),('$P(RAMDV,"^",18)) D Q 54 49 . ; residents can't verify reports linked to this division 55 50 . K RAESIG S RAERR="Residents are not permitted to verify reports." 56 51 . Q 57 I '$D(^XUSEC("RA VERIFY",+$G(RAVERF))) ,'$G(RATELE)D Q52 I '$D(^XUSEC("RA VERIFY",+$G(RAVERF))) D Q 58 53 . ; verifier MUST have the RA VERIFY key. 59 54 . K RAESIG S RAERR="Provider does not meet security requirements to verify report." 60 55 . Q 61 I '$G(RATELE),$P($G(^VA(200,+$G(RAVERF),"RA")),"^",3),($P(^("RA"),"^",3)'>$$DT^XLFDT()) D56 I $P($G(^VA(200,+$G(RAVERF),"RA")),"^",3),($P(^("RA"),"^",3)'>$$DT^XLFDT()) D 62 57 . ; Rad/Nuc Med user has been inactivated. 63 58 . K RAESIG S RAERR="Inactive Rad/Nuc Med Classification for Interpreting Physician." 64 59 . Q 65 I '$ G(RATELE),'$S('$D(^VA(200,+$G(RAVERF),"RA")):1,$P(^("RA"),"^")'="Y":1,1:0) D60 I '$S('$D(^VA(200,+$G(RAVERF),"RA")):1,$P(^("RA"),"^")'="Y":1,1:0) D 66 61 . K RAESIG S RAERR="Staff review required to verify report." 67 62 . Q … … 94 89 . I RAVCNT=1,('$D(RAVIEN(RAVCNT))#2) S RAVIEN(RAVCNT)=RAVIEN 95 90 . 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)) 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" 100 94 Q 101 95 ESIG ; Added for COTS E-Sig capability -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO4.m
r628 r636 1 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 ; 2 ;;5.0;Radiology/Nuclear Medicine;**4,8,81**;Mar 16, 1998;Build 12 9 3 TASK ; Task ORU message 10 4 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) 5 ;S:$L($G(RANOSEND))&'$O(RAPRSET(RADTI,0)) ZTSAVE("RANOSEND")="" D ^%ZTLOAD 13 6 S:$L($G(RANOSEND)) ZTSAVE("RANOSEND")="" D ^%ZTLOAD 14 7 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE … … 22 15 D ^%ZTLOAD K RAMES,ZTDESC,ZTSK,ZTIO,ZTSAVE,ZTRTN,RASV,ZTDTH 23 16 Q 24 ; 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 25 21 UPMEM ;copy (prim:dx,stf,res),rpt ien to other members of same print set 26 22 ; first clear those fields -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLR.m
r628 r636 1 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 132 ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,71,82,75,80**;Mar 16, 1998;Build 19 3 3 ;Generates msg whenever a case is registered or cancelled or examined 4 4 ; registered cancelled examined … … 6 6 ; Order status : IP CA CM 7 7 ;02/14/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R 8 ;9 ;Integration Agreements10 ;----------------------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 8 S:$D(HLNDAP) ZTSAVE("HLNDAP")="" S:$D(HLDAP) ZTSAVE("HLDAP")="" S:$D(RAEXMDUN) ZTSAVE("RAEXMDUN")="" 20 9 S:$D(RAEXEDT) ZTSAVE("RAEXEDT")="" … … 36 25 ;RAEXMDUN passed from EXM^RAHLRPC if conditions are met 37 26 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 27 Q:$O(HL(""))="" ;disabled server appl, or no server appl 39 28 ;** 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) Q29 ;I HL("VER")]2.3 D EN^RAHLR1(RADFN,RADTI,RACNI,RAEID) Q 41 30 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 42 31 S RACN0=$S($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)):^(0),1:"") Q:RACN0']"" … … 47 36 S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9),RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT) 48 37 ;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 ??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 50 39 ;Compile 'PID' Segment 51 40 K VA,VADM,VAERR,RAVADM S DFN=RADFN D DEM^VADPT I VADM(1)']"" S HLP("ERRTEXT")="Invalid Patient Identifier" G EXIT … … 73 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" 74 63 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) 64 S HLA("HLS",3)="OBR"_HLFS_HLFS_RADTE_HLFS_RADTI_"-"_RACNI_$E(HLECH)_RADTE_$E(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_HLDT1 79 65 S HLA("HLS",3)=HLA("HLS",3)_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS_HLQ_HLFS_HLFS 80 66 S RAPRV=$$GET1^DIQ(200,+$P(RACN0,"^",14),.01) … … 126 112 N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP 127 113 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") 114 D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP) 130 115 D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP) 131 116 Q … … 134 119 INIT ; initialize HL7 variables 135 120 D NOW^%DTC S HLDT=%,HLDT1=$$HLDATE^HLFNC(%) 136 ;Note: HLDT1 is used for HL7 fields: ORC-9 & OBR-22137 121 Q:'$G(RAEID) S EID=RAEID 138 122 S HL="HLS(""HLS"")",INT=1 139 123 D INIT^HLFNC2(EID,.HL,INT) 140 124 Q:'$D(HL("Q")) ;no server application defined 141 S HLQ=HL("Q") 125 S HLQ=HL("Q"),HLFS=HL("FS") 142 126 S HLECH=HL("ECH") 143 127 S HLFS=HL("FS") -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPC.m
r628 r636 1 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 132 ;;5.0;Radiology/Nuclear Medicine;**12,25,54,71,82,81**;Mar 16, 1998;Build 12 3 3 ; 03/16/2006 *71 Rem Call 124379 allow exam updates to create HL7 msg 4 ;5 ;Integration Agreements6 ;----------------------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 4 REG ; register exam 12 N X,RA 101Z,RAEID13 S RA 101Z="RA REF" ; get all protocols beginning RA REG14 F S RA 101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA REG" D15 .S RAEID=$O(^ORD(101,"B",RA 101Z,0))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)) 16 9 .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR 17 10 Q 18 11 CANCEL ; cancel exam 19 N X,RA 101Z,RAEID20 S RA 101Z="RA CANCEK" ; get all protocols beginning RA CANCEL21 F S RA 101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA CANCEL" D22 .S RAEID=$O(^ORD(101,"B",RA 101Z,0))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)) 23 16 .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR 24 17 Q 25 18 ; 26 19 RPT ; report verified or released/not verified 27 N X,RA 101Z,RAEID,RASSS ; RASSS subcriber array to be passed to HLL for GENERATE^HLMA20 N X,RAPID,RAEID,RASSS ; RASSS subcriber array to be passed to HLL for GENERATE^HLMA 28 21 ;S X="^%ET",@^%ZOSF("TRAP") 29 S RA 101Z="RA RPS" ; get all protocols beginning RA RPT30 F S RA 101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA RPT" D31 .S RAEID=$O(^ORD(101,"B",RA 101Z,0)) K RASSS ; RA*5*8122 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 32 25 .S:$L($G(RANOSEND)) RAEID=$$GETEID(RAEID,RANOSEND,.RASSS) ;RA*5*81 33 26 .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLRPT … … 51 44 ; RAEXEDT = Indication of editing of: proc, proc mod, req phys, CPT mod, Tech comm... 52 45 ; RAGENHL7 = Indication that sending ORU is due... 53 ; RASSSX1(IENs) = Array of subscribers from 771, the message will be sent (SCIMGE)54 46 ; 55 N RAIMGTYI,RAIMGTYJ,RALOWER,RANEWST,RAEXMDUN,RAGENHL7 ,RASSSX147 N RAIMGTYI,RAIMGTYJ,RALOWER,RANEWST,RAEXMDUN,RAGENHL7 56 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) 57 49 S:$P(^RA(72,RANEWST,0),U,8)="Y" RAGENHL7=1 ;this status has GEN HL7 marked Y … … 61 53 ;?? none of the lower status levels have GEN HL7 marked Y 62 54 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) 55 Q:'$G(RAEXEDT)&'$G(RAGENHL7) 56 ; 68 57 1 N RAEXMDUN 69 58 S RAEXMDUN=1 70 A1 N X,RA 101Z,RAEID71 S RA 101Z="RA EXAMINEC" ; get all protocols beginning RA EXAMINED72 F S RA 101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA EXAMINED" D73 .N RAGENHL7 S RAEID=$O(^ORD(101,"B",RA 101Z,0))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)) 74 63 .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR 75 64 S:$G(RAGENHL7) $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y" … … 82 71 ; 0 (zero) returned if No subscriber exist or all subscribers associated with RANOSEND application. 83 72 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 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 87 75 D GETS^DIQ(101,RAEID_",","**","I","RAXX","ERR") 88 76 Q:$D(ERR) RAEID ; Was not able get Event driver info... so just pass event driver... -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPT.m
r628 r636 1 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 132 ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,81,80**;Mar 16, 1998;Build 19 3 3 EN ; Called from RA RPT and RA RPT 2.3 protocol entry action 4 4 ; Input variables: … … 10 10 ; Output variables: 11 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 section14 ; RATELX = Text used as indication of Release for local dictation... if not set use defauld above...15 ; RATELE = 1 If RANOSEND is Teleradiology type vendor16 12 ; 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 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) 25 17 I +$P(RACN0,U,25)=2 D Q ; printset 26 18 .; loop through all cases in set and create message … … 37 29 D INIT^RAHLRU ;initialize HL7 variables 38 30 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)31 Q:$O(HL(""))="" ;failed return from init^hlfnc2 40 32 ; 41 33 ;** 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 Q34 ;I HL("VER")]2.3 D EN^RAHLRPT1(RADFN,RADTI,RACNI,RAEID),EXIT Q 43 35 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** 44 36 ; … … 49 41 ; for an inexact date of birth. If inexact, pass null for DOB in 50 42 ; the 'PID' segment. Some COTS systems can't handle inexact DOB's. 51 D SETUP ^RAHLRPTT,PID^RAHLRPTT,OBR,OBXPRC,OBXIMP,OBXDIA,OBXRPT,OBXMOD,OBXTCM43 D SETUP,PID,OBR,OBXPRC,OBXIMP,OBXDIA,OBXRPT,OBXMOD,OBXTCM 52 44 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 Telerad55 45 S HL("MTN")="ORU" 56 46 N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP 57 47 S HLEID=RAEID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I" 58 48 M:$D(RASSS) HLP=RASSS 59 D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP ,"RASSSX")49 D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP) 60 50 D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP) 61 51 K RAVADM … … 102 92 S $P(X1,HLFS,35)="" I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) D 103 93 .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']"" Q94 .S X2=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",X2,0)) I X2']"" Q 105 95 .S XX2=$$GET1^DIQ(200,X2,.01) Q:XX2']"" 106 96 .S Y=$$HLNAME^HLFNC(XX2) I Y']"" Q … … 108 98 ;Transcriptionist 109 99 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']"" Q100 .S X2=$$GET1^DIQ(200,^RARPT(RARPT,"T"),.01) I X2']"" Q 111 101 .S Y=$$HLNAME^HLFNC(X2) I Y']"" Q 112 102 .S $P(X1,HLFS,36)=^RARPT(RARPT,"T")_$E(HLECH)_Y 113 103 ; 114 104 ; if long str, break so 2nd str begins with separator to avoid abend 115 N RAPART I $L(X1)>245F 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)="")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)="") 116 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" 117 107 S RAN=RAN+1 … … 146 136 OBXIMP ;Compile 'OBX' segment for Impression 147 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 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 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 150 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 151 140 Q … … 156 145 S RAN=RAN+1 D OBXPRC^RAHLRU 157 146 Q 158 OBXTCM ; Compile 'OBX' Segment for Tech Comments147 OBXTCM ; Compile 'OBX' Segment for Tech Comments 159 148 D OBXTCM^RAHLRU 160 149 Q 161 150 OBXRPT ;Compile 'OBX' Segment for Radiology Report Text 162 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 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 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 165 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 166 154 ; Replace above with following when Imaging can cope with ESC chars 167 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 168 156 Q 169 RATELREL ;Release the study for local reading 170 I $G(RATELE),X[$G(RATELX) S RATELREL=1 Q 171 ; 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 -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRS1.m
r628 r636 1 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 2 ;;5.0;Radiology/Nuclear Medicine;**80**;Mar 01, 2007;Build 19 3 ; 3 4 ; Utility to RESEND HL7 messages for selected Timeframe 4 ;5 ;Integration Agreements6 ;----------------------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 5 ; 12 6 N RACNI,RADFN,RADTI,RARPT,X,RAED,RABD,RASHBD,RASHED,RASHTD,RASHTM,DIC,DA,XX,YY … … 30 24 S RAED=RAED_"."_9999 31 25 K XX G:'$$GETAP(.XX) STOP 32 W !!,"*** Pick the application in which to send the radiology data***",!!26 W !!,"****Pick the application to send the RAD data to*****",!! 33 27 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) 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 38 31 W !!,"The: ",$O(XX(+X,""))," will be the recipient" 39 32 W !!,"Reviewing exams for selected time period... (This may take a few minutes)... " … … 53 46 W !,"Task ",$S('$D(ZTSK):" Has Not been Tasked !!!",1:"#:"_ZTSK_" Has been Tasked") 54 47 D:$D(ZTSK) 55 .N RAX,RAMPG,XMSUB,XMY,XMTEXT56 .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: "_RASHTM59 .S RAX(4)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED)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) 60 53 .S XMSUB="TASKMAN SCHEDULE NOTIFICATION/INFO" 61 54 .S RAMPG="G.RAD HL7 MESSAGES" 62 55 .S XMY(RAMPG)="",XMDUZ=.5 63 .S XMTEXT=" RAX("56 .S XMTEXT="X(" 64 57 .D ^XMD 65 58 Q … … 72 65 ..S RADTI=0 F S RADTI=$O(^RADPT("AR",RABD,RADFN,RADTI)) Q:'RADTI D 73 66 ...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)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) 79 72 S:$G(RASUM7E) X(6)="# Of Exams not transferred because of ""BAD DATA"": "_$G(RASUM7E) 80 73 S XMSUB="TASKMAN ""RESEND HL7 OPTION"" COMPLETED/INFO" 81 74 S RAMPG="G.RAD HL7 MESSAGES" 82 75 S XMY(RAMPG)="",XMDUZ=.5 83 S XMTEXT=" RAX("76 S XMTEXT="X(" 84 77 D ^XMD 85 78 G STOP … … 88 81 RESEND(RADFN,RADTI,RACNI) ; re-send exam message(s) to HL7 subscribers 89 82 ; 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 Q92 N RABD,RAED P80,QUIT83 I '(+^(RACNI,0)) S RASUM7E=RASUM7E+1 Q 84 I '$P(^(0),U,2) S RASUM7E=RASUM7E+1 Q 85 N RABD,RAED,QUIT 93 86 ; 94 87 I '$D(DT) D ^%DT S DT=Y 95 88 ; 96 S RAED P80=$$RAED(RADFN,RADTI,RACNI)97 I '$L(RAED P80) S RASUM7E=RASUM7E+1 Q98 D:RAED P80[",REG,"89 S RAED=$$RAED(RADFN,RADTI,RACNI) 90 I '$L(RAED) S RASUM7E=RASUM7E+1 Q 91 D:RAED[",REG," 99 92 .D CHSUM N RASUM7,RASUM7R,RASUM7E D REG^RAHLRPC 100 D:RAED P80[",CANCEL,"93 D:RAED[",CANCEL," 101 94 .D CHSUM N RASUM7,RASUM7R,RASUM7E D CANCEL^RAHLRPC 102 D:RAED P80[",EXAM,"95 D:RAED[",EXAM," 103 96 .D CHSUM 104 97 .S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",30)="" ;Reset sent flag 105 98 .N RASUM7,RAEXMDUN,RASUM7R,RASUM7E D 1^RAHLRPC 106 D:RAED P80[",RPT,"99 D:RAED[",RPT," 107 100 .D CHSUM N RASUM7,RANOSEND,RASUM7R,RASUM7E,RARPT D RPT^RAHLRPC 108 101 Q … … 153 146 .F S X1=$O(^ORD(101,"B",X1)) Q:X1'[X11 S X2=$O(^ORD(101,"B",X1,0)) Q:'X2 D 154 147 ..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 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 162 150 Q $S($D(XXX):1,1:0) 163 151 ; … … 176 164 ...S XX=+$P($G(^ORD(101,XX,770)),U,7) S:XX LINK(XX)="" 177 165 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 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 184 169 Q 185 170 CHSUM ;CHECKSUM -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLTCPB.m
r628 r636 1 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 132 ;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81**;Mar 16, 1998;Build 12 3 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 ; 4 ; 09/01/2006 Acomodate multiplr ORC/OBR segments Patch 81 10 5 EN1 ; Build the ^TMP("RARPT-REC" global when we receive the 11 6 ; 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 7 ; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1 8 ;G:$G(HL("VER"))]"2.3" EN1^RAHLTCPX 17 9 S RASUB=HL("MID"),RAHLTCPB=1 K RAERR 18 10 ;********************************************** … … 68 60 . S:$P(RADTCN,$E(HL("ECH")),2)]"" ^TMP(RARRR,$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HL("ECH")),2) 69 61 . Q 70 I $G(RADTI)'>0 S RAERR="Invalid exam registration timestamp" D XIT Q71 I $G(RACNI)'>0 S RAERR="Invalid exam record IEN" D XIT Q72 62 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS")) K RAHL70 73 63 I RAHLD="" S RAERR="Missing Report Status" D XIT Q 74 I "AFR"'[RAHLD S RAERR="Invalid Report Status : "_RAHLDD XIT Q64 I "AFR"'[RAHLD S RAERR="Invalid Report Status" D XIT Q 75 65 S ^TMP(RARRR,$J,RASUB,"RASTAT")=RAHLD 76 66 G:$P(RARRR,"-",3) 112 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS")) K RAHL70 … … 82 72 E D ; $D(^VA(200,"B",RAVERF)) true, get the entry ien 83 73 . S RAVERF=$O(^VA(200,"B",RAVERF,0)) 84 . S:'RAVERF RAERR="Invalid Provider Name : "_RAHLD74 . S:'RAVERF RAERR="Invalid Provider Name" 85 75 ; can't get resident info from medspeak 86 76 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,33,HL("FS")),RARSDNT="" K RAHL70 … … 96 86 I $D(RAERR) D XIT Q 97 87 D ESIG^RAHLO3 98 ;99 88 ;If last OBR set provider info to all OBRs 100 89 K XX F I=1:1:RACN S XX=RARRR_"-"_I D:$D(^TMP(XX,$J,RASUB)) … … 110 99 . Q:SEGMNT?@("1"""_HL("FS")_"""."""_HL("FS")_"""") ;Quit if OBX is something as: OBX|||||||| 111 100 . 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))101 . S OBXTYP=$P(SEGMNT,HL("FS"),3),OBXTYP=$E(OBXTYP,$F(OBXTYP,"&")) 113 102 . S OBX2CE="" 114 103 . S:OBXTYP="" OBXTYP=" " … … 144 133 S X=$P(SEGMNT,HL("FS"),5) 145 134 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 84147 135 D PAR 148 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 149 137 I X=""!(LIN'="") S L=999 D P2 150 138 Q 151 ; 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 152 147 PAR ; Build text paragraph 153 148 S LIN=LIN_X … … 167 162 S MSA1="AA" 168 163 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")164 I $D(RAERR) S MSA1=$S($G(HL("SAN"))="RA-PSCRIBE-TCP":"AE",1:"AR") 170 165 ; Added next line to support MedSpeak interface. Must re-initialize 171 166 ; FS and EC's before sending ACK. … … 176 171 K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT) 177 172 Q 178 ;179 FORMAT ; Format report text for Escape Character delimited codes.180 S Y=X N T,Q181 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=X182 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=X183 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=X184 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=X185 I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT186 Q187 ; -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAMAIN.m
r628 r636 1 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 22 ;;5.0;Radiology/Nuclear Medicine;**31,43,50,54**;Mar 16, 1998 3 3 ; 4 ; 11/15/07 BAY/KAM RA*5*87 Rem Call 205080 Option File Access5 4 3 ;;Major AMIS Code Enter/Edit 6 5 N RAI F RAI=1:1:5 W !?9,$P($T(REMIND+RAI),";;",2) … … 76 75 10 ;;Procedure Modifiers Entry 77 76 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" 77 S (DIC,DLAYGO)="^RAMIS(71.2,",DIC(0)="AEMQL" 81 78 S DIC("A")="Select Procedure Modifier: ",DIC("W")="D PROHLP^RAMAIN" 82 79 W ! D ^DIC K DIC,DLAYGO I +Y'>0 K D,X,Y,POP,I,DDH,DG,DISYS,DUOUT Q -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RO1.m
r628 r636 1 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 72 ;;5.0;Radiology/Nuclear Medicine;**2,75**;Mar 16, 1998;Build 4 3 3 ; 4 4 EN1(RAERR) ; errors encountered with OE v3.0 back & frontdoor transmission … … 6 6 I RAEMSG]"" Q RAEMSG 7 7 Q "Error # "_RAERR_" does not exist" 8 ;9 ;Note: Error code nine (9) disappears with the release of CPRS GUI V27. P8610 8 ; 11 9 MSG ; error messages -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RON.m
r628 r636 1 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 2 ;;5.0;Radiology/Nuclear Medicine;**41,75**;Mar 16, 1998;Build 4 9 3 ; 10 4 ;------------------------- Variable List ------------------------------- … … 46 40 S RAERR=$$EN3^RAO7VLD(44,+RAPV13) S:RAERR RAERR=3 Q:RAERR 47 41 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 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 54 44 S RAPV119=$P(RADATA,RAHLFS,19) 55 45 Q -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1.m
r628 r636 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 ; 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 16 3 ;*Billing Awareness Project: 17 4 ; RABWDX Array: ICD Diagnosis^SC^AO^IR^EC^MST^HNC … … 21 8 S RAPKG="" N RAPTLKUP,RAGMTS,RACOPYOR 22 9 G ADDORD:$D(RAVSTFLG)&($D(RALIFN))&($D(RAPIFN)) 23 ;24 10 I '$D(RAREGFLG),'$D(RAVSTFLG) N RAPTLOCK K RAWARD D G:'RAPTLKUP Q 25 11 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 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 28 16 .S (DFN,RADFN)=+Y,(VA200,RAPTLKUP)=1 29 17 .W ! D IN5^VADPT S:VAIP(1) RAWARD=$P(VAIP(5),"^",2) 30 18 .D ELIG^RABWORD2 31 19 .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 ; 20 PL S DIC("A")="Patient Location: ",DIC("B")=$S($D(RAWARD):RAWARD,1:""),DIC="^SC(",DIC(0)="AEMQ",DIC("S")="I $$SCREEN^RAORD1A()" 48 21 D ^DIC K DIC K:'$D(RAREGFLG) RAWARD G Q:Y<0 S RALIFN=+Y 49 22 S DIC("A")="Person Requesting Order: " … … 66 39 S RADIV=$S($D(^RA(79,RADIV,0)):RADIV,1:$O(^RA(79,0))) 67 40 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" 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) 73 47 .Q 48 K:$D(RAWARD)&($E(RACAT,1)="O") RAWARD 49 K RASTRNG 74 50 ; clear clin hist if: 75 51 ; rad backdoor, or -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1A.m
r628 r636 1 RAORD1A ;HISC/FPT-Request an Exam ; 7/27/07 08:002 ;;5.0;Radiology/Nuclear Medicine;**1 ,86**;Mar 16, 1998;Build 71 RAORD1A ;HISC/FPT-Request an Exam ;9/29/97 10:40 2 ;;5.0;Radiology/Nuclear Medicine;**1**;Mar 16, 1998 3 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 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. 9 8 ; 10 SCREEN(RAINPAT,RACPRS27) ; screen for active clinics/wards 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 11 33 ; 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: 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 15 64 ; 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 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:"") 19 97 ; 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 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:"") 79 103 ; 80 104 PREG(RADFN,RADT) ; Subroutine will display the pregnancy prompt to the … … 105 129 F S RACNT=$O(RAMOD(RACNT),-1) Q:RACNT=""!(X=0) S:RAMOD(RACNT)=Y X=0 106 130 Q X 107 ; -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR.m
r628 r636 1 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 42 ;;5.0;Radiology/Nuclear Medicine;**5,13,16,27,43,55,75**;Mar 16, 1998;Build 4 3 3 PRT ; Begin print/build of e-mail message 4 4 ; … … 132 132 K RARPT,RAHDFM,RAFTFM,RAV,RAIOF,RABTCH,RAOOUT,RAPIR,RAPIS,VAERR,Z 133 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 134 K RASTRSK,RAORIOF,RAFFLF,RAERRFLG 140 135 Q 141 136 Q ; Queue the report -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR0.m
r628 r636 1 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 132 ;;5.0;Radiology/Nuclear Medicine;**8,26,74**;Mar 16, 1998;Build 2 3 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... 4 EN1 ; Called from RARTR 11 5 S RARPT(0)=$G(^RARPT(+$G(RARPT),0)) Q:RARPT(0)']"" 12 6 S RARPT(10)=$P(RARPT(0),"^",10) 13 7 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_"," 8 S RAPIR=+$P(RALB,"^",12),RAPIS=+$P(RALB,"^",15) 22 9 S RAWHOVER=+$P(RARPT(0),"^",17) 23 10 I RAVERF,((RAPIR=RAVERF)!(RAPIS=RAVERF)) D … … 25 12 . Q 26 13 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 . ; 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) 35 18 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) 36 19 . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL 37 20 . 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))21 .. W !,"Primary Interpreting Staff:" 22 .. W !?2,$S(RALBS]"":RALBS,1:"Unknown"),", ",$E(RALBST,1,((IOM-$X)-16)) 40 23 .. ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING 41 24 .. Q … … 43 26 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Staff:" 44 27 .. 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))28 .. N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT)) 46 29 .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBST,1,((80-RALEN)-16)) 47 30 .. Q 48 . I $D(RAVERFND)&(RAPIS=RAVERF) ,(RAPIS(200,RAPIS("IENS"),.01)'="RADIOLOGY,OUTSIDE SERVICE")D31 . I $D(RAVERFND)&(RAPIS=RAVERF) D 49 32 .. I $G(RARPT(10))']"",('$D(RAUTOE)) D Q 50 33 ... W:RAWHOVER=RAPIS !?10,"(Verifier, no e-sig)" … … 62 45 . Q 63 46 D SECSTF^RARTR1 Q:$D(RAOOUT) ; Print secondary interp'ting staff now 64 ;now for primary resident definitions...65 47 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 . ; 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) 74 52 . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) 75 53 . 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 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 80 57 . I $D(RAUTOE) D 81 58 .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Resident:" 82 59 .. 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))60 .. N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT)) 84 61 .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBRT,1,((80-RALEN)-16)) 85 62 .. Q … … 100 77 . Q 101 78 D SECRES^RARTR1 ; Print out secondary interp'ting resident now 102 K RAPIR,RAPIS ;P84 kills added103 79 Q 104 ; 105 TITLE(X) ;Return the radiology classification in lieu of the signature block title 80 TITLE(X) ; Determine an individuals title 106 81 ; 'X' is the IEN of the Primary Interpreting Resident i.e, ^DD(70.03,12 107 82 ; -OR- 108 83 ; '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 ; 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 111 89 HEAD ; Set up header info for e-mail message (called from INIT^RARTR) 112 90 ; 06/28/2006 BAY/KAM Remedy Call 146291 Change Patient Age to DOB -
FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL1.m
r628 r636 1 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 132 ;;5.0;Radiology/Nuclear Medicine;**5,9,18,71,82**;Mar 16, 1998;Build 8 3 3 ;last modification by SS for P18 June 19,00 4 4 ;02/10/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R 5 ;6 ;Integration Agreements7 ;----------------------8 ;DIC(10006); DIE(10018); FILE^DIE(2053); UPDATE^DIE(2053); EN^ORB3(1362); NOTE^ORX3(868)9 ;10 5 I "IOSCR"'[X!(X="") S X="Unknown" Q 11 6 G @($E(X)) … … 36 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 37 32 ;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 Q33 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 39 34 X RAMTIME S Y1=X I X<0 S Y="Neg. Time" G Q 40 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) … … 46 41 I $G(RAIMGTY)="" K XQUIT Q ; didn't sign-on to an imaging location 47 42 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 UPDATE49 I $D(^RA(72,"AA",RAIMGTY,0,+RAST)) W !!?3, $C(7),"Exam has been 'cancelled' therefore the status cannot be changed." G UPDATE43 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 50 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 51 46 D UP1 I RAOR>0 D 52 .L +^RADPT(RADFN,"DT",RADTI,"P",RACNI) :$G(DILOCKTM,3)47 .L +^RADPT(RADFN,"DT",RADTI,"P",RACNI) 53 48 .N RAIEN 54 49 .S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_"," … … 56 51 .K RAERR D UPDATE^DIE("E","RAFDA","RAIEN","RAERR") 57 52 .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 Q53 .I $D(RAERR) L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) K RAIEN Q 59 54 .S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_"," 60 55 .S RAFDA(70.07,RAIENS,2)="U" 61 56 .S RAFDA(70.07,RAIENS,3)=$S($G(RADUZ):RADUZ,1:DUZ) 62 .D FILE^DIE(,"RAFDA" ,"RAERR")57 .D FILE^DIE(,"RAFDA") 63 58 .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 59 UPQ K RAFDA,RAIENS 66 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 … … 96 90 ;S DR(2,70.05)=$S($P(RAMDV,"^",11)&('$D(ZTQUEUED)):".01;",1:"")_"2////"_RASTI_";3////"_$S($G(RADUZ):RADUZ,1:DUZ) 97 91 ;D ^DIE 98 L +^RADPT(RADFN,"DT",RADTI,"P",RACNI) :$G(DILOCKTM,3)92 L +^RADPT(RADFN,"DT",RADTI,"P",RACNI) 99 93 N RAIEN 100 94 S RAIENS=RACNI_","_RADTI_","_RADFN_"," 101 95 S RAFDA(70.03,RAIENS,3)=RASTI 102 96 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 - P1897 I $D(RAERR) L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) G UP2K ;L - P18 104 98 I $P(RAMDV,"^",10) D 105 .N RAERR2106 99 .S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_"," 107 100 .S RAFDA(70.05,RAIENS,.01)=$$MIDNGHT^RAUTL5($$NOW^XLFDT()) 108 .D UPDATE^DIE(,"RAFDA","RAIEN" ,"RAERR")101 .D UPDATE^DIE(,"RAFDA","RAIEN") 109 102 .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 103 .Q:'$D(RAIEN(1)) 112 104 .I $P(RAMDV,"^",11),('$D(ZTQUEUED)) D … … 117 109 .S RAFDA(70.05,RAIENS,2)=RASTI 118 110 .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) 111 .K RAERR2 D FILE^DIE(,"RAFDA") 121 112 ;Patch RA*5*82 added next line send EXM message after status update, not before the update 122 D :'$D(RAERR)EXM^RAHLRPC113 D EXM^RAHLRPC 123 114 L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) 124 115 ;
Note:
See TracChangeset
for help on using the changeset viewer.
