- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- Location:
- WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ
- Files:
-
- 218 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP.m
r613 r623 1 OCXOCMP ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Main Entry point - All Rules) ;3/21/01 08:50 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 EN ; 6 ; 7 N OCXQ 8 ; 9 S OCXQ=$$READ("Y","Do you want to queue the compiler to run ","NO") Q:(OCXQ[U) I OCXQ D Q 10 .D QUE^OCXOCMPV(10) 11 .W !!,"Expert system compiler queued to run in 10 seconds." 12 .W !,"You will be sent a Mailman bulletin when it has finished.",!! 13 .H 2 14 ; 15 MAN K ZTSK D MAN^OCXOCMPV Q ; Run the compiler (interactive/manual mode) 16 ; ; Ask for option settings. 17 ; 18 AUTO D AUTO^OCXOCMPV Q ; Run the compiler (Automatic mode) 19 ; ; Program Execution Trace Mode OFF 20 ; ; Elapsed time logging OFF 21 ; ; Raw Data Logging OFF 22 ; 23 QUE D QUE^OCXOCMPV(10) Q ; Queue the compiler to run in the background 24 ; ; Uses option setting from last compile. 25 ; ; If no last compile then all options are 26 ; ; turned OFF as in Automatic mode. 27 RUN ; 28 ; 29 N OCX1,OCX2,OCX3,OCX4 30 ; 31 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(1,20) 32 ; 33 D MESG("Build list of Active Rules, Elements and Datafields...") 34 D SETFLAG^OCXOCMPV ; H 1 35 I $$EN^OCXOCMP9 D ERMESG("Compiler Aborted while building list of Rules, Elements and Datafields...") Q 36 Q:$G(OCXWARN) 37 ; 38 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(2,20) 39 ; 40 S OCX1="" F S OCX1=$O(^TMP("OCXCMP",$J,OCX1)) Q:'$L(OCX1) D 41 .S OCX2=0 F OCX3=0:1 S OCX2=$O(^TMP("OCXCMP",$J,OCX1,OCX2)) Q:'OCX2 42 .D MESG(" "_$J(OCX3,5)_" "_OCX1_$S(OCX3=1:"",1:"S")) 43 ; 44 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(3,20) 45 ; 46 D MESG("Compile DataField Navigation code...") 47 D SETFLAG^OCXOCMPV ; H 1 48 I $$EN^OCXOCMP1 D ERMESG("Compiler Aborted due to Datafield syntax errors...") Q 49 Q:$G(OCXWARN) 50 ; 51 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(4,20) 52 ; 53 S (OCX3,OCX1)=0 F S OCX1=$O(^TMP("OCXCMP",$J,"DATA FIELD",OCX1)) Q:'OCX1 D 54 .S OCX2=0 F S OCX2=$O(^TMP("OCXCMP",$J,"DATA FIELD",OCX1,OCX2)) Q:'OCX2 S OCX3=OCX3+1 55 D MESG(" "_$J(OCX3,5)_" DataField Navigation Code Array"_$S(OCX3=1:"",1:"s")) 56 ; 57 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(5,20) 58 ; 59 D MESG("Compile Element Evaluation code...") 60 D SETFLAG^OCXOCMPV ; H 1 61 I $$EN^OCXOCMP2 D ERMESG("Compiler Aborted due to Rule Element syntax errors...") Q 62 Q:$G(OCXWARN) 63 ; 64 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(6,20) 65 ; 66 S (OCX1,OCX2)=0 F S OCX1=$O(^TMP("OCXCMP",$J,"A CODE",OCX1)) Q:'OCX1 S OCX2=OCX2+1 67 D MESG(" "_$J(OCX2,5)_" Event Evaluation Code Array"_$S(OCX2=1:"",1:"s")) 68 ; 69 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(7,20) 70 ; 71 D MESG("Compile Element MetaCode...") 72 D SETFLAG^OCXOCMPV ; H 1 73 I $$EN^OCXOCMPM D ERMESG("Compiler Aborted due to Element metacode errors...") Q 74 Q:$G(OCXWARN) 75 ; 76 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(8,20) 77 ; 78 S OCX1="",OCX2=0 F S OCX1=$O(^TMP("OCXCMP",$J,"INCLUDE",OCX1)) Q:'$L(OCX1) S:($E(OCX1,1,3)="MCE") OCX2=OCX2+1 79 D MESG(" "_$J(OCX2,5)_" Element Metacode Array"_$S(OCX2=1:"",1:"s")) 80 ; 81 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(9,20) 82 ; 83 D MESG("Get Compiler Function Code...") 84 D SETFLAG^OCXOCMPV ; H 1 85 I $$EN^OCXOCMPO D ERMESG("Compiler Aborted due to Compiler Function code errors...") Q 86 Q:$G(OCXWARN) 87 ; 88 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(10,20) 89 ; 90 S OCX1="",OCX2=0 F S OCX1=$O(^TMP("OCXCMP",$J,"INCLUDE",OCX1)) Q:'$L(OCX1) S:'($E(OCX1,1,3)="MCE") OCX2=OCX2+1 91 D MESG(" "_$J(OCX2,5)_" Compiler Include Function"_$S(OCX2=1:"",1:"s")) 92 ; 93 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(12,20) 94 ; 95 D MESG("Compile Rule Element Relation code...") 96 D SETFLAG^OCXOCMPV ; H 1 97 I $$EN^OCXOCMP3 D ERMESG("Compiler Aborted due to Rule syntax errors...") Q 98 Q:$G(OCXWARN) 99 ; 100 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(13,20) 101 ; 102 S (OCX1,OCX2)=0 F S OCX1=$O(^TMP("OCXCMP",$J,"RULE",OCX1)) Q:'OCX1 D 103 .S OCX3=0 F S OCX3=$O(^TMP("OCXCMP",$J,"RULE",OCX1,OCX3)) Q:'OCX3 S:$O(^(OCX3,"CODE",0)) OCX2=OCX2+1 104 D MESG(" "_$J(OCX2,5)_" Rule Element Relation Code Array"_$S(OCX2=1:"",1:"s")) 105 ; 106 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(14,20) 107 ; 108 D MESG("Construct Decision Tree...") 109 D SETFLAG^OCXOCMPV ; H 1 110 I $$EN^OCXOCMP4 D ERMESG("Compiler Aborted due to Compiler errors...") Q 111 Q:$G(OCXWARN) 112 ; 113 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(15,20) 114 ; 115 S OCX1=0 F OCX2=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"C CODE",OCX1)) Q:'OCX1 116 D MESG(" "_$J(OCX2,5)_" Sub-Routine"_$S(OCX2=1:"",1:"s")) 117 ; 118 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(16,20) 119 ; 120 D MESG("Optimize Sub-Routines...") 121 D SETFLAG^OCXOCMPV ; H 1 122 I $$EN^OCXOCMP5 D ERMESG("Compiler Aborted due to Compiler errors...") Q 123 Q:$G(OCXWARN) 124 ; 125 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(17,20) 126 ; 127 S OCX1=0 F OCX3=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"C CODE",OCX1)) Q:'OCX1 128 D MESG(" "_$J(OCX3,5)_" Sub-Routine"_$S(OCX3=1:"",1:"s")) 129 D MESG(" "_(100-(((OCX3/OCX2)*1000)\1/10))_"% Optimization") 130 ; 131 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(18,20) 132 ; 133 D MESG("Assemble Routines...") 134 D SETFLAG^OCXOCMPV ; H 1 135 I $$EN^OCXOCMP6 D ERMESG("Compiler Aborted due to Compiler errors...") Q 136 Q:$G(OCXWARN) 137 ; 138 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(19,20) 139 ; 140 S OCX1=0 F OCX2=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"D CODE",OCX1)) Q:'OCX1 141 D MESG(" "_$J(OCX2,5)_" OCXOZ* Routine"_$S(OCX2=1:"",1:"s")) 142 ; 143 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(20,20) 144 ; 145 L -^OCXD(861,1) 146 ; 147 Q 148 ; 149 MESG(OCXX) ; 150 I '$G(OCXAUTO) W !!,OCXX 151 I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX) 152 Q 153 ; 154 ERMESG(OCXX) ; 155 N OCXY S OCXY=OCXX 156 I '$G(OCXAUTO) W !!,OCXX 157 I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX) 158 S OCXERRM=OCXY 159 Q 160 ; 161 READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; 162 N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT 163 Q:'$L($G(OCXZ0)) U 164 S DIR(0)=OCXZ0 165 S:$L($G(OCXZA)) DIR("A")=OCXZA 166 S:$L($G(OCXZB)) DIR("B")=OCXZB 167 F OCXLINE=1:1:($G(OCXZL)-1) W ! 168 D ^DIR 169 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U 170 Q Y 171 ; 172 Q 173 ; 174 DT(X,D) N Y,%DT S %DT=D D ^%DT Q Y 175 Q 176 ; 177 CNT(X) ; 178 ; 179 N CNT,D0 180 S D0=0 F CNT=1:1 S D0=$O(@X@(D0)) Q:'D0 181 W !!,?10,X," ",CNT 182 Q CNT 183 ; 184 DATE() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") Q Y 185 ; 186 CONV(Y) Q:'(Y["@") Y Q $P(Y,"@",1)_" at "_$P(Y,"@",2,99) 187 ; 188 ; 189 VERSION() Q $P($T(+3),";;",3) 190 ; 1 OCXOCMP ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Main Entry point - All Rules) ;3/21/01 08:50 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 EN ; 6 ; 7 N OCXQ 8 ; 9 S OCXQ=$$READ("Y","Do you want to queue the compiler to run ","NO") Q:(OCXQ[U) I OCXQ D Q 10 .D QUE^OCXOCMPV(10) 11 .W !!,"Expert system compiler queued to run in 10 seconds." 12 .W !,"You will be sent a Mailman bulletin when it has finished.",!! 13 .H 2 14 ; 15 MAN K ZTSK D MAN^OCXOCMPV Q ; Run the compiler (interactive/manual mode) 16 ; ; Ask for option settings. 17 ; 18 AUTO D AUTO^OCXOCMPV Q ; Run the compiler (Automatic mode) 19 ; ; Program Execution Trace Mode OFF 20 ; ; Elapsed time logging OFF 21 ; ; Raw Data Logging OFF 22 ; 23 QUE D QUE^OCXOCMPV(10) Q ; Queue the compiler to run in the background 24 ; ; Uses option setting from last compile. 25 ; ; If no last compile then all options are 26 ; ; turned OFF as in Automatic mode. 27 RUN ; 28 ; 29 N OCX1,OCX2,OCX3,OCX4 30 ; 31 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(1,20) 32 ; 33 D MESG("Build list of Active Rules, Elements and Datafields...") 34 D SETFLAG^OCXOCMPV ; H 1 35 I $$EN^OCXOCMP9 D ERMESG("Compiler Aborted while building list of Rules, Elements and Datafields...") Q 36 Q:$G(OCXWARN) 37 ; 38 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(2,20) 39 ; 40 S OCX1="" F S OCX1=$O(^TMP("OCXCMP",$J,OCX1)) Q:'$L(OCX1) D 41 .S OCX2=0 F OCX3=0:1 S OCX2=$O(^TMP("OCXCMP",$J,OCX1,OCX2)) Q:'OCX2 42 .D MESG(" "_$J(OCX3,5)_" "_OCX1_$S(OCX3=1:"",1:"S")) 43 ; 44 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(3,20) 45 ; 46 D MESG("Compile DataField Navigation code...") 47 D SETFLAG^OCXOCMPV ; H 1 48 I $$EN^OCXOCMP1 D ERMESG("Compiler Aborted due to Datafield syntax errors...") Q 49 Q:$G(OCXWARN) 50 ; 51 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(4,20) 52 ; 53 S (OCX3,OCX1)=0 F S OCX1=$O(^TMP("OCXCMP",$J,"DATA FIELD",OCX1)) Q:'OCX1 D 54 .S OCX2=0 F S OCX2=$O(^TMP("OCXCMP",$J,"DATA FIELD",OCX1,OCX2)) Q:'OCX2 S OCX3=OCX3+1 55 D MESG(" "_$J(OCX3,5)_" DataField Navigation Code Array"_$S(OCX3=1:"",1:"s")) 56 ; 57 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(5,20) 58 ; 59 D MESG("Compile Element Evaluation code...") 60 D SETFLAG^OCXOCMPV ; H 1 61 I $$EN^OCXOCMP2 D ERMESG("Compiler Aborted due to Rule Element syntax errors...") Q 62 Q:$G(OCXWARN) 63 ; 64 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(6,20) 65 ; 66 S (OCX1,OCX2)=0 F S OCX1=$O(^TMP("OCXCMP",$J,"A CODE",OCX1)) Q:'OCX1 S OCX2=OCX2+1 67 D MESG(" "_$J(OCX2,5)_" Event Evaluation Code Array"_$S(OCX2=1:"",1:"s")) 68 ; 69 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(7,20) 70 ; 71 D MESG("Compile Element MetaCode...") 72 D SETFLAG^OCXOCMPV ; H 1 73 I $$EN^OCXOCMPM D ERMESG("Compiler Aborted due to Element metacode errors...") Q 74 Q:$G(OCXWARN) 75 ; 76 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(8,20) 77 ; 78 S OCX1="",OCX2=0 F S OCX1=$O(^TMP("OCXCMP",$J,"INCLUDE",OCX1)) Q:'$L(OCX1) S:($E(OCX1,1,3)="MCE") OCX2=OCX2+1 79 D MESG(" "_$J(OCX2,5)_" Element Metacode Array"_$S(OCX2=1:"",1:"s")) 80 ; 81 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(9,20) 82 ; 83 D MESG("Get Compiler Function Code...") 84 D SETFLAG^OCXOCMPV ; H 1 85 I $$EN^OCXOCMPO D ERMESG("Compiler Aborted due to Compiler Function code errors...") Q 86 Q:$G(OCXWARN) 87 ; 88 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(10,20) 89 ; 90 S OCX1="",OCX2=0 F S OCX1=$O(^TMP("OCXCMP",$J,"INCLUDE",OCX1)) Q:'$L(OCX1) S:'($E(OCX1,1,3)="MCE") OCX2=OCX2+1 91 D MESG(" "_$J(OCX2,5)_" Compiler Include Function"_$S(OCX2=1:"",1:"s")) 92 ; 93 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(12,20) 94 ; 95 D MESG("Compile Rule Element Relation code...") 96 D SETFLAG^OCXOCMPV ; H 1 97 I $$EN^OCXOCMP3 D ERMESG("Compiler Aborted due to Rule syntax errors...") Q 98 Q:$G(OCXWARN) 99 ; 100 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(13,20) 101 ; 102 S (OCX1,OCX2)=0 F S OCX1=$O(^TMP("OCXCMP",$J,"RULE",OCX1)) Q:'OCX1 D 103 .S OCX3=0 F S OCX3=$O(^TMP("OCXCMP",$J,"RULE",OCX1,OCX3)) Q:'OCX3 S:$O(^(OCX3,"CODE",0)) OCX2=OCX2+1 104 D MESG(" "_$J(OCX2,5)_" Rule Element Relation Code Array"_$S(OCX2=1:"",1:"s")) 105 ; 106 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(14,20) 107 ; 108 D MESG("Construct Decision Tree...") 109 D SETFLAG^OCXOCMPV ; H 1 110 I $$EN^OCXOCMP4 D ERMESG("Compiler Aborted due to Compiler errors...") Q 111 Q:$G(OCXWARN) 112 ; 113 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(15,20) 114 ; 115 S OCX1=0 F OCX2=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"C CODE",OCX1)) Q:'OCX1 116 D MESG(" "_$J(OCX2,5)_" Sub-Routine"_$S(OCX2=1:"",1:"s")) 117 ; 118 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(16,20) 119 ; 120 D MESG("Optimize Sub-Routines...") 121 D SETFLAG^OCXOCMPV ; H 1 122 I $$EN^OCXOCMP5 D ERMESG("Compiler Aborted due to Compiler errors...") Q 123 Q:$G(OCXWARN) 124 ; 125 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(17,20) 126 ; 127 S OCX1=0 F OCX3=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"C CODE",OCX1)) Q:'OCX1 128 D MESG(" "_$J(OCX3,5)_" Sub-Routine"_$S(OCX3=1:"",1:"s")) 129 D MESG(" "_(100-(((OCX3/OCX2)*1000)\1/10))_"% Optimization") 130 ; 131 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(18,20) 132 ; 133 D MESG("Assemble Routines...") 134 D SETFLAG^OCXOCMPV ; H 1 135 I $$EN^OCXOCMP6 D ERMESG("Compiler Aborted due to Compiler errors...") Q 136 Q:$G(OCXWARN) 137 ; 138 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(19,20) 139 ; 140 S OCX1=0 F OCX2=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"D CODE",OCX1)) Q:'OCX1 141 D MESG(" "_$J(OCX2,5)_" OCXOZ* Routine"_$S(OCX2=1:"",1:"s")) 142 D MESG(" "_OCXLCNT_" Lines of code generated.") 143 ; 144 D:($G(OCXAUTO)<2) STATUS^OCXOPOST(20,20) 145 ; 146 L -^OCXD(861,1) 147 ; 148 Q 149 ; 150 MESG(OCXX) ; 151 I '$G(OCXAUTO) W !!,OCXX 152 I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX) 153 Q 154 ; 155 ERMESG(OCXX) ; 156 N OCXY S OCXY=OCXX 157 I '$G(OCXAUTO) W !!,OCXX 158 I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX) 159 S OCXERRM=OCXY 160 Q 161 ; 162 READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; 163 N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT 164 Q:'$L($G(OCXZ0)) U 165 S DIR(0)=OCXZ0 166 S:$L($G(OCXZA)) DIR("A")=OCXZA 167 S:$L($G(OCXZB)) DIR("B")=OCXZB 168 F OCXLINE=1:1:($G(OCXZL)-1) W ! 169 D ^DIR 170 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U 171 Q Y 172 ; 173 Q 174 ; 175 DT(X,D) N Y,%DT S %DT=D D ^%DT Q Y 176 Q 177 ; 178 CNT(X) ; 179 ; 180 N CNT,D0 181 S D0=0 F CNT=1:1 S D0=$O(@X@(D0)) Q:'D0 182 W !!,?10,X," ",CNT 183 Q CNT 184 ; 185 DATE() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") Q Y 186 ; 187 CONV(Y) Q:'(Y["@") Y Q $P(Y,"@",1)_" at "_$P(Y,"@",2,99) 188 ; 189 ; 190 VERSION() Q $P($T(+3),";;",3) 191 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP6.m
r613 r623 1 OCXOCMP6 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines) ;1/05/04 14:33 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 EN() ; 6 ; 7 Q:$G(OCXWARN) 1 8 N OCXD0,OCXD1,OCXRN,OCXSCNT,OCXOFF 9 ; 10 W:'$G(OCXAUTO) !,?5,"Generate Extrinsic Function and Variables documentation..." 11 S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0 D DOC^OCXOCMPT(OCXD0) 12 ; 13 K ^OCXS(860.3,"APGM") 14 S OCXD0=0 F S OCXD0=$O(^OCXS(860.3,OCXD0)) Q:'OCXD0 D 15 .K ^OCXS(860.3,OCXD0,"RTN") I '$G(OCXAUTO) W:($X>60) ! W "." 16 ; 17 K ^TMP("OCXCMP",$J,"D CODE") 18 ; 19 W:'$G(OCXAUTO) !,?5,"Assign Subroutines to Routines..." 20 S OCXRN=1,OCXD0=0 21 D GETHDR(1) 22 F S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0 D Q:OCXWARN 23 .N OCXLLAB,OCXSKIP,OCXEXF,OCXSUB,OCXSIZE,OCXFILE,OCXCCODE,OCXDCODE,OCXLAST 24 .I '$G(OCXAUTO) W:($X>60) ! W "." 25 .S OCXLLAB=^TMP("OCXCMP",$J,"LINE",OCXD0) 26 .S OCXSKIP=((OCXLLAB="UPDATE")!(OCXLLAB="LOG")) 27 .S OCXSIZE=$$SIZE^OCXOCMP8(OCXRN,OCXD0) 28 .S OCXLAST='$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) 29 .S OCXFILE=(OCXSIZE>OCXCRS)!(OCXLAST) S:OCXSKIP OCXFILE=0 30 .I OCXFILE D 31 ..K OCXEXF S OCXEXF="" 32 ..I $D(^TMP("OCXCMP",$J,"D CODE",OCXRN,"CALLS")) M OCXEXF=^("CALLS") 33 ..S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) I 'OCXEXF(OCXSUB) D 34 ...S OCXEXF(OCXSUB)=1,OCXEXF=OCXSUB 35 ...S OCXSUB="" F S OCXSUB=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXEXF,"CALLS",OCXSUB)) Q:'$L(OCXSUB) D 36 ....S OCXEXF(OCXSUB)=$G(OCXEXF(OCXSUB)) 37 ..S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) D 38 ...D APPEND^OCXOCMP8(OCXRN,OCXSUB,"F") 39 ..D APPEND^OCXOCMP8(OCXRN,"$") 40 ..S OCXRN=OCXRN+1 D GETHDR(OCXRN) 41 ..; 42 .D APPEND^OCXOCMP8(OCXRN,OCXD0,"C",OCXLLAB) 43 .I ($E(OCXLLAB,1,2)="EL") D 44 ..S ^OCXS(860.3,"APGM",(+$E(OCXLLAB,3,$L(OCXLLAB))),(OCXLLAB_U_$$RNAM(OCXRN)))="" 45 .S $P(^TMP("OCXCMP",$J,"LINE",OCXD0),U,2)=$$RNAM(OCXRN) 46 .Q:'OCXLAST 47 .K OCXEXF S OCXEXF="" 48 .I $D(^TMP("OCXCMP",$J,"D CODE",OCXRN,"CALLS")) M OCXEXF=^("CALLS") 49 .S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) I 'OCXEXF(OCXSUB) D 50 ..S OCXEXF(OCXSUB)=1,OCXEXF=OCXSUB 51 ..S OCXSUB="" F S OCXSUB=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXEXF,"CALLS",OCXSUB)) Q:'$L(OCXSUB) D 52 ...S OCXEXF(OCXSUB)=$G(OCXEXF(OCXSUB)) 53 .S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) D 54 ..D APPEND^OCXOCMP8(OCXRN,OCXSUB,"F") 55 .D APPEND^OCXOCMP8(OCXRN,"$") 56 ; 57 W:'$G(OCXAUTO) !,?5,"Resolve Routine Line Tags..." 58 S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",OCXD0)) Q:'OCXD0 D Q:OCXWARN 59 .I '$G(OCXAUTO) W:($X>60) ! W "." 60 .N TEXT,RTN,TEMP,ALT,LABL,OBJ,PIEC 61 .S RTN=$$RNAM(OCXD0) 62 .K TEMP M TEMP=^TMP("OCXCMP",$J,"D CODE",OCXD0) 63 .S OCXD1=0 F OCXOFF=0:1 S OCXD1=$O(TEMP(OCXD1)) Q:'OCXD1 D Q:OCXWARN 64 ..N TEXT,PIEC 65 ..S TEXT=TEMP(OCXD1,0) Q:'(TEXT["||") 66 ..; 67 ..F PIEC=2:2:$L(TEXT,"||") D Q:OCXWARN 68 ...S LABL=$P(TEXT,"||",PIEC) 69 ...I ($E(LABL,1,5)="LINE:") D I 1 70 ....S LABL=$G(^TMP("OCXCMP",$J,"LINE",+$P(LABL,":",2))) 71 ....I '$L(LABL) D WARN^OCXOCMPV("Line Label not found: "_$P(TEXT,"|",2),$P($T(+1)," ",1)) Q 72 ....S:($P(LABL,"^",2)=RTN) LABL=$P(LABL,"^",1) 73 ...; 74 ...E I ($E(LABL,1,5)="LNTAG") D I 1 75 ....N D0,CNT 76 ....S D0=OCXD1 F CNT=1:1 S D0=$O(TEMP(D0),-1) Q:$L($P(TEMP(D0,0)," ",1)) 77 ....S LABL=$P(TEMP(D0,0)," ",1) S:(LABL["(") LABL=$P(LABL,"(",1) 78 ....S LABL="(+$P($H,"","",2))_""<"_LABL_"+"_CNT_U_RTN_">""" 79 ...; 80 ...E D WARN^OCXOCMPV("Unknown Compiler directive: "_LABL,$P($T(+1)," ",1)) Q 81 ...; 82 ...S $P(TEXT,"||",PIEC)=LABL 83 ..; 84 ..F Q:'(TEXT["||") S TEXT=$P(TEXT,"||",1)_$P(TEXT,"||",2,999) 85 ..S TEMP(OCXD1,0)=TEXT 86 .; 87 .K ^TMP("OCXCMP",$J,"D CODE",OCXD0) 88 .M ^TMP("OCXCMP",$J,"D CODE",OCXD0)=TEMP 89 ; 90 Q:OCXWARN 1 91 W:'$G(OCXAUTO) !,?5,"Generate Subroutine and Call documentation..." 92 S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0 D CALL^OCXOCMPT(OCXD0) 93 ; 94 W:'$G(OCXAUTO) !!,?5,"Delete Old OCXOZ* Routines..." 95 S OCXRTEST=^%ZOSF("TEST"),OCXSAVE=^%ZOSF("SAVE"),OCXDEL=^%ZOSF("DEL") 96 F OCXRN=1:1:1290 D 97 .I '$G(OCXAUTO) W:($X>60) ! W:'(OCXRN#100) "." 98 .S X=$$RNAM(OCXRN) X OCXRTEST I X OCXDEL W:'$G(OCXAUTO) "!" 99 ; 100 W:'$G(OCXAUTO) !,?5,"File New OCXOZ* routines..." 101 S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",0)) Q:'OCXD0 1 102 F S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",OCXD0)) Q:'OCXD0 D Q:OCXWARN 103 .I '$G(OCXAUTO) W:($X>60) ! W "." 104 .D FILE^OCXOCMP8(OCXD0) 105 S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",0)) Q:'OCXD0 1 D FILE^OCXOCMP8(OCXD0) 106 ; 107 Q OCXWARN 108 ; 109 GETHDR(RNUM) ; 110 ; 111 N OCXREC,D0,EFC,OCXEFF,PIEC,TEXT 112 S OCXREC(1,0)=$$RNAM(RNUM)_" ;SLC/RJS,CLA - Order Check Scan ;"_$$NOW 113 S OCXREC(2,0)=$T(+2) 114 S OCXREC(3,0)=$T(+3) 115 S OCXREC(4,0)=" ;" 116 S OCXREC(5,0)=" ; ***************************************************************" 117 S OCXREC(6,0)=" ; ** Warning: This routine is automatically generated by the **" 118 S OCXREC(7,0)=" ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine **" 119 S OCXREC(8,0)=" ; ** will be lost the next time the rule compiler executes. **" 120 S OCXREC(9,0)=" ; ***************************************************************" 121 S OCXREC(10,0)=" ;" 122 I (RNUM=1) D 123 .S OCXREC(11,0)=" ; compiled code line length: "_OCXCLL 124 .S OCXREC(12,0)=" ; compiled routine size: "_OCXCRS 125 .S OCXREC(13,0)=" ; triggered rule ignore period: "_OCXTSPI 126 .S OCXREC(14,0)=" ;" 127 .S OCXREC(15,0)=" ; Program Execution Trace Mode: "_$S($G(OCXTRACE):" ON",1:"OFF") 128 .S OCXREC(16,0)=" ;" ; " ; Elapsed time logging: "_$S($G(OCXTLOG):" ON",1:"OFF") 129 .S OCXREC(17,0)=" ; Raw Data Logging: "_$S($G(OCXDLOG):(" ON Keep data for "_OCXDLOG_" day"_$S(OCXDLOG=1:"",1:"s")_" then purge."),1:"OFF") 130 .S OCXREC(18,0)=" ; Compiler mode: "_$S(($G(OCXAUTO)>1):"Queued",$G(OCXAUTO):" ON",1:"OFF") 131 .S OCXREC(19,0)=" ; Compiled by: "_$P($G(^VA(200,+$G(DUZ),0)),U,1)_" (DUZ="_(+$G(DUZ))_")" 132 .S OCXREC(20,0)=" Q" 133 .S OCXREC(21,0)=" ;" 134 ; 135 E D 136 .S OCXREC(11,0)=" Q" 137 .S OCXREC(12,0)=" ;" 138 ; 139 M ^TMP("OCXCMP",$J,"D CODE",RNUM)=OCXREC 140 Q 141 ; 142 RNAM(X) ; 143 N CHAR 144 S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 145 Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1)) 146 ; 147 TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y 148 ; 149 NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y 150 ; 1 OCXOCMP6 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines) ;1/05/04 14:33 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 EN() ; 6 ; 7 Q:$G(OCXWARN) 1 8 N OCXD0,OCXD1,OCXRN,OCXSCNT,OCXOFF 9 ; 10 S OCXLCNT=0 11 ; 12 W:'$G(OCXAUTO) !,?5,"Generate Extrinsic Function and Variables documentation..." 13 S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0 D DOC^OCXOCMPT(OCXD0) 14 ; 15 K ^OCXS(860.3,"APGM") 16 S OCXD0=0 F S OCXD0=$O(^OCXS(860.3,OCXD0)) Q:'OCXD0 D 17 .K ^OCXS(860.3,OCXD0,"RTN") I '$G(OCXAUTO) W:($X>60) ! W "." 18 ; 19 K ^TMP("OCXCMP",$J,"D CODE") 20 ; 21 W:'$G(OCXAUTO) !,?5,"Assign Subroutines to Routines..." 22 S OCXRN=1,OCXD0=0 23 D GETHDR(1) 24 F S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0 D Q:OCXWARN 25 .N OCXLLAB,OCXSKIP,OCXEXF,OCXSUB,OCXSIZE,OCXFILE,OCXCCODE,OCXDCODE,OCXLAST 26 .I '$G(OCXAUTO) W:($X>60) ! W "." 27 .S OCXLLAB=^TMP("OCXCMP",$J,"LINE",OCXD0) 28 .S OCXSKIP=((OCXLLAB="UPDATE")!(OCXLLAB="LOG")) 29 .S OCXSIZE=$$SIZE^OCXOCMP8(OCXRN,OCXD0) 30 .S OCXLAST='$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) 31 .S OCXFILE=(OCXSIZE>OCXCRS)!(OCXLAST) S:OCXSKIP OCXFILE=0 32 .I OCXFILE D 33 ..K OCXEXF S OCXEXF="" 34 ..I $D(^TMP("OCXCMP",$J,"D CODE",OCXRN,"CALLS")) M OCXEXF=^("CALLS") 35 ..S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) I 'OCXEXF(OCXSUB) D 36 ...S OCXEXF(OCXSUB)=1,OCXEXF=OCXSUB 37 ...S OCXSUB="" F S OCXSUB=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXEXF,"CALLS",OCXSUB)) Q:'$L(OCXSUB) D 38 ....S OCXEXF(OCXSUB)=$G(OCXEXF(OCXSUB)) 39 ..S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) D 40 ...D APPEND^OCXOCMP8(OCXRN,OCXSUB,"F") 41 ..D APPEND^OCXOCMP8(OCXRN,"$") 42 ..S OCXRN=OCXRN+1 D GETHDR(OCXRN) 43 ..; 44 .D APPEND^OCXOCMP8(OCXRN,OCXD0,"C",OCXLLAB) 45 .I ($E(OCXLLAB,1,2)="EL") D 46 ..S ^OCXS(860.3,"APGM",(+$E(OCXLLAB,3,$L(OCXLLAB))),(OCXLLAB_U_$$RNAM(OCXRN)))="" 47 .S $P(^TMP("OCXCMP",$J,"LINE",OCXD0),U,2)=$$RNAM(OCXRN) 48 .Q:'OCXLAST 49 .K OCXEXF S OCXEXF="" 50 .I $D(^TMP("OCXCMP",$J,"D CODE",OCXRN,"CALLS")) M OCXEXF=^("CALLS") 51 .S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) I 'OCXEXF(OCXSUB) D 52 ..S OCXEXF(OCXSUB)=1,OCXEXF=OCXSUB 53 ..S OCXSUB="" F S OCXSUB=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXEXF,"CALLS",OCXSUB)) Q:'$L(OCXSUB) D 54 ...S OCXEXF(OCXSUB)=$G(OCXEXF(OCXSUB)) 55 .S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) D 56 ..D APPEND^OCXOCMP8(OCXRN,OCXSUB,"F") 57 .D APPEND^OCXOCMP8(OCXRN,"$") 58 ; 59 W:'$G(OCXAUTO) !,?5,"Resolve Routine Line Tags..." 60 S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",OCXD0)) Q:'OCXD0 D Q:OCXWARN 61 .I '$G(OCXAUTO) W:($X>60) ! W "." 62 .N TEXT,RTN,TEMP,ALT,LABL,OBJ,PIEC 63 .S RTN=$$RNAM(OCXD0) 64 .K TEMP M TEMP=^TMP("OCXCMP",$J,"D CODE",OCXD0) 65 .S OCXD1=0 F OCXOFF=0:1 S OCXD1=$O(TEMP(OCXD1)) Q:'OCXD1 D Q:OCXWARN 66 ..N TEXT,PIEC 67 ..S TEXT=TEMP(OCXD1,0) Q:'(TEXT["||") 68 ..; 69 ..F PIEC=2:2:$L(TEXT,"||") D Q:OCXWARN 70 ...S LABL=$P(TEXT,"||",PIEC) 71 ...I ($E(LABL,1,5)="LINE:") D I 1 72 ....S LABL=$G(^TMP("OCXCMP",$J,"LINE",+$P(LABL,":",2))) 73 ....I '$L(LABL) D WARN^OCXOCMPV("Line Label not found: "_$P(TEXT,"|",2),$P($T(+1)," ",1)) Q 74 ....S:($P(LABL,"^",2)=RTN) LABL=$P(LABL,"^",1) 75 ...; 76 ...E I ($E(LABL,1,5)="LNTAG") D I 1 77 ....N D0,CNT 78 ....S D0=OCXD1 F CNT=1:1 S D0=$O(TEMP(D0),-1) Q:$L($P(TEMP(D0,0)," ",1)) 79 ....S LABL=$P(TEMP(D0,0)," ",1) S:(LABL["(") LABL=$P(LABL,"(",1) 80 ....S LABL="(+$P($H,"","",2))_""<"_LABL_"+"_CNT_U_RTN_">""" 81 ...; 82 ...E D WARN^OCXOCMPV("Unknown Compiler directive: "_LABL,$P($T(+1)," ",1)) Q 83 ...; 84 ...S $P(TEXT,"||",PIEC)=LABL 85 ..; 86 ..F Q:'(TEXT["||") S TEXT=$P(TEXT,"||",1)_$P(TEXT,"||",2,999) 87 ..S TEMP(OCXD1,0)=TEXT 88 .; 89 .K ^TMP("OCXCMP",$J,"D CODE",OCXD0) 90 .M ^TMP("OCXCMP",$J,"D CODE",OCXD0)=TEMP 91 ; 92 Q:OCXWARN 1 93 W:'$G(OCXAUTO) !,?5,"Generate Subroutine and Call documentation..." 94 S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0 D CALL^OCXOCMPT(OCXD0) 95 ; 96 W:'$G(OCXAUTO) !!,?5,"Delete Old OCXOZ* Routines..." 97 S OCXRTEST=^%ZOSF("TEST"),OCXSAVE=^%ZOSF("SAVE"),OCXDEL=^%ZOSF("DEL") 98 F OCXRN=1:1:1290 D 99 .I '$G(OCXAUTO) W:($X>60) ! W:'(OCXRN#100) "." 100 .S X=$$RNAM(OCXRN) X OCXRTEST I X OCXDEL W:'$G(OCXAUTO) "!" 101 ; 102 W:'$G(OCXAUTO) !,?5,"File New OCXOZ* routines..." 103 S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",0)) Q:'OCXD0 1 104 F S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",OCXD0)) Q:'OCXD0 D Q:OCXWARN 105 .I '$G(OCXAUTO) W:($X>60) ! W "." 106 .D FILE^OCXOCMP8(OCXD0) 107 S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",0)) Q:'OCXD0 1 D FILE^OCXOCMP8(OCXD0) 108 ; 109 Q OCXWARN 110 ; 111 GETHDR(RNUM) ; 112 ; 113 N OCXREC,D0,EFC,OCXEFF,PIEC,TEXT 114 S OCXREC(1,0)=$$RNAM(RNUM)_" ;SLC/RJS,CLA - Order Check Scan ;"_$$NOW 115 S OCXREC(2,0)=$T(+2) 116 S OCXREC(3,0)=$T(+3) 117 S OCXREC(4,0)=" ;" 118 S OCXREC(5,0)=" ; ***************************************************************" 119 S OCXREC(6,0)=" ; ** Warning: This routine is automatically generated by the **" 120 S OCXREC(7,0)=" ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine **" 121 S OCXREC(8,0)=" ; ** will be lost the next time the rule compiler executes. **" 122 S OCXREC(9,0)=" ; ***************************************************************" 123 S OCXREC(10,0)=" ;" 124 I (RNUM=1) D 125 .S OCXREC(11,0)=" ; compiled code line length: "_OCXCLL 126 .S OCXREC(12,0)=" ; compiled routine size: "_OCXCRS 127 .S OCXREC(13,0)=" ; triggered rule ignore period: "_OCXTSPI 128 .S OCXREC(14,0)=" ;" 129 .S OCXREC(15,0)=" ; Program Execution Trace Mode: "_$S($G(OCXTRACE):" ON",1:"OFF") 130 .S OCXREC(16,0)=" ;" ; " ; Elapsed time logging: "_$S($G(OCXTLOG):" ON",1:"OFF") 131 .S OCXREC(17,0)=" ; Raw Data Logging: "_$S($G(OCXDLOG):(" ON Keep data for "_OCXDLOG_" day"_$S(OCXDLOG=1:"",1:"s")_" then purge."),1:"OFF") 132 .S OCXREC(18,0)=" ; Compiler mode: "_$S(($G(OCXAUTO)>1):"Queued",$G(OCXAUTO):" ON",1:"OFF") 133 .S OCXREC(19,0)=" ; Compiled by: "_$P($G(^VA(200,+$G(DUZ),0)),U,1)_" (DUZ="_(+$G(DUZ))_")" 134 .S OCXREC(20,0)=" Q" 135 .S OCXREC(21,0)=" ;" 136 ; 137 E D 138 .S OCXREC(11,0)=" Q" 139 .S OCXREC(12,0)=" ;" 140 ; 141 M ^TMP("OCXCMP",$J,"D CODE",RNUM)=OCXREC 142 Q 143 ; 144 RNAM(X) ; 145 N CHAR 146 S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 147 Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1)) 148 ; 149 TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y 150 ; 151 NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y 152 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP8.m
r613 r623 1 OCXOCMP8 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines utilities) ;10/29/98 12:37 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 Q 6 FILE(RNUM) ; 7 ; 8 W:'$G(OCXAUTO) !,$$RNAM(RNUM) 9 N DIE,XCN,X 10 S DIE="^TMP(""OCXCMP"",$J,""D CODE"","_RNUM_",",XCN=0,X=$$RNAM(RNUM) 11 X ^%ZOSF("SAVE") 12 Q 13 ; 14 APPEND(DSUB,CSUB,SRC,LABEL) ; 15 ; 16 N OCXSRC,OCXNDX,OCXNEXT,GLD,GLC 17 S GLD="^TMP(""OCXCMP"",$J,""D CODE"","_(+DSUB)_")" 18 I (CSUB="$") D Q 19 .S OCXNEXT=$O(@GLD@(" "),-1)+1 20 .S @GLD@(OCXNEXT,0)="$" 21 .S OCXNEXT=$O(@GLD@(" "),-1)+1 22 .S @GLD@(OCXNEXT,0)="" 23 ; 24 I (SRC="C") M GLC=^TMP("OCXCMP",$J,"C CODE",+CSUB) S ^TMP("OCXCMP",$J,"D CODE","LINE",LABEL)=DSUB_","_($O(@GLD@(" "),-1)+1) 25 I (SRC="F") M GLC=^TMP("OCXCMP",$J,"INCLUDE",CSUB) 26 S OCXNDX=0 F S OCXNDX=$O(GLC(OCXNDX)) Q:'OCXNDX D 27 .S OCXNEXT=$O(@GLD@(" "),-1)+1 28 .S @GLD@(OCXNEXT,0)=GLC(OCXNDX,0) 29 M @GLD@("CALLS")=GLC("CALLS") 30 S @GLD@("SIZE")=$G(@GLD@("SIZE"))+$G(GLC("SIZE")) 31 Q 32 ; 33 SIZE(DSUB,CSUB) ; 34 ; 35 N D0,EFC,OCXEFC,OCXEFD,OCXEFF,OCXREC 36 N OCXTEMP,PIEC,SIZEC,SIZED,SIZEF,TEXT 37 ; 38 S (SIZEC,SIZED,SIZEF)=0 39 K OCXEFF,OCXEFC,OCXEFD 40 S (OCXEFF,OCXEFC,OCXEFD)="" 41 ; 42 I $G(CSUB),$D(^TMP("OCXCMP",$J,"C CODE",+CSUB)) D 43 .I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")) D Q 44 ..S SIZEC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE") 45 ..I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")) D 46 ...K OCXEFC M OCXEFC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS") 47 .K OCXREC M OCXREC=^TMP("OCXCMP",$J,"C CODE",+CSUB) 48 .S D0=0 F S D0=$O(OCXREC(D0)) Q:'D0 D 49 ..S TEXT=OCXREC(D0,0),SIZEC=SIZEC+$L(TEXT) 50 ..Q:'(TEXT["$$") 51 ..F PIEC=2:1:$L(TEXT,"$$") D 52 ...S EFC=$P($P(TEXT,"$$",PIEC),"(",1) 53 ...S:(EFC[" ") EFC=$P(EFC," ",1) Q:(EFC["^") Q:'$L(EFC) 54 ...I '$D(^TMP("OCXCMP",$J,"INCLUDE",EFC)) D Q 55 ....D WARN^OCXOCMPV("Unknown Local Extrinsic Function: "_EFC,$P($T(+1)," ",1)) Q 56 ...S OCXEFC(EFC)="" 57 .S SIZEC=SIZEC+100 ; ADJUST FOR SUBROUTINE DOCUMENTATION 58 .S ^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")=SIZEC 59 .M ^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")=OCXEFC 60 ; 61 I $G(DSUB),$D(^TMP("OCXCMP",$J,"D CODE",+DSUB)) D 62 .I $G(^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE")) D Q 63 ..S SIZED=^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE") 64 ..I $D(^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS")) D 65 ...K OCXEFD M OCXEFD=^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS") 66 ; 67 K OCXEFF M OCXEFF=OCXEFC,OCXEFF=OCXEFD 68 ; 69 I $D(OCXEFF) S EFC="" F S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC) I 'OCXEFF(EFC) D 70 .K OCXTEMP 71 .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE")) M OCXTEMP("SIZE")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE") 72 .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS")) M OCXTEMP("CALLS")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS") 73 .S OCXEFF(EFC)=OCXTEMP("SIZE") 74 .Q:'$D(OCXTEMP("CALLS")) 75 .S EFC="" F S EFC=$O(OCXTEMP("CALLS",EFC)) Q:'$L(EFC) S OCXEFF(EFC)=+$G(OCXEFF(EFC)) 76 ; 77 I $D(OCXEFF) S EFC="" F S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC) S SIZEF=SIZEF+OCXEFF(EFC) 78 ; 79 Q $G(SIZEC)+$G(SIZED)+$G(SIZEF) 80 ; 81 RNAM(X) ; 82 N CHAR 83 S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 84 Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1)) 85 ; 86 TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y 87 ; 88 NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y 89 ; 1 OCXOCMP8 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines utilities) ;6:55 PM 24 Jan 2008 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997;Build 2 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; Modified from FOIA VISTA, 6 ; Copyright (C) 2007 WorldVistA 7 ; 8 ; This program is free software; you can redistribute it and/or modify 9 ; it under the terms of the GNU General Public License as published by 10 ; the Free Software Foundation; either version 2 of the License, or 11 ; (at your option) any later version. 12 ; 13 Q 14 FILE(RNUM) ; 15 ; 16 W:'$G(OCXAUTO) !,$$RNAM(RNUM) 17 N DIE,XCN,X 18 S DIE="^TMP(""OCXCMP"",$J,""D CODE"","_RNUM_",",XCN=0,X=$$RNAM(RNUM) 19 X ^%ZOSF("SAVE") 20 ; 21 ; WVEHR/SO 01/24/08 ;Commented out next 2 lines 22 ; W:'$G(OCXAUTO) " ...",XCM," lines filed." 23 ; S OCXLCNT=$G(OCXLCNT)+XCM 24 ; 25 Q 26 ; 27 APPEND(DSUB,CSUB,SRC,LABEL) ; 28 ; 29 N OCXSRC,OCXNDX,OCXNEXT,GLD,GLC 30 S GLD="^TMP(""OCXCMP"",$J,""D CODE"","_(+DSUB)_")" 31 I (CSUB="$") D Q 32 .S OCXNEXT=$O(@GLD@(" "),-1)+1 33 .S @GLD@(OCXNEXT,0)="$" 34 .S OCXNEXT=$O(@GLD@(" "),-1)+1 35 .S @GLD@(OCXNEXT,0)="" 36 ; 37 I (SRC="C") M GLC=^TMP("OCXCMP",$J,"C CODE",+CSUB) S ^TMP("OCXCMP",$J,"D CODE","LINE",LABEL)=DSUB_","_($O(@GLD@(" "),-1)+1) 38 I (SRC="F") M GLC=^TMP("OCXCMP",$J,"INCLUDE",CSUB) 39 S OCXNDX=0 F S OCXNDX=$O(GLC(OCXNDX)) Q:'OCXNDX D 40 .S OCXNEXT=$O(@GLD@(" "),-1)+1 41 .S @GLD@(OCXNEXT,0)=GLC(OCXNDX,0) 42 M @GLD@("CALLS")=GLC("CALLS") 43 S @GLD@("SIZE")=$G(@GLD@("SIZE"))+$G(GLC("SIZE")) 44 Q 45 ; 46 SIZE(DSUB,CSUB) ; 47 ; 48 N D0,EFC,OCXEFC,OCXEFD,OCXEFF,OCXREC 49 N OCXTEMP,PIEC,SIZEC,SIZED,SIZEF,TEXT 50 ; 51 S (SIZEC,SIZED,SIZEF)=0 52 K OCXEFF,OCXEFC,OCXEFD 53 S (OCXEFF,OCXEFC,OCXEFD)="" 54 ; 55 I $G(CSUB),$D(^TMP("OCXCMP",$J,"C CODE",+CSUB)) D 56 .I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")) D Q 57 ..S SIZEC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE") 58 ..I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")) D 59 ...K OCXEFC M OCXEFC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS") 60 .K OCXREC M OCXREC=^TMP("OCXCMP",$J,"C CODE",+CSUB) 61 .S D0=0 F S D0=$O(OCXREC(D0)) Q:'D0 D 62 ..S TEXT=OCXREC(D0,0),SIZEC=SIZEC+$L(TEXT) 63 ..Q:'(TEXT["$$") 64 ..F PIEC=2:1:$L(TEXT,"$$") D 65 ...S EFC=$P($P(TEXT,"$$",PIEC),"(",1) 66 ...S:(EFC[" ") EFC=$P(EFC," ",1) Q:(EFC["^") Q:'$L(EFC) 67 ...I '$D(^TMP("OCXCMP",$J,"INCLUDE",EFC)) D Q 68 ....D WARN^OCXOCMPV("Unknown Local Extrinsic Function: "_EFC,$P($T(+1)," ",1)) Q 69 ...S OCXEFC(EFC)="" 70 .S SIZEC=SIZEC+100 ; ADJUST FOR SUBROUTINE DOCUMENTATION 71 .S ^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")=SIZEC 72 .M ^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")=OCXEFC 73 ; 74 I $G(DSUB),$D(^TMP("OCXCMP",$J,"D CODE",+DSUB)) D 75 .I $G(^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE")) D Q 76 ..S SIZED=^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE") 77 ..I $D(^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS")) D 78 ...K OCXEFD M OCXEFD=^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS") 79 ; 80 K OCXEFF M OCXEFF=OCXEFC,OCXEFF=OCXEFD 81 ; 82 I $D(OCXEFF) S EFC="" F S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC) I 'OCXEFF(EFC) D 83 .K OCXTEMP 84 .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE")) M OCXTEMP("SIZE")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE") 85 .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS")) M OCXTEMP("CALLS")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS") 86 .S OCXEFF(EFC)=OCXTEMP("SIZE") 87 .Q:'$D(OCXTEMP("CALLS")) 88 .S EFC="" F S EFC=$O(OCXTEMP("CALLS",EFC)) Q:'$L(EFC) S OCXEFF(EFC)=+$G(OCXEFF(EFC)) 89 ; 90 I $D(OCXEFF) S EFC="" F S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC) S SIZEF=SIZEF+OCXEFF(EFC) 91 ; 92 Q $G(SIZEC)+$G(SIZED)+$G(SIZEF) 93 ; 94 RNAM(X) ; 95 N CHAR 96 S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 97 Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1)) 98 ; 99 TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y 100 ; 101 NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y 102 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMPV.m
r613 r623 1 OCXOCMPV 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105,221,243**;Dec 17,1997;Build 242 3 4 5 MAN 6 7 N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXOETIM,OCXAUTO,OCXERRM,OCXTSPI8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 MESG(OCXX) 38 39 40 41 42 ERMESG(OCXX) 43 44 45 46 47 48 49 WARN(X,FILE,D0,RLINE) 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 READ(OCXZ0,OCXZA,OCXZB,OCXZL) 93 94 95 96 97 98 99 100 101 102 103 104 105 DT(X,D) 106 107 108 CNT(X) 109 110 111 112 113 114 115 AUTO 116 N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXAUTO,OCXOETIM,OCXTSPI117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 BULL(OCXDUZ) 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 .S XMB(9)="No longer tracked" ;$S($G(OCXLCNT):OCXLCNT,1:"Zero")158 159 160 161 162 163 164 165 166 167 168 169 DATE() 170 171 CONV(Y) 172 173 SETFLAG 174 175 176 177 178 KILLFLAG 179 180 181 182 183 184 QUE(OCXADD) 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 TASK 202 203 N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXAUTO,OCXOETIM,OCXTSPI204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 1 OCXOCMPV ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Main Entry point - All Rules cont...) ;1/05/04 14:09 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 MAN ; 6 I '$D(DUZ) W !!,"DUZ not defined." Q 7 N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXOETIM,OCXLCNT,OCXAUTO,OCXERRM,OCXTSPI 8 S OCXWARN=0,OCXOETIM=$H 9 K ^TMP("OCXCMP",$J) 10 S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" 11 ; 12 ; Compiler Constants 13 ; 14 S OCXCLL=200 ; compiled code line length 15 S OCXCRS=4000 ; compiled routine size 16 S OCXTSPI=300 ; Duplicate triggered Rule message "ignore period" in seconds 17 ; 18 S OCXTRACE=0,OCXTLOG=0,OCXDLOG=0,OCXAUTO=0,OCXERRM="" 19 ; 20 S OCXTRACE=$$READ("Y","Want to enable Compiled Routine Execution Display ","NO") Q:(OCXTRACE[U) 21 S OCXDLOG=$$READ("Y","Want to enable Logging of incoming raw data ","NO") Q:(OCXDLOG[U) 22 I OCXDLOG S OCXDLOG=$$READ("N^1:20","Number of days to keep raw data ","3") Q:(OCXDLOG[U) 23 I OCXDLOG W !!,"*** Note: The raw data log will only hold 200,000 entries. *****",! 24 I 0 I OCXDLOG S OCXTLOG=$$READ("Y","Want to enable Elapsed Time Logging ","YES") Q:(OCXTLOG[U) 25 ; 26 Q:'$$READ("Y","Are you sure you want to recompile the Expert System routines ","NO") 27 ; 28 D SETFLAG 29 L +^OCXD(861,1):5 E D ERMESG("Run aborted. Another compiler run has ^OCXD(861,1) locked.") Q 30 D RUN^OCXOCMP,BULL(DUZ),KILLFLAG 31 L -^OCXD(861,1) 32 ; 33 ;K ^TMP("OCXCMP",$J) 34 ; 35 Q 36 ; 37 MESG(OCXX) ; 38 I '$G(OCXAUTO) W !!,OCXX 39 I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX) 40 Q 41 ; 42 ERMESG(OCXX) ; 43 N OCXY S OCXY=OCXX 44 I '$G(OCXAUTO) W !!,OCXX 45 I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX) 46 S OCXERRM=OCXY 47 Q 48 ; 49 WARN(X,FILE,D0,RLINE) ; 50 ; 51 Q:$G(OCXWARN) 52 ; 53 S OCXWARN=1 54 ; 55 I $G(OCXAUTO) D Q 56 .D MESG(" Error... "_X) 57 .D MESG(" Error... File:"_(+$G(FILE))) 58 .D MESG(" Error... Index:"_(+$G(D0))) 59 .D MESG(" Error... Order Check Routine Compile Aborted.") 60 ; 61 S OCXWARN=$G(OCXWARN)+1 62 N OCXSP,OCXST,OCXTXT,OCXLEN,OCXZZZ,OCXCNT 63 S OCXLEN=60,OCXTXT="Compiler Warning # "_OCXWARN 64 I ($D(X)>2) S OCXCNT=0 F S OCXCNT=$O(X(OCXCNT)) Q:'OCXCNT D 65 .I ($L(X(OCXCNT))>OCXLEN),($L(X(OCXCNT))<80) S OCXLEN=$L(X(OCXCNT)) 66 S (OCXSP,OCXST)="",$P(OCXST,"*",150)="*",$P(OCXSP," ",150)=" " 67 W !! 68 W !,$E(OCXST,1,OCXLEN+6) 69 W !,"**",$E(OCXSP,1,OCXLEN+2),"**" 70 W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **" 71 W:$L($G(RLINE)) !,"** ",RLINE,$E(OCXSP,$L(RLINE),OCXLEN-1)," **" 72 W !,"**",$E(OCXSP,1,OCXLEN+2),"**" 73 S OCXGL="^OCXS" S:(FILE=1) OCXGL="^OCXD" S:(FILE=7) OCXGL="^OCXD" S:(FILE=10) OCXGL="^OCXD" S FILE=FILE/10+860 74 I $G(FILE),$G(D0),$D(@OCXGL@(FILE,D0,0)) D 75 .S OCXTXT=$P(@OCXGL@(FILE,0),U,1) 76 .W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **" 77 .S OCXTXT=" "_$P(@OCXGL@(FILE,D0,0),U,1) 78 .W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **" 79 W !,"**",$E(OCXSP,1,OCXLEN+2),"**" 80 I ($D(X)#2) D 81 .W !,"** " F OCXCNT=1:1:$L(X," ") D 82 ..I (($X+$L($P(X," ",OCXCNT)))>OCXLEN) W $E(OCXSP,$X,OCXLEN+2)," **",!,"** " 83 ..W $P(X," ",OCXCNT)," " 84 .W $E(OCXSP,$X,OCXLEN+2)," **" 85 I ($D(X)>2) S OCXCNT=0 F S OCXCNT=$O(X(OCXCNT)) Q:'OCXCNT D 86 .W !,"** ",X(OCXCNT),$E(OCXSP,$X,OCXLEN+2)," **" 87 W !,$E(OCXST,1,OCXLEN+6) 88 W !!!,"Press <Return> to continue... " R OCXZZZ:DTIME 89 Q 90 K D0 91 ; 92 READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; 93 N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT 94 Q:'$L($G(OCXZ0)) U 95 S DIR(0)=OCXZ0 96 S:$L($G(OCXZA)) DIR("A")=OCXZA 97 S:$L($G(OCXZB)) DIR("B")=OCXZB 98 F OCXLINE=1:1:($G(OCXZL)-1) W ! 99 D ^DIR 100 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U 101 Q Y 102 ; 103 Q 104 ; 105 DT(X,D) N Y,%DT S %DT=D D ^%DT Q Y 106 Q 107 ; 108 CNT(X) ; 109 ; 110 N CNT,D0 111 S D0=0 F CNT=1:1 S D0=$O(@X@(D0)) Q:'D0 112 W !!,?10,X," ",CNT 113 Q CNT 114 ; 115 AUTO ; 116 N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXAUTO,OCXOETIM,OCXLCNT,OCXTSPI 117 S OCXWARN=0,OCXOETIM=$H 118 K ^TMP("OCXCMP",$J) 119 S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" 120 ; 121 ; Compiler Constants 122 ; 123 S OCXCLL=200 ; compiled code line length 124 S OCXCRS=8000 ; compiled routine size 125 S OCXTSPI=300 ; Duplicate triggered Rule message "ignore period" in seconds 126 ; 127 S OCXTRACE=0 ; Program Execution Trace Mode (OFF) 128 S OCXTLOG=0 ; Elapsed time logging (OFF) 129 S OCXDLOG=0 ; Raw Data Logging (OFF) 130 S OCXAUTO=1 ; Compile in the Background Mode (ON) 131 ; 132 D SETFLAG 133 L +^OCXD(861,1):5 E D ERMESG("Run aborted. Another compiler run has ^OCXD(861,1) locked."),BULL(DUZ),KILLFLAG Q 134 D RUN^OCXOCMP,BULL(DUZ),KILLFLAG 135 L -^OCXD(861,1) 136 ; 137 K ^TMP("OCXCMP",$J) 138 ; 139 Q 140 ; 141 BULL(OCXDUZ) ; 142 I $L($T(^XMB)) D 143 .; 144 .N XMB,XMDUZ,XMY,OCXTIME 145 .S OCXTIME=$H-OCXOETIM*86400 146 .S OCXTIME=OCXTIME+($P($H,",",2)-$P(OCXOETIM,",",2)) 147 .S XMB="OCX COMPILER RUN" 148 .S XMB(1)=$P($T(+3),";;",3) 149 .S XMB(2)=$$CONV($$DATE) 150 .S XMB(3)="" 151 .S:$G(OCXDUZ) XMB(3)="["_OCXDUZ_"] "_$P($G(^VA(200,OCXDUZ,0)),U,1) 152 .S XMB(4)=(OCXTIME\60)_" minutes "_(OCXTIME#60)_" seconds " 153 .S XMB(5)=$S(($G(OCXAUTO)>1):"Queued",$G(OCXAUTO):"Automatic Mode",1:"Interactive Mode") 154 .S XMB(6)=$S($G(OCXTRACE):" ON",1:"OFF") 155 .S XMB(7)=" " ; $S($G(OCXTLOG):" ON",1:"OFF") 156 .S XMB(8)=$S($G(OCXDLOG):(" ON Keep data for "_OCXDLOG_" day"_$S(OCXDLOG=1:"",1:"s")_" then purge."),1:"OFF") 157 .S XMB(9)=$S($G(OCXLCNT):OCXLCNT,1:"Zero") 158 .S XMB(10)=$G(OCXERRM) 159 .S XMB(11)=$S($L($G(OCXERRM)):"ABORTED",1:"has completed normally") 160 .S XMY("G.OCX DEVELOPERS@ISC-SLC.VA.GOV")="" 161 .S XMY("G.OCX DEVELOPERS")="" 162 .S XMY(OCXDUZ)="" 163 .S XMDUZ=.5 164 .S XMDT="N" 165 .D ^XMB 166 ; 167 Q 168 ; 169 DATE() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") Q Y 170 ; 171 CONV(Y) Q:'(Y["@") Y Q $P(Y,"@",1)_" at "_$P(Y,"@",2,99) 172 ; 173 SETFLAG ; 174 I '($P($G(^OCXD(861,1,0)),U,1)="SITE PREFERENCES") K ^OCXD(861,1) S ^OCXD(861,1,0)="SITE PREFERENCES" 175 S $P(^OCXD(861,1,0),U,3)=$H 176 Q 177 ; 178 KILLFLAG ; 179 ; 180 I '($P($G(^OCXD(861,1,0)),U,1)="SITE PREFERENCES") K ^OCXD(861,1) S ^OCXD(861,1,0)="SITE PREFERENCES" 181 S $P(^OCXD(861,1,0),U,3)="" 182 Q 183 ; 184 QUE(OCXADD) ; 185 ; 186 N ZTCPU,ZTDESC,ZTDTH,ZTIO,ZTPAR,ZTPRE,ZTPRI,ZTRTN,ZTSAVE,ZTSK,ZTUCI 187 N OCXDUZ 188 ; 189 S ZTDTH=$P($H,",",2)+OCXADD,OCXADD=0 190 I (ZTDTH>86400) S ZTDTH=(86400-ZTDTH),OCXADD=1 191 S ZTDTH=($H+OCXADD)_","_ZTDTH 192 S OCXDUZ=$G(DUZ) 193 S ZTIO="",ZTRTN="TASK^OCXOCMPV",ZTDESC="Queued Compiler: "_$P($T(+3),";;",2) 194 K ZTSAVE,ZTCPU,ZTUCI,ZTPRI,ZTPAR,ZTPRE 195 S ZTSAVE("OCXDUZ")="" 196 ; 197 D ^%ZTLOAD 198 ; 199 Q 200 ; 201 TASK ; 202 ; 203 N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXAUTO,OCXOETIM,OCXLCNT,OCXTSPI 204 S OCXWARN=0,OCXOETIM=$H 205 K ^TMP("OCXCMP",$J) 206 S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" 207 ; 208 ; Compiler Constants 209 ; 210 S OCXCLL=200 ; compiled code line length 211 S OCXCRS=8000 ; compiled routine size 212 S OCXTSPI=300 ; Duplicate triggered Rule message "ignore period" in seconds 213 ; 214 S OCXDATA="0^0^0" 215 I $L($T(CDATA^OCXOZ01)) S OCXDATA=$$CDATA^OCXOZ01 216 ; 217 S OCXTRACE=$P(OCXDATA,U,1),OCXTLOG=$P(OCXDATA,U,2),OCXDLOG=$P(OCXDATA,U,3) 218 ; 219 S OCXAUTO=2 ; Compile in the Background Mode (ON QUEUED) 220 ; 221 D SETFLAG 222 L +^OCXD(861,1):5 E D QUE^OCXOCMPV(300),ERMESG("Run rescheduled. Another compiler run has ^OCXD(861,1) locked."),BULL(OCXDUZ),KILLFLAG Q 223 D RUN^OCXOCMP,BULL(OCXDUZ),KILLFLAG 224 L -^OCXD(861,1) 225 ; 226 K ^TMP("OCXCMP",$J) 227 ; 228 I $G(ZTSK) D KILL^%ZTLOAD 229 ; 230 Q 231 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ01.m
r613 r623 1 OCXOZ01 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ; Compiled by: DEWAYNE,ROBERT (DUZ=9)20 21 22 LOG() 23 24 25 26 27 CDATA() 28 29 30 31 32 UPDATE(DFN,OCXSRC,OUTMSG) 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 GETDF 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 SWAPOUT(NAME,ARRAY) 104 105 106 107 108 109 110 111 112 113 114 115 SWAPIN(NAME,ARRAY) 116 117 118 119 120 121 122 123 124 125 126 SCAN 127 128 129 130 131 132 133 134 135 136 137 138 139 140 TERM(OCXTERM,OCXLIST) 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 DT2INT(OCXDT) 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 1 OCXOZ01 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 ; compiled code line length: 200 12 ; compiled routine size: 8000 13 ; triggered rule ignore period: 300 14 ; 15 ; Program Execution Trace Mode: OFF 16 ; 17 ; Raw Data Logging: OFF 18 ; Compiler mode: ON 19 ; Compiled by: ORMSBY,SKIP (DUZ=1) 20 Q 21 ; 22 LOG() ; Returns the number of days to keep the Raw Data Log or 0 if logging is disabled. 23 ; External Call. 24 ; 25 Q 0 26 ; 27 CDATA() ; Returns compiler flags, Execution TRACE ON/OFF, Time Logging ON/OFF, and Raw Data Logging ON/OFF 28 ; External Call. 29 ; 30 Q "0^0^0" 31 ; 32 UPDATE(DFN,OCXSRC,OUTMSG) ; Main Entry point for evaluating Rules. 33 ; External Call. 34 ; 35 ; 36 K ^TMP("OCXCHK",$J) 37 S ^TMP("OCXCHK",$J)=($P($H,",",2)+($H*86400)+(2*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" 38 N OCXOERR,OCXOCMSG,OCXNDX,OCXDF,OCXX,OCXTSPI 39 S OCXTSPI=300 40 Q:'$G(DFN) 41 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D GETDF,SWAPOUT("OCXODATA",.OCXODATA) 42 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D CHK1^OCXOZ02 43 I ($G(OCXOSRC)="DGPM PATIENT MOVEMENT PROTOCOL") D CHK23^OCXOZ03 44 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") D CHK58^OCXOZ05 45 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D CHK95^OCXOZ06 46 ; 47 D SCAN 48 ; 49 I $O(OCXOCMSG("")) D 50 .N OCXNDX1,OCXNDX2 51 .S OCXNDX1=0 F S OCXNDX1=$O(OCXOCMSG(OCXNDX1)) Q:'OCXNDX1 D 52 ..S OCXNDX2=0 F S OCXNDX2=$O(OUTMSG(OCXNDX2)) Q:'OCXNDX2 Q:(OUTMSG(OCXNDX2)=OCXOCMSG(OCXNDX1)) 53 ..Q:OCXNDX2 S OUTMSG($O(OUTMSG(999999),-1)+1)=OCXOCMSG(OCXNDX1) 54 K ^TMP("OCXCHK",$J) 55 ; 56 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") K OCXDF D SWAPIN("OCXODATA",.OCXODATA) 57 Q 58 ; 59 GETDF ;This subroutine loads the OCXDF data field array from variables in the environment. 60 ; Called from UPDATE+9. 61 ; 62 Q:$G(OCXOERR) 63 ; 64 ; Local GETDF Variables 65 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) 66 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 67 ; OCXDF(5) ----> Data Field: ORDER PRIORITY (OBR) (FREE TEXT) 68 ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT) 69 ; OCXDF(9) ----> Data Field: ORDER ST D/T (DATE/TIME) 70 ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT) 71 ; OCXDF(13) ---> Data Field: LAB COLLECTION D/T (DATE/TIME) 72 ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT) 73 ; OCXDF(21) ---> Data Field: ORDER PRIORITY (ORC) (FREE TEXT) 74 ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) 75 ; OCXDF(24) ---> Data Field: ORDERABLE ITEM LOCAL TEXT (FREE TEXT) 76 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 77 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 78 ; OCXDF(82) ---> Data Field: PHARMACY LOCAL ORDERABLE ITEM TEXT (FREE TEXT) 79 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) 80 ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC) 81 ; 82 ; Local Extrinsic Functions 83 ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT 84 ; 85 S OCXDF(1)=$P($G(OCXODATA("ORC",1)),"^",1) 86 S OCXDF(2)=$P($G(OCXODATA("ORC",3)),"^",2) 87 S OCXDF(5)=$P($P($G(OCXODATA("OBR",27)),"^",6),";",1) 88 S OCXDF(6)=$P($G(OCXODATA("OBX",8)),"^",1) 89 S OCXDF(9)=$$DT2INT($P($G(OCXODATA("ORC",15)),"^",1)) 90 S OCXDF(12)=$P($G(OCXODATA("OBX",5)),"^",1) 91 S OCXDF(13)=$$DT2INT($P($G(OCXODATA("OBR",7)),"^",1)) 92 S OCXDF(15)=$P($G(OCXODATA("OBX",11)),"^",1) 93 S OCXDF(21)=$P($G(OCXODATA("ORC",7)),"^",6) 94 S OCXDF(23)=$P($G(OCXODATA("OBR",25)),"^",1) 95 S OCXDF(24)=$P($G(OCXODATA("OBR",4)),"^",5) 96 S OCXDF(34)=$P($G(OCXODATA("ORC",2)),"^",1) 97 S OCXDF(37)=$G(OCXODATA("PID",3)) 98 S OCXDF(82)=$P($G(OCXODATA("RXO",1)),"^",5) 99 S OCXDF(113)=$P($G(OCXODATA("OBX",3)),"^",4) 100 S OCXDF(152)=$P($P($G(OCXODATA("OBR",15)),"^",4),";",1) 101 Q 102 ; 103 SWAPOUT(NAME,ARRAY) ; 104 ; Called from UPDATE+9. 105 ; 106 Q:$G(OCXOERR) 107 ; 108 Q:'$L(NAME) 109 K ^TMP("OCXSWAP",$J,NAME) 110 S ^TMP("OCXSWAP",$J)=($P($H,",",2)+($H*86400)+(2*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" 111 M ^TMP("OCXSWAP",$J,NAME)=ARRAY 112 K ARRAY 113 Q 114 ; 115 SWAPIN(NAME,ARRAY) ; 116 ; Called from UPDATE+24. 117 ; 118 Q:$G(OCXOERR) 119 ; 120 Q:'$L(NAME) 121 K ARRAY 122 M ARRAY=^TMP("OCXSWAP",$J,NAME) 123 K ^TMP("OCXSWAP",$J,NAME) 124 Q 125 ; 126 SCAN ; Tests all Rules for Event/Elements that were found to be valid in the UPDATE subroutine. 127 ; Called from UPDATE+15. 128 ; 129 Q:$G(OCXOERR) 130 ; 131 ; 132 N OCXD0,OCXRULE S OCXD0=0 F S OCXD0=$O(^TMP("OCXCHK",$J,DFN,OCXD0)) Q:'OCXD0 D 133 .Q:'($G(^TMP("OCXCHK",$J,DFN,OCXD0))=1) 134 .N OCXPGM S OCXPGM=$O(^OCXS(860.3,"APGM",OCXD0,"")) Q:'$L(OCXPGM) X "I $L($T("_OCXPGM_"))" E Q 135 .D @OCXPGM 136 .S ^TMP("OCXCHK",$J,DFN,OCXD0)=$G(^TMP("OCXCHK",$J,DFN,OCXD0))+10 137 K ^TMP("OCXCHK",$J) 138 Q 139 ; 140 TERM(OCXTERM,OCXLIST) ; Local Term Lookup 141 ; Internal Call. 142 ; 143 Q:$G(OCXOERR) 144 ; 145 Q:'$L(OCXTERM) 0 146 ; 147 N FILE,IEN,LINE,LTERM,NTERM,TEXT S FILE=0 K OCXLIST 148 F LINE=1:1:999 S TEXT=$T(TERM+LINE) Q:$P(TEXT,";",2) I ($E(TEXT,2,3)=";;") D 149 .S TEXT=$P(TEXT,";;",2) 150 .S NTERM=$P(TEXT,U,1) Q:'$L(NTERM) Q:'(OCXTERM=NTERM) 151 .S FILE=$P(TEXT,U,2),IEN=$P(TEXT,U,3),LTERM=$P(TEXT,U,4) 152 .S OCXLIST(IEN)=LTERM,OCXLIST("B",LTERM,IEN)="" 153 ; 154 Q FILE 155 ; 156 ;TERM DATA; 157 ;1; 158 ; 159 Q 160 ; 161 DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer 162 ; By taking the Years, Months, Days, Hours and Minutes converting 163 ; Them into Seconds and then adding them all together into one big integer 164 ; 165 Q:'$L($G(OCXDT)) "" 166 N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0 167 ; 168 I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT 169 .N OCXHR,OCXMIN,OCXTIME 170 .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2) 171 .S:(OCXDT["Midnight") OCXHR=00 172 .S:(OCXDT["PM") OCXHR=OCXHR+12 173 .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3) 174 ; 175 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT 176 .N OCXMON 177 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) 178 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","") 179 .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2) 180 ; 181 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT 182 .N OCXMON 183 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) 184 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","") 185 .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3) 186 ; 187 I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT 188 .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1 189 .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y 190 ; 191 I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT 192 ; 193 I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT 194 ; 195 I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT 196 ; 197 Q OCXVAL 198 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ02.m
r613 r623 1 OCXOZ02 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 CHK1 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 I $L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)) D CHK436^OCXOZ0E47 I $L(OCXDF(12)),$L(OCXDF(152)),$L(OCXDF(113)) D CHK463^OCXOZ0F48 49 50 CHK2 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 CHK6 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 CHK11 91 92 93 94 95 96 97 98 99 100 101 FILE(DFN,OCXELE,OCXDFL) 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 LIST(DATA,LIST) 117 118 119 120 121 ORDITEM(OIEN) 122 123 124 125 126 127 128 PATLOC(DFN) 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 1 OCXOZ02 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK1 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from UPDATE+10^OCXOZ01. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK1 Variables 19 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) 20 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 21 ; OCXDF(5) ----> Data Field: ORDER PRIORITY (OBR) (FREE TEXT) 22 ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT) 23 ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT) 24 ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT) 25 ; OCXDF(21) ---> Data Field: ORDER PRIORITY (ORC) (FREE TEXT) 26 ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) 27 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 28 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 29 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) 30 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) 31 ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC) 32 ; 33 ; Local Extrinsic Functions 34 ; FILE(DFN,16, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 OERR ORDER) 35 ; LIST( ------------> IN LIST OPERATOR 36 ; PATLOC( ----------> PATIENT LOCATION 37 ; 38 I $L(OCXDF(23)) D CHK2 39 I $L(OCXDF(1)) D CHK12^OCXOZ03 40 I $L(OCXDF(2)),(OCXDF(2)="OR") S OCXOERR=$$FILE(DFN,16,"") Q:OCXOERR 41 I $L(OCXDF(6)) D CHK34^OCXOZ04 42 I $L(OCXDF(15)),$$LIST(OCXDF(15),"F,C") D CHK47^OCXOZ05 43 I $L(OCXDF(34)) D CHK113^OCXOZ06 44 I $L(OCXDF(5)),(OCXDF(5)="S") D CHK151^OCXOZ07 45 I $L(OCXDF(21)),(OCXDF(21)="S") D CHK157^OCXOZ07 46 I $L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)) D CHK444^OCXOZ0E 47 I $L(OCXDF(12)),$L(OCXDF(152)),$L(OCXDF(113)) D CHK471^OCXOZ0F 48 Q 49 ; 50 CHK2 ; Look through the current environment for valid Event/Elements for this patient. 51 ; Called from CHK1+25. 52 ; 53 Q:$G(OCXOERR) 54 ; 55 ; Local CHK2 Variables 56 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) 57 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 58 ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) 59 ; 60 ; Local Extrinsic Functions 61 ; LIST( ------------> IN LIST OPERATOR 62 ; 63 I $$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK6 64 I (OCXDF(23)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK121^OCXOZ07 65 Q 66 ; 67 CHK6 ; Look through the current environment for valid Event/Elements for this patient. 68 ; Called from CHK2+13. 69 ; 70 Q:$G(OCXOERR) 71 ; 72 ; Local CHK6 Variables 73 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 74 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 75 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 76 ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) 77 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 78 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) 79 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 80 ; 81 ; Local Extrinsic Functions 82 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 83 ; PATLOC( ----------> PATIENT LOCATION 84 ; 85 I ($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK11 86 I (OCXDF(2)="RA"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) D CHK302^OCXOZ0C 87 I (OCXDF(2)="GMRC"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) D CHK336^OCXOZ0C 88 Q 89 ; 90 CHK11 ; Look through the current environment for valid Event/Elements for this patient. 91 ; Called from CHK6+18. 92 ; 93 Q:$G(OCXOERR) 94 ; 95 ; Local Extrinsic Functions 96 ; FILE(DFN,5, ------> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 FINAL LAB RESULT) 97 ; 98 S OCXOERR=$$FILE(DFN,5,"12,37,96,113,147,152") Q:OCXOERR 99 Q 100 ; 101 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 102 ; 103 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 104 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 105 ; 106 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 107 ; 108 S OCXDATA(DFN,OCXELE)=1 109 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 110 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 111 ; 112 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 113 ; 114 Q 0 115 ; 116 LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST 117 ; 118 S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," 119 Q (LIST[DATA) 120 ; 121 ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER 122 Q:'$G(OIEN) "" 123 ; 124 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." 125 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." 126 Q $P(X,U,1) 127 ; 128 PATLOC(DFN) ; Compiler Function: PATIENT LOCATION 129 ; 130 N OCXP1,OCXP2 131 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) 132 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) 133 I OCXP2 D 134 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) 135 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) 136 .E S OCXP2=$P(OCXP2,"^",1) 137 .S:'$L(OCXP2) OCXP2="NO LOC" 138 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 139 ; 140 S OCXP2=$G(^DPT(+$G(DFN),.1)) 141 I $L(OCXP2) Q "I^"_OCXP2 142 Q "O^OUTPT" 143 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ03.m
r613 r623 1 OCXOZ03 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 CHK12 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 CHK23 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 FILE(DFN,OCXELE,OCXDFL) 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 FOODDRG(OCXOR) 86 87 88 89 90 91 92 93 94 95 LIST(DATA,LIST) 96 97 98 99 100 OI(OCXOR) 101 102 103 104 105 106 PATLOC(DFN) 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 POINTER(OCXFILE,D0) 123 124 125 126 127 128 129 130 TERMLKUP(OCXTERM,OCXLIST) 131 132 133 WARDSERV(WARD) 134 135 136 137 138 139 140 141 142 1 OCXOZ03 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK12 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK1+26^OCXOZ02. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK12 Variables 19 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) 20 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 21 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 22 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 23 ; OCXDF(105) --> Data Field: ORDER TEXT (51 CHARS) (FREE TEXT) 24 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) 25 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 26 ; OCXDF(148) --> Data Field: FOOD-DRUG INTERACTION MED (BOOLEAN) 27 ; 28 ; Local Extrinsic Functions 29 ; FILE(DFN,126, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 DCED OERR ORDER) 30 ; FILE(DFN,20, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB ORDER CANCELLED) 31 ; FILE(DFN,30, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY ORDER PUT ON-HOLD) 32 ; FILE(DFN,31, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY ORDER CANCELLED) 33 ; FILE(DFN,32, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY ORDER DISCONTINUED) 34 ; FILE(DFN,40, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB REQUEST CANCELLED) 35 ; FILE(DFN,6, ------> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 NEW OERR ORDER) 36 ; FOODDRG( ---------> FOOD-DRUG INTERACTION MED 37 ; LIST( ------------> IN LIST OPERATOR 38 ; PATLOC( ----------> PATIENT LOCATION 39 ; 40 I $$LIST(OCXDF(1),"NW,SN,XR"),$L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,6,"147") Q:OCXOERR 41 I (OCXDF(1)="OC"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,20,"105") Q:OCXOERR 42 I (OCXDF(1)="OH"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,30,"105") Q:OCXOERR 43 I (OCXDF(1)="OD"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,31,"105") Q:OCXOERR 44 I (OCXDF(1)="DC"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,32,"105") Q:OCXOERR 45 I (OCXDF(1)="CA"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,40,"105") Q:OCXOERR 46 I $$LIST(OCXDF(1),"NW,SN,XO"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) D CHK131^OCXOZ07 47 I $$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(148)=$P($$FOODDRG(OCXDF(34)),"^",1) I $L(OCXDF(148)),(OCXDF(148)),$L(OCXDF(37)) D CHK270^OCXOZ0B 48 I $$LIST(OCXDF(1),"DC,CA,OD,OC"),$L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,126,"147") Q:OCXOERR 49 Q 50 ; 51 CHK23 ; Look through the current environment for valid Event/Elements for this patient. 52 ; Called from UPDATE+11^OCXOZ01. 53 ; 54 Q:$G(OCXOERR) 55 ; 56 ; Local CHK23 Variables 57 ; OCXDF(25) ---> Data Field: PATIENT MOVEMENT TYPE CURRENT (FREE TEXT) 58 ; OCXDF(92) ---> Data Field: PATIENT MOVEMENT WARD IEN CURRENT (NUMERIC) 59 ; OCXDF(93) ---> Data Field: PATIENT MOVEMENT WARD IEN PREVIOUS (NUMERIC) 60 ; OCXDF(94) ---> Data Field: PATIENT MOVEMENT SERVICE PREVIOUS (FREE TEXT) 61 ; 62 ; Local Extrinsic Functions 63 ; POINTER( ---------> RETURN POINTED TO VALUE 64 ; WARDSERV( --------> GET WARD SERVICE 65 ; 66 S OCXDF(25)=$$POINTER(405.3,$P($G(DGPMA),"^",2)) I $L(OCXDF(25)) D CHK25^OCXOZ04 67 S OCXDF(93)=$P($G(DGPM0),"^",6) I $L(OCXDF(93)) S OCXDF(94)=$$WARDSERV(OCXDF(93)) I $L(OCXDF(94)),(OCXDF(94)="PSYCHIATRY") S OCXDF(92)=$P($G(DGPMA),"^",6) D CHK87^OCXOZ05 68 Q 69 ; 70 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 71 ; 72 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 73 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 74 ; 75 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 76 ; 77 S OCXDATA(DFN,OCXELE)=1 78 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 79 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 80 ; 81 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 82 ; 83 Q 0 84 ; 85 FOODDRG(OCXOR) ;func rtns 1^<med name> if OCXOR is food-drug med 86 N OCXTL,OCXT,OCXFD,OCXOI 87 S OCXOI=$$OI(OCXOR) 88 Q:'$L(OCXOI) "0^" 89 Q:'$$TERMLKUP("FOOD-DRUG INTERACTION MED",.OCXTL) "0^" 90 S OCXFD="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D Q:$L(OCXFD) 91 .I OCXT=OCXOI S OCXFD="1^"_OCXTL(OCXT) 92 Q:'$L(OCXFD) "0^" 93 Q OCXFD 94 ; 95 LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST 96 ; 97 S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," 98 Q (LIST[DATA) 99 ; 100 OI(OCXOR) ;func rtns orderable item for an order number (OCXOR) 101 Q:+$G(OCXOR)<1 "" 102 N OCXOI S OCXOI="" 103 S OCXOI=+$G(^OR(100,+$G(OCXOR),.1,1,0)) 104 Q OCXOI 105 ; 106 PATLOC(DFN) ; Compiler Function: PATIENT LOCATION 107 ; 108 N OCXP1,OCXP2 109 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) 110 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) 111 I OCXP2 D 112 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) 113 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) 114 .E S OCXP2=$P(OCXP2,"^",1) 115 .S:'$L(OCXP2) OCXP2="NO LOC" 116 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 117 ; 118 S OCXP2=$G(^DPT(+$G(DFN),.1)) 119 I $L(OCXP2) Q "I^"_OCXP2 120 Q "O^OUTPT" 121 ; 122 POINTER(OCXFILE,D0) ; This Local Extrinsic Function gets the value of the name field 123 ; of record D0 in file OCXFILE 124 Q:'$G(D0) "" Q:'$L($G(OCXFILE)) "" 125 N GLREF 126 I '(OCXFILE=(+OCXFILE)) S GLREF=U_OCXFILE 127 E S GLREF=$$FILE^OCXBDTD(+OCXFILE,"GLOBAL NAME") Q:'$L(GLREF) "" 128 Q $P($G(@(GLREF_(+D0)_",0)")),U,1) 129 ; 130 TERMLKUP(OCXTERM,OCXLIST) ; 131 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) 132 ; 133 WARDSERV(WARD) ; Compiler Function: GET WARD SERVICE 134 ; 135 N CODESET,PC,SERV,DIC,X,Y,DA 136 S CODESET="M:MEDICINE;S:SURGERY;P:PSYCHIATRY;NH:NHCU;NE:NEUROLOGY;I:INTERMEDIATE MED;R:REHAB MEDICINE;SCI:SPINAL CORD INJURY;D:DOMICILIARY;B:BLIND REHAB;NC:NON-COUNT" 137 S DIC=42,DIC(0)="NZ",X="`"_(+WARD) D ^DIC Q:(Y<1) "" 138 S SERV=$P($G(Y(0)),U,3) 139 Q:'$L(SERV) "" Q:'$L(CODESET) "" 140 F PC=1:1:$L(CODESET,";"),0 I PC,($P($P(CODESET,";",PC),":",1)=SERV) Q 141 Q:'PC "" Q $P($P(CODESET,";",PC),":",2) 142 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ04.m
r613 r623 1 OCXOZ04 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 CHK25 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 CHK30 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 CHK34 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 CHK35 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 CHK43 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 DT2INT(OCXDT) 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 FILE(DFN,OCXELE,OCXDFL) 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 LIST(DATA,LIST) 156 157 158 159 160 ORDITEM(OIEN) 161 162 163 164 165 166 167 WARDRMBD(DFN) 168 169 170 171 172 1 OCXOZ04 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK25 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK23+15^OCXOZ03. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK25 Variables 19 ; OCXDF(25) ---> Data Field: PATIENT MOVEMENT TYPE CURRENT (FREE TEXT) 20 ; OCXDF(26) ---> Data Field: PATIENT MOVEMENT DATE CURRENT (DATE/TIME) 21 ; OCXDF(97) ---> Data Field: NEW PATIENT MOVEMENT (BOOLEAN) 22 ; 23 ; Local Extrinsic Functions 24 ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT 25 ; FILE(DFN,56, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT DISCHARGE) 26 ; 27 I (OCXDF(25)="ADMISSION") S OCXDF(97)=('(+$G(DGPMA)=+$G(DGPM0))&'$L(DGPMP)) I $L(OCXDF(97)),(OCXDF(97)) S OCXDF(26)=$$DT2INT($P($G(DGPMA),"^",1)) D CHK30 28 I (OCXDF(25)="DISCHARGE") S OCXDF(26)=$$DT2INT($P($G(DGPMA),"^",1)),OCXOERR=$$FILE(DFN,56,"26") Q:OCXOERR 29 Q 30 ; 31 CHK30 ; Look through the current environment for valid Event/Elements for this patient. 32 ; Called from CHK25+14. 33 ; 34 Q:$G(OCXOERR) 35 ; 36 ; Local CHK30 Variables 37 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 38 ; OCXDF(83) ---> Data Field: PATIENT WARD ROOM-BED (FREE TEXT) 39 ; 40 ; Local Extrinsic Functions 41 ; FILE(DFN,21, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT ADMISSION) 42 ; WARDRMBD( --------> WARD ROOM-BED 43 ; 44 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(83)=$P($$WARDRMBD(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,21,"26,83") Q:OCXOERR 45 Q 46 ; 47 CHK34 ; Look through the current environment for valid Event/Elements for this patient. 48 ; Called from CHK1+28^OCXOZ02. 49 ; 50 Q:$G(OCXOERR) 51 ; 52 ; Local CHK34 Variables 53 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) 54 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 55 ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT) 56 ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) 57 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 58 ; 59 ; Local Extrinsic Functions 60 ; LIST( ------------> IN LIST OPERATOR 61 ; 62 I $$LIST(OCXDF(6),"H,L") D CHK35 63 I $$LIST(OCXDF(6),"HH,LL"),$L(OCXDF(23)),$$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) D CHK324^OCXOZ0C 64 Q 65 ; 66 CHK35 ; Look through the current environment for valid Event/Elements for this patient. 67 ; Called from CHK34+15. 68 ; 69 Q:$G(OCXOERR) 70 ; 71 ; Local CHK35 Variables 72 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) 73 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 74 ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT) 75 ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) 76 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 77 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 78 ; 79 ; Local Extrinsic Functions 80 ; LIST( ------------> IN LIST OPERATOR 81 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 82 ; 83 I $L(OCXDF(23)),$$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK43 84 I $L(OCXDF(15)),$$LIST(OCXDF(15),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK314^OCXOZ0C 85 Q 86 ; 87 CHK43 ; Look through the current environment for valid Event/Elements for this patient. 88 ; Called from CHK35+17. 89 ; 90 Q:$G(OCXOERR) 91 ; 92 ; Local CHK43 Variables 93 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) 94 ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) 95 ; 96 ; Local Extrinsic Functions 97 ; FILE(DFN,23, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB ORDER RESULTS ABNORMAL) 98 ; 99 I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,23,"12,13,96,114") Q:OCXOERR 100 Q 101 ; 102 DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer 103 ; By taking the Years, Months, Days, Hours and Minutes converting 104 ; Them into Seconds and then adding them all together into one big integer 105 ; 106 Q:'$L($G(OCXDT)) "" 107 N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0 108 ; 109 I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT 110 .N OCXHR,OCXMIN,OCXTIME 111 .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2) 112 .S:(OCXDT["Midnight") OCXHR=00 113 .S:(OCXDT["PM") OCXHR=OCXHR+12 114 .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3) 115 ; 116 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT 117 .N OCXMON 118 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) 119 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","") 120 .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2) 121 ; 122 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT 123 .N OCXMON 124 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) 125 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","") 126 .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3) 127 ; 128 I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT 129 .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1 130 .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y 131 ; 132 I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT 133 ; 134 I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT 135 ; 136 I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT 137 ; 138 Q OCXVAL 139 ; 140 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 141 ; 142 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 143 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 144 ; 145 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 146 ; 147 S OCXDATA(DFN,OCXELE)=1 148 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 149 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 150 ; 151 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 152 ; 153 Q 0 154 ; 155 LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST 156 ; 157 S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," 158 Q (LIST[DATA) 159 ; 160 ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER 161 Q:'$G(OIEN) "" 162 ; 163 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." 164 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." 165 Q $P(X,U,1) 166 ; 167 WARDRMBD(DFN) ; Compiler Function: WARD ROOM-BED 168 ; 169 Q:'$G(DFN) 0 170 N OUT S OUT=$G(^DPT(DFN,.1)) Q:'$L(OUT) 0 171 S OUT=1_"^"_OUT_" "_$G(^DPT(DFN,.101)) Q OUT 172 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ05.m
r613 r623 1 OCXOZ05 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 CHK47 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 CHK55 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 CHK58 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(143)=$P($$DMED64(OCXDF(73)),"^",2) I $L(OCXDF(143)) D CHK398^OCXOZ0D 73 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK446^OCXOZ0F74 75 76 CHK60 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 CHK87 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 CHK93 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 DMED64(OCXOI) 127 128 129 130 131 132 133 134 FILE(DFN,OCXELE,OCXDFL) 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 LIST(DATA,LIST) 150 151 152 153 154 ORDITEM(OIEN) 155 156 157 158 159 160 161 PATLOC(DFN) 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 POINTER(OCXFILE,D0) 178 179 180 181 182 183 184 185 TERMLKUP(OCXTERM,OCXLIST) 186 187 188 WARDSERV(WARD) 189 190 191 192 193 194 195 196 197 1 OCXOZ05 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK47 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK1+29^OCXOZ02. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK47 Variables 19 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) 20 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 21 ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT) 22 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 23 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 24 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 25 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) 26 ; 27 ; Local Extrinsic Functions 28 ; LIST( ------------> IN LIST OPERATOR 29 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 30 ; PATLOC( ----------> PATIENT LOCATION 31 ; 32 I $L(OCXDF(6)),$$LIST(OCXDF(6),"HH,LL"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK55 33 I $L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) D CHK144^OCXOZ07 34 Q 35 ; 36 CHK55 ; Look through the current environment for valid Event/Elements for this patient. 37 ; Called from CHK47+19. 38 ; 39 Q:$G(OCXOERR) 40 ; 41 ; Local CHK55 Variables 42 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) 43 ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) 44 ; 45 ; Local Extrinsic Functions 46 ; FILE(DFN,24, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB TEST RESULTS CRITICAL) 47 ; 48 I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,24,"12,13,96,114") Q:OCXOERR 49 Q 50 ; 51 CHK58 ; Look through the current environment for valid Event/Elements for this patient. 52 ; Called from UPDATE+12^OCXOZ01. 53 ; 54 Q:$G(OCXOERR) 55 ; 56 ; Local CHK58 Variables 57 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 58 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 59 ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT) 60 ; OCXDF(47) ---> Data Field: OI LOCAL TEXT (FREE TEXT) 61 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) 62 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 63 ; OCXDF(143) --> Data Field: DANGEROUS MEDS FOR PT > 64 NAME (FREE TEXT) 64 ; 65 ; Local Extrinsic Functions 66 ; DMED64( ----------> DANGEROUS MEDS FOR PATIENTS > 64 67 ; 68 S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK60 69 S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)) D CHK163^OCXOZ07 70 S OCXDF(47)=$P($P($G(OCXPSD),"|",3),"^",5) I $L(OCXDF(47)) D CHK188^OCXOZ09 71 S OCXDF(131)=$P($P($G(OCXPSD),"|",3),"^",4) I $L(OCXDF(131)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK347^OCXOZ0C 72 S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(143)=$P($$DMED64(OCXDF(73)),"^",2) I $L(OCXDF(143)) D CHK406^OCXOZ0E 73 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK454^OCXOZ0F 74 Q 75 ; 76 CHK60 ; Look through the current environment for valid Event/Elements for this patient. 77 ; Called from CHK58+17. 78 ; 79 Q:$G(OCXOERR) 80 ; 81 ; Local CHK60 Variables 82 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 83 ; 84 ; Local Extrinsic Functions 85 ; FILE(DFN,135, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: DIET ORDER) 86 ; FILE(DFN,137, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PHARMACY ORDER) 87 ; FILE(DFN,28, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY ORDER) 88 ; 89 I (OCXDF(2)="RA") S OCXOERR=$$FILE(DFN,28,"") Q:OCXOERR 90 I (OCXDF(2)="FH") S OCXOERR=$$FILE(DFN,135,"") Q:OCXOERR 91 I ($E(OCXDF(2),1,2)="PS") S OCXOERR=$$FILE(DFN,137,"") Q:OCXOERR 92 Q 93 ; 94 CHK87 ; Look through the current environment for valid Event/Elements for this patient. 95 ; Called from CHK23+16^OCXOZ03. 96 ; 97 Q:$G(OCXOERR) 98 ; 99 ; Local CHK87 Variables 100 ; OCXDF(90) ---> Data Field: PATIENT MOVEMENT WARD CURRENT (FREE TEXT) 101 ; OCXDF(91) ---> Data Field: PATIENT MOVEMENT SERVICE CURRENT (FREE TEXT) 102 ; OCXDF(92) ---> Data Field: PATIENT MOVEMENT WARD IEN CURRENT (NUMERIC) 103 ; 104 ; Local Extrinsic Functions 105 ; POINTER( ---------> RETURN POINTED TO VALUE 106 ; WARDSERV( --------> GET WARD SERVICE 107 ; 108 I $L(OCXDF(92)) S OCXDF(91)=$$WARDSERV(OCXDF(92)) I $L(OCXDF(91)),($L(OCXDF(91))>0),'(OCXDF(91)="PSYCHIATRY") S OCXDF(90)=$$POINTER(42,$P($G(DGPMA),"^",6)) D CHK93 109 Q 110 ; 111 CHK93 ; Look through the current environment for valid Event/Elements for this patient. 112 ; Called from CHK87+14. 113 ; 114 Q:$G(OCXOERR) 115 ; 116 ; Local CHK93 Variables 117 ; OCXDF(95) ---> Data Field: PATIENT MOVEMENT WARD PREVIOUS (FREE TEXT) 118 ; 119 ; Local Extrinsic Functions 120 ; FILE(DFN,42, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT TRANSFERRED FROM PSYCH WARD) 121 ; POINTER( ---------> RETURN POINTED TO VALUE 122 ; 123 S OCXDF(95)=$$POINTER(42,$P($G(DGPM0),"^",6)),OCXOERR=$$FILE(DFN,42,"90,95") Q:OCXOERR 124 Q 125 ; 126 DMED64(OCXOI) ;ext func rtns med oi^med name if OCXOI is dangerous 127 N OCXTL,OCXT,OCXDM 128 Q:'$$TERMLKUP("DANGEROUS MEDS FOR PTS > 64",.OCXTL) "0^" 129 S OCXDM="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D Q:$L(OCXDM) 130 .I OCXT=OCXOI S OCXDM=OCXT_"^"_OCXTL(OCXT) 131 Q:'$L(OCXDM) "0^" 132 Q OCXDM 133 ; 134 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 135 ; 136 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 137 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 138 ; 139 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 140 ; 141 S OCXDATA(DFN,OCXELE)=1 142 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 143 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 144 ; 145 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 146 ; 147 Q 0 148 ; 149 LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST 150 ; 151 S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," 152 Q (LIST[DATA) 153 ; 154 ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER 155 Q:'$G(OIEN) "" 156 ; 157 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." 158 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." 159 Q $P(X,U,1) 160 ; 161 PATLOC(DFN) ; Compiler Function: PATIENT LOCATION 162 ; 163 N OCXP1,OCXP2 164 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) 165 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) 166 I OCXP2 D 167 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) 168 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) 169 .E S OCXP2=$P(OCXP2,"^",1) 170 .S:'$L(OCXP2) OCXP2="NO LOC" 171 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 172 ; 173 S OCXP2=$G(^DPT(+$G(DFN),.1)) 174 I $L(OCXP2) Q "I^"_OCXP2 175 Q "O^OUTPT" 176 ; 177 POINTER(OCXFILE,D0) ; This Local Extrinsic Function gets the value of the name field 178 ; of record D0 in file OCXFILE 179 Q:'$G(D0) "" Q:'$L($G(OCXFILE)) "" 180 N GLREF 181 I '(OCXFILE=(+OCXFILE)) S GLREF=U_OCXFILE 182 E S GLREF=$$FILE^OCXBDTD(+OCXFILE,"GLOBAL NAME") Q:'$L(GLREF) "" 183 Q $P($G(@(GLREF_(+D0)_",0)")),U,1) 184 ; 185 TERMLKUP(OCXTERM,OCXLIST) ; 186 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) 187 ; 188 WARDSERV(WARD) ; Compiler Function: GET WARD SERVICE 189 ; 190 N CODESET,PC,SERV,DIC,X,Y,DA 191 S CODESET="M:MEDICINE;S:SURGERY;P:PSYCHIATRY;NH:NHCU;NE:NEUROLOGY;I:INTERMEDIATE MED;R:REHAB MEDICINE;SCI:SPINAL CORD INJURY;D:DOMICILIARY;B:BLIND REHAB;NC:NON-COUNT" 192 S DIC=42,DIC(0)="NZ",X="`"_(+WARD) D ^DIC Q:(Y<1) "" 193 S SERV=$P($G(Y(0)),U,3) 194 Q:'$L(SERV) "" Q:'$L(CODESET) "" 195 F PC=1:1:$L(CODESET,";"),0 I PC,($P($P(CODESET,";",PC),":",1)=SERV) Q 196 Q:'PC "" Q $P($P(CODESET,";",PC),":",2) 197 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ06.m
r613 r623 1 OCXOZ06 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 CHK95 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 CHK97 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 CHK113 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 CANCELER(ORNUM) 82 83 84 85 86 87 88 89 90 DT2INT(OCXDT) 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 FILE(DFN,OCXELE,OCXDFL) 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 INT2DT(OCXDT,OCXF) 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 ORDERER(ORNUM) 168 169 170 171 172 173 174 175 176 177 178 ORDITEM(OIEN) 179 180 181 182 183 184 1 OCXOZ06 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK95 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from UPDATE+13^OCXOZ01. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK95 Variables 19 ; OCXDF(27) ---> Data Field: ORDER FLAGGED FOR CLARIFICATION (BOOLEAN) 20 ; OCXDF(28) ---> Data Field: ORDER REQ. CHART SIGN. (BOOLEAN) 21 ; OCXDF(29) ---> Data Field: SERV. ORDER REQ CHART SIG. (BOOLEAN) 22 ; OCXDF(30) ---> Data Field: ORDER REQ. CO-SIG. (BOOLEAN) 23 ; OCXDF(31) ---> Data Field: ORDER REQ. ELEC. SIG. (BOOLEAN) 24 ; 25 ; Local Extrinsic Functions 26 ; FILE(DFN,45, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER REQUIRES CHART SIGNATURE) 27 ; FILE(DFN,46, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SERVICE ORDER REQUIRES CHART SIGNATURE) 28 ; FILE(DFN,47, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER REQUIRES CO-SIGNATURE) 29 ; FILE(DFN,48, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER REQUIRES ELECTRONIC SIGNATURE) 30 ; 31 S OCXDF(27)=$P($G(OCXORD),"^",4) I $L(OCXDF(27)) D CHK97 32 S OCXDF(28)=$P($G(OCXORD),"^",5) I $L(OCXDF(28)),(OCXDF(28)) S OCXOERR=$$FILE(DFN,45,"") Q:OCXOERR 33 S OCXDF(29)=$P($G(OCXORD),"^",6) I $L(OCXDF(29)),(OCXDF(29)) S OCXOERR=$$FILE(DFN,46,"") Q:OCXOERR 34 S OCXDF(30)=$P($G(OCXORD),"^",7) I $L(OCXDF(30)),(OCXDF(30)) S OCXOERR=$$FILE(DFN,47,"") Q:OCXOERR 35 S OCXDF(31)=$P($G(OCXORD),"^",8) I $L(OCXDF(31)),(OCXDF(31)) S OCXOERR=$$FILE(DFN,48,"") Q:OCXOERR 36 Q 37 ; 38 CHK97 ; Look through the current environment for valid Event/Elements for this patient. 39 ; Called from CHK95+18. 40 ; 41 Q:$G(OCXOERR) 42 ; 43 ; Local CHK97 Variables 44 ; OCXDF(27) ---> Data Field: ORDER FLAGGED FOR CLARIFICATION (BOOLEAN) 45 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 46 ; OCXDF(115) --> Data Field: CURRENT DATE/TIME (FREE TEXT) 47 ; 48 ; Local Extrinsic Functions 49 ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT 50 ; FILE(DFN,134, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER UNFLAGGED) 51 ; FILE(DFN,44, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER FLAGGED) 52 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT 53 ; 54 I (OCXDF(27)) S OCXDF(37)=$P($G(OCXORD),"^",1),OCXDF(115)=$$INT2DT($$DT2INT("N"),0),OCXOERR=$$FILE(DFN,44,"37,115") Q:OCXOERR 55 I '(OCXDF(27)) S OCXDF(37)=$P($G(OCXORD),"^",1),OCXDF(115)=$$INT2DT($$DT2INT("N"),0),OCXOERR=$$FILE(DFN,134,"37,115") Q:OCXOERR 56 Q 57 ; 58 CHK113 ; Look through the current environment for valid Event/Elements for this patient. 59 ; Called from CHK1+30^OCXOZ02. 60 ; 61 Q:$G(OCXOERR) 62 ; 63 ; Local CHK113 Variables 64 ; OCXDF(32) ---> Data Field: ORDER FLAGGED FOR RESULTS (BOOLEAN) 65 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 66 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 67 ; OCXDF(105) --> Data Field: ORDER TEXT (51 CHARS) (FREE TEXT) 68 ; OCXDF(112) --> Data Field: ORDERED BY (FREE TEXT) 69 ; OCXDF(149) --> Data Field: ORDER CANCELED BY (FREE TEXT) 70 ; 71 ; Local Extrinsic Functions 72 ; CANCELER( --------> ORDER CANCELING PROVIDER 73 ; FILE(DFN,49, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER FLAGGED FOR RESULTS) 74 ; ORDERER( ---------> ORDERING PROVIDER 75 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 76 ; 77 S OCXDF(32)=$$RSLTFLG^ORQOR2(OCXDF(34)) I $L(OCXDF(32)),(OCXDF(32)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,49,"96") Q:OCXOERR 78 S OCXDF(112)=$$ORDERER(OCXDF(34)),OCXDF(149)=$$CANCELER(OCXDF(34)) I '(OCXDF(112)=OCXDF(149)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2) D CHK293^OCXOZ0B 79 Q 80 ; 81 CANCELER(ORNUM) ; Compiler Function: ORDER CANCELING PROVIDER 82 ; 83 Q:'$G(ORNUM) "" 84 S ORNUM=+$G(ORNUM) 85 N ORQDUZ 86 Q:'$D(^OR(100,ORNUM,6)) "" 87 S ORQDUZ=$P(^OR(100,ORNUM,6),U,2) 88 Q ORQDUZ 89 ; 90 DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer 91 ; By taking the Years, Months, Days, Hours and Minutes converting 92 ; Them into Seconds and then adding them all together into one big integer 93 ; 94 Q:'$L($G(OCXDT)) "" 95 N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0 96 ; 97 I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT 98 .N OCXHR,OCXMIN,OCXTIME 99 .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2) 100 .S:(OCXDT["Midnight") OCXHR=00 101 .S:(OCXDT["PM") OCXHR=OCXHR+12 102 .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3) 103 ; 104 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT 105 .N OCXMON 106 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) 107 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","") 108 .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2) 109 ; 110 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT 111 .N OCXMON 112 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) 113 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","") 114 .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3) 115 ; 116 I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT 117 .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1 118 .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y 119 ; 120 I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT 121 ; 122 I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT 123 ; 124 I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT 125 ; 126 Q OCXVAL 127 ; 128 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 129 ; 130 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 131 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 132 ; 133 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 134 ; 135 S OCXDATA(DFN,OCXELE)=1 136 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 137 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 138 ; 139 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 140 ; 141 Q 0 142 ; 143 INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format 144 ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT 145 ; 146 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) 147 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR 148 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" 149 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 150 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 151 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 152 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) 153 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 154 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR 155 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" 156 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" 157 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) 158 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 159 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) 160 E S OCXMON=$E(OCXMON+100,2,3) 161 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") 162 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 163 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) 164 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP 165 Q OCXMON_" "_OCXDAY_","_OCXYR 166 ; 167 ORDERER(ORNUM) ; Compiler Function: ORDERING PROVIDER 168 ; 169 Q:'$G(ORNUM) "" 170 S ORNUM=+$G(ORNUM) 171 N ORQDUZ,ORQI S ORQDUZ="" 172 I $L($G(^OR(100,ORNUM,8,0))) D 173 .S ORQI=0,ORQI=$O(^OR(100,ORNUM,8,"C","NW",ORQI)) 174 Q:+$G(ORQI)<1 "" 175 S ORQDUZ=$P(^OR(100,ORNUM,8,ORQI,0),U,3) 176 Q ORQDUZ 177 ; 178 ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER 179 Q:'$G(OIEN) "" 180 ; 181 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." 182 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." 183 Q $P(X,U,1) 184 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ07.m
r613 r623 1 OCXOZ07 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 CHK121 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 CHK131 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 CHK136 53 54 55 56 57 58 59 60 61 62 63 CHK144 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 CHK149 84 85 86 87 88 89 90 91 92 93 94 CHK151 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 CHK157 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 CHK163 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 FILE(DFN,OCXELE,OCXDFL) 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 LIST(DATA,LIST) 169 170 171 172 173 ORDITEM(OIEN) 174 175 176 177 178 179 180 PATLOC(DFN) 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 1 OCXOZ07 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK121 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK2+14^OCXOZ02. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK121 Variables 19 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 20 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 21 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 22 ; 23 ; Local Extrinsic Functions 24 ; FILE(DFN,101, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 FINAL IMAGING RESULT) 25 ; FILE(DFN,55, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CONSULT FINAL RESULTS) 26 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 27 ; 28 I (OCXDF(2)="GMRC"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,55,"96") Q:OCXOERR 29 I (OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,101,"96") Q:OCXOERR 30 Q 31 ; 32 CHK131 ; Look through the current environment for valid Event/Elements for this patient. 33 ; Called from CHK12+33^OCXOZ03. 34 ; 35 Q:$G(OCXOERR) 36 ; 37 ; Local CHK131 Variables 38 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 39 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 40 ; OCXDF(54) ---> Data Field: SITE FLAGGED ORDER (BOOLEAN) 41 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 42 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) 43 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 44 ; 45 ; Local Extrinsic Functions 46 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 47 ; PATLOC( ----------> PATIENT LOCATION 48 ; 49 S OCXDF(54)=$$SITEORD^ORB3F1(OCXDF(34),OCXDF(146)) I $L(OCXDF(54)),(OCXDF(54)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK136 50 Q 51 ; 52 CHK136 ; Look through the current environment for valid Event/Elements for this patient. 53 ; Called from CHK131+17. 54 ; 55 Q:$G(OCXOERR) 56 ; 57 ; Local Extrinsic Functions 58 ; FILE(DFN,58, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NEW SITE FLAGGED ORDER) 59 ; 60 S OCXOERR=$$FILE(DFN,58,"9,96,147") Q:OCXOERR 61 Q 62 ; 63 CHK144 ; Look through the current environment for valid Event/Elements for this patient. 64 ; Called from CHK47+20^OCXOZ05. 65 ; 66 Q:$G(OCXOERR) 67 ; 68 ; Local CHK144 Variables 69 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 70 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 71 ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) 72 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 73 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) 74 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 75 ; 76 ; Local Extrinsic Functions 77 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 78 ; PATLOC( ----------> PATIENT LOCATION 79 ; 80 S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK149 81 Q 82 ; 83 CHK149 ; Look through the current environment for valid Event/Elements for this patient. 84 ; Called from CHK144+17. 85 ; 86 Q:$G(OCXOERR) 87 ; 88 ; Local Extrinsic Functions 89 ; FILE(DFN,59, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SITE FLAGGED FINAL LAB RESULT) 90 ; 91 S OCXOERR=$$FILE(DFN,59,"9,96,147") Q:OCXOERR 92 Q 93 ; 94 CHK151 ; Look through the current environment for valid Event/Elements for this patient. 95 ; Called from CHK1+31^OCXOZ02. 96 ; 97 Q:$G(OCXOERR) 98 ; 99 ; Local CHK151 Variables 100 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) 101 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 102 ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT) 103 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 104 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 105 ; 106 ; Local Extrinsic Functions 107 ; FILE(DFN,60, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NEW OBR STAT ORDER) 108 ; LIST( ------------> IN LIST OPERATOR 109 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 110 ; 111 I $L(OCXDF(1)),$$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,60,"96") Q:OCXOERR 112 I $L(OCXDF(15)),(OCXDF(15)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK264^OCXOZ0B 113 Q 114 ; 115 CHK157 ; Look through the current environment for valid Event/Elements for this patient. 116 ; Called from CHK1+32^OCXOZ02. 117 ; 118 Q:$G(OCXOERR) 119 ; 120 ; Local CHK157 Variables 121 ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) 122 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 123 ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) 124 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 125 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 126 ; 127 ; Local Extrinsic Functions 128 ; FILE(DFN,61, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NEW ORC STAT ORDER) 129 ; LIST( ------------> IN LIST OPERATOR 130 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 131 ; 132 I $L(OCXDF(1)),$$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,61,"96") Q:OCXOERR 133 I $L(OCXDF(23)),(OCXDF(23)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK253^OCXOZ0B 134 Q 135 ; 136 CHK163 ; Look through the current environment for valid Event/Elements for this patient. 137 ; Called from CHK58+18^OCXOZ05. 138 ; 139 Q:$G(OCXOERR) 140 ; 141 ; Local CHK163 Variables 142 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 143 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 144 ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT) 145 ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT) 146 ; 147 I (OCXDF(40)="ACCEPT") D CHK164^OCXOZ08 148 I (OCXDF(40)="DISPLAY") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK182^OCXOZ08 149 I (OCXDF(40)="SELECT") D CHK196^OCXOZ09 150 I (OCXDF(40)="SESSION") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(43)=$P($P($G(OCXPSD),"|",3),"^",1) I $L(OCXDF(43)) D CHK227^OCXOZ0A 151 Q 152 ; 153 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 154 ; 155 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 156 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 157 ; 158 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 159 ; 160 S OCXDATA(DFN,OCXELE)=1 161 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 162 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 163 ; 164 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 165 ; 166 Q 0 167 ; 168 LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST 169 ; 170 S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," 171 Q (LIST[DATA) 172 ; 173 ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER 174 Q:'$G(OIEN) "" 175 ; 176 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." 177 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." 178 Q $P(X,U,1) 179 ; 180 PATLOC(DFN) ; Compiler Function: PATIENT LOCATION 181 ; 182 N OCXP1,OCXP2 183 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) 184 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) 185 I OCXP2 D 186 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) 187 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) 188 .E S OCXP2=$P(OCXP2,"^",1) 189 .S:'$L(OCXP2) OCXP2="NO LOC" 190 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 191 ; 192 S OCXP2=$G(^DPT(+$G(DFN),.1)) 193 I $L(OCXP2) Q "I^"_OCXP2 194 Q "O^OUTPT" 195 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ08.m
r613 r623 1 OCXOZ08 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 CHK164 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)) I $L(OCXDF(62)) D CHK426^OCXOZ0E30 31 32 CHK171 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 CHK176 51 52 53 54 55 56 57 58 59 60 61 CHK182 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 CHK186 85 86 87 88 89 90 91 92 93 94 95 CH(OCXOI) 96 97 98 99 CRCL(DFN) 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 FILE(DFN,OCXELE,OCXDFL) 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 FLAB(DFN,OCXLIST,OCXSPEC) 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 RECCH(DFN,DAYS) 179 180 181 182 RECCHST(DFN,DAYS) 183 184 185 186 187 188 189 TERMLKUP(OCXTERM,OCXLIST) 190 191 1 OCXOZ08 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK164 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK163+11^OCXOZ07. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK164 Variables 19 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 20 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 21 ; OCXDF(59) ---> Data Field: CHOLECYSTOGRAM PROCEDURE FLAG (BOOLEAN) 22 ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) 23 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) 24 ; 25 ; Local Extrinsic Functions 26 ; CH( --------------> IS THIS A CHOLECYSTOGRAM RADIOLOGY PROCEDURE 27 ; 28 S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(59)=$P($$CH(OCXDF(73)),"^",1) I $L(OCXDF(59)),(OCXDF(59)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK171 29 S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)) I $L(OCXDF(62)) D CHK434^OCXOZ0E 30 Q 31 ; 32 CHK171 ; Look through the current environment for valid Event/Elements for this patient. 33 ; Called from CHK164+15. 34 ; 35 Q:$G(OCXOERR) 36 ; 37 ; Local CHK171 Variables 38 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 39 ; OCXDF(60) ---> Data Field: RECENT CHOLECYSTOGRAM FLAG (BOOLEAN) 40 ; OCXDF(61) ---> Data Field: RECENT CHOLECYSTOGRAM TEXT (FREE TEXT) 41 ; OCXDF(122) --> Data Field: RECENT CHOLECYSTOGRAM ORDER STATUS (FREE TEXT) 42 ; 43 ; Local Extrinsic Functions 44 ; RECCH( -----------> RECENT CHOLECYSTOGRAM PREOCEDURE 45 ; RECCHST( ---------> RECENT CHOLECYSTOGRAM ORDER STATUS 46 ; 47 S OCXDF(60)=$P($$RECCH(OCXDF(37),7),"^",1) I $L(OCXDF(60)),(OCXDF(60)) S OCXDF(61)=$P($$RECCH(OCXDF(37),7),"^",3),OCXDF(122)=$P($$RECCHST(OCXDF(37),7),"^",2) D CHK176 48 Q 49 ; 50 CHK176 ; Look through the current environment for valid Event/Elements for this patient. 51 ; Called from CHK171+15. 52 ; 53 Q:$G(OCXOERR) 54 ; 55 ; Local Extrinsic Functions 56 ; FILE(DFN,63, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT HAS RECENT CHOLECYSTOGRAM) 57 ; 58 S OCXOERR=$$FILE(DFN,63,"61,122") Q:OCXOERR 59 Q 60 ; 61 CHK182 ; Look through the current environment for valid Event/Elements for this patient. 62 ; Called from CHK163+12^OCXOZ07. 63 ; 64 Q:$G(OCXOERR) 65 ; 66 ; Local CHK182 Variables 67 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 68 ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) 69 ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT) 70 ; OCXDF(76) ---> Data Field: CREATININE CLEARANCE (ESTIM) VALUE (NUMERIC) 71 ; OCXDF(109) --> Data Field: NUMBER OF MEDS (NUMERIC) 72 ; OCXDF(123) --> Data Field: POLYPHARMACY (BOOLEAN) 73 ; 74 ; Local Extrinsic Functions 75 ; CRCL( ------------> CREATININE CLEARANCE (ESTIMATED/CALCULATED) 76 ; FILE(DFN,95, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: POLYPHARMACY) 77 ; FLAB( ------------> FORMATTED LAB RESULTS 78 ; 79 S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)) I $L(OCXDF(62)),(OCXDF(62)>65) S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN") D CHK186 80 S OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2) I $L(OCXDF(76)),(OCXDF(76)<50),(OCXDF(76)>0) D CHK247^OCXOZ0B 81 S OCXDF(123)=$P($$POLYRX^ORKPS(OCXDF(37)),"^",1) I $L(OCXDF(123)),(OCXDF(123)) S OCXDF(109)=$P($$NUMRX^ORKPS(OCXDF(37)),"^",1),OCXOERR=$$FILE(DFN,95,"109") Q:OCXOERR 82 Q 83 ; 84 CHK186 ; Look through the current environment for valid Event/Elements for this patient. 85 ; Called from CHK182+18. 86 ; 87 Q:$G(OCXOERR) 88 ; 89 ; Local Extrinsic Functions 90 ; FILE(DFN,64, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PHARMACY PATIENT OVER 65) 91 ; 92 S OCXOERR=$$FILE(DFN,64,"64") Q:OCXOERR 93 Q 94 ; 95 CH(OCXOI) ; Compiler Function: IS THIS A CHOLECYSTOGRAM RADIOLOGY PROCEDURE 96 ; 97 N OCXVAL S OCXVAL=$$CM^ORQQRA(OCXOI) Q:(OCXVAL["C") 1_U_OCXVAL Q 0 98 ; 99 CRCL(DFN) ; Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED) 100 ; 101 N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR 102 N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW 103 S RSLT="0^<Unavailable>" 104 S PSCR="^^^^^^0" 105 D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT) 106 Q:'$D(ORW) RSLT 107 S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT 108 S ABW=ABW/2.2 ;ABW (actual body weight) in kg 109 D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT) 110 Q:'$D(ORH) RSLT 111 S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT 112 S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT 113 S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT 114 S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT 115 S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT 116 S SCR="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D 117 .S OCXTS=0 F S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS D 118 ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U)) 119 ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR 120 S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT 121 S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT 122 ; 123 S HTGT60=$S(HT>60:(HT-60)*2.3,1:0) ;if ht > 60 inches 124 I HTGT60>0 D 125 .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60) ;Ideal Body Weight 126 .S BWRATIO=(ABW/IBW) ;body weight ratio 127 .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0) 128 .S LOWBW=$S(IBW<ABW:IBW,1:ABW) 129 .I BWRATIO>1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW) 130 .E S ADJBW=LOWBW 131 I +$G(ADJBW)<1 D 132 .S ADJBW=ABW 133 S CRCL=(((140-AGE)*ADJBW)/(SCRV*72)) 134 ; 135 S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1) 136 S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1) 137 Q RSLT 138 ; 139 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 140 ; 141 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 142 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 143 ; 144 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 145 ; 146 S OCXDATA(DFN,OCXELE)=1 147 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 148 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 149 ; 150 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 151 ; 152 Q 0 153 ; 154 FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS 155 ; 156 Q:'$G(DFN) "<Patient Not Specified>" 157 Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>" 158 N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC="" 159 I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL) 160 F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D 161 .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR 162 .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL) 163 .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D 164 ..I $L($G(OCXSL)) D 165 ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D 166 ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D 167 .....S OCXA($P(OCXX,U,7))=OCXX 168 ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"") 169 ..Q:'$L(OCXX) 170 .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR) 171 .I $L(OCXX) D 172 ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4) 173 ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"") 174 ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P") 175 .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY) 176 Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT 177 ; 178 RECCH(DFN,DAYS) ; Compiler Function: RECENT CHOLECYSTOGRAM PREOCEDURE 179 ; 180 Q:'$G(DFN) 0 Q:'$G(DAYS) 0 N OUT S OUT=$$RECENTCH^ORKRA(DFN,DAYS) Q:'$L(OUT) 0 Q 1_U_OUT 181 ; 182 RECCHST(DFN,DAYS) ; Compiler Function: RECENT CHOLECYSTOGRAM ORDER STATUS 183 ; 184 Q:'$G(DFN) 0 Q:'$G(DAYS) 0 185 N ORDER S ORDER=$P($$RECENTCH^ORKRA(DFN,DAYS),U) Q:'$L(ORDER) 0 186 N STATUS S STATUS=$P($$STATUS^ORQOR2(ORDER),U,2) Q:'$L(STATUS) 0 187 Q 1_U_STATUS 188 ; 189 TERMLKUP(OCXTERM,OCXLIST) ; 190 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) 191 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ09.m
r613 r623 1 OCXOZ09 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 CHK188 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 CHK192 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 CHK196 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK458^OCXOZ0F65 66 67 68 CHK198 69 70 71 72 73 74 75 76 77 I ($E(OCXDF(2),1,2)="PS") D CHK360^OCXOZ0D78 79 80 CHK199 81 82 83 84 85 86 87 88 89 90 91 92 93 CHK201 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 CHK207 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 CHK211 131 132 133 134 135 136 137 138 139 140 141 ALRGY(ORPT) 142 143 144 145 146 147 148 CLIST(DATA,LIST) 149 150 151 152 153 CONTRANS(OCXC) 154 155 156 157 158 159 160 161 162 163 164 165 EQTERM(DATA,TERM) 166 167 168 169 170 171 172 173 174 FILE(DFN,OCXELE,OCXDFL) 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 MTSTF(OILIST) 190 191 192 193 194 195 196 197 198 199 200 RECBAR(DFN,HOURS) 201 202 203 204 205 TERMLKUP(OCXTERM,OCXLIST) 206 207 1 OCXOZ09 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK188 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK58+19^OCXOZ05. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK188 Variables 19 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 20 ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT) 21 ; OCXDF(47) ---> Data Field: OI LOCAL TEXT (FREE TEXT) 22 ; 23 ; Local Extrinsic Functions 24 ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES 25 ; EQTERM( ----------> EQUALS TERM OPERATOR 26 ; 27 I $$EQTERM(OCXDF(47),"ANGIOGRAM (PERIPHERAL)") S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)),(OCXDF(40)="SESSION") D CHK192 28 I $$CLIST(OCXDF(47),"GLUCOPHAGE,METFORMIN") S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)),(OCXDF(40)="SELECT") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK280^OCXOZ0B 29 Q 30 ; 31 CHK192 ; Look through the current environment for valid Event/Elements for this patient. 32 ; Called from CHK188+14. 33 ; 34 Q:$G(OCXOERR) 35 ; 36 ; Local CHK192 Variables 37 ; OCXDF(68) ---> Data Field: MISSING ANGIOGRAM, CATH PERIF LAB TESTS (FREE TEXT) 38 ; 39 ; Local Extrinsic Functions 40 ; FILE(DFN,65, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SESSION ORDER FOR ANGIOGRAM) 41 ; MTSTF( -----------> MISSING TESTS DURING SESSION 42 ; 43 S OCXDF(68)=$$MTSTF("PROTHROMBIN TIME,PARTIAL THROMBOPLASTIN TIME") I $L(OCXDF(68)),($L(OCXDF(68))>0) S OCXOERR=$$FILE(DFN,65,"68") Q:OCXOERR 44 Q 45 ; 46 CHK196 ; Look through the current environment for valid Event/Elements for this patient. 47 ; Called from CHK163+13^OCXOZ07. 48 ; 49 Q:$G(OCXOERR) 50 ; 51 ; Local CHK196 Variables 52 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 53 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 54 ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) 55 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) 56 ; OCXDF(156) --> Data Field: ALLERGY ASSESSMENT (BOOLEAN) 57 ; 58 ; Local Extrinsic Functions 59 ; ALRGY( -----------> ALLERGY ASSESSMENT 60 ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES 61 ; FILE(DFN,136, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NO ALLERGY ASSESSMENT) 62 ; 63 S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK198 64 S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK466^OCXOZ0F 65 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(156)=$$ALRGY(OCXDF(37)) I $L(OCXDF(156)),'(OCXDF(156)) S OCXOERR=$$FILE(DFN,136,"") Q:OCXOERR 66 Q 67 ; 68 CHK198 ; Look through the current environment for valid Event/Elements for this patient. 69 ; Called from CHK196+17. 70 ; 71 Q:$G(OCXOERR) 72 ; 73 ; Local CHK198 Variables 74 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 75 ; 76 I (OCXDF(2)="RA") D CHK199 77 I ($E(OCXDF(2),1,2)="PS") D CHK362^OCXOZ0D 78 Q 79 ; 80 CHK199 ; Look through the current environment for valid Event/Elements for this patient. 81 ; Called from CHK198+8. 82 ; 83 Q:$G(OCXOERR) 84 ; 85 ; Local CHK199 Variables 86 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 87 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) 88 ; 89 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK201 90 S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) D CHK236^OCXOZ0A 91 Q 92 ; 93 CHK201 ; Look through the current environment for valid Event/Elements for this patient. 94 ; Called from CHK199+9. 95 ; 96 Q:$G(OCXOERR) 97 ; 98 ; Local CHK201 Variables 99 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 100 ; OCXDF(65) ---> Data Field: CONTRAST MEDIA ALLERGY FLAG (BOOLEAN) 101 ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) 102 ; OCXDF(69) ---> Data Field: RECENT BARIUM STUDY FLAG (BOOLEAN) 103 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) 104 ; 105 ; Local Extrinsic Functions 106 ; RECBAR( ----------> RECENT BARIUM STUDY 107 ; 108 S OCXDF(65)=$$ORCHK^GMRAOR(OCXDF(37),"CM","") I $L(OCXDF(65)),(OCXDF(65)) S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) D CHK207 109 S OCXDF(69)=$P($$RECBAR(OCXDF(37),48),"^",1) I $L(OCXDF(69)),(OCXDF(69)) S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) D CHK217^OCXOZ0A 110 Q 111 ; 112 CHK207 ; Look through the current environment for valid Event/Elements for this patient. 113 ; Called from CHK201+15. 114 ; 115 Q:$G(OCXOERR) 116 ; 117 ; Local CHK207 Variables 118 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 119 ; OCXDF(66) ---> Data Field: CONTRAST MEDIA CODE TRANSLATION (FREE TEXT) 120 ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) 121 ; OCXDF(159) --> Data Field: ALLERGY CONTRAST MEDIA LOCATION (FREE TEXT) 122 ; 123 ; Local Extrinsic Functions 124 ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES 125 ; CONTRANS( --------> CONTRAST MEDIA CODE TRANSLATION 126 ; 127 I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N,L,C,G,B") S OCXDF(66)=$$CONTRANS(OCXDF(67)),OCXDF(159)=$P($$ORCHK^GMRAOR(OCXDF(37),"CM","",1),"^",2) D CHK211 128 Q 129 ; 130 CHK211 ; Look through the current environment for valid Event/Elements for this patient. 131 ; Called from CHK207+15. 132 ; 133 Q:$G(OCXOERR) 134 ; 135 ; Local Extrinsic Functions 136 ; FILE(DFN,66, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CONTRAST MEDIA ALLERGY) 137 ; 138 S OCXOERR=$$FILE(DFN,66,"66,159") Q:OCXOERR 139 Q 140 ; 141 ALRGY(ORPT) ; determine if pt has an allergy assessment 142 ; rtn 0 if no allergy assessment, 1 if allergy assessment or NKA 143 N ORALRGY 144 D EN1^GMRAOR1(ORPT,"ORALRGY") 145 Q:$G(ORALRGY)="" 0 146 Q 1 147 ; 148 CLIST(DATA,LIST) ; DOES THE DATA FIELD CONTAIN AN ELEMENT IN THE LIST 149 ; 150 N PC F PC=1:1:$L(LIST,","),0 I PC,$L($P(LIST,",",PC)),(DATA[$P(LIST,",",PC)) Q 151 Q ''PC 152 ; 153 CONTRANS(OCXC) ; Compiler Function: CONTRAST MEDIA CODE TRANSLATION 154 ; 155 N OCXX 156 Q:'$L($G(OCXC)) "" S OCXX=$S((OCXC["B"):"Barium",1:"") 157 I (OCXC["G") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Gastrografin" 158 I (OCXC["I") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Ionic Iodinated" 159 I (OCXC["N") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Non-ionic Iodinated" 160 I (OCXC["L") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Gadolinium" 161 I (OCXC["C") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Cholecystographic" 162 I (OCXC["M") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Unspecified contrast media" 163 Q OCXX 164 ; 165 EQTERM(DATA,TERM) ; Compiler Function: EQUALS TERM OPERATOR 166 ; 167 N OCXF,OCXL 168 ; 169 S OCXL="",OCXF=$$TERMLKUP(TERM,.OCXL) 170 Q:'OCXF 0 171 I ($D(OCXL(DATA))!$D(OCXL("B",DATA))) Q 1 172 Q 0 173 ; 174 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 175 ; 176 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 177 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 178 ; 179 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 180 ; 181 S OCXDATA(DFN,OCXELE)=1 182 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 183 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 184 ; 185 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 186 ; 187 Q 0 188 ; 189 MTSTF(OILIST) ; Compiler Function: MISSING TESTS DURING SESSION 190 ; 191 N OCXPC,OCXOI,OCXOUT S OCXOUT="" 192 F OCXPC=1:1:$L(OILIST,",") S OCXOI=$P(OILIST,",",OCXPC) I $L(OCXOI) D 193 .N OCXL,OCXF,OCXD0 194 .S OCXL="",OCXF=$$TERMLKUP(OCXOI,.OCXL) 195 .S OCXD0=0 F S OCXD0=$O(OCXL(OCXD0)) Q:'OCXD0 Q:$$OISESS^ORKCHK2(+OCXD0) 196 .Q:OCXD0 197 .S:$L(OCXOUT) OCXOUT=OCXOUT_", " S OCXOUT=OCXOUT_OCXOI 198 Q OCXOUT 199 ; 200 RECBAR(DFN,HOURS) ; Compiler Function: RECENT BARIUM STUDY 201 ; 202 Q:'$G(DFN) 0 Q:'$G(HOURS) 0 N OUT S OUT=$$RECENTBA^ORKRA(DFN,HOURS) Q:'$L(OUT) 0 Q 1_U_OUT 203 ; 204 ; 205 TERMLKUP(OCXTERM,OCXLIST) ; 206 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) 207 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0A.m
r613 r623 1 OCXOZ0A ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 CHK217 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 CHK227 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 CHK232 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 CHK236 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 CLIST(DATA,LIST) 86 87 88 89 90 CRCL(DFN) 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 CTMRI(DFN,OCXOI) 131 132 133 134 135 136 137 138 139 140 141 142 143 144 FILE(DFN,OCXELE,OCXDFL) 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 FLAB(DFN,OCXLIST,OCXSPEC) 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 RECBAR(DFN,HOURS) 184 185 186 187 188 RECBARST(DFN,HOURS) 189 190 191 192 193 194 195 TERMLKUP(OCXTERM,OCXLIST) 196 197 1 OCXOZ0A ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK217 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK201+16^OCXOZ09. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK217 Variables 19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 20 ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) 21 ; OCXDF(70) ---> Data Field: RECENT BARIUM STUDY TEXT (FREE TEXT) 22 ; OCXDF(121) --> Data Field: RECENT BARIUM STUDY ORDER STATUS (FREE TEXT) 23 ; 24 ; Local Extrinsic Functions 25 ; FILE(DFN,67, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RECENT BARIUM STUDY ORDERED) 26 ; RECBAR( ----------> RECENT BARIUM STUDY 27 ; RECBARST( --------> RECENT BARIUM ORDER STATUS 28 ; 29 I $L(OCXDF(67)),(OCXDF(67)["B") S OCXDF(70)=$P($$RECBAR(OCXDF(37),48),"^",3),OCXDF(121)=$P($$RECBARST(OCXDF(37),48),"^",2),OCXOERR=$$FILE(DFN,67,"70,121") Q:OCXOERR 30 Q 31 ; 32 CHK227 ; Look through the current environment for valid Event/Elements for this patient. 33 ; Called from CHK163+14^OCXOZ07. 34 ; 35 Q:$G(OCXOERR) 36 ; 37 ; Local CHK227 Variables 38 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 39 ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT) 40 ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT) 41 ; 42 ; Local Extrinsic Functions 43 ; 44 S OCXDF(74)=$P($$ENVAC^PSJORUT2(OCXDF(43)),"^",2) I $L(OCXDF(74)),(OCXDF(74)="AMINOGLYCOSIDES") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK232 45 Q 46 ; 47 CHK232 ; Look through the current environment for valid Event/Elements for this patient. 48 ; Called from CHK227+12. 49 ; 50 Q:$G(OCXOERR) 51 ; 52 ; Local CHK232 Variables 53 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 54 ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT) 55 ; OCXDF(76) ---> Data Field: CREATININE CLEARANCE (ESTIM) VALUE (NUMERIC) 56 ; 57 ; Local Extrinsic Functions 58 ; CRCL( ------------> CREATININE CLEARANCE (ESTIMATED/CALCULATED) 59 ; FILE(DFN,71, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: AMINOGLYCOSIDE ORDER SESSION) 60 ; FLAB( ------------> FORMATTED LAB RESULTS 61 ; 62 S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,71,"64,76") Q:OCXOERR 63 Q 64 ; 65 CHK236 ; Look through the current environment for valid Event/Elements for this patient. 66 ; Called from CHK199+10^OCXOZ09. 67 ; 68 Q:$G(OCXOERR) 69 ; 70 ; Local CHK236 Variables 71 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 72 ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) 73 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) 74 ; OCXDF(78) ---> Data Field: PATIENT TOO BIG FOR SCANNER FLAG (BOOLEAN) 75 ; 76 ; Local Extrinsic Functions 77 ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES 78 ; CTMRI( -----------> CT MRI PHYSICAL LIMITS 79 ; FILE(DFN,106, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA) 80 ; 81 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(78)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",1) I $L(OCXDF(78)),(OCXDF(78)) D CHK241^OCXOZ0B 82 S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N") S OCXOERR=$$FILE(DFN,106,"") Q:OCXOERR 83 Q 84 ; 85 CLIST(DATA,LIST) ; DOES THE DATA FIELD CONTAIN AN ELEMENT IN THE LIST 86 ; 87 N PC F PC=1:1:$L(LIST,","),0 I PC,$L($P(LIST,",",PC)),(DATA[$P(LIST,",",PC)) Q 88 Q ''PC 89 ; 90 CRCL(DFN) ; Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED) 91 ; 92 N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR 93 N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW 94 S RSLT="0^<Unavailable>" 95 S PSCR="^^^^^^0" 96 D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT) 97 Q:'$D(ORW) RSLT 98 S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT 99 S ABW=ABW/2.2 ;ABW (actual body weight) in kg 100 D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT) 101 Q:'$D(ORH) RSLT 102 S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT 103 S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT 104 S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT 105 S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT 106 S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT 107 S SCR="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D 108 .S OCXTS=0 F S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS D 109 ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U)) 110 ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR 111 S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT 112 S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT 113 ; 114 S HTGT60=$S(HT>60:(HT-60)*2.3,1:0) ;if ht > 60 inches 115 I HTGT60>0 D 116 .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60) ;Ideal Body Weight 117 .S BWRATIO=(ABW/IBW) ;body weight ratio 118 .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0) 119 .S LOWBW=$S(IBW<ABW:IBW,1:ABW) 120 .I BWRATIO>1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW) 121 .E S ADJBW=LOWBW 122 I +$G(ADJBW)<1 D 123 .S ADJBW=ABW 124 S CRCL=(((140-AGE)*ADJBW)/(SCRV*72)) 125 ; 126 S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1) 127 S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1) 128 Q RSLT 129 ; 130 CTMRI(DFN,OCXOI) ; Compiler Function: CT MRI PHYSICAL LIMITS 131 ; 132 N OCXDEV,OCXWTP,OCXHTP,OCXWTL,OCXHTL 133 S OCXDEV=$$TYPE^ORKRA(OCXOI) 134 Q:'((OCXDEV="MRI")!(OCXDEV="CT")) 0_U 135 S OCXWTP=$P($$WT^ORQPTQ4(DFN),U,2),OCXHTP=$P($$HT^ORQPTQ4(DFN),U,2) 136 I (OCXDEV="CT") S OCXWTL=$$GET^XPAR("ALL","ORK CT LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK CT LIMIT HT",1,"Q") 137 I (OCXDEV="CT"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"CT scanner" 138 I (OCXDEV="CT"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"CT scanner" 139 I (OCXDEV="MRI") S OCXWTL=$$GET^XPAR("ALL","ORK MRI LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK MRI LIMIT HT",1,"Q") 140 I (OCXDEV="MRI"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"MRI scanner" 141 I (OCXDEV="MRI"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"MRI scanner" 142 Q 0_U 143 ; 144 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 145 ; 146 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 147 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 148 ; 149 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 150 ; 151 S OCXDATA(DFN,OCXELE)=1 152 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 153 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 154 ; 155 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 156 ; 157 Q 0 158 ; 159 FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS 160 ; 161 Q:'$G(DFN) "<Patient Not Specified>" 162 Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>" 163 N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC="" 164 I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL) 165 F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D 166 .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR 167 .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL) 168 .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D 169 ..I $L($G(OCXSL)) D 170 ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D 171 ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D 172 .....S OCXA($P(OCXX,U,7))=OCXX 173 ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"") 174 ..Q:'$L(OCXX) 175 .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR) 176 .I $L(OCXX) D 177 ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4) 178 ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"") 179 ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P") 180 .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY) 181 Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT 182 ; 183 RECBAR(DFN,HOURS) ; Compiler Function: RECENT BARIUM STUDY 184 ; 185 Q:'$G(DFN) 0 Q:'$G(HOURS) 0 N OUT S OUT=$$RECENTBA^ORKRA(DFN,HOURS) Q:'$L(OUT) 0 Q 1_U_OUT 186 ; 187 ; 188 RECBARST(DFN,HOURS) ; Compiler Function: RECENT BARIUM ORDER STATUS 189 ; 190 Q:'$G(DFN) 0 Q:'$G(HOURS) 0 191 N ORDER S ORDER=$P($$RECENTBA^ORKRA(DFN,HOURS),U) Q:'$L(ORDER) 0 192 N STATUS S STATUS=$P($$STATUS^ORQOR2(ORDER),U,2) Q:'$L(STATUS) 0 193 Q 1_U_STATUS 194 ; 195 TERMLKUP(OCXTERM,OCXLIST) ; 196 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) 197 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0B.m
r613 r623 1 OCXOZ0B ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 CHK241 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 CHK247 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 CHK253 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 CHK264 67 68 69 70 71 72 73 74 75 76 77 CHK270 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 CHK280 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 CHK285 112 113 114 115 116 117 118 119 120 121 122 CHK293 123 124 125 126 127 128 129 130 131 132 133 CTMRI(DFN,OCXOI) 134 135 136 137 138 139 140 141 142 143 144 145 146 147 FILE(DFN,OCXELE,OCXDFL) 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 FLAB(DFN,OCXLIST,OCXSPEC) 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 ORDITEM(OIEN) 187 188 189 190 191 192 193 PATLOC(DFN) 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 TERMLKUP(OCXTERM,OCXLIST) 210 211 212 WARDRMBD(DFN) 213 214 215 216 217 1 OCXOZ0B ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK241 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK236+16^OCXOZ0A. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK241 Variables 19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 20 ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) 21 ; OCXDF(79) ---> Data Field: PATIENT TOO BIG FOR SCANNER TEXT (FREE TEXT) 22 ; OCXDF(80) ---> Data Field: PATIENT TOO BIG FOR SCANNER DEVICE (FREE TEXT) 23 ; 24 ; Local Extrinsic Functions 25 ; CTMRI( -----------> CT MRI PHYSICAL LIMITS 26 ; FILE(DFN,72, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT OVER CT OR MRI DEVICE LIMITATIONS) 27 ; 28 S OCXDF(79)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",2),OCXDF(80)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",3),OCXOERR=$$FILE(DFN,72,"79,80") Q:OCXOERR 29 Q 30 ; 31 CHK247 ; Look through the current environment for valid Event/Elements for this patient. 32 ; Called from CHK182+19^OCXOZ08. 33 ; 34 Q:$G(OCXOERR) 35 ; 36 ; Local CHK247 Variables 37 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 38 ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT) 39 ; 40 ; Local Extrinsic Functions 41 ; FILE(DFN,73, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CREATININE CLEARANCE ESTIMATE) 42 ; FLAB( ------------> FORMATTED LAB RESULTS 43 ; 44 S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXOERR=$$FILE(DFN,73,"64,76") Q:OCXOERR 45 Q 46 ; 47 CHK253 ; Look through the current environment for valid Event/Elements for this patient. 48 ; Called from CHK157+18^OCXOZ07. 49 ; 50 Q:$G(OCXOERR) 51 ; 52 ; Local CHK253 Variables 53 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 54 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 55 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 56 ; 57 ; Local Extrinsic Functions 58 ; FILE(DFN,110, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: STAT CONSULT RESULT) 59 ; FILE(DFN,75, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: STAT IMAGING RESULT) 60 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 61 ; 62 I (OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,75,"24,96") Q:OCXOERR 63 I (OCXDF(2)="GMRC"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,110,"24,96") Q:OCXOERR 64 Q 65 ; 66 CHK264 ; Look through the current environment for valid Event/Elements for this patient. 67 ; Called from CHK151+18^OCXOZ07. 68 ; 69 Q:$G(OCXOERR) 70 ; 71 ; Local Extrinsic Functions 72 ; FILE(DFN,76, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: STAT LAB RESULT) 73 ; 74 S OCXOERR=$$FILE(DFN,76,"24,96") Q:OCXOERR 75 Q 76 ; 77 CHK270 ; Look through the current environment for valid Event/Elements for this patient. 78 ; Called from CHK12+34^OCXOZ03. 79 ; 80 Q:$G(OCXOERR) 81 ; 82 ; Local CHK270 Variables 83 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 84 ; OCXDF(84) ---> Data Field: INPATIENT (BOOLEAN) 85 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 86 ; 87 ; Local Extrinsic Functions 88 ; FILE(DFN,84, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: INPATIENT FOOD-DRUG REACTION) 89 ; PATLOC( ----------> PATIENT LOCATION 90 ; WARDRMBD( --------> WARD ROOM-BED 91 ; 92 S OCXDF(84)=$P($$WARDRMBD(OCXDF(37)),"^",1) I $L(OCXDF(84)),(OCXDF(84)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,84,"82,147") Q:OCXOERR 93 Q 94 ; 95 CHK280 ; Look through the current environment for valid Event/Elements for this patient. 96 ; Called from CHK188+15^OCXOZ09. 97 ; 98 Q:$G(OCXOERR) 99 ; 100 ; Local CHK280 Variables 101 ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) 102 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 103 ; OCXDF(125) --> Data Field: RECENT GLUCOPHAGE CREATININE TEXT (FREE TEXT) 104 ; OCXDF(127) --> Data Field: RECENT GLUCOPHAGE CREATININE DAYS (NUMERIC) 105 ; 106 ; Local Extrinsic Functions 107 ; 108 I ($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1) D CHK285 109 Q 110 ; 111 CHK285 ; Look through the current environment for valid Event/Elements for this patient. 112 ; Called from CHK280+13. 113 ; 114 Q:$G(OCXOERR) 115 ; 116 ; Local Extrinsic Functions 117 ; FILE(DFN,86, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: GLUCOPHAGE ORDER) 118 ; 119 S OCXOERR=$$FILE(DFN,86,"125,127") Q:OCXOERR 120 Q 121 ; 122 CHK293 ; Look through the current environment for valid Event/Elements for this patient. 123 ; Called from CHK113+20^OCXOZ06. 124 ; 125 Q:$G(OCXOERR) 126 ; 127 ; Local Extrinsic Functions 128 ; FILE(DFN,100, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER) 129 ; 130 S OCXOERR=$$FILE(DFN,100,"105") Q:OCXOERR 131 Q 132 ; 133 CTMRI(DFN,OCXOI) ; Compiler Function: CT MRI PHYSICAL LIMITS 134 ; 135 N OCXDEV,OCXWTP,OCXHTP,OCXWTL,OCXHTL 136 S OCXDEV=$$TYPE^ORKRA(OCXOI) 137 Q:'((OCXDEV="MRI")!(OCXDEV="CT")) 0_U 138 S OCXWTP=$P($$WT^ORQPTQ4(DFN),U,2),OCXHTP=$P($$HT^ORQPTQ4(DFN),U,2) 139 I (OCXDEV="CT") S OCXWTL=$$GET^XPAR("ALL","ORK CT LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK CT LIMIT HT",1,"Q") 140 I (OCXDEV="CT"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"CT scanner" 141 I (OCXDEV="CT"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"CT scanner" 142 I (OCXDEV="MRI") S OCXWTL=$$GET^XPAR("ALL","ORK MRI LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK MRI LIMIT HT",1,"Q") 143 I (OCXDEV="MRI"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"MRI scanner" 144 I (OCXDEV="MRI"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"MRI scanner" 145 Q 0_U 146 ; 147 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 148 ; 149 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 150 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 151 ; 152 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 153 ; 154 S OCXDATA(DFN,OCXELE)=1 155 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 156 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 157 ; 158 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 159 ; 160 Q 0 161 ; 162 FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS 163 ; 164 Q:'$G(DFN) "<Patient Not Specified>" 165 Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>" 166 N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC="" 167 I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL) 168 F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D 169 .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR 170 .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL) 171 .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D 172 ..I $L($G(OCXSL)) D 173 ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D 174 ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D 175 .....S OCXA($P(OCXX,U,7))=OCXX 176 ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"") 177 ..Q:'$L(OCXX) 178 .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR) 179 .I $L(OCXX) D 180 ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4) 181 ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"") 182 ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P") 183 .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY) 184 Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT 185 ; 186 ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER 187 Q:'$G(OIEN) "" 188 ; 189 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." 190 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." 191 Q $P(X,U,1) 192 ; 193 PATLOC(DFN) ; Compiler Function: PATIENT LOCATION 194 ; 195 N OCXP1,OCXP2 196 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) 197 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) 198 I OCXP2 D 199 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) 200 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) 201 .E S OCXP2=$P(OCXP2,"^",1) 202 .S:'$L(OCXP2) OCXP2="NO LOC" 203 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 204 ; 205 S OCXP2=$G(^DPT(+$G(DFN),.1)) 206 I $L(OCXP2) Q "I^"_OCXP2 207 Q "O^OUTPT" 208 ; 209 TERMLKUP(OCXTERM,OCXLIST) ; 210 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) 211 ; 212 WARDRMBD(DFN) ; Compiler Function: WARD ROOM-BED 213 ; 214 Q:'$G(DFN) 0 215 N OUT S OUT=$G(^DPT(DFN,.1)) Q:'$L(OUT) 0 216 S OUT=1_"^"_OUT_" "_$G(^DPT(DFN,.101)) Q OUT 217 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0C.m
r613 r623 1 OCXOZ0C ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK302 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK6+19^OCXOZ02. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK302 Variables 19 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 20 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 21 ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) 22 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 23 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 24 ; 25 ; Local Extrinsic Functions 26 ; FILE(DFN,102, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SITE FLAGGED FINAL IMAGING RESULT) 27 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 28 ; PATLOC( ----------> PATIENT LOCATION 29 ; 30 I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,102,"9,96,147") Q:OCXOERR 31 Q 32 ; 33 CHK314 ; Look through the current environment for valid Event/Elements for this patient. 34 ; Called from CHK35+18^OCXOZ04. 35 ; 36 Q:$G(OCXOERR) 37 ; 38 ; Local CHK314 Variables 39 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) 40 ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) 41 ; 42 ; Local Extrinsic Functions 43 ; FILE(DFN,103, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB TEST RESULTS ABNORMAL) 44 ; 45 I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,103,"12,13,96,114") Q:OCXOERR 46 Q 47 ; 48 CHK324 ; Look through the current environment for valid Event/Elements for this patient. 49 ; Called from CHK34+16^OCXOZ04. 50 ; 51 Q:$G(OCXOERR) 52 ; 53 ; Local CHK324 Variables 54 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 55 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 56 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) 57 ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) 58 ; 59 ; Local Extrinsic Functions 60 ; FILE(DFN,105, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB ORDER RESULTS CRITICAL) 61 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 62 ; 63 S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,105,"12,13,96,114") Q:OCXOERR 64 Q 65 ; 66 CHK336 ; Look through the current environment for valid Event/Elements for this patient. 67 ; Called from CHK6+20^OCXOZ02. 68 ; 69 Q:$G(OCXOERR) 70 ; 71 ; Local CHK336 Variables 72 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 73 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 74 ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) 75 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 76 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 77 ; 78 ; Local Extrinsic Functions 79 ; FILE(DFN,109, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SITE FLAGGED FINAL CONSULT RESULT) 80 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 81 ; PATLOC( ----------> PATIENT LOCATION 82 ; 83 I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,109,"9,96,147") Q:OCXOERR 84 Q 85 ; 86 CHK347 ; Look through the current environment for valid Event/Elements for this patient. 87 ; Called from CHK58+20^OCXOZ05. 88 ; 89 Q:$G(OCXOERR) 90 ; 91 ; Local CHK347 Variables 92 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 93 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 94 ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN) 95 ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC) 96 ; OCXDF(139) --> Data Field: CLOZAPINE WBC W/IN 7 FLAG (BOOLEAN) 97 ; OCXDF(140) --> Data Field: CLOZAPINE WBC W/IN 7 RESULT (NUMERIC) 98 ; 99 ; Local Extrinsic Functions 100 ; 101 S OCXDF(137)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",2) I $L(OCXDF(137)) D CHK349 102 S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),'(OCXDF(136)) D CHK371^OCXOZ0D 103 S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),'(OCXDF(139)) D CHK375^OCXOZ0D 104 S OCXDF(140)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",2) I $L(OCXDF(140)) D CHK378^OCXOZ0D 105 Q 106 ; 107 CHK349 ; Look through the current environment for valid Event/Elements for this patient. 108 ; Called from CHK347+15. 109 ; 110 Q:$G(OCXOERR) 111 ; 112 ; Local CHK349 Variables 113 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 114 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 115 ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN) 116 ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC) 117 ; 118 ; Local Extrinsic Functions 119 ; 120 I (OCXDF(137)<1.5) S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK353 121 I (OCXDF(137)>1.499) D CHK355 122 Q 123 ; 124 CHK353 ; Look through the current environment for valid Event/Elements for this patient. 125 ; Called from CHK349+13. 126 ; 127 Q:$G(OCXOERR) 128 ; 129 ; Local CHK353 Variables 130 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 131 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 132 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 133 ; 134 ; Local Extrinsic Functions 135 ; FILE(DFN,114, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE ANC < 1.5) 136 ; 137 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,114,"130") Q:OCXOERR 138 Q 139 ; 140 CHK355 ; Look through the current environment for valid Event/Elements for this patient. 141 ; Called from CHK349+14. 142 ; 143 Q:$G(OCXOERR) 144 ; 145 ; Local CHK355 Variables 146 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 147 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 148 ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN) 149 ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC) 150 ; 151 ; Local Extrinsic Functions 152 ; 153 S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK358 154 I (OCXDF(137)<"2.0") S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK505^OCXOZ0G 155 Q 156 ; 157 CHK358 ; Look through the current environment for valid Event/Elements for this patient. 158 ; Called from CHK355+13. 159 ; 160 Q:$G(OCXOERR) 161 ; 162 ; Local CHK358 Variables 163 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 164 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 165 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 166 ; 167 ; Local Extrinsic Functions 168 ; FILE(DFN,115, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE ANC >= 1.5) 169 ; 170 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,115,"130") Q:OCXOERR 171 Q 172 ; 173 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 174 ; 175 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 176 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 177 ; 178 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 179 ; 180 S OCXDATA(DFN,OCXELE)=1 181 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 182 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 183 ; 184 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 185 ; 186 Q 0 187 ; 188 ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER 189 Q:'$G(OIEN) "" 190 ; 191 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." 192 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." 193 Q $P(X,U,1) 194 ; 195 PATLOC(DFN) ; Compiler Function: PATIENT LOCATION 196 ; 197 N OCXP1,OCXP2 198 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) 199 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) 200 I OCXP2 D 201 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) 202 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) 203 .E S OCXP2=$P(OCXP2,"^",1) 204 .S:'$L(OCXP2) OCXP2="NO LOC" 205 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 206 ; 207 S OCXP2=$G(^DPT(+$G(DFN),.1)) 208 I $L(OCXP2) Q "I^"_OCXP2 209 Q "O^OUTPT" 210 ; 1 OCXOZ0C ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK302 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK6+19^OCXOZ02. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK302 Variables 19 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 20 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 21 ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) 22 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 23 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 24 ; 25 ; Local Extrinsic Functions 26 ; FILE(DFN,102, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SITE FLAGGED FINAL IMAGING RESULT) 27 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 28 ; PATLOC( ----------> PATIENT LOCATION 29 ; 30 I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,102,"9,96,147") Q:OCXOERR 31 Q 32 ; 33 CHK314 ; Look through the current environment for valid Event/Elements for this patient. 34 ; Called from CHK35+18^OCXOZ04. 35 ; 36 Q:$G(OCXOERR) 37 ; 38 ; Local CHK314 Variables 39 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) 40 ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) 41 ; 42 ; Local Extrinsic Functions 43 ; FILE(DFN,103, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB TEST RESULTS ABNORMAL) 44 ; 45 I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,103,"12,13,96,114") Q:OCXOERR 46 Q 47 ; 48 CHK324 ; Look through the current environment for valid Event/Elements for this patient. 49 ; Called from CHK34+16^OCXOZ04. 50 ; 51 Q:$G(OCXOERR) 52 ; 53 ; Local CHK324 Variables 54 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 55 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 56 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) 57 ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) 58 ; 59 ; Local Extrinsic Functions 60 ; FILE(DFN,105, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB ORDER RESULTS CRITICAL) 61 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 62 ; 63 S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,105,"12,13,96,114") Q:OCXOERR 64 Q 65 ; 66 CHK336 ; Look through the current environment for valid Event/Elements for this patient. 67 ; Called from CHK6+20^OCXOZ02. 68 ; 69 Q:$G(OCXOERR) 70 ; 71 ; Local CHK336 Variables 72 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 73 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 74 ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) 75 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 76 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 77 ; 78 ; Local Extrinsic Functions 79 ; FILE(DFN,109, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SITE FLAGGED FINAL CONSULT RESULT) 80 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 81 ; PATLOC( ----------> PATIENT LOCATION 82 ; 83 I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,109,"9,96,147") Q:OCXOERR 84 Q 85 ; 86 CHK347 ; Look through the current environment for valid Event/Elements for this patient. 87 ; Called from CHK58+20^OCXOZ05. 88 ; 89 Q:$G(OCXOERR) 90 ; 91 ; Local CHK347 Variables 92 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 93 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 94 ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN) 95 ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC) 96 ; OCXDF(139) --> Data Field: CLOZAPINE WBC W/IN 7 FLAG (BOOLEAN) 97 ; OCXDF(140) --> Data Field: CLOZAPINE WBC W/IN 7 RESULT (NUMERIC) 98 ; 99 ; Local Extrinsic Functions 100 ; 101 S OCXDF(137)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",2) I $L(OCXDF(137)) D CHK349 102 S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),'(OCXDF(136)) D CHK374^OCXOZ0D 103 S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),'(OCXDF(139)) D CHK379^OCXOZ0D 104 S OCXDF(140)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",2) I $L(OCXDF(140)) D CHK383^OCXOZ0D 105 Q 106 ; 107 CHK349 ; Look through the current environment for valid Event/Elements for this patient. 108 ; Called from CHK347+15. 109 ; 110 Q:$G(OCXOERR) 111 ; 112 ; Local CHK349 Variables 113 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 114 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 115 ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN) 116 ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC) 117 ; 118 ; Local Extrinsic Functions 119 ; 120 I (OCXDF(137)<1.5) S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK353 121 I (OCXDF(137)>1.499) S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK359^OCXOZ0D 122 Q 123 ; 124 CHK353 ; Look through the current environment for valid Event/Elements for this patient. 125 ; Called from CHK349+13. 126 ; 127 Q:$G(OCXOERR) 128 ; 129 ; Local CHK353 Variables 130 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 131 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 132 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 133 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) 134 ; 135 ; Local Extrinsic Functions 136 ; FILE(DFN,114, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE ANC < 1.5) 137 ; MSGTEXT( ---------> MESSAGE TEXT 138 ; 139 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,114,"130,145") Q:OCXOERR 140 Q 141 ; 142 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 143 ; 144 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 145 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 146 ; 147 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 148 ; 149 S OCXDATA(DFN,OCXELE)=1 150 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 151 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 152 ; 153 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 154 ; 155 Q 0 156 ; 157 MSGTEXT(ID) ; Compiler Function: MESSAGE TEXT 158 ; 159 N MSG 160 S MSG="" 161 ; 162 I ID="AMITRIPTYLINE" D 163 .S MSG="Amitriptyline can cause cognitive impairment and loss of" 164 .S MSG=MSG_" balance in older patients. Consider other antidepressant" 165 .S MSG=MSG_" medications on formulary." 166 ; 167 I ID="CHLORPROPAMIDE" D 168 .S MSG="Older patients may experience hypoglycemia with" 169 .S MSG=MSG_" Chlorpropamide due to its long duration and variable" 170 .S MSG=MSG_" renal secretion. They may also be at increased risk for" 171 .S MSG=MSG_" Chlorpropamide-induced SIADH." 172 ; 173 I ID="DIPYRIDAMOLE" D 174 .S MSG="Older patients can experience adverse reactions at high doses" 175 .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI" 176 .S MSG=MSG_" intolerance.) There is also questionable efficacy at" 177 .S MSG=MSG_" lower doses." 178 ; 179 I ID="CLOZWBC30_35" D 180 .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill" 181 .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC" 182 .S MSG=MSG_" immediately." 183 ; 184 Q MSG 185 ; 186 ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER 187 Q:'$G(OIEN) "" 188 ; 189 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." 190 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." 191 Q $P(X,U,1) 192 ; 193 PATLOC(DFN) ; Compiler Function: PATIENT LOCATION 194 ; 195 N OCXP1,OCXP2 196 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) 197 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) 198 I OCXP2 D 199 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) 200 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) 201 .E S OCXP2=$P(OCXP2,"^",1) 202 .S:'$L(OCXP2) OCXP2="NO LOC" 203 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 204 ; 205 S OCXP2=$G(^DPT(+$G(DFN),.1)) 206 I $L(OCXP2) Q "I^"_OCXP2 207 Q "O^OUTPT" 208 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0D.m
r613 r623 1 OCXOZ0D ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK360 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK198+9^OCXOZ09. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK360 Variables 19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 20 ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT) 21 ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT) 22 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 23 ; OCXDF(132) --> Data Field: CLOZAPINE MED (BOOLEAN) 24 ; 25 ; Local Extrinsic Functions 26 ; 27 S OCXDF(131)=$P($P($G(OCXPSD),"|",3),"^",4) I $L(OCXDF(131)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(132)=$P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",1) D CHK365 28 S OCXDF(43)=$P($P($G(OCXPSD),"|",3),"^",1) I $L(OCXDF(43)) S OCXDF(74)=$P($$ENVAC^PSJORUT2(OCXDF(43)),"^",2) I $L(OCXDF(74)) D CHK497^OCXOZ0G 29 Q 30 ; 31 CHK365 ; Look through the current environment for valid Event/Elements for this patient. 32 ; Called from CHK360+14. 33 ; 34 Q:$G(OCXOERR) 35 ; 36 ; Local CHK365 Variables 37 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 38 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 39 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 40 ; OCXDF(132) --> Data Field: CLOZAPINE MED (BOOLEAN) 41 ; 42 ; Local Extrinsic Functions 43 ; FILE(DFN,116, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE DRUG SELECTED) 44 ; 45 I $L(OCXDF(132)),(OCXDF(132)) S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,116,"130") Q:OCXOERR 46 Q 47 ; 48 CHK371 ; Look through the current environment for valid Event/Elements for this patient. 49 ; Called from CHK347+16^OCXOZ0C. 50 ; 51 Q:$G(OCXOERR) 52 ; 53 ; Local CHK371 Variables 54 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 55 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 56 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 57 ; 58 ; Local Extrinsic Functions 59 ; FILE(DFN,117, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE NO ANC W/IN 7 DAYS) 60 ; 61 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,117,"130") Q:OCXOERR 62 Q 63 ; 64 CHK375 ; Look through the current environment for valid Event/Elements for this patient. 65 ; Called from CHK347+17^OCXOZ0C. 66 ; 67 Q:$G(OCXOERR) 68 ; 69 ; Local CHK375 Variables 70 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 71 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 72 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 73 ; 74 ; Local Extrinsic Functions 75 ; FILE(DFN,118, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE NO WBC W/IN 7 DAYS) 76 ; 77 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,118,"130") Q:OCXOERR 78 Q 79 ; 80 CHK378 ; Look through the current environment for valid Event/Elements for this patient. 81 ; Called from CHK347+18^OCXOZ0C. 82 ; 83 Q:$G(OCXOERR) 84 ; 85 ; Local CHK378 Variables 86 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 87 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 88 ; OCXDF(139) --> Data Field: CLOZAPINE WBC W/IN 7 FLAG (BOOLEAN) 89 ; OCXDF(140) --> Data Field: CLOZAPINE WBC W/IN 7 RESULT (NUMERIC) 90 ; 91 ; Local Extrinsic Functions 92 ; 93 I (OCXDF(140)<"3.0") S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK382 94 I (OCXDF(140)>2.999),(OCXDF(140)<3.5) S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK388 95 I (OCXDF(140)>3.499) S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK393 96 Q 97 ; 98 CHK382 ; Look through the current environment for valid Event/Elements for this patient. 99 ; Called from CHK378+13. 100 ; 101 Q:$G(OCXOERR) 102 ; 103 ; Local CHK382 Variables 104 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 105 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 106 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 107 ; 108 ; Local Extrinsic Functions 109 ; FILE(DFN,119, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE WBC < 3.0) 110 ; 111 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,119,"130") Q:OCXOERR 112 Q 113 ; 114 CHK388 ; Look through the current environment for valid Event/Elements for this patient. 115 ; Called from CHK378+14. 116 ; 117 Q:$G(OCXOERR) 118 ; 119 ; Local CHK388 Variables 120 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 121 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 122 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 123 ; 124 ; Local Extrinsic Functions 125 ; FILE(DFN,120, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE WBC >= 3.0 & < 3.5) 126 ; 127 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,120,"130") Q:OCXOERR 128 Q 129 ; 130 CHK393 ; Look through the current environment for valid Event/Elements for this patient. 131 ; Called from CHK378+15. 132 ; 133 Q:$G(OCXOERR) 134 ; 135 ; Local CHK393 Variables 136 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 137 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 138 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 139 ; 140 ; Local Extrinsic Functions 141 ; FILE(DFN,121, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE WBC >= 3.5) 142 ; 143 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,121,"130") Q:OCXOERR 144 Q 145 ; 146 CHK398 ; Look through the current environment for valid Event/Elements for this patient. 147 ; Called from CHK58+21^OCXOZ05. 148 ; 149 Q:$G(OCXOERR) 150 ; 151 ; Local CHK398 Variables 152 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 153 ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) 154 ; OCXDF(141) --> Data Field: AMITRIPTYLINE TEXT (FREE TEXT) 155 ; OCXDF(143) --> Data Field: DANGEROUS MEDS FOR PT > 64 NAME (FREE TEXT) 156 ; 157 ; Local Extrinsic Functions 158 ; MSGTEXT( ---------> MESSAGE TEXT 159 ; 160 I (OCXDF(143)["AMITRIPTYLINE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK403^OCXOZ0E 161 I (OCXDF(143)["CHLORPROPAMIDE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK410^OCXOZ0E 162 I (OCXDF(143)["DIPYRIDAMOLE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK417^OCXOZ0E 163 Q 164 ; 165 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 166 ; 167 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 168 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 169 ; 170 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 171 ; 172 S OCXDATA(DFN,OCXELE)=1 173 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 174 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 175 ; 176 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 177 ; 178 Q 0 179 ; 180 MSGTEXT(ID) ; Compiler Function: MESSAGE TEXT 181 ; 182 N MSG 183 S MSG="" 184 ; 185 I ID="AMITRIPTYLINE" D 186 .S MSG="Amitriptyline can cause cognitive impairment and loss of" 187 .S MSG=MSG_" balance in older patients. Consider other antidepressant" 188 .S MSG=MSG_" medications on formulary." 189 ; 190 I ID="CHLORPROPAMIDE" D 191 .S MSG="Older patients may experience hypoglycemia with" 192 .S MSG=MSG_" Chlorpropamide due to its long duration and variable" 193 .S MSG=MSG_" renal secretion. They may also be at increased risk for" 194 .S MSG=MSG_" Chlorpropamide-induced SIADH." 195 ; 196 I ID="DIPYRIDAMOLE" D 197 .S MSG="Older patients can experience adverse reactions at high doses" 198 .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI" 199 .S MSG=MSG_" intolerance.) There is also questionable efficacy at" 200 .S MSG=MSG_" lower doses." 201 ; 202 I ID="CLOZWBC30_35" D 203 .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill" 204 .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC" 205 .S MSG=MSG_" immediately." 206 ; 207 Q MSG 208 ; 1 OCXOZ0D ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK359 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK349+14^OCXOZ0C. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK359 Variables 19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 20 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 21 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 22 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) 23 ; 24 ; Local Extrinsic Functions 25 ; FILE(DFN,115, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE ANC >= 1.5) 26 ; MSGTEXT( ---------> MESSAGE TEXT 27 ; 28 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,115,"130,145") Q:OCXOERR 29 Q 30 ; 31 CHK362 ; Look through the current environment for valid Event/Elements for this patient. 32 ; Called from CHK198+9^OCXOZ09. 33 ; 34 Q:$G(OCXOERR) 35 ; 36 ; Local CHK362 Variables 37 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 38 ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT) 39 ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT) 40 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 41 ; OCXDF(132) --> Data Field: CLOZAPINE MED (BOOLEAN) 42 ; 43 ; Local Extrinsic Functions 44 ; 45 S OCXDF(131)=$P($P($G(OCXPSD),"|",3),"^",4) I $L(OCXDF(131)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(132)=$P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",1) D CHK367 46 S OCXDF(43)=$P($P($G(OCXPSD),"|",3),"^",1) I $L(OCXDF(43)) S OCXDF(74)=$P($$ENVAC^PSJORUT2(OCXDF(43)),"^",2) I $L(OCXDF(74)) D CHK505^OCXOZ0G 47 Q 48 ; 49 CHK367 ; Look through the current environment for valid Event/Elements for this patient. 50 ; Called from CHK362+14. 51 ; 52 Q:$G(OCXOERR) 53 ; 54 ; Local CHK367 Variables 55 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 56 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 57 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 58 ; OCXDF(132) --> Data Field: CLOZAPINE MED (BOOLEAN) 59 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) 60 ; 61 ; Local Extrinsic Functions 62 ; FILE(DFN,116, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE DRUG SELECTED) 63 ; MSGTEXT( ---------> MESSAGE TEXT 64 ; 65 I $L(OCXDF(132)),(OCXDF(132)) S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,116,"130,145") Q:OCXOERR 66 Q 67 ; 68 CHK374 ; Look through the current environment for valid Event/Elements for this patient. 69 ; Called from CHK347+16^OCXOZ0C. 70 ; 71 Q:$G(OCXOERR) 72 ; 73 ; Local CHK374 Variables 74 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 75 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 76 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 77 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) 78 ; 79 ; Local Extrinsic Functions 80 ; FILE(DFN,117, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE NO ANC W/IN 7 DAYS) 81 ; MSGTEXT( ---------> MESSAGE TEXT 82 ; 83 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,117,"130,145") Q:OCXOERR 84 Q 85 ; 86 CHK379 ; Look through the current environment for valid Event/Elements for this patient. 87 ; Called from CHK347+17^OCXOZ0C. 88 ; 89 Q:$G(OCXOERR) 90 ; 91 ; Local CHK379 Variables 92 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 93 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 94 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 95 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) 96 ; 97 ; Local Extrinsic Functions 98 ; FILE(DFN,118, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE NO WBC W/IN 7 DAYS) 99 ; MSGTEXT( ---------> MESSAGE TEXT 100 ; 101 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,118,"130,145") Q:OCXOERR 102 Q 103 ; 104 CHK383 ; Look through the current environment for valid Event/Elements for this patient. 105 ; Called from CHK347+18^OCXOZ0C. 106 ; 107 Q:$G(OCXOERR) 108 ; 109 ; Local CHK383 Variables 110 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 111 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 112 ; OCXDF(139) --> Data Field: CLOZAPINE WBC W/IN 7 FLAG (BOOLEAN) 113 ; OCXDF(140) --> Data Field: CLOZAPINE WBC W/IN 7 RESULT (NUMERIC) 114 ; 115 ; Local Extrinsic Functions 116 ; 117 I (OCXDF(140)<"3.0") S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK387 118 I (OCXDF(140)>2.999),(OCXDF(140)<3.5) S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK394 119 I (OCXDF(140)>3.499) S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK400^OCXOZ0E 120 Q 121 ; 122 CHK387 ; Look through the current environment for valid Event/Elements for this patient. 123 ; Called from CHK383+13. 124 ; 125 Q:$G(OCXOERR) 126 ; 127 ; Local CHK387 Variables 128 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 129 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 130 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 131 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) 132 ; 133 ; Local Extrinsic Functions 134 ; FILE(DFN,119, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE WBC < 3.0) 135 ; MSGTEXT( ---------> MESSAGE TEXT 136 ; 137 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,119,"130,145") Q:OCXOERR 138 Q 139 ; 140 CHK394 ; Look through the current environment for valid Event/Elements for this patient. 141 ; Called from CHK383+14. 142 ; 143 Q:$G(OCXOERR) 144 ; 145 ; Local CHK394 Variables 146 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 147 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 148 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 149 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) 150 ; 151 ; Local Extrinsic Functions 152 ; FILE(DFN,120, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE WBC >= 3.0 & < 3.5) 153 ; MSGTEXT( ---------> MESSAGE TEXT 154 ; 155 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,120,"130,145") Q:OCXOERR 156 Q 157 ; 158 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 159 ; 160 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 161 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 162 ; 163 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 164 ; 165 S OCXDATA(DFN,OCXELE)=1 166 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 167 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 168 ; 169 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 170 ; 171 Q 0 172 ; 173 MSGTEXT(ID) ; Compiler Function: MESSAGE TEXT 174 ; 175 N MSG 176 S MSG="" 177 ; 178 I ID="AMITRIPTYLINE" D 179 .S MSG="Amitriptyline can cause cognitive impairment and loss of" 180 .S MSG=MSG_" balance in older patients. Consider other antidepressant" 181 .S MSG=MSG_" medications on formulary." 182 ; 183 I ID="CHLORPROPAMIDE" D 184 .S MSG="Older patients may experience hypoglycemia with" 185 .S MSG=MSG_" Chlorpropamide due to its long duration and variable" 186 .S MSG=MSG_" renal secretion. They may also be at increased risk for" 187 .S MSG=MSG_" Chlorpropamide-induced SIADH." 188 ; 189 I ID="DIPYRIDAMOLE" D 190 .S MSG="Older patients can experience adverse reactions at high doses" 191 .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI" 192 .S MSG=MSG_" intolerance.) There is also questionable efficacy at" 193 .S MSG=MSG_" lower doses." 194 ; 195 I ID="CLOZWBC30_35" D 196 .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill" 197 .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC" 198 .S MSG=MSG_" immediately." 199 ; 200 Q MSG 201 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0E.m
r613 r623 1 OCXOZ0E ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK403 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK398+14^OCXOZ0D. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK403 Variables 19 ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) 20 ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) 21 ; 22 ; Local Extrinsic Functions 23 ; FILE(DFN,122, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: AMITRIPTYLINE ORDER) 24 ; MSGTEXT( ---------> MESSAGE TEXT 25 ; 26 S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,122,"62,141,142,144") Q:OCXOERR 27 Q 28 ; 29 CHK410 ; Look through the current environment for valid Event/Elements for this patient. 30 ; Called from CHK398+15^OCXOZ0D. 31 ; 32 Q:$G(OCXOERR) 33 ; 34 ; Local CHK410 Variables 35 ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) 36 ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) 37 ; 38 ; Local Extrinsic Functions 39 ; FILE(DFN,123, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CHLORPROPAMIDE ORDER) 40 ; MSGTEXT( ---------> MESSAGE TEXT 41 ; 42 S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,123,"62,141,142,144") Q:OCXOERR 43 Q 44 ; 45 CHK417 ; Look through the current environment for valid Event/Elements for this patient. 46 ; Called from CHK398+16^OCXOZ0D. 47 ; 48 Q:$G(OCXOERR) 49 ; 50 ; Local CHK417 Variables 51 ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) 52 ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) 53 ; 54 ; Local Extrinsic Functions 55 ; FILE(DFN,124, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: DIPYRIDAMOLE ORDER) 56 ; MSGTEXT( ---------> MESSAGE TEXT 57 ; 58 S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,124,"62,141,142,144") Q:OCXOERR 59 Q 60 ; 61 CHK426 ; Look through the current environment for valid Event/Elements for this patient. 62 ; Called from CHK164+16^OCXOZ08. 63 ; 64 Q:$G(OCXOERR) 65 ; 66 ; Local CHK426 Variables 67 ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) 68 ; OCXDF(141) --> Data Field: AMITRIPTYLINE TEXT (FREE TEXT) 69 ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) 70 ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) 71 ; 72 ; Local Extrinsic Functions 73 ; MSGTEXT( ---------> MESSAGE TEXT 74 ; 75 I (OCXDF(62)>64) S OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE"),OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE") D CHK430 76 Q 77 ; 78 CHK430 ; Look through the current environment for valid Event/Elements for this patient. 79 ; Called from CHK426+14. 80 ; 81 Q:$G(OCXOERR) 82 ; 83 ; Local Extrinsic Functions 84 ; FILE(DFN,125, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: MED ORDER FOR PT > 64) 85 ; 86 S OCXOERR=$$FILE(DFN,125,"62,141,142,144") Q:OCXOERR 87 Q 88 ; 89 CHK436 ; Look through the current environment for valid Event/Elements for this patient. 90 ; Called from CHK1+33^OCXOZ02. 91 ; 92 Q:$G(OCXOERR) 93 ; 94 ; Local CHK436 Variables 95 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 96 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 97 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 98 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) 99 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 100 ; 101 ; Local Extrinsic Functions 102 ; FILE(DFN,127, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: INPATIENT) 103 ; FILE(DFN,128, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: OUTPATIENT) 104 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 105 ; PATLOC( ----------> PATIENT LOCATION 106 ; 107 I (OCXDF(146)="I"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,127,"9,96,147") Q:OCXOERR 108 I (OCXDF(146)="O"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,128,"9,96,147") Q:OCXOERR 109 Q 110 ; 111 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 112 ; 113 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 114 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 115 ; 116 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 117 ; 118 S OCXDATA(DFN,OCXELE)=1 119 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 120 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 121 ; 122 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 123 ; 124 Q 0 125 ; 126 MSGTEXT(ID) ; Compiler Function: MESSAGE TEXT 127 ; 128 N MSG 129 S MSG="" 130 ; 131 I ID="AMITRIPTYLINE" D 132 .S MSG="Amitriptyline can cause cognitive impairment and loss of" 133 .S MSG=MSG_" balance in older patients. Consider other antidepressant" 134 .S MSG=MSG_" medications on formulary." 135 ; 136 I ID="CHLORPROPAMIDE" D 137 .S MSG="Older patients may experience hypoglycemia with" 138 .S MSG=MSG_" Chlorpropamide due to its long duration and variable" 139 .S MSG=MSG_" renal secretion. They may also be at increased risk for" 140 .S MSG=MSG_" Chlorpropamide-induced SIADH." 141 ; 142 I ID="DIPYRIDAMOLE" D 143 .S MSG="Older patients can experience adverse reactions at high doses" 144 .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI" 145 .S MSG=MSG_" intolerance.) There is also questionable efficacy at" 146 .S MSG=MSG_" lower doses." 147 ; 148 I ID="CLOZWBC30_35" D 149 .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill" 150 .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC" 151 .S MSG=MSG_" immediately." 152 ; 153 Q MSG 154 ; 155 ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER 156 Q:'$G(OIEN) "" 157 ; 158 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." 159 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." 160 Q $P(X,U,1) 161 ; 162 PATLOC(DFN) ; Compiler Function: PATIENT LOCATION 163 ; 164 N OCXP1,OCXP2 165 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) 166 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) 167 I OCXP2 D 168 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) 169 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) 170 .E S OCXP2=$P(OCXP2,"^",1) 171 .S:'$L(OCXP2) OCXP2="NO LOC" 172 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 173 ; 174 S OCXP2=$G(^DPT(+$G(DFN),.1)) 175 I $L(OCXP2) Q "I^"_OCXP2 176 Q "O^OUTPT" 177 ; 1 OCXOZ0E ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK400 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK383+15^OCXOZ0D. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK400 Variables 19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 20 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 21 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 22 ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) 23 ; 24 ; Local Extrinsic Functions 25 ; FILE(DFN,121, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE WBC >= 3.5) 26 ; MSGTEXT( ---------> MESSAGE TEXT 27 ; 28 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,121,"130,145") Q:OCXOERR 29 Q 30 ; 31 CHK406 ; Look through the current environment for valid Event/Elements for this patient. 32 ; Called from CHK58+21^OCXOZ05. 33 ; 34 Q:$G(OCXOERR) 35 ; 36 ; Local CHK406 Variables 37 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 38 ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) 39 ; OCXDF(141) --> Data Field: AMITRIPTYLINE TEXT (FREE TEXT) 40 ; OCXDF(143) --> Data Field: DANGEROUS MEDS FOR PT > 64 NAME (FREE TEXT) 41 ; 42 ; Local Extrinsic Functions 43 ; MSGTEXT( ---------> MESSAGE TEXT 44 ; 45 I (OCXDF(143)["AMITRIPTYLINE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK411 46 I (OCXDF(143)["CHLORPROPAMIDE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK418 47 I (OCXDF(143)["DIPYRIDAMOLE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK425 48 Q 49 ; 50 CHK411 ; Look through the current environment for valid Event/Elements for this patient. 51 ; Called from CHK406+14. 52 ; 53 Q:$G(OCXOERR) 54 ; 55 ; Local CHK411 Variables 56 ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) 57 ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) 58 ; 59 ; Local Extrinsic Functions 60 ; FILE(DFN,122, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: AMITRIPTYLINE ORDER) 61 ; MSGTEXT( ---------> MESSAGE TEXT 62 ; 63 S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,122,"62,141,142,144") Q:OCXOERR 64 Q 65 ; 66 CHK418 ; Look through the current environment for valid Event/Elements for this patient. 67 ; Called from CHK406+15. 68 ; 69 Q:$G(OCXOERR) 70 ; 71 ; Local CHK418 Variables 72 ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) 73 ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) 74 ; 75 ; Local Extrinsic Functions 76 ; FILE(DFN,123, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CHLORPROPAMIDE ORDER) 77 ; MSGTEXT( ---------> MESSAGE TEXT 78 ; 79 S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,123,"62,141,142,144") Q:OCXOERR 80 Q 81 ; 82 CHK425 ; Look through the current environment for valid Event/Elements for this patient. 83 ; Called from CHK406+16. 84 ; 85 Q:$G(OCXOERR) 86 ; 87 ; Local CHK425 Variables 88 ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) 89 ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) 90 ; 91 ; Local Extrinsic Functions 92 ; FILE(DFN,124, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: DIPYRIDAMOLE ORDER) 93 ; MSGTEXT( ---------> MESSAGE TEXT 94 ; 95 S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,124,"62,141,142,144") Q:OCXOERR 96 Q 97 ; 98 CHK434 ; Look through the current environment for valid Event/Elements for this patient. 99 ; Called from CHK164+16^OCXOZ08. 100 ; 101 Q:$G(OCXOERR) 102 ; 103 ; Local CHK434 Variables 104 ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) 105 ; OCXDF(141) --> Data Field: AMITRIPTYLINE TEXT (FREE TEXT) 106 ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) 107 ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) 108 ; 109 ; Local Extrinsic Functions 110 ; MSGTEXT( ---------> MESSAGE TEXT 111 ; 112 I (OCXDF(62)>64) S OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE"),OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE") D CHK438 113 Q 114 ; 115 CHK438 ; Look through the current environment for valid Event/Elements for this patient. 116 ; Called from CHK434+14. 117 ; 118 Q:$G(OCXOERR) 119 ; 120 ; Local Extrinsic Functions 121 ; FILE(DFN,125, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: MED ORDER FOR PT > 64) 122 ; 123 S OCXOERR=$$FILE(DFN,125,"62,141,142,144") Q:OCXOERR 124 Q 125 ; 126 CHK444 ; Look through the current environment for valid Event/Elements for this patient. 127 ; Called from CHK1+33^OCXOZ02. 128 ; 129 Q:$G(OCXOERR) 130 ; 131 ; Local CHK444 Variables 132 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 133 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 134 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 135 ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) 136 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 137 ; 138 ; Local Extrinsic Functions 139 ; FILE(DFN,127, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: INPATIENT) 140 ; FILE(DFN,128, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: OUTPATIENT) 141 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 142 ; PATLOC( ----------> PATIENT LOCATION 143 ; 144 I (OCXDF(146)="I"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,127,"9,96,147") Q:OCXOERR 145 I (OCXDF(146)="O"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,128,"9,96,147") Q:OCXOERR 146 Q 147 ; 148 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 149 ; 150 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 151 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 152 ; 153 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 154 ; 155 S OCXDATA(DFN,OCXELE)=1 156 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 157 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 158 ; 159 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 160 ; 161 Q 0 162 ; 163 MSGTEXT(ID) ; Compiler Function: MESSAGE TEXT 164 ; 165 N MSG 166 S MSG="" 167 ; 168 I ID="AMITRIPTYLINE" D 169 .S MSG="Amitriptyline can cause cognitive impairment and loss of" 170 .S MSG=MSG_" balance in older patients. Consider other antidepressant" 171 .S MSG=MSG_" medications on formulary." 172 ; 173 I ID="CHLORPROPAMIDE" D 174 .S MSG="Older patients may experience hypoglycemia with" 175 .S MSG=MSG_" Chlorpropamide due to its long duration and variable" 176 .S MSG=MSG_" renal secretion. They may also be at increased risk for" 177 .S MSG=MSG_" Chlorpropamide-induced SIADH." 178 ; 179 I ID="DIPYRIDAMOLE" D 180 .S MSG="Older patients can experience adverse reactions at high doses" 181 .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI" 182 .S MSG=MSG_" intolerance.) There is also questionable efficacy at" 183 .S MSG=MSG_" lower doses." 184 ; 185 I ID="CLOZWBC30_35" D 186 .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill" 187 .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC" 188 .S MSG=MSG_" immediately." 189 ; 190 Q MSG 191 ; 192 ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER 193 Q:'$G(OIEN) "" 194 ; 195 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." 196 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." 197 Q $P(X,U,1) 198 ; 199 PATLOC(DFN) ; Compiler Function: PATIENT LOCATION 200 ; 201 N OCXP1,OCXP2 202 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) 203 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) 204 I OCXP2 D 205 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) 206 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) 207 .E S OCXP2=$P(OCXP2,"^",1) 208 .S:'$L(OCXP2) OCXP2="NO LOC" 209 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 210 ; 211 S OCXP2=$G(^DPT(+$G(DFN),.1)) 212 I $L(OCXP2) Q "I^"_OCXP2 213 Q "O^OUTPT" 214 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0F.m
r613 r623 1 OCXOZ0F ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK446 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK58+22^OCXOZ05. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK446 Variables 19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 20 ; OCXDF(57) ---> Data Field: MOST RECENT RENAL TEST ABNORMAL FLAG (BOOLEAN) 21 ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT) 22 ; OCXDF(154) --> Data Field: RECENT CONTRAST MEDIA CREATININE DAYS (NUMERIC) 23 ; OCXDF(155) --> Data Field: RECENT CONTRAST MEDIA CREATININE FLAG (BOOLEAN) 24 ; 25 ; Local Extrinsic Functions 26 ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW 27 ; RECCREAT( --------> RECENT CREATININE LAB PROCEDURE 28 ; 29 S OCXDF(57)=$P($$ABREN(OCXDF(37)),"^",1) I $L(OCXDF(57)),(OCXDF(57)) S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1) D CHK451 30 S OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1) I $L(OCXDF(154)) S OCXDF(155)=$P($$RECCREAT(OCXDF(37),OCXDF(154)),"^",1) I $L(OCXDF(155)),'(OCXDF(155)) D CHK482^OCXOZ0G 31 Q 32 ; 33 CHK451 ; Look through the current environment for valid Event/Elements for this patient. 34 ; Called from CHK446+16. 35 ; 36 Q:$G(OCXOERR) 37 ; 38 ; Local Extrinsic Functions 39 ; FILE(DFN,129, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ABNORMAL RENAL RESULTS) 40 ; 41 S OCXOERR=$$FILE(DFN,129,"58,154") Q:OCXOERR 42 Q 43 ; 44 CHK458 ; Look through the current environment for valid Event/Elements for this patient. 45 ; Called from CHK196+18^OCXOZ09. 46 ; 47 Q:$G(OCXOERR) 48 ; 49 ; Local CHK458 Variables 50 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 51 ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT) 52 ; OCXDF(154) --> Data Field: RECENT CONTRAST MEDIA CREATININE DAYS (NUMERIC) 53 ; 54 ; Local Extrinsic Functions 55 ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW 56 ; FILE(DFN,130, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CONTRAST MEDIA ORDER) 57 ; 58 S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1),OCXOERR=$$FILE(DFN,130,"58,154") Q:OCXOERR 59 Q 60 ; 61 CHK463 ; Look through the current environment for valid Event/Elements for this patient. 62 ; Called from CHK1+34^OCXOZ02. 63 ; 64 Q:$G(OCXOERR) 65 ; 66 ; Local CHK463 Variables 67 ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT) 68 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 69 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 70 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 71 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) 72 ; OCXDF(150) --> Data Field: LAB RESULT < THRESHOLD (BOOLEAN) 73 ; OCXDF(151) --> Data Field: LAB RESULT > THRESHOLD (BOOLEAN) 74 ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC) 75 ; 76 ; Local Extrinsic Functions 77 ; LABTHRSB( --------> LAB THRESHOLD EXCEEDED BOOLEAN 78 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 79 ; 80 S OCXDF(151)=$P($$LABTHRSB(OCXDF(113),OCXDF(152),OCXDF(12),">"),"^",1) I $L(OCXDF(151)),(OCXDF(151)),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) D CHK469 81 S OCXDF(150)=$P($$LABTHRSB(OCXDF(113),OCXDF(152),OCXDF(12),"<"),"^",1) I $L(OCXDF(150)),(OCXDF(150)),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) D CHK476 82 Q 83 ; 84 CHK469 ; Look through the current environment for valid Event/Elements for this patient. 85 ; Called from CHK463+19. 86 ; 87 Q:$G(OCXOERR) 88 ; 89 ; Local CHK469 Variables 90 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 91 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 92 ; 93 ; Local Extrinsic Functions 94 ; FILE(DFN,131, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: GREATER THAN LAB THRESHOLD) 95 ; PATLOC( ----------> PATIENT LOCATION 96 ; 97 S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,131,"12,37,96,113,147,152") Q:OCXOERR 98 Q 99 ; 100 CHK476 ; Look through the current environment for valid Event/Elements for this patient. 101 ; Called from CHK463+20. 102 ; 103 Q:$G(OCXOERR) 104 ; 105 ; Local CHK476 Variables 106 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 107 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 108 ; 109 ; Local Extrinsic Functions 110 ; FILE(DFN,132, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: LESS THAN LAB THRESHOLD) 111 ; PATLOC( ----------> PATIENT LOCATION 112 ; 113 S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,132,"12,37,96,113,147,152") Q:OCXOERR 114 Q 115 ; 116 ABREN(DFN) ; Compiler Function: DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW 117 ; 118 N OCXFLAG,OCXVAL,OCXLIST,OCXTEST,UNAV,OCXTLIST,OCXTERM,OCXSLIST,OCXSPEC 119 S (OCXLIST,OCXTLIST)="",UNAV="0^<Unavailable>" 120 S OCXSLIST="" Q:'$$TERMLKUP("SERUM SPECIMEN",.OCXSLIST) UNAV 121 F OCXTERM="SERUM CREATININE","SERUM UREA NITROGEN" D Q:($L(OCXLIST)>130) 122 .Q:'$$TERMLKUP(OCXTERM,.OCXTLIST) 123 .S OCXTEST=0 F S OCXTEST=$O(OCXTLIST(OCXTEST)) Q:'OCXTEST D Q:($L(OCXLIST)>130) 124 ..S OCXSPEC=0 F S OCXSPEC=$O(OCXSLIST(OCXSPEC)) Q:'OCXSPEC D Q:($L(OCXLIST)>130) 125 ...S OCXVAL=$$LOCL^ORQQLR1(DFN,OCXTEST,OCXSPEC),OCXFLAG=$P(OCXVAL,U,5) 126 ...I $L(OCXVAL),((OCXFLAG["H")!(OCXFLAG["L")) D 127 ....N OCXY S OCXY="" 128 ....S OCXY=$P(OCXVAL,U,2)_": "_$P(OCXVAL,U,3)_" "_$P(OCXVAL,U,4) 129 ....S OCXY=OCXY_" "_$S($L(OCXFLAG):"["_OCXFLAG_"]",1:"") 130 ....S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXVAL,U,7),"2P") 131 ....S:$L(OCXLIST) OCXLIST=OCXLIST_" " S OCXLIST=OCXLIST_OCXY 132 Q:'$L(OCXLIST) UNAV Q 1_U_OCXLIST 133 ; 134 ; 135 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 136 ; 137 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 138 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 139 ; 140 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 141 ; 142 S OCXDATA(DFN,OCXELE)=1 143 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 144 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 145 ; 146 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 147 ; 148 Q 0 149 ; 150 LABTHRSB(OCXLAB,OCXSPEC,OCXRSLT,OCXOP) ; Compiler Function: LAB THRESHOLD EXCEEDED BOOLEAN 151 ; 152 S OCXRSLT=$TR($G(OCXRSLT),"<>=","") 153 Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT)!'$L($G(OCXOP)) 0 154 ; 155 N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXEXCD 156 S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXSPEC 157 D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR) 158 Q:+$G(ORERR)'=0 OCXEXCD 159 Q:+$G(OCXX)=0 OCXEXCD 160 S OCXPENT="" F S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT!OCXEXCD=1 D 161 .S OCXPVAL=OCXX(OCXPENT,OCXLABSP) 162 .I $L(OCXPVAL) D 163 ..I $P(OCXPENT,";",2)="VA(200,",@((+OCXRSLT)_OCXOP_OCXPVAL) D 164 ...S OCXEXCD=1 165 Q OCXEXCD 166 ; 167 ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER 168 Q:'$G(OIEN) "" 169 ; 170 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." 171 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." 172 Q $P(X,U,1) 173 ; 174 PATLOC(DFN) ; Compiler Function: PATIENT LOCATION 175 ; 176 N OCXP1,OCXP2 177 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) 178 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) 179 I OCXP2 D 180 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) 181 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) 182 .E S OCXP2=$P(OCXP2,"^",1) 183 .S:'$L(OCXP2) OCXP2="NO LOC" 184 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 185 ; 186 S OCXP2=$G(^DPT(+$G(DFN),.1)) 187 I $L(OCXP2) Q "I^"_OCXP2 188 Q "O^OUTPT" 189 ; 190 RECCREAT(ORDFN,ORDAYS) ;extrinsic function to return most recent 191 ;SERUM CREATININE within <ORDAYS> in format: 192 ; test id^result units flag ref range collection d/t 193 N BDT,CDT,ORY,ORX,ORZ,X,ORI,ORJ,CREARSLT,LABFILE,SPECFILE 194 Q:'$L($G(ORDFN)) "0^" 195 Q:'$L($G(ORDAYS)) "0^" 196 D NOW^%DTC 197 S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","") 198 K % 199 Q:'$L($G(BDT)) "0^" 200 S LABFILE=$$TERMLKUP("SERUM CREATININE",.ORY) 201 Q:$G(LABFILE)'=60 "0^" 202 Q:+$D(ORY)<1 "0^" 203 S SPECFILE=$$TERMLKUP("SERUM SPECIMEN",.ORX) 204 Q:$G(SPECFILE)'=61 "0^" 205 Q:+$D(ORX)<1 "0^" 206 S ORI=0 F S ORI=$O(ORY(ORI)) Q:'ORI I +$G(CREARSLT)<1 D 207 .S ORJ=0 F S ORJ=$O(ORX(ORJ)) Q:'ORJ I +$G(CREARSLT)<1 D 208 ..S ORZ=$$LOCL^ORQQLR1(ORDFN,ORI,ORJ) 209 ..Q:'$L($G(ORZ)) 210 ..S CDT=$P(ORZ,U,7) 211 ..I CDT'<BDT S CREARSLT=1 212 Q:+$G(CREARSLT)<1 "0^" 213 Q $P(ORZ,U)_U_$P(ORZ,U,3)_" "_$P(ORZ,U,4)_" "_$P(ORZ,U,5)_" ("_$P(ORZ,U,6)_") "_$$FMTE^XLFDT(CDT,"2P")_U_$P(ORZ,U,3) 214 ; 215 TERMLKUP(OCXTERM,OCXLIST) ; 216 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) 217 ; 1 OCXOZ0F ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK454 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK58+22^OCXOZ05. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK454 Variables 19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 20 ; OCXDF(57) ---> Data Field: MOST RECENT RENAL TEST ABNORMAL FLAG (BOOLEAN) 21 ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT) 22 ; OCXDF(154) --> Data Field: RECENT CONTRAST MEDIA CREATININE DAYS (NUMERIC) 23 ; OCXDF(155) --> Data Field: RECENT CONTRAST MEDIA CREATININE FLAG (BOOLEAN) 24 ; 25 ; Local Extrinsic Functions 26 ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW 27 ; RECCREAT( --------> RECENT CREATININE LAB PROCEDURE 28 ; 29 S OCXDF(57)=$P($$ABREN(OCXDF(37)),"^",1) I $L(OCXDF(57)),(OCXDF(57)) S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1) D CHK459 30 S OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1) I $L(OCXDF(154)) S OCXDF(155)=$P($$RECCREAT(OCXDF(37),OCXDF(154)),"^",1) I $L(OCXDF(155)),'(OCXDF(155)) D CHK490^OCXOZ0G 31 Q 32 ; 33 CHK459 ; Look through the current environment for valid Event/Elements for this patient. 34 ; Called from CHK454+16. 35 ; 36 Q:$G(OCXOERR) 37 ; 38 ; Local Extrinsic Functions 39 ; FILE(DFN,129, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ABNORMAL RENAL RESULTS) 40 ; 41 S OCXOERR=$$FILE(DFN,129,"58,154") Q:OCXOERR 42 Q 43 ; 44 CHK466 ; Look through the current environment for valid Event/Elements for this patient. 45 ; Called from CHK196+18^OCXOZ09. 46 ; 47 Q:$G(OCXOERR) 48 ; 49 ; Local CHK466 Variables 50 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 51 ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT) 52 ; OCXDF(154) --> Data Field: RECENT CONTRAST MEDIA CREATININE DAYS (NUMERIC) 53 ; 54 ; Local Extrinsic Functions 55 ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW 56 ; FILE(DFN,130, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CONTRAST MEDIA ORDER) 57 ; 58 S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1),OCXOERR=$$FILE(DFN,130,"58,154") Q:OCXOERR 59 Q 60 ; 61 CHK471 ; Look through the current environment for valid Event/Elements for this patient. 62 ; Called from CHK1+34^OCXOZ02. 63 ; 64 Q:$G(OCXOERR) 65 ; 66 ; Local CHK471 Variables 67 ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT) 68 ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) 69 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 70 ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) 71 ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) 72 ; OCXDF(150) --> Data Field: LAB RESULT < THRESHOLD (BOOLEAN) 73 ; OCXDF(151) --> Data Field: LAB RESULT > THRESHOLD (BOOLEAN) 74 ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC) 75 ; 76 ; Local Extrinsic Functions 77 ; LABTHRSB( --------> LAB THRESHOLD EXCEEDED BOOLEAN 78 ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER 79 ; 80 S OCXDF(151)=$P($$LABTHRSB(OCXDF(113),OCXDF(152),OCXDF(12),">"),"^",1) I $L(OCXDF(151)),(OCXDF(151)),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) D CHK477 81 S OCXDF(150)=$P($$LABTHRSB(OCXDF(113),OCXDF(152),OCXDF(12),"<"),"^",1) I $L(OCXDF(150)),(OCXDF(150)),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) D CHK484 82 Q 83 ; 84 CHK477 ; Look through the current environment for valid Event/Elements for this patient. 85 ; Called from CHK471+19. 86 ; 87 Q:$G(OCXOERR) 88 ; 89 ; Local CHK477 Variables 90 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 91 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 92 ; 93 ; Local Extrinsic Functions 94 ; FILE(DFN,131, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: GREATER THAN LAB THRESHOLD) 95 ; PATLOC( ----------> PATIENT LOCATION 96 ; 97 S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,131,"12,37,96,113,147,152") Q:OCXOERR 98 Q 99 ; 100 CHK484 ; Look through the current environment for valid Event/Elements for this patient. 101 ; Called from CHK471+20. 102 ; 103 Q:$G(OCXOERR) 104 ; 105 ; Local CHK484 Variables 106 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 107 ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) 108 ; 109 ; Local Extrinsic Functions 110 ; FILE(DFN,132, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: LESS THAN LAB THRESHOLD) 111 ; PATLOC( ----------> PATIENT LOCATION 112 ; 113 S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,132,"12,37,96,113,147,152") Q:OCXOERR 114 Q 115 ; 116 ABREN(DFN) ; Compiler Function: DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW 117 ; 118 N OCXFLAG,OCXVAL,OCXLIST,OCXTEST,UNAV,OCXTLIST,OCXTERM,OCXSLIST,OCXSPEC 119 S (OCXLIST,OCXTLIST)="",UNAV="0^<Unavailable>" 120 S OCXSLIST="" Q:'$$TERMLKUP("SERUM SPECIMEN",.OCXSLIST) UNAV 121 F OCXTERM="SERUM CREATININE","SERUM UREA NITROGEN" D Q:($L(OCXLIST)>130) 122 .Q:'$$TERMLKUP(OCXTERM,.OCXTLIST) 123 .S OCXTEST=0 F S OCXTEST=$O(OCXTLIST(OCXTEST)) Q:'OCXTEST D Q:($L(OCXLIST)>130) 124 ..S OCXSPEC=0 F S OCXSPEC=$O(OCXSLIST(OCXSPEC)) Q:'OCXSPEC D Q:($L(OCXLIST)>130) 125 ...S OCXVAL=$$LOCL^ORQQLR1(DFN,OCXTEST,OCXSPEC),OCXFLAG=$P(OCXVAL,U,5) 126 ...I $L(OCXVAL),((OCXFLAG["H")!(OCXFLAG["L")) D 127 ....N OCXY S OCXY="" 128 ....S OCXY=$P(OCXVAL,U,2)_": "_$P(OCXVAL,U,3)_" "_$P(OCXVAL,U,4) 129 ....S OCXY=OCXY_" "_$S($L(OCXFLAG):"["_OCXFLAG_"]",1:"") 130 ....S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXVAL,U,7),"2P") 131 ....S:$L(OCXLIST) OCXLIST=OCXLIST_" " S OCXLIST=OCXLIST_OCXY 132 Q:'$L(OCXLIST) UNAV Q 1_U_OCXLIST 133 ; 134 ; 135 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 136 ; 137 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 138 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 139 ; 140 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 141 ; 142 S OCXDATA(DFN,OCXELE)=1 143 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 144 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 145 ; 146 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 147 ; 148 Q 0 149 ; 150 LABTHRSB(OCXLAB,OCXSPEC,OCXRSLT,OCXOP) ; Compiler Function: LAB THRESHOLD EXCEEDED BOOLEAN 151 ; 152 Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT)!'$L($G(OCXOP)) 0 153 ; 154 N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXEXCD 155 S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXSPEC 156 D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR) 157 Q:+$G(ORERR)'=0 OCXEXCD 158 Q:+$G(OCXX)=0 OCXEXCD 159 S OCXPENT="" F S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT!OCXEXCD=1 D 160 .S OCXPVAL=OCXX(OCXPENT,OCXLABSP) 161 .I $L(OCXPVAL) D 162 ..I $P(OCXPENT,";",2)="VA(200,",@((+OCXRSLT)_OCXOP_OCXPVAL) D 163 ...S OCXEXCD=1 164 Q OCXEXCD 165 ; 166 ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER 167 Q:'$G(OIEN) "" 168 ; 169 N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." 170 S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." 171 Q $P(X,U,1) 172 ; 173 PATLOC(DFN) ; Compiler Function: PATIENT LOCATION 174 ; 175 N OCXP1,OCXP2 176 S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) 177 S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) 178 I OCXP2 D 179 .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) 180 .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) 181 .E S OCXP2=$P(OCXP2,"^",1) 182 .S:'$L(OCXP2) OCXP2="NO LOC" 183 I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 184 ; 185 S OCXP2=$G(^DPT(+$G(DFN),.1)) 186 I $L(OCXP2) Q "I^"_OCXP2 187 Q "O^OUTPT" 188 ; 189 RECCREAT(ORDFN,ORDAYS) ;extrinsic function to return most recent 190 ;SERUM CREATININE within <ORDAYS> in format: 191 ; test id^result units flag ref range collection d/t 192 N BDT,CDT,ORY,ORX,ORZ,X,ORI,ORJ,CREARSLT,LABFILE,SPECFILE 193 Q:'$L($G(ORDFN)) "0^" 194 Q:'$L($G(ORDAYS)) "0^" 195 D NOW^%DTC 196 S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","") 197 K % 198 Q:'$L($G(BDT)) "0^" 199 S LABFILE=$$TERMLKUP("SERUM CREATININE",.ORY) 200 Q:$G(LABFILE)'=60 "0^" 201 Q:+$D(ORY)<1 "0^" 202 S SPECFILE=$$TERMLKUP("SERUM SPECIMEN",.ORX) 203 Q:$G(SPECFILE)'=61 "0^" 204 Q:+$D(ORX)<1 "0^" 205 S ORI=0 F S ORI=$O(ORY(ORI)) Q:'ORI I +$G(CREARSLT)<1 D 206 .S ORJ=0 F S ORJ=$O(ORX(ORJ)) Q:'ORJ I +$G(CREARSLT)<1 D 207 ..S ORZ=$$LOCL^ORQQLR1(ORDFN,ORI,ORJ) 208 ..Q:'$L($G(ORZ)) 209 ..S CDT=$P(ORZ,U,7) 210 ..I CDT'<BDT S CREARSLT=1 211 Q:+$G(CREARSLT)<1 "0^" 212 Q $P(ORZ,U)_U_$P(ORZ,U,3)_" "_$P(ORZ,U,4)_" "_$P(ORZ,U,5)_" ("_$P(ORZ,U,6)_") "_$$FMTE^XLFDT(CDT,"2P")_U_$P(ORZ,U,3) 213 ; 214 TERMLKUP(OCXTERM,OCXLIST) ; 215 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) 216 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0G.m
r613 r623 1 OCXOZ0G ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 CHK4 82; Look through the current environment for valid Event/Elements for this patient.14 ; Called from CHK446+17^OCXOZ0F.15 16 17 18 ; Local CHK482Variables19 20 21 22 23 24 25 26 27 28 29 CHK 497; Look through the current environment for valid Event/Elements for this patient.30 ; Called from CHK360+15^OCXOZ0D.31 32 33 34 ; Local CHK497Variables35 36 37 38 39 40 41 42 43 I $$LIST(OCXDF(74),"OPIOID ANALGESICS,OPIOID ANTAGONIST ANALGESICS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(158)=$P($$OPIOID(OCXDF(37)),"^",2) D CHK501 44 45 46 CHK50 1; Look through the current environment for valid Event/Elements for this patient.47 ; Called from CHK497+14.48 49 50 51 52 53 54 55 56 57 CHK505 ; Look through the current environment for valid Event/Elements for this patient. 58 ; Called from CHK355+14^OCXOZ0C.59 60 61 62 ; Local CHK505 Variables 63 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 64 ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) 65 ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) 66 ; 67 ; Local Extrinsic Functions 68 ; FILE(DFN,140, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE ANC >= 1.5 & < 2.0)69 70 S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,140,"130") Q:OCXOERR 71 72 73 EL 24 ; Examine every rule that involves Element #24 [HL7 LAB TEST RESULTS CRITICAL]74 75 76 77 78 D R3R1A^OCXOZ0I ; Check Relation #1 in Rule #3 'CRITICAL LAB RESULTS'79 80 81 EL1 05 ; Examine every rule that involves Element #105 [HL7 LAB ORDER RESULTS CRITICAL]82 83 84 85 86 D R3R2A^OCXOZ0J ; Check Relation #2 in Rule #3 'CRITICAL LAB RESULTS'87 88 89 EL4 4 ; Examine every rule that involves Element #44 [ORDER FLAGGED]90 91 92 93 94 D R5R1A^OCXOZ0J ; Check Relation #1 in Rule #5 'ORDER FLAGGED FOR CLARIFICATION'95 96 97 EL 134 ; Examine every rule that involves Element #134 [ORDER UNFLAGGED]98 99 100 101 102 D R5R2A^OCXOZ0K ; Check Relation #2 in Rule #5 'ORDER FLAGGED FOR CLARIFICATION'103 104 105 EL 45 ; Examine every rule that involves Element #45 [ORDER REQUIRES CHART SIGNATURE]106 107 108 109 110 D R6R1A^OCXOZ0K ; Check Relation #1 in Rule #6 'ORDER REQUIRES CHART SIGNATURE'111 112 113 EL 21 ; Examine every rule that involves Element #21 [PATIENT ADMISSION]114 115 116 117 118 D R7R1A^OCXOZ0K ; Check Relation #1 in Rule #7 'PATIENT ADMISSION'119 Q 120 ; 121 EL31 ; Examine every rule that involves Element #31 [RADIOLOGY ORDER CANCELLED] 122 ; Called from SCAN+9^OCXOZ01. 123 124 Q:$G(OCXOERR) 125 ; 126 D R11R1A^OCXOZ0L ; Check Relation #1 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' 127 Q 128 129 EL100 ; Examine every rule that involves Element #100 [CANCELED BY NON-ORIG ORDERING PROVIDER] 130 ; Called from SCAN+9^OCXOZ01. 131 132 Q:$G(OCXOERR) 133 ; 134 D R11R1A^OCXOZ0L ; Check Relation #1 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' 135 D R11R2A^OCXOZ0L ; Check Relation #2 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' 136 D R11R3A^OCXOZ0M ; Check Relation #3 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' 137 D R35R1A^OCXOZ0Q ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED'138 139 140 EL 30 ; Examine every rule that involves Element #30 [RADIOLOGY ORDER PUT ON-HOLD]141 142 143 144 145 D R11R2A^OCXOZ0L ; Check Relation #2 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'146 147 148 EL 32 ; Examine every rule that involves Element #32 [RADIOLOGY ORDER DISCONTINUED]149 150 151 152 153 D R11R3A^OCXOZ0M ; Check Relation #3 in Rule #11 'IMAGING REQUEST CANCELLED/HELD'154 155 156 EL 46 ; Examine every rule that involves Element #46 [SERVICE ORDER REQUIRES CHART SIGNATURE]157 158 159 160 161 D R16R1A^OCXOZ0M ; Check Relation #1 in Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE'162 163 164 EL 76 ; Examine every rule that involves Element #76 [STAT LABRESULT]165 166 167 168 169 D R18R1A^OCXOZ0M ; Check Relation #1in Rule #18 'STAT RESULTS AVAILABLE'170 171 172 EL 75 ; Examine every rule that involves Element #75 [STAT IMAGING RESULT]173 174 175 176 177 D R18R2A^OCXOZ0N ; Check Relation #2 in Rule #18 'STAT RESULTS AVAILABLE'178 179 180 EL 110 ; Examine every rule that involves Element #110 [STAT CONSULT RESULT]181 182 183 184 185 D R18R3A^OCXOZ0N ; Check Relation #3 in Rule #18 'STAT RESULTS AVAILABLE'186 187 188 ABREN(DFN) 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 FILE(DFN,OCXELE,OCXDFL) 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 LIST(DATA,LIST) 223 224 225 226 227 OPIOID(ORPT) 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 TERMLKUP(OCXTERM,OCXLIST) 257 258 1 OCXOZ0G ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 CHK490 ; Look through the current environment for valid Event/Elements for this patient. 14 ; Called from CHK454+17^OCXOZ0F. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local CHK490 Variables 19 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 20 ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT) 21 ; 22 ; Local Extrinsic Functions 23 ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW 24 ; FILE(DFN,133, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NO CREAT RESULTS W/IN X DAYS) 25 ; 26 S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,133,"58,154") Q:OCXOERR 27 Q 28 ; 29 CHK505 ; Look through the current environment for valid Event/Elements for this patient. 30 ; Called from CHK362+15^OCXOZ0D. 31 ; 32 Q:$G(OCXOERR) 33 ; 34 ; Local CHK505 Variables 35 ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) 36 ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT) 37 ; OCXDF(158) --> Data Field: DUPLICATE OPIOID MEDICATIONS TEXT (FREE TEXT) 38 ; 39 ; Local Extrinsic Functions 40 ; LIST( ------------> IN LIST OPERATOR 41 ; OPIOID( ----------> OPIOID MEDICATIONS 42 ; 43 I $$LIST(OCXDF(74),"OPIOID ANALGESICS,OPIOID ANTAGONIST ANALGESICS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(158)=$P($$OPIOID(OCXDF(37)),"^",2) D CHK509 44 Q 45 ; 46 CHK509 ; Look through the current environment for valid Event/Elements for this patient. 47 ; Called from CHK505+14. 48 ; 49 Q:$G(OCXOERR) 50 ; 51 ; Local Extrinsic Functions 52 ; FILE(DFN,139, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: OPIOID MED ORDER) 53 ; 54 S OCXOERR=$$FILE(DFN,139,"158") Q:OCXOERR 55 Q 56 ; 57 EL24 ; Examine every rule that involves Element #24 [HL7 LAB TEST RESULTS CRITICAL] 58 ; Called from SCAN+9^OCXOZ01. 59 ; 60 Q:$G(OCXOERR) 61 ; 62 D R3R1A^OCXOZ0I ; Check Relation #1 in Rule #3 'CRITICAL LAB RESULTS' 63 Q 64 ; 65 EL105 ; Examine every rule that involves Element #105 [HL7 LAB ORDER RESULTS CRITICAL] 66 ; Called from SCAN+9^OCXOZ01. 67 ; 68 Q:$G(OCXOERR) 69 ; 70 D R3R2A^OCXOZ0J ; Check Relation #2 in Rule #3 'CRITICAL LAB RESULTS' 71 Q 72 ; 73 EL44 ; Examine every rule that involves Element #44 [ORDER FLAGGED] 74 ; Called from SCAN+9^OCXOZ01. 75 ; 76 Q:$G(OCXOERR) 77 ; 78 D R5R1A^OCXOZ0J ; Check Relation #1 in Rule #5 'ORDER FLAGGED FOR CLARIFICATION' 79 Q 80 ; 81 EL134 ; Examine every rule that involves Element #134 [ORDER UNFLAGGED] 82 ; Called from SCAN+9^OCXOZ01. 83 ; 84 Q:$G(OCXOERR) 85 ; 86 D R5R2A^OCXOZ0K ; Check Relation #2 in Rule #5 'ORDER FLAGGED FOR CLARIFICATION' 87 Q 88 ; 89 EL45 ; Examine every rule that involves Element #45 [ORDER REQUIRES CHART SIGNATURE] 90 ; Called from SCAN+9^OCXOZ01. 91 ; 92 Q:$G(OCXOERR) 93 ; 94 D R6R1A^OCXOZ0K ; Check Relation #1 in Rule #6 'ORDER REQUIRES CHART SIGNATURE' 95 Q 96 ; 97 EL21 ; Examine every rule that involves Element #21 [PATIENT ADMISSION] 98 ; Called from SCAN+9^OCXOZ01. 99 ; 100 Q:$G(OCXOERR) 101 ; 102 D R7R1A^OCXOZ0K ; Check Relation #1 in Rule #7 'PATIENT ADMISSION' 103 Q 104 ; 105 EL31 ; Examine every rule that involves Element #31 [RADIOLOGY ORDER CANCELLED] 106 ; Called from SCAN+9^OCXOZ01. 107 ; 108 Q:$G(OCXOERR) 109 ; 110 D R11R1A^OCXOZ0L ; Check Relation #1 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' 111 Q 112 ; 113 EL100 ; Examine every rule that involves Element #100 [CANCELED BY NON-ORIG ORDERING PROVIDER] 114 ; Called from SCAN+9^OCXOZ01. 115 ; 116 Q:$G(OCXOERR) 117 ; 118 D R11R1A^OCXOZ0L ; Check Relation #1 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' 119 D R11R2A^OCXOZ0L ; Check Relation #2 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' 120 D R11R3A^OCXOZ0M ; Check Relation #3 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' 121 D R35R1A^OCXOZ0Q ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED' 122 Q 123 ; 124 EL30 ; Examine every rule that involves Element #30 [RADIOLOGY ORDER PUT ON-HOLD] 125 ; Called from SCAN+9^OCXOZ01. 126 ; 127 Q:$G(OCXOERR) 128 ; 129 D R11R2A^OCXOZ0L ; Check Relation #2 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' 130 Q 131 ; 132 EL32 ; Examine every rule that involves Element #32 [RADIOLOGY ORDER DISCONTINUED] 133 ; Called from SCAN+9^OCXOZ01. 134 ; 135 Q:$G(OCXOERR) 136 ; 137 D R11R3A^OCXOZ0M ; Check Relation #3 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' 138 Q 139 ; 140 EL46 ; Examine every rule that involves Element #46 [SERVICE ORDER REQUIRES CHART SIGNATURE] 141 ; Called from SCAN+9^OCXOZ01. 142 ; 143 Q:$G(OCXOERR) 144 ; 145 D R16R1A^OCXOZ0M ; Check Relation #1 in Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE' 146 Q 147 ; 148 EL76 ; Examine every rule that involves Element #76 [STAT LAB RESULT] 149 ; Called from SCAN+9^OCXOZ01. 150 ; 151 Q:$G(OCXOERR) 152 ; 153 D R18R1A^OCXOZ0M ; Check Relation #1 in Rule #18 'STAT RESULTS AVAILABLE' 154 Q 155 ; 156 EL75 ; Examine every rule that involves Element #75 [STAT IMAGING RESULT] 157 ; Called from SCAN+9^OCXOZ01. 158 ; 159 Q:$G(OCXOERR) 160 ; 161 D R18R2A^OCXOZ0N ; Check Relation #2 in Rule #18 'STAT RESULTS AVAILABLE' 162 Q 163 ; 164 EL110 ; Examine every rule that involves Element #110 [STAT CONSULT RESULT] 165 ; Called from SCAN+9^OCXOZ01. 166 ; 167 Q:$G(OCXOERR) 168 ; 169 D R18R3A^OCXOZ0N ; Check Relation #3 in Rule #18 'STAT RESULTS AVAILABLE' 170 Q 171 ; 172 EL56 ; Examine every rule that involves Element #56 [PATIENT DISCHARGE] 173 ; Called from SCAN+9^OCXOZ01. 174 ; 175 Q:$G(OCXOERR) 176 ; 177 D R19R1A^OCXOZ0N ; Check Relation #1 in Rule #19 'PATIENT DISCHARGE' 178 Q 179 ; 180 EL47 ; Examine every rule that involves Element #47 [ORDER REQUIRES CO-SIGNATURE] 181 ; Called from SCAN+9^OCXOZ01. 182 ; 183 Q:$G(OCXOERR) 184 ; 185 D R22R1A^OCXOZ0O ; Check Relation #1 in Rule #22 'ORDER REQUIRES CO-SIGNATURE' 186 Q 187 ; 188 ABREN(DFN) ; Compiler Function: DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW 189 ; 190 N OCXFLAG,OCXVAL,OCXLIST,OCXTEST,UNAV,OCXTLIST,OCXTERM,OCXSLIST,OCXSPEC 191 S (OCXLIST,OCXTLIST)="",UNAV="0^<Unavailable>" 192 S OCXSLIST="" Q:'$$TERMLKUP("SERUM SPECIMEN",.OCXSLIST) UNAV 193 F OCXTERM="SERUM CREATININE","SERUM UREA NITROGEN" D Q:($L(OCXLIST)>130) 194 .Q:'$$TERMLKUP(OCXTERM,.OCXTLIST) 195 .S OCXTEST=0 F S OCXTEST=$O(OCXTLIST(OCXTEST)) Q:'OCXTEST D Q:($L(OCXLIST)>130) 196 ..S OCXSPEC=0 F S OCXSPEC=$O(OCXSLIST(OCXSPEC)) Q:'OCXSPEC D Q:($L(OCXLIST)>130) 197 ...S OCXVAL=$$LOCL^ORQQLR1(DFN,OCXTEST,OCXSPEC),OCXFLAG=$P(OCXVAL,U,5) 198 ...I $L(OCXVAL),((OCXFLAG["H")!(OCXFLAG["L")) D 199 ....N OCXY S OCXY="" 200 ....S OCXY=$P(OCXVAL,U,2)_": "_$P(OCXVAL,U,3)_" "_$P(OCXVAL,U,4) 201 ....S OCXY=OCXY_" "_$S($L(OCXFLAG):"["_OCXFLAG_"]",1:"") 202 ....S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXVAL,U,7),"2P") 203 ....S:$L(OCXLIST) OCXLIST=OCXLIST_" " S OCXLIST=OCXLIST_OCXY 204 Q:'$L(OCXLIST) UNAV Q 1_U_OCXLIST 205 ; 206 ; 207 FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. 208 ; 209 N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI 210 S DFN=+$G(DFN),OCXELE=+$G(OCXELE) 211 ; 212 Q:'DFN 1 Q:'OCXELE 1 K OCXDATA 213 ; 214 S OCXDATA(DFN,OCXELE)=1 215 F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D 216 .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL 217 ; 218 M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) 219 ; 220 Q 0 221 ; 222 LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST 223 ; 224 S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," 225 Q (LIST[DATA) 226 ; 227 OPIOID(ORPT) ;determine if pat is receiving opioid med 228 ; rtn 1^opioid drug 1, opioid drug 2, opioid drug3, ... 229 N ORDG,ORTN,ORNUM,ORDI,ORDCLAS,ORDERS,ORTEXT,DUP,DUPI,DUPJ,DUPLEN 230 S ORDG=0,ORTN=0,DUPI=0,DUPLEN=20 231 K ^TMP("ORR",$J) 232 S ORDG=$O(^ORD(100.98,"B","RX",ORDG)) 233 D EN^ORQ1(ORPT_";DPT(",ORDG,2,"","","",0,0) 234 N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0 235 S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 ORTN 236 F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D 237 .S X=^TMP("ORR",$J,HOR,SEQ) 238 .S ORNUM=+$P(X,";") 239 .Q:ORNUM=+$G(ORIFN) ;quit if dup med order # = current order # 240 .S ORDI=$$VALUE^ORCSAVE2(ORNUM,"DRUG") 241 .I +$G(ORDI)>0 D 242 ..S ORDCLAS=$P(^PSDRUG(ORDI,0),U,2) ;va drug class 243 ..I ($G(ORDCLAS)="CN101")!($G(ORDCLAS)="CN102") D ;opioid classes 244 ...S ORTEXT=$$FULLTEXT^ORQOR1(ORNUM) 245 ...S ORTEXT=$P(ORTEXT,U)_" ["_$P(ORTEXT,U,2)_"]" 246 ...S DUPI=DUPI+1,DUP(DUPI)=" ["_DUPI_"] "_ORTEXT 247 ...S ORTN=1 248 I DUPI>0 D 249 .S DUPLEN=$P(215/DUPI,".") 250 .F DUPJ=1:1:DUPI D 251 ..I DUPJ=1 S ORDERS=$E(DUP(DUPJ),1,DUPLEN) 252 ..E S ORDERS=ORDERS_", "_$E(DUP(DUPJ),1,DUPLEN) 253 K ^TMP("ORR",$J) 254 Q ORTN_U_$G(ORDERS) 255 ; 256 TERMLKUP(OCXTERM,OCXLIST) ; 257 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) 258 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0H.m
r613 r623 1 OCXOZ0H ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 EL56 ; Examine every rule that involves Element #56 [PATIENT DISCHARGE] 14 ; Called from SCAN+9^OCXOZ01. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 D R19R1A^OCXOZ0N ; Check Relation #1 in Rule #19 'PATIENT DISCHARGE' 19 Q 20 ; 21 EL47 ; Examine every rule that involves Element #47 [ORDER REQUIRES CO-SIGNATURE] 22 ; Called from SCAN+9^OCXOZ01. 23 ; 24 Q:$G(OCXOERR) 25 ; 26 D R22R1A^OCXOZ0O ; Check Relation #1 in Rule #22 'ORDER REQUIRES CO-SIGNATURE' 27 Q 28 ; 29 EL5 ; Examine every rule that involves Element #5 [HL7 FINAL LAB RESULT] 30 ; Called from SCAN+9^OCXOZ01. 31 ; 32 Q:$G(OCXOERR) 33 ; 34 D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' 35 D R66R1A^OCXOZ0Z ; Check Relation #1 in Rule #66 'LAB RESULTS' 36 D R69R1A^OCXOZ11 ; Check Relation #1 in Rule #69 'LAB THRESHOLD' 37 Q 38 ; 39 EL49 ; Examine every rule that involves Element #49 [ORDER FLAGGED FOR RESULTS] 40 ; Called from SCAN+9^OCXOZ01. 41 ; 42 Q:$G(OCXOERR) 43 ; 44 D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' 45 Q 46 ; 47 EL55 ; Examine every rule that involves Element #55 [CONSULT FINAL RESULTS] 48 ; Called from SCAN+9^OCXOZ01. 49 ; 50 Q:$G(OCXOERR) 51 ; 52 D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' 53 Q 54 ; 55 EL101 ; Examine every rule that involves Element #101 [HL7 FINAL IMAGING RESULT] 56 ; Called from SCAN+9^OCXOZ01. 57 ; 58 Q:$G(OCXOERR) 59 ; 60 D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' 61 Q 62 ; 63 EL60 ; Examine every rule that involves Element #60 [NEW OBR STAT ORDER] 64 ; Called from SCAN+9^OCXOZ01. 65 ; 66 Q:$G(OCXOERR) 67 ; 68 D R28R1A^OCXOZ0P ; Check Relation #1 in Rule #28 'STAT ORDER PLACED' 69 Q 70 ; 71 EL61 ; Examine every rule that involves Element #61 [NEW ORC STAT ORDER] 72 ; Called from SCAN+9^OCXOZ01. 73 ; 74 Q:$G(OCXOERR) 75 ; 76 D R28R1A^OCXOZ0P ; Check Relation #1 in Rule #28 'STAT ORDER PLACED' 77 Q 78 ; 79 EL42 ; Examine every rule that involves Element #42 [PATIENT TRANSFERRED FROM PSYCH WARD] 80 ; Called from SCAN+9^OCXOZ01. 81 ; 82 Q:$G(OCXOERR) 83 ; 84 D R32R1A^OCXOZ0P ; Check Relation #1 in Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO ANOTHER UNIT' 85 Q 86 ; 87 EL20 ; Examine every rule that involves Element #20 [HL7 LAB ORDER CANCELLED] 88 ; Called from SCAN+9^OCXOZ01. 89 ; 90 Q:$G(OCXOERR) 91 ; 92 D R35R1A^OCXOZ0Q ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED' 93 Q 94 ; 95 EL40 ; Examine every rule that involves Element #40 [HL7 LAB REQUEST CANCELLED] 96 ; Called from SCAN+9^OCXOZ01. 97 ; 98 Q:$G(OCXOERR) 99 ; 100 D R35R1A^OCXOZ0Q ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED' 101 Q 102 ; 103 EL6 ; Examine every rule that involves Element #6 [HL7 NEW OERR ORDER] 104 ; Called from SCAN+9^OCXOZ01. 105 ; 106 Q:$G(OCXOERR) 107 ; 108 D R38R1A^OCXOZ0Q ; Check Relation #1 in Rule #38 'NEW ORDER PLACED' 109 Q 110 ; 111 EL126 ; Examine every rule that involves Element #126 [HL7 DCED OERR ORDER] 112 ; Called from SCAN+9^OCXOZ01. 113 ; 114 Q:$G(OCXOERR) 115 ; 116 D R38R2A^OCXOZ0Q ; Check Relation #2 in Rule #38 'NEW ORDER PLACED' 117 Q 118 ; 119 EL23 ; Examine every rule that involves Element #23 [HL7 LAB ORDER RESULTS ABNORMAL] 120 ; Called from SCAN+9^OCXOZ01. 121 ; 122 Q:$G(OCXOERR) 123 ; 124 D R42R1A^OCXOZ0R ; Check Relation #1 in Rule #42 'ABNORMAL LAB RESULTS' 125 Q 126 ; 127 EL103 ; Examine every rule that involves Element #103 [HL7 LAB TEST RESULTS ABNORMAL] 128 ; Called from SCAN+9^OCXOZ01. 129 ; 130 Q:$G(OCXOERR) 131 ; 132 D R42R2A^OCXOZ0R ; Check Relation #2 in Rule #42 'ABNORMAL LAB RESULTS' 133 Q 134 ; 135 EL48 ; Examine every rule that involves Element #48 [ORDER REQUIRES ELECTRONIC SIGNATURE] 136 ; Called from SCAN+9^OCXOZ01. 137 ; 138 Q:$G(OCXOERR) 139 ; 140 D R44R1A^OCXOZ0R ; Check Relation #1 in Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE' 141 Q 142 ; 143 EL58 ; Examine every rule that involves Element #58 [NEW SITE FLAGGED ORDER] 144 ; Called from SCAN+9^OCXOZ01. 145 ; 146 Q:$G(OCXOERR) 147 ; 148 D R48R1A^OCXOZ0S ; Check Relation #1 in Rule #48 'SITE FLAGGED ORDER' 149 D R48R2A^OCXOZ0S ; Check Relation #2 in Rule #48 'SITE FLAGGED ORDER' 150 Q 151 ; 152 EL127 ; Examine every rule that involves Element #127 [INPATIENT] 153 ; Called from SCAN+9^OCXOZ01. 154 ; 155 Q:$G(OCXOERR) 156 ; 157 D R48R1A^OCXOZ0S ; Check Relation #1 in Rule #48 'SITE FLAGGED ORDER' 158 D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' 159 Q 160 ; 161 EL128 ; Examine every rule that involves Element #128 [OUTPATIENT] 162 ; Called from SCAN+9^OCXOZ01. 163 ; 164 Q:$G(OCXOERR) 165 ; 166 D R48R2A^OCXOZ0S ; Check Relation #2 in Rule #48 'SITE FLAGGED ORDER' 167 D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' 168 Q 169 ; 170 EL59 ; Examine every rule that involves Element #59 [SITE FLAGGED FINAL LAB RESULT] 171 ; Called from SCAN+9^OCXOZ01. 172 ; 173 Q:$G(OCXOERR) 174 ; 175 D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' 176 D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' 177 Q 178 ; 179 EL102 ; Examine every rule that involves Element #102 [SITE FLAGGED FINAL IMAGING RESULT] 180 ; Called from SCAN+9^OCXOZ01. 181 ; 182 Q:$G(OCXOERR) 183 ; 184 D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' 185 D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' 186 Q 187 ; 188 EL109 ; Examine every rule that involves Element #109 [SITE FLAGGED FINAL CONSULT RESULT] 189 ; Called from SCAN+9^OCXOZ01. 190 ; 191 Q:$G(OCXOERR) 192 ; 193 D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' 194 D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' 195 Q 196 ; 197 EL129 ; Examine every rule that involves Element #129 [ABNORMAL RENAL RESULTS] 198 ; Called from SCAN+9^OCXOZ01. 199 ; 200 Q:$G(OCXOERR) 201 ; 202 D R50R1A^OCXOZ0U ; Check Relation #1 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' 203 Q 204 ; 205 EL130 ; Examine every rule that involves Element #130 [CONTRAST MEDIA ORDER] 206 ; Called from SCAN+9^OCXOZ01. 207 ; 208 Q:$G(OCXOERR) 209 ; 210 D R50R1A^OCXOZ0U ; Check Relation #1 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' 211 D R50R2A^OCXOZ0V ; Check Relation #2 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' 212 Q 213 ; 214 EL133 ; Examine every rule that involves Element #133 [NO CREAT RESULTS W/IN X DAYS] 215 ; Called from SCAN+9^OCXOZ01. 216 ; 217 Q:$G(OCXOERR) 218 ; 219 D R50R2A^OCXOZ0V ; Check Relation #2 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' 220 Q 221 ; 222 EL63 ; Examine every rule that involves Element #63 [PATIENT HAS RECENT CHOLECYSTOGRAM] 223 ; Called from SCAN+9^OCXOZ01. 224 ; 225 Q:$G(OCXOERR) 226 ; 227 D R51R1A^OCXOZ0V ; Check Relation #1 in Rule #51 'RECENT CHOLECYSTOGRAM ORDER' 228 Q 229 ; 230 EL64 ; Examine every rule that involves Element #64 [PHARMACY PATIENT OVER 65] 231 ; Called from SCAN+9^OCXOZ01. 232 ; 233 Q:$G(OCXOERR) 234 ; 235 D R53R1A^OCXOZ0V ; Check Relation #1 in Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK' 236 Q 237 ; 238 EL65 ; Examine every rule that involves Element #65 [SESSION ORDER FOR ANGIOGRAM] 239 ; Called from SCAN+9^OCXOZ01. 240 ; 241 Q:$G(OCXOERR) 242 ; 243 D R54R1A^OCXOZ0V ; Check Relation #1 in Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CATH - PERIPHERAL' 244 Q 245 ; 246 EL66 ; Examine every rule that involves Element #66 [CONTRAST MEDIA ALLERGY] 247 ; Called from SCAN+9^OCXOZ01. 248 ; 249 Q:$G(OCXOERR) 250 ; 251 D R55R1A^OCXOZ0V ; Check Relation #1 in Rule #55 'ALLERGY - CONTRAST MEDIA REACTION' 252 Q 253 ; 254 EL67 ; Examine every rule that involves Element #67 [RECENT BARIUM STUDY ORDERED] 255 ; Called from SCAN+9^OCXOZ01. 256 ; 257 Q:$G(OCXOERR) 258 ; 259 D R56R1A^OCXOZ0W ; Check Relation #1 in Rule #56 'RECENT BARIUM STUDY' 260 Q 261 ; 262 EL116 ; Examine every rule that involves Element #116 [CLOZAPINE DRUG SELECTED] 263 ; Called from SCAN+9^OCXOZ01. 264 ; 265 Q:$G(OCXOERR) 266 ; 267 D R57R1A^OCXOZ0W ; Check Relation #1 in Rule #57 'CLOZAPINE' 268 D R57R2A^OCXOZ0W ; Check Relation #2 in Rule #57 'CLOZAPINE' 269 D R57R3A^OCXOZ0W ; Check Relation #3 in Rule #57 'CLOZAPINE' 270 D R57R4A^OCXOZ0W ; Check Relation #4 in Rule #57 'CLOZAPINE' 271 Q 272 ; 273 EL117 ; Examine every rule that involves Element #117 [CLOZAPINE NO ANC W/IN 7 DAYS] 274 ; Called from SCAN+9^OCXOZ01. 275 ; 276 Q:$G(OCXOERR) 277 ; 278 D R57R1A^OCXOZ0W ; Check Relation #1 in Rule #57 'CLOZAPINE' 279 Q 280 ; 281 EL118 ; Examine every rule that involves Element #118 [CLOZAPINE NO WBC W/IN 7 DAYS] 282 ; Called from SCAN+9^OCXOZ01. 283 ; 284 Q:$G(OCXOERR) 285 ; 286 D R57R1A^OCXOZ0W ; Check Relation #1 in Rule #57 'CLOZAPINE' 287 Q 288 ; 1 OCXOZ0H ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 EL5 ; Examine every rule that involves Element #5 [HL7 FINAL LAB RESULT] 14 ; Called from SCAN+9^OCXOZ01. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' 19 D R66R1A^OCXOZ0Z ; Check Relation #1 in Rule #66 'LAB RESULTS' 20 D R69R1A^OCXOZ11 ; Check Relation #1 in Rule #69 'LAB THRESHOLD' 21 Q 22 ; 23 EL49 ; Examine every rule that involves Element #49 [ORDER FLAGGED FOR RESULTS] 24 ; Called from SCAN+9^OCXOZ01. 25 ; 26 Q:$G(OCXOERR) 27 ; 28 D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' 29 Q 30 ; 31 EL55 ; Examine every rule that involves Element #55 [CONSULT FINAL RESULTS] 32 ; Called from SCAN+9^OCXOZ01. 33 ; 34 Q:$G(OCXOERR) 35 ; 36 D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' 37 Q 38 ; 39 EL101 ; Examine every rule that involves Element #101 [HL7 FINAL IMAGING RESULT] 40 ; Called from SCAN+9^OCXOZ01. 41 ; 42 Q:$G(OCXOERR) 43 ; 44 D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' 45 Q 46 ; 47 EL60 ; Examine every rule that involves Element #60 [NEW OBR STAT ORDER] 48 ; Called from SCAN+9^OCXOZ01. 49 ; 50 Q:$G(OCXOERR) 51 ; 52 D R28R1A^OCXOZ0P ; Check Relation #1 in Rule #28 'STAT ORDER PLACED' 53 Q 54 ; 55 EL61 ; Examine every rule that involves Element #61 [NEW ORC STAT ORDER] 56 ; Called from SCAN+9^OCXOZ01. 57 ; 58 Q:$G(OCXOERR) 59 ; 60 D R28R1A^OCXOZ0P ; Check Relation #1 in Rule #28 'STAT ORDER PLACED' 61 Q 62 ; 63 EL42 ; Examine every rule that involves Element #42 [PATIENT TRANSFERRED FROM PSYCH WARD] 64 ; Called from SCAN+9^OCXOZ01. 65 ; 66 Q:$G(OCXOERR) 67 ; 68 D R32R1A^OCXOZ0P ; Check Relation #1 in Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO ANOTHER UNIT' 69 Q 70 ; 71 EL20 ; Examine every rule that involves Element #20 [HL7 LAB ORDER CANCELLED] 72 ; Called from SCAN+9^OCXOZ01. 73 ; 74 Q:$G(OCXOERR) 75 ; 76 D R35R1A^OCXOZ0Q ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED' 77 Q 78 ; 79 EL40 ; Examine every rule that involves Element #40 [HL7 LAB REQUEST CANCELLED] 80 ; Called from SCAN+9^OCXOZ01. 81 ; 82 Q:$G(OCXOERR) 83 ; 84 D R35R1A^OCXOZ0Q ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED' 85 Q 86 ; 87 EL6 ; Examine every rule that involves Element #6 [HL7 NEW OERR ORDER] 88 ; Called from SCAN+9^OCXOZ01. 89 ; 90 Q:$G(OCXOERR) 91 ; 92 D R38R1A^OCXOZ0Q ; Check Relation #1 in Rule #38 'NEW ORDER PLACED' 93 Q 94 ; 95 EL126 ; Examine every rule that involves Element #126 [HL7 DCED OERR ORDER] 96 ; Called from SCAN+9^OCXOZ01. 97 ; 98 Q:$G(OCXOERR) 99 ; 100 D R38R2A^OCXOZ0Q ; Check Relation #2 in Rule #38 'NEW ORDER PLACED' 101 Q 102 ; 103 EL23 ; Examine every rule that involves Element #23 [HL7 LAB ORDER RESULTS ABNORMAL] 104 ; Called from SCAN+9^OCXOZ01. 105 ; 106 Q:$G(OCXOERR) 107 ; 108 D R42R1A^OCXOZ0R ; Check Relation #1 in Rule #42 'ABNORMAL LAB RESULTS' 109 Q 110 ; 111 EL103 ; Examine every rule that involves Element #103 [HL7 LAB TEST RESULTS ABNORMAL] 112 ; Called from SCAN+9^OCXOZ01. 113 ; 114 Q:$G(OCXOERR) 115 ; 116 D R42R2A^OCXOZ0R ; Check Relation #2 in Rule #42 'ABNORMAL LAB RESULTS' 117 Q 118 ; 119 EL48 ; Examine every rule that involves Element #48 [ORDER REQUIRES ELECTRONIC SIGNATURE] 120 ; Called from SCAN+9^OCXOZ01. 121 ; 122 Q:$G(OCXOERR) 123 ; 124 D R44R1A^OCXOZ0R ; Check Relation #1 in Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE' 125 Q 126 ; 127 EL58 ; Examine every rule that involves Element #58 [NEW SITE FLAGGED ORDER] 128 ; Called from SCAN+9^OCXOZ01. 129 ; 130 Q:$G(OCXOERR) 131 ; 132 D R48R1A^OCXOZ0S ; Check Relation #1 in Rule #48 'SITE FLAGGED ORDER' 133 D R48R2A^OCXOZ0S ; Check Relation #2 in Rule #48 'SITE FLAGGED ORDER' 134 Q 135 ; 136 EL127 ; Examine every rule that involves Element #127 [INPATIENT] 137 ; Called from SCAN+9^OCXOZ01. 138 ; 139 Q:$G(OCXOERR) 140 ; 141 D R48R1A^OCXOZ0S ; Check Relation #1 in Rule #48 'SITE FLAGGED ORDER' 142 D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' 143 Q 144 ; 145 EL128 ; Examine every rule that involves Element #128 [OUTPATIENT] 146 ; Called from SCAN+9^OCXOZ01. 147 ; 148 Q:$G(OCXOERR) 149 ; 150 D R48R2A^OCXOZ0S ; Check Relation #2 in Rule #48 'SITE FLAGGED ORDER' 151 D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' 152 Q 153 ; 154 EL59 ; Examine every rule that involves Element #59 [SITE FLAGGED FINAL LAB RESULT] 155 ; Called from SCAN+9^OCXOZ01. 156 ; 157 Q:$G(OCXOERR) 158 ; 159 D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' 160 D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' 161 Q 162 ; 163 EL102 ; Examine every rule that involves Element #102 [SITE FLAGGED FINAL IMAGING RESULT] 164 ; Called from SCAN+9^OCXOZ01. 165 ; 166 Q:$G(OCXOERR) 167 ; 168 D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' 169 D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' 170 Q 171 ; 172 EL109 ; Examine every rule that involves Element #109 [SITE FLAGGED FINAL CONSULT RESULT] 173 ; Called from SCAN+9^OCXOZ01. 174 ; 175 Q:$G(OCXOERR) 176 ; 177 D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' 178 D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' 179 Q 180 ; 181 EL129 ; Examine every rule that involves Element #129 [ABNORMAL RENAL RESULTS] 182 ; Called from SCAN+9^OCXOZ01. 183 ; 184 Q:$G(OCXOERR) 185 ; 186 D R50R1A^OCXOZ0U ; Check Relation #1 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' 187 Q 188 ; 189 EL130 ; Examine every rule that involves Element #130 [CONTRAST MEDIA ORDER] 190 ; Called from SCAN+9^OCXOZ01. 191 ; 192 Q:$G(OCXOERR) 193 ; 194 D R50R1A^OCXOZ0U ; Check Relation #1 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' 195 D R50R2A^OCXOZ0V ; Check Relation #2 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' 196 Q 197 ; 198 EL133 ; Examine every rule that involves Element #133 [NO CREAT RESULTS W/IN X DAYS] 199 ; Called from SCAN+9^OCXOZ01. 200 ; 201 Q:$G(OCXOERR) 202 ; 203 D R50R2A^OCXOZ0V ; Check Relation #2 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' 204 Q 205 ; 206 EL63 ; Examine every rule that involves Element #63 [PATIENT HAS RECENT CHOLECYSTOGRAM] 207 ; Called from SCAN+9^OCXOZ01. 208 ; 209 Q:$G(OCXOERR) 210 ; 211 D R51R1A^OCXOZ0V ; Check Relation #1 in Rule #51 'RECENT CHOLECYSTOGRAM ORDER' 212 Q 213 ; 214 EL64 ; Examine every rule that involves Element #64 [PHARMACY PATIENT OVER 65] 215 ; Called from SCAN+9^OCXOZ01. 216 ; 217 Q:$G(OCXOERR) 218 ; 219 D R53R1A^OCXOZ0V ; Check Relation #1 in Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK' 220 Q 221 ; 222 EL65 ; Examine every rule that involves Element #65 [SESSION ORDER FOR ANGIOGRAM] 223 ; Called from SCAN+9^OCXOZ01. 224 ; 225 Q:$G(OCXOERR) 226 ; 227 D R54R1A^OCXOZ0V ; Check Relation #1 in Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CATH - PERIPHERAL' 228 Q 229 ; 230 EL66 ; Examine every rule that involves Element #66 [CONTRAST MEDIA ALLERGY] 231 ; Called from SCAN+9^OCXOZ01. 232 ; 233 Q:$G(OCXOERR) 234 ; 235 D R55R1A^OCXOZ0V ; Check Relation #1 in Rule #55 'ALLERGY - CONTRAST MEDIA REACTION' 236 Q 237 ; 238 EL67 ; Examine every rule that involves Element #67 [RECENT BARIUM STUDY ORDERED] 239 ; Called from SCAN+9^OCXOZ01. 240 ; 241 Q:$G(OCXOERR) 242 ; 243 D R56R1A^OCXOZ0W ; Check Relation #1 in Rule #56 'RECENT BARIUM STUDY' 244 Q 245 ; 246 EL114 ; Examine every rule that involves Element #114 [CLOZAPINE ANC < 1.5] 247 ; Called from SCAN+9^OCXOZ01. 248 ; 249 Q:$G(OCXOERR) 250 ; 251 D R57R1A^OCXOZ0W ; Check Relation #1 in Rule #57 'CLOZAPINE' 252 Q 253 ; 254 EL116 ; Examine every rule that involves Element #116 [CLOZAPINE DRUG SELECTED] 255 ; Called from SCAN+9^OCXOZ01. 256 ; 257 Q:$G(OCXOERR) 258 ; 259 D R57R1A^OCXOZ0W ; Check Relation #1 in Rule #57 'CLOZAPINE' 260 D R57R2A^OCXOZ0W ; Check Relation #2 in Rule #57 'CLOZAPINE' 261 D R57R3A^OCXOZ0W ; Check Relation #3 in Rule #57 'CLOZAPINE' 262 D R57R4A^OCXOZ0W ; Check Relation #4 in Rule #57 'CLOZAPINE' 263 D R57R5A^OCXOZ0X ; Check Relation #5 in Rule #57 'CLOZAPINE' 264 Q 265 ; 266 EL119 ; Examine every rule that involves Element #119 [CLOZAPINE WBC < 3.0] 267 ; Called from SCAN+9^OCXOZ01. 268 ; 269 Q:$G(OCXOERR) 270 ; 271 D R57R1A^OCXOZ0W ; Check Relation #1 in Rule #57 'CLOZAPINE' 272 Q 273 ; 274 EL118 ; Examine every rule that involves Element #118 [CLOZAPINE NO WBC W/IN 7 DAYS] 275 ; Called from SCAN+9^OCXOZ01. 276 ; 277 Q:$G(OCXOERR) 278 ; 279 D R57R2A^OCXOZ0W ; Check Relation #2 in Rule #57 'CLOZAPINE' 280 Q 281 ; 282 EL117 ; Examine every rule that involves Element #117 [CLOZAPINE NO ANC W/IN 7 DAYS] 283 ; Called from SCAN+9^OCXOZ01. 284 ; 285 Q:$G(OCXOERR) 286 ; 287 D R57R3A^OCXOZ0W ; Check Relation #3 in Rule #57 'CLOZAPINE' 288 Q 289 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0I.m
r613 r623 1 OCXOZ0I ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 EL114 ; Examine every rule that involves Element #114 [CLOZAPINE ANC < 1.5] 14 ; Called from SCAN+9^OCXOZ01. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 D R57R2A^OCXOZ0W ; Check Relation #2 in Rule #57 'CLOZAPINE' 19 Q 20 ; 21 EL119 ; Examine every rule that involves Element #119 [CLOZAPINE WBC < 3.0] 22 ; Called from SCAN+9^OCXOZ01. 23 ; 24 Q:$G(OCXOERR) 25 ; 26 D R57R2A^OCXOZ0W ; Check Relation #2 in Rule #57 'CLOZAPINE' 27 Q 28 ; 29 EL115 ; Examine every rule that involves Element #115 [CLOZAPINE ANC >= 1.5] 30 ; Called from SCAN+9^OCXOZ01. 31 ; 32 Q:$G(OCXOERR) 33 ; 34 D R57R3A^OCXOZ0W ; Check Relation #3 in Rule #57 'CLOZAPINE' 35 Q 36 ; 37 EL120 ; Examine every rule that involves Element #120 [CLOZAPINE WBC >= 3.0 & < 3.5] 38 ; Called from SCAN+9^OCXOZ01. 39 ; 40 Q:$G(OCXOERR) 41 ; 42 D R57R3A^OCXOZ0W ; Check Relation #3 in Rule #57 'CLOZAPINE' 43 Q 44 ; 45 EL140 ; Examine every rule that involves Element #140 [CLOZAPINE ANC >= 1.5 & < 2.0] 46 ; Called from SCAN+9^OCXOZ01. 47 ; 48 Q:$G(OCXOERR) 49 ; 50 D R57R4A^OCXOZ0W ; Check Relation #4 in Rule #57 'CLOZAPINE' 51 Q 52 ; 53 EL71 ; Examine every rule that involves Element #71 [AMINOGLYCOSIDE ORDER SESSION] 54 ; Called from SCAN+9^OCXOZ01. 55 ; 56 Q:$G(OCXOERR) 57 ; 58 D R59R1A^OCXOZ0X ; Check Relation #1 in Rule #59 'AMINOGLYCOSIDE ORDER' 59 Q 60 ; 61 EL72 ; Examine every rule that involves Element #72 [PATIENT OVER CT OR MRI DEVICE LIMITATIONS] 62 ; Called from SCAN+9^OCXOZ01. 63 ; 64 Q:$G(OCXOERR) 65 ; 66 D R60R1A^OCXOZ0X ; Check Relation #1 in Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK' 67 Q 68 ; 69 EL73 ; Examine every rule that involves Element #73 [CREATININE CLEARANCE ESTIMATE] 70 ; Called from SCAN+9^OCXOZ01. 71 ; 72 Q:$G(OCXOERR) 73 ; 74 D R61R1A^OCXOZ0Y ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION' 75 Q 76 ; 77 EL96 ; Examine every rule that involves Element #96 [CREATININE CLEARANCE DATE/TIME] 78 ; Called from SCAN+9^OCXOZ01. 79 ; 80 Q:$G(OCXOERR) 81 ; 82 D R61R1A^OCXOZ0Y ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION' 83 Q 84 ; 85 EL97 ; Examine every rule that involves Element #97 [RENAL RESULTS] 86 ; Called from SCAN+9^OCXOZ01. 87 ; 88 Q:$G(OCXOERR) 89 ; 90 D R61R1A^OCXOZ0Y ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION' 91 Q 92 ; 93 EL84 ; Examine every rule that involves Element #84 [INPATIENT FOOD-DRUG REACTION] 94 ; Called from SCAN+9^OCXOZ01. 95 ; 96 Q:$G(OCXOERR) 97 ; 98 D R62R1A^OCXOZ0Z ; Check Relation #1 in Rule #62 'FOOD/DRUG INTERACTION' 99 Q 100 ; 101 EL91 ; Examine every rule that involves Element #91 [PATIENT WITH GLUCOPHAGE MED] 102 ; Called from SCAN+9^OCXOZ01. 103 ; 104 Q:$G(OCXOERR) 105 ; 106 D R63R1A^OCXOZ0Z ; Check Relation #1 in Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' 107 Q 108 ; 109 EL106 ; Examine every rule that involves Element #106 [RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA] 110 ; Called from SCAN+9^OCXOZ01. 111 ; 112 Q:$G(OCXOERR) 113 ; 114 D R63R1A^OCXOZ0Z ; Check Relation #1 in Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' 115 Q 116 ; 117 EL95 ; Examine every rule that involves Element #95 [POLYPHARMACY] 118 ; Called from SCAN+9^OCXOZ01. 119 ; 120 Q:$G(OCXOERR) 121 ; 122 D R65R1A^OCXOZ0Z ; Check Relation #1 in Rule #65 'POLYPHARMACY' 123 Q 124 ; 125 EL86 ; Examine every rule that involves Element #86 [GLUCOPHAGE ORDER] 126 ; Called from SCAN+9^OCXOZ01. 127 ; 128 Q:$G(OCXOERR) 129 ; 130 D R67R1A^OCXOZ10 ; Check Relation #1 in Rule #67 'GLUCOPHAGE - LAB RESULTS' 131 D R67R2A^OCXOZ10 ; Check Relation #2 in Rule #67 'GLUCOPHAGE - LAB RESULTS' 132 Q 133 ; 134 EL111 ; Examine every rule that involves Element #111 [GLUCOPHAGE CREATININE > 1.5] 135 ; Called from SCAN+9^OCXOZ01. 136 ; 137 Q:$G(OCXOERR) 138 ; 139 D R67R1A^OCXOZ10 ; Check Relation #1 in Rule #67 'GLUCOPHAGE - LAB RESULTS' 140 Q 141 ; 142 EL112 ; Examine every rule that involves Element #112 [NO GLUCOPHAGE CREATININE] 143 ; Called from SCAN+9^OCXOZ01. 144 ; 145 Q:$G(OCXOERR) 146 ; 147 D R67R2A^OCXOZ10 ; Check Relation #2 in Rule #67 'GLUCOPHAGE - LAB RESULTS' 148 Q 149 ; 150 EL122 ; Examine every rule that involves Element #122 [AMITRIPTYLINE ORDER] 151 ; Called from SCAN+9^OCXOZ01. 152 ; 153 Q:$G(OCXOERR) 154 ; 155 D R68R1A^OCXOZ11 ; Check Relation #1 in Rule #68 'DANGEROUS MEDS OVER AGE 64' 156 Q 157 ; 158 EL125 ; Examine every rule that involves Element #125 [MED ORDER FOR PT > 64] 159 ; Called from SCAN+9^OCXOZ01. 160 ; 161 Q:$G(OCXOERR) 162 ; 163 D R68R1A^OCXOZ11 ; Check Relation #1 in Rule #68 'DANGEROUS MEDS OVER AGE 64' 164 D R68R2A^OCXOZ11 ; Check Relation #2 in Rule #68 'DANGEROUS MEDS OVER AGE 64' 165 D R68R3A^OCXOZ11 ; Check Relation #3 in Rule #68 'DANGEROUS MEDS OVER AGE 64' 166 Q 167 ; 168 EL123 ; Examine every rule that involves Element #123 [CHLORPROPAMIDE ORDER] 169 ; Called from SCAN+9^OCXOZ01. 170 ; 171 Q:$G(OCXOERR) 172 ; 173 D R68R2A^OCXOZ11 ; Check Relation #2 in Rule #68 'DANGEROUS MEDS OVER AGE 64' 174 Q 175 ; 176 EL124 ; Examine every rule that involves Element #124 [DIPYRIDAMOLE ORDER] 177 ; Called from SCAN+9^OCXOZ01. 178 ; 179 Q:$G(OCXOERR) 180 ; 181 D R68R3A^OCXOZ11 ; Check Relation #3 in Rule #68 'DANGEROUS MEDS OVER AGE 64' 182 Q 183 ; 184 EL131 ; Examine every rule that involves Element #131 [GREATER THAN LAB THRESHOLD] 185 ; Called from SCAN+9^OCXOZ01. 186 ; 187 Q:$G(OCXOERR) 188 ; 189 D R69R1A^OCXOZ11 ; Check Relation #1 in Rule #69 'LAB THRESHOLD' 190 Q 191 ; 192 EL132 ; Examine every rule that involves Element #132 [LESS THAN LAB THRESHOLD] 193 ; Called from SCAN+9^OCXOZ01. 194 ; 195 Q:$G(OCXOERR) 196 ; 197 D R69R1A^OCXOZ11 ; Check Relation #1 in Rule #69 'LAB THRESHOLD' 198 Q 199 ; 200 EL28 ; Examine every rule that involves Element #28 [RADIOLOGY ORDER] 201 ; Called from SCAN+9^OCXOZ01. 202 ; 203 Q:$G(OCXOERR) 204 ; 205 D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' 206 Q 207 ; 208 EL135 ; Examine every rule that involves Element #135 [DIET ORDER] 209 ; Called from SCAN+9^OCXOZ01. 210 ; 211 Q:$G(OCXOERR) 212 ; 213 D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' 214 Q 215 ; 216 EL136 ; Examine every rule that involves Element #136 [NO ALLERGY ASSESSMENT] 217 ; Called from SCAN+9^OCXOZ01. 218 ; 219 Q:$G(OCXOERR) 220 ; 221 D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' 222 Q 223 ; 224 EL137 ; Examine every rule that involves Element #137 [PHARMACY ORDER] 225 ; Called from SCAN+9^OCXOZ01. 226 ; 227 Q:$G(OCXOERR) 228 ; 229 D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' 230 Q 231 ; 232 EL138 ; Examine every rule that involves Element #138 [DUP OPIOID MEDS] 233 ; Called from SCAN+9^OCXOZ01. 234 ; 235 Q:$G(OCXOERR) 236 ; 237 D R71R1A^OCXOZ13 ; Check Relation #1 in Rule #71 'OPIOID MEDICATIONS' 238 Q 239 ; 240 EL139 ; Examine every rule that involves Element #139 [OPIOID MED ORDER] 241 ; Called from SCAN+9^OCXOZ01. 242 ; 243 Q:$G(OCXOERR) 244 ; 245 D R71R1A^OCXOZ13 ; Check Relation #1 in Rule #71 'OPIOID MEDICATIONS' 246 Q 247 ; 248 R3R1A ; Verify all Event/Elements of Rule #3 'CRITICAL LAB RESULTS' Relation #1 'CRITICAL LAB TEST' 249 ; Called from EL24+5^OCXOZ0G. 250 ; 251 Q:$G(OCXOERR) 252 ; 253 ; Local Extrinsic Functions 254 ; MCE24( -----------> Verify Event/Element: 'HL7 LAB TEST RESULTS CRITICAL' 255 ; 256 Q:$G(^OCXS(860.2,3,"INACT")) 257 ; 258 I $$MCE24 D R3R1B^OCXOZ0J 259 Q 260 ; 261 MCE24() ; Verify Event/Element: HL7 LAB TEST RESULTS CRITICAL 262 ; 263 ; 264 N OCXRES 265 I $L(OCXDF(37)) S OCXRES(24,37)=OCXDF(37) 266 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),24)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),24)) 267 Q 0 268 ; 1 OCXOZ0I ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 EL120 ; Examine every rule that involves Element #120 [CLOZAPINE WBC >= 3.0 & < 3.5] 14 ; Called from SCAN+9^OCXOZ01. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 D R57R3A^OCXOZ0W ; Check Relation #3 in Rule #57 'CLOZAPINE' 19 D R57R4A^OCXOZ0W ; Check Relation #4 in Rule #57 'CLOZAPINE' 20 Q 21 ; 22 EL115 ; Examine every rule that involves Element #115 [CLOZAPINE ANC >= 1.5] 23 ; Called from SCAN+9^OCXOZ01. 24 ; 25 Q:$G(OCXOERR) 26 ; 27 D R57R4A^OCXOZ0W ; Check Relation #4 in Rule #57 'CLOZAPINE' 28 Q 29 ; 30 EL121 ; Examine every rule that involves Element #121 [CLOZAPINE WBC >= 3.5] 31 ; Called from SCAN+9^OCXOZ01. 32 ; 33 Q:$G(OCXOERR) 34 ; 35 D R57R5A^OCXOZ0X ; Check Relation #5 in Rule #57 'CLOZAPINE' 36 Q 37 ; 38 EL71 ; Examine every rule that involves Element #71 [AMINOGLYCOSIDE ORDER SESSION] 39 ; Called from SCAN+9^OCXOZ01. 40 ; 41 Q:$G(OCXOERR) 42 ; 43 D R59R1A^OCXOZ0X ; Check Relation #1 in Rule #59 'AMINOGLYCOSIDE ORDER' 44 Q 45 ; 46 EL72 ; Examine every rule that involves Element #72 [PATIENT OVER CT OR MRI DEVICE LIMITATIONS] 47 ; Called from SCAN+9^OCXOZ01. 48 ; 49 Q:$G(OCXOERR) 50 ; 51 D R60R1A^OCXOZ0X ; Check Relation #1 in Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK' 52 Q 53 ; 54 EL73 ; Examine every rule that involves Element #73 [CREATININE CLEARANCE ESTIMATE] 55 ; Called from SCAN+9^OCXOZ01. 56 ; 57 Q:$G(OCXOERR) 58 ; 59 D R61R1A^OCXOZ0Y ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION' 60 Q 61 ; 62 EL96 ; Examine every rule that involves Element #96 [CREATININE CLEARANCE DATE/TIME] 63 ; Called from SCAN+9^OCXOZ01. 64 ; 65 Q:$G(OCXOERR) 66 ; 67 D R61R1A^OCXOZ0Y ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION' 68 Q 69 ; 70 EL97 ; Examine every rule that involves Element #97 [RENAL RESULTS] 71 ; Called from SCAN+9^OCXOZ01. 72 ; 73 Q:$G(OCXOERR) 74 ; 75 D R61R1A^OCXOZ0Y ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION' 76 Q 77 ; 78 EL84 ; Examine every rule that involves Element #84 [INPATIENT FOOD-DRUG REACTION] 79 ; Called from SCAN+9^OCXOZ01. 80 ; 81 Q:$G(OCXOERR) 82 ; 83 D R62R1A^OCXOZ0Z ; Check Relation #1 in Rule #62 'FOOD/DRUG INTERACTION' 84 Q 85 ; 86 EL91 ; Examine every rule that involves Element #91 [PATIENT WITH GLUCOPHAGE MED] 87 ; Called from SCAN+9^OCXOZ01. 88 ; 89 Q:$G(OCXOERR) 90 ; 91 D R63R1A^OCXOZ0Z ; Check Relation #1 in Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' 92 Q 93 ; 94 EL106 ; Examine every rule that involves Element #106 [RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA] 95 ; Called from SCAN+9^OCXOZ01. 96 ; 97 Q:$G(OCXOERR) 98 ; 99 D R63R1A^OCXOZ0Z ; Check Relation #1 in Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' 100 Q 101 ; 102 EL95 ; Examine every rule that involves Element #95 [POLYPHARMACY] 103 ; Called from SCAN+9^OCXOZ01. 104 ; 105 Q:$G(OCXOERR) 106 ; 107 D R65R1A^OCXOZ0Z ; Check Relation #1 in Rule #65 'POLYPHARMACY' 108 Q 109 ; 110 EL86 ; Examine every rule that involves Element #86 [GLUCOPHAGE ORDER] 111 ; Called from SCAN+9^OCXOZ01. 112 ; 113 Q:$G(OCXOERR) 114 ; 115 D R67R1A^OCXOZ10 ; Check Relation #1 in Rule #67 'GLUCOPHAGE - LAB RESULTS' 116 D R67R2A^OCXOZ10 ; Check Relation #2 in Rule #67 'GLUCOPHAGE - LAB RESULTS' 117 Q 118 ; 119 EL111 ; Examine every rule that involves Element #111 [GLUCOPHAGE CREATININE > 1.5] 120 ; Called from SCAN+9^OCXOZ01. 121 ; 122 Q:$G(OCXOERR) 123 ; 124 D R67R1A^OCXOZ10 ; Check Relation #1 in Rule #67 'GLUCOPHAGE - LAB RESULTS' 125 Q 126 ; 127 EL112 ; Examine every rule that involves Element #112 [NO GLUCOPHAGE CREATININE] 128 ; Called from SCAN+9^OCXOZ01. 129 ; 130 Q:$G(OCXOERR) 131 ; 132 D R67R2A^OCXOZ10 ; Check Relation #2 in Rule #67 'GLUCOPHAGE - LAB RESULTS' 133 Q 134 ; 135 EL122 ; Examine every rule that involves Element #122 [AMITRIPTYLINE ORDER] 136 ; Called from SCAN+9^OCXOZ01. 137 ; 138 Q:$G(OCXOERR) 139 ; 140 D R68R1A^OCXOZ11 ; Check Relation #1 in Rule #68 'DANGEROUS MEDS OVER AGE 64' 141 Q 142 ; 143 EL125 ; Examine every rule that involves Element #125 [MED ORDER FOR PT > 64] 144 ; Called from SCAN+9^OCXOZ01. 145 ; 146 Q:$G(OCXOERR) 147 ; 148 D R68R1A^OCXOZ11 ; Check Relation #1 in Rule #68 'DANGEROUS MEDS OVER AGE 64' 149 D R68R2A^OCXOZ11 ; Check Relation #2 in Rule #68 'DANGEROUS MEDS OVER AGE 64' 150 D R68R3A^OCXOZ11 ; Check Relation #3 in Rule #68 'DANGEROUS MEDS OVER AGE 64' 151 Q 152 ; 153 EL123 ; Examine every rule that involves Element #123 [CHLORPROPAMIDE ORDER] 154 ; Called from SCAN+9^OCXOZ01. 155 ; 156 Q:$G(OCXOERR) 157 ; 158 D R68R2A^OCXOZ11 ; Check Relation #2 in Rule #68 'DANGEROUS MEDS OVER AGE 64' 159 Q 160 ; 161 EL124 ; Examine every rule that involves Element #124 [DIPYRIDAMOLE ORDER] 162 ; Called from SCAN+9^OCXOZ01. 163 ; 164 Q:$G(OCXOERR) 165 ; 166 D R68R3A^OCXOZ11 ; Check Relation #3 in Rule #68 'DANGEROUS MEDS OVER AGE 64' 167 Q 168 ; 169 EL131 ; Examine every rule that involves Element #131 [GREATER THAN LAB THRESHOLD] 170 ; Called from SCAN+9^OCXOZ01. 171 ; 172 Q:$G(OCXOERR) 173 ; 174 D R69R1A^OCXOZ11 ; Check Relation #1 in Rule #69 'LAB THRESHOLD' 175 Q 176 ; 177 EL132 ; Examine every rule that involves Element #132 [LESS THAN LAB THRESHOLD] 178 ; Called from SCAN+9^OCXOZ01. 179 ; 180 Q:$G(OCXOERR) 181 ; 182 D R69R1A^OCXOZ11 ; Check Relation #1 in Rule #69 'LAB THRESHOLD' 183 Q 184 ; 185 EL28 ; Examine every rule that involves Element #28 [RADIOLOGY ORDER] 186 ; Called from SCAN+9^OCXOZ01. 187 ; 188 Q:$G(OCXOERR) 189 ; 190 D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' 191 Q 192 ; 193 EL135 ; Examine every rule that involves Element #135 [DIET ORDER] 194 ; Called from SCAN+9^OCXOZ01. 195 ; 196 Q:$G(OCXOERR) 197 ; 198 D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' 199 Q 200 ; 201 EL136 ; Examine every rule that involves Element #136 [NO ALLERGY ASSESSMENT] 202 ; Called from SCAN+9^OCXOZ01. 203 ; 204 Q:$G(OCXOERR) 205 ; 206 D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' 207 Q 208 ; 209 EL137 ; Examine every rule that involves Element #137 [PHARMACY ORDER] 210 ; Called from SCAN+9^OCXOZ01. 211 ; 212 Q:$G(OCXOERR) 213 ; 214 D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' 215 Q 216 ; 217 EL138 ; Examine every rule that involves Element #138 [DUP OPIOID MEDS] 218 ; Called from SCAN+9^OCXOZ01. 219 ; 220 Q:$G(OCXOERR) 221 ; 222 D R71R1A^OCXOZ13 ; Check Relation #1 in Rule #71 'OPIOID MEDICATIONS' 223 Q 224 ; 225 EL139 ; Examine every rule that involves Element #139 [OPIOID MED ORDER] 226 ; Called from SCAN+9^OCXOZ01. 227 ; 228 Q:$G(OCXOERR) 229 ; 230 D R71R1A^OCXOZ13 ; Check Relation #1 in Rule #71 'OPIOID MEDICATIONS' 231 Q 232 ; 233 R3R1A ; Verify all Event/Elements of Rule #3 'CRITICAL LAB RESULTS' Relation #1 'CRITICAL LAB TEST' 234 ; Called from EL24+5^OCXOZ0G. 235 ; 236 Q:$G(OCXOERR) 237 ; 238 ; Local Extrinsic Functions 239 ; MCE24( -----------> Verify Event/Element: 'HL7 LAB TEST RESULTS CRITICAL' 240 ; 241 Q:$G(^OCXS(860.2,3,"INACT")) 242 ; 243 I $$MCE24 D R3R1B^OCXOZ0J 244 Q 245 ; 246 MCE24() ; Verify Event/Element: HL7 LAB TEST RESULTS CRITICAL 247 ; 248 ; 249 N OCXRES 250 I $L(OCXDF(37)) S OCXRES(24,37)=OCXDF(37) 251 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),24)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),24)) 252 Q 0 253 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0J.m
r613 r623 1 OCXOZ0J ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R3R1B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 R3R2A 47 48 49 50 51 52 53 54 55 56 57 58 59 R3R2B 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 R5R1A 92 93 94 95 96 97 98 99 100 101 102 103 104 CKSUM(STR) 105 106 107 108 109 110 111 GETDATA(DFN,OCXL,OCXDFI) 112 113 114 115 116 117 INT2DT(OCXDT,OCXF) 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 MCE105() 142 143 144 145 146 147 148 149 MCE44() 150 151 152 153 154 155 156 157 158 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 SETAP(ROOT,DD,DATA,DA) 220 221 222 223 224 225 226 1 OCXOZ0J ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R3R1B ; Send Order Check, Notication messages and/or Execute code for Rule #3 'CRITICAL LAB RESULTS' Relation #1 'CRITICAL LAB TEST' 14 ; Called from R3R1A+10^OCXOZ0I. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT 21 ; NEWRULE( ---------> NEW RULE MESSAGE 22 ; 23 Q:$D(OCXRULE("R3R1B")) 24 ; 25 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 26 S OCXCMSG="" 27 S OCXNMSG="Critical lab: "_$$GETDATA(DFN,"24^",114)_" "_$$GETDATA(DFN,"24^",12)_" "_$$INT2DT($$GETDATA(DFN,"24^",13),0) 28 ; 29 Q:$G(OCXOERR) 30 ; 31 ; Send Notification 32 ; 33 S (OCXDUZ,OCXDATA)="",OCXNUM=0 34 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 35 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 36 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 37 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 38 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 39 .S OCXNUM=+$P(OCXORD,U,2) 40 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 41 S OCXRULE("R3R1B")="" 42 I $$NEWRULE(DFN,OCXNUM,3,1,24,OCXNMSG) D I 1 43 .D:($G(OCXTRACE)<5) EN^ORB3(24,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 44 Q 45 ; 46 R3R2A ; Verify all Event/Elements of Rule #3 'CRITICAL LAB RESULTS' Relation #2 'CRITICAL LAB ORDER' 47 ; Called from EL105+5^OCXOZ0G. 48 ; 49 Q:$G(OCXOERR) 50 ; 51 ; Local Extrinsic Functions 52 ; MCE105( ----------> Verify Event/Element: 'HL7 LAB ORDER RESULTS CRITICAL' 53 ; 54 Q:$G(^OCXS(860.2,3,"INACT")) 55 ; 56 I $$MCE105 D R3R2B 57 Q 58 ; 59 R3R2B ; Send Order Check, Notication messages and/or Execute code for Rule #3 'CRITICAL LAB RESULTS' Relation #2 'CRITICAL LAB ORDER' 60 ; Called from R3R2A+10. 61 ; 62 Q:$G(OCXOERR) 63 ; 64 ; Local Extrinsic Functions 65 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 66 ; NEWRULE( ---------> NEW RULE MESSAGE 67 ; 68 Q:$D(OCXRULE("R3R2B")) 69 ; 70 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 71 S OCXCMSG="" 72 S OCXNMSG="Critical labs - ["_$$GETDATA(DFN,"105^",96)_"]" 73 ; 74 Q:$G(OCXOERR) 75 ; 76 ; Send Notification 77 ; 78 S (OCXDUZ,OCXDATA)="",OCXNUM=0 79 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 80 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 81 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 82 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 83 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 84 .S OCXNUM=+$P(OCXORD,U,2) 85 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 86 S OCXRULE("R3R2B")="" 87 I $$NEWRULE(DFN,OCXNUM,3,2,57,OCXNMSG) D I 1 88 .D:($G(OCXTRACE)<5) EN^ORB3(57,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 89 Q 90 ; 91 R5R1A ; Verify all Event/Elements of Rule #5 'ORDER FLAGGED FOR CLARIFICATION' Relation #1 'ORDER FLAGGED' 92 ; Called from EL44+5^OCXOZ0G. 93 ; 94 Q:$G(OCXOERR) 95 ; 96 ; Local Extrinsic Functions 97 ; MCE44( -----------> Verify Event/Element: 'ORDER FLAGGED' 98 ; 99 Q:$G(^OCXS(860.2,5,"INACT")) 100 ; 101 I $$MCE44 D R5R1B^OCXOZ0K 102 Q 103 ; 104 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 105 ; 106 N CKSUM,PTR,ASC S CKSUM=0 107 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 108 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 109 Q +CKSUM 110 ; 111 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 112 ; 113 N OCXE,VAL,PC S VAL="" 114 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 115 Q VAL 116 ; 117 INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format 118 ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT 119 ; 120 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) 121 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR 122 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" 123 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 124 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 125 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 126 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) 127 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 128 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR 129 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" 130 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" 131 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) 132 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 133 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) 134 E S OCXMON=$E(OCXMON+100,2,3) 135 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") 136 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 137 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) 138 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP 139 Q OCXMON_" "_OCXDAY_","_OCXYR 140 ; 141 MCE105() ; Verify Event/Element: HL7 LAB ORDER RESULTS CRITICAL 142 ; 143 ; 144 N OCXRES 145 I $L(OCXDF(37)) S OCXRES(105,37)=OCXDF(37) 146 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),105)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),105)) 147 Q 0 148 ; 149 MCE44() ; Verify Event/Element: ORDER FLAGGED 150 ; 151 ; OCXDF(37) -> PATIENT IEN data field 152 ; 153 N OCXRES 154 S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(44,37)=OCXDF(37) 155 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),44)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),44)) 156 Q 0 157 ; 158 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 159 ; 160 ; 161 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 162 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 163 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 164 ; 165 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 166 ; 167 S OCXTIME=(+$H) 168 S OCXCKSUM=$$CKSUM(OCXMESS) 169 ; 170 S OCXTSP=($H*86400)+$P($H,",",2) 171 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 172 ; 173 Q:(OCXTSPL>OCXTSP) 0 174 ; 175 K OCXDATA 176 S OCXDATA(OCXDFN,0)=OCXDFN 177 S OCXDATA("B",OCXDFN,OCXDFN)="" 178 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 179 ; 180 S OCXGR="^OCXD(860.7" 181 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 182 ; 183 K OCXDATA 184 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 185 S OCXDATA(OCXRUL,"M")=OCXMESS 186 S OCXDATA("B",OCXRUL,OCXRUL)="" 187 S OCXGR=OCXGR_","_OCXDFN_",1" 188 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 189 ; 190 K OCXDATA 191 S OCXDATA(OCXREL,0)=OCXREL 192 S OCXDATA("B",OCXREL,OCXREL)="" 193 S OCXGR=OCXGR_","_OCXRUL_",1" 194 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 195 ; 196 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 197 .; 198 .N OCXGR1 199 .S OCXGR1=OCXGR_","_OCXREL_",1" 200 .K OCXDATA 201 .S OCXDATA(OCXELE,0)=OCXELE 202 .S OCXDATA(OCXELE,"TIME")=OCXTIME 203 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 204 .S OCXDATA("B",OCXELE,OCXELE)="" 205 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 206 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 207 .; 208 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 209 ..N OCXGR2 210 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 211 ..K OCXDATA 212 ..S OCXDATA(OCXDFI,0)=OCXDFI 213 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 214 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 215 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 216 ; 217 Q 1 218 ; 219 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 220 M @ROOT=DATA 221 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 222 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 223 ; 224 Q 225 ; 226 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0K.m
r613 r623 1 OCXOZ0K ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R5R1B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 R5R2A 46 47 48 49 50 51 52 53 54 55 56 57 58 R5R2B 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 R6R1A 80 81 82 83 84 85 86 87 88 89 90 91 92 R6R1B 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 R7R1A 124 125 126 127 128 129 130 131 132 133 134 135 136 CKSUM(STR) 137 138 139 140 141 142 143 GETDATA(DFN,OCXL,OCXDFI) 144 145 146 147 148 149 MCE134() 150 151 152 153 154 155 156 157 158 MCE21() 159 160 161 162 163 164 165 166 167 MCE45() 168 169 170 171 172 173 174 175 176 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 SETAP(ROOT,DD,DATA,DA) 238 239 240 241 242 243 244 1 OCXOZ0K ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R5R1B ; Send Order Check, Notication messages and/or Execute code for Rule #5 'ORDER FLAGGED FOR CLARIFICATION' Relation #1 'ORDER FLAGGED' 14 ; Called from R5R1A+10^OCXOZ0J. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; NEWRULE( ---------> NEW RULE MESSAGE 21 ; 22 Q:$D(OCXRULE("R5R1B")) 23 ; 24 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 25 S OCXCMSG="" 26 S OCXNMSG="Order(s) needing clarification: Flagged "_$$GETDATA(DFN,"44^",115)_"." 27 ; 28 Q:$G(OCXOERR) 29 ; 30 ; Send Notification 31 ; 32 S (OCXDUZ,OCXDATA)="",OCXNUM=0 33 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 34 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 35 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 36 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 37 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 38 .S OCXNUM=+$P(OCXORD,U,2) 39 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 40 S OCXRULE("R5R1B")="" 41 I $$NEWRULE(DFN,OCXNUM,5,1,6,OCXNMSG) D I 1 42 .D:($G(OCXTRACE)<5) EN^ORB3(6,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 43 Q 44 ; 45 R5R2A ; Verify all Event/Elements of Rule #5 'ORDER FLAGGED FOR CLARIFICATION' Relation #2 'ORDER UNFLAGGED' 46 ; Called from EL134+5^OCXOZ0G. 47 ; 48 Q:$G(OCXOERR) 49 ; 50 ; Local Extrinsic Functions 51 ; MCE134( ----------> Verify Event/Element: 'ORDER UNFLAGGED' 52 ; 53 Q:$G(^OCXS(860.2,5,"INACT")) 54 ; 55 I $$MCE134 D R5R2B 56 Q 57 ; 58 R5R2B ; Send Order Check, Notication messages and/or Execute code for Rule #5 'ORDER FLAGGED FOR CLARIFICATION' Relation #2 'ORDER UNFLAGGED' 59 ; Called from R5R2A+10. 60 ; 61 Q:$G(OCXOERR) 62 ; 63 ; Local Extrinsic Functions 64 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 65 ; 66 Q:$D(OCXRULE("R5R2B")) 67 ; 68 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 69 S OCXCMSG="" 70 S OCXNMSG="" 71 ; 72 ; 73 ; Run Execute Code 74 ; 75 D UNFLAG^ORB3FUP1($$GETDATA(DFN,"134^",37)) 76 Q:$G(OCXOERR) 77 Q 78 ; 79 R6R1A ; Verify all Event/Elements of Rule #6 'ORDER REQUIRES CHART SIGNATURE' Relation #1 'SIGNATURE' 80 ; Called from EL45+5^OCXOZ0G. 81 ; 82 Q:$G(OCXOERR) 83 ; 84 ; Local Extrinsic Functions 85 ; MCE45( -----------> Verify Event/Element: 'ORDER REQUIRES CHART SIGNATURE' 86 ; 87 Q:$G(^OCXS(860.2,6,"INACT")) 88 ; 89 I $$MCE45 D R6R1B 90 Q 91 ; 92 R6R1B ; Send Order Check, Notication messages and/or Execute code for Rule #6 'ORDER REQUIRES CHART SIGNATURE' Relation #1 'SIGNATURE' 93 ; Called from R6R1A+10. 94 ; 95 Q:$G(OCXOERR) 96 ; 97 ; Local Extrinsic Functions 98 ; NEWRULE( ---------> NEW RULE MESSAGE 99 ; 100 Q:$D(OCXRULE("R6R1B")) 101 ; 102 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 103 S OCXCMSG="" 104 S OCXNMSG="Order released - requires chart signature." 105 ; 106 Q:$G(OCXOERR) 107 ; 108 ; Send Notification 109 ; 110 S (OCXDUZ,OCXDATA)="",OCXNUM=0 111 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 112 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 113 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 114 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 115 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 116 .S OCXNUM=+$P(OCXORD,U,2) 117 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 118 S OCXRULE("R6R1B")="" 119 I $$NEWRULE(DFN,OCXNUM,6,1,5,OCXNMSG) D I 1 120 .D:($G(OCXTRACE)<5) EN^ORB3(5,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 121 Q 122 ; 123 R7R1A ; Verify all Event/Elements of Rule #7 'PATIENT ADMISSION' Relation #1 'ADMISSION' 124 ; Called from EL21+5^OCXOZ0G. 125 ; 126 Q:$G(OCXOERR) 127 ; 128 ; Local Extrinsic Functions 129 ; MCE21( -----------> Verify Event/Element: 'PATIENT ADMISSION' 130 ; 131 Q:$G(^OCXS(860.2,7,"INACT")) 132 ; 133 I $$MCE21 D R7R1B^OCXOZ0L 134 Q 135 ; 136 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 137 ; 138 N CKSUM,PTR,ASC S CKSUM=0 139 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 140 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 141 Q +CKSUM 142 ; 143 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 144 ; 145 N OCXE,VAL,PC S VAL="" 146 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 147 Q VAL 148 ; 149 MCE134() ; Verify Event/Element: ORDER UNFLAGGED 150 ; 151 ; OCXDF(37) -> PATIENT IEN data field 152 ; 153 N OCXRES 154 S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(134,37)=OCXDF(37) 155 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),134)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),134)) 156 Q 0 157 ; 158 MCE21() ; Verify Event/Element: PATIENT ADMISSION 159 ; 160 ; OCXDF(37) -> PATIENT IEN data field 161 ; 162 N OCXRES 163 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(21,37)=OCXDF(37) 164 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),21)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),21)) 165 Q 0 166 ; 167 MCE45() ; Verify Event/Element: ORDER REQUIRES CHART SIGNATURE 168 ; 169 ; OCXDF(37) -> PATIENT IEN data field 170 ; 171 N OCXRES 172 S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(45,37)=OCXDF(37) 173 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),45)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),45)) 174 Q 0 175 ; 176 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 177 ; 178 ; 179 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 180 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 181 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 182 ; 183 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 184 ; 185 S OCXTIME=(+$H) 186 S OCXCKSUM=$$CKSUM(OCXMESS) 187 ; 188 S OCXTSP=($H*86400)+$P($H,",",2) 189 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 190 ; 191 Q:(OCXTSPL>OCXTSP) 0 192 ; 193 K OCXDATA 194 S OCXDATA(OCXDFN,0)=OCXDFN 195 S OCXDATA("B",OCXDFN,OCXDFN)="" 196 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 197 ; 198 S OCXGR="^OCXD(860.7" 199 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 200 ; 201 K OCXDATA 202 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 203 S OCXDATA(OCXRUL,"M")=OCXMESS 204 S OCXDATA("B",OCXRUL,OCXRUL)="" 205 S OCXGR=OCXGR_","_OCXDFN_",1" 206 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 207 ; 208 K OCXDATA 209 S OCXDATA(OCXREL,0)=OCXREL 210 S OCXDATA("B",OCXREL,OCXREL)="" 211 S OCXGR=OCXGR_","_OCXRUL_",1" 212 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 213 ; 214 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 215 .; 216 .N OCXGR1 217 .S OCXGR1=OCXGR_","_OCXREL_",1" 218 .K OCXDATA 219 .S OCXDATA(OCXELE,0)=OCXELE 220 .S OCXDATA(OCXELE,"TIME")=OCXTIME 221 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 222 .S OCXDATA("B",OCXELE,OCXELE)="" 223 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 224 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 225 .; 226 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 227 ..N OCXGR2 228 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 229 ..K OCXDATA 230 ..S OCXDATA(OCXDFI,0)=OCXDFI 231 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 232 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 233 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 234 ; 235 Q 1 236 ; 237 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 238 M @ROOT=DATA 239 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 240 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 241 ; 242 Q 243 ; 244 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0L.m
r613 r623 1 OCXOZ0L ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R7R1B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 R11R1A 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 R11R1B 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 R11R2A 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 CKSUM(STR) 109 110 111 112 113 114 115 GETDATA(DFN,OCXL,OCXDFI) 116 117 118 119 120 121 INT2DT(OCXDT,OCXF) 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 MCE100() 146 147 148 149 150 151 152 153 MCE30() 154 155 156 157 158 159 160 161 MCE31() 162 163 164 165 166 167 168 169 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 SETAP(ROOT,DD,DATA,DA) 231 232 233 234 235 236 237 1 OCXOZ0L ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R7R1B ; Send Order Check, Notication messages and/or Execute code for Rule #7 'PATIENT ADMISSION' Relation #1 'ADMISSION' 14 ; Called from R7R1A+10^OCXOZ0K. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT 21 ; NEWRULE( ---------> NEW RULE MESSAGE 22 ; 23 Q:$D(OCXRULE("R7R1B")) 24 ; 25 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 26 S OCXCMSG="" 27 S OCXNMSG="Admitted on "_$$INT2DT($$GETDATA(DFN,"21^",26),0)_" to "_$$GETDATA(DFN,"21^",83) 28 ; 29 Q:$G(OCXOERR) 30 ; 31 ; Send Notification 32 ; 33 S (OCXDUZ,OCXDATA)="",OCXNUM=0 34 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 35 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 36 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 37 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 38 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 39 .S OCXNUM=+$P(OCXORD,U,2) 40 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 41 S OCXRULE("R7R1B")="" 42 I $$NEWRULE(DFN,OCXNUM,7,1,18,OCXNMSG) D I 1 43 .D:($G(OCXTRACE)<5) EN^ORB3(18,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 44 Q 45 ; 46 R11R1A ; Verify all Event/Elements of Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #1 'CANCELLED AND CANCELED BY NON-ORIG ORDERER' 47 ; Called from EL31+5^OCXOZ0G, and EL100+5^OCXOZ0G. 48 ; 49 Q:$G(OCXOERR) 50 ; 51 ; Local Extrinsic Functions 52 ; MCE100( ----------> Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER' 53 ; MCE31( -----------> Verify Event/Element: 'RADIOLOGY ORDER CANCELLED' 54 ; 55 Q:$G(^OCXS(860.2,11,"INACT")) 56 ; 57 I $$MCE31 D 58 .I $$MCE100 D R11R1B 59 Q 60 ; 61 R11R1B ; Send Order Check, Notication messages and/or Execute code for Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #1 'CANCELLED AND CANCELED BY NON-ORIG ORDERER' 62 ; Called from R11R1A+12. 63 ; 64 Q:$G(OCXOERR) 65 ; 66 ; Local Extrinsic Functions 67 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 68 ; NEWRULE( ---------> NEW RULE MESSAGE 69 ; 70 Q:$D(OCXRULE("R11R1B")) 71 ; 72 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 73 S OCXCMSG="" 74 S OCXNMSG="Imaging request canceled: "_$$GETDATA(DFN,"31^100",105) 75 ; 76 Q:$G(OCXOERR) 77 ; 78 ; Send Notification 79 ; 80 S (OCXDUZ,OCXDATA)="",OCXNUM=0 81 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 82 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 83 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 84 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 85 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 86 .S OCXNUM=+$P(OCXORD,U,2) 87 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 88 S OCXRULE("R11R1B")="" 89 I $$NEWRULE(DFN,OCXNUM,11,1,26,OCXNMSG) D I 1 90 .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 91 Q 92 ; 93 R11R2A ; Verify all Event/Elements of Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #2 'ON HOLD AND CANCELED BY NON-ORIG ORDERER' 94 ; Called from EL100+6^OCXOZ0G, and EL30+5^OCXOZ0G. 95 ; 96 Q:$G(OCXOERR) 97 ; 98 ; Local Extrinsic Functions 99 ; MCE100( ----------> Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER' 100 ; MCE30( -----------> Verify Event/Element: 'RADIOLOGY ORDER PUT ON-HOLD' 101 ; 102 Q:$G(^OCXS(860.2,11,"INACT")) 103 ; 104 I $$MCE30 D 105 .I $$MCE100 D R11R2B^OCXOZ0M 106 Q 107 ; 108 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 109 ; 110 N CKSUM,PTR,ASC S CKSUM=0 111 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 112 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 113 Q +CKSUM 114 ; 115 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 116 ; 117 N OCXE,VAL,PC S VAL="" 118 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 119 Q VAL 120 ; 121 INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format 122 ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT 123 ; 124 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) 125 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR 126 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" 127 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 128 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 129 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 130 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) 131 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 132 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR 133 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" 134 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" 135 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) 136 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 137 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) 138 E S OCXMON=$E(OCXMON+100,2,3) 139 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") 140 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 141 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) 142 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP 143 Q OCXMON_" "_OCXDAY_","_OCXYR 144 ; 145 MCE100() ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER 146 ; 147 ; 148 N OCXRES 149 I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37) 150 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100)) 151 Q 0 152 ; 153 MCE30() ; Verify Event/Element: RADIOLOGY ORDER PUT ON-HOLD 154 ; 155 ; 156 N OCXRES 157 I $L(OCXDF(37)) S OCXRES(30,37)=OCXDF(37) 158 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),30)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),30)) 159 Q 0 160 ; 161 MCE31() ; Verify Event/Element: RADIOLOGY ORDER CANCELLED 162 ; 163 ; 164 N OCXRES 165 I $L(OCXDF(37)) S OCXRES(31,37)=OCXDF(37) 166 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),31)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),31)) 167 Q 0 168 ; 169 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 170 ; 171 ; 172 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 173 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 174 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 175 ; 176 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 177 ; 178 S OCXTIME=(+$H) 179 S OCXCKSUM=$$CKSUM(OCXMESS) 180 ; 181 S OCXTSP=($H*86400)+$P($H,",",2) 182 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 183 ; 184 Q:(OCXTSPL>OCXTSP) 0 185 ; 186 K OCXDATA 187 S OCXDATA(OCXDFN,0)=OCXDFN 188 S OCXDATA("B",OCXDFN,OCXDFN)="" 189 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 190 ; 191 S OCXGR="^OCXD(860.7" 192 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 193 ; 194 K OCXDATA 195 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 196 S OCXDATA(OCXRUL,"M")=OCXMESS 197 S OCXDATA("B",OCXRUL,OCXRUL)="" 198 S OCXGR=OCXGR_","_OCXDFN_",1" 199 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 200 ; 201 K OCXDATA 202 S OCXDATA(OCXREL,0)=OCXREL 203 S OCXDATA("B",OCXREL,OCXREL)="" 204 S OCXGR=OCXGR_","_OCXRUL_",1" 205 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 206 ; 207 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 208 .; 209 .N OCXGR1 210 .S OCXGR1=OCXGR_","_OCXREL_",1" 211 .K OCXDATA 212 .S OCXDATA(OCXELE,0)=OCXELE 213 .S OCXDATA(OCXELE,"TIME")=OCXTIME 214 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 215 .S OCXDATA("B",OCXELE,OCXELE)="" 216 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 217 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 218 .; 219 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 220 ..N OCXGR2 221 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 222 ..K OCXDATA 223 ..S OCXDATA(OCXDFI,0)=OCXDFI 224 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 225 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 226 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 227 ; 228 Q 1 229 ; 230 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 231 M @ROOT=DATA 232 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 233 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 234 ; 235 Q 236 ; 237 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0M.m
r613 r623 1 OCXOZ0M ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R11R2B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 R11R3A 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 R11R3B 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 R16R1A 93 94 95 96 97 98 99 100 101 102 103 104 105 R16R1B 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 R18R1A 137 138 139 140 141 142 143 144 145 146 147 148 149 CKSUM(STR) 150 151 152 153 154 155 156 GETDATA(DFN,OCXL,OCXDFI) 157 158 159 160 161 162 MCE100() 163 164 165 166 167 168 169 170 MCE32() 171 172 173 174 175 176 177 178 MCE46() 179 180 181 182 183 184 185 186 187 MCE76() 188 189 190 191 192 193 194 195 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 SETAP(ROOT,DD,DATA,DA) 257 258 259 260 261 262 263 1 OCXOZ0M ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R11R2B ; Send Order Check, Notication messages and/or Execute code for Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #2 'ON HOLD AND CANCELED BY NON-ORIG ORDERER' 14 ; Called from R11R2A+12^OCXOZ0L. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; NEWRULE( ---------> NEW RULE MESSAGE 21 ; 22 Q:$D(OCXRULE("R11R2B")) 23 ; 24 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 25 S OCXCMSG="" 26 S OCXNMSG="Imaging request held: "_$$GETDATA(DFN,"30^100",105) 27 ; 28 Q:$G(OCXOERR) 29 ; 30 ; Send Notification 31 ; 32 S (OCXDUZ,OCXDATA)="",OCXNUM=0 33 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 34 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 35 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 36 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 37 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 38 .S OCXNUM=+$P(OCXORD,U,2) 39 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 40 S OCXRULE("R11R2B")="" 41 I $$NEWRULE(DFN,OCXNUM,11,2,26,OCXNMSG) D I 1 42 .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 43 Q 44 ; 45 R11R3A ; Verify all Event/Elements of Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #3 'DISCONTINUED AND CANCELED BY NON-ORIG ORDERER' 46 ; Called from EL100+7^OCXOZ0G, and EL32+5^OCXOZ0G. 47 ; 48 Q:$G(OCXOERR) 49 ; 50 ; Local Extrinsic Functions 51 ; MCE100( ----------> Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER' 52 ; MCE32( -----------> Verify Event/Element: 'RADIOLOGY ORDER DISCONTINUED' 53 ; 54 Q:$G(^OCXS(860.2,11,"INACT")) 55 ; 56 I $$MCE32 D 57 .I $$MCE100 D R11R3B 58 Q 59 ; 60 R11R3B ; Send Order Check, Notication messages and/or Execute code for Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #3 'DISCONTINUED AND CANCELED BY NON-ORIG ORDERER' 61 ; Called from R11R3A+12. 62 ; 63 Q:$G(OCXOERR) 64 ; 65 ; Local Extrinsic Functions 66 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 67 ; NEWRULE( ---------> NEW RULE MESSAGE 68 ; 69 Q:$D(OCXRULE("R11R3B")) 70 ; 71 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 72 S OCXCMSG="" 73 S OCXNMSG="Imaging request discontinued: "_$$GETDATA(DFN,"32^100",105) 74 ; 75 Q:$G(OCXOERR) 76 ; 77 ; Send Notification 78 ; 79 S (OCXDUZ,OCXDATA)="",OCXNUM=0 80 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 81 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 82 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 83 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 84 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 85 .S OCXNUM=+$P(OCXORD,U,2) 86 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 87 S OCXRULE("R11R3B")="" 88 I $$NEWRULE(DFN,OCXNUM,11,3,26,OCXNMSG) D I 1 89 .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 90 Q 91 ; 92 R16R1A ; Verify all Event/Elements of Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE' Relation #1 'SERVICE' 93 ; Called from EL46+5^OCXOZ0G. 94 ; 95 Q:$G(OCXOERR) 96 ; 97 ; Local Extrinsic Functions 98 ; MCE46( -----------> Verify Event/Element: 'SERVICE ORDER REQUIRES CHART SIGNATURE' 99 ; 100 Q:$G(^OCXS(860.2,16,"INACT")) 101 ; 102 I $$MCE46 D R16R1B 103 Q 104 ; 105 R16R1B ; Send Order Check, Notication messages and/or Execute code for Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE' Relation #1 'SERVICE' 106 ; Called from R16R1A+10. 107 ; 108 Q:$G(OCXOERR) 109 ; 110 ; Local Extrinsic Functions 111 ; NEWRULE( ---------> NEW RULE MESSAGE 112 ; 113 Q:$D(OCXRULE("R16R1B")) 114 ; 115 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 116 S OCXCMSG="" 117 S OCXNMSG="Service order - requires chart signature." 118 ; 119 Q:$G(OCXOERR) 120 ; 121 ; Send Notification 122 ; 123 S (OCXDUZ,OCXDATA)="",OCXNUM=0 124 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 125 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 126 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 127 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 128 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 129 .S OCXNUM=+$P(OCXORD,U,2) 130 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 131 S OCXRULE("R16R1B")="" 132 I $$NEWRULE(DFN,OCXNUM,16,1,28,OCXNMSG) D I 1 133 .D:($G(OCXTRACE)<5) EN^ORB3(28,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 134 Q 135 ; 136 R18R1A ; Verify all Event/Elements of Rule #18 'STAT RESULTS AVAILABLE' Relation #1 'STAT LAB RESULT' 137 ; Called from EL76+5^OCXOZ0G. 138 ; 139 Q:$G(OCXOERR) 140 ; 141 ; Local Extrinsic Functions 142 ; MCE76( -----------> Verify Event/Element: 'STAT LAB RESULT' 143 ; 144 Q:$G(^OCXS(860.2,18,"INACT")) 145 ; 146 I $$MCE76 D R18R1B^OCXOZ0N 147 Q 148 ; 149 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 150 ; 151 N CKSUM,PTR,ASC S CKSUM=0 152 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 153 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 154 Q +CKSUM 155 ; 156 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 157 ; 158 N OCXE,VAL,PC S VAL="" 159 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 160 Q VAL 161 ; 162 MCE100() ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER 163 ; 164 ; 165 N OCXRES 166 I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37) 167 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100)) 168 Q 0 169 ; 170 MCE32() ; Verify Event/Element: RADIOLOGY ORDER DISCONTINUED 171 ; 172 ; 173 N OCXRES 174 I $L(OCXDF(37)) S OCXRES(32,37)=OCXDF(37) 175 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),32)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),32)) 176 Q 0 177 ; 178 MCE46() ; Verify Event/Element: SERVICE ORDER REQUIRES CHART SIGNATURE 179 ; 180 ; OCXDF(37) -> PATIENT IEN data field 181 ; 182 N OCXRES 183 S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(46,37)=OCXDF(37) 184 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),46)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),46)) 185 Q 0 186 ; 187 MCE76() ; Verify Event/Element: STAT LAB RESULT 188 ; 189 ; 190 N OCXRES 191 I $L(OCXDF(37)) S OCXRES(76,37)=OCXDF(37) 192 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),76)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),76)) 193 Q 0 194 ; 195 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 196 ; 197 ; 198 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 199 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 200 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 201 ; 202 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 203 ; 204 S OCXTIME=(+$H) 205 S OCXCKSUM=$$CKSUM(OCXMESS) 206 ; 207 S OCXTSP=($H*86400)+$P($H,",",2) 208 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 209 ; 210 Q:(OCXTSPL>OCXTSP) 0 211 ; 212 K OCXDATA 213 S OCXDATA(OCXDFN,0)=OCXDFN 214 S OCXDATA("B",OCXDFN,OCXDFN)="" 215 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 216 ; 217 S OCXGR="^OCXD(860.7" 218 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 219 ; 220 K OCXDATA 221 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 222 S OCXDATA(OCXRUL,"M")=OCXMESS 223 S OCXDATA("B",OCXRUL,OCXRUL)="" 224 S OCXGR=OCXGR_","_OCXDFN_",1" 225 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 226 ; 227 K OCXDATA 228 S OCXDATA(OCXREL,0)=OCXREL 229 S OCXDATA("B",OCXREL,OCXREL)="" 230 S OCXGR=OCXGR_","_OCXRUL_",1" 231 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 232 ; 233 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 234 .; 235 .N OCXGR1 236 .S OCXGR1=OCXGR_","_OCXREL_",1" 237 .K OCXDATA 238 .S OCXDATA(OCXELE,0)=OCXELE 239 .S OCXDATA(OCXELE,"TIME")=OCXTIME 240 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 241 .S OCXDATA("B",OCXELE,OCXELE)="" 242 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 243 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 244 .; 245 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 246 ..N OCXGR2 247 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 248 ..K OCXDATA 249 ..S OCXDATA(OCXDFI,0)=OCXDFI 250 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 251 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 252 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 253 ; 254 Q 1 255 ; 256 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 257 M @ROOT=DATA 258 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 259 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 260 ; 261 Q 262 ; 263 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0N.m
r613 r623 1 OCXOZ0N ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R18R1B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 R18R2A 46 47 48 49 50 51 52 53 54 55 56 57 58 R18R2B 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 R18R3A 91 92 93 94 95 96 97 98 99 100 101 102 103 R18R3B 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 R19R1A 136 ; Called from EL56+5^OCXOZ0H.137 138 139 140 141 142 143 144 145 146 147 148 CKSUM(STR) 149 150 151 152 153 154 155 GETDATA(DFN,OCXL,OCXDFI) 156 157 158 159 160 161 MCE110() 162 163 164 165 166 167 168 169 MCE56() 170 171 172 173 174 175 176 177 178 MCE75() 179 180 181 182 183 184 185 186 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 SETAP(ROOT,DD,DATA,DA) 248 249 250 251 252 253 254 1 OCXOZ0N ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R18R1B ; Send Order Check, Notication messages and/or Execute code for Rule #18 'STAT RESULTS AVAILABLE' Relation #1 'STAT LAB RESULT' 14 ; Called from R18R1A+10^OCXOZ0M. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; NEWRULE( ---------> NEW RULE MESSAGE 21 ; 22 Q:$D(OCXRULE("R18R1B")) 23 ; 24 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 25 S OCXCMSG="" 26 S OCXNMSG="STAT lab results: ["_$$GETDATA(DFN,"76^",96)_"]" 27 ; 28 Q:$G(OCXOERR) 29 ; 30 ; Send Notification 31 ; 32 S (OCXDUZ,OCXDATA)="",OCXNUM=0 33 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 34 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 35 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 36 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 37 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 38 .S OCXNUM=+$P(OCXORD,U,2) 39 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 40 S OCXRULE("R18R1B")="" 41 I $$NEWRULE(DFN,OCXNUM,18,1,44,OCXNMSG) D I 1 42 .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 43 Q 44 ; 45 R18R2A ; Verify all Event/Elements of Rule #18 'STAT RESULTS AVAILABLE' Relation #2 'STAT IMAGING RESULT' 46 ; Called from EL75+5^OCXOZ0G. 47 ; 48 Q:$G(OCXOERR) 49 ; 50 ; Local Extrinsic Functions 51 ; MCE75( -----------> Verify Event/Element: 'STAT IMAGING RESULT' 52 ; 53 Q:$G(^OCXS(860.2,18,"INACT")) 54 ; 55 I $$MCE75 D R18R2B 56 Q 57 ; 58 R18R2B ; Send Order Check, Notication messages and/or Execute code for Rule #18 'STAT RESULTS AVAILABLE' Relation #2 'STAT IMAGING RESULT' 59 ; Called from R18R2A+10. 60 ; 61 Q:$G(OCXOERR) 62 ; 63 ; Local Extrinsic Functions 64 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 65 ; NEWRULE( ---------> NEW RULE MESSAGE 66 ; 67 Q:$D(OCXRULE("R18R2B")) 68 ; 69 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 70 S OCXCMSG="" 71 S OCXNMSG="STAT imaging results: "_$$GETDATA(DFN,"75^",24) 72 ; 73 Q:$G(OCXOERR) 74 ; 75 ; Send Notification 76 ; 77 S (OCXDUZ,OCXDATA)="",OCXNUM=0 78 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 79 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 80 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 81 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 82 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 83 .S OCXNUM=+$P(OCXORD,U,2) 84 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 85 S OCXRULE("R18R2B")="" 86 I $$NEWRULE(DFN,OCXNUM,18,2,44,OCXNMSG) D I 1 87 .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 88 Q 89 ; 90 R18R3A ; Verify all Event/Elements of Rule #18 'STAT RESULTS AVAILABLE' Relation #3 'STAT CONSULT RESULT' 91 ; Called from EL110+5^OCXOZ0G. 92 ; 93 Q:$G(OCXOERR) 94 ; 95 ; Local Extrinsic Functions 96 ; MCE110( ----------> Verify Event/Element: 'STAT CONSULT RESULT' 97 ; 98 Q:$G(^OCXS(860.2,18,"INACT")) 99 ; 100 I $$MCE110 D R18R3B 101 Q 102 ; 103 R18R3B ; Send Order Check, Notication messages and/or Execute code for Rule #18 'STAT RESULTS AVAILABLE' Relation #3 'STAT CONSULT RESULT' 104 ; Called from R18R3A+10. 105 ; 106 Q:$G(OCXOERR) 107 ; 108 ; Local Extrinsic Functions 109 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 110 ; NEWRULE( ---------> NEW RULE MESSAGE 111 ; 112 Q:$D(OCXRULE("R18R3B")) 113 ; 114 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 115 S OCXCMSG="" 116 S OCXNMSG="STAT consult results: "_$$GETDATA(DFN,"110^",24) 117 ; 118 Q:$G(OCXOERR) 119 ; 120 ; Send Notification 121 ; 122 S (OCXDUZ,OCXDATA)="",OCXNUM=0 123 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 124 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 125 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 126 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 127 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 128 .S OCXNUM=+$P(OCXORD,U,2) 129 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 130 S OCXRULE("R18R3B")="" 131 I $$NEWRULE(DFN,OCXNUM,18,3,44,OCXNMSG) D I 1 132 .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 133 Q 134 ; 135 R19R1A ; Verify all Event/Elements of Rule #19 'PATIENT DISCHARGE' Relation #1 'DISCHARGE' 136 ; Called from EL56+5^OCXOZ0G. 137 ; 138 Q:$G(OCXOERR) 139 ; 140 ; Local Extrinsic Functions 141 ; MCE56( -----------> Verify Event/Element: 'PATIENT DISCHARGE' 142 ; 143 Q:$G(^OCXS(860.2,19,"INACT")) 144 ; 145 I $$MCE56 D R19R1B^OCXOZ0O 146 Q 147 ; 148 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 149 ; 150 N CKSUM,PTR,ASC S CKSUM=0 151 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 152 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 153 Q +CKSUM 154 ; 155 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 156 ; 157 N OCXE,VAL,PC S VAL="" 158 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 159 Q VAL 160 ; 161 MCE110() ; Verify Event/Element: STAT CONSULT RESULT 162 ; 163 ; 164 N OCXRES 165 I $L(OCXDF(37)) S OCXRES(110,37)=OCXDF(37) 166 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),110)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),110)) 167 Q 0 168 ; 169 MCE56() ; Verify Event/Element: PATIENT DISCHARGE 170 ; 171 ; OCXDF(37) -> PATIENT IEN data field 172 ; 173 N OCXRES 174 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(56,37)=OCXDF(37) 175 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),56)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),56)) 176 Q 0 177 ; 178 MCE75() ; Verify Event/Element: STAT IMAGING RESULT 179 ; 180 ; 181 N OCXRES 182 I $L(OCXDF(37)) S OCXRES(75,37)=OCXDF(37) 183 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),75)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),75)) 184 Q 0 185 ; 186 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 187 ; 188 ; 189 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 190 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 191 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 192 ; 193 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 194 ; 195 S OCXTIME=(+$H) 196 S OCXCKSUM=$$CKSUM(OCXMESS) 197 ; 198 S OCXTSP=($H*86400)+$P($H,",",2) 199 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 200 ; 201 Q:(OCXTSPL>OCXTSP) 0 202 ; 203 K OCXDATA 204 S OCXDATA(OCXDFN,0)=OCXDFN 205 S OCXDATA("B",OCXDFN,OCXDFN)="" 206 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 207 ; 208 S OCXGR="^OCXD(860.7" 209 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 210 ; 211 K OCXDATA 212 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 213 S OCXDATA(OCXRUL,"M")=OCXMESS 214 S OCXDATA("B",OCXRUL,OCXRUL)="" 215 S OCXGR=OCXGR_","_OCXDFN_",1" 216 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 217 ; 218 K OCXDATA 219 S OCXDATA(OCXREL,0)=OCXREL 220 S OCXDATA("B",OCXREL,OCXREL)="" 221 S OCXGR=OCXGR_","_OCXRUL_",1" 222 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 223 ; 224 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 225 .; 226 .N OCXGR1 227 .S OCXGR1=OCXGR_","_OCXREL_",1" 228 .K OCXDATA 229 .S OCXDATA(OCXELE,0)=OCXELE 230 .S OCXDATA(OCXELE,"TIME")=OCXTIME 231 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 232 .S OCXDATA("B",OCXELE,OCXELE)="" 233 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 234 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 235 .; 236 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 237 ..N OCXGR2 238 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 239 ..K OCXDATA 240 ..S OCXDATA(OCXDFI,0)=OCXDFI 241 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 242 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 243 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 244 ; 245 Q 1 246 ; 247 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 248 M @ROOT=DATA 249 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 250 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 251 ; 252 Q 253 ; 254 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0O.m
r613 r623 1 OCXOZ0O ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R19R1B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 R22R1A 47 ; Called from EL47+5^OCXOZ0H.48 49 50 51 52 53 54 55 56 57 58 59 R22R1B 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 R24R1A 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 CKSUM(STR) 110 111 112 113 114 115 116 GETDATA(DFN,OCXL,OCXDFI) 117 118 119 120 121 122 INT2DT(OCXDT,OCXF) 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 MCE101() 147 148 149 150 151 152 153 154 MCE47() 155 156 157 158 159 160 161 162 163 MCE49() 164 165 166 167 168 169 170 171 MCE5() 172 173 174 175 176 177 178 179 MCE55() 180 181 182 183 184 185 186 187 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 SETAP(ROOT,DD,DATA,DA) 249 250 251 252 253 254 255 1 OCXOZ0O ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R19R1B ; Send Order Check, Notication messages and/or Execute code for Rule #19 'PATIENT DISCHARGE' Relation #1 'DISCHARGE' 14 ; Called from R19R1A+10^OCXOZ0N. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT 21 ; NEWRULE( ---------> NEW RULE MESSAGE 22 ; 23 Q:$D(OCXRULE("R19R1B")) 24 ; 25 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 26 S OCXCMSG="" 27 S OCXNMSG="Discharged on "_$$INT2DT($$GETDATA(DFN,"56^",26),0) 28 ; 29 Q:$G(OCXOERR) 30 ; 31 ; Send Notification 32 ; 33 S (OCXDUZ,OCXDATA)="",OCXNUM=0 34 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 35 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 36 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 37 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 38 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 39 .S OCXNUM=+$P(OCXORD,U,2) 40 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 41 S OCXRULE("R19R1B")="" 42 I $$NEWRULE(DFN,OCXNUM,19,1,35,OCXNMSG) D I 1 43 .D:($G(OCXTRACE)<5) EN^ORB3(35,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 44 Q 45 ; 46 R22R1A ; Verify all Event/Elements of Rule #22 'ORDER REQUIRES CO-SIGNATURE' Relation #1 'COSIG' 47 ; Called from EL47+5^OCXOZ0G. 48 ; 49 Q:$G(OCXOERR) 50 ; 51 ; Local Extrinsic Functions 52 ; MCE47( -----------> Verify Event/Element: 'ORDER REQUIRES CO-SIGNATURE' 53 ; 54 Q:$G(^OCXS(860.2,22,"INACT")) 55 ; 56 I $$MCE47 D R22R1B 57 Q 58 ; 59 R22R1B ; Send Order Check, Notication messages and/or Execute code for Rule #22 'ORDER REQUIRES CO-SIGNATURE' Relation #1 'COSIG' 60 ; Called from R22R1A+10. 61 ; 62 Q:$G(OCXOERR) 63 ; 64 ; Local Extrinsic Functions 65 ; NEWRULE( ---------> NEW RULE MESSAGE 66 ; 67 Q:$D(OCXRULE("R22R1B")) 68 ; 69 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 70 S OCXCMSG="" 71 S OCXNMSG="Order requires a co-signature" 72 ; 73 Q:$G(OCXOERR) 74 ; 75 ; Send Notification 76 ; 77 S (OCXDUZ,OCXDATA)="",OCXNUM=0 78 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 79 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 80 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 81 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 82 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 83 .S OCXNUM=+$P(OCXORD,U,2) 84 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 85 S OCXRULE("R22R1B")="" 86 I $$NEWRULE(DFN,OCXNUM,22,1,37,OCXNMSG) D I 1 87 .D:($G(OCXTRACE)<5) EN^ORB3(37,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 88 Q 89 ; 90 R24R1A ; Verify all Event/Elements of Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' Relation #1 'ORDER FLAGGED FOR RESULTS AND (LAB RESULT OR IMAGI...' 91 ; Called from EL5+5^OCXOZ0H, and EL49+5^OCXOZ0H, and EL55+5^OCXOZ0H, and EL101+5^OCXOZ0H. 92 ; 93 Q:$G(OCXOERR) 94 ; 95 ; Local Extrinsic Functions 96 ; MCE101( ----------> Verify Event/Element: 'HL7 FINAL IMAGING RESULT' 97 ; MCE49( -----------> Verify Event/Element: 'ORDER FLAGGED FOR RESULTS' 98 ; MCE5( ------------> Verify Event/Element: 'HL7 FINAL LAB RESULT' 99 ; MCE55( -----------> Verify Event/Element: 'CONSULT FINAL RESULTS' 100 ; 101 Q:$G(^OCXS(860.2,24,"INACT")) 102 ; 103 I $$MCE49 D 104 .I $$MCE5 D R24R1B^OCXOZ0P 105 .I $$MCE101 D R24R1B^OCXOZ0P 106 .I $$MCE55 D R24R1B^OCXOZ0P 107 Q 108 ; 109 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 110 ; 111 N CKSUM,PTR,ASC S CKSUM=0 112 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 113 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 114 Q +CKSUM 115 ; 116 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 117 ; 118 N OCXE,VAL,PC S VAL="" 119 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 120 Q VAL 121 ; 122 INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format 123 ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT 124 ; 125 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) 126 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR 127 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" 128 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 129 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 130 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 131 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) 132 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 133 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR 134 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" 135 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" 136 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) 137 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 138 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) 139 E S OCXMON=$E(OCXMON+100,2,3) 140 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") 141 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 142 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) 143 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP 144 Q OCXMON_" "_OCXDAY_","_OCXYR 145 ; 146 MCE101() ; Verify Event/Element: HL7 FINAL IMAGING RESULT 147 ; 148 ; 149 N OCXRES 150 I $L(OCXDF(37)) S OCXRES(101,37)=OCXDF(37) 151 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),101)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),101)) 152 Q 0 153 ; 154 MCE47() ; Verify Event/Element: ORDER REQUIRES CO-SIGNATURE 155 ; 156 ; OCXDF(37) -> PATIENT IEN data field 157 ; 158 N OCXRES 159 S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(47,37)=OCXDF(37) 160 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),47)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),47)) 161 Q 0 162 ; 163 MCE49() ; Verify Event/Element: ORDER FLAGGED FOR RESULTS 164 ; 165 ; 166 N OCXRES 167 I $L(OCXDF(37)) S OCXRES(49,37)=OCXDF(37) 168 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),49)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),49)) 169 Q 0 170 ; 171 MCE5() ; Verify Event/Element: HL7 FINAL LAB RESULT 172 ; 173 ; 174 N OCXRES 175 I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37) 176 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5)) 177 Q 0 178 ; 179 MCE55() ; Verify Event/Element: CONSULT FINAL RESULTS 180 ; 181 ; 182 N OCXRES 183 I $L(OCXDF(37)) S OCXRES(55,37)=OCXDF(37) 184 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),55)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),55)) 185 Q 0 186 ; 187 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 188 ; 189 ; 190 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 191 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 192 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 193 ; 194 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 195 ; 196 S OCXTIME=(+$H) 197 S OCXCKSUM=$$CKSUM(OCXMESS) 198 ; 199 S OCXTSP=($H*86400)+$P($H,",",2) 200 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 201 ; 202 Q:(OCXTSPL>OCXTSP) 0 203 ; 204 K OCXDATA 205 S OCXDATA(OCXDFN,0)=OCXDFN 206 S OCXDATA("B",OCXDFN,OCXDFN)="" 207 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 208 ; 209 S OCXGR="^OCXD(860.7" 210 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 211 ; 212 K OCXDATA 213 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 214 S OCXDATA(OCXRUL,"M")=OCXMESS 215 S OCXDATA("B",OCXRUL,OCXRUL)="" 216 S OCXGR=OCXGR_","_OCXDFN_",1" 217 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 218 ; 219 K OCXDATA 220 S OCXDATA(OCXREL,0)=OCXREL 221 S OCXDATA("B",OCXREL,OCXREL)="" 222 S OCXGR=OCXGR_","_OCXRUL_",1" 223 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 224 ; 225 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 226 .; 227 .N OCXGR1 228 .S OCXGR1=OCXGR_","_OCXREL_",1" 229 .K OCXDATA 230 .S OCXDATA(OCXELE,0)=OCXELE 231 .S OCXDATA(OCXELE,"TIME")=OCXTIME 232 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 233 .S OCXDATA("B",OCXELE,OCXELE)="" 234 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 235 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 236 .; 237 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 238 ..N OCXGR2 239 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 240 ..K OCXDATA 241 ..S OCXDATA(OCXDFI,0)=OCXDFI 242 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 243 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 244 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 245 ; 246 Q 1 247 ; 248 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 249 M @ROOT=DATA 250 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 251 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 252 ; 253 Q 254 ; 255 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0P.m
r613 r623 1 OCXOZ0P ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R24R1B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 R28R1A 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 R28R1B 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 R32R1A 93 94 95 96 97 98 99 100 101 102 103 104 105 R32R1B 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 CKSUM(STR) 138 139 140 141 142 143 144 GETDATA(DFN,OCXL,OCXDFI) 145 146 147 148 149 150 MCE42() 151 152 153 154 155 156 157 158 159 MCE60() 160 161 162 163 164 165 166 167 MCE61() 168 169 170 171 172 173 174 175 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 SETAP(ROOT,DD,DATA,DA) 237 238 239 240 241 242 243 1 OCXOZ0P ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R24R1B ; Send Order Check, Notication messages and/or Execute code for Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' Relation #1 'ORDER FLAGGED FOR RESULTS AND (LAB RESULT OR IMAGI...' 14 ; Called from R24R1A+14^OCXOZ0O. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; NEWRULE( ---------> NEW RULE MESSAGE 21 ; 22 Q:$D(OCXRULE("R24R1B")) 23 ; 24 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 25 S OCXCMSG="" 26 S OCXNMSG="Requested results available: "_$$GETDATA(DFN,"5^49^55^101",96) 27 ; 28 Q:$G(OCXOERR) 29 ; 30 ; Send Notification 31 ; 32 S (OCXDUZ,OCXDATA)="",OCXNUM=0 33 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 34 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 35 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 36 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 37 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 38 .S OCXNUM=+$P(OCXORD,U,2) 39 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 40 S OCXRULE("R24R1B")="" 41 I $$NEWRULE(DFN,OCXNUM,24,1,33,OCXNMSG) D I 1 42 .D:($G(OCXTRACE)<5) EN^ORB3(33,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 43 Q 44 ; 45 R28R1A ; Verify all Event/Elements of Rule #28 'STAT ORDER PLACED' Relation #1 'NEW OBR STAT OR NEW ORC STAT' 46 ; Called from EL60+5^OCXOZ0H, and EL61+5^OCXOZ0H. 47 ; 48 Q:$G(OCXOERR) 49 ; 50 ; Local Extrinsic Functions 51 ; MCE60( -----------> Verify Event/Element: 'NEW OBR STAT ORDER' 52 ; MCE61( -----------> Verify Event/Element: 'NEW ORC STAT ORDER' 53 ; 54 Q:$G(^OCXS(860.2,28,"INACT")) 55 ; 56 I $$MCE60 D R28R1B 57 I $$MCE61 D R28R1B 58 Q 59 ; 60 R28R1B ; Send Order Check, Notication messages and/or Execute code for Rule #28 'STAT ORDER PLACED' Relation #1 'NEW OBR STAT OR NEW ORC STAT' 61 ; Called from R28R1A+11. 62 ; 63 Q:$G(OCXOERR) 64 ; 65 ; Local Extrinsic Functions 66 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 67 ; NEWRULE( ---------> NEW RULE MESSAGE 68 ; 69 Q:$D(OCXRULE("R28R1B")) 70 ; 71 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 72 S OCXCMSG="" 73 S OCXNMSG="STAT order: "_$$GETDATA(DFN,"60^61",96) 74 ; 75 Q:$G(OCXOERR) 76 ; 77 ; Send Notification 78 ; 79 S (OCXDUZ,OCXDATA)="",OCXNUM=0 80 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 81 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 82 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 83 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 84 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 85 .S OCXNUM=+$P(OCXORD,U,2) 86 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 87 S OCXRULE("R28R1B")="" 88 I $$NEWRULE(DFN,OCXNUM,28,1,43,OCXNMSG) D I 1 89 .D:($G(OCXTRACE)<5) EN^ORB3(43,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 90 Q 91 ; 92 R32R1A ; Verify all Event/Elements of Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO A...' Relation #1 'FROM PSYCH WARD' 93 ; Called from EL42+5^OCXOZ0H. 94 ; 95 Q:$G(OCXOERR) 96 ; 97 ; Local Extrinsic Functions 98 ; MCE42( -----------> Verify Event/Element: 'PATIENT TRANSFERRED FROM PSYCH WARD' 99 ; 100 Q:$G(^OCXS(860.2,32,"INACT")) 101 ; 102 I $$MCE42 D R32R1B 103 Q 104 ; 105 R32R1B ; Send Order Check, Notication messages and/or Execute code for Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO A...' Relation #1 'FROM PSYCH WARD' 106 ; Called from R32R1A+10. 107 ; 108 Q:$G(OCXOERR) 109 ; 110 ; Local Extrinsic Functions 111 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 112 ; NEWRULE( ---------> NEW RULE MESSAGE 113 ; 114 Q:$D(OCXRULE("R32R1B")) 115 ; 116 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 117 S OCXCMSG="" 118 S OCXNMSG="Transfer from Psych ward: "_$$GETDATA(DFN,"42^",95)_" to ward: "_$$GETDATA(DFN,"42^",90) 119 ; 120 Q:$G(OCXOERR) 121 ; 122 ; Send Notification 123 ; 124 S (OCXDUZ,OCXDATA)="",OCXNUM=0 125 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 126 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 127 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 128 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 129 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 130 .S OCXNUM=+$P(OCXORD,U,2) 131 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 132 S OCXRULE("R32R1B")="" 133 I $$NEWRULE(DFN,OCXNUM,32,1,36,OCXNMSG) D I 1 134 .D:($G(OCXTRACE)<5) EN^ORB3(36,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 135 Q 136 ; 137 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 138 ; 139 N CKSUM,PTR,ASC S CKSUM=0 140 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 141 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 142 Q +CKSUM 143 ; 144 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 145 ; 146 N OCXE,VAL,PC S VAL="" 147 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 148 Q VAL 149 ; 150 MCE42() ; Verify Event/Element: PATIENT TRANSFERRED FROM PSYCH WARD 151 ; 152 ; OCXDF(37) -> PATIENT IEN data field 153 ; 154 N OCXRES 155 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(42,37)=OCXDF(37) 156 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),42)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),42)) 157 Q 0 158 ; 159 MCE60() ; Verify Event/Element: NEW OBR STAT ORDER 160 ; 161 ; 162 N OCXRES 163 I $L(OCXDF(37)) S OCXRES(60,37)=OCXDF(37) 164 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),60)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),60)) 165 Q 0 166 ; 167 MCE61() ; Verify Event/Element: NEW ORC STAT ORDER 168 ; 169 ; 170 N OCXRES 171 I $L(OCXDF(37)) S OCXRES(61,37)=OCXDF(37) 172 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),61)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),61)) 173 Q 0 174 ; 175 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 176 ; 177 ; 178 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 179 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 180 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 181 ; 182 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 183 ; 184 S OCXTIME=(+$H) 185 S OCXCKSUM=$$CKSUM(OCXMESS) 186 ; 187 S OCXTSP=($H*86400)+$P($H,",",2) 188 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 189 ; 190 Q:(OCXTSPL>OCXTSP) 0 191 ; 192 K OCXDATA 193 S OCXDATA(OCXDFN,0)=OCXDFN 194 S OCXDATA("B",OCXDFN,OCXDFN)="" 195 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 196 ; 197 S OCXGR="^OCXD(860.7" 198 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 199 ; 200 K OCXDATA 201 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 202 S OCXDATA(OCXRUL,"M")=OCXMESS 203 S OCXDATA("B",OCXRUL,OCXRUL)="" 204 S OCXGR=OCXGR_","_OCXDFN_",1" 205 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 206 ; 207 K OCXDATA 208 S OCXDATA(OCXREL,0)=OCXREL 209 S OCXDATA("B",OCXREL,OCXREL)="" 210 S OCXGR=OCXGR_","_OCXRUL_",1" 211 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 212 ; 213 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 214 .; 215 .N OCXGR1 216 .S OCXGR1=OCXGR_","_OCXREL_",1" 217 .K OCXDATA 218 .S OCXDATA(OCXELE,0)=OCXELE 219 .S OCXDATA(OCXELE,"TIME")=OCXTIME 220 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 221 .S OCXDATA("B",OCXELE,OCXELE)="" 222 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 223 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 224 .; 225 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 226 ..N OCXGR2 227 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 228 ..K OCXDATA 229 ..S OCXDATA(OCXDFI,0)=OCXDFI 230 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 231 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 232 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 233 ; 234 Q 1 235 ; 236 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 237 M @ROOT=DATA 238 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 239 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 240 ; 241 Q 242 ; 243 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Q.m
r613 r623 1 OCXOZ0Q ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R35R1A 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 R35R1B 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 R38R1A 64 65 66 67 68 69 70 71 72 73 74 75 76 R38R1B 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 R38R2A 109 110 111 112 113 114 115 116 117 118 119 120 121 R38R2B 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 CKSUM(STR) 154 155 156 157 158 159 160 GETDATA(DFN,OCXL,OCXDFI) 161 162 163 164 165 166 MCE100() 167 168 169 170 171 172 173 174 MCE126() 175 176 177 178 179 180 181 182 MCE20() 183 184 185 186 187 188 189 190 MCE40() 191 192 193 194 195 196 197 198 MCE6() 199 200 201 202 203 204 205 206 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 SETAP(ROOT,DD,DATA,DA) 268 269 270 271 272 273 274 1 OCXOZ0Q ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R35R1A ; Verify all Event/Elements of Rule #35 'LAB ORDER CANCELLED' Relation #1 '(CANCEL OR REQCANCEL) AND CANCELED BY NON-ORIG ORD...' 14 ; Called from EL100+8^OCXOZ0G, and EL20+5^OCXOZ0H, and EL40+5^OCXOZ0H. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; MCE100( ----------> Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER' 20 ; MCE20( -----------> Verify Event/Element: 'HL7 LAB ORDER CANCELLED' 21 ; MCE40( -----------> Verify Event/Element: 'HL7 LAB REQUEST CANCELLED' 22 ; 23 Q:$G(^OCXS(860.2,35,"INACT")) 24 ; 25 I $$MCE20 D 26 .I $$MCE100 D R35R1B 27 I $$MCE40 D 28 .I $$MCE100 D R35R1B 29 Q 30 ; 31 R35R1B ; Send Order Check, Notication messages and/or Execute code for Rule #35 'LAB ORDER CANCELLED' Relation #1 '(CANCEL OR REQCANCEL) AND CANCELED BY NON-ORIG ORD...' 32 ; Called from R35R1A+13. 33 ; 34 Q:$G(OCXOERR) 35 ; 36 ; Local Extrinsic Functions 37 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 38 ; NEWRULE( ---------> NEW RULE MESSAGE 39 ; 40 Q:$D(OCXRULE("R35R1B")) 41 ; 42 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 43 S OCXCMSG="" 44 S OCXNMSG="Lab order canceled: "_$$GETDATA(DFN,"20^40^100",105) 45 ; 46 Q:$G(OCXOERR) 47 ; 48 ; Send Notification 49 ; 50 S (OCXDUZ,OCXDATA)="",OCXNUM=0 51 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 52 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 53 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 54 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 55 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 56 .S OCXNUM=+$P(OCXORD,U,2) 57 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 58 S OCXRULE("R35R1B")="" 59 I $$NEWRULE(DFN,OCXNUM,35,1,42,OCXNMSG) D I 1 60 .D:($G(OCXTRACE)<5) EN^ORB3(42,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 61 Q 62 ; 63 R38R1A ; Verify all Event/Elements of Rule #38 'NEW ORDER PLACED' Relation #1 'NEW' 64 ; Called from EL6+5^OCXOZ0H. 65 ; 66 Q:$G(OCXOERR) 67 ; 68 ; Local Extrinsic Functions 69 ; MCE6( ------------> Verify Event/Element: 'HL7 NEW OERR ORDER' 70 ; 71 Q:$G(^OCXS(860.2,38,"INACT")) 72 ; 73 I $$MCE6 D R38R1B 74 Q 75 ; 76 R38R1B ; Send Order Check, Notication messages and/or Execute code for Rule #38 'NEW ORDER PLACED' Relation #1 'NEW' 77 ; Called from R38R1A+10. 78 ; 79 Q:$G(OCXOERR) 80 ; 81 ; Local Extrinsic Functions 82 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 83 ; NEWRULE( ---------> NEW RULE MESSAGE 84 ; 85 Q:$D(OCXRULE("R38R1B")) 86 ; 87 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 88 S OCXCMSG="" 89 S OCXNMSG="["_$$GETDATA(DFN,"6^",147)_"] New order(s) placed." 90 ; 91 Q:$G(OCXOERR) 92 ; 93 ; Send Notification 94 ; 95 S (OCXDUZ,OCXDATA)="",OCXNUM=0 96 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 97 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 98 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 99 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 100 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 101 .S OCXNUM=+$P(OCXORD,U,2) 102 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 103 S OCXRULE("R38R1B")="" 104 I $$NEWRULE(DFN,OCXNUM,38,1,50,OCXNMSG) D I 1 105 .D:($G(OCXTRACE)<5) EN^ORB3(50,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 106 Q 107 ; 108 R38R2A ; Verify all Event/Elements of Rule #38 'NEW ORDER PLACED' Relation #2 'DCED' 109 ; Called from EL126+5^OCXOZ0H. 110 ; 111 Q:$G(OCXOERR) 112 ; 113 ; Local Extrinsic Functions 114 ; MCE126( ----------> Verify Event/Element: 'HL7 DCED OERR ORDER' 115 ; 116 Q:$G(^OCXS(860.2,38,"INACT")) 117 ; 118 I $$MCE126 D R38R2B 119 Q 120 ; 121 R38R2B ; Send Order Check, Notication messages and/or Execute code for Rule #38 'NEW ORDER PLACED' Relation #2 'DCED' 122 ; Called from R38R2A+10. 123 ; 124 Q:$G(OCXOERR) 125 ; 126 ; Local Extrinsic Functions 127 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 128 ; NEWRULE( ---------> NEW RULE MESSAGE 129 ; 130 Q:$D(OCXRULE("R38R2B")) 131 ; 132 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 133 S OCXCMSG="" 134 S OCXNMSG="["_$$GETDATA(DFN,"126^",147)_"] New DC order(s) placed." 135 ; 136 Q:$G(OCXOERR) 137 ; 138 ; Send Notification 139 ; 140 S (OCXDUZ,OCXDATA)="",OCXNUM=0 141 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 142 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 143 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 144 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 145 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 146 .S OCXNUM=+$P(OCXORD,U,2) 147 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 148 S OCXRULE("R38R2B")="" 149 I $$NEWRULE(DFN,OCXNUM,38,2,62,OCXNMSG) D I 1 150 .D:($G(OCXTRACE)<5) EN^ORB3(62,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 151 Q 152 ; 153 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 154 ; 155 N CKSUM,PTR,ASC S CKSUM=0 156 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 157 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 158 Q +CKSUM 159 ; 160 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 161 ; 162 N OCXE,VAL,PC S VAL="" 163 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 164 Q VAL 165 ; 166 MCE100() ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER 167 ; 168 ; 169 N OCXRES 170 I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37) 171 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100)) 172 Q 0 173 ; 174 MCE126() ; Verify Event/Element: HL7 DCED OERR ORDER 175 ; 176 ; 177 N OCXRES 178 I $L(OCXDF(37)) S OCXRES(126,37)=OCXDF(37) 179 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),126)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),126)) 180 Q 0 181 ; 182 MCE20() ; Verify Event/Element: HL7 LAB ORDER CANCELLED 183 ; 184 ; 185 N OCXRES 186 I $L(OCXDF(37)) S OCXRES(20,37)=OCXDF(37) 187 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),20)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),20)) 188 Q 0 189 ; 190 MCE40() ; Verify Event/Element: HL7 LAB REQUEST CANCELLED 191 ; 192 ; 193 N OCXRES 194 I $L(OCXDF(37)) S OCXRES(40,37)=OCXDF(37) 195 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),40)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),40)) 196 Q 0 197 ; 198 MCE6() ; Verify Event/Element: HL7 NEW OERR ORDER 199 ; 200 ; 201 N OCXRES 202 I $L(OCXDF(37)) S OCXRES(6,37)=OCXDF(37) 203 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),6)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),6)) 204 Q 0 205 ; 206 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 207 ; 208 ; 209 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 210 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 211 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 212 ; 213 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 214 ; 215 S OCXTIME=(+$H) 216 S OCXCKSUM=$$CKSUM(OCXMESS) 217 ; 218 S OCXTSP=($H*86400)+$P($H,",",2) 219 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 220 ; 221 Q:(OCXTSPL>OCXTSP) 0 222 ; 223 K OCXDATA 224 S OCXDATA(OCXDFN,0)=OCXDFN 225 S OCXDATA("B",OCXDFN,OCXDFN)="" 226 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 227 ; 228 S OCXGR="^OCXD(860.7" 229 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 230 ; 231 K OCXDATA 232 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 233 S OCXDATA(OCXRUL,"M")=OCXMESS 234 S OCXDATA("B",OCXRUL,OCXRUL)="" 235 S OCXGR=OCXGR_","_OCXDFN_",1" 236 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 237 ; 238 K OCXDATA 239 S OCXDATA(OCXREL,0)=OCXREL 240 S OCXDATA("B",OCXREL,OCXREL)="" 241 S OCXGR=OCXGR_","_OCXRUL_",1" 242 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 243 ; 244 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 245 .; 246 .N OCXGR1 247 .S OCXGR1=OCXGR_","_OCXREL_",1" 248 .K OCXDATA 249 .S OCXDATA(OCXELE,0)=OCXELE 250 .S OCXDATA(OCXELE,"TIME")=OCXTIME 251 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 252 .S OCXDATA("B",OCXELE,OCXELE)="" 253 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 254 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 255 .; 256 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 257 ..N OCXGR2 258 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 259 ..K OCXDATA 260 ..S OCXDATA(OCXDFI,0)=OCXDFI 261 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 262 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 263 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 264 ; 265 Q 1 266 ; 267 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 268 M @ROOT=DATA 269 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 270 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 271 ; 272 Q 273 ; 274 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0R.m
r613 r623 1 OCXOZ0R ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R42R1A 14 15 16 17 18 19 20 21 22 23 24 25 26 R42R1B 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 R42R2A 59 60 61 62 63 64 65 66 67 68 69 70 71 R42R2B 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 R44R1A 105 106 107 108 109 110 111 112 113 114 115 116 117 CKSUM(STR) 118 119 120 121 122 123 124 GETDATA(DFN,OCXL,OCXDFI) 125 126 127 128 129 130 INT2DT(OCXDT,OCXF) 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 MCE103() 155 156 157 158 159 160 161 162 MCE23() 163 164 165 166 167 168 169 170 MCE48() 171 172 173 174 175 176 177 178 179 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 SETAP(ROOT,DD,DATA,DA) 241 242 243 244 245 246 247 1 OCXOZ0R ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R42R1A ; Verify all Event/Elements of Rule #42 'ABNORMAL LAB RESULTS' Relation #1 'ABNORMAL LAB ORDER' 14 ; Called from EL23+5^OCXOZ0H. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; MCE23( -----------> Verify Event/Element: 'HL7 LAB ORDER RESULTS ABNORMAL' 20 ; 21 Q:$G(^OCXS(860.2,42,"INACT")) 22 ; 23 I $$MCE23 D R42R1B 24 Q 25 ; 26 R42R1B ; Send Order Check, Notication messages and/or Execute code for Rule #42 'ABNORMAL LAB RESULTS' Relation #1 'ABNORMAL LAB ORDER' 27 ; Called from R42R1A+10. 28 ; 29 Q:$G(OCXOERR) 30 ; 31 ; Local Extrinsic Functions 32 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 33 ; NEWRULE( ---------> NEW RULE MESSAGE 34 ; 35 Q:$D(OCXRULE("R42R1B")) 36 ; 37 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 38 S OCXCMSG="" 39 S OCXNMSG="Abnormal labs - ["_$$GETDATA(DFN,"23^",96)_"]" 40 ; 41 Q:$G(OCXOERR) 42 ; 43 ; Send Notification 44 ; 45 S (OCXDUZ,OCXDATA)="",OCXNUM=0 46 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 47 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 48 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 49 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 50 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 51 .S OCXNUM=+$P(OCXORD,U,2) 52 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 53 S OCXRULE("R42R1B")="" 54 I $$NEWRULE(DFN,OCXNUM,42,1,14,OCXNMSG) D I 1 55 .D:($G(OCXTRACE)<5) EN^ORB3(14,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 56 Q 57 ; 58 R42R2A ; Verify all Event/Elements of Rule #42 'ABNORMAL LAB RESULTS' Relation #2 'ABNORMAL LAB TEST' 59 ; Called from EL103+5^OCXOZ0H. 60 ; 61 Q:$G(OCXOERR) 62 ; 63 ; Local Extrinsic Functions 64 ; MCE103( ----------> Verify Event/Element: 'HL7 LAB TEST RESULTS ABNORMAL' 65 ; 66 Q:$G(^OCXS(860.2,42,"INACT")) 67 ; 68 I $$MCE103 D R42R2B 69 Q 70 ; 71 R42R2B ; Send Order Check, Notication messages and/or Execute code for Rule #42 'ABNORMAL LAB RESULTS' Relation #2 'ABNORMAL LAB TEST' 72 ; Called from R42R2A+10. 73 ; 74 Q:$G(OCXOERR) 75 ; 76 ; Local Extrinsic Functions 77 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 78 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT 79 ; NEWRULE( ---------> NEW RULE MESSAGE 80 ; 81 Q:$D(OCXRULE("R42R2B")) 82 ; 83 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 84 S OCXCMSG="" 85 S OCXNMSG="Abnormal lab: "_$$GETDATA(DFN,"103^",114)_" "_$$GETDATA(DFN,"103^",12)_" "_$$INT2DT($$GETDATA(DFN,"103^",13),0) 86 ; 87 Q:$G(OCXOERR) 88 ; 89 ; Send Notification 90 ; 91 S (OCXDUZ,OCXDATA)="",OCXNUM=0 92 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 93 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 94 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 95 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 96 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 97 .S OCXNUM=+$P(OCXORD,U,2) 98 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 99 S OCXRULE("R42R2B")="" 100 I $$NEWRULE(DFN,OCXNUM,42,2,58,OCXNMSG) D I 1 101 .D:($G(OCXTRACE)<5) EN^ORB3(58,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 102 Q 103 ; 104 R44R1A ; Verify all Event/Elements of Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE' Relation #1 'ELECTRONIC SIGNATURE' 105 ; Called from EL48+5^OCXOZ0H. 106 ; 107 Q:$G(OCXOERR) 108 ; 109 ; Local Extrinsic Functions 110 ; MCE48( -----------> Verify Event/Element: 'ORDER REQUIRES ELECTRONIC SIGNATURE' 111 ; 112 Q:$G(^OCXS(860.2,44,"INACT")) 113 ; 114 I $$MCE48 D R44R1B^OCXOZ0S 115 Q 116 ; 117 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 118 ; 119 N CKSUM,PTR,ASC S CKSUM=0 120 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 121 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 122 Q +CKSUM 123 ; 124 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 125 ; 126 N OCXE,VAL,PC S VAL="" 127 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 128 Q VAL 129 ; 130 INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format 131 ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT 132 ; 133 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) 134 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR 135 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" 136 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 137 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 138 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 139 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) 140 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 141 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR 142 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" 143 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" 144 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) 145 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 146 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) 147 E S OCXMON=$E(OCXMON+100,2,3) 148 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") 149 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 150 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) 151 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP 152 Q OCXMON_" "_OCXDAY_","_OCXYR 153 ; 154 MCE103() ; Verify Event/Element: HL7 LAB TEST RESULTS ABNORMAL 155 ; 156 ; 157 N OCXRES 158 I $L(OCXDF(37)) S OCXRES(103,37)=OCXDF(37) 159 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),103)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),103)) 160 Q 0 161 ; 162 MCE23() ; Verify Event/Element: HL7 LAB ORDER RESULTS ABNORMAL 163 ; 164 ; 165 N OCXRES 166 I $L(OCXDF(37)) S OCXRES(23,37)=OCXDF(37) 167 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),23)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),23)) 168 Q 0 169 ; 170 MCE48() ; Verify Event/Element: ORDER REQUIRES ELECTRONIC SIGNATURE 171 ; 172 ; OCXDF(37) -> PATIENT IEN data field 173 ; 174 N OCXRES 175 S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(48,37)=OCXDF(37) 176 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),48)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),48)) 177 Q 0 178 ; 179 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 180 ; 181 ; 182 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 183 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 184 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 185 ; 186 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 187 ; 188 S OCXTIME=(+$H) 189 S OCXCKSUM=$$CKSUM(OCXMESS) 190 ; 191 S OCXTSP=($H*86400)+$P($H,",",2) 192 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 193 ; 194 Q:(OCXTSPL>OCXTSP) 0 195 ; 196 K OCXDATA 197 S OCXDATA(OCXDFN,0)=OCXDFN 198 S OCXDATA("B",OCXDFN,OCXDFN)="" 199 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 200 ; 201 S OCXGR="^OCXD(860.7" 202 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 203 ; 204 K OCXDATA 205 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 206 S OCXDATA(OCXRUL,"M")=OCXMESS 207 S OCXDATA("B",OCXRUL,OCXRUL)="" 208 S OCXGR=OCXGR_","_OCXDFN_",1" 209 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 210 ; 211 K OCXDATA 212 S OCXDATA(OCXREL,0)=OCXREL 213 S OCXDATA("B",OCXREL,OCXREL)="" 214 S OCXGR=OCXGR_","_OCXRUL_",1" 215 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 216 ; 217 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 218 .; 219 .N OCXGR1 220 .S OCXGR1=OCXGR_","_OCXREL_",1" 221 .K OCXDATA 222 .S OCXDATA(OCXELE,0)=OCXELE 223 .S OCXDATA(OCXELE,"TIME")=OCXTIME 224 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 225 .S OCXDATA("B",OCXELE,OCXELE)="" 226 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 227 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 228 .; 229 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 230 ..N OCXGR2 231 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 232 ..K OCXDATA 233 ..S OCXDATA(OCXDFI,0)=OCXDFI 234 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 235 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 236 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 237 ; 238 Q 1 239 ; 240 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 241 M @ROOT=DATA 242 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 243 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 244 ; 245 Q 246 ; 247 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0S.m
r613 r623 1 OCXOZ0S ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R44R1B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 R48R1A 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 R48R1B 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 R48R2A 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 CKSUM(STR) 108 109 110 111 112 113 114 GETDATA(DFN,OCXL,OCXDFI) 115 116 117 118 119 120 INT2DT(OCXDT,OCXF) 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 MCE127() 145 146 147 148 149 150 151 152 MCE128() 153 154 155 156 157 158 159 160 MCE58() 161 162 163 164 165 166 167 168 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 SETAP(ROOT,DD,DATA,DA) 230 231 232 233 234 235 236 1 OCXOZ0S ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R44R1B ; Send Order Check, Notication messages and/or Execute code for Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE' Relation #1 'ELECTRONIC SIGNATURE' 14 ; Called from R44R1A+10^OCXOZ0R. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; NEWRULE( ---------> NEW RULE MESSAGE 20 ; 21 Q:$D(OCXRULE("R44R1B")) 22 ; 23 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 24 S OCXCMSG="" 25 S OCXNMSG="Order requires electronic signature." 26 ; 27 Q:$G(OCXOERR) 28 ; 29 ; Send Notification 30 ; 31 S (OCXDUZ,OCXDATA)="",OCXNUM=0 32 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 33 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 34 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 35 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 36 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 37 .S OCXNUM=+$P(OCXORD,U,2) 38 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 39 S OCXRULE("R44R1B")="" 40 I $$NEWRULE(DFN,OCXNUM,44,1,12,OCXNMSG) D I 1 41 .D:($G(OCXTRACE)<5) EN^ORB3(12,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 42 Q 43 ; 44 R48R1A ; Verify all Event/Elements of Rule #48 'SITE FLAGGED ORDER' Relation #1 'NEW SITE FLAGGED ORDER AND INPATIENT' 45 ; Called from EL58+5^OCXOZ0H, and EL127+5^OCXOZ0H. 46 ; 47 Q:$G(OCXOERR) 48 ; 49 ; Local Extrinsic Functions 50 ; MCE127( ----------> Verify Event/Element: 'INPATIENT' 51 ; MCE58( -----------> Verify Event/Element: 'NEW SITE FLAGGED ORDER' 52 ; 53 Q:$G(^OCXS(860.2,48,"INACT")) 54 ; 55 I $$MCE58 D 56 .I $$MCE127 D R48R1B 57 Q 58 ; 59 R48R1B ; Send Order Check, Notication messages and/or Execute code for Rule #48 'SITE FLAGGED ORDER' Relation #1 'NEW SITE FLAGGED ORDER AND INPATIENT' 60 ; Called from R48R1A+12. 61 ; 62 Q:$G(OCXOERR) 63 ; 64 ; Local Extrinsic Functions 65 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 66 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT 67 ; NEWRULE( ---------> NEW RULE MESSAGE 68 ; 69 Q:$D(OCXRULE("R48R1B")) 70 ; 71 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 72 S OCXCMSG="" 73 S OCXNMSG="["_$$GETDATA(DFN,"58^127",147)_"] Order placed: "_$$GETDATA(DFN,"58^127",96)_" "_$$INT2DT($$GETDATA(DFN,"58^127",9),0)_"." 74 ; 75 Q:$G(OCXOERR) 76 ; 77 ; Send Notification 78 ; 79 S (OCXDUZ,OCXDATA)="",OCXNUM=0 80 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 81 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 82 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 83 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 84 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 85 .S OCXNUM=+$P(OCXORD,U,2) 86 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 87 S OCXRULE("R48R1B")="" 88 I $$NEWRULE(DFN,OCXNUM,48,1,41,OCXNMSG) D I 1 89 .D:($G(OCXTRACE)<5) EN^ORB3(41,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 90 Q 91 ; 92 R48R2A ; Verify all Event/Elements of Rule #48 'SITE FLAGGED ORDER' Relation #2 'NEW SITE FLAGGED ORDER AND OUTPATIENT' 93 ; Called from EL58+6^OCXOZ0H, and EL128+5^OCXOZ0H. 94 ; 95 Q:$G(OCXOERR) 96 ; 97 ; Local Extrinsic Functions 98 ; MCE128( ----------> Verify Event/Element: 'OUTPATIENT' 99 ; MCE58( -----------> Verify Event/Element: 'NEW SITE FLAGGED ORDER' 100 ; 101 Q:$G(^OCXS(860.2,48,"INACT")) 102 ; 103 I $$MCE58 D 104 .I $$MCE128 D R48R2B^OCXOZ0T 105 Q 106 ; 107 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 108 ; 109 N CKSUM,PTR,ASC S CKSUM=0 110 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 111 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 112 Q +CKSUM 113 ; 114 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 115 ; 116 N OCXE,VAL,PC S VAL="" 117 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 118 Q VAL 119 ; 120 INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format 121 ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT 122 ; 123 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) 124 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR 125 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" 126 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 127 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 128 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 129 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) 130 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 131 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR 132 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" 133 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" 134 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) 135 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 136 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) 137 E S OCXMON=$E(OCXMON+100,2,3) 138 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") 139 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 140 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) 141 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP 142 Q OCXMON_" "_OCXDAY_","_OCXYR 143 ; 144 MCE127() ; Verify Event/Element: INPATIENT 145 ; 146 ; 147 N OCXRES 148 I $L(OCXDF(37)) S OCXRES(127,37)=OCXDF(37) 149 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),127)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),127)) 150 Q 0 151 ; 152 MCE128() ; Verify Event/Element: OUTPATIENT 153 ; 154 ; 155 N OCXRES 156 I $L(OCXDF(37)) S OCXRES(128,37)=OCXDF(37) 157 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),128)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),128)) 158 Q 0 159 ; 160 MCE58() ; Verify Event/Element: NEW SITE FLAGGED ORDER 161 ; 162 ; 163 N OCXRES 164 I $L(OCXDF(37)) S OCXRES(58,37)=OCXDF(37) 165 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),58)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),58)) 166 Q 0 167 ; 168 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 169 ; 170 ; 171 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 172 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 173 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 174 ; 175 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 176 ; 177 S OCXTIME=(+$H) 178 S OCXCKSUM=$$CKSUM(OCXMESS) 179 ; 180 S OCXTSP=($H*86400)+$P($H,",",2) 181 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 182 ; 183 Q:(OCXTSPL>OCXTSP) 0 184 ; 185 K OCXDATA 186 S OCXDATA(OCXDFN,0)=OCXDFN 187 S OCXDATA("B",OCXDFN,OCXDFN)="" 188 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 189 ; 190 S OCXGR="^OCXD(860.7" 191 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 192 ; 193 K OCXDATA 194 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 195 S OCXDATA(OCXRUL,"M")=OCXMESS 196 S OCXDATA("B",OCXRUL,OCXRUL)="" 197 S OCXGR=OCXGR_","_OCXDFN_",1" 198 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 199 ; 200 K OCXDATA 201 S OCXDATA(OCXREL,0)=OCXREL 202 S OCXDATA("B",OCXREL,OCXREL)="" 203 S OCXGR=OCXGR_","_OCXRUL_",1" 204 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 205 ; 206 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 207 .; 208 .N OCXGR1 209 .S OCXGR1=OCXGR_","_OCXREL_",1" 210 .K OCXDATA 211 .S OCXDATA(OCXELE,0)=OCXELE 212 .S OCXDATA(OCXELE,"TIME")=OCXTIME 213 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 214 .S OCXDATA("B",OCXELE,OCXELE)="" 215 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 216 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 217 .; 218 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 219 ..N OCXGR2 220 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 221 ..K OCXDATA 222 ..S OCXDATA(OCXDFI,0)=OCXDFI 223 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 224 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 225 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 226 ; 227 Q 1 228 ; 229 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 230 M @ROOT=DATA 231 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 232 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 233 ; 234 Q 235 ; 236 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0T.m
r613 r623 1 OCXOZ0T ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R48R2B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 R49R1A 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 R49R1B 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 CKSUM(STR) 99 100 101 102 103 104 105 GETDATA(DFN,OCXL,OCXDFI) 106 107 108 109 110 111 INT2DT(OCXDT,OCXF) 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 MCE102() 136 137 138 139 140 141 142 143 MCE109() 144 145 146 147 148 149 150 151 MCE127() 152 153 154 155 156 157 158 159 MCE59() 160 161 162 163 164 165 166 167 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 SETAP(ROOT,DD,DATA,DA) 229 230 231 232 233 234 235 1 OCXOZ0T ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R48R2B ; Send Order Check, Notication messages and/or Execute code for Rule #48 'SITE FLAGGED ORDER' Relation #2 'NEW SITE FLAGGED ORDER AND OUTPATIENT' 14 ; Called from R48R2A+12^OCXOZ0S. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT 21 ; NEWRULE( ---------> NEW RULE MESSAGE 22 ; 23 Q:$D(OCXRULE("R48R2B")) 24 ; 25 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 26 S OCXCMSG="" 27 S OCXNMSG="["_$$GETDATA(DFN,"58^128",147)_"] Order placed: "_$$GETDATA(DFN,"58^128",96)_" "_$$INT2DT($$GETDATA(DFN,"58^128",9),0)_"." 28 ; 29 Q:$G(OCXOERR) 30 ; 31 ; Send Notification 32 ; 33 S (OCXDUZ,OCXDATA)="",OCXNUM=0 34 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 35 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 36 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 37 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 38 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 39 .S OCXNUM=+$P(OCXORD,U,2) 40 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 41 S OCXRULE("R48R2B")="" 42 I $$NEWRULE(DFN,OCXNUM,48,2,61,OCXNMSG) D I 1 43 .D:($G(OCXTRACE)<5) EN^ORB3(61,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 44 Q 45 ; 46 R49R1A ; Verify all Event/Elements of Rule #49 'SITE FLAGGED RESULT' Relation #1 'INPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FLA...' 47 ; Called from EL127+6^OCXOZ0H, and EL59+5^OCXOZ0H, and EL102+5^OCXOZ0H, and EL109+5^OCXOZ0H. 48 ; 49 Q:$G(OCXOERR) 50 ; 51 ; Local Extrinsic Functions 52 ; MCE102( ----------> Verify Event/Element: 'SITE FLAGGED FINAL IMAGING RESULT' 53 ; MCE109( ----------> Verify Event/Element: 'SITE FLAGGED FINAL CONSULT RESULT' 54 ; MCE127( ----------> Verify Event/Element: 'INPATIENT' 55 ; MCE59( -----------> Verify Event/Element: 'SITE FLAGGED FINAL LAB RESULT' 56 ; 57 Q:$G(^OCXS(860.2,49,"INACT")) 58 ; 59 I $$MCE127 D 60 .I $$MCE59 D R49R1B 61 .I $$MCE102 D R49R1B 62 .I $$MCE109 D R49R1B 63 Q 64 ; 65 R49R1B ; Send Order Check, Notication messages and/or Execute code for Rule #49 'SITE FLAGGED RESULT' Relation #1 'INPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FLA...' 66 ; Called from R49R1A+14. 67 ; 68 Q:$G(OCXOERR) 69 ; 70 ; Local Extrinsic Functions 71 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 72 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT 73 ; NEWRULE( ---------> NEW RULE MESSAGE 74 ; 75 Q:$D(OCXRULE("R49R1B")) 76 ; 77 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 78 S OCXCMSG="" 79 S OCXNMSG="["_$$GETDATA(DFN,"59^102^109^127",147)_"] Result available: "_$$GETDATA(DFN,"59^102^109^127",96)_" "_$$INT2DT($$GETDATA(DFN,"59^102^109^127",9),0)_" " 80 ; 81 Q:$G(OCXOERR) 82 ; 83 ; Send Notification 84 ; 85 S (OCXDUZ,OCXDATA)="",OCXNUM=0 86 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 87 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 88 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 89 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 90 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 91 .S OCXNUM=+$P(OCXORD,U,2) 92 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 93 S OCXRULE("R49R1B")="" 94 I $$NEWRULE(DFN,OCXNUM,49,1,32,OCXNMSG) D I 1 95 .D:($G(OCXTRACE)<5) EN^ORB3(32,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 96 Q 97 ; 98 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 99 ; 100 N CKSUM,PTR,ASC S CKSUM=0 101 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 102 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 103 Q +CKSUM 104 ; 105 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 106 ; 107 N OCXE,VAL,PC S VAL="" 108 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 109 Q VAL 110 ; 111 INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format 112 ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT 113 ; 114 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) 115 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR 116 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" 117 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 118 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 119 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 120 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) 121 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 122 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR 123 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" 124 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" 125 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) 126 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 127 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) 128 E S OCXMON=$E(OCXMON+100,2,3) 129 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") 130 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 131 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) 132 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP 133 Q OCXMON_" "_OCXDAY_","_OCXYR 134 ; 135 MCE102() ; Verify Event/Element: SITE FLAGGED FINAL IMAGING RESULT 136 ; 137 ; 138 N OCXRES 139 I $L(OCXDF(37)) S OCXRES(102,37)=OCXDF(37) 140 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),102)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),102)) 141 Q 0 142 ; 143 MCE109() ; Verify Event/Element: SITE FLAGGED FINAL CONSULT RESULT 144 ; 145 ; 146 N OCXRES 147 I $L(OCXDF(37)) S OCXRES(109,37)=OCXDF(37) 148 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),109)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),109)) 149 Q 0 150 ; 151 MCE127() ; Verify Event/Element: INPATIENT 152 ; 153 ; 154 N OCXRES 155 I $L(OCXDF(37)) S OCXRES(127,37)=OCXDF(37) 156 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),127)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),127)) 157 Q 0 158 ; 159 MCE59() ; Verify Event/Element: SITE FLAGGED FINAL LAB RESULT 160 ; 161 ; 162 N OCXRES 163 I $L(OCXDF(37)) S OCXRES(59,37)=OCXDF(37) 164 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),59)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),59)) 165 Q 0 166 ; 167 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 168 ; 169 ; 170 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 171 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 172 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 173 ; 174 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 175 ; 176 S OCXTIME=(+$H) 177 S OCXCKSUM=$$CKSUM(OCXMESS) 178 ; 179 S OCXTSP=($H*86400)+$P($H,",",2) 180 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 181 ; 182 Q:(OCXTSPL>OCXTSP) 0 183 ; 184 K OCXDATA 185 S OCXDATA(OCXDFN,0)=OCXDFN 186 S OCXDATA("B",OCXDFN,OCXDFN)="" 187 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 188 ; 189 S OCXGR="^OCXD(860.7" 190 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 191 ; 192 K OCXDATA 193 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 194 S OCXDATA(OCXRUL,"M")=OCXMESS 195 S OCXDATA("B",OCXRUL,OCXRUL)="" 196 S OCXGR=OCXGR_","_OCXDFN_",1" 197 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 198 ; 199 K OCXDATA 200 S OCXDATA(OCXREL,0)=OCXREL 201 S OCXDATA("B",OCXREL,OCXREL)="" 202 S OCXGR=OCXGR_","_OCXRUL_",1" 203 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 204 ; 205 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 206 .; 207 .N OCXGR1 208 .S OCXGR1=OCXGR_","_OCXREL_",1" 209 .K OCXDATA 210 .S OCXDATA(OCXELE,0)=OCXELE 211 .S OCXDATA(OCXELE,"TIME")=OCXTIME 212 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 213 .S OCXDATA("B",OCXELE,OCXELE)="" 214 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 215 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 216 .; 217 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 218 ..N OCXGR2 219 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 220 ..K OCXDATA 221 ..S OCXDATA(OCXDFI,0)=OCXDFI 222 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 223 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 224 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 225 ; 226 Q 1 227 ; 228 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 229 M @ROOT=DATA 230 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 231 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 232 ; 233 Q 234 ; 235 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0U.m
r613 r623 1 OCXOZ0U ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R49R2A 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 R49R2B 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 R50R1A 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 CKSUM(STR) 81 82 83 84 85 86 87 GETDATA(DFN,OCXL,OCXDFI) 88 89 90 91 92 93 INT2DT(OCXDT,OCXF) 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 MCE102() 118 119 120 121 122 123 124 125 MCE109() 126 127 128 129 130 131 132 133 MCE128() 134 135 136 137 138 139 140 141 MCE129() 142 143 144 145 146 147 148 149 150 MCE130() 151 152 153 154 155 156 157 158 159 MCE59() 160 161 162 163 164 165 166 167 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 SETAP(ROOT,DD,DATA,DA) 229 230 231 232 233 234 235 1 OCXOZ0U ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R49R2A ; Verify all Event/Elements of Rule #49 'SITE FLAGGED RESULT' Relation #2 'OUTPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FL...' 14 ; Called from EL128+6^OCXOZ0H, and EL59+6^OCXOZ0H, and EL102+6^OCXOZ0H, and EL109+6^OCXOZ0H. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; MCE102( ----------> Verify Event/Element: 'SITE FLAGGED FINAL IMAGING RESULT' 20 ; MCE109( ----------> Verify Event/Element: 'SITE FLAGGED FINAL CONSULT RESULT' 21 ; MCE128( ----------> Verify Event/Element: 'OUTPATIENT' 22 ; MCE59( -----------> Verify Event/Element: 'SITE FLAGGED FINAL LAB RESULT' 23 ; 24 Q:$G(^OCXS(860.2,49,"INACT")) 25 ; 26 I $$MCE128 D 27 .I $$MCE59 D R49R2B 28 .I $$MCE102 D R49R2B 29 .I $$MCE109 D R49R2B 30 Q 31 ; 32 R49R2B ; Send Order Check, Notication messages and/or Execute code for Rule #49 'SITE FLAGGED RESULT' Relation #2 'OUTPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FL...' 33 ; Called from R49R2A+14. 34 ; 35 Q:$G(OCXOERR) 36 ; 37 ; Local Extrinsic Functions 38 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 39 ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT 40 ; NEWRULE( ---------> NEW RULE MESSAGE 41 ; 42 Q:$D(OCXRULE("R49R2B")) 43 ; 44 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 45 S OCXCMSG="" 46 S OCXNMSG="["_$$GETDATA(DFN,"59^102^109^128",147)_"] Result available: "_$$GETDATA(DFN,"59^102^109^128",96)_" "_$$INT2DT($$GETDATA(DFN,"59^102^109^128",9),0)_" " 47 ; 48 Q:$G(OCXOERR) 49 ; 50 ; Send Notification 51 ; 52 S (OCXDUZ,OCXDATA)="",OCXNUM=0 53 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 54 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 55 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 56 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 57 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 58 .S OCXNUM=+$P(OCXORD,U,2) 59 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 60 S OCXRULE("R49R2B")="" 61 I $$NEWRULE(DFN,OCXNUM,49,2,60,OCXNMSG) D I 1 62 .D:($G(OCXTRACE)<5) EN^ORB3(60,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 63 Q 64 ; 65 R50R1A ; Verify all Event/Elements of Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...' Relation #1 'CONTRAST MEDIA ORDER AND ABNORMAL RENAL RESULTS' 66 ; Called from EL129+5^OCXOZ0H, and EL130+5^OCXOZ0H. 67 ; 68 Q:$G(OCXOERR) 69 ; 70 ; Local Extrinsic Functions 71 ; MCE129( ----------> Verify Event/Element: 'ABNORMAL RENAL RESULTS' 72 ; MCE130( ----------> Verify Event/Element: 'CONTRAST MEDIA ORDER' 73 ; 74 Q:$G(^OCXS(860.2,50,"INACT")) 75 ; 76 I $$MCE130 D 77 .I $$MCE129 D R50R1B^OCXOZ0V 78 Q 79 ; 80 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 81 ; 82 N CKSUM,PTR,ASC S CKSUM=0 83 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 84 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 85 Q +CKSUM 86 ; 87 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 88 ; 89 N OCXE,VAL,PC S VAL="" 90 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 91 Q VAL 92 ; 93 INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format 94 ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT 95 ; 96 Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) 97 N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR 98 S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" 99 S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 100 S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 101 S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 102 S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) 103 S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 104 S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR 105 S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" 106 S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" 107 F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) 108 S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 109 I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) 110 E S OCXMON=$E(OCXMON+100,2,3) 111 S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") 112 I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 113 Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) 114 Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP 115 Q OCXMON_" "_OCXDAY_","_OCXYR 116 ; 117 MCE102() ; Verify Event/Element: SITE FLAGGED FINAL IMAGING RESULT 118 ; 119 ; 120 N OCXRES 121 I $L(OCXDF(37)) S OCXRES(102,37)=OCXDF(37) 122 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),102)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),102)) 123 Q 0 124 ; 125 MCE109() ; Verify Event/Element: SITE FLAGGED FINAL CONSULT RESULT 126 ; 127 ; 128 N OCXRES 129 I $L(OCXDF(37)) S OCXRES(109,37)=OCXDF(37) 130 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),109)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),109)) 131 Q 0 132 ; 133 MCE128() ; Verify Event/Element: OUTPATIENT 134 ; 135 ; 136 N OCXRES 137 I $L(OCXDF(37)) S OCXRES(128,37)=OCXDF(37) 138 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),128)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),128)) 139 Q 0 140 ; 141 MCE129() ; Verify Event/Element: ABNORMAL RENAL RESULTS 142 ; 143 ; OCXDF(37) -> PATIENT IEN data field 144 ; 145 N OCXRES 146 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(129,37)=OCXDF(37) 147 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),129)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),129)) 148 Q 0 149 ; 150 MCE130() ; Verify Event/Element: CONTRAST MEDIA ORDER 151 ; 152 ; OCXDF(37) -> PATIENT IEN data field 153 ; 154 N OCXRES 155 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(130,37)=OCXDF(37) 156 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),130)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),130)) 157 Q 0 158 ; 159 MCE59() ; Verify Event/Element: SITE FLAGGED FINAL LAB RESULT 160 ; 161 ; 162 N OCXRES 163 I $L(OCXDF(37)) S OCXRES(59,37)=OCXDF(37) 164 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),59)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),59)) 165 Q 0 166 ; 167 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 168 ; 169 ; 170 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 171 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 172 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 173 ; 174 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 175 ; 176 S OCXTIME=(+$H) 177 S OCXCKSUM=$$CKSUM(OCXMESS) 178 ; 179 S OCXTSP=($H*86400)+$P($H,",",2) 180 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 181 ; 182 Q:(OCXTSPL>OCXTSP) 0 183 ; 184 K OCXDATA 185 S OCXDATA(OCXDFN,0)=OCXDFN 186 S OCXDATA("B",OCXDFN,OCXDFN)="" 187 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 188 ; 189 S OCXGR="^OCXD(860.7" 190 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 191 ; 192 K OCXDATA 193 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 194 S OCXDATA(OCXRUL,"M")=OCXMESS 195 S OCXDATA("B",OCXRUL,OCXRUL)="" 196 S OCXGR=OCXGR_","_OCXDFN_",1" 197 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 198 ; 199 K OCXDATA 200 S OCXDATA(OCXREL,0)=OCXREL 201 S OCXDATA("B",OCXREL,OCXREL)="" 202 S OCXGR=OCXGR_","_OCXRUL_",1" 203 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 204 ; 205 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 206 .; 207 .N OCXGR1 208 .S OCXGR1=OCXGR_","_OCXREL_",1" 209 .K OCXDATA 210 .S OCXDATA(OCXELE,0)=OCXELE 211 .S OCXDATA(OCXELE,"TIME")=OCXTIME 212 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 213 .S OCXDATA("B",OCXELE,OCXELE)="" 214 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 215 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 216 .; 217 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 218 ..N OCXGR2 219 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 220 ..K OCXDATA 221 ..S OCXDATA(OCXDFI,0)=OCXDFI 222 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 223 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 224 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 225 ; 226 Q 1 227 ; 228 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 229 M @ROOT=DATA 230 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 231 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 232 ; 233 Q 234 ; 235 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0V.m
r613 r623 1 OCXOZ0V ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R50R1B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 R50R2A 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 R50R2B 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 R51R1A 73 74 75 76 77 78 79 80 81 82 83 84 85 R51R1B 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 R53R1A 108 109 110 111 112 113 114 115 116 117 118 119 120 R53R1B 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 R54R1A 143 144 145 146 147 148 149 150 151 152 153 154 155 R54R1B 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 R55R1A 178 179 180 181 182 183 184 185 186 187 188 189 190 R55R1B 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 GETDATA(DFN,OCXL,OCXDFI) 213 214 215 216 217 218 MCE130() 219 220 221 222 223 224 225 226 227 MCE133() 228 229 230 231 232 233 234 235 236 MCE63() 237 238 239 240 241 242 243 244 245 MCE64() 246 247 248 249 250 251 252 253 254 MCE65() 255 256 257 258 259 260 261 262 263 MCE66() 264 265 266 267 268 269 270 271 1 OCXOZ0V ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R50R1B ; Send Order Check, Notication messages and/or Execute code for Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...' Relation #1 'CONTRAST MEDIA ORDER AND ABNORMAL RENAL RESULTS' 14 ; Called from R50R1A+12^OCXOZ0U. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; 21 Q:$D(OCXRULE("R50R1B")) 22 ; 23 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 24 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^9^^Procedure uses intravenous contrast media - abnormal biochem result: "_$$GETDATA(DFN,"129^130",58) I 1 25 E S OCXCMSG="Procedure uses intravenous contrast media - abnormal biochem result: "_$$GETDATA(DFN,"129^130",58) 26 S OCXNMSG="" 27 ; 28 Q:$G(OCXOERR) 29 ; 30 ; Send Order Check Message 31 ; 32 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 33 Q 34 ; 35 R50R2A ; Verify all Event/Elements of Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...' Relation #2 'CONTRAST MEDIA ORDER AND NO CREAT RESULTS W/IN X D...' 36 ; Called from EL130+6^OCXOZ0H, and EL133+5^OCXOZ0H. 37 ; 38 Q:$G(OCXOERR) 39 ; 40 ; Local Extrinsic Functions 41 ; MCE130( ----------> Verify Event/Element: 'CONTRAST MEDIA ORDER' 42 ; MCE133( ----------> Verify Event/Element: 'NO CREAT RESULTS W/IN X DAYS' 43 ; 44 Q:$G(^OCXS(860.2,50,"INACT")) 45 ; 46 I $$MCE130 D 47 .I $$MCE133 D R50R2B 48 Q 49 ; 50 R50R2B ; Send Order Check, Notication messages and/or Execute code for Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...' Relation #2 'CONTRAST MEDIA ORDER AND NO CREAT RESULTS W/IN X D...' 51 ; Called from R50R2A+12. 52 ; 53 Q:$G(OCXOERR) 54 ; 55 ; Local Extrinsic Functions 56 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 57 ; 58 Q:$D(OCXRULE("R50R2B")) 59 ; 60 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 61 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^9^^Procedure uses intravenous contrast media - no creatinine results within "_$$GETDATA(DFN,"130^133",154)_" days" I 1 62 E S OCXCMSG="Procedure uses intravenous contrast media - no creatinine results within "_$$GETDATA(DFN,"130^133",154)_" days" 63 S OCXNMSG="" 64 ; 65 Q:$G(OCXOERR) 66 ; 67 ; Send Order Check Message 68 ; 69 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 70 Q 71 ; 72 R51R1A ; Verify all Event/Elements of Rule #51 'RECENT CHOLECYSTOGRAM ORDER' Relation #1 'RECENT CHOLECGRM' 73 ; Called from EL63+5^OCXOZ0H. 74 ; 75 Q:$G(OCXOERR) 76 ; 77 ; Local Extrinsic Functions 78 ; MCE63( -----------> Verify Event/Element: 'PATIENT HAS RECENT CHOLECYSTOGRAM' 79 ; 80 Q:$G(^OCXS(860.2,51,"INACT")) 81 ; 82 I $$MCE63 D R51R1B 83 Q 84 ; 85 R51R1B ; Send Order Check, Notication messages and/or Execute code for Rule #51 'RECENT CHOLECYSTOGRAM ORDER' Relation #1 'RECENT CHOLECGRM' 86 ; Called from R51R1A+10. 87 ; 88 Q:$G(OCXOERR) 89 ; 90 ; Local Extrinsic Functions 91 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 92 ; 93 Q:$D(OCXRULE("R51R1B")) 94 ; 95 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 96 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^15^^Recent Cholecystogram: "_$$GETDATA(DFN,"63^",61)_" ["_$$GETDATA(DFN,"63^",122)_"]" I 1 97 E S OCXCMSG="Recent Cholecystogram: "_$$GETDATA(DFN,"63^",61)_" ["_$$GETDATA(DFN,"63^",122)_"]" 98 S OCXNMSG="" 99 ; 100 Q:$G(OCXOERR) 101 ; 102 ; Send Order Check Message 103 ; 104 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 105 Q 106 ; 107 R53R1A ; Verify all Event/Elements of Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK' Relation #1 'PHARM PAT OVER 65' 108 ; Called from EL64+5^OCXOZ0H. 109 ; 110 Q:$G(OCXOERR) 111 ; 112 ; Local Extrinsic Functions 113 ; MCE64( -----------> Verify Event/Element: 'PHARMACY PATIENT OVER 65' 114 ; 115 Q:$G(^OCXS(860.2,53,"INACT")) 116 ; 117 I $$MCE64 D R53R1B 118 Q 119 ; 120 R53R1B ; Send Order Check, Notication messages and/or Execute code for Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK' Relation #1 'PHARM PAT OVER 65' 121 ; Called from R53R1A+10. 122 ; 123 Q:$G(OCXOERR) 124 ; 125 ; Local Extrinsic Functions 126 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 127 ; 128 Q:$D(OCXRULE("R53R1B")) 129 ; 130 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 131 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^21^^Patient >65. Renal Results: "_$$GETDATA(DFN,"64^",64) I 1 132 E S OCXCMSG="Patient >65. Renal Results: "_$$GETDATA(DFN,"64^",64) 133 S OCXNMSG="" 134 ; 135 Q:$G(OCXOERR) 136 ; 137 ; Send Order Check Message 138 ; 139 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 140 Q 141 ; 142 R54R1A ; Verify all Event/Elements of Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CAT...' Relation #1 'ANGIOGRAM' 143 ; Called from EL65+5^OCXOZ0H. 144 ; 145 Q:$G(OCXOERR) 146 ; 147 ; Local Extrinsic Functions 148 ; MCE65( -----------> Verify Event/Element: 'SESSION ORDER FOR ANGIOGRAM' 149 ; 150 Q:$G(^OCXS(860.2,54,"INACT")) 151 ; 152 I $$MCE65 D R54R1B 153 Q 154 ; 155 R54R1B ; Send Order Check, Notication messages and/or Execute code for Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CAT...' Relation #1 'ANGIOGRAM' 156 ; Called from R54R1A+10. 157 ; 158 Q:$G(OCXOERR) 159 ; 160 ; Local Extrinsic Functions 161 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 162 ; 163 Q:$D(OCXRULE("R54R1B")) 164 ; 165 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 166 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^22^^Missing Labs for Angiogram: "_$$GETDATA(DFN,"65^",68) I 1 167 E S OCXCMSG="Missing Labs for Angiogram: "_$$GETDATA(DFN,"65^",68) 168 S OCXNMSG="" 169 ; 170 Q:$G(OCXOERR) 171 ; 172 ; Send Order Check Message 173 ; 174 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 175 Q 176 ; 177 R55R1A ; Verify all Event/Elements of Rule #55 'ALLERGY - CONTRAST MEDIA REACTION' Relation #1 'ALLERGY' 178 ; Called from EL66+5^OCXOZ0H. 179 ; 180 Q:$G(OCXOERR) 181 ; 182 ; Local Extrinsic Functions 183 ; MCE66( -----------> Verify Event/Element: 'CONTRAST MEDIA ALLERGY' 184 ; 185 Q:$G(^OCXS(860.2,55,"INACT")) 186 ; 187 I $$MCE66 D R55R1B 188 Q 189 ; 190 R55R1B ; Send Order Check, Notication messages and/or Execute code for Rule #55 'ALLERGY - CONTRAST MEDIA REACTION' Relation #1 'ALLERGY' 191 ; Called from R55R1A+10. 192 ; 193 Q:$G(OCXOERR) 194 ; 195 ; Local Extrinsic Functions 196 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 197 ; 198 Q:$D(OCXRULE("R55R1B")) 199 ; 200 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 201 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^4^^Patient allergic to contrast media. ("_$$GETDATA(DFN,"66^",159)_") This procedure uses: "_$$GETDATA(DFN,"66^",66) I 1 202 E S OCXCMSG="Patient allergic to contrast media. ("_$$GETDATA(DFN,"66^",159)_") This procedure uses: "_$$GETDATA(DFN,"66^",66) 203 S OCXNMSG="" 204 ; 205 Q:$G(OCXOERR) 206 ; 207 ; Send Order Check Message 208 ; 209 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 210 Q 211 ; 212 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 213 ; 214 N OCXE,VAL,PC S VAL="" 215 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 216 Q VAL 217 ; 218 MCE130() ; Verify Event/Element: CONTRAST MEDIA ORDER 219 ; 220 ; OCXDF(37) -> PATIENT IEN data field 221 ; 222 N OCXRES 223 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(130,37)=OCXDF(37) 224 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),130)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),130)) 225 Q 0 226 ; 227 MCE133() ; Verify Event/Element: NO CREAT RESULTS W/IN X DAYS 228 ; 229 ; OCXDF(37) -> PATIENT IEN data field 230 ; 231 N OCXRES 232 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(133,37)=OCXDF(37) 233 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),133)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),133)) 234 Q 0 235 ; 236 MCE63() ; Verify Event/Element: PATIENT HAS RECENT CHOLECYSTOGRAM 237 ; 238 ; OCXDF(37) -> PATIENT IEN data field 239 ; 240 N OCXRES 241 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(63,37)=OCXDF(37) 242 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),63)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),63)) 243 Q 0 244 ; 245 MCE64() ; Verify Event/Element: PHARMACY PATIENT OVER 65 246 ; 247 ; OCXDF(37) -> PATIENT IEN data field 248 ; 249 N OCXRES 250 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(64,37)=OCXDF(37) 251 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),64)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),64)) 252 Q 0 253 ; 254 MCE65() ; Verify Event/Element: SESSION ORDER FOR ANGIOGRAM 255 ; 256 ; OCXDF(37) -> PATIENT IEN data field 257 ; 258 N OCXRES 259 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(65,37)=OCXDF(37) 260 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),65)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),65)) 261 Q 0 262 ; 263 MCE66() ; Verify Event/Element: CONTRAST MEDIA ALLERGY 264 ; 265 ; OCXDF(37) -> PATIENT IEN data field 266 ; 267 N OCXRES 268 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(66,37)=OCXDF(37) 269 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),66)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),66)) 270 Q 0 271 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0W.m
r613 r623 1 OCXOZ0W ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R56R1A ; Verify all Event/Elements of Rule #56 'RECENT BARIUM STUDY' Relation #1 'BARIUM' 14 ; Called from EL67+5^OCXOZ0H. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; MCE67( -----------> Verify Event/Element: 'RECENT BARIUM STUDY ORDERED' 20 ; 21 Q:$G(^OCXS(860.2,56,"INACT")) 22 ; 23 I $$MCE67 D R56R1B 24 Q 25 ; 26 R56R1B ; Send Order Check, Notication messages and/or Execute code for Rule #56 'RECENT BARIUM STUDY' Relation #1 'BARIUM' 27 ; Called from R56R1A+10. 28 ; 29 Q:$G(OCXOERR) 30 ; 31 ; Local Extrinsic Functions 32 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 33 ; 34 Q:$D(OCXRULE("R56R1B")) 35 ; 36 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 37 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^14^^Recent Barium study: "_$$GETDATA(DFN,"67^",70)_" ["_$$GETDATA(DFN,"67^",121)_"]" I 1 38 E S OCXCMSG="Recent Barium study: "_$$GETDATA(DFN,"67^",70)_" ["_$$GETDATA(DFN,"67^",121)_"]" 39 S OCXNMSG="" 40 ; 41 Q:$G(OCXOERR) 42 ; 43 ; Send Order Check Message 44 ; 45 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 46 Q 47 ; 48 R57R1A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #1 'CLOZAPINE AND (NO WBC W/IN 7 DAYS OR NO ANC W/IN 7...' 49 ; Called from EL116+5^OCXOZ0H, and EL117+5^OCXOZ0H, and EL118+5^OCXOZ0H. 50 ; 51 Q:$G(OCXOERR) 52 ; 53 ; Local Extrinsic Functions 54 ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' 55 ; MCE117( ----------> Verify Event/Element: 'CLOZAPINE NO ANC W/IN 7 DAYS' 56 ; MCE118( ----------> Verify Event/Element: 'CLOZAPINE NO WBC W/IN 7 DAYS' 57 ; 58 Q:$G(^OCXS(860.2,57,"INACT")) 59 ; 60 I $$MCE116 D 61 .I $$MCE118 D R57R1B 62 .I $$MCE117 D R57R1B 63 Q 64 ; 65 R57R1B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #1 'CLOZAPINE AND (NO WBC W/IN 7 DAYS OR NO ANC W/IN 7...' 66 ; Called from R57R1A+13. 67 ; 68 Q:$G(OCXOERR) 69 ; 70 ; Local Extrinsic Functions 71 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 72 ; 73 Q:$D(OCXRULE("R57R1B")) 74 ; 75 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 76 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^Clozapine orders require a CBC/Diff within past 7 days. Please order CBC/Diff with WBC and ANC immediately. Most recent results - "_$$GETDATA(DFN,"116^117^118",130) I 1 77 E S OCXCMSG="Clozapine orders require a CBC/Diff within past 7 days. Please order CBC/Diff with WBC and ANC immediately. Most recent results - "_$$GETDATA(DFN,"116^117^118",130) 78 S OCXNMSG="" 79 ; 80 Q:$G(OCXOERR) 81 ; 82 ; Send Order Check Message 83 ; 84 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 85 Q 86 ; 87 R57R2A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #2 'CLOZAPINE AND (WBC < 3.0 OR ANC < 1.5)' 88 ; Called from EL116+6^OCXOZ0H, and EL114+5^OCXOZ0I, and EL119+5^OCXOZ0I. 89 ; 90 Q:$G(OCXOERR) 91 ; 92 ; Local Extrinsic Functions 93 ; MCE114( ----------> Verify Event/Element: 'CLOZAPINE ANC < 1.5' 94 ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' 95 ; MCE119( ----------> Verify Event/Element: 'CLOZAPINE WBC < 3.0' 96 ; 97 Q:$G(^OCXS(860.2,57,"INACT")) 98 ; 99 I $$MCE116 D 100 .I $$MCE119 D R57R2B 101 .I $$MCE114 D R57R2B 102 Q 103 ; 104 R57R2B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #2 'CLOZAPINE AND (WBC < 3.0 OR ANC < 1.5)' 105 ; Called from R57R2A+13. 106 ; 107 Q:$G(OCXOERR) 108 ; 109 ; Local Extrinsic Functions 110 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 111 ; 112 Q:$D(OCXRULE("R57R2B")) 113 ; 114 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 115 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^WBC < 3.0 and/or ANC < 1.5 - pharmacy cannot fill clozapine order. Most recent results - "_$$GETDATA(DFN,"114^116^119",130) I 1 116 E S OCXCMSG="WBC < 3.0 and/or ANC < 1.5 - pharmacy cannot fill clozapine order. Most recent results - "_$$GETDATA(DFN,"114^116^119",130) 117 S OCXNMSG="" 118 ; 119 Q:$G(OCXOERR) 120 ; 121 ; Send Order Check Message 122 ; 123 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 124 Q 125 ; 126 R57R3A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #3 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND ANC >= 1.5' 127 ; Called from EL116+7^OCXOZ0H, and EL115+5^OCXOZ0I, and EL120+5^OCXOZ0I. 128 ; 129 Q:$G(OCXOERR) 130 ; 131 ; Local Extrinsic Functions 132 ; MCE115( ----------> Verify Event/Element: 'CLOZAPINE ANC >= 1.5' 133 ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' 134 ; MCE120( ----------> Verify Event/Element: 'CLOZAPINE WBC >= 3.0 & < 3.5' 135 ; 136 Q:$G(^OCXS(860.2,57,"INACT")) 137 ; 138 I $$MCE116 D 139 .I $$MCE120 D 140 ..I $$MCE115 D R57R3B 141 Q 142 ; 143 R57R3B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #3 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND ANC >= 1.5' 144 ; Called from R57R3A+14. 145 ; 146 Q:$G(OCXOERR) 147 ; 148 ; Local Extrinsic Functions 149 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 150 ; 151 Q:$D(OCXRULE("R57R3B")) 152 ; 153 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 154 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^WBC between 3.0 and 3.5 with ANC >= 1.5 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly. Most recent results - "_$$GETDATA(DFN,"115^116^120",130) I 1 155 E S OCXCMSG="WBC between 3.0 and 3.5 with ANC >= 1.5 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly. Most recent results - "_$$GETDATA(DFN,"115^116^120",130) 156 S OCXNMSG="" 157 ; 158 Q:$G(OCXOERR) 159 ; 160 ; Send Order Check Message 161 ; 162 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 163 Q 164 ; 165 R57R4A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #4 'CLOZAPINE AND 1.5 <= ANC < 2.0' 166 ; Called from EL116+8^OCXOZ0H, and EL140+5^OCXOZ0I. 167 ; 168 Q:$G(OCXOERR) 169 ; 170 ; Local Extrinsic Functions 171 ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' 172 ; MCE140( ----------> Verify Event/Element: 'CLOZAPINE ANC >= 1.5 & < 2.0' 173 ; 174 Q:$G(^OCXS(860.2,57,"INACT")) 175 ; 176 I $$MCE116 D 177 .I $$MCE140 D R57R4B^OCXOZ0X 178 Q 179 ; 180 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 181 ; 182 N OCXE,VAL,PC S VAL="" 183 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 184 Q VAL 185 ; 186 MCE114() ; Verify Event/Element: CLOZAPINE ANC < 1.5 187 ; 188 ; OCXDF(37) -> PATIENT IEN data field 189 ; 190 N OCXRES 191 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(114,37)=OCXDF(37) 192 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),114)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),114)) 193 Q 0 194 ; 195 MCE115() ; Verify Event/Element: CLOZAPINE ANC >= 1.5 196 ; 197 ; OCXDF(37) -> PATIENT IEN data field 198 ; 199 N OCXRES 200 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(115,37)=OCXDF(37) 201 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),115)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),115)) 202 Q 0 203 ; 204 MCE116() ; Verify Event/Element: CLOZAPINE DRUG SELECTED 205 ; 206 ; OCXDF(37) -> PATIENT IEN data field 207 ; 208 N OCXRES 209 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(116,37)=OCXDF(37) 210 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),116)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),116)) 211 Q 0 212 ; 213 MCE117() ; Verify Event/Element: CLOZAPINE NO ANC W/IN 7 DAYS 214 ; 215 ; OCXDF(37) -> PATIENT IEN data field 216 ; 217 N OCXRES 218 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(117,37)=OCXDF(37) 219 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),117)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),117)) 220 Q 0 221 ; 222 MCE118() ; Verify Event/Element: CLOZAPINE NO WBC W/IN 7 DAYS 223 ; 224 ; OCXDF(37) -> PATIENT IEN data field 225 ; 226 N OCXRES 227 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(118,37)=OCXDF(37) 228 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),118)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),118)) 229 Q 0 230 ; 231 MCE119() ; Verify Event/Element: CLOZAPINE WBC < 3.0 232 ; 233 ; OCXDF(37) -> PATIENT IEN data field 234 ; 235 N OCXRES 236 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(119,37)=OCXDF(37) 237 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),119)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),119)) 238 Q 0 239 ; 240 MCE120() ; Verify Event/Element: CLOZAPINE WBC >= 3.0 & < 3.5 241 ; 242 ; OCXDF(37) -> PATIENT IEN data field 243 ; 244 N OCXRES 245 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(120,37)=OCXDF(37) 246 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),120)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),120)) 247 Q 0 248 ; 249 MCE140() ; Verify Event/Element: CLOZAPINE ANC >= 1.5 & < 2.0 250 ; 251 ; OCXDF(37) -> PATIENT IEN data field 252 ; 253 N OCXRES 254 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(140,37)=OCXDF(37) 255 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),140)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),140)) 256 Q 0 257 ; 258 MCE67() ; Verify Event/Element: RECENT BARIUM STUDY ORDERED 259 ; 260 ; OCXDF(37) -> PATIENT IEN data field 261 ; 262 N OCXRES 263 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(67,37)=OCXDF(37) 264 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),67)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),67)) 265 Q 0 266 ; 1 OCXOZ0W ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R56R1A ; Verify all Event/Elements of Rule #56 'RECENT BARIUM STUDY' Relation #1 'BARIUM' 14 ; Called from EL67+5^OCXOZ0H. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; MCE67( -----------> Verify Event/Element: 'RECENT BARIUM STUDY ORDERED' 20 ; 21 Q:$G(^OCXS(860.2,56,"INACT")) 22 ; 23 I $$MCE67 D R56R1B 24 Q 25 ; 26 R56R1B ; Send Order Check, Notication messages and/or Execute code for Rule #56 'RECENT BARIUM STUDY' Relation #1 'BARIUM' 27 ; Called from R56R1A+10. 28 ; 29 Q:$G(OCXOERR) 30 ; 31 ; Local Extrinsic Functions 32 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 33 ; 34 Q:$D(OCXRULE("R56R1B")) 35 ; 36 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 37 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^14^^Recent Barium study: "_$$GETDATA(DFN,"67^",70)_" ["_$$GETDATA(DFN,"67^",121)_"]" I 1 38 E S OCXCMSG="Recent Barium study: "_$$GETDATA(DFN,"67^",70)_" ["_$$GETDATA(DFN,"67^",121)_"]" 39 S OCXNMSG="" 40 ; 41 Q:$G(OCXOERR) 42 ; 43 ; Send Order Check Message 44 ; 45 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 46 Q 47 ; 48 R57R1A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #1 'CLOZAPINE AND (WBC < 3.0 OR ANC < 1.5)' 49 ; Called from EL114+5^OCXOZ0H, and EL116+5^OCXOZ0H, and EL119+5^OCXOZ0H. 50 ; 51 Q:$G(OCXOERR) 52 ; 53 ; Local Extrinsic Functions 54 ; MCE114( ----------> Verify Event/Element: 'CLOZAPINE ANC < 1.5' 55 ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' 56 ; MCE119( ----------> Verify Event/Element: 'CLOZAPINE WBC < 3.0' 57 ; 58 Q:$G(^OCXS(860.2,57,"INACT")) 59 ; 60 I $$MCE116 D 61 .I $$MCE119 D R57R1B 62 .I $$MCE114 D R57R1B 63 Q 64 ; 65 R57R1B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #1 'CLOZAPINE AND (WBC < 3.0 OR ANC < 1.5)' 66 ; Called from R57R1A+13. 67 ; 68 Q:$G(OCXOERR) 69 ; 70 ; Local Extrinsic Functions 71 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 72 ; 73 Q:$D(OCXRULE("R57R1B")) 74 ; 75 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 76 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^WBC < 3.0 and/or ANC < 1.5 - pharmacy cannot fill clozapine order. Most recent results - "_$$GETDATA(DFN,"114^116^119",130) I 1 77 E S OCXCMSG="WBC < 3.0 and/or ANC < 1.5 - pharmacy cannot fill clozapine order. Most recent results - "_$$GETDATA(DFN,"114^116^119",130) 78 S OCXNMSG="" 79 ; 80 Q:$G(OCXOERR) 81 ; 82 ; Send Order Check Message 83 ; 84 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 85 Q 86 ; 87 R57R2A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #2 'CLOZAPINE AND NO WBC W/IN 7 DAYS' 88 ; Called from EL116+6^OCXOZ0H, and EL118+5^OCXOZ0H. 89 ; 90 Q:$G(OCXOERR) 91 ; 92 ; Local Extrinsic Functions 93 ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' 94 ; MCE118( ----------> Verify Event/Element: 'CLOZAPINE NO WBC W/IN 7 DAYS' 95 ; 96 Q:$G(^OCXS(860.2,57,"INACT")) 97 ; 98 I $$MCE116 D 99 .I $$MCE118 D R57R2B 100 Q 101 ; 102 R57R2B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #2 'CLOZAPINE AND NO WBC W/IN 7 DAYS' 103 ; Called from R57R2A+12. 104 ; 105 Q:$G(OCXOERR) 106 ; 107 ; Local Extrinsic Functions 108 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 109 ; 110 Q:$D(OCXRULE("R57R2B")) 111 ; 112 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 113 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^Clozapine orders require a CBC/Diff within past 7 days. Please order CBC/Diff with WBC and ANC immediately. Most recent results - "_$$GETDATA(DFN,"116^118",130) I 1 114 E S OCXCMSG="Clozapine orders require a CBC/Diff within past 7 days. Please order CBC/Diff with WBC and ANC immediately. Most recent results - "_$$GETDATA(DFN,"116^118",130) 115 S OCXNMSG="" 116 ; 117 Q:$G(OCXOERR) 118 ; 119 ; Send Order Check Message 120 ; 121 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 122 Q 123 ; 124 R57R3A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #3 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND NO ANC W/IN 7 D...' 125 ; Called from EL116+7^OCXOZ0H, and EL117+5^OCXOZ0H, and EL120+5^OCXOZ0I. 126 ; 127 Q:$G(OCXOERR) 128 ; 129 ; Local Extrinsic Functions 130 ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' 131 ; MCE117( ----------> Verify Event/Element: 'CLOZAPINE NO ANC W/IN 7 DAYS' 132 ; MCE120( ----------> Verify Event/Element: 'CLOZAPINE WBC >= 3.0 & < 3.5' 133 ; 134 Q:$G(^OCXS(860.2,57,"INACT")) 135 ; 136 I $$MCE116 D 137 .I $$MCE120 D 138 ..I $$MCE117 D R57R3B 139 Q 140 ; 141 R57R3B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #3 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND NO ANC W/IN 7 D...' 142 ; Called from R57R3A+14. 143 ; 144 Q:$G(OCXOERR) 145 ; 146 ; Local Extrinsic Functions 147 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 148 ; 149 Q:$D(OCXRULE("R57R3B")) 150 ; 151 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 152 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^"_$$GETDATA(DFN,"116^117^120",145)_" Most recent results - "_$$GETDATA(DFN,"116^117^120",130) I 1 153 E S OCXCMSG=$$GETDATA(DFN,"116^117^120",145)_" Most recent results - "_$$GETDATA(DFN,"116^117^120",130) 154 S OCXNMSG="" 155 ; 156 Q:$G(OCXOERR) 157 ; 158 ; Send Order Check Message 159 ; 160 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 161 Q 162 ; 163 R57R4A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #4 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND ANC >= 1.5' 164 ; Called from EL116+8^OCXOZ0H, and EL120+6^OCXOZ0I, and EL115+5^OCXOZ0I. 165 ; 166 Q:$G(OCXOERR) 167 ; 168 ; Local Extrinsic Functions 169 ; MCE115( ----------> Verify Event/Element: 'CLOZAPINE ANC >= 1.5' 170 ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' 171 ; MCE120( ----------> Verify Event/Element: 'CLOZAPINE WBC >= 3.0 & < 3.5' 172 ; 173 Q:$G(^OCXS(860.2,57,"INACT")) 174 ; 175 I $$MCE116 D 176 .I $$MCE120 D 177 ..I $$MCE115 D R57R4B^OCXOZ0X 178 Q 179 ; 180 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 181 ; 182 N OCXE,VAL,PC S VAL="" 183 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 184 Q VAL 185 ; 186 MCE114() ; Verify Event/Element: CLOZAPINE ANC < 1.5 187 ; 188 ; OCXDF(37) -> PATIENT IEN data field 189 ; 190 N OCXRES 191 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(114,37)=OCXDF(37) 192 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),114)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),114)) 193 Q 0 194 ; 195 MCE115() ; Verify Event/Element: CLOZAPINE ANC >= 1.5 196 ; 197 ; OCXDF(37) -> PATIENT IEN data field 198 ; 199 N OCXRES 200 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(115,37)=OCXDF(37) 201 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),115)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),115)) 202 Q 0 203 ; 204 MCE116() ; Verify Event/Element: CLOZAPINE DRUG SELECTED 205 ; 206 ; OCXDF(37) -> PATIENT IEN data field 207 ; 208 N OCXRES 209 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(116,37)=OCXDF(37) 210 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),116)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),116)) 211 Q 0 212 ; 213 MCE117() ; Verify Event/Element: CLOZAPINE NO ANC W/IN 7 DAYS 214 ; 215 ; OCXDF(37) -> PATIENT IEN data field 216 ; 217 N OCXRES 218 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(117,37)=OCXDF(37) 219 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),117)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),117)) 220 Q 0 221 ; 222 MCE118() ; Verify Event/Element: CLOZAPINE NO WBC W/IN 7 DAYS 223 ; 224 ; OCXDF(37) -> PATIENT IEN data field 225 ; 226 N OCXRES 227 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(118,37)=OCXDF(37) 228 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),118)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),118)) 229 Q 0 230 ; 231 MCE119() ; Verify Event/Element: CLOZAPINE WBC < 3.0 232 ; 233 ; OCXDF(37) -> PATIENT IEN data field 234 ; 235 N OCXRES 236 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(119,37)=OCXDF(37) 237 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),119)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),119)) 238 Q 0 239 ; 240 MCE120() ; Verify Event/Element: CLOZAPINE WBC >= 3.0 & < 3.5 241 ; 242 ; OCXDF(37) -> PATIENT IEN data field 243 ; 244 N OCXRES 245 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(120,37)=OCXDF(37) 246 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),120)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),120)) 247 Q 0 248 ; 249 MCE67() ; Verify Event/Element: RECENT BARIUM STUDY ORDERED 250 ; 251 ; OCXDF(37) -> PATIENT IEN data field 252 ; 253 N OCXRES 254 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(67,37)=OCXDF(37) 255 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),67)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),67)) 256 Q 0 257 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0X.m
r613 r623 1 OCXOZ0X ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R57R4B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #4 'CLOZAPINE AND 1.5 <= ANC < 2.0' 14 ; Called from R57R4A+12^OCXOZ0W. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; 21 Q:$D(OCXRULE("R57R4B")) 22 ; 23 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 24 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^ANC between 1.5 and 2.0 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly. Most recent results - "_$$GETDATA(DFN,"116^140",130) I 1 25 E S OCXCMSG="ANC between 1.5 and 2.0 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly. Most recent results - "_$$GETDATA(DFN,"116^140",130) 26 S OCXNMSG="" 27 ; 28 Q:$G(OCXOERR) 29 ; 30 ; Send Order Check Message 31 ; 32 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 33 Q 34 ; 35 R59R1A ; Verify all Event/Elements of Rule #59 'AMINOGLYCOSIDE ORDER' Relation #1 'AGS ORDER' 36 ; Called from EL71+5^OCXOZ0I. 37 ; 38 Q:$G(OCXOERR) 39 ; 40 ; Local Extrinsic Functions 41 ; MCE71( -----------> Verify Event/Element: 'AMINOGLYCOSIDE ORDER SESSION' 42 ; 43 Q:$G(^OCXS(860.2,59,"INACT")) 44 ; 45 I $$MCE71 D R59R1B 46 Q 47 ; 48 R59R1B ; Send Order Check, Notication messages and/or Execute code for Rule #59 'AMINOGLYCOSIDE ORDER' Relation #1 'AGS ORDER' 49 ; Called from R59R1A+10. 50 ; 51 Q:$G(OCXOERR) 52 ; 53 ; Local Extrinsic Functions 54 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 55 ; 56 Q:$D(OCXRULE("R59R1B")) 57 ; 58 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 59 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^20^^Aminoglycoside - est. CrCl: "_$$GETDATA(DFN,"71^",76)_" ("_$$GETDATA(DFN,"71^",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in)]" I 1 60 E S OCXCMSG="Aminoglycoside - est. CrCl: "_$$GETDATA(DFN,"71^",76)_" ("_$$GETDATA(DFN,"71^",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in)]" 61 S OCXNMSG="" 62 ; 63 Q:$G(OCXOERR) 64 ; 65 ; Send Order Check Message 66 ; 67 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 68 Q 69 ; 70 R60R1A ; Verify all Event/Elements of Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK' Relation #1 'TOO BIG' 71 ; Called from EL72+5^OCXOZ0I. 72 ; 73 Q:$G(OCXOERR) 74 ; 75 ; Local Extrinsic Functions 76 ; MCE72( -----------> Verify Event/Element: 'PATIENT OVER CT OR MRI DEVICE LIMITATIONS' 77 ; 78 Q:$G(^OCXS(860.2,60,"INACT")) 79 ; 80 I $$MCE72 D R60R1B 81 Q 82 ; 83 R60R1B ; Send Order Check, Notication messages and/or Execute code for Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK' Relation #1 'TOO BIG' 84 ; Called from R60R1A+10. 85 ; 86 Q:$G(OCXOERR) 87 ; 88 ; Local Extrinsic Functions 89 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 90 ; 91 Q:$D(OCXRULE("R60R1B")) 92 ; 93 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 94 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^8^^Patient may be "_$$GETDATA(DFN,"72^",79)_" for the "_$$GETDATA(DFN,"72^",80)_"." I 1 95 E S OCXCMSG="Patient may be "_$$GETDATA(DFN,"72^",79)_" for the "_$$GETDATA(DFN,"72^",80)_"." 96 S OCXNMSG="" 97 ; 98 Q:$G(OCXOERR) 99 ; 100 ; Send Order Check Message 101 ; 102 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 103 Q 104 ; 105 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 106 ; 107 N OCXE,VAL,PC S VAL="" 108 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 109 Q VAL 110 ; 111 MCE71() ; Verify Event/Element: AMINOGLYCOSIDE ORDER SESSION 112 ; 113 ; OCXDF(37) -> PATIENT IEN data field 114 ; 115 N OCXRES 116 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(71,37)=OCXDF(37) 117 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),71)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),71)) 118 Q 0 119 ; 120 MCE72() ; Verify Event/Element: PATIENT OVER CT OR MRI DEVICE LIMITATIONS 121 ; 122 ; OCXDF(37) -> PATIENT IEN data field 123 ; 124 N OCXRES 125 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(72,37)=OCXDF(37) 126 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),72)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),72)) 127 Q 0 128 ; 1 OCXOZ0X ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R57R4B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #4 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND ANC >= 1.5' 14 ; Called from R57R4A+14^OCXOZ0W. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; 21 Q:$D(OCXRULE("R57R4B")) 22 ; 23 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 24 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^WBC between 3.0 and 3.5 with ANC >= 1.5 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly. Most recent results - "_$$GETDATA(DFN,"115^116^120",130) I 1 25 E S OCXCMSG="WBC between 3.0 and 3.5 with ANC >= 1.5 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly. Most recent results - "_$$GETDATA(DFN,"115^116^120",130) 26 S OCXNMSG="" 27 ; 28 Q:$G(OCXOERR) 29 ; 30 ; Send Order Check Message 31 ; 32 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 33 Q 34 ; 35 R57R5A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #5 'CLOZAPINE AND WBC >= 3.5' 36 ; Called from EL116+9^OCXOZ0H, and EL121+5^OCXOZ0I. 37 ; 38 Q:$G(OCXOERR) 39 ; 40 ; Local Extrinsic Functions 41 ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' 42 ; MCE121( ----------> Verify Event/Element: 'CLOZAPINE WBC >= 3.5' 43 ; 44 Q:$G(^OCXS(860.2,57,"INACT")) 45 ; 46 I $$MCE116 D 47 .I $$MCE121 D R57R5B 48 Q 49 ; 50 R57R5B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #5 'CLOZAPINE AND WBC >= 3.5' 51 ; Called from R57R5A+12. 52 ; 53 Q:$G(OCXOERR) 54 ; 55 ; Local Extrinsic Functions 56 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 57 ; 58 Q:$D(OCXRULE("R57R5B")) 59 ; 60 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 61 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^Clozapine - most recent results - "_$$GETDATA(DFN,"116^121",130) I 1 62 E S OCXCMSG="Clozapine - most recent results - "_$$GETDATA(DFN,"116^121",130) 63 S OCXNMSG="" 64 ; 65 Q:$G(OCXOERR) 66 ; 67 ; Send Order Check Message 68 ; 69 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 70 Q 71 ; 72 R59R1A ; Verify all Event/Elements of Rule #59 'AMINOGLYCOSIDE ORDER' Relation #1 'AGS ORDER' 73 ; Called from EL71+5^OCXOZ0I. 74 ; 75 Q:$G(OCXOERR) 76 ; 77 ; Local Extrinsic Functions 78 ; MCE71( -----------> Verify Event/Element: 'AMINOGLYCOSIDE ORDER SESSION' 79 ; 80 Q:$G(^OCXS(860.2,59,"INACT")) 81 ; 82 I $$MCE71 D R59R1B 83 Q 84 ; 85 R59R1B ; Send Order Check, Notication messages and/or Execute code for Rule #59 'AMINOGLYCOSIDE ORDER' Relation #1 'AGS ORDER' 86 ; Called from R59R1A+10. 87 ; 88 Q:$G(OCXOERR) 89 ; 90 ; Local Extrinsic Functions 91 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 92 ; 93 Q:$D(OCXRULE("R59R1B")) 94 ; 95 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 96 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^20^^Aminoglycoside - est. CrCl: "_$$GETDATA(DFN,"71^",76)_" ("_$$GETDATA(DFN,"71^",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in)]" I 1 97 E S OCXCMSG="Aminoglycoside - est. CrCl: "_$$GETDATA(DFN,"71^",76)_" ("_$$GETDATA(DFN,"71^",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in)]" 98 S OCXNMSG="" 99 ; 100 Q:$G(OCXOERR) 101 ; 102 ; Send Order Check Message 103 ; 104 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 105 Q 106 ; 107 R60R1A ; Verify all Event/Elements of Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK' Relation #1 'TOO BIG' 108 ; Called from EL72+5^OCXOZ0I. 109 ; 110 Q:$G(OCXOERR) 111 ; 112 ; Local Extrinsic Functions 113 ; MCE72( -----------> Verify Event/Element: 'PATIENT OVER CT OR MRI DEVICE LIMITATIONS' 114 ; 115 Q:$G(^OCXS(860.2,60,"INACT")) 116 ; 117 I $$MCE72 D R60R1B 118 Q 119 ; 120 R60R1B ; Send Order Check, Notication messages and/or Execute code for Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK' Relation #1 'TOO BIG' 121 ; Called from R60R1A+10. 122 ; 123 Q:$G(OCXOERR) 124 ; 125 ; Local Extrinsic Functions 126 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 127 ; 128 Q:$D(OCXRULE("R60R1B")) 129 ; 130 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 131 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^8^^Patient may be "_$$GETDATA(DFN,"72^",79)_" for the "_$$GETDATA(DFN,"72^",80)_"." I 1 132 E S OCXCMSG="Patient may be "_$$GETDATA(DFN,"72^",79)_" for the "_$$GETDATA(DFN,"72^",80)_"." 133 S OCXNMSG="" 134 ; 135 Q:$G(OCXOERR) 136 ; 137 ; Send Order Check Message 138 ; 139 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 140 Q 141 ; 142 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 143 ; 144 N OCXE,VAL,PC S VAL="" 145 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 146 Q VAL 147 ; 148 MCE116() ; Verify Event/Element: CLOZAPINE DRUG SELECTED 149 ; 150 ; OCXDF(37) -> PATIENT IEN data field 151 ; 152 N OCXRES 153 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(116,37)=OCXDF(37) 154 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),116)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),116)) 155 Q 0 156 ; 157 MCE121() ; Verify Event/Element: CLOZAPINE WBC >= 3.5 158 ; 159 ; OCXDF(37) -> PATIENT IEN data field 160 ; 161 N OCXRES 162 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(121,37)=OCXDF(37) 163 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),121)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),121)) 164 Q 0 165 ; 166 MCE71() ; Verify Event/Element: AMINOGLYCOSIDE ORDER SESSION 167 ; 168 ; OCXDF(37) -> PATIENT IEN data field 169 ; 170 N OCXRES 171 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(71,37)=OCXDF(37) 172 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),71)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),71)) 173 Q 0 174 ; 175 MCE72() ; Verify Event/Element: PATIENT OVER CT OR MRI DEVICE LIMITATIONS 176 ; 177 ; OCXDF(37) -> PATIENT IEN data field 178 ; 179 N OCXRES 180 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(72,37)=OCXDF(37) 181 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),72)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),72)) 182 Q 0 183 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Y.m
r613 r623 1 OCXOZ0Y ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R61R1A 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 R61R1B 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 CRCL(DFN) 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 DT2INT(OCXDT) 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 FLAB(DFN,OCXLIST,OCXSPEC) 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 GETDATA(DFN,OCXL,OCXDFI) 155 156 157 158 159 160 MCE73() 161 162 163 164 165 166 167 168 169 MCE96() 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 MCE97() 185 186 187 188 189 190 191 192 193 194 195 196 197 198 TERMLKUP(OCXTERM,OCXLIST) 199 200 1 OCXOZ0Y ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R61R1A ; Verify all Event/Elements of Rule #61 'CREATININE CLEARANCE ESTIMATION' Relation #1 'IF CREAT CLEAR AND ( CREATININE CLEARANCE DATE OR ...' 14 ; Called from EL73+5^OCXOZ0I, and EL96+5^OCXOZ0I, and EL97+5^OCXOZ0I. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; MCE73( -----------> Verify Event/Element: 'CREATININE CLEARANCE ESTIMATE' 20 ; MCE96( -----------> Verify Event/Element: 'CREATININE CLEARANCE DATE/TIME' 21 ; MCE97( -----------> Verify Event/Element: 'RENAL RESULTS' 22 ; 23 Q:$G(^OCXS(860.2,61,"INACT")) 24 ; 25 I $$MCE73 D 26 .I $$MCE96 D R61R1B 27 .I $$MCE97 D R61R1B 28 Q 29 ; 30 R61R1B ; Send Order Check, Notication messages and/or Execute code for Rule #61 'CREATININE CLEARANCE ESTIMATION' Relation #1 'IF CREAT CLEAR AND ( CREATININE CLEARANCE DATE OR ...' 31 ; Called from R61R1A+13. 32 ; 33 Q:$G(OCXOERR) 34 ; 35 ; Local Extrinsic Functions 36 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 37 ; 38 Q:$D(OCXRULE("R61R1B")) 39 ; 40 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 41 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^1^^Est. CrCl: "_$$GETDATA(DFN,"73^96^97",76)_" ("_$$GETDATA(DFN,"73^96^97",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in.)]" I 1 42 E S OCXCMSG="Est. CrCl: "_$$GETDATA(DFN,"73^96^97",76)_" ("_$$GETDATA(DFN,"73^96^97",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in.)]" 43 S OCXNMSG="" 44 ; 45 Q:$G(OCXOERR) 46 ; 47 ; Send Order Check Message 48 ; 49 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 50 Q 51 ; 52 CRCL(DFN) ; Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED) 53 ; 54 N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR 55 N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW 56 S RSLT="0^<Unavailable>" 57 S PSCR="^^^^^^0" 58 D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT) 59 Q:'$D(ORW) RSLT 60 S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT 61 S ABW=ABW/2.2 ;ABW (actual body weight) in kg 62 D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT) 63 Q:'$D(ORH) RSLT 64 S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT 65 S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT 66 S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT 67 S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT 68 S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT 69 S SCR="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D 70 .S OCXTS=0 F S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS D 71 ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U)) 72 ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR 73 S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT 74 S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT 75 ; 76 S HTGT60=$S(HT>60:(HT-60)*2.3,1:0) ;if ht > 60 inches 77 I HTGT60>0 D 78 .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60) ;Ideal Body Weight 79 .S BWRATIO=(ABW/IBW) ;body weight ratio 80 .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0) 81 .S LOWBW=$S(IBW<ABW:IBW,1:ABW) 82 .I BWRATIO>1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW) 83 .E S ADJBW=LOWBW 84 I +$G(ADJBW)<1 D 85 .S ADJBW=ABW 86 S CRCL=(((140-AGE)*ADJBW)/(SCRV*72)) 87 ; 88 S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1) 89 S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1) 90 Q RSLT 91 ; 92 DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer 93 ; By taking the Years, Months, Days, Hours and Minutes converting 94 ; Them into Seconds and then adding them all together into one big integer 95 ; 96 Q:'$L($G(OCXDT)) "" 97 N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0 98 ; 99 I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT 100 .N OCXHR,OCXMIN,OCXTIME 101 .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2) 102 .S:(OCXDT["Midnight") OCXHR=00 103 .S:(OCXDT["PM") OCXHR=OCXHR+12 104 .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3) 105 ; 106 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT 107 .N OCXMON 108 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) 109 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","") 110 .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2) 111 ; 112 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT 113 .N OCXMON 114 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) 115 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","") 116 .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3) 117 ; 118 I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT 119 .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1 120 .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y 121 ; 122 I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT 123 ; 124 I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT 125 ; 126 I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT 127 ; 128 Q OCXVAL 129 ; 130 FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS 131 ; 132 Q:'$G(DFN) "<Patient Not Specified>" 133 Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>" 134 N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC="" 135 I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL) 136 F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D 137 .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR 138 .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL) 139 .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D 140 ..I $L($G(OCXSL)) D 141 ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D 142 ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D 143 .....S OCXA($P(OCXX,U,7))=OCXX 144 ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"") 145 ..Q:'$L(OCXX) 146 .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR) 147 .I $L(OCXX) D 148 ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4) 149 ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"") 150 ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P") 151 .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY) 152 Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT 153 ; 154 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 155 ; 156 N OCXE,VAL,PC S VAL="" 157 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 158 Q VAL 159 ; 160 MCE73() ; Verify Event/Element: CREATININE CLEARANCE ESTIMATE 161 ; 162 ; OCXDF(37) -> PATIENT IEN data field 163 ; 164 N OCXRES 165 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(73,37)=OCXDF(37) 166 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),73)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),73)) 167 Q 0 168 ; 169 MCE96() ; Verify Event/Element: CREATININE CLEARANCE DATE/TIME 170 ; 171 ; OCXDF(76) -> CREATININE CLEARANCE (ESTIM) VALUE data field 172 ; OCXDF(64) -> FORMATTED RENAL LAB RESULTS data field 173 ; OCXDF(77) -> CREATININE CLEARANCE (ESTIM) DATE data field 174 ; OCXDF(37) -> PATIENT IEN data field 175 ; 176 N OCXRES 177 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(96,37)=OCXDF(37) 178 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),96)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),96)) 179 S OCXRES(96)=0,OCXDF(77)=$$DT2INT($P($$CRCL(OCXDF(37)),"^",1)) I $L(OCXDF(77)) S OCXRES(96,77)=OCXDF(77) I (OCXDF(77)>$$DT2INT(0)) 180 E Q 0 181 S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXRES(96)=11 M ^TMP("OCXCHK",$J,OCXDF(37),96)=OCXRES(96) 182 Q +OCXRES(96) 183 ; 184 MCE97() ; Verify Event/Element: RENAL RESULTS 185 ; 186 ; OCXDF(76) -> CREATININE CLEARANCE (ESTIM) VALUE data field 187 ; OCXDF(64) -> FORMATTED RENAL LAB RESULTS data field 188 ; OCXDF(37) -> PATIENT IEN data field 189 ; 190 N OCXRES 191 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(97,37)=OCXDF(37) 192 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),97)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),97)) 193 S OCXRES(97)=0,OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN") I '(OCXDF(64)="<Results Not Found>") 194 E Q 0 195 S OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXRES(97)=11 M ^TMP("OCXCHK",$J,OCXDF(37),97)=OCXRES(97) 196 Q +OCXRES(97) 197 ; 198 TERMLKUP(OCXTERM,OCXLIST) ; 199 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) 200 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Z.m
r613 r623 1 OCXOZ0Z ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R62R1A 14 15 16 17 18 19 20 21 22 23 24 25 26 R62R1B 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 R63R1A 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 R63R1B 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 R65R1A 93 94 95 96 97 98 99 100 101 102 103 104 105 R65R1B 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 R66R1A 128 129 130 131 132 133 134 135 136 137 138 139 140 CKSUM(STR) 141 142 143 144 145 146 147 GETDATA(DFN,OCXL,OCXDFI) 148 149 150 151 152 153 MCE106() 154 155 156 157 158 159 160 161 162 MCE5() 163 164 165 166 167 168 169 170 MCE84() 171 172 173 174 175 176 177 178 MCE91() 179 180 181 182 183 184 185 186 187 188 189 190 191 MCE95() 192 193 194 195 196 197 198 199 200 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 SETAP(ROOT,DD,DATA,DA) 262 263 264 265 266 267 268 1 OCXOZ0Z ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R62R1A ; Verify all Event/Elements of Rule #62 'FOOD/DRUG INTERACTION' Relation #1 'INPATIENT FOOD DRUG REACTION' 14 ; Called from EL84+5^OCXOZ0I. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; MCE84( -----------> Verify Event/Element: 'INPATIENT FOOD-DRUG REACTION' 20 ; 21 Q:$G(^OCXS(860.2,62,"INACT")) 22 ; 23 I $$MCE84 D R62R1B 24 Q 25 ; 26 R62R1B ; Send Order Check, Notication messages and/or Execute code for Rule #62 'FOOD/DRUG INTERACTION' Relation #1 'INPATIENT FOOD DRUG REACTION' 27 ; Called from R62R1A+10. 28 ; 29 Q:$G(OCXOERR) 30 ; 31 ; Local Extrinsic Functions 32 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 33 ; NEWRULE( ---------> NEW RULE MESSAGE 34 ; 35 Q:$D(OCXRULE("R62R1B")) 36 ; 37 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 38 S OCXCMSG="" 39 S OCXNMSG="["_$$GETDATA(DFN,"84^",147)_"] "_$$GETDATA(DFN,"84^",82)_" ordered - adjust diet accordingly." 40 ; 41 Q:$G(OCXOERR) 42 ; 43 ; Send Notification 44 ; 45 S (OCXDUZ,OCXDATA)="",OCXNUM=0 46 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 47 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 48 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 49 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 50 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 51 .S OCXNUM=+$P(OCXORD,U,2) 52 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 53 S OCXRULE("R62R1B")="" 54 I $$NEWRULE(DFN,OCXNUM,62,1,55,OCXNMSG) D I 1 55 .D:($G(OCXTRACE)<5) EN^ORB3(55,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 56 Q 57 ; 58 R63R1A ; Verify all Event/Elements of Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' Relation #1 'IF PROC USES NON-BARIUM MEDIA AND PATIENT TAKING G...' 59 ; Called from EL91+5^OCXOZ0I, and EL106+5^OCXOZ0I. 60 ; 61 Q:$G(OCXOERR) 62 ; 63 ; Local Extrinsic Functions 64 ; MCE106( ----------> Verify Event/Element: 'RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA' 65 ; MCE91( -----------> Verify Event/Element: 'PATIENT WITH GLUCOPHAGE MED' 66 ; 67 Q:$G(^OCXS(860.2,63,"INACT")) 68 ; 69 I $$MCE106 D 70 .I $$MCE91 D R63R1B 71 Q 72 ; 73 R63R1B ; Send Order Check, Notication messages and/or Execute code for Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' Relation #1 'IF PROC USES NON-BARIUM MEDIA AND PATIENT TAKING G...' 74 ; Called from R63R1A+12. 75 ; 76 Q:$G(OCXOERR) 77 ; 78 Q:$D(OCXRULE("R63R1B")) 79 ; 80 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 81 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^23^^Procedure uses intravenous contrast media and patient is taking metformin." I 1 82 E S OCXCMSG="Procedure uses intravenous contrast media and patient is taking metformin." 83 S OCXNMSG="" 84 ; 85 Q:$G(OCXOERR) 86 ; 87 ; Send Order Check Message 88 ; 89 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 90 Q 91 ; 92 R65R1A ; Verify all Event/Elements of Rule #65 'POLYPHARMACY' Relation #1 'POLYPHARMACY' 93 ; Called from EL95+5^OCXOZ0I. 94 ; 95 Q:$G(OCXOERR) 96 ; 97 ; Local Extrinsic Functions 98 ; MCE95( -----------> Verify Event/Element: 'POLYPHARMACY' 99 ; 100 Q:$G(^OCXS(860.2,65,"INACT")) 101 ; 102 I $$MCE95 D R65R1B 103 Q 104 ; 105 R65R1B ; Send Order Check, Notication messages and/or Execute code for Rule #65 'POLYPHARMACY' Relation #1 'POLYPHARMACY' 106 ; Called from R65R1A+10. 107 ; 108 Q:$G(OCXOERR) 109 ; 110 ; Local Extrinsic Functions 111 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 112 ; 113 Q:$D(OCXRULE("R65R1B")) 114 ; 115 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 116 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^26^^Potential polypharmacy - patient currently receiving "_$$GETDATA(DFN,"95^",109)_" medications." I 1 117 E S OCXCMSG="Potential polypharmacy - patient currently receiving "_$$GETDATA(DFN,"95^",109)_" medications." 118 S OCXNMSG="" 119 ; 120 Q:$G(OCXOERR) 121 ; 122 ; Send Order Check Message 123 ; 124 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 125 Q 126 ; 127 R66R1A ; Verify all Event/Elements of Rule #66 'LAB RESULTS' Relation #1 'HL7 LAB RESULTS' 128 ; Called from EL5+6^OCXOZ0H. 129 ; 130 Q:$G(OCXOERR) 131 ; 132 ; Local Extrinsic Functions 133 ; MCE5( ------------> Verify Event/Element: 'HL7 FINAL LAB RESULT' 134 ; 135 Q:$G(^OCXS(860.2,66,"INACT")) 136 ; 137 I $$MCE5 D R66R1B^OCXOZ10 138 Q 139 ; 140 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 141 ; 142 N CKSUM,PTR,ASC S CKSUM=0 143 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 144 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 145 Q +CKSUM 146 ; 147 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 148 ; 149 N OCXE,VAL,PC S VAL="" 150 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 151 Q VAL 152 ; 153 MCE106() ; Verify Event/Element: RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA 154 ; 155 ; OCXDF(37) -> PATIENT IEN data field 156 ; 157 N OCXRES 158 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(106,37)=OCXDF(37) 159 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),106)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),106)) 160 Q 0 161 ; 162 MCE5() ; Verify Event/Element: HL7 FINAL LAB RESULT 163 ; 164 ; 165 N OCXRES 166 I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37) 167 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5)) 168 Q 0 169 ; 170 MCE84() ; Verify Event/Element: INPATIENT FOOD-DRUG REACTION 171 ; 172 ; 173 N OCXRES 174 I $L(OCXDF(37)) S OCXRES(84,37)=OCXDF(37) 175 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),84)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),84)) 176 Q 0 177 ; 178 MCE91() ; Verify Event/Element: PATIENT WITH GLUCOPHAGE MED 179 ; 180 ; OCXDF(103) -> PATIENT CURRENTLY ON GLUCOPHAGE data field 181 ; OCXDF(37) -> PATIENT IEN data field 182 ; 183 N OCXRES 184 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(91,37)=OCXDF(37) 185 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),91)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),91)) 186 S OCXRES(91)=0,OCXDF(103)=$P($$TAKEMED^ORKPS(OCXDF(37),"^GLUCOPHAGE^METFORMIN^AVANDAMET^METAGLIP"),"^",1) I $L(OCXDF(103)) S OCXRES(91,103)=OCXDF(103) I (OCXDF(103)) 187 E Q 0 188 S OCXRES(91)=11 M ^TMP("OCXCHK",$J,OCXDF(37),91)=OCXRES(91) 189 Q +OCXRES(91) 190 ; 191 MCE95() ; Verify Event/Element: POLYPHARMACY 192 ; 193 ; OCXDF(37) -> PATIENT IEN data field 194 ; 195 N OCXRES 196 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(95,37)=OCXDF(37) 197 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),95)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),95)) 198 Q 0 199 ; 200 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 201 ; 202 ; 203 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 204 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 205 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 206 ; 207 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 208 ; 209 S OCXTIME=(+$H) 210 S OCXCKSUM=$$CKSUM(OCXMESS) 211 ; 212 S OCXTSP=($H*86400)+$P($H,",",2) 213 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 214 ; 215 Q:(OCXTSPL>OCXTSP) 0 216 ; 217 K OCXDATA 218 S OCXDATA(OCXDFN,0)=OCXDFN 219 S OCXDATA("B",OCXDFN,OCXDFN)="" 220 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 221 ; 222 S OCXGR="^OCXD(860.7" 223 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 224 ; 225 K OCXDATA 226 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 227 S OCXDATA(OCXRUL,"M")=OCXMESS 228 S OCXDATA("B",OCXRUL,OCXRUL)="" 229 S OCXGR=OCXGR_","_OCXDFN_",1" 230 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 231 ; 232 K OCXDATA 233 S OCXDATA(OCXREL,0)=OCXREL 234 S OCXDATA("B",OCXREL,OCXREL)="" 235 S OCXGR=OCXGR_","_OCXRUL_",1" 236 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 237 ; 238 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 239 .; 240 .N OCXGR1 241 .S OCXGR1=OCXGR_","_OCXREL_",1" 242 .K OCXDATA 243 .S OCXDATA(OCXELE,0)=OCXELE 244 .S OCXDATA(OCXELE,"TIME")=OCXTIME 245 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 246 .S OCXDATA("B",OCXELE,OCXELE)="" 247 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 248 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 249 .; 250 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 251 ..N OCXGR2 252 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 253 ..K OCXDATA 254 ..S OCXDATA(OCXDFI,0)=OCXDFI 255 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 256 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 257 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 258 ; 259 Q 1 260 ; 261 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 262 M @ROOT=DATA 263 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 264 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 265 ; 266 Q 267 ; 268 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ10.m
r613 r623 1 OCXOZ10 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R66R1B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 R67R1A 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 R67R1B 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 R67R2A 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 R67R2B 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 CKSUM(STR) 120 121 122 123 124 125 126 GETDATA(DFN,OCXL,OCXDFI) 127 128 129 130 131 132 MCE111() 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 MCE112() 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 MCE86() 163 164 165 166 167 168 169 170 171 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 SETAP(ROOT,DD,DATA,DA) 233 234 235 236 237 238 239 1 OCXOZ10 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R66R1B ; Send Order Check, Notication messages and/or Execute code for Rule #66 'LAB RESULTS' Relation #1 'HL7 LAB RESULTS' 14 ; Called from R66R1A+10^OCXOZ0Z. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; NEWRULE( ---------> NEW RULE MESSAGE 21 ; 22 Q:$D(OCXRULE("R66R1B")) 23 ; 24 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 25 S OCXCMSG="" 26 S OCXNMSG="Labs resulted - ["_$$GETDATA(DFN,"5^",96)_"]" 27 ; 28 Q:$G(OCXOERR) 29 ; 30 ; Send Notification 31 ; 32 S (OCXDUZ,OCXDATA)="",OCXNUM=0 33 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 34 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 35 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 36 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 37 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 38 .S OCXNUM=+$P(OCXORD,U,2) 39 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 40 S OCXRULE("R66R1B")="" 41 I $$NEWRULE(DFN,OCXNUM,66,1,3,OCXNMSG) D I 1 42 .D:($G(OCXTRACE)<5) EN^ORB3(3,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 43 Q 44 ; 45 R67R1A ; Verify all Event/Elements of Rule #67 'GLUCOPHAGE - LAB RESULTS' Relation #1 'GLUCOPHAGE ORDER AND GLUCOPHAGE CREATININE > 1.5' 46 ; Called from EL86+5^OCXOZ0I, and EL111+5^OCXOZ0I. 47 ; 48 Q:$G(OCXOERR) 49 ; 50 ; Local Extrinsic Functions 51 ; MCE111( ----------> Verify Event/Element: 'GLUCOPHAGE CREATININE > 1.5' 52 ; MCE86( -----------> Verify Event/Element: 'GLUCOPHAGE ORDER' 53 ; 54 Q:$G(^OCXS(860.2,67,"INACT")) 55 ; 56 I $$MCE86 D 57 .I $$MCE111 D R67R1B 58 Q 59 ; 60 R67R1B ; Send Order Check, Notication messages and/or Execute code for Rule #67 'GLUCOPHAGE - LAB RESULTS' Relation #1 'GLUCOPHAGE ORDER AND GLUCOPHAGE CREATININE > 1.5' 61 ; Called from R67R1A+12. 62 ; 63 Q:$G(OCXOERR) 64 ; 65 ; Local Extrinsic Functions 66 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 67 ; 68 Q:$D(OCXRULE("R67R1B")) 69 ; 70 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 71 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^28^^Metformin - Creatinine results: "_$$GETDATA(DFN,"86^111",125) I 1 72 E S OCXCMSG="Metformin - Creatinine results: "_$$GETDATA(DFN,"86^111",125) 73 S OCXNMSG="" 74 ; 75 Q:$G(OCXOERR) 76 ; 77 ; Send Order Check Message 78 ; 79 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 80 Q 81 ; 82 R67R2A ; Verify all Event/Elements of Rule #67 'GLUCOPHAGE - LAB RESULTS' Relation #2 'GLUCOPHAGE ORDER AND NO GLUCOPHAGE CREATININE' 83 ; Called from EL86+6^OCXOZ0I, and EL112+5^OCXOZ0I. 84 ; 85 Q:$G(OCXOERR) 86 ; 87 ; Local Extrinsic Functions 88 ; MCE112( ----------> Verify Event/Element: 'NO GLUCOPHAGE CREATININE' 89 ; MCE86( -----------> Verify Event/Element: 'GLUCOPHAGE ORDER' 90 ; 91 Q:$G(^OCXS(860.2,67,"INACT")) 92 ; 93 I $$MCE86 D 94 .I $$MCE112 D R67R2B 95 Q 96 ; 97 R67R2B ; Send Order Check, Notication messages and/or Execute code for Rule #67 'GLUCOPHAGE - LAB RESULTS' Relation #2 'GLUCOPHAGE ORDER AND NO GLUCOPHAGE CREATININE' 98 ; Called from R67R2A+12. 99 ; 100 Q:$G(OCXOERR) 101 ; 102 ; Local Extrinsic Functions 103 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 104 ; 105 Q:$D(OCXRULE("R67R2B")) 106 ; 107 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 108 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^28^^Metformin - no serum creatinine within past "_$$GETDATA(DFN,"86^112",127)_" days." I 1 109 E S OCXCMSG="Metformin - no serum creatinine within past "_$$GETDATA(DFN,"86^112",127)_" days." 110 S OCXNMSG="" 111 ; 112 Q:$G(OCXOERR) 113 ; 114 ; Send Order Check Message 115 ; 116 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 117 Q 118 ; 119 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 120 ; 121 N CKSUM,PTR,ASC S CKSUM=0 122 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 123 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 124 Q +CKSUM 125 ; 126 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 127 ; 128 N OCXE,VAL,PC S VAL="" 129 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 130 Q VAL 131 ; 132 MCE111() ; Verify Event/Element: GLUCOPHAGE CREATININE > 1.5 133 ; 134 ; OCXDF(127) -> RECENT GLUCOPHAGE CREATININE DAYS data field 135 ; OCXDF(125) -> RECENT GLUCOPHAGE CREATININE TEXT data field 136 ; OCXDF(126) -> RECENT GLUCOPHAGE CREATININE RESULT data field 137 ; OCXDF(37) -> PATIENT IEN data field 138 ; 139 N OCXRES 140 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(111,37)=OCXDF(37) 141 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),111)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),111)) 142 S OCXRES(111)=0,OCXDF(126)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",3) I $L(OCXDF(126)) S OCXRES(111,126)=OCXDF(126) I (OCXDF(126)>1.5) 143 E Q 0 144 S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1),OCXRES(111)=11 M ^TMP("OCXCHK",$J,OCXDF(37),111)=OCXRES(111) 145 Q +OCXRES(111) 146 ; 147 MCE112() ; Verify Event/Element: NO GLUCOPHAGE CREATININE 148 ; 149 ; OCXDF(127) -> RECENT GLUCOPHAGE CREATININE DAYS data field 150 ; OCXDF(125) -> RECENT GLUCOPHAGE CREATININE TEXT data field 151 ; OCXDF(124) -> RECENT GLUCOPHAGE CREATININE FLAG data field 152 ; OCXDF(37) -> PATIENT IEN data field 153 ; 154 N OCXRES 155 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(112,37)=OCXDF(37) 156 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),112)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),112)) 157 S OCXRES(112)=0,OCXDF(124)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",1) I $L(OCXDF(124)) S OCXRES(112,124)=OCXDF(124) I '(OCXDF(124)) 158 E Q 0 159 S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1),OCXRES(112)=11 M ^TMP("OCXCHK",$J,OCXDF(37),112)=OCXRES(112) 160 Q +OCXRES(112) 161 ; 162 MCE86() ; Verify Event/Element: GLUCOPHAGE ORDER 163 ; 164 ; OCXDF(37) -> PATIENT IEN data field 165 ; 166 N OCXRES 167 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(86,37)=OCXDF(37) 168 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),86)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),86)) 169 Q 0 170 ; 171 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 172 ; 173 ; 174 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 175 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 176 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 177 ; 178 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 179 ; 180 S OCXTIME=(+$H) 181 S OCXCKSUM=$$CKSUM(OCXMESS) 182 ; 183 S OCXTSP=($H*86400)+$P($H,",",2) 184 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 185 ; 186 Q:(OCXTSPL>OCXTSP) 0 187 ; 188 K OCXDATA 189 S OCXDATA(OCXDFN,0)=OCXDFN 190 S OCXDATA("B",OCXDFN,OCXDFN)="" 191 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 192 ; 193 S OCXGR="^OCXD(860.7" 194 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 195 ; 196 K OCXDATA 197 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 198 S OCXDATA(OCXRUL,"M")=OCXMESS 199 S OCXDATA("B",OCXRUL,OCXRUL)="" 200 S OCXGR=OCXGR_","_OCXDFN_",1" 201 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 202 ; 203 K OCXDATA 204 S OCXDATA(OCXREL,0)=OCXREL 205 S OCXDATA("B",OCXREL,OCXREL)="" 206 S OCXGR=OCXGR_","_OCXRUL_",1" 207 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 208 ; 209 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 210 .; 211 .N OCXGR1 212 .S OCXGR1=OCXGR_","_OCXREL_",1" 213 .K OCXDATA 214 .S OCXDATA(OCXELE,0)=OCXELE 215 .S OCXDATA(OCXELE,"TIME")=OCXTIME 216 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 217 .S OCXDATA("B",OCXELE,OCXELE)="" 218 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 219 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 220 .; 221 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 222 ..N OCXGR2 223 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 224 ..K OCXDATA 225 ..S OCXDATA(OCXDFI,0)=OCXDFI 226 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 227 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 228 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 229 ; 230 Q 1 231 ; 232 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 233 M @ROOT=DATA 234 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 235 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 236 ; 237 Q 238 ; 239 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ11.m
r613 r623 1 OCXOZ11 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R68R1A 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 R68R1B 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 R68R2A 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 R68R2B 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 R68R3A 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 R68R3B 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 R69R1A 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 GETDATA(DFN,OCXL,OCXDFI) 142 143 144 145 146 147 MCE122() 148 149 150 151 152 153 154 155 156 MCE123() 157 158 159 160 161 162 163 164 165 MCE124() 166 167 168 169 170 171 172 173 174 MCE125() 175 176 177 178 179 180 181 182 183 MCE131() 184 185 186 187 188 189 190 191 MCE132() 192 193 194 195 196 197 198 199 MCE5() 200 201 202 203 204 205 206 1 OCXOZ11 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R68R1A ; Verify all Event/Elements of Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #1 'MED ORDER FOR PT > 64 AND AMITRIPTYLINE' 14 ; Called from EL122+5^OCXOZ0I, and EL125+5^OCXOZ0I. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; MCE122( ----------> Verify Event/Element: 'AMITRIPTYLINE ORDER' 20 ; MCE125( ----------> Verify Event/Element: 'MED ORDER FOR PT > 64' 21 ; 22 Q:$G(^OCXS(860.2,68,"INACT")) 23 ; 24 I $$MCE125 D 25 .I $$MCE122 D R68R1B 26 Q 27 ; 28 R68R1B ; Send Order Check, Notication messages and/or Execute code for Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #1 'MED ORDER FOR PT > 64 AND AMITRIPTYLINE' 29 ; Called from R68R1A+12. 30 ; 31 Q:$G(OCXOERR) 32 ; 33 ; Local Extrinsic Functions 34 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 35 ; 36 Q:$D(OCXRULE("R68R1B")) 37 ; 38 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 39 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"122^125",62)_". "_$$GETDATA(DFN,"122^125",141) I 1 40 E S OCXCMSG="Patient is "_$$GETDATA(DFN,"122^125",62)_". "_$$GETDATA(DFN,"122^125",141) 41 S OCXNMSG="" 42 ; 43 Q:$G(OCXOERR) 44 ; 45 ; Send Order Check Message 46 ; 47 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 48 Q 49 ; 50 R68R2A ; Verify all Event/Elements of Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #2 'MED ORDER FOR PT > 64 AND CHLORPROPAMIDE' 51 ; Called from EL125+6^OCXOZ0I, and EL123+5^OCXOZ0I. 52 ; 53 Q:$G(OCXOERR) 54 ; 55 ; Local Extrinsic Functions 56 ; MCE123( ----------> Verify Event/Element: 'CHLORPROPAMIDE ORDER' 57 ; MCE125( ----------> Verify Event/Element: 'MED ORDER FOR PT > 64' 58 ; 59 Q:$G(^OCXS(860.2,68,"INACT")) 60 ; 61 I $$MCE125 D 62 .I $$MCE123 D R68R2B 63 Q 64 ; 65 R68R2B ; Send Order Check, Notication messages and/or Execute code for Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #2 'MED ORDER FOR PT > 64 AND CHLORPROPAMIDE' 66 ; Called from R68R2A+12. 67 ; 68 Q:$G(OCXOERR) 69 ; 70 ; Local Extrinsic Functions 71 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 72 ; 73 Q:$D(OCXRULE("R68R2B")) 74 ; 75 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 76 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"123^125",62)_". "_$$GETDATA(DFN,"123^125",142) I 1 77 E S OCXCMSG="Patient is "_$$GETDATA(DFN,"123^125",62)_". "_$$GETDATA(DFN,"123^125",142) 78 S OCXNMSG="" 79 ; 80 Q:$G(OCXOERR) 81 ; 82 ; Send Order Check Message 83 ; 84 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 85 Q 86 ; 87 R68R3A ; Verify all Event/Elements of Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #3 'MED ORDER FOR PT > 64 AND DIPYRIDAMOLE' 88 ; Called from EL125+7^OCXOZ0I, and EL124+5^OCXOZ0I. 89 ; 90 Q:$G(OCXOERR) 91 ; 92 ; Local Extrinsic Functions 93 ; MCE124( ----------> Verify Event/Element: 'DIPYRIDAMOLE ORDER' 94 ; MCE125( ----------> Verify Event/Element: 'MED ORDER FOR PT > 64' 95 ; 96 Q:$G(^OCXS(860.2,68,"INACT")) 97 ; 98 I $$MCE125 D 99 .I $$MCE124 D R68R3B 100 Q 101 ; 102 R68R3B ; Send Order Check, Notication messages and/or Execute code for Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #3 'MED ORDER FOR PT > 64 AND DIPYRIDAMOLE' 103 ; Called from R68R3A+12. 104 ; 105 Q:$G(OCXOERR) 106 ; 107 ; Local Extrinsic Functions 108 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 109 ; 110 Q:$D(OCXRULE("R68R3B")) 111 ; 112 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 113 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"124^125",62)_". "_$$GETDATA(DFN,"124^125",144) I 1 114 E S OCXCMSG="Patient is "_$$GETDATA(DFN,"124^125",62)_". "_$$GETDATA(DFN,"124^125",144) 115 S OCXNMSG="" 116 ; 117 Q:$G(OCXOERR) 118 ; 119 ; Send Order Check Message 120 ; 121 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 122 Q 123 ; 124 R69R1A ; Verify all Event/Elements of Rule #69 'LAB THRESHOLD' Relation #1 'IF HL7 LAB RESULTS AND (GREATER THAN THRESHOLD VAL...' 125 ; Called from EL5+7^OCXOZ0H, and EL131+5^OCXOZ0I, and EL132+5^OCXOZ0I. 126 ; 127 Q:$G(OCXOERR) 128 ; 129 ; Local Extrinsic Functions 130 ; MCE131( ----------> Verify Event/Element: 'GREATER THAN LAB THRESHOLD' 131 ; MCE132( ----------> Verify Event/Element: 'LESS THAN LAB THRESHOLD' 132 ; MCE5( ------------> Verify Event/Element: 'HL7 FINAL LAB RESULT' 133 ; 134 Q:$G(^OCXS(860.2,69,"INACT")) 135 ; 136 I $$MCE5 D 137 .I $$MCE131 D R69R1B^OCXOZ12 138 .I $$MCE132 D R69R1B^OCXOZ12 139 Q 140 ; 141 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 142 ; 143 N OCXE,VAL,PC S VAL="" 144 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 145 Q VAL 146 ; 147 MCE122() ; Verify Event/Element: AMITRIPTYLINE ORDER 148 ; 149 ; OCXDF(37) -> PATIENT IEN data field 150 ; 151 N OCXRES 152 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(122,37)=OCXDF(37) 153 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),122)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),122)) 154 Q 0 155 ; 156 MCE123() ; Verify Event/Element: CHLORPROPAMIDE ORDER 157 ; 158 ; OCXDF(37) -> PATIENT IEN data field 159 ; 160 N OCXRES 161 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(123,37)=OCXDF(37) 162 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),123)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),123)) 163 Q 0 164 ; 165 MCE124() ; Verify Event/Element: DIPYRIDAMOLE ORDER 166 ; 167 ; OCXDF(37) -> PATIENT IEN data field 168 ; 169 N OCXRES 170 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(124,37)=OCXDF(37) 171 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),124)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),124)) 172 Q 0 173 ; 174 MCE125() ; Verify Event/Element: MED ORDER FOR PT > 64 175 ; 176 ; OCXDF(37) -> PATIENT IEN data field 177 ; 178 N OCXRES 179 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(125,37)=OCXDF(37) 180 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),125)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),125)) 181 Q 0 182 ; 183 MCE131() ; Verify Event/Element: GREATER THAN LAB THRESHOLD 184 ; 185 ; 186 N OCXRES 187 I $L(OCXDF(37)) S OCXRES(131,37)=OCXDF(37) 188 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),131)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),131)) 189 Q 0 190 ; 191 MCE132() ; Verify Event/Element: LESS THAN LAB THRESHOLD 192 ; 193 ; 194 N OCXRES 195 I $L(OCXDF(37)) S OCXRES(132,37)=OCXDF(37) 196 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),132)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),132)) 197 Q 0 198 ; 199 MCE5() ; Verify Event/Element: HL7 FINAL LAB RESULT 200 ; 201 ; 202 N OCXRES 203 I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37) 204 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5)) 205 Q 0 206 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ12.m
r613 r623 1 OCXOZ12 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R69R1B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 R70R1A 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 R70R1B 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 CKSUM(STR) 96 97 98 99 100 101 102 GETDATA(DFN,OCXL,OCXDFI) 103 104 105 106 107 108 LABTHRSR(OCXDUZ,OCXLAB,OCXSPEC,OCXRSLT,OCXPTDFN) 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 MCE135() 127 128 129 130 131 132 133 134 135 MCE136() 136 137 138 139 140 141 142 143 144 MCE137() 145 146 147 148 149 150 151 152 153 MCE28() 154 155 156 157 158 159 160 161 162 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 SETAP(ROOT,DD,DATA,DA) 224 225 226 227 228 229 230 1 OCXOZ12 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R69R1B ; Send Order Check, Notication messages and/or Execute code for Rule #69 'LAB THRESHOLD' Relation #1 'IF HL7 LAB RESULTS AND (GREATER THAN THRESHOLD VAL...' 14 ; Called from R69R1A+13^OCXOZ11. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; LABTHRSR( --------> LAB THRESHOLD EXCEEDED RESULTS 21 ; NEWRULE( ---------> NEW RULE MESSAGE 22 ; 23 Q:$D(OCXRULE("R69R1B")) 24 ; 25 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 26 S OCXCMSG="" 27 S OCXNMSG="["_$$GETDATA(DFN,"5^131^132",147)_"] Lab threshold exceeded - ["_$$GETDATA(DFN,"5^131^132",96)_"]" 28 ; 29 ; 30 ; Run Execute Code 31 ; 32 S OCXTMP=$$LABTHRSR(.OCXDUZ,$$GETDATA(DFN,"5^131^132",113),$$GETDATA(DFN,"5^131^132",152),$$GETDATA(DFN,"5^131^132",12),$$GETDATA(DFN,"5^131^132",37)) 33 Q:$G(OCXOERR) 34 ; 35 ; Send Notification 36 ; 37 S (OCXDUZ,OCXDATA)="",OCXNUM=0 38 I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D 39 .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) 40 .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA 41 I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D 42 .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" 43 .S OCXNUM=+$P(OCXORD,U,2) 44 S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) 45 S OCXRULE("R69R1B")="" 46 I $$NEWRULE(DFN,OCXNUM,69,1,68,OCXNMSG) D I 1 47 .D:($G(OCXTRACE)<5) EN^ORB3(68,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) 48 Q 49 ; 50 R70R1A ; Verify all Event/Elements of Rule #70 'NO ALLERGY ASSESSMENT' Relation #1 'NO ALLERGY ASSESSMENT AND (RADIOLOGY ORDER OR PHAR...' 51 ; Called from EL28+5^OCXOZ0I, and EL135+5^OCXOZ0I, and EL136+5^OCXOZ0I, and EL137+5^OCXOZ0I. 52 ; 53 Q:$G(OCXOERR) 54 ; 55 ; Local Extrinsic Functions 56 ; MCE135( ----------> Verify Event/Element: 'DIET ORDER' 57 ; MCE136( ----------> Verify Event/Element: 'NO ALLERGY ASSESSMENT' 58 ; MCE137( ----------> Verify Event/Element: 'PHARMACY ORDER' 59 ; MCE28( -----------> Verify Event/Element: 'RADIOLOGY ORDER' 60 ; 61 Q:$G(^OCXS(860.2,70,"INACT")) 62 ; 63 I $$MCE136 D 64 .I $$MCE28 D R70R1B 65 .I $$MCE137 D R70R1B 66 .I $$MCE135 D R70R1B 67 Q 68 ; 69 R70R1B ; Send Order Check, Notication messages and/or Execute code for Rule #70 'NO ALLERGY ASSESSMENT' Relation #1 'NO ALLERGY ASSESSMENT AND (RADIOLOGY ORDER OR PHAR...' 70 ; Called from R70R1A+14. 71 ; 72 Q:$G(OCXOERR) 73 ; 74 ; Local Extrinsic Functions 75 ; NEWRULE( ---------> NEW RULE MESSAGE 76 ; 77 Q:$D(OCXRULE("R70R1B")) 78 ; 79 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 80 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^32^^Patient has no allergy assessment." I 1 81 E S OCXCMSG="Patient has no allergy assessment." 82 S OCXNMSG="" 83 ; 84 ; 85 ; Run Execute Code 86 ; 87 Q:'$$NEWRULE(DFN,$J,39,1,999,"Patient has no allergy assessment.") 88 Q:$G(OCXOERR) 89 ; 90 ; Send Order Check Message 91 ; 92 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 93 Q 94 ; 95 CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM 96 ; 97 N CKSUM,PTR,ASC S CKSUM=0 98 S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 99 F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC 100 Q +CKSUM 101 ; 102 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 103 ; 104 N OCXE,VAL,PC S VAL="" 105 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 106 Q VAL 107 ; 108 LABTHRSR(OCXDUZ,OCXLAB,OCXSPEC,OCXRSLT,OCXPTDFN) ; Compiler Function: LAB THRESHOLD EXCEEDED RESULTS 109 ; 110 Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT) 0 111 ; 112 N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXOP,OCXEXCD 113 S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXSPEC 114 F OCXOP="<",">" D 115 .D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR) 116 .Q:+$G(ORERR)'=0 117 .Q:+$G(OCXX)=0 118 .S OCXPENT="" F S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT D 119 ..S OCXPVAL=OCXX(OCXPENT,OCXLABSP) 120 ..I $L(OCXPVAL) D 121 ...I $P(OCXPENT,";",2)="VA(200,",@(OCXRSLT_OCXOP_OCXPVAL) D 122 ....I +$$PPLINK^ORQPTQ1(+OCXPENT,OCXPTDFN) D 123 .....S OCXDUZ(+OCXPENT)="",OCXEXCD=1 124 Q OCXEXCD 125 ; 126 MCE135() ; Verify Event/Element: DIET ORDER 127 ; 128 ; OCXDF(37) -> PATIENT IEN data field 129 ; 130 N OCXRES 131 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(135,37)=OCXDF(37) 132 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),135)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),135)) 133 Q 0 134 ; 135 MCE136() ; Verify Event/Element: NO ALLERGY ASSESSMENT 136 ; 137 ; OCXDF(37) -> PATIENT IEN data field 138 ; 139 N OCXRES 140 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(136,37)=OCXDF(37) 141 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),136)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),136)) 142 Q 0 143 ; 144 MCE137() ; Verify Event/Element: PHARMACY ORDER 145 ; 146 ; OCXDF(37) -> PATIENT IEN data field 147 ; 148 N OCXRES 149 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(137,37)=OCXDF(37) 150 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),137)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),137)) 151 Q 0 152 ; 153 MCE28() ; Verify Event/Element: RADIOLOGY ORDER 154 ; 155 ; OCXDF(37) -> PATIENT IEN data field 156 ; 157 N OCXRES 158 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(28,37)=OCXDF(37) 159 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),28)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),28)) 160 Q 0 161 ; 162 NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number 163 ; 164 ; 165 Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 166 Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 167 S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN 168 ; 169 N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL 170 ; 171 S OCXTIME=(+$H) 172 S OCXCKSUM=$$CKSUM(OCXMESS) 173 ; 174 S OCXTSP=($H*86400)+$P($H,",",2) 175 S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) 176 ; 177 Q:(OCXTSPL>OCXTSP) 0 178 ; 179 K OCXDATA 180 S OCXDATA(OCXDFN,0)=OCXDFN 181 S OCXDATA("B",OCXDFN,OCXDFN)="" 182 S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP 183 ; 184 S OCXGR="^OCXD(860.7" 185 D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) 186 ; 187 K OCXDATA 188 S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) 189 S OCXDATA(OCXRUL,"M")=OCXMESS 190 S OCXDATA("B",OCXRUL,OCXRUL)="" 191 S OCXGR=OCXGR_","_OCXDFN_",1" 192 D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) 193 ; 194 K OCXDATA 195 S OCXDATA(OCXREL,0)=OCXREL 196 S OCXDATA("B",OCXREL,OCXREL)="" 197 S OCXGR=OCXGR_","_OCXRUL_",1" 198 D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) 199 ; 200 S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D 201 .; 202 .N OCXGR1 203 .S OCXGR1=OCXGR_","_OCXREL_",1" 204 .K OCXDATA 205 .S OCXDATA(OCXELE,0)=OCXELE 206 .S OCXDATA(OCXELE,"TIME")=OCXTIME 207 .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) 208 .S OCXDATA("B",OCXELE,OCXELE)="" 209 .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) 210 .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) 211 .; 212 .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D 213 ..N OCXGR2 214 ..S OCXGR2=OCXGR1_","_OCXELE_",1" 215 ..K OCXDATA 216 ..S OCXDATA(OCXDFI,0)=OCXDFI 217 ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) 218 ..S OCXDATA("B",OCXDFI,OCXDFI)="" 219 ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) 220 ; 221 Q 1 222 ; 223 SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data 224 M @ROOT=DATA 225 I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 226 I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) 227 ; 228 Q 229 ; 230 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ13.m
r613 r623 1 OCXOZ13 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R71R1A 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 MCE138() 29 30 31 32 33 34 35 36 37 38 39 40 41 42 MCE139() 43 44 45 46 47 48 49 50 51 OPIOID(ORPT) 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 1 OCXOZ13 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R71R1A ; Verify all Event/Elements of Rule #71 'OPIOID MEDICATIONS' Relation #1 'OPIOID MED ORDER AND DUP OPIOID MEDS' 14 ; Called from EL138+5^OCXOZ0I, and EL139+5^OCXOZ0I. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; MCE138( ----------> Verify Event/Element: 'DUP OPIOID MEDS' 20 ; MCE139( ----------> Verify Event/Element: 'OPIOID MED ORDER' 21 ; 22 Q:$G(^OCXS(860.2,71,"INACT")) 23 ; 24 I $$MCE139 D 25 .I $$MCE138 D R71R1B^OCXOZ14 26 Q 27 ; 28 MCE138() ; Verify Event/Element: DUP OPIOID MEDS 29 ; 30 ; OCXDF(158) -> DUPLICATE OPIOID MEDICATIONS TEXT data field 31 ; OCXDF(157) -> DUPLICATE OPIOID MEDICATIONS FLAG data field 32 ; OCXDF(37) -> PATIENT IEN data field 33 ; 34 N OCXRES 35 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(138,37)=OCXDF(37) 36 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),138)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),138)) 37 S OCXRES(138)=0,OCXDF(157)=$P($$OPIOID(OCXDF(37)),"^",1) I $L(OCXDF(157)) S OCXRES(138,157)=OCXDF(157) I (OCXDF(157)) 38 E Q 0 39 S OCXDF(158)=$P($$OPIOID(OCXDF(37)),"^",2),OCXRES(138)=11 M ^TMP("OCXCHK",$J,OCXDF(37),138)=OCXRES(138) 40 Q +OCXRES(138) 41 ; 42 MCE139() ; Verify Event/Element: OPIOID MED ORDER 43 ; 44 ; OCXDF(37) -> PATIENT IEN data field 45 ; 46 N OCXRES 47 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(139,37)=OCXDF(37) 48 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),139)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),139)) 49 Q 0 50 ; 51 OPIOID(ORPT) ;determine if pat is receiving opioid med 52 ; rtn 1^opioid drug 1, opioid drug 2, opioid drug3, ... 53 N ORDG,ORTN,ORNUM,ORDI,ORDCLAS,ORDERS,ORTEXT,DUP,DUPI,DUPJ,DUPLEN 54 S ORDG=0,ORTN=0,DUPI=0,DUPLEN=20 55 K ^TMP("ORR",$J) 56 S ORDG=$O(^ORD(100.98,"B","RX",ORDG)) 57 D EN^ORQ1(ORPT_";DPT(",ORDG,2,"","","",0,0) 58 N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0 59 S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 ORTN 60 F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D 61 .S X=^TMP("ORR",$J,HOR,SEQ) 62 .S ORNUM=+$P(X,";") 63 .Q:ORNUM=+$G(ORIFN) ;quit if dup med order # = current order # 64 .S ORDI=$$VALUE^ORCSAVE2(ORNUM,"DRUG") 65 .I +$G(ORDI)>0 D 66 ..S ORDCLAS=$P(^PSDRUG(ORDI,0),U,2) ;va drug class 67 ..I ($G(ORDCLAS)="CN101")!($G(ORDCLAS)="CN102") D ;opioid classes 68 ...S ORTEXT=$$FULLTEXT^ORQOR1(ORNUM) 69 ...S ORTEXT=$P(ORTEXT,U)_" ["_$P(ORTEXT,U,2)_"]" 70 ...S DUPI=DUPI+1,DUP(DUPI)=" ["_DUPI_"] "_ORTEXT 71 ...S ORTN=1 72 I DUPI>0 D 73 .S DUPLEN=$P(215/DUPI,".") 74 .F DUPJ=1:1:DUPI D 75 ..I DUPJ=1 S ORDERS=$E(DUP(DUPJ),1,DUPLEN) 76 ..E S ORDERS=ORDERS_", "_$E(DUP(DUPJ),1,DUPLEN) 77 K ^TMP("ORR",$J) 78 Q ORTN_U_$G(ORDERS) 79 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ14.m
r613 r623 1 OCXOZ14 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R71R1B 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 GETDATA(DFN,OCXL,OCXDFI) 36 37 38 39 40 1 OCXOZ14 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 ; *************************************************************** 6 ; ** Warning: This routine is automatically generated by the ** 7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** 8 ; ** will be lost the next time the rule compiler executes. ** 9 ; *************************************************************** 10 ; 11 Q 12 ; 13 R71R1B ; Send Order Check, Notication messages and/or Execute code for Rule #71 'OPIOID MEDICATIONS' Relation #1 'OPIOID MED ORDER AND DUP OPIOID MEDS' 14 ; Called from R71R1A+12^OCXOZ13. 15 ; 16 Q:$G(OCXOERR) 17 ; 18 ; Local Extrinsic Functions 19 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE 20 ; 21 Q:$D(OCXRULE("R71R1B")) 22 ; 23 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD 24 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^33^^Duplicate opioid medications: "_$$GETDATA(DFN,"138^139",158) I 1 25 E S OCXCMSG="Duplicate opioid medications: "_$$GETDATA(DFN,"138^139",158) 26 S OCXNMSG="" 27 ; 28 Q:$G(OCXOERR) 29 ; 30 ; Send Order Check Message 31 ; 32 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG 33 Q 34 ; 35 GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data 36 ; 37 N OCXE,VAL,PC S VAL="" 38 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) 39 Q VAL 40 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND.m
r613 r623 1 OCXSEND ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES ;2/22/08 12:30 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 S ; 6 N X,IOP,TOTL S TOTL=0 7 N CVER,RCNT,RSIZE,LASTFILE,HEADER1,HEADER2,HEADER3,HEADER4,HEADER5 8 N OCXASK,OCXID,OCXLIN2,OCXLIN3,OCXPATCH,OCXSCR,PARM,PARMV,DIE,DIERR,DIQ2,FCPARM,TEXT 9 I '$D(IOM) S IOP=0 D ^%ZIS K IOP 10 K ^TMP("OCXSEND",$J),^UTILITY($J),OCXPATH 11 K ^UTILITY($J),OCXPATH 12 S ^TMP("OCXSEND",$J)=($P($H,",",2)+($H*86400)+(4*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" 13 S OCXLIN2=$T(+2) 14 S OCXLIN3=$T(+3) 15 ; 16 D ^OCXSEND1 ; Get List of Objects to Transport 17 ; 18 I '$O(^TMP("OCXSEND",$J,"LIST",0)) K ^TMP("OCXSEND",$J) Q ; Nothing selected so Quit 19 ; 20 S OCXASK="" F D Q:$L(OCXASK) 21 .W ! 22 .W !,"When the transport routine encounters locally" 23 .W !,"altered rule data at a site, do you want to:" 24 .; 25 .S OCXASK=$$READ("S^O:Overwrite local data;D:Display locally altered data only;A:Ask the site what to do","(O)verwrite, (D)isplay, or (A)sk the site ? ","Ask") 26 ; 27 Q:(OCXASK[U) 28 I (OCXASK="O") W !!,"Locally altered data will be overwritten without asking.",!! 29 I (OCXASK="D") W !!,"Locally altered data will be displayed only.",!! 30 I (OCXASK="A") W !!,"Sites will be asked before locally altered data is overwritten.",!! 31 ; 32 S OCXPATCH="" F D Q:$L(OCXPATCH) 33 .W !!,"Enter Patch ID (ex. OR*3*96): " R OCXPATCH:DTIME E S OCXPATCH="^" Q 34 .Q:(OCXPATCH="^") 35 .I '$L(OCXPATCH) S OCXPATCH="^^" Q 36 .I $L(OCXPATCH),'(OCXPATCH?1"OR*"1N1"*"1.4N) D S OCXPATCH="" Q 37 ..W !! 38 ..W:'(OCXPATCH["?") "Invalid" 39 ..W " Format -> OR*v*ppp" 40 ..W !," v = Package Version." 41 ..W !," ppp = Patch Number." 42 ..W ! 43 Q:(OCXPATCH="^") 44 S:(OCXPATCH="^^") OCXPATCH="" 45 I $P(OCXPATCH,"*",3) S $P(OCXLIN2,";",5)="**"_$P(OCXPATCH,"*",3)_"**" 46 I $L(OCXPATCH) S OCXPATCH="(Delete after Install of "_OCXPATCH_")" 47 ; 48 Q:'$$RSDEL 49 ; 50 D ^OCXSEND2 ; Get File Data 51 ; 52 S TOTL=$$EN^OCXSEND3 ; File Routines 53 ; 54 S TOTL=TOTL+$$EN^OCXSENDA ; File Main Runtime Library Routine 55 ; 56 S TOTL=TOTL+$$EN^OCXSEND4 ; File Utility Runtime Library Routine 0 57 ; 58 S TOTL=TOTL+$$EN^OCXSEND5 ; File Utility Runtime Library Routine 1 59 ; 60 S TOTL=TOTL+$$EN^OCXSEND6 ; File Utility Runtime Library Routine 2 61 ; 62 S TOTL=TOTL+$$EN^OCXSEND7 ; File Utility Runtime Library Routine 3 63 ; 64 S TOTL=TOTL+$$EN^OCXSEND8 ; File Utility Runtime Library Routine 4 65 ; 66 EXIT K ^TMP("OCXSEND",$J),^UTILITY($J) 67 ; 68 W !!,"Routines filed.",!! 69 ; 70 Q 71 ; 72 READ(OCX0,OCXA,OCXB,OCXL) ; 73 N X,DIR,DTOUT,DUOUT,DIRUT,DIROUT 74 Q:'$L($G(OCX0)) U 75 S DIR(0)=OCX0 76 S:$L($G(OCXA)) DIR("A")=OCXA 77 S:$L($G(OCXB)) DIR("B")=OCXB 78 F X=1:1:($G(OCXL)-1) W ! 79 D ^DIR 80 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U 81 Q Y 82 ; 83 CUCI() Q:'$D(^%ZOSF("UCI")) "" N Y X ^%ZOSF("UCI") Q Y 84 ; 85 NETNAME() ; 86 N NETNAME 87 S NETNAME=$P($$NETNAME^XMXUTIL(DUZ),"@",2) 88 I $L(NETNAME) Q NETNAME 89 ; Q:$L($G(^XMB("NETNAME"))) ^XMB("NETNAME") 90 ; Q:$L($G(^XMB("NAME"))) ^XMB("NAME") 91 Q $$CUCI 92 ; 93 RSDEL() ; 94 ; 95 W !!,"Scanning for old rule transport routines..." 96 N X,CNT,RCNT,RLIST,RNAME 97 S RCNT=0 98 ; 99 ; Scan for Routines To Delete 100 ; 101 ; Main Routine 102 S RNAME=$$RNAME^OCXSEND3(0,0) I $$RFIND(RNAME,100) S RLIST(RNAME)="" 103 ; 104 ; Runtime Library routines 105 F CNT=0:1:35 S RNAME=$$RNAME^OCXSEND3(CNT,1) I $$RFIND(RNAME,CNT) S RLIST(RNAME)="" 106 ; 107 ; Data Routines 108 F CNT=0:1:46655 S RNAME=$$RNAME^OCXSEND3(CNT,2) I $$RFIND(RNAME,CNT) S RLIST(RNAME)="" 109 ; 110 I '$L($O(RLIST(""))) W !,"No old rule transport routines found..." H 2 Q 1 111 ; 112 W !!,"These routines will be deleted and overwritten." 113 Q:'$$READ("Y"," Do you want to proceed?","NO") 0 114 ; 115 ; Delete The routines 116 ; 117 I '$D(^%ZOSF("DEL")) W !!,"Old rule transport routines not deleted (^%ZOSF(""DEL"") undefined)" Q 0 118 ; 119 S RNAME="" F RCNT=1:1 S RNAME=$O(RLIST(RNAME)) Q:'$L(RNAME) D 120 .W !,RNAME 121 .I $$RDEL(RNAME) W " Deleted..." Q 122 .W " Not Deleted..." 123 ; 124 W !!,RCNT," routine",$S((RCNT=1):"",1:"s")," deleted." 125 ; 126 H 2 Q 1 127 ; 128 RFIND(X,C) ; 129 W:($X>70) ! W:'(C#100) "." 130 Q:'$L(X) 0 X "S TEXT=$T(+1^"_X_")" Q:'$L(TEXT) 0 131 W !,X Q 1 132 Q 133 ; 134 RDEL(X) ; 135 ; 136 Q:'$L(X) 0 X "S TEXT=$T(+1^"_X_")" Q:'$L(TEXT) 0 137 X ^%ZOSF("DEL") Q 1 138 ; 1 OCXSEND ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES ;2/01/01 10:10 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 S ; 6 N X,IOP,TOTL S TOTL=0 7 N CVER,RCNT,RSIZE,LASTFILE,HEADER1,HEADER2,HEADER3,HEADER4,HEADER5 8 N OCXASK,OCXID,OCXLIN2,OCXLIN3,OCXPATCH,OCXSCR,PARM,PARMV,DIE,DIERR,DIQ2,FCPARM,TEXT 9 I '$D(IOM) S IOP=0 D ^%ZIS K IOP 10 K ^TMP("OCXSEND",$J),^UTILITY($J),OCXPATH 11 K ^UTILITY($J),OCXPATH 12 S ^TMP("OCXSEND",$J)=($P($H,",",2)+($H*86400)+(4*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" 13 S OCXLIN2=$T(+2) 14 S OCXLIN3=$T(+3) 15 ; 16 D ^OCXSEND1 ; Get List of Objects to Transport 17 ; 18 I '$O(^TMP("OCXSEND",$J,"LIST",0)) K ^TMP("OCXSEND",$J) Q ; Nothing selected so Quit 19 ; 20 S OCXASK="" F D Q:$L(OCXASK) 21 .W ! 22 .W !,"When the transport routine encounters locally" 23 .W !,"altered rule data at a site, do you want to:" 24 .; 25 .S OCXASK=$$READ("S^O:Overwrite local data;D:Display locally altered data only;A:Ask the site what to do","(O)verwrite, (D)isplay, or (A)sk the site ? ","Ask") 26 ; 27 Q:(OCXASK[U) 28 I (OCXASK="O") W !!,"Locally altered data will be overwritten without asking.",!! 29 I (OCXASK="D") W !!,"Locally altered data will be displayed only.",!! 30 I (OCXASK="A") W !!,"Sites will be asked before locally altered data is overwritten.",!! 31 ; 32 S OCXPATCH="" F D Q:$L(OCXPATCH) 33 .W !!,"Enter Patch ID (ex. OR*3*96): " R OCXPATCH:DTIME E S OCXPATCH="^" Q 34 .Q:(OCXPATCH="^") 35 .I '$L(OCXPATCH) S OCXPATCH="^^" Q 36 .I $L(OCXPATCH),'(OCXPATCH?1"OR*"1N1"*"1.4N) D S OCXPATCH="" Q 37 ..W !! 38 ..W:'(OCXPATCH["?") "Invalid" 39 ..W " Format -> OR*v*ppp" 40 ..W !," v = Package Version." 41 ..W !," ppp = Patch Number." 42 ..W ! 43 Q:(OCXPATCH="^") 44 S:(OCXPATCH="^^") OCXPATCH="" 45 I $P(OCXPATCH,"*",3) S $P(OCXLIN2,";",5)="**"_$P(OCXPATCH,"*",3)_"**" 46 I $L(OCXPATCH) S OCXPATCH="(Delete after Install of "_OCXPATCH_")" 47 ; 48 Q:'$$RSDEL 49 ; 50 D ^OCXSEND2 ; Get File Data 51 ; 52 S TOTL=$$EN^OCXSEND3 ; File Routines 53 ; 54 S TOTL=TOTL+$$EN^OCXSENDA ; File Main Runtime Library Routine 55 ; 56 S TOTL=TOTL+$$EN^OCXSEND4 ; File Utility Runtime Library Routine 0 57 ; 58 S TOTL=TOTL+$$EN^OCXSEND5 ; File Utility Runtime Library Routine 1 59 ; 60 S TOTL=TOTL+$$EN^OCXSEND6 ; File Utility Runtime Library Routine 2 61 ; 62 S TOTL=TOTL+$$EN^OCXSEND7 ; File Utility Runtime Library Routine 3 63 ; 64 S TOTL=TOTL+$$EN^OCXSEND8 ; File Utility Runtime Library Routine 4 65 ; 66 EXIT K ^TMP("OCXSEND",$J),^UTILITY($J) 67 ; 68 W !!,TOTL," total lines of code filed.",!! 69 ; 70 Q 71 ; 72 READ(OCX0,OCXA,OCXB,OCXL) ; 73 N X,DIR,DTOUT,DUOUT,DIRUT,DIROUT 74 Q:'$L($G(OCX0)) U 75 S DIR(0)=OCX0 76 S:$L($G(OCXA)) DIR("A")=OCXA 77 S:$L($G(OCXB)) DIR("B")=OCXB 78 F X=1:1:($G(OCXL)-1) W ! 79 D ^DIR 80 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U 81 Q Y 82 ; 83 CUCI() Q:'$D(^%ZOSF("UCI")) "" N Y X ^%ZOSF("UCI") Q Y 84 ; 85 NETNAME() ; 86 Q:$L($G(^XMB("NETNAME"))) ^XMB("NETNAME") 87 Q:$L($G(^XMB("NAME"))) ^XMB("NAME") 88 Q $$CUCI 89 ; 90 RSDEL() ; 91 ; 92 W !!,"Scanning for old rule transport routines..." 93 N X,CNT,RCNT,RLIST,RNAME 94 S RCNT=0 95 ; 96 ; Scan for Routines To Delete 97 ; 98 ; Main Routine 99 S RNAME=$$RNAME^OCXSEND3(0,0) I $$RFIND(RNAME,100) S RLIST(RNAME)="" 100 ; 101 ; Runtime Library routines 102 F CNT=0:1:35 S RNAME=$$RNAME^OCXSEND3(CNT,1) I $$RFIND(RNAME,CNT) S RLIST(RNAME)="" 103 ; 104 ; Data Routines 105 F CNT=0:1:46655 S RNAME=$$RNAME^OCXSEND3(CNT,2) I $$RFIND(RNAME,CNT) S RLIST(RNAME)="" 106 ; 107 I '$L($O(RLIST(""))) W !,"No old rule transport routines found..." H 2 Q 1 108 ; 109 W !!,"These routines will be deleted and overwritten." 110 Q:'$$READ("Y"," Do you want to proceed?","NO") 0 111 ; 112 ; Delete The routines 113 ; 114 I '$D(^%ZOSF("DEL")) W !!,"Old rule transport routines not deleted (^%ZOSF(""DEL"") undefined)" Q 0 115 ; 116 S RNAME="" F RCNT=1:1 S RNAME=$O(RLIST(RNAME)) Q:'$L(RNAME) D 117 .W !,RNAME 118 .I $$RDEL(RNAME) W " Deleted..." Q 119 .W " Not Deleted..." 120 ; 121 W !!,RCNT," routine",$S((RCNT=1):"",1:"s")," deleted." 122 ; 123 H 2 Q 1 124 ; 125 RFIND(X,C) ; 126 W:($X>70) ! W:'(C#100) "." 127 Q:'$L(X) 0 X "S TEXT=$T(+1^"_X_")" Q:'$L(TEXT) 0 128 W !,X Q 1 129 Q 130 ; 131 RDEL(X) ; 132 ; 133 Q:'$L(X) 0 X "S TEXT=$T(+1^"_X_")" Q:'$L(TEXT) 0 134 X ^%ZOSF("DEL") Q 1 135 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND3.m
r613 r623 1 OCXSEND3 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Routines) ;1/31/01 08:51 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105,243**;Dec 17,1997;Build 242 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 EN() ; 6 ; 7 N LAST,RLINE,RNUM,RTEXT,TOTLINE 8 K ^TMP("OCXSEND",$J,"RTN") S ^TMP("OCXSEND",$J,"RTN",100,0)=" ;" 9 S (TOTLINE,RSIZE,RLINE,RCNT)=0,RNUM=1 F S RLINE=$O(^TMP("OCXSEND",$J,"DATA",RLINE)) Q:'RLINE D 10 .S RTEXT=$G(^TMP("OCXSEND",$J,"DATA",RLINE)) Q:'$L(RTEXT) 11 .S LAST=$O(^TMP("OCXSEND",$J,"RTN",""),-1)+1,RCNT=RCNT+1,RSIZE=RSIZE+$L(RTEXT) 12 .S ^TMP("OCXSEND",$J,"RTN",LAST,0)=" ;;"_RTEXT 13 .I (RSIZE>6000) S TOTLINE=TOTLINE+$$RFILE($O(^TMP("OCXSEND",$J,"DATA",RLINE)),.RNUM) S (RSIZE,RCNT)=0 14 I $O(^TMP("OCXSEND",$J,"RTN",100)) S TOTLINE=TOTLINE+$$RFILE(0,.RNUM) 15 ; 16 Q TOTLINE 17 ; 18 RFILE(LINK,RNUM) ; 19 ; 20 N DIE,LAST,X,XCN 21 D HDR(LINK,RNUM) 22 S LAST=$O(^TMP("OCXSEND",$J,"RTN",""),-1)+1 23 S ^TMP("OCXSEND",$J,"RTN",LAST,0)=" ;1;" 24 S ^TMP("OCXSEND",$J,"RTN",LAST+1,0)=" ;" 25 S ^TMP("OCXSEND",$J,"RTN",LAST+2,0)="$" 26 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0 27 S X=$$RNAME(RNUM,2) 28 W !,X 29 X ^%ZOSF("SAVE") 30 S RNUM=RNUM+1 31 K ^TMP("OCXSEND",$J,"RTN") S ^TMP("OCXSEND",$J,"RTN",100,0)=" ;" 32 Q "" 33 ; 34 NOW() ; 35 N X,Y,%DT 36 S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) 37 I (Y["@") S Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) 38 Q Y 39 ; 40 HDR(LINK,RNUM) ; 41 ; 42 N R,LINE,TEXT,RNAME,RLINK,NOW 43 S NOW=$$NOW 44 I 'LINK S RLINK=";" 45 E S RLINK="G ^"_$$RNAME(RNUM+1,2) 46 S RNAME=$$RNAME(RNUM,2),(HEADER1,HEADER2,HEADER3,HEADER4,HEADER5)=";" 47 ; 48 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV(TEXT) 49 ; 50 M ^TMP("OCXSEND",$J,"RTN")=R 51 ; 52 Q 53 ; 54 HEX(X) Q:'X "" Q $$HEX(X\36)_$E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",((X#36)+1)) 55 ; 56 RNAME(X,Y) ; 57 ; Y=0 -> Main Routine 58 ; Y=1 -> Runtime Library Routine 59 ; Y=2 -> Data Routine for ORYppp 60 ; Y=3 -> Data Routine for OCXRU 61 ; 62 N OCXRN1,OCXRN2,OCXSEQ 63 ; 64 S OCXRN1="OCXRULE",OCXRN2="OCXRU" 65 S:$L($G(OCXPATCH)) OCXRN2="ORY"_$E((1000+$P(OCXPATCH,"*",3)),2,4),OCXRN1=OCXRN2_"ES" 66 ; 67 Q:'Y OCXRN1 68 ; 69 I (Y=1),(X>35) Q "" 70 I (Y=2),'$L($G(OCXPATCH)) S Y=3 71 I (Y=2),(X>1295) Q "" 72 I (Y=3),(X>46655) Q "" 73 ; 74 S OCXSEQ=0 S:X OCXSEQ=$$HEX(X) 75 S OCXSEQ="00000"_OCXSEQ 76 S OCXSEQ=$E(OCXSEQ,($L(OCXSEQ)-Y+1),$L(OCXSEQ)) 77 ; 78 Q OCXRN2_OCXSEQ 79 ; 80 CONV(X) ; 81 N VAL 82 F Q:'(X["|") D 83 .S VAL=$P(X,"|",2) 84 .X "S VAL="_VAL 85 .S X=$P(X,"|",1)_VAL_$P(X,"|",3,999) 86 I '(X="$"),'$L($P(X," ",2)) S X=X_" ;" 87 Q X 88 ; 89 TEXT ; 90 ;;|RNAME| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| 91 ;;|OCXLIN2| 92 ;;|OCXLIN3| 93 ;; ; 94 ;;S ; 95 ;; ; 96 ;; D DOT^|$$RNAME^OCXSEND3(0,0)| 97 ;; ; 98 ;; ; 99 ;; K REMOTE,LOCAL,OPCODE,REF 100 ;; F LINE=1:1:500 S TEXT=$P($T(DATA+LINE),";",2,999) Q:TEXT I $L(TEXT) D Q:QUIT 101 ;; .S ^TMP("OCXRULE",$J,$O(^TMP("OCXRULE",$J,"A"),-1)+1)=TEXT 102 ;; ; 103 ;; |RLINK| 104 ;; ; 105 ;; Q 106 ;; ; 107 ;;DATA ; 108 ;1; 109 ; 1 OCXSEND3 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Routines) ;1/31/01 08:51 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 EN() ; 6 ; 7 N LAST,RLINE,RNUM,RTEXT,TOTLINE 8 K ^TMP("OCXSEND",$J,"RTN") S ^TMP("OCXSEND",$J,"RTN",100,0)=" ;" 9 S (TOTLINE,RSIZE,RLINE,RCNT)=0,RNUM=1 F S RLINE=$O(^TMP("OCXSEND",$J,"DATA",RLINE)) Q:'RLINE D 10 .S RTEXT=$G(^TMP("OCXSEND",$J,"DATA",RLINE)) Q:'$L(RTEXT) 11 .S LAST=$O(^TMP("OCXSEND",$J,"RTN",""),-1)+1,RCNT=RCNT+1,RSIZE=RSIZE+$L(RTEXT) 12 .S ^TMP("OCXSEND",$J,"RTN",LAST,0)=" ;;"_RTEXT 13 .I (RSIZE>6000) S TOTLINE=TOTLINE+$$RFILE($O(^TMP("OCXSEND",$J,"DATA",RLINE)),.RNUM) S (RSIZE,RCNT)=0 14 I $O(^TMP("OCXSEND",$J,"RTN",100)) S TOTLINE=TOTLINE+$$RFILE(0,.RNUM) 15 ; 16 Q TOTLINE 17 ; 18 RFILE(LINK,RNUM) ; 19 ; 20 N DIE,LAST,X,XCN,XCM 21 D HDR(LINK,RNUM) 22 S LAST=$O(^TMP("OCXSEND",$J,"RTN",""),-1)+1 23 S ^TMP("OCXSEND",$J,"RTN",LAST,0)=" ;1;" 24 S ^TMP("OCXSEND",$J,"RTN",LAST+1,0)=" ;" 25 S ^TMP("OCXSEND",$J,"RTN",LAST+2,0)="$" 26 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0 27 S X=$$RNAME(RNUM,2) 28 W !,X 29 X ^%ZOSF("SAVE") 30 W " ... ",XCM," Lines filed" 31 S RNUM=RNUM+1 32 K ^TMP("OCXSEND",$J,"RTN") S ^TMP("OCXSEND",$J,"RTN",100,0)=" ;" 33 Q XCM 34 ; 35 NOW() ; 36 N X,Y,%DT 37 S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) 38 I (Y["@") S Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) 39 Q Y 40 ; 41 HDR(LINK,RNUM) ; 42 ; 43 N R,LINE,TEXT,RNAME,RLINK,NOW 44 S NOW=$$NOW 45 I 'LINK S RLINK=";" 46 E S RLINK="G ^"_$$RNAME(RNUM+1,2) 47 S RNAME=$$RNAME(RNUM,2),(HEADER1,HEADER2,HEADER3,HEADER4,HEADER5)=";" 48 ; 49 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV(TEXT) 50 ; 51 M ^TMP("OCXSEND",$J,"RTN")=R 52 ; 53 Q 54 ; 55 HEX(X) Q:'X "" Q $$HEX(X\36)_$E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",((X#36)+1)) 56 ; 57 RNAME(X,Y) ; 58 ; Y=0 -> Main Routine 59 ; Y=1 -> Runtime Library Routine 60 ; Y=2 -> Data Routine for ORYppp 61 ; Y=3 -> Data Routine for OCXRU 62 ; 63 N OCXRN1,OCXRN2,OCXSEQ 64 ; 65 S OCXRN1="OCXRULE",OCXRN2="OCXRU" 66 S:$L($G(OCXPATCH)) OCXRN2="ORY"_$E((1000+$P(OCXPATCH,"*",3)),2,4),OCXRN1=OCXRN2_"ES" 67 ; 68 Q:'Y OCXRN1 69 ; 70 I (Y=1),(X>35) Q "" 71 I (Y=2),'$L($G(OCXPATCH)) S Y=3 72 I (Y=2),(X>1295) Q "" 73 I (Y=3),(X>46655) Q "" 74 ; 75 S OCXSEQ=0 S:X OCXSEQ=$$HEX(X) 76 S OCXSEQ="00000"_OCXSEQ 77 S OCXSEQ=$E(OCXSEQ,($L(OCXSEQ)-Y+1),$L(OCXSEQ)) 78 ; 79 Q OCXRN2_OCXSEQ 80 ; 81 CONV(X) ; 82 N VAL 83 F Q:'(X["|") D 84 .S VAL=$P(X,"|",2) 85 .X "S VAL="_VAL 86 .S X=$P(X,"|",1)_VAL_$P(X,"|",3,999) 87 I '(X="$"),'$L($P(X," ",2)) S X=X_" ;" 88 Q X 89 ; 90 TEXT ; 91 ;;|RNAME| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| 92 ;;|OCXLIN2| 93 ;;|OCXLIN3| 94 ;; ; 95 ;;S ; 96 ;; ; 97 ;; D DOT^|$$RNAME^OCXSEND3(0,0)| 98 ;; ; 99 ;; ; 100 ;; K REMOTE,LOCAL,OPCODE,REF 101 ;; F LINE=1:1:500 S TEXT=$P($T(DATA+LINE),";",2,999) Q:TEXT I $L(TEXT) D Q:QUIT 102 ;; .S ^TMP("OCXRULE",$J,$O(^TMP("OCXRULE",$J,"A"),-1)+1)=TEXT 103 ;; ; 104 ;; |RLINK| 105 ;; ; 106 ;; Q 107 ;; ; 108 ;;DATA ; 109 ;1; 110 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND4.m
r613 r623 1 OCXSEND4 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105,243**;Dec 17,1997;Build 242 3 4 5 EN() 6 7 N R,LINE,TEXT,NOW,RUCI 8 9 10 11 12 13 14 W !,X X ^%ZOSF("SAVE")K ^TMP("OCXSEND",$J,"RTN")15 16 Q " " 17 18 TEXT 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 1 OCXSEND4 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 0) ;2/01/01 09:56 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 EN() ; 6 ; 7 N R,LINE,TEXT,NOW,RUCI,XCM 8 S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND 9 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) 10 ; 11 M ^TMP("OCXSEND",$J,"RTN")=R 12 ; 13 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(0,1) 14 W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN") 15 ; 16 Q XCM 17 ; 18 TEXT ; 19 ;;|$$RNAME^OCXSEND3(0,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| 20 ;;|OCXLIN2| 21 ;;|OCXLIN3| 22 ;; ; 23 ;;S ; 24 ;; ; 25 ;; Q 26 ;; ; 27 ;;WARN(RTN,MSG,LINES) ; 28 ;; ; 29 ;; Q:$G(OCXAUTO) 30 ;; ; 31 ;; N DASH,LINE,NLINE,PLINE 32 ;; ; 33 ;; S DASH="",$P(DASH,"-",(55-$L(MSG)-2))="-" 34 ;; W !!,"--------------",MSG,DASH 35 ;; ; 36 ;; W !,RTN,?10,"[|RUCI|] -> [",$$NETNAME^OCXSEND,"] Line" 37 ;; ; 38 ;; I $O(LINES($O(LINES(0)))) W "s: " 39 ;; E W ": " 40 ;; ; 41 ;; S LINE=0 F S LINE=$O(LINES(LINE)) Q:'LINE D 42 ;; .W:($X>60) !,?40 43 ;; .S NLINE=LINE F S PLINE=NLINE,NLINE=$O(LINES(NLINE)) Q:(NLINE-PLINE-1) 44 ;; .I (PLINE=LINE) W " ",LINE 45 ;; .E W " ",LINE,"-",PLINE S LINE=PLINE 46 ;; ; 47 ;; W ! Q 48 ;; ; 49 ;;TEXT(RTN,LINE) ; 50 ;; ; 51 ;; N TEXT X "S TEXT=$T(+"_(+LINE)_"^"_RTN_")" Q TEXT 52 ;; ; 53 ;;HEADER ; 54 ;; ; 55 ;; W !," Created: |NOW| at |RUCI|" 56 ;; W !," Current Date: ",$$NOW," at ",$$NETNAME^OCXSEND,!! 57 ;; S LASTFILE=0 K ^TMP("OCXRULE",$J) 58 ;; S ^TMP("OCXRULE",$J)=($P($H,",",2)+($H*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" 59 ;; Q 60 ;; ; 61 ;;GETFILE(FILE,RECNAME,ARRAY) ; 62 ;; ; 63 ;; N CHECK,GLNEXT,GLREF,LINES,REC,DD,FLD 64 ;; S REC=$$LOOKUP(FILE,RECNAME) 65 ;; I 'REC W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME Q 0 66 ;; I (REC=-1) W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME," duplicate local entries.",! Q 0 67 ;; I (REC=-2) W !!,$$FILENAME^OCXSENDD(FILE)," (",FILE,") local file not found." W ! Q:$$PAUSE -10 Q REC 68 ;; I (REC<0) W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME," unknown lookup error." W ! Q:$$PAUSE -10 Q REC 69 ;; I (REC>0) D 70 ;; .S CHECK=0,LINES=0 71 ;; .D GETREC($$FILE^OCXSENDD(FILE,"GLOBAL NAME"),"ARRAY(",REC,.ARRAY) 72 ;; .S GLREF="ARRAY" F S GLREF=$Q(@GLREF) Q:'$L(GLREF) Q:'($E(GLREF,1,6)="ARRAY(") K:'$L(@GLREF) @GLREF 73 ;; ; 74 ;; Q REC 75 ;; ; 76 ;;LKUPARRY(DD,KEY,ARRAY) ; 77 ;; ; 78 ;; N D0 S D0=0 F S D0=$O(ARRAY(DD,D0)) Q:'D0 Q:($G(ARRAY(DD,D0,.01,"E"))=KEY) 79 ;; Q D0 80 ;; ; 81 ;;LOOKUP(FILE,KEY) ; 82 ;; I $O(^TMP("OCXRULE",$J,"B",FILE,KEY,0)) Q 0 83 ;; N RECNAM,REC,D0,CNT,SHORT S (REC,CNT)=0 84 ;; S GL=$$FILE^OCXSENDD(FILE,"GLOBAL NAME") Q:'$L(GL) -2 S GL=$E(GL,1,$L(GL)-1)_")" 85 ;; S SHORT=$E(KEY,1,30),RECNAM=SHORT D F S RECNAM=$O(@GL@("B",RECNAM)) Q:'$L(RECNAM) Q:'($E(RECNAM,1,$L(SHORT))=SHORT) D 86 ;; .S D0=0 F S D0=$O(@GL@("B",RECNAM,D0)) Q:'D0 I ($P($G(@GL@(D0,0)),U,1)=KEY) S CNT=CNT+1,REC=D0_U_RECNAME 87 ;; Q:(CNT>1) -1 88 ;; S:$L($P(REC,U,2)) ^TMP("OCXRULE",$J,"A",FILE,$P(REC,U,2))="" 89 ;; Q +REC 90 ;; ; 91 ;;GETREC(GL,PATH,D0,REM) ; 92 ;; ; 93 ;; Q:'($P($G(@(GL_"0)")),U,2)) 94 ;; N S1,DATA,DD 95 ;; S DATA="" D DIQ(GL,D0,.DATA) 96 ;; S DD=$O(DATA(0)) Q:'DD 97 ;; ; 98 ;; I $L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_""""_DD_":"_D0_"""" 99 ;; I '$L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_","""_DD_":"_D0_"""" 100 ;; M @(PATH_")")=DATA(DD,D0) 101 ;; ; 102 ;; S S1="" F S S1=$O(@(GL_D0_","_$$SUB(S1)_")")) Q:'$L(S1) I ($D(@(GL_D0_","_$$SUB(S1)_")"))>3) D 103 ;; .N D1,GLREF S GLREF=GL_D0_","_$$SUB(S1)_"," 104 ;; .S D1=0 F S D1=$O(@(GLREF_D1_")")) Q:'D1 D GETREC(GLREF,PATH,D1,.REM) 105 ;; ; 106 ;; Q 107 ;; ; 108 ;;SUB(X) Q:'(X=+X) """"_X_"""" Q X 109 ;; ; 110 ;;DIQ(DIC,DA,OCXARY) ; 111 ;; N DR,DIQ S DR=".01:99999",DIQ="OCXARY(",DIQ(0)="EN" D EN^DIQ1 112 ;; Q 113 ;; ; 114 ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) 115 ;; ; 116 ;;NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y 117 ;; ; 118 ;;$ 119 ;1; 120 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND5.m
r613 r623 1 OCXSEND5 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105,243**;Dec 17,1997;Build 242 3 4 5 EN() 6 7 N R,LINE,TEXT,NOW,RUCI 8 9 10 11 12 13 14 W !,X X ^%ZOSF("SAVE")K ^TMP("OCXSEND",$J,"RTN")15 16 Q " " 17 18 TEXT 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 1 OCXSEND5 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 1) ;2/01/01 09:56 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 EN() ; 6 ; 7 N R,LINE,TEXT,NOW,RUCI,XCM 8 S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND 9 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) 10 ; 11 M ^TMP("OCXSEND",$J,"RTN")=R 12 ; 13 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(1,1) 14 W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN") 15 ; 16 Q XCM 17 ; 18 TEXT ; 19 ;;|$$RNAME^OCXSEND3(1,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| 20 ;;|OCXLIN2| 21 ;;|OCXLIN3| 22 ;; ; 23 ;;S ; 24 ;; ; 25 ;; Q 26 ;; ; 27 ;; ; 28 ;;COMPARE(L,R) ; 29 ;; ; 30 ;; Q:$$RES("R") 1 31 ;; ; 32 ;; Q:'$L($O(L(""))) $$ADDREC^|$$RNAME^OCXSEND3(2,1)|("R") 33 ;; ; 34 ;; N C,OCXDD M C=L,C=R S OCXDD=$O(C("")) Q $$MULT("C",OCXDD) 35 ;; ; 36 ;; Q 0 37 ;; ; 38 ;;RES(REF) ; 39 ;; ; 40 ;; N QUIT,SUB 41 ;; S QUIT=0 42 ;; S SUB="" F S SUB=$O(@REF@(SUB)) Q:'$L(SUB) I (SUB[":") D Q:QUIT 43 ;; .N DD,DA 44 ;; .S DD=$P(SUB,":",1),DA=$P(SUB,":",2) 45 ;; .I $L(DA),'(DA=+DA) D Q:QUIT 46 ;; ..N DANEW,SUBNEW 47 ;; ..S DANEW=$O(^OCXS($P(DA,U,2),"B",$P(DA,U,1),0)) 48 ;; ..I 'DANEW W !!,$P($G(^OCXS(+$P(DA,U,2),0)),U,1),": ",$P(DA,U,1)," could not resolve name.",!!," End Transport." S QUIT=1 Q 49 ;; ..S SUBNEW=DD_":"_DANEW 50 ;; ..I $D(@REF@(SUBNEW)) W !!," multiple #",DANEW," already existed." S QUIT=1 Q 51 ;; ..M @REF@(SUBNEW)=@REF@(SUB) 52 ;; ..K @REF@(SUB) 53 ;; ..S SUB="" 54 ;; .I $L(SUB),($D(@REF@(SUB))>9) S QUIT=$$RES($NA(@REF@(SUB))) 55 ;; ; 56 ;; Q QUIT 57 ;; ; 58 ;;MULT(CREF,OCXDD) ; 59 ;; ; 60 ;; N OCXSUB,LREF,RREF,QUIT,OCXFLD 61 ;; S LREF="L"_$E(CREF,2,$L(CREF)),RREF="R"_$E(CREF,2,$L(CREF)) 62 ;; ; 63 ;; S QUIT=0,OCXFLD="" F S OCXFLD=$O(@CREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) D Q:QUIT 64 ;; .I (OCXFLD[":") D Q:QUIT 65 ;; ..Q:$$EXFLD(+OCXFLD,0) 66 ;; ..I '$D(@LREF@(OCXDD,OCXFLD,.01,"E")) D M @LREF@(OCXDD,OCXFLD)=@RREF@(OCXDD,OCXFLD) 67 ;; ...D WARN("Missing multiple:",CREF,OCXDD,OCXFLD) 68 ;; ...S QUIT=$$ADDMULT^|$$RNAME^OCXSEND3(3,1)|(CREF,OCXDD,OCXFLD) 69 ;; ..I '$D(@RREF@(OCXDD,OCXFLD,.01,"E")) D M @RREF@(OCXDD,OCXFLD)=@LREF@(OCXDD,OCXFLD) 70 ;; ...D WARN("Extra multiple:",CREF,OCXDD,OCXFLD) 71 ;; ...S QUIT=$$DELMULT^|$$RNAME^OCXSEND3(3,1)|($$APPEND(CREF,OCXDD),OCXFLD) 72 ;; .; 73 ;; .I (OCXFLD=+OCXFLD),'$$EXFLD(+OCXDD,OCXFLD) D 74 ;; ..I ($O(@CREF@(OCXDD,OCXFLD,""))="E") D Q 75 ;; ...I $L($G(@RREF@(OCXDD,OCXFLD,"E"))),'$L($G(@LREF@(OCXDD,OCXFLD,"E"))) D Q 76 ;; ....D WARN("Data Value Missing in "_$$NETNAME^OCXSEND,CREF,OCXDD,OCXFLD,"E") 77 ;; ....S QUIT=$$EDITFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E") 78 ;; ...I $L($G(@LREF@(OCXDD,OCXFLD,"E"))),'$L($G(@RREF@(OCXDD,OCXFLD,"E"))) D Q 79 ;; ....D WARN("Extra Data Value in "_$$NETNAME^OCXSEND,CREF,OCXDD,OCXFLD,"E") 80 ;; ....S QUIT=$$DELFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E") 81 ;; ...I '(@LREF@(OCXDD,OCXFLD,"E")=@RREF@(OCXDD,OCXFLD,"E")) D 82 ;; ....D WARN("Inconsistent Data",CREF,OCXDD,OCXFLD,"E") 83 ;; ....S QUIT=$$EDITFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E") 84 ;; ..S OCXSUB=0 F Q:QUIT S OCXSUB=$O(@CREF@(OCXDD,OCXFLD,OCXSUB)) Q:'OCXSUB I '($G(@RREF@(OCXDD,OCXFLD,OCXSUB))=$G(@LREF@(OCXDD,OCXFLD,OCXSUB))) D Q 85 ;; ...D WARN("Inconsistent word Data",CREF,OCXDD,OCXFLD,OCXSUB) 86 ;; ...S QUIT=$$LOADWORD^|$$RNAME^OCXSEND3(2,1)|(RREF,OCXDD,OCXFLD,OCXSUB) 87 ;; .; 88 ;; .I 'QUIT,(OCXFLD[":") S QUIT=$$MULT($$APPEND(CREF,OCXDD),OCXFLD) 89 ;; Q QUIT 90 ;; ; 91 ;;APPEND(ARRAY,OCXSUB) ; 92 ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_"""" 93 ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")" 94 ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")" 95 ;; ; 96 ;;EXFLD(FILE,OCXFLD) ; 97 ;; N OCXFNAM 98 ;; S OCXFNAM=$$FIELD^OCXSENDD(FILE,OCXFLD,"LABEL") 99 ;; I (OCXFNAM["UNIQUE OBJECT IDENTIFIER") Q 1 100 ;; I (FILE=860.2),(OCXFLD=.02) Q 1 101 ;; I (FILE=860.22),(OCXFLD=4) Q 1 102 ;; I (FILE=860.3),(OCXFLD=3) Q 1 103 ;; I (FILE=860.9),(OCXFLD=1) Q 1 104 ;; I (FILE=860.91) Q 1 105 ;; I (FILE=860.801) Q 1 106 ;; I (FILE=860.81) Q 1 107 ;; I (FILE=861.01) Q 1 108 ;; I (FILE=863.02) Q 1 109 ;; I (FILE=863.54) Q 1 110 ;; I (FILE=863.61) Q 1 111 ;; I (FILE=863.72) Q 1 112 ;; I (FILE=863.81) Q 1 113 ;; I ($E(OCXFNAM,1)="*") Q 1 114 ;; Q 0 115 ;; ; 116 ;;WARN(MSG,CREF,OCXDD,OCXFLD,OCXSUB) ; 117 ;; ; 118 ;; Q:$G(OCXAUTO) 119 ;; ; 120 ;; N D0,DASH,OCXDDPTH,OCXDPTR,FILE,FILEID,LREF,OCXPTR,RREF 121 ;; ; 122 ;; S DASH="",$P(DASH,"-",(55-$L(MSG)))="-" 123 ;; W !!,"------------",MSG,DASH 124 ;; D DSPHDR(CREF,OCXDD,OCXFLD) 125 ;; I $D(OCXSUB) D DSPFLD(CREF,OCXDD,OCXFLD,OCXSUB) 126 ;; I '$D(OCXSUB) D DSPREC(CREF,OCXDD,OCXFLD) 127 ;; ; 128 ;; W ! Q 129 ;; ; 130 ;;DSPREC(CREF,OCXDD,OCXFLD) ; 131 ;; ; 132 ;; N OCXDPTR,OCXDDPTH,LEVL,OCXCREF,OCXSUB 133 ;; S OCXCREF=$$APPEND($$APPEND(CREF,OCXDD),OCXFLD) 134 ;; S OCXDDPTH=$P($P(OCXCREF,"(",2),")",1),LEVL=$L(OCXDDPTH,",") 135 ;; S OCXSUB="" F S OCXSUB=$O(@OCXCREF@(OCXSUB)) Q:'$L(OCXSUB) D 136 ;; .; 137 ;; .I '(OCXSUB[":"),'((OCXSUB=.01)&$O(@OCXCREF@(OCXSUB))) D 138 ;; ..N LINE 139 ;; ..Q:$$EXFLD(+OCXFLD,OCXSUB) 140 ;; ..I OCXFLD W !,?(5+((LEVL)*4)),$$FIELD^OCXSENDD(+OCXFLD,OCXSUB,"LABEL"),": ",$G(@OCXCREF@(OCXSUB,"E")) 141 ;; ..S LINE=0 F S LINE=$O(@OCXCREF@(OCXSUB,LINE)) Q:'LINE D 142 ;; ...W !,?(5+(LEVL*4)),$J(LINE,3),">",@OCXCREF@(OCXSUB,LINE) 143 ;; .; 144 ;; .I (OCXSUB[":") D 145 ;; ..N D0,OCXDD,FILENAME 146 ;; ..S D0=+$P(OCXSUB,":",2),OCXDD=+OCXSUB 147 ;; ..S FILENAME=$$FILENAME^OCXSENDD(OCXDD) 148 ;; ..I $L(FILENAME) W !,?(5+($L(LEVL)*4)),FILENAME 149 ;; ..E W !!,?(5+(LEVL*4)),FILENAME 150 ;; ..W " ",D0,": ",$G(@OCXCREF@(OCXSUB,.01,"E")) 151 ;; ..D DSPREC($$APPEND(CREF,OCXDD),OCXFLD,OCXSUB) 152 ;; ; 153 ;; Q 154 ;; ; 155 ;;DSPHDR(CREF,OCXDD,OCXFLD) ; 156 ;; ; 157 ;; N D0,FILE,FILEID,OCXPTR,OCXDDPTH 158 ;; S OCXDDPTH=$P($P($$APPEND($$APPEND(CREF,OCXDD),OCXFLD),"(",2),")",1) 159 ;; S FILE="" F OCXPTR=1:1:$L(OCXDDPTH,",") D 160 ;; .N OCXDD,D0,FILEID 161 ;; .S FILEID=$P(OCXDDPTH,",",OCXPTR) 162 ;; .I (FILEID[":") D 163 ;; ..S D0=+$P(FILEID,":",2),OCXDD=+$E(FILEID,2,$L(FILEID)) 164 ;; ..W !,?(5+(OCXPTR*4)),$$FILENAME^OCXSENDD(OCXDD) 165 ;; ..S:$L(FILE) FILE=FILE_"," S FILE=FILE_FILEID 166 ;; ..I $D(@("L("_FILE_",.01,""E"")")) W ": ",@("L("_FILE_",.01,""E"")") W:D0 " [",D0,"]" 167 ;; ..E I $D(@("R("_FILE_",.01,""E"")")) W ": ",@("R("_FILE_",.01,""E"")") W:D0 " [",D0,"]" 168 ;; ; 169 ;; Q 170 ;; ; 171 ;;DSPFLD(CREF,OCXDD,OCXFLD,OCXSUB) ; 172 ;; ; 173 ;; N OCXDPTR,LREF,RREF,OCXDDPTH 174 ;; ; 175 ;; S OCXDDPTH=$P($P($$APPEND(CREF,OCXDD),"(",2),")",1) 176 ;; S LREF="L("_OCXDDPTH_")",RREF="R("_OCXDDPTH_")" 177 ;; W !,?(5+(($L(OCXDDPTH,",")+1)*4)),$$FIELD^OCXSENDD(OCXDD,OCXFLD,"LABEL")," field [",OCXFLD,"]" 178 ;; I OCXSUB W " Line #",OCXSUB 179 ;; ; 180 ;; W:($D(@RREF@(OCXFLD,OCXSUB))) !,?(5+(($L(OCXDDPTH,",")+2)*4)),"(R) |RUCI|: ",@RREF@(OCXFLD,OCXSUB) 181 ;; W:($D(@LREF@(OCXFLD,OCXSUB))) !,?(5+(($L(OCXDDPTH,",")+2)*4)),"(L) ",$$NETNAME^OCXSEND,": ",@LREF@(OCXFLD,OCXSUB) 182 ;; ; 183 ;; Q 184 ;; ; 185 ;; W !,?10 Q 0 Q $$PAUSE 186 ;; ; 187 ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) 188 ;; ; 189 ;;NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y 190 ;; ; 191 ;;$ 192 ;1; 193 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND6.m
r613 r623 1 OCXSEND6 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,76,74,96,105,243**;Dec 17,1997;Build 242 3 4 5 EN() 6 7 N R,LINE,TEXT,NOW,RUCI 8 9 10 11 12 13 14 W !,X X ^%ZOSF("SAVE")K ^TMP("OCXSEND",$J,"RTN")15 16 Q " " 17 18 TEXT 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 1 OCXSEND6 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 2) ;2/01/01 10:03 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,76,74,96,105**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 EN() ; 6 ; 7 N R,LINE,TEXT,NOW,RUCI,XCM 8 S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND 9 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) 10 ; 11 M ^TMP("OCXSEND",$J,"RTN")=R 12 ; 13 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(2,1) 14 W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN") 15 ; 16 Q XCM 17 ; 18 TEXT ; 19 ;;|$$RNAME^OCXSEND3(2,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| 20 ;;|OCXLIN2| 21 ;;|OCXLIN3| 22 ;; ; 23 ;;S ; 24 ;; ; Record Utilities 25 ;; Q 26 ;; ; 27 ;;ADDREC(OCXCREF) ; 28 ;; ; 29 ;; N QUIT,OCXDD,OCXDA,OCXGREF,OCXNAME 30 ;; S OCXDD=$O(@OCXCREF@("")) Q:'OCXDD 0 31 ;; S OCXNAME=$G(@OCXCREF@(OCXDD,.01,"E")) 32 ;; ; 33 ;; W " record missing..." 34 ;; I (OCXFLAG["D") Q 0 35 ;; ; 36 ;; S OCXDA=0 D CREATE(OCXCREF,OCXDD,.OCXDA,0) 37 ;; S:$L(OCXNAME) ^TMP("OCXRULE",$J,"A",+OCXDD,OCXNAME)="" 38 ;; ; 39 ;; Q 0 40 ;; ; 41 ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ; 42 ;; ; 43 ;; N OCXFLD,OCXGREF,OCXKEY 44 ;; ; 45 ;; I $L(OCXDA),'(OCXDA=+OCXDA) W !!,"Unresolved subscript." Q 46 ;; ; 47 ;; S OCXKEY=@OCXCREF@(OCXDD,.01,"E") 48 ;; S OCXGREF=$$GETREF(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF) 49 ;; I 'OCXDA D 50 ;; .S OCXDA=$O(^TMP("OCXRULE",$J,"B",+OCXDD,OCXKEY,0)) Q:OCXDA 51 ;; .S OCXDA=$O(@(OCXGREF_""" "")"),-1)+1 52 ;; .F OCXDA=OCXDA:1 Q:'$D(@(OCXGREF_OCXDA_",0)")) 53 ;; .I $D(@(OCXGREF_OCXDA_",0)")) S OCXDA=0 54 ;; ; 55 ;; I 'OCXDA W !!,"Error adding record..." Q 56 ;; ; 57 ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U 58 ;; ; 59 ;; S OCXFLD=0 F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD Q:(OCXFLD[":") I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D 60 ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL) 61 ;; .I $O(@OCXCREF@(OCXDD,OCXFLD,0)) D WORD(OCXDD,OCXGREF,OCXFLD,.OCXDA,OCXCREF) 62 ;; ; 63 ;; D PUSH(.OCXDA) 64 ;; S OCXFLD="" F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) I (OCXFLD[":") D 65 ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1) 66 ;; D POP(.OCXDA) 67 ;; Q 68 ;; ; 69 ;;LOADWORD(RREF,OCXDD,OCXFLD,OCXSUB) ; 70 ;; ; 71 ;; N QUIT,DDPATH,INDEX,OCXDA,OCXGREF 72 ;; S DDPATH=$P($P($$APPEND(RREF,OCXDD),"(",2),")",1) 73 ;; F INDEX=1:1:$L(DDPATH,",") S OCXDA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2) 74 ;; S OCXDA=$G(OCXDA(0)) K OCXDA(0) 75 ;; Q:(OCXFLAG["D") 0 76 ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to reload the local '"_$$FIELD^OCXSENDD(+OCXDD,+OCXFLD,"LABEL")_"' field ?","YES") Q:'QUIT (QUIT[U) 77 ;; S OCXGREF=$$GETREF(+OCXDD,.OCXDA,$L(DDPATH,",")-1) Q:'$L(OCXGREF) 78 ;; D WORD(OCXDD,OCXGREF,OCXFLD,.OCXDA,RREF) 79 ;; Q 0 80 ;; ; 81 ;;GETREF(OCXDD,OCXDA,OCXLVL) ; 82 ;; ; 83 ;; Q:'OCXDD "" 84 ;; ; 85 ;; N OCXIENS,OCXERR,OCXX 86 ;; S OCXIENS=$$IENS^DILF(.OCXDA),OCXERR="" 87 ;; S OCXX=$$ROOT^DILFD(OCXDD,OCXIENS,0,OCXERR) 88 ;; Q OCXX 89 ;; ; 90 ;;WORD(DD,GREF,FLD,DA,RREF) ; 91 ;; ; 92 ;; N SUB,GLROOT,LINE 93 ;; S SUB=$P($$FIELD^OCXSENDD(+DD,FLD,"GLOBAL SUBSCRIPT LOCATION"),";",1) S:'(SUB=+SUB) SUB=""""_SUB_"""" 94 ;; S GLROOT=GREF_DA_","_SUB_")" K @GLROOT 95 ;; S LINE=0 F S LINE=$O(@RREF@(DD,FLD,LINE)) Q:'LINE D 96 ;; .S @GLROOT@($O(@GLROOT@(""),-1)+1,0)=@RREF@(DD,FLD,LINE) 97 ;; S LINE=$O(@GLROOT@(""),-1),@GLROOT@(0)=U_U_LINE_U_LINE_U_$$DATE("T")_U 98 ;; ; 99 ;; Q 100 ;; ; 101 ;;DATE(X) N %DT,Y S %DT="" D ^%DT Q +Y 102 ;; ; 103 ;;DIE(OCXDD,OCXDIC,OCXFLD,OCXVAL,OCXDA,OCXLVL) ; 104 ;; ; 105 ;; N DIC,DIE,X,Y,DR,DA,OCXDVAL,OCXPTR,OCXGREF,D0,OCXSCR 106 ;; S (D0,DA)=OCXDA,(DIC,DIE)=OCXDIC,DR="" 107 ;; S:OCXLVL D0=OCXDA(1),DR="S DA(1)="_(+D0)_",D0="_(+D0)_";" 108 ;; S:OCXVAL="?" OCXVAL="? " S DR=DR_OCXFLD_"///^S X=OCXVAL" 109 ;; I '(OCXVAL="@") W !,?(OCXLVL*5),$$FIELD^OCXSENDD(+OCXDD,OCXFLD,"LABEL"),": ",OCXVAL 110 ;; ; 111 ;; I '(OCXVAL="@") D 112 ;; .N OCXIEN,SHORT 113 ;; .S OCXPTR=+$P($$FIELD^OCXSENDD(+OCXDD,OCXFLD,"SPECIFIER"),"P",2) 114 ;; .Q:'OCXPTR 115 ;; .S OCXGREF="^"_$$FIELD^OCXSENDD(+OCXDD,OCXFLD,"POINTER") 116 ;; .I '($E(OCXGREF,1,4)="^OCX"),'(OCXGREF="^ORD(100.9,"),'(OCXGREF="^ORD(100.8,") Q 117 ;; .Q:$$DIC(OCXGREF,OCXVAL,0) 118 ;; .S OCXIEN=$$DIC(OCXGREF,OCXVAL,1) 119 ;; .S ^TMP("OCXRULE",$J,"B",OCXPTR,OCXVAL,OCXIEN)="" 120 ;; ; 121 ;; S OCXSCR=1 122 ;; D ^DIE 123 ;; ; 124 ;; ; I $D(Y) -> DIE FILER ERROR 125 ;; I $D(Y) W " ^DIE filer data error..." S OCXDIER=$G(OCXDIER)+1 126 ;; I '$D(Y) W " ...Correct data Filed" 127 ;; ; 128 ;; Q 129 ;; ; 130 ;;DIC(DIC,X,OCXADD) N OCXSCR S DIC(0)="",OCXSCR=1 S:OCXADD DIC(0)="L" D ^DIC Q:(+Y>0) +Y Q 0 131 ;; ; 132 ;;PUSH(OCXDA) ; 133 ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB S OCXDA(OCXSUB+1)=OCXDA(OCXSUB) 134 ;; S OCXDA(1)=OCXDA,OCXDA=0 135 ;; Q 136 ;; ; 137 ;;POP(OCXDA) ; 138 ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1)) 139 ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1)) 140 ;; Q 141 ;; ; 142 ;;APPEND(ARRAY,OCXSUB) ; 143 ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_"""" 144 ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")" 145 ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")" 146 ;; ; 147 ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; 148 ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT 149 ;; Q:'$L($G(OCXZ0)) U 150 ;; S DIR(0)=OCXZ0 151 ;; S:$L($G(OCXZA)) DIR("A")=OCXZA 152 ;; S:$L($G(OCXZB)) DIR("B")=OCXZB 153 ;; F OCXLINE=1:1:($G(OCXZL)-1) W ! 154 ;; D ^DIR 155 ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U 156 ;; Q Y 157 ;; ; 158 ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) 159 ;; ; 160 ;;$ 161 ;1; 162 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND7.m
r613 r623 1 OCXSEND7 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105,243**;Dec 17,1997;Build 242 3 4 5 EN() 6 7 N R,LINE,TEXT,NOW,RUCI 8 9 10 11 12 13 14 W !,X X ^%ZOSF("SAVE")K ^TMP("OCXSEND",$J,"RTN")15 16 Q " " 17 18 TEXT 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 1 OCXSEND7 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 3) ;1/31/01 11:07 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 EN() ; 6 ; 7 N R,LINE,TEXT,NOW,RUCI,XCM 8 S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND 9 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) 10 ; 11 M ^TMP("OCXSEND",$J,"RTN")=R 12 ; 13 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(3,1) 14 W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN") 15 ; 16 Q XCM 17 ; 18 TEXT ; 19 ;;|$$RNAME^OCXSEND3(3,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| 20 ;;|OCXLIN2| 21 ;;|OCXLIN3| 22 ;; ; 23 ;;S ; 24 ;; ; Multiple Utilities 25 ;; Q 26 ;; ; 27 ;;ADDMULT(OCXCREF,OCXDD,OCXFLD) ; 28 ;; ; 29 ;; ; 30 ;; N QUIT,OCXDA,OCXGREF,OCXNAME,DDPATH,INDEX 31 ;; ; 32 ;; S DDPATH=$P($P($$APPEND($$APPEND(OCXCREF,OCXDD),OCXFLD),"(",2),")",1) 33 ;; F INDEX=1:1:$L(DDPATH,",") S OCXDA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2) 34 ;; S OCXDA=$G(OCXDA(0)) K OCXDA(0) 35 ;; ; 36 ;; Q:(OCXFLAG["D") 0 37 ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to add a local '"_$$FILENAME^OCXSENDD(+OCXFLD)_"' multiple ?","YES") Q:'QUIT (QUIT[U) 38 ;; ; 39 ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXFLD,.OCXDA,1) 40 ;; D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,1) 41 ;; ; 42 ;; Q 0 43 ;; ; 44 ;;DELMULT(OCXCREF,OCXDD) ; 45 ;; ; 46 ;; N QUIT,OCXGREF,DA,INDEX,DDPATH 47 ;; ; 48 ;; Q:(OCXFLAG["D") 0 49 ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to delete the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' multiple ?","YES") Q:'QUIT (QUIT[U) 50 ;; ; 51 ;; S DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1) 52 ;; F INDEX=1:1:$L(DDPATH,",") S DA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2) 53 ;; S DA=$G(DA(0)) K DA(0) 54 ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.DA,1) 55 ;; ; 56 ;; D DIE^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,OCXGREF,.01,"@",.DA,$L(DDPATH,",")-1) 57 ;; K @OCXCREF@(OCXDD) W !!," deleted..." 58 ;; ; 59 ;; Q 0 60 ;; ; 61 ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ; 62 ;; ; 63 ;; N OCXFLD,OCXGREF 64 ;; ; 65 ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF) S:'OCXDA OCXDA=$O(@(OCXGREF_"""@"")"),-1)+1 66 ;; ; 67 ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U 68 ;; ; 69 ;; S OCXFLD=0 F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD Q:(OCXFLD[":") I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D 70 ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL) 71 ;; ; 72 ;; D PUSH(.OCXDA) 73 ;; S OCXFLD="" F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) I (OCXFLD[":") D 74 ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1) 75 ;; D POP(.OCXDA) 76 ;; Q 77 ;; ; 78 ;;PUSH(OCXDA) ; 79 ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB S OCXDA(OCXSUB+1)=OCXDA(OCXSUB) 80 ;; S OCXDA(1)=OCXDA,OCXDA=0 81 ;; Q 82 ;; ; 83 ;;POP(OCXDA) ; 84 ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1)) 85 ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1)) 86 ;; Q 87 ;; ; 88 ;;APPEND(ARRAY,OCXSUB) ; 89 ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_"""" 90 ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")" 91 ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")" 92 ;; ; 93 ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; 94 ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT 95 ;; Q:'$L($G(OCXZ0)) U 96 ;; S DIR(0)=OCXZ0 97 ;; S:$L($G(OCXZA)) DIR("A")=OCXZA 98 ;; S:$L($G(OCXZB)) DIR("B")=OCXZB 99 ;; F OCXLINE=1:1:($G(OCXZL)-1) W ! 100 ;; D ^DIR 101 ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U 102 ;; Q Y 103 ;; ; 104 ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) 105 ;; ; 106 ;;$ 107 ;1; 108 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND8.m
r613 r623 1 OCXSEND8 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105,243**;Dec 17,1997;Build 242 3 4 5 EN() 6 7 N R,LINE,TEXT,NOW,RUCI 8 9 10 11 12 13 14 W !,X X ^%ZOSF("SAVE")K ^TMP("OCXSEND",$J,"RTN")15 16 Q " " 17 18 TEXT 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 1 OCXSEND8 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 4) ;1/31/01 08:44 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 EN() ; 6 ; 7 N R,LINE,TEXT,NOW,RUCI,XCM 8 S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND 9 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) 10 ; 11 M ^TMP("OCXSEND",$J,"RTN")=R 12 ; 13 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(4,1) 14 W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN") 15 ; 16 Q XCM 17 ; 18 TEXT ; 19 ;;|$$RNAME^OCXSEND3(4,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| 20 ;;|OCXLIN2| 21 ;;|OCXLIN3| 22 ;; ; 23 ;;S ; 24 ;; ; Field Utilities 25 ;; Q 26 ;; ; 27 ;;EDITFLD(OCXCREF,OCXDD,OCXFLD,OCXSUB) ; 28 ;; ; 29 ;; N DDPATH,OCXDA,OCXPC,OCXLVL,QUIT 30 ;; ; 31 ;; S QUIT=0,DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1) 32 ;; S OCXLVL=$L(DDPATH,",") 33 ;; F OCXPC=1:1:OCXLVL S OCXDA(OCXLVL-OCXPC)=+$P($P(DDPATH,",",OCXPC),":",2) 34 ;; S OCXDA=OCXDA(0) K OCXDA(0) 35 ;; I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D 36 ;; .N RESP 37 ;; .Q:(OCXFLAG["D") 38 ;; .I (OCXFLAG["A") S RESP=$$READ("Y"," Do you want to change the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' field ?","YES") I 'RESP S QUIT=(RESP[U) Q 39 ;; .S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL-1) Q:'$L(OCXGREF) 40 ;; .D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL-1) 41 ;; ; 42 ;; Q QUIT 43 ;; ; 44 ;;DELFLD(OCXCREF,OCXDD,OCXFLD,OCXSUB) ; 45 ;; ; 46 ;; N DDPATH,OCXDA,OCXPC,OCXLVL,QUIT,RESP 47 ;; ; 48 ;; S QUIT=0,DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1) 49 ;; S OCXLVL=$L(DDPATH,",") 50 ;; F OCXPC=1:1:OCXLVL S OCXDA(OCXLVL-OCXPC)=+$P($P(DDPATH,",",OCXPC),":",2) 51 ;; S OCXDA=OCXDA(0) K OCXDA(0) 52 ;; Q:(OCXFLAG["D") 0 53 ;; I (OCXFLAG["A") S RESP=$$READ("Y"," Do you want to Delete the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' value ?","YES") I 'RESP S QUIT=(RESP[U) Q QUIT 54 ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL-1) Q:'$L(OCXGREF) 55 ;; D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,"@",.OCXDA,OCXLVL-1) 56 ;; ; 57 ;; Q QUIT 58 ;; ; 59 ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ; 60 ;; ; 61 ;; N OCXFLD,OCXGREF 62 ;; ; 63 ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF) S:'OCXDA OCXDA=$O(@(OCXGREF_"""@"")"),-1)+1 64 ;; ; 65 ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U 66 ;; ; 67 ;; S OCXFLD=0 F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD Q:(OCXFLD[":") I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D 68 ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL) 69 ;; ; 70 ;; D PUSH(.OCXDA) 71 ;; S OCXFLD="" F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) I (OCXFLD[":") D 72 ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1) 73 ;; D POP(.OCXDA) 74 ;; Q 75 ;; ; 76 ;;PUSH(OCXDA) ; 77 ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB S OCXDA(OCXSUB+1)=OCXDA(OCXSUB) 78 ;; S OCXDA(1)=OCXDA,OCXDA=0 79 ;; Q 80 ;; ; 81 ;;POP(OCXDA) ; 82 ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1)) 83 ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1)) 84 ;; Q 85 ;; ; 86 ;;APPEND(ARRAY,OCXSUB) ; 87 ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_"""" 88 ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")" 89 ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")" 90 ;; ; 91 ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; 92 ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT 93 ;; Q:'$L($G(OCXZ0)) U 94 ;; S DIR(0)=OCXZ0 95 ;; S:$L($G(OCXZA)) DIR("A")=OCXZA 96 ;; S:$L($G(OCXZB)) DIR("B")=OCXZB 97 ;; F OCXLINE=1:1:($G(OCXZL)-1) W ! 98 ;; D ^DIR 99 ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U 100 ;; Q Y 101 ;; ; 102 ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) 103 ;; ; 104 ;;$ 105 ;1; 106 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSENDA.m
r613 r623 1 OCXSENDA 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105,143,243**;Dec 17,1997;Build 242 3 4 5 EN() 6 7 N R,LINE,TEXT,NOW,RUCI 8 9 10 11 12 13 14 W !,X X ^%ZOSF("SAVE")K ^TMP("OCXSEND",$J,"RTN")15 16 Q " " 17 18 19 TEXT 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 1 OCXSENDA ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Main Routine) ;6/12/02 12:03 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105,143**;Dec 17,1997 3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 4 ; 5 EN() ; 6 ; 7 N R,LINE,TEXT,NOW,RUCI,XCM 8 S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND,CVER=$$VERSION^OCXOCMP 9 F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) 10 ; 11 M ^TMP("OCXSEND",$J,"RTN")=R 12 ; 13 S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(0,0) 14 W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN") 15 ; 16 Q XCM 17 ; 18 ; 19 TEXT ; 20 ;;|$$RNAME^OCXSEND3(0,0)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| 21 ;;|OCXLIN2| 22 ;;|OCXLIN3| 23 ;; ; 24 ;;S ; 25 ;; ; 26 ;; N OCXDIER,QUIT,LINE,TEXT,REMOTE,LOCAL,D0,OPCODE,REF,OCXFLAG S QUIT=0 27 ;; N OCXAUTO,OCZSCR 28 ;; ; 29 ;; D DOT 30 ;; I $L($T(VERSION^OCXOCMP)),($$VERSION^OCXOCMP="|CVER|"),1 31 ;; E D Q 32 ;; .W ! 33 ;; .W !,"Rule Transport aborted, version mismatch." 34 ;; .W !,"Current Local version: ",$$VERSION^OCXOCMP 35 ;; .W !," Rule Transport Version: |CVER|" 36 ;; I '$D(DTIME) W !!,"DTIME not defined !!",!! Q 37 ;; W !!,"Order Check Expert System Rule Transporter" 38 ;; W !," Created: |NOW| at |RUCI|" 39 ;; W !," Current Date: ",$$NOW^|$$RNAME^OCXSEND3(0,1)|," at ",$$NETNAME^OCXSEND,!! 40 ;; S LASTFILE=0 K ^TMP("OCXRULE",$J) 41 ;; S ^TMP("OCXRULE",$J)=($P($H,",",2)+($H*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" 42 ;; S OCXFLAG="|OCXASK|" 43 ;; ; 44 ;;RUN ; 45 ;; ; 46 ;; W !,"Loading Data " D ^|$$RNAME^OCXSEND3(1,2)| 47 ;; ; 48 ;; S LINE=0 F S LINE=$O(^TMP("OCXRULE",$J,LINE)) Q:'LINE D Q:QUIT 49 ;; .D:'(LINE#50) STATUS^OCXOPOST(LINE,$O(^TMP("OCXRULE",$J," "),-1)) 50 ;; .S TEXT=$G(^TMP("OCXRULE",$J,LINE)) I $L(TEXT) D Q:QUIT 51 ;; ..S TEXT=$P(TEXT,";",2,999),OPCODE=$P(TEXT,U,1),TEXT=$P(TEXT,U,2,999) 52 ;; ..; 53 ;; ..I OPCODE="KEY" D DOT S LOCAL="",D0=$$GETFILE^|$$RNAME^OCXSEND3(0,1)|(+$P(TEXT,U,1),$P(TEXT,U,2),.LOCAL) S QUIT=(D0=(-10)) Q 54 ;; ..I OPCODE="R" S REF="REMOTE("_$P(TEXT,":",1)_":"_D0_$P(TEXT,":",2,99)_")" Q 55 ;; ..I OPCODE="D",$D(REF) S @REF=$P(TEXT,U,1,999) K REF Q 56 ;; ..; 57 ;; ..I OPCODE="EOR" S QUIT=$$COMPARE^|$$RNAME^OCXSEND3(1,1)|(.LOCAL,.REMOTE) K LOCAL,REMOTE Q 58 ;; ..I OPCODE="EOF" K LOCAL,REMOTE Q 59 ;; ..I OPCODE="SOF" W !," Installing '",TEXT,"' records... " Q 60 ;; ..I OPCODE="ROOT" D Q 61 ;; ...N FILE,DATA 62 ;; ...S FILE=U_$P(TEXT,U,1),DATA=$P(TEXT,U,2,3) 63 ;; ...I ($P($G(@FILE),U,1,2)=DATA) Q 64 ;; ...S $P(@FILE,U,1,2)=DATA 65 ;; ...W !," Restoring file #",(+$P(DATA,U,2))," zero node" 66 ;; ..; 67 ;; ..W !,"Unknown OpCode: ",OPCODE," in: ",TEXT S QUIT=$$PAUSE^|$$RNAME^OCXSEND3(0,1)| W ! 68 ;; ; 69 ;; K ^TMP("OCXRULE",$J) 70 ;; ; 71 ;; I $D(^OCXS) D 72 ;; .N FILE,DO,PD0,CNT 73 ;; .S FILE=0 F S FILE=$O(^OCXS(FILE)) Q:'FILE D 74 ;; ..S D0=0 F CNT=0:1 S PD0=D0,D0=$O(^OCXS(FILE,D0)) Q:'D0 75 ;; ..S $P(^OCXS(FILE,0),U,3,4)=CNT_U_PD0 76 ;; ; 77 ;; I $G(OCXDIER) D 78 ;; .W !!!!!!! 79 ;; .W !,?5,"******************** Warning ******************** " 80 ;; .W !,?7,+$G(OCXDIER)," data filing error",$S(($G(OCXDIER)=1):"",1:"s"),"." 81 ;; .W !,?7,"Some expert system rules may be incomplete." 82 ;; .W !,?5,"******************** Warning ******************** " 83 ;; I '$G(OCXDIER) W !!,?5," No data filing errors." 84 ;; W !!,"Transport Finished..." 85 ;; ; 86 ;; D 87 ;; .N OCXOETIM 88 ;; .D BMES^XPDUTL("---Creating Order Check Routines-----------------------------------") 89 ;; .D AUTO^OCXOCMP 90 ;; ; 91 ;; Q 92 ;; ; 93 ;;DOT Q:$G(OCXAUTO) W:($X>70) ! W " ." Q 94 ;; ; 95 ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; 96 ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT 97 ;; Q:'$L($G(OCXZ0)) U 98 ;; S DIR(0)=OCXZ0 99 ;; S:$L($G(OCXZA)) DIR("A")=OCXZA 100 ;; S:$L($G(OCXZB)) DIR("B")=OCXZB 101 ;; F OCXLINE=1:1:($G(OCXZL)-1) W ! 102 ;; D ^DIR 103 ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U 104 ;; Q Y 105 ;; ; 106 ;;$ 107 ;1; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3FUP1.m
r613 r623 1 ORB3FUP1 ; slc/CLA - Routine to support notification follow-up actions ; 4/8/08 9:32am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,64,74,105,139,243**;Dec 17, 1997;Build 242 3 Q 4 TYPE(ORBY,ORXQAID) ; return notif follow-up action type 5 N NIEN 6 S NIEN=$P($P(ORXQAID,";"),",",3) 7 S ORBY=$G(^ORD(100.9,NIEN,3)) 8 I ORBY="" S ORBY="INFO^" 9 E S ORBY=$P(ORBY,U,2) 10 Q 11 GUI(ORBY,ORXQAID) ; Notification follow-up for GUI called via API: ORB FOLLOW-UP 12 ; called by ORB FOLLOW-UP api: 13 S ORENVIR="GUI" 14 D PROCESS 15 Q 16 PROCESS ; main process for notification follow-up 17 ;ORXQAID = OR,dfn,nien; 18 ;XQADATA = placer num^placer id;filler num^filler id 19 ;XQAKILL = value of parameter ORB DELETE MECHANISM for notif in 100.9 20 N ORPDIEN,ORN,ORDFN,ORSITE,ORFID,ORFIEN,ORKILL 21 D GETACT^XQALERT(ORXQAID) ;return follow-up action info 22 ;Q:'($D(XQADATA)) Q:'($D(XQAID)) 23 ;Q:($P(XQAID,",")'="OR") 24 ;call function rpc stored in xqarou with params from xqadata 25 D @XQAROU 26 K ORENVIR 27 Q 28 MSG ; display msg re: alert being processed for non-GUI follow-up actions 29 I $G(ORENVIR)'="GUI" D 30 .I $L($G(XQX)) W !!,"Processing alert: ",$P(XQX,U,3) H 1.5 31 Q 32 DEL(ORBY,XQAID,ORKILL) ; delete an alert 33 N ORN 34 S ORN=$P($P(XQAID,";"),",",3) 35 I $G(ORKILL)=1!($G(ORKILL)=0) S XQAKILL=ORKILL 36 I $G(XQAKILL)="" S XQAKILL=$$XQAKILL^ORB3F1(ORN) 37 I $G(XQAKILL)="" S XQAKILL=1 38 S ORBY="FALSE" 39 I $L($G(XQAID)) D DELETE^XQALERT S ORBY="TRUE" 40 K XQAKILL 41 Q 42 CSORD ;co-sign order(s) follow-up 43 K XQAKILL 44 N ORPT,ORDG,ORBXQAID,ORY S ORBXQAID=XQAID 45 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 46 ;the FLG code for orders requiring CO-SIGNATURE in ORQ1 is 'to be determined when ASU is available' 47 D DEL(.ORY,XQAID) ;until ASU is implemented, delete the alert and quit 48 Q ;quit until ASU is implemented 49 ;I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",???,"","") 50 ;I $G(ORENVIR)'="GUI" D 51 ;.D MSG 52 ;.S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 53 ;.D EN^ORCB(ORPT,???,ORDG,???) 54 ;.K ^TMP("ORR",$J) 55 ;.D EN^ORQ1(ORPT_";DPT(",ORDG,???,"","","",0,0) 56 ;.S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 57 ;..D DEL(.ORY,ORBXQAID) ;if no more orders req. co-sign, delete the alert 58 ;.K ^TMP("ORR",$J) 59 Q 60 EXDNR ;expiring dnr follow-up 61 K XQAKILL 62 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 63 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 64 N DNRORD,DNRY S DNRORD=$P(XQADATA,"@") 65 I $G(ORENVIR)="GUI" D 66 .S ORBY(1)=DNRY 67 I $G(ORENVIR)'="GUI" D 68 .D MSG 69 .D EN1^ORCB(DNRORD,"RENEW") ;display order, allow renewing, then delete 70 .D DEL(.ORY,ORBXQAID) 71 Q 72 UNLINKED ;unlinked provider follow-up 73 K XQAKILL 74 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 75 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 76 N ORNUM,ORUNY S ORNUM=$P(XQADATA,"@") 77 I $G(ORENVIR)="GUI" D 78 .S ORBY(1)=ORUNY 79 I $G(ORENVIR)'="GUI" D 80 .D MSG 81 .D EN1^ORCB(ORNUM,"REPLACE") ;display order, allow replace, then delete 82 .D DEL(.ORY,ORBXQAID) 83 Q 84 FLORD ;flagged order(s) follow-up 85 K XQAKILL 86 N ORPT,ORDG,X,ORBXQAID,ORY,ORBLMDEL 87 S ORBXQAID=XQAID 88 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 89 ;the FLG code for "FLAGGED" in ORQ1 is '12' 90 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",12,"","") 91 I $G(ORENVIR)'="GUI" D 92 .D MSG 93 .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 94 .D EN^ORCB(ORPT,12,ORDG,.ORBLMDEL) 95 .K ^TMP("ORR",$J) 96 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 97 .D EN^ORQ1(ORPT_";DPT(",ORDG,12,"","","",0,0) 98 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 99 ..D DEL(.ORY,ORBXQAID) ;if no more flagged orders found, delete alert 100 .K ^TMP("ORR",$J) 101 Q 102 NEWORD ;new order(s) follow-up 103 K XQAKILL 104 N ORPT,ORDG,ORSDT,OREDT,ENT,X,ORBXQAID,ORY,ORBLMDEL 105 S ORSDT="",OREDT="",ENT="USR",ORBXQAID=XQAID 106 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 107 ;the FLG code for NEW orders since last reviewed orders in ORQ1 is '6' 108 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",6,"","") 109 I $G(ORENVIR)'="GUI" D 110 .D MSG 111 .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 112 .D EN^ORCB(ORPT,6,ORDG,.ORBLMDEL) 113 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 114 .D DEL(.ORY,ORBXQAID) ;delete the alert 115 Q 116 DCORD ;DC order(s) follow-up 117 K XQAKILL 118 N ORPT,ORDG,ORSDT,OREDT,ENT,X,ORBXQAID,ORY,ORBLMDEL 119 S ORSDT="",OREDT="",ENT="USR",ORBXQAID=XQAID 120 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 121 ;the FLG code for DC orders is '3' 122 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",6,"","") 123 I $G(ORENVIR)'="GUI" D 124 .D MSG 125 .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 126 .D EN^ORCB(ORPT,6,ORDG,.ORBLMDEL) 127 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 128 .D DEL(.ORY,ORBXQAID) ;delete the alert 129 Q 130 NUMORD ;detailed order display follow-up - return order number 131 K XQAKILL 132 N ORBXQAID,ORY S ORBXQAID=XQAID 133 S ORNUM=$P(XQADATA,"@") 134 I $G(ORENVIR)="GUI" D 135 .Q 136 I $G(ORENVIR)'="GUI" D 137 .D MSG 138 .D EN1^ORCB(+ORNUM,"NEW") ;display order, allow new order then delete 139 .D DEL(.ORY,ORBXQAID) 140 Q 141 ESORD ;order(s) requiring electronic signature follow-up 142 K XQAKILL 143 N ORPT,ORDG,ORBXQAID,ORY,ORX,ORZ,ORDERS,ORDNUM,ORQUIT,ORBLMDEL 144 S ORBXQAID=XQAID,ORDERS=0,ORQUIT=0 145 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 146 ;the FLG code for UNSIGNED orders in ORQ1 is '11' 147 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",11,"","") 148 I $G(ORENVIR)'="GUI" D 149 .D MSG 150 .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 151 .D EN^ORCB(ORPT,11,ORDG,.ORBLMDEL) 152 .K ^TMP("ORR",$J) ;clean up array 153 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 154 .I $L($G(XQAID)) D ;EN^ORCB may kill XQAID in its follow-up 155 ..; 156 ..;get unsigned orders - if none exist, delete alert then quit: 157 ..D EN^ORQ1(ORPT_";DPT(",ORDG,11,"","","",0,0) 158 ..S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" I +$G(^TMP("ORR",$J,ORX,"TOT"))<1 D DEL(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q 159 ..; 160 ..;user does not have ORES key, delete user's alert: 161 ..I '$D(^XUSEC("ORES",DUZ)) S XQAKILL=1 D DEL(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q 162 ..; 163 ..;if prov is NOT linked to pt via attending, primary, teams or PCMM: 164 ..I $$PPLINK^ORQPTQ1(DUZ,ORPT)=0 D 165 ...S ORX="" F S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""!(ORDERS=1) D 166 ....S ORZ="" F S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:ORZ=""!(ORDERS=1) D 167 .....S ORDNUM=^TMP("ORR",$J,ORX,ORZ) 168 .....;quit if this unsigned order's last action was made by the user 169 .....I DUZ=+$$UNSIGNOR^ORQOR2(ORDNUM) S ORDERS=1 170 ...I ORDERS'=1 D ;provider has no outstanding unsiged orders for pt 171 ....S XQAKILL=1 D DEL(.ORY,ORBXQAID) ;delete alert for this user 172 ..K ^TMP("ORR",$J) 173 Q 174 UNFLAG(ORPT) ;order unflagged - delete alert if no more flagged orders 175 N ORDG,ORDOIT,ORQUIT,X,XQAID,XQAKILL,XQAUSER 176 S ORDOIT=1,ORQUIT=0 177 S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 178 K ^TMP("ORR",$J) 179 D EN^ORQ1(ORPT_";DPT(",ORDG,12,"","","",0,0) 180 ;========DELETE ALERT (FOR ALL USERS) IF NO FLAGGED ORDERS AT ALL===== 181 S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 182 .;if no more flagged orders found, delete alert: 183 .S XQAKILL=$$XQAKILL^ORB3F1(6) 184 .I $G(XQAKILL)="" S XQAKILL=1 185 .S XQAID="OR,"_ORPT_",6" D DELETEA^XQALERT K XQAID,XQAKILL S ORQUIT=1 186 Q:ORQUIT 187 ;========DELETE ALERT IF NO FLAGGED ORDERS LEFT RELATED TO THE USER THAT IS UNFLAGGING===== 188 S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" D 189 .N Y S Y="" F S Y=$O(^TMP("ORR",$J,X,Y)) Q:'Y D 190 ..N ORDER S ORDER=$G(^TMP("ORR",$J,X,Y)) 191 ..I $$FLAGRULE^ORWORR1(+ORDER)=0 S ORDOIT=0 ; FOUND A FLAGGED ORDER THAT THE USER SHOULD GET 192 I ORDOIT D 193 .;if no more flagged orders found for this user, delete alert only for this user: 194 .S XQAKILL=1 195 .S XQAID="OR,"_ORPT_",6" D DELETEA^XQALERT K XQAID,XQAKILL 196 ;========DELETE ALERT IF NO FLAGGED ORDERS LEFT RELATED TO THE USER THAT WAS THE ALERTED PROVIDER OF THE CURRENT ORDER===== 197 S ORDOIT=1 198 ;get the alerted provider 199 I $G(ORIFN) D 200 .N ORD,ORACT S ORD=+$G(ORIFN),ORACT=$P($G(ORIFN),";",2) 201 .N ORUSR S ORUSR=$P($G(^OR(100,ORD,8,ORACT,3)),U,9) 202 .I ORUSR D 203 ..S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" D 204 ...N Y S Y="" F S Y=$O(^TMP("ORR",$J,X,Y)) Q:'Y D 205 ....N ORDER S ORDER=$G(^TMP("ORR",$J,X,Y)) 206 ....I $$FLAGRULE^ORWORR1(+ORDER,ORUSR)=0 S ORDOIT=0 ; FOUND A FLAGGED ORDER THAT THE USER SHOULD GET 207 ..I ORDOIT D 208 ...;if no more flagged orders found for this user, delete alert only for this user: 209 ...S XQAKILL=1,XQAUSER=ORUSR 210 ...S XQAID="OR,"_ORPT_",6" D DELETEA^XQALERT K XQAID,XQAKILL,XQAUSER 211 K ^TMP("ORR",$J) 212 Q 1 ORB3FUP1 ; slc/CLA - Routine to support notification follow-up actions ;7/15/95 17:23 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,64,74,105,139**;Dec 17, 1997 3 Q 4 TYPE(ORBY,ORXQAID) ; return notif follow-up action type 5 N NIEN 6 S NIEN=$P($P(ORXQAID,";"),",",3) 7 S ORBY=$G(^ORD(100.9,NIEN,3)) 8 I ORBY="" S ORBY="INFO^" 9 E S ORBY=$P(ORBY,U,2) 10 Q 11 GUI(ORBY,ORXQAID) ; Notification follow-up for GUI called via API: ORB FOLLOW-UP 12 ; called by ORB FOLLOW-UP api: 13 S ORENVIR="GUI" 14 D PROCESS 15 Q 16 PROCESS ; main process for notification follow-up 17 ;ORXQAID = OR,dfn,nien; 18 ;XQADATA = placer num^placer id;filler num^filler id 19 ;XQAKILL = value of parameter ORB DELETE MECHANISM for notif in 101.9 20 N ORPDIEN,ORN,ORDFN,ORSITE,ORFID,ORFIEN,ORKILL 21 D GETACT^XQALERT(ORXQAID) ;return follow-up action info 22 ;Q:'($D(XQADATA)) Q:'($D(XQAID)) 23 ;Q:($P(XQAID,",")'="OR") 24 ;call function rpc stored in xqarou with params from xqadata 25 D @XQAROU 26 K ORENVIR 27 Q 28 MSG ; display msg re: alert being processed for non-GUI follow-up actions 29 I $G(ORENVIR)'="GUI" D 30 .I $L($G(XQX)) W !!,"Processing alert: ",$P(XQX,U,3) H 1.5 31 Q 32 DEL(ORBY,XQAID,ORKILL) ; delete an alert 33 N ORN 34 S ORN=$P($P(XQAID,";"),",",3) 35 I $G(ORKILL)=1!($G(ORKILL)=0) S XQAKILL=ORKILL 36 I $G(XQAKILL)="" S XQAKILL=$$XQAKILL^ORB3F1(ORN) 37 I $G(XQAKILL)="" S XQAKILL=1 38 S ORBY="FALSE" 39 I $L($G(XQAID)) D DELETE^XQALERT S ORBY="TRUE" 40 K XQAKILL 41 Q 42 CSORD ;co-sign order(s) follow-up 43 K XQAKILL 44 N ORPT,ORDG,ORBXQAID,ORY S ORBXQAID=XQAID 45 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 46 ;the FLG code for orders requiring CO-SIGNATURE in ORQ1 is 'to be determined when ASU is available' 47 D DEL(.ORY,XQAID) ;until ASU is implemented, delete the alert and quit 48 Q ;quit until ASU is implemented 49 ;I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",???,"","") 50 ;I $G(ORENVIR)'="GUI" D 51 ;.D MSG 52 ;.S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 53 ;.D EN^ORCB(ORPT,???,ORDG,???) 54 ;.K ^TMP("ORR",$J) 55 ;.D EN^ORQ1(ORPT_";DPT(",ORDG,???,"","","",0,0) 56 ;.S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 57 ;..D DEL(.ORY,ORBXQAID) ;if no more orders req. co-sign, delete the alert 58 ;.K ^TMP("ORR",$J) 59 Q 60 EXDNR ;expiring dnr follow-up 61 K XQAKILL 62 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 63 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 64 N DNRORD,DNRY S DNRORD=$P(XQADATA,"@") 65 I $G(ORENVIR)="GUI" D 66 .S ORBY(1)=DNRY 67 I $G(ORENVIR)'="GUI" D 68 .D MSG 69 .D EN1^ORCB(DNRORD,"RENEW") ;display order, allow renewing, then delete 70 .D DEL(.ORY,ORBXQAID) 71 Q 72 UNLINKED ;unlinked provider follow-up 73 K XQAKILL 74 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 75 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 76 N ORNUM,ORUNY S ORNUM=$P(XQADATA,"@") 77 I $G(ORENVIR)="GUI" D 78 .S ORBY(1)=ORUNY 79 I $G(ORENVIR)'="GUI" D 80 .D MSG 81 .D EN1^ORCB(ORNUM,"REPLACE") ;display order, allow replace, then delete 82 .D DEL(.ORY,ORBXQAID) 83 Q 84 FLORD ;flagged order(s) follow-up 85 K XQAKILL 86 N ORPT,ORDG,X,ORBXQAID,ORY,ORBLMDEL 87 S ORBXQAID=XQAID 88 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 89 ;the FLG code for "FLAGGED" in ORQ1 is '12' 90 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",12,"","") 91 I $G(ORENVIR)'="GUI" D 92 .D MSG 93 .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 94 .D EN^ORCB(ORPT,12,ORDG,.ORBLMDEL) 95 .K ^TMP("ORR",$J) 96 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 97 .D EN^ORQ1(ORPT_";DPT(",ORDG,12,"","","",0,0) 98 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 99 ..D DEL(.ORY,ORBXQAID) ;if no more flagged orders found, delete alert 100 .K ^TMP("ORR",$J) 101 Q 102 NEWORD ;new order(s) follow-up 103 K XQAKILL 104 N ORPT,ORDG,ORSDT,OREDT,ENT,X,ORBXQAID,ORY,ORBLMDEL 105 S ORSDT="",OREDT="",ENT="USR",ORBXQAID=XQAID 106 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 107 ;the FLG code for NEW orders since last reviewed orders in ORQ1 is '6' 108 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",6,"","") 109 I $G(ORENVIR)'="GUI" D 110 .D MSG 111 .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 112 .D EN^ORCB(ORPT,6,ORDG,.ORBLMDEL) 113 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 114 .D DEL(.ORY,ORBXQAID) ;delete the alert 115 Q 116 DCORD ;DC order(s) follow-up 117 K XQAKILL 118 N ORPT,ORDG,ORSDT,OREDT,ENT,X,ORBXQAID,ORY,ORBLMDEL 119 S ORSDT="",OREDT="",ENT="USR",ORBXQAID=XQAID 120 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 121 ;the FLG code for DC orders is '3' 122 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",6,"","") 123 I $G(ORENVIR)'="GUI" D 124 .D MSG 125 .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 126 .D EN^ORCB(ORPT,6,ORDG,.ORBLMDEL) 127 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 128 .D DEL(.ORY,ORBXQAID) ;delete the alert 129 Q 130 NUMORD ;detailed order display follow-up - return order number 131 K XQAKILL 132 N ORBXQAID,ORY S ORBXQAID=XQAID 133 S ORNUM=$P(XQADATA,"@") 134 I $G(ORENVIR)="GUI" D 135 .Q 136 I $G(ORENVIR)'="GUI" D 137 .D MSG 138 .D EN1^ORCB(+ORNUM,"NEW") ;display order, allow new order then delete 139 .D DEL(.ORY,ORBXQAID) 140 Q 141 ESORD ;order(s) requiring electronic signature follow-up 142 K XQAKILL 143 N ORPT,ORDG,ORBXQAID,ORY,ORX,ORZ,ORDERS,ORDNUM,ORQUIT,ORBLMDEL 144 S ORBXQAID=XQAID,ORDERS=0,ORQUIT=0 145 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 146 ;the FLG code for UNSIGNED orders in ORQ1 is '11' 147 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",11,"","") 148 I $G(ORENVIR)'="GUI" D 149 .D MSG 150 .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 151 .D EN^ORCB(ORPT,11,ORDG,.ORBLMDEL) 152 .K ^TMP("ORR",$J) ;clean up array 153 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 154 .I $L($G(XQAID)) D ;EN^ORCB may kill XQAID in its follow-up 155 ..; 156 ..;get unsigned orders - if none exist, delete alert then quit: 157 ..D EN^ORQ1(ORPT_";DPT(",ORDG,11,"","","",0,0) 158 ..S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" I +$G(^TMP("ORR",$J,ORX,"TOT"))<1 D DEL(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q 159 ..; 160 ..;user does not have ORES key, delete user's alert: 161 ..I '$D(^XUSEC("ORES",DUZ)) S XQAKILL=1 D DEL(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q 162 ..; 163 ..;if prov is NOT linked to pt via attending, primary, teams or PCMM: 164 ..I $$PPLINK^ORQPTQ1(DUZ,ORPT)=0 D 165 ...S ORX="" F S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""!(ORDERS=1) D 166 ....S ORZ="" F S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:ORZ=""!(ORDERS=1) D 167 .....S ORDNUM=^TMP("ORR",$J,ORX,ORZ) 168 .....;quit if this unsigned order's last action was made by the user 169 .....I DUZ=+$$UNSIGNOR^ORQOR2(ORDNUM) S ORDERS=1 170 ...I ORDERS'=1 D ;provider has no outstanding unsiged orders for pt 171 ....S XQAKILL=1 D DEL(.ORY,ORBXQAID) ;delete alert for this user 172 ..K ^TMP("ORR",$J) 173 Q 174 UNFLAG(ORPT) ;order unflagged - delete alert if no more flagged orders 175 N ORDG 176 S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 177 K ^TMP("ORR",$J) 178 D EN^ORQ1(ORPT_";DPT(",ORDG,12,"","","",0,0) 179 S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 180 .;if no more flagged orders found, delete alert: 181 .S XQAKILL=$$XQAKILL^ORB3F1(6) 182 .I $G(XQAKILL)="" S XQAKILL=1 183 .S XQAID="OR,"_ORPT_",6" D DELETEA^XQALERT K XQAID,XQAKILL 184 K ^TMP("ORR",$J) 185 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3FUP2.m
r613 r623 1 ORB3FUP2 ; slc/CLA - Routine to support notification follow-up actions ;6/28/00 12:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**31,64,88,112,243**;Dec 17, 1997;Build 242 3 RESULT ;STAT, orderer-flagged and site-flagged result follow-up 4 ;determine what pkg to get report/results from then do RPTLAB or RPTRAD 5 N ORBFILL S ORBFILL=$P($P(XQADATA,"|",2),"@",2) 6 I ORBFILL["LR" D RPTLAB 7 I ORBFILL["RA" D RPTRAD 8 I ORBFILL["GMRC" D RPTCON 9 Q 10 CSPN ;co-sign progress note(s) follow-up 11 K XQAKILL 12 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 13 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 14 I $G(ORENVIR)="GUI" ;entry pt to get notes req co-sign then quit 15 ;joel rtn to display notes req co-signature and allow co-sign on vt 16 ;if lm fup action completed D DEL^ORB3FUP1(.ORY,ORBXQAID) 17 Q 18 USPN ;unsigned progress note(s) follow-up 19 K XQAKILL 20 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 21 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 22 I $G(ORENVIR)="GUI" ;entry pt to get unsigned notes then quit 23 ;joel rtn to display notes req signature and allow signature on vt 24 ;if lm fup action completed D DEL^ORB3FUP1(.ORY,ORBXQAID) 25 Q 26 EXMED ;expiring med(s) follow-up 27 K XQAKILL 28 N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL 29 S ORBXQAID=XQAID 30 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 31 ;the FLG code for EXPIRING orders in ORQ1 is '5' 32 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"RX",5,"","") 33 I $G(ORENVIR)'="GUI" D 34 .D MSG^ORB3FUP1 35 .S ORDG=$$DG^ORQOR1("RX") ;get Display Group ien 36 .D EN^ORCB(ORPT,5,ORDG,.ORBLMDEL) 37 .K ^TMP("ORR",$J) 38 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 39 .D EN^ORQ1(ORPT_";DPT(",ORDG,5,"","","",0,0) 40 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 41 ..D DEL^ORB3FUP1(.ORY,ORBXQAID) ;if no more EXPIRING orders found, delete the alert 42 .K X,^TMP("ORR",$J) 43 Q 44 UVMED ;unverified med(s) follow-up 45 K XQAKILL 46 N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL,ORADT 47 S ORBXQAID=XQAID 48 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 49 ;the FLG code for UNVERIFIED (NURSE) orders in ORQ1 is '9' 50 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"RX",9,"","") 51 I $G(ORENVIR)'="GUI" D 52 .D MSG^ORB3FUP1 53 .S ORDG=$$DG^ORQOR1("RX") ;get Display Group ien 54 .D EN^ORCB(ORPT,9,ORDG,.ORBLMDEL) 55 .K ^TMP("ORR",$J) 56 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 57 .; 58 .;if user doesn't have ORELSE or ORMAS keys (can't verify), 59 .; delete user's alert after display: 60 .I '$D(^XUSEC("ORELSE",DUZ)),('$D(^XUSEC("OREMAS",DUZ))) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) Q 61 .; 62 .;get current admission date/time: 63 .N DFN S DFN=ORPT,VA200="" D INP^VADPT 64 .S ORADT=$P($G(VAIN(7)),U) 65 .S ORADT=$S('$L($G(ORADT)):$$FMADD^XLFDT($$NOW^XLFDT,"-30"),1:ORADT) 66 .; 67 .;if no more UNVERIFIED MED orders found (within current admission or 68 .; past 30 days), delete the alert: 69 .D EN^ORQ1(ORPT_";DPT(",ORDG,9,"",ORADT,$$NOW^XLFDT,0,0) 70 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 71 ..D DEL^ORB3FUP1(.ORY,ORBXQAID) 72 .K X,^TMP("ORR",$J),VA200,VAIN 73 Q 74 UNVER ;unverified order(s) follow-up 75 K XQAKILL 76 N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL,ORADT 77 S ORBXQAID=XQAID 78 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 79 ;the FLG code for UNVERIFIED (NURSE) orders in ORQ1 is '9' 80 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",9,"","") 81 I $G(ORENVIR)'="GUI" D 82 .D MSG^ORB3FUP1 83 .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 84 .D EN^ORCB(ORPT,9,ORDG,.ORBLMDEL) 85 .K ^TMP("ORR",$J) 86 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 87 .; 88 .;if user doesn't have ORELSE or ORMAS keys (can't verify), 89 .; delete user's alert after display: 90 .I '$D(^XUSEC("ORELSE",DUZ)),('$D(^XUSEC("OREMAS",DUZ))) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) Q 91 .; 92 .;get current admission date/time: 93 .N DFN S DFN=ORPT,VA200="" D INP^VADPT 94 .S ORADT=$P($G(VAIN(7)),U) 95 .S ORADT=$S('$L($G(ORADT)):$$FMADD^XLFDT($$NOW^XLFDT,"-30"),1:ORADT) 96 .; 97 .;if no more UNVERIFIED orders found (within current admission or past 98 .; 30 days), delete the alert: 99 .D EN^ORQ1(ORPT_";DPT(",ORDG,9,"",ORADT,$$NOW^XLFDT,0,0) 100 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 101 ..D DEL^ORB3FUP1(.ORY,ORBXQAID) 102 .K X,^TMP("ORR",$J),VA200,VAIN 103 Q 104 NEWCON ;new consult/request follow-up 105 K XQAKILL 106 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 107 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 108 ;I $G(ORENVIR)="GUI" D ;comment out until GUI follow-up 109 ;.entry pt to get new consults then quit 110 I $G(ORENVIR)'="GUI" D 111 .D MSG^ORB3FUP1 112 .D EN^GMRCALRT(XQADATA,XQAID) ;display new c/r and allow action 113 .;D DEL^ORB3FUP1(.ORY,ORBXQAID) ;Dwight does the delete in GMRC 114 Q 115 UPCON ;updated consult/request follow-up 116 K XQAKILL 117 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 118 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 119 I $G(ORENVIR)'="GUI" D 120 .D MSG^ORB3FUP1 121 .D EN^GMRCALRT(XQADATA,XQAID) ;display updated c/r and allow action 122 Q 123 DCCON ;cancelled, held or DCed consult/request follow-up 124 K XQAKILL 125 N ORPT,NXQADATA 126 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 127 ;I $G(ORENVIR)="GUI" D ;comment out until GUI follow-up 128 ;.entry pt to get new consults then quit 129 I $G(ORENVIR)'="GUI" D 130 .D MSG^ORB3FUP1 131 .I XQADATA["GMRC" S NXQADATA=$P($P(XQADATA,"|",2),"@") D EN^GMRCEDIT(NXQADATA,XQAID) 132 .I +$G(NXQADATA)<1 D EN^GMRCEDIT(XQADATA,XQAID) 133 Q 134 RPTCON ;consult result follow-up 135 K XQAKILL 136 N NXQADATA 137 ;N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 138 ;S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 139 I $G(ORENVIR)="GUI" D DETAIL^ORQQCN(.ORBY,XQADATA) 140 I $G(ORENVIR)'="GUI" D 141 .D MSG^ORB3FUP1 142 .D EN^GMRCALRT(XQADATA,XQAID) 143 .;I XQADATA["GMRC" S NXQADATA=$P($P(XQADATA,"|",2),"@") D EN^GMRCALRT(NXQADATA,XQAID) 144 .;I +$G(NXQADATA)<1 D EN^GMRCALRT(XQADATA,XQAID) 145 .;D DEL^ORB3FUP1(.ORY,ORBXQAID) ;Dwight does the delete in GMRC 146 Q 147 RPTAP ; AP lab result follow-up 148 K XQAKILL 149 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 150 S ORPT=$P($P(ORBXQAID,";"),",",2) ;get pt dfn from xqaid 151 N ORACCNUM,ORDTSTKN S ORACCNUM=$P(XQADATA,U,2),ORDTSTKN=$P(XQADATA,U,3) 152 I $G(ORENVIR)'="GUI" D 153 .D MSG^ORB3FUP1 154 .D EN1^ORCXPND(ORPT,ORACCNUM_"-"_ORDTSTKN,"LABS") 155 .D DEL^ORB3FUP1(.ORY,ORBXQAID) 156 Q 157 RPTLAB ;lab result follow-up 158 K XQAKILL 159 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 160 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 161 N ORDER,ORLAB S ORDER=$P(XQADATA,"@") 162 I $G(ORENVIR)="GUI" D DETAIL^ORQQLR(.ORBY,ORPT,ORDER) 163 I $G(ORENVIR)'="GUI" D 164 .D MSG^ORB3FUP1 165 .;S ORLAB=$$OETOLAB^ORQQLR1(ORDER) 166 .;Q:'$L($G(ORLAB)) 167 .;D EN1^ORCXPND(ORPT,ORLAB,"LABS") ;api used lab # pre-6/97 168 .D EN1^ORCXPND(ORPT,ORDER,"LABS") 169 .D DEL^ORB3FUP1(.ORY,ORBXQAID) 170 Q 171 RPTRAD ;radiology result follow-up for HL7-triggered notifications 172 K XQAKILL 173 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 174 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 175 N INVDT,CASE S INVDT="",CASE="" 176 ;XQADATA is different for HL7-triggered vs. radiology pkg triggered 177 S INVDT=$P(XQADATA,"~",2),CASE=$P($P(XQADATA,"~",3),"@") 178 I $G(ORENVIR)="GUI" D DETAIL^ORQQRA(.ORBY,ORPT,INVDT,CASE) 179 I $G(ORENVIR)'="GUI" D 180 .D MSG^ORB3FUP1 181 .D EN1^ORCXPND(ORPT,INVDT_"-"_CASE,"XRAYS") 182 .D DEL^ORB3FUP1(.ORY,ORBXQAID) 183 Q 184 RPTRAD2 ;radiology result follow-up for radiology pkg-triggered notifications 185 K XQAKILL 186 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 187 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 188 N INVDT,CASE S INVDT="",CASE="" 189 ;XQADATA is different for HL7-triggered vs. radiology pkg triggered 190 S INVDT=$P(XQADATA,"~",1),CASE=$P(XQADATA,"~",2) 191 I $G(ORENVIR)="GUI" D DETAIL^ORQQRA(.ORBY,ORPT,INVDT,CASE) 192 I $G(ORENVIR)'="GUI" D 193 .D MSG^ORB3FUP1 194 .D EN1^ORCXPND(ORPT,INVDT_"-"_CASE,"XRAYS") 195 .D DEL^ORB3FUP1(.ORY,ORBXQAID) 196 Q 197 EXOI ;expiring flagged orderable items follow-up 198 K XQAKILL 199 N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL 200 S ORBXQAID=XQAID 201 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 202 ;the FLG code for EXPIRING orders in ORQ1 is '5' 203 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",5,"","") 204 I $G(ORENVIR)'="GUI" D 205 .D MSG^ORB3FUP1 206 .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 207 .D EN^ORCB(ORPT,5,ORDG,.ORBLMDEL) 208 .K ^TMP("ORR",$J) 209 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 210 .D EN^ORQ1(ORPT_";DPT(",ORDG,5,"","","",0,0) 211 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 212 ..D DEL^ORB3FUP1(.ORY,ORBXQAID) ;if no more EXPIRING orders found, delete the alert 213 .K X,^TMP("ORR",$J) 214 Q 215 INTCON ;consult interpretation follow-up 216 K XQAKILL 217 N NXQADATA 218 I $G(ORENVIR)'="GUI" D 219 .D MSG^ORB3FUP1 220 .R !!?5,"This alert must be processed in the CPRS GUI.",X:10 221 .K X 222 Q 223 CHGRAD ;radiology follow-up for #67 Imaging Request Changed 224 K XQAKILL 225 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 226 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 227 I $G(ORENVIR)'="GUI" D 228 .D MSG^ORB3FUP1 229 .I $L($T(EN1^RAO7PC4))>0 D 230 ..D EN1^RAO7PC4 ;display before and after change(s) 231 ..D DEL^ORB3FUP1(.ORY,ORBXQAID) 232 Q 233 INFODEL ;follow-up action to delete "informational" alerts 234 K XQAKILL 235 N ORY,ORBXQAID 236 S ORBXQAID=XQAID 237 D MSG^ORB3FUP1 238 D DEL^ORB3FUP1(.ORY,ORBXQAID) 239 Q 1 ORB3FUP2 ; slc/CLA - Routine to support notification follow-up actions ;6/28/00 12:00 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**31,64,88,112**;Dec 17, 1997 3 RESULT ;STAT, orderer-flagged and site-flagged result follow-up 4 ;determine what pkg to get report/results from then do RPTLAB or RPTRAD 5 N ORBFILL S ORBFILL=$P($P(XQADATA,"|",2),"@",2) 6 I ORBFILL["LR" D RPTLAB 7 I ORBFILL["RA" D RPTRAD 8 I ORBFILL["GMRC" D RPTCON 9 Q 10 CSPN ;co-sign progress note(s) follow-up 11 K XQAKILL 12 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 13 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 14 I $G(ORENVIR)="GUI" ;entry pt to get notes req co-sign then quit 15 ;joel rtn to display notes req co-signature and allow co-sign on vt 16 ;if lm fup action completed D DEL^ORB3FUP1(.ORY,ORBXQAID) 17 Q 18 USPN ;unsigned progress note(s) follow-up 19 K XQAKILL 20 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 21 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 22 I $G(ORENVIR)="GUI" ;entry pt to get unsigned notes then quit 23 ;joel rtn to display notes req signature and allow signature on vt 24 ;if lm fup action completed D DEL^ORB3FUP1(.ORY,ORBXQAID) 25 Q 26 EXMED ;expiring med(s) follow-up 27 K XQAKILL 28 N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL 29 S ORBXQAID=XQAID 30 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 31 ;the FLG code for EXPIRING orders in ORQ1 is '5' 32 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"RX",5,"","") 33 I $G(ORENVIR)'="GUI" D 34 .D MSG^ORB3FUP1 35 .S ORDG=$$DG^ORQOR1("RX") ;get Display Group ien 36 .D EN^ORCB(ORPT,5,ORDG,.ORBLMDEL) 37 .K ^TMP("ORR",$J) 38 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 39 .D EN^ORQ1(ORPT_";DPT(",ORDG,5,"","","",0,0) 40 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 41 ..D DEL^ORB3FUP1(.ORY,ORBXQAID) ;if no more EXPIRING orders found, delete the alert 42 .K X,^TMP("ORR",$J) 43 Q 44 UVMED ;unverified med(s) follow-up 45 K XQAKILL 46 N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL,ORADT 47 S ORBXQAID=XQAID 48 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 49 ;the FLG code for UNVERIFIED (NURSE) orders in ORQ1 is '9' 50 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"RX",9,"","") 51 I $G(ORENVIR)'="GUI" D 52 .D MSG^ORB3FUP1 53 .S ORDG=$$DG^ORQOR1("RX") ;get Display Group ien 54 .D EN^ORCB(ORPT,9,ORDG,.ORBLMDEL) 55 .K ^TMP("ORR",$J) 56 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 57 .; 58 .;if user doesn't have ORELSE or ORMAS keys (can't verify), 59 .; delete user's alert after display: 60 .I '$D(^XUSEC("ORELSE",DUZ)),('$D(^XUSEC("OREMAS",DUZ))) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) Q 61 .; 62 .;get current admission date/time: 63 .N DFN S DFN=ORPT,VA200="" D INP^VADPT 64 .S ORADT=$P($G(VAIN(7)),U) 65 .S ORADT=$S('$L($G(ORADT)):$$FMADD^XLFDT($$NOW^XLFDT,"-30"),1:ORADT) 66 .; 67 .;if no more UNVERIFIED MED orders found (within current admission or 68 .; past 30 days), delete the alert: 69 .D EN^ORQ1(ORPT_";DPT(",ORDG,9,"",ORADT,$$NOW^XLFDT,0,0) 70 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 71 ..D DEL^ORB3FUP1(.ORY,ORBXQAID) 72 .K X,^TMP("ORR",$J),VA200,VAIN 73 Q 74 UNVER ;unverified order(s) follow-up 75 K XQAKILL 76 N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL,ORADT 77 S ORBXQAID=XQAID 78 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 79 ;the FLG code for UNVERIFIED (NURSE) orders in ORQ1 is '9' 80 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",9,"","") 81 I $G(ORENVIR)'="GUI" D 82 .D MSG^ORB3FUP1 83 .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 84 .D EN^ORCB(ORPT,9,ORDG,.ORBLMDEL) 85 .K ^TMP("ORR",$J) 86 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 87 .; 88 .;if user doesn't have ORELSE or ORMAS keys (can't verify), 89 .; delete user's alert after display: 90 .I '$D(^XUSEC("ORELSE",DUZ)),('$D(^XUSEC("OREMAS",DUZ))) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) Q 91 .; 92 .;get current admission date/time: 93 .N DFN S DFN=ORPT,VA200="" D INP^VADPT 94 .S ORADT=$P($G(VAIN(7)),U) 95 .S ORADT=$S('$L($G(ORADT)):$$FMADD^XLFDT($$NOW^XLFDT,"-30"),1:ORADT) 96 .; 97 .;if no more UNVERIFIED orders found (within current admission or past 98 .; 30 days), delete the alert: 99 .D EN^ORQ1(ORPT_";DPT(",ORDG,9,"",ORADT,$$NOW^XLFDT,0,0) 100 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 101 ..D DEL^ORB3FUP1(.ORY,ORBXQAID) 102 .K X,^TMP("ORR",$J),VA200,VAIN 103 Q 104 NEWCON ;new consult/request follow-up 105 K XQAKILL 106 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 107 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 108 ;I $G(ORENVIR)="GUI" D ;comment out until GUI follow-up 109 ;.entry pt to get new consults then quit 110 I $G(ORENVIR)'="GUI" D 111 .D MSG^ORB3FUP1 112 .D EN^GMRCALRT(XQADATA,XQAID) ;display new c/r and allow action 113 .;D DEL^ORB3FUP1(.ORY,ORBXQAID) ;Dwight does the delete in GMRC 114 Q 115 UPCON ;updated consult/request follow-up 116 K XQAKILL 117 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 118 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 119 I $G(ORENVIR)'="GUI" D 120 .D MSG^ORB3FUP1 121 .D EN^GMRCALRT(XQADATA,XQAID) ;display updated c/r and allow action 122 Q 123 DCCON ;cancelled, held or DCed consult/request follow-up 124 K XQAKILL 125 N ORPT,NXQADATA 126 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 127 ;I $G(ORENVIR)="GUI" D ;comment out until GUI follow-up 128 ;.entry pt to get new consults then quit 129 I $G(ORENVIR)'="GUI" D 130 .D MSG^ORB3FUP1 131 .I XQADATA["GMRC" S NXQADATA=$P($P(XQADATA,"|",2),"@") D EN^GMRCEDIT(NXQADATA,XQAID) 132 .I +$G(NXQADATA)<1 D EN^GMRCEDIT(XQADATA,XQAID) 133 Q 134 RPTCON ;consult result follow-up 135 K XQAKILL 136 N NXQADATA 137 ;N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 138 ;S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 139 I $G(ORENVIR)="GUI" D DETAIL^ORQQCN(.ORBY,XQADATA) 140 I $G(ORENVIR)'="GUI" D 141 .D MSG^ORB3FUP1 142 .D EN^GMRCALRT(XQADATA,XQAID) 143 .;I XQADATA["GMRC" S NXQADATA=$P($P(XQADATA,"|",2),"@") D EN^GMRCALRT(NXQADATA,XQAID) 144 .;I +$G(NXQADATA)<1 D EN^GMRCALRT(XQADATA,XQAID) 145 .;D DEL^ORB3FUP1(.ORY,ORBXQAID) ;Dwight does the delete in GMRC 146 Q 147 RPTLAB ;lab result follow-up 148 K XQAKILL 149 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 150 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 151 N ORDER,ORLAB S ORDER=$P(XQADATA,"@") 152 I $G(ORENVIR)="GUI" D DETAIL^ORQQLR(.ORBY,ORPT,ORDER) 153 I $G(ORENVIR)'="GUI" D 154 .D MSG^ORB3FUP1 155 .;S ORLAB=$$OETOLAB^ORQQLR1(ORDER) 156 .;Q:'$L($G(ORLAB)) 157 .;D EN1^ORCXPND(ORPT,ORLAB,"LABS") ;api used lab # pre-6/97 158 .D EN1^ORCXPND(ORPT,ORDER,"LABS") 159 .D DEL^ORB3FUP1(.ORY,ORBXQAID) 160 Q 161 RPTRAD ;radiology result follow-up for HL7-triggered notifications 162 K XQAKILL 163 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 164 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 165 N INVDT,CASE S INVDT="",CASE="" 166 ;XQADATA is different for HL7-triggered vs. radiology pkg triggered 167 S INVDT=$P(XQADATA,"~",2),CASE=$P($P(XQADATA,"~",3),"@") 168 I $G(ORENVIR)="GUI" D DETAIL^ORQQRA(.ORBY,ORPT,INVDT,CASE) 169 I $G(ORENVIR)'="GUI" D 170 .D MSG^ORB3FUP1 171 .D EN1^ORCXPND(ORPT,INVDT_"-"_CASE,"XRAYS") 172 .D DEL^ORB3FUP1(.ORY,ORBXQAID) 173 Q 174 RPTRAD2 ;radiology result follow-up for radiology pkg-triggered notifications 175 K XQAKILL 176 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 177 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 178 N INVDT,CASE S INVDT="",CASE="" 179 ;XQADATA is different for HL7-triggered vs. radiology pkg triggered 180 S INVDT=$P(XQADATA,"~",1),CASE=$P(XQADATA,"~",2) 181 I $G(ORENVIR)="GUI" D DETAIL^ORQQRA(.ORBY,ORPT,INVDT,CASE) 182 I $G(ORENVIR)'="GUI" D 183 .D MSG^ORB3FUP1 184 .D EN1^ORCXPND(ORPT,INVDT_"-"_CASE,"XRAYS") 185 .D DEL^ORB3FUP1(.ORY,ORBXQAID) 186 Q 187 EXOI ;expiring flagged orderable items follow-up 188 K XQAKILL 189 N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL 190 S ORBXQAID=XQAID 191 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 192 ;the FLG code for EXPIRING orders in ORQ1 is '5' 193 I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",5,"","") 194 I $G(ORENVIR)'="GUI" D 195 .D MSG^ORB3FUP1 196 .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 197 .D EN^ORCB(ORPT,5,ORDG,.ORBLMDEL) 198 .K ^TMP("ORR",$J) 199 .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM 200 .D EN^ORQ1(ORPT_";DPT(",ORDG,5,"","","",0,0) 201 .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D 202 ..D DEL^ORB3FUP1(.ORY,ORBXQAID) ;if no more EXPIRING orders found, delete the alert 203 .K X,^TMP("ORR",$J) 204 Q 205 INTCON ;consult interpretation follow-up 206 K XQAKILL 207 N NXQADATA 208 I $G(ORENVIR)'="GUI" D 209 .D MSG^ORB3FUP1 210 .R !!?5,"This alert must be processed in the CPRS GUI.",X:10 211 .K X 212 Q 213 CHGRAD ;radiology follow-up for #67 Imaging Request Changed 214 K XQAKILL 215 N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID 216 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 217 I $G(ORENVIR)'="GUI" D 218 .D MSG^ORB3FUP1 219 .I $L($T(EN1^RAO7PC4))>0 D 220 ..D EN1^RAO7PC4 ;display before and after change(s) 221 ..D DEL^ORB3FUP1(.ORY,ORBXQAID) 222 Q 223 INFODEL ;follow-up action to delete "informational" alerts 224 K XQAKILL 225 N ORY,ORBXQAID 226 S ORBXQAID=XQAID 227 D MSG^ORB3FUP1 228 D DEL^ORB3FUP1(.ORY,ORBXQAID) 229 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3LAB.m
r613 r623 1 ORB3LAB ; slc/CLA/TC - Routine to trigger Lab-related notifications ;10/14/03 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**210,243**;Dec 17, 1997;Build 242 3 ; 4 LAB(ORDFN,ORLRDFN,ORLRI,ORLRA,ORLRSS,ORXQA) ;trigger Lab Anatomic Path notifs 5 ; called by SEND^LRAPRES1 (DBIA #4287) 6 ; 7 N ORBMSG,ORAPMD,ORBADUZ,ORSRPT,ORACCNO 8 I '$D(ORXQA) D 9 . S ORAPMD=$S(ORLRSS="AU":$P(ORLRA,U,12),1:$P(ORLRA,U,7)) ;provider/physician "ordering" the ap test 10 . I $L(ORAPMD) S ORBADUZ(ORAPMD)="" 11 I $D(ORXQA) M ORBADUZ=ORXQA 12 S ORSRPT=$S($D(^LR(ORLRDFN,84,0))!($D(^LR(ORLRDFN,ORLRSS,ORLRI,1.2,0))):" supplmntl rpt",1:"") ; AP supplmntl rpt - DBIA #5157 13 S ORBMSG=$S(ORLRSS="AU":"Autopsy",ORLRSS="CY":"Cytology",ORLRSS="SP":"Surgical Pathology",ORLRSS="EM":"Electron Microscopy",1:"Anatomic Pathology") 14 S ORBMSG=ORBMSG_ORSRPT_" results available." 15 S ORACCNO=$P(ORLRA,U,6) ;accession # of lab section 16 D EN^ORB3(71,ORDFN,"",.ORBADUZ,ORBMSG,ORLRSS_U_ORACCNO_U_ORLRI) ;XQADATA="Lab section^Accession#^DT specimen taken (inverse format)" 17 Q 1 ORB3LAB ; slc/CLA - Routine to trigger Lab-related notifications ;10/14/03 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**210**;Dec 17, 1997 3 ; 4 LAB(DFN,LRDFN,LRI,LRA,LRSS) ;trigger Lab Anatomic Path notifs 5 ; called by ADD^LRWOMEN (DBIA #4287) 6 ; 7 N ORBMSG,APMD,ORBADUZ,SRPT 8 S APMD=$P(LRA,U,7) ;provider/physician "ordering" the ap test 9 I $L(APMD) S ORBADUZ(APMD)="" 10 S SRPT=$P(LRA,U,15) ;original release date 11 S SRPT=$S($L(SRPT):" supplmntl rpt",1:"") 12 S ORBMSG=$S(LRSS="CY":"Cytology",LRSS="SP":"Surgical Pathology",1:"Anatomic Pathology") 13 S ORBMSG=ORBMSG_SRPT_" results available." 14 D EN^ORB3(71,DFN,"",.ORBADUZ,ORBMSG,"") 15 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA1.m
r613 r623 1 ORBCMA1 ; SLC/JLI - Pharmacy Calls for Windows Dialog [ 3/7/2006 ] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,243**;Dec 17, 1997;Build 242 3 ;;OR BCMA ORDER COM V1.0 ;**133**; Jan 19, 2002 4 ; 5 ODSLCT(LST,PSTYPE,DFN,LOC) ; return default lists for dialog 6 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) 7 N ILST S ILST=0 8 S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR 9 S ILST=ILST+1,LST(ILST)="~DispMsg" 10 S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG 11 ; 12 ; I PSTYPE="F" D Q ; IV Fluids 13 ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT 14 ; 15 I PSTYPE="O" D ; Outpatient 16 . S ILST=ILST+1,LST(ILST)="~Refills" 17 . S ILST=ILST+1,LST(ILST)="d0^0" 18 . S ILST=ILST+1,LST(ILST)="~Pickup" 19 . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC)) 20 . ; S ILST=ILST+1,LST(ILST)="~Supply" 21 . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN) 22 Q 23 PRIOR ; from DLGSLCT, get list of allowed priorities 24 N X,XREF 25 S X=0 26 S X=$O(^ORD(101.42,"B","DONE",X)) 27 S ILST=ILST+1,LST(ILST)="d"_X_U_$P(^ORD(101.42,X,0),U,2) 28 Q 29 DEFPICK(LOC) ; return default routing 30 N X,DLG,PRMT 31 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" 32 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) 33 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) 34 I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action 35 ; 36 S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I") 37 I X="C" S X="C^in Clinic" G XPICK 38 I X="M" S X="M^by Mail" G XPICK 39 I X="W" S X="W^at Window" G XPICK 40 I X="N" S X="" G XPICK 41 I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") 42 XPICK Q X 43 ; 44 DEFSPLY(DFN) ; return default days supply for this patient 45 N ORWX 46 S ORWX("PATIENT")=DFN 47 D DSUP^PSOSIGDS(.ORWX) 48 Q $G(ORWX("DAYS SUPPLY")) 49 ; 50 DFLTSPLY(VAL,UPD,SCH,PAT,DRG) ; return days supply given quantity 51 ; VAL: default days supply 52 N ORWX,I 53 S ORWX("PATIENT")=PAT 54 I DRG S ORWX("DRUG")=DRG 55 F I=1:1:$L(UPD,U)-1 D 56 . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) 57 . S ORWX("SCHEDULE",I)=$P(SCH,U,I) 58 D DSUP^PSOSIGDS(.ORWX) 59 S VAL=$G(ORWX("DAYS SUPPLY")) 60 Q 61 DISPMSG() ; return 1 to suppress dispense message 62 Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I") 63 ; 64 SCHALL(LST) ; return all schedules 65 N ILST,SCH,IEN,EXP,TYP,X0 66 K ^TMP($J,"ORBCMA1 SCHALL") 67 D AP^PSS51P1("PSJ",,,,"ORBCMA1 SCHALL") 68 S ILST=0,SCH="" 69 F S SCH=$O(^TMP($J,"ORBCMA1 SCHALL","APPSJ",SCH)) Q:SCH="" D 70 . I (SCH="STAT")!(SCH="NOW") D 71 .. S IEN=$O(^TMP($J,"ORBCMA1 SCHALL","APPSJ",SCH,"")) 72 .. S EXP=$G(^TMP($J,"ORBCMA1 SCHALL",SCH,8)) 73 .. S TYP=$P($G(^TMP($J,"ORBCMA1 SCHALL",SCH,5)),U) 74 .. S ILST=ILST+1,LST(ILST)=SCH_U_EXP_U_TYP 75 K ^TMP($J,"ORBCMA1 SCHALL") 76 Q 77 FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives 78 N PSID,I 79 S IEN=+$P(^ORD(101.43,IEN,0),U,2) 80 D EN1^PSSUTIL1(.IEN,PSTYPE) 81 S PSID=0,I=0 82 F S PSID=$O(IEN(PSID)) Q:'PSID D 83 . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0)) 84 . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U) 85 Q 86 DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose 87 N I,OI,ORWLST,ILST S ILST=0 88 D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST) 89 S I=0 F S I=$O(ORWLST(I)) Q:'I D 90 . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0)) 91 . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U) 92 Q 93 FAILDEA(FAIL,OI,ORNP,PSTYPE) ; return 1 if DEA check fails for this provider 94 N DEAFLG,PSOI 95 S FAIL=0,PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) Q:PSOI'>0 96 I '$L($T(OIDEA^PSSUTLA1)) Q 97 S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0 98 I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1 99 Q 100 CHK94(VAL) ; return 1 if patch 94 has been installed 101 S VAL=0 102 I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1 103 Q 1 ORBCMA1 ; SLC/JLI - Pharmacy Calls for Windows Dialog [ 2/11/02 4:30PM ] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133**;Dec 17, 1997 3 ;;OR BCMA ORDER COM V1.0 ;**133**; Jan 19, 2002 4 ; 5 ODSLCT(LST,PSTYPE,DFN,LOC) ; return default lists for dialog 6 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) 7 N ILST S ILST=0 8 S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR 9 S ILST=ILST+1,LST(ILST)="~DispMsg" 10 S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG 11 ; 12 ; I PSTYPE="F" D Q ; IV Fluids 13 ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT 14 ; 15 I PSTYPE="O" D ; Outpatient 16 . S ILST=ILST+1,LST(ILST)="~Refills" 17 . S ILST=ILST+1,LST(ILST)="d0^0" 18 . S ILST=ILST+1,LST(ILST)="~Pickup" 19 . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC)) 20 . ; S ILST=ILST+1,LST(ILST)="~Supply" 21 . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN) 22 Q 23 PRIOR ; from DLGSLCT, get list of allowed priorities 24 N X,XREF 25 S X=0 26 S X=$O(^ORD(101.42,"B","DONE",X)) 27 S ILST=ILST+1,LST(ILST)="d"_X_U_$P(^ORD(101.42,X,0),U,2) 28 Q 29 DEFPICK(LOC) ; return default routing 30 N X,DLG,PRMT 31 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" 32 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) 33 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) 34 I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action 35 ; 36 S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I") 37 I X="C" S X="C^in Clinic" G XPICK 38 I X="M" S X="M^by Mail" G XPICK 39 I X="W" S X="W^at Window" G XPICK 40 I X="N" S X="" G XPICK 41 I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") 42 XPICK Q X 43 ; 44 DEFSPLY(DFN) ; return default days supply for this patient 45 N ORWX 46 S ORWX("PATIENT")=DFN 47 D DSUP^PSOSIGDS(.ORWX) 48 Q $G(ORWX("DAYS SUPPLY")) 49 ; 50 DFLTSPLY(VAL,UPD,SCH,PAT,DRG) ; return days supply given quantity 51 ; VAL: default days supply 52 N ORWX,I 53 S ORWX("PATIENT")=PAT 54 I DRG S ORWX("DRUG")=DRG 55 F I=1:1:$L(UPD,U)-1 D 56 . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) 57 . S ORWX("SCHEDULE",I)=$P(SCH,U,I) 58 D DSUP^PSOSIGDS(.ORWX) 59 S VAL=$G(ORWX("DAYS SUPPLY")) 60 Q 61 DISPMSG() ; return 1 to suppress dispense message 62 Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I") 63 ; 64 SCHALL(LST) ; return all schedules 65 N ILST,SCH,IEN,EXP,TYP,X0 66 S ILST=0,SCH="" 67 F S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH="" D 68 . I (SCH="STAT")!(SCH="NOW") D 69 .. S IEN=$O(^PS(51.1,"APPSJ",SCH,0)) 70 .. S X0=$G(^PS(51.1,IEN,0)),EXP=$P(X0,U,8),TYP=$P(X0,U,5) 71 .. S ILST=ILST+1,LST(ILST)=SCH_U_EXP_U_TYP 72 Q 73 FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives 74 N PSID,I 75 S IEN=+$P(^ORD(101.43,IEN,0),U,2) 76 D EN1^PSSUTIL1(.IEN,PSTYPE) 77 S PSID=0,I=0 78 F S PSID=$O(IEN(PSID)) Q:'PSID D 79 . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0)) 80 . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U) 81 Q 82 DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose 83 N I,OI,ORWLST,ILST S ILST=0 84 D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST) 85 S I=0 F S I=$O(ORWLST(I)) Q:'I D 86 . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0)) 87 . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U) 88 Q 89 FAILDEA(FAIL,OI,ORNP,PSTYPE) ; return 1 if DEA check fails for this provider 90 N DEAFLG,PSOI 91 S FAIL=0,PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) Q:PSOI'>0 92 I '$L($T(OIDEA^PSSUTLA1)) Q 93 S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0 94 I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1 95 Q 96 CHK94(VAL) ; return 1 if patch 94 has been installed 97 S VAL=0 98 I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1 99 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA32.m
r613 r623 1 ORBCMA32 ; SLC/JLI - Pharmacy Calls for GUI Dialog 02/11/2008 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,243**;Dec 17, 1997;Build 242 3 ;;BCMA ORDER V1.0 ;**133,243**;Jan 17, 2002 4 ; 5 NXT() ; -- returns next available index in return data array 6 S ILST=ILST+1 7 Q ILST 8 ; 9 DLGSLCT(LST,PSTYPE) ; return default lists for dialog 10 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) 11 N ILST S ILST=0 12 I PSTYPE="F" D Q ; IV Fluids 13 . S LST($$NXT)="~ShortList" D SHORT 14 . S LST($$NXT)="~Priorities" D PRIOR 15 ; 16 S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpatient 17 S LST($$NXT)="~Schedules" D SCHED 18 S LST($$NXT)="~Priorities" D PRIOR 19 I PSTYPE="O" D ; Outpatient 20 . S LST($$NXT)="~Pickup" D PICKUP 21 . S LST($$NXT)="~SCStatus" D SCLIST 22 Q 23 SHORT ; from DLGSLCT, get short list of med quick orders 24 N I,X,TMP 25 I PSTYPE="U" S X="UD RX" 26 I PSTYPE="F" S X="IV RX" 27 I PSTYPE="O" S X="O RX" 28 D GETQLST^ORWDXQ(.TMP,X,"iQ") 29 S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I) 30 Q 31 SCHED ; from DLGSLCT, get all pharmacy administration schedules 32 N X 33 K ^TMP($J,"ORBCMA32 SCHED") 34 D AP^PSS51P1("PSJ",,,,"ORBCMA32 SCHED") 35 S X="" F S X=$O(^TMP($J,"ORBCMA32 SCHED","APPSJ",X)) Q:X="" S LST($$NXT)="i"_X 36 K ^TMP($J,"ORBCMA32 SCHED") 37 Q 38 SCHEDA ; (similar to SCHED, but also returns administration times) 39 N X,IEN,SCH 40 K ^TMP($J,"ORBCMA32 SCHEDA") 41 D AP^PSS51P1("PSJ",,,,"ORBCMA32 SCHEDA") 42 S SCH="" F S SCH=$O(^TMP($J,"ORBCMA32 SCHEDA","APPSJ",SCH)) Q:SCH="" D 43 . S IEN=0 F S IEN=$O(^TMP($J,"ORBCMA32 SCHEDA","APPSJ",SCH,IEN)) Q:IEN'>0 D 44 . . S X=$S($L(^TMP($J,"ORBCMA32 SCHEDA",IEN,2)):" ("_^TMP($J,"ORBCMA32 SCHEDA",IEN,2)_")",1:"") 45 . . S LST($$NXT)="i"_IEN_U_SCH_X 46 Q 47 PRIOR ; from DLGSLCT, get list of allowed priorities 48 N X,XREF 49 S X=0 50 S X=$O(^ORD(101.42,"B","DONE",X)) 51 S LST($$NXT)="i"_X_U_$P(^ORD(101.42,X,0),U,2) 52 Q 53 PICKUP ; from DLGSLCT, get prescription routing 54 N X,EDITONLY 55 F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X 56 S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X 57 Q 58 DEFPICK() ; return default routing 59 N X,DLG,PRMT 60 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" 61 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) 62 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) 63 I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action 64 ; 65 S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I") 66 I X="C" S X="C^in Clinic" G XPICK 67 I X="M" S X="M^by Mail" G XPICK 68 I X="W" S X="W^at Window" G XPICK 69 I X="N" S X="" G XPICK 70 I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") 71 XPICK Q X 72 ; 73 SCLIST ; from DLGSLCT, get options for service connected 74 F X="0^No","1^Yes" S LST($$NXT)="i"_X 75 Q 76 ; 77 OISLCT(LST,OI,PSTYPE,ORVP) ; return for defaults for pharmacy orderable item 78 N ILST S ILST=0 79 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 80 S LST($$NXT)="~Dispense" D DISPDRG 81 S LST($$NXT)="~Instruct" D INSTRCT 82 S LST($$NXT)="~Route" D ROUTE 83 S LST($$NXT)="~Message" D MESSAGE 84 I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J) 85 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 86 Q 87 ; 88 DISPDRUG(LST,OI) ; list dispense drugs for an orderable item 89 N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG 90 Q 91 ; 92 DISPDRG ; from OISLCT, get dispense drugs for this pharmacy orderable item 93 N I,ORTMP,ORX 94 S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",") 95 I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP) 96 I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) 97 S I="" F S I=$O(ORTMP(I)) Q:I="" D 98 . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF" 99 . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5) 100 . S LST($$NXT)="i"_ORTMP(I) 101 Q 102 INSTRCT ; from OISLCT, get list of potential instructions (based on drug form) 103 N INOUN,NOUN,IINS,INS,VERB,INSREC 104 D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2)) 105 I PSTYPE="U" Q ; don't use the instructions list for inpatients 106 S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D 107 . S INSREC=$G(^TMP("PSJINS",$J,IINS)) 108 . I '$D(VERB) S VERB=$P(INSREC,U) 109 . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2) 110 S LST($$NXT)="~Nouns" 111 S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D 112 . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U) 113 I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB 114 ; 115 Q 116 MIXED(X) ; Return mixed case 117 Q X ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") 118 ; 119 ROUTE ; from OISLCT, get list of routes for the drug form 120 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX 121 N I,CNT,ABBR,IEN,ROUT,X 122 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 123 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) 124 . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR 125 . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default 126 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 127 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) 128 . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR 129 Q 130 MESSAGE ; message 131 S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0) 132 Q 133 ALLROUTE(LST) ; returns a list of all available med routes 134 N I,X,ILST 135 S ILST=0 136 K ^TMP($J,"ORWDPS32 ALLROUTE") 137 D ALL^PSS51P2(,"??",,,"ORWDPS32 ALLROUTE") 138 S I=0 F S I=$O(^TMP($J,"ORWDPS32 ALLROUTE",I)) Q:'I D 139 . I +$P(^TMP($J,"ORWDPS32 ALLROUTE",I,3),U)>0 S LST($$NXT)=I_U_^TMP($J,"ORWDPS32 ALLROUTE",I,.01)_U_^TMP($J,"ORWDPS32 ALLROUTE",I,1) 140 Q 141 VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation 142 N ABBR,NAME,IEN 143 K ^TMP($J,"ORBCMA32 VALROUTE") 144 S X=$$UPPER(X) 145 D ALL^PSS51P2(,X,,1,"ORBCMA32 VALROUTE") 146 I $P(^TMP($J,"ORBCMA32 VALROUTE",0),U)=-1 K ^TMP($J,"ORBCMA32 VALROUTE") S REC=0 Q 147 S IEN=$O(^TMP($J,"ORBCMA32 VALROUTE","B",X,"")) 148 I IEN'>0 S IEN=$O(^TMP($J,"ORBCMA32 VALROUTE","C",X,"")) 149 I IEN'>0 S REC=0 Q 150 S NAME=$G(^TMP($J,"ORBCMA32 VALROUTE",IEN,.01)) 151 S ABBR=$G(^TMP($J,"ORBCMA32 VALROUTE",IEN,1)) 152 I '$L(ABBR) S ABBR=NAME 153 I ($$UPPER(NAME)'=X),($$UPPER(ABBR)'=X) S REC=0 K ^TMP($J,"ORBCMA32 VALROUTE") Q 154 S REC=IEN_U_ABBR 155 K ^TMP($J,"ORBCMA32 VALROUTE") 156 Q 157 AUTH(VAL,PRV) ; For inpatient meds, check restrictions 158 N NAME,AUTH,INACT,X S VAL=0 159 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) 160 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) 161 I 'AUTH!(INACT&(DT>INACT)) D Q 162 . S VAL="1^"_NAME_" is not authorized to write medication orders." 163 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q 164 . S VAL="1^OREMAS key holders may not enter medication orders." 165 Q 166 DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug 167 N X S X=$$ENDCM^PSJORUTL(IEN) 168 S VAL=$P(X,U,2)_U_$P(X,U,4) 169 Q 170 MEDISIV(VAL,IEN) ; return true if orderable item is IV medication 171 S VAL=0 172 I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1 173 Q 174 ISSPLY(VAL,IEN) ; return true if orderable item is a supply 175 S VAL=0 176 I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1 177 Q 178 IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln 179 N I,PSOI,ORWY,AMT,IVFLAG 180 S IVFLAG=$P(OI,U,2) 181 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)_ORWTYP,VAL="" 182 I IVFLAG="NF" D ENVOL2^PSJORUT2(PSOI,.ORWY) 183 I IVFLAG="" D ENVOL^PSJORUT2(PSOI,.ORWY) 184 I ORWTYP="B" D 185 . S I=0 F S I=$O(ORWY(I)) Q:I'>0 S AMT(+ORWY(I))="" 186 . S AMT=0,VAL="ML" F S AMT=$O(AMT(AMT)) Q:AMT'>0 S VAL=VAL_U_AMT 187 I ORWTYP="A" D 188 . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2) 189 . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL" 190 Q 191 VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid 192 I $E($RE($$UPPER(X)),1,5)="RH/LM" S X=$E(X,1,$L(X)-5) 193 S X=$$TRIM(X) 194 D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0) 195 Q 196 UPPER(X) ; return uppercase 197 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 198 ; 199 TRIM(X) ; trim leading and trailing spaces 200 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail 201 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead 202 Q X 203 SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient 204 N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0 205 I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS 206 I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS 207 S VAL=1 208 XSCSTS Q 209 FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives 210 D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST) 211 S I=0 F S I=$O(ORLST(I)) Q:'I D 212 . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0)) 213 . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U) 214 Q 215 VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not 216 I '$L($T(EN^PSSGSGUI)) S OK=-1 Q 217 I $E($T(EN^PSSGSGUI),1,4)="EN(X" D 218 . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I")) 219 . K X S:$D(ORX) X=ORX 220 E D 221 . D EN^PSSGSGUI 222 S OK=$S($D(X):1,1:0) 223 Q 224 VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not 225 ; to be compatible with LM, make sure X is integer from 1 to 240 226 ; this is based on the input transform from 52,7 227 K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X 228 S OK=$S($D(X):1,1:0) 229 Q 230 DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY 231 N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O" 232 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) 233 S ORI=0 F S ORI=$O(ORTMP(ORI)) Q:'ORI S ORWDRG=+ORTMP(ORI) D 234 . K ^TMP($J,"ORBCMA32 DRUG") 235 . D NDF^PSS50(+ORWDRG,,,,,"ORBCMA32 DRUG") 236 . S VAPN=$P($G(^TMP($J,"ORBCMA32 DRUG",+ORWDRG,22)),U),NDF=$P($G(^TMP($J,"ORBCMA32 DRUG",+ORWDRG,20)),U) 237 . S X=$$DFSU^PSNAPIS(NDF,VAPN) 238 . S LSTA($P(X,U,4),$P(X,U,6))="" 239 . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))="" 240 K ^TMP($J,"ORBCMA32 DRUG") 241 S ORI="",ILST=0 F S ORI=$O(LSTA(ORI)) Q:ORI="" D 242 . S ORJ="" F S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ="" D 243 . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ 244 Q 1 ORBCMA32 ; SLC/JLI - Pharmacy Calls for GUI Dialog ;01/17/02 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,237**;Dec 17, 1997 3 ;;BCMA ORDER V1.0 ;**133,237**;Jan 17, 2002 4 ; 5 NXT() ; -- returns next available index in return data array 6 S ILST=ILST+1 7 Q ILST 8 ; 9 DLGSLCT(LST,PSTYPE) ; return default lists for dialog 10 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) 11 N ILST S ILST=0 12 I PSTYPE="F" D Q ; IV Fluids 13 . S LST($$NXT)="~ShortList" D SHORT 14 . S LST($$NXT)="~Priorities" D PRIOR 15 ; 16 S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpatient 17 S LST($$NXT)="~Schedules" D SCHED 18 S LST($$NXT)="~Priorities" D PRIOR 19 I PSTYPE="O" D ; Outpatient 20 . S LST($$NXT)="~Pickup" D PICKUP 21 . S LST($$NXT)="~SCStatus" D SCLIST 22 Q 23 SHORT ; from DLGSLCT, get short list of med quick orders 24 ; !!! change this so that it uses the ORWDXQ call!!! 25 N I,X,TMP 26 I PSTYPE="U" S X="UD RX" 27 I PSTYPE="F" S X="IV RX" 28 I PSTYPE="O" S X="O RX" 29 D GETQLST^ORWDXQ(.TMP,X,"iQ") 30 S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I) 31 Q 32 SCHED ; from DLGSLCT, get all pharmacy administration schedules 33 N X 34 S X="" F S X=$O(^PS(51.1,"APPSJ",X)) Q:X="" S LST($$NXT)="i"_X 35 Q 36 SCHEDA ; (similar to SCHED, but also returns administration times) 37 N X,IEN,SCH 38 S SCH="" F S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH="" D 39 . S IEN=0 F S IEN=$O(^PS(51.1,"APPSJ",SCH,IEN)) Q:IEN'>0 D 40 . . S X=^PS(51.1,IEN,0) S X=$S($L($P(X,U,2)):" ("_$P(X,U,2)_")",1:"") 41 . . S LST($$NXT)="i"_IEN_U_SCH_X 42 Q 43 PRIOR ; from DLGSLCT, get list of allowed priorities 44 N X,XREF 45 S X=0 46 S X=$O(^ORD(101.42,"B","DONE",X)) 47 S LST($$NXT)="i"_X_U_$P(^ORD(101.42,X,0),U,2) 48 Q 49 PICKUP ; from DLGSLCT, get prescription routing 50 N X,EDITONLY 51 F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X 52 S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X 53 Q 54 DEFPICK() ; return default routing 55 N X,DLG,PRMT 56 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" 57 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) 58 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) 59 I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action 60 ; 61 S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I") 62 I X="C" S X="C^in Clinic" G XPICK 63 I X="M" S X="M^by Mail" G XPICK 64 I X="W" S X="W^at Window" G XPICK 65 I X="N" S X="" G XPICK 66 I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") 67 XPICK Q X 68 ; 69 SCLIST ; from DLGSLCT, get options for service connected 70 F X="0^No","1^Yes" S LST($$NXT)="i"_X 71 Q 72 ; 73 OISLCT(LST,OI,PSTYPE,ORVP) ; return for defaults for pharmacy orderable item 74 N ILST S ILST=0 75 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 76 S LST($$NXT)="~Dispense" D DISPDRG 77 S LST($$NXT)="~Instruct" D INSTRCT 78 S LST($$NXT)="~Route" D ROUTE 79 S LST($$NXT)="~Message" D MESSAGE 80 I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J) 81 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 82 Q 83 ; 84 DISPDRUG(LST,OI) ; list dispense drugs for an orderable item 85 N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG 86 Q 87 ; 88 DISPDRG ; from OISLCT, get dispense drugs for this pharmacy orderable item 89 N I,ORTMP,ORX 90 S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",") 91 I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP) 92 I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) 93 S I="" F S I=$O(ORTMP(I)) Q:I="" D 94 . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF" 95 . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5) 96 . S LST($$NXT)="i"_ORTMP(I) 97 Q 98 INSTRCT ; from OISLCT, get list of potential instructions (based on drug form) 99 N INOUN,NOUN,IINS,INS,VERB,INSREC 100 D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2)) 101 I PSTYPE="U" Q ; don't use the instructions list for inpatients 102 S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D 103 . S INSREC=$G(^TMP("PSJINS",$J,IINS)) 104 . I '$D(VERB) S VERB=$P(INSREC,U) 105 . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2) 106 S LST($$NXT)="~Nouns" 107 S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D 108 . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U) 109 I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB 110 ; 111 Q 112 MIXED(X) ; Return mixed case 113 Q X ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") 114 ; 115 ROUTE ; from OISLCT, get list of routes for the drug form 116 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX 117 N I,CNT,ABBR,IEN,ROUT,X 118 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 119 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) 120 . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR 121 . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default 122 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 123 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) 124 . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR 125 Q 126 MESSAGE ; message 127 S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0) 128 Q 129 ALLROUTE(LST) ; returns a list of all available med routes 130 N I,X,ILST S ILST=0 131 S I=0 F S I=$O(^PS(51.2,I)) Q:'I S X=^(I,0) D 132 . I $P(X,U,4) S LST($$NXT)=I_U_$P(X,U)_U_$P(X,U,3) 133 Q 134 VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation 135 N ORLST,ABBR 136 D FIND^DIC(51.2,"",1,"MO",X,1,,"I $P(^(0),U,4)=1",,"ORLST") 137 I 'ORLST("DILIST",0) S REC=0 Q 138 S X=$$UPPER(X),ABBR=ORLST("DILIST","ID",1,1) 139 I '$L(ABBR) S ABBR=ORLST("DILIST",1,1) 140 I ($$UPPER(ORLST("DILIST",1,1))'=X),($$UPPER(ABBR)'=X) S REC=0 Q 141 S REC=ORLST("DILIST",2,1)_U_ABBR 142 Q 143 AUTH(VAL,PRV) ; For inpatient meds, check restrictions 144 N NAME,AUTH,INACT,X S VAL=0 145 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) 146 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) 147 I 'AUTH!(INACT&(DT>INACT)) D Q 148 . S VAL="1^"_NAME_" is not authorized to write medication orders." 149 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q 150 . S VAL="1^OREMAS key holders may not enter medication orders." 151 Q 152 DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug 153 N X S X=$$ENDCM^PSJORUTL(IEN) 154 S VAL=$P(X,U,2)_U_$P(X,U,4) 155 Q 156 MEDISIV(VAL,IEN) ; return true if orderable item is IV medication 157 S VAL=0 158 I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1 159 Q 160 ISSPLY(VAL,IEN) ; return true if orderable item is a supply 161 S VAL=0 162 I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1 163 Q 164 IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln 165 N I,PSOI,ORWY,AMT,IVFLAG 166 S IVFLAG=$P(OI,U,2) 167 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)_ORWTYP,VAL="" 168 I IVFLAG="NF" D ENVOL2^PSJORUT2(PSOI,.ORWY) 169 I IVFLAG="" D ENVOL^PSJORUT2(PSOI,.ORWY) 170 I ORWTYP="B" D 171 . S I=0 F S I=$O(ORWY(I)) Q:I'>0 S AMT(+ORWY(I))="" 172 . S AMT=0,VAL="ML" F S AMT=$O(AMT(AMT)) Q:AMT'>0 S VAL=VAL_U_AMT 173 I ORWTYP="A" D 174 . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2) 175 . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM" 176 Q 177 VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid 178 I $E($RE($$UPPER(X)),1,5)="RH/LM" S X=$E(X,1,$L(X)-5) 179 S X=$$TRIM(X) 180 D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0) 181 Q 182 UPPER(X) ; return uppercase 183 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 184 ; 185 TRIM(X) ; trim leading and trailing spaces 186 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail 187 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead 188 Q X 189 SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient 190 N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0 191 I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS 192 I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS 193 S VAL=1 194 XSCSTS Q 195 FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives 196 D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST) 197 S I=0 F S I=$O(ORLST(I)) Q:'I D 198 . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0)) 199 . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U) 200 Q 201 VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not 202 I '$L($T(EN^PSSGSGUI)) S OK=-1 Q 203 I $E($T(EN^PSSGSGUI),1,4)="EN(X" D 204 . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I")) 205 . K X S:$D(ORX) X=ORX 206 E D 207 . D EN^PSSGSGUI 208 S OK=$S($D(X):1,1:0) 209 Q 210 VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not 211 ; to be compatible with LM, make sure X is integer from 1 to 240 212 ; this is based on the input transform from 52,7 213 K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X 214 S OK=$S($D(X):1,1:0) 215 Q 216 DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY 217 N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O" 218 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) 219 S ORI=0 F S ORI=$O(ORTMP(ORI)) Q:'ORI S ORWDRG=+ORTMP(ORI) D 220 . S NDF=$G(^PSDRUG(+ORWDRG,"ND")),VAPN=$P(NDF,U,3),NDF=+NDF 221 . S X=$$DFSU^PSNAPIS(NDF,VAPN) 222 . S LSTA($P(X,U,4),$P(X,U,6))="" 223 . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))="" 224 S ORI="",ILST=0 F S ORI=$O(LSTA(ORI)) Q:ORI="" D 225 . S ORJ="" F S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ="" D 226 . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ 227 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT0.m
r613 r623 1 ORCACT0 ;SLC/MKB-Validate order action ;5/19/08 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,86,92,94,141,165,177,173,190,215,243**;Dec 17, 1997;Build 242 3 ; 4 VALID(IFN,ACTION,ERROR,NATR) ; -- Determines if action is valid for order IFN 5 N OR0,OR3,ORA0,AIFN,PKG,DG,ORDSTS,ACTSTS,VER,X,Y,MEDPARM K ERROR 6 S OR0=$G(^OR(100,+IFN,0)),OR3=$G(^(3)),PKG=$$NMSP^ORCD($P(OR0,U,14)) 7 S DG=$P($G(^ORD(100.98,+$P(OR0,U,11),0)),U,3) 8 S MEDPARM=$S($G(NATR)="A":2,PKG'="PS":2,'$D(^XUSEC("OREMAS",DUZ)):2,DG="NV RX":$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS"),1:$$GET^XPAR("ALL","OR OREMAS MED ORDERS")) 9 S AIFN=$P(IFN,";",2) S:'AIFN AIFN=+$P(OR3,U,7) 10 S ORA0=$G(^OR(100,+IFN,8,AIFN,0)),ACTSTS=$P(ORA0,U,15) 11 S ORDSTS=$P(OR3,U,3),VER=$S($P(OR0,U,5)["101.41":3,1:2) 12 CM I ACTION="CM" S ERROR="This action is no longer available!" G VQ ; ward comments - no restrictions 13 FL I ACTION="FL" D G VQ ; flag 14 . I +$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is already flagged!" Q 15 UF I ACTION="UF" D G VQ ; unflag 16 . I '+$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is not flagged!" Q 17 DC1 I ACTION="DC",ACTSTS D G VQ ; discontinue/cancel unrel or canc order 18 . I (ACTSTS=11)!(ACTSTS=10) D Q ; unreleased 19 .. I 'MEDPARM S ERROR="You are not authorized to cancel med orders!" Q 20 .. I $G(NATR)="A" S X=$O(^ORE(100.2,"AO",+IFN,0)) I X,'$G(^ORE(100.2,X,1)) S ERROR="Future event orders may not be auto-discontinued!" Q 21 . I ACTSTS=12 S ERROR="This order has been dc'd due to edit!" Q 22 . I ACTSTS=13 S ERROR="This order has been cancelled!" Q 23 ES I (ACTION="ES")!(ACTION="OC")!(ACTION="RS")!(ACTION="DS") D ES^ORCACT01 G VQ ; sign 24 VR I ACTION="VR" D G VQ ; verify 25 . I $G(ORVER)="N",$P(ORA0,U,9) S ERROR="This order has been verified!" Q 26 . I $G(ORVER)="C",$P(ORA0,U,11) S ERROR="This order has been verified!" Q 27 . I $G(ORVER)="R",$P(ORA0,U,19) S ERROR="This order has been reviewed!" Q 28 . I (ACTSTS=11)!(ACTSTS=10) S ERROR="This order has not been released to the service." Q 29 . I AIFN=1,ORDSTS=5,PKG="PS" S X=$$DISABLED I X S ERROR=$P(X,U,2) Q 30 DIS S X=$$DISABLED I X S ERROR=$P(X,U,2) G VQ 31 MN I ACTION="MN" D G VQ ; manually release (delayed) 32 . I ACTSTS'=10,ACTSTS'=11 S ERROR="This order has already been released!" Q 33 . I $P(OR0,U,12)="I",'$G(^DPT(+ORVP,.105)) S ERROR="This patient is not currently admitted!" 34 GMRA I PKG="GMRA" S ERROR="This action is not allowed on an allergy/adverse reaction!" G VQ ; no actions allowed on Allergies 35 MEDS I PKG="PS",'MEDPARM S ERROR="You are not authorized to enter med orders!" G VQ 36 RW I ACTION="RW" D RW^ORCACT01 G VQ ; rewrite/copy 37 XFR I ACTION="XFR" D XFR^ORCACT01 G VQ ; transfer to in/outpt 38 RN I ACTION="RN" D RN^ORCACT01 G VQ ; renew 39 TRM I $$DONE G VQ ; ORDSTS=1,2,7,12,13 40 EV I ACTION="EV" D G VQ ; change delay event 41 . I ORDSTS'=10,ORDSTS'=11 S ERROR="This order has been released!" Q 42 . I DG="NV RX" S ERROR="Non-VA Med orders do not support this action!" Q 43 . I $$EVTORDER^OREVNTX(IFN) S ERROR="The release event for this order may not be changed!" Q 44 . S X=$P(ORA0,U,4) I X'=2,X'=3 S ERROR="Signed orders may not be delayed to another event!" Q 45 DC2 I ACTION="DC",ACTSTS="" D G VQ ; DC released order 46 . I $G(NATR)="A" D Q:$D(ERROR) 47 .. S X=$O(^ORE(100.2,"AO",+IFN,0)) I X S:'$G(^ORE(100.2,X,1)) ERROR="Future event orders may not be auto-discontinued!" Q 48 .. I $$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO",$G(DGPMT)=1 Q ;177 If admission auto-dc and order is outpt med then no further checking needed 49 .. I $G(DGPMT)=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)'="C" S ERROR="Only outpatient orders may be auto-discontinued!" Q 50 .. I $G(DGPMT)'=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)="C",PKG'="PS" S ERROR="Only inpatient orders may be auto-discontinued!" Q 51 . I PKG="RA",ORDSTS=6 S ERROR="Active Radiology orders cannot be discontinued!" Q 52 . I PKG="VBEC",ORDSTS=6 S ERROR="Active Blood Product orders cannot be discontinued!" Q 53 . I PKG="LR" D Q 54 .. I $$COLLECTD S ERROR="Lab orders that have been collected may not be discontinued!" Q 55 .. I $G(NATR)="A","^12^38^"'[(U_$P($G(DGPMA),U,18)_U),$$VALUE^ORX8(+IFN,"COLLECT")="SP",$P(OR0,U,8)'<DT S ERROR="Future Send Patient orders may not be auto-discontinued!" Q 56 . I PKG="GMRC",ORDSTS=9 S ERROR="Consults orders with partial results cannot be discontinued!" Q 57 . I DG="DO",$G(DGPMT)'=3,ORDSTS=6,'$$NPO(+IFN) S ERROR="Active Diets cannot be discontinued; please order a new diet!" Q 58 RL I ACTION="RL" D G VQ ; release hold 59 . I ORDSTS'=3 D Q 60 ..I $P(ORA0,U,4)=2 S ERROR="Providers has not yet signed the hold order and therefor it cannot yet be released" Q 61 ..S ERROR="Orders not on hold cannot be released!" Q 62 . I ACTSTS S ERROR=$$ACTION($P(ORA0,U,2))_" orders cannot be released from hold!" Q 63 . N NATR,ACT S ACT=$S($P(ORA0,U,2)="HD":AIFN,1:+$P(OR3,U,7)) 64 . S NATR=+$P($G(^OR(100,+IFN,8,ACT,0)),U,12),ACT=$P($G(^(0)),U,2) 65 . I PKG="RA"!(ACT'="HD")!($P($G(^ORD(100.02,NATR,0)),U,2)="S") S ERROR="Orders held by a service must be released from hold through the service!" Q 66 AIFN S X=$P(ORA0,U,2) I AIFN>1,ACTSTS S ERROR="This action is not allowed on a "_$$ACTION(X)_" order!" G VQ 67 RF I ACTION="RF" D G VQ 68 . I DG'="O RX" S ERROR="Only Outpatient Med orders may be refilled!" Q 69 . I ORDSTS=5 S ERROR="Pending orders may not be refilled!" Q 70 . I ORDSTS=7 S ERROR="Expired orders may not be refilled!" Q 71 . N X,PSIFN S PSIFN=$G(^OR(100,+IFN,4)) 72 . S X=$$REFILL^PSOREF(PSIFN) I X'>0 S ERROR=$P(X,U,2) Q 73 CP I ACTION="CP" D G VQ ; complete 74 . I PKG'="OR" S ERROR="Only generic text orders may be completed through this option!" Q 75 . I ORDSTS=11!(ORDSTS=10) S ERROR="This order has not been released!" Q 76 AL I ACTION="AL" D G VQ 77 . I PKG'="LR",PKG'="RA",PKG'="GMRC" S ERROR="This order does not generate results!" Q 78 . I $P(OR3,U,10) S ERROR="This order is already flagged to alert the provider when resulted!" Q 79 XX I ACTION="XX" D G VQ ; edit/change 80 . I ORDSTS=7 S ERROR="Expired orders may not be changed!" Q 81 . D XX^ORCACT01 82 HD I ACTION="HD" D G VQ ; hold 83 . I PKG="FH" S ERROR="Diet orders cannot be held!" Q 84 . I PKG="LR" S ERROR="Lab orders cannot be held!" Q 85 . I PKG="RA" S ERROR="Radiology orders cannot be held!" Q 86 . I PKG="GMRC" S ERROR="Consult orders cannot be held!" Q 87 . I DG="NV RX" S ERROR="Non-VA Med orders cannot be held!" Q 88 . I ORDSTS=3 S ERROR="This order is already on hold!" Q 89 . I ORDSTS'=6,PKG="PS" S ERROR="Only active Pharmacy orders may be held!" Q 90 . I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q 91 VQ S Y=$S($D(ERROR):0,1:1) 92 Q Y 93 ; 94 ACTION(X) ; -- Return text of action X 95 N Y S Y=$S(X="NW":"New",X="DC":"Discontinue",X="HD":"Hold",X="RL":"Release Hold",X="RN":"Renew",1:X) 96 Q Y 97 ; 98 NPO(ORIFN) ; -- Returns 1 or 0, if order ORIFN is for NPO 99 N X,Y S X=$$VALUE^ORX8(+ORIFN,"ORDERABLE",1,"E") 100 S Y=$S($E(X,1,3)="NPO":1,1:0) 101 Q Y 102 ; 103 COLLECTD() ; -- Lab order collected/active (incl all children)? 104 I (ORDSTS=11)!(ORDSTS=10) Q 0 ; unreleased 105 I '$O(^OR(100,+IFN,2,0)) Q (ORDSTS'=5) 106 ;I ORDSTS'=6 Q 1 ; Parent -> active instead of pending 107 N Y,Z S Y=1,Z=0 108 F S Z=$O(^OR(100,+IFN,2,Z)) Q:Z'>0 I $P($G(^OR(100,Z,3)),U,3)=5 S Y=0 Q 109 Q Y 110 ; 111 DONE() ; -- sets ERROR if terminal status 112 I ORDSTS=1 S ERROR="This order has been discontinued!" Q 1 113 I ORDSTS=2 S ERROR="This order has been completed!" Q 1 114 I ORDSTS=7,DG'="O RX" S ERROR="This order has expired!" Q 1 115 I ORDSTS=12 S ERROR="This order has been changed!" Q 1 116 I ORDSTS=13 S ERROR="This order has been cancelled!" Q 1 117 I ORDSTS=14 S ERROR="This order has lapsed!" Q 1 118 I ORDSTS=15 S ERROR="This order has been renewed!" Q 1 119 Q 0 120 ; 121 DISABLED() ; -- Order dialog [or protocol] disabled? 122 N X,DLG S DLG=$P(OR0,U,5),X=0 I +DLG'>0 Q X 123 I VER'<3,DLG?1.N1";ORD(101.41," S X=$$MSG^ORXD(+DLG) Q X 124 S DLG=$S(PKG="RA":"RA OERR EXAM",PKG="GMRC":"GMRCOR CONSULT",1:"") 125 I $L(DLG) S DLG=+$O(^ORD(101.41,"AB",DLG,0)),X=$$MSG^ORXD(DLG) 126 Q X 1 ORCACT0 ;SLC/MKB-Validate order action ;2/24/03 10:35 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,86,92,94,141,165,177,173,190,215**;Dec 17, 1997 3 ; 4 VALID(IFN,ACTION,ERROR,NATR) ; -- Determines if action is valid for order IFN 5 N OR0,OR3,ORA0,AIFN,PKG,DG,ORDSTS,ACTSTS,VER,X,Y,MEDPARM K ERROR 6 S OR0=$G(^OR(100,+IFN,0)),OR3=$G(^(3)),PKG=$$NMSP^ORCD($P(OR0,U,14)) 7 S DG=$P($G(^ORD(100.98,+$P(OR0,U,11),0)),U,3) 8 S MEDPARM=$S($G(NATR)="A":2,PKG'="PS":2,'$D(^XUSEC("OREMAS",DUZ)):2,DG="NV RX":$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS"),1:$$GET^XPAR("ALL","OR OREMAS MED ORDERS")) 9 S AIFN=$P(IFN,";",2) S:'AIFN AIFN=+$P(OR3,U,7) 10 S ORA0=$G(^OR(100,+IFN,8,AIFN,0)),ACTSTS=$P(ORA0,U,15) 11 S ORDSTS=$P(OR3,U,3),VER=$S($P(OR0,U,5)["101.41":3,1:2) 12 CM I ACTION="CM" S ERROR="This action is no longer available!" G VQ ; ward comments - no restrictions 13 FL I ACTION="FL" D G VQ ; flag 14 . I +$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is already flagged!" Q 15 UF I ACTION="UF" D G VQ ; unflag 16 . I '+$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is not flagged!" Q 17 DC1 I ACTION="DC",ACTSTS D G VQ ; discontinue/cancel unrel or canc order 18 . I (ACTSTS=11)!(ACTSTS=10) D Q ; unreleased 19 .. I 'MEDPARM S ERROR="You are not authorized to cancel med orders!" Q 20 .. I $G(NATR)="A" S X=$O(^ORE(100.2,"AO",+IFN,0)) I X,'$G(^ORE(100.2,X,1)) S ERROR="Future event orders may not be auto-discontinued!" Q 21 . I ACTSTS=12 S ERROR="This order has been dc'd due to edit!" Q 22 . I ACTSTS=13 S ERROR="This order has been cancelled!" Q 23 ES I (ACTION="ES")!(ACTION="OC")!(ACTION="RS")!(ACTION="DS") D ES^ORCACT01 G VQ ; sign 24 VR I ACTION="VR" D G VQ ; verify 25 . I $G(ORVER)="N",$P(ORA0,U,9) S ERROR="This order has been verified!" Q 26 . I $G(ORVER)="C",$P(ORA0,U,11) S ERROR="This order has been verified!" Q 27 . I $G(ORVER)="R",$P(ORA0,U,19) S ERROR="This order has been reviewed!" Q 28 . I (ACTSTS=11)!(ACTSTS=10) S ERROR="This order has not been released to the service." Q 29 . I AIFN=1,ORDSTS=5,PKG="PS" S X=$$DISABLED I X S ERROR=$P(X,U,2) Q 30 DIS S X=$$DISABLED I X S ERROR=$P(X,U,2) G VQ 31 MN I ACTION="MN" D G VQ ; manually release (delayed) 32 . I ACTSTS'=10,ACTSTS'=11 S ERROR="This order has already been released!" Q 33 . I $P(OR0,U,12)="I",'$G(^DPT(+ORVP,.105)) S ERROR="This patient is not currently admitted!" 34 GMRA I PKG="GMRA" S ERROR="This action is not allowed on an allergy/adverse reaction!" G VQ ; no actions allowed on Allergies 35 MEDS I PKG="PS",'MEDPARM S ERROR="You are not authorized to enter med orders!" G VQ 36 RW I ACTION="RW" D RW^ORCACT01 G VQ ; rewrite/copy 37 XFR I ACTION="XFR" D XFR^ORCACT01 G VQ ; transfer to in/outpt 38 RN I ACTION="RN" D RN^ORCACT01 G VQ ; renew 39 TRM I $$DONE G VQ ; ORDSTS=1,2,7,12,13 40 EV I ACTION="EV" D G VQ ; change delay event 41 . I ORDSTS'=10,ORDSTS'=11 S ERROR="This order has been released!" Q 42 . I DG="NV RX" S ERROR="Non-VA Med orders do not support this action!" Q 43 . I $$EVTORDER^OREVNTX(IFN) S ERROR="The release event for this order may not be changed!" Q 44 . S X=$P(ORA0,U,4) I X'=2,X'=3 S ERROR="Signed orders may not be delayed to another event!" Q 45 DC2 I ACTION="DC",ACTSTS="" D G VQ ; DC released order 46 . I $G(NATR)="A" D Q:$D(ERROR) 47 .. S X=$O(^ORE(100.2,"AO",+IFN,0)) I X S:'$G(^ORE(100.2,X,1)) ERROR="Future event orders may not be auto-discontinued!" Q 48 .. I $$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO",$G(DGPMT)=1 Q ;177 If admission auto-dc and order is outpt med then no further checking needed 49 .. I $G(DGPMT)=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)'="C" S ERROR="Only outpatient orders may be auto-discontinued!" Q 50 .. I $G(DGPMT)'=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)="C" S ERROR="Only inpatient orders may be auto-discontinued!" Q 51 . I PKG="RA",ORDSTS=6 S ERROR="Active Radiology orders cannot be discontinued!" Q 52 . I PKG="VBEC",ORDSTS=6 S ERROR="Active Blood Product orders cannot be discontinued!" Q 53 . I PKG="LR" D Q 54 .. I $$COLLECTD S ERROR="Lab orders that have been collected may not be discontinued!" Q 55 .. I $G(NATR)="A","^12^38^"'[(U_$P($G(DGPMA),U,18)_U),$$VALUE^ORX8(+IFN,"COLLECT")="SP",$P(OR0,U,8)'<DT S ERROR="Future Send Patient orders may not be auto-discontinued!" Q 56 . I PKG="GMRC",ORDSTS=9 S ERROR="Consults orders with partial results cannot be discontinued!" Q 57 . I DG="DO",$G(DGPMT)'=3,ORDSTS=6,'$$NPO(+IFN) S ERROR="Active Diets cannot be discontinued; please order a new diet!" Q 58 RL I ACTION="RL" D G VQ ; release hold 59 . I ORDSTS'=3 S ERROR="Orders not on hold cannot be released!" Q 60 . I ACTSTS S ERROR=$$ACTION($P(ORA0,U,2))_" orders cannot be released from hold!" Q 61 . N NATR,ACT S ACT=$S($P(ORA0,U,2)="HD":AIFN,1:+$P(OR3,U,7)) 62 . S NATR=+$P($G(^OR(100,+IFN,8,ACT,0)),U,12),ACT=$P($G(^(0)),U,2) 63 . I PKG="RA"!(ACT'="HD")!($P($G(^ORD(100.02,NATR,0)),U,2)="S") S ERROR="Orders held by a service must be released from hold through the service!" Q 64 AIFN S X=$P(ORA0,U,2) I AIFN>1,ACTSTS S ERROR="This action is not allowed on a "_$$ACTION(X)_" order!" G VQ 65 RF I ACTION="RF" D G VQ 66 . I DG'="O RX" S ERROR="Only Outpatient Med orders may be refilled!" Q 67 . I ORDSTS=5 S ERROR="Pending orders may not be refilled!" Q 68 . N X,PSIFN S PSIFN=$G(^OR(100,+IFN,4)) 69 . S X=$$REFILL^PSOREF(PSIFN) I X'>0 S ERROR=$P(X,U,2) Q 70 CP I ACTION="CP" D G VQ ; complete 71 . I PKG'="OR" S ERROR="Only generic text orders may be completed through this option!" Q 72 . I ORDSTS=11!(ORDSTS=10) S ERROR="This order has not been released!" Q 73 AL I ACTION="AL" D G VQ 74 . I PKG'="LR",PKG'="RA",PKG'="GMRC" S ERROR="This order does not generate results!" Q 75 . I $P(OR3,U,10) S ERROR="This order is already flagged to alert the provider when resulted!" Q 76 XX I ACTION="XX" D XX^ORCACT01 G VQ ; edit/change 77 HD I ACTION="HD" D G VQ ; hold 78 . I PKG="FH" S ERROR="Diet orders cannot be held!" Q 79 . I PKG="LR" S ERROR="Lab orders cannot be held!" Q 80 . I PKG="RA" S ERROR="Radiology orders cannot be held!" Q 81 . I PKG="GMRC" S ERROR="Consult orders cannot be held!" Q 82 . I DG="NV RX" S ERROR="Non-VA Med orders cannot be held!" Q 83 . I ORDSTS=3 S ERROR="This order is already on hold!" Q 84 . I ORDSTS'=6,PKG="PS" S ERROR="Only active Pharmacy orders may be held!" Q 85 . I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q 86 VQ S Y=$S($D(ERROR):0,1:1) 87 Q Y 88 ; 89 ACTION(X) ; -- Return text of action X 90 N Y S Y=$S(X="NW":"New",X="DC":"Discontinue",X="HD":"Hold",X="RL":"Release Hold",X="RN":"Renew",1:X) 91 Q Y 92 ; 93 NPO(ORIFN) ; -- Returns 1 or 0, if order ORIFN is for NPO 94 N X,Y S X=$$VALUE^ORX8(+ORIFN,"ORDERABLE",1,"E") 95 S Y=$S($E(X,1,3)="NPO":1,1:0) 96 Q Y 97 ; 98 COLLECTD() ; -- Lab order collected/active (incl all children)? 99 I (ORDSTS=11)!(ORDSTS=10) Q 0 ; unreleased 100 I '$O(^OR(100,+IFN,2,0)) Q (ORDSTS'=5) 101 ;I ORDSTS'=6 Q 1 ; Parent -> active instead of pending 102 N Y,Z S Y=1,Z=0 103 F S Z=$O(^OR(100,+IFN,2,Z)) Q:Z'>0 I $P($G(^OR(100,Z,3)),U,3)=5 S Y=0 Q 104 Q Y 105 ; 106 DONE() ; -- sets ERROR if terminal status 107 I ORDSTS=1 S ERROR="This order has been discontinued!" Q 1 108 I ORDSTS=2 S ERROR="This order has been completed!" Q 1 109 I ORDSTS=7 S ERROR="This order has expired!" Q 1 110 I ORDSTS=12 S ERROR="This order has been changed!" Q 1 111 I ORDSTS=13 S ERROR="This order has been cancelled!" Q 1 112 I ORDSTS=14 S ERROR="This order has lapsed!" Q 1 113 I ORDSTS=15 S ERROR="This order has been renewed!" Q 1 114 Q 0 115 ; 116 DISABLED() ; -- Order dialog [or protocol] disabled? 117 N X,DLG S DLG=$P(OR0,U,5),X=0 I +DLG'>0 Q X 118 I VER'<3,DLG?1.N1";ORD(101.41," S X=$$MSG^ORXD(+DLG) Q X 119 S DLG=$S(PKG="RA":"RA OERR EXAM",PKG="GMRC":"GMRCOR CONSULT",1:"") 120 I $L(DLG) S DLG=+$O(^ORD(101.41,"AB",DLG,0)),X=$$MSG^ORXD(DLG) 121 Q X -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT01.m
r613 r623 1 ORCACT01 ;SLC/MKB-Validate order actions cont ;03/28/2008 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,141,163,187,190,213,243**;Dec 17, 1997;Build 242 3 ; 4 ES ; -- sign [on chart] 5 I ORDSTS=11,VER<3,PKG'="OR" S ERROR="This order cannot be released and must be discontinued!" Q 6 N X I ACTSTS=11!(ACTSTS=10) D Q:$L($G(ERROR)) 7 . I $P(ORA0,U,2)="DC",$$DONE^ORCACT0 D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN S OREBUILD=1 Q 8 . S X=$$DISABLED^ORCACT0 I X S ERROR=$P(X,U,2) Q 9 I ACTION="OC",$G(DG)="NV RX" S:MEDPARM<2 ERROR="You are not authorized to release non-VA med orders!" Q 10 S X=$P(ORA0,U,4) I X=3 S:ACTSTS'=11&(ACTSTS'=10) ERROR="This order does not require a signature!" Q 11 I X'=2 S ERROR="This order has been signed!" Q 12 I DG="O RX",ACTION'="ES",ACTION'="DS",$G(NATR)'="I" S ERROR="Outpatient meds may not be released without a clinician's signature!" Q 13 I (ACTION="ES"!(ACTION="DS")),$D(^XUSEC("ORELSE",DUZ)),$P(OR0,U,16)'<2 S ERROR="You are not privileged to sign this order!" Q 14 I ACTION="OC" S:MEDPARM<2 ERROR="You are not authorized to release med orders!" Q 15 I ACTION="RS" D Q:$D(ERROR) Q:$G(NATR)'="I" 16 . Q:ACTSTS=11 Q:ACTSTS=10 ;unreleased - ok 17 . S ERROR="This order has already been released!" 18 ES1 I PKG="PS" D ;authorized to write meds? 19 . N TYPE,OI,PSOI,DEAFLG,PKI,IVERROR 20 . S X=$G(^VA(200,DUZ,"PS")) 21 . I '$P(X,U) S ERROR="You are not authorized to sign med orders!" Q 22 . I $P(X,U,4),$$NOW^XLFDT>$P(X,U,4) S ERROR="You are no longer authorized to sign med orders!" Q 23 . ;Q:DG="IV RX" Q:$P(ORA0,U,2)="DC" ;don't need to ck DEA# 24 . Q:$P(ORA0,U,2)="DC" 25 . I DG="IV RX" D Q 26 . .I $$IVDEACHK(+IFN)=1 S ERROR="You must have a valid DEA# or VA# to sign this order!" 27 . S OI=+$$VALUE^ORX8(+IFN,"ORDERABLE") 28 . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) Q:PSOI'>0 29 . S TYPE=$S($P(DG," ")="O":"O",1:"I"),DEAFLG=$$OIDEA^PSSUTLA1(PSOI,TYPE) 30 . I (DEAFLG>0||$$ISCLOZ^ORALWORD(OI)),'$L($$DEA^XUSER()) S ERROR="You must have a valid DEA# or VA# to sign this order!" Q 31 . D PKISITE^ORWOR(.PKI) 32 . I $G(PKI),ACTION="RS",DEAFLG=1 S ERROR="This order cannot be released without a Digital Signature" Q 33 Q 34 ; 35 IVDEACHK(IFN) ; -- Returns value of prompt by ID 36 I '$G(IFN)!('$D(^OR(100,+$G(IFN),0))) Q "" 37 N I,DIAL,DIALTYP,FAIL,PATCLASS,RESULT,Y 38 S PATCLASS=$P(^OR(100,+IFN,0),U,12) 39 S RESULT=0 40 ;if ORNP is not set then assume this is called from VistA not CPRS 41 I $G(ORNP)="" S ORNP=DUZ 42 S I=0,Y="" S:'$G(INST) INST=1 43 F S I=$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",I)) Q:I'>0!(RESULT=1) D 44 .S Y=$G(^OR(100,+IFN,4.5,I,1)) Q:Y'>0 45 .;S PSOI=+$P($G(^ORD(101.43,Y,0)),U,2) Q:PSOI'>0 46 .I PATCLASS="I" D Q 47 ..D FAILDEA^ORWDPS1(.FAIL,Y,ORNP,"I") I FAIL=1 S RESULT=1 48 .S DIAL=+$P(^OR(100,+IFN,4.5,I,0),U,2) 49 .S DIALTYP=$S($P(^ORD(101.41,DIAL,0),U)["ADDITIVE":"A",1:"S") 50 .D FDEA1^ORWDPS1(.FAIL,Y,DIALTYP,ORNP) 51 .I FAIL=1 S RESULT=1 52 .;I $$OIDEA^PSSUTLA1(PSOI,"I")>0 S RESULT=1 Q 53 Q RESULT 54 ; 55 XFR ; -- transfer to inpt/outpt [IFN=order to be transferred] 56 N OI,PS I DG="TPN" S ERROR="TPN orders may not be copied!" Q 57 I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be transferred; please enter a new order!" Q 58 S OI=+$O(^OR(100,+IFN,.1,"B",0)),ORPS=$G(^ORD(101.43,OI,"PS")) 59 I DG="UD RX",'$P(ORPS,U,2) S ERROR="This drug may not be ordered for an outpatient!" Q 60 I DG="O RX" D Q:$L($G(ERROR)) 61 . I '$P(ORPS,U) S ERROR="This drug may not be ordered for an inpatient!" Q 62 . D:$O(^OR(100,+IFN,4.5,"ID","MISC",0)) DOSES^ORCACT02(+IFN) 63 Q 64 ; 65 RW ; -- rewrite/copy 66 I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be copied!" Q 67 I DG="NV RX" S ERROR="Non-VA Med orders cannot be copied!" Q 68 I DG="TPN" S ERROR="TPN orders may not be rewritten!" Q 69 I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be rewritten!" Q 70 I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be copied; please enter a new order!" Q 71 I PKG="PS",'$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q 72 I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form 73 Q 74 ; 75 RN ; -- renew 76 I PKG'="PS",PKG'="OR" S ERROR="This order may not be renewed!" Q 77 I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q 78 I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be renewed!" Q 79 I $P(OR3,U,6) S ERROR="This order has already been "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"changed!",1:"renewed!") Q 80 I PKG="OR" D Q ;Generic orders 81 . I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be renewed!" Q 82 . I DG="ADT" S ERROR="M.A.S. orders may not be renewed!" Q 83 . I "^1^2^6^7^"[(U_ORDSTS_U) Q ;ok 84 . S ERROR="This order may not be renewed!" 85 I (PKG="PS"),$$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be renewed!" Q 86 I '$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q 87 RN1 N PSIFN S PSIFN=$G(^OR(100,+IFN,4)) 88 I PSIFN<1,'$O(^OR(100,+IFN,2,0)) S ERROR="Missing or invalid order number!" Q 89 I DG="O RX" D Q ;Outpt Meds 90 . N ORZ,ORD S ORZ=$L($T(RENEW^PSORENW),",") 91 . I ORZ>1 S ORD=+$$VALUE^ORX8(+IFN,"DRUG"),X=$$RENEW^PSORENW(PSIFN,ORD) 92 . S:ORZ'>1 X=$$RENEW^PSORENW(PSIFN) I X<1 S ERROR=$P(X,U,2) Q 93 . S X=+$P(X,U,2) D:X RESET^ORCACT03(+IFN,X) 94 . I $O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old format 95 I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be renewed!" Q 96 I ORDSTS=7,'$$IV^ORCACT03,$P(OR0,U,9)<$$FMADD^XLFDT(DT,-4) S ERROR="Inpatient med orders may not be renewed more than 4 days after expiration!" Q 97 I ORDSTS'=6,ORDSTS'=7 S ERROR="This order may not be renewed!" Q 98 RN2 I $O(^OR(100,+IFN,2,0))!$P(OR3,U,9) D Q:$D(ERROR)!'PSIFN 99 . I $P(OR3,U,9),$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" S ERROR="One-time NOW orders may not be renewed!" Q 100 . N DAD,ORD3,I,Y S DAD=$S($P(OR3,U,9):+$P(OR3,U,9),1:+IFN),Y=0 101 . S ORD3=$G(^OR(100,DAD,3)) I $P(ORD3,U,6) S ERROR="This complex order has already been renewed!" Q 102 . I $P(ORD3,U,3)'=6 S ERROR="This complex order is not active and may not be renewed!" Q 103 . I '$$AND^ORX8(DAD) S ERROR="Complex orders with sequential doses may not be renewed!" Q 104 . S I=0 F S I=+$O(^OR(100,DAD,2,I)) Q:I<1 D Q:Y 105 .. I I=+$O(^OR(100,DAD,2,0)),$$VALUE^ORX8(I,"SCHEDULE",1,"E")="NOW",$$VALUE^ORX8(DAD,"NOW") Q ;ignore NOW orders 106 .. I $P($G(^OR(100,I,3)),U,3)'=6 S Y=1,ERROR="Complex orders with terminated doses may not be renewed!" Q 107 .. I PSIFN<1 S X=$$ACTIVE^PSJORREN(+ORVP,$G(^OR(100,I,4))) I +X'=1 S ERROR="This order may not be renewed: "_$S(+X>1:"Inactive orderable item",1:$P(X,U,2)) Q 108 ;I DG="TPN" S ERROR="TPN orders may not be renewed!" Q 109 S X=$$ACTIVE^PSJORREN(+ORVP,PSIFN) Q:+X=1 ;Ok 110 I +X>1,$P(X,U,2) D RESET^ORCACT03(+IFN,+$P(X,U,2)) Q ;replace OI 111 S ERROR="This order may not be renewed: "_$P(X,U,2) 112 Q 113 ; 114 XX ; -- edit/change-- 115 I PKG="RA",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Radiology cannot be changed!" Q 116 I PKG="LR",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Lab cannot be changed!" Q 117 I PKG="FH",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Dietetics cannot be changed!" Q 118 I PKG="GMRC",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Consults cannot be changed!" Q 119 I DG="TPN" S ERROR="TPN orders may not be changed!" Q 120 I ORDSTS=3 S ERROR="Orders on hold may not be changed!" Q 121 I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be changed!" Q 122 I $O(^OR(100,+IFN,2,0)) S ERROR="Complex orders may not be changed!" Q 123 I $P(OR3,U,9) D Q:$D(ERROR) 124 . Q:$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" ;NOW ok 125 . Q:'$O(^OR(100,+$P(OR3,U,9),4.5,"ID","CONJ",0)) ;no conj=1dose/ok 126 . S ERROR="Complex orders may not be changed!" Q 127 I $P(OR3,U,6) S ERROR="This order may not be changed - a "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"change",1:"renewal")_" order already exists!" Q 128 I $P(OR3,U,11)=2 D Q:$D(ERROR) 129 . I (ORDSTS=10!(ORDSTS=11)),DG'="O RX" S ERROR="Unreleased renewals may not be changed!" Q 130 . I PKG="PS",ORDSTS=5 S ERROR="Pending renewals may not be changed!" Q 131 I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be changed; please enter a new order!" Q 132 I PKG="PS",'$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q 133 I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form 134 Q 135 ; 1 ORCACT01 ;SLC/MKB-Validate order actions cont ;5/6/04 20:39 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,141,163,187,190,213**;Dec 17, 1997 3 ; 4 ES ; -- sign [on chart] 5 I ORDSTS=11,VER<3,PKG'="OR" S ERROR="This order cannot be released and must be discontinued!" Q 6 N X I ACTSTS=11!(ACTSTS=10) D Q:$L($G(ERROR)) 7 . I $P(ORA0,U,2)="DC",$$DONE^ORCACT0 D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN S OREBUILD=1 Q 8 . S X=$$DISABLED^ORCACT0 I X S ERROR=$P(X,U,2) Q 9 I ACTION="OC",$G(DG)="NV RX" S:MEDPARM<2 ERROR="You are not authorized to release non-VA med orders!" Q 10 S X=$P(ORA0,U,4) I X=3 S:ACTSTS'=11&(ACTSTS'=10) ERROR="This order does not require a signature!" Q 11 I X'=2 S ERROR="This order has been signed!" Q 12 I DG="O RX",ACTION'="ES",ACTION'="DS",$G(NATR)'="I" S ERROR="Outpatient meds may not be released without a clinician's signature!" Q 13 I (ACTION="ES"!(ACTION="DS")),$D(^XUSEC("ORELSE",DUZ)),$P(OR0,U,16)'<2 S ERROR="You are not privileged to sign this order!" Q 14 I ACTION="OC" S:MEDPARM<2 ERROR="You are not authorized to release med orders!" Q 15 I ACTION="RS" D Q:$D(ERROR) Q:$G(NATR)'="I" 16 . Q:ACTSTS=11 Q:ACTSTS=10 ;unreleased - ok 17 . S ERROR="This order has already been released!" 18 ES1 I PKG="PS" D ;authorized to write meds? 19 . N TYPE,OI,PSOI,DEAFLG,PKI 20 . S X=$G(^VA(200,DUZ,"PS")) 21 . I '$P(X,U) S ERROR="You are not authorized to sign med orders!" Q 22 . I $P(X,U,4),$$NOW^XLFDT>$P(X,U,4) S ERROR="You are no longer authorized to sign med orders!" Q 23 . Q:DG="IV RX" Q:$P(ORA0,U,2)="DC" ;don't need to ck DEA# 24 . S OI=+$$VALUE^ORX8(+IFN,"ORDERABLE") 25 . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) Q:PSOI'>0 26 . S TYPE=$S($P(DG," ")="O":"O",1:"I"),DEAFLG=$$OIDEA^PSSUTLA1(PSOI,TYPE) 27 . I DEAFLG>0,'$L($$DEA^XUSER()) S ERROR="You must have a valid DEA# or VA# to sign this order!" Q 28 . D PKISITE^ORWOR(.PKI) 29 . I $G(PKI),ACTION="RS",DEAFLG=1 S ERROR="This order cannot be released without a Digital Signature" Q 30 Q 31 ; 32 XFR ; -- transfer to inpt/outpt [IFN=order to be transferred] 33 N OI,PS I DG="TPN" S ERROR="TPN orders may not be copied!" Q 34 I $$INACTIVE S ERROR="Orders for inactive orderables may not be transferred; please enter a new order!" Q 35 S OI=+$O(^OR(100,+IFN,.1,"B",0)),ORPS=$G(^ORD(101.43,OI,"PS")) 36 I DG="UD RX",'$P(ORPS,U,2) S ERROR="This drug may not be ordered for an outpatient!" Q 37 I DG="O RX" D Q:$L($G(ERROR)) 38 . I '$P(ORPS,U) S ERROR="This drug may not be ordered for an inpatient!" Q 39 . D:$O(^OR(100,+IFN,4.5,"ID","MISC",0)) DOSES^ORCACT02(+IFN) 40 Q 41 ; 42 RW ; -- rewrite/copy 43 I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be copied!" Q 44 I DG="NV RX" S ERROR="Non-VA Med orders cannot be copied!" Q 45 I DG="TPN" S ERROR="TPN orders may not be rewritten!" Q 46 I DG="UD RX",$$NTBG(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be rewritten!" Q 47 I $$INACTIVE S ERROR="Orders for inactive orderables may not be copied; please enter a new order!" Q 48 I PKG="PS",'$$MEDOK S ERROR="This drug may not be ordered!" Q 49 I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form 50 Q 51 ; 52 RN ; -- renew 53 I PKG'="PS",PKG'="OR" S ERROR="This order may not be renewed!" Q 54 I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q 55 I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be renewed!" Q 56 I $P(OR3,U,6) S ERROR="This order has already been "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"changed!",1:"renewed!") Q 57 I PKG="OR" D Q ;Generic orders 58 . I $$INACTIVE S ERROR="Orders for inactive orderables may not be renewed!" Q 59 . I DG="ADT" S ERROR="M.A.S. orders may not be renewed!" Q 60 . I "^1^2^6^7^"[(U_ORDSTS_U) Q ;ok 61 . S ERROR="This order may not be renewed!" 62 I (PKG="PS"),$$INACTIVE S ERROR="Orders for inactive orderables may not be renewed!" Q 63 I '$$MEDOK S ERROR="This drug may not be ordered!" Q 64 RN1 N PSIFN S PSIFN=$G(^OR(100,+IFN,4)) 65 I PSIFN<1,'$O(^OR(100,+IFN,2,0)) S ERROR="Missing or invalid order number!" Q 66 I DG="O RX" D Q ;Outpt Meds 67 . N ORZ,ORD S ORZ=$L($T(RENEW^PSORENW),",") 68 . I ORZ>1 S ORD=+$$VALUE^ORX8(+IFN,"DRUG"),X=$$RENEW^PSORENW(PSIFN,ORD) 69 . S:ORZ'>1 X=$$RENEW^PSORENW(PSIFN) I X<1 S ERROR=$P(X,U,2) Q 70 . S X=+$P(X,U,2) D:X RESET(+IFN,X) 71 . I $O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old format 72 I DG="UD RX",$$NTBG(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be renewed!" Q 73 I ORDSTS=7,'$$IV,$P(OR0,U,9)<$$FMADD^XLFDT(DT,-4) S ERROR="Inpatient med orders may not be renewed more than 4 days after expiration!" Q 74 I ORDSTS'=6,ORDSTS'=7 S ERROR="This order may not be renewed!" Q 75 RN2 I $O(^OR(100,+IFN,2,0))!$P(OR3,U,9) D Q:$D(ERROR)!'PSIFN 76 . I $P(OR3,U,9),$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" S ERROR="One-time NOW orders may not be renewed!" Q 77 . N DAD,ORD3,I,Y S DAD=$S($P(OR3,U,9):+$P(OR3,U,9),1:+IFN),Y=0 78 . S ORD3=$G(^OR(100,DAD,3)) I $P(ORD3,U,6) S ERROR="This complex order has already been renewed!" Q 79 . I $P(ORD3,U,3)'=6 S ERROR="This complex order is not active and may not be renewed!" Q 80 . I '$$AND^ORX8(DAD) S ERROR="Complex orders with sequential doses may not be renewed!" Q 81 . S I=0 F S I=+$O(^OR(100,DAD,2,I)) Q:I<1 D Q:Y 82 .. I I=+$O(^OR(100,DAD,2,0)),$$VALUE^ORX8(I,"SCHEDULE",1,"E")="NOW",$$VALUE^ORX8(DAD,"NOW") Q ;ignore NOW orders 83 .. I $P($G(^OR(100,I,3)),U,3)'=6 S Y=1,ERROR="Complex orders with terminated doses may not be renewed!" Q 84 .. I PSIFN<1 S X=$$ACTIVE^PSJORREN(+ORVP,$G(^OR(100,I,4))) I +X'=1 S ERROR="This order may not be renewed: "_$S(+X>1:"Inactive orderable item",1:$P(X,U,2)) Q 85 ;I DG="TPN" S ERROR="TPN orders may not be renewed!" Q 86 S X=$$ACTIVE^PSJORREN(+ORVP,PSIFN) Q:+X=1 ;Ok 87 I +X>1,$P(X,U,2) D RESET(+IFN,+$P(X,U,2)) Q ;replace OI 88 S ERROR="This order may not be renewed: "_$P(X,U,2) 89 Q 90 ; 91 XX ; -- edit/change-- 92 I PKG="RA",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Radiology cannot be changed!" Q 93 I PKG="LR",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Lab cannot be changed!" Q 94 I PKG="FH",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Dietetics cannot be changed!" Q 95 I PKG="GMRC",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Consults cannot be changed!" Q 96 I DG="TPN" S ERROR="TPN orders may not be changed!" Q 97 I ORDSTS=3 S ERROR="Orders on hold may not be changed!" Q 98 I DG="UD RX",$$NTBG(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be changed!" Q 99 I $O(^OR(100,+IFN,2,0)) S ERROR="Complex orders may not be changed!" Q 100 I $P(OR3,U,9) D Q:$D(ERROR) 101 . Q:$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" ;NOW ok 102 . Q:'$O(^OR(100,+$P(OR3,U,9),4.5,"ID","CONJ",0)) ;no conj=1dose/ok 103 . S ERROR="Complex orders may not be changed!" Q 104 I $P(OR3,U,6) S ERROR="This order may not be changed - a "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"change",1:"renewal")_" order already exists!" Q 105 I $P(OR3,U,11)=2 D Q:$D(ERROR) 106 . I (ORDSTS=10!(ORDSTS=11)),DG'="O RX" S ERROR="Unreleased renewals may not be changed!" Q 107 . I PKG="PS",ORDSTS=5 S ERROR="Pending renewals may not be changed!" Q 108 I $$INACTIVE S ERROR="Orders for inactive orderables may not be changed; please enter a new order!" Q 109 I PKG="PS",'$$MEDOK S ERROR="This drug may not be ordered!" Q 110 I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form 111 Q 112 ; 113 INACTIVE() ; -- Returns 1 or 0, if OI is now inactive 114 N I,OI,PREOI,PREOIX,X,Y,ORNOW,DD,PSOI S Y=0,ORNOW=$$NOW^XLFDT 115 S I=0 F S I=+$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D Q:Y 116 . S OI=+$G(^OR(100,+IFN,4.5,I,1)) 117 . I OI S X=$G(^ORD(101.43,OI,.1)) I X,X<ORNOW S Y=1 118 I Y,PKG="PS",DG'="IV RX" D ;replacement OI? 119 . S I=+$O(^OR(100,+IFN,4.5,"ID","DRUG",0)) Q:I'>0 ;first 120 . S DD=+$G(^OR(100,+IFN,4.5,I,1)) Q:DD'>0 Q:$G(OI)'>0 121 . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2),X=$$ITEM^PSSUTIL1(PSOI,DD) 122 . Q:X'>0 S X=+$O(^ORD(101.43,"ID",+$P(X,U,2)_";99PSP",0)) Q:X'>0 123 . I $G(^ORD(101.43,X,.1)),$G(^(.1))<ORNOW Q ;make sure new OI is active 124 . S I=+$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",0)) 125 . IF I D 126 . . S PREOI=$G(^OR(100,+IFN,4.5,I,1)) 127 . . S PREOIX=$O(^OR(100,+IFN,.1,"B",PREOI,0)) 128 . . K ^OR(100,+IFN,.1,"B",PREOI,PREOIX) 129 . . S ^OR(100,+IFN,.1,"B",X,PREOIX)="" 130 . . S ^OR(100,+IFN,.1,PREOIX,0)=X 131 . . S ^OR(100,+IFN,4.5,I,1)=X 132 . . S Y=0 ;reset 133 Q Y 134 ; 135 MEDOK() ; -- Returns 1 or 0, if med OI usage=Y 136 N Y,OI,ORPS,X S Y=1,X=$P(OR0,U,12) 137 I (DG="SPLY")!(DG="O RX")!(DG="I RX")!(DG="UD RX") D 138 . S OI=+$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",0)) 139 . S OI=+$G(^OR(100,+IFN,4.5,OI,1)) 140 . S ORPS=$G(^ORD(101.43,OI,"PS")) 141 I DG="SPLY",'$P(ORPS,U,5) S Y=0 142 I DG="O RX",'(X="O"&$P(ORPS,U,2)),'(X="I"&($P(ORPS,U)=2)) S Y=0 143 I DG="I RX"!(DG="UD RX"),'$P(ORPS,U) S Y=0 144 I DG="IV RX" D 145 . N I,X0,X1 S I=0 146 . F S I=+$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",I)) Q:I<1 D Q:Y<1 147 .. S X0=$G(^OR(100,+IFN,4.5,I,0)),X1=+$G(^(1)) 148 .. I $P($G(^ORD(101.41,+$P(X0,U,2),0)),U)["ADDITIVE" S:'$P($G(^ORD(101.43,X1,"PS")),U,4) Y=0 Q 149 .. S:'$P($G(^ORD(101.43,X1,"PS")),U,3) Y=0 150 Q Y 151 ; 152 IV() ; -- IV order, either Inpt or Fluid? 153 I DG="IV RX" Q 1 154 N I,OI,X S I=+$O(^OR(100,IFN,4.5,"ID","ORDERABLE",0)) 155 S OI=+$G(^OR(100,IFN,4.5,+I,1)),X=$P($G(^ORD(101.43,+OI,"PS")),U) 156 Q (X>1) 157 ; 158 NTBG(ORIFN) ; -- Inpt order marked as 'Not to be Given'? 159 N PSIFN,Y,ORI,ORCH S Y="" 160 S PSIFN=$G(^OR(100,+ORIFN,4)) I PSIFN>0 Q $$ENNG^PSJORUT2(+ORVP,PSIFN) 161 S ORI=0 F S ORI=$O(^OR(100,+ORIFN,2,ORI)) Q:ORI'>0 S ORCH=+$G(^(ORI,0)),PSIFN=$G(^OR(100,ORCH,4)) I PSIFN>0 S Y=$$ENNG^PSJORUT2(+ORVP,PSIFN) Q:Y 162 Q Y 163 ; 164 RESET(IFN,NEWOI) ; -- Update OI if changed before renewing 165 Q:'$G(IFN) Q:'$D(^OR(100,+IFN,0)) Q:'$G(NEWOI) 166 N I,ORIT S ORIT=+$O(^ORD(101.43,"ID",NEWOI_";99PSP",0)) Q:ORIT'>0 167 S I=$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",0)) 168 S:I ^OR(100,+IFN,4.5,I,1)=ORIT 169 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT2.m
r613 r623 1 ORCACT2 ;SLC/MKB-DC orders ; 03/27/2007 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,48,79,92,108,94,141,149,265,243**;Dec 17, 1997;Build 242 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 DC ; -- start here with: 5 ; ORNMBR = #,#,...,# of selected orders 6 ; 7 ; OREBUILD defined on return if Orders tab needs to be rebuilt 8 ; 9 N ORACT,ORI,NMBR,ORQUIT,ORIFN,ORDC,OREVT,ORNATR,ORPTLK,ORLK,IDX,ORDITM,ORPRINT,ORERR,ORSTS,ORPRNT,ORCLNUP,ORDA,ORCREATE,OR0,OR3,OREASON,ORXNP,ORX S VALMBCK="" 10 S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q 11 I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR DCQ 12 D FREEZE^ORCMENU S ORACT="DC",VALMBCK="R" K OREBUILD 13 DC1 F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR Q:$D(ORQUIT) 14 . S IDX=$G(^TMP("OR",$J,ORTAB,"IDX",NMBR)) 15 . S ORIFN=$S(ORTAB="MEDS":$P(IDX,U,4),1:$P(IDX,U)) Q:'ORIFN 16 . I '$D(^OR(100,+ORIFN,0)) W !,"This order has been deleted!" H 1 Q 17 . S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";"_+$P($G(^OR(100,+ORIFN,3)),U,7) 18 . S ORDITM=$$ORDITEM(ORIFN) D SUBHDR(ORDITM) 19 . I '$$VALID^ORCACT0(ORIFN,ORACT,.ORERR) W !,ORERR H 1 Q 20 . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q 21 . S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)),ORSTS=$P($G(^(8,+$P(ORIFN,";",2),0)),U,15) 22 . S:$P(OR0,U,17) OREVT(+$P(OR0,U,17))="" ;ck event when done 23 . I (ORSTS=10)!(ORSTS=11) D UNREL Q ;delete unreleased orders 24 . I $P(OR0,U,11)=$O(^ORD(100.98,"B","TF",0)),$P(OR3,U,3)=6 D RESUME(ORIFN) Q:$G(ORQUIT) 25 DC2 . S ORDC(ORI)=ORIFN I $$NMSP^ORCD(+$P(OR0,U,14))="PS" S ORX=1 D ;meds 26 .. I $P(OR3,U,9),$$VALUE^ORX8(+ORIFN,"SCHEDULE")'="NOW",$$DOSES^ORCACT4($P(OR3,U,9))>1 D 27 ... N I,X S ORDC("DAD",+$P(OR3,U,9),+ORIFN)="" 28 ... W !,$C(7),"This is part of a complex order, which will be discontinued in its entirety:" 29 ... S I=0 F S I=$O(^OR(100,+$P(OR3,U,9),8,1,.1,I)) Q:I<1 S X=$G(^(I,0)) W:$$UP^XLFSTR(X)'=" FIRST DOSE NOW" !,X 30 .. N ORY,ORJ,ORV,ORTX,DA,DIK D DELAYED^ORX8(.ORY,+ORIFN) Q:ORY'>0 31 .. W !,+ORY_" delayed order(s) for the same medication were found:" 32 .. S ORJ=0 F S ORJ=$O(ORY(ORJ)) Q:ORJ'>0 S ORV=ORY(ORJ) D TEXT^ORQ12(.ORTX,ORJ) W !,$E(ORTX(1),1,75)_$S($L(ORTX(1))>75:"...",1:""),!," >> delayed until "_$P(ORV,U,2) 33 .. I '$$OK(+ORY) W ! Q 34 .. W !,"Orders not signed or released to the service will be deleted.",! 35 .. S DIK="^OR(100,",DA=0 F S DA=$O(ORY(DA)) Q:DA'>0 D 36 ... N ORJ,ORSIG,STS,ORLKD 37 ... S ORLKD=$$LOCK1^ORX2(+DA) I 'ORLKD W !,$P(ORLKD,U,2) H 1 Q 38 ... S STS=$P($G(^OR(100,DA,3)),U,3),ORSIG=$S($P($G(^(8,1,0)),U,4)=2:0,1:1) 39 ... I STS'=10 S ORDC($$NXT)=DA Q ;released - add to list 40 ... D CLRDLY(DA):ORSIG,^DIK:'ORSIG S OREVT(+ORY(DA))="" 41 ... I $D(^TMP("ORNEW",$J,DA,1)) K ^(1) D UNLK1^ORX2(DA) ;unlock again 42 G:'$O(ORDC(0)) DCQ D:$D(ORDC("DAD")) COMPLX 43 DC3 S OREASON=$$DCREASON I OREASON'>0 D UNLOCK G DCQ 44 S ORNATR=$P(OREASON,U,3),ORCREATE=1 ; CHGD $$CREATE^ORX1(ORNATR) 45 I 'ORCREATE,$G(ORX),$D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS MED ORDERS")<2 W $C(7),!,"You are not authorized to release med orders.",! G DC3 46 I ORCREATE D I (ORNP="^")!($G(ORL)="^") D UNLOCK G DCQ 47 . S ORNP=$$PROVIDER^ORCMENU1 Q:ORNP="^" ;S:ORNP=DUZ ORNATR="E" 48 . I $G(ORX) D PROVIDER^ORCDPSIV I $G(ORQUIT) S ORNP="^" Q 49 . S:'$G(ORL) ORL=$$LOCATION^ORCMENU1 50 W ! W:'ORCREATE "Discontinuing orders ..." 51 S ORPRNT=$$PRINT(ORNATR),ORCLNUP=$S(ORNATR="D":1,ORNATR="M":1,1:0) 52 S (ORI,ORPRINT)=0 F S ORI=$O(ORDC(ORI)) Q:ORI'>0 S ORIFN=ORDC(ORI) D 53 . I ORCREATE S ORDA=$$ACTION^ORCSAVE("DC",+ORIFN,ORNP) Q:'ORDA D SET(+ORIFN,ORNATR,+OREASON,$P(OREASON,U,2)) S ^TMP("ORNEW",$J,+ORIFN,ORDA)="" W "." Q 54 . ; release -> no order or ES req'd 55 . D EN^ORCSEND(+ORIFN,ORACT,3,1,ORNATR,+OREASON,.ORERR),UNLK1^ORX2(+ORIFN) 56 . I '$G(ORERR) S:$P(ORPRNT,U)!$P(ORPRNT,U,5) ORPRINT=ORPRINT+1,ORPRINT(ORPRINT)=+ORIFN_";" W "." Q 57 . W !,$$ORDITEM(+ORIFN)_" not discontinued." 58 . W:$L($P($G(ORERR),U,2)) !," >> "_$P(ORERR,U,2) W ! H 1 59 W:ORCREATE "... discontinue order(s) placed." H 1 60 I $O(ORPRINT(0)) D PRINT^ORPR02(ORVP,.ORPRINT,,ORL,ORPRNT) 61 S OREBUILD=1 ; rebuild orders list 62 DCQ D:$G(OREBUILD) UNOTIF^ORCSIGN ; undo notif? 63 D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders 64 S:$G(ORXNP) ORNP=ORXNP ;reset provider if needed 65 D:$D(OREVT) EVENT ;cancel any events? 66 Q 67 ; 68 UNLOCK ; -- Unlock orders in ORDC(ORI)=ORIFN 69 N ORI,ORIFN S ORI=0 70 F S ORI=$O(ORDC(ORI)) Q:ORI'>0 S ORIFN=+ORDC(ORI) D UNLK1^ORX2(ORIFN) 71 Q 72 ; 73 OK(NUM) ; -- Ok to DC delayed order(s) too? 74 N X,Y,DIR S DIR(0)="YA",DIR("B")="NO" 75 S DIR("A")="Do you want to discontinue "_$S(NUM>1:"these orders",1:"this order")_" too? " 76 S DIR("?")="Enter YES to also cancel the delayed order(s), or NO to allow the order(s) to be activated when the designated event occurs." 77 W ! D ^DIR 78 Q +Y 79 ; 80 NXT() ; -- Return next available subscript in ORDC() 81 N Y S Y=$L(ORNMBR,",")+1 S:Y'>$O(ORDC(""),-1) Y=$O(ORDC(""),-1)+1 82 Q Y 83 ; 84 PRINT(NATR) ; -- Ok to print order? 85 N I,OR1,Y S I=$O(^ORD(100.02,"C",NATR,0)),OR1=$G(^ORD(100.02,I,1)) 86 S Y=$P(OR1,U,2)_"^^^^"_$P(OR1,U,5) 87 Q Y 88 ; 89 ORDITEM(ID) ; -- Returns order text 90 ;N X,I,MORE S X="" 91 ;I $P(ID,";",2)>1 S I=$P($G(^OR(100,+ID,8,+$P(ID,";",2),0)),U,2),X=$S(I="DC":"Discontinue ",I="HD":"Hold ",1:"") 92 ;S I=$O(^OR(100,+ID,1,0)) Q:'I "" S MORE=$O(^(I)),X=X_$G(^(I,0)) 93 ;I $L(X)>68 S X=$E(X,1,68),MORE=1 94 ;S:MORE X=X_" ..." 95 N X,ORX D TEXT^ORQ12(.ORX,ID,68) S X=ORX(1)_$S(ORX>1:" ...",1:"") 96 Q X 97 ; 98 SUBHDR(X) ; -- Display subheader of order being acted on 99 W !!,?(36-($L(X)\2)),"-- "_X_" --",! 100 Q 101 ; 102 COMPLX ; -- Ck for other child orders to be dc'd at same time 103 N DAD,CHLD 104 S DAD=0 F S DAD=$O(ORDC("DAD",DAD)) Q:DAD<1 D 105 . S CHLD=0 F S CHLD=$O(^OR(100,DAD,2,CHLD)) Q:CHLD<1 D 106 .. Q:"^1^2^7^12^13^14^15^"[(U_$P($G(^OR(100,CHLD,3)),U,3)_U) 107 .. Q:$D(ORDC("DAD",DAD,CHLD)) S ORDC($$NXT)=CHLD 108 Q 109 ; 110 DCREASON() ; -- Returns Reason for DC 111 N X,Y,DIC 112 ;I $D(^XUSEC("ORES",DUZ)) S Y=+$O(^ORD(100.03,"C","ORREQ",0)) I Y S Y(0)=$G(^ORD(100.03,Y,0)),Y=Y_U_$P(Y(0),U) G DCRQ ; silent 113 S DIC="^ORD(100.03,",DIC(0)="AEMQZ",DIC("B")=+$O(^ORD(100.03,"C","ORREQ",0)),DIC("W")="W:$L($P(^(0),U))>30 $E($P(^(0),U),31,999)" K:DIC("B")'>0 DIC("B") 114 S DIC("S")="I '$P(^(0),U,4),$P(^(0),U,5)="_+$O(^DIC(9.4,"C","OR",0))_",$P(^(0),U,7)'="_+$O(^ORD(100.02,"C","A",0)),DIC("A")="REASON FOR DC: " 115 D ^DIC 116 DCRQ S:Y>0 Y=Y_U_$S($P(Y(0),U,7):$P($G(^ORD(100.02,+$P(Y(0),U,7),0)),U,2),1:"W") ; ^nature 117 Q Y 118 ; 119 SET(ORDER,NATURE,REASON,TEXT,DCORIG) ; -- Set DC Reason into 6-node 120 Q:'$G(ORDER) Q:'$D(^OR(100,+ORDER,0)) S ORDER=+ORDER 121 I $L($G(NATURE)),NATURE'>0 S NATURE=$O(^ORD(100.02,"C",NATURE,0)) 122 S $P(^OR(100,ORDER,6),U,1,5)=$G(NATURE)_U_DUZ_U_$E($$NOW^XLFDT,1,12)_U_$G(REASON)_U_$G(TEXT),$P(^(6),U,9)=$G(DCORIG) 123 Q 124 ; 125 RESUME(ORDER) ; -- Resume tray service when dc'ing tubefeeding ORDER? 126 N X,Y,DIR,DIC,DA S X=$$RESUME^FHWORR(+ORVP) 127 I '$L(X) W !,"NOTE: NO current diet order exists for this patient!" Q 128 Q:'X I X=2 W !,"Note: Patient is on a WITHHOLD SERVICE order!" 129 S DIR(0)="YA",DIR("A")="Do you wish to resume tray service? " 130 S DIR("?")="Enter YES to resume the previous diet order",DIR("B")="NO" 131 D ^DIR I Y'=1 S:$D(DTOUT)!(X["^") ORQUIT=1 132 D:Y=1 RESUME^ORCSAVE(+ORDER) 133 Q 134 ; 135 UNREL ; -- Process unreleased/delayed order 136 N ORA,ORA0,DA,DR,DIE 137 S ORA=+$P(ORIFN,";",2),ORA0=$G(^OR(100,+ORIFN,8,ORA,0)) 138 ;S ORDEL=$S(ORSTS=11:1,$P(ORA0,U,4)=2:1,1:0) 139 ;W !,"This order was not released "_$S(ORDEL:"to the service and will be deleted.",1:"but signed and will be cancelled.") 140 K:$P(ORA0,U,2)="DC" ^OR(100,+ORIFN,6) I $P(ORA0,U,2)="NW" D 141 . S:$P(OR3,U,5) $P(^OR(100,+$P(OR3,U,5),3),U,6)="" 142 . I $P(OR0,U,17) S DA=+$O(^ORE(100.2,"AO",+ORIFN,0)) I DA S DR="4///@",DIE=100.2 D ^DIE 143 D UNLK1^ORX2(+ORIFN) S OREBUILD=1 144 I $D(^TMP("ORNEW",$J,+ORIFN,ORA)) K ^(ORA) D Q ;new this session 145 . W !,"This order will be deleted." H 1 146 . D DELETE^ORCSAVE2(ORIFN),UNLK1^ORX2(+ORIFN) ;decrement lock again 147 W !,"This order was not released and will be cancelled." H 1 148 D CANCEL^ORCSAVE2(ORIFN):ORSTS=11,CLRDLY(+ORIFN):ORSTS=10 149 Q 150 ; 151 CLRDLY(IFN) ; -- [old Clear delayed fields] Cancel delayed [event]order 152 N STS,ORX S IFN=+$G(IFN) Q:IFN'>0 153 Q:'$D(^OR(100,IFN,0)) S STS=$P($G(^(3)),U,3) 154 S ORX="Delayed "_$S(STS=10:"Order",1:"Release Event")_" Cancelled" 155 S ^OR(100,IFN,6)=$O(^ORD(100.02,"C","M",0))_U_DUZ_U_+$E($$NOW^XLFDT,1,12)_U_U_ORX 156 D STATUS^ORCSAVE2(IFN,13) S $P(^OR(100,IFN,8,1,0),U,15)=13 157 Q 158 ; 159 EVENT ; -- Cancel event too? 160 N EVT,X 161 S EVT=0 F S EVT=$O(OREVT(EVT)) Q:EVT<1 D Q:$G(ORQUIT) 162 . Q:$G(^ORE(100.2,EVT,1)) Q:'$$EMPTY^OREVNTX(EVT) ;done or has orders 163 . ;W !!,$P($$NAME^OREVNTX(EVT)," ",2,99)_" has no more delayed orders." 164 . ;S DIR(0)="YA",DIR("A")="Do you want to cancel this event? " 165 . ;S DIR("?")="Enter NO if you wish to enter new delayed orders for this event, otherwise enter YES to terminate it." 166 . ;S DIR("B")="YES" D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q 167 . D CANCEL^OREVNTX(EVT) S X=$P($$NAME^OREVNTX(EVT)," ",2,99) 168 . W !," ... "_X_" event cancelled." H 1 169 . I $G(OREVENT),OREVENT=EVT D EX^OREVNT ;Return to Active Orders 170 Q 171 ; 172 DCD(IFN) ; -- order discontinued already? 173 N STS,Y,I S Y=0 I '$G(IFN) Q 1 174 S STS=+$P($G(^OR(100,+IFN,3)),U,3) 175 I "^1^2^7^12^13^14^"[(U_STS_U) S Y=1 G DQ ;terminal sts 176 ;look for existing DC action awaiting ES: 177 S I=0 F S I=+$O(^OR(100,+IFN,8,"C","DC",I)) Q:I<1 I $P($G(^OR(100,+IFN,8,I,0)),U,15)=11 S Y=1 Q 178 DQ Q Y 1 ORCACT2 ;SLC/MKB-DC orders ; 08 May 2002 2:12 PM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,48,79,92,108,94,141,149,265**;Dec 17, 1997;Build 17 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 DC ; -- start here with: 5 ; ORNMBR = #,#,...,# of selected orders 6 ; 7 ; OREBUILD defined on return if Orders tab needs to be rebuilt 8 ; 9 N ORACT,ORI,NMBR,ORQUIT,ORIFN,ORDC,OREVT,ORNATR,ORPTLK,ORLK,IDX,ORDITM,ORPRINT,ORERR,ORSTS,ORPRNT,ORCLNUP,ORDA,ORCREATE,OR0,OR3,OREASON,ORXNP,ORX S VALMBCK="" 10 S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q 11 I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR DCQ 12 D FREEZE^ORCMENU S ORACT="DC",VALMBCK="R" K OREBUILD 13 DC1 F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR Q:$D(ORQUIT) 14 . S IDX=$G(^TMP("OR",$J,ORTAB,"IDX",NMBR)) 15 . S ORIFN=$S(ORTAB="MEDS":$P(IDX,U,4),1:$P(IDX,U)) Q:'ORIFN 16 . I '$D(^OR(100,+ORIFN,0)) W !,"This order has been deleted!" H 1 Q 17 . S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";"_+$P($G(^OR(100,+ORIFN,3)),U,7) 18 . S ORDITM=$$ORDITEM(ORIFN) D SUBHDR(ORDITM) 19 . I '$$VALID^ORCACT0(ORIFN,ORACT,.ORERR) W !,ORERR H 1 Q 20 . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q 21 . S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)),ORSTS=$P($G(^(8,+$P(ORIFN,";",2),0)),U,15) 22 . S:$P(OR0,U,17) OREVT(+$P(OR0,U,17))="" ;ck event when done 23 . I (ORSTS=10)!(ORSTS=11) D UNREL Q ;delete unreleased orders 24 . I $P(OR0,U,11)=$O(^ORD(100.98,"B","TF",0)),$P(OR3,U,3)=6 D RESUME(ORIFN) Q:$G(ORQUIT) 25 DC2 . S ORDC(ORI)=ORIFN I $$NMSP^ORCD(+$P(OR0,U,14))="PS" S ORX=1 D ;meds 26 .. I $P(OR3,U,9),$$VALUE^ORX8(+ORIFN,"SCHEDULE")'="NOW",$$DOSES^ORCACT4($P(OR3,U,9))>1 D 27 ... N I,X S ORDC("DAD",+$P(OR3,U,9),+ORIFN)="" 28 ... W !,$C(7),"This is part of a complex order, which will be discontinued in its entirety:" 29 ... S I=0 F S I=$O(^OR(100,+$P(OR3,U,9),8,1,.1,I)) Q:I<1 S X=$G(^(I,0)) W:$$UP^XLFSTR(X)'=" FIRST DOSE NOW" !,X 30 .. N ORY,ORJ,ORV,ORTX,DA,DIK D DELAYED^ORX8(.ORY,+ORIFN) Q:ORY'>0 31 .. W !,+ORY_" delayed order(s) for the same medication were found:" 32 .. S ORJ=0 F S ORJ=$O(ORY(ORJ)) Q:ORJ'>0 S ORV=ORY(ORJ) D TEXT^ORQ12(.ORTX,ORJ) W !,$E(ORTX(1),1,75)_$S($L(ORTX(1))>75:"...",1:""),!," >> delayed until "_$P(ORV,U,2) 33 .. I '$$OK(+ORY) W ! Q 34 .. W !,"Orders not signed or released to the service will be deleted.",! 35 .. S DIK="^OR(100,",DA=0 F S DA=$O(ORY(DA)) Q:DA'>0 D 36 ... N ORJ,ORSIG,STS,ORLKD 37 ... S ORLKD=$$LOCK1^ORX2(+DA) I 'ORLKD W !,$P(ORLKD,U,2) H 1 Q 38 ... S STS=$P($G(^OR(100,DA,3)),U,3),ORSIG=$S($P($G(^(8,1,0)),U,4)=2:0,1:1) 39 ... I STS'=10 S ORDC($$NXT)=DA Q ;released - add to list 40 ... D CLRDLY(DA):ORSIG,^DIK:'ORSIG S OREVT(+ORY(DA))="" 41 ... I $D(^TMP("ORNEW",$J,DA,1)) K ^(1) D UNLK1^ORX2(DA) ;unlock again 42 G:'$O(ORDC(0)) DCQ D:$D(ORDC("DAD")) COMPLX 43 DC3 S OREASON=$$DCREASON I OREASON'>0 D UNLOCK G DCQ 44 S ORNATR=$P(OREASON,U,3),ORCREATE=1 ; CHGD $$CREATE^ORX1(ORNATR) 45 I 'ORCREATE,$G(ORX),$D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS MED ORDERS")<2 W $C(7),!,"You are not authorized to release med orders.",! G DC3 46 I ORCREATE D I (ORNP="^")!($G(ORL)="^") D UNLOCK G DCQ 47 . S ORNP=$$PROVIDER^ORCMENU1 Q:ORNP="^" ;S:ORNP=DUZ ORNATR="E" 48 . I $G(ORX) D PROVIDER^ORCDPSIV I $G(ORQUIT) S ORNP="^" Q 49 . S:'$G(ORL) ORL=$$LOCATION^ORCMENU1 50 W ! W:'ORCREATE "Discontinuing orders ..." 51 S ORPRNT=$$PRINT(ORNATR),ORCLNUP=$S(ORNATR="D":1,ORNATR="M":1,1:0) 52 S (ORI,ORPRINT)=0 F S ORI=$O(ORDC(ORI)) Q:ORI'>0 S ORIFN=ORDC(ORI) D 53 . I ORCREATE S ORDA=$$ACTION^ORCSAVE("DC",+ORIFN,ORNP) Q:'ORDA D SET(+ORIFN,ORNATR,+OREASON,$P(OREASON,U,2)) S ^TMP("ORNEW",$J,+ORIFN,ORDA)="" W "." Q 54 . ; release -> no order or ES req'd 55 . D EN^ORCSEND(+ORIFN,ORACT,3,1,ORNATR,+OREASON,.ORERR),UNLK1^ORX2(+ORIFN) 56 . I '$G(ORERR) S:$P(ORPRNT,U)!$P(ORPRNT,U,5) ORPRINT=ORPRINT+1,ORPRINT(ORPRINT)=+ORIFN_";" W "." Q 57 . W !,$$ORDITEM(+ORIFN)_" not discontinued." 58 . W:$L($P($G(ORERR),U,2)) !," >> "_$P(ORERR,U,2) W ! H 1 59 W:ORCREATE "... discontinue order(s) placed." H 1 60 I $O(ORPRINT(0)) D PRINT^ORPR02(ORVP,.ORPRINT,,ORL,ORPRNT) 61 S OREBUILD=1 ; rebuild orders list 62 DCQ D:$G(OREBUILD) UNOTIF^ORCSIGN ; undo notif? 63 D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders 64 S:$G(ORXNP) ORNP=ORXNP ;reset provider if needed 65 D:$D(OREVT) EVENT ;cancel any events? 66 Q 67 ; 68 UNLOCK ; -- Unlock orders in ORDC(ORI)=ORIFN 69 N ORI,ORIFN S ORI=0 70 F S ORI=$O(ORDC(ORI)) Q:ORI'>0 S ORIFN=+ORDC(ORI) D UNLK1^ORX2(ORIFN) 71 Q 72 ; 73 OK(NUM) ; -- Ok to DC delayed order(s) too? 74 N X,Y,DIR S DIR(0)="YA",DIR("B")="NO" 75 S DIR("A")="Do you want to discontinue "_$S(NUM>1:"these orders",1:"this order")_" too? " 76 S DIR("?")="Enter YES to also cancel the delayed order(s), or NO to allow the order(s) to be activated when the designated event occurs." 77 W ! D ^DIR 78 Q +Y 79 ; 80 NXT() ; -- Return next available subscript in ORDC() 81 N Y S Y=$L(ORNMBR,",")+1 S:Y'>$O(ORDC(""),-1) Y=$O(ORDC(""),-1)+1 82 Q Y 83 ; 84 PRINT(NATR) ; -- Ok to print order? 85 N I,OR1,Y S I=$O(^ORD(100.02,"C",NATR,0)),OR1=$G(^ORD(100.02,I,1)) 86 S Y=$P(OR1,U,2)_"^^^^"_$P(OR1,U,5) 87 Q Y 88 ; 89 ORDITEM(ID) ; -- Returns order text 90 ;N X,I,MORE S X="" 91 ;I $P(ID,";",2)>1 S I=$P($G(^OR(100,+ID,8,+$P(ID,";",2),0)),U,2),X=$S(I="DC":"Discontinue ",I="HD":"Hold ",1:"") 92 ;S I=$O(^OR(100,+ID,1,0)) Q:'I "" S MORE=$O(^(I)),X=X_$G(^(I,0)) 93 ;I $L(X)>68 S X=$E(X,1,68),MORE=1 94 ;S:MORE X=X_" ..." 95 N X,ORX D TEXT^ORQ12(.ORX,ID,68) S X=ORX(1)_$S(ORX>1:" ...",1:"") 96 Q X 97 ; 98 SUBHDR(X) ; -- Display subheader of order being acted on 99 W !!,?(36-($L(X)\2)),"-- "_X_" --",! 100 Q 101 ; 102 COMPLX ; -- Ck for other child orders to be dc'd at same time 103 N DAD,CHLD 104 S DAD=0 F S DAD=$O(ORDC("DAD",DAD)) Q:DAD<1 D 105 . S CHLD=0 F S CHLD=$O(^OR(100,DAD,2,CHLD)) Q:CHLD<1 D 106 .. Q:"^1^2^7^12^13^14^15^"[(U_$P($G(^OR(100,CHLD,3)),U,3)_U) 107 .. Q:$D(ORDC("DAD",DAD,CHLD)) S ORDC($$NXT)=CHLD 108 Q 109 ; 110 DCREASON() ; -- Returns Reason for DC 111 N X,Y,DIC 112 ;I $D(^XUSEC("ORES",DUZ)) S Y=+$O(^ORD(100.03,"C","ORREQ",0)) I Y S Y(0)=$G(^ORD(100.03,Y,0)),Y=Y_U_$P(Y(0),U) G DCRQ ; silent 113 S DIC="^ORD(100.03,",DIC(0)="AEMQZ",DIC("B")=+$O(^ORD(100.03,"C","ORREQ",0)),DIC("W")="W:$L($P(^(0),U))>30 $E($P(^(0),U),31,999)" K:DIC("B")'>0 DIC("B") 114 S DIC("S")="I '$P(^(0),U,4),$P(^(0),U,5)="_+$O(^DIC(9.4,"C","OR",0))_",$P(^(0),U,7)'="_+$O(^ORD(100.02,"C","A",0)),DIC("A")="REASON FOR DC: " ;is referenced by DBIA #2058 115 D ^DIC 116 DCRQ S:Y>0 Y=Y_U_$S($P(Y(0),U,7):$P($G(^ORD(100.02,+$P(Y(0),U,7),0)),U,2),1:"W") ; ^nature 117 Q Y 118 ; 119 SET(ORDER,NATURE,REASON,TEXT) ; -- Set DC Reason into 6-node 120 Q:'$G(ORDER) Q:'$D(^OR(100,+ORDER,0)) S ORDER=+ORDER 121 I $L($G(NATURE)),NATURE'>0 S NATURE=$O(^ORD(100.02,"C",NATURE,0)) 122 S ^OR(100,ORDER,6)=$G(NATURE)_U_DUZ_U_$E($$NOW^XLFDT,1,12)_U_$G(REASON)_U_$G(TEXT) 123 Q 124 ; 125 RESUME(ORDER) ; -- Resume tray service when dc'ing tubefeeding ORDER? 126 N X,Y,DIR,DIC,DA S X=$$RESUME^FHWORR(+ORVP) 127 I '$L(X) W !,"NOTE: NO current diet order exists for this patient!" Q 128 Q:'X I X=2 W !,"Note: Patient is on a WITHHOLD SERVICE order!" 129 S DIR(0)="YA",DIR("A")="Do you wish to resume tray service? " 130 S DIR("?")="Enter YES to resume the previous diet order",DIR("B")="NO" 131 D ^DIR I Y'=1 S:$D(DTOUT)!(X["^") ORQUIT=1 132 D:Y=1 RESUME^ORCSAVE(+ORDER) 133 Q 134 ; 135 UNREL ; -- Process unreleased/delayed order 136 N ORA,ORA0,ORDEL,DA,DR,DIE 137 S ORA=+$P(ORIFN,";",2),ORA0=$G(^OR(100,+ORIFN,8,ORA,0)) 138 S ORDEL=$S(ORSTS=11:1,$P(ORA0,U,4)=2:1,1:0) 139 W !,"This order was not released "_$S(ORDEL:"to the service and will be deleted.",1:"but signed and will be cancelled.") H 1 I ORDEL D 140 . K:$P(ORA0,U,2)="DC" ^OR(100,+ORIFN,6) I $P(ORA0,U,2)="NW" D 141 .. S:$P(OR3,U,5) $P(^OR(100,+$P(OR3,U,5),3),U,6)="" 142 .. I $P(OR0,U,17) S DA=+$O(^ORE(100.2,"AO",+ORIFN,0)) I DA S DR="4///@",DIE=100.2 D ^DIE 143 . D DELETE^ORCSAVE2(ORIFN) 144 D CLRDLY(+ORIFN):'ORDEL,UNLK1^ORX2(+ORIFN) S OREBUILD=1 145 I $D(^TMP("ORNEW",$J,+ORIFN,ORA)) K ^(ORA) D UNLK1^ORX2(+ORIFN) ;decrement lock again 146 Q 147 ; 148 EVENT ; -- Cancel event too? 149 N EVT,X 150 S EVT=0 F S EVT=$O(OREVT(EVT)) Q:EVT<1 D Q:$G(ORQUIT) 151 . Q:$G(^ORE(100.2,EVT,1)) Q:'$$EMPTY^OREVNTX(EVT) ;done or has orders 152 . ;W !!,$P($$NAME^OREVNTX(EVT)," ",2,99)_" has no more delayed orders." 153 . ;S DIR(0)="YA",DIR("A")="Do you want to cancel this event? " 154 . ;S DIR("?")="Enter NO if you wish to enter new delayed orders for this event, otherwise enter YES to terminate it." 155 . ;S DIR("B")="YES" D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q 156 . D CANCEL^OREVNTX(EVT) S X=$P($$NAME^OREVNTX(EVT)," ",2,99) 157 . W !," ... "_X_" event cancelled." H 1 158 . I $G(OREVENT),OREVENT=EVT D EX^OREVNT ;Return to Active Orders 159 Q 160 ; 161 DCD(IFN) ; -- order discontinued already? 162 N STS,Y,I S Y=0 I '$G(IFN) Q 1 163 S STS=+$P($G(^OR(100,+IFN,3)),U,3) 164 I "^1^2^7^12^13^14^"[(U_STS_U) S Y=1 G DQ ;terminal sts 165 ;look for existing DC action awaiting ES: 166 S I=0 F S I=+$O(^OR(100,+IFN,8,"C","DC",I)) Q:I<1 I $P($G(^OR(100,+IFN,8,I,0)),U,15)=11 S Y=1 Q 167 DQ Q Y 168 ; 169 CLRDLY(IFN) ; -- [old Clear delayed fields] Cancel delayed [event]order 170 N STS,ORX S IFN=+$G(IFN) Q:IFN'>0 171 Q:'$D(^OR(100,IFN,0)) S STS=$P($G(^(3)),U,3) 172 S ORX="Delayed "_$S(STS=10:"Order",1:"Release Event")_" Cancelled" 173 S ^OR(100,IFN,6)=$O(^ORD(100.02,"C","M",0))_U_DUZ_U_+$E($$NOW^XLFDT,1,12)_U_U_ORX 174 D STATUS^ORCSAVE2(IFN,13) S $P(^OR(100,IFN,8,1,0),U,15)=13 175 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCB.m
r613 r623 1 ORCB ;SLC/MKB-Notifications followup for LMgr chart ;4/5/01 21:32 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,36,48,70,108,116,243**;Dec 17, 1997;Build 242 3 EN(DFN,ORFLG,DGRP,DEL) ; -- main entry point 4 Q:'$G(DFN) Q:'$G(ORFLG) 5 N BEG,END D SLCT1^ORQPT 6 S DGRP=$P($G(^ORD(100.98,+$G(DGRP),0)),U,3) S:'$L(DGRP) DGRP="ALL" 7 S (BEG,END)="" I ORFLG=6 D ;get BEG from XQAID for New Orders 8 . S BEG=$P(XQAID,";",3) I BEG'?7N1".".6N!(BEG'<DT) S BEG="" Q 9 . S BEG=$$FMADD^XLFDT(BEG,,,-5),END=$$NOW^XLFDT 10 I ORFLG=9 D ;get BEG from Current Admission 11 . N ADM S ADM=+$G(^DPT(DFN,.105)) S:ADM ADM=+$P($G(^DGPM(ADM,0)),U) 12 . S END=$$NOW^XLFDT,BEG=$S(ADM:ADM,1:$$FMADD^XLFDT(END,-30)) 13 S ^TMP("OR",$J,"ORDERS",0)="^^"_BEG_";"_END_";"_ORFLG_";"_DGRP_";L" 14 D EN^VALM("ORCB NOTIFICATIONS") 15 Q 16 ; 17 INIT ; -- init variables and list array 18 S ORTAB="ORDERS" D TAB^ORCHART("ORDERS",1) 19 I VALMCNT=1,$G(^TMP("OR",$J,ORTAB,1,0))["No data available" D 20 . N X,I S X=" No "_$S(ORFLG=5:"expiring",ORFLG=11:"unsigned",ORFLG=12:"flagged",9:"unverified",1:"new")_" orders found." 21 . F I="ORDERS","CURRENT" S ^TMP("OR",$J,I,1,0)=$$LJ^XLFSTR(X,45)_"|" 22 Q 23 ; 24 HELP ; -- help code 25 N X S VALMBCK="" 26 W !!,"Enter the display numbers of the orders you wish to act on;" 27 W !,"select either DT for a detailed listing of information about each" 28 W !,"order, or the desired action. Enter Q to exit." 29 W !!,"Press <return> to continue ..." R X:DTIME 30 Q 31 ; 32 PHDR ; -- protocol menu header code 33 N NUM,ORI,ORDEF,I,X K ORNMBR,OREBUILD 34 S VALMSG=$$MSG^ORCHART D SHOW^VALM 35 S NUM=+$P($G(^TMP("OR",$J,"CURRENT",0)),U,2) 36 S XQORM("#")=$O(^ORD(101,"B","ORCB ACTIONS",0))_"^1:"_NUM 37 S ORI=$S(ORFLG=5:1,ORFLG=11:"2,3,4",ORFLG=12:"3,4,5,6,7",1:8) 38 S ORDEF=$S(ORFLG=5:1,ORFLG=11:9,ORFLG=12:5,1:10) 39 F I=1:1:$L(ORI,",") S X=$T(ACTIONS+$P(ORI,",",I)),XQORM("KEY",$P(X,";",3))=$O(^ORD(101,"B","ORC "_$P(X,";",4)_" ORDERS",0))_"^1" 40 S XQORM("KEY","DT")=$O(^ORD(101,"B","ORC DETAILED DISPLAY",0))_"^1" 41 I +$P($G(^TMP("OR",$J,"CURRENT",0)),U,2)>0,XQORM("B")="Quit" S X=$T(ACTIONS+ORDEF),X=$P(X,";",4),XQORM("KEY",$P(X," "))=$O(^ORD(101,"B","ORC "_X_" ORDERS",0))_"^1",XQORM("B")=$$LOWER^VALM1(X)_" Orders" ; default action 42 S:'$G(ORL) ORL=$$FINDLOC ; attempt to determine location from orders 43 Q 44 ; 45 SELECT ; -- process selected order(s) 46 N MENU,XQORM,Y,ORNMBR,OREBUILD,ORY S VALMBCK="" 47 S ORNMBR=$P(XQORNOD(0),"=",2) D SELECT^ORCHART(ORNMBR) 48 S:'$G(ORFLG) ORFLG=$P($P(^TMP("OR",$J,"CURRENT",0),U,3),";",3) 49 S MENU=$S(ORFLG=5:"EXPIRING",ORFLG=11:"UNSIGNED",ORFLG=12:"FLAGGED",1:"NEW") 50 S XQORM=$O(^ORD(101,"B","ORCB "_MENU_" MENU",0))_";ORD(101," 51 I 'XQORM W !!,"ERROR" H 2 G SQ 52 S XQORM(0)="1AD",XQORM("A")="Select action: " 53 W ! D EN^XQORM G:Y'>0 SQ M ORY=Y 54 I $D(^ORD(101,+$P(ORY(1),U,2),20)) X ^(20) S VALMBCK="R" 55 I $G(OREBUILD) D:ORFLG=12 UNFLAG D TAB^ORCHART(ORTAB,1) Q 56 SQ D DESELECT^ORCHART(ORNMBR) 57 Q 58 ; 59 UNFLAG ; -- Unflag orders 60 N ORX,ORI,NUM,ORIFN,ORA,X 61 S ORX=$P(ORY(1),U,3) Q:(ORX="Unflag")!(ORX="Detailed Display") 62 F ORI=1:1:$L(ORNMBR,",") S NUM=$P(ORNMBR,",",ORI) I NUM D 63 . S ORIFN=$P(^TMP("OR",$J,"CURRENT","IDX",NUM),U) Q:'ORIFN 64 . S ORA=+$P(ORIFN,";",2),ORIFN=+ORIFN Q:'ORA 65 . Q:'$D(^OR(100,ORIFN)) Q:(ORX="Edit")&($P(^(ORIFN,3),U,3)'=12) 66 . S X=+$G(^OR(100,ORIFN,8,ORA,0)),$P(^(3),U)=0,$P(^(3),U,6,8)=X_U_DUZ_"^Unflagged by action" ; Unflag 67 . S X=ORIFN_";"_ORA D MSG^ORCFLAG(X) 68 Q 69 ; 70 EN1(ORIFN,ACTION) ; -- entry point to display single order 71 Q:'ORIFN Q:'$D(^OR(100,ORIFN)) 72 Q:"^^NEW^RENEW^REPLACE^"'[(U_$G(ACTION)_U) 73 S DFN=+$P(^OR(100,ORIFN,0),U,2) Q:'DFN 74 S ^TMP("ORXPND",$J,0)=ORIFN_U_$G(ACTION) 75 D EN1^ORCXPND(DFN,ORIFN) 76 K ^TMP("ORXPND",$J),^TMP("OR",$J) 77 Q 78 ; 79 NEW ; -- Add new order as follow-up action 80 N IFN,TYPE,ORIG,ORNP,ORPTLK S VALMBCK="" K ^TMP("ORNEW",$J) 81 S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q 82 S ORNP=$$PROVIDER^ORCMENU1,VALMBCK="R" G:ORNP="^" NWQ 83 I '$G(ORL) S ORL=$$LOCATION^ORCMENU1 G:ORL["^" NWQ 84 S ORIG=+$P($G(^TMP("ORXPND",$J,0)),U),IFN=+$P($G(^OR(100,+ORIG,0)),U,5) 85 G:'IFN NWQ S TYPE=$P($G(^ORD(101.41,IFN,0)),U,4) 86 ; If 2.5 order, use DG or PKG to get dlg 87 D FULL^VALM1,ORDER^ORCMENU 88 I $O(^TMP("ORNEW",$J,0)) D SIGN,NOTIF^ORCMENU2 89 K ^TMP("ORNEW",$J) S VALMBCK="R" 90 NWQ D UNLOCK^ORX2(+ORVP) 91 Q 92 ; 93 EDIT ; -- Edit order as follow-up action 94 N OREBUILD K ^TMP("ORNEW",$J) 95 D EDIT^ORCACT I $G(OREBUILD) D 96 . D SIGN,NOTIF^ORCMENU2 97 . S $P(^TMP("ORXPND",$J,0),U,2)="" 98 K ^TMP("ORNEW",$J) S VALMBCK="R" 99 D UNLOCK^ORX2(+ORVP) 100 Q 101 ; 102 RENEW ; --Renew order as follow-up action 103 N OREBUILD K ^TMP("ORNEW",$J) 104 D RENEW^ORCACT I $G(OREBUILD) D 105 . D SIGN,NOTIF^ORCMENU2 106 . S $P(^TMP("ORXPND",$J,0),U,2)="" 107 . K ^TMP("ORXPND",$J) D INIT^ORCXPND 108 K ^TMP("ORNEW",$J) S VALMBCK="R" 109 D UNLOCK^ORX2(+ORVP) 110 Q 111 ; 112 SIGN ; -- Sign new order 113 N ORIFN,ORTAB,ORNMBR,CNT 114 S ORTAB="NEW",(ORIFN,CNT)=0,ORNMBR="" 115 F S ORIFN=+$O(^TMP("ORNEW",$J,ORIFN)) Q:ORIFN'>0 S CNT=CNT+1,^TMP("OR",$J,"NEW","IDX",CNT)=ORIFN,ORNMBR=ORNMBR_CNT_"," 116 I CNT D EN^ORCSIGN K ^TMP("OR",$J,"NEW","IDX") 117 Q 118 ; 119 EXIT ; -- exit action 120 I $P($P(^TMP("OR",$J,"CURRENT",0),U,3),";",3)=12 D ; flagged orders 121 . Q:'$$GET^XPAR("ALL","ORPF AUTO UNFLAG") 122 . N ORI,ORIFN,ORA,XQAKILL,ORN,ORUNF 123 . S ORUNF=+$E($$NOW^XLFDT,1,12)_U_DUZ_"^Auto-Unflagged" 124 . S ORI=0 F S ORI=$O(^TMP("OR",$J,"CURRENT","IDX",ORI)) Q:ORI'>0 S ORIFN=$P(^(ORI),U),ORA=+$P(ORIFN,";",2) I ORIFN,$D(^OR(100,+ORIFN,0)) S $P(^(8,ORA,3),U)=0,$P(^(3),U,6,8)=ORUNF D MSG^ORCFLAG(ORIFN) ; unflag 125 . S ORN=+$O(^ORD(100.9,"B","FLAGGED ORDERS",0)) 126 . S XQAKILL=$$XQAKILL^ORB3F1(ORN) D:$D(XQAID) DELETE^XQALERT 127 D EXIT^ORCHART 128 Q 129 ; 130 ACTIONS ;;KEY;NAME 131 ;;RN;RENEW 132 ;;$;SIGN 133 ;;DC;DISCONTINUE 134 ;;ED;CHANGE 135 ;;UF;UNFLAG 136 ;;HD;HOLD 137 ;;RL;UNHOLD 138 ;;VF;VERIFY 139 ;;;SIGN ALL 140 ;;;VERIFY ALL 141 ; 142 ALL ; -- Select ALL orders 143 N X,Y,DIR,MAX 144 S MAX=+$P($G(^TMP("OR",$J,"CURRENT",0)),U,2),X="1-"_MAX,Y="" 145 S DIR(0)="L^1:"_MAX,DIR("V")="" D:MAX ^DIR 146 S ORNMBR=Y 147 Q 148 ; 149 FINDLOC() ; -- Loop through orders in alert to find assigned location 150 N ORI,ORIFN,ORY S ORI=0,ORY="" 151 F S ORI=$O(^TMP("OR",$J,"CURRENT","IDX",ORI)) Q:ORI'>0 S ORIFN=+^(ORI),ORX=$P($G(^OR(100,ORIFN,0)),U,10) S:ORY="" ORY=ORX I ORY'="",ORX'=ORY S ORY="" Q ; ORY=location for all orders, or "" if different 152 Q ORY 153 ; 154 DELETE ; -- Delete current alert 155 N %,%Y,X,Y,PRMT,XQAKILL S VALMBCK="",XQAKILL=1 156 S PRMT="Your "_$S(ORFLG=5:"Expiring",ORFLG=11:"Unsigned",ORFLG=12:"Flagged",ORFLG=9:"Unverified",1:"New")_" Orders alert for "_$G(ORPNM)_" will be deleted!" 157 D1 W !!,PRMT,!,"Are you sure" S %=2 D YN^DICN 158 I (%<0)!(%=2) W !,"Nothing deleted." H 2 Q 159 I %=0 D G D1 160 . W !!,"This action will delete the alert you are currently processing; the alert will",!,"disappear automatically when all orders have been acted on, but this action may",!,"be used to remove the alert if some orders are to be left unchanged." 161 . W !,"Press <return> to continue ..." R X:DTIME 162 W !,"Removing alert ..." D:$D(XQAID) DEL^ORB3FUP1(.Y,XQAID) 163 I $G(Y)="TRUE" W " done." S VALMBCK="Q",DEL=1 H 2 164 E W " unable to delete alert." H 2 165 Q 1 ORCB ;SLC/MKB-Notifications followup for LMgr chart ;4/5/01 21:32 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,36,48,70,108,116**;Dec 17, 1997 3 EN(DFN,ORFLG,DGRP,DEL) ; -- main entry point 4 Q:'$G(DFN) Q:'$G(ORFLG) 5 N BEG,END D SLCT1^ORQPT 6 S DGRP=$P($G(^ORD(100.98,+$G(DGRP),0)),U,3) S:'$L(DGRP) DGRP="ALL" 7 S (BEG,END)="" I ORFLG=6 D ;get BEG from XQAID for New Orders 8 . S BEG=$P(XQAID,";",3) I BEG'?7N1".".6N!(BEG'<DT) S BEG="" Q 9 . S BEG=$$FMADD^XLFDT(BEG,,,-5),END=$$NOW^XLFDT 10 I ORFLG=9 D ;get BEG from Current Admission 11 . N ADM S ADM=+$G(^DPT(DFN,.105)) S:ADM ADM=+$P($G(^DGPM(ADM,0)),U) 12 . S END=$$NOW^XLFDT,BEG=$S(ADM:ADM,1:$$FMADD^XLFDT(END,-30)) 13 S ^TMP("OR",$J,"ORDERS",0)="^^"_BEG_";"_END_";"_ORFLG_";"_DGRP_";L" 14 D EN^VALM("ORCB NOTIFICATIONS") 15 Q 16 ; 17 INIT ; -- init variables and list array 18 S ORTAB="ORDERS" D TAB^ORCHART("ORDERS",1) 19 I VALMCNT=1,$G(^TMP("OR",$J,ORTAB,1,0))["No data available" D 20 . N X,I S X=" No "_$S(ORFLG=5:"expiring",ORFLG=11:"unsigned",ORFLG=12:"flagged",9:"unverified",1:"new")_" orders found." 21 . F I="ORDERS","CURRENT" S ^TMP("OR",$J,I,1,0)=$$LJ^XLFSTR(X,45)_"|" 22 Q 23 ; 24 HELP ; -- help code 25 N X S VALMBCK="" 26 W !!,"Enter the display numbers of the orders you wish to act on;" 27 W !,"select either DT for a detailed listing of information about each" 28 W !,"order, or the desired action. Enter Q to exit." 29 W !!,"Press <return> to continue ..." R X:DTIME 30 Q 31 ; 32 PHDR ; -- protocol menu header code 33 N NUM,ORI,ORDEF,I,X K ORNMBR,OREBUILD 34 S VALMSG=$$MSG^ORCHART D SHOW^VALM 35 S NUM=+$P($G(^TMP("OR",$J,"CURRENT",0)),U,2) 36 S XQORM("#")=$O(^ORD(101,"B","ORCB ACTIONS",0))_"^1:"_NUM 37 S ORI=$S(ORFLG=5:1,ORFLG=11:"2,3,4",ORFLG=12:"3,4,5,6,7",1:8) 38 S ORDEF=$S(ORFLG=5:1,ORFLG=11:9,ORFLG=12:5,1:10) 39 F I=1:1:$L(ORI,",") S X=$T(ACTIONS+$P(ORI,",",I)),XQORM("KEY",$P(X,";",3))=$O(^ORD(101,"B","ORC "_$P(X,";",4)_" ORDERS",0))_"^1" 40 S XQORM("KEY","DT")=$O(^ORD(101,"B","ORC DETAILED DISPLAY",0))_"^1" 41 I +$P($G(^TMP("OR",$J,"CURRENT",0)),U,2)>0,XQORM("B")="Quit" S X=$T(ACTIONS+ORDEF),X=$P(X,";",4),XQORM("KEY",$P(X," "))=$O(^ORD(101,"B","ORC "_X_" ORDERS",0))_"^1",XQORM("B")=$$LOWER^VALM1(X)_" Orders" ; default action 42 S:'$G(ORL) ORL=$$FINDLOC ; attempt to determine location from orders 43 Q 44 ; 45 SELECT ; -- process selected order(s) 46 N MENU,XQORM,Y,ORNMBR,OREBUILD,ORY S VALMBCK="" 47 S ORNMBR=$P(XQORNOD(0),"=",2) D SELECT^ORCHART(ORNMBR) 48 S:'$G(ORFLG) ORFLG=$P($P(^TMP("OR",$J,"CURRENT",0),U,3),";",3) 49 S MENU=$S(ORFLG=5:"EXPIRING",ORFLG=11:"UNSIGNED",ORFLG=12:"FLAGGED",1:"NEW") 50 S XQORM=$O(^ORD(101,"B","ORCB "_MENU_" MENU",0))_";ORD(101," 51 I 'XQORM W !!,"ERROR" H 2 G SQ 52 S XQORM(0)="1AD",XQORM("A")="Select action: " 53 W ! D EN^XQORM G:Y'>0 SQ M ORY=Y 54 I $D(^ORD(101,+$P(ORY(1),U,2),20)) X ^(20) S VALMBCK="R" 55 I $G(OREBUILD) D:ORFLG=12 UNFLAG D TAB^ORCHART(ORTAB,1) Q 56 SQ D DESELECT^ORCHART(ORNMBR) 57 Q 58 ; 59 UNFLAG ; -- Unflag orders 60 N X,ORI,NUM,ORIFN,ORA 61 S X=$P(ORY(1),U,3) Q:(X="Unflag")!(X="Detailed Display") 62 F ORI=1:1:$L(ORNMBR,",") S NUM=$P(ORNMBR,",",ORI) I NUM D 63 . S ORIFN=$P(^TMP("OR",$J,"CURRENT","IDX",NUM),U) Q:'ORIFN 64 . S ORA=+$P(ORIFN,";",2),ORIFN=+ORIFN Q:'ORA 65 . Q:'$D(^OR(100,ORIFN)) Q:(X="Edit")&($P(^(ORIFN,3),U,3)'=12) 66 . S $P(^OR(100,ORIFN,8,ORA,3),U)=0 ; Unflag 67 Q 68 ; 69 EN1(ORIFN,ACTION) ; -- entry point to display single order 70 Q:'ORIFN Q:'$D(^OR(100,ORIFN)) 71 Q:"^^NEW^RENEW^REPLACE^"'[(U_$G(ACTION)_U) 72 S DFN=+$P(^OR(100,ORIFN,0),U,2) Q:'DFN 73 S ^TMP("ORXPND",$J,0)=ORIFN_U_$G(ACTION) 74 D EN1^ORCXPND(DFN,ORIFN) 75 K ^TMP("ORXPND",$J),^TMP("OR",$J) 76 Q 77 ; 78 NEW ; -- Add new order as follow-up action 79 N IFN,TYPE,ORIG,ORNP,ORPTLK S VALMBCK="" K ^TMP("ORNEW",$J) 80 S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q 81 S ORNP=$$PROVIDER^ORCMENU1,VALMBCK="R" G:ORNP="^" NWQ 82 I '$G(ORL) S ORL=$$LOCATION^ORCMENU1 G:ORL["^" NWQ 83 S ORIG=+$P($G(^TMP("ORXPND",$J,0)),U),IFN=+$P($G(^OR(100,+ORIG,0)),U,5) 84 G:'IFN NWQ S TYPE=$P($G(^ORD(101.41,IFN,0)),U,4) 85 ; If 2.5 order, use DG or PKG to get dlg 86 D FULL^VALM1,ORDER^ORCMENU 87 I $O(^TMP("ORNEW",$J,0)) D SIGN,NOTIF^ORCMENU2 88 K ^TMP("ORNEW",$J) S VALMBCK="R" 89 NWQ D UNLOCK^ORX2(+ORVP) 90 Q 91 ; 92 EDIT ; -- Edit order as follow-up action 93 N OREBUILD K ^TMP("ORNEW",$J) 94 D EDIT^ORCACT I $G(OREBUILD) D 95 . D SIGN,NOTIF^ORCMENU2 96 . S $P(^TMP("ORXPND",$J,0),U,2)="" 97 K ^TMP("ORNEW",$J) S VALMBCK="R" 98 D UNLOCK^ORX2(+ORVP) 99 Q 100 ; 101 RENEW ; --Renew order as follow-up action 102 N OREBUILD K ^TMP("ORNEW",$J) 103 D RENEW^ORCACT I $G(OREBUILD) D 104 . D SIGN,NOTIF^ORCMENU2 105 . S $P(^TMP("ORXPND",$J,0),U,2)="" 106 . K ^TMP("ORXPND",$J) D INIT^ORCXPND 107 K ^TMP("ORNEW",$J) S VALMBCK="R" 108 D UNLOCK^ORX2(+ORVP) 109 Q 110 ; 111 SIGN ; -- Sign new order 112 N ORIFN,ORTAB,ORNMBR,CNT 113 S ORTAB="NEW",(ORIFN,CNT)=0,ORNMBR="" 114 F S ORIFN=+$O(^TMP("ORNEW",$J,ORIFN)) Q:ORIFN'>0 S CNT=CNT+1,^TMP("OR",$J,"NEW","IDX",CNT)=ORIFN,ORNMBR=ORNMBR_CNT_"," 115 I CNT D EN^ORCSIGN K ^TMP("OR",$J,"NEW","IDX") 116 Q 117 ; 118 EXIT ; -- exit action 119 I $P($P(^TMP("OR",$J,"CURRENT",0),U,3),";",3)=12 D ; flagged orders 120 . Q:'$$GET^XPAR("ALL","ORPF AUTO UNFLAG") 121 . N ORI,ORIFN,ORA,XQAKILL,ORN,ORUNF 122 . S ORUNF=+$E($$NOW^XLFDT,1,12)_U_DUZ_"^Auto-Unflagged" 123 . S ORI=0 F S ORI=$O(^TMP("OR",$J,"CURRENT","IDX",ORI)) Q:ORI'>0 S ORIFN=$P(^(ORI),U),ORA=+$P(ORIFN,";",2) I ORIFN,$D(^OR(100,+ORIFN,0)) S $P(^(8,ORA,3),U)=0,$P(^(3),U,6,8)=ORUNF ; unflag 124 . S ORN=+$O(^ORD(100.9,"B","FLAGGED ORDERS",0)) 125 . S XQAKILL=$$XQAKILL^ORB3F1(ORN) D:$D(XQAID) DELETE^XQALERT 126 D EXIT^ORCHART 127 Q 128 ; 129 ACTIONS ;;KEY;NAME 130 ;;RN;RENEW 131 ;;$;SIGN 132 ;;DC;DISCONTINUE 133 ;;ED;CHANGE 134 ;;UF;UNFLAG 135 ;;HD;HOLD 136 ;;RL;UNHOLD 137 ;;VF;VERIFY 138 ;;;SIGN ALL 139 ;;;VERIFY ALL 140 ; 141 ALL ; -- Select ALL orders 142 N X,Y,DIR,MAX 143 S MAX=+$P($G(^TMP("OR",$J,"CURRENT",0)),U,2),X="1-"_MAX,Y="" 144 S DIR(0)="L^1:"_MAX,DIR("V")="" D:MAX ^DIR 145 S ORNMBR=Y 146 Q 147 ; 148 FINDLOC() ; -- Loop through orders in alert to find assigned location 149 N ORI,ORIFN,ORY S ORI=0,ORY="" 150 F S ORI=$O(^TMP("OR",$J,"CURRENT","IDX",ORI)) Q:ORI'>0 S ORIFN=+^(ORI),ORX=$P($G(^OR(100,ORIFN,0)),U,10) S:ORY="" ORY=ORX I ORY'="",ORX'=ORY S ORY="" Q ; ORY=location for all orders, or "" if different 151 Q ORY 152 ; 153 DELETE ; -- Delete current alert 154 N %,%Y,X,Y,PRMT,XQAKILL S VALMBCK="",XQAKILL=1 155 S PRMT="Your "_$S(ORFLG=5:"Expiring",ORFLG=11:"Unsigned",ORFLG=12:"Flagged",ORFLG=9:"Unverified",1:"New")_" Orders alert for "_$G(ORPNM)_" will be deleted!" 156 D1 W !!,PRMT,!,"Are you sure" S %=2 D YN^DICN 157 I (%<0)!(%=2) W !,"Nothing deleted." H 2 Q 158 I %=0 D G D1 159 . W !!,"This action will delete the alert you are currently processing; the alert will",!,"disappear automatically when all orders have been acted on, but this action may",!,"be used to remove the alert if some orders are to be left unchanged." 160 . W !,"Press <return> to continue ..." R X:DTIME 161 W !,"Removing alert ..." D:$D(XQAID) DEL^ORB3FUP1(.Y,XQAID) 162 I $G(Y)="TRUE" W " done." S VALMBCK="Q",DEL=1 H 2 163 E W " unable to delete alert." H 2 164 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCD.m
r613 r623 1 ORCD ; SLC/MKB - Order Dialog utilities ;12/15/2006 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,38,68,94,161,141,195,215,243**;Dec 17,1997;Build 242 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 INPT() ; -- Return 1 or 0, if patient/order sheet = inpatient 5 N Y S Y=$S($G(ORWARD):1,$G(^DPT(+ORVP,.105)):1,1:0) 6 I $G(OREVENT) D ;override if delayed order 7 . N X,X0 S X=$$EVT^OREVNTX(+OREVENT),X0=$G(^ORD(100.5,+X,0)) 8 . I $P(X0,U,12) S X0=$G(^ORD(100.5,$P(X0,U,12),0)) ;use parent 9 . S X=$P(X0,U,2) Q:X="M" Q:X="O" ;M/O keep current inpt status 10 . S Y=$S(X="A":1,X="T":1,1:0) 11 . I X="D",$P(X0,U,7)=41 S Y=1 ;From ASIH = Inpt 12 . I X="T",$P(X0,U,7),$P(X0,U,7)<4 S Y=0 ;pass = Outpt 13 Q Y 14 ; 15 EXT(P,I,F) ; -- Returns external value of ORDIALOG(Prompt,Instance) 16 N TYPE,PARAM,FNUM,IENS,X,Y,J,Z 17 S TYPE=$E($G(ORDIALOG(P,0))),PARAM=$P($G(ORDIALOG(P,0)),U,2) 18 S X=$G(ORDIALOG(P,I)) I X="" Q "" 19 I TYPE="N",X<1 S X=0_+X I X="00" S X=0 20 I "FNW"[TYPE Q X 21 I TYPE="Y" Q $S(X:"YES",X=0:"NO",1:"") 22 I TYPE="D" S:'$L($G(F)) F=1 Q $$FMTE^XLFDT(X,F) 23 I TYPE="R" Q $$FTDATE(X,$G(F)) ; DAY@TIME 24 I TYPE="P" D Q Y 25 . S PARAM=$P(PARAM,":"),FNUM=$S(PARAM:+PARAM,1:+$P(@(U_PARAM_"0)"),U,2)) 26 . S IENS=+X_",",J=$L(PARAM,",") I J>2 F S J=J-2 Q:J'>0 S Z=$P(PARAM,",",J),IENS=IENS_$S(Z:Z,1:+$P(Z,"(",2))_"," 27 . S:'+$G(F) F=.01 S Y=$$GET1^DIQ(FNUM,IENS,+F) 28 . I Y="",F'=.01 S Y=$$GET1^DIQ(FNUM,IENS,.01) 29 I TYPE="S" F J=1:1:$L(PARAM,";") S Z=$P(PARAM,";",J) I $P(Z,":")=X S Y=$S(+$G(F):X,1:$P(Z,":",2)) Q 30 Q $G(Y) 31 ; 32 FTDATE(X,F) ; -- Returns free text form of date (i.e. TODAY) 33 N D,T,P,Y I X="" Q "" 34 S X=$$UP^XLFSTR(X),D=$P(X,"@"),T=$P(X,"@",2) ; D=date,T=time parts 35 I "NOW"[X Q "NOW" 36 I "NOON"[X Q "NOON" 37 I $E("MIDNIGHT",1,$L(X))=X Q "MIDNIGHT" 38 I (X="AM")!(X="NEXT") Q X_" Lab collection" 39 I (X="NEXTA")!(X="CLOSEST") Q $S(X="NEXTA":"NEXT",1:X)_" administration time" 40 I $E(D)'="T",$E(D)'="V",($E(D)'="N"!($E(D,1,3)="NOV")) D Q $$FMTE^XLFDT(X,F) 41 . N %DT S %DT="TX" D ^%DT S:Y>0 X=Y S:'$G(F) F=1 42 S P=$S(D["+":"+",D["-":"-",1:"") 43 I P="" S Y=$S($E(D)="T":"TODAY",$E(D)="V":"NEXT VISIT",1:"NOW") 44 FTD1 E D 45 . N OFFSET,NUM,UNIT 46 . S OFFSET=$P(D,P,2),NUM=+OFFSET,UNIT=$E($P(OFFSET,NUM,2)) ; +/-#D 47 . I $E(D)="T",NUM=1,UNIT=""!(UNIT="D") S Y=$S(P="+":"TOMORROW",1:"YESTERDAY") Q 48 . S Y=NUM_" "_$S(UNIT="'":"MINUTE",UNIT="H":"HOUR",UNIT="W":"WEEK",UNIT="M":"MONTH",1:"DAY") 49 . S:NUM>1 Y=Y_"S" ; plural 50 . S:$E(D)="N" Y=Y_" "_$S(P="+":"FROM NOW",1:"AGO") 51 . S:$E(D)="T" Y=Y_" "_$S(P="+":"FROM TODAY",1:"AGO") 52 . S:$E(D)="V" Y=Y_" "_$S(P="+":"AFTER",1:"BEFORE")_" NEXT VISIT" 53 I $L(T) S Y=Y_"@"_$$TIME(T) 54 Q Y 55 ; 56 FTDHELP ; -- Displays ??-help for R-type prompts 57 G R^ORCDLGH 58 Q 59 ; 60 FTDCOMP(X1,X2,OPER) ; -- Compares free text dates from prompts X1 & X2 61 ; Returns 1 or 0, IF $$VAL(X1)<OPER>$$VAL(X2) is true 62 N X,Y,Y1,Y2,Z,%DT 63 S X=$$VAL(X1),%DT="TX" D ^%DT S Y1=Y ; Y'>0 ?? 64 S X=$$VAL(X2),%DT="TX" D ^%DT S Y2=Y ; Y'>0 ?? 65 S Z="I "_Y1_OPER_Y2 X Z 66 Q $T 67 ; 68 TIME(X) ; -- Returns 00:00 PM formatted time 69 N Y,Z,%DT 70 I X?1U,"BNE"[X Q $S(X="B":"BREAKFAST",X="N":"NOON",X="E":"EVENING",1:"") 71 I "NOON"[X Q X 72 I "MIDNIGHT"[X Q "MIDNIGHT" 73 S X="T@"_X,%DT="TX" D ^%DT I Y'>0 Q "" 74 S Z=$$FMTE^XLFDT(Y,"2P"),Z=$P(Z," ",2)_$$UP^XLFSTR($P(Z," ",3)) 75 Q Z 76 ; 77 VAL(TEXT,INST) ; -- Returns internal form of TEXT's current value 78 N I,X S X="" S:'$G(INST) INST=1 79 I '$D(ORDIALOG("B",TEXT)) S I=$O(ORDIALOG("B",TEXT)) Q:$E(I,1,$L(TEXT))'=TEXT X S TEXT=I ; partial match 80 S X=$P($G(ORDIALOG("B",TEXT)),U,2) ; ptr 81 Q $G(ORDIALOG(X,INST)) 82 ; 83 ORDMSG(OI) ; -- Display order message for orderable OI 84 Q:'$O(^ORD(101.43,OI,8,0)) ; no order message 85 N I S I=0 W ! 86 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 W !,$G(^(I,0)) 87 W ! Q 88 ; 89 PTR(NAME) ; -- Returns pointer to Dialog file for prompt NAME 90 Q +$O(^ORD(101.41,"AB",$E(NAME,1,63),0)) 91 ; 92 NMSP(PKG) ; -- Returns package namespace from pointer 93 N Y S Y=$$GET1^DIQ(9.4,+PKG_",",1) 94 S:$E(Y,1,2)="PS" Y="PS" S:Y="GMRV" Y="OR" 95 Q Y 96 ; 97 GETQDLG(QIFN) ; -- define ORDIALOG(PROMPT) for quick order QIFN 98 S ORDIALOG=$$DEFDLG(QIFN) Q:'ORDIALOG 99 D GETDLG(ORDIALOG),GETORDER("^ORD(101.41,"_QIFN_",6)") 100 X:$D(^ORD(101.41,QIFN,3)) ^(3) ; entry action for quick order 101 Q 102 ; 103 DEFDLG(QDLG) ; -- Returns default dialog for QDLG 104 N DG,DLG,TOP S DG=+$P($G(^ORD(101.41,+QDLG,0)),U,5) 105 S DLG=+$P($G(^ORD(100.98,DG,0)),U,4) ; default dialog 106 I 'DLG S TOP=+$O(^ORD(100.98,"AD",DG,0)),DLG=+$P($G(^ORD(100.98,TOP,0)),U,4) 107 Q DLG 108 ; 109 GETDLG(IFN) ; -- define ORDIALOG(PROMPT) for dialog IFN 110 N SEQ,DA,ITEM,PTR,PROMPT,TEXT,INDEX,HELP,XHELP,SCREEN,ORD,INPUTXFM,LKP 111 S SEQ=0 K ^TMP("ORWORD",$J) 112 F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D 113 . S ITEM=$G(^ORD(101.41,IFN,10,DA,0)),INPUTXFM=$G(^(.1)),HELP=$G(^(1)),SCREEN=$G(^(4)),XHELP=$G(^(6)) 114 . S PTR=$P(ITEM,U,2),TEXT=$P(ITEM,U,4),INDEX=$P(ITEM,U,10) Q:'PTR 115 . S:'$L(TEXT) TEXT=$P(^ORD(101.41,PTR,0),U,2) K ORD 116 . S PROMPT=$G(^ORD(101.41,PTR,1)),ORD=DA_U_$P(PROMPT,U,3) 117 . S ORD(0)=$P(PROMPT,U)_$S($P(PROMPT,U)="S":"M",1:"")_U_$P(PROMPT,U,2)_$S($L(INPUTXFM):U_INPUTXFM,1:"") 118 . S ORD("A")=TEXT S:$L($P(ITEM,U,13)) ORD("TTL")=$P(ITEM,U,13) 119 . I $P(ITEM,U,7) S ORD("MAX")=$P(ITEM,U,12),ORD("MORE")=$P(ITEM,U,14) ; fields for multiples 120 . I $L(HELP) S LKP=$P(HELP,U,2),HELP=$P(HELP,U) S:$L(HELP) ORD("?")=HELP S:$L(LKP) ORD("LKP")=$S($L(LKP,";")>1:$TR(LKP,";","^"),1:U_LKP) 121 . S:$L(XHELP) ORD("??")=U_XHELP 122 . S:$L(INDEX) ORD("D")=INDEX 123 . S:$L(SCREEN) ORD("S")=SCREEN 124 . S ORDIALOG("B",$$UP^XLFSTR($P(TEXT,":")))=SEQ_U_PTR 125 . M ORDIALOG(PTR)=ORD 126 Q 127 ; 128 GETDLG1(IFN) ; -- basic ORDIALOG(PROMPT) for dialog IFN 129 N SEQ,DA,PROMPT,PTR,WINCTRL 130 K ^TMP("ORWORD",$J) S SEQ=0 131 F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D 132 . S PTR=$P($G(^ORD(101.41,IFN,10,DA,0)),U,2) Q:'PTR 133 . S WINCTRL=$P($G(^ORD(101.41,IFN,10,DA,"W")),U) 134 . S PROMPT=$G(^ORD(101.41,PTR,1)) Q:'$L(PROMPT) 135 . S ORDIALOG(PTR)=DA_U_$P(PROMPT,U,3)_U_WINCTRL 136 . S ORDIALOG(PTR,0)=$P(PROMPT,U,1,2) 137 Q 138 ; 139 GETORDER(ROOT,ARRAY) ; -- retrieve order values from RESPONSES in ARRAY() 140 N ORI,ID,PTR,INST,TYPE,DA,X,ORTXT S:'$L($G(ARRAY)) ARRAY="ORDIALOG" 141 I +ROOT=ROOT S ROOT="^OR(100,"_ROOT_",4.5)" ; assume Orders file IFN 142 S ORI=0 F S ORI=$O(@ROOT@(ORI)) Q:ORI'>0 S ID=$G(@ROOT@(ORI,0)) D 143 . S DA=$P(ID,U),PTR=$P(ID,U,2),INST=$P(ID,U,3) S:'INST INST=1 144 . S:'PTR PTR=$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) Q:'PTR 145 . Q:'$D(ORDIALOG(PTR)) S TYPE=$E($G(ORDIALOG(PTR,0))) Q:'$L(TYPE) 146 . I TYPE'="W" S X=$G(@ROOT@(ORI,1)) S:$L(X) @ARRAY@(PTR,INST)=X Q 147 . D RESTXT ;resolve objects 148 . I ARRAY="ORDIALOG" M ^TMP("ORWORD",$J,PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)="^TMP(""ORWORD"","_$J_","_PTR_","_INST_")" 149 . I ARRAY'="ORDIALOG" M @ARRAY@(PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)=$NA(@ARRAY@(PTR,INST)) 150 . K @ORTXT 151 Q 152 ; 153 RESTXT ; -- resolve objects in text [from GETORDER+8] 154 I $$BROKER^XWBLIB!($G(ORTYPE)="Z") M ^TMP("ORX",$J)=@ROOT@(ORI,2) S ORTXT=$NA(^TMP("ORX",$J)) Q ;return text unresolved 155 N ARRAY,PTR,INST 156 D BLRPLT^TIUSRVD(.ORTXT,,+$G(ORVP),,$NA(@ROOT@(ORI,2))) 157 Q 158 ; 159 DUP(PROMPT,CURRENT) ; -- Compare CURRENT instance of PROMPT for duplicates 160 N X,Y,I 161 S X=ORDIALOG(PROMPT,CURRENT),Y=0 162 S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 I I'=CURRENT,$P(ORDIALOG(PROMPT,I),U)=$P(ORDIALOG(PROMPT,CURRENT),U) S Y=1 Q 163 Q Y 164 ; 165 LIST ; -- Show contents of ORDIALOG(PROMPT,"LIST") 166 N NUM S NUM=$G(ORDIALOG(PROMPT,"LIST")) Q:'NUM 167 W !,"Choose from"_$S('$P(NUM,U,2):" (or enter another):",1:":") 168 LIST1 N I,DONE,CNT S (I,CNT,DONE)=0 169 F S I=$O(ORDIALOG(PROMPT,"LIST",I)) Q:I'>0 D Q:DONE 170 . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE S DONE=1 Q 171 . W !,$J(I,6)_" "_$P(ORDIALOG(PROMPT,"LIST",I),U,2) 172 Q 173 ; 174 SETLIST ; -- Show allowable set of codes 175 W !,"Choose from:" 176 SETLST1 N I,X F I=1:1:$L(DOMAIN,";") S X=$P(DOMAIN,";",I) I $L(X) D 177 . W !,?5,$P(X,":"),?15,$P(X,":",2) 178 Q 179 ; 180 MORE() ; -- show more? 181 N X,Y,DIR 182 S DIR(0)="EA",DIR("A")=" press <return> to continue or ^ to exit ..." 183 D ^DIR 184 Q +Y 185 ; 186 FIRST(P,I) ; -- Returns 1 or 0, if current instance I is first of multiple 187 Q '$O(ORDIALOG(P,I),-1) 188 ; 189 RECALL(P,I) ; -- Returns first value for prompt P, instance I 190 N Y S:'$G(I) I=1 S Y=$G(^TMP("ORECALL",$J,+ORDIALOG,P,I)) 191 Q Y 1 ORCD ; SLC/MKB - Order Dialog utilities ;9/21/2005 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,38,68,94,161,141,195,215**;Dec 17,1997 3 INPT() ; -- Return 1 or 0, if patient/order sheet = inpatient 4 N Y S Y=$S($G(ORWARD):1,$G(^DPT(+ORVP,.105)):1,1:0) 5 I $G(OREVENT) D ;override if delayed order 6 . N X,X0 S X=$$EVT^OREVNTX(+OREVENT),X0=$G(^ORD(100.5,+X,0)) 7 . I $P(X0,U,12) S X0=$G(^ORD(100.5,$P(X0,U,12),0)) ;use parent 8 . S X=$P(X0,U,2) Q:X="M" Q:X="O" ;M/O keep current inpt status 9 . S Y=$S(X="A":1,X="T":1,1:0) 10 . I X="D",$P(X0,U,7)=41 S Y=1 ;From ASIH = Inpt 11 . I X="T",$P(X0,U,7),$P(X0,U,7)<4 S Y=0 ;pass = Outpt 12 Q Y 13 ; 14 EXT(P,I,F) ; -- Returns external value of ORDIALOG(Prompt,Instance) 15 N TYPE,PARAM,FNUM,IENS,X,Y,J,Z 16 S TYPE=$E($G(ORDIALOG(P,0))),PARAM=$P($G(ORDIALOG(P,0)),U,2) 17 S X=$G(ORDIALOG(P,I)) I X="" Q "" 18 I "FNW"[TYPE Q X 19 I TYPE="Y" Q $S(X:"YES",X=0:"NO",1:"") 20 I TYPE="D" S:'$L($G(F)) F=1 Q $$FMTE^XLFDT(X,F) 21 I TYPE="R" Q $$FTDATE(X,$G(F)) ; DAY@TIME 22 I TYPE="P" D Q Y 23 . S PARAM=$P(PARAM,":"),FNUM=$S(PARAM:+PARAM,1:+$P(@(U_PARAM_"0)"),U,2)) 24 . S IENS=+X_",",J=$L(PARAM,",") I J>2 F S J=J-2 Q:J'>0 S Z=$P(PARAM,",",J),IENS=IENS_$S(Z:Z,1:+$P(Z,"(",2))_"," 25 . S:'+$G(F) F=.01 S Y=$$GET1^DIQ(FNUM,IENS,+F) 26 . I Y="",F'=.01 S Y=$$GET1^DIQ(FNUM,IENS,.01) 27 I TYPE="S" F J=1:1:$L(PARAM,";") S Z=$P(PARAM,";",J) I $P(Z,":")=X S Y=$S(+$G(F):X,1:$P(Z,":",2)) Q 28 Q $G(Y) 29 ; 30 FTDATE(X,F) ; -- Returns free text form of date (i.e. TODAY) 31 N D,T,P,Y I X="" Q "" 32 S X=$$UP^XLFSTR(X),D=$P(X,"@"),T=$P(X,"@",2) ; D=date,T=time parts 33 I "NOW"[X Q "NOW" 34 I "NOON"[X Q "NOON" 35 I $E("MIDNIGHT",1,$L(X))=X Q "MIDNIGHT" 36 I (X="AM")!(X="NEXT") Q X_" Lab collection" 37 I (X="NEXTA")!(X="CLOSEST") Q $S(X="NEXTA":"NEXT",1:X)_" administration time" 38 I $E(D)'="T",$E(D)'="V",($E(D)'="N"!($E(D,1,3)="NOV")) D Q $$FMTE^XLFDT(X,F) 39 . N %DT S %DT="TX" D ^%DT S:Y>0 X=Y S:'$G(F) F=1 40 S P=$S(D["+":"+",D["-":"-",1:"") 41 I P="" S Y=$S($E(D)="T":"TODAY",$E(D)="V":"NEXT VISIT",1:"NOW") 42 FTD1 E D 43 . N OFFSET,NUM,UNIT 44 . S OFFSET=$P(D,P,2),NUM=+OFFSET,UNIT=$E($P(OFFSET,NUM,2)) ; +/-#D 45 . I $E(D)="T",NUM=1,UNIT=""!(UNIT="D") S Y=$S(P="+":"TOMORROW",1:"YESTERDAY") Q 46 . S Y=NUM_" "_$S(UNIT="'":"MINUTE",UNIT="H":"HOUR",UNIT="W":"WEEK",UNIT="M":"MONTH",1:"DAY") 47 . S:NUM>1 Y=Y_"S" ; plural 48 . S:$E(D)="N" Y=Y_" "_$S(P="+":"FROM NOW",1:"AGO") 49 . S:$E(D)="T" Y=Y_" "_$S(P="+":"FROM TODAY",1:"AGO") 50 . S:$E(D)="V" Y=Y_" "_$S(P="+":"AFTER",1:"BEFORE")_" NEXT VISIT" 51 I $L(T) S Y=Y_"@"_$$TIME(T) 52 Q Y 53 ; 54 FTDHELP ; -- Displays ??-help for R-type prompts 55 G R^ORCDLGH 56 Q 57 ; 58 FTDCOMP(X1,X2,OPER) ; -- Compares free text dates from prompts X1 & X2 59 ; Returns 1 or 0, IF $$VAL(X1)<OPER>$$VAL(X2) is true 60 N X,Y,Y1,Y2,Z,%DT 61 S X=$$VAL(X1),%DT="TX" D ^%DT S Y1=Y ; Y'>0 ?? 62 S X=$$VAL(X2),%DT="TX" D ^%DT S Y2=Y ; Y'>0 ?? 63 S Z="I "_Y1_OPER_Y2 X Z 64 Q $T 65 ; 66 TIME(X) ; -- Returns 00:00 PM formatted time 67 N Y,Z,%DT 68 I "NOON"[X Q X 69 I "MIDNIGHT"[X Q "MIDNIGHT" 70 I X?1U,"BNE"[X Q $S(X="B":"BREAKFAST",X="N":"NOON",X="E":"EVENING",1:"") 71 S X="T@"_X,%DT="TX" D ^%DT I Y'>0 Q "" 72 S Z=$$FMTE^XLFDT(Y,"2P"),Z=$P(Z," ",2)_$$UP^XLFSTR($P(Z," ",3)) 73 Q Z 74 ; 75 VAL(TEXT,INST) ; -- Returns internal form of TEXT's current value 76 N I,X S X="" S:'$G(INST) INST=1 77 I '$D(ORDIALOG("B",TEXT)) S I=$O(ORDIALOG("B",TEXT)) Q:$E(I,1,$L(TEXT))'=TEXT X S TEXT=I ; partial match 78 S X=$P($G(ORDIALOG("B",TEXT)),U,2) ; ptr 79 Q $G(ORDIALOG(X,INST)) 80 ; 81 ORDMSG(OI) ; -- Display order message for orderable OI 82 Q:'$O(^ORD(101.43,OI,8,0)) ; no order message 83 N I S I=0 W ! 84 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 W !,$G(^(I,0)) 85 W ! Q 86 ; 87 PTR(NAME) ; -- Returns pointer to Dialog file for prompt NAME 88 Q +$O(^ORD(101.41,"AB",$E(NAME,1,63),0)) 89 ; 90 NMSP(PKG) ; -- Returns package namespace from pointer 91 N Y S Y=$$GET1^DIQ(9.4,+PKG_",",1) 92 S:$E(Y,1,2)="PS" Y="PS" S:Y="GMRV" Y="OR" 93 Q Y 94 ; 95 GETQDLG(QIFN) ; -- define ORDIALOG(PROMPT) for quick order QIFN 96 S ORDIALOG=$$DEFDLG(QIFN) Q:'ORDIALOG 97 D GETDLG(ORDIALOG),GETORDER("^ORD(101.41,"_QIFN_",6)") 98 X:$D(^ORD(101.41,QIFN,3)) ^(3) ; entry action for quick order 99 Q 100 ; 101 DEFDLG(QDLG) ; -- Returns default dialog for QDLG 102 N DG,DLG,TOP S DG=+$P($G(^ORD(101.41,+QDLG,0)),U,5) 103 S DLG=+$P($G(^ORD(100.98,DG,0)),U,4) ; default dialog 104 I 'DLG S TOP=+$O(^ORD(100.98,"AD",DG,0)),DLG=+$P($G(^ORD(100.98,TOP,0)),U,4) 105 Q DLG 106 ; 107 GETDLG(IFN) ; -- define ORDIALOG(PROMPT) for dialog IFN 108 N SEQ,DA,ITEM,PTR,PROMPT,TEXT,INDEX,HELP,XHELP,SCREEN,ORD,INPUTXFM,LKP 109 S SEQ=0 K ^TMP("ORWORD",$J) 110 F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D 111 . S ITEM=$G(^ORD(101.41,IFN,10,DA,0)),INPUTXFM=$G(^(.1)),HELP=$G(^(1)),SCREEN=$G(^(4)),XHELP=$G(^(6)) 112 . S PTR=$P(ITEM,U,2),TEXT=$P(ITEM,U,4),INDEX=$P(ITEM,U,10) Q:'PTR 113 . S:'$L(TEXT) TEXT=$P(^ORD(101.41,PTR,0),U,2) K ORD 114 . S PROMPT=$G(^ORD(101.41,PTR,1)),ORD=DA_U_$P(PROMPT,U,3) 115 . S ORD(0)=$P(PROMPT,U)_$S($P(PROMPT,U)="S":"M",1:"")_U_$P(PROMPT,U,2)_$S($L(INPUTXFM):U_INPUTXFM,1:"") 116 . S ORD("A")=TEXT S:$L($P(ITEM,U,13)) ORD("TTL")=$P(ITEM,U,13) 117 . I $P(ITEM,U,7) S ORD("MAX")=$P(ITEM,U,12),ORD("MORE")=$P(ITEM,U,14) ; fields for multiples 118 . I $L(HELP) S LKP=$P(HELP,U,2),HELP=$P(HELP,U) S:$L(HELP) ORD("?")=HELP S:$L(LKP) ORD("LKP")=$S($L(LKP,";")>1:$TR(LKP,";","^"),1:U_LKP) 119 . S:$L(XHELP) ORD("??")=U_XHELP 120 . S:$L(INDEX) ORD("D")=INDEX 121 . S:$L(SCREEN) ORD("S")=SCREEN 122 . S ORDIALOG("B",$$UP^XLFSTR($P(TEXT,":")))=SEQ_U_PTR 123 . M ORDIALOG(PTR)=ORD 124 Q 125 ; 126 GETDLG1(IFN) ; -- basic ORDIALOG(PROMPT) for dialog IFN 127 N SEQ,DA,PROMPT,PTR,WINCTRL 128 K ^TMP("ORWORD",$J) S SEQ=0 129 F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D 130 . S PTR=$P($G(^ORD(101.41,IFN,10,DA,0)),U,2) Q:'PTR 131 . S WINCTRL=$P($G(^ORD(101.41,IFN,10,DA,"W")),U) 132 . S PROMPT=$G(^ORD(101.41,PTR,1)) Q:'$L(PROMPT) 133 . S ORDIALOG(PTR)=DA_U_$P(PROMPT,U,3)_U_WINCTRL 134 . S ORDIALOG(PTR,0)=$P(PROMPT,U,1,2) 135 Q 136 ; 137 GETORDER(ROOT,ARRAY) ; -- retrieve order values from RESPONSES in ARRAY() 138 N ORI,ID,PTR,INST,TYPE,DA,X,ORTXT S:'$L($G(ARRAY)) ARRAY="ORDIALOG" 139 I +ROOT=ROOT S ROOT="^OR(100,"_ROOT_",4.5)" ; assume Orders file IFN 140 S ORI=0 F S ORI=$O(@ROOT@(ORI)) Q:ORI'>0 S ID=$G(@ROOT@(ORI,0)) D 141 . S DA=$P(ID,U),PTR=$P(ID,U,2),INST=$P(ID,U,3) S:'INST INST=1 142 . S:'PTR PTR=$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) Q:'PTR 143 . Q:'$D(ORDIALOG(PTR)) S TYPE=$E($G(ORDIALOG(PTR,0))) Q:'$L(TYPE) 144 . I TYPE'="W" S X=$G(@ROOT@(ORI,1)) S:$L(X) @ARRAY@(PTR,INST)=X Q 145 . D RESTXT ;resolve objects 146 . I ARRAY="ORDIALOG" M ^TMP("ORWORD",$J,PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)="^TMP(""ORWORD"","_$J_","_PTR_","_INST_")" 147 . I ARRAY'="ORDIALOG" M @ARRAY@(PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)=$NA(@ARRAY@(PTR,INST)) 148 . K @ORTXT 149 Q 150 ; 151 RESTXT ; -- resolve objects in text [from GETORDER+8] 152 I $$BROKER^XWBLIB!($G(ORTYPE)="Z") M ^TMP("ORX",$J)=@ROOT@(ORI,2) S ORTXT=$NA(^TMP("ORX",$J)) Q ;return text unresolved 153 N ARRAY,PTR,INST 154 D BLRPLT^TIUSRVD(.ORTXT,,+$G(ORVP),,$NA(@ROOT@(ORI,2))) 155 Q 156 ; 157 DUP(PROMPT,CURRENT) ; -- Compare CURRENT instance of PROMPT for duplicates 158 N X,Y,I 159 S X=ORDIALOG(PROMPT,CURRENT),Y=0 160 S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 I I'=CURRENT,$P(ORDIALOG(PROMPT,I),U)=$P(ORDIALOG(PROMPT,CURRENT),U) S Y=1 Q 161 Q Y 162 ; 163 LIST ; -- Show contents of ORDIALOG(PROMPT,"LIST") 164 N NUM S NUM=$G(ORDIALOG(PROMPT,"LIST")) Q:'NUM 165 W !,"Choose from"_$S('$P(NUM,U,2):" (or enter another):",1:":") 166 LIST1 N I,DONE,CNT S (I,CNT,DONE)=0 167 F S I=$O(ORDIALOG(PROMPT,"LIST",I)) Q:I'>0 D Q:DONE 168 . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE S DONE=1 Q 169 . W !,$J(I,6)_" "_$P(ORDIALOG(PROMPT,"LIST",I),U,2) 170 Q 171 ; 172 SETLIST ; -- Show allowable set of codes 173 W !,"Choose from:" 174 SETLST1 N I,X F I=1:1:$L(DOMAIN,";") S X=$P(DOMAIN,";",I) I $L(X) D 175 . W !,?5,$P(X,":"),?15,$P(X,":",2) 176 Q 177 ; 178 MORE() ; -- show more? 179 N X,Y,DIR 180 S DIR(0)="EA",DIR("A")=" press <return> to continue or ^ to exit ..." 181 D ^DIR 182 Q +Y 183 ; 184 FIRST(P,I) ; -- Returns 1 or 0, if current instance I is first of multiple 185 Q '$O(ORDIALOG(P,I),-1) 186 ; 187 RECALL(P,I) ; -- Returns first value for prompt P, instance I 188 N Y S:'$G(I) I=1 S Y=$G(^TMP("ORECALL",$J,+ORDIALOG,P,I)) 189 Q Y -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDFH1.m
r613 r623 1 ORCDFH1 ;SLC/MKB,DKM - Utility functions for FH dialogs cont ;8/24/01 10:22 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**73,95,243**;Dec 17, 1997;Build 242 3 ; 4 RECENT ; -- get 5 most recent diet orders 5 N ORDT,ORIFN,ORIT,ORTXT,ORCURR,I,X,CNT,INDT S ORDT=$$NOW^XLFDT,CNT=0 6 F S ORDT=$O(^OR(100,"AW",ORVP,ORDG,ORDT),-1) Q:ORDT'>0 S ORIFN=0 D Q:CNT'<5 7 . F S ORIFN=$O(^OR(100,"AW",ORVP,ORDG,ORDT,ORIFN)) Q:ORIFN'>0 D Q:CNT'<5 8 .. S (ORIT,ORTXT)="" K ORCURR 9 .. S:$P($G(^OR(100,+ORIFN,3)),U,3)=6 ORCURR=1 Q:'$O(^(.1,0)) 10 .. S I=0 F S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0 S X=+$G(^(I,0)) I X D ;**95 11 ... S INDT=$G(^ORD(101.43,X,.1)) S ORIT=ORIT_$S($L(ORIT):";",1:"")_X,ORTXT=ORTXT_$S($L(ORTXT):", ",1:"")_$P($G(^ORD(101.43,X,0)),U)_$S(INDT&(INDT<$$NOW^XLFDT):" (*INACTIVE*)",1:"") ;**95 12 .. Q:'ORIT Q:'$L(ORTXT) Q:ORTXT="NPO" 13 .. S ORDIALOG(PROMPT,"LIST","D",ORIT)=ORIFN ;link oi string to order# 14 .. Q:$G(ORCURR) Q:+$G(ORDIALOG(PROMPT,"LIST","B",ORTXT)) 15 .. S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=ORIT_U_ORTXT 16 .. S ORDIALOG(PROMPT,"LIST","B",ORTXT)=ORIT 17 S ORDIALOG(PROMPT,"LIST")=CNT,ORDIALOG(PROMPT,"TOT")=0 18 Q 19 ; 20 PTR(X) ; -- Return ptr to Order Dialog file #101.41 for prompt X 21 Q +$O(^ORD(101.41,"B","OR GTX "_X,0)) 22 ; 23 EXP ; -- Expand old order into instances 24 N X,I,P,D S X=$G(ORDIALOG(PROMPT,ORI)) Q:'$L(X) Q:X'[";" 25 S ORDIALOG(PROMPT,ORI)=+X,I=ORI ;1st mod only 26 F P=2:1:$L(X,";") S D=$P(X,";",P),I=I+1,ORDIALOG(PROMPT,I)=D,ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1 27 ;S:FIRST MAX=$L(X,";") 28 Q 29 ; 30 VALID() ; -- Returns 1 or 0, if selected diet modification is valid 31 N Y,NUM,I,TOTAL,OI 32 S OI=$G(ORDIALOG(PROMPT,ORI)) I OI[";" D Q Y 33 .S Y=1 D EXP 34 .I $$INACTIVE S Y=0 S ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-($L(OI,";")-1) F I=0:1:($L(OI,";")-1) K ORDIALOG(PROMPT,(I+ORI)) ;**95 35 S Y=1,TOTAL=+$G(ORDIALOG(PROMPT,"TOT")),ORDIALOG(PROMPT,"MAX")=5,MAX=5 36 I $$INACTIVE Q 0 ;**95 37 ;S:FIRST MAX=$S($G(ORDIALOG(PROMPT,"LIST","D",OI)):1,1:5) 38 S OI=$P($G(^ORD(101.43,+OI,0)),U) 39 I (OI="REGULAR")!(OI="NPO") D Q Y 40 . I '$D(ORESET),TOTAL=0 S ORDIALOG(PROMPT,"MAX")=1,MAX=1 Q ; add first 41 . I $G(ORESET),TOTAL'>1 S ORDIALOG(PROMPT,"MAX")=1,MAX=1 Q ; edit first 42 . S Y=0 W $C(7),!,OI_" may not be ordered with other diets!" 43 ;I $$DUP^ORCD(PROMPT,ORI) W $C(7),"This diet has already been selected!" Q 0 ;may delete after testing patch 95 44 S NUM=$P($G(^ORD(101.43,+ORDIALOG(PROMPT,ORI),"FH")),U,2) ; precedence # 45 S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 D Q:Y'>0 46 . Q:I=ORI Q:$P($G(^ORD(101.43,+ORDIALOG(PROMPT,I),"FH")),U,2)'=NUM ;ok 47 . S Y=0 W $C(7),!,"This diet is not orderable with those already selected!",! 48 Q Y 49 ; 50 PREV ; -- Ck if previous diet being reordered 51 N I,OI,IFN S OI="",I=0 52 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 S OI=OI_$S(OI:";",1:"")_ORDIALOG(PROMPT,I) 53 S IFN=$S(OI:$G(ORDIALOG(PROMPT,"LIST","D",OI)),1:"") 54 S:IFN ORDIALOG("PREV")=IFN K:'IFN ORDIALOG("PREV") 55 Q 56 ; 57 CNV ; -- Convert meal abbreviation to time in X [Input Xform] 58 ; Expects X,PROMPT [also called from Entry Action, DO^ORWDXM2] 59 N A1 S X=$$UP^XLFSTR(X),A1=$P(X,"@",2) 60 I A1?1U,"BNE"[A1 D 61 . I $G(ORTYPE)="Z" S DATATYPE="",Y=X Q ;editor - ok 62 . N TIMES S TIMES=$S($D(ORPARAM(2)):$P(ORPARAM(2),U,7,9),1:"6:00A^12:00P^6:00P") 63 . S A1=$S(A1="B":$P(TIMES,U),A1="N":$P(TIMES,U,2),A1="E":$P(TIMES,U,3),1:A1) 64 . S $P(X,"@",2)=A1 65 Q 66 ; 67 LKUP ; -- special lookup routine for diet modifications 68 G:'$G(ORDIALOG(PROMPT,"LIST")) LKQ N OROOT,Z 69 S:X=" " X=$$SPACE^ORCDLG2(DOMAIN) S OROOT=$NA(ORDIALOG(PROMPT,"LIST")) 70 S Y=$$FIND^ORCDLG2(OROOT,X) 71 I Y Q:X?1N Q:'$$MORE(X,Y) S Z=$$OK Q:Z I Z="^" S Y="^" Q 72 LKQ D DIC^ORCDLG2 73 Q 74 ; 75 MORE(XX,YY) ; -- Returns 1 or 0, if more matches exist 76 Q:$P(YY,U)[";" 1 ;multiple mods 77 N CNT,XP,NOW S CNT=0,XP=XX,NOW=+$$NOW^XLFDT 78 F S XP=$O(^ORD(101.43,"S.DO",XP)) Q:$E(XP,1,$L(XX))'=XX D Q:CNT 79 . N IFN S IFN=$O(^ORD(101.43,"S.DO",XP,0)) Q:IFN=+YY ;same mod 80 . I $G(^ORD(101.43,IFN,.1)),$G(^(.1))'>NOW Q ;inactive 81 . S CNT=CNT+1 82 Q CNT 83 ; 84 OK() ; -- Verify multiple diet mod selection 85 N X,Y,DIR S DIR(0)="YA",DIR("A")=" ... OK? ",DIR("B")="Yes" 86 S DIR("?")="Enter YES if you wish to re-order this entire diet, or NO to search for another single diet modification" 87 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="^" 88 Q Y 89 INACTIVE() ;Check for inactive/duplicate diets in single or multiple modifications ;**95 90 N I,Y 91 S Y=0 92 S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:'+I D 93 .I $G(^ORD(101.43,ORDIALOG(PROMPT,I),.1)),^(.1)<$$NOW^XLFDT S Y=1 W !,"The ",$P(^ORD(101.43,ORDIALOG(PROMPT,I),0),U)," diet is INACTIVE." Q ;Quit if inactive diet found in order 94 F I=0:1:($L(OI,";")-1) I $$DUP^ORCD(PROMPT,(I+ORI)) S Y=1 W !,"The ",$P(^ORD(101.43,ORDIALOG(PROMPT,(I+ORI)),0),U)," diet has already been selected." ;check for duplicate orders 95 Q Y 1 ORCDFH1 ;SLC/MKB,DKM - Utility functions for FH dialogs cont ;8/24/01 10:22 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**73,95**;Dec 17, 1997 3 ; 4 RECENT ; -- get 5 most recent diet orders 5 N ORDT,ORIFN,ORIT,ORTXT,ORCURR,I,X,CNT,INDT S ORDT=$$NOW^XLFDT,CNT=0 6 F S ORDT=$O(^OR(100,"AW",ORVP,ORDG,ORDT),-1) Q:ORDT'>0 S ORIFN=0 D Q:CNT'<5 7 . F S ORIFN=$O(^OR(100,"AW",ORVP,ORDG,ORDT,ORIFN)) Q:ORIFN'>0 D Q:CNT'<5 8 .. S (ORIT,ORTXT)="" K ORCURR 9 .. S:$P($G(^OR(100,+ORIFN,3)),U,3)=6 ORCURR=1 Q:'$O(^(.1,0)) 10 .. S I=0 F S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0 S X=+$G(^(I,0)) I X D ;**95 11 ... S INDT=$G(^ORD(101.43,X,.1)) S ORIT=ORIT_$S($L(ORIT):";",1:"")_X,ORTXT=ORTXT_$S($L(ORTXT):", ",1:"")_$P($G(^ORD(101.43,X,0)),U)_$S(INDT&(INDT<$$NOW^XLFDT):" (*INACTIVE*)",1:"") ;**95 12 .. Q:'ORIT Q:'$L(ORTXT) Q:ORTXT="NPO" 13 .. S ORDIALOG(PROMPT,"LIST","D",ORIT)=ORIFN ;link oi string to order# 14 .. Q:$G(ORCURR) Q:+$G(ORDIALOG(PROMPT,"LIST","B",ORTXT)) 15 .. S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=ORIT_U_ORTXT 16 .. S ORDIALOG(PROMPT,"LIST","B",ORTXT)=ORIT 17 S ORDIALOG(PROMPT,"LIST")=CNT,ORDIALOG(PROMPT,"TOT")=0 18 Q 19 ; 20 PTR(X) ; -- Return ptr to Order Dialog file #101.41 for prompt X 21 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) 22 ; 23 EXP ; -- Expand old order into instances 24 N X,I,P,D S X=$G(ORDIALOG(PROMPT,ORI)) Q:'$L(X) Q:X'[";" 25 S ORDIALOG(PROMPT,ORI)=+X,I=ORI ;1st mod only 26 F P=2:1:$L(X,";") S D=$P(X,";",P),I=I+1,ORDIALOG(PROMPT,I)=D,ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1 27 ;S:FIRST MAX=$L(X,";") 28 Q 29 ; 30 VALID() ; -- Returns 1 or 0, if selected diet modification is valid 31 N Y,NUM,I,TOTAL,OI 32 S OI=$G(ORDIALOG(PROMPT,ORI)) I OI[";" D Q Y 33 .S Y=1 D EXP 34 .I $$INACTIVE S Y=0 S ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-($L(OI,";")-1) F I=0:1:($L(OI,";")-1) K ORDIALOG(PROMPT,(I+ORI)) ;**95 35 S Y=1,TOTAL=+$G(ORDIALOG(PROMPT,"TOT")),ORDIALOG(PROMPT,"MAX")=5,MAX=5 36 I $$INACTIVE Q 0 ;**95 37 ;S:FIRST MAX=$S($G(ORDIALOG(PROMPT,"LIST","D",OI)):1,1:5) 38 S OI=$P($G(^ORD(101.43,+OI,0)),U) 39 I (OI="REGULAR")!(OI="NPO") D Q Y 40 . I '$D(ORESET),TOTAL=0 S ORDIALOG(PROMPT,"MAX")=1,MAX=1 Q ; add first 41 . I $G(ORESET),TOTAL'>1 S ORDIALOG(PROMPT,"MAX")=1,MAX=1 Q ; edit first 42 . S Y=0 W $C(7),!,OI_" may not be ordered with other diets!" 43 ;I $$DUP^ORCD(PROMPT,ORI) W $C(7),"This diet has already been selected!" Q 0 ;may delete after testing patch 95 44 S NUM=$P($G(^ORD(101.43,+ORDIALOG(PROMPT,ORI),"FH")),U,2) ; precedence # 45 S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 D Q:Y'>0 46 . Q:I=ORI Q:$P($G(^ORD(101.43,+ORDIALOG(PROMPT,I),"FH")),U,2)'=NUM ;ok 47 . S Y=0 W $C(7),!,"This diet is not orderable with those already selected!",! 48 Q Y 49 ; 50 PREV ; -- Ck if previous diet being reordered 51 N I,OI,IFN S OI="",I=0 52 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 S OI=OI_$S(OI:";",1:"")_ORDIALOG(PROMPT,I) 53 S IFN=$S(OI:$G(ORDIALOG(PROMPT,"LIST","D",OI)),1:"") 54 S:IFN ORDIALOG("PREV")=IFN K:'IFN ORDIALOG("PREV") 55 Q 56 ; 57 CNV ; -- Convert meal abbreviation to time [Input Xform] 58 N A1 S A1=$E($P(X,"@",2)) Q:'$L(A1) ;not in form T@meal 59 S A1=$S(A1="M":"11:59P",'$D(ORPARAM(2)):A1,A1="B":$P(ORPARAM(2),U,7),A1="N":$P(ORPARAM(2),U,8),A1="E":$P(ORPARAM(2),U,9),1:A1),$P(X,"@",2)=A1 60 I $G(ORTYPE)="Z",A1?1U,"BNE"[A1 S DATATYPE="",Y=X ;editor 61 Q 62 ; 63 LKUP ; -- special lookup routine for diet modifications 64 G:'$G(ORDIALOG(PROMPT,"LIST")) LKQ N OROOT,Z 65 S:X=" " X=$$SPACE^ORCDLG2(DOMAIN) S OROOT=$NA(ORDIALOG(PROMPT,"LIST")) 66 S Y=$$FIND^ORCDLG2(OROOT,X) 67 I Y Q:X?1N Q:'$$MORE(X,Y) S Z=$$OK Q:Z I Z="^" S Y="^" Q 68 LKQ D DIC^ORCDLG2 69 Q 70 ; 71 MORE(XX,YY) ; -- Returns 1 or 0, if more matches exist 72 Q:$P(YY,U)[";" 1 ;multiple mods 73 N CNT,XP,NOW S CNT=0,XP=XX,NOW=+$$NOW^XLFDT 74 F S XP=$O(^ORD(101.43,"S.DO",XP)) Q:$E(XP,1,$L(XX))'=XX D Q:CNT 75 . N IFN S IFN=$O(^ORD(101.43,"S.DO",XP,0)) Q:IFN=+YY ;same mod 76 . I $G(^ORD(101.43,IFN,.1)),$G(^(.1))'>NOW Q ;inactive 77 . S CNT=CNT+1 78 Q CNT 79 ; 80 OK() ; -- Verify multiple diet mod selection 81 N X,Y,DIR S DIR(0)="YA",DIR("A")=" ... OK? ",DIR("B")="Yes" 82 S DIR("?")="Enter YES if you wish to re-order this entire diet, or NO to search for another single diet modification" 83 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="^" 84 Q Y 85 INACTIVE() ;Check for inactive/duplicate diets in single or multiple modifications ;**95 86 N I,Y 87 S Y=0 88 S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:'+I D 89 .I $G(^ORD(101.43,ORDIALOG(PROMPT,I),.1)),^(.1)<$$NOW^XLFDT S Y=1 W !,"The ",$P(^ORD(101.43,ORDIALOG(PROMPT,I),0),U)," diet is INACTIVE." Q ;Quit if inactive diet found in order 90 F I=0:1:($L(OI,";")-1) I $$DUP^ORCD(PROMPT,(I+ORI)) S Y=1 W !,"The ",$P(^ORD(101.43,ORDIALOG(PROMPT,(I+ORI)),0),U)," diet has already been selected." ;check for duplicate orders 91 Q Y -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG1.m
r613 r623 1 ORCDLG1 ; SLC/MKB - Order dialogs cont ;12/15/2006 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**60,71,95,110,243**;Dec 17, 1997;Build 242 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 EN(ITM,INST) ; -- ask each ITM prompt where 5 ; ORDIALOG(PROMPT,#) = internal form of each response 6 ; 7 N ITEM,COND,MULT,REQD,EDITONLY,DATATYPE,DOMAIN,DIR,Y,ACTION,PROMPT,ORX,VALIDEF 8 S ITEM=$G(^ORD(101.41,+ORDIALOG,10,ITM,0)),COND=$G(^(3)) 9 S PROMPT=$P(ITEM,U,2) Q:'PROMPT S:'$G(INST) INST=1 10 S MULT=$P(ITEM,U,7),ACTION=$P(ITEM,U,9) 11 S REQD=$P(ITEM,U,6),EDITONLY=$P(ITEM,U,8) S:$G(ORTYPE)="Z" (REQD,EDITONLY)=0 12 I $D(^ORD(101.41,+ORDIALOG,10,ITM,9)) X ^(9) G:$G(ORQUIT) ENQ ;Entry 13 I $G(ORTYPE)="Q",$D(ORDIALOG(PROMPT,INST)),$E(ORDIALOG(PROMPT,0))'="W" S EDITONLY=1 14 I '$D(ORDIALOG(PROMPT,INST)) D ; get default value 15 . I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 M ^TMP("ORWORD",$J,PROMPT,INST)=^(8) S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" Q 16 . K Y X:$D(^ORD(101.41,+ORDIALOG,10,ITM,7)) ^(7) 17 . I $D(Y) S VALIDEF=$$VALID S:VALIDEF ORDIALOG(PROMPT,INST)=Y ;**95 18 . I $G(VALIDEF)=0 W !,"The DEFAULT value for the ",$G(ORDIALOG(PROMPT,"A"))," prompt is invalid." S EDITONLY=0 ;**95 19 . K VALIDEF ;**95 20 I $G(AUTO),'REQD!($E(ORDIALOG(PROMPT,0))="W"&$D(ORDIALOG(PROMPT,INST))) S EDITONLY=1 ;Auto-accept 21 EN0 I FIRST&EDITONLY D:$D(ORDIALOG(PROMPT,INST)) G ENQ ;ck child prompts 22 . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) N SEQ,DA,ITEM,PRMT,X,Y,VALIDEF ;**95 23 . S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D Q:$G(ORQUIT) 24 . . K VALIDEF ;110 25 . . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITEM,U,2) 26 . . Q:$D(ORDIALOG(PRMT,INST)) ; already has a value 27 . . K Y X:$D(^ORD(101.41,+ORDIALOG,10,DA,7)) ^(7) 28 . . I $D(Y) S VALIDEF=$$VALID ;**95 29 . . I $G(VALIDEF)!('$P(ITEM,U,6)) S:$G(VALIDEF) ORDIALOG(PRMT,INST)=Y Q ;**95 30 . . D EN(DA,INST) ; ask 31 I ($G(OREDIT)&(ACTION'["C"))!($G(ORENEW)&(ACTION'["R")) G ENQ ;ask? 32 I $G(OREWRITE),ACTION'["W",FIRST,'REQD!$D(ORDIALOG(PROMPT,INST)) G ENQ 33 I $L(COND) X COND G:'$T ENQ ; failed condition 34 M DIR=ORDIALOG(PROMPT) S DATATYPE=$E(DIR(0)),DOMAIN=$P(DIR(0),U,2) 35 I 'MULT D WP^ORCDLG2:DATATYPE="W",ONE(INST,REQD):DATATYPE'="W" G ENQ 36 EN1 ; -- loop for multiples 37 I '$O(ORDIALOG(PROMPT,0)) D G:$G(ORQUIT)!('$O(ORDIALOG(PROMPT,0)))!FIRST ENQ 38 M1 . D ADDMULT Q:$G(ORQUIT) 39 . Q:'REQD!$O(ORDIALOG(PROMPT,0)) I FIRST,$G(SEQ)=1 S ORQUIT=1 Q 40 . W $C(7),!!,$$REQUIRED,! G M1 41 F S ORX=$$SELECT Q:ORX="" S:ORX="^" ORQUIT=1 Q:$G(ORQUIT) D Q:$G(DIROUT) 42 . S DIR("A")=ORDIALOG(PROMPT,"A"),X=$S('REQD:0,$$ONLY(ORX):1,1:0) 43 . D ADDMULT:ORX="A",ONE(ORX,X):ORX Q:$G(DIROUT) K ORQUIT,DIR("B") 44 . I REQD,'$O(ORDIALOG(PROMPT,0)) W $C(7),!!,$$REQUIRED,! 45 ENQ X:$D(^ORD(101.41,+ORDIALOG,10,ITM,10)) ^(10) ; exit action 46 Q 47 ; 48 REQUIRED() ; -- Required response message 49 Q "A response is required! Enter '^' to quit." 50 ; 51 SELECT() ; -- select instance of multiple to edit 52 N DIR,X,Y,CNT,I,MAX,TOTAL,DONE 53 S MAX=+$G(ORDIALOG(PROMPT,"MAX")),TOTAL=+$G(ORDIALOG(PROMPT,"TOT")) 54 S DIR("A",1)=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A")) 55 S (I,CNT)=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 S CNT=CNT+1,CNT(CNT)=I,DIR("A",CNT+1)=$J(CNT,3)_": "_$$ITEM^ORCDLG(PROMPT,I) ; parent+children 56 I 'MAX!(MAX&(MAX>TOTAL)) S CNT=CNT+1,CNT(CNT)="A",DIR("A",CNT+1)=$J(CNT,3)_": <enter more>" 57 S DIR("A")="Select "_$S(CNT>1:"(1-"_CNT_")",1:1)_" or <return> to continue: " 58 S DIR(0)="NAO^1:"_CNT,DIR("?")="Select the instance you wish to change" 59 S1 D ^DIR I $D(DTOUT)!(Y="^") Q "^" 60 I Y?1"^".E D UJUMP Q:$G(ORQUIT)!($G(DONE)) "" G S1 61 I Y="" Q Y 62 Q CNT(Y) 63 ; 64 ONLY(I) ; -- I the only instance? 65 N J,Z S J=0,Z=1 66 F S J=$O(ORDIALOG(PROMPT,J)) Q:J'>0 I J'=I S Z=0 Q 67 Q Z 68 ; 69 ADDMULT ; -- add new instances of multiple 70 N DONE,LAST,INST,MAX,ANOTHER 71 S MAX=+$G(ORDIALOG(PROMPT,"MAX")) I MAX,MAX'>$G(ORDIALOG(PROMPT,"TOT")) W $C(7),!,"Only "_MAX_" items may be selected!",! Q 72 S ANOTHER=$G(ORDIALOG(PROMPT,"MORE")) S:'$L(ANOTHER) ANOTHER="Another " 73 S DIR("A")=$S($O(ORDIALOG(PROMPT,0)):ANOTHER,1:"")_ORDIALOG(PROMPT,"A") 74 F D Q:$G(ORQUIT)!($G(DONE)) I MAX Q:MAX'>$G(ORDIALOG(PROMPT,"TOT")) 75 . S INST=$O(ORDIALOG(PROMPT,"?"),-1)+1 76 . D ONE(INST,0) I '$D(ORDIALOG(PROMPT,INST)) S DONE=1 Q 77 . S ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1,DIR("A")=ANOTHER_ORDIALOG(PROMPT,"A") 78 Q 79 ; 80 ONE(ORI,REQD) ; -- ask single-valued prompt 81 N DONE,ORESET 82 S:$D(ORDIALOG(PROMPT,ORI)) DIR("B")=$$EXT^ORCD(PROMPT,ORI),ORESET=ORDIALOG(PROMPT,ORI) 83 F D Q:$G(DONE) I $G(ORQUIT) Q:FIRST Q:'REQD!$D(ORDIALOG(PROMPT,ORI)) S FIRST=$$DONE^ORCDLG2 Q:FIRST K ORQUIT 84 . D DIR^ORCDLG2 I $D(DTOUT)!$D(DIROUT)!(X=U) S ORQUIT=1 Q 85 . I X="" S DONE=1 Q 86 . I X?1"^".E D UJUMP Q 87 . I X="@" D DELETE Q 88 . I $E(DIR(0))="N",Y<1,$E(Y,1,2)'="0." S Y=0_Y 89 . S ORDIALOG(PROMPT,ORI)=$P(Y,U),DONE=1 90 . X:$L($G(^ORD(101.41,+ORDIALOG,10,ITM,5))) ^(5) I '$G(DONE) D RESET Q ; validate - if failed, K DONE to reask 91 . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) CHILDREN(PROMPT,ORI) I '$G(DONE),'FIRST D DELCHILD(PROMPT,ORI),RESET Q 92 Q 93 ; 94 CHILDREN(PARENT,INST) ; -- ask child prompts 95 N SEQ,DA,ORQUIT S SEQ=0 96 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D EN(DA,INST) Q:$G(ORQUIT) 97 K:$G(ORQUIT) DONE ; reask parent 98 Q 99 ; 100 RESET ; -- Reset original prompt value 101 K ORDIALOG(PROMPT,ORI) 102 S:$D(ORESET) ORDIALOG(PROMPT,ORI)=ORESET 103 Q 104 ; 105 UJUMP ; -- ^-jump 106 N XP,P,CNT,MATCH,I,DIR,NEWSEQ ; XP=$$UP(X),P=PROMPT 107 I $G(NOJUMP) W $C(7)," ^-jumping not allowed!" Q 108 S XP=$$UP^XLFSTR($P(X,U,2)) I "^"[XP S ORQUIT=1 Q 109 I $G(ORDIALOG("B",XP)) S NEWSEQ=+ORDIALOG("B",XP) G UJQ 110 S CNT=0,P=XP F S P=$O(ORDIALOG("B",P)) Q:P="" Q:$E(P,1,$L(XP))'=XP Q:FIRST&(+ORDIALOG("B",P)'<SEQ) S CNT=CNT+1,MATCH(CNT)=+ORDIALOG("B",P)_U_P ; =SEQ^TEXT 111 I 'CNT W $C(7)," ??" Q 112 I CNT=1 S P=$P(MATCH(1),U,2) W $E(P,$L(XP)+1,$L(P)) S NEWSEQ=+MATCH(1) G UJQ 113 F I=1:1:CNT S DIR("A",I)=I_" "_$P(MATCH(I),U,2) 114 S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT 115 S DIR("?")="Select the field you wish to jump to, by number" 116 D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") Q 117 S NEWSEQ=+MATCH(Y) 118 UJQ I FIRST,NEWSEQ'<SEQ W $C(7)," ^-jumping ahead not allowed now!" Q 119 S SEQ=NEWSEQ-.01,DONE=1 120 Q 121 ; 122 DELETE ; -- delete response 123 I '$D(DIR("B")) W $C(7)," ??" Q 124 Q:'$$SURE S DONE=1 125 K ORDIALOG(PROMPT,ORI),DIR("B") 126 S:$G(ORDIALOG(PROMPT,"TOT")) ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-1 127 I $D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) D DELCHILD(PROMPT,ORI) 128 Q 129 ; 130 DELCHILD(PARENT,INST) ; -- delete child prompts 131 N SEQ,DA,PTR S:'$G(INST) INST=1 132 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)),PTR=+$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) K:PTR ORDIALOG(PTR,INST) 133 Q 134 ; 135 SURE() ; -- sure you want to delete? 136 N X,Y,DIR 137 S DIR(0)="YA",DIR("A")=" Are you sure you want to delete this value? " 138 S DIR("B")="NO" W $C(7) D ^DIR 139 S:$D(DTOUT) Y="^" 140 Q Y 141 ; 142 VALID() ;Check to see if default value is valid. Returns 0 or 1 143 ;Entire section added in patch 95 144 N TYPE,RANGE,MIN,MAX,DIR,X,ORDIC,DDS,RTYPE,ORIG 145 I Y="" Q 1 ;If default is null allow to pass ;110 146 S DIR(0)=$G(ORDIALOG(PROMPT,0)),(ORIG,X)=Y,DIR("V")="" ;Set reader type, default input, silent call 147 S TYPE=$E($P(DIR(0),"^")) ;Get type of look-up being done 148 I TYPE="W" Q 1 ;If word processing assume value is valid, may be referencing a global location 149 I TYPE="R" S $P(DIR(0),"^")="D"_$E($P(DIR(0),"^"),2,999),TYPE="D",RTYPE=1 ;If type is R then change to date look up 150 I TYPE="D" I X="AM"!(X="NEXT")!(X="NEXTA")!(X="CLOSEST") Q 1 ;If date/time prompt default is AM, NEXT, NEXTA, or CLOSEST then accept without checking 151 S:TYPE="P"&(X=+X) X="`"_X ;If pointer type add ` to IEN for DIR call 152 I TYPE="P" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",2)=$TR($P(ORDIC,":",2),"QE","") S $P(DIR(0),"^",2)=ORDIC ;If pointer type remove Q&E from DIC(0) so no echo and no ?? on erroneous input 153 I TYPE="D" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",3)=$TR($P(ORDIC,":",3),"E",""),$P(ORDIC,":")=$TR($P(ORDIC,":"),"DTNOW",""),$P(DIR(0),"^",2)=ORDIC ;Remove "E" so no echo, remove DT and NOW so DIR call works correctly 154 I TYPE="Y" S:"^Y^YE^YES^"[("^"_$TR(X,"yes","YES")_"^")!(X=1) X="YES" S:"^N^NO^"[("^"_$TR(X,"no","NO")_"^")!(X=0) X="NO" ;If yes/no type convert input to uppercase full entry to avoid echo 155 I TYPE="S" S DDS=1 ;Stops DIR call from echoing rest of entry for set of codes 156 D ^DIR 157 I TYPE="D"&('$D(Y(0))) Q 0 ;Date not valid 158 I TYPE="L"&($G(Y)="") Q 0 ;List/Range not valid 159 I TYPE="N"&('$D(Y)) Q 0 ;Numeric not valid 160 I TYPE="P"&($G(Y)=-1) Q 0 ;Pointer not valid 161 I TYPE="S"&($G(Y(0))="") Q 0 ;Set of codes not valid 162 I TYPE="Y"&($G(Y(0))="") Q 0 ;Yes/No not valid 163 I TYPE="F" S RANGE=$P(DIR(0),"^",2),MIN=$S($P(RANGE,":"):$P(RANGE,":"),1:1),MAX=$S($P(RANGE,":",2):$P(RANGE,":",2),1:240) I $L(Y)<MIN!($L(Y)>MAX) Q 0 ;Free text and not within valid limit 164 I $G(RTYPE) S Y=ORIG ;Set y back to relative date 165 I TYPE="P" S Y=$P(Y,"^") ;only store IEN ;110 166 Q 1 ;Must be valid 1 ORCDLG1 ; SLC/MKB - Order dialogs cont ;11/21/01 08:03 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**60,71,95,110**;Dec 17, 1997 3 EN(ITM,INST) ; -- ask each ITM prompt where 4 ; ORDIALOG(PROMPT,#) = internal form of each response 5 ; 6 N ITEM,COND,MULT,REQD,EDITONLY,DATATYPE,DOMAIN,DIR,Y,ACTION,PROMPT,ORX,VALIDEF 7 S ITEM=$G(^ORD(101.41,+ORDIALOG,10,ITM,0)),COND=$G(^(3)) 8 S PROMPT=$P(ITEM,U,2) Q:'PROMPT S:'$G(INST) INST=1 9 S MULT=$P(ITEM,U,7),ACTION=$P(ITEM,U,9) 10 S REQD=$P(ITEM,U,6),EDITONLY=$P(ITEM,U,8) S:$G(ORTYPE)="Z" (REQD,EDITONLY)=0 11 I $D(^ORD(101.41,+ORDIALOG,10,ITM,9)) X ^(9) G:$G(ORQUIT) ENQ ;Entry 12 I $G(ORTYPE)="Q",$D(ORDIALOG(PROMPT,INST)),$E(ORDIALOG(PROMPT,0))'="W" S EDITONLY=1 13 I '$D(ORDIALOG(PROMPT,INST)) D ; get default value 14 . I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 M ^TMP("ORWORD",$J,PROMPT,INST)=^(8) S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" Q 15 . K Y X:$D(^ORD(101.41,+ORDIALOG,10,ITM,7)) ^(7) 16 . I $D(Y) S VALIDEF=$$VALID S:VALIDEF ORDIALOG(PROMPT,INST)=Y ;**95 17 . I $G(VALIDEF)=0 W !,"The DEFAULT value for the ",$G(ORDIALOG(PROMPT,"A"))," prompt is invalid." S EDITONLY=0 ;**95 18 . K VALIDEF ;**95 19 I $G(AUTO),'REQD!($E(ORDIALOG(PROMPT,0))="W"&$D(ORDIALOG(PROMPT,INST))) S EDITONLY=1 ;Auto-accept 20 EN0 I FIRST&EDITONLY D:$D(ORDIALOG(PROMPT,INST)) G ENQ ;ck child prompts 21 . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) N SEQ,DA,ITEM,PRMT,X,Y,VALIDEF ;**95 22 . S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D Q:$G(ORQUIT) 23 . . K VALIDEF ;110 24 . . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITEM,U,2) 25 . . Q:$D(ORDIALOG(PRMT,INST)) ; already has a value 26 . . K Y X:$D(^ORD(101.41,+ORDIALOG,10,DA,7)) ^(7) 27 . . I $D(Y) S VALIDEF=$$VALID ;**95 28 . . I $G(VALIDEF)!('$P(ITEM,U,6)) S:$G(VALIDEF) ORDIALOG(PRMT,INST)=Y Q ;**95 29 . . D EN(DA,INST) ; ask 30 I ($G(OREDIT)&(ACTION'["C"))!($G(ORENEW)&(ACTION'["R")) G ENQ ;ask? 31 I $G(OREWRITE),ACTION'["W",FIRST,'REQD!$D(ORDIALOG(PROMPT,INST)) G ENQ 32 I $L(COND) X COND G:'$T ENQ ; failed condition 33 M DIR=ORDIALOG(PROMPT) S DATATYPE=$E(DIR(0)),DOMAIN=$P(DIR(0),U,2) 34 I 'MULT D WP^ORCDLG2:DATATYPE="W",ONE(INST,REQD):DATATYPE'="W" G ENQ 35 EN1 ; -- loop for multiples 36 I '$O(ORDIALOG(PROMPT,0)) D G:$G(ORQUIT)!('$O(ORDIALOG(PROMPT,0)))!FIRST ENQ 37 M1 . D ADDMULT Q:$G(ORQUIT) 38 . Q:'REQD!$O(ORDIALOG(PROMPT,0)) I FIRST,$G(SEQ)=1 S ORQUIT=1 Q 39 . W $C(7),!!,$$REQUIRED,! G M1 40 F S ORX=$$SELECT Q:ORX="" S:ORX="^" ORQUIT=1 Q:$G(ORQUIT) D Q:$G(DIROUT) 41 . S DIR("A")=ORDIALOG(PROMPT,"A"),X=$S('REQD:0,$$ONLY(ORX):1,1:0) 42 . D ADDMULT:ORX="A",ONE(ORX,X):ORX Q:$G(DIROUT) K ORQUIT,DIR("B") 43 . I REQD,'$O(ORDIALOG(PROMPT,0)) W $C(7),!!,$$REQUIRED,! 44 ENQ X:$D(^ORD(101.41,+ORDIALOG,10,ITM,10)) ^(10) ; exit action 45 Q 46 ; 47 REQUIRED() ; -- Required response message 48 Q "A response is required! Enter '^' to quit." 49 ; 50 SELECT() ; -- select instance of multiple to edit 51 N DIR,X,Y,CNT,I,MAX,TOTAL,DONE 52 S MAX=+$G(ORDIALOG(PROMPT,"MAX")),TOTAL=+$G(ORDIALOG(PROMPT,"TOT")) 53 S DIR("A",1)=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A")) 54 S (I,CNT)=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 S CNT=CNT+1,CNT(CNT)=I,DIR("A",CNT+1)=$J(CNT,3)_": "_$$ITEM^ORCDLG(PROMPT,I) ; parent+children 55 I 'MAX!(MAX&(MAX>TOTAL)) S CNT=CNT+1,CNT(CNT)="A",DIR("A",CNT+1)=$J(CNT,3)_": <enter more>" 56 S DIR("A")="Select "_$S(CNT>1:"(1-"_CNT_")",1:1)_" or <return> to continue: " 57 S DIR(0)="NAO^1:"_CNT,DIR("?")="Select the instance you wish to change" 58 S1 D ^DIR I $D(DTOUT)!(Y="^") Q "^" 59 I Y?1"^".E D UJUMP Q:$G(ORQUIT)!($G(DONE)) "" G S1 60 I Y="" Q Y 61 Q CNT(Y) 62 ; 63 ONLY(I) ; -- I the only instance? 64 N J,Z S J=0,Z=1 65 F S J=$O(ORDIALOG(PROMPT,J)) Q:J'>0 I J'=I S Z=0 Q 66 Q Z 67 ; 68 ADDMULT ; -- add new instances of multiple 69 N DONE,LAST,INST,MAX,ANOTHER 70 S MAX=+$G(ORDIALOG(PROMPT,"MAX")) I MAX,MAX'>$G(ORDIALOG(PROMPT,"TOT")) W $C(7),!,"Only "_MAX_" items may be selected!",! Q 71 S ANOTHER=$G(ORDIALOG(PROMPT,"MORE")) S:'$L(ANOTHER) ANOTHER="Another " 72 S DIR("A")=$S($O(ORDIALOG(PROMPT,0)):ANOTHER,1:"")_ORDIALOG(PROMPT,"A") 73 F D Q:$G(ORQUIT)!($G(DONE)) I MAX Q:MAX'>$G(ORDIALOG(PROMPT,"TOT")) 74 . S INST=$O(ORDIALOG(PROMPT,"?"),-1)+1 75 . D ONE(INST,0) I '$D(ORDIALOG(PROMPT,INST)) S DONE=1 Q 76 . S ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1,DIR("A")=ANOTHER_ORDIALOG(PROMPT,"A") 77 Q 78 ; 79 ONE(ORI,REQD) ; -- ask single-valued prompt 80 N DONE,ORESET 81 S:$D(ORDIALOG(PROMPT,ORI)) DIR("B")=$$EXT^ORCD(PROMPT,ORI),ORESET=ORDIALOG(PROMPT,ORI) 82 F D Q:$G(DONE) I $G(ORQUIT) Q:FIRST Q:'REQD!$D(ORDIALOG(PROMPT,ORI)) S FIRST=$$DONE^ORCDLG2 Q:FIRST K ORQUIT 83 . D DIR^ORCDLG2 I $D(DTOUT)!$D(DIROUT)!(X=U) S ORQUIT=1 Q 84 . I X="" S DONE=1 Q 85 . I X?1"^".E D UJUMP Q 86 . I X="@" D DELETE Q 87 . S ORDIALOG(PROMPT,ORI)=$P(Y,U),DONE=1 88 . X:$L($G(^ORD(101.41,+ORDIALOG,10,ITM,5))) ^(5) I '$G(DONE) D RESET Q ; validate - if failed, K DONE to reask 89 . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) CHILDREN(PROMPT,ORI) I '$G(DONE),'FIRST D DELCHILD(PROMPT,ORI),RESET Q 90 Q 91 ; 92 CHILDREN(PARENT,INST) ; -- ask child prompts 93 N SEQ,DA,ORQUIT S SEQ=0 94 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D EN(DA,INST) Q:$G(ORQUIT) 95 K:$G(ORQUIT) DONE ; reask parent 96 Q 97 ; 98 RESET ; -- Reset original prompt value 99 K ORDIALOG(PROMPT,ORI) 100 S:$D(ORESET) ORDIALOG(PROMPT,ORI)=ORESET 101 Q 102 ; 103 UJUMP ; -- ^-jump 104 N XP,P,CNT,MATCH,I,DIR,NEWSEQ ; XP=$$UP(X),P=PROMPT 105 I $G(NOJUMP) W $C(7)," ^-jumping not allowed!" Q 106 S XP=$$UP^XLFSTR($P(X,U,2)) I "^"[XP S ORQUIT=1 Q 107 I $G(ORDIALOG("B",XP)) S NEWSEQ=+ORDIALOG("B",XP) G UJQ 108 S CNT=0,P=XP F S P=$O(ORDIALOG("B",P)) Q:P="" Q:$E(P,1,$L(XP))'=XP Q:FIRST&(+ORDIALOG("B",P)'<SEQ) S CNT=CNT+1,MATCH(CNT)=+ORDIALOG("B",P)_U_P ; =SEQ^TEXT 109 I 'CNT W $C(7)," ??" Q 110 I CNT=1 S P=$P(MATCH(1),U,2) W $E(P,$L(XP)+1,$L(P)) S NEWSEQ=+MATCH(1) G UJQ 111 F I=1:1:CNT S DIR("A",I)=I_" "_$P(MATCH(I),U,2) 112 S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT 113 S DIR("?")="Select the field you wish to jump to, by number" 114 D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") Q 115 S NEWSEQ=+MATCH(Y) 116 UJQ I FIRST,NEWSEQ'<SEQ W $C(7)," ^-jumping ahead not allowed now!" Q 117 S SEQ=NEWSEQ-.01,DONE=1 118 Q 119 ; 120 DELETE ; -- delete response 121 I '$D(DIR("B")) W $C(7)," ??" Q 122 Q:'$$SURE S DONE=1 123 K ORDIALOG(PROMPT,ORI),DIR("B") 124 S:$G(ORDIALOG(PROMPT,"TOT")) ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-1 125 I $D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) D DELCHILD(PROMPT,ORI) 126 Q 127 ; 128 DELCHILD(PARENT,INST) ; -- delete child prompts 129 N SEQ,DA,PTR S:'$G(INST) INST=1 130 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)),PTR=+$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) K:PTR ORDIALOG(PTR,INST) 131 Q 132 ; 133 SURE() ; -- sure you want to delete? 134 N X,Y,DIR 135 S DIR(0)="YA",DIR("A")=" Are you sure you want to delete this value? " 136 S DIR("B")="NO" W $C(7) D ^DIR 137 S:$D(DTOUT) Y="^" 138 Q Y 139 ; 140 VALID() ;Check to see if default value is valid. Returns 0 or 1 141 ;Entire section added in patch 95 142 N TYPE,RANGE,MIN,MAX,DIR,X,ORDIC,DDS,RTYPE,ORIG 143 I Y="" Q 1 ;If default is null allow to pass ;110 144 S DIR(0)=$G(ORDIALOG(PROMPT,0)),(ORIG,X)=Y,DIR("V")="" ;Set reader type, default input, silent call 145 S TYPE=$E($P(DIR(0),"^")) ;Get type of look-up being done 146 I TYPE="W" Q 1 ;If word processing assume value is valid, may be referencing a global location 147 I TYPE="R" S $P(DIR(0),"^")="D"_$E($P(DIR(0),"^"),2,999),TYPE="D",RTYPE=1 ;If type is R then change to date look up 148 I TYPE="D" I X="AM"!(X="NEXT")!(X="NEXTA")!(X="CLOSEST") Q 1 ;If date/time prompt default is AM, NEXT, NEXTA, or CLOSEST then accept without checking 149 S:TYPE="P"&(X=+X) X="`"_X ;If pointer type add ` to IEN for DIR call 150 I TYPE="P" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",2)=$TR($P(ORDIC,":",2),"QE","") S $P(DIR(0),"^",2)=ORDIC ;If pointer type remove Q&E from DIC(0) so no echo and no ?? on erroneous input 151 I TYPE="D" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",3)=$TR($P(ORDIC,":",3),"E",""),$P(ORDIC,":")=$TR($P(ORDIC,":"),"DTNOW",""),$P(DIR(0),"^",2)=ORDIC ;Remove "E" so no echo, remove DT and NOW so DIR call works correctly 152 I TYPE="Y" S:"^Y^YE^YES^"[("^"_$TR(X,"yes","YES")_"^")!(X=1) X="YES" S:"^N^NO^"[("^"_$TR(X,"no","NO")_"^")!(X=0) X="NO" ;If yes/no type convert input to uppercase full entry to avoid echo 153 I TYPE="S" S DDS=1 ;Stops DIR call from echoing rest of entry for set of codes 154 D ^DIR 155 I TYPE="D"&('$D(Y(0))) Q 0 ;Date not valid 156 I TYPE="L"&($G(Y)="") Q 0 ;List/Range not valid 157 I TYPE="N"&('$D(Y)) Q 0 ;Numeric not valid 158 I TYPE="P"&($G(Y)=-1) Q 0 ;Pointer not valid 159 I TYPE="S"&($G(Y(0))="") Q 0 ;Set of codes not valid 160 I TYPE="Y"&($G(Y(0))="") Q 0 ;Yes/No not valid 161 I TYPE="F" S RANGE=$P(DIR(0),"^",2),MIN=$S($P(RANGE,":"):$P(RANGE,":"),1:1),MAX=$S($P(RANGE,":",2):$P(RANGE,":",2),1:240) I $L(Y)<MIN!($L(Y)>MAX) Q 0 ;Free text and not within valid limit 162 I $G(RTYPE) S Y=ORIG ;Set y back to relative date 163 I TYPE="P" S Y=$P(Y,"^") ;only store IEN ;110 164 Q 1 ;Must be valid -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG2.m
r613 r623 1 ORCDLG2 ;SLC/MKB-Order dialogs cont ;10/12/2007 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,60,79,94,243**;Dec 17, 1997;Build 242 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 DIR ; -- ^DIR read of X, returns Y 5 N INPUTXFM,LKUP,REPL K DTOUT,DUOUT,DIRUT,DIROUT,DDER,Y 6 S (X,Y)="",INPUTXFM=$P(DIR(0),U,3,99) 7 S LKUP=$G(ORDIALOG(PROMPT,"LKP")) ; special lookup rtn 8 S REPL=$S(DATATYPE'="F":0,$L($G(DIR("B")))>20:1,1:0) S:REPL DIR(0)=$E(DIR(0))_"AO^"_$P(DIR(0),U,2,99) 9 DIR1 I 'REPL W !,DIR("A")_$S($D(DIR("B")):DIR("B")_"// ",1:"") R X:DTIME I '$T S DTOUT=1 Q 10 I REPL D ^DIR Q:$D(DTOUT)!$D(DUOUT) 11 I X="" S:$D(DIR("B")) X=DIR("B"),Y=ORDIALOG(PROMPT,ORI) S:'$L(X)&(SEQ=1)&('MULT) X="^" Q:'REQD!$L(X) W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1 12 I X="@" Q:'REQD W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1 13 I X?1"^".E S (DUOUT,DIRUT)=1,Y=X S:X="^^" DIROUT=1 Q 14 I X?1"?".E D G DIR1 15 . N XHELP 16 . S XHELP=$S($D(DIR("??")):$P(DIR("??"),U,2,99),1:("D "_DATATYPE_"^ORCDLGH")) 17 . I (DATATYPE="P")!(DATATYPE="S")!(X?1"??".E) X XHELP 18 . S:'$D(DIR("?")) DIR("?")=$$HELP(DATATYPE) 19 . I $L(DIR("?"))<80 W !,DIR("?"),! 20 . E D W ! 21 . . N X,DIWL,DIWR,I S X=DIR("?"),DIWL=1,DIWR=80 K ^UTILITY($J,"W") 22 . . D ^DIWP F I=1:1:^UTILITY($J,"W",DIWL) W !,$G(^UTILITY($J,"W",DIWL,I,0)) 23 I $L(INPUTXFM) X INPUTXFM I '$D(X) D ERR G DIR1 24 I $L(LKUP),$L($T(@LKUP)) D @LKUP Q:Y>0 D ERR G DIR1 25 I $G(ORDIALOG(PROMPT,"LIST")) D Q:$L(Y) I $P(ORDIALOG(PROMPT,"LIST"),U,2) W $C(7) D LIST^ORCD G DIR1 26 . N OROOT S OROOT="ORDIALOG("_PROMPT_",""LIST"")" 27 . S:(X=" ")&(DATATYPE="P") X=$$SPACE(DOMAIN) 28 . S Y=$$FIND(OROOT,X) ; I X'[",",X'["-" S Y=$$FIND Q 29 . ; S ORX=$$EXPLIST(X) F S Y(Y+1)=$$FIND 30 I DATATYPE="P" D DIC I Y'>0 D ERR G DIR1 31 I (DATATYPE="R")!(DATATYPE="D") D DT I Y<0 D ERR G DIR1 32 I "^F^N^S^Y^"[(U_DATATYPE_U) D I $G(DDER) D ERR G DIR1 ;JEH 'REPL was checked 33 . N I F I=1:1:31 S X=$TR(X,$C(I)) ; strip out control char's 34 . S DIR("V")="" D ^DIR ; silent 35 Q 36 ; 37 ERR ; -- show help msg on error 38 W:$D(DIR("?")) $C(7),!,DIR("?"),! 39 Q 40 ; 41 FIND(LIST,X) ; -- find value X in LIST(#) or LIST("B",name) 42 N Y,XP,CNT,MATCH,I,DIR 43 S:$L(X)>63 X=$E(X,1,63) S X=$$UP^XLFSTR(X) 44 S CNT=0,XP="" F S XP=$O(@LIST@("B",XP)) Q:XP="" I $S(X=+X:+XP=+X,1:$E(XP,1,$L(X))=X) S CNT=CNT+1,MATCH(CNT)=@LIST@("B",XP)_U_XP,DIR("A",CNT)=$J(CNT,3)_" "_XP 45 I X=+X!(X?1"0."1.N) S Y=$G(@LIST@(X)) I $L(Y) W " "_$P(Y,U,2) G:$$OK FQ S X="" W " " ;force entire text to echo if CNT=1 46 I 'CNT S Y="" G FQ 47 I CNT=1 S Y=MATCH(1),XP=$P(Y,U,2) W $E(XP,$L(X)+1,$L(XP)) G FQ 48 S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT 49 S DIR("?")="Select the desired value, by number" 50 D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") S Y="" G FQ 51 S Y=MATCH(Y) W " "_$P(Y,U,2) 52 FQ D:Y&((+DOMAIN=101.43)!(DOMAIN?1"ORD(101.43,:".E)) SETDISV 53 Q Y 54 ; 55 OK() ; -- Return 1 or 0, if selected item is correct 56 N X,Y,DIR I CNT'>0 Q 1 ;no other matches 57 S DIR(0)="YA",DIR("A")=" ...OK? ",DIR("B")="YES" 58 S DIR("?")="Enter YES if this is the item you wish to select, or NO to continue searching the list" 59 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="" 60 Q +Y 61 ; 62 DIC ; -- ^DIC lookup on X, return Y 63 N ORDMN,ORDITM,DIC,D,ORDIC,TYPE S Y=-1,ORDMN=$P(ORDIALOG(PROMPT,0),U,2) 64 S ORDITM=$S(+ORDMN=101.43:1,ORDMN?1"ORD(101.43,:".E:1,1:0) ; OI file? 65 I X=" ",ORDITM D SPBAR W $S(Y>0:" "_X,1:$C(7)_" ??") Q 66 I ORDITM,X?1"`"1.N W $C(7),!,"Lookup by internal entry number not allowed!",! Q 67 I X=$G(DIR("B")) S Y=ORDIALOG(PROMPT,ORI) Q ; default 68 S DIC=$P(ORDMN,":"),DIC(0)=$P(ORDMN,":",2),ORDIC="^DIC" S:'DIC DIC=U_DIC 69 S:$D(ORDIALOG(PROMPT,"S")) DIC("S")=ORDIALOG(PROMPT,"S") 70 S TYPE=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) 71 S:ORDITM DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"_$S(TYPE["RX":" W:$P($G(^(""PS"")),U,6) "" (non-formulary)"" ",1:"") ;W NAME if OI/synm, or NF 72 S D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^") 73 I $L(D) S ORDIC="IX^DIC" S:$L(D,U)>1 ORDIC="MIX^DIC1",DIC(0)=DIC(0)_"M" 74 D @ORDIC,SETDISV:Y&ORDITM 75 I DIC(0)["S",X'=$P(Y,"^",2) W " ",$P(Y,"^",2) 76 Q 77 ; 78 SPACE(FILE) ; -- Resolve spbar-return for ptrs 79 N X,Y,DIC,ROOT S X=" ",FILE=$P(FILE,":") 80 I (+FILE=101.43)!(FILE="ORD(101.43,") D SPBAR Q X 81 S ROOT=$S(+FILE:$$ROOT^DILFD(+FILE),1:U_FILE),Y=$G(^DISV(DUZ,ROOT)) 82 S:Y X=$P(@(ROOT_Y_",0)"),U) 83 Q X 84 ; 85 SPBAR ; -- Resolve spbar-return for #101.43 86 N SDX,I,X1,D S SDX="",D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^") 87 F I=1:1:$L(D,"^") I $P(D,U,I)?1"S."1.E S SDX=$P(D,U,I) Q 88 Q:'$L(SDX) S X1=$G(^DISV(DUZ,"ORDITM",SDX,1)) Q:'$L(X1) 89 S Y=$O(^ORD(101.43,SDX,X1,0)) S:Y X=X1,Y=Y_U_X1 90 Q 91 ; 92 SETDISV ; -- Save entry Y=ifn^name in ^DISV for #101.43 93 N SDX,I Q:'$L($P(Y,U,2)) 94 S SDX="",D=$G(ORDIALOG(PROMPT,"D")) Q:D'["S." 95 F I=1:1:$L(D,";") I $P(D,";",I)?1"S."1.E S SDX=$P(D,";",I) Q 96 Q:'$L(SDX) S ^DISV(DUZ,"ORDITM",SDX,1)=$P(Y,U,2) 97 Q 98 ; 99 DT ; -- %DT validation on X, return Y 100 N %DT,BEG,END S %DT=$P(DOMAIN,":",3),X=$$UP^XLFSTR(X) 101 I $L($P(DOMAIN,":")) S BEG=$$FMDT($P(DOMAIN,":")) ;earliest date allowed 102 I $L($P(DOMAIN,":",2)) S END=$$FMDT($P(DOMAIN,":",2)) ;latest allowed 103 D ^%DT Q:Y'>0 104 I $G(BEG) D Q:Y<0 105 . I $L(Y,".")'=$L(BEG,".") S BEG=$P(BEG,".") ; date only 106 . I Y<BEG W $C(7),!,"Date may not be before "_$$FMTE^XLFDT(BEG) S Y=-1 Q 107 I $G(END) D Q:Y<0 108 . I $L(Y,".")'=$L(END,".") S END=$P(END,".") ; date only 109 . I Y>END W $C(7),!,"Date may not be after "_$$FMTE^XLFDT(END) S Y=-1 Q 110 I DATATYPE="R",$$RELDT(X) S:(%DT'["T")&("NOW"[X) X="TODAY" S Y=X ;text 111 Q 112 DT1 S:X="NOON" X="T@NOON" S:$E("MIDNIGHT",1,$L(X))=X X="T@MIDNIGHT" 113 I X'?1"V".E,X'?1"T".E D ^%DT S:Y>0&("NOW"[X) Y="NOW" Q 114 S D=$$UP^XLFSTR($P(X,"@")),T=$P(X,"@",2) 115 S Y=$E(D) I "VT"'[Y S Y=-1 Q 116 I (D["+")!(D["-") D Q:Y<0 117 . N SIGN,OFFSET,X1,X2 118 . S SIGN=$S(D["+":"+",1:"-"),OFFSET=$P(D,SIGN,2) I 'OFFSET S Y=-1 Q 119 . S X1=+OFFSET,X2=$P(OFFSET,X1,2) I "DWM"'[$E(X2) S Y=-1 Q 120 . S Y=Y_SIGN_X1_$E(X2) ; T+3W, e.g. 121 I '$L(T)&(DOMAIN["R") S Y=-1 Q ; time missing, required 122 I $L(T) D I '$D(T) S Y=-1 Q 123 . I '(DOMAIN["T"!(DOMAIN["R")) K T Q ; time prohibited 124 . N X,Y S X="T@"_T,%DT=$TR(DOMAIN,"E") D ^%DT I Y<0 K T Q 125 . S T=$E($P(Y,".",2),1,4) S:$L(T)<4 T=T_$E("0000",1,4-$L(T)) 126 S:$L(T) Y=Y_"@"_T ; Y=date text, or -1 if error 127 Q 128 ; 129 RELDT(X) ; -- Returns 1 or 0, if X is relative date 130 N Y S X=$G(X) 131 I ("NOON"[X)!("MIDNIGHT"[X)!($E(X)="T")!($E(X)="N") S Y=1 132 E S Y=0 133 Q Y 134 ; 135 FMDT(X) ; -- Return FM form of date X 136 N Y,%DT S %DT="T" D ^%DT 137 Q Y 138 ; 139 WP ; -- edit WP field 140 N DIC,DWLW,DWPK,DIWESUB,DONE,ORLINEDT,LCNT,UPCARR 141 S DIC="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_",",DWLW=80,DWPK=1 142 S DIWESUB=$P(DIR("A"),":"),ORLINEDT=$$LINEDTR(DUZ) 143 I '$D(^TMP("ORWORD",$J,PROMPT,INST)) M:$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 ^TMP("ORWORD",$J,PROMPT,INST)=^(8) 144 I 'ORLINEDT,'REQD,'$$EDITWP Q ;94 145 WP1 W:ORLINEDT !,DIR("A") S DIWESUB=$P(DIR("A"),":") 146 D EN^DIWE I $D(DTOUT)!($D(DUOUT)) S ORQUIT=1 Q 147 I REQD,'$O(^TMP("ORWORD",$J,PROMPT,INST,0)) W $C(7),!!,"A response is required!" G:'$$DONE WP1 S ORQUIT=1 Q 148 I '$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ^TMP("ORWORD",$J,PROMPT,INST),ORDIALOG(PROMPT,INST) Q ;empty 149 S LCNT="",UPCARR=0 150 F S LCNT=$O(^TMP("ORWORD",$J,PROMPT,INST,LCNT)) Q:LCNT=""!(UPCARR=1) D 151 .I LCNT>0,$G(^TMP("ORWORD",$J,PROMPT,INST,LCNT,0))[U S UPCARR=1 152 I UPCARR=1 W !!,"An ""^"" is not allowed in a word processing field." G:'$$DONE WP1 S ORQUIT=1 Q 153 S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")",DONE=1 154 I $D(^ORD(101.41,+ORDIALOG,10,ITM,5)) X ^(5) Q:$G(ORQUIT)!($G(DONE)) G WP1 155 Q 156 ; 157 EDITWP() ; -- Want to edit WP field? 158 N X,Y,%,%Y 159 W !,ORDIALOG(PROMPT,"A") S Y=$D(ORDIALOG(PROMPT,INST)) 160 I 'Y,REQD Q 1 ; no data, req'd 161 W:'Y !," No existing text",! I Y D ; show comments 162 . N X,DIWL,DIWR,DIWF,ORI 163 . S DIWL=3,DIWR=79,DIWF="W" K ^UTILITY($J,"W") 164 . S ORI=0 F S ORI=$O(^TMP("ORWORD",$J,PROMPT,INST,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) D:$L(X) ^DIWP 165 . D ^DIWW 166 ED1 S %=$S($D(OREDIT):1,1:2) W " Edit" D YN^DICN 167 I %=0 W !," Enter 'YES' if you wish to go into the editor.",!," Enter 'NO' if you do not wish to edit at this time.",! G ED1 168 S Y=$S(%<0:"^",%=2:0,1:1) 169 Q Y 170 ; 171 LINEDTR(USER) ; -- Returns 1 or 0, if user's editor will be LineEd 172 N X,Y 173 S X=+$P($G(^VA(200,USER,1)),U,5),Y=0 I 'X S Y=1 174 E S:$$GET1^DIQ(1.2,+X_",",.01)="LINE EDITOR - VA FILEMAN" Y=1 175 Q Y 176 ; 177 RETURN() ; -- press return to cont 178 N X W !,"Press <return> to continue ..." R X:DTIME 179 Q "" 180 ; 181 DONE() ; -- Done editing? 182 N DIR,X,Y 183 S DIR(0)="YA",DIR("A")="Do you want to quit? ",DIR("B")="NO" 184 S DIR("?")="Enter YES to exit this order, or NO to continue editing" 185 D ^DIR 186 Q +Y 187 ; 188 HELP(TYPE) ; -- Returns default help msg for TYPE prompt 189 N Y S Y="" 190 I TYPE="D" S Y="Enter a date[/time]." 191 I TYPE="R" S Y="Enter a date[/time] as T for TODAY or T+1 for TOMORROW." 192 I TYPE="F" S Y="Enter a string of text." 193 I TYPE="N" S Y="Enter a number." 194 I TYPE="S" S Y="Enter an item from the list." 195 I TYPE="Y" S Y="Enter YES or NO." 196 I TYPE="P" S Y="Enter an item from the file." 197 I TYPE="W" S Y="" 198 Q Y 1 ORCDLG2 ;SLC/MKB-Order dialogs cont ;3/13/01 11:16 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,60,79,94**;Dec 17, 1997 3 DIR ; -- ^DIR read of X, returns Y 4 N INPUTXFM,LKUP,REPL K DTOUT,DUOUT,DIRUT,DIROUT,DDER,Y 5 S (X,Y)="",INPUTXFM=$P(DIR(0),U,3,99) 6 S LKUP=$G(ORDIALOG(PROMPT,"LKP")) ; special lookup rtn 7 S REPL=$S(DATATYPE'="F":0,$L($G(DIR("B")))>20:1,1:0) S:REPL DIR(0)=$E(DIR(0))_"AO^"_$P(DIR(0),U,2,99) 8 DIR1 I 'REPL W !,DIR("A")_$S($D(DIR("B")):DIR("B")_"// ",1:"") R X:DTIME I '$T S DTOUT=1 Q 9 I REPL D ^DIR Q:$D(DTOUT)!$D(DUOUT) 10 I X="" S:$D(DIR("B")) X=DIR("B"),Y=ORDIALOG(PROMPT,ORI) S:'$L(X)&(SEQ=1)&('MULT) X="^" Q:'REQD!$L(X) W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1 11 I X="@" Q:'REQD W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1 12 I X?1"^".E S (DUOUT,DIRUT)=1,Y=X S:X="^^" DIROUT=1 Q 13 I X?1"?".E D G DIR1 14 . N XHELP 15 . S XHELP=$S($D(DIR("??")):$P(DIR("??"),U,2,99),1:("D "_DATATYPE_"^ORCDLGH")) 16 . I (DATATYPE="P")!(DATATYPE="S")!(X?1"??".E) X XHELP 17 . S:'$D(DIR("?")) DIR("?")=$$HELP(DATATYPE) 18 . I $L(DIR("?"))<80 W !,DIR("?"),! 19 . E D W ! 20 . . N X,DIWL,DIWR,I S X=DIR("?"),DIWL=1,DIWR=80 K ^UTILITY($J,"W") 21 . . D ^DIWP F I=1:1:^UTILITY($J,"W",DIWL) W !,$G(^UTILITY($J,"W",DIWL,I,0)) 22 I $L(INPUTXFM) X INPUTXFM I '$D(X) D ERR G DIR1 23 I $L(LKUP),$L($T(@LKUP)) D @LKUP Q:Y>0 D ERR G DIR1 24 I $G(ORDIALOG(PROMPT,"LIST")) D Q:$L(Y) I $P(ORDIALOG(PROMPT,"LIST"),U,2) W $C(7) D LIST^ORCD G DIR1 25 . N OROOT S OROOT="ORDIALOG("_PROMPT_",""LIST"")" 26 . S:(X=" ")&(DATATYPE="P") X=$$SPACE(DOMAIN) 27 . S Y=$$FIND(OROOT,X) ; I X'[",",X'["-" S Y=$$FIND Q 28 . ; S ORX=$$EXPLIST(X) F S Y(Y+1)=$$FIND 29 I DATATYPE="P" D DIC I Y'>0 D ERR G DIR1 30 I (DATATYPE="R")!(DATATYPE="D") D DT I Y<0 D ERR G DIR1 31 I "^F^N^S^Y^"[(U_DATATYPE_U),'REPL D I $G(DDER) D ERR G DIR1 32 . N I F I=1:1:31 S X=$TR(X,$C(I)) ; strip out control char's 33 . S DIR("V")="" D ^DIR ; silent 34 Q 35 ; 36 ERR ; -- show help msg on error 37 W:$D(DIR("?")) $C(7),!,DIR("?"),! 38 Q 39 ; 40 FIND(LIST,X) ; -- find value X in LIST(#) or LIST("B",name) 41 N Y,XP,CNT,MATCH,I,DIR 42 S:$L(X)>63 X=$E(X,1,63) S X=$$UP^XLFSTR(X) 43 S CNT=0,XP="" F S XP=$O(@LIST@("B",XP)) Q:XP="" I $S(X=+X:+XP=+X,1:$E(XP,1,$L(X))=X) S CNT=CNT+1,MATCH(CNT)=@LIST@("B",XP)_U_XP,DIR("A",CNT)=$J(CNT,3)_" "_XP 44 I X=+X S Y=$G(@LIST@(X)) I $L(Y) W " "_$P(Y,U,2) G:$$OK FQ S X="" W " " ;force entire text to echo if CNT=1 45 I 'CNT S Y="" G FQ 46 I CNT=1 S Y=MATCH(1),XP=$P(Y,U,2) W $E(XP,$L(X)+1,$L(XP)) G FQ 47 S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT 48 S DIR("?")="Select the desired value, by number" 49 D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") S Y="" G FQ 50 S Y=MATCH(Y) W " "_$P(Y,U,2) 51 FQ D:Y&((+DOMAIN=101.43)!(DOMAIN?1"ORD(101.43,:".E)) SETDISV 52 Q Y 53 ; 54 OK() ; -- Return 1 or 0, if selected item is correct 55 N X,Y,DIR I CNT'>0 Q 1 ;no other matches 56 S DIR(0)="YA",DIR("A")=" ...OK? ",DIR("B")="YES" 57 S DIR("?")="Enter YES if this is the item you wish to select, or NO to continue searching the list" 58 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="" 59 Q +Y 60 ; 61 DIC ; -- ^DIC lookup on X, return Y 62 N ORDMN,ORDITM,DIC,D,ORDIC,TYPE S Y=-1,ORDMN=$P(ORDIALOG(PROMPT,0),U,2) 63 S ORDITM=$S(+ORDMN=101.43:1,ORDMN?1"ORD(101.43,:".E:1,1:0) ; OI file? 64 I X=" ",ORDITM D SPBAR W $S(Y>0:" "_X,1:$C(7)_" ??") Q 65 I ORDITM,X?1"`"1.N W $C(7),!,"Lookup by internal entry number not allowed!",! Q 66 I X=$G(DIR("B")) S Y=ORDIALOG(PROMPT,ORI) Q ; default 67 S DIC=$P(ORDMN,":"),DIC(0)=$P(ORDMN,":",2),ORDIC="^DIC" S:'DIC DIC=U_DIC 68 S:$D(ORDIALOG(PROMPT,"S")) DIC("S")=ORDIALOG(PROMPT,"S") 69 S TYPE=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) 70 S:ORDITM DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"_$S(TYPE["RX":" W:$P($G(^(""PS"")),U,6) "" (non-formulary)"" ",1:"") ;W NAME if OI/synm, or NF 71 S D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^") 72 I $L(D) S ORDIC="IX^DIC" S:$L(D,U)>1 ORDIC="MIX^DIC1",DIC(0)=DIC(0)_"M" 73 D @ORDIC,SETDISV:Y&ORDITM 74 I DIC(0)["S",X'=$P(Y,"^",2) W " ",$P(Y,"^",2) 75 Q 76 ; 77 SPACE(FILE) ; -- Resolve spbar-return for ptrs 78 N X,Y,DIC,ROOT S X=" ",FILE=$P(FILE,":") 79 I (+FILE=101.43)!(FILE="ORD(101.43,") D SPBAR Q X 80 S ROOT=$S(+FILE:$$ROOT^DILFD(+FILE),1:U_FILE),Y=$G(^DISV(DUZ,ROOT)) 81 S:Y X=$P(@(ROOT_Y_",0)"),U) 82 Q X 83 ; 84 SPBAR ; -- Resolve spbar-return for #101.43 85 N SDX,I,X1,D S SDX="",D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^") 86 F I=1:1:$L(D,"^") I $P(D,U,I)?1"S."1.E S SDX=$P(D,U,I) Q 87 Q:'$L(SDX) S X1=$G(^DISV(DUZ,"ORDITM",SDX,1)) Q:'$L(X1) 88 S Y=$O(^ORD(101.43,SDX,X1,0)) S:Y X=X1,Y=Y_U_X1 89 Q 90 ; 91 SETDISV ; -- Save entry Y=ifn^name in ^DISV for #101.43 92 N SDX,I Q:'$L($P(Y,U,2)) 93 S SDX="",D=$G(ORDIALOG(PROMPT,"D")) Q:D'["S." 94 F I=1:1:$L(D,";") I $P(D,";",I)?1"S."1.E S SDX=$P(D,";",I) Q 95 Q:'$L(SDX) S ^DISV(DUZ,"ORDITM",SDX,1)=$P(Y,U,2) 96 Q 97 ; 98 DT ; -- %DT validation on X, return Y 99 N %DT,BEG,END S %DT=$P(DOMAIN,":",3),X=$$UP^XLFSTR(X) 100 I $L($P(DOMAIN,":")) S BEG=$$FMDT($P(DOMAIN,":")) ;earliest date allowed 101 I $L($P(DOMAIN,":",2)) S END=$$FMDT($P(DOMAIN,":",2)) ;latest allowed 102 D ^%DT Q:Y'>0 103 I $G(BEG) D Q:Y<0 104 . I $L(Y,".")'=$L(BEG,".") S BEG=$P(BEG,".") ; date only 105 . I Y<BEG W $C(7),!,"Date may not be before "_$$FMTE^XLFDT(BEG) S Y=-1 Q 106 I $G(END) D Q:Y<0 107 . I $L(Y,".")'=$L(END,".") S END=$P(END,".") ; date only 108 . I Y>END W $C(7),!,"Date may not be after "_$$FMTE^XLFDT(END) S Y=-1 Q 109 I DATATYPE="R",$$RELDT(X) S:(%DT'["T")&("NOW"[X) X="TODAY" S Y=X ;text 110 Q 111 DT1 S:X="NOON" X="T@NOON" S:$E("MIDNIGHT",1,$L(X))=X X="T@MIDNIGHT" 112 I X'?1"V".E,X'?1"T".E D ^%DT S:Y>0&("NOW"[X) Y="NOW" Q 113 S D=$$UP^XLFSTR($P(X,"@")),T=$P(X,"@",2) 114 S Y=$E(D) I "VT"'[Y S Y=-1 Q 115 I (D["+")!(D["-") D Q:Y<0 116 . N SIGN,OFFSET,X1,X2 117 . S SIGN=$S(D["+":"+",1:"-"),OFFSET=$P(D,SIGN,2) I 'OFFSET S Y=-1 Q 118 . S X1=+OFFSET,X2=$P(OFFSET,X1,2) I "DWM"'[$E(X2) S Y=-1 Q 119 . S Y=Y_SIGN_X1_$E(X2) ; T+3W, e.g. 120 I '$L(T)&(DOMAIN["R") S Y=-1 Q ; time missing, required 121 I $L(T) D I '$D(T) S Y=-1 Q 122 . I '(DOMAIN["T"!(DOMAIN["R")) K T Q ; time prohibited 123 . N X,Y S X="T@"_T,%DT=$TR(DOMAIN,"E") D ^%DT I Y<0 K T Q 124 . S T=$E($P(Y,".",2),1,4) S:$L(T)<4 T=T_$E("0000",1,4-$L(T)) 125 S:$L(T) Y=Y_"@"_T ; Y=date text, or -1 if error 126 Q 127 ; 128 RELDT(X) ; -- Returns 1 or 0, if X is relative date 129 N Y S X=$G(X) 130 I ("NOON"[X)!("MIDNIGHT"[X)!($E(X)="T")!($E(X)="N") S Y=1 131 E S Y=0 132 Q Y 133 ; 134 FMDT(X) ; -- Return FM form of date X 135 N Y,%DT S %DT="T" D ^%DT 136 Q Y 137 ; 138 WP ; -- edit WP field 139 N DIC,DWLW,DWPK,DIWESUB,DONE,ORLINEDT 140 S DIC="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_",",DWLW=80,DWPK=1 141 S DIWESUB=$P(DIR("A"),":"),ORLINEDT=$$LINEDTR(DUZ) 142 I '$D(^TMP("ORWORD",$J,PROMPT,INST)) M:$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 ^TMP("ORWORD",$J,PROMPT,INST)=^(8) 143 I 'ORLINEDT,'REQD,'$$EDITWP Q ;94 144 WP1 W:ORLINEDT !,DIR("A") S DIWESUB=$P(DIR("A"),":") 145 D EN^DIWE I $D(DTOUT)!($D(DUOUT)) S ORQUIT=1 Q 146 I REQD,'$O(^TMP("ORWORD",$J,PROMPT,INST,0)) W $C(7),!!,"A response is required!" G:'$$DONE WP1 S ORQUIT=1 Q 147 I '$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ^TMP("ORWORD",$J,PROMPT,INST),ORDIALOG(PROMPT,INST) Q ;empty 148 S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")",DONE=1 149 I $D(^ORD(101.41,+ORDIALOG,10,ITM,5)) X ^(5) Q:$G(ORQUIT)!($G(DONE)) G WP1 150 Q 151 ; 152 EDITWP() ; -- Want to edit WP field? 153 N X,Y,%,%Y 154 W !,ORDIALOG(PROMPT,"A") S Y=$D(ORDIALOG(PROMPT,INST)) 155 I 'Y,REQD Q 1 ; no data, req'd 156 W:'Y !," No existing text",! I Y D ; show comments 157 . N X,DIWL,DIWR,DIWF,ORI 158 . S DIWL=3,DIWR=79,DIWF="W" K ^UTILITY($J,"W") 159 . S ORI=0 F S ORI=$O(^TMP("ORWORD",$J,PROMPT,INST,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) D:$L(X) ^DIWP 160 . D ^DIWW 161 ED1 S %=$S($D(OREDIT):1,1:2) W " Edit" D YN^DICN 162 I %=0 W !," Enter 'YES' if you wish to go into the editor.",!," Enter 'NO' if you do not wish to edit at this time.",! G ED1 163 S Y=$S(%<0:"^",%=2:0,1:1) 164 Q Y 165 ; 166 LINEDTR(USER) ; -- Returns 1 or 0, if user's editor will be LineEd 167 N X,Y 168 S X=+$P($G(^VA(200,USER,1)),U,5),Y=0 I 'X S Y=1 169 E S:$$GET1^DIQ(1.2,+X_",",.01)="LINE EDITOR - VA FILEMAN" Y=1 170 Q Y 171 ; 172 RETURN() ; -- press return to cont 173 N X W !,"Press <return> to continue ..." R X:DTIME 174 Q "" 175 ; 176 DONE() ; -- Done editing? 177 N DIR,X,Y 178 S DIR(0)="YA",DIR("A")="Do you want to quit? ",DIR("B")="NO" 179 S DIR("?")="Enter YES to exit this order, or NO to continue editing" 180 D ^DIR 181 Q +Y 182 ; 183 HELP(TYPE) ; -- Returns default help msg for TYPE prompt 184 N Y S Y="" 185 I TYPE="D" S Y="Enter a date[/time]." 186 I TYPE="R" S Y="Enter a date[/time] as T for TODAY or T+1 for TOMORROW." 187 I TYPE="F" S Y="Enter a string of text." 188 I TYPE="N" S Y="Enter a number." 189 I TYPE="S" S Y="Enter an item from the list." 190 I TYPE="Y" S Y="Enter YES or NO." 191 I TYPE="P" S Y="Enter an item from the file." 192 I TYPE="W" S Y="" 193 Q Y -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLR.m
r613 r623 1 ORCDLR ;SLC/MKB-Utility functions for LR dialogs ;11/22/06 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,71,79,175,243**;Dec 17, 1997;Build 242 3 TEST ; -- Setup ORTEST() array of ordering parameters 4 N OI,TST,WRD,I,DG 5 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI 6 I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST 7 S WRD="GenWardInstructions" I $O(ORTEST(WRD,0)) D W ! 8 . W ! S I=0 F S I=$O(ORTEST(WRD,I)) Q:I'>0 W !,ORTEST(WRD,I,0) 9 S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB" 10 S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG 11 Q 12 ; 13 CKTYP ; -- ck type of test [Exit Action] 14 N X,Y S X=$G(ORDIALOG(PROMPT,INST)) Q:'X 15 S Y=$P($G(^ORD(101.43,+X,"LR")),U,7) 16 I (Y="O")!(Y="N") W $C(7),!,"This test may not be ordered anymore. Please select another test." S ORQUIT=1 D WAIT Q 17 Q 18 ; 19 WAIT ; -- Wait for user 20 N X W !,"Press <return> to continue ..." R X:DTIME 21 Q 22 ; 23 SHOWMAX ; -- Setup max days allowed for cont orders 24 K ^TMP($J,"ORCDLR SHOWMAX") 25 D ZERO^PSS51P1(+ORSCH,,,,"ORCDLR SHOWMAX") 26 I $S('$G(ORSCH):1,"CD"'[$P($G(^TMP($J,"ORCDLR SHOWMAX",+ORSCH,5)),U):1,1:0) K ORDIALOG(PROMPT,INST) Q ;just in case 27 ;I $S('$G(ORSCH):1,"CD"'[$P($G(^PS(51.1,+ORSCH,0)),U,5):1,1:0) K ORDIALOG(PROMPT,INST) Q ;just in case 28 N Y,OK S ORSMAX=$G(^TMP($J,"ORCDLR SHOWMAX",+ORSCH,2.5)),ORSTMS=$P($G(^(0)),U,3) 29 ;N Y,OK S ORSMAX=$P($G(^PS(51.1,ORSCH,0)),U,7),ORSTMS=$P($G(^(0)),U,3) 30 S ORSMAX=$S('$G(ORSMAX):ORMAX,$G(ORTYPE)="Z":ORSMAX,ORMAX<ORSMAX:ORMAX,1:ORSMAX),ORSTMS=$S(ORSMAX&ORSTMS:ORSMAX*1440\ORSTMS,1:"") ;set max days, times 31 I FIRST,$G(ORTYPE)="Q" S Y=$G(ORDIALOG(PROMPT,INST)) I $L(Y) S OK=$$CKMAX(Y) Q:OK K ORDIALOG(PROMPT,INST) ;Q if valid, else fall thru and prompt 32 W !!,"Maximum number of days for continuous orders is "_ORSMAX_"; enter a duration",!,"as either a number of days (3) or Xnumber of times (X3).",! 33 K ^TMP($J,"ORCDLR SHOWMAX") 34 Q 35 ; 36 CKMAX(X) ; -- Ck duration X against max allowed 37 N Y S Y=1 38 I +X=X S Y=$S(X<0:"0^Cannot order in the past.",'ORSMAX:1,X'>ORSMAX:1,1:"0^Cannot order more than "_ORSMAX_" days in advance.") G CKQ 39 I (X'?1"X"1.N),(X'?1"x"1.N) S Y="0^Enter either a number of days or X_number of times." G CKQ 40 I ORSTMS,+$E(X,2,9)>ORSTMS S Y="0^Cannot order more than "_ORSTMS_" time* s." G CKQ 41 I 'ORSTMS,+$E(X,2,9)>ORSMAX S Y="0^Cannot order for more than "_ORSMAX_" days." G CKQ ; day of week schedule 42 S Y=1 43 CKQ Q Y 44 ; 45 SAMPLE() ; -- Get default sample from Test for INST 46 N X,Y I $L($G(LRFSAMP)) Q LRFSAMP 47 I (ORCOLLCT="LC")!(ORCOLLCT="I") S X=$G(ORTEST("Lab CollSamp")) G SAMPQ 48 S X=$G(ORTEST("Unique CollSamp")) G:X SAMPQ 49 S X=$G(ORTEST("Default CollSamp")) 50 SAMPQ S Y=+$G(ORTEST("CollSamp",+X)) 51 Q Y 52 ; 53 ENSAMP ; -- Get list of samples to pick from 54 Q:$G(ORDIALOG(PROMPT,"LIST")) N I,CNT,X,Y S (I,CNT)=0 55 F S I=$O(ORTEST("CollSamp",I)) Q:I'>0 S X=$G(ORTEST("CollSamp",I)) D 56 . S Y=$P(X,U,1,2)_" "_$$GET1^DIQ(61,+$P(X,U,3)_",",.01)_" "_$P(X,U,4) 57 . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=Y 58 . S ORDIALOG(PROMPT,"LIST","B",$P(X,U,2))=+X 59 S:CNT ORDIALOG(PROMPT,"LIST")=CNT_$S($$SECTION'="MI":"^1",1:"") 60 Q 61 ; 62 ASKSAMP() ; -- Ask for Collection Sample? 63 N X,Y,DIR,DEFSAMP,SAMP0 64 S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0)) 65 I $G(ORTYPE)="Z",DEFSAMP Q 1 66 I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) W !!,"Lab will collect "_$P(SAMP0,U)_" "_$P(SAMP0,U,3)_".",! Q 0 67 I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask 68 I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask 69 I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice 70 S DIR(0)="YA",DIR("A")="Is "_$P(SAMP0,U)_" "_$P(SAMP0,U,3)_" the correct sample to collect? ",DIR("B")="Yes" 71 D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q 0 72 D:'Y LIST^ORCD 73 Q 'Y 74 ; 75 SECTION() ; -- Returns Lab section of Orderable Item 76 N PTR,X 77 S PTR=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) 78 S X=$P($G(^ORD(101.43,+$G(ORDIALOG(PTR,1)),"LR")),U,6) 79 Q X 80 ; 81 SHOWCOMM(SAMP) ; -- Show comments for sample 82 Q:'$G(SAMP) Q:'$G(ORTEST) N ORCOMM,I 83 D SCOM^LR7OR3(+ORTEST,SAMP,.ORCOMM) 84 S I=0 F S I=$O(ORCOMM(I)) Q:I'>0 W !,ORCOMM(I,0) 85 Q 86 ; 87 SPECIMEN() ; -- Get default specimen from Sample for INST 88 N X,Y I $L($G(LRFSPEC)) S Y=LRFSPEC 89 E S X=$$VAL^ORCD("COLLECTION SAMPLE"),Y=+$P($G(^LAB(62,+X,0)),U,2) 90 Q Y 91 ; 92 SPECHELP ; -- Xecutable help for Specimen prompt 93 I '$D(^LAB(61,"E")) D P^ORCDLGH Q 94 W !,"Choose from: " 95 N SP,I,DONE,CNT S (CNT,DONE)=0,SP="" 96 F S SP=$O(^LAB(61,"E",SP)) Q:SP="" S I=+$O(^(SP,0)) I I D 97 . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE^ORCD S DONE=1 Q 98 . W !," "_$P($G(^LAB(61,I,0)),U) 99 Q 100 ; 101 URGENCY ; -- Get list of urgencies to pick from 102 Q:$D(ORDIALOG(PROMPT,"LIST")) N I,J,X 103 I $G(ORTEST("Default Urgency")) S ORDIALOG(PROMPT,"LIST")="1^1",ORDIALOG(PROMPT,"LIST",1)=ORTEST("Default Urgency") Q ; Forced Urgency 104 I '$D(ORTEST("Urgencies")) S ORDIALOG(PROMPT,"LIST")="0^1" Q 105 S (I,J)=0 F S I=$O(ORTEST("Urgencies",I)) Q:I'>0 D 106 . S X=ORTEST("Urgencies",I) I $G(ORCOLLCT)="LC",'$P($G(^LAB(62.05,+X,0)),U,2) Q ; Lab cannot collect 107 . S J=J+1,ORDIALOG(PROMPT,"LIST",J)=X,ORDIALOG(PROMPT,"LIST","B",$P(X,U,2))=+X 108 S ORDIALOG(PROMPT,"LIST")=J_"^1" 109 Q 110 ; 111 ASKURG() ; -- Ask urgency prompt? 112 I $G(ORTEST("Default Urgency")) Q 0 ; Forced Urgency 113 I FIRST,$G(ORL) Q $$GET^XPAR("ALL^"_ORL,"LR ASK URGENCY") 114 Q (+$G(ORDIALOG(PROMPT,"LIST"))>1) 115 ; 116 REQDCOMM() ; -- Process required comments 117 I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 0 ;edit as WP 118 N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM 119 S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN") 120 S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0)) 121 S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6) 122 S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19) Q:'REQDCOMM 1 123 I $G(ORTYPE)="Z",$P($G(^LAB(62.07,+REQDCOMM,0)),U)'="ORDER COMMENT" Q 1 124 X:$D(^LAB(62.07,REQDCOMM,.1)) ^(.1) 125 S (CNT,I)=0 K REQDCOMM 126 F S I=$O(LRTCOM(LRTEST(1),I)) Q:I'>0 S CNT=CNT+1,REQDCOMM(CNT,0)=LRTCOM(LRTEST(1),I) 127 S:$L($G(LRCCOM)) CNT=CNT+1,REQDCOMM(CNT,0)=LRCCOM 128 I CNT S REQDCOMM(0)="^^"_CNT_U_CNT_U_DT_U_U,ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_")" M ^TMP("ORWORD",$J,PROMPT,INST)=REQDCOMM 129 RQ Q 1 130 ; 131 XHELP(PTR) ; -- Xecutable help 132 I $D(ORDIALOG(PTR,"LIST")),X="?"!$P(ORDIALOG(PTR,"LIST"),U,2) D LIST^ORCD Q 133 D P^ORCDLGH ; ??-help 134 Q 135 ; 136 CHANGED(FLD) ; -- Kill dependent values when FLD changes 137 N PROMPTS,P,NAME,PTR K ORCOLLCT 138 S PROMPTS="COLLECTION SAMPLE^SPECIMEN^WORD PROCESSING 1^START DATE/TIME" 139 S:FLD="OI" PROMPTS="COLLECTION TYPE^"_PROMPTS_"^LAB URGENCY" 140 F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P),PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) I PTR K ORDIALOG(PTR,ORI),ORDIALOG(PTR,"LIST") 141 Q 142 ; 143 LB(ORDER) ; -- Returns 1 or 0, if "LB #" is already in text 144 N I,Y S I=0,Y=0 145 F S I=$O(^OR(100,+ORDER,1,I)) Q:I'>0 I $G(^(I,0))["LB #" S Y=1 Q 146 Q Y 147 ; 148 DATE(X) ; Free text input to FM time 149 N %DT,Y 150 D ^%DT 151 Q Y 152 ; 153 XSCH ; -- xecutable help for schedule prompt 154 N X,IFN,CNT,Z,DONE 155 K ^TMP($J,"ORSCLR XSCH") 156 D AP^PSS51P1("LR",,,,"ORSCLR XSCH") 157 W !!,"Choose from:" S CNT=1 158 S X="" F S X=$O(^TMP($J,"ORSCLR XSCH","APLR",X)) Q:X="" S IFN=0 D Q:$G(DONE) 159 .;S X="" F S X=$O(^PS(51.1,"APLR",X)) Q:X="" S IFN=0 D Q:$G(DONE) 160 . F S IFN=$O(^TMP($J,"ORSCLR XSCH","APLR",X,IFN)) Q:IFN'>0 D Q:$G(DONE) 161 . .;F S IFN=$O(^PS(51.1,"APLR",X,IFN)) Q:IFN'>0 D Q:$G(DONE) 162 .. W !," "_X S CNT=CNT+1 Q:CNT'>(IOSL-5) S CNT=0 163 .. W !," '^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1 164 W ! 165 K ^TMP($J,"ORSCLR XSCH") 166 Q 167 ; 168 MULT(ORIFN,CTYPE,CDATE) ;check multiple orders from VALID^ORCDLR1 169 N KID,OREVENT,ORSTRT,OK,X,Y,%DT 170 I '$D(CTYPE) S CTYPE=$$VALUE^ORCSAVE2(ORIFN,"COLLECT") 171 Q:"SPWC"[CTYPE 0 ; only check LC and I 172 I '$D(CDATE) S CDATE=$$VALUE^ORCSAVE2(ORIFN,"START") 173 D AM^ORCSAVE2:CDATE="AM",NEXT^ORCSAVE2:CDATE="NEXT" ; returns X 174 S %DT="T" S:'$D(X) X=CDATE D ^%DT I Y<1 Q 0 175 D SCHEDULE^ORCSEND1(ORIFN,"LR",.ORSTRT,Y) Q:ORSTRT'>1 0 ; get all starts 176 S KID=0,OK=1 F S KID=$O(ORSTRT(KID)) Q:'KID!('OK) D 177 . I CTYPE="LC" S OK=$$LABCOLL^ORCDLR1(KID) Q 178 . S OK=$$IMMCOLL^ORCDLR1(KID) 179 I OK Q 0 180 Q "1^One or more of the multiple orders will be changed to Ward Collect" 1 ORCDLR ;SLC/MKB-Utility functions for LR dialogs ;6/11/97 11:47 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,71,79,175**;Dec 17, 1997 3 TEST ; -- Setup ORTEST() array of ordering parameters 4 N OI,TST,WRD,I,DG 5 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI 6 I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST 7 S WRD="GenWardInstructions" I $O(ORTEST(WRD,0)) D W ! 8 . W ! S I=0 F S I=$O(ORTEST(WRD,I)) Q:I'>0 W !,ORTEST(WRD,I,0) 9 S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB" 10 S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG 11 Q 12 ; 13 CKTYP ; -- ck type of test [Exit Action] 14 N X,Y S X=$G(ORDIALOG(PROMPT,INST)) Q:'X 15 S Y=$P($G(^ORD(101.43,+X,"LR")),U,7) 16 I (Y="O")!(Y="N") W $C(7),!,"This test may not be ordered anymore. Please select another test." S ORQUIT=1 D WAIT Q 17 Q 18 ; 19 WAIT ; -- Wait for user 20 N X W !,"Press <return> to continue ..." R X:DTIME 21 Q 22 ; 23 SHOWMAX ; -- Setup max days allowed for cont orders 24 I $S('$G(ORSCH):1,"CD"'[$P($G(^PS(51.1,+ORSCH,0)),U,5):1,1:0) K ORDIALOG(PROMPT,INST) Q ;just in case 25 N Y,OK S ORSMAX=$P($G(^PS(51.1,ORSCH,0)),U,7),ORSTMS=$P($G(^(0)),U,3) 26 S ORSMAX=$S('$G(ORSMAX):ORMAX,$G(ORTYPE)="Z":ORSMAX,ORMAX<ORSMAX:ORMAX,1:ORSMAX),ORSTMS=$S(ORSMAX&ORSTMS:ORSMAX*1440\ORSTMS,1:"") ;set max days, times 27 I FIRST,$G(ORTYPE)="Q" S Y=$G(ORDIALOG(PROMPT,INST)) I $L(Y) S OK=$$CKMAX(Y) Q:OK K ORDIALOG(PROMPT,INST) ;Q if valid, else fall thru and prompt 28 W !!,"Maximum number of days for continuous orders is "_ORSMAX_"; enter a duration",!,"as either a number of days (3) or Xnumber of times (X3).",! 29 Q 30 ; 31 CKMAX(X) ; -- Ck duration X against max allowed 32 N Y S Y=1 33 I +X=X S Y=$S(X<0:"0^Cannot order in the past.",'ORSMAX:1,X'>ORSMAX:1,1:"0^Cannot order more than "_ORSMAX_" days in advance.") G CKQ 34 I (X'?1"X"1.N),(X'?1"x"1.N) S Y="0^Enter either a number of days or X_number of times." G CKQ 35 I ORSTMS,+$E(X,2,9)>ORSTMS S Y="0^Cannot order more than "_ORSTMS_" time* s." G CKQ 36 I 'ORSTMS,+$E(X,2,9)>ORSMAX S Y="0^Cannot order for more than "_ORSMAX_" days." G CKQ ; day of week schedule 37 S Y=1 38 CKQ Q Y 39 ; 40 SAMPLE() ; -- Get default sample from Test for INST 41 N X,Y I $L($G(LRFSAMP)) Q LRFSAMP 42 I (ORCOLLCT="LC")!(ORCOLLCT="I") S X=$G(ORTEST("Lab CollSamp")) G SAMPQ 43 S X=$G(ORTEST("Unique CollSamp")) G:X SAMPQ 44 S X=$G(ORTEST("Default CollSamp")) 45 SAMPQ S Y=+$G(ORTEST("CollSamp",+X)) 46 Q Y 47 ; 48 ENSAMP ; -- Get list of samples to pick from 49 Q:$G(ORDIALOG(PROMPT,"LIST")) N I,CNT,X,Y S (I,CNT)=0 50 F S I=$O(ORTEST("CollSamp",I)) Q:I'>0 S X=$G(ORTEST("CollSamp",I)) D 51 . S Y=$P(X,U,1,2)_" "_$$GET1^DIQ(61,+$P(X,U,3)_",",.01)_" "_$P(X,U,4) 52 . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=Y 53 . S ORDIALOG(PROMPT,"LIST","B",$P(X,U,2))=+X 54 S:CNT ORDIALOG(PROMPT,"LIST")=CNT_$S($$SECTION'="MI":"^1",1:"") 55 Q 56 ; 57 ASKSAMP() ; -- Ask for Collection Sample? 58 N X,Y,DIR,DEFSAMP,SAMP0 59 S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0)) 60 I $G(ORTYPE)="Z",DEFSAMP Q 1 61 I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) W !!,"Lab will collect "_$P(SAMP0,U)_" "_$P(SAMP0,U,3)_".",! Q 0 62 I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask 63 I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask 64 I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice 65 S DIR(0)="YA",DIR("A")="Is "_$P(SAMP0,U)_" "_$P(SAMP0,U,3)_" the correct sample to collect? ",DIR("B")="Yes" 66 D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q 0 67 D:'Y LIST^ORCD 68 Q 'Y 69 ; 70 SECTION() ; -- Returns Lab section of Orderable Item 71 N PTR,X 72 S PTR=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) 73 S X=$P($G(^ORD(101.43,+$G(ORDIALOG(PTR,1)),"LR")),U,6) 74 Q X 75 ; 76 SHOWCOMM(SAMP) ; -- Show comments for sample 77 Q:'$G(SAMP) Q:'$G(ORTEST) N ORCOMM,I 78 D SCOM^LR7OR3(+ORTEST,SAMP,.ORCOMM) 79 S I=0 F S I=$O(ORCOMM(I)) Q:I'>0 W !,ORCOMM(I,0) 80 Q 81 ; 82 SPECIMEN() ; -- Get default specimen from Sample for INST 83 N X,Y I $L($G(LRFSPEC)) S Y=LRFSPEC 84 E S X=$$VAL^ORCD("COLLECTION SAMPLE"),Y=+$P($G(^LAB(62,+X,0)),U,2) 85 Q Y 86 ; 87 SPECHELP ; -- Xecutable help for Specimen prompt 88 I '$D(^LAB(61,"E")) D P^ORCDLGH Q 89 W !,"Choose from: " 90 N SP,I,DONE,CNT S (CNT,DONE)=0,SP="" 91 F S SP=$O(^LAB(61,"E",SP)) Q:SP="" S I=+$O(^(SP,0)) I I D 92 . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE^ORCD S DONE=1 Q 93 . W !," "_$P($G(^LAB(61,I,0)),U) 94 Q 95 ; 96 URGENCY ; -- Get list of urgencies to pick from 97 Q:$D(ORDIALOG(PROMPT,"LIST")) N I,J,X 98 I $G(ORTEST("Default Urgency")) S ORDIALOG(PROMPT,"LIST")="1^1",ORDIALOG(PROMPT,"LIST",1)=ORTEST("Default Urgency") Q ; Forced Urgency 99 I '$D(ORTEST("Urgencies")) S ORDIALOG(PROMPT,"LIST")="0^1" Q 100 S (I,J)=0 F S I=$O(ORTEST("Urgencies",I)) Q:I'>0 D 101 . S X=ORTEST("Urgencies",I) I $G(ORCOLLCT)="LC",'$P($G(^LAB(62.05,+X,0)),U,2) Q ; Lab cannot collect 102 . S J=J+1,ORDIALOG(PROMPT,"LIST",J)=X,ORDIALOG(PROMPT,"LIST","B",$P(X,U,2))=+X 103 S ORDIALOG(PROMPT,"LIST")=J_"^1" 104 Q 105 ; 106 ASKURG() ; -- Ask urgency prompt? 107 I $G(ORTEST("Default Urgency")) Q 0 ; Forced Urgency 108 I FIRST,$G(ORL) Q $$GET^XPAR("ALL^"_ORL,"LR ASK URGENCY") 109 Q (+$G(ORDIALOG(PROMPT,"LIST"))>1) 110 ; 111 REQDCOMM() ; -- Process required comments 112 I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 0 ;edit as WP 113 N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM 114 S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN") 115 S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0)) 116 S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6) 117 S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19) Q:'REQDCOMM 1 118 I $G(ORTYPE)="Z",$P($G(^LAB(62.07,+REQDCOMM,0)),U)'="ORDER COMMENT" Q 1 119 X:$D(^LAB(62.07,REQDCOMM,.1)) ^(.1) 120 S (CNT,I)=0 K REQDCOMM 121 F S I=$O(LRTCOM(LRTEST(1),I)) Q:I'>0 S CNT=CNT+1,REQDCOMM(CNT,0)=LRTCOM(LRTEST(1),I) 122 S:$L($G(LRCCOM)) CNT=CNT+1,REQDCOMM(CNT,0)=LRCCOM 123 I CNT S REQDCOMM(0)="^^"_CNT_U_CNT_U_DT_U_U,ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_")" M ^TMP("ORWORD",$J,PROMPT,INST)=REQDCOMM 124 RQ Q 1 125 ; 126 XHELP(PTR) ; -- Xecutable help 127 I $D(ORDIALOG(PTR,"LIST")),X="?"!$P(ORDIALOG(PTR,"LIST"),U,2) D LIST^ORCD Q 128 D P^ORCDLGH ; ??-help 129 Q 130 ; 131 CHANGED(FLD) ; -- Kill dependent values when FLD changes 132 N PROMPTS,P,NAME,PTR K ORCOLLCT 133 S PROMPTS="COLLECTION SAMPLE^SPECIMEN^WORD PROCESSING 1^START DATE/TIME" 134 S:FLD="OI" PROMPTS="COLLECTION TYPE^"_PROMPTS_"^LAB URGENCY" 135 F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P),PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) I PTR K ORDIALOG(PTR,ORI),ORDIALOG(PTR,"LIST") 136 Q 137 ; 138 LB(ORDER) ; -- Returns 1 or 0, if "LB #" is already in text 139 N I,Y S I=0,Y=0 140 F S I=$O(^OR(100,+ORDER,1,I)) Q:I'>0 I $G(^(I,0))["LB #" S Y=1 Q 141 Q Y 142 ; 143 DATE(X) ; Free text input to FM time 144 N %DT,Y 145 D ^%DT 146 Q Y 147 ; 148 XSCH ; -- xecutable help for schedule prompt 149 N X,IFN,CNT,Z,DONE 150 W !!,"Choose from:" S CNT=1 151 S X="" F S X=$O(^PS(51.1,"APLR",X)) Q:X="" S IFN=0 D Q:$G(DONE) 152 . F S IFN=$O(^PS(51.1,"APLR",X,IFN)) Q:IFN'>0 D Q:$G(DONE) 153 .. W !," "_X S CNT=CNT+1 Q:CNT'>(IOSL-5) S CNT=0 154 .. W !," '^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1 155 W ! 156 Q 157 ; 158 MULT(ORIFN,CTYPE,CDATE) ;check multiple orders from VALID^ORCDLR1 159 N KID,OREVENT,ORSTRT,OK,X,Y,%DT 160 I '$D(CTYPE) S CTYPE=$$VALUE^ORCSAVE2(ORIFN,"COLLECT") 161 Q:"SPWC"[CTYPE 0 ; only check LC and I 162 I '$D(CDATE) S CDATE=$$VALUE^ORCSAVE2(ORIFN,"START") 163 D AM^ORCSAVE2:CDATE="AM",NEXT^ORCSAVE2:CDATE="NEXT" ; returns X 164 S %DT="T" S:'$D(X) X=CDATE D ^%DT I Y<1 Q 0 165 D SCHEDULE^ORCSEND1(ORIFN,"LR",.ORSTRT,Y) Q:ORSTRT'>1 0 ; get all starts 166 S KID=0,OK=1 F S KID=$O(ORSTRT(KID)) Q:'KID!('OK) D 167 . I CTYPE="LC" S OK=$$LABCOLL^ORCDLR1(KID) Q 168 . S OK=$$IMMCOLL^ORCDLR1(KID) 169 I OK Q 0 170 Q "1^One or more of the multiple orders will be changed to Ward Collect" -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLR1.m
r613 r623 1 ORCDLR1 ;SLC/MKB,JFR - Utility fcns for LR dialogs cont ;8/29/02 14:45 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,79,141,143,243**;Dec 17, 1997;Build 242 3 ; 4 EN ; -- Entry Action for LR OTHER LAB TESTS order dialog 5 D GETIMES S ORMAX=0 6 S:$G(ORL) ORMAX=$$GET^XPAR("LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q") 7 Q 8 ; 9 EX ; -- Exit Action for order dialog 10 K ORTIME,ORCOLLCT,ORMAX,ORTEST,ORDIV,ORIMTIME,ORSMAX,ORSTMS,ORSCH,ORCAT 11 I $G(ORXL) S ORL=ORXL K ORXL 12 Q 13 ; 14 GETIMES ; -- Set list of routine collections into ORTIME($H)=FMtime 15 N I,X,CNT,ON K ORTIME 16 I '$D(VALIDT) D 17 . S I=$$PTR^ORCD("OR GTX START DATE/TIME"),X=$P(ORDIALOG(I,0),U,2) 18 . S X="T::ETX",$P(ORDIALOG(I,0),U,2)=X ; reset lower bound 19 S ORDIV=+$P($G(^SC(+$G(ORL),0)),U,4) S:'ORDIV ORDIV=+$G(DUZ(2)) 20 I $G(OREVENT) S ORDIV=+$$DIV^OREVNTX(OREVENT),ORXL=$G(ORL),ORL=$$LOC^OREVNTX(OREVENT) 21 D GETLST^XPAR(.ORTIME,ORDIV_";DIC(4,","LR PHLEBOTOMY COLLECTION","N") 22 S (I,CNT)=0 F S I=$O(ORTIME(I)) Q:I'>0 S CNT=CNT+1,X=$P(ORTIME(I),U),ORTIME(I)=X,ORTIME("B",+("."_X))=I ; ORTIME($H time)=0000 FM time, ORTIME("B",.0000)=$H time of cut-off 23 S ORTIME=CNT,I=$O(ORTIME(0)) S:I ORTIME("AM")=ORTIME(I) ; 1st collection 24 S I=$O(ORTIME($P($H,",",2))) S:I ORTIME("NEXT")=ORTIME(I) ;NEXT coll 25 S ON=$$ON^LR7OV4(ORDIV) D:ON SHOW^LR7OV4(ORDIV,.ORIMTIME) 26 I 'ON,'$D(VALIDT) S I=$$PTR^ORCD("OR GTX COLLECTION TYPE"),X=$P(ORDIALOG(I,0),U,2),$P(ORDIALOG(I,0),U,2)=$P(X,";",1,3) ;Remove Immed if '$$ON 27 Q 28 ; 29 DEFTIME() ; -- Returns default collection time 30 I $L($G(LRFDATE)) S EDITONLY=1 Q LRFDATE 31 I '$D(ORCOLLCT) Q "" 32 N Y S Y="" I $D(^TMP("ORECALL",$J,ORDIALOG,PROMPT)) D Q:$L(Y) Y 33 . S Y=$$RECALL^ORCD(PROMPT) 34 . I '$S(ORCOLLCT="LC":$$LABCOLL(Y),ORCOLLCT="I":$$IMMCOLL(Y),1:$$CKDATE(Y)) S Y="" Q 35 . S EDITONLY=1 36 ;I $G(ORTYPE)="Q" Q $S(ORCOLLCT="LC":"AM",1:"") 37 D LIST^ORCD:ORCOLLCT="LC"&$G(ORDIALOG(PROMPT,"LIST")) 38 D IMMTIMES:ORCOLLCT="I"&$O(ORIMTIME(0)) 39 Q $S(ORCOLLCT="LC":"NEXT",ORCOLLCT="I":$$IMMDEF,ORCOLLCT="WC":"NOW",1:"TODAY") 40 ; 41 IMMDEF() ; -- Returns immediate collect default 42 N X,Y S X=$$DEFTIME^LR7OV4(ORDIV) 43 S Y=$S($P(X,U,3):"NOW+"_$P(X,U,3)_"'",1:$P(X,U)) 44 Q Y 45 ; 46 COLLTIME ; -- Get list of common collection times 47 I ORCOLLCT="I" D:'$D(ORIMTIME) SHOW^LR7OV4(ORDIV,.ORIMTIME) 48 I ORCOLLCT'="LC" K ORDIALOG(PROMPT,"LIST") Q 49 Q:$G(ORDIALOG(PROMPT,"LIST")) Q:'$O(ORTIME(0)) 50 N I,X,CNT,NEXT,DAY,NOW S NOW=$P($H,",",2) 51 S NEXT=$O(ORTIME(NOW)),DAY=$$NEXTCOLL($S(NEXT:"T",1:"T+1")) Q:DAY="" 52 S:'NEXT!(DAY["+") NEXT=$O(ORTIME(0)) 53 S CNT=1,ORDIALOG(PROMPT,"LIST",1)="NEXT^NEXT Lab collection ("_DAY_"@"_$$TIME(ORTIME(NEXT))_")",ORDIALOG(PROMPT,"LIST","B","NEXT LAB COLLECTION")="NEXT" 54 S ORDIALOG(PROMPT,"LIST","B","AM LAB COLLECTION")="AM" 55 G:ORTIME'>1 CTMQ ; only NEXT 56 S I=NEXT F S I=$O(ORTIME(I)) Q:I'>0 S X=DAY_"@"_$$TIME(ORTIME(I)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")",ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X 57 I NEXT>$O(ORTIME(0)) D ;add morning times before NEXT to T+1 58 . S DAY="T+"_(+$P(DAY,"+",2)+1),DAY=$$NEXTCOLL(DAY),I=$O(ORTIME(0)) 59 . S X=DAY_"@"_$$TIME(ORTIME("AM")),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)="AM^AM Lab collection ("_X_")" 60 . F S I=$O(ORTIME(I)) Q:(I'>0)!(I'<NEXT) S X=DAY_"@"_$$TIME(ORTIME(I)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")",ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X 61 CTMQ S ORDIALOG(PROMPT,"LIST")=CNT 62 Q 63 ; 64 NEXTCOLL(START) ; -- Returns the next day that routine lab collects are done 65 N X,Y,%DT,OFFSET,ORDAYS,PARAM I '$O(ORTIME(0)) Q "" ; no Lab collect 66 S:'$D(START) START="T" S OFFSET=+$P(START,"+",2),START=$P(START,"+") 67 F ORDAYS=1:1:7 D Q:$D(X) S OFFSET=OFFSET+1 ; ck up to a week 68 . S %DT="X",X=START_$S(OFFSET:"+"_OFFSET,1:"") 69 . D ^%DT I Y'>0 K X Q 70 . I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q 71 . S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(Y)) 72 . I '$$GET^XPAR("ALL",PARAM) K X Q 73 . I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY($P(Y,"."))) K X Q 74 S Y=$S($D(X):X,1:"") 75 Q Y 76 ; 77 TIME(X) ; -- Returns 00:00AM from 0000 FileMan time 78 N HOUR,MIN,XM,Y 79 S HOUR=$E(X,1,2),MIN=$E(X,3,4),XM="AM" 80 I HOUR'<12 S XM="PM" S:HOUR>12 HOUR=HOUR-12 81 S:$E(HOUR)="0" HOUR=$E(HOUR,2) ; strip leading 0 82 S Y=HOUR_":"_MIN_XM 83 Q Y 84 ; 85 LISTCOLL ; -- Lists the routine collection times for ??-help 86 I '$O(ORTIME(0)) W !,"No routine lab collection times defined." Q 87 N I,X S I=0,X="" 88 F S I=$O(ORTIME(I)) Q:I'>0 S X=X_$S($L(X):", ",1:"")_$$TIME(ORTIME(I)) 89 W !,"Routine collection times are "_X_"." 90 W !,"You may also enter AM for the morning collection, or NEXT for the next",!,"routine collection time." 91 Q 92 ; 93 IMMTIMES ; -- Show the valid date/times for immediate collect 94 N I S I=0 95 F S I=$O(ORIMTIME(I)) Q:I'>0 W !,ORIMTIME(I) 96 Q 97 ; 98 CKDATE(X) ; -- Valid coll time for SP or WC? 99 S X=$$UP^XLFSTR(X) I ("NOW"[X)!("TODAY"[X) Q 1 100 I X?1"T+"1.3N,+$P(X,"+",2)'>370 Q 1 101 N Y,%DT,D 102 I X'?7N.1".".6N S %DT="TX" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time" 103 S D=$P(X,".") I D<DT Q "0^Cannot order for past days" 104 I $P(X,".",2),X<$$NOW^XLFDT,'$G(OREVENT),$G(ORTYPE)'="Z" Q "0^The requested collection time has passed" 105 I D>$$FMADD^XLFDT(DT,370) Q "0^Cannot order more than 370 days in advance" 106 Q 1 107 ; 108 IMMCOLL(X) ; -- Valid immediate collection date/time? 109 I X?1"NOW+"1.N1"'" Q 1 110 I X'?7N.1".".6N N Y,%DT S %DT="T" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time" 111 Q $$VALID^LR7OV4(ORDIV,X) 112 ; 113 LABCOLL(ORXTIM) ; -- Valid lab collection date/time? 114 ; Returns valid flag of 1 or 0^message 115 N I,X,Y,%DT,ORD,ORT,PARAM,ORDY 116 I '$O(ORTIME(0)) Q "0^There are no lab collection times defined!" 117 I (ORXTIM="AM")!(ORXTIM="NEXT") Q 1 118 I ORXTIM'?7N.1".".6N S %DT="T",X=ORXTIM D ^%DT S:Y>0 ORXTIM=Y I Y'>0 Q "0^Invalid date/time" 119 ;I ORXTIM?1"V".E S T="."_$P(ORXTIM,"@",2) G D1 ; Visit - ignore day (D ^%DT ??) 120 S ORD=$P(ORXTIM,"."),ORT="."_$P(ORXTIM,".",2) 121 S:ORT="." ORT=+("."_$G(ORTIME("AM"))) 122 I '$D(ORTIME("B",ORT)) Q "0^Invalid lab collection time" 123 LC1 ; -- check date 124 I ORD<DT Q "0^Can not order for past days." 125 I ORXTIM<$$NOW^XLFDT,'$G(OREVENT) Q "0^Cannot order in the past" 126 I $G(ORTYPE)'="Z",'$G(OREVENT),ORD=DT,$P($H,",",2)>ORTIME("B",ORT) Q "0^The cut-off time for this collection has passed" 127 S ORDY=7 I $D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE")),$G(ORL) S ORDY=+$$GET^XPAR("ALL^DIV.`"_ORDIV_"^LOC.`"_+ORL,"LR LAB COLLECT FUTURE",1,"I") 128 I ORXTIM>$$FMADD^XLFDT($$NOW^XLFDT,ORDY) Q "0^Cannot order a lab collection more than "_ORDY_" days in advance" 129 I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q 1 130 S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(ORD)) 131 I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL",PARAM) Q "0^There are no lab collections that day" 132 I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY(ORD)) Q "0^There are no lab collections on holidays" 133 Q 1 134 ; 135 LABSAMP() ; -- Lab Collect sample? 136 N X,Y S X=+$$VAL^ORCD("COLLECTION SAMPLE"),Y=$P($G(^LAB(62,X,0)),U,7) 137 Q Y 138 ; 139 COLLTYPE() ; -- Returns default collection type 140 N Y I $G(ORTYPE)="Z" S Y="" G CTQ 141 I $L($G(LRFZX)) S Y=LRFZX,EDITONLY=1 G CTQ 142 I $D(^TMP("ORECALL",$J,+ORDIALOG,PROMPT)) D G CTQ 143 . S Y=$$RECALL^ORCD(PROMPT),EDITONLY=1 144 S:$G(ORL) Y=$$GET^XPAR("ALL^"_ORL,"LR DEFAULT TYPE QUICK") 145 I '$L($G(Y)) S Y=$S('$$INPT^ORCD:"SP",$G(ORTYPE)="Q":"LC",1:"WC") 146 CTQ I Y="I",'$O(ORIMTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC" 147 I Y="LC",'$O(ORTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC" 148 ;S:$G(ORTYPE)="Q" EDITONLY=1 149 I '(FIRST&EDITONLY) D HELPTYPE 150 Q Y 151 ; 152 CKTYPE ; -- Valid type for time, sample? 153 I Y="LC",'$O(ORTIME(0)) W $C(7),!,"There are no lab collection times defined!" K DONE Q 154 I Y="I",'$O(ORIMTIME(0)) W $C(7),!,"There are no immediate collection times defined!" K DONE Q 155 I (Y="LC"!(Y="I")),'$G(ORTEST("Lab CollSamp")) W $C(7),!,"There is no lab collection sample defined for this test!",! K DONE Q 156 I $D(ORESET),ORESET'=Y,("ILC"[ORESET)!("ILC"[Y) D CHANGED^ORCDLR("TYPE") K ORDIALOG($$PTR^ORCD("OR GTX LAB URGENCY"),"LIST") 157 Q 158 ; 159 HELPTYPE ; -- Xecutable help for Coll Type 160 W !!,"SEND TO LAB - Means the patient is ambulatory and will be sent to the",!,"Laboratory draw room to have blood drawn." 161 W !,"WARD COLLECT - Means that either the physician or a nurse will be collecting",!,"the sample on the ward." 162 W !,"LAB BLOOD TEAM - Means the phlebotomist from Lab will draw the blood on the",!,"ward. This method is limited to laboratory defined collection times." 163 W:$$ON^LR7OV4(ORDIV) !,"IMMEDIATE COLLECT BY BLOOD TEAM - Means the phlebotomist from Lab is on",!,"call to draw blood on the ward. This method is available during times",!,"defined by Laboratory." W ! 164 N DOMAIN S DOMAIN=$P(ORDIALOG(PROMPT,0),U,2) D SETLST1^ORCD 165 Q 166 VALID(ORDER) ;check collection time on release 167 N VALIDT,OREVENT,COLLTYPE,COLLDT,OK,ORDIV,ORTXT,ORPTLK,ORTIME,ORIMTIME,ORACT 168 S VALIDT="" D GETIMES 169 S COLLDT=$$VALUE^ORCSAVE2(ORDER,"START") 170 S COLLTYPE=$$VALUE^ORCSAVE2(ORDER,"COLLECT") 171 I $L($P(^OR(100,+ORIFN,0),U,17)) S OREVENT=$P(^(0),U,17) 172 I "NOWAMNEXT"[COLLDT D:'$G(OREVENT) MULT Q 1 ;OK 173 S OK=$S(COLLTYPE="LC":$$LABCOLL(COLLDT),COLLTYPE="I":$$IMMCOLL(COLLDT),1:$$CKDATE(COLLDT)) 174 I OK D:'$G(OREVENT) MULT Q 1 ;COLLDT passed checks 175 W !!,$C(7),$P(OK,U,2) 176 D TEXT^ORQ12(.ORTXT,ORDER) W !,$G(ORTXT(1)) K ORTXT 177 W !,"must be edited before signing/release." K VALIDT D 178 . N ORDIV,ORIMTIME,ORTIME,ORNP 179 . S ORNP=$P(^OR(100,ORDER,0),U,4) 180 . S ORACT="XX" D XX^ORCACT4 ;edit order 181 I $$VALUE^ORCSAVE2(ORDER,"START")'=COLLDT D:'$G(OREVENT) MULT Q 1 ;OK 182 Q 0 183 ; 184 MULT ; -- ck child orders 185 N CHGD S CHGD=$$MULT^ORCDLR(ORDER,COLLTYPE,COLLDT) Q:'CHGD 186 W !!,$P(CHGD,U,2) H 2 187 Q 1 ORCDLR1 ;SLC/MKB,JFR - Utility fcns for LR dialogs cont ;8/29/02 14:45 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,79,141**;Dec 17, 1997 3 ; 4 EN ; -- Entry Action for LR OTHER LAB TESTS order dialog 5 D GETIMES S ORMAX=0 6 S:$G(ORL) ORMAX=$$GET^XPAR("LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q") 7 Q 8 ; 9 EX ; -- Exit Action for order dialog 10 K ORTIME,ORCOLLCT,ORMAX,ORTEST,ORDIV,ORIMTIME,ORSMAX,ORSTMS,ORSCH,ORCAT 11 I $G(ORXL) S ORL=ORXL K ORXL 12 Q 13 ; 14 GETIMES ; -- Set list of routine collections into ORTIME($H)=FMtime 15 N I,X,CNT,ON K ORTIME 16 I '$D(VALIDT) D 17 . S I=$$PTR^ORCD("OR GTX START DATE/TIME"),X=$P(ORDIALOG(I,0),U,2) 18 . S X="T::ETX",$P(ORDIALOG(I,0),U,2)=X ; reset lower bound 19 S ORDIV=+$P($G(^SC(+$G(ORL),0)),U,4) S:'ORDIV ORDIV=+$G(DUZ(2)) 20 I $G(OREVENT) S ORDIV=+$$DIV^OREVNTX(OREVENT),ORXL=$G(ORL),ORL=$$LOC^OREVNTX(OREVENT) 21 D GETLST^XPAR(.ORTIME,ORDIV_";DIC(4,","LR PHLEBOTOMY COLLECTION","N") 22 S (I,CNT)=0 F S I=$O(ORTIME(I)) Q:I'>0 S CNT=CNT+1,X=$P(ORTIME(I),U),ORTIME(I)=X,ORTIME("B",+("."_X))=I ; ORTIME($H time)=0000 FM time, ORTIME("B",.0000)=$H time of cut-off 23 S ORTIME=CNT,I=$O(ORTIME(0)) S:I ORTIME("AM")=ORTIME(I) ; 1st collection 24 S I=$O(ORTIME($P($H,",",2))) S:I ORTIME("NEXT")=ORTIME(I) ;NEXT coll 25 S ON=$$ON^LR7OV4(ORDIV) D:ON SHOW^LR7OV4(ORDIV,.ORIMTIME) 26 I 'ON,'$D(VALIDT) S I=$$PTR^ORCD("OR GTX COLLECTION TYPE"),X=$P(ORDIALOG(I,0),U,2),$P(ORDIALOG(I,0),U,2)=$P(X,";",1,3) ;Remove Immed if '$$ON 27 Q 28 ; 29 DEFTIME() ; -- Returns default collection time 30 I $L($G(LRFDATE)) S EDITONLY=1 Q LRFDATE 31 N Y S Y="" I $D(^TMP("ORECALL",$J,ORDIALOG,PROMPT)) D Q:$L(Y) Y 32 . S Y=$$RECALL^ORCD(PROMPT) 33 . I '$S(ORCOLLCT="LC":$$LABCOLL(Y),ORCOLLCT="I":$$IMMCOLL(Y),1:$$CKDATE(Y)) S Y="" Q 34 . S EDITONLY=1 35 ;I $G(ORTYPE)="Q" Q $S(ORCOLLCT="LC":"AM",1:"") 36 D LIST^ORCD:ORCOLLCT="LC"&$G(ORDIALOG(PROMPT,"LIST")) 37 D IMMTIMES:ORCOLLCT="I"&$O(ORIMTIME(0)) 38 Q $S(ORCOLLCT="LC":"NEXT",ORCOLLCT="I":$$IMMDEF,ORCOLLCT="WC":"NOW",1:"TODAY") 39 ; 40 IMMDEF() ; -- Returns immediate collect default 41 N X,Y S X=$$DEFTIME^LR7OV4(ORDIV) 42 S Y=$S($P(X,U,3):"NOW+"_$P(X,U,3)_"'",1:$P(X,U)) 43 Q Y 44 ; 45 COLLTIME ; -- Get list of common collection times 46 I ORCOLLCT="I" D:'$D(ORIMTIME) SHOW^LR7OV4(ORDIV,.ORIMTIME) 47 I ORCOLLCT'="LC" K ORDIALOG(PROMPT,"LIST") Q 48 Q:$G(ORDIALOG(PROMPT,"LIST")) Q:'$O(ORTIME(0)) 49 N I,X,CNT,NEXT,DAY,NOW S NOW=$P($H,",",2) 50 S NEXT=$O(ORTIME(NOW)),DAY=$$NEXTCOLL($S(NEXT:"T",1:"T+1")) Q:DAY="" 51 S:'NEXT!(DAY["+") NEXT=$O(ORTIME(0)) 52 S CNT=1,ORDIALOG(PROMPT,"LIST",1)="NEXT^NEXT Lab collection ("_DAY_"@"_$$TIME(ORTIME(NEXT))_")",ORDIALOG(PROMPT,"LIST","B","NEXT LAB COLLECTION")="NEXT" 53 S ORDIALOG(PROMPT,"LIST","B","AM LAB COLLECTION")="AM" 54 G:ORTIME'>1 CTMQ ; only NEXT 55 S I=NEXT F S I=$O(ORTIME(I)) Q:I'>0 S X=DAY_"@"_$$TIME(ORTIME(I)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")",ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X 56 I NEXT>$O(ORTIME(0)) D ;add morning times before NEXT to T+1 57 . S DAY="T+"_(+$P(DAY,"+",2)+1),DAY=$$NEXTCOLL(DAY),I=$O(ORTIME(0)) 58 . S X=DAY_"@"_$$TIME(ORTIME("AM")),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)="AM^AM Lab collection ("_X_")" 59 . F S I=$O(ORTIME(I)) Q:(I'>0)!(I'<NEXT) S X=DAY_"@"_$$TIME(ORTIME(I)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")",ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X 60 CTMQ S ORDIALOG(PROMPT,"LIST")=CNT 61 Q 62 ; 63 NEXTCOLL(START) ; -- Returns the next day that routine lab collects are done 64 N X,Y,%DT,OFFSET,ORDAYS,PARAM I '$O(ORTIME(0)) Q "" ; no Lab collect 65 S:'$D(START) START="T" S OFFSET=+$P(START,"+",2),START=$P(START,"+") 66 F ORDAYS=1:1:7 D Q:$D(X) S OFFSET=OFFSET+1 ; ck up to a week 67 . S %DT="X",X=START_$S(OFFSET:"+"_OFFSET,1:"") 68 . D ^%DT I Y'>0 K X Q 69 . I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q 70 . S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(Y)) 71 . I '$$GET^XPAR("ALL",PARAM) K X Q 72 . I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY($P(Y,"."))) K X Q 73 S Y=$S($D(X):X,1:"") 74 Q Y 75 ; 76 TIME(X) ; -- Returns 00:00AM from 0000 FileMan time 77 N HOUR,MIN,XM,Y 78 S HOUR=$E(X,1,2),MIN=$E(X,3,4),XM="AM" 79 I HOUR'<12 S XM="PM" S:HOUR>12 HOUR=HOUR-12 80 S:$E(HOUR)="0" HOUR=$E(HOUR,2) ; strip leading 0 81 S Y=HOUR_":"_MIN_XM 82 Q Y 83 ; 84 LISTCOLL ; -- Lists the routine collection times for ??-help 85 I '$O(ORTIME(0)) W !,"No routine lab collection times defined." Q 86 N I,X S I=0,X="" 87 F S I=$O(ORTIME(I)) Q:I'>0 S X=X_$S($L(X):", ",1:"")_$$TIME(ORTIME(I)) 88 W !,"Routine collection times are "_X_"." 89 W !,"You may also enter AM for the morning collection, or NEXT for the next",!,"routine collection time." 90 Q 91 ; 92 IMMTIMES ; -- Show the valid date/times for immediate collect 93 N I S I=0 94 F S I=$O(ORIMTIME(I)) Q:I'>0 W !,ORIMTIME(I) 95 Q 96 ; 97 CKDATE(X) ; -- Valid coll time for SP or WC? 98 S X=$$UP^XLFSTR(X) I ("NOW"[X)!("TODAY"[X) Q 1 99 I X?1"T+"1.3N,+$P(X,"+",2)'>370 Q 1 100 N Y,%DT,D 101 I X'?7N.1".".6N S %DT="TX" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time" 102 S D=$P(X,".") I D<DT Q "0^Cannot order for past days" 103 I $P(X,".",2),X<$$NOW^XLFDT,'$G(OREVENT),$G(ORTYPE)'="Z" Q "0^The requested collection time has passed" 104 I D>$$FMADD^XLFDT(DT,370) Q "0^Cannot order more than 370 days in advance" 105 Q 1 106 ; 107 IMMCOLL(X) ; -- Valid immediate collection date/time? 108 I X?1"NOW+"1.N1"'" Q 1 109 I X'?7N.1".".6N N Y,%DT S %DT="T" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time" 110 Q $$VALID^LR7OV4(ORDIV,X) 111 ; 112 LABCOLL(ORXTIM) ; -- Valid lab collection date/time? 113 ; Returns valid flag of 1 or 0^message 114 N I,X,Y,%DT,ORD,ORT,PARAM,ORDY 115 I '$O(ORTIME(0)) Q "0^There are no lab collection times defined!" 116 I (ORXTIM="AM")!(ORXTIM="NEXT") Q 1 117 I ORXTIM'?7N.1".".6N S %DT="T",X=ORXTIM D ^%DT S:Y>0 ORXTIM=Y I Y'>0 Q "0^Invalid date/time" 118 ;I ORXTIM?1"V".E S T="."_$P(ORXTIM,"@",2) G D1 ; Visit - ignore day (D ^%DT ??) 119 S ORD=$P(ORXTIM,"."),ORT="."_$P(ORXTIM,".",2) 120 S:ORT="." ORT=+("."_$G(ORTIME("AM"))) 121 I '$D(ORTIME("B",ORT)) Q "0^Invalid lab collection time" 122 LC1 ; -- check date 123 I ORD<DT Q "0^Can not order for past days." 124 I ORXTIM<$$NOW^XLFDT,'$G(OREVENT) Q "0^Cannot order in the past" 125 I $G(ORTYPE)'="Z",'$G(OREVENT),ORD=DT,$P($H,",",2)>ORTIME("B",ORT) Q "0^The cut-off time for this collection has passed" 126 S ORDY=7 I $D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE")),$G(ORL) S ORDY=+$$GET^XPAR("ALL^DIV.`"_ORDIV_"^LOC.`"_+ORL,"LR LAB COLLECT FUTURE",1,"I") 127 I ORXTIM>$$FMADD^XLFDT($$NOW^XLFDT,ORDY) Q "0^Cannot order a lab collection more than "_ORDY_" days in advance" 128 I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q 1 129 S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(ORD)) 130 I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL",PARAM) Q "0^There are no lab collections that day" 131 I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY(ORD)) Q "0^There are no lab collections on holidays" 132 Q 1 133 ; 134 LABSAMP() ; -- Lab Collect sample? 135 N X,Y S X=+$$VAL^ORCD("COLLECTION SAMPLE"),Y=$P($G(^LAB(62,X,0)),U,7) 136 Q Y 137 ; 138 COLLTYPE() ; -- Returns default collection type 139 N Y I $G(ORTYPE)="Z" S Y="" G CTQ 140 I $L($G(LRFZX)) S Y=LRFZX,EDITONLY=1 G CTQ 141 I $D(^TMP("ORECALL",$J,+ORDIALOG,PROMPT)) D G CTQ 142 . S Y=$$RECALL^ORCD(PROMPT),EDITONLY=1 143 S:$G(ORL) Y=$$GET^XPAR("ALL^"_ORL,"LR DEFAULT TYPE QUICK") 144 I '$L($G(Y)) S Y=$S('$$INPT^ORCD:"SP",$G(ORTYPE)="Q":"LC",1:"WC") 145 CTQ I Y="I",'$O(ORIMTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC" 146 I Y="LC",'$O(ORTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC" 147 ;S:$G(ORTYPE)="Q" EDITONLY=1 148 I '(FIRST&EDITONLY) D HELPTYPE 149 Q Y 150 ; 151 CKTYPE ; -- Valid type for time, sample? 152 I Y="LC",'$O(ORTIME(0)) W $C(7),!,"There are no lab collection times defined!" K DONE Q 153 I Y="I",'$O(ORIMTIME(0)) W $C(7),!,"There are no immediate collection times defined!" K DONE Q 154 I (Y="LC"!(Y="I")),'$G(ORTEST("Lab CollSamp")) W $C(7),!,"There is no lab collection sample defined for this test!",! K DONE Q 155 I $D(ORESET),ORESET'=Y,("ILC"[ORESET)!("ILC"[Y) D CHANGED^ORCDLR("TYPE") K ORDIALOG($$PTR^ORCD("OR GTX LAB URGENCY"),"LIST") 156 Q 157 ; 158 HELPTYPE ; -- Xecutable help for Coll Type 159 W !!,"SEND TO LAB - Means the patient is ambulatory and will be sent to the",!,"Laboratory draw room to have blood drawn." 160 W !,"WARD COLLECT - Means that either the physician or a nurse will be collecting",!,"the sample on the ward." 161 W !,"LAB BLOOD TEAM - Means the phlebotomist from Lab will draw the blood on the",!,"ward. This method is limited to laboratory defined collection times." 162 W:$$ON^LR7OV4(ORDIV) !,"IMMEDIATE COLLECT BY BLOOD TEAM - Means the phlebotomist from Lab is on",!,"call to draw blood on the ward. This method is available during times",!,"defined by Laboratory." W ! 163 N DOMAIN S DOMAIN=$P(ORDIALOG(PROMPT,0),U,2) D SETLST1^ORCD 164 Q 165 VALID(ORDER) ;check collection time on release 166 N VALIDT,OREVENT,COLLTYPE,COLLDT,OK,ORDIV,ORTXT,ORPTLK,ORTIME,ORIMTIME,ORACT 167 S VALIDT="" D GETIMES 168 S COLLDT=$$VALUE^ORCSAVE2(ORDER,"START") 169 S COLLTYPE=$$VALUE^ORCSAVE2(ORDER,"COLLECT") 170 I $L($P(^OR(100,+ORIFN,0),U,17)) S OREVENT=$P(^(0),U,17) 171 I "NOWAMNEXT"[COLLDT D:'$G(OREVENT) MULT Q 1 ;OK 172 S OK=$S(COLLTYPE="LC":$$LABCOLL(COLLDT),COLLTYPE="I":$$IMMCOLL(COLLDT),1:$$CKDATE(COLLDT)) 173 I OK D:'$G(OREVENT) MULT Q 1 ;COLLDT passed checks 174 W !!,$C(7),$P(OK,U,2) 175 D TEXT^ORQ12(.ORTXT,ORDER) W !,$G(ORTXT(1)) K ORTXT 176 W !,"must be edited before signing/release." K VALIDT D 177 . N ORDIV,ORIMTIME,ORTIME,ORNP 178 . S ORNP=$P(^OR(100,ORDER,0),U,4) 179 . S ORACT="XX" D XX^ORCACT4 ;edit order 180 I $$VALUE^ORCSAVE2(ORDER,"START")'=COLLDT D:'$G(OREVENT) MULT Q 1 ;OK 181 Q 0 182 ; 183 MULT ; -- ck child orders 184 N CHGD S CHGD=$$MULT^ORCDLR(ORDER,COLLTYPE,COLLDT) Q:'CHGD 185 W !!,$P(CHGD,U,2) H 2 186 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS1.m
r613 r623 1 ORCDPS1 ;SLC/MKB-Pharmacy dialog utilities ; 08 May 2002 2:12 PM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,117,141,149,195,215,243**;Dec 17, 1997;Build 242 3 ; 4 ; DBIA 2418 START^PSSJORDF ^TMP("PSJMR",$J) 5 ; DBIA 3166 EN^PSSDIN ^TMP("PSSDIN",$J) 6 ; 7 EN(TYPE) ; -- entry action for Meds dialogs 8 S ORINPT=$$INPT^ORCD,ORCAT=$G(TYPE) 9 I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location? 10 I ORCAT="" D 11 . I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT),$L($P($G(OR0),U,12)) S ORCAT=$P(OR0,U,12) Q ;use value from order, via ORCACT4 12 . S ORCAT=$S(ORINPT:"I",1:"O") 13 S ORDG=+$O(^ORD(100.98,"B",$S(ORCAT="I":"UD RX",1:"O RX"),0)) 14 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 15 I $G(ORENEW)!$G(OREWRITE)!$G(OREDIT)!$G(ORXFER) D Q:$G(ORQUIT) 16 . I 'ORINPT,ORCAT="I" D Q:$G(ORQUIT) 17 .. N OI S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1 18 .. I '$O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORQUIT=1 W $C(7),!!,"This order may not be placed at this location!" Q 19 . K ORDIALOG($$PTR("START DATE/TIME"),1) 20 . K ORDIALOG($$PTR("NOW"),1) Q:ORCAT'="O" 21 . N WP S WP=$$PTR("WORD PROCESSING 1") 22 . I '$G(ORXFER),'$$DRAFT^ORWDX2($G(ORIFN)) K ORDIALOG(WP,1),^TMP("ORWORD",$J,WP) 23 . I $G(OREDIT),'$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) K ^TMP("ORWORD",$J) 24 I ORINPT,ORCAT="O" W $C(7),!!,"NOTE: This will create an outpatient prescription for an inpatient!",! 25 Q 26 ; 27 EN1 ; -- setup Meds dialog for quick order editor using ORDG 28 N DG S DG=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) 29 I $P(DG," ")="O"!(DG="SPLY") S ORINPT=0,ORCAT="O" 30 E S ORINPT=1,ORCAT="I" 31 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 32 Q 33 ; 34 ENOI ; -- setup OI prompt 35 N D S D=$G(ORDIALOG(PROMPT,"D")) 36 S:D="S.RX" ORDIALOG(PROMPT,"D")=$S(ORCAT="I":"S.UD RX",1:"S.O RX") 37 I ORCAT="I",'ORINPT,D="S.UD RX" D ;limit to IV meds for outpt's 38 . S ORDIALOG(PROMPT,"D")="S.IVM RX" ;ORDG=+$O(^ORD(100.98,"B","O RX",0)) 39 . S ORDIALOG(PROMPT,"?")="Enter the IV medication you wish to order for this patient." 40 Q 41 ; 42 DEA ; -- ck DEA# of ordering provider if SchedII drug 43 Q:$G(ORTYPE)="Z" N DEAFLG,PSOI 44 S PSOI=+$P($G(^ORD(101.43,+$G(Y),0)),U,2) Q:PSOI'>0 45 S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,ORCAT) Q:DEAFLG'>0 ;ok 46 I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" K DONE Q 47 I DEAFLG=1 W $C(7),!,"This order will require a wet signature!" 48 Q 49 ; 50 CHANGED(X) ; -- Kill dependent values when prompt X changes 51 N PROMPTS,NAME,PTR,P,I 52 S PROMPTS=X I X="OI" D 53 . S PROMPTS="INSTRUCTIONS^ROUTE^SCHEDULE^START DATE/TIME^DURATION^AND/THEN^DOSE^DISPENSE DRUG^SIG^PATIENT INSTRUCTIONS^DAYS SUPPLY^QUANTITY^REFILLS^SERVICE CONNECTED" 54 . K ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,ORQTY,ORQTYUNT,OREFILLS,ORCOPAY 55 . K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 56 I X="DS" S PROMPTS="QUANTITY^REFILLS" K OREFILLS 57 F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D 58 . S PTR=$$PTR(NAME) Q:'PTR 59 . S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I) 60 . K ORDIALOG(PTR,"LIST"),^TMP("ORWORD",$J,PTR) 61 Q 62 ; 63 ORDITM(OI) ; -- Check OI, get dependent info 64 Q:OI'>0 ;quit - no value 65 N ORPS,ORPSOI S ORPS=$G(^ORD(101.43,+OI,"PS")),ORPSOI=+$P($G(^(0)),U,2) 66 S ORIV=$S($P(ORPS,U)=2:1,1:0) 67 I $G(ORCAT)="O",'$P(ORPS,U,2) W $C(7),!,"This drug may not be used in an outpatient order." S ORQUIT=1 D WAIT Q 68 I $G(ORCAT)="I" D Q:$G(ORQUIT) 69 . I $G(ORINPT),'$P(ORPS,U) W $C(7),!,"This drug may not be used in an inpatient order." S ORQUIT=1 D WAIT Q 70 . I '$G(ORINPT),'ORIV W $C(7),!,"This drug may not be ordered for an outpatient." S ORQUIT=1 D WAIT Q 71 I $G(ORTYPE)="Q" D I $G(ORQUIT) D WAIT Q 72 . N DEAFLG S DEAFLG=$$OIDEA^PSSUTLA1(ORPSOI,ORCAT) Q:DEAFLG'>0 ;ok 73 . I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q 74 . I DEAFLG=1 W $C(7),!,"This order will require a wet signature!" 75 OI1 ; -ck NF status 76 I $P(ORPS,U,6),'$G(ORENEW) D ;alternative 77 . W !!,"*** This medication is not in the formulary! ***" 78 . N PSX,CNT,ORX,DIR,X,Y,DTOUT,DUOUT 79 . D EN1^PSSUTIL1(.ORPSOI,ORCAT) I '$O(ORPSOI(0)) D Q 80 .. W !," There are no formulary alternatives entered for this item." 81 .. W !," Please consult with your pharmacy before ordering it." 82 . S PSX=0,CNT=0 F S PSX=$O(ORPSOI(PSX)) Q:PSX'>0 D 83 .. S ORX=+$O(^ORD(101.43,"ID",PSX_";99PSP",0)) Q:ORX'>0 84 .. S CNT=CNT+1,ORPSOI("OI",CNT)=ORX_U_PSX 85 .. S DIR("A",CNT)=$J(CNT,3)_" "_$P($G(^ORD(101.43,ORX,0)),U) 86 . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select alternative (or <return> to continue): " 87 . S DIR("?")="The medication selected is not in the formulary; you may select one of the above listed alternatives instead, or press <return> to continue processing this order." 88 . Q:CNT'>0 W !," Formulary alternatives:" D ^DIR 89 . I Y'>0 S:$D(DTOUT)!$D(DUOUT) ORQUIT=1 Q 90 . D:OI'=+ORPSOI("OI",+Y) CHANGED("OI") ;reset parameters if different 91 . S OI=+ORPSOI("OI",+Y),ORDIALOG(PROMPT,INST)=OI,OROI=OI 92 . S ORPSOI=+$P(ORPSOI("OI",+Y),U,2) 93 OI2 ; -get routes, doses [also called from NF^ORCDPS] 94 D:'$D(^TMP("PSJMR",$J)) START^PSSJORDF(ORPSOI,$G(ORCAT)) ;DBIA 2418 95 I '$D(ORDOSE) D 96 . D DOSE^PSSORUTL(.ORDOSE,ORPSOI,$S($G(ORCAT)="I":"U",1:"O"),+ORVP) 97 . K:$G(ORDOSE(1))=-1 ORDOSE 98 Q 99 ; 100 NFI(OI) ; -- Show NFI restrictions, if exist 101 N PSOI,I,J,LCNT,MAX,X,STOP 102 S PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) 103 D EN^PSSDIN(PSOI,"") Q:'$D(^TMP("PSSDIN",$J,"OI",PSOI)) ;DBIA 3166 104 S I=0,LCNT=0,MAX=$S($G(IOBM)&$G(IOTM):IOBM-IOTM+1,1:24) W ! 105 F S I=$O(^TMP("PSSDIN",$J,"OI",PSOI,I)) Q:I'>0 D 106 . S J=0 F S J=$O(^TMP("PSSDIN",$J,"OI",PSOI,I,J)) Q:J'>0 S X=$G(^(J)) D Q:$G(STOP) 107 .. S LCNT=LCNT+1 I LCNT'<MAX S:'$$CONT STOP=1 Q:$G(STOP) S LCNT=1 108 .. W !,X 109 W ! K ^TMP("PSSDIN",$J,"OI",PSOI) 110 Q 111 ; 112 CONT() ; -- Cont or stop? 113 N X,Y,DIR,DUOUT,DTOUT,DIRUT,DIROUT S DIR(0)="EA" 114 S DIR("A")="Press <return> to continue or ^ to stop ..." 115 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="" 116 Q +Y 117 ; 118 WAIT ; -- Wait for user 119 N X W !,"Press <return> to continue ..." R X:DTIME 120 Q 121 ; 122 ROUTES ; -- Get med routes 123 Q:$G(ORDIALOG(PROMPT,"LIST")) N I,X,CNT S (I,CNT)=0 124 F S I=$O(^TMP("PSJMR",$J,I)) Q:I'>0 S X=^(I),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=$P(X,U,3)_U_$P(X,U,1,2),ORDIALOG(PROMPT,"LIST","B",$P(X,U))=$P(X,U,3) 125 S:$G(CNT) ORDIALOG(PROMPT,"LIST")=CNT 126 S:$G(ORTYPE)'="Z" REQD=$S(ORCAT="I":1,$P($G(^ORD(101.43,+$G(OROI),"PS")),U,5):0,1:1) 127 Q 128 ; 129 DEFRTE ; -- Get default route 130 N INST1 S INST1=$O(ORDIALOG(PROMPT,0)) S:INST1'>0 INST1=INST 131 I INST1=INST S Y=+$P($G(^TMP("PSJMR",$J,1)),U,3) K:Y'>0 Y Q 132 S Y=+$G(ORDIALOG(PROMPT,INST1)) K:Y'>0 Y S:$G(Y) EDITONLY=1 133 Q 134 ; 135 CKSCH ; -- validate schedule [Called from P-S Action] 136 N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET) K ORSD 137 D EN^PSSGS0(.ORX,$G(ORCAT)) 138 I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX D CHANGED("QUANTITY") Q ;ok 139 W $C(7),!,"Enter a standard schedule for administering this medication" 140 K DONE I $G(ORCAT)="I" W ".",! Q 141 W " or one of your own,",!,"up to 20 characters.",! 142 Q 143 ; 144 DEFCONJ ; -- Set default conjuction for previous instance [P-S Action] 145 N LAST,DUR,CONJ 146 S LAST=$O(ORDIALOG(PROMPT,ORI),-1) Q:LAST'>0 ;first instance 147 S CONJ=$$PTR("AND/THEN") Q:$L($G(ORDIALOG(CONJ,LAST))) 148 S DUR=$G(ORDIALOG($$PTR("DURATION"),LAST)) 149 S ORDIALOG(CONJ,LAST)=$S(+DUR'>0:"A",1:"T") 150 Q 151 ; 152 ENCONJ ; -- Get allowable values, if req'd for INST 153 N P S P=$$PTR("INSTRUCTIONS") 154 S REQD=$S($O(ORDIALOG(P,INST)):1,1:0) 155 S ORDIALOG(PROMPT,"A")="And/then"_$S(ORCAT="O":"/except: ",1:": ") 156 S $P(ORDIALOG(PROMPT,0),U,2)="A:AND;T:THEN;"_$S(ORCAT="O":"X:EXCEPT;",1:"") 157 Q 158 ; 159 DSUP ; -- Get max/default days supply 160 N ORX,Y 161 S ORX("PATIENT")=+$G(ORVP),ORX("DRUG")=+$G(ORDRUG) 162 D DSUP^PSOSIGDS(.ORX) S Y=+$G(ORX("DAYS SUPPLY")) S:Y'>0 Y=90 163 ;S $P(ORDIALOG(PROMPT,0),U,2)="1:"_Y ;max allowed 164 I '$G(ORDIALOG(PROMPT,1)),$G(ORTYPE)'="Z" S ORDIALOG(PROMPT,1)=Y 165 Q 166 ; 167 QTY() ; -- Return default quantity [Expects ORDSUP] 168 N INSTR,DOSE,DUR,SCH,I,ORX,X,Y 169 S Y="" I $G(ORDSUP)'>0!'$G(ORDRUG) G QTYQ ;need days supply, disp drug 170 S INSTR=$$PTR("INSTRUCTIONS") 171 S DOSE=$$PTR("DOSE"),CONJ=$$PTR("AND/THEN") 172 S DUR=$$PTR("DURATION"),SCH=$$PTR("SCHEDULE") 173 S I=0 F S I=$O(ORDIALOG(INSTR,I)) Q:I'>0 D Q:'$D(ORX) 174 . S X=$P($G(ORDIALOG(DOSE,I)),"&",3) I X'>0 K ORX Q 175 . S ORX("DOSE ORDERED",I)=X,ORX("SCHEDULE",I)=$G(ORDIALOG(SCH,I)) 176 . S X=$G(ORDIALOG(DUR,I)),ORX("DURATION",I)=$$HL7DUR^ORMBLDPS 177 . S ORX("CONJUNCTION",I)=$G(ORDIALOG(CONJ,I)) 178 G:'$D(ORX) QTYQ ;no doses 179 S ORX("PATIENT")=+$G(ORVP),ORX("DRUG")=+$G(ORDRUG) 180 S ORX("DAYS SUPPLY")=+$G(ORDSUP) 181 D QTYX^PSOSIG(.ORX) S Y=$G(ORX("QTY")) 182 QTYQ Q Y 183 ; 184 MAXREFS ; -- Get max refills allowed [Entry Action] 185 Q:$G(ORCAT)'="O" N ORX,X 186 S ORX("ITEM")=+$P($G(^ORD(101.43,+$G(OROI),0)),U,2) 187 S ORX("DRUG")=+$G(ORDRUG),ORX("PATIENT")=+$G(ORVP) 188 I $G(OREVENT),$$TYPE^OREVNTX(OREVENT)="D" S ORX("DISCHARGE")=1 189 S ORX("DAYS SUPPLY")=$G(ORDSUP) D MAX^PSOSIGDS(.ORX) 190 S OREFILLS=$G(ORX("MAX")),X=$G(ORDIALOG(PROMPT,INST)) 191 I OREFILLS'>0 S ORDIALOG(PROMPT,INST)=0 W !,"No refills allowed." Q 192 S $P(ORDIALOG(PROMPT,0),U,2)="0:"_OREFILLS 193 S ORDIALOG(PROMPT,"A")="Refills (0-"_OREFILLS_"): " 194 I X,X>OREFILLS S ORDIALOG(PROMPT,INST)=OREFILLS 195 Q 196 ; 197 ASKSC() ; -- Return 1 or 0, if SC prompt should be asked 198 I $$SC^PSOCP(+ORVP,+$G(ORDRUG)) Q 0 199 ;I $$RXST^IBARXEU(+ORVP)>0 Q 0 ;exempt from copay 200 Q 1 201 ; 202 PTR(X) ; -- Return ptr to prompt OR GTX X 203 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) 204 ; 205 EXIT ; -- exit action for Meds 206 S:$G(ORXNP) ORNP=ORXNP 207 K ORXNP,ORINPT,ORCAT,ORPKG,OROI,ORIV,ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,OREFILLS,ORQTY,ORQTYUNT,ORCOPAY,PSJNOPC,ORCOMPLX 208 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 209 Q 1 ORCDPS1 ;SLC/MKB-Pharmacy dialog utilities ; 08 May 2002 2:12 PM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,117,141,149,195,215**;Dec 17, 1997 3 ; 4 ; DBIA 2418 START^PSSJORDF ^TMP("PSJMR",$J) 5 ; DBIA 3166 EN^PSSDIN ^TMP("PSSDIN",$J) 6 ; 7 EN(TYPE) ; -- entry action for Meds dialogs 8 S ORINPT=$$INPT^ORCD,ORCAT=$G(TYPE) 9 I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location? 10 I ORCAT="" D 11 . I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT),$L($P($G(OR0),U,12)) S ORCAT=$P(OR0,U,12) Q ;use value from order, via ORCACT4 12 . S ORCAT=$S(ORINPT:"I",1:"O") 13 S ORDG=+$O(^ORD(100.98,"B",$S(ORCAT="I":"UD RX",1:"O RX"),0)) 14 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 15 I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT)!$G(ORXFER) D Q:$G(ORQUIT) 16 . I 'ORINPT,ORCAT="I" D Q:$G(ORQUIT) 17 .. N OI S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1 18 .. I '$O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORQUIT=1 W $C(7),!!,"This order may not be placed at this location!" Q 19 . K ORDIALOG($$PTR("START DATE/TIME"),1) 20 . K ORDIALOG($$PTR("NOW"),1) Q:ORCAT'="O" 21 . I $G(OREDIT)!$G(OREWRITE) N PI S PI=$$PTR("PATIENT INSTRUCTIONS") K ORDIALOG(PI,1),^TMP("ORWORD",$J,PI) 22 . I $D(OREDIT),'$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) K ^TMP("ORWORD",$J) 23 I ORINPT,ORCAT="O" W $C(7),!!,"NOTE: This will create an outpatient prescription for an inpatient!",! 24 Q 25 ; 26 EN1 ; -- setup Meds dialog for quick order editor using ORDG 27 N DG S DG=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) 28 I $P(DG," ")="O"!(DG="SPLY") S ORINPT=0,ORCAT="O" 29 E S ORINPT=1,ORCAT="I" 30 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 31 Q 32 ; 33 ENOI ; -- setup OI prompt 34 N D S D=$G(ORDIALOG(PROMPT,"D")) 35 S:D="S.RX" ORDIALOG(PROMPT,"D")=$S(ORCAT="I":"S.UD RX",1:"S.O RX") 36 I ORCAT="I",'ORINPT,D="S.UD RX" D ;limit to IV meds for outpt's 37 . S ORDIALOG(PROMPT,"D")="S.IVM RX" ;ORDG=+$O(^ORD(100.98,"B","O RX",0)) 38 . S ORDIALOG(PROMPT,"?")="Enter the IV medication you wish to order for this patient." 39 Q 40 ; 41 DEA ; -- ck DEA# of ordering provider if SchedII drug 42 Q:$G(ORTYPE)="Z" N DEAFLG,PSOI 43 S PSOI=+$P($G(^ORD(101.43,+$G(Y),0)),U,2) Q:PSOI'>0 44 S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,ORCAT) Q:DEAFLG'>0 ;ok 45 I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" K DONE Q 46 I DEAFLG=1 W $C(7),!,"This order will require a wet signature!" 47 Q 48 ; 49 CHANGED(X) ; -- Kill dependent values when prompt X changes 50 N PROMPTS,NAME,PTR,P,I 51 S PROMPTS=X I X="OI" D 52 . S PROMPTS="INSTRUCTIONS^ROUTE^SCHEDULE^START DATE/TIME^DURATION^AND/THEN^DOSE^DISPENSE DRUG^SIG^PATIENT INSTRUCTIONS^DAYS SUPPLY^QUANTITY^REFILLS^SERVICE CONNECTED" 53 . K ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,ORQTY,ORQTYUNT,OREFILLS,ORCOPAY 54 . K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 55 I X="DS" S PROMPTS="QUANTITY^REFILLS" K OREFILLS 56 F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D 57 . S PTR=$$PTR(NAME) Q:'PTR 58 . S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I) 59 . K ORDIALOG(PTR,"LIST"),^TMP("ORWORD",$J,PTR) 60 Q 61 ; 62 ORDITM(OI) ; -- Check OI, get dependent info 63 Q:OI'>0 ;quit - no value 64 N ORPS,ORPSOI S ORPS=$G(^ORD(101.43,+OI,"PS")),ORPSOI=+$P($G(^(0)),U,2) 65 S ORIV=$S($P(ORPS,U)=2:1,1:0) 66 I $G(ORCAT)="O",'$P(ORPS,U,2) W $C(7),!,"This drug may not be used in an outpatient order." S ORQUIT=1 D WAIT Q 67 I $G(ORCAT)="I" D Q:$G(ORQUIT) 68 . I $G(ORINPT),'$P(ORPS,U) W $C(7),!,"This drug may not be used in an inpatient order." S ORQUIT=1 D WAIT Q 69 . I '$G(ORINPT),'ORIV W $C(7),!,"This drug may not be ordered for an outpatient." S ORQUIT=1 D WAIT Q 70 I $G(ORTYPE)="Q" D I $G(ORQUIT) D WAIT Q 71 . N DEAFLG S DEAFLG=$$OIDEA^PSSUTLA1(ORPSOI,ORCAT) Q:DEAFLG'>0 ;ok 72 . I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q 73 . I DEAFLG=1 W $C(7),!,"This order will require a wet signature!" 74 OI1 ; -ck NF status 75 I $P(ORPS,U,6),'$G(ORENEW) D ;alternative 76 . W !!,"*** This medication is not in the formulary! ***" 77 . N PSX,CNT,ORX,DIR,X,Y,DTOUT,DUOUT 78 . D EN1^PSSUTIL1(.ORPSOI,ORCAT) I '$O(ORPSOI(0)) D Q 79 .. W !," There are no formulary alternatives entered for this item." 80 .. W !," Please consult with your pharmacy before ordering it." 81 . S PSX=0,CNT=0 F S PSX=$O(ORPSOI(PSX)) Q:PSX'>0 D 82 .. S ORX=+$O(^ORD(101.43,"ID",PSX_";99PSP",0)) Q:ORX'>0 83 .. S CNT=CNT+1,ORPSOI("OI",CNT)=ORX_U_PSX 84 .. S DIR("A",CNT)=$J(CNT,3)_" "_$P($G(^ORD(101.43,ORX,0)),U) 85 . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select alternative (or <return> to continue): " 86 . S DIR("?")="The medication selected is not in the formulary; you may select one of the above listed alternatives instead, or press <return> to continue processing this order." 87 . Q:CNT'>0 W !," Formulary alternatives:" D ^DIR 88 . I Y'>0 S:$D(DTOUT)!$D(DUOUT) ORQUIT=1 Q 89 . D:OI'=+ORPSOI("OI",+Y) CHANGED("OI") ;reset parameters if different 90 . S OI=+ORPSOI("OI",+Y),ORDIALOG(PROMPT,INST)=OI,OROI=OI 91 . S ORPSOI=+$P(ORPSOI("OI",+Y),U,2) 92 OI2 ; -get routes, doses [also called from NF^ORCDPS] 93 D:'$D(^TMP("PSJMR",$J)) START^PSSJORDF(ORPSOI,$G(ORCAT)) ;DBIA 2418 94 I '$D(ORDOSE) D 95 . D DOSE^PSSORUTL(.ORDOSE,ORPSOI,$S($G(ORCAT)="I":"U",1:"O"),+ORVP) 96 . K:$G(ORDOSE(1))=-1 ORDOSE 97 Q 98 ; 99 NFI(OI) ; -- Show NFI restrictions, if exist 100 N PSOI,I,J,LCNT,MAX,X,STOP 101 S PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) 102 D EN^PSSDIN(PSOI,"") Q:'$D(^TMP("PSSDIN",$J,"OI",PSOI)) ;DBIA 3166 103 S I=0,LCNT=0,MAX=$S($G(IOBM)&$G(IOTM):IOBM-IOTM+1,1:24) W ! 104 F S I=$O(^TMP("PSSDIN",$J,"OI",PSOI,I)) Q:I'>0 D 105 . S J=0 F S J=$O(^TMP("PSSDIN",$J,"OI",PSOI,I,J)) Q:J'>0 S X=$G(^(J)) D Q:$G(STOP) 106 .. S LCNT=LCNT+1 I LCNT'<MAX S:'$$CONT STOP=1 Q:$G(STOP) S LCNT=1 107 .. W !,X 108 W ! K ^TMP("PSSDIN",$J,"OI",PSOI) 109 Q 110 ; 111 CONT() ; -- Cont or stop? 112 N X,Y,DIR,DUOUT,DTOUT,DIRUT,DIROUT S DIR(0)="EA" 113 S DIR("A")="Press <return> to continue or ^ to stop ..." 114 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="" 115 Q +Y 116 ; 117 WAIT ; -- Wait for user 118 N X W !,"Press <return> to continue ..." R X:DTIME 119 Q 120 ; 121 ROUTES ; -- Get med routes 122 Q:$G(ORDIALOG(PROMPT,"LIST")) N I,X,CNT S (I,CNT)=0 123 F S I=$O(^TMP("PSJMR",$J,I)) Q:I'>0 S X=^(I),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=$P(X,U,3)_U_$P(X,U,1,2),ORDIALOG(PROMPT,"LIST","B",$P(X,U))=$P(X,U,3) 124 S:$G(CNT) ORDIALOG(PROMPT,"LIST")=CNT 125 S:$G(ORTYPE)'="Z" REQD=$S(ORCAT="I":1,$P($G(^ORD(101.43,+$G(OROI),"PS")),U,5):0,1:1) 126 Q 127 ; 128 DEFRTE ; -- Get default route 129 N INST1 S INST1=$O(ORDIALOG(PROMPT,0)) S:INST1'>0 INST1=INST 130 I INST1=INST S Y=+$P($G(^TMP("PSJMR",$J,1)),U,3) K:Y'>0 Y Q 131 S Y=+$G(ORDIALOG(PROMPT,INST1)) K:Y'>0 Y S:$G(Y) EDITONLY=1 132 Q 133 ; 134 CKSCH ; -- validate schedule [Called from P-S Action] 135 N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET) K ORSD 136 D EN^PSSGS0(.ORX,$G(ORCAT)) 137 I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX D CHANGED("QUANTITY") Q ;ok 138 W $C(7),!,"Enter a standard administration schedule" 139 K DONE I $G(ORCAT)="I" W ".",! Q 140 W " or one of your own,",!,"up to 70 characters and no more than 2 spaces.",! 141 Q 142 ; 143 DEFCONJ ; -- Set default conjuction for previous instance [P-S Action] 144 N LAST,DUR,CONJ 145 S LAST=$O(ORDIALOG(PROMPT,ORI),-1) Q:LAST'>0 ;first instance 146 S CONJ=$$PTR("AND/THEN") Q:$L($G(ORDIALOG(CONJ,LAST))) 147 S DUR=$G(ORDIALOG($$PTR("DURATION"),LAST)) 148 S ORDIALOG(CONJ,LAST)=$S(+DUR'>0:"A",1:"T") 149 Q 150 ; 151 ENCONJ ; -- Get allowable values, if req'd for INST 152 N P S P=$$PTR("INSTRUCTIONS") 153 S REQD=$S($O(ORDIALOG(P,INST)):1,1:0) 154 S ORDIALOG(PROMPT,"A")="And/then"_$S(ORCAT="O":"/except: ",1:": ") 155 S $P(ORDIALOG(PROMPT,0),U,2)="A:AND;T:THEN;"_$S(ORCAT="O":"X:EXCEPT;",1:"") 156 Q 157 ; 158 DSUP ; -- Get max/default days supply 159 N ORX,Y 160 S ORX("PATIENT")=+$G(ORVP),ORX("DRUG")=+$G(ORDRUG) 161 D DSUP^PSOSIGDS(.ORX) S Y=+$G(ORX("DAYS SUPPLY")) S:Y'>0 Y=90 162 ;S $P(ORDIALOG(PROMPT,0),U,2)="1:"_Y ;max allowed 163 I '$G(ORDIALOG(PROMPT,1)),$G(ORTYPE)'="Z" S ORDIALOG(PROMPT,1)=Y 164 Q 165 ; 166 QTY() ; -- Return default quantity [Expects ORDSUP] 167 N INSTR,DOSE,DUR,SCH,I,ORX,X,Y 168 S Y="" I $G(ORDSUP)'>0!'$G(ORDRUG) G QTYQ ;need days supply, disp drug 169 S INSTR=$$PTR("INSTRUCTIONS") 170 S DOSE=$$PTR("DOSE"),CONJ=$$PTR("AND/THEN") 171 S DUR=$$PTR("DURATION"),SCH=$$PTR("SCHEDULE") 172 S I=0 F S I=$O(ORDIALOG(INSTR,I)) Q:I'>0 D Q:'$D(ORX) 173 . S X=$P($G(ORDIALOG(DOSE,I)),"&",3) I X'>0 K ORX Q 174 . S ORX("DOSE ORDERED",I)=X,ORX("SCHEDULE",I)=$G(ORDIALOG(SCH,I)) 175 . S X=$G(ORDIALOG(DUR,I)),ORX("DURATION",I)=$$HL7DUR^ORMBLDPS 176 . S ORX("CONJUNCTION",I)=$G(ORDIALOG(CONJ,I)) 177 G:'$D(ORX) QTYQ ;no doses 178 S ORX("PATIENT")=+$G(ORVP),ORX("DRUG")=+$G(ORDRUG) 179 S ORX("DAYS SUPPLY")=+$G(ORDSUP) 180 D QTYX^PSOSIG(.ORX) S Y=$G(ORX("QTY")) 181 QTYQ Q Y 182 ; 183 MAXREFS ; -- Get max refills allowed [Entry Action] 184 Q:$G(ORCAT)'="O" N ORX,X 185 S ORX("ITEM")=+$P($G(^ORD(101.43,+$G(OROI),0)),U,2) 186 S ORX("DRUG")=+$G(ORDRUG),ORX("PATIENT")=+$G(ORVP) 187 I $G(OREVENT),$$TYPE^OREVNTX(OREVENT)="D" S ORX("DISCHARGE")=1 188 S ORX("DAYS SUPPLY")=$G(ORDSUP) D MAX^PSOSIGDS(.ORX) 189 S OREFILLS=$G(ORX("MAX")),X=$G(ORDIALOG(PROMPT,INST)) 190 I OREFILLS'>0 S ORDIALOG(PROMPT,INST)=0 W !,"No refills allowed." Q 191 S $P(ORDIALOG(PROMPT,0),U,2)="0:"_OREFILLS 192 S ORDIALOG(PROMPT,"A")="Refills (0-"_OREFILLS_"): " 193 I X,X>OREFILLS S ORDIALOG(PROMPT,INST)=OREFILLS 194 Q 195 ; 196 ASKSC() ; -- Return 1 or 0, if SC prompt should be asked 197 I $$SC^PSOCP(+ORVP,+$G(ORDRUG)) Q 0 198 ;I $$RXST^IBARXEU(+ORVP)>0 Q 0 ;exempt from copay 199 Q 1 200 ; 201 PTR(X) ; -- Return ptr to prompt OR GTX X 202 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) 203 ; 204 EXIT ; -- exit action for Meds 205 S:$G(ORXNP) ORNP=ORXNP 206 K ORXNP,ORINPT,ORCAT,ORPKG,OROI,ORIV,ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,OREFILLS,ORQTY,ORQTYUNT,ORCOPAY,PSJNOPC,ORCOMPLX 207 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 208 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS2.m
r613 r623 1 ORCDPS2 ;SLC/MKB-Pharmacy dialog utilities ;12/14/2006 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,125,131,243**;Dec 17, 1997;Build 242 3 ; 4 COMPLEX() ; -- Single or complex? 5 N X,Y,DIR,DUOUT,DTOUT,COMPLX 6 S COMPLX=$S($O(ORDIALOG(PROMPT,"?"),-1)>1:1,$L($G(ORDIALOG($$PTR("DURATION"),1))):1,1:0) 7 I $G(ORTYPE)="Q",$O(ORDIALOG(PROMPT,0)),FIRST Q COMPLX 8 I $D(ORENEW)!$D(OREWRITE)!$D(ORXFER)!COMPLX Q COMPLX 9 I $D(OREDIT) Q:$D(ORCOMPLX)!COMPLX COMPLX G CP1 ;Q if complex or 'first, else ask 10 I 'FIRST S Y=$S($D(ORCOMPLX):ORCOMPLX,1:COMPLX) Q Y 11 CP1 S DIR(0)="YA",DIR("A")="Complex dose? ",DIR("B")="NO" 12 S DIR("?")="Enter YES if you wish to enter multiple sets of dosage instructions, a tapering dose, or to limit the duration of a single dose." 13 D ^DIR S:$D(DTOUT) Y="^" 14 Q Y 15 ; 16 DOSES ; -- Available common doses 17 ;S $P(ORDIALOG(PROMPT,0),U,2)=$S(ORCAT="I":"1:20",1:"1:80") 18 S ORDIALOG(PROMPT,"A")="Dose"_$S(ORCAT="I"&$G(ORIV):" or Rate: ",1:": ") 19 S $P(ORDIALOG(PROMPT,"?"),",",2)=$S($G(ORIV):" as either a dose amount or infusion rate.",1:" as a dose or amount.") 20 I FIRST,'$O(ORDIALOG(PROMPT,0)),$G(ORXFER) D SHOWSIG^ORCMED 21 S ORCOMPLX=$$COMPLEX,MULT=+ORCOMPLX I ORCOMPLX="^" S ORQUIT=1 Q 22 Q:$G(ORDIALOG(PROMPT,"LIST")) Q:'$D(ORDOSE) 23 D1 ; -- Entry from ORCMED,NF^ORCDPS to build list 24 N I,J,X,DD,DRUG,DOSE,CONJ,CNT,UD,COST,TEXT 25 S (I,CNT)=0,CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ 26 F S I=$O(ORDOSE(I)) Q:I'>0 D 27 . S X=ORDOSE(I),DD=+$P(X,U,6),DRUG=ORDOSE("DD",DD) 28 . ; =TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN^Cost 29 . ;DD=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills? 30 . S DOSE=$P(X,U,5),UD=$P(X,U,3),COST=$P(X,U,7) Q:'$L(DOSE) 31 . I '$P(X,U) S DOSE=DOSE_CONJ_" "_$S($L($P(DRUG,U,5)):$P(DRUG,U,5)_$P(DRUG,U,6),1:$P(DRUG,U)) 32 . ;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4) 33 . S TEXT=DOSE_$S($L(COST):" $"_COST,1:"")_$S($P(DRUG,U,3):" (non-formulary)",1:"") 34 . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=DOSE_U_TEXT 35 . S ORDIALOG(PROMPT,"LIST","B",TEXT)=DOSE 36 . S ORDIALOG(PROMPT,"LIST","D",DOSE)=DD ;default DispDrug 37 . S ORDOSE("DD",DD,DOSE)=$P(ORDOSE(I),U,1,6)_U_$P(DRUG,U,5,6) 38 . S J=0 F S J=$O(ORDOSE(I,J)) Q:J'>0 D ;xref alt forms of dose 39 .. S DD=+$P(ORDOSE(I,J),U,6),DRUG=$G(ORDOSE("DD",DD)) 40 .. S ORDOSE("DD",DD,DOSE)=$P(ORDOSE(I,J),U,1,6)_U_$P(DRUG,U,5,6) 41 S:CNT ORDIALOG(PROMPT,"LIST")=CNT 42 Q 43 ; 44 CHDOSE ; -- Kill dependent values if inst ORI of dose changes 45 N X,PROMPTS,P,NAME,DOSE,DD S X=$G(ORDIALOG(PROMPT,ORI)) 46 S X=$$UP^XLFSTR(X),ORDIALOG(PROMPT,ORI)=X ;force uppercase 47 I X,X'?1.N.E1.A.E K DONE W $C(7),!,"Enter the amount of this drug that the patient is to receive as a dose,",!,"NOT as the number of units per dose." Q 48 I $L(X)>60,'$D(ORDIALOG(PROMPT,"LIST","B",X)) K DONE W $C(7),!,"Instructions may not be longer than 60 characters." Q 49 I $G(ORESET)'=X D ;kill dependent values if new/changed dose 50 . S PROMPTS="STRENGTH^DRUG NAME^DOSE^DISPENSE DRUG^DAYS SUPPLY^QUANTITY^REFILLS" 51 . F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) K ORDIALOG($$PTR(NAME),ORI) 52 . K ORQTY,ORQTYUNT,ORDRUG,ORDIALOG($$PTR("DISPENSE DRUG"),1) 53 . K ^TMP("ORWORD",$J,$$PTR("SIG")) 54 S DOSE=$$PTR("DOSE") I $L(X),'$L($G(ORDIALOG(DOSE,ORI))) D ;set ID 55 . S DD=+$G(ORDIALOG(PROMPT,"LIST","D",X)) 56 . S:DD ORDIALOG(DOSE,ORI)=$TR($G(ORDOSE("DD",DD,X)),"^","&") 57 S DD=+$P($G(ORDIALOG(DOSE,ORI)),"&",6) 58 I DD,$P($G(ORDOSE("DD",DD)),U,3) D NF^ORCDPS(DD) ;look for FormAlt 59 Q 60 ; 61 EXDOSE ; -- Exit Action 62 Q:'$O(ORDIALOG(PROMPT,0)) N DRUG,MISC,QUIT,LAST 63 S ORDRUG=$$DISPDRUG^ORCDPS,DRUG=$G(ORDOSE("DD",+ORDRUG)) 64 I ORDRUG D I $G(QUIT) S ORQUIT=1 Q 65 . ;I $P(DRUG,U,10),'$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S QUIT=1 Q 66 . ;I $P(DRUG,U,10)=1 W $C(7),!,"This order will require a wet signature!" 67 . S ORDIALOG($$PTR("DISPENSE DRUG"),1)=ORDRUG 68 . D:$G(ORCAT)="O" RESETID^ORCDPS 69 . N STR,MED S STR=$P(DRUG,U,5)_$P(DRUG,U,6) 70 . I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG,U) Q 71 . S MED=$P($G(^ORD(101.43,+$G(OROI),0)),U) 72 . I MED'[STR,ORCAT="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR 73 I +ORDRUG'>0,ORCAT="O" W $C(7),!,"Cannot determine dispense drug - some defaults and order checks may not occur!" 74 EXD1 ; -- Kill dangling conjunction, [re]build Sig, get Qty info 75 S LAST=$O(ORDIALOG(PROMPT,"?"),-1) K ORDIALOG($$PTR("AND/THEN"),LAST) 76 D ADMIN^ORCDPS3 D:$G(ORTYPE)'="Z" SIG ;[re]build Sig/Text 77 I ORDRUG,ORCAT="O" D ;set Qty info 78 . S:$L($P(DRUG,U,4)) ORQTYUNT=$P(DRUG,U,4) 79 . S MISC=$$ENDCM^PSJORUTL(+ORDRUG),ORQTY=$P(MISC,U,4) 80 . W:$L($P(MISC,U,2)) !!,$P(MISC,U,2),! 81 Q 82 ; 83 SIG ; -- Create ORDIALOG(SIG) from Instructions PROMPT,ORDOSE,ORDRUG,ORCAT 84 ; Return text in ^TMP("ORWORD",$J,SIG,INST) 85 ; [also called from PSJ^ORCSEND1 to build child orders] 86 ; 87 N ORT,ORSCH,ORDUR,ORID,ORDD,ORCNJ,ORMISC,ORPREP,ORX,ORI,CNT,ORSIG,ORS,DOSE 88 S ORT=$$PTR("ROUTE"),ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION") 89 S ORID=$$PTR("DOSE"),ORCNJ=$$PTR("AND/THEN"),ORS=$$PTR("SIG") 90 S ORMISC=$G(ORDOSE("MISC")),ORPREP=$P(ORMISC,U,2) 91 S ORX=$S(ORCAT="I":"",ORCAT="O"&(+$G(ISIMO)=1):"",$L($P(ORMISC,U)):$P(ORMISC,U)_" ",1:"") ;"TAKE " 92 S (CNT,ORI)=0 F S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI'>0 D 93 . S DOSE=$G(ORDIALOG(PROMPT,ORI)) Q:'$L(DOSE) 94 . S ORX=ORX_$$DOSE_$$RTE_$$SCH_$$DUR_$$CONJ 95 . S CNT=CNT+1,ORSIG(CNT,0)=ORX,ORX="" 96 Q:CNT'>0 S ORSIG(0)="^^"_CNT_U_CNT_U_DT_U 97 K ^TMP("ORWORD",$J,ORS,1) M ^(1)=ORSIG S ORDIALOG(PROMPT,"FORMAT")="@" 98 S ORDIALOG(ORS,1)=$NA(^TMP("ORWORD",$J,ORS,1)) 99 Q 100 ; 101 PTR(X) ; -- Ptr to prompt OR GTX X 102 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) 103 ; 104 DOSE() ; -- Dosage 105 N X0,Y S X0=$G(ORDIALOG(ORID,ORI)) ;ID string 106 S Y=DOSE I ORDRUG,$L(X0) D ;use local dose if common DispDrug 107 . S:$L($P(X0,"&",5)) Y=$P(X0,"&",5) ;unless Outpt w/total dose 108 . I ORCAT="O",X0 S Y=$$WORD($P(X0,"&",3))_" "_$P(X0,"&",4) ;u/d 109 Q Y 110 ; 111 WORD(X) ; -- Words for number X 112 N X1,X2,Y S X1=$P(+X,"."),X2=$P(+X,".",2) 113 S Y="" I X1 S Y=$S(X1=1:"ONE",X1=2:"TWO",X1=3:"THREE",X1=4:"FOUR",X1=5:"FIVE",X1=6:"SIX",X1=7:"SEVEN",X1=8:"EIGHT",X1=9:"NINE",X1=10:"TEN",1:X1) 114 I X2 S Y=Y_$S($L(Y):" AND ",1:"")_$S(X2=5:"ONE-HALF",X2=33!(X2=34):"ONE-THIRD",X2=25:"ONE-FOURTH",X2=66!(X2=67):"TWO-THIRDS",X2=75:"THREE-FOURTHS",1:"."_X2) 115 Q Y 116 ; 117 RTE() ; -- Expansion of route 118 N X,X0,Y S X=+$G(ORDIALOG(ORT,ORI)) Q:X'>0 "" 119 K ^TMP($J,"ORCDPS2 RTE") 120 D ALL^PSS51P2(+X,,,,"ORCDPS2 RTE") 121 ;S X0=$G(^PS(51.2,+X,0)),Y="" 122 I ORCAT="I"!(+$G(ISIMO)=1) S Y=" "_$S($L(^TMP($J,"ORCDPS2 RTE",+X,1)):^TMP($J,"ORCDPS2 RTE",+X,1),1:^TMP($J,"ORCDPS2 RTE",+X,.01)) 123 ;I ORCAT="I" S Y=" "_$S($L($P(X0,U,3)):$P(X0,U,3),1:$P(X0,U)) 124 I ORCAT="O",'+$G(ISIMO) S Y=" "_$S($L(ORPREP):ORPREP_" ",1:"")_$S($L(^TMP($J,"ORCDPS2 RTE",+X,4)):^TMP($J,"ORCDPS2 RTE",+X,4),1:^TMP($J,"ORCDPS2 RTE",+X,.01)) 125 Q Y 126 ; 127 SCH() ; -- [outpatient] expansion of schedule 128 N X,Y S X=$G(ORDIALOG(ORSCH,ORI)) 129 I $L(X),ORCAT="O",'+$G(ISIMO) D SCH^PSSUTIL1(.X) 130 S Y=$S($L(X):" "_X,1:"") 131 Q Y 132 ; 133 DUR() ; -- Duration 134 N X,Y S X=$G(ORDIALOG(ORDUR,ORI)),Y="" 135 I X S Y=" FOR "_$$UP^XLFSTR(X)_$S(+X=X:" DAYS",1:"") 136 Q Y 137 ; 138 CONJ() ; -- Conjunction 139 N X,Y S X=$G(ORDIALOG(ORCNJ,ORI)) 140 S:$L(X)>1 X=$E(X) S:X="E" S="X" 141 S Y=$S(X="T":", THEN",X="X":" EXCEPT",X="A":" AND",1:"") 142 Q Y 143 ; 144 DOSETEXT ; -- Reset dose text in ORDIALOG(INSTR) for backdoor orders 145 ; [Called from ORMPS1 - uses ORCAT,PSOI,ORVP,DRUG,INSTR,DOSE] 146 ; 147 N ORTYPE,ORDOSE,CONJ,ORDRUG,DRUG0,STRG,ORI,LDOSE,X,PROMPT 148 S ORTYPE=$S($G(ORCAT)="I":"U",1:"O") 149 D DOSE^PSSORUTL(.ORDOSE,+PSOI,ORTYPE,+ORVP) 150 S CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ 151 S ORDRUG=+$G(ORDIALOG(DRUG,1)),DRUG0=$G(ORDOSE("DD",ORDRUG)) 152 S STRG=$P(DRUG0,U,5)_$P(DRUG0,U,6) 153 I '$G(ORDOSE(1)) S ORI=0 F S ORI=$O(ORDIALOG(INSTR,ORI)) Q:ORI'>0 D 154 . S LDOSE=$G(ORDIALOG(INSTR,ORI)),X=$G(ORDIALOG(DOSE,ORI)) Q:'$L(X) 155 . S:'X ORDIALOG(INSTR,ORI)=LDOSE_CONJ_" "_$S(STRG:STRG,1:$P(DRUG0,U)) 156 ; -build Sig/Text if not defined 157 I '$D(ORDIALOG(+$$PTR("SIG"),1)) S PROMPT=INSTR D SIG 158 Q 159 ; 160 PI ; -- Include Pt Instructions w/Sig in Outpt order? 161 N X,Y,DIR,DUOUT,DTOUT,DIRUT,ORTX,ORMAX,I,CNT 162 I $G(ORCAT)'="O" D CLEARWP Q ;!'$O(ORDOSE("PI",0)) 163 Q:$G(ORENEW) S I=0,ORMAX=57 164 I $G(OREDIT)!$G(OREWRITE),$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ORDOSE("PI") S I=0 F S I=$O(^TMP("ORWORD",$J,PROMPT,INST,I)) Q:I<1 S ORDOSE("PI",I)=$G(^(I,0)) 165 I '$O(ORDOSE("PI",0)) D CLEARWP Q 166 F S I=$O(ORDOSE("PI",I)) Q:I'>0 S X=ORDOSE("PI",I) D TXT^ORCHTAB 167 S DIR(0)="YA",DIR("A")="Include Patient Instructions in Sig? " 168 S DIR("?")="Enter NO if you do not want these instructions included in the sig for this order",DIR("B")=$S($D(^TMP("ORWORD",$J,PROMPT)):"YES",1:"NO") 169 W ! S I=0 F S I=$O(ORTX(I)) Q:I'>0 W !,$S(I=1:"Patient Instructions: ",1:" ")_ORTX(I) 170 D ^DIR I $D(DUOUT)!$D(DTOUT) S ORQUIT=1 Q 171 I Y D Q ;save text 172 . K ^TMP("ORWORD",$J,PROMPT,INST) S CNT=0 173 . S I=0 F S I=$O(ORDOSE("PI",I)) Q:I'>0 S ^TMP("ORWORD",$J,PROMPT,INST,I,0)=ORDOSE("PI",I),CNT=CNT+1 174 . S ^TMP("ORWORD",$J,PROMPT,INST,0)="^^"_CNT_U_CNT_U_DT_U 175 . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" 176 I Y'>0 K ORDIALOG(PROMPT,INST),^TMP("ORWORD",$J,PROMPT,INST) 177 Q 178 ; 179 CLEARWP ; -- Clear INST of wp field PROMPT 180 K ORDIALOG(PROMPT,INST),^TMP("ORWORD",$J,PROMPT,INST) 181 Q 1 ORCDPS2 ;SLC/MKB-Pharmacy dialog utilities ;07:24 AM 5 Apr 2001 [12/31/01 6:35pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,125,131**;Dec 17, 1997 3 ; 4 COMPLEX() ; -- Single or complex dose? 5 N X,Y,DIR,DUOUT,DTOUT,COMPLX 6 S COMPLX=$S($O(ORDIALOG(PROMPT,"?"),-1)>1:1,$L($G(ORDIALOG($$PTR("DURATION"),1))):1,1:0) 7 I $G(ORTYPE)="Q",$O(ORDIALOG(PROMPT,0)),FIRST Q COMPLX 8 I $D(ORENEW)!$D(OREWRITE)!$D(ORXFER)!COMPLX Q COMPLX 9 I $D(OREDIT) Q:$D(ORCOMPLX)!COMPLX COMPLX G CP1 ;Q if complex or 'first, else ask 10 I 'FIRST S Y=$S($D(ORCOMPLX):ORCOMPLX,1:COMPLX) Q Y 11 CP1 S DIR(0)="YA",DIR("A")="Complex dose? ",DIR("B")="NO" 12 S DIR("?")="Enter YES if you wish to enter multiple sets of dosage instructions, a tapering dose, or to limit the duration of a single dose." 13 D ^DIR S:$D(DTOUT) Y="^" 14 Q Y 15 ; 16 DOSES ; -- Get available common doses 17 ;S $P(ORDIALOG(PROMPT,0),U,2)=$S(ORCAT="I":"1:20",1:"1:80") 18 S ORDIALOG(PROMPT,"A")="Dose"_$S(ORCAT="I"&$G(ORIV):" or Rate: ",1:": ") 19 S $P(ORDIALOG(PROMPT,"?"),",",2)=$S($G(ORIV):" as either a dose amount or infusion rate.",1:" as a dose or amount.") 20 I FIRST,'$O(ORDIALOG(PROMPT,0)),$G(ORXFER) D SHOWSIG^ORCMED 21 S ORCOMPLX=$$COMPLEX,MULT=+ORCOMPLX I ORCOMPLX="^" S ORQUIT=1 Q 22 Q:$G(ORDIALOG(PROMPT,"LIST")) Q:'$D(ORDOSE) 23 D1 ; -- enter here from ORCMED,NF^ORCDPS to build list 24 N I,J,X,DD,DRUG,DOSE,CONJ,CNT,UD,COST,TEXT 25 S (I,CNT)=0,CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ 26 F S I=$O(ORDOSE(I)) Q:I'>0 D 27 . S X=ORDOSE(I),DD=+$P(X,U,6),DRUG=ORDOSE("DD",DD) 28 . ; =TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN^Cost 29 . ;DD=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills? 30 . S DOSE=$P(X,U,5),UD=$P(X,U,3),COST=$P(X,U,7) Q:'$L(DOSE) 31 . I '$P(X,U) S DOSE=DOSE_CONJ_" "_$S($L($P(DRUG,U,5)):$P(DRUG,U,5)_$P(DRUG,U,6),1:$P(DRUG,U)) 32 . ;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4) 33 . S TEXT=DOSE_$S($L(COST):" $"_COST,1:"")_$S($P(DRUG,U,3):" (non-formulary)",1:"") 34 . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=DOSE_U_TEXT 35 . S ORDIALOG(PROMPT,"LIST","B",TEXT)=DOSE 36 . S ORDIALOG(PROMPT,"LIST","D",DOSE)=DD ;default DispDrug 37 . S ORDOSE("DD",DD,DOSE)=$P(ORDOSE(I),U,1,6)_U_$P(DRUG,U,5,6) 38 . S J=0 F S J=$O(ORDOSE(I,J)) Q:J'>0 D ;xref alt forms of dose 39 .. S DD=+$P(ORDOSE(I,J),U,6),DRUG=$G(ORDOSE("DD",DD)) 40 .. S ORDOSE("DD",DD,DOSE)=$P(ORDOSE(I,J),U,1,6)_U_$P(DRUG,U,5,6) 41 S:CNT ORDIALOG(PROMPT,"LIST")=CNT 42 Q 43 ; 44 CHDOSE ; -- kill dependent values if inst ORI of dose changes 45 N X,PROMPTS,P,NAME,DOSE,DD S X=$G(ORDIALOG(PROMPT,ORI)) 46 S X=$$UP^XLFSTR(X),ORDIALOG(PROMPT,ORI)=X ;force uppercase 47 I X,X'?1.N.E1.A.E K DONE W $C(7),!,"Enter the amount of this drug that the patient is to receive as a dose,",!,"NOT as the number of units per dose." Q 48 I $L(X)>60,'$D(ORDIALOG(PROMPT,"LIST","B",X)) K DONE W $C(7),!,"Instructions may not be longer than 60 characters." Q 49 I $G(ORESET)'=X D ;kill dependent values if new/changed dose 50 . S PROMPTS="STRENGTH^DRUG NAME^DOSE^DISPENSE DRUG^DAYS SUPPLY^QUANTITY^REFILLS" 51 . F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) K ORDIALOG($$PTR(NAME),ORI) 52 . K ORQTY,ORQTYUNT,ORDRUG,ORDIALOG($$PTR("DISPENSE DRUG"),1) 53 . K ^TMP("ORWORD",$J,$$PTR("SIG")) 54 S DOSE=$$PTR("DOSE") I $L(X),'$L($G(ORDIALOG(DOSE,ORI))) D ;set ID 55 . S DD=+$G(ORDIALOG(PROMPT,"LIST","D",X)) 56 . S:DD ORDIALOG(DOSE,ORI)=$TR($G(ORDOSE("DD",DD,X)),"^","&") 57 S DD=+$P($G(ORDIALOG(DOSE,ORI)),"&",6) 58 I DD,$P($G(ORDOSE("DD",DD)),U,3) D NF^ORCDPS(DD) ;look for FormAlt 59 Q 60 ; 61 EXDOSE ; -- Dose Exit Action 62 Q:'$O(ORDIALOG(PROMPT,0)) N DRUG,MISC,QUIT,LAST 63 S ORDRUG=$$DISPDRUG^ORCDPS,DRUG=$G(ORDOSE("DD",+ORDRUG)) 64 I ORDRUG D I $G(QUIT) S ORQUIT=1 Q 65 . ;I $P(DRUG,U,10),'$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S QUIT=1 Q 66 . ;I $P(DRUG,U,10)=1 W $C(7),!,"This order will require a wet signature!" 67 . S ORDIALOG($$PTR("DISPENSE DRUG"),1)=ORDRUG 68 . D:$G(ORCAT)="O" RESETID^ORCDPS 69 . N STR,MED S STR=$P(DRUG,U,5)_$P(DRUG,U,6) 70 . I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG,U) Q 71 . S MED=$P($G(^ORD(101.43,+$G(OROI),0)),U) 72 . I MED'[STR,ORCAT="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR 73 I +ORDRUG'>0,ORCAT="O" W $C(7),!,"Cannot determine dispense drug - some defaults and order checks may not occur!" 74 EXD1 ; -kill dangling conjunction, [re]build Sig, get Qty info 75 S LAST=$O(ORDIALOG(PROMPT,"?"),-1) K ORDIALOG($$PTR("AND/THEN"),LAST) 76 D ADMIN^ORCDPS3 D:$G(ORTYPE)'="Z" SIG ;[re]build Sig/Text 77 I ORDRUG,ORCAT="O" D ;set Qty info 78 . S:$L($P(DRUG,U,4)) ORQTYUNT=$P(DRUG,U,4) 79 . S MISC=$$ENDCM^PSJORUTL(+ORDRUG),ORQTY=$P(MISC,U,4) 80 . W:$L($P(MISC,U,2)) !!,$P(MISC,U,2),! 81 Q 82 ; 83 SIG ; -- Create ORDIALOG(SIG) from Instructions PROMPT,ORDOSE,ORDRUG,ORCAT 84 ; Return text in ^TMP("ORWORD",$J,SIG,INST) 85 ; [also called from PSJ^ORCSEND1 to build child orders] 86 ; 87 N ORT,ORSCH,ORDUR,ORID,ORDD,ORCNJ,ORMISC,ORPREP,ORX,ORI,CNT,ORSIG,ORS,DOSE 88 S ORT=$$PTR("ROUTE"),ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION") 89 S ORID=$$PTR("DOSE"),ORCNJ=$$PTR("AND/THEN"),ORS=$$PTR("SIG") 90 S ORMISC=$G(ORDOSE("MISC")),ORPREP=$P(ORMISC,U,2) 91 S ORX=$S(ORCAT="I":"",$L($P(ORMISC,U)):$P(ORMISC,U)_" ",1:"") ;"TAKE " 92 S (CNT,ORI)=0 F S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI'>0 D 93 . S DOSE=$G(ORDIALOG(PROMPT,ORI)) Q:'$L(DOSE) 94 . S ORX=ORX_$$DOSE_$$RTE_$$SCH_$$DUR_$$CONJ 95 . S CNT=CNT+1,ORSIG(CNT,0)=ORX,ORX="" 96 Q:CNT'>0 S ORSIG(0)="^^"_CNT_U_CNT_U_DT_U 97 K ^TMP("ORWORD",$J,ORS,1) M ^(1)=ORSIG S ORDIALOG(PROMPT,"FORMAT")="@" 98 S ORDIALOG(ORS,1)=$NA(^TMP("ORWORD",$J,ORS,1)) 99 Q 100 ; 101 PTR(X) ; -- Return ptr to prompt OR GTX X 102 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) 103 ; 104 DOSE() ; -- Return dosage 105 N X0,Y S X0=$G(ORDIALOG(ORID,ORI)) ;ID string 106 S Y=DOSE I ORDRUG,$L(X0) D ;use local dose if common DispDrug 107 . S:$L($P(X0,"&",5)) Y=$P(X0,"&",5) ;unless Outpt w/total dose 108 . I ORCAT="O",X0 S Y=$$WORD($P(X0,"&",3))_" "_$P(X0,"&",4) ;u/d 109 Q Y 110 ; 111 WORD(X) ; -- Return words for number X 112 N X1,X2,Y S X1=$P(+X,"."),X2=$P(+X,".",2) 113 S Y="" I X1 S Y=$S(X1=1:"ONE",X1=2:"TWO",X1=3:"THREE",X1=4:"FOUR",X1=5:"FIVE",X1=6:"SIX",X1=7:"SEVEN",X1=8:"EIGHT",X1=9:"NINE",X1=10:"TEN",1:X1) 114 I X2 S Y=Y_$S($L(Y):" AND ",1:"")_$S(X2=5:"ONE-HALF",X2=33!(X2=34):"ONE-THIRD",X2=25:"ONE-FOURTH",X2=66!(X2=67):"TWO-THIRDS",X2=75:"THREE-FOURTHS",1:"."_X2) 115 Q Y 116 ; 117 RTE() ; -- Return expansion of route 118 N X,X0,Y S X=+$G(ORDIALOG(ORT,ORI)) Q:X'>0 "" 119 S X0=$G(^PS(51.2,+X,0)),Y="" 120 I ORCAT="I" S Y=" "_$S($L($P(X0,U,3)):$P(X0,U,3),1:$P(X0,U)) 121 I ORCAT="O" S Y=" "_$S($L(ORPREP):ORPREP_" ",1:"")_$S($L($P(X0,U,2)):$P(X0,U,2),1:$P(X0,U)) 122 Q Y 123 ; 124 SCH() ; -- Return [outpatient] expansion of schedule 125 N X,Y S X=$G(ORDIALOG(ORSCH,ORI)) 126 I $L(X),ORCAT="O" D SCH^PSSUTIL1(.X) 127 S Y=$S($L(X):" "_X,1:"") 128 Q Y 129 ; 130 DUR() ; -- Return duration 131 N X,Y S X=$G(ORDIALOG(ORDUR,ORI)),Y="" 132 I X S Y=" FOR "_$$UP^XLFSTR(X)_$S(+X=X:" DAYS",1:"") 133 Q Y 134 ; 135 CONJ() ; -- Return conjuction 136 N X,Y S X=$G(ORDIALOG(ORCNJ,ORI)) 137 S:$L(X)>1 X=$E(X) S:X="E" S="X" 138 S Y=$S(X="T":", THEN",X="X":" EXCEPT",X="A":" AND",1:"") 139 Q Y 140 ; 141 DOSETEXT ; -- Reset dose text in ORDIALOG(INSTR) for backdoor orders 142 ; [Called from ORMPS1 - uses ORCAT,PSOI,ORVP,DRUG,INSTR,DOSE] 143 ; 144 N ORTYPE,ORDOSE,CONJ,ORDRUG,DRUG0,STRG,ORI,LDOSE,X,PROMPT 145 S ORTYPE=$S($G(ORCAT)="I":"U",1:"O") 146 D DOSE^PSSORUTL(.ORDOSE,+PSOI,ORTYPE,+ORVP) 147 S CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ 148 S ORDRUG=+$G(ORDIALOG(DRUG,1)),DRUG0=$G(ORDOSE("DD",ORDRUG)) 149 S STRG=$P(DRUG0,U,5)_$P(DRUG0,U,6) 150 I '$G(ORDOSE(1)) S ORI=0 F S ORI=$O(ORDIALOG(INSTR,ORI)) Q:ORI'>0 D 151 . S LDOSE=$G(ORDIALOG(INSTR,ORI)),X=$G(ORDIALOG(DOSE,ORI)) Q:'$L(X) 152 . S:'X ORDIALOG(INSTR,ORI)=LDOSE_CONJ_" "_$S(STRG:STRG,1:$P(DRUG0,U)) 153 ; -build Sig/Text if not defined 154 I '$D(ORDIALOG(+$$PTR("SIG"),1)) S PROMPT=INSTR D SIG 155 Q 156 ; 157 PI ; -- Include Patient Instructions w/Sig in Outpt order? 158 N X,Y,DIR,DUOUT,DTOUT,DIRUT,ORTX,ORMAX,I,CNT 159 I $G(ORCAT)'="O" D CLEARWP Q ;!'$O(ORDOSE("PI",0)) 160 Q:$G(ORENEW) S I=0,ORMAX=57 161 I $G(OREDIT)!$G(OREWRITE),$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ORDOSE("PI") S I=0 F S I=$O(^TMP("ORWORD",$J,PROMPT,INST,I)) Q:I<1 S ORDOSE("PI",I)=$G(^(I,0)) 162 I '$O(ORDOSE("PI",0)) D CLEARWP Q 163 F S I=$O(ORDOSE("PI",I)) Q:I'>0 S X=ORDOSE("PI",I) D TXT^ORCHTAB 164 S DIR(0)="YA",DIR("A")="Include Patient Instructions in Sig? " 165 S DIR("?")="Enter NO if you do not want these instructions included in the sig for this order",DIR("B")="YES" 166 W ! S I=0 F S I=$O(ORTX(I)) Q:I'>0 W !,$S(I=1:"Patient Instructions: ",1:" ")_ORTX(I) 167 D ^DIR I $D(DUOUT)!$D(DTOUT) S ORQUIT=1 Q 168 I Y D Q ;save text 169 . K ^TMP("ORWORD",$J,PROMPT,INST) S CNT=0 170 . S I=0 F S I=$O(ORDOSE("PI",I)) Q:I'>0 S ^TMP("ORWORD",$J,PROMPT,INST,I,0)=ORDOSE("PI",I),CNT=CNT+1 171 . S ^TMP("ORWORD",$J,PROMPT,INST,0)="^^"_CNT_U_CNT_U_DT_U 172 . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" 173 I Y'>0 K ORDIALOG(PROMPT,INST),^TMP("ORWORD",$J,PROMPT,INST) 174 Q 175 ; 176 CLEARWP ; -- Clear INST of wp field PROMPT 177 K ORDIALOG(PROMPT,INST),^TMP("ORWORD",$J,PROMPT,INST) 178 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS3.m
r613 r623 1 ORCDPS3 ;SLC/MKB-Pharmacy dialog utilities ;09/11/07 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,158,149,190,277,243**;Dec 17, 1997;Build 242 3 ; 4 START ; -- Start Date entry action 5 S $P(ORDIALOG(PROMPT,0),":",3)=$S($G(ORCAT)="I":"ETRX",1:"EX") 6 I $G(ORCAT)'="I" K ORSD K:$G(ORENEW)!$G(OREWRITE)!$D(OREDIT) ORDIALOG(PROMPT,INST) ;Inpt only 7 Q 8 ; 9 ADMIN ; -- Return default admin time for order in ORSD 10 ; Called from EXDOSE^ORCDPS2 11 Q:$D(ORSD) Q:$G(ORCAT)'="I" ;inpt only 12 N PSOI,PSIFN,SCH,CNJ,ORI,ORX 13 S PSOI=+$P($G(^ORD(101.43,+$G(OROI),0)),U,2) 14 S PSIFN=$S($G(ORENEW):$G(^OR(100,+$G(ORIFN),4)),1:"") 15 S SCH=$$PTR^ORCD("OR GTX SCHEDULE"),CNJ=$$PTR^ORCD("OR GTX AND/THEN"),ORX="" 16 S ORI=0 F S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI<1 S ORX=ORX_$S($L(ORX):U,1:"")_$G(ORDIALOG(CNJ,ORI))_";"_$G(ORDIALOG(SCH,ORI)) 17 S ORSD=$$FIRST(+ORVP,+$G(ORWARD),PSOI,ORX,PSIFN,"") 18 S:$P(ORSD,U)="NEXT" ORSD="NEXTA^"_$P(ORSD,U,2,99) 19 Q 20 ; 21 FIRST(DFN,WARD,OI,DATA,ORDER,ADMIN) ; -- Return expected first admin time of order 22 N CNT,ORCNT,ORI,J,ORZ,Y,SCH,ORX,TNUM 23 I '$G(DFN)!'$G(OI) Q "" 24 S ORCNT=0 F ORI=1:1:$L(DATA,"^") S ORZ=$P(DATA,U,ORI) D Q:$E(ORZ)="T" 25 .S TNUM=$$NUMCHAR(ORZ,";") Q:TNUM=0 26 .F CNT=1:1:TNUM D 27 .. S SCH=$P(ORZ,";",CNT+1) Q:'$L(SCH) S ORCNT=ORCNT+1 28 .. I ORCNT>1 S ADMIN="" 29 .. S ORX(ORCNT)=$$STARTSTP^PSJORPOE(DFN,SCH,OI,WARD,$G(ORDER),$G(ADMIN)) 30 S Y=9999999,J=0 31 F ORI=1:1:ORCNT S ORZ=$P(ORX(ORI),U,4) I ORZ<Y S Y=ORZ,J=ORI ;earliest 32 S Y=$S(J:ORX(J),1:"") 33 Q Y 34 ; 35 NUMCHAR(STRING,SUB) ; 36 N CNT,RESULT 37 S RESULT=0 38 F CNT=1:1:$L(STRING) I $E(STRING,CNT)=SUB S RESULT=RESULT+1 39 Q RESULT 40 ; 41 NOW ; -- First dose now? 42 N X,Y,DIR,SCH 43 K ^TMP($J,"ORCDPS3 NOW") 44 I $G(ORCAT)="O"!'$D(ORSD)!$L($G(OREVENT))!$G(ORENEW) K ORDIALOG(PROMPT,INST),^TMP($J,"ORCDPS3 NOW") Q 45 D AP^PSS51P1("PSJ",,,,"ORCDPS3 NOW") 46 ; ask on Copy? Change? 47 S X=$$PTR^ORCD("OR GTX SCHEDULE"),Y=+$O(ORDIALOG(X,0)) 48 S SCH=$G(ORDIALOG(X,Y)),Y=+$O(^TMP($J,"ORCDPS3 NOW","APPSJ",SCH,0)) ;1st one 49 ;S SCH=$G(ORDIALOG(X,Y)),Y=+$O(^PS(51.1,"APPSJ",SCH,0)) ;1st one 50 I $G(^TMP($J,"ORCDPS3 NOW",SCH,5))=""!(Y<1) K ORDIALOG(PROMPT,INST),^TMP($J,"ORCDPS3 NOW") Q 51 ;I $P($G(^PS(51.1,Y,0)),U,5)="O"!(Y<1) K ORDIALOG(PROMPT,INST),^TMP($J,"ORCDPS3 NOW") Q 52 ; other conditions? 53 S DIR(0)="YA",DIR("A")="Give additional dose NOW? " 54 S DIR("B")=$S($G(ORDIALOG(PROMPT,INST)):"YES",1:"NO") 55 I ORINPT,$P(ORSD,U,4) S DIR("A",1)="Next scheduled administration time: "_$$FMTE^XLFDT($P(ORSD,U,4)) 56 S DIR("?")="Enter YES if you want a dose given now in addition to the regular administration times for this schedule and ward." 57 D ^DIR S:$D(DTOUT)!$D(DUOUT) ORQUIT=1 58 I $G(ORQUIT)!(Y'>0) K ORDIALOG(PROMPT,INST),^TMP($J,"ORCDPS3 NOW") Q 59 S ORDIALOG(PROMPT,INST)=1 I $G(ORCOMPLX) D 60 . W $C(7),!," >> First Dose NOW is in addition to those already entered. <<" 61 . W !," >> Please adjust the duration of the first one, if necessary. <<" 62 K ^TMP($J,"ORCDPS3 NOW") 63 Q 64 ; 65 DEFSTRT ; -- Returns default start date/time in Y 66 ; Expects PROMPT,INST,ORDIALOG,ORSD to be defined 67 ; 68 Q:$G(ORCAT)="O" Q:$G(ORTYPE)="Z" ;skip if outpt or editor 69 N LAST,STRT,DUR,D1,D2,OFF,F1,F2,UNT,Y1,Y2,I,J K Y 70 S LAST=+$O(ORDIALOG(+$$PTR^ORCD("OR GTX INSTRUCTIONS"),INST),-1) 71 S STRT=$G(ORDIALOG(PROMPT,LAST)) 72 I LAST'>0!'$L(STRT) S:$L($P($G(ORSD),U)) Y=$P(ORSD,U) Q ;first inst 73 S DUR=$G(ORDIALOG(+$$PTR^ORCD("OR GTX DURATION"),LAST)) 74 I +DUR'>0 S Y=STRT Q ;no duration = same start 75 S DUR=$$FMDUR(DUR) I STRT D Q ;FM date/time, so just add 76 . N X,%DT S %DT="TX",X=STRT_"+"_DUR D ^%DT 77 . I Y'>0 S Y=STRT ;error 78 S D1=+DUR,D2=$P(DUR,D1,2) S:(STRT="NEXTA")!(STRT="CLOSEST") STRT="NOW" 79 S OFF=$P(STRT,"+",2) I '$L(OFF) S Y=STRT_"+"_DUR Q ;no prev offset 80 S F1=+OFF,F2=$P(OFF,F1,2),UNT=F2,Y=STRT 81 I D2=F2 S Y=$P(STRT,"+")_"+"_(D1+F1)_UNT Q ;same units 82 F I="S","'","H","D","W","M" I (F2=I)!(D2=I) S UNT=I D Q 83 . S:D2=UNT Y1=D1,X1=F1,X2=F2 ; Y1=# in UNT 84 . S:F2=UNT Y1=F1,X1=D1,X2=D2 ; X1=# in other units X2 85 . F J=1:1 S Z=$T(CONV+J) Q:Z["ZZZZ" I $P(Z,";",3,4)=(X2_";"_UNT) S Y2=+$P(Z,";",5) Q 86 . S Y=$P(STRT,"+")_"+"_(Y1+$S(Y2:Y2*X1,1:0))_UNT 87 Q 88 ; 89 FMDUR(X) ; -- convert '# DAYS' to #D 90 N X1,X2,Y I +X'>0 Q "" 91 S X1=+X,X2=$P(X," ",2) S:'$L(X2) X2="DAYS" 92 S Y=X1_$S("MINUTES"[X2:"'",1:$E(X2)) 93 Q Y 94 ; 95 CONV ;;unit;unit;factor 96 ;;';S;60 97 ;;H;';60 98 ;;H;S;3600 99 ;;D;H;24 100 ;;D;';1440 101 ;;D;S;86400 102 ;;W;D;7 103 ;;W;H;168 104 ;;W;';10080 105 ;;W;S;604800 106 ;;M;W;4 107 ;;M;D;30 108 ;;M;H;720 109 ;;M;';43200 110 ;;M;S;2592000 111 ;;ZZZZ 112 ; 113 ASKDUR() ; -- Returns 1 or 0, if Duration prompt should be asked 114 K ^TMP($J,"ORCDPS3 ASKDUR") 115 N X,Y I '$G(ORCOMPLX) K ORDIALOG(PROMPT,INST) Q 0 116 S Y=1 G:'$L($G(ORSCH)) ADQ ;no schedule 117 D AP^PSS51P1("PSJ",,,,"ORCDPS3 ASKDUR") 118 S X=+$O(^TMP($J,"ORCDPS3 ASKDUR","APPSJ",ORSCH,"")) G:X'>0 ADQ 119 ;S X=+$O(^PS(51.1,"APPSJ",ORSCH,0)) G:X'>0 ADQ 120 S:^TMP($J,"ORCDPS3 ASKDUR",X,5)="O" Y=0 121 ;S:$P($G(^PS(51.1,X,0)),U,5)="O" Y=0 122 ADQ ; 123 K ^TMP($J,"ORCDPS3 ASKDUR") 124 Q Y 125 ; 126 CKDUR(X) ; -- Returns validated form of duration X, or null if invalid 127 N X1,X2,Y,Z S Y="" 128 S X1=+$G(X),X2=$P($G(X),X1,2) I X1'>0 Q "" 129 S X2=$$UP^XLFSTR(X2),X2=$$STRIP^XLFSTR(X2," ") S:'$L(X2) X2="DAYS" 130 F Z="MONTHS^&MONTHS&MONS","WEEKS^&WEEKS&WKS","DAYS^&DAYS&DYS","HOURS^&HOURS&HRS","MINUTES^&MINUTES&MINS'","SECONDS^&SECONDS&SECS" I $P(Z,U,2)[("&"_X2) S Y=$P(Z,U) Q 131 S:$L(Y) Y=X1_" "_$S(X1=1:$E(Y,1,$L(Y)-1),1:Y) ;strip trailing 's' 132 Q Y 133 ; 134 DUR ; -- Process duration [from P-S Action] 135 N X S X=$G(ORDIALOG(PROMPT,ORI)),X=$$CKDUR(X) 136 I '$L(X) K DONE W $C(7),!,ORDIALOG(PROMPT,"?"),! Q 137 S ORDIALOG(PROMPT,ORI)=X D:$G(ORESET)'=X CHANGED^ORCDPS1("QUANTITY") 138 Q 139 ; 140 TEST(START,DURTN) ; -- test DEFSTRT 141 N INST,ORSD,ORDIALOG,PROMPT 142 S ORDIALOG(136,1)="",INST=2,ORSD="NOW",PROMPT=6 143 S:$L($G(START)) ORDIALOG(6,1)=START S:$G(DURTN) ORDIALOG(153,1)=DURTN 144 D DEFSTRT W !,Y 145 Q 146 ; 147 SC ; -- Dialog validation, to ask SC questions 148 ; Expects ORIFN, ORDA, and ORDER 149 ; 150 Q:'$L($T(SCNEW^PSOCP)) Q:'$G(ORIFN) Q:'$G(ORDA) 151 Q:$P($G(^OR(100,ORIFN,0)),U,12)'="O" Q:$P($G(^(8,ORDA,0)),U,2)'="NW" Q:$P($G(^(0)),U,15)="" 152 ; 153 N OR3,ORDRUG,PSIFN,ORX,I,J,DIE,DR,DA,X,Y,DTOUT,ORIGVIEW,DFN 154 S OR3=$G(^OR(100,ORIFN,3)),X=$P(OR3,U,11) I X>2 Q ;new, edit, or renew 155 I X S Y=$P(OR3,U,5),PSIFN=$G(^OR(100,Y,4)) ;get PS# if edit/renewal 156 S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG") 157 D SCNEW^PSOCP(.ORX,+ORVP,ORDRUG,$G(PSIFN)) Q:'$D(ORX) 158 S DIE="^OR(100,",DA=ORIFN,DR="",J=0 159 F I="SC","MST","AO","IR","EC","HNC","CV" S J=J+1 I $D(ORX(I)) S X=ORX(I) S:I="CV"&(X="") X=1 S DR=DR_";5"_J_"R"_$S($L(X):"//"_$S(X:"YES",1:"NO"),1:"") 160 S:$E(DR)=";" DR=$E(DR,2,999) Q:'$L(DR) S ORIGVIEW=1 161 I $D(ORX("SC")) S DFN=+ORVP D DIS^DGRPDB ;show current SC data 162 W !!,"Is "_$$ORDITEM^ORCACT(ORDER)_" for treatment related to:" 163 D ^DIE S:$D(DTOUT)!$D(Y) ORQUIT=1 164 Q 1 ORCDPS3 ;SLC/MKB-Pharmacy dialog utilities ;11/25/02 09:47 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,158,149,190,277**;Dec 17, 199;Build 13 3 ; 4 START ; -- Start Date entry action 5 S $P(ORDIALOG(PROMPT,0),":",3)=$S($G(ORCAT)="I":"ETRX",1:"EX") 6 I $G(ORCAT)'="I" K ORSD K:$G(ORENEW)!$G(OREWRITE)!$D(OREDIT) ORDIALOG(PROMPT,INST) ;Inpt only 7 Q 8 ; 9 ADMIN ; -- Return default admin time for order in ORSD 10 ; Called from EXDOSE^ORCDPS2 11 Q:$D(ORSD) Q:$G(ORCAT)'="I" ;inpt only 12 N PSOI,PSIFN,SCH,CNJ,ORI,ORX 13 S PSOI=+$P($G(^ORD(101.43,+$G(OROI),0)),U,2) 14 S PSIFN=$S($G(ORENEW):$G(^OR(100,+$G(ORIFN),4)),1:"") 15 S SCH=$$PTR^ORCD("OR GTX SCHEDULE"),CNJ=$$PTR^ORCD("OR GTX AND/THEN"),ORX="" 16 S ORI=0 F S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI<1 S ORX=ORX_$S($L(ORX):U,1:"")_$G(ORDIALOG(CNJ,ORI))_";"_$G(ORDIALOG(SCH,ORI)) 17 S ORSD=$$FIRST(+ORVP,+$G(ORWARD),PSOI,ORX,PSIFN) 18 S:$P(ORSD,U)="NEXT" ORSD="NEXTA^"_$P(ORSD,U,2,99) 19 Q 20 ; 21 FIRST(DFN,WARD,OI,DATA,ORDER) ; -- Return expected first admin time of order 22 N ORCNT,ORI,J,ORZ,Y,SCH,ORX I '$G(DFN)!'$G(OI) Q "" 23 S ORCNT=0 F ORI=1:1:$L(DATA,"^") S ORZ=$P(DATA,U,ORI) D Q:$E(ORZ)="T" 24 . S SCH=$P(ORZ,";",2) Q:'$L(SCH) S ORCNT=ORCNT+1 25 . S ORX(ORCNT)=$$STARTSTP^PSJORPOE(DFN,SCH,OI,WARD,$G(ORDER)) 26 S Y=9999999,J=0 27 F ORI=1:1:ORCNT S ORZ=$P(ORX(ORI),U,4) I ORZ<Y S Y=ORZ,J=ORI ;earliest 28 S Y=$S(J:ORX(J),1:"") 29 Q Y 30 ; 31 NOW ; -- First dose now? 32 N X,Y,DIR,SCH 33 I $G(ORCAT)="O"!'$D(ORSD)!$L($G(OREVENT))!$G(ORENEW) K ORDIALOG(PROMPT,INST) Q 34 ; ask on Copy? Change? 35 S X=$$PTR^ORCD("OR GTX SCHEDULE"),Y=+$O(ORDIALOG(X,0)) 36 S SCH=$G(ORDIALOG(X,Y)),Y=+$O(^PS(51.1,"APPSJ",SCH,0)) ;1st one 37 I $P($G(^PS(51.1,Y,0)),U,5)="O"!(Y<1) K ORDIALOG(PROMPT,INST) Q 38 ; other conditions? 39 S DIR(0)="YA",DIR("A")="Give additional dose NOW? " 40 S DIR("B")=$S($G(ORDIALOG(PROMPT,INST)):"YES",1:"NO") 41 I ORINPT,$P(ORSD,U,4) S DIR("A",1)="Next scheduled administration time: "_$$FMTE^XLFDT($P(ORSD,U,4)) 42 S DIR("?")="Enter YES if you want a dose given now in addition to the regular administration times for this schedule and ward." 43 D ^DIR S:$D(DTOUT)!$D(DUOUT) ORQUIT=1 44 I $G(ORQUIT)!(Y'>0) K ORDIALOG(PROMPT,INST) Q 45 S ORDIALOG(PROMPT,INST)=1 I $G(ORCOMPLX) D 46 . W $C(7),!," >> First Dose NOW is in addition to those already entered. <<" 47 . W !," >> Please adjust the duration of the first one, if necessary. <<" 48 Q 49 ; 50 DEFSTRT ; -- Returns default start date/time in Y 51 ; Expects PROMPT,INST,ORDIALOG,ORSD to be defined 52 ; 53 Q:$G(ORCAT)="O" Q:$G(ORTYPE)="Z" ;skip if outpt or editor 54 N LAST,STRT,DUR,D1,D2,OFF,F1,F2,UNT,Y1,Y2,I,J K Y 55 S LAST=+$O(ORDIALOG(+$$PTR^ORCD("OR GTX INSTRUCTIONS"),INST),-1) 56 S STRT=$G(ORDIALOG(PROMPT,LAST)) 57 I LAST'>0!'$L(STRT) S:$L($P($G(ORSD),U)) Y=$P(ORSD,U) Q ;first inst 58 S DUR=$G(ORDIALOG(+$$PTR^ORCD("OR GTX DURATION"),LAST)) 59 I +DUR'>0 S Y=STRT Q ;no duration = same start 60 S DUR=$$FMDUR(DUR) I STRT D Q ;FM date/time, so just add 61 . N X,%DT S %DT="TX",X=STRT_"+"_DUR D ^%DT 62 . I Y'>0 S Y=STRT ;error 63 S D1=+DUR,D2=$P(DUR,D1,2) S:(STRT="NEXTA")!(STRT="CLOSEST") STRT="NOW" 64 S OFF=$P(STRT,"+",2) I '$L(OFF) S Y=STRT_"+"_DUR Q ;no prev offset 65 S F1=+OFF,F2=$P(OFF,F1,2),UNT=F2,Y=STRT 66 I D2=F2 S Y=$P(STRT,"+")_"+"_(D1+F1)_UNT Q ;same units 67 F I="S","'","H","D","W","M" I (F2=I)!(D2=I) S UNT=I D Q 68 . S:D2=UNT Y1=D1,X1=F1,X2=F2 ; Y1=# in UNT 69 . S:F2=UNT Y1=F1,X1=D1,X2=D2 ; X1=# in other units X2 70 . F J=1:1 S Z=$T(CONV+J) Q:Z["ZZZZ" I $P(Z,";",3,4)=(X2_";"_UNT) S Y2=+$P(Z,";",5) Q 71 . S Y=$P(STRT,"+")_"+"_(Y1+$S(Y2:Y2*X1,1:0))_UNT 72 Q 73 ; 74 FMDUR(X) ; -- convert '# DAYS' to #D 75 N X1,X2,Y I +X'>0 Q "" 76 S X1=+X,X2=$P(X," ",2) S:'$L(X2) X2="DAYS" 77 S Y=X1_$S("MINUTES"[X2:"'",1:$E(X2)) 78 Q Y 79 ; 80 CONV ;;unit;unit;factor 81 ;;';S;60 82 ;;H;';60 83 ;;H;S;3600 84 ;;D;H;24 85 ;;D;';1440 86 ;;D;S;86400 87 ;;W;D;7 88 ;;W;H;168 89 ;;W;';10080 90 ;;W;S;604800 91 ;;M;W;4 92 ;;M;D;30 93 ;;M;H;720 94 ;;M;';43200 95 ;;M;S;2592000 96 ;;ZZZZ 97 ; 98 ASKDUR() ; -- Returns 1 or 0, if Duration prompt should be asked 99 N X,Y I '$G(ORCOMPLX) K ORDIALOG(PROMPT,INST) Q 0 100 S Y=1 G:'$L($G(ORSCH)) ADQ ;no schedule 101 S X=+$O(^PS(51.1,"APPSJ",ORSCH,0)) G:X'>0 ADQ 102 S:$P($G(^PS(51.1,X,0)),U,5)="O" Y=0 103 ADQ Q Y 104 ; 105 CKDUR(X) ; -- Returns validated form of duration X, or null if invalid 106 N X1,X2,Y,Z S Y="" 107 S X1=+$G(X),X2=$P($G(X),X1,2) I X1'>0 Q "" 108 S X2=$$UP^XLFSTR(X2),X2=$$STRIP^XLFSTR(X2," ") S:'$L(X2) X2="DAYS" 109 F Z="MONTHS^&MONTHS&MONS","WEEKS^&WEEKS&WKS","DAYS^&DAYS&DYS","HOURS^&HOURS&HRS","MINUTES^&MINUTES&MINS'","SECONDS^&SECONDS&SECS" I $P(Z,U,2)[("&"_X2) S Y=$P(Z,U) Q 110 S:$L(Y) Y=X1_" "_$S(X1=1:$E(Y,1,$L(Y)-1),1:Y) ;strip trailing 's' 111 Q Y 112 ; 113 DUR ; -- Process duration [from P-S Action] 114 N X S X=$G(ORDIALOG(PROMPT,ORI)),X=$$CKDUR(X) 115 I '$L(X) K DONE W $C(7),!,ORDIALOG(PROMPT,"?"),! Q 116 S ORDIALOG(PROMPT,ORI)=X D:$G(ORESET)'=X CHANGED^ORCDPS1("QUANTITY") 117 Q 118 ; 119 TEST(START,DURTN) ; -- test DEFSTRT 120 N INST,ORSD,ORDIALOG,PROMPT 121 S ORDIALOG(136,1)="",INST=2,ORSD="NOW",PROMPT=6 122 S:$L($G(START)) ORDIALOG(6,1)=START S:$G(DURTN) ORDIALOG(153,1)=DURTN 123 D DEFSTRT W !,Y 124 Q 125 ; 126 SC ; -- Dialog validation, to ask SC questions 127 ; Expects ORIFN, ORDA, and ORDER 128 ; 129 Q:'$L($T(SCNEW^PSOCP)) Q:'$G(ORIFN) Q:'$G(ORDA) 130 Q:$P($G(^OR(100,ORIFN,0)),U,12)'="O" Q:$P($G(^(8,ORDA,0)),U,2)'="NW" Q:$P($G(^(0)),U,15)="" 131 ; 132 N OR3,ORDRUG,PSIFN,ORX,I,J,DIE,DR,DA,X,Y,DTOUT,ORIGVIEW,DFN 133 S OR3=$G(^OR(100,ORIFN,3)),X=$P(OR3,U,11) I X>2 Q ;new, edit, or renew 134 I X S Y=$P(OR3,U,5),PSIFN=$G(^OR(100,Y,4)) ;get PS# if edit/renewal 135 S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG") 136 D SCNEW^PSOCP(.ORX,+ORVP,ORDRUG,$G(PSIFN)) Q:'$D(ORX) 137 S DIE="^OR(100,",DA=ORIFN,DR="",J=0 138 F I="SC","MST","AO","IR","EC","HNC","CV" S J=J+1 I $D(ORX(I)) S X=ORX(I) S:I="CV"&(X="") X=1 S DR=DR_";5"_J_"R"_$S($L(X):"//"_$S(X:"YES",1:"NO"),1:"") 139 S:$E(DR)=";" DR=$E(DR,2,999) Q:'$L(DR) S ORIGVIEW=1 140 I $D(ORX("SC")) S DFN=+ORVP D DIS^DGRPDB ;show current SC data 141 W !!,"Is "_$$ORDITEM^ORCACT(ORDER)_" for treatment related to:" 142 D ^DIE S:$D(DTOUT)!$D(Y) ORQUIT=1 143 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPSH.m
r613 r623 1 ORCDPSH 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,215,243**;Dec 17, 1997;Build 242 3 4 5 6 7 EN(TYPE) 8 9 10 11 12 13 14 15 16 EN1 17 18 19 20 21 22 ENOI 23 24 25 26 CHANGED(X) 27 28 29 30 31 32 33 34 35 36 37 38 ORDITM(OI) 39 40 41 42 43 OI1 44 OI2 45 46 47 48 49 50 51 NFI(OI) 52 53 54 55 56 57 58 59 60 61 62 63 CONT() 64 65 66 67 68 69 WAIT 70 71 72 73 ROUTES 74 75 76 77 78 79 80 DEFRTE 81 82 83 84 85 86 CKSCH 87 88 89 90 W $C(7),!,"Enter a standard schedule for administering this medication or one of your own,",!,"up to 20 characters.",!91 92 93 94 PTR(X) 95 96 97 EXIT 98 99 100 101 1 ORCDPSH ;SLC/CLA-Pharmacy dialog utilities-Non-VA Meds ; 09 April 2003 11:00 AM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,215**;Dec 17, 1997 3 ; 4 ; DBIA 2418 START^PSSJORDF ^TMP("PSJMR",$J) 5 ; DBIA 3166 EN^PSSDIN ^TMP("PSSDIN",$J) 6 ; 7 EN(TYPE) ; -- entry action for Meds dialogs 8 S ORDG=+$O(^ORD(100.98,"B","NV RX",0)),ORCAT="O" 9 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 10 I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT)!$G(ORXFER) D 11 . K ORDIALOG($$PTR("START DATE/TIME"),1) 12 . K ORDIALOG($$PTR("NOW"),1) 13 . I $D(OREDIT),'$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) K ^TMP("ORWORD",$J) 14 Q 15 ; 16 EN1 ; -- setup Non-VA Meds dialog for quick order editor using ORDG 17 N DG S DG=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) 18 S ORINPT=0,ORCAT="O" 19 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 20 Q 21 ; 22 ENOI ; -- setup OI prompt 23 S ORDIALOG(PROMPT,"D")="S.NV RX" 24 Q 25 ; 26 CHANGED(X) ; -- Kill dependent values when prompt X changes 27 N PROMPTS,NAME,PTR,P,I 28 S PROMPTS=X I X="OI" D 29 . S PROMPTS="INSTRUCTIONS^ROUTE^SCHEDULE^START DATE/TIME^DOSE^DISPENSE DRUG^SIG^PATIENT INSTRUCTIONS" 30 . K ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,ORQTY,ORQTYUNT,OREFILLS,ORCOPAY 31 . K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 32 F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D 33 . S PTR=$$PTR(NAME) Q:'PTR 34 . S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I) 35 . K ORDIALOG(PTR,"LIST"),^TMP("ORWORD",$J,PTR) 36 Q 37 ; 38 ORDITM(OI) ; -- Check OI inactive date & type, get dependent info 39 Q:OI'>0 ;quit - no value 40 N ORPS,PSOI S ORPS=$G(^ORD(101.43,+OI,"PS")),PSOI=+$P($G(^(0)),U,2) 41 S ORIV=$S($P(ORPS,U)=2:1,1:0) 42 I '$P(ORPS,U,7) W $C(7),!,"This drug may not be used in a non-VA med order." S ORQUIT=1 D WAIT Q 43 OI1 ; ck NF status (don't care if Non-VA Meds are formulary or not) 44 OI2 ; -get selectable routes, doses [also called from NF^ORCDPS] 45 D:'$D(^TMP("PSJMR",$J)) START^PSSJORDF(PSOI,$G(ORCAT)) ;DBIA 2418 46 I '$D(ORDOSE) D 47 . D DOSE^PSSORUTL(.ORDOSE,PSOI,"X",+ORVP) 48 . K:$G(ORDOSE(1))=-1 ORDOSE 49 Q 50 ; 51 NFI(OI) ; -- Show NFI restrictions, if exist 52 N PSOI,I,J,LCNT,MAX,X,STOP 53 S PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) 54 D EN^PSSDIN(PSOI,"") Q:'$D(^TMP("PSSDIN",$J,"OI",PSOI)) ;DBIA 3166 55 S I=0,LCNT=0,MAX=$S($G(IOBM)&$G(IOTM):IOBM-IOTM+1,1:24) W ! 56 F S I=$O(^TMP("PSSDIN",$J,"OI",PSOI,I)) Q:I'>0 D 57 . S J=0 F S J=$O(^TMP("PSSDIN",$J,"OI",PSOI,I,J)) Q:J'>0 S X=$G(^(J)) D Q:$G(STOP) 58 .. S LCNT=LCNT+1 I LCNT'<MAX S:'$$CONT STOP=1 Q:$G(STOP) S LCNT=1 59 .. W !,X 60 W ! K ^TMP("PSSDIN",$J,"OI",PSOI) 61 Q 62 ; 63 CONT() ; -- Press return to cont or ^ to stop 64 N X,Y,DIR,DUOUT,DTOUT,DIRUT,DIROUT S DIR(0)="EA" 65 S DIR("A")="Press <return> to continue or ^ to stop ..." 66 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="" 67 Q +Y 68 ; 69 WAIT ; -- Wait for user 70 N X W !,"Press <return> to continue ..." R X:DTIME 71 Q 72 ; 73 ROUTES ; -- Get allowable med routes 74 Q:$G(ORDIALOG(PROMPT,"LIST")) N I,X,CNT S (I,CNT)=0 75 F S I=$O(^TMP("PSJMR",$J,I)) Q:I'>0 S X=^(I),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=$P(X,U,3)_U_$P(X,U,1,2),ORDIALOG(PROMPT,"LIST","B",$P(X,U))=$P(X,U,3) 76 S:$G(CNT) ORDIALOG(PROMPT,"LIST")=CNT 77 S REQD=0 78 Q 79 ; 80 DEFRTE ; -- Get default route 81 N INST1 S INST1=$O(ORDIALOG(PROMPT,0)) S:INST1'>0 INST1=INST ;1st inst 82 I INST1=INST S Y=+$P($G(^TMP("PSJMR",$J,1)),U,3) K:Y'>0 Y Q 83 S Y=+$G(ORDIALOG(PROMPT,INST1)) K:Y'>0 Y S:$G(Y) EDITONLY=1 84 Q 85 ; 86 CKSCH ; -- validate schedule [Called from P-S Action] 87 N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET) K ORSD ;reset 88 D EN^PSSGS0(.ORX,"X") 89 I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX D CHANGED("QUANTITY") Q ;ok 90 W $C(7),!,"Enter either a standard administration schedule or one of your own,",!,"up to 70 characters and no more than 2 spaces.",! 91 K DONE 92 Q 93 ; 94 PTR(X) ; -- Return ptr to prompt OR GTX X 95 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) 96 ; 97 EXIT ; -- exit action for Meds dialogs 98 S:$G(ORXNP) ORNP=ORXNP 99 K ORXNP,ORINPT,ORCAT,ORPKG,OROI,ORIV,ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,OREFILLS,ORQTY,ORQTYUNT,ORCOPAY,PSJNOPC,ORCOMPLX 100 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 101 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPSIV.m
r613 r623 1 ORCDPSIV ;SLC/MKB-Pharmacy IV dialog utilities ;5/07/08 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,38,48,158,195,243**;Dec 17, 1997;Build 242 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 CKSCH ; -- validate schedule [Called from P-S Action] 5 N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET) K ORSD 6 D EN^PSSGS0(.ORX,"I") 7 I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX Q 8 W $C(7),!,"Enter a standard schedule for administering this medication." 9 Q 10 ISONETIM(SCH) ; 11 N DUR 12 I SCH="" Q 0 13 K ^TMP($J,"ORCDPSIV GETSCHTYP") 14 D ZERO^PSS51P1(,SCH,"PSJ","O","ORCDPSIV GETSCHTYP") 15 I +^TMP($J,"ORCDPSIV GETSCHTYP",0)>0 D Q 1 16 .S DUR=$$PTR^ORCD("OR GTX DURATION") 17 .I $G(ORDIALOG(DUR,1))="" Q 18 .S ORDIALOG(DUR,1)="" 19 .W !,"IV Orders with a schedule type of one-time cannot have a duration." 20 .W !,"The duration has been deleted from this quick order." H 1 21 K ^TMP($J,"ORCDPSIV GETSCHTYP") 22 Q 0 23 ; 24 PROVIDER ; -- Check provider, if authorized to write med orders 25 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") W $C(7),!!,"OREMAS key holders may not enter medication orders." S ORQUIT=1 Q 26 N PS,NAME S PS=$G(^VA(200,+$G(ORNP),"PS")),NAME=$P($G(^(20)),U,2) 27 I '$L(NAME) S NAME=$P(^VA(200,+$G(ORNP),0),U) 28 I '$P(PS,U) W $C(7),!!,NAME_" is not authorized to write medication orders!" S ORQUIT=1 29 I $P(PS,U,4),$$NOW^XLFDT>$P(PS,U,4) W $C(7),!!,NAME_" is no longer authorized to write medication orders!" S ORQUIT=1 30 I $G(ORQUIT) W !,"You must select another provider to continue.",! S PS=$$MEDPROV I PS S ORXNP=ORNP,ORNP=PS K ORQUIT 31 Q 32 ; 33 MEDPROV() ; -- Return ordering med provider 34 N X,Y,D,DIC 35 S DIC=200,DIC(0)="AEQ",DIC("A")="Select PROVIDER: ",D="AK.PROVIDER" 36 S DIC("S")="I $P($G(^(""PS"")),U),'$P(^(""PS""),U,4)!($P(^(""PS""),U,4)>$$NOW^XLFDT)" 37 D IX^DIC S:Y>0 Y=+Y I Y'>0 S Y="^" 38 Q Y 39 ; 40 CHANGED(TYPE) ; -- Kill dependent values when OI changes 41 N PROMPTS,NAME,PTR,P,I 42 Q:'$L($G(TYPE)) S PROMPTS="" 43 S:TYPE="B" PROMPTS="VOLUME" 44 S:TYPE="A" PROMPTS="STRENGTH PSIV^UNITS" 45 S:TYPE="T" PROMPTS="INFUSION RATE^SCHEDULE" 46 F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D 47 . S PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) Q:'PTR 48 . S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I) 49 . K ORDIALOG(PTR,"LIST") 50 Q 51 ; 52 INACTIVE(TYPE) ; -- Check OI inactive date 53 N OI,X,I,PSOI,DEA,EXIT S:$G(TYPE)'="A" TYPE="S" 54 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:OI'>0 55 I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D Q ;inactive 56 . S X=$S(TYPE="A":"additive",1:"solution"),ORQUIT=1 57 . W $C(7),!,"This "_X_" may not be ordered anymore. Please select another." 58 S I=$S(TYPE="A":4,1:3) I '$P($G(^ORD(101.43,OI,"PS")),U,I) D Q 59 . S X=$S(TYPE="A":"an additive",1:"a solution"),ORQUIT=1 60 . W $C(7),!,"This item may not be ordered as "_X_"." 61 S EXIT=$$INPT^ORCD I EXIT=0 D ROUTECHK Q 62 Q:'$L($T(IVDEA^PSSUTIL1)) ;DBIA #3784 63 S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) 64 S DEA=$$IVDEA^PSSUTIL1(PSOI,TYPE) I DEA>0 D Q:$G(ORQUIT) 65 . I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q 66 . I DEA=1 W $C(7),!,"This order will require a wet signature!" 67 D ROUTECHK 68 Q 69 ; 70 VOLUME ; -- get allowable volumes for solution 71 N PSOI,ORY,CNT,I,XORY K ORDIALOG(PROMPT,"LIST") 72 S PSOI=+$P($G(^ORD(101.43,+$$VAL^ORCD("SOLUTION",INST),0)),U,2)_"B" 73 D ENVOL^PSJORUT2(PSOI,.ORY) Q:'ORY 74 ;S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",+ORY(I))=+ORY(I) 75 S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 D 76 . S CNT=CNT+1 77 . S XORY(I)=+ORY(I) I XORY(I)<1,$E(XORY(I),1,2)'="0." S XORY(I)=0_XORY(I) 78 . S ORDIALOG(PROMPT,"LIST",XORY(I))=XORY(I) 79 S ORDIALOG(PROMPT,"LIST")=CNT_"^1" 80 Q 81 ; 82 UNITS ; -- get allowable units for current additive 83 N PSOI,ORY,I,UNITS 84 S PSOI=+$P(^ORD(101.43,+ORDIALOG($$PTR^ORCD("OR GTX ADDITIVE"),INST),0),U,2)_"A" 85 D ENVOL^PSJORUT2(PSOI,.ORY) 86 S I=$O(ORY(0)) Q:'I S UNITS=$P($G(ORY(I)),U,2) 87 S ORDIALOG($$PTR^ORCD("OR GTX UNITS"),INST)=UNITS 88 W !," (Units for this additive are "_UNITS_")" 89 Q 90 ; 91 PREMIX() ; -- Returns 1 or 0, if IV base is a premix solution 92 N BASE,PS,I,Y 93 S BASE=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),Y=0 94 S I=0 F S I=$O(ORDIALOG(BASE,I)) Q:I'>0 D Q:Y 95 . S PS=$G(^ORD(101.43,+$G(ORDIALOG(BASE,I)),"PS")) 96 . I $P(PS,U,3)&($P(PS,U,4)) S Y=1 97 Q Y 98 ; 99 IVRTEENT ; 100 N ARRAY,DIR,RIEN,TROUTE 101 I ORTYPE'="Z" Q 102 S RIEN=$P($G(ORDIALOG("B","ROUTE")),U,2) Q:RIEN'>0 103 S EXIT=0,TROUTE=$G(ORDIALOG(RIEN,1)) Q:TROUTE'>0 104 I $$IVRTESCR(TROUTE)=1 Q 105 S ORDIALOG(RIEN,1)="" 106 W !!,"The selected route is not a valid route for this order." 107 W !,"Select a new route for this order from the list of routes below." 108 D RTEDISP(.ARRAY) 109 Q 110 ; 111 BIVOI(ARRAY) ; 112 N CNT,NUM,OIIEN,OTYPE 113 S CNT=0 114 F OTYPE="SOLUTION","ADDITIVE" D 115 .S OIIEN=+$P($G(ORDIALOG("B",OTYPE)),U,2) I OIIEN>0 D 116 ..S NUM=0 F S NUM=$O(ORDIALOG(OIIEN,NUM)) Q:NUM'>0 I +$G(ORDIALOG(OIIEN,NUM))>0 D 117 ...S CNT=CNT+1,ARRAY(CNT)=ORDIALOG(OIIEN,NUM) 118 Q 119 ; 120 LVROUTES ; 121 N ARRAY,ROUTES 122 D BIVOI(.ARRAY) 123 D IVDOSFRM^ORWDPS33(.ROUTES,.ARRAY,0,1) 124 D RTEDISP(.ROUTES) 125 Q 126 ; 127 RTEDISP(ROUTES) ; 128 N CNT 129 S CNT="" F S CNT=$O(ROUTES(CNT)) Q:CNT'>0 D 130 .W !,$P($G(ROUTES(CNT)),U,2) 131 Q 132 ; 133 IVRTESCR(Y) ; 134 N ARRAY,ROUTES,VALUE 135 D BIVOI(.ARRAY) 136 S VALUE=$$IVQOVAL^ORWDPS33(.ARRAY,Y) I VALUE'="" Q 1 137 Q 0 138 ; 139 ROUTECHK ; 140 N CNT,IEN,ROUTE,VALUE 141 S RIEN=$P($G(ORDIALOG("B","ROUTE")),U,2) Q:RIEN'>0 142 S TROUTE=$G(ORDIALOG(RIEN,1)) Q:TROUTE'>0 143 I $$IVRTESCR(TROUTE)=1 Q 144 S ORDIALOG(RIEN,1)="" 145 W !!,"The route defined for this order is an invalid route." 146 W !,"You will need to define a new route for this order." 147 Q 148 ; 149 ENRATE ; -- set display text, help based on IV TYPE 150 N X,MSG S X=$G(ORIVTYPE),MSG="" 151 S ORDIALOG(PROMPT,"A")=$S(X="I":"Infuse over time (min): ",1:"Infusion Rate (ml/hr): ") 152 S MSG="Enter the "_$S(X="I":"number of minutes over which to infuse this medication.",1:"infusion rate, as the number of ml/hr or Text@Number of Labels per day. ") 153 S ORDIALOG(PROMPT,"?")=MSG 154 I X="I" D 155 .N RATEI,RATEV,TIME,UNIT 156 .S RATEI=$P($G(ORDIALOG("B","INFUSION RATE")),U,2) Q:RATEI'>0 157 .S RATEV=$G(ORDIALOG(RATEI,1)) Q:'$L(RATEV) 158 .I RATEV'["INFUSE OVER" Q 159 .S TIME=$P(RATEV," ",3) 160 .S UNIT=$P(RATEV," ",4) 161 .I TIME["." Q 162 .I UNIT="Hours" S TIME=TIME*60 163 .S ORDIALOG(RATEI,1)=TIME 164 Q 165 ; 166 INF ; -- input transform for INFUSION RATE 167 N ALPHA,CNT,EXIT,FAIL,LDEC,RDEC,TEMP 168 I $G(ORIVTYPE)="I" D Q 169 .I X["." W !,"Infuse Over Time must be a whole number." K X Q 170 .I $L(X)>4 W !,"Infuse Over Time cannot exceed 4 spaces for minutes." K X 171 .S FAIL=0 172 .F CNT=1:1:$L(X) D I FAIL=1 Q 173 ..I ($A($E(X,CNT))<48)!($A($E(X,CNT))>58) S FAIL=1 174 .I FAIL=1 W !,"Infuse Over Time must be a whole number." K X Q 175 K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q 176 I $G(ORIVTYPE)="C" D Q 177 .S TEMP=$E(X,($L(X)-5),$L(X)) 178 .I X["@",$$UP^XLFSTR(TEMP)=" ML/HR" Q 179 .S ALPHA=0 180 .I X'["@" D I ALPHA=1 K X Q 181 ..F CNT=1:1:$L(X) D I ALPHA=1 Q 182 ...I ($A($E(X,CNT))<48)!($A($E(X,CNT))>58) S ALPHA=1 183 .S EXIT=0 184 .I X[".",X'["@" D I EXIT=1 K X Q 185 ..S LDEC=$P(X,"."),RDEC=$P(X,".",2) 186 ..I LDEC="" W !,"Infusion Rate required a leading numeric value." S EXIT=1 187 ..I $L(RDEC)>1 W !,"Infusion Rate cannot exceed one decimal place." S EXIT=1 188 ..S ALPHA=0 189 ..F CNT=1:1:$L(LDEC) D I ALPHA=1 S EXIT=1 Q 190 ...I ($A($E(LDEC,CNT))<48)!($A($E(LDEC,CNT))>58) S ALPHA=1 191 ..I $L(RDEC)=0 Q 192 ..F CNT=1:1:$L(RDEC) D I ALPHA=1 S EXIT=1 Q 193 ...I ($A($E(RDEC,CNT))<48)!($A($E(RDEC,CNT))>58) S ALPHA=1 194 .D ORINF^PSIVSP Q 195 ; -- assume #minutes for now 196 K:(X'=+X)!(X<1)!(X>999) X ;range? 197 Q 198 ; 199 VALIDAYS(X) ; -- Validate IV duration 200 N UNITS,X1,X2,Y,I 201 I X'?1.N." "1.A Q 0 202 S UNITS="^MIN^HOURS^DAYS^M^H^D^",(X1,X2)="" 203 F I=1:1:$L(X) S Y=$E(X,I) S:Y?1N X1=X1_Y S:Y?1A X2=X2_$$UP^XLFSTR(Y) 204 I 'X1 Q 0 205 I UNITS'[(U_X2_U) Q 0 206 Q 1 207 ; 208 VALDURA(X) ;-- Validate IV duration/limitation 209 K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q 210 ; 211 IVPSI ;INPUT-TRANSFORM 212 I $L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) S X="" Q 213 I $L(X)>1,X[" " W !,"Spaces are not allow in the duration." K X Q 214 I $E(X)=0 W !,!,"Duration cannot start with a zero." K X Q 215 I X["." W !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!" S X="" Q 216 S X=$$UP^XLFSTR(X) 217 I X["DOSES" D Q 218 .I $G(ORIVTYPE)'="I" K X W !,"Continuous IV Orders cannot have DOSES as a duration." Q 219 .I +$P(X,"DOSES")<1,+$P(X,"DOSES")>200000 W !,"Invalid number of Doses.",! K X Q 220 I (X'?.N1.2A),(X'?.N1".".N1.2A) W !,!,"Invalid duration or total volume.",! S X="" Q 221 I (X?.N1A) D 222 . I (X["L")!(X["H")!(X["D") Q 223 . E W !,!,"Invalid duration or total volume.",! S X="" Q 224 I (X?.N1".".N1A) D 225 . I X["L" Q 226 . E W !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!",! S X="" Q 227 I (X?.N2A)!(X?.N1".".N2A) D 228 . I (X["ML")!(X["CC") Q 229 . E W !,!,"Invalid duration or total volume",! S X="" Q 230 I X="" K X 231 Q 232 ; 233 IVPSI1 ; ASK ON CONDITION 234 N DURI,DURV 235 I $G(OROTSCH)=1 Q 236 S DURI=$P($G(ORDIALOG("B","LIMITATION")),U,2) 237 I DURI>0 S DURV=$G(ORDIALOG(DURI,1)) 238 I $L(DURV)>1,$E(DURV)="f",DURV["doses" D 239 .S TEMPX=$P(DURV," ",5)_"DOSES" 240 .I TEMPX'="",TEMPX'=DURV S ORDIALOG(DURI,1)=TEMPX 241 N INT,IVTYPE,ONETIME,TYPE,SCH,SCHNAME 242 I $G(ORIVTYPE)'="I" D G IVPS1X 243 .W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours to set limitation." 244 .W !,"(Examples: 1500ML, 1000CC, 1L, 3D, or 72H)",! 245 W !,"This field is optional a value does not need to be entered." 246 W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours or DOSES to set limitation." 247 W !,"(Examples: 1500ML, 1000CC, 1L, 3D, 72H, or 10DOSES)",! 248 IVPS1X ; 249 W !,"This field is optional a value does not need to be entered." 250 I 1 251 Q 1 ORCDPSIV ;SLC/MKB-Pharmacy IV dialog utilities ;11/25/02 09:47 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,38,48,158,195**;Dec 17, 1997 3 PROVIDER ; -- Check provider, if authorized to write med orders 4 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") W $C(7),!!,"OREMAS key holders may not enter medication orders." S ORQUIT=1 Q 5 N PS,NAME S PS=$G(^VA(200,+$G(ORNP),"PS")),NAME=$P($G(^(20)),U,2) 6 I '$L(NAME) S NAME=$P(^VA(200,+$G(ORNP),0),U) 7 I '$P(PS,U) W $C(7),!!,NAME_" is not authorized to write medication orders!" S ORQUIT=1 8 I $P(PS,U,4),$$NOW^XLFDT>$P(PS,U,4) W $C(7),!!,NAME_" is no longer authorized to write medication orders!" S ORQUIT=1 9 I $G(ORQUIT) W !,"You must select another provider to continue.",! S PS=$$MEDPROV I PS S ORXNP=ORNP,ORNP=PS K ORQUIT 10 Q 11 ; 12 MEDPROV() ; -- Return ordering med provider 13 N X,Y,D,DIC 14 S DIC=200,DIC(0)="AEQ",DIC("A")="Select PROVIDER: ",D="AK.PROVIDER" 15 S DIC("S")="I $P($G(^(""PS"")),U),'$P(^(""PS""),U,4)!($P(^(""PS""),U,4)>$$NOW^XLFDT)" 16 D IX^DIC S:Y>0 Y=+Y I Y'>0 S Y="^" 17 Q Y 18 ; 19 CHANGED(TYPE) ; -- Kill dependent values when OI changes 20 N PROMPTS,NAME,PTR,P,I 21 Q:'$L($G(TYPE)) S PROMPTS="" 22 S:TYPE="B" PROMPTS="VOLUME" 23 S:TYPE="A" PROMPTS="STRENGTH PSIV^UNITS" 24 F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D 25 . S PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) Q:'PTR 26 . S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I) 27 . K ORDIALOG(PTR,"LIST") 28 Q 29 ; 30 INACTIVE(TYPE) ; -- Check OI inactive date 31 N OI,X,I,PSOI,DEA S:$G(TYPE)'="A" TYPE="S" 32 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:OI'>0 33 I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D Q ;inactive 34 . S X=$S(TYPE="A":"additive",1:"solution"),ORQUIT=1 35 . W $C(7),!,"This "_X_" may not be ordered anymore. Please select another." 36 S I=$S(TYPE="A":4,1:3) I '$P($G(^ORD(101.43,OI,"PS")),U,I) D Q 37 . S X=$S(TYPE="A":"an additive",1:"a solution"),ORQUIT=1 38 . W $C(7),!,"This item may not be ordered as "_X_"." 39 Q:'$$INPT^ORCD Q:'$L($T(IVDEA^PSSUTIL1)) ;DBIA #3784 40 S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) 41 S DEA=$$IVDEA^PSSUTIL1(PSOI,TYPE) I DEA>0 D Q:$G(ORQUIT) 42 . I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q 43 . I DEA=1 W $C(7),!,"This order will require a wet signature!" 44 Q 45 ; 46 VOLUME ; -- get allowable volumes for solution 47 N PSOI,ORY,CNT,I K ORDIALOG(PROMPT,"LIST") 48 S PSOI=+$P($G(^ORD(101.43,+$$VAL^ORCD("SOLUTION",INST),0)),U,2)_"B" 49 D ENVOL^PSJORUT2(PSOI,.ORY) Q:'ORY 50 S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",+ORY(I))=+ORY(I) 51 S ORDIALOG(PROMPT,"LIST")=CNT_"^1" 52 Q 53 ; 54 UNITS ; -- get allowable units for current additive 55 N PSOI,ORY,I,UNITS 56 S PSOI=+$P(^ORD(101.43,+ORDIALOG($$PTR^ORCD("OR GTX ADDITIVE"),INST),0),U,2)_"A" 57 D ENVOL^PSJORUT2(PSOI,.ORY) 58 S I=$O(ORY(0)) Q:'I S UNITS=$P($G(ORY(I)),U,2) 59 S ORDIALOG($$PTR^ORCD("OR GTX UNITS"),INST)=UNITS 60 W !," (Units for this additive are "_UNITS_")" 61 Q 62 ; 63 PREMIX() ; -- Returns 1 or 0, if IV base is a premix solution 64 N BASE,PS,I,Y 65 S BASE=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),Y=0 66 S I=0 F S I=$O(ORDIALOG(BASE,I)) Q:I'>0 D Q:Y 67 . S PS=$G(^ORD(101.43,+$G(ORDIALOG(BASE,I)),"PS")) 68 . I $P(PS,U,3)&($P(PS,U,4)) S Y=1 69 Q Y 70 ; 71 VALIDAYS(X) ; -- Validate IV duration 72 N UNITS,X1,X2,Y,I 73 I X'?1.N." "1.A Q 0 ; invalid format 74 S UNITS="^MIN^HOURS^DAYS^M^H^D^",(X1,X2)="" 75 F I=1:1:$L(X) S Y=$E(X,I) S:Y?1N X1=X1_Y S:Y?1A X2=X2_$$UP^XLFSTR(Y) 76 I 'X1 Q 0 77 I UNITS'[(U_X2_U) Q 0 78 Q 1 79 ; 80 VALDURA(X) ;-- Validate IV duration/limitation 81 K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q 82 ; 83 IVPSI ;INPUT-TRANSFORM 84 I $L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) S X="" Q 85 S X=$$UP^XLFSTR(X) 86 I (X'?.N1.2A),(X'?.N1".".N1.2A) W !,!,"Invalid duration or total volume.",! S X="" Q 87 I (X?.N1A) D 88 . I (X["L")!(X["H")!(X["D") Q 89 . E W !,!,"Invalid duration or total volume.",! S X="" Q 90 I (X?.N1".".N1A) D 91 . I X["L" Q 92 . E W !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!",! S X="" Q 93 I (X?.N2A)!(X?.N1".".N2A) D 94 . I (X["ML")!(X["CC") Q 95 . E W !,!,"Invalid duration or total volume",! S X="" Q 96 I X="" K X 97 Q 98 ; 99 IVPSI1 ; ASK ON CONDITION 100 W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours to set limitation." 101 W !,"(Examples: 1500ML, 1000CC, 1.5L, 3D, or 72H)",! 102 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCFLAG.m
r613 r623 1 ORCFLAG ; SLC/MKB - Flag orders ;12/26/20062 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,243**;Dec 17, 1997;Build 242 3 4 EN1(ORIFN) 5 6 7 8 9 10 11 12 13 14 15 16 EN 17 18 19 20 21 22 23 24 25 26 27 28 UN 29 30 31 32 33 34 35 36 37 38 39 SHOWFLAG 40 41 42 43 44 45 46 REASON() 47 48 49 50 51 52 53 COMMENT() 54 55 56 57 58 59 60 PROV(ORDR) 61 62 63 64 65 66 67 68 BULLETIN 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 LTIM(X) 87 88 89 90 91 92 MSG(ORDER) 93 94 95 96 97 Q:"^PSJ^PSIV^PSO^"'[(U_$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)_U) ;Inpt or IV98 99 100 101 102 103 104 105 106 1 ORCFLAG ; SLC/MKB - Flag orders ;6/2/97 10:44 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141**;Dec 17, 1997 3 ; 4 EN1(ORIFN) ; -- standalone entry point to un/flag order ORIFN 5 N ORLK,ORERR,VA,VADM,VAERR,DFN,ORVP,ORPNM,ORSSN,ORAGE,ORACTN,ORPS 6 Q:'$G(ORIFN) S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";1" 7 S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2),DFN=+ORVP I 'ORVP!'$D(^(8,+$P(ORIFN,";",2),0)) W !,"Missing or invalid order!" H 1 Q 8 D DEM^VADPT S ORPNM=VADM(1),ORSSN=$P(VADM(2),U,2),ORAGE=VADM(4) 9 S ORACTN=$S($G(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),3)):"UF",1:"FL") 10 I '$$VALID^ORCACT0(ORIFN,ORACTN,.ORERR) W !,ORERR H 1 Q 11 S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q 12 S ORACTN=$S(ORACTN="UF":"UN",1:"EN"),ORPS=1 13 D @ORACTN,UNLK1^ORX2(+ORIFN) 14 Q 15 ; 16 EN ; -- Flag order ORIFN 17 N OREASON,DA,ORB,ORNP,ORNOW S ORNOW=+$E($$NOW^XLFDT,1,12) 18 S DA=$P(ORIFN,";",2) I 'DA W !,"Unable to flag!" H 1 Q 19 S OREASON=$$REASON Q:OREASON="^" 20 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3),ORNP=$$PROV(ORNP) Q:ORNP="^" 21 D BULLETIN ;use ORNP? 22 K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_ORNOW_U_DUZ_U_OREASON_"^^^^"_ORNP 23 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT,OREBUILD=1 ; Last Activity 24 S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification 25 W !?10,"... order flagged." H 1 D KILL^XM,MSG(ORIFN) 26 Q 27 ; 28 UN ; -- Unflag order ORIFN 29 N OREASON,DA,ORB,ORNP,ORNOW S ORNOW=+$E($$NOW^XLFDT,1,12) 30 S DA=$P(ORIFN,";",2) I 'DA W !,"Unable to unflag order!" H 1 Q 31 D SHOWFLAG S OREASON=$$COMMENT Q:OREASON="^" 32 S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=ORNOW_U_DUZ_U_OREASON 33 S ORNP=+$P(^OR(100,+ORIFN,8,DA,3),U,9) S:'ORNP ORNP=+$P($G(^(0)),U,3) 34 S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification 35 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT,OREBUILD=1 ; Last Activity 36 W !?10,"... order unflagged." H 1 D MSG(ORIFN) 37 Q 38 ; 39 SHOWFLAG ; -- Display [last] flag for order ORIFN 40 N FLAG 41 S FLAG=$G(^OR(100,+ORIFN,8,DA,3)) 42 W !," FLAGGED: "_$$LTIM($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U) 43 W !?10,$P(FLAG,U,5) ; reason 44 Q 45 ; 46 REASON() ; -- Reason for flag 47 N X,Y,DIR 48 S DIR(0)="FA^1:80",DIR("A")="REASON FOR FLAG: " ; ck E3R 49 S DIR("?")="A reason must be entered to flag this order." 50 D ^DIR 51 Q Y 52 ; 53 COMMENT() ; -- Comments on unflag 54 N X,Y,DIR 55 S DIR(0)="FAO^1:80",DIR("A")="COMMENTS: " 56 S DIR("?")="A comment may be entered to clarify this order." 57 D ^DIR S:$D(DTOUT) Y="^" 58 Q Y 59 ; 60 PROV(ORDR) ; -- Get provider to alert 61 N X,Y,DIC 62 S DIC=200,DIC(0)="AEQM",DIC("A")="Send alert to: " 63 I $G(ORDR) S ORDR=$P($G(^VA(200,+ORDR,0)),U) S:$L(ORDR) DIC("B")=ORDR 64 S DIC("S")="N ORT S ORT=$P(^(0),U,11) I 'ORT!(ORT>DT)" 65 D ^DIC S:Y>0 Y=+Y I Y'>0 S Y="^" 66 Q Y 67 ; 68 BULLETIN ; -- Send bulletin re: flag 69 N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR 70 S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)) ;ORUSR=+$P(OR0,U,4) 71 S ORUSR=+$G(ORNP),ORSRV=+$P($G(^VA(200,ORUSR,5)),U) 72 S ORENT="USR.`"_ORUSR_"^SRV.`"_ORSRV_"^DIV^SYS^PKG" 73 S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q") 74 Q:$G(BULL)'="Y" ;quit if parameter value is not 'Y'es 75 ; 76 W !,"Sending bulletin to "_$P($G(^VA(200,ORUSR,0)),U)_"..." 77 S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(ORUSR)="" 78 S XMB(1)=ORPNM,XMB(2)=ORSSN,XMB(3)=ORAGE,XMB(4)=$$LTIM($P(OR0,U,7)) 79 D TEXT^ORQ12(.ORDTXT,+ORIFN,80) 80 S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3)) 81 S XMB(8)=$$LTIM($P(OR0,U,8)),XMB(9)=$$LTIM($P(OR0,U,9)),XMB(10)=OREASON 82 S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U) 83 D EN^XMB 84 Q 85 ; 86 LTIM(X) ; -- format FM date/time into MM/DD HH:MM 87 N Y S Y="" 88 S:X Y=$E(X,4,5)_"/"_$E(X,6,7) 89 S:X["." Y=Y_" "_$E(X_"0",9,10)_":"_$E(X_"000",11,12) 90 Q Y 91 ; 92 MSG(ORDER) ; -- Sends HL7 message to Pharmacy when order is un/flagged 93 Q:'$L($T(OBR^PSJHL4)) ;needs PSJ*5*85 94 Q:'$G(ORDER) Q:'$D(^OR(100,+ORDER,0)) Q:'$P(ORDER,";",2) 95 N OR0,OR3,ORMSG,ORVP,ORX,ORFLAG 96 S OR0=$G(^OR(100,+ORDER,0)),OR3=$G(^(8,+$P(ORDER,";",2),3)) 97 Q:"^PSJ^PSIV^"'[(U_$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)_U) ;Inpt or IV 98 S ORMSG(1)=$$MSH^ORMBLD("ORU","PS") 99 S ORVP=$P(OR0,U,2),ORMSG(2)=$$PID^ORMBLD(ORVP) 100 S ORMSG(3)=$$PV1^ORMBLD(ORVP,$P(OR0,U,12),+$P(OR0,U,10)) 101 S ORX=$S(OR3:$P(OR3,U,3,5),1:$P(OR3,U,6,8)) 102 S ORFLAG=$S(OR3:"FL",1:"UF")_"|||"_$$HL7DATE^ORMBLD($P(ORX,U))_"||||||"_$P(ORX,U,3)_"|||"_+$P(ORX,U,2) 103 S:$G(ORPS) ORFLAG=ORFLAG_"||||||||PHR" ;action taken by pharmacist 104 S ORMSG(4)="OBR|1|"_ORDER_"^OR|"_$G(^OR(100,+ORDER,4))_"^PS|"_ORFLAG 105 D MSG^XQOR("OR EVSEND PS",.ORMSG) 106 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHANG2.m
r613 r623 1 ORCHANG2 ;SLC/MKB-Change View status ; 08 May 2002 2:12 PM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,68,141,215,243**;Dec 17, 1997;Build 242 3 ORDERS ; -- Select new order status 4 N X,Y,HDR,I,DOMAIN,DEFAULT,PROMPT,HELP,STS 5 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT="" 6 F I=1:1 S X=$T(ORDSTS+I) Q:$P(X,";",4)="ZZZZ" D SET 7 S DOMAIN(0)=I-1,PROMPT="Select Order Status: " 8 S HELP="Enter the status of orders you wish to see listed here." 9 D EN Q:Y="^" S STS=+$G(DOMAIN(Y)) 10 I "^8^9^10^20^"[(U_STS_U) D Q:Y="^" 11 . N STRT,STOP,Z 12 . S STRT=$$START^ORCHANGE("NOW-24H") I STRT="^" S Y="^" Q 13 . S STOP=$$STOP^ORCHANGE("NOW") I STOP="^" S Y="^" Q 14 . I STOP<STRT S Z=STRT,STRT=STOP,STOP=Z 15 . S $P(HDR,";",1,2)=$P(STRT,U,2)_";"_$P(STOP,U,2) 16 S $P(HDR,";",3)=STS,$P(HDR,";",8)="" 17 I (STS=2)!(STS=5) D 18 . I $P(HDR,";")'="" D 19 . . N THISTS,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y 20 . . S THISTS=" only active " 21 . . S:STS=5 THISTS=" expiring " 22 . . W !,"Date range can not be selected when viewing"_THISTS_"orders" 23 . . W !,"and will be cleared." 24 . . S DIR(0)="E" D ^DIR 25 . S $P(HDR,";",1,2)=";" 26 I STS=6,$P(HDR,";")="" S $P(HDR,";",1,2)="T;T@23:59" 27 S $P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 28 Q 29 ; 30 STSLST(ORY) ; -- Returns array of order views as 31 ; ORY(n) = id ^ name ^ parent id [^+ if has members] 32 N I,X,CNT S CNT=0 33 F I=1:1 S X=$T(ORDSTS+I) Q:$P(X,";",4)="ZZZZ" S CNT=CNT+1,ORY(CNT)=$TR($P(X,";",3,6),";","^") 34 ; include specific patient events?? 35 Q 36 ; 37 ORDSTS ;;#;Name of Order Context 38 ;;1;All;0;+ 39 ;;2;Active (includes pending, recent activity);1 40 ;;23;Current (Active & Pending status only);1 41 ;;3;Discontinued;1 42 ;;28;Discontinued/Entered in Error;1 43 ;;4;Completed/Expired;1 44 ;;5;Expiring;1 45 ;;7;Pending;1 46 ;;18;On Hold;1 47 ;;19;New Orders;1 48 ;;11;Unsigned;1 49 ;;8;Unverified by anyone;1;+ 50 ;;9;Unverified by Nursing;8 51 ;;10;Unverified by Clerk;8 52 ;;20;Unverified/Chart Review;8 53 ;;13;Verbal/Phoned;1;+ 54 ;;14;Verbal/Phoned unsigned;13 55 ;;12;Flagged;1 56 ;;6;Recent Activity (defaults to today's orders);1 57 ;;24;Delayed (all events);1;+ 58 ;;15;Delayed Admission;24 59 ;;17;Delayed Transfer;24 60 ;;16;Delayed Discharge;24 61 ;;25;Delayed Return from O.R.;24 62 ;;26;Delayed for Manual Release;24 63 ;;22;Lapsed (never processed);1 64 ;;;ZZZZ 65 ; 66 STS ; -- Select new [order or consult] status 67 N HDR,DEFAULT,DOMAIN,PROMPT,HELP,X,Y,I 68 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT="" 69 S (I,Y)=0 F S I=$O(^ORD(100.01,I)) Q:I'>0 Q:I=99 S X=$G(^(I,0)) D 70 . Q:"^1^2^5^6^8^9^13^"'[(U_I_U) S Y=Y+1 71 . S DOMAIN(Y)=I_U_$$LOWER^VALM1($P(X,U)),DOMAIN("B",$P(X,U))=Y 72 . S:I=$P(HDR,";",3) DEFAULT=$P(DOMAIN(Y),U,2) 73 S Y=Y+1,DOMAIN(Y)="^All Statuses",DOMAIN("B","ALL STATUSES")=Y 74 S DOMAIN(0)=Y,PROMPT="Select Consult Status: " 75 S HELP="Enter the status of consults you wish to see listed here." 76 D EN Q:Y="^" 77 S $P(HDR,";",3)=$P(DOMAIN(Y),U),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 78 Q 79 ; 80 TIU ; -- Select new document status 81 N X,Y,ORY,I,CNT,HDR,DOMAIN,DEFAULT,PROMPT,HELP 82 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT=$P(HDR,";",3) 83 D STATUS^TIUSRVL(.ORY) 84 S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 S CNT=CNT+1,DOMAIN(CNT)=ORY(I),DOMAIN("B",$$UP^XLFSTR($P(ORY(I),U,2)))=CNT 85 S DOMAIN(0)=CNT,PROMPT="Select Signature Status: " 86 S HELP="Enter the signature status you would like to screen on" 87 D EN Q:Y="^" 88 S $P(HDR,";",3)=$P(DOMAIN(Y),U,2),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 89 Q 90 ; 91 PLIST ; -- Select problem status 92 N X,Y,HDR,I,ID,NAME,DOMAIN,DEFAULT,PROMPT,HELP 93 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3) 94 F I=1:1 S X=$T(PLSTS+I) Q:$P(X,";",4)="ZZZZ" D SET 95 S DOMAIN(0)=I-1,PROMPT="Select Problem Status: " 96 S HELP="Enter the status of the problems you wish to see listed here." 97 D EN Q:Y="^" 98 S $P(HDR,";",3)=$P(DOMAIN(Y),U),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 99 Q 100 ; 101 PLSTS ;;I;name 102 ;;A;active 103 ;;I;inactive 104 ;;B;both active & inactive 105 ;;;ZZZZ 106 ; 107 SET ; -- set DOMAIN(I)=ID^NAME, DEFAULT from X=";;ID;NAME" 108 N ID,NAME 109 S ID=$P(X,";",3),NAME=$P(X,";",4) 110 S DOMAIN(I)=ID_U_NAME,DOMAIN("B",$$UP^XLFSTR(NAME))=I 111 S:ID=$P(HDR,";",3) DEFAULT=NAME 112 Q 113 ; 114 EN ; -- Select new status via DOMAIN(), PROMPT, DEFAULT, HELP 115 N DONE S DONE=0,Y="" F D Q:DONE 116 . W !,PROMPT_$S($L(DEFAULT):DEFAULT_"//",1:"") 117 . R X:DTIME S:'$T X="^" I X["^" S Y="^",DONE=1 Q 118 . S:X="" X=DEFAULT I X="" S Y="^",DONE=1 Q 119 . I X["?" W !!,HELP D LIST Q 120 . D I 'Y W $C(7),!,HELP Q 121 . . N XP,XY,CNT,MATCH,DIR,I 122 . . S X=$$UP^XLFSTR(X),Y=+$G(DOMAIN("B",X)) Q:Y ; done 123 . . S CNT=0,XP=X F S XP=$O(DOMAIN("B",XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X S CNT=CNT+1,XY=+DOMAIN("B",XP),MATCH(CNT)=XY_U_$P(DOMAIN(XY),U,2) 124 . . Q:'CNT 125 . . I CNT=1 S Y=+MATCH(1),XP=$P(MATCH(1),U,2) W $E(XP,$L(X)+1,$L(XP)) Q 126 . . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": " 127 . . F I=1:1:CNT S DIR("A",I)=$J(I,3)_" "_$P(MATCH(I),U,2) 128 . . S DIR("?")="Select the desired value, by number" 129 . . I CNT>3 D FULL^VALM1 S VALMBCK="R" ;need to scroll 130 . . D ^DIR I $D(DIRUT) S Y="" Q 131 . . S Y=+MATCH(Y) W " "_$P(DOMAIN(Y),U,2) 132 . S DONE=1 133 Q 134 ; 135 LIST ; -- List order statuses in DOMAIN 136 N I,Z,CNT,DONE D FULL^VALM1 S VALMBCK="R" 137 S CNT=0 W !,"Choose from:" 138 F I=1:1:DOMAIN(0) D Q:$G(DONE) 139 . S CNT=CNT+1 W ! I CNT>(IOSL-3) D Q:$G(DONE) 140 .. W ?3,"'^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1 S CNT=1 141 . W $C(13)," "_$P(DOMAIN(I),U,2) 142 Q 1 ORCHANG2 ;SLC/MKB-Change View status ; 08 May 2002 2:12 PM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,68,141,215**;Dec 17, 1997 3 ORDERS ; -- Select new order status 4 N X,Y,HDR,I,DOMAIN,DEFAULT,PROMPT,HELP,STS 5 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT="" 6 F I=1:1 S X=$T(ORDSTS+I) Q:$P(X,";",4)="ZZZZ" D SET 7 S DOMAIN(0)=I-1,PROMPT="Select Order Status: " 8 S HELP="Enter the status of orders you wish to see listed here." 9 D EN Q:Y="^" S STS=+$G(DOMAIN(Y)) 10 I "^8^9^10^20^"[(U_STS_U) D Q:Y="^" 11 . N STRT,STOP,Z 12 . S STRT=$$START^ORCHANGE("NOW-24H") I STRT="^" S Y="^" Q 13 . S STOP=$$STOP^ORCHANGE("NOW") I STOP="^" S Y="^" Q 14 . I STOP<STRT S Z=STRT,STRT=STOP,STOP=Z 15 . S $P(HDR,";",1,2)=$P(STRT,U,2)_";"_$P(STOP,U,2) 16 S $P(HDR,";",3)=STS,$P(HDR,";",8)="" S:STS=2 $P(HDR,";",1,2)=";" 17 I STS=6,$P(HDR,";")="" S $P(HDR,";",1,2)="T;T@23:59" 18 S $P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 19 Q 20 ; 21 STSLST(ORY) ; -- Returns array of order views as 22 ; ORY(n) = id ^ name ^ parent id [^+ if has members] 23 N I,X,CNT S CNT=0 24 F I=1:1 S X=$T(ORDSTS+I) Q:$P(X,";",4)="ZZZZ" S CNT=CNT+1,ORY(CNT)=$TR($P(X,";",3,6),";","^") 25 ; include specific patient events?? 26 Q 27 ; 28 ORDSTS ;;#;Name of Order Context 29 ;;1;All;0;+ 30 ;;2;Active (includes pending, recent activity);1 31 ;;23;Current (Active & Pending status only);1 32 ;;3;Discontinued;1 33 ;;28;Discontinued/Entered in Error;1 34 ;;4;Completed/Expired;1 35 ;;5;Expiring;1 36 ;;7;Pending;1 37 ;;18;On Hold;1 38 ;;19;New Orders;1 39 ;;11;Unsigned;1 40 ;;8;Unverified by anyone;1;+ 41 ;;9;Unverified by Nursing;8 42 ;;10;Unverified by Clerk;8 43 ;;20;Unverified/Chart Review;8 44 ;;13;Verbal/Phoned;1;+ 45 ;;14;Verbal/Phoned unsigned;13 46 ;;12;Flagged;1 47 ;;6;Recent Activity (defaults to today's orders);1 48 ;;24;Delayed (all events);1;+ 49 ;;15;Delayed Admission;24 50 ;;17;Delayed Transfer;24 51 ;;16;Delayed Discharge;24 52 ;;25;Delayed Return from O.R.;24 53 ;;26;Delayed for Manual Release;24 54 ;;22;Lapsed (never processed);1 55 ;;;ZZZZ 56 ; 57 STS ; -- Select new [order or consult] status 58 N HDR,DEFAULT,DOMAIN,PROMPT,HELP,X,Y,I 59 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT="" 60 S (I,Y)=0 F S I=$O(^ORD(100.01,I)) Q:I'>0 Q:I=99 S X=$G(^(I,0)) D 61 . Q:"^1^2^5^6^8^9^13^"'[(U_I_U) S Y=Y+1 62 . S DOMAIN(Y)=I_U_$$LOWER^VALM1($P(X,U)),DOMAIN("B",$P(X,U))=Y 63 . S:I=$P(HDR,";",3) DEFAULT=$P(DOMAIN(Y),U,2) 64 S Y=Y+1,DOMAIN(Y)="^All Statuses",DOMAIN("B","ALL STATUSES")=Y 65 S DOMAIN(0)=Y,PROMPT="Select Consult Status: " 66 S HELP="Enter the status of consults you wish to see listed here." 67 D EN Q:Y="^" 68 S $P(HDR,";",3)=$P(DOMAIN(Y),U),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 69 Q 70 ; 71 TIU ; -- Select new document status 72 N X,Y,ORY,I,CNT,HDR,DOMAIN,DEFAULT,PROMPT,HELP 73 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT=$P(HDR,";",3) 74 D STATUS^TIUSRVL(.ORY) 75 S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 S CNT=CNT+1,DOMAIN(CNT)=ORY(I),DOMAIN("B",$$UP^XLFSTR($P(ORY(I),U,2)))=CNT 76 S DOMAIN(0)=CNT,PROMPT="Select Signature Status: " 77 S HELP="Enter the signature status you would like to screen on" 78 D EN Q:Y="^" 79 S $P(HDR,";",3)=$P(DOMAIN(Y),U,2),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 80 Q 81 ; 82 PLIST ; -- Select problem status 83 N X,Y,HDR,I,ID,NAME,DOMAIN,DEFAULT,PROMPT,HELP 84 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3) 85 F I=1:1 S X=$T(PLSTS+I) Q:$P(X,";",4)="ZZZZ" D SET 86 S DOMAIN(0)=I-1,PROMPT="Select Problem Status: " 87 S HELP="Enter the status of the problems you wish to see listed here." 88 D EN Q:Y="^" 89 S $P(HDR,";",3)=$P(DOMAIN(Y),U),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 90 Q 91 ; 92 PLSTS ;;I;name 93 ;;A;active 94 ;;I;inactive 95 ;;B;both active & inactive 96 ;;;ZZZZ 97 ; 98 SET ; -- set DOMAIN(I)=ID^NAME, DEFAULT from X=";;ID;NAME" 99 N ID,NAME 100 S ID=$P(X,";",3),NAME=$P(X,";",4) 101 S DOMAIN(I)=ID_U_NAME,DOMAIN("B",$$UP^XLFSTR(NAME))=I 102 S:ID=$P(HDR,";",3) DEFAULT=NAME 103 Q 104 ; 105 EN ; -- Select new status via DOMAIN(), PROMPT, DEFAULT, HELP 106 N DONE S DONE=0,Y="" F D Q:DONE 107 . W !,PROMPT_$S($L(DEFAULT):DEFAULT_"//",1:"") 108 . R X:DTIME S:'$T X="^" I X["^" S Y="^",DONE=1 Q 109 . S:X="" X=DEFAULT I X="" S Y="^",DONE=1 Q 110 . I X["?" W !!,HELP D LIST Q 111 . D I 'Y W $C(7),!,HELP Q 112 . . N XP,XY,CNT,MATCH,DIR,I 113 . . S X=$$UP^XLFSTR(X),Y=+$G(DOMAIN("B",X)) Q:Y ; done 114 . . S CNT=0,XP=X F S XP=$O(DOMAIN("B",XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X S CNT=CNT+1,XY=+DOMAIN("B",XP),MATCH(CNT)=XY_U_$P(DOMAIN(XY),U,2) 115 . . Q:'CNT 116 . . I CNT=1 S Y=+MATCH(1),XP=$P(MATCH(1),U,2) W $E(XP,$L(X)+1,$L(XP)) Q 117 . . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": " 118 . . F I=1:1:CNT S DIR("A",I)=$J(I,3)_" "_$P(MATCH(I),U,2) 119 . . S DIR("?")="Select the desired value, by number" 120 . . I CNT>3 D FULL^VALM1 S VALMBCK="R" ;need to scroll 121 . . D ^DIR I $D(DIRUT) S Y="" Q 122 . . S Y=+MATCH(Y) W " "_$P(DOMAIN(Y),U,2) 123 . S DONE=1 124 Q 125 ; 126 LIST ; -- List order statuses in DOMAIN 127 N I,Z,CNT,DONE D FULL^VALM1 S VALMBCK="R" 128 S CNT=0 W !,"Choose from:" 129 F I=1:1:DOMAIN(0) D Q:$G(DONE) 130 . S CNT=CNT+1 W ! I CNT>(IOSL-3) D Q:$G(DONE) 131 .. W ?3,"'^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1 S CNT=1 132 . W $C(13)," "_$P(DOMAIN(I),U,2) 133 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHANGE.m
r613 r623 1 ORCHANGE ;SLC/MKB-Change View utilities ; 08 May 2002 2:12 PM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,141,243**;Dec 17, 1997;Build 242 3 EN ; -- Change view of current list 4 N XQORM,Y,ORI 5 S XQORM=$G(^TMP("OR",$J,"CURRENT","CHANGE")),VALMBCK="" 6 I 'XQORM W !!,"No other views of this list currently available" H 2 Q 7 S Y=$S(ORTAB="NOTES"!(ORTAB="SUMMRIES"):"1\",ORTAB="ORDERS":"\",1:"") 8 S XQORM(0)=Y_"AD" K Y 9 S XQORM("A")=$S($L($G(^ORD(101,+XQORM,28))):^(28),1:"Select attribute(s) to change: ") 10 D EN^XQORM S ORI=0 11 F S ORI=$O(Y(ORI)) Q:ORI'>0 X:$D(^ORD(101,+$P(Y(ORI),U,2),20)) ^(20) 12 I $G(^TMP("OR",$J,"CURRENT",0))'=$G(^TMP("OR",$J,ORTAB,0)) K VALMBG D TAB^ORCHART(ORTAB,1) 13 Q 14 ; 15 RANGE ; -- Get new date range for list 16 N HDR,OLD,NEW,REQ,BEG,END 17 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3) 18 S REQ=$S(ORTAB="XRAYS":1,ORTAB="REPORTS":1,1:0) 19 I ($P(HDR,";",3)=2)!($P(HDR,";",3)=5) D Q 20 . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,THISTS 21 . S THISTS=" only active " 22 . I $P(HDR,";",3)=5 S THISTS=" expiring " 23 . W !,"Date range can not be selected when viewing"_THISTS_"orders." 24 . S DIR(0)="E" D ^DIR 25 S OLD=$P(HDR,";"),NEW=$$START(OLD,REQ) Q:NEW="^" S BEG=NEW 26 I BEG="" S END="" G RQ 27 S OLD=$P(HDR,";",2),NEW=$$STOP(OLD,REQ) Q:NEW="^" S END=NEW 28 I END<BEG S NEW=END,END=BEG,BEG=NEW ; switch 29 RQ S $P(HDR,";",1,2)=$P(BEG,U,2)_";"_$P(END,U,2) 30 S $P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 31 Q 32 ; 33 START(CURRENT,REQD) ; -- Return new beginning date 34 N X,Y,DIR 35 S DIR(0)="DA"_$S('$G(REQD):"O",1:"")_"^::ETX",DIR("A")="Beginning Date[/time]: " 36 S:$L($G(CURRENT)) DIR("B")=$S(CURRENT?7N.1".".6N:$$FMTE^XLFDT(CURRENT),1:CURRENT) 37 S DIR("?")="Enter the earliest date [and time] from which you want to see data; a null response will return all data on this patient" 38 D ^DIR S:$D(DTOUT) Y="^" S:X="@" Y="" S:Y Y=Y_U_X 39 Q Y 40 ; 41 STOP(CURRENT,REQD) ; -- Return new ending date 42 N X,Y,DIR 43 S DIR(0)="DA"_$S('$G(REQD):"O",1:"")_"^::ETX",DIR("A")="Ending Date[/time]: " 44 S:$L($G(CURRENT)) DIR("B")=$S(CURRENT?7N.1".".6N:$$FMTE^XLFDT(CURRENT),1:CURRENT) 45 S DIR("?")="Enter the latest date [and time] for which you want to see data; a null response will assume TODAY" 46 D ^DIR S:$D(DTOUT) Y="^" S:X="@" Y="" S:Y Y=Y_U_X 47 Q Y 48 ; 49 MAX ; -- Get new max # of items to list 50 N X,Y,DIR 51 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),X=$P(HDR,";",5) 52 S DIR(0)="NAO^1:999" S:X DIR("B")=X 53 S DIR("A")="Maximum # of items to display: " 54 S DIR("?")="Enter the total number of items you wish to be displayed here" 55 D ^DIR Q:'Y 56 S $P(HDR,";",5)=Y,$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 57 Q 58 ; 59 AUTHOR(USER) ; -- Select new author of note 60 N X,Y,DIC D FULL^VALM1 S VALMBCK="R" 61 S DIC=200,DIC(0)="AEQM",DIC("A")="Select AUTHOR: " 62 S:$G(USER) DIC("B")=$P($G(^VA(200,+USER,0)),U) 63 D ^DIC S:Y'>0 Y="" 64 Q +Y 65 ; 66 LISTHDR ; -- List available subhdrs 67 N HDR,DONE,CNT D FULL^VALM1 68 W !!,"Choose from:" S HDR="",(CNT,DONE)=0,VALMBCK="R" 69 F S HDR=$O(^TMP("OR",$J,"CURRENT","HDR",HDR)) Q:HDR="" D Q:DONE 70 . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE^ORCD S DONE=1 Q 71 . W !," "_HDR 72 Q 73 ; 74 LRSUB ; -- Return lab subscript to jump to in list 75 ; Available subscripts in ^TMP("OR",$J,"IDX",name)=line # 76 I '$D(^TMP("OR",$J,"CURRENT","HDR")) W !!,"There are no section headers defined for this report." H 3 Q 77 N X,Y,DIR,XP,P,CNT,MATCH D FULL^VALM1 S VALMBCK="R" 78 LRS S DIR(0)="FAO^1:30",DIR("A")="Select Lab Section: " 79 S DIR("A",1)="Available sections in this report:",X="" 80 F I=2:1 S X=$O(^TMP("OR",$J,"CURRENT","HDR",X)) Q:X="" S DIR("A",I)=" "_X 81 S DIR("?")="Enter the lab section from which to wish to see results; the display will scroll to the top of the selected section" ;,DIR("??")="^D LISTHDR^ORCHANGE" 82 D ^DIR Q:"^"[Y 83 S XP=$$UP^XLFSTR(X) 84 I $G(^TMP("OR",$J,"CURRENT","HDR",XP)) S VALMBG=^(XP),VALMBCK="R" Q 85 S CNT=0,P=XP F S P=$O(^TMP("OR",$J,"CURRENT","HDR",P)) Q:$E(P,1,$L(XP))'=XP S CNT=CNT+1,MATCH(CNT)=+$G(^(P))_U_P ; line# ^ hdr name 86 I 'CNT W $C(7)," ??" G LRS 87 I CNT=1 S VALMBG=+MATCH(CNT),VALMBCK="R",P=$P(MATCH(1),U,2) W $E(P,$L(X)+1,$L(P)) Q 88 LRS1 K DIR S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": " 89 F I=1:1:CNT S DIR("A",I)=I_" "_$P(MATCH(I),U,2) 90 S DIR("?")="Select the lab section you want to go to, by number" 91 D ^DIR Q:$D(DTOUT)!($D(DUOUT)) I 'Y K DIR G LRS 92 S VALMBG=+MATCH(Y),VALMBCK="R" 93 Q 94 ; 95 DGROUP ; -- Select new service (display group) 96 N X,Y,Z,ZZ,DIC,HDR,DONE,HELP 97 D FULL^VALM1 S VALMBCK="R" 98 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),Z=$P(HDR,";",4),ZZ=+$O(^ORD(100.98,"B",$S($L(Z):Z,1:"ALL"),0)) 99 S HELP="Enter the service or section from which you wish to see orders for this patient." 100 S DONE=0 F D Q:DONE 101 . W !!,"Select Service/Section: "_$P(^ORD(100.98,+ZZ,0),U)_"//" 102 . R X:DTIME S:'$T X="^" I X["^" S DONE=1 Q 103 . I X="" S DONE=1 Q ; no change 104 . I X["?" W !!,HELP,!,"Choose from:" D DG^ORCHANG1(1,"DISP") Q 105 . S DIC=100.98,DIC(0)="NEQZ" D ^DIC S:Y>0 Z=$P(Y(0),U,3),ZZ=+Y,DONE=1 106 S $P(HDR,";",4)=Z,$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 107 Q 108 ; 109 CS ; -- Select new consult service 110 N GMRCDG,GMRCBUF,GMRCACT,GMRCQUT,GMRCGRP,HDR 111 D FULL^VALM1,ASRV^GMRCASV S VALMBCK="R" Q:$D(GMRCQUT) 112 S:$G(GMRCDG) HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),$P(HDR,";",4)=GMRCDG,$P(^(0),U,3,4)=HDR_U 113 K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J) 114 Q 115 ; 116 REMOVE ; -- Remove preferred view 117 N ORDEL S ORDEL=1 118 SAVE ; -- Save current view as preferred 119 Q:'$$OK($G(ORDEL)) N X,Y,PARAM 120 S X=$S($G(ORDEL):"@",1:$P($G(^TMP("OR",$J,ORTAB,0)),U,3)),Y="" 121 ;S:$G(ORTAB)="MEDS" Y=$S($P(X,";",3):"IN",1:"OUT")_"PT " 122 S:$G(ORTAB)="LABS" Y=$S($G(ORWARD):"IN",1:"OUT")_"PT " 123 S PARAM="ORCH CONTEXT "_Y_$G(ORTAB) 124 D EN^XPAR("USR",PARAM,1,X) W " ...done." H 1 125 Q 126 ; 127 OK(DEL) ; -- Are you sure you want to save/remove view of ORTAB? 128 N X,Y,DIR S DIR(0)="YA" 129 S DIR("A")="Are you sure you want to "_$S($G(DEL):"remove",1:"save the current view as")_" your preference? " 130 S:$G(DEL) DIR("?",1)="Enter YES if you wish to remove your preferred view of this chart tab and use",DIR("?")="the default view next time, or NO to quit without changing anything." 131 S:'$G(DEL) DIR("?",1)="Enter YES if you wish to use these same parameters again the next time the ",DIR("?")=$$LOWER^VALM1(ORTAB)_" tab is created for you, or NO to quit without saving anything." 132 D ^DIR 133 Q +Y 134 ; 135 RETURN ; -- Return to preferred view of ORTAB 136 S $P(^TMP("OR",$J,ORTAB,0),U,4)=1 137 Q 1 ORCHANGE ;SLC/MKB-Change View utilities ; 08 May 2002 2:12 PM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,141**;Dec 17, 1997 3 EN ; -- Change view of current list 4 N XQORM,Y,ORI 5 S XQORM=$G(^TMP("OR",$J,"CURRENT","CHANGE")),VALMBCK="" 6 I 'XQORM W !!,"No other views of this list currently available" H 2 Q 7 S Y=$S(ORTAB="NOTES"!(ORTAB="SUMMRIES"):"1\",ORTAB="ORDERS":"\",1:"") 8 S XQORM(0)=Y_"AD" K Y 9 S XQORM("A")=$S($L($G(^ORD(101,+XQORM,28))):^(28),1:"Select attribute(s) to change: ") 10 D EN^XQORM S ORI=0 11 F S ORI=$O(Y(ORI)) Q:ORI'>0 X:$D(^ORD(101,+$P(Y(ORI),U,2),20)) ^(20) 12 I $G(^TMP("OR",$J,"CURRENT",0))'=$G(^TMP("OR",$J,ORTAB,0)) K VALMBG D TAB^ORCHART(ORTAB,1) 13 Q 14 ; 15 RANGE ; -- Get new date range for list 16 N HDR,OLD,NEW,REQ 17 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3) 18 S REQ=$S(ORTAB="XRAYS":1,ORTAB="REPORTS":1,1:0) 19 I $P(HDR,";",3)=2 D Q 20 . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y 21 . W !,"Date range can not be selected when viewing only active orders" 22 . S DIR(0)="E" D ^DIR 23 S OLD=$P(HDR,";"),NEW=$$START(OLD,REQ) Q:NEW="^" S BEG=NEW 24 I BEG="" S END="" G RQ 25 S OLD=$P(HDR,";",2),NEW=$$STOP(OLD,REQ) Q:NEW="^" S END=NEW 26 I END<BEG S NEW=END,END=BEG,BEG=NEW ; switch 27 RQ S $P(HDR,";",1,2)=$P(BEG,U,2)_";"_$P(END,U,2) 28 S $P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 29 Q 30 ; 31 START(CURRENT,REQD) ; -- Return new beginning date 32 N X,Y,DIR 33 S DIR(0)="DA"_$S('$G(REQD):"O",1:"")_"^::ETX",DIR("A")="Beginning Date[/time]: " 34 S:$L($G(CURRENT)) DIR("B")=$S(CURRENT?7N.1".".6N:$$FMTE^XLFDT(CURRENT),1:CURRENT) 35 S DIR("?")="Enter the earliest date [and time] from which you want to see data; a null response will return all data on this patient" 36 D ^DIR S:$D(DTOUT) Y="^" S:X="@" Y="" S:Y Y=Y_U_X 37 Q Y 38 ; 39 STOP(CURRENT,REQD) ; -- Return new ending date 40 N X,Y,DIR 41 S DIR(0)="DA"_$S('$G(REQD):"O",1:"")_"^::ETX",DIR("A")="Ending Date[/time]: " 42 S:$L($G(CURRENT)) DIR("B")=$S(CURRENT?7N.1".".6N:$$FMTE^XLFDT(CURRENT),1:CURRENT) 43 S DIR("?")="Enter the latest date [and time] for which you want to see data; a null response will assume TODAY" 44 D ^DIR S:$D(DTOUT) Y="^" S:X="@" Y="" S:Y Y=Y_U_X 45 Q Y 46 ; 47 MAX ; -- Get new max # of items to list 48 N X,Y,DIR 49 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),X=$P(HDR,";",5) 50 S DIR(0)="NAO^1:999" S:X DIR("B")=X 51 S DIR("A")="Maximum # of items to display: " 52 S DIR("?")="Enter the total number of items you wish to be displayed here" 53 D ^DIR Q:'Y 54 S $P(HDR,";",5)=Y,$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 55 Q 56 ; 57 AUTHOR(USER) ; -- Select new author of note 58 N X,Y,DIC D FULL^VALM1 S VALMBCK="R" 59 S DIC=200,DIC(0)="AEQM",DIC("A")="Select AUTHOR: " 60 S:$G(USER) DIC("B")=$P($G(^VA(200,+USER,0)),U) 61 D ^DIC S:Y'>0 Y="" 62 Q +Y 63 ; 64 LISTHDR ; -- List available subhdrs 65 N HDR,DONE,CNT D FULL^VALM1 66 W !!,"Choose from:" S HDR="",(CNT,DONE)=0,VALMBCK="R" 67 F S HDR=$O(^TMP("OR",$J,"CURRENT","HDR",HDR)) Q:HDR="" D Q:DONE 68 . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE^ORCD S DONE=1 Q 69 . W !," "_HDR 70 Q 71 ; 72 LRSUB ; -- Return lab subscript to jump to in list 73 ; Available subscripts in ^TMP("OR",$J,"IDX",name)=line # 74 I '$D(^TMP("OR",$J,"CURRENT","HDR")) W !!,"There are no section headers defined for this report." H 3 Q 75 N X,Y,DIR,XP,P,CNT,MATCH D FULL^VALM1 S VALMBCK="R" 76 LRS S DIR(0)="FAO^1:30",DIR("A")="Select Lab Section: " 77 S DIR("A",1)="Available sections in this report:",X="" 78 F I=2:1 S X=$O(^TMP("OR",$J,"CURRENT","HDR",X)) Q:X="" S DIR("A",I)=" "_X 79 S DIR("?")="Enter the lab section from which to wish to see results; the display will scroll to the top of the selected section" ;,DIR("??")="^D LISTHDR^ORCHANGE" 80 D ^DIR Q:"^"[Y 81 S XP=$$UP^XLFSTR(X) 82 I $G(^TMP("OR",$J,"CURRENT","HDR",XP)) S VALMBG=^(XP),VALMBCK="R" Q 83 S CNT=0,P=XP F S P=$O(^TMP("OR",$J,"CURRENT","HDR",P)) Q:$E(P,1,$L(XP))'=XP S CNT=CNT+1,MATCH(CNT)=+$G(^(P))_U_P ; line# ^ hdr name 84 I 'CNT W $C(7)," ??" G LRS 85 I CNT=1 S VALMBG=+MATCH(CNT),VALMBCK="R",P=$P(MATCH(1),U,2) W $E(P,$L(X)+1,$L(P)) Q 86 LRS1 K DIR S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": " 87 F I=1:1:CNT S DIR("A",I)=I_" "_$P(MATCH(I),U,2) 88 S DIR("?")="Select the lab section you want to go to, by number" 89 D ^DIR Q:$D(DTOUT)!($D(DUOUT)) I 'Y K DIR G LRS 90 S VALMBG=+MATCH(Y),VALMBCK="R" 91 Q 92 ; 93 DGROUP ; -- Select new service (display group) 94 N X,Y,Z,ZZ,DIC,HDR,DONE,HELP 95 D FULL^VALM1 S VALMBCK="R" 96 S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),Z=$P(HDR,";",4),ZZ=+$O(^ORD(100.98,"B",$S($L(Z):Z,1:"ALL"),0)) 97 S HELP="Enter the service or section from which you wish to see orders for this patient." 98 S DONE=0 F D Q:DONE 99 . W !!,"Select Service/Section: "_$P(^ORD(100.98,+ZZ,0),U)_"//" 100 . R X:DTIME S:'$T X="^" I X["^" S DONE=1 Q 101 . I X="" S DONE=1 Q ; no change 102 . I X["?" W !!,HELP,!,"Choose from:" D DG^ORCHANG1(1,"DISP") Q 103 . S DIC=100.98,DIC(0)="NEQZ" D ^DIC S:Y>0 Z=$P(Y(0),U,3),ZZ=+Y,DONE=1 104 S $P(HDR,";",4)=Z,$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U 105 Q 106 ; 107 CS ; -- Select new consult service 108 N GMRCDG,GMRCBUF,GMRCACT,GMRCQUT,GMRCGRP,HDR 109 D FULL^VALM1,ASRV^GMRCASV S VALMBCK="R" Q:$D(GMRCQUT) 110 S:$G(GMRCDG) HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),$P(HDR,";",4)=GMRCDG,$P(^(0),U,3,4)=HDR_U 111 K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J) 112 Q 113 ; 114 REMOVE ; -- Remove preferred view 115 N ORDEL S ORDEL=1 116 SAVE ; -- Save current view as preferred 117 Q:'$$OK($G(ORDEL)) N X,Y,PARAM 118 S X=$S($G(ORDEL):"@",1:$P($G(^TMP("OR",$J,ORTAB,0)),U,3)),Y="" 119 ;S:$G(ORTAB)="MEDS" Y=$S($P(X,";",3):"IN",1:"OUT")_"PT " 120 S:$G(ORTAB)="LABS" Y=$S($G(ORWARD):"IN",1:"OUT")_"PT " 121 S PARAM="ORCH CONTEXT "_Y_$G(ORTAB) 122 D EN^XPAR("USR",PARAM,1,X) W " ...done." H 1 123 Q 124 ; 125 OK(DEL) ; -- Are you sure you want to save/remove view of ORTAB? 126 N X,Y,DIR S DIR(0)="YA" 127 S DIR("A")="Are you sure you want to "_$S($G(DEL):"remove",1:"save the current view as")_" your preference? " 128 S:$G(DEL) DIR("?",1)="Enter YES if you wish to remove your preferred view of this chart tab and use",DIR("?")="the default view next time, or NO to quit without changing anything." 129 S:'$G(DEL) DIR("?",1)="Enter YES if you wish to use these same parameters again the next time the ",DIR("?")=$$LOWER^VALM1(ORTAB)_" tab is created for you, or NO to quit without saving anything." 130 D ^DIR 131 Q +Y 132 ; 133 RETURN ; -- Return to preferred view of ORTAB 134 S $P(^TMP("OR",$J,ORTAB,0),U,4)=1 135 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHECK.m
r613 r623 1 ORCHECK ;SLC/MKB-Order checking calls ; 08 May 2002 2:12 PM [8/16/05 5:28am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,94,141,215,243**;Dec 17, 1997;Build 242 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 DISPLAY ; -- DISPLAY event [called from ORCDLG,ORCACT4,ORCMED] 5 ; Expects ORVP, ORNMSP, ORTAB, [ORWARD] 6 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" 7 N ORX,ORY,I 8 I ORNMSP="PS" D ;reset to PSJ, PSJI, or PSO 9 . I $G(ORDG) S I=$P($G(^ORD(100.98,+ORDG,0)),U,3),I=$P(I," ") Q:'$L(I) S ORNMSP="PS"_$S(I="UD":"I",1:I) Q 10 . I $G(ORXFER) S I=$P($P(^TMP("OR",$J,ORTAB,0),U,3),";",3) S:I="" I=$G(ORWARD) S ORNMSP="PS"_$S(I:"O",1:"I") ;opposite of list 11 S ORX(1)="|"_ORNMSP,ORX=1 12 D EN^ORKCHK(.ORY,+ORVP,.ORX,"DISPLAY") Q:'$D(ORY) 13 S I=0 F S I=$O(ORY(I)) Q:I'>0 W !,$P(ORY(I),U,4) ; display only 14 Q 15 ; 16 SELECT ; -- SELECT event 17 ; Expects ORVP, ORDAILOG(PROMPT,ORI), ORNMSP 18 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" 19 N ORX,ORY,OI 20 S OI=+$G(ORDIALOG(PROMPT,ORI)) 21 S ORX=1,ORX(1)=OI_"|"_ORNMSP_"|"_$$USID^ORMBLD(OI) 22 D EN^ORKCHK(.ORY,+ORVP,.ORX,"SELECT"),RETURN:$D(ORY) 23 Q 24 ; 25 ACCEPT(MODE) ; -- ACCEPT event [called from ORCDLG,ORCACT4,ORCMED] 26 ; Expects ORVP, ORDIALOG(), ORNMSP 27 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" 28 N ORX,ORY,ORZ,OI,ORSTRT,ORI,ORIT,ORID,ORSP 29 S:'$L($G(MODE)) MODE="ACCEPT" 30 S OI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),ORSTRT=$$START,ORX=0 31 S ORI=0 F S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0 D STUF 32 I $G(ORDG)=+$O(^ORD(100.98,"B","IV RX",0)) S OI=$$PTR^ORCD("OR GTX ADDITIVE"),ORI=0 F S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0 D STUF 33 D EN^ORKCHK(.ORY,+ORVP,.ORX,MODE),RETURN:$D(ORY) 34 Q 35 STUF S ORIT=ORDIALOG(OI,ORI),ORSP="" 36 S:ORNMSP="LR" ORSP=+$G(ORDIALOG($$PTR^ORCD("OR GTX SPECIMEN"),ORI)) 37 S ORID=$S($E(ORNMSP,1,2)="PS":$$DRUG(ORIT,OI),1:$$USID^ORMBLD(ORIT)) 38 S ORZ=1,ORZ(1)=ORIT_"|"_ORNMSP_"|"_ORID 39 I MODE'="ALL" D EN^ORKCHK(.ORY,+ORVP,.ORZ,"SELECT"),RETURN:$D(ORY) 40 S ORX=ORX+1,ORX(ORX)=ORZ(1)_"|"_ORSTRT_"||"_ORSP K ORY,ORZ 41 Q 42 ; 43 DELAY(MODE) ; -- Delayed ACCEPT event [called from ORMEVNT] 44 ; Expects ORVP, ORIFN 45 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" 46 N ORX,ORY,ORCHECK S:'$L($G(MODE)) MODE="NOTIF" 47 D BLD(+ORIFN),EN^ORKCHK(.ORY,+ORVP,.ORX,MODE) Q:'$D(ORY) 48 D RETURN I MODE="NOTIF" S ORCHECK("OK")="Notification sent to provider" D OC^ORCSAVE2 Q ; silent 49 Q 50 ; 51 SESSION ; -- SESSION event [called from ORCSIGN] 52 ; Expects ORVP, ORES() 53 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" 54 N ORX,ORY,ORIFN,I,X,Y 55 S ORIFN=0 F S ORIFN=$O(ORES(ORIFN)) Q:ORIFN'>0 I +$P(ORIFN,";",2)'>1 D 56 . I "^5^6^10^11^"'[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) Q ;unreleased 57 . D BLD(+ORIFN) Q:'$D(^OR(100,+ORIFN,9)) 58 . S ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1 59 . S I=0 F S I=$O(^OR(100,+ORIFN,9,I)) Q:I'>0 S X=$G(^(I,0)),Y=$G(^(1)),ORCHECK=+$G(ORCHECK)+1,ORCHECK(+ORIFN,$S($P(X,U,2):$P(X,U,2),1:99),ORCHECK)=$P(X,U,1,2)_U_Y 60 I $D(ORX) D EN^ORKCHK(.ORY,+ORVP,.ORX,"SESSION"),RETURN:$D(ORY),REMDUPS 61 Q 62 ; 63 BLD(ORDER) ; -- Build new ORX(#) for ORDER 64 Q:'$G(ORDER) Q:'$D(^OR(100,ORDER,0)) ;Q:$P($G(^(3)),U,11) ;edit/renew 65 N PKG,START,ORI,ITEM,USID,SPEC,ORDG,PTR,INST 66 S ORDG=$P(^OR(100,ORDER,0),U,11),PKG=$$GET1^DIQ(9.4,$P(^(0),U,14)_",",1) 67 I PKG="PS",$G(ORDG) S ORI=$P($G(^ORD(100.98,+ORDG,0)),U,3),ORI=$P(ORI," "),PKG=PKG_$S(ORI="UD":"I",1:ORI) 68 S START=$$START(ORDER),ORI=0 69 F S ORI=$O(^OR(100,ORDER,4.5,"ID","ORDERABLE",ORI)) Q:ORI'>0 D 70 . S INST=$P($G(^OR(100,ORDER,4.5,ORI,0)),U,3),PTR=$P($G(^(0)),U,2),ITEM=+$G(^(1)) 71 . S USID=$S(PKG?1"PS".E:$$DRUG(ITEM,PTR,ORDER),1:$$USID^ORMBLD(ITEM)) 72 . S SPEC=$S(PKG="LR":$$VALUE^ORCSAVE2(ORDER,"SPECIMEN",INST),1:"") 73 . S ORX=+$G(ORX)+1,ORX(ORX)=ITEM_"|"_PKG_"|"_USID_"|"_START_"|"_ORDER_"|"_SPEC 74 Q 75 ; 76 RETURN ; -- Return checks in ORCHECK(ORIFN,CDL,#) 77 N I,IFN,CDL S I=0 F S I=$O(ORY(I)) Q:I'>0 D 78 . S IFN=+$P(ORY(I),U) S:'IFN IFN="NEW" 79 . S CDL=+$P(ORY(I),U,3) S:'CDL CDL=99 80 . S:'$D(ORCHECK(IFN)) ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1 ; count 81 . S ORCHECK=+$G(ORCHECK)+1,ORCHECK(IFN,CDL,ORCHECK)=$P(ORY(I),U,2,4) 82 Q 83 ; 84 REMDUPS ; 85 N IFN,CDL,I 86 S IFN=0 F S IFN=$O(ORCHECK(IFN)) Q:'IFN D 87 . S CDL=0 F S CDL=$O(ORCHECK(IFN,CDL)) Q:'CDL D 88 . . S I=0 F S I=$O(ORCHECK(IFN,CDL,I)) Q:'I D 89 . . . S J=I F S J=$O(ORCHECK(IFN,CDL,J)) Q:'J I $G(ORCHECK(IFN,CDL,I))=$G(ORCHECK(IFN,CDL,J)) K ORCHECK(IFN,CDL,J) S ORCHECK=$G(ORCHECK)-1 90 Q 91 START(DA) ; -- Returns start date/time 92 N I,X,Y,%DT S Y="" 93 I $G(DA) S X=$O(^OR(100,DA,4.5,"ID","START",0)),X=$G(^OR(100,DA,4.5,+X,1)) 94 E D ; look in ORDIALOG instead 95 . S I=0 F S I=$O(ORDIALOG(I)) Q:I'>0 Q:$P(ORDIALOG(I),U,2)="START" 96 . S X=$S(I:$G(ORDIALOG(I,1)),1:"") 97 D AM^ORCSAVE2:X="AM",NEXT^ORCSAVE2:X="NEXT" 98 D ADMIN^ORCSAVE2("NEXT"):X="NEXTA",ADMIN^ORCSAVE2("CLOSEST"):X="CLOSEST" 99 I $L(X) S %DT="TX" D ^%DT S:Y'>0 Y="" 100 Q Y 101 ; 102 DRUG(OI,PTR,IFN) ; -- Returns 6 ^-piece identifier for Dispense Drug 103 N ORDD,ORNDF,Y 104 I ORDG=+$O(^ORD(100.98,"B","IV RX",0)) S ORDD=$$IV G D1 105 I $G(IFN) S ORDD=$O(^OR(100,IFN,4.5,"ID","DRUG",0)),ORDD=+$G(^OR(100,IFN,4.5,+ORDD,1)) 106 E S ORDD=+$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1)) 107 D1 Q:'ORDD "" S ORNDF=$$ENDCM^PSJORUTL(ORDD) 108 S Y=$P(ORNDF,U,3)_"^^99NDF^"_ORDD_U_$$NAME50^ORPEAPI(ORDD)_"^99PSD" 109 Q Y 110 ; 111 IV() ; -- Get Dispense Drug for IV orderable 112 N PSOI,TYPE,VOL,ORY 113 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),VOL="" 114 S TYPE=$S(PTR=$$PTR^ORCD("OR GTX ADDITIVE"):"A",1:"B") 115 S:TYPE="B" VOL=$S($G(IFN):$$VALUE^ORCSAVE2(IFN,"VOLUME"),1:+$G(ORDIALOG($$PTR^ORCD("OR GTX VOLUME"),1))) 116 D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORY) 117 Q +$G(ORY) 118 ; 119 LIST(IFN) ; -- Displays list of ORCHECK(IFN) checks 120 N ORI,ORJ,ORZ,ORMAX,ORTX,ON,OFF 121 S ORZ=0 F S ORZ=$O(ORCHECK(IFN,ORZ)) Q:ORZ'>0 D 122 . S:ORZ=1 ON=IOINHI,OFF=IOINORM S:ORZ'=1 (ON,OFF)="" ; use bold if High 123 . S ORI=0 F S ORI=$O(ORCHECK(IFN,ORZ,ORI)) Q:ORI'>0 D 124 . . S X=$P(ORCHECK(IFN,ORZ,ORI),U,3) I $L(X)<75 W !,ON_">>> "_X_OFF Q 125 . . S ORMAX=74 K ORTX D TXT^ORCHTAB Q:'$G(ORTX) ; wrap 126 . . F ORJ=1:1:ORTX W !,ON_$S(ORJ=1:">>> ",1:" ")_ORTX(ORJ)_OFF 127 W ! 128 Q 129 ; 130 CANCEL() ; -- Returns 1 or 0: Cancel order(s)? 131 N X,Y,DIR,NUM 132 S NUM=+$G(ORCHECK("IFN")),DIR(0)="YA" 133 S DIR("A")="Do you want to cancel "_$S(NUM>1:"any of the new orders? ",1:"the new order? ") 134 S DIR("?",1)="Enter YES to cancel "_$S(NUM>1:"an",1:"the")_" order. If you wish to override these order checks" 135 S DIR("?",2)="and release "_$S(NUM>1:"these orders",1:"this order")_", enter NO; you will be prompted for a justification",DIR("?")="if there are any highlighted critical order checks." 136 D ^DIR 137 Q +Y 138 ; 139 REASON() ; -- Reason for overriding order checks 140 ; I '$D(^XUSEC("ORES",DUZ)),'$D(^XUSEC("ORELSE",DUZ)) Q ?? 141 N X,Y,DIR 142 S DIR(0)="FA^2:80^K:X?1."" "" X",DIR("A")="REASON FOR OVERRIDE: " 143 S DIR("?")="Enter a justification for overriding these order checks, up to 80 characters" 144 D ^DIR I $D(DTOUT)!$D(DUOUT) S Y="^" 145 Q Y 146 OCAPI(IFN,ORPLACE) ;IA #4859 147 ;API to get the order checking info for a specific order (IFN) 148 ;info is stored in ^TMP($J,ORPLACE) 149 ; ^TMP($J,ORPLACE,D0,"OC LEVEL")="order check level" 150 ; ,"OC TEXT")="order check text" 151 ; ,"OR REASON")="over ride reason text" 152 ; ,"OR PROVIDER")="provider DUZ who entered over ride reason" 153 ; ,"OR DT")="date/time over ride reason was entered" 154 ; NOTE on OC LEVEL: 1 is HIGH, 2 is MODERATE, 3 is LOW 155 I '$D(^OR(100,IFN,9)) Q 156 N I 157 S I=0 F S I=$O(^OR(100,IFN,9,I)) Q:'I D 158 .S ^TMP($J,ORPLACE,I,"OC LEVEL")=$P($G(^OR(100,IFN,9,I,0)),U,2) 159 .S ^TMP($J,ORPLACE,I,"OC TEXT")=$G(^OR(100,IFN,9,I,1)) 160 .S ^TMP($J,ORPLACE,I,"OR REASON")=$P($G(^OR(100,IFN,9,I,0)),U,4) 161 .S ^TMP($J,ORPLACE,I,"OR PROVIDER")=$P($G(^OR(100,IFN,9,I,0)),U,5) 162 .S ^TMP($J,ORPLACE,I,"OR DT")=$P($G(^OR(100,IFN,9,I,0)),U,6) 163 Q 1 ORCHECK ;SLC/MKB-Order checking calls ; 08 May 2002 2:12 PM [8/16/05 5:28am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,94,141,215**;Dec 17, 1997 3 DISPLAY ; -- DISPLAY event [called from ORCDLG,ORCACT4,ORCMED] 4 ; Expects ORVP, ORNMSP, ORTAB, [ORWARD] 5 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" 6 N ORX,ORY,I 7 I ORNMSP="PS" D ;reset to PSJ, PSJI, or PSO 8 . I $G(ORDG) S I=$P($G(^ORD(100.98,+ORDG,0)),U,3),I=$P(I," ") Q:'$L(I) S ORNMSP="PS"_$S(I="UD":"I",1:I) Q 9 . I $G(ORXFER) S I=$P($P(^TMP("OR",$J,ORTAB,0),U,3),";",3) S:I="" I=$G(ORWARD) S ORNMSP="PS"_$S(I:"O",1:"I") ;opposite of list 10 S ORX(1)="|"_ORNMSP,ORX=1 11 D EN^ORKCHK(.ORY,+ORVP,.ORX,"DISPLAY") Q:'$D(ORY) 12 S I=0 F S I=$O(ORY(I)) Q:I'>0 W !,$P(ORY(I),U,4) ; display only 13 Q 14 ; 15 SELECT ; -- SELECT event 16 ; Expects ORVP, ORDAILOG(PROMPT,ORI), ORNMSP 17 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" 18 N ORX,ORY,OI 19 S OI=+$G(ORDIALOG(PROMPT,ORI)) 20 S ORX=1,ORX(1)=OI_"|"_ORNMSP_"|"_$$USID^ORMBLD(OI) 21 D EN^ORKCHK(.ORY,+ORVP,.ORX,"SELECT"),RETURN:$D(ORY) 22 Q 23 ; 24 ACCEPT(MODE) ; -- ACCEPT event [called from ORCDLG,ORCACT4,ORCMED] 25 ; Expects ORVP, ORDIALOG(), ORNMSP 26 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" 27 N ORX,ORY,ORZ,OI,ORSTRT,ORI,ORIT,ORID,ORSP 28 S:'$L($G(MODE)) MODE="ACCEPT" 29 S OI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),ORSTRT=$$START,ORX=0 30 S ORI=0 F S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0 D STUF 31 I $G(ORDG)=+$O(^ORD(100.98,"B","IV RX",0)) S OI=$$PTR^ORCD("OR GTX ADDITIVE"),ORI=0 F S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0 D STUF 32 D EN^ORKCHK(.ORY,+ORVP,.ORX,MODE),RETURN:$D(ORY) 33 Q 34 STUF S ORIT=ORDIALOG(OI,ORI),ORSP="" 35 S:ORNMSP="LR" ORSP=+$G(ORDIALOG($$PTR^ORCD("OR GTX SPECIMEN"),ORI)) 36 S ORID=$S($E(ORNMSP,1,2)="PS":$$DRUG(ORIT,OI),1:$$USID^ORMBLD(ORIT)) 37 S ORZ=1,ORZ(1)=ORIT_"|"_ORNMSP_"|"_ORID 38 I MODE'="ALL" D EN^ORKCHK(.ORY,+ORVP,.ORZ,"SELECT"),RETURN:$D(ORY) 39 S ORX=ORX+1,ORX(ORX)=ORZ(1)_"|"_ORSTRT_"||"_ORSP K ORY,ORZ 40 Q 41 ; 42 DELAY(MODE) ; -- Delayed ACCEPT event [called from ORMEVNT] 43 ; Expects ORVP, ORIFN 44 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" 45 N ORX,ORY,ORCHECK S:'$L($G(MODE)) MODE="NOTIF" 46 D BLD(+ORIFN),EN^ORKCHK(.ORY,+ORVP,.ORX,MODE) Q:'$D(ORY) 47 D RETURN I MODE="NOTIF" S ORCHECK("OK")="Notification sent to provider" D OC^ORCSAVE2 Q ; silent 48 Q 49 ; 50 SESSION ; -- SESSION event [called from ORCSIGN] 51 ; Expects ORVP, ORES() 52 Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" 53 N ORX,ORY,ORIFN,I,X,Y 54 S ORIFN=0 F S ORIFN=$O(ORES(ORIFN)) Q:ORIFN'>0 I +$P(ORIFN,";",2)'>1 D 55 . I "^5^6^10^11^"'[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) Q ;unreleased 56 . D BLD(+ORIFN) Q:'$D(^OR(100,+ORIFN,9)) 57 . S ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1 58 . S I=0 F S I=$O(^OR(100,+ORIFN,9,I)) Q:I'>0 S X=$G(^(I,0)),Y=$G(^(1)),ORCHECK=+$G(ORCHECK)+1,ORCHECK(+ORIFN,$S($P(X,U,2):$P(X,U,2),1:99),ORCHECK)=$P(X,U,1,2)_U_Y 59 I $D(ORX) D EN^ORKCHK(.ORY,+ORVP,.ORX,"SESSION"),RETURN:$D(ORY),REMDUPS 60 Q 61 ; 62 BLD(ORDER) ; -- Build new ORX(#) for ORDER 63 Q:'$G(ORDER) Q:'$D(^OR(100,ORDER,0)) ;Q:$P($G(^(3)),U,11) ;edit/renew 64 N PKG,START,ORI,ITEM,USID,SPEC,ORDG,PTR,INST 65 S ORDG=$P(^OR(100,ORDER,0),U,11),PKG=$$GET1^DIQ(9.4,$P(^(0),U,14)_",",1) 66 I PKG="PS",$G(ORDG) S ORI=$P($G(^ORD(100.98,+ORDG,0)),U,3),ORI=$P(ORI," "),PKG=PKG_$S(ORI="UD":"I",1:ORI) 67 S START=$$START(ORDER),ORI=0 68 F S ORI=$O(^OR(100,ORDER,4.5,"ID","ORDERABLE",ORI)) Q:ORI'>0 D 69 . S INST=$P($G(^OR(100,ORDER,4.5,ORI,0)),U,3),PTR=$P($G(^(0)),U,2),ITEM=+$G(^(1)) 70 . S USID=$S(PKG?1"PS".E:$$DRUG(ITEM,PTR,ORDER),1:$$USID^ORMBLD(ITEM)) 71 . S SPEC=$S(PKG="LR":$$VALUE^ORCSAVE2(ORDER,"SPECIMEN",INST),1:"") 72 . S ORX=+$G(ORX)+1,ORX(ORX)=ITEM_"|"_PKG_"|"_USID_"|"_START_"|"_ORDER_"|"_SPEC 73 Q 74 ; 75 RETURN ; -- Return checks in ORCHECK(ORIFN,CDL,#) 76 N I,IFN,CDL S I=0 F S I=$O(ORY(I)) Q:I'>0 D 77 . S IFN=+$P(ORY(I),U) S:'IFN IFN="NEW" 78 . S CDL=+$P(ORY(I),U,3) S:'CDL CDL=99 79 . S:'$D(ORCHECK(IFN)) ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1 ; count 80 . S ORCHECK=+$G(ORCHECK)+1,ORCHECK(IFN,CDL,ORCHECK)=$P(ORY(I),U,2,4) 81 Q 82 ; 83 REMDUPS ; 84 N IFN,CDL,I 85 S IFN=0 F S IFN=$O(ORCHECK(IFN)) Q:'IFN D 86 . S CDL=0 F S CDL=$O(ORCHECK(IFN,CDL)) Q:'CDL D 87 . . S I=0 F S I=$O(ORCHECK(IFN,CDL,I)) Q:'I D 88 . . . S J=I F S J=$O(ORCHECK(IFN,CDL,J)) Q:'J I $G(ORCHECK(IFN,CDL,I))=$G(ORCHECK(IFN,CDL,J)) K ORCHECK(IFN,CDL,J) S ORCHECK=$G(ORCHECK)-1 89 Q 90 START(DA) ; -- Returns start date/time 91 N I,X,Y,%DT S Y="" 92 I $G(DA) S X=$O(^OR(100,DA,4.5,"ID","START",0)),X=$G(^OR(100,DA,4.5,+X,1)) 93 E D ; look in ORDIALOG instead 94 . S I=0 F S I=$O(ORDIALOG(I)) Q:I'>0 Q:$P(ORDIALOG(I),U,2)="START" 95 . S X=$S(I:$G(ORDIALOG(I,1)),1:"") 96 D AM^ORCSAVE2:X="AM",NEXT^ORCSAVE2:X="NEXT" 97 D ADMIN^ORCSAVE2("NEXT"):X="NEXTA",ADMIN^ORCSAVE2("CLOSEST"):X="CLOSEST" 98 I $L(X) S %DT="TX" D ^%DT S:Y'>0 Y="" 99 Q Y 100 ; 101 DRUG(OI,PTR,IFN) ; -- Returns 6 ^-piece identifier for Dispense Drug 102 N ORDD,ORNDF,Y 103 I ORDG=+$O(^ORD(100.98,"B","IV RX",0)) S ORDD=$$IV G D1 104 I $G(IFN) S ORDD=$O(^OR(100,IFN,4.5,"ID","DRUG",0)),ORDD=+$G(^OR(100,IFN,4.5,+ORDD,1)) 105 E S ORDD=+$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1)) 106 D1 Q:'ORDD "" S ORNDF=$$ENDCM^PSJORUTL(ORDD) 107 S Y=$P(ORNDF,U,3)_"^^99NDF^"_ORDD_U_$P($G(^PSDRUG(ORDD,0)),U)_"^99PSD" 108 Q Y 109 ; 110 IV() ; -- Get Dispense Drug for IV orderable 111 N PSOI,TYPE,VOL,ORY 112 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),VOL="" 113 S TYPE=$S(PTR=$$PTR^ORCD("OR GTX ADDITIVE"):"A",1:"B") 114 S:TYPE="B" VOL=$S($G(IFN):$$VALUE^ORCSAVE2(IFN,"VOLUME"),1:+$G(ORDIALOG($$PTR^ORCD("OR GTX VOLUME"),1))) 115 D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORY) 116 Q +$G(ORY) 117 ; 118 LIST(IFN) ; -- Displays list of ORCHECK(IFN) checks 119 N ORI,ORJ,ORZ,ORMAX,ORTX,ON,OFF 120 S ORZ=0 F S ORZ=$O(ORCHECK(IFN,ORZ)) Q:ORZ'>0 D 121 . S:ORZ=1 ON=IOINHI,OFF=IOINORM S:ORZ'=1 (ON,OFF)="" ; use bold if High 122 . S ORI=0 F S ORI=$O(ORCHECK(IFN,ORZ,ORI)) Q:ORI'>0 D 123 . . S X=$P(ORCHECK(IFN,ORZ,ORI),U,3) I $L(X)<75 W !,ON_">>> "_X_OFF Q 124 . . S ORMAX=74 K ORTX D TXT^ORCHTAB Q:'$G(ORTX) ; wrap 125 . . F ORJ=1:1:ORTX W !,ON_$S(ORJ=1:">>> ",1:" ")_ORTX(ORJ)_OFF 126 W ! 127 Q 128 ; 129 CANCEL() ; -- Returns 1 or 0: Cancel order(s)? 130 N X,Y,DIR,NUM 131 S NUM=+$G(ORCHECK("IFN")),DIR(0)="YA" 132 S DIR("A")="Do you want to cancel "_$S(NUM>1:"any of the new orders? ",1:"the new order? ") 133 S DIR("?",1)="Enter YES to cancel "_$S(NUM>1:"an",1:"the")_" order. If you wish to override these order checks" 134 S DIR("?",2)="and release "_$S(NUM>1:"these orders",1:"this order")_", enter NO; you will be prompted for a justification",DIR("?")="if there are any highlighted critical order checks." 135 D ^DIR 136 Q +Y 137 ; 138 REASON() ; -- Reason for overriding order checks 139 ; I '$D(^XUSEC("ORES",DUZ)),'$D(^XUSEC("ORELSE",DUZ)) Q ?? 140 N X,Y,DIR 141 S DIR(0)="FA^2:80^K:X?1."" "" X",DIR("A")="REASON FOR OVERRIDE: " 142 S DIR("?")="Enter a justification for overriding these order checks, up to 80 characters" 143 D ^DIR I $D(DTOUT)!$D(DUOUT) S Y="^" 144 Q Y -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMED.m
r613 r623 1 ORCMED ;SLC/MKB-Medication actions ;03/19/072 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,7,38,48,94,141,178,190,195,243**;Dec 17, 1997;Build 242 3 XFER 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 XF1 25 26 27 28 29 30 31 32 33 34 35 36 37 38 XF2 39 40 41 42 43 44 45 46 XFQ 47 48 49 50 51 IN 52 53 54 55 56 OUT 57 58 59 60 61 62 63 64 65 66 DOSES(TYPE) 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 CONT() 84 85 86 87 88 89 90 SHOWSIG 91 92 93 94 95 96 97 PTR(NAME) 98 99 100 REFILLS 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 RFQ 118 119 RETURN() 120 121 122 123 ROUTING() 124 125 126 127 128 129 130 NW 131 132 133 134 135 136 137 138 139 140 141 142 NWQ 143 1 ORCMED ;SLC/MKB-Medication actions ;4/2/02 16:45 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,7,38,48,94,141,178,190,195**;Dec 17, 1997 3 XFER ; -- transfer to in/outpt meds 4 N ORPTLK,ORTYPE,ORXFER,ORSRC,ORCAT,OREVENT,X,ORINPT,ORIDLG,ORODLG,ORIVDLG,ORNMSP,ORCNT,ORI,NMBR,ORIFN,OLDIFN,ORDIALOG,ORDG,ORCHECK,ORQUIT,ORDUZ,ORLOG,FIRST,ORDITM,ORD,ORERR 5 S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK D G XFQ ; lock pt chart 6 . W !!,$C(7),$P(ORPTLK,U,2) H 2 7 . S:'$D(VALMBCK) VALMBCK="" 8 I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("transfer") G:'ORNMBR XFQ 9 D FULL^VALM1 S VALMBCK="R",ORTYPE="Q",ORXFER=1,ORDUZ=DUZ,ORSRC="X" 10 S X=$P($P($G(^TMP("OR",$J,"CURRENT",0)),U,3),";",3) S:X="" X=$G(ORWARD) 11 S ORCAT=$S(X:"O",1:"I") I ORCAT="I"!$G(ORWARD) D Q:$G(OREVENT)="^" 12 . W !!,$$CURRENT^OREVNT 13 . S X=$$DELAY^ORCACT I X="^" S OREVENT="^" Q 14 . S:X OREVENT=+$$PTEVENT^OREVNT(+ORVP,1) 15 I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL="^" XFQ 16 S ORINPT=$$INPT^ORCD,ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" XFQ 17 I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location? 18 S ORIDLG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) 19 S ORODLG=+$O(^ORD(101.41,"AB","PSO OERR",0)) 20 S ORIVDLG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0)) 21 D PROVIDER^ORCDPSIV G:$G(ORQUIT) XFQ ;X:$D(^ORD(101.41,ORDIALOG,3)) ^(3) 22 S ORNMSP="PS" D DISPLAY^ORCHECK 23 S ORCNT=$L(ORNMBR,",") S:$P(ORNMBR,",",ORCNT)'>0 ORCNT=ORCNT-1 24 XF1 F ORI=1:1:ORCNT S NMBR=$P(ORNMBR,",",ORI) D:NMBR I $D(ORQUIT),ORI<ORCNT Q:'$$CONT ;if not last one, ask 25 . K ORIFN,ORDIALOG,ORDG,ORDOSE,ORCHECK,ORQUIT,ORERR 26 . K ^TMP("PSJMR",$J),^TMP("ORWORD",$J),^TMP("ORSIG",$J) 27 . S OLDIFN=+$P($G(^TMP("OR",$J,ORTAB,"IDX",NMBR)),U,4) 28 . S ORDITM=$$ORDITEM^ORCACT(OLDIFN) D SUBHDR^ORCACT(ORDITM) 29 . I '$$VALID^ORCACT0(OLDIFN,"XFR",.ORERR) W !,ORERR H 2 Q 30 . S ORD=$P($G(^OR(100,OLDIFN,0)),U,5) Q:ORD'["101.41" ;error msg? 31 . S ORDIALOG=$S(+ORD=ORIVDLG:ORIVDLG,ORCAT="I":ORIDLG,1:ORODLG) 32 . S ORDG=+$P($G(^ORD(101.41,ORDIALOG,0)),U,5) 33 . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(OLDIFN) 34 . I ORDIALOG'=ORIVDLG D OUT:ORCAT="I",IN:ORCAT="O" ;convert data 35 . K ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1) 36 . K ORDIALOG($$PTR^ORCD("OR GTX NOW"),1) 37 . S ORLOG=+$E($$NOW^XLFDT,1,12),FIRST=1 38 XF2 . D DIALOG^ORCDLG Q:$G(ORQUIT)&FIRST K ORQUIT 39 . D ACCEPT^ORCHECK(),DISPLAY^ORCDLG S X=$$OK^ORCDLG I X="^" S ORQUIT=1 Q 40 . I X="E" K ORCHECK S FIRST=0 G XF2 41 . I X="C" W !?10,"... order cancelled.",! Q 42 . I X="P" D 43 . . D EN^ORCSAVE W !?10,$S(ORIFN:"... order placed.",1:"ERROR"),! 44 . . S:$G(ORIFN) ^TMP("ORNEW",$J,ORIFN,1)="" 45 . . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^(ORDIALOG)=ORDIALOG M:$D(^TMP("ORWORD",$J)) ^TMP("ORECALL",$J,ORDIALOG)=^TMP("ORWORD",$J) ;save 1st values 46 XFQ D EXIT^ORCDPS1 ;X:$D(^ORD(101.41,ORDIALOG,4)) ^(4) 47 K ^TMP("ORWORD",$J),^TMP("ORSIG",$J) 48 D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders 49 Q 50 ; 51 IN ; -- Kill extra values, Reset ID's/DD from Inpt dialog 52 N P F P="START DATE/TIME","NOW" K ORDIALOG($$PTR(P),1) 53 D DOSES("O") 54 Q 55 ; 56 OUT ; -- Kill extra values, Reset ID's/DD from Outpt dialog 57 N P I '$O(ORDIALOG($$PTR("INSTRUCTIONS"),0)) D ;old sig in comments 58 . N WP S WP=$$PTR("WORD PROCESSING 1") K ^TMP("ORSIG",$J) 59 . M ^TMP("ORSIG",$J)=^TMP("ORWORD",$J,WP,1) 60 . K ORDIALOG(WP,1),^TMP("ORWORD",$J,WP,1) 61 F P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED" K ORDIALOG($$PTR(P),1) 62 I $G(ORDIALOG($$PTR("URGENCY"),1))=99 K ORDIALOG($$PTR("URGENCY"),1) 63 D DOSES("I") 64 Q 65 ; 66 DOSES(TYPE) ; -- Convert doses to new TYPE, reset ID strings 67 N PSOI,ORMED,PROMPT,DOSE,DRUG,I,X,DD,DRUG0,STR 68 F I="DISPENSE DRUG","STRENGTH","DRUG NAME","SIG" K ORDIALOG($$PTR(I),1) 69 S PSOI=+$P($G(^ORD(101.43,+$G(ORDIALOG($$PTR("ORDERABLE ITEM"),1)),0)),U,2),ORMED=$P($G(^(0)),U) 70 D DOSE^PSSORUTL(.ORDOSE,PSOI,TYPE,+ORVP) I $G(ORDOSE(1))=-1 K ORDOSE 71 S PROMPT=$$PTR("INSTRUCTIONS"),DOSE=$$PTR("DOSE") 72 S DRUG=$$PTR("DISPENSE DRUG") D D1^ORCDPS2 73 S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 D 74 . K ORDIALOG(DOSE,I) S X=$G(ORDIALOG(PROMPT,I)) Q:'$L(X) 75 . S X=$$UP^XLFSTR(X),DD=+$G(ORDIALOG(PROMPT,"LIST","D",X)) Q:'DD 76 . S ORDIALOG(DOSE,I)=$TR($G(ORDOSE("DD",DD,X)),"^","&") 77 . S ORDIALOG(DRUG,I)=DD,DRUG0=$G(ORDOSE("DD",DD)) 78 . S STR=$P(DRUG0,U,5)_$P(DRUG0,U,6) 79 . I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG0,U) Q 80 . I ORMED'[STR,TYPE="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR 81 Q 82 ; 83 CONT() ; -- Want to continue processing orders? 84 N X,Y,DIR 85 S DIR(0)="YA",DIR("A")="Do you want to continue transferring orders? ",DIR("B")="YES" 86 S DIR("?")="Enter YES to continue transferring the remaining orders selected, or NO to quit this option." 87 D ^DIR 88 Q +Y 89 ; 90 SHOWSIG ; -- Show old sig for transfer in ^TMP("ORSIG",$J) 91 N ORTX,I,X,ORMAX S ORMAX=72 92 S I=0 F S I=$O(^TMP("ORSIG",$J,I)) Q:I'>0 S X=$G(^(I,0)) D:$L(X) TXT^ORCHTAB 93 S I=0 F S I=$O(ORTX(I)) Q:I'>0 W !,$S(I=1:"(Sig: ",1:" ")_ORTX(I) 94 W ")" 95 Q 96 ; 97 PTR(NAME) ; -- Returns pointer to OR GTX NAME 98 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) 99 ; 100 REFILLS ; -- Request a refill for med orders 101 ; ORNMBR = #,#,...,# of selected orders 102 ; 103 N ORLK,ORI,NMBR,IDX,ORIFN,ORDITM,ORERR,ORQUIT,OROUT 104 I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR RFQ 105 D FREEZE^ORCMENU S VALMBCK="R" 106 S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" RFQ 107 S:'$G(ORL) ORL=$$LOCATION^ORCMENU1 G:ORL="^" RFQ 108 S OROUT=$$ROUTING G:OROUT="^" RFQ 109 F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR Q:$D(ORQUIT) 110 . S IDX=$G(^TMP("OR",$J,"CURRENT","IDX",NMBR)),ORIFN=+$P(IDX,U,4) 111 . Q:'ORIFN I '$D(^OR(100,ORIFN,0)) W !,"Invalid order number!" H 2 Q 112 . S ORDITM=$$ORDITEM^ORCACT(ORIFN) D SUBHDR^ORCACT(ORDITM) 113 . I '$$VALID^ORCACT0(ORIFN,"RF",.ORERR) W !,ORERR H 2 Q 114 . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 2 Q 115 . D REF^ORMBLDPS(ORIFN,OROUT),UNLK1^ORX2(+ORIFN) 116 . W !?10,"... refill requested.",$$RETURN 117 RFQ Q 118 ; 119 RETURN() ; -- press return to cont 120 N X W !,"Press <return> to continue ..." R X:DTIME 121 Q "" 122 ; 123 ROUTING() ; -- Routing for refill 124 N X,Y,DIR S DIR(0)="SAM^W:WINDOW;M:MAIL;C:ADMINISTERED IN CLINIC;" 125 S DIR("A")="Routing: ",DIR("B")=$S($D(^PSX(550,"C")):"MAIL",1:"WINDOW") 126 S DIR("?")="Select how the patient is to receive this refill, by mail or at the window or in the clinic" 127 D ^DIR S:$D(DTOUT)!(X["^") Y="^" 128 Q Y 129 ; 130 NW ; -- Order New Medication from Meds tab 131 ; Requires ORDIALOG = name of pkg dialog 132 ; OREVENT = event, if delaying orders 133 ; OREVENT("TS") = treating spec, if admission or transfer 134 N ORPTLK G:'$L($G(ORDIALOG)) NWQ 135 S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q 136 D FREEZE^ORCMENU S VALMBCK="R" 137 S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" NWQ 138 I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL["^" NWQ 139 S ORDIALOG=$O(^ORD(101.41,"AB",$E(ORDIALOG,1,63),0)) G:'ORDIALOG NWQ 140 D ADD^ORCDLG,REBLD^ORCMENU:$D(^TMP("ORNEW",$J)) 141 K ORDIALOG,^TMP("ORWORD",$J),^TMP("ORECALL",$J) S VALMBCK="R" 142 NWQ D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders 143 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT0.m
r613 r623 1 ORCMEDT0 ;SLC/MKB-Dialog Utilities ;08/06/2007 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**46,60,190,215,243**;Dec 17, 1997;Build 242 3 DIALOG(TYPE) ; -- Get Dialog file entry 4 N X,Y,Z,D,DIC,DIE,DIK,DA,DR,DLAYGO,ORPKG,ORDLG,ORIT,OROI,I,IDX 5 S ORPKG="ORDER ENTRY/RESULTS REPORTING",DIC="^ORD(101.41,",DIC(0)="AEQLZ" 6 S DIC("S")="I $P(^(0),U,4)="""_TYPE_"""",DLAYGO=101.41 7 S DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",TYPE="A":"ACTION",1:"ORDER DIALOG")_" NAME: " 8 S DIC("DR")="4///"_TYPE_$S(TYPE="D":";7///^S X=ORPKG",1:"") 9 D0 S D="AB" D IX^DIC I Y'>0 S ORDLG="^" G DQ 10 S ORDLG=+Y,ORDG=$P(Y(0),U,5) G:'$P(Y,U,3) DQ ; not a new entry 11 I $O(^ORD(101.41,"AB",$P(Y,U,2),0))'=+Y W $C(7),!,"Another entry already exists by this name!",! D DEL(+Y) G D0 12 I TYPE="D" D G:ORDLG="^" DQ ;new dialog 13 . S DA=ORDLG,DR="5R",DIE=DIC,ORIT=$P(Y,U,2) D ^DIE 14 . S ORDG=+$P($G(^ORD(101.41,ORDLG,0)),U,5) 15 . I 'ORDG W $C(7),!,"Deleting <"_ORIT_"> ..." S DA=ORDLG,DIK=DIC D ^DIK S ORDLG="^" Q 16 . S ORIT=$$OI^ORCMEDT3(+ORDG) S:ORIT="^" ORDLG="^" 17 I TYPE="Q" D G DQ ;new quick order 18 . S DIC="^ORD(100.98,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)" 19 . S DIC("A")="TYPE OF QUICK ORDER: " D ^DIC 20 . I Y>0 S ORDG=+Y,$P(^ORD(101.41,ORDLG,0),U,5)=+Y Q 21 . W !,$P(^ORD(101.41,ORDLG,0),U)_" quick order dialog DELETED!",! 22 . S DA=ORDLG,DIK="^ORD(101.41,",ORDLG="^" D ^DIK 23 D1 I $$COPY^ORCMEDIT(TYPE) D ;copy an existing dialog? 24 . K DLAYGO,DIC("B") S DIC(0)="AEQZ",DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",1:"ORDER DIALOG")_" TO COPY: " 25 . D ^DIC Q:Y'>0 W !,"Copying ..." 26 . F I=2,6,8,9 S $P(^ORD(101.41,ORDLG,0),U,I)=$P(Y(0),U,I) 27 . S:TYPE'="D" $P(^ORD(101.41,ORDLG,0),U,5)=$P(Y(0),U,5) ;skip DG if Dlg 28 . S:$L($P(Y(0),U,2)) ^ORD(101.41,"C",$$UP^XLFSTR($P(Y(0),U,2)),ORDLG)="" ;disp text 29 . F I=2,3,3.1,4,5,6,7,9,10 I $D(^ORD(101.41,+Y,I)) M ^ORD(101.41,ORDLG,I)=^ORD(101.41,+Y,I) 30 . I $P(Y(0),U,7) S DA=ORDLG,DIE=DIC,DR="7///"_$P(Y(0),U,7) D ^DIE 31 . K DA S DA(1)=ORDLG,DIK="^ORD(101.41,"_ORDLG_",10,",DIK(1)="2^AD" D ENALL^DIK 32 D2 I TYPE="D",$G(ORIT) D ;stuff in default OI 33 . S DA=ORDLG,DR="2///"_$P(ORIT,U,2),DIE="^ORD(101.41," D ^DIE 34 . S OROI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),DA=$O(^ORD(101.41,ORDLG,10,"D",OROI,0)) I 'DA D Q:'DA ;create OI prompt 35 .. S X=+$O(^ORD(101.41,ORDLG,10,"B",0)),X=$S(X=0:1,1:X-.1) ;get Seq# 36 .. K DA,DIC S DIC="^ORD(101.41,"_ORDLG_",10,",DIC(0)="L",DA(1)=ORDLG 37 .. D ^DIC Q:Y'>0 S DA=+Y ;S DIC("P")=$P(^DD(101.41,10,0),U,2) 38 .. S Z=+$O(^ORD(101.41,ORDLG,10,"ATXT",0)),Z=$S(Z=0:1,1:Z-.1) ;TxtSeq# 39 .. S ^ORD(101.41,ORDLG,10,DA,0)=X_U_OROI_"^^Order: ^^1",^(2)=Z 40 .. S ^ORD(101.41,"AD",OROI,ORDLG,DA)="",^ORD(101.41,ORDLG,10,"B",X,DA)="",^ORD(101.41,ORDLG,10,"D",OROI,DA)="",^ORD(101.41,ORDLG,10,"ATXT",X,DA)="" 41 . S IDX="S."_$P($G(^ORD(100.98,+ORDG,0)),U,3) 42 . S $P(^ORD(101.41,ORDLG,10,DA,0),U,8)=1,$P(^(0),U,10)=IDX,^(3)="I 0 ;uneditable",^(7)="S Y="_+ORIT 43 DQ Q ORDLG 44 ; 45 DEL(DA) ; -- delete bad entry in Order Dialog file 46 N DIK S DIK="^ORD(101.41," D:$G(DA) ^DIK 47 Q 48 ; 49 SAVE ; -- Save ORDG, responses in ORDIALOG to dialog ORQDLG 50 N PROMPT,CNT,ITM,TYPE,INST,VALUE,INP,UD K ^ORD(101.41,ORQDLG,6) 51 S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D 52 . S ITM=ORDIALOG(PROMPT),TYPE=$E(ORDIALOG(PROMPT,0)) 53 . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D 54 . . S VALUE=$G(ORDIALOG(PROMPT,INST)),CNT=CNT+1 55 . . S ^ORD(101.41,ORQDLG,6,CNT,0)=+ITM_U_PROMPT_U_INST 56 . . S:TYPE'="W" ^ORD(101.41,ORQDLG,6,CNT,1)=VALUE 57 . . M:TYPE="W" ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE 58 . . S ^ORD(101.41,ORQDLG,6,"D",PROMPT,CNT)="" 59 S ^ORD(101.41,ORQDLG,6,0)="^101.416^"_CNT_U_CNT 60 S INP=+$O(^ORD(100.98,"B","INPATIENT MEDICATIONS","")) 61 S UD=+$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS","")) 62 I +$G(ORDG)>0,ORDG=INP,UD>0 S ORDG=UD 63 S:$G(ORDG) $P(^ORD(101.41,ORQDLG,0),U,5)=+ORDG 64 Q 65 ; 66 ITEM(Z) ; -- Select new item to add 67 N X,Y,DIC,ORDDF,ORERR,I 68 S DIC=101.41,DIC(0)="AEQM",DIC("A")="ITEM: " 69 I $G(Z) S Z=$P($G(^ORD(101.41,+Z,0)),U) S:$L(Z) DIC("B")=Z 70 S DIC("S")="I $P(^(0),U,4)'=""P""" 71 IT1 D ^DIC I Y'>0 S Y=$S($D(DUOUT)!$D(DTOUT):"^",1:"") Q Y 72 D RECURSV^ORCMEDT5(+Y,+ORMENU,.ORERR) I $D(ORERR) D G IT1 73 . W $C(7),!!,"An ancestor of this menu may not be added as an item!" 74 . W !,ORERR S I=0 F S I=$O(ORERR(I)) Q:I'>0 W !?18," =>"_ORERR(I) 75 Q +Y 1 ORCMEDT0 ;SLC/MKB-Dialog Utilities ;04:11 PM 12 Feb 1999 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**46,60,190,215**;Dec 17, 1997 3 DIALOG(TYPE) ; -- Get Dialog file entry 4 N X,Y,Z,D,DIC,DIE,DIK,DA,DR,DLAYGO,ORPKG,ORDLG,ORIT,OROI,I,IDX 5 S ORPKG="ORDER ENTRY/RESULTS REPORTING",DIC="^ORD(101.41,",DIC(0)="AEQLZ" 6 S DIC("S")="I $P(^(0),U,4)="""_TYPE_"""",DLAYGO=101.41 7 S DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",TYPE="A":"ACTION",1:"ORDER DIALOG")_" NAME: " 8 S DIC("DR")="4///"_TYPE_$S(TYPE="D":";7///^S X=ORPKG",1:"") 9 D0 S D="AB" D IX^DIC I Y'>0 S ORDLG="^" G DQ 10 S ORDLG=+Y,ORDG=$P(Y(0),U,5) G:'$P(Y,U,3) DQ ; not a new entry 11 I $O(^ORD(101.41,"AB",$P(Y,U,2),0))'=+Y W $C(7),!,"Another entry already exists by this name!",! D DEL(+Y) G D0 12 I TYPE="D" D G:ORDLG="^" DQ ;new dialog 13 . S DA=ORDLG,DR="5R",DIE=DIC,ORIT=$P(Y,U,2) D ^DIE 14 . S ORDG=+$P($G(^ORD(101.41,ORDLG,0)),U,5) 15 . I 'ORDG W $C(7),!,"Deleting <"_ORIT_"> ..." S DA=ORDLG,DIK=DIC D ^DIK S ORDLG="^" Q 16 . S ORIT=$$OI^ORCMEDT3(+ORDG) S:ORIT="^" ORDLG="^" 17 I TYPE="Q" D G DQ ;new quick order 18 . S DIC="^ORD(100.98,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)" 19 . S DIC("A")="TYPE OF QUICK ORDER: " D ^DIC 20 . I Y>0 S ORDG=+Y,$P(^ORD(101.41,ORDLG,0),U,5)=+Y Q 21 . W !,$P(^ORD(101.41,ORDLG,0),U)_" quick order dialog DELETED!",! 22 . S DA=ORDLG,DIK="^ORD(101.41,",ORDLG="^" D ^DIK 23 D1 I $$COPY^ORCMEDIT(TYPE) D ;copy an existing dialog? 24 . K DLAYGO,DIC("B") S DIC(0)="AEQZ",DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",1:"ORDER DIALOG")_" TO COPY: " 25 . D ^DIC Q:Y'>0 W !,"Copying ..." 26 . F I=2,6,8,9 S $P(^ORD(101.41,ORDLG,0),U,I)=$P(Y(0),U,I) 27 . S:TYPE'="D" $P(^ORD(101.41,ORDLG,0),U,5)=$P(Y(0),U,5) ;skip DG if Dlg 28 . S:$L($P(Y(0),U,2)) ^ORD(101.41,"C",$$UP^XLFSTR($P(Y(0),U,2)),ORDLG)="" ;disp text 29 . F I=2,3,3.1,4,5,6,7,9,10 I $D(^ORD(101.41,+Y,I)) M ^ORD(101.41,ORDLG,I)=^ORD(101.41,+Y,I) 30 . I $P(Y(0),U,7) S DA=ORDLG,DIE=DIC,DR="7///"_$P(Y(0),U,7) D ^DIE 31 . K DA S DA(1)=ORDLG,DIK="^ORD(101.41,"_ORDLG_",10,",DIK(1)="2^AD" D ENALL^DIK 32 D2 I TYPE="D",$G(ORIT) D ;stuff in default OI 33 . S DA=ORDLG,DR="2///"_$P(ORIT,U,2),DIE="^ORD(101.41," D ^DIE 34 . S OROI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),DA=$O(^ORD(101.41,ORDLG,10,"D",OROI,0)) I 'DA D Q:'DA ;create OI prompt 35 .. S X=+$O(^ORD(101.41,ORDLG,10,"B",0)),X=$S(X=0:1,1:X-.1) ;get Seq# 36 .. K DA,DIC S DIC="^ORD(101.41,"_ORDLG_",10,",DIC(0)="L",DA(1)=ORDLG 37 .. D ^DIC Q:Y'>0 S DA=+Y ;S DIC("P")=$P(^DD(101.41,10,0),U,2) 38 .. S Z=+$O(^ORD(101.41,ORDLG,10,"ATXT",0)),Z=$S(Z=0:1,1:Z-.1) ;TxtSeq# 39 .. S ^ORD(101.41,ORDLG,10,DA,0)=X_U_OROI_"^^Order: ^^1",^(2)=Z 40 .. S ^ORD(101.41,"AD",OROI,ORDLG,DA)="",^ORD(101.41,ORDLG,10,"B",X,DA)="",^ORD(101.41,ORDLG,10,"D",OROI,DA)="",^ORD(101.41,ORDLG,10,"ATXT",X,DA)="" 41 . S IDX="S."_$P($G(^ORD(100.98,+ORDG,0)),U,3) 42 . S $P(^ORD(101.41,ORDLG,10,DA,0),U,8)=1,$P(^(0),U,10)=IDX,^(3)="I 0 ;uneditable",^(7)="S Y="_+ORIT 43 DQ Q ORDLG 44 ; 45 DEL(DA) ; -- delete bad entry in Order Dialog file 46 N DIK S DIK="^ORD(101.41," D:$G(DA) ^DIK 47 Q 48 ; 49 SAVE ; -- Save ORDG, responses in ORDIALOG to dialog ORQDLG 50 N PROMPT,CNT,ITM,TYPE,INST,VALUE K ^ORD(101.41,ORQDLG,6) 51 S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D 52 . S ITM=ORDIALOG(PROMPT),TYPE=$E(ORDIALOG(PROMPT,0)) 53 . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D 54 . . S VALUE=$G(ORDIALOG(PROMPT,INST)),CNT=CNT+1 55 . . S ^ORD(101.41,ORQDLG,6,CNT,0)=+ITM_U_PROMPT_U_INST 56 . . S:TYPE'="W" ^ORD(101.41,ORQDLG,6,CNT,1)=VALUE 57 . . M:TYPE="W" ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE 58 . . S ^ORD(101.41,ORQDLG,6,"D",PROMPT,CNT)="" 59 S ^ORD(101.41,ORQDLG,6,0)="^101.416^"_CNT_U_CNT 60 S:$G(ORDG) $P(^ORD(101.41,ORQDLG,0),U,5)=+ORDG 61 Q 62 ; 63 ITEM(Z) ; -- Select new item to add 64 N X,Y,DIC,ORDDF,ORERR,I 65 S DIC=101.41,DIC(0)="AEQM",DIC("A")="ITEM: " 66 I $G(Z) S Z=$P($G(^ORD(101.41,+Z,0)),U) S:$L(Z) DIC("B")=Z 67 S DIC("S")="I $P(^(0),U,4)'=""P""" 68 IT1 D ^DIC I Y'>0 S Y=$S($D(DUOUT)!$D(DTOUT):"^",1:"") Q Y 69 D RECURSV^ORCMEDT5(+Y,+ORMENU,.ORERR) I $D(ORERR) D G IT1 70 . W $C(7),!!,"An ancestor of this menu may not be added as an item!" 71 . W !,ORERR S I=0 F S I=$O(ORERR(I)) Q:I'>0 W !?18," =>"_ORERR(I) 72 Q +Y -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT1.m
r613 r623 1 ORCMEDT1 ;SLC/MKB-QO,Set editor ;02/25/08 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,57,95,110,245,243**;Dec 17, 1997;Build 242 3 OI ; -- Enter/edit generic orderable items 4 N X,Y,DA,DR,DIE,DIC,ID,DLAYGO,ORDG 5 F S ORDG=$$DGRP Q:ORDG'>0 D W !! 6 . F S D="S."_$P(ORDG,U,4) D Q:Y'>0 S DA=+Y,ID=DA_";99ORD",DR=".01"_$S($P(Y,U,3):";2///^S X=ID;5////"_+ORDG,1:"") D ^DIE W ! ;110 7 .. S DIC="^ORD(101.43,",DIC(0)="AEQL",DLAYGO=101.43,DIE=DIC D IX^DIC ;110 8 Q 9 ; 10 DGRP() ; -- Returns sub-display group of Nursing or Other for generic OI 11 N X,Y,DIC,ORGRP,ORDG,ORI 12 F ORI="NURS","OTHER" S ORDG=+$O(^ORD(100.98,"B",ORI,0)) D DG^ORCHANG1(ORDG,"BILD",.ORGRP) 13 S DIC="^ORD(100.98,",DIC(0)="AEQ",DIC("S")="I $D(ORGRP(+Y))" 14 S DIC("A")="Type of Orderable: " D ^DIC 15 S:Y>0 Y=+Y_U_$G(^ORD(100.98,+Y,0)) 16 Q Y 17 ; 18 QUICK ; -- Enter/edit quick order dialogs 19 N ORQDLG,ORDG 20 F S ORQDLG=$$DIALOG^ORCMEDT0("Q") Q:ORQDLG="^" D QCK0(ORQDLG) W ! 21 Q 22 QCK0(ORQDLG) ; -- edit quick order ORQDLG 23 N ORDIALOG,DA,DR,DIE,DIDEL,ORQUIT,ORVP,ORL,ACTION,FIRST,ORTYPE,ORNAME,X,Y,BEFORCRC,AFTERCRC 24 Q:'$G(ORQDLG) S DA=ORQDLG,(ORVP,ORL)=0,FIRST=1,ORTYPE="Z" 25 S ORNAME=$$NAME^ORCMEDT4(ORQDLG) Q:(ORNAME="@")!(ORNAME="^") ;deleted,^ 26 S BEFORCRC=$$RAWCRC^ORCMEDT8(ORQDLG) 27 S DR=".01///^S X=ORNAME;2;8;20"_$S(DUZ(0)="@":";30",1:""),DIE="^ORD(101.41," 28 D ^DIE G:$D(Y)!$D(DTOUT) QR D GETQDLG^ORCD(ORQDLG) G:'$G(ORDIALOG) QR 29 I '$P($G(^ORD(101.41,ORQDLG,0)),U,7) S X=+$P($G(^ORD(101.41,+ORDIALOG,0)),U,7) S:X $P(^ORD(101.41,ORQDLG,0),U,7)=X,^ORD(101.41,"APKG",X,ORQDLG)="" 30 W ! I $D(^ORD(101.41,+ORDIALOG,3.1)) X ^(3.1) G:$G(ORQUIT) QQ 31 Q1 D DIALOG^ORCDLG G:$G(ORQUIT) QQ 32 D DISPLAY^ORCDLG S ACTION=$$OK G:ACTION="^" QQ 33 D:ACTION="P" SAVE^ORCMEDT0,AUTO(ORQDLG) I ACTION="E" S FIRST=0 G Q1 ;fall thru if "C" 34 QQ X:$D(^ORD(101.41,+ORDIALOG,4)) ^(4) 35 QR S AFTERCRC=$$RAWCRC^ORCMEDT8(ORQDLG) 36 I BEFORCRC'=AFTERCRC D UPDQNAME^ORCMEDT8(ORQDLG) ; Rename personal quick order if modified 37 Q 38 ; 39 OK() ; -- Ready to save? 40 N X,Y,DIR S DIR(0)="SAM^P:PLACE;E:EDIT;C:CANCEL;",DIR("B")="PLACE" 41 S DIR("A")="(P)lace, (E)dit, or (C)ancel this quick order? " 42 S DIR("?")="Enter P to save this quick order, or E to change any of the displayed values; enter C to quit without saving these responses" 43 D ^DIR S:$D(DTOUT) Y="^" 44 Q Y 45 ; 46 SAVE G SAVE^ORCMEDT0 47 ; 48 AUTO(DLG) ; -- set AutoAccept flag for GUI 49 N X,Y,DIR 50 I $$VALQO^ORWDXM3(+DLG)=0 S $P(^ORD(101.41,+DLG,5),U,8)="" Q 51 S DIR(0)="YA",DIR("A")="Auto-accept this order? " 52 S DIR("B")=$S($P($G(^ORD(101.41,+DLG,5)),U,8):"YES",1:"NO") 53 S DIR("?")="Enter YES if this order can be placed simply by selecting it, or NO if the dialog should be presented to complete the order." 54 D ^DIR S:Y=1!(Y=0) $P(^ORD(101.41,+DLG,5),U,8)=$S(Y:1,1:"") 55 I $P($G(^ORD(101.41,+DLG,0)),"^",8)'=1&($P($G(^(0)),"^",9)=2)&(Y) D EXPLAIN S $P(^ORD(101.41,+DLG,5),"^",8)="" ;Reset auto-accept to no if explanation required. 56 Q 57 ; 58 SET ; -- Order Sets 59 N ORSET,ORDG 60 F S ORSET=$$DIALOG^ORCMEDT0("O") Q:ORSET="^" D SET0(ORSET) W ! 61 Q 62 SET0(ORSET) ; -- edit order set ORSET 63 N DA,DR,DIE,DIC,DIK,X,Y,SEQ,ITM,LCNT,QUIT,ORNAME Q:'$G(ORSET) 64 S ORNAME=$$NAME^ORCMEDT4(ORSET) Q:(ORNAME="@")!(ORNAME="^") ;deleted,^ 65 S DR=".01///^S X=ORNAME;2;20"_$S(DUZ(0)="@":";30;40",1:""),DA=ORSET 66 S DIE="^ORD(101.41," D ^DIE Q:$D(Y) Q:'$G(DA) 67 S1 I $O(^ORD(101.41,+ORSET,10,0)) D Q:QUIT ;Show existing components 68 . W !,"ORDER SET COMPONENTS:" S (SEQ,LCNT,QUIT)=0 69 . S DIK="^ORD(101.41,"_+ORSET_",10,",DA(1)=+ORSET ;just in case 70 . F S SEQ=$O(^ORD(101.41,+ORSET,10,"B",SEQ)) Q:SEQ'>0 D 71 . . S DA=0 F S DA=$O(^ORD(101.41,+ORSET,10,"B",SEQ,DA)) Q:DA'>0 D 72 . . . S ITM=$P($G(^ORD(101.41,+ORSET,10,DA,0)),U,2) I ITM'>0 D ^DIK Q 73 . . . S LCNT=LCNT+1 I LCNT>(IOSL-3) R !,"Press <return> to continue ...",X:DTIME S LCNT=0 I X["^" S QUIT=1 Q 74 . . . W !?3,SEQ,?10,$P(^ORD(101.41,ITM,0),U) 75 S2 S QUIT=0 F D Q:QUIT W ! ;Enter/edit components 76 . S DIC="^ORD(101.41,"_+ORSET_",10,",DIC(0)="AEQLM",D="B^D" 77 . S DIC("A")="Select COMPONENT SEQUENCE#: ",DIC("P")=$P(^DD(101.41,10,0),U,2) 78 . K DA S DA(1)=+ORSET D MIX^DIC1 I Y'>0 S QUIT=1 Q 79 . S DA=+Y,DIE=DIC,DR=".01;2R" D ^DIE Q:'$G(DA) 80 . I $D(^ORD(101.41,+ORSET,10,DA,0)),'$P(^(0),U,2) S DIK=DIE D ^DIK 81 Q 82 ; 83 PROTOCOL ; -- Convert additional protocols to dialogs 84 N X,Y,DIC,ORERR 85 F S DIC="^ORD(101,",DIC(0)="AEQM" D ^DIC Q:Y'>0 D W ! 86 . S ORP=+Y,ORM=$$MENU Q:ORM="^" ; What about "^^"-jumping? (ORWARD) 87 . W !,"Converting ..." D ONE(ORP,ORM,.ORERR) I '$G(ORERR) W " done." Q 88 . W " unable to convert.",!,">> "_$P(ORERR,U,2) K ORERR 89 Q 90 ONE(PITEM,ORADD,ERROR) ; -- Convert single item protocol, add to menu(s) 91 N PMENU,DMENU,NAME,ORPOS,POS,XUTL,DA,DIK 92 I $D(^ORD(100.99,1,101.41,PITEM,0)) S DA=PITEM,DA(1)=1,DIK="^ORD(100.99,1,101.41," D ^DIK ; delete error entry 93 S NAME=$P($G(^ORD(101,PITEM,0)),U),DITEM=$$ITEM^ORCONVRT(PITEM) 94 I 'DITEM!$D(^ORD(100.99,1,101.41,PITEM,0)) S ERROR=$G(^(0)) Q 95 Q:'$G(ORADD) ;to add, may enter here with PITEM & DITEM defined 96 ADD S PMENU=0 F S PMENU=$O(^ORD(101,"AD",PITEM,PMENU)) Q:PMENU'>0 D W "." 97 . S DMENU=$O(^ORD(101.41,"AB",$P(^ORD(101,PMENU,0),U),0)) Q:'DMENU 98 . S ORPOS=$$FINDXUTL(PMENU,PITEM) Q:'ORPOS 99 . S XUTL=$G(^XUTL("XQORM",PMENU_";ORD(101,",ORPOS,0)) 100 . S DA=$O(^ORD(101.41,DMENU,10,"B",ORPOS,0)) I DA Q:$P(^ORD(101.41,DMENU,10,DA,0),U,2)=DITEM S POS=$O(^ORD(101.41,DMENU,10,"B",""),-1),ORPOS=($P(POS,".")+1)_".1",DA="" ; move to end, if collision 101 . S DA=$$NEXT^ORCONVRT(DMENU) 102 . S ^ORD(101.41,DMENU,10,DA,0)=ORPOS_U_DITEM_U_$P(XUTL,U,4)_U_$S($P(XUTL,U,3)'=$P(^ORD(101.41,DITEM,0),U,2):$P(XUTL,U,3),1:"") 103 . S ^ORD(101.41,DMENU,10,"B",ORPOS,DA)="",^ORD(101.41,DMENU,10,"D",DITEM,DA)="" 104 . S ^ORD(101.41,"AD",DITEM,DMENU,DA)="",^ORD(101.41,DMENU,99)=$H 105 Q 106 ; 107 FINDXUTL(MENU,ITEM) ; -- Returns position of ITEM in MENU 108 N XQORM,POS 109 S XQORM=MENU_";ORD(101," D XREF^XQORM 110 S POS=0 F S POS=$O(^XUTL("XQORM",XQORM,POS)) Q:POS'>0 I $P(^(POS,0),U,2)=ITEM Q 111 Q POS 112 ; 113 MENU() ; -- Add converted item to menus? 114 N X,Y,DIR S DIR(0)="YA" 115 S DIR("A")="Add this item to the same menus again? ",DIR("B")="YES" 116 S DIR("?")="Enter YES to have this item placed on the same menus in the Order Dialog file as it was in the Protocol file" 117 D ^DIR S:$D(DTOUT) Y="^" 118 Q Y 119 EXPLAIN ;Give reason why user can't set auto-accept to yes 120 W !!,"The combination of VERIFY set to NO and ASK FOR ANOTHER ORDER set to",!,"YES, DON'T ASK and AUTO-ACCEPT set to YES is not allowed." 121 W !!,"This combination of settings could cause CPRS to enter into an infinite loop",!,"creating the same order over and over. If you wish to have" 122 W !,"AUTO-ACCEPT set to YES you must change one of the other two fields",!,"to a different value.",!!,"AUTO-ACCEPT is being set to NO for you." 123 Q 1 ORCMEDT1 ;SLC/MKB-QO,Set editor ;11/6/01 13:33 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,57,95,110,245**;Dec 17, 1997;Build 2 3 OI ; -- Enter/edit generic orderable items 4 N X,Y,DA,DR,DIE,DIC,ID,DLAYGO,ORDG 5 F S ORDG=$$DGRP Q:ORDG'>0 D W !! 6 . F S D="S."_$P(ORDG,U,4) D Q:Y'>0 S DA=+Y,ID=DA_";99ORD",DR=".01"_$S($P(Y,U,3):";2///^S X=ID;5////"_+ORDG,1:"") D ^DIE W ! ;110 7 .. S DIC="^ORD(101.43,",DIC(0)="AEQL",DLAYGO=101.43,DIE=DIC D IX^DIC ;110 8 Q 9 ; 10 DGRP() ; -- Returns sub-display group of Nursing or Other for generic OI 11 N X,Y,DIC,ORGRP,ORDG,ORI 12 F ORI="NURS","OTHER" S ORDG=+$O(^ORD(100.98,"B",ORI,0)) D DG^ORCHANG1(ORDG,"BILD",.ORGRP) 13 S DIC="^ORD(100.98,",DIC(0)="AEQ",DIC("S")="I $D(ORGRP(+Y))" 14 S DIC("A")="Type of Orderable: " D ^DIC 15 S:Y>0 Y=+Y_U_$G(^ORD(100.98,+Y,0)) 16 Q Y 17 ; 18 QUICK ; -- Enter/edit quick order dialogs 19 N ORQDLG,ORDG 20 F S ORQDLG=$$DIALOG^ORCMEDT0("Q") Q:ORQDLG="^" D QCK0(ORQDLG) W ! 21 Q 22 QCK0(ORQDLG) ; -- edit quick order ORQDLG 23 N ORDIALOG,DA,DR,DIE,DIDEL,ORQUIT,ORVP,ORL,ACTION,FIRST,ORTYPE,ORNAME,X,Y,BEFORCRC,AFTERCRC 24 Q:'$G(ORQDLG) S DA=ORQDLG,(ORVP,ORL)=0,FIRST=1,ORTYPE="Z" 25 S ORNAME=$$NAME^ORCMEDT4(ORQDLG) Q:(ORNAME="@")!(ORNAME="^") ;deleted,^ 26 S BEFORCRC=$$RAWCRC^ORCMEDT8(ORQDLG) 27 S DR=".01///^S X=ORNAME;2;8;20"_$S(DUZ(0)="@":";30",1:""),DIE="^ORD(101.41," 28 D ^DIE G:$D(Y)!$D(DTOUT) QR D GETQDLG^ORCD(ORQDLG) G:'$G(ORDIALOG) QR 29 I '$P($G(^ORD(101.41,ORQDLG,0)),U,7) S X=+$P($G(^ORD(101.41,+ORDIALOG,0)),U,7) S:X $P(^ORD(101.41,ORQDLG,0),U,7)=X,^ORD(101.41,"APKG",X,ORQDLG)="" 30 W ! I $D(^ORD(101.41,+ORDIALOG,3.1)) X ^(3.1) G:$G(ORQUIT) QQ 31 Q1 D DIALOG^ORCDLG G:$G(ORQUIT) QQ 32 D DISPLAY^ORCDLG S ACTION=$$OK G:ACTION="^" QQ 33 D:ACTION="P" SAVE^ORCMEDT0,AUTO(ORQDLG) I ACTION="E" S FIRST=0 G Q1 ;fall thru if "C" 34 QQ X:$D(^ORD(101.41,+ORDIALOG,4)) ^(4) 35 QR S AFTERCRC=$$RAWCRC^ORCMEDT8(ORQDLG) 36 I BEFORCRC'=AFTERCRC D UPDQNAME^ORCMEDT8(ORQDLG) ; Rename personal quick order if modified 37 Q 38 ; 39 OK() ; -- Ready to save? 40 N X,Y,DIR S DIR(0)="SAM^P:PLACE;E:EDIT;C:CANCEL;",DIR("B")="PLACE" 41 S DIR("A")="(P)lace, (E)dit, or (C)ancel this quick order? " 42 S DIR("?")="Enter P to save this quick order, or E to change any of the displayed values; enter C to quit without saving these responses" 43 D ^DIR S:$D(DTOUT) Y="^" 44 Q Y 45 ; 46 SAVE G SAVE^ORCMEDT0 47 ; 48 AUTO(DLG) ; -- set AutoAccept flag for GUI 49 N X,Y,DIR 50 S DIR(0)="YA",DIR("A")="Auto-accept this order? " 51 S DIR("B")=$S($P($G(^ORD(101.41,+DLG,5)),U,8):"YES",1:"NO") 52 S DIR("?")="Enter YES if this order can be placed simply by selecting it, or NO if the dialog should be presented to complete the order." 53 D ^DIR S:Y=1!(Y=0) $P(^ORD(101.41,+DLG,5),U,8)=$S(Y:1,1:"") 54 I $P($G(^ORD(101.41,+DLG,0)),"^",8)'=1&($P($G(^(0)),"^",9)=2)&(Y) D EXPLAIN S $P(^ORD(101.41,+DLG,5),"^",8)="" ;Reset auto-accept to no if explanation required. 55 Q 56 ; 57 SET ; -- Order Sets 58 N ORSET,ORDG 59 F S ORSET=$$DIALOG^ORCMEDT0("O") Q:ORSET="^" D SET0(ORSET) W ! 60 Q 61 SET0(ORSET) ; -- edit order set ORSET 62 N DA,DR,DIE,DIC,DIK,X,Y,SEQ,ITM,LCNT,QUIT,ORNAME Q:'$G(ORSET) 63 S ORNAME=$$NAME^ORCMEDT4(ORSET) Q:(ORNAME="@")!(ORNAME="^") ;deleted,^ 64 S DR=".01///^S X=ORNAME;2;20"_$S(DUZ(0)="@":";30;40",1:""),DA=ORSET 65 S DIE="^ORD(101.41," D ^DIE Q:$D(Y) Q:'$G(DA) 66 S1 I $O(^ORD(101.41,+ORSET,10,0)) D Q:QUIT ;Show existing components 67 . W !,"ORDER SET COMPONENTS:" S (SEQ,LCNT,QUIT)=0 68 . S DIK="^ORD(101.41,"_+ORSET_",10,",DA(1)=+ORSET ;just in case 69 . F S SEQ=$O(^ORD(101.41,+ORSET,10,"B",SEQ)) Q:SEQ'>0 D 70 . . S DA=0 F S DA=$O(^ORD(101.41,+ORSET,10,"B",SEQ,DA)) Q:DA'>0 D 71 . . . S ITM=$P($G(^ORD(101.41,+ORSET,10,DA,0)),U,2) I ITM'>0 D ^DIK Q 72 . . . S LCNT=LCNT+1 I LCNT>(IOSL-3) R !,"Press <return> to continue ...",X:DTIME S LCNT=0 I X["^" S QUIT=1 Q 73 . . . W !?3,SEQ,?10,$P(^ORD(101.41,ITM,0),U) 74 S2 S QUIT=0 F D Q:QUIT W ! ;Enter/edit components 75 . S DIC="^ORD(101.41,"_+ORSET_",10,",DIC(0)="AEQLM",D="B^D" 76 . S DIC("A")="Select COMPONENT SEQUENCE#: ",DIC("P")=$P(^DD(101.41,10,0),U,2) 77 . K DA S DA(1)=+ORSET D MIX^DIC1 I Y'>0 S QUIT=1 Q 78 . S DA=+Y,DIE=DIC,DR=".01;2R" D ^DIE Q:'$G(DA) 79 . I $D(^ORD(101.41,+ORSET,10,DA,0)),'$P(^(0),U,2) S DIK=DIE D ^DIK 80 Q 81 ; 82 PROTOCOL ; -- Convert additional protocols to dialogs 83 N X,Y,DIC,ORERR 84 F S DIC="^ORD(101,",DIC(0)="AEQM" D ^DIC Q:Y'>0 D W ! 85 . S ORP=+Y,ORM=$$MENU Q:ORM="^" ; What about "^^"-jumping? (ORWARD) 86 . W !,"Converting ..." D ONE(ORP,ORM,.ORERR) I '$G(ORERR) W " done." Q 87 . W " unable to convert.",!,">> "_$P(ORERR,U,2) K ORERR 88 Q 89 ONE(PITEM,ORADD,ERROR) ; -- Convert single item protocol, add to menu(s) 90 N PMENU,DMENU,NAME,ORPOS,POS,XUTL,DA,DIK 91 I $D(^ORD(100.99,1,101.41,PITEM,0)) S DA=PITEM,DA(1)=1,DIK="^ORD(100.99,1,101.41," D ^DIK ; delete error entry 92 S NAME=$P($G(^ORD(101,PITEM,0)),U),DITEM=$$ITEM^ORCONVRT(PITEM) 93 I 'DITEM!$D(^ORD(100.99,1,101.41,PITEM,0)) S ERROR=$G(^(0)) Q 94 Q:'$G(ORADD) ;to add, may enter here with PITEM & DITEM defined 95 ADD S PMENU=0 F S PMENU=$O(^ORD(101,"AD",PITEM,PMENU)) Q:PMENU'>0 D W "." 96 . S DMENU=$O(^ORD(101.41,"AB",$P(^ORD(101,PMENU,0),U),0)) Q:'DMENU 97 . S ORPOS=$$FINDXUTL(PMENU,PITEM) Q:'ORPOS 98 . S XUTL=$G(^XUTL("XQORM",PMENU_";ORD(101,",ORPOS,0)) 99 . S DA=$O(^ORD(101.41,DMENU,10,"B",ORPOS,0)) I DA Q:$P(^ORD(101.41,DMENU,10,DA,0),U,2)=DITEM S POS=$O(^ORD(101.41,DMENU,10,"B",""),-1),ORPOS=($P(POS,".")+1)_".1",DA="" ; move to end, if collision 100 . S DA=$$NEXT^ORCONVRT(DMENU) 101 . S ^ORD(101.41,DMENU,10,DA,0)=ORPOS_U_DITEM_U_$P(XUTL,U,4)_U_$S($P(XUTL,U,3)'=$P(^ORD(101.41,DITEM,0),U,2):$P(XUTL,U,3),1:"") 102 . S ^ORD(101.41,DMENU,10,"B",ORPOS,DA)="",^ORD(101.41,DMENU,10,"D",DITEM,DA)="" 103 . S ^ORD(101.41,"AD",DITEM,DMENU,DA)="",^ORD(101.41,DMENU,99)=$H 104 Q 105 ; 106 FINDXUTL(MENU,ITEM) ; -- Returns position of ITEM in MENU 107 N XQORM,POS 108 S XQORM=MENU_";ORD(101," D XREF^XQORM 109 S POS=0 F S POS=$O(^XUTL("XQORM",XQORM,POS)) Q:POS'>0 I $P(^(POS,0),U,2)=ITEM Q 110 Q POS 111 ; 112 MENU() ; -- Add converted item to menus? 113 N X,Y,DIR S DIR(0)="YA" 114 S DIR("A")="Add this item to the same menus again? ",DIR("B")="YES" 115 S DIR("?")="Enter YES to have this item placed on the same menus in the Order Dialog file as it was in the Protocol file" 116 D ^DIR S:$D(DTOUT) Y="^" 117 Q Y 118 EXPLAIN ;Give reason why user can't set auto-accept to yes 119 W !!,"The combination of VERIFY set to NO and ASK FOR ANOTHER ORDER set to",!,"YES, DON'T ASK and AUTO-ACCEPT set to YES is not allowed." 120 W !!,"This combination of settings could cause CPRS to enter into an infinite loop",!,"creating the same order over and over. If you wish to have" 121 W !,"AUTO-ACCEPT set to YES you must change one of the other two fields",!,"to a different value.",!!,"AUTO-ACCEPT is being set to NO for you." 122 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT8.m
r613 r623 1 ORCMEDT8 ;SLC/JM-QO, Generate quick order CRC ;10/18/07 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**245,243**;Dec 17, 1997;Build 242 3 Q 4 ; 5 UPDQNAME(ORIEN) ; Rename personal quick order name if needed 6 N OLDNAME,NEWNAME,DA,DR,DIE,DIDEL 7 I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" Q 8 S OLDNAME=$P($G(^ORD(101.41,ORIEN,0)),U,1) 9 I $E($P(OLDNAME,U),1,6)'="ORWDQ " Q 10 S NEWNAME="ORWDQ "_$$CRC4QCK(ORIEN) 11 I OLDNAME'=NEWNAME D 12 . S NEWNAME=$$ENSURNEW(NEWNAME) 13 . S DA=ORIEN,DR=".01///"_NEWNAME,DIE="^ORD(101.41," D ^DIE 14 Q 15 ; 16 ENSURNEW(NAME) ; Ensures the name is a new entry 17 N IDX,BASENAME,ABC,NEWNAME 18 S NEWNAME=NAME 19 S IDX=0,BASENAME=NEWNAME,ABC=97 ; Find an unused name 20 F S IDX=$O(^ORD(101.41,"B",NEWNAME,0)) Q:'IDX D 21 . S NEWNAME=BASENAME_$C(ABC) ; append letter 'a' - 'z' 22 . S ABC=ABC+1 I ABC>122 S BASENAME=BASENAME_"a",ABC=97 23 Q NEWNAME 24 RAWCRC(ORIEN) ; Get a raw CRC value to determine if a record has changed 25 N ORDATA,RESULT,ADDCRLF,LASTLINE,LASTIDX,OLDCRC 26 S (RESULT,OLDCRC)="" 27 I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G RWQ 28 I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G RWQ 29 D LOADRSP^ORWDX(.ORDATA,ORIEN) 30 D PARSE 31 RWQ Q RESULT 32 ; 33 ; The following code attemps to duplicate the CRC calculated by the Delphi code 34 ; in CPRS for quick orders. It will not match all the time, since not all the 35 ; data neded to make the determination is stored on the M side, but it does it's best. 36 ; 37 CRC4QCK(ORIEN) ; Get CRC for a personal quick order 38 N ORDATA,DISPGRP,DEFDLG,FORMID,RESULT,FORMDATA,ADDCRLF 39 N LASTLINE,LASTIDX,OLDCRC,FORMINFO,IDINFO,NEXTFORM 40 S RESULT="",FORMID=0 41 ; Must be personal quick order 42 I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G EXT 43 I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G EXT 44 S OLDCRC=$E($P($G(^ORD(101.41,ORIEN,0)),U,1),7,14) 45 F Q:(RESULT=OLDCRC)!(FORMID="") D 46 . K ORDATA D LOADRSP^ORWDX(.ORDATA,ORIEN) 47 . ; First pass don't use any form id - get baseline CRC 48 . I FORMID=1 D Q:FORMID="" 49 . . S FORMID="" 50 . . S DISPGRP=$P($G(^ORD(101.41,ORIEN,0)),U,5) I '+DISPGRP Q ; Must have a valid display group 51 . . S DEFDLG=$P($G(^ORD(100.98,DISPGRP,0)),U,4) I '+DEFDLG Q ; Display group must have a valid default dialog 52 . . D FORMID^ORWDXM(.FORMID,DEFDLG) I '+FORMID S FORMID="" Q ; Default dialog must have a valid windows form ID 53 . . I (FORMID=130)!(FORMID=140) D 54 . . . N NEWFORM D CHK94^ORWDPS1(.NEWFORM) I NEWFORM=1 S FORMID=135 55 . . D FORMINFO(.FORMINFO,.IDINFO,.NEXTFORM) 56 . I FORMID=0 S FORMID=1 57 . E D SORTDATA I FORMDATA="" S FORMID="" Q ; Updates FORMID 58 . D PARSE 59 EXT Q RESULT 60 ; 61 PARSE ; Parse Data 62 N DATAIDX,IDX,LINE,CODE,CRCDATA,OUTPUT,DONE,ISMASTER,LASTMSTR,FIRST,P3,LK4SPACE 63 S DATAIDX="",(IDX,DONE,ISMASTER,LASTMSTR,LASTIDX)=0,LASTLINE="" 64 F D GETLINE Q:DONE D Q:DONE 65 . I ISMASTER D 66 . . S OUTPUT=+$P(LINE,U,1)_U_+$P(LINE,U,2)_U 67 . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT 68 . . S FIRST=1,P3=$P(LINE,U,3) 69 . . I P3="COMMENT" S ADDCRLF=1,LK4SPACE=1 70 . . E D 71 . . . I P3="STATEMENTS" S ADDCRLF=1,LK4SPACE=0 72 . . . E S ADDCRLF=0,LK4SPACE=0 73 . . F D GETLINE Q:DONE!ISMASTER D 74 . . . I CODE="i" S IDX=IDX+1,CRCDATA(IDX)=LINE 75 . . . I CODE="t" D 76 . . . . I FIRST S FIRST=0,OUTPUT=LINE 77 . . . . E D 78 . . . . . I $L(LASTLINE)=0 S OUTPUT=$C(13)_$C(10)_LINE Q 79 . . . . . I LK4SPACE,$L(LASTLINE)>1,$E(LASTLINE,$L(LASTLINE))=" " S OUTPUT="" 80 . . . . . E D 81 . . . . . . I ADDCRLF S OUTPUT=$C(13)_$C(10) ; ,$L(LASTLINE)<65 82 . . . . . . E S OUTPUT=" " 83 . . . . . S OUTPUT=OUTPUT_LINE 84 . . . . S LASTLINE=LINE 85 . . . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT 86 . . . . I ADDCRLF S LASTIDX=IDX 87 . . I ISMASTER,'DONE S LASTMSTR=1 88 S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA) 89 ; Same data can generate 2 different CRCs - CRLF on end of comments are stripped 90 I OLDCRC'="",RESULT'=OLDCRC,LASTIDX>0 D 91 . S CRCDATA(LASTIDX)=CRCDATA(LASTIDX)_$C(13)_$C(10) 92 . S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA) 93 Q 94 ; 95 SORTDATA ; Sorts data by fields according to FormID 96 N IN,OUT,LINE,DATA,ID,CODE,INDEX,END,IDX,RTN,SUBFORM,SUBFORM2,SUBIDX,NODE 97 S SUBFORM="",SUBFORM2="" 98 S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q 99 I $E(FORMDATA,1,2)'="00" S RTN="SUBID"_$E(FORMDATA,1,2) D @RTN S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q 100 S IN=0,OUT=0,END=1000000,IDX=0 101 F S IN=$O(ORDATA(IN)) Q:'+IN D 102 . S LINE=ORDATA(IN) 103 . I $E(LINE)="~" D 104 . . S IDX=1,ID=$P(LINE,U,3),CODE="."_IDINFO(ID)_".",NODE=$P(LINE,U,2) 105 . . S INDEX=$F(FORMDATA,CODE),SUBIDX=0 106 . . I INDEX=0,SUBFORM'="" D 107 . . . S INDEX=($F(FORMDATA,".ZZZ.")) 108 . . . I INDEX>0 S SUBIDX=$F(SUBFORM,CODE) I SUBIDX<1 S INDEX=0 109 . . I INDEX=0,SUBFORM2'="" D 110 . . . S INDEX=($F(FORMDATA,".XXX.")) 111 . . . I INDEX>0 S SUBIDX=$F(SUBFORM2,CODE) I SUBIDX<1 S INDEX=0 112 . . I INDEX=0 S OUT=END,END=END+1 113 . . E D 114 . . . I SUBIDX>0 D I 1 115 . . . . S OUT=(INDEX-4)*250 116 . . . . S SUBIDX=(SUBIDX-4)\4 117 . . . . S OUT=OUT+SUBIDX+(NODE*20) 118 . . . E S OUT=(INDEX-4)*250 119 . I IDX>0 D 120 . . S DATA(OUT,IDX)=LINE 121 . . S IDX=IDX+1 122 K ORDATA 123 S (IN,OUT,INDEX)=0 124 F S IN=$O(DATA(IN)) Q:'+IN D 125 . F S INDEX=$O(DATA(IN,INDEX)) Q:'+INDEX D 126 . . S OUT=OUT+1 127 . . S ORDATA(OUT)=DATA(IN,INDEX) 128 S FORMID=$G(NEXTFORM(FORMID)) 129 Q 130 ; 131 GETLINE ; 132 I LASTMSTR S LASTMSTR=0 Q 133 S DATAIDX=$O(ORDATA(DATAIDX)) 134 S DONE=(DATAIDX="") 135 I 'DONE S CODE=$E(ORDATA(DATAIDX),1),LINE=$E(ORDATA(DATAIDX),2,9999),ISMASTER=(CODE="~") 136 Q 137 ; 138 FORMINFO(FORMINFO,IDINFO,NEXTFORM) ; populates FORMINFO,IDINFO and NEXTFORM arrays 139 N IDX,LINE,CODE,RTN,NEXT 140 S IDX=1 141 F S LINE=$E($T(FORMTBL+IDX),21,999) Q:$L(LINE)<1 D 142 . S CODE=$E(LINE,1,3),NEXT=$E(LINE,5,7),LINE=$E(LINE,9,999) 143 . S FORMINFO(CODE)=LINE 144 . I NEXT'=" " S NEXTFORM(CODE)=NEXT 145 . S IDX=IDX+1 146 S IDX=1 147 F S LINE=$E($T(IDTABLE+IDX),4,999) Q:$L(LINE)<1 D 148 . S CODE=$E(LINE,1,3),LINE=$E(LINE,5,99) 149 . S IDINFO(LINE)=CODE,IDX=IDX+1 150 Q 151 ; 152 HASCODE(CODE) ; scans data for code 153 N RESULT,IDX,LINE S IDX="",RESULT=0 154 F S IDX=$O(ORDATA(IDX)) Q:IDX="" D Q:IDX="" 155 . S LINE=ORDATA(IDX) 156 . I $E(LINE)="~" D 157 . . S LINE=$P(LINE,U,3) 158 . . I LINE=CODE S RESULT=1,IDX="" 159 Q RESULT 160 ; 161 SUBID ; SubID codes are used to change the form ID depending on depending on data 162 ; Data below is FormID;SubID.list of ID codes in order of use 163 ; SubID's are used to change the FormID depending on data values. 164 Q 165 SUBID01 ; Generic Meds dialog 166 N INPT,COMPLEX 167 S INPT=$$HASCODE("NOW"),COMPLEX=$$HASCODE("DAYS") 168 I INPT D I 1 169 . I COMPLEX S FORMID="INX",SUBFORM=$G(FORMINFO("MDX")) 170 . E S FORMID="INP" 171 E I COMPLEX S FORMID="OPX",SUBFORM=$G(FORMINFO("MDX")) 172 Q 173 SUBID02 ; IV Meds 174 S SUBFORM=$G(FORMINFO("IVL")) 175 Q 176 SUBID03 ; Delphi code adds URGENCY prompt that does not exist in dialog on M side 177 I '$$HASCODE("URGENCY") D 178 . N X 179 . S X=$O(ORDATA(999999),-1)+1 180 . S ORDATA(X)="~0^1^URGENCY" 181 Q 182 SUBID04 ; Blood Bank will probably be wrong - quick orders not working in v26 183 S SUBFORM=$G(FORMINFO("BBK")) 184 S SUBFORM2=$G(FORMINFO("BBX")) 185 Q 186 SUBID05 ; Diet 187 I FORMID="117" S SUBFORM=$G(FORMINFO("DLN")) 188 I FORMID="TBF" S SUBFORM=$G(FORMINFO("TBL")) 189 Q 190 FORMTBL ; Form Table - Forms allowing personal quick orders, as of CPRS GUI v26 (OR*3*215) 191 ;;Consult ;110;CS2;00.ORD.CLS.URG.PLA.MSC.COD.PRV.COM. 192 ;; ;CS2; ;00.ORD.CLS.URG.PLA.MSC.COD.COM.PRV. 193 ;;Procedure ;112;PR2;00.SER.ORD.CLS.URG.PLA.MSC.COD.PRV.COM. 194 ;; ;PR2;PR3;00.SER.ORD.COM.CLS.URG.PLA.MSC.COD.PRV. 195 ;; ;PR3; ;00.SER.ORD.CLS.URG.PLA.MSC.COD.COM.PRV. 196 ;;Diet ;117;TBF;05.STT.STP.ZZZ.COM.DEL.CAN. 197 ;; ;TBF;OPM;05.ZZZ.COM.CAN. 198 ;; ;OPM; ;00.ORD.MEL.STT.STP.SCH.COM.DEL. 199 ;; ;DLN; ;00.ORD. 200 ;; ;TBL; ;00.ORD.STR.INS. 201 ;;Lab ;120; ;00.ORD.SAM.SPE.URG.COM.COL.STT.SCH.DAY. 202 ;;Blood Bank ;125;BB2;04.ZZZ.DTE.COL.URG.COM.STT.MSC.REA.YN0.XXX.LAB. 203 ;; ;BB2; ;04.ZZZ.URG.COM.COL.DTE.MSC.REA.YN0.STT.XXX. 204 ;; ;BBK; ;00.ORD.QTY.MDF.SPC. 205 ;; ;BBX; ;00.RES. 206 ;;Inpatient Meds ;130; ;00.ORD.DRG.INS.ROU.SCH.URG.COM.SCT.ADM 207 ;;Generic Meds ;135; ;01.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG. 208 ;; ;INP; ;00.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.NOW.SIG. 209 ;; ;OPX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG. 210 ;; ;INX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.NOW.SIG. 211 ;; ;MDX; ;00.INS.DOS.ROU.SCH.DAY.CNJ. 212 ;;Outpatient Meds ;140; ;00.ORD.DRG.INS.MSC.ROU.SCH.QTY.REF.PCK.URG.COM.SC0. 213 ;;Non-VA Meds ;145; ;03.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.STT.STA.NOW.SIG. 214 ;;Radiology ;160; ;00.ORD.STT.URG.MOD.CLS.IML.PRG.YN0.PRE.COM.MDF.PRV.CON.RSH.LOC. 215 ;;IV Meds ;180; ;02.ZZZ.RAT.URG.DAY.COM.SCH.TYP.ADM 216 ;; ;IVL; ;00.ORD.VOL.ADD.STR.UNT. 217 ;; 218 IDTABLE ; ID table - returns codes used in the form table IDINFO("LONGNAME")=SHORNAME 219 ;;ADD;ADDITIVE 220 ;;ADM:ADMIN 221 ;;CAN;CANCEL 222 ;;CLS;CLASS 223 ;;COD;CODE 224 ;;COL;COLLECT 225 ;;COM;COMMENT 226 ;;CNJ;CONJ 227 ;;CON;CONTRACT 228 ;;DTE;DATETIME 229 ;;DAY;DAYS 230 ;;DEL;DELIVERY 231 ;;DOS;DOSE 232 ;;DRG;DRUG 233 ;;IML;IMLOC 234 ;;INS;INSTR 235 ;;ISO;ISOLATION 236 ;;LAB;LAB 237 ;;LOC;LOCATION 238 ;;MEL;MEAL 239 ;;MSC;MISC 240 ;;MOD;MODE 241 ;;MDF;MODIFIER 242 ;;NAM;NAME 243 ;;NOW;NOW 244 ;;ORD;ORDERABLE 245 ;;PI0;PI 246 ;;PCK;PICKUP 247 ;;PLA;PLACE 248 ;;PRG;PREGNANT 249 ;;PRE;PREOP 250 ;;PRV;PROVIDER 251 ;;QTY;QTY 252 ;;RAT;RATE 253 ;;REA;REASON 254 ;;REF;REFILLS 255 ;;RSH:RESEARCH 256 ;;RES;RESULTS 257 ;;ROU;ROUTE 258 ;;SAM;SAMPLE 259 ;;SC0;SC 260 ;;SCH;SCHEDULE 261 ;;SCT:SCHTYPE 262 ;;SER;SERVICE 263 ;;SIG;SIG 264 ;;SPE;SPECIMEN 265 ;;SPC;SPECSTS 266 ;;STT;START 267 ;;STA;STATEMENTS 268 ;;STP;STOP 269 ;;STR;STRENGTH 270 ;;SUP;SUPPLY 271 ;;TIM;TIME 272 ;;TYP:TYPE 273 ;;UNT;UNITS 274 ;;URG;URGENCY 275 ;;VIS;VISITSTR 276 ;;VOL;VOLUME 277 ;;XFU;XFUSION 278 ;;YN0;YN 279 ;;XXX;XXX 280 ;;ZZZ;ZZZ 281 ;; 1 ORCMEDT8 ;SLC/JM-QO, Generate quick order CRC ;3/3/06 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**245**;Dec 17, 1997;Build 2 3 Q 4 ; 5 UPDQNAME(ORIEN) ; Rename personal quick order name if needed 6 N OLDNAME,NEWNAME,DA,DR,DIE,DIDEL 7 I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" Q 8 S OLDNAME=$P($G(^ORD(101.41,ORIEN,0)),U,1) 9 I $E($P(OLDNAME,U),1,6)'="ORWDQ " Q 10 S NEWNAME="ORWDQ "_$$CRC4QCK(ORIEN) 11 I OLDNAME'=NEWNAME D 12 . S NEWNAME=$$ENSURNEW(NEWNAME) 13 . S DA=ORIEN,DR=".01///"_NEWNAME,DIE="^ORD(101.41," D ^DIE 14 Q 15 ; 16 ENSURNEW(NAME) ; Ensures the name is a new entry 17 N IDX,BASENAME,ABC,NEWNAME 18 S NEWNAME=NAME 19 S IDX=0,BASENAME=NEWNAME,ABC=97 ; Find an unused name 20 F S IDX=$O(^ORD(101.41,"B",NEWNAME,0)) Q:'IDX D 21 . S NEWNAME=BASENAME_$C(ABC) ; append letter 'a' - 'z' 22 . S ABC=ABC+1 I ABC>122 S BASENAME=BASENAME_"a",ABC=97 23 Q NEWNAME 24 RAWCRC(ORIEN) ; Get a raw CRC value to determine if a record has changed 25 N ORDATA,RESULT,ADDCRLF,LASTLINE,LASTIDX,OLDCRC 26 S (RESULT,OLDCRC)="" 27 I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G RWQ 28 I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G RWQ 29 D LOADRSP^ORWDX(.ORDATA,ORIEN) 30 D PARSE 31 RWQ Q RESULT 32 ; 33 ; The following code attemps to duplicate the CRC calculated by the Delphi code 34 ; in CPRS for quick orders. It will not match all the time, since not all the 35 ; data neded to make the determination is stored on the M side, but it does it's best. 36 ; 37 CRC4QCK(ORIEN) ; Get CRC for a personal quick order 38 N ORDATA,DISPGRP,DEFDLG,FORMID,RESULT,FORMDATA,ADDCRLF 39 N LASTLINE,LASTIDX,OLDCRC,FORMINFO,IDINFO,NEXTFORM 40 S RESULT="",FORMID=0 41 ; Must be personal quick order 42 I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G EXT 43 I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G EXT 44 S OLDCRC=$E($P($G(^ORD(101.41,ORIEN,0)),U,1),7,14) 45 F Q:(RESULT=OLDCRC)!(FORMID="") D 46 . K ORDATA D LOADRSP^ORWDX(.ORDATA,ORIEN) 47 . ; First pass don't use any form id - get baseline CRC 48 . I FORMID=1 D Q:FORMID="" 49 . . S FORMID="" 50 . . S DISPGRP=$P($G(^ORD(101.41,ORIEN,0)),U,5) I '+DISPGRP Q ; Must have a valid display group 51 . . S DEFDLG=$P($G(^ORD(100.98,DISPGRP,0)),U,4) I '+DEFDLG Q ; Display group must have a valid default dialog 52 . . D FORMID^ORWDXM(.FORMID,DEFDLG) I '+FORMID S FORMID="" Q ; Default dialog must have a valid windows form ID 53 . . I (FORMID=130)!(FORMID=140) D 54 . . . N NEWFORM D CHK94^ORWDPS1(.NEWFORM) I NEWFORM=1 S FORMID=135 55 . . D FORMINFO(.FORMINFO,.IDINFO,.NEXTFORM) 56 . I FORMID=0 S FORMID=1 57 . E D SORTDATA I FORMDATA="" S FORMID="" Q ; Updates FORMID 58 . D PARSE 59 EXT Q RESULT 60 ; 61 PARSE ; Parse Data 62 N DATAIDX,IDX,LINE,CODE,CRCDATA,OUTPUT,DONE,ISMASTER,LASTMSTR,FIRST,P3,LK4SPACE 63 S DATAIDX="",(IDX,DONE,ISMASTER,LASTMSTR,LASTIDX)=0,LASTLINE="" 64 F D GETLINE Q:DONE D Q:DONE 65 . I ISMASTER D 66 . . S OUTPUT=+$P(LINE,U,1)_U_+$P(LINE,U,2)_U 67 . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT 68 . . S FIRST=1,P3=$P(LINE,U,3) 69 . . I P3="COMMENT" S ADDCRLF=1,LK4SPACE=1 70 . . E D 71 . . . I P3="STATEMENTS" S ADDCRLF=1,LK4SPACE=0 72 . . . E S ADDCRLF=0,LK4SPACE=0 73 . . F D GETLINE Q:DONE!ISMASTER D 74 . . . I CODE="i" S IDX=IDX+1,CRCDATA(IDX)=LINE 75 . . . I CODE="t" D 76 . . . . I FIRST S FIRST=0,OUTPUT=LINE 77 . . . . E D 78 . . . . . I $L(LASTLINE)=0 S OUTPUT=$C(13)_$C(10)_LINE Q 79 . . . . . I LK4SPACE,$L(LASTLINE)>1,$E(LASTLINE,$L(LASTLINE))=" " S OUTPUT="" 80 . . . . . E D 81 . . . . . . I ADDCRLF S OUTPUT=$C(13)_$C(10) ; ,$L(LASTLINE)<65 82 . . . . . . E S OUTPUT=" " 83 . . . . . S OUTPUT=OUTPUT_LINE 84 . . . . S LASTLINE=LINE 85 . . . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT 86 . . . . I ADDCRLF S LASTIDX=IDX 87 . . I ISMASTER,'DONE S LASTMSTR=1 88 S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA) 89 ; Same data can generate 2 different CRCs - CRLF on end of comments are stripped 90 I OLDCRC'="",RESULT'=OLDCRC,LASTIDX>0 D 91 . S CRCDATA(LASTIDX)=CRCDATA(LASTIDX)_$C(13)_$C(10) 92 . S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA) 93 Q 94 ; 95 SORTDATA ; Sorts data by fields according to FormID 96 N IN,OUT,LINE,DATA,ID,CODE,INDEX,END,IDX,RTN,SUBFORM,SUBFORM2,SUBIDX,NODE 97 S SUBFORM="",SUBFORM2="" 98 S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q 99 I $E(FORMDATA,1,2)'="00" S RTN="SUBID"_$E(FORMDATA,1,2) D @RTN S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q 100 S IN=0,OUT=0,END=1000000,IDX=0 101 F S IN=$O(ORDATA(IN)) Q:'+IN D 102 . S LINE=ORDATA(IN) 103 . I $E(LINE)="~" D 104 . . S IDX=1,ID=$P(LINE,U,3),CODE="."_IDINFO(ID)_".",NODE=$P(LINE,U,2) 105 . . S INDEX=$F(FORMDATA,CODE),SUBIDX=0 106 . . I INDEX=0,SUBFORM'="" D 107 . . . S INDEX=($F(FORMDATA,".ZZZ.")) 108 . . . I INDEX>0 S SUBIDX=$F(SUBFORM,CODE) I SUBIDX<1 S INDEX=0 109 . . I INDEX=0,SUBFORM2'="" D 110 . . . S INDEX=($F(FORMDATA,".XXX.")) 111 . . . I INDEX>0 S SUBIDX=$F(SUBFORM2,CODE) I SUBIDX<1 S INDEX=0 112 . . I INDEX=0 S OUT=END,END=END+1 113 . . E D 114 . . . I SUBIDX>0 D I 1 115 . . . . S OUT=(INDEX-4)*250 116 . . . . S SUBIDX=(SUBIDX-4)\4 117 . . . . S OUT=OUT+SUBIDX+(NODE*20) 118 . . . E S OUT=(INDEX-4)*250 119 . I IDX>0 D 120 . . S DATA(OUT,IDX)=LINE 121 . . S IDX=IDX+1 122 K ORDATA 123 S (IN,OUT,INDEX)=0 124 F S IN=$O(DATA(IN)) Q:'+IN D 125 . F S INDEX=$O(DATA(IN,INDEX)) Q:'+INDEX D 126 . . S OUT=OUT+1 127 . . S ORDATA(OUT)=DATA(IN,INDEX) 128 S FORMID=$G(NEXTFORM(FORMID)) 129 Q 130 ; 131 GETLINE ; 132 I LASTMSTR S LASTMSTR=0 Q 133 S DATAIDX=$O(ORDATA(DATAIDX)) 134 S DONE=(DATAIDX="") 135 I 'DONE S CODE=$E(ORDATA(DATAIDX),1),LINE=$E(ORDATA(DATAIDX),2,9999),ISMASTER=(CODE="~") 136 Q 137 ; 138 FORMINFO(FORMINFO,IDINFO,NEXTFORM) ; populates FORMINFO,IDINFO and NEXTFORM arrays 139 N IDX,LINE,CODE,RTN,NEXT 140 S IDX=1 141 F S LINE=$E($T(FORMTBL+IDX),21,999) Q:$L(LINE)<1 D 142 . S CODE=$E(LINE,1,3),NEXT=$E(LINE,5,7),LINE=$E(LINE,9,999) 143 . S FORMINFO(CODE)=LINE 144 . I NEXT'=" " S NEXTFORM(CODE)=NEXT 145 . S IDX=IDX+1 146 S IDX=1 147 F S LINE=$E($T(IDTABLE+IDX),4,999) Q:$L(LINE)<1 D 148 . S CODE=$E(LINE,1,3),LINE=$E(LINE,5,99) 149 . S IDINFO(LINE)=CODE,IDX=IDX+1 150 Q 151 ; 152 HASCODE(CODE) ; scans data for code 153 N RESULT,IDX,LINE S IDX="",RESULT=0 154 F S IDX=$O(ORDATA(IDX)) Q:IDX="" D Q:IDX="" 155 . S LINE=ORDATA(IDX) 156 . I $E(LINE)="~" D 157 . . S LINE=$P(LINE,U,3) 158 . . I LINE=CODE S RESULT=1,IDX="" 159 Q RESULT 160 ; 161 SUBID ; SubID codes are used to change the form ID depending on depending on data 162 ; Data below is FormID;SubID.list of ID codes in order of use 163 ; SubID's are used to change the FormID depending on data values. 164 Q 165 SUBID01 ; Generic Meds dialog 166 N INPT,COMPLEX 167 S INPT=$$HASCODE("NOW"),COMPLEX=$$HASCODE("DAYS") 168 I INPT D I 1 169 . I COMPLEX S FORMID="INX",SUBFORM=$G(FORMINFO("MDX")) 170 . E S FORMID="INP" 171 E I COMPLEX S FORMID="OPX",SUBFORM=$G(FORMINFO("MDX")) 172 Q 173 SUBID02 ; IV Meds 174 S SUBFORM=$G(FORMINFO("IVL")) 175 Q 176 SUBID03 ; Delphi code adds URGENCY prompt that does not exist in dialog on M side 177 I '$$HASCODE("URGENCY") D 178 . N X 179 . S X=$O(ORDATA(999999),-1)+1 180 . S ORDATA(X)="~0^1^URGENCY" 181 Q 182 SUBID04 ; Blood Bank will probably be wrong - quick orders not working in v26 183 S SUBFORM=$G(FORMINFO("BBK")) 184 S SUBFORM2=$G(FORMINFO("BBX")) 185 Q 186 SUBID05 ; Diet 187 I FORMID="117" S SUBFORM=$G(FORMINFO("DLN")) 188 I FORMID="TBF" S SUBFORM=$G(FORMINFO("TBL")) 189 Q 190 FORMTBL ; Form Table - Forms allowing personal quick orders, as of CPRS GUI v26 (OR*3*215) 191 ;;Consult ;110;CS2;00.ORD.CLS.URG.PLA.MSC.COD.PRV.COM. 192 ;; ;CS2; ;00.ORD.CLS.URG.PLA.MSC.COD.COM.PRV. 193 ;;Procedure ;112;PR2;00.SER.ORD.CLS.URG.PLA.MSC.COD.PRV.COM. 194 ;; ;PR2;PR3;00.SER.ORD.COM.CLS.URG.PLA.MSC.COD.PRV. 195 ;; ;PR3; ;00.SER.ORD.CLS.URG.PLA.MSC.COD.COM.PRV. 196 ;;Diet ;117;TBF;05.STT.STP.ZZZ.COM.DEL.CAN. 197 ;; ;TBF;OPM;05.ZZZ.COM.CAN. 198 ;; ;OPM; ;00.ORD.MEL.STT.STP.SCH.COM.DEL. 199 ;; ;DLN; ;00.ORD. 200 ;; ;TBL; ;00.ORD.STR.INS. 201 ;;Lab ;120; ;00.ORD.SAM.SPE.URG.COM.COL.STT.SCH.DAY. 202 ;;Blood Bank ;125;BB2;04.ZZZ.DTE.COL.URG.COM.STT.MSC.REA.YN0.XXX. 203 ;; ;BB2; ;04.ZZZ.URG.COM.COL.DTE.MSC.REA.YN0.STT.XXX. 204 ;; ;BBK; ;00.ORD.QTY.MDF.SPC. 205 ;; ;BBX; ;00.RES. 206 ;;Inpatient Meds ;130; ;00.ORD.DRG.INS.ROU.SCH.URG.COM. 207 ;;Generic Meds ;135; ;01.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG. 208 ;; ;INP; ;00.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.NOW.SIG. 209 ;; ;OPX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG. 210 ;; ;INX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.NOW.SIG. 211 ;; ;MDX; ;00.INS.DOS.ROU.SCH.DAY.CNJ. 212 ;;Outpatient Meds ;140; ;00.ORD.DRG.INS.MSC.ROU.SCH.QTY.REF.PCK.URG.COM.SC0. 213 ;;Non-VA Meds ;145; ;03.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.STT.STA.NOW.SIG. 214 ;;Radiology ;160; ;00.ORD.STT.URG.MOD.CLS.IML.PRG.YN0.PRE.COM.MDF.PRV.CON.RSH.LOC. 215 ;;IV Meds ;180; ;02.ZZZ.RAT.URG.DAY.COM.SCH. 216 ;; ;IVL; ;00.ORD.VOL.ADD.STR.UNT. 217 ;; 218 IDTABLE ; ID table - returns codes used in the form table IDINFO("LONGNAME")=SHORNAME 219 ;;ADD;ADDITIVE 220 ;;CAN;CANCEL 221 ;;CLS;CLASS 222 ;;COD;CODE 223 ;;COL;COLLECT 224 ;;COM;COMMENT 225 ;;CNJ;CONJ 226 ;;CON;CONTRACT 227 ;;DTE;DATETIME 228 ;;DAY;DAYS 229 ;;DEL;DELIVERY 230 ;;DOS;DOSE 231 ;;DRG;DRUG 232 ;;IML;IMLOC 233 ;;INS;INSTR 234 ;;ISO;ISOLATION 235 ;;LOC;LOCATION 236 ;;MEL;MEAL 237 ;;MSC;MISC 238 ;;MOD;MODE 239 ;;MDF;MODIFIER 240 ;;NAM;NAME 241 ;;NOW;NOW 242 ;;ORD;ORDERABLE 243 ;;PI0;PI 244 ;;PCK;PICKUP 245 ;;PLA;PLACE 246 ;;PRG;PREGNANT 247 ;;PRE;PREOP 248 ;;PRV;PROVIDER 249 ;;QTY;QTY 250 ;;RAT;RATE 251 ;;REA;REASON 252 ;;REF;REFILLS 253 ;;RSH:RESEARCH 254 ;;RES;RESULTS 255 ;;ROU;ROUTE 256 ;;SAM;SAMPLE 257 ;;SC0;SC 258 ;;SCH;SCHEDULE 259 ;;SER;SERVICE 260 ;;SIG;SIG 261 ;;SPE;SPECIMEN 262 ;;SPC;SPECSTS 263 ;;STT;START 264 ;;STA;STATEMENTS 265 ;;STP;STOP 266 ;;STR;STRENGTH 267 ;;SUP;SUPPLY 268 ;;TIM;TIME 269 ;;UNT;UNITS 270 ;;URG;URGENCY 271 ;;VIS;VISITSTR 272 ;;VOL;VOLUME 273 ;;XFU;XFUSION 274 ;;YN0;YN 275 ;;XXX;XXX 276 ;;ZZZ;ZZZ 277 ;; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE.m
r613 r623 1 ORCSAVE ;SLC/MKB/JDL-Save ; 7/24/07 9:54am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,195,243**;Dec 17, 1997;Build 242 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG) ; -- New order 5 ; Returns ORIFN = [new] order number, if created/saved 6 D EN 7 Q 8 ; 9 XX ; -- save new/unreleased edited order into Orders file 10 ; Requires: ORDIALOG() = array of dialog values 11 ; ORIFN = IFN of original order that was edited 12 ; 13 N OLDIFN S ORIFN=+ORIFN,OLDIFN=0 14 I $S($P(^OR(100,ORIFN,3),U,3)=11:0,$P(^(3),U,3)'=10:1,$P(^(8,1,0),U,4)=2:0,1:1) S OLDIFN=ORIFN K ORIFN ; create new order if released or delayed&signed 15 D EN Q:'ORIFN S:'$G(ORDA) ORDA=1 16 I $G(OLDIFN) D ;save links between orders 17 . S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=1 18 . S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5) 19 I $D(^OR(100,+OLDIFN,0)) D 20 . Q:'$G(OREVTDF) 21 . N OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN 22 . S (OLDEVT,OLDSTS,LSTACT)=0 23 . S NOW=$$NOW^XLFDT 24 . S OLDEVT=$P(^(0),U,17),OLDSTS=$P(^(3),U,3) 25 . ; Active status = 6 from #100.01 26 . I (OLDEVT>0),OLDSTS=6 D 27 . . S $P(^OR(100,+ORIFN,0),U,17)=OLDEVT 28 . . S $P(^OR(100,+ORIFN,3),U,3)=11 29 . . S LSTACT=$P($G(^OR(100,+ORIFN,3)),U,7) 30 . . I $D(^OR(100,+ORIFN,8,LSTACT,0)) D 31 . . . S $P(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11 32 . . . S PATID=$P(^OR(100,+ORIFN,0),U,2) 33 . . . S WHEN=$P(^OR(100,+ORIFN,8,LSTACT,0),U) 34 . . . S ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)="" 35 Q 36 ; 37 RN ; -- save new/unreleased renewal order into Orders file 38 ; Requires: ORDIALOG() = array of new dialog values 39 ; ORIFN = IFN of original order that was renewed 40 ; 41 N OLDIFN S OLDIFN=+ORIFN K ORIFN 42 D EN Q:'ORIFN S:'$G(ORDA) ORDA=1 43 S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=2 44 S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5) 45 Q 46 ; 47 EN ; -- save new/unreleased order in ORDIALOG() into Orders file 48 ; Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available] 49 ; If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC 50 ; (else use values from ORDIALOG and current state) 51 ; 52 N PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE 53 Q:'$G(ORVP) Q:'$G(ORDIALOG) Q:'$D(^ORD(101.41,+ORDIALOG,0)) 54 S NOW=$$NOW^XLFDT,SIGNREQD=+$P(^ORD(101.41,+ORDIALOG,0),U,6) 55 S CATG=$S($L($G(ORCAT)):ORCAT,1:$S($$INPT^ORCD:"I",1:"O")) 56 S PKG=$S($G(ORPKG):ORPKG,1:$P(^ORD(101.41,+ORDIALOG,0),U,7)) 57 I $G(ORIFN),$D(^OR(100,ORIFN,0)) S STS=$P(^(3),U,3) G EN2 ; unrel order 58 S DG=$S($G(ORDG):+ORDG,1:$P(^ORD(101.41,+ORDIALOG,0),U,5)) 59 I $G(OREVENT),$$GET1^DIQ(9.4,+PKG_",",1)'="PSO",'$G(DGPMT) S LOC="",TRSPEC="" ;195 60 E S LOC=$G(ORL),TRSPEC=$G(ORTS) 61 S TYPE=$S("^B^C^X^P^0^"[(U_$G(ORSRC)_U):ORSRC,$G(ORDCNTRL)="SN":"P",1:0) 62 S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ) 63 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed 64 S STS=$S($G(OREVENT):10,1:11),ORIFN=$$NEXTIFN Q:'ORIFN 65 EN1 S ^OR(100,ORIFN,0)=ORIFN_U_ORVP_U_U_$G(ORNP)_U_+ORDIALOG_";ORD(101.41,^"_USR_U_LOG_U_U_U_LOC_U_DG_U_CATG_U_TRSPEC_U_PKG_U_U_SIGNREQD_U_$G(OREVENT)_U_$G(ORAPPT) 66 S ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$S($G(ORIT):ORIT_";ORD(101.41,",1:"")_U_$G(ORDIALOG("PREV"))_"^^1^^^^"_TYPE 67 S ^OR(100,ORIFN,8,0)="^100.008DA^1^1",^OR(100,ORIFN,8,1,0)=LOG_"^NW^"_$G(ORNP)_U_$S(SIGNREQD:2,1:3)_"^^^^^^^^"_NATR_U_USR_"^1^"_STS,^OR(100,ORIFN,8,"C","NW",1)="" 68 S ^OR(100,"AF",LOG,ORIFN,1)="" 69 S ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)="" 70 S:STS'=10 ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)="" 71 S:SIGNREQD ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)="" 72 S:$G(OREVENT) ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)="" 73 EN2 S ORIFN=+ORIFN D RESPONSE ; save responses 74 I $P(^OR(100,ORIFN,0),"^",5) D ;Copy orders PKI fix 75 . N OI 76 . S OI=+$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,ORIFN,4.5,OI,1)) Q:'OI 77 . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q 78 . D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q")) 79 . I $E($G(ORY))=2 S ORDEA=ORY 80 K ^OR(100,ORIFN,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFN_";1") ; order text 81 S NODE=$G(^OR(100,ORIFN,0)) D S ^OR(100,ORIFN,0)=NODE 82 . S $P(NODE,U,4)=$G(ORNP) ; COST? 83 . S I=$O(^OR(100,ORIFN,4.5,"ID","LOCATION",0)) 84 . I I,$P(NODE,U,10) S X=+$G(^OR(100,ORIFN,4.5,+I,1)) S:X $P(NODE,U,10)=X_";SC(" ;reset Loc if prev value 85 . S I=$O(^OR(100,ORIFN,4.5,"ID","CLASS",0)) 86 . I I S X=$G(^OR(100,ORIFN,4.5,+I,1)) S:"^I^O^"[(U_X_U) $P(NODE,U,12)=X 87 S $P(^OR(100,ORIFN,3),U)=NOW 88 K ^OR(100,ORIFN,9) I $G(ORCHECK) D ; save order checks 89 . S (CNT,CDL)=0 F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL'>0 S I=0 D 90 . . F S I=$O(ORCHECK("NEW",CDL,I)) Q:I'>0 S X=ORCHECK("NEW",CDL,I) D 91 . . . S CNT=CNT+1,^OR(100,ORIFN,9,"B",+X,CNT)="" 92 . . . S ^OR(100,ORIFN,9,CNT,0)=$P(X,U,1,2),^(1)=$E($P(X,U,3),1,245) 93 . S:CNT ^OR(100,ORIFN,9,0)="^100.09PA^"_CNT_U_CNT 94 K ORDEA 95 ENQ Q 96 ; 97 NEXTIFN() ; -- Returns next available ORIFN 98 N I,HDR,LAST,TOTAL,DA 99 F I=1:1:10 L +^OR(100,0):1 Q:$T H 2 100 I '$T Q "^" 101 S HDR=$G(^OR(100,0)),TOTAL=+$P(HDR,U,4),LAST=$O(^OR(100,"?"),-1) 102 S I=LAST\1 F I=(I+1):1 Q:'$D(^OR(100,I,0)) 103 S DA=I,^OR(100,DA,0)=DA,$P(HDR,U,3,4)=DA_U_(TOTAL+1) 104 S ^OR(100,0)=HDR L -^OR(100,0) 105 Q DA 106 ; 107 RESPONSE ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5) 108 N PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X 109 S PAT=$P(^OR(100,ORIFN,0),U,2),START=$P(^(0),U,8) K ^(4.5) 110 S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D 111 . S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM 112 . S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE) 113 . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D 114 . . S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE="" S CNT=CNT+1 115 . . S ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2) 116 . . S:$L($P(ITM,U,2)) ^OR(100,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)="" 117 . . I VALUE<1,TYPE="N" S VALUE=0_+VALUE I VALUE="00" S VALUE=0 118 . . S:TYPE'="W" ^OR(100,ORIFN,4.5,CNT,1)=VALUE 119 . . M:TYPE="W" ^OR(100,ORIFN,4.5,CNT,2)=@VALUE ; array root 120 S ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT 121 R1 ; [Reset] Orderables 122 I $D(^OR(100,ORIFN,.1)) S I=0 F S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0 S X=$G(^(I,0)) I X,PAT,START K ^OR(100,"AOI",X,PAT,9999999-START,ORIFN) ; kill xref 123 K ^OR(100,ORIFN,.1) I $D(^OR(100,ORIFN,4.5,"ID","ORDERABLE")) D 124 . S (I,CNT)=0 125 . F S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D 126 . . S X=$G(^OR(100,ORIFN,4.5,I,1)) Q:'X 127 . . S CNT=CNT+1,^OR(100,ORIFN,.1,CNT,0)=X,^OR(100,ORIFN,.1,"B",X,CNT)="" 128 . . I PAT,START S ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)="" 129 . S ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT 130 Q 131 ; 132 RESUME(IFN) ; -- add Response nodes for RESUME tray service 133 ; S ^OR(100,+IFN,4.5,<next>,0)=DT_"^^^RESUME",^(1)=1 134 ; 135 N X,Y,DA,DIC 136 S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT 137 S DIC("DR")=".04///RESUME",DIC("P")=$P(^DD(100,4.5,0),U,2) 138 D ^DIC S:Y ^OR(100,+IFN,4.5,+Y,1)=1 139 Q 140 ; 141 PROVIDER(ORDER,PROV) ; -- Change PROVider assigned to ORDER 142 Q:'$G(ORDER) Q:'$G(PROV) 143 N ORACT S ORACT=+$P(ORDER,";",2) S:'ORACT ORACT=1 144 S $P(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV 145 S:ORACT=1 $P(^OR(100,+ORDER,0),U,4)=PROV 146 Q 147 ; 148 ACTION(CODE,DA,PROV,REASON,WHEN,WHO) ; -- save new action 149 N NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT S DA=+DA 150 Q:'$D(^OR(100,DA,0)) 0 Q:$G(CODE)'?2U 0 151 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ 152 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed 153 S PAT=$P(^OR(100,DA,0),U,2),DGRP=$P(^(0),U,11),SIG=$P(^(0),U,16),X=+$P($G(^(3)),U,7),HDR=$G(^(8,0)) 154 S:X'>0 X=1 S TXT=$P($G(^OR(100,DA,8,X,0)),U,14) ;current actn's txt ptr 155 S:HDR="" HDR="^100.008DA^^" S TOTAL=+$P(HDR,U,4) 156 S LAST=$O(^OR(100,DA,8,"C",CODE,"?"),-1) I LAST D 157 . S X=$G(^OR(100,DA,8,LAST,0)) Q:$P(X,U,15)'=11 Q:$P(X,U,4)'=2 158 . S NEXT=LAST I PAT,$P(X,U) D ; kill old xref entries 159 . . K:DGRP ^OR(100,"ACT",PAT,(9999999-$P(X,U)),DGRP,DA,NEXT) 160 . . K ^OR(100,"AC",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AS",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AF",$P(X,U),DA,NEXT) 161 S:'$G(NEXT) NEXT=$O(^OR(100,DA,8,"?"),-1)+1,TOTAL=TOTAL+1 162 S ^OR(100,DA,8,NEXT,0)=WHEN_U_CODE_U_$G(PROV)_U_$S(SIG:2,1:3)_"^^^^^^^^"_NATR_U_WHO_U_TXT_"^11",^OR(100,DA,8,"C",CODE,NEXT)="" 163 S ^OR(100,"AF",WHEN,DA,NEXT)="" 164 I PAT,DGRP S ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)="" 165 I PAT S ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)="" 166 I SIG S ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)="" 167 S:$L($G(REASON)) ^OR(100,DA,8,NEXT,1)=REASON 168 S $P(HDR,U,3,4)=NEXT_U_TOTAL,^OR(100,DA,8,0)=HDR 169 Q NEXT 170 ; 171 SET(DLG) ; -- Create new parent for order set ORDIALOG 172 ; Returns ORPIFN = ifn of new parent order for set 173 ; 174 Q:'$G(ORVP) Q:'$G(DLG) N OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X 175 S OR0=$G(^ORD(101.41,DLG,0)) Q:OR0="" S ORPIFN=$$NEXTIFN Q:'ORPIFN 176 S PKG=$O(^DIC(9.4,"C","OR",0)),CATG=$S($$INPT^ORCD:"I",1:"O"),STS=$S($G(OREVENT):10,1:11),NOW=$S($G(ORSLOG):ORSLOG,1:+$E($$NOW^XLFDT,1,12)) 177 I $G(OREVENT) S ORLOC="",TRSPEC="" 178 S ^OR(100,ORPIFN,0)=ORPIFN_U_ORVP_U_U_$G(ORNP)_U_DLG_";ORD(101.41,^"_DUZ_U_NOW_U_U_U_ORLOC_U_U_CATG_U_TRSPEC_U_PKG_"^^^"_$G(OREVENT),^(3)=NOW_"^90^"_STS_U_$S($G(ORIT):ORIT_"ORD(101.41,",1:"")_"^^^1^^^^0^^"_+$P(OR0,U,6) 179 S ^OR(100,ORPIFN,8,0)="^100.008DA^1^1",^(1,0)=NOW_"^NW^"_$G(ORNP)_"^^^^^^^^^^"_DUZ_"^^"_STS,^OR(100,ORPIFN,8,"C","NW",1)="",^OR(100,"AF",NOW,ORPIFN,1)="" 180 S ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)="" 181 S:STS=11 ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)="" 182 ; AEVNT ?? 183 S ^OR(100,ORPIFN,1,0)="^100.011^1^1",^(1,0)=$P(OR0,U,2) ; Order text 184 Q 1 ORCSAVE ;SLC/MKB/JDL-Save ;9/13/04 14:05 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,195**;Dec 17, 1997 3 NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG) ; -- New order 4 ; Returns ORIFN = [new] order number, if created/saved 5 D EN 6 Q 7 ; 8 XX ; -- save new/unreleased edited order into Orders file 9 ; Requires: ORDIALOG() = array of dialog values 10 ; ORIFN = IFN of original order that was edited 11 ; 12 N OLDIFN S ORIFN=+ORIFN,OLDIFN=0 13 I $S($P(^OR(100,ORIFN,3),U,3)=11:0,$P(^(3),U,3)'=10:1,$P(^(8,1,0),U,4)=2:0,1:1) S OLDIFN=ORIFN K ORIFN ; create new order if released or delayed&signed 14 D EN Q:'ORIFN S:'$G(ORDA) ORDA=1 15 I $G(OLDIFN) D ;save links between orders 16 . S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=1 17 . S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5) 18 I $D(^OR(100,+OLDIFN,0)) D 19 . Q:'$G(OREVTDF) 20 . N OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN 21 . S (OLDEVT,OLDSTS,LSTACT)=0 22 . S NOW=$$NOW^XLFDT 23 . S OLDEVT=$P(^(0),U,17),OLDSTS=$P(^(3),U,3) 24 . ; Active status = 6 from #100.01 25 . I (OLDEVT>0),OLDSTS=6 D 26 . . S $P(^OR(100,+ORIFN,0),U,17)=OLDEVT 27 . . S $P(^OR(100,+ORIFN,3),U,3)=11 28 . . S LSTACT=$P($G(^OR(100,+ORIFN,3)),U,7) 29 . . I $D(^OR(100,+ORIFN,8,LSTACT,0)) D 30 . . . S $P(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11 31 . . . S PATID=$P(^OR(100,+ORIFN,0),U,2) 32 . . . S WHEN=$P(^OR(100,+ORIFN,8,LSTACT,0),U) 33 . . . S ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)="" 34 Q 35 ; 36 RN ; -- save new/unreleased renewal order into Orders file 37 ; Requires: ORDIALOG() = array of new dialog values 38 ; ORIFN = IFN of original order that was renewed 39 ; 40 N OLDIFN S OLDIFN=+ORIFN K ORIFN 41 D EN Q:'ORIFN S:'$G(ORDA) ORDA=1 42 S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=2 43 S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5) 44 Q 45 ; 46 EN ; -- save new/unreleased order in ORDIALOG() into Orders file 47 ; Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available] 48 ; If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC 49 ; (else use values from ORDIALOG and current state) 50 ; 51 N PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE 52 Q:'$G(ORVP) Q:'$G(ORDIALOG) Q:'$D(^ORD(101.41,+ORDIALOG,0)) 53 S NOW=$$NOW^XLFDT,SIGNREQD=+$P(^ORD(101.41,+ORDIALOG,0),U,6) 54 S CATG=$S($L($G(ORCAT)):ORCAT,1:$S($$INPT^ORCD:"I",1:"O")) 55 S PKG=$S($G(ORPKG):ORPKG,1:$P(^ORD(101.41,+ORDIALOG,0),U,7)) 56 I $G(ORIFN),$D(^OR(100,ORIFN,0)) S STS=$P(^(3),U,3) G EN2 ; unrel order 57 S DG=$S($G(ORDG):+ORDG,1:$P(^ORD(101.41,+ORDIALOG,0),U,5)) 58 I $G(OREVENT),$$GET1^DIQ(9.4,+PKG_",",1)'="PSO",'$G(DGPMT) S LOC="",TRSPEC="" ;195 59 E S LOC=$G(ORL),TRSPEC=$G(ORTS) 60 S TYPE=$S("^B^C^X^P^0^"[(U_$G(ORSRC)_U):ORSRC,$G(ORDCNTRL)="SN":"P",1:0) 61 S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ) 62 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed 63 S STS=$S($G(OREVENT):10,1:11),ORIFN=$$NEXTIFN Q:'ORIFN 64 EN1 S ^OR(100,ORIFN,0)=ORIFN_U_ORVP_U_U_$G(ORNP)_U_+ORDIALOG_";ORD(101.41,^"_USR_U_LOG_U_U_U_LOC_U_DG_U_CATG_U_TRSPEC_U_PKG_U_U_SIGNREQD_U_$G(OREVENT)_U_$G(ORAPPT) 65 S ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$S($G(ORIT):ORIT_";ORD(101.41,",1:"")_U_$G(ORDIALOG("PREV"))_"^^1^^^^"_TYPE 66 S ^OR(100,ORIFN,8,0)="^100.008DA^1^1",^OR(100,ORIFN,8,1,0)=LOG_"^NW^"_$G(ORNP)_U_$S(SIGNREQD:2,1:3)_"^^^^^^^^"_NATR_U_USR_"^1^"_STS,^OR(100,ORIFN,8,"C","NW",1)="" 67 S ^OR(100,"AF",LOG,ORIFN,1)="" 68 S ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)="" 69 S:STS'=10 ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)="" 70 S:SIGNREQD ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)="" 71 S:$G(OREVENT) ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)="" 72 EN2 S ORIFN=+ORIFN D RESPONSE ; save responses 73 I $P(^OR(100,ORIFN,0),"^",5) D ;Copy orders PKI fix 74 . N OI 75 . S OI=+$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,ORIFN,4.5,OI,1)) Q:'OI 76 . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q 77 . D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q")) 78 . I $E($G(ORY))=2 S ORDEA=ORY 79 K ^OR(100,ORIFN,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFN_";1") ; order text 80 S NODE=$G(^OR(100,ORIFN,0)) D S ^OR(100,ORIFN,0)=NODE 81 . S $P(NODE,U,4)=$G(ORNP) ; COST? 82 . S I=$O(^OR(100,ORIFN,4.5,"ID","LOCATION",0)) 83 . I I,$P(NODE,U,10) S X=+$G(^OR(100,ORIFN,4.5,+I,1)) S:X $P(NODE,U,10)=X_";SC(" ;reset Loc if prev value 84 . S I=$O(^OR(100,ORIFN,4.5,"ID","CLASS",0)) 85 . I I S X=$G(^OR(100,ORIFN,4.5,+I,1)) S:"^I^O^"[(U_X_U) $P(NODE,U,12)=X 86 S $P(^OR(100,ORIFN,3),U)=NOW 87 K ^OR(100,ORIFN,9) I $G(ORCHECK) D ; save order checks 88 . S (CNT,CDL)=0 F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL'>0 S I=0 D 89 . . F S I=$O(ORCHECK("NEW",CDL,I)) Q:I'>0 S X=ORCHECK("NEW",CDL,I) D 90 . . . S CNT=CNT+1,^OR(100,ORIFN,9,"B",+X,CNT)="" 91 . . . S ^OR(100,ORIFN,9,CNT,0)=$P(X,U,1,2),^(1)=$E($P(X,U,3),1,245) 92 . S:CNT ^OR(100,ORIFN,9,0)="^100.09PA^"_CNT_U_CNT 93 K ORDEA 94 ENQ Q 95 ; 96 NEXTIFN() ; -- Returns next available ORIFN 97 N I,HDR,LAST,TOTAL,DA 98 F I=1:1:10 L +^OR(100,0):1 Q:$T H 2 99 I '$T Q "^" 100 S HDR=$G(^OR(100,0)),TOTAL=+$P(HDR,U,4),LAST=$O(^OR(100,"?"),-1) 101 S I=LAST\1 F I=(I+1):1 Q:'$D(^OR(100,I,0)) 102 S DA=I,^OR(100,DA,0)=DA,$P(HDR,U,3,4)=DA_U_(TOTAL+1) 103 S ^OR(100,0)=HDR L -^OR(100,0) 104 Q DA 105 ; 106 RESPONSE ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5) 107 N PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X 108 S PAT=$P(^OR(100,ORIFN,0),U,2),START=$P(^(0),U,8) K ^(4.5) 109 S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D 110 . S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM 111 . S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE) 112 . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D 113 . . S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE="" S CNT=CNT+1 114 . . S ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2) 115 . . S:$L($P(ITM,U,2)) ^OR(100,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)="" 116 . . S:TYPE'="W" ^OR(100,ORIFN,4.5,CNT,1)=VALUE 117 . . M:TYPE="W" ^OR(100,ORIFN,4.5,CNT,2)=@VALUE ; array root 118 S ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT 119 R1 ; [Reset] Orderables 120 I $D(^OR(100,ORIFN,.1)) S I=0 F S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0 S X=$G(^(I,0)) I X,PAT,START K ^OR(100,"AOI",X,PAT,9999999-START,ORIFN) ; kill xref 121 K ^OR(100,ORIFN,.1) I $D(^OR(100,ORIFN,4.5,"ID","ORDERABLE")) D 122 . S (I,CNT)=0 123 . F S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D 124 . . S X=$G(^OR(100,ORIFN,4.5,I,1)) Q:'X 125 . . S CNT=CNT+1,^OR(100,ORIFN,.1,CNT,0)=X,^OR(100,ORIFN,.1,"B",X,CNT)="" 126 . . I PAT,START S ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)="" 127 . S ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT 128 Q 129 ; 130 RESUME(IFN) ; -- add Response nodes for RESUME tray service 131 ; S ^OR(100,+IFN,4.5,<next>,0)=DT_"^^^RESUME",^(1)=1 132 ; 133 N X,Y,DA,DIC 134 S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT 135 S DIC("DR")=".04///RESUME",DIC("P")=$P(^DD(100,4.5,0),U,2) 136 D ^DIC S:Y ^OR(100,+IFN,4.5,+Y,1)=1 137 Q 138 ; 139 PROVIDER(ORDER,PROV) ; -- Change PROVider assigned to ORDER 140 Q:'$G(ORDER) Q:'$G(PROV) 141 N ORACT S ORACT=+$P(ORDER,";",2) S:'ORACT ORACT=1 142 S $P(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV 143 S:ORACT=1 $P(^OR(100,+ORDER,0),U,4)=PROV 144 Q 145 ; 146 ACTION(CODE,DA,PROV,REASON,WHEN,WHO) ; -- save new action 147 N NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT S DA=+DA 148 Q:'$D(^OR(100,DA,0)) 0 Q:$G(CODE)'?2U 0 149 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ 150 S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed 151 S PAT=$P(^OR(100,DA,0),U,2),DGRP=$P(^(0),U,11),SIG=$P(^(0),U,16),X=+$P($G(^(3)),U,7),HDR=$G(^(8,0)) 152 S:X'>0 X=1 S TXT=$P($G(^OR(100,DA,8,X,0)),U,14) ;current actn's txt ptr 153 S:HDR="" HDR="^100.008DA^^" S TOTAL=+$P(HDR,U,4) 154 S LAST=$O(^OR(100,DA,8,"C",CODE,"?"),-1) I LAST D 155 . S X=$G(^OR(100,DA,8,LAST,0)) Q:$P(X,U,15)'=11 Q:$P(X,U,4)'=2 156 . S NEXT=LAST I PAT,$P(X,U) D ; kill old xref entries 157 . . K:DGRP ^OR(100,"ACT",PAT,(9999999-$P(X,U)),DGRP,DA,NEXT) 158 . . K ^OR(100,"AC",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AS",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AF",$P(X,U),DA,NEXT) 159 S:'$G(NEXT) NEXT=$O(^OR(100,DA,8,"?"),-1)+1,TOTAL=TOTAL+1 160 S ^OR(100,DA,8,NEXT,0)=WHEN_U_CODE_U_$G(PROV)_U_$S(SIG:2,1:3)_"^^^^^^^^"_NATR_U_WHO_U_TXT_"^11",^OR(100,DA,8,"C",CODE,NEXT)="" 161 S ^OR(100,"AF",WHEN,DA,NEXT)="" 162 I PAT,DGRP S ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)="" 163 I PAT S ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)="" 164 I SIG S ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)="" 165 S:$L($G(REASON)) ^OR(100,DA,8,NEXT,1)=REASON 166 S $P(HDR,U,3,4)=NEXT_U_TOTAL,^OR(100,DA,8,0)=HDR 167 Q NEXT 168 ; 169 SET(DLG) ; -- Create new parent for order set ORDIALOG 170 ; Returns ORPIFN = ifn of new parent order for set 171 ; 172 Q:'$G(ORVP) Q:'$G(DLG) N OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X 173 S OR0=$G(^ORD(101.41,DLG,0)) Q:OR0="" S ORPIFN=$$NEXTIFN Q:'ORPIFN 174 S PKG=$O(^DIC(9.4,"C","OR",0)),CATG=$S($$INPT^ORCD:"I",1:"O"),STS=$S($G(OREVENT):10,1:11),NOW=$S($G(ORSLOG):ORSLOG,1:+$E($$NOW^XLFDT,1,12)) 175 I $G(OREVENT) S ORLOC="",TRSPEC="" 176 S ^OR(100,ORPIFN,0)=ORPIFN_U_ORVP_U_U_$G(ORNP)_U_DLG_";ORD(101.41,^"_DUZ_U_NOW_U_U_U_ORLOC_U_U_CATG_U_TRSPEC_U_PKG_"^^^"_$G(OREVENT),^(3)=NOW_"^90^"_STS_U_$S($G(ORIT):ORIT_"ORD(101.41,",1:"")_"^^^1^^^^0^^"_+$P(OR0,U,6) 177 S ^OR(100,ORPIFN,8,0)="^100.008DA^1^1",^(1,0)=NOW_"^NW^"_$G(ORNP)_"^^^^^^^^^^"_DUZ_"^^"_STS,^OR(100,ORPIFN,8,"C","NW",1)="",^OR(100,"AF",NOW,ORPIFN,1)="" 178 S ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)="" 179 S:STS=11 ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)="" 180 ; AEVNT ?? 181 S ^OR(100,ORPIFN,1,0)="^100.011^1^1",^(1,0)=$P(OR0,U,2) ; Order text 182 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE1.m
r613 r623 1 ORCSAVE1 ; SLC/MKB - Save Order Text ;02/22/07 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**92,132,141,163,187,223,243**;Dec 17, 1997;Build 242 3 ; 4 ; ^ORD(101.41,+ORDIALOG,10,ITM,2)=Seq#^Format^Omit^Lead Text^Trail Text 5 ; ^ORD(101.41,+ORDIALOG,10,"ATXT",Seq#,ITM)="" 6 ; 7 ORDTEXT(ORDER) ; -- Build and save order text from ORDIALOG() into ORDER 8 N ORTX,I,IFN,ACT,ORSET 9 D ORTX(240) Q:'$G(ORTX) 10 S IFN=+ORDER,ACT=+$P(ORDER,";",2) S:ACT'>0 ACT=1 11 F I=1:1:ORTX S ^OR(100,IFN,8,ACT,.1,I,0)=ORTX(I) 12 S ^OR(100,IFN,8,ACT,.1,0)=U_U_ORTX_U_ORTX_U_DT_U 13 I $E($G(ORDEA))=2 D ;PKI Drug Schedule - in future may allow 2-5 14 . S ORSET=0 15 . D DIGTEXT(IFN,ORDEA) 16 . F I=1:1:ORSET S ^OR(100,IFN,8,ACT,.2,I,0)=ORSET(I) 17 . I ORSET>0 S ^OR(100,IFN,8,ACT,.2,0)=U_U_ORSET_U_ORSET_U_DT_U 18 Q 19 ; 20 ORTX(WIDTH) ; -- May enter here to return order text in ORTX() 21 N ORP,SEQ,ITEM,ORMAX,IVIEN,IVITEM,IVTYPE,RATE 22 K ORTX S ORMAX=$S(+$G(WIDTH):WIDTH,1:240) 23 D EXT ; get external form of values 24 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"ATXT",SEQ)) Q:SEQ'>0 D 25 . S ITEM=0 F S ITEM=$O(^ORD(101.41,+ORDIALOG,10,"ATXT",SEQ,ITEM)) Q:ITEM'>0 D TEXT(ITEM) 26 Q 27 ; 28 TEXT(DA) ; -- Includes text of item DA 29 Q:$P(^ORD(101.41,ORDIALOG,10,DA,0),U,11) Q:'$O(ORP(DA,0)) 30 N NEWLN,INST,TYPE,PTR,CHSEQ,CHILD,ORI,X,Y 31 S:'$G(ORTX) ORTX=1,ORTX(1)="" 32 S NEWLN=+$P(ORP(DA),U,4),INST=$O(ORP(DA,0)),Y="" 33 I NEWLN,$L(ORTX(ORTX)) S ORTX=ORTX+1,ORTX(ORTX)="",Y=" " 34 S X=$$GETXT($P(ORP(DA),U,2)) I $L(X) S X=Y_X,Y="" D TXT^ORCHTAB ;lead tx 35 S PTR=+ORP(DA),TYPE=$E(ORDIALOG(PTR,0)) 36 TXT1 I TYPE'="W" S X=Y_ORP(DA,INST),Y="" D TXT^ORCHTAB 37 I TYPE="W" S ORI=0 F S ORI=$O(ORP(DA,INST,ORI)) Q:ORI'>0 D S Y="" 38 . S Y=$S(Y=" ":" ",$P(ORP(DA),U,5):" ",1:"") ;new line, or as stored 39 . S X=Y_ORP(DA,INST,ORI,0),Y="" 40 . I $E(X)'=" " D TXT^ORCHTAB Q ; wrap 41 . S:$L(ORTX(ORTX)) ORTX=ORTX+1,ORTX(ORTX)="" ; force new line 42 . I X?1." " S ORTX(ORTX)=" ",ORTX=ORTX+1,ORTX(ORTX)="" ; blank line 43 . E D TXT^ORCHTAB 44 D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PTR)) CHILD(PTR) 45 S INST=$O(ORP(DA,INST)) ; multiple? 46 I INST S ORTX(ORTX)=ORTX(ORTX)_",",Y="" S:NEWLN ORTX=ORTX+1,ORTX(ORTX)="",Y=" " G TXT1 47 S X=$$GETXT($P(ORP(DA),U,3)) D:$L(X) TXT^ORCHTAB ; trailing text 48 Q 49 ; 50 CHILD(PARENT) ; -- add child values 51 N CHSEQ,CHILD S CHSEQ=0 52 F S CHSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,CHSEQ)) Q:CHSEQ'>0 S CHILD=$O(^(CHSEQ,0)) D 53 . Q:'$L($G(ORP(CHILD,INST))) 54 . S X=$$GETXT($P(ORP(CHILD),U,2)) D:$L(X) TXT^ORCHTAB ; lead text 55 . S X=ORP(CHILD,INST) D TXT^ORCHTAB 56 . S X=$$GETXT($P(ORP(CHILD),U,3)) D:$L(X) TXT^ORCHTAB ; trail text 57 Q 58 ; 59 GETXT(X) ; -- Returns text of X 60 I $E(X)="@" N VAR S VAR=$E(X,2,99),X=$G(@VAR) K @VAR ; variable w/text 61 Q X 62 ; 63 EXT ; -- Build ORP(DA) array of external forms 64 N PROMPT,INST,DA,NODE,FORMAT,OMIT,X,Y,TYPE,PTR 65 S PROMPT=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D 66 . S DA=+$G(ORDIALOG(PROMPT)),TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE) 67 . Q:'DA S NODE=$G(^ORD(101.41,ORDIALOG,10,DA,2)),FORMAT=$P(NODE,U,2),OMIT=$P(NODE,U,3) 68 . S:$D(ORDIALOG(PROMPT,"FORMAT")) FORMAT=ORDIALOG(PROMPT,"FORMAT") 69 . I $E(FORMAT)="@" S PTR=+$E(FORMAT,2,99) Q:'PTR ; Don't include 70 . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D 71 . . Q:ORDIALOG(PROMPT,INST)="" 72 . . I $E(FORMAT)="@",$L($G(ORDIALOG(PTR,INST))) Q ; use PTR instead 73 . . I $E(FORMAT)="*" S PTR=+$E(FORMAT,2,99) I '$L($G(ORDIALOG(PTR,INST))) Q ; must have PTR too 74 . . I $E(FORMAT)="=" S PTR=+$E(FORMAT,2,99) I PTR,$L($G(ORDIALOG(PTR,INST))) S Y=$$EXT^ORCD(PTR,INST),X=$$EXT^ORCD(PROMPT,INST) I (X=Y)!(X[Y)!(Y[X) Q 75 . . I TYPE="W" M ORP(DA,INST)=@ORDIALOG(PROMPT,INST) 76 . . E S X=$$EXT^ORCD(PROMPT,INST,FORMAT) Q:X="" Q:OMIT[X S ORP(DA,INST)=X 77 . . S ORP(DA)=PROMPT_U_$P(NODE,U,4,7) ; ptr^lead^trail^new line^wrap 78 Q 79 DIGTEXT(ORDER,ORDEA,ORSIGNER) ;Build text used to create Digital Signature 80 ;ORDER = ifn of order # (file 100) 81 ;ORDEA = Controlled substance schedule of drug (2-5) 82 ;ORSIGNER = DUZ of sigining physician 83 ;ORSET(1)=1)Date of Prescription (RX) -Date Ordered HL7 format 2)Full Patient Name 3)Patient SSN 4)DFN 84 ;ORSET(2)=5)Patient Street1 6)Patient Street2 7)Patient Street3 8)Patient City 9)Patient State 10)Patient Zip 11)??? 85 ;ORSET(3)=12)Drug name (From Dispense Drug or Orderable Item) 13)Variable ptr for Drug (file 50 or 101.43) 14)Drug quantity prescribed 15)Schedule of medication 16)DEA Schedule 86 ;ORSET(4)=17)Direction for use 87 ;ORSET(5)=18)Practitioner's name 19)DUZ 20)Practitioner's (DEA) registration number 88 ;ORSET(6)=22)SiteName 23)SiteStreet1 24)SiteStreet2 25)SiteCity 26)SiteState 27)SiteZip 89 ;ORSET(7)=28)$H 90 N I,DFN,OR80,ORPNM,ORSSN,ORXDT,VAERR,VAPA,X0,X1,X4,X5,X6,X8,X9,X10,X11,X12,X13,X14,SIG 91 S OR80=$G(^OR(100,ORDER,8,1,0)) 92 Q:'$L(OR80) 93 S:'$G(ORSIGNER) ORSIGNER=$P(OR80,"^",3) 94 Q:'ORSIGNER 95 S $P(^OR(100,ORDER,8,1,2),"^",4,5)=ORDEA_"^"_1 ;Flag to signing process to get digital signature 96 S ORXDT=$P(OR80,"^"),X1=$$FMTHL7^XLFDT(ORXDT),X4="",X14="",X10="" 97 I '$D(ORVP) S ORVP=$P(^OR(100,ORDER,0),"^",2) 98 S DFN=+ORVP 99 D ADD^VADPT 100 S ORPNM=^DPT(+ORVP,0),ORSSN=$P(ORPNM,"^",9),ORPNM=$P(ORPNM,"^") 101 F I=1:1:6 S X4=X4_$S($L($G(VAPA(I))):$S((I=5):$P(VAPA(I),"^",2),1:VAPA(I)),1:"")_"^" 102 S X11=$$GET1^DIQ(200,ORSIGNER,.01,"E") Q:'$L(X11) 103 S X12=$$DEA^XUSER(,ORSIGNER) 104 S X0=$$GET1^DIQ(4,+$G(DUZ(2)),.01,"E") 105 I $L(X0) S X14=X0_"^"_$$GET1^DIQ(4,DUZ(2),1.01,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.02,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.03,"E")_"^"_$$GET1^DIQ(4,DUZ(2),.02,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.04,"E") 106 S X5=$$VALUE^ORX8(ORDER,"DRUG",,"E"),X6=$$VALUE^ORX8(ORDER,"DRUG")_";50" 107 I '$L(X5) S X5=$$VALUE^ORX8(ORDER,"ORDERABLE",,"E"),X6=$$VALUE^ORX8(ORDER,"ORDERABLE")_";101.43" 108 S X8=$$VALUE^ORX8(ORDER,"QTY",,"E"),X9=$$VALUE^ORX8(ORDER,"SCHEDULE",,"E") 109 S SIG=+$O(^OR(100,ORDER,4.5,"ID","SIG",0)) I SIG,$L($G(^OR(100,ORDER,4.5,SIG,2,1,0))) S X10=^(0) 110 S ORSET(1)=X1_"^"_ORPNM_"^"_ORSSN_"^"_+ORVP_"^" 111 S ORSET(2)=X4_"^" 112 S ORSET(3)=X5_"^"_X6_"^"_X8_"^"_X9_"^"_ORDEA_"^" 113 S ORSET(4)=X10_"^" 114 S ORSET(5)=X11_"^"_ORSIGNER_"^"_X12_"^" 115 S ORSET(6)=X14 116 S ORSET(7)=$H 117 S ORSET=7 118 Q 1 ORCSAVE1 ; SLC/MKB - Save Order Text ;7/13/04 15:41 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**92,132,141,163,187,223**;Dec 17, 1997 3 ; 4 ; ^ORD(101.41,+ORDIALOG,10,ITM,2)=Seq#^Format^Omit^Lead Text^Trail Text 5 ; ^ORD(101.41,+ORDIALOG,10,"ATXT",Seq#,ITM)="" 6 ; 7 ORDTEXT(ORDER) ; -- Build and save order text from ORDIALOG() into ORDER 8 N ORTX,I,IFN,ACT,ORSET 9 D ORTX(240) Q:'$G(ORTX) 10 S IFN=+ORDER,ACT=+$P(ORDER,";",2) S:ACT'>0 ACT=1 11 F I=1:1:ORTX S ^OR(100,IFN,8,ACT,.1,I,0)=ORTX(I) 12 S ^OR(100,IFN,8,ACT,.1,0)=U_U_ORTX_U_ORTX_U_DT_U 13 I $E($G(ORDEA))=2 D ;PKI Drug Schedule - in future may allow 2-5 14 . S ORSET=0 15 . D DIGTEXT(IFN,ORDEA) 16 . F I=1:1:ORSET S ^OR(100,IFN,8,ACT,.2,I,0)=ORSET(I) 17 . I ORSET>0 S ^OR(100,IFN,8,ACT,.2,0)=U_U_ORSET_U_ORSET_U_DT_U 18 Q 19 ; 20 ORTX(WIDTH) ; -- May enter here to return order text in ORTX() 21 N ORP,SEQ,ITEM,ORMAX 22 K ORTX S ORMAX=$S(+$G(WIDTH):WIDTH,1:240) 23 D EXT ; get external form of values 24 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"ATXT",SEQ)) Q:SEQ'>0 S ITEM=$O(^(SEQ,0)) D TEXT(ITEM) 25 Q 26 ; 27 TEXT(DA) ; -- Includes text of item DA 28 Q:$P(^ORD(101.41,ORDIALOG,10,DA,0),U,11) Q:'$O(ORP(DA,0)) 29 N NEWLN,INST,TYPE,PTR,CHSEQ,CHILD,ORI,X,Y 30 S:'$G(ORTX) ORTX=1,ORTX(1)="" 31 S NEWLN=+$P(ORP(DA),U,4),INST=$O(ORP(DA,0)),Y="" 32 I NEWLN,$L(ORTX(ORTX)) S ORTX=ORTX+1,ORTX(ORTX)="",Y=" " 33 S X=$$GETXT($P(ORP(DA),U,2)) I $L(X) S X=Y_X,Y="" D TXT^ORCHTAB ;lead tx 34 S PTR=+ORP(DA),TYPE=$E(ORDIALOG(PTR,0)) 35 TXT1 I TYPE'="W" S X=Y_ORP(DA,INST),Y="" D TXT^ORCHTAB 36 I TYPE="W" S ORI=0 F S ORI=$O(ORP(DA,INST,ORI)) Q:ORI'>0 D S Y="" 37 . S Y=$S(Y=" ":" ",$P(ORP(DA),U,5):" ",1:"") ;new line, or as stored 38 . S X=Y_ORP(DA,INST,ORI,0),Y="" 39 . I $E(X)'=" " D TXT^ORCHTAB Q ; wrap 40 . S:$L(ORTX(ORTX)) ORTX=ORTX+1,ORTX(ORTX)="" ; force new line 41 . I X?1." " S ORTX(ORTX)=" ",ORTX=ORTX+1,ORTX(ORTX)="" ; blank line 42 . E D TXT^ORCHTAB 43 D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PTR)) CHILD(PTR) 44 S INST=$O(ORP(DA,INST)) ; multiple? 45 I INST S ORTX(ORTX)=ORTX(ORTX)_",",Y="" S:NEWLN ORTX=ORTX+1,ORTX(ORTX)="",Y=" " G TXT1 46 S X=$$GETXT($P(ORP(DA),U,3)) D:$L(X) TXT^ORCHTAB ; trailing text 47 Q 48 ; 49 CHILD(PARENT) ; -- add child values 50 N CHSEQ,CHILD S CHSEQ=0 51 F S CHSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,CHSEQ)) Q:CHSEQ'>0 S CHILD=$O(^(CHSEQ,0)) D 52 . Q:'$L($G(ORP(CHILD,INST))) 53 . S X=$$GETXT($P(ORP(CHILD),U,2)) D:$L(X) TXT^ORCHTAB ; lead text 54 . S X=ORP(CHILD,INST) D TXT^ORCHTAB 55 . S X=$$GETXT($P(ORP(CHILD),U,3)) D:$L(X) TXT^ORCHTAB ; trail text 56 Q 57 ; 58 GETXT(X) ; -- Returns text of X 59 I $E(X)="@" N VAR S VAR=$E(X,2,99),X=$G(@VAR) K @VAR ; variable w/text 60 Q X 61 ; 62 EXT ; -- Build ORP(DA) array of external forms 63 N PROMPT,INST,DA,NODE,FORMAT,OMIT,X,Y,TYPE,PTR 64 S PROMPT=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D 65 . S DA=+$G(ORDIALOG(PROMPT)),TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE) 66 . Q:'DA S NODE=$G(^ORD(101.41,ORDIALOG,10,DA,2)),FORMAT=$P(NODE,U,2),OMIT=$P(NODE,U,3) 67 . S:$D(ORDIALOG(PROMPT,"FORMAT")) FORMAT=ORDIALOG(PROMPT,"FORMAT") 68 . I $E(FORMAT)="@" S PTR=+$E(FORMAT,2,99) Q:'PTR ; Don't include 69 . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D 70 . . Q:ORDIALOG(PROMPT,INST)="" 71 . . I $E(FORMAT)="@",$L($G(ORDIALOG(PTR,INST))) Q ; use PTR instead 72 . . I $E(FORMAT)="*" S PTR=+$E(FORMAT,2,99) I '$L($G(ORDIALOG(PTR,INST))) Q ; must have PTR too 73 . . I $E(FORMAT)="=" S PTR=+$E(FORMAT,2,99) I PTR,$L($G(ORDIALOG(PTR,INST))) S Y=$$EXT^ORCD(PTR,INST),X=$$EXT^ORCD(PROMPT,INST) I (X=Y)!(X[Y)!(Y[X) Q 74 . . I TYPE="W" M ORP(DA,INST)=@ORDIALOG(PROMPT,INST) 75 . . E S X=$$EXT^ORCD(PROMPT,INST,FORMAT) Q:X="" Q:OMIT[X S ORP(DA,INST)=X 76 . . S ORP(DA)=PROMPT_U_$P(NODE,U,4,7) ; ptr^lead^trail^new line^wrap 77 Q 78 DIGTEXT(ORDER,ORDEA,ORSIGNER) ;Build text used to create Digital Signature 79 ;ORDER = ifn of order # (file 100) 80 ;ORDEA = Controlled substance schedule of drug (2-5) 81 ;ORSIGNER = DUZ of sigining physician 82 ;ORSET(1)=1)Date of Prescription (RX) -Date Ordered HL7 format 2)Full Patient Name 3)Patient SSN 4)DFN 83 ;ORSET(2)=5)Patient Street1 6)Patient Street2 7)Patient Street3 8)Patient City 9)Patient State 10)Patient Zip 11)??? 84 ;ORSET(3)=12)Drug name (From Dispense Drug or Orderable Item) 13)Variable ptr for Drug (file 50 or 101.43) 14)Drug quantity prescribed 15)Schedule of medication 16)DEA Schedule 85 ;ORSET(4)=17)Direction for use 86 ;ORSET(5)=18)Practitioner's name 19)DUZ 20)Practitioner's (DEA) registration number 87 ;ORSET(6)=22)SiteName 23)SiteStreet1 24)SiteStreet2 25)SiteCity 26)SiteState 27)SiteZip 88 ;ORSET(7)=28)$H 89 N I,DFN,OR80,ORPNM,ORSSN,ORXDT,VAERR,VAPA,X0,X1,X4,X5,X6,X8,X9,X10,X11,X12,X13,X14,SIG 90 S OR80=$G(^OR(100,ORDER,8,1,0)) 91 Q:'$L(OR80) 92 S:'$G(ORSIGNER) ORSIGNER=$P(OR80,"^",3) 93 Q:'ORSIGNER 94 S $P(^OR(100,ORDER,8,1,2),"^",4,5)=ORDEA_"^"_1 ;Flag to signing process to get digital signature 95 S ORXDT=$P(OR80,"^"),X1=$$FMTHL7^XLFDT(ORXDT),X4="",X14="",X10="" 96 I '$D(ORVP) S ORVP=$P(^OR(100,ORDER,0),"^",2) 97 S DFN=+ORVP 98 D ADD^VADPT 99 S ORPNM=^DPT(+ORVP,0),ORSSN=$P(ORPNM,"^",9),ORPNM=$P(ORPNM,"^") 100 F I=1:1:6 S X4=X4_$S($L($G(VAPA(I))):$S((I=5):$P(VAPA(I),"^",2),1:VAPA(I)),1:"")_"^" 101 S X11=$$GET1^DIQ(200,ORSIGNER,.01,"E") Q:'$L(X11) 102 S X12=$$DEA^XUSER(,ORSIGNER) 103 S X0=$$GET1^DIQ(4,+$G(DUZ(2)),.01,"E") 104 I $L(X0) S X14=X0_"^"_$$GET1^DIQ(4,DUZ(2),1.01,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.02,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.03,"E")_"^"_$$GET1^DIQ(4,DUZ(2),.02,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.04,"E") 105 S X5=$$VALUE^ORX8(ORDER,"DRUG",,"E"),X6=$$VALUE^ORX8(ORDER,"DRUG")_";50" 106 I '$L(X5) S X5=$$VALUE^ORX8(ORDER,"ORDERABLE",,"E"),X6=$$VALUE^ORX8(ORDER,"ORDERABLE")_";101.43" 107 S X8=$$VALUE^ORX8(ORDER,"QTY",,"E"),X9=$$VALUE^ORX8(ORDER,"SCHEDULE",,"E") 108 S SIG=+$O(^OR(100,ORDER,4.5,"ID","SIG",0)) I SIG,$L($G(^OR(100,ORDER,4.5,SIG,2,1,0))) S X10=^(0) 109 S ORSET(1)=X1_"^"_ORPNM_"^"_ORSSN_"^"_+ORVP_"^" 110 S ORSET(2)=X4_"^" 111 S ORSET(3)=X5_"^"_X6_"^"_X8_"^"_X9_"^"_ORDEA_"^" 112 S ORSET(4)=X10_"^" 113 S ORSET(5)=X11_"^"_ORSIGNER_"^"_X12_"^" 114 S ORSET(6)=X14 115 S ORSET(7)=$H 116 S ORSET=7 117 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE2.m
r613 r623 1 ORCSAVE2 ;SLC/MKB-Utilities to update an order ; 4/8/08 12:04pm 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,56,70,94,116,190,157,215,265,243**;Dec 17, 1997;Build 242 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 STATUS(IFN,ST) ; -- Update status of order 6 Q:'$G(IFN) Q:'$D(^OR(100,+IFN,0)) Q:$P($G(^(3)),U,3)=$G(ST) ;no change 7 Q:'$G(ST) Q:'$D(^ORD(100.01,+ST,0)) 8 N NODE0,NODE3,ORNOW,DA,XACT,PROV,ORVP 9 S NODE3=$G(^OR(100,+IFN,3)),ORVP=$P($G(^(0)),U,2),ORNOW=$$NOW^XLFDT 10 S $P(NODE3,U)=ORNOW,$P(NODE3,U,3)=ST,^OR(100,+IFN,3)=NODE3 11 I (ST<3)!(ST=12)!(ST=13),$G(ORDCNTRL)'="ZC" D DATES(+IFN,,+$E(ORNOW,1,12)) 12 I "^1^2^7^12^13^15^"[(U_ST_U) D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN 13 I $P(NODE3,U,9) D CKPARENT($P(NODE3,U,9)) ; ck siblings to update parent 14 D SETALL^ORDD100(+IFN) 15 Q 16 ; 17 CKPARENT(ORIFN) ; -- Update status of parent order, if appropriate 18 N ORSTS,ALLRELSD,ALLDONE,DC,COMP,CH,CHSTS,ACTIVE,LAPS 19 Q:'$D(^OR(100,ORIFN,0)) S ORSTS=$P($G(^(3)),U,3) 20 I (ORSTS=11)!(ORSTS=10) S ALLRELSD=1 D Q ;Parent unrel'd - ck children 21 . F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0 D Q:'ALLRELSD 22 . . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q 23 . . S CHSTS=$P($G(^OR(100,CH,3)),U,3) S:CHSTS=11 ALLRELSD=0 24 . I ALLRELSD D STATUS(ORIFN,5) ; update Parent order to pending 25 S ALLDONE=1,(DC,COMP,LAPS,ACTIVE)=0 26 F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0 D Q:'ALLDONE 27 . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q 28 . S CHSTS=$P($G(^OR(100,CH,3)),U,3) I CHSTS=14 S LAPS=1 Q 29 . I "^1^12^13^"[(U_CHSTS_U) S DC=1 Q 30 . I "^2^7^"[(U_CHSTS_U) S COMP=1 Q 31 . S ALLDONE=0 S:CHSTS=6 ACTIVE=1 32 I ALLDONE S ORSTS=$S(COMP:2,DC:1,LAPS:14,1:"") D:ORSTS STATUS(ORIFN,ORSTS) Q 33 I ACTIVE,ORSTS'=6 D STATUS(ORIFN,6) ;at least child active 34 Q 35 ; 36 RELEASE(ORDER,ACTION,WHEN,WHO,NATURE) ; -- Mark order as released to service 37 S:'$G(ACTION) ACTION=1 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ 38 Q:'$G(ORDER) N OR0 S OR0=$G(^OR(100,ORDER,8,ACTION,0)) 39 S:$L($G(NATURE)) $P(OR0,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0))) 40 S:($P(OR0,U,15)=10)!($P(OR0,U,15)=11) $P(OR0,U,15)="" 41 ;S $P(OR0,U,16,17)=WHEN_U_WHO,^OR(100,"AR",ORVP,9999999-WHEN,ORDER,ACTION)="" 42 S $P(OR0,U,16,17)=WHEN_U_WHO 43 S ^OR(100,ORDER,8,ACTION,0)=OR0 44 I $P(OR0,U,2)="NW",'$P(^OR(100,ORDER,0),U,8) D STARTDT(ORDER) 45 ;Set the "AR" index. 46 D RS^ORDD100(ORDER,ACTION,ORVP,WHEN) 47 Q 48 ; 49 STARTDT(DA) ; -- resolve Start and Stop dates from Responses 50 N X,Y,%DT,ORDG,ORT,ORLAB 51 S ORDG=$P($G(^ORD(100.98,+$P(^OR(100,DA,0),U,11),0)),U,3) 52 S ORLAB="^LAB^CH^HEMA^MI^AP^AU^EM^SP^CY^BB^"[(U_ORDG_U),ORT="" 53 S:ORDG="E/L T" ORT=$$VALUE(DA,"TIME") S:ORDG="MEAL" ORT=$$MEALTIME^ORCDFHO(DA) 54 STRT S X=$$VALUE(DA,"START") I '$L(X) D WS^ORDD100 Q S:$L(ORT) X=X_"@"_ORT 55 D AM:X="AM",NEXT:X="NEXT",ADMIN("NEXT"):X="NEXTA",ADMIN("CLOSEST"):X="CLOSEST" 56 S %DT="T" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359" 57 S $P(^OR(100,DA,0),U,8)=Y D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA) 58 STOP I ORLAB S X=$$VALUE(DA,"DAYS") Q:X'>1 S X=$$FMADD^XLFDT(Y,(X-1)) 59 I 'ORLAB S X=$$VALUE(DA,"STOP") Q:'$L(X) S:$L(ORT) X=X_"@"_ORT 60 S %DT="T" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359" 61 S $P(^OR(100,DA,0),U,9)=Y D ES^ORDD100A 62 Q 63 ; 64 NEXT ; -- Resolve next lab collection to FM date/time 65 N ORTIME,ORDAY,NOW,NEXT,ENT 66 ;is referenced by DBIA #964 67 S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL" 68 D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N") 69 S NOW=$P($H,",",2),ORDAY=$S($O(ORTIME(NOW)):"T",1:"T+1") 70 S ORDAY=$$NEXTCOLL^ORCDLR1(ORDAY) S:ORDAY["+" NOW=0 71 S NEXT=$O(ORTIME(NOW)),X=ORDAY_"@"_$P($G(ORTIME(+NEXT)),U) 72 Q 73 ; 74 AM ; -- Resolve AM lab collection to FM date/time 75 N ORTIME,ORDAY,AM,NOW,ENT 76 ;is referenced by DBIA #964 77 S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL" 78 D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N") 79 S AM=$O(ORTIME(0)),NOW=$P($H,",",2) 80 S ORDAY=$S(AM=$O(ORTIME(NOW)):"T",1:"T+1") 81 S X=$$NEXTCOLL^ORCDLR1(ORDAY)_"@"_$P($G(ORTIME(+AM)),U) 82 Q 83 ; 84 ADMIN(START) ; -- Resolve next/closest administration times to FM date/time 85 N PAT,SCH,OI,LOC,Y,I 86 I $G(DA) D ;get data from order DA 87 . S PAT=+$P($G(^OR(100,DA,0)),U,2),LOC="" 88 . S I=+$O(^OR(100,DA,4.5,"ID","INSTR",0)),I=+$P($G(^OR(100,DA,4.5,I,0)),U,3) ;first 89 . S SCH=$$VALUE(DA,"SCHEDULE",I),OI=$$VALUE(DA,"ORDERABLE") 90 I '$G(DA) D ;or look in ORDIALOG() instead 91 . S I=+$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) 92 . S PAT=$G(ORVP),SCH=$G(ORDIALOG($$PTR^ORCD("OR GTX SCHEDULE"),I)) 93 . S OI=$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)),LOC="" 94 S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) ;PSOI 95 ;is referenced by DBIA #3167 96 S Y=$$RESOLVE^PSJORPOE(PAT,SCH,OI,START,LOC),X=$P(Y,U,2) 97 Q 98 ; 99 SIGN(DA,WHO,WHEN,HOW,WHAT) ; -- affix ES to order 100 Q:'$G(DA) S:'$G(WHAT) WHAT=1 101 N X S X=$G(^OR(100,DA,8,WHAT,0)) D S2^ORDD100(DA,WHAT) ; kill AS xref 102 S $P(X,U,4,7)=$G(HOW)_U_$G(WHO)_U_$E($G(WHEN),1,12)_U_$S(HOW=0:DUZ,1:"") 103 ; S:$G(WHO) $P(X,U,3)=WHO ; reset provider to signer 104 S ^OR(100,DA,8,WHAT,0)=X 105 D:$G(HOW)=2 S1^ORDD100(DA,WHAT) ; reset AS xref 106 Q 107 ; 108 SIGSTS(IFN,ACT) ; -- Set SigSts for backdoor orders [Called from ^ORM* rtns] 109 ; Expects ORNATR, ORVP, ORNP to be defined 110 Q:'$G(IFN) Q:'$G(ACT) N X,OR0 S OR0=+$P($G(^OR(100,+IFN,8,ACT,0)),U) 111 S X=$S($$SIGNREQD^ORCACT1(+IFN):$$SIGSTS^ORX1(ORNATR),1:3) 112 K ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT) 113 S $P(^OR(100,+IFN,8,ACT,0),U,4)=X 114 I X=2 S ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)="" D NOTIF^ORCSIGN 115 Q 116 ; 117 UNVEIL(IFN) ; -- unveil new order 118 S $P(^OR(100,IFN,3),U,8)="" 119 Q 120 ; 121 DELETE(ORDER) ; -- delete order [action] 122 N DIK,DA,DAD 123 I $P(ORDER,";",2)>1 S DA=+$P(ORDER,";",2),DA(1)=+ORDER,DIK="^OR(100,"_DA(1)_",8," D:DA ^DIK Q 124 S DAD=+$P($G(^OR(100,+ORDER,3)),U,9) I DAD S DIK="^OR(100,"_DAD_",2,",DA(1)=DAD,DA=+ORDER D ^DIK ; remove link to child from parent 125 K DA S DA=+ORDER,DIK="^OR(100," D ^DIK ;remove order, text 126 Q 127 ; 128 VERIFY(IFN,DA,TYPE,WHO,WHEN) ; -- order verified 129 Q:'$G(IFN) Q:'$G(DA) Q:"^N^C^R^"'[(U_$G(TYPE)_U) 130 N FLD S FLD=$S(TYPE="N":8,TYPE="C":10,1:18) 131 S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) 132 S $P(^OR(100,IFN,8,DA,0),U,FLD,FLD+1)=WHO_U_WHEN 133 D:$L($T(VER^EDPFMON)) VER^EDPFMON(IFN) 134 Q 135 ; 136 COMP(IFN,WHO,WHEN) ; -- order completed 137 Q:'$G(IFN) S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) 138 D DATES(+IFN,,WHEN),STATUS(+IFN,2) 139 S $P(^OR(100,+IFN,6),U,6,7)=WHEN_U_WHO 140 D:$L($T(COMP^EDPFMON)) COMP^EDPFMON(IFN) 141 Q 142 ; 143 DATES(DA,START,STOP) ; -- Update start/stop dates for order DA 144 Q:'$G(DA) I $G(START) D 145 . Q:START=$P(^OR(100,DA,0),U,8) 146 . D SK^ORDD100,WK^ORDD100,OI2^ORDD100A(DA) 147 . S $P(^OR(100,DA,0),U,8)=START 148 . D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA) 149 I $G(STOP) D 150 . ;Q:STOP=$P(^OR(100,DA,0),U,9) ;ck xref anyway 151 . D EK^ORDD100A S $P(^OR(100,DA,0),U,9)=STOP D ES^ORDD100A 152 Q 153 ; 154 OC ; -- Save order checks in ORCHECK() in ^OR(100,+ORIFN,9) 155 Q:'$G(ORIFN) Q:'$D(^OR(100,+ORIFN,0)) K ^OR(100,+ORIFN,9) 156 N NOW,CNT,CDL,I,OC,OVERIDE S NOW=+$E($$NOW^XLFDT,1,12),CNT=0 157 S CDL=0 F S CDL=$O(ORCHECK(+ORIFN,CDL)) Q:CDL'>0 D 158 . S I=0 F S I=$O(ORCHECK(+ORIFN,CDL,I)) Q:I'>0 D 159 . . S OC=ORCHECK(+ORIFN,CDL,I) Q:'OC 160 . . S OVERIDE=$S($G(MODE)="NOTIF":$G(ORCHECK("OK"))_U,CDL=1:$G(ORCHECK("OK"))_U_DUZ,1:U_DUZ)_U_NOW 161 . . S CNT=CNT+1,^OR(100,+ORIFN,9,"B",+OC,CNT)="" 162 . . S ^OR(100,+ORIFN,9,CNT,0)=$P(OC,U,1,2)_U_U_OVERIDE,^(1)=$E($P(OC,U,3),1,245) 163 S:CNT ^OR(100,+ORIFN,9,0)="^100.09PA^"_CNT_U_CNT 164 Q 165 ; 166 VALUE(IFN,ID,INST) ; -- Returns value of prompt by identifier ID 167 I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q "" 168 N I,Y S I=0,Y="" S:'$G(INST) INST=1 169 F S I=$O(^OR(100,IFN,4.5,"ID",ID,I)) Q:I'>0 I $P($G(^OR(100,IFN,4.5,+I,0)),U,3)=INST S Y=$G(^(1)) Q 170 Q Y 171 ; 172 SC(ORX,ORIFN) ; -- save responses to SC questions 173 Q:'$G(ORIFN) Q:'$D(^OR(100,+ORIFN,0)) ;invalid order number 174 N OR5,I,P S OR5=$G(^OR(100,+ORIFN,5)),P=0 175 F I="SC","MST","AO","IR","EC","HNC","CV","SHD" S P=P+1 S:$D(ORX(I)) $P(OR5,U,P)=ORX(I) 176 S ^OR(100,+ORIFN,5)=OR5 177 Q 178 ; 179 CANCEL(ORDER) ; -- cancel order [action] 180 N ORA,DIE,DA,DR,ORX 181 S ORDER=$G(ORDER),ORA=+$P(ORDER,";",2) Q:'ORA!('ORDER) 182 I $D(^OR(100,+ORDER,8,ORA)) D 183 .S ORX="Unsigned/unreleased order cancelled by provider" 184 .S DIE="^OR(100,"_+ORDER_",8,",DA=ORA,DA(1)=+ORDER 185 .S DR="4////5;15////13;1////^S X=ORX" D ^DIE 186 I ORA=1 D 187 .K DA S DIE="^OR(100,",DA=+ORDER,DR="5////13" D ^DIE 188 Q 189 ; 190 LAPSE(ORDER) ; -- lapse order [action] 191 N ORA S ORA=+$P(ORDER,";",2) 192 Q:'$D(^OR(100,+ORDER,0)) Q:'ORA!('ORDER) 193 I $D(^OR(100,+ORDER,8,ORA)) D 194 .N DIE,DA,DR 195 .S DIE="^OR(100,"_+ORDER_",8,",DA=ORA,DA(1)=+ORDER 196 .S DR="4////5;15////14" D ^DIE 197 I ORA=1 D 198 .N DIE,DA,DR 199 .S DIE="^OR(100,",DA=+ORDER,DR="5////14" 200 .D ^DIE,ALPS(DA,ORA) 201 Q 202 ALPS(DA,ORACT,TYPE) ;set the lapse index ^OR(100,"ALPS") 203 N ORVP,X,OR0,ORLOG 204 S OR0=$G(^OR(100,DA,8,ORACT,0)) 205 S ORLOG=$P(OR0,U),ORVP=$P($G(^OR(100,DA,0)),U,2) 206 I ORVP,ORLOG S ^OR(100,"ALPS",ORVP,9999999-ORLOG,DA,ORACT)=$G(TYPE) 207 S ^OR(100,DA,10)=$$NOW^XLFDT 208 Q 209 ; 210 RESP(IFN,PRMT,VAL,INST) ; -- update a single Response VALue 211 S IFN=+$G(IFN),VAL=$G(VAL),PRMT=+$O(^ORD(101.41,"AB",PRMT,0)) 212 N ID,DA,DIK S:'$G(INST) INST=1 213 S ID=$P($G(^ORD(101.41,PRMT,1)),U,3) Q:'$L(ID) 214 S DA=0 F S DA=$O(^OR(100,IFN,4.5,"ID",ID,DA)) Q:DA<1 Q:$P($G(^OR(100,IFN,4.5,DA,0)),U,3)=INST 215 I 'DA D:$L(VAL) Q ;add 216 . N DO,DIC,DLG,X 217 . S DIC="^OR(100,"_IFN_",4.5,",DA(1)=IFN,DIC(0)="FL" 218 . S DIC("DR")=".02///"_PRMT_";.03///"_INST_";.04///"_ID 219 . S DLG=+$P($G(^OR(100,IFN,0)),U,5) 220 . S X=+$O(^ORD(101.41,DLG,10,"D",PRMT,0)) 221 . D FILE^DICN S:Y ^OR(100,IFN,4.5,+Y,1)=VAL 222 I $L(VAL) S ^OR(100,IFN,4.5,DA,1)=VAL Q ;change 223 S DIK="^OR(100,"_IFN_",4.5,",DA(1)=IFN D ^DIK ;delete 224 Q 1 ORCSAVE2 ;SLC/MKB-Utilities to update an order ;04:19 PM 06/16/2004 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,56,70,94,116,190,157,215,265**;Dec 17, 1997;Build 17 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 STATUS(IFN,ST) ; -- Update status of order 6 Q:'$G(IFN) Q:'$D(^OR(100,+IFN,0)) Q:$P($G(^(3)),U,3)=$G(ST) ;no change 7 Q:'$G(ST) Q:'$D(^ORD(100.01,+ST,0)) 8 N NODE0,NODE3,ORNOW,DA,XACT,PROV,ORVP 9 S NODE3=$G(^OR(100,+IFN,3)),ORVP=$P($G(^(0)),U,2),ORNOW=$$NOW^XLFDT 10 S $P(NODE3,U)=ORNOW,$P(NODE3,U,3)=ST,^OR(100,+IFN,3)=NODE3 11 I (ST<3)!(ST=12)!(ST=13),$G(ORDCNTRL)'="ZC" D DATES(+IFN,,+$E(ORNOW,1,12)) 12 I "^1^2^7^12^13^15^"[(U_ST_U) D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN 13 I $P(NODE3,U,9) D CKPARENT($P(NODE3,U,9)) ; ck siblings to update parent 14 D SETALL^ORDD100(+IFN) 15 Q 16 ; 17 CKPARENT(ORIFN) ; -- Update status of parent order, if appropriate 18 N ORSTS,ALLRELSD,ALLDONE,DC,COMP,CH,CHSTS,ACTIVE,LAPS 19 Q:'$D(^OR(100,ORIFN,0)) S ORSTS=$P($G(^(3)),U,3) 20 I (ORSTS=11)!(ORSTS=10) S ALLRELSD=1 D Q ;Parent unrel'd - ck children 21 . F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0 D Q:'ALLRELSD 22 . . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q 23 . . S CHSTS=$P($G(^OR(100,CH,3)),U,3) S:CHSTS=11 ALLRELSD=0 24 . I ALLRELSD D STATUS(ORIFN,5) ; update Parent order to pending 25 S ALLDONE=1,(DC,COMP,LAPS,ACTIVE)=0 26 F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0 D Q:'ALLDONE 27 . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q 28 . S CHSTS=$P($G(^OR(100,CH,3)),U,3) I CHSTS=14 S LAPS=1 Q 29 . I "^1^12^13^"[(U_CHSTS_U) S DC=1 Q 30 . I "^2^7^"[(U_CHSTS_U) S COMP=1 Q 31 . S ALLDONE=0 S:CHSTS=6 ACTIVE=1 32 I ALLDONE S ORSTS=$S(COMP:2,DC:1,LAPS:14,1:"") D:ORSTS STATUS(ORIFN,ORSTS) Q 33 I ACTIVE,ORSTS'=6 D STATUS(ORIFN,6) ;at least child active 34 Q 35 ; 36 RELEASE(ORDER,ACTION,WHEN,WHO,NATURE) ; -- Mark order as released to service 37 S:'$G(ACTION) ACTION=1 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ 38 Q:'$G(ORDER) N OR0 S OR0=$G(^OR(100,ORDER,8,ACTION,0)) 39 S:$L($G(NATURE)) $P(OR0,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0))) 40 S:($P(OR0,U,15)=10)!($P(OR0,U,15)=11) $P(OR0,U,15)="" 41 ;S $P(OR0,U,16,17)=WHEN_U_WHO,^OR(100,"AR",ORVP,9999999-WHEN,ORDER,ACTION)="" 42 S $P(OR0,U,16,17)=WHEN_U_WHO 43 S ^OR(100,ORDER,8,ACTION,0)=OR0 44 I $P(OR0,U,2)="NW",'$P(^OR(100,ORDER,0),U,8) D STARTDT(ORDER) 45 ;Set the "AR" index. 46 D RS^ORDD100(ORDER,ACTION,ORVP,WHEN) 47 Q 48 ; 49 STARTDT(DA) ; -- resolve Start and Stop dates from Responses 50 N X,Y,%DT,ORDG,ORT,ORLAB 51 S ORDG=$P($G(^ORD(100.98,+$P(^OR(100,DA,0),U,11),0)),U,3) 52 S ORLAB="^LAB^CH^HEMA^MI^AP^AU^EM^SP^CY^BB^"[(U_ORDG_U),ORT="" 53 S:ORDG="E/L T" ORT=$$VALUE(DA,"TIME") S:ORDG="MEAL" ORT=$$MEALTIME^ORCDFHO(DA) 54 STRT S X=$$VALUE(DA,"START") I '$L(X) D WS^ORDD100 Q S:$L(ORT) X=X_"@"_ORT 55 D AM:X="AM",NEXT:X="NEXT",ADMIN("NEXT"):X="NEXTA",ADMIN("CLOSEST"):X="CLOSEST" 56 S %DT="T" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359" 57 S $P(^OR(100,DA,0),U,8)=Y D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA) 58 STOP I ORLAB S X=$$VALUE(DA,"DAYS") Q:X'>1 S X=$$FMADD^XLFDT(Y,(X-1)) 59 I 'ORLAB S X=$$VALUE(DA,"STOP") Q:'$L(X) S:$L(ORT) X=X_"@"_ORT 60 S %DT="T" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359" 61 S $P(^OR(100,DA,0),U,9)=Y D ES^ORDD100A 62 Q 63 ; 64 NEXT ; -- Resolve next lab collection to FM date/time 65 N ORTIME,ORDAY,NOW,NEXT,ENT 66 S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL" ;is referenced by DBIA #964 67 D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N") 68 S NOW=$P($H,",",2),ORDAY=$S($O(ORTIME(NOW)):"T",1:"T+1") 69 S ORDAY=$$NEXTCOLL^ORCDLR1(ORDAY) S:ORDAY["+" NOW=0 70 S NEXT=$O(ORTIME(NOW)),X=ORDAY_"@"_$P($G(ORTIME(+NEXT)),U) 71 Q 72 ; 73 AM ; -- Resolve AM lab collection to FM date/time 74 N ORTIME,ORDAY,AM,NOW,ENT 75 S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL" ;is referenced by DBIA #964 76 D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N") 77 S AM=$O(ORTIME(0)),NOW=$P($H,",",2) 78 S ORDAY=$S(AM=$O(ORTIME(NOW)):"T",1:"T+1") 79 S X=$$NEXTCOLL^ORCDLR1(ORDAY)_"@"_$P($G(ORTIME(+AM)),U) 80 Q 81 ; 82 ADMIN(START) ; -- Resolve next/closest administration times to FM date/time 83 N PAT,SCH,OI,LOC,Y,I 84 I $G(DA) D ;get data from order DA 85 . S PAT=+$P($G(^OR(100,DA,0)),U,2),LOC="" 86 . S I=+$O(^OR(100,DA,4.5,"ID","INSTR",0)),I=+$P($G(^OR(100,DA,4.5,I,0)),U,3) ;first 87 . S SCH=$$VALUE(DA,"SCHEDULE",I),OI=$$VALUE(DA,"ORDERABLE") 88 I '$G(DA) D ;or look in ORDIALOG() instead 89 . S I=+$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) 90 . S PAT=$G(ORVP),SCH=$G(ORDIALOG($$PTR^ORCD("OR GTX SCHEDULE"),I)) 91 . S OI=$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)),LOC="" 92 S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) ;PSOI 93 S Y=$$RESOLVE^PSJORPOE(PAT,SCH,OI,START,LOC),X=$P(Y,U,2) ;is referenced by DBIA #3167 94 Q 95 ; 96 SIGN(DA,WHO,WHEN,HOW,WHAT) ; -- affix ES to order 97 Q:'$G(DA) S:'$G(WHAT) WHAT=1 98 N X S X=$G(^OR(100,DA,8,WHAT,0)) D S2^ORDD100(DA,WHAT) ; kill AS xref 99 S $P(X,U,4,7)=$G(HOW)_U_$G(WHO)_U_$E($G(WHEN),1,12)_U_$S(HOW=0:DUZ,1:"") 100 ; S:$G(WHO) $P(X,U,3)=WHO ; reset provider to signer 101 S ^OR(100,DA,8,WHAT,0)=X 102 D:$G(HOW)=2 S1^ORDD100(DA,WHAT) ; reset AS xref 103 Q 104 ; 105 SIGSTS(IFN,ACT) ; -- Set SigSts for backdoor orders [Called from ^ORM* rtns] 106 ; Expects ORNATR, ORVP, ORNP to be defined 107 Q:'$G(IFN) Q:'$G(ACT) N X,OR0 S OR0=+$P($G(^OR(100,+IFN,8,ACT,0)),U) 108 S X=$S($$SIGNREQD^ORCACT1(+IFN):$$SIGSTS^ORX1(ORNATR),1:3) 109 K ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT) 110 S $P(^OR(100,+IFN,8,ACT,0),U,4)=X 111 I X=2 S ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)="" D NOTIF^ORCSIGN 112 Q 113 ; 114 UNVEIL(IFN) ; -- unveil new order 115 S $P(^OR(100,IFN,3),U,8)="" 116 Q 117 ; 118 DELETE(ORDER) ; -- delete order [action] 119 N DIK,DA,DAD 120 I $P(ORDER,";",2)>1 S DA=+$P(ORDER,";",2),DA(1)=+ORDER,DIK="^OR(100,"_DA(1)_",8," D:DA ^DIK Q 121 S DAD=+$P($G(^OR(100,+ORDER,3)),U,9) I DAD S DIK="^OR(100,"_DAD_",2,",DA(1)=DAD,DA=+ORDER D ^DIK ; remove link to child from parent 122 K DA S DA=+ORDER,DIK="^OR(100," D ^DIK ;remove order, text 123 Q 124 ; 125 VERIFY(IFN,DA,TYPE,WHO,WHEN) ; -- order verified 126 Q:'$G(IFN) Q:'$G(DA) Q:"^N^C^R^"'[(U_$G(TYPE)_U) 127 N FLD S FLD=$S(TYPE="N":8,TYPE="C":10,1:18) 128 S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) 129 S $P(^OR(100,IFN,8,DA,0),U,FLD,FLD+1)=WHO_U_WHEN 130 Q 131 ; 132 COMP(IFN,WHO,WHEN) ; -- order completed 133 Q:'$G(IFN) S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) 134 D DATES(+IFN,,WHEN),STATUS(+IFN,2) 135 S $P(^OR(100,+IFN,6),U,6,7)=WHEN_U_WHO 136 Q 137 ; 138 DATES(DA,START,STOP) ; -- Update start/stop dates for order DA 139 Q:'$G(DA) I $G(START) D 140 . Q:START=$P(^OR(100,DA,0),U,8) 141 . D SK^ORDD100,WK^ORDD100,OI2^ORDD100A(DA) 142 . S $P(^OR(100,DA,0),U,8)=START 143 . D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA) 144 I $G(STOP) D 145 . ;Q:STOP=$P(^OR(100,DA,0),U,9) ;ck xref anyway 146 . D EK^ORDD100A S $P(^OR(100,DA,0),U,9)=STOP D ES^ORDD100A 147 Q 148 ; 149 OC ; -- Save order checks in ORCHECK() in ^OR(100,+ORIFN,9) 150 Q:'$G(ORIFN) Q:'$D(^OR(100,+ORIFN,0)) K ^OR(100,+ORIFN,9) 151 N NOW,CNT,CDL,I,OC,OVERIDE S NOW=+$E($$NOW^XLFDT,1,12),CNT=0 152 S CDL=0 F S CDL=$O(ORCHECK(+ORIFN,CDL)) Q:CDL'>0 D 153 . S I=0 F S I=$O(ORCHECK(+ORIFN,CDL,I)) Q:I'>0 D 154 . . S OC=ORCHECK(+ORIFN,CDL,I) Q:'OC 155 . . S OVERIDE=$S($G(MODE)="NOTIF":$G(ORCHECK("OK"))_U,CDL=1:$G(ORCHECK("OK"))_U_DUZ,1:U_DUZ)_U_NOW 156 . . S CNT=CNT+1,^OR(100,+ORIFN,9,"B",+OC,CNT)="" 157 . . S ^OR(100,+ORIFN,9,CNT,0)=$P(OC,U,1,2)_U_U_OVERIDE,^(1)=$E($P(OC,U,3),1,245) 158 S:CNT ^OR(100,+ORIFN,9,0)="^100.09PA^"_CNT_U_CNT 159 Q 160 ; 161 VALUE(IFN,ID,INST) ; -- Returns value of prompt by identifier ID 162 I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q "" 163 N I,Y S I=0,Y="" S:'$G(INST) INST=1 164 F S I=$O(^OR(100,IFN,4.5,"ID",ID,I)) Q:I'>0 I $P($G(^OR(100,IFN,4.5,+I,0)),U,3)=INST S Y=$G(^(1)) Q 165 Q Y 166 ; 167 SC(ORX,ORIFN) ; -- save responses to SC questions 168 Q:'$G(ORIFN) Q:'$D(^OR(100,+ORIFN,0)) ;invalid order number 169 N OR5,I,P S OR5=$G(^OR(100,+ORIFN,5)),P=0 170 F I="SC","MST","AO","IR","EC","HNC","CV" S P=P+1 S:$D(ORX(I)) $P(OR5,U,P)=ORX(I) 171 S ^OR(100,+ORIFN,5)=OR5 172 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSEND.m
r613 r623 1 ORCSEND ;SLC/MKB-Release orders ; 11/8/2006 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,45,79,92,141,165,195,243**;Dec 17, 1997;Build 242 3 ; 4 EN(ORIFN,ACTION,SIGSTS,RELSTS,NATURE,REASON,ORERR) ; -- Release [actions on] orders 5 N ORDA,ORNOW,SIGNREQD,SIGNED,SIGNER 6 S SIGNREQD=+$P($G(^OR(100,+ORIFN,0)),U,16),ORERR="" 7 S SIGNED=$S(SIGSTS=2:0,1:1),SIGNER=$S(SIGSTS=1:DUZ,SIGSTS=7:DUZ,1:"") 8 S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN,ORNOW=+$E($$NOW^XLFDT,1,12) 9 S:"ES"[$G(ACTION) ACTION=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2) 10 I SIGNREQD,ORDA,"^NW^RW^XX^RN^DC^HD^RL^"[(U_ACTION_U) D ; sign/alert 11 . I 'SIGNED D NOTIF^ORCSIGN Q 12 . D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA) 13 . D:SIGSTS=4 CHART^ORCSIGN ; not used anymore 14 I '$L(ACTION) S ORERR="1^Invalid order action" Q 15 I $$READY(ORIFN,ORDA) D:$L($T(@ACTION)) @ACTION I 'ORERR,ACTION="NW" D 16 . N OREVT S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17) Q:OREVT<1 17 . I '$$EVTORDER^OREVNTX(ORIFN) D SAVE^ORMEVNT1(ORIFN,OREVT,2,"ES") 18 ; If order originated from the back door, send Dx and TxF back to ancil. 19 I SIGNED,$P($G(^OR(100,+ORIFN,3)),U,11)="P" D BDOEDIT^ORWDBA7 20 Q 21 ; 22 EN1(ORDER,ORERR) ; -- Delayed Release [from RELEASE^ORMEVNT] 23 ; 24 Q:$P($G(^OR(100,+ORDER,3)),U,3)'=10 25 N ORPKG,ORA0,ORNOW,ORIFN,ORDA,ORNP,ORNATR,ORQUIT,ORDUZ,SIGSTS,RELSTS 26 S ORPKG=$P($G(^OR(100,+ORDER,0)),U,14),ORA0=$G(^(8,1,0)) 27 S ORNOW=+$E($$NOW^XLFDT,1,12),ORIFN=+ORDER,ORDA=1,ORNP=$P(ORA0,U,3) 28 S SIGSTS=$P(ORA0,U,4),ORNATR=$P($G(^ORD(100.02,+$P(ORA0,U,12),0)),U,2) 29 S RELSTS=$S(SIGSTS'=2:1,"^V^P^"[(U_ORNATR_U):1,1:0) I RELSTS D 30 . D STARTDT^ORCSAVE2(ORIFN),PKGSTUFF^ORCSEND1(ORPKG) Q:$G(ORQUIT) 31 . S ORDUZ=$S(SIGSTS=0:$P(ORA0,U,7),SIGSTS=1:$P(ORA0,U,5),SIGSTS=2:$P(ORA0,U,17),SIGSTS=3:$P(ORA0,U,13),1:DUZ) 32 . D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORDUZ),NEW^ORMBLD(ORIFN) 33 . I "^10^13^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) S ORERR=1 ;error 34 I 'RELSTS!$G(ORERR),$P($G(^OR(100,ORIFN,3)),U,3)=10 D STATUS^ORCSAVE2(ORIFN,11) S $P(^OR(100,ORIFN,8,1,0),U,15)=11 35 Q 36 ; 37 EN2(ORIFN,SIGSTS,NATURE,ORERR) ; -- Manual Release [from OREVNT1,SENDED^ORWDX] 38 N ORDA,ORNOW,OREVT,ORA0,ORNP,SIGNREQD,SIGNED,RELSTS 39 S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN S:ORDA<1 ORDA=1 40 S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17),ORA0=$G(^(8,ORDA,0)) 41 S ORNP=$P(ORA0,U,3),SIGNREQD=($P(ORA0,U,4)'=3),(SIGNED,RELSTS)=1 42 S ORNOW=+$E($$NOW^XLFDT,1,12),ORERR="" I $P(ORA0,U,4)=2 D ;needs ES 43 . N SIGNER S SIGNER=$S(SIGSTS=1:DUZ,1:"") 44 . I SIGSTS=2 D NOTIF^ORCSIGN S SIGNED=0 Q ;still unsigned 45 . D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA) 46 D NW I 'ORERR D SAVE^ORMEVNT1(+ORIFN,OREVT,2,"MN") 47 Q 48 ; 49 NW ; -- New order ORIFN 50 RW ; -- Rewritten order ORIFN 51 XX ; -- Changed order ORIFN 52 RN ; -- Renewed order ORIFN 53 N ORQUIT,STS,TYPE,OR0,OR3,CODE,ORIG,ORSAVE 54 N IVDIEN,IVPKGM 55 S IVPKGM=0 56 S IVDIEN=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE","")) 57 I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG,OREBUILD=1 Q 58 S:'ORDA ORDA=1 S ORSAVE=ORIFN 59 S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)) D STARTDT^ORCSAVE2(ORIFN) 60 S TYPE=$P(OR3,U,11),ORIG=+$P(OR3,U,5),CODE="NW" 61 I TYPE=1,ORIG,$D(^OR(100,ORIG,4)) S CODE="XO",^OR(100,ORIG,6)=$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW 62 I $$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSJ" S IVPKGM=1 63 I IVPKGM=1,$P($P(OR0,U,5),";")=IVDIEN D PSJI^ORCSEND3 Q:$G(ORQUIT) 64 I IVPKGM=0!($P($P(OR0,U,5),";")'=IVDIEN) D PKGSTUFF^ORCSEND1(+$P(OR0,U,14)) Q:$G(ORQUIT) 65 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) 66 D NEW^ORMBLD(ORIFN,CODE) S ORIFN=ORSAVE,STS=$P($G(^OR(100,ORIFN,3)),U,3) 67 I (STS=1)!(STS=13) S ORERR="1^"_$$WHY(ORIFN,1) D:'SIGNED&SIGNREQD NOSIG K:ORIG ^OR(100,ORIG,6) 68 I STS=11 S ORERR="1^ERROR" 69 Q 70 ; 71 DC ; -- DC order ORIFN 72 N PKG,CODE,ORCHLD,ORCHDA,STS,ORIDA,ORSAVE,OR3,OR6,DCNATURE 73 I '$G(REASON),$G(NATURE)="D" S REASON=+$O(^ORD(100.03,"C","ORDUP",0)) 74 S:$G(REASON) $P(^OR(100,ORIFN,6),U,1,5)=$S($G(NATURE):NATURE,$L($G(NATURE)):$O(^ORD(100.02,"C",NATURE,0)),1:"")_"^^^"_+REASON_U_$P(^ORD(100.03,+REASON,0),U) 75 I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q 76 S $P(^OR(100,ORIFN,6),U,2,3)=$S($G(DGPMT):"",1:DUZ)_U_ORNOW,ORSAVE=ORIFN S:'$G(REASON) REASON=$P(^(6),U,4) 77 S STS=$P($G(^OR(100,ORIFN,3)),U,3),PKG=$P($G(^(0)),U,14),PKG=$$NMSP^ORCD(PKG),CODE=$S(PKG="LR":"CA",(PKG="PS")&(STS=5):"CA",(PKG="FH")&(STS=8):"CA",1:"DC") 78 D:ORDA RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) 79 DC1 I $O(^OR(100,ORIFN,2,0)) D G DC2 ; DC children 80 . S ORCHLD=0 F S ORCHLD=$O(^OR(100,ORIFN,2,ORCHLD)) Q:ORCHLD'>0 I $$VALID^ORCACT0(ORCHLD,"DC") D Q:$G(ORERR) 81 . . S ORCHDA=$S(ORDA:$$ACTION^ORCSAVE("DC",ORCHLD,ORNP),1:0) 82 . . D:ORCHDA SIGN^ORCSAVE2(ORCHLD,,,8,ORCHDA) ;Sig on Parent only 83 . . D MSG^ORMBLD((ORCHLD_";"_ORCHDA),CODE,$G(REASON)) 84 . . I "^1^13^"'[(U_$P(^OR(100,ORCHLD,3),U,3)_U) S ORERR="1^"_$$WHY(ORCHLD,ORCHDA) 85 . ;D:'$G(ORERR) STATUS^ORCSAVE2(ORIFN,1) 86 . S:$G(ORERR) ^OR(100,ORIFN,8,ORDA,1)=$P(ORERR,U,2) 87 D MSG^ORMBLD((ORIFN_";"_ORDA),CODE,$G(REASON)) 88 DC2 S ORIFN=ORSAVE,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3) 89 S OR6=$G(^OR(100,ORIFN,6)) 90 I STS'=1,STS'=13,STS'=2 D Q 91 . S ORERR="1^"_$S(ORDA:$$WHY(ORIFN,ORDA),1:"Unable to discontinue") 92 . I ORDA,'SIGNED&SIGNREQD D NOSIG ; sig no longer reqd 93 . K ^OR(100,ORIFN,6) 94 S DCNATURE=$S(+OR6:+OR6,1:$G(NATURE)) 95 S $P(^OR(100,ORIFN,3),U,7)=$S('$$ACTV^ORX1($G(DCNATURE)):0,1:$P(OR3,U,7)) 96 D CANCEL(ORIFN),SETALL^ORDD100(ORIFN) 97 I $P(OR3,U,11)=2 D ; dc a renewal 98 . N ORIG,ORIG3,NATR S ORIG=$P(OR3,U,5),ORIG3=$G(^OR(100,ORIG,3)) Q:'ORIG 99 . ;I CODE="CA",+$P(OR6,U,9)'>0 S $P(^OR(100,ORIG,3),U,6)="" Q ;pend - remove fwd ptr 100 . I +$P(OR6,U,9)'>0 S $P(^OR(100,ORIG,3),U,6)="" Q ;pend - remove fwd ptr 101 . Q:"^1^7^12^13^"[(U_$P(ORIG3,U,3)_U) S NATR=$O(^ORD(100.02,"C","A",0)) 102 . S ^OR(100,ORIG,6)=NATR_U_DUZ_U_ORNOW_"^^Renewal cancelled" 103 . D MSG^ORMBLD(ORIG,"DC") I "^1^13^"'[$P(^OR(100,ORIG,3),U,3) K ^(6) Q 104 . S:'$$ACTV^ORX1(NATR) $P(^OR(100,ORIG,3),U,7)=0 105 Q 106 ; 107 CANCEL(IFN) ; -- Cancel any outstanding actions for order IFN 108 N I S I=0 109 F S I=$O(^OR(100,IFN,8,I)) Q:I'>0 I $P(^(I,0),U,15)=11 S $P(^(0),U,15)=13 D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,I) ; cancelled, sig not reqd now 110 Q 111 ; 112 HD ; -- Hold order ORIFN 113 N STS,ORSAVE I 'ORDA S ORERR="1^Unable to hold" Q 114 I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q 115 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) 116 S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"HD") S ORIFN=ORSAVE 117 S STS=$P($G(^OR(100,ORIFN,3)),U,3) I STS=3 S $P(^(3),U,7)=ORDA D SET^ORDD100(ORIFN,ORDA) 118 I STS'=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG 119 Q 120 ; 121 RL ; -- Release hold on order ORIFN 122 N STS,ORSAVE,ORHD I 'ORDA S ORERR="1^Unable to release hold" Q 123 I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q 124 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) 125 S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"RL") S ORIFN=ORSAVE 126 S STS=$P($G(^OR(100,ORIFN,3)),U,3),ORHD=+$P($G(^(3)),U,7) 127 I STS'=3 S $P(^OR(100,ORIFN,3),U,7)=ORDA,$P(^(8,ORHD,2),U,1,2)=ORNOW_U_DUZ D SET^ORDD100(ORIFN,ORDA) 128 I STS=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG 129 Q 130 ; 131 FL ; -- Flag order ORIFN 132 Q 133 ; 134 UF ; -- Unflag order ORIFN 135 Q 136 ; 137 CM ; -- Add Ward comments to order ORIFN 138 Q 139 ; 140 VR ; -- Verify order ORIFN 141 I 'ORDA!(SIGSTS=2) S ORERR="1^Unable to verify" Q 142 I "^N^C^R^"'[(U_$G(ORVER)_U) S ORERR="1^Unable to verify" Q 143 D VERIFY^ORCSAVE2(ORIFN,ORDA,ORVER,DUZ,ORNOW) 144 ; -- send HL7 msg to Pharmacy if Nurse-Verified, [Sts=pending] 145 Q:ORVER'="N" N ORSTS,ORPKG,ORX 146 S ORX=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2) Q:ORX'="NW"&(ORX'="XX") 147 S ORPKG=+$P($G(^OR(100,ORIFN,0)),U,14),ORSTS=$P($G(^(3)),U,3) 148 ;I ORSTS=5!$L($T(ZV^ORMPS)),$$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN) 149 I $$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN) 150 Q 151 ; 152 NEEDSIG() ; -- Msg 153 Q "1^This order requires a signature." 154 ; 155 WHY(IFN,DA) ; -- Return reason request was rejected 156 N X S X=$G(^OR(100,IFN,8,DA,1)) 157 S:'$L(X) X="Unable to "_$S(ACTION="HD":"hold",ACTION="RL":"release hold",ACTION="DC":"discontinue",ACTION="XX":"change",ACTION="RN":"renew",1:"release") 158 Q X 159 ; 160 NOSIG ; -- Mark order as Sig not Req'd due to cancel/reject 161 D SIGN^ORCSAVE2(ORIFN,"","",5,ORDA) S SIGNREQD=0 162 Q 163 ; 164 READY(IFN,ACT) ; -- Ready to release? 165 N X,Y,OR0,OR3,ORA 166 I ACTION="VR" S Y=1 G RQ ; no action to release 167 I 'ACT,ACTION="DC" S Y=1 G RQ ; cancel a duplicate 168 S Y=0,OR0=$G(^OR(100,IFN,0)),OR3=$G(^(3)),ORA=$G(^(8,ACT,0)) 169 I $P(ORA,U,15)=11 S Y=1 G RQ ; unreleased 170 I $P(ORA,U,15)=10 D G RQ ; delayed 171 . I $G(^DPT(+ORVP,.105)),$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO" S Y=1 Q 172 . Q:'RELSTS N ORIG S ORIG=+$P(OR3,U,5) 173 . I 'SIGNED,$L($G(NATURE)) S $P(ORA,U,17)=DUZ,$P(ORA,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0))),^OR(100,IFN,8,ACT,0)=ORA 174 . Q:$P(OR3,U,11)'=1!('ORIG) ;dc original if signed edit 175 . D STATUS^ORCSAVE2(ORIG,12) 176 . S ^OR(100,ORIG,6)=+$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW 177 . S $P(^OR(100,ORIG,3),U,7)=0,$P(^(8,1,0),U,15)=12 D:$P($G(^(0)),U,4)=2 SIGN^ORCSAVE2(ORIG,,,5,1) 178 I $P(OR3,U,3)=11,$P(ORA,U,2)="NW" S Y=1 ; Action Sts = "" (old) 179 RQ I +$$SWSTAT^IBBAPI() D:Y=1 EN^ORWPFSS4(+IFN) ; Associate PFSS Account Reference with order, Patch OR*3.0*228 IA #4663 180 Q Y 1 ORCSEND ;SLC/MKB-Release orders ; 08 May 2002 2:12 PM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,45,79,92,141,165,195,228**;Dec 17, 1997 3 ; 4 EN(ORIFN,ACTION,SIGSTS,RELSTS,NATURE,REASON,ORERR) ; -- Release [actions on] orders 5 N ORDA,ORNOW,SIGNREQD,SIGNED,SIGNER 6 S SIGNREQD=+$P($G(^OR(100,+ORIFN,0)),U,16),ORERR="" 7 S SIGNED=$S(SIGSTS=2:0,1:1),SIGNER=$S(SIGSTS=1:DUZ,SIGSTS=7:DUZ,1:"") 8 S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN,ORNOW=+$E($$NOW^XLFDT,1,12) 9 S:"ES"[$G(ACTION) ACTION=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2) 10 I SIGNREQD,ORDA,"^NW^RW^XX^RN^DC^HD^RL^"[(U_ACTION_U) D ; sign/alert 11 . I 'SIGNED D NOTIF^ORCSIGN Q 12 . D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA) 13 . D:SIGSTS=4 CHART^ORCSIGN ; not used anymore 14 I '$L(ACTION) S ORERR="1^Invalid order action" Q 15 I $$READY(ORIFN,ORDA) D:$L($T(@ACTION)) @ACTION I 'ORERR,ACTION="NW" D 16 . N OREVT S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17) Q:OREVT<1 17 . I '$$EVTORDER^OREVNTX(ORIFN) D SAVE^ORMEVNT1(ORIFN,OREVT,2,"ES") 18 ; If order originated from the back door, send Dx and TxF back to ancil. 19 I SIGNED,$P($G(^OR(100,+ORIFN,3)),U,11)="P" D BDOEDIT^ORWDBA7 20 Q 21 ; 22 EN1(ORDER,ORERR) ; -- Delayed Release [from RELEASE^ORMEVNT] 23 ; 24 Q:$P($G(^OR(100,+ORDER,3)),U,3)'=10 25 N ORPKG,ORA0,ORNOW,ORIFN,ORDA,ORNP,ORNATR,ORQUIT,ORDUZ,SIGSTS,RELSTS 26 S ORPKG=$P($G(^OR(100,+ORDER,0)),U,14),ORA0=$G(^(8,1,0)) 27 S ORNOW=+$E($$NOW^XLFDT,1,12),ORIFN=+ORDER,ORDA=1,ORNP=$P(ORA0,U,3) 28 S SIGSTS=$P(ORA0,U,4),ORNATR=$P($G(^ORD(100.02,+$P(ORA0,U,12),0)),U,2) 29 S RELSTS=$S(SIGSTS'=2:1,"^V^P^"[(U_ORNATR_U):1,1:0) 30 I RELSTS D 31 . D STARTDT^ORCSAVE2(ORIFN),PKGSTUFF^ORCSEND1(ORPKG) Q:$G(ORQUIT) 32 . S ORDUZ=$S(SIGSTS=0:$P(ORA0,U,7),SIGSTS=1:$P(ORA0,U,5),SIGSTS=2:$P(ORA0,U,17),SIGSTS=3:$P(ORA0,U,13),1:DUZ) 33 . D EDO1^ORWPFSS1 ;PFSS Event Delayed Orders 34 . D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORDUZ),NEW^ORMBLD(ORIFN) 35 . I "^10^13^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) S ORERR=1 ;error 36 I 'RELSTS!$G(ORERR),$P($G(^OR(100,ORIFN,3)),U,3)=10 D STATUS^ORCSAVE2(ORIFN,11) S $P(^OR(100,ORIFN,8,1,0),U,15)=11 37 Q 38 ; 39 EN2(ORIFN,SIGSTS,NATURE,ORERR) ; -- Manual Release [from OREVNT1,SENDED^ORWDX] 40 N ORDA,ORNOW,OREVT,ORA0,ORNP,SIGNREQD,SIGNED,RELSTS 41 S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN S:ORDA<1 ORDA=1 42 S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17),ORA0=$G(^(8,ORDA,0)) 43 S ORNP=$P(ORA0,U,3),SIGNREQD=($P(ORA0,U,4)'=3),(SIGNED,RELSTS)=1 44 S ORNOW=+$E($$NOW^XLFDT,1,12),ORERR="" 45 I $P(ORA0,U,4)=2 D ;needs ES 46 . N SIGNER S SIGNER=$S(SIGSTS=1:DUZ,1:"") 47 . I SIGSTS=2 D NOTIF^ORCSIGN S SIGNED=0 Q ;still unsigned 48 . D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA) 49 D EDO2^ORWPFSS1 ;PFSS Event Delayed Orders 50 D NW I 'ORERR D SAVE^ORMEVNT1(+ORIFN,OREVT,2,"MN") 51 Q 52 ; 53 NW ; -- New order ORIFN 54 RW ; -- Rewritten order ORIFN 55 XX ; -- Changed order ORIFN 56 RN ; -- Renewed order ORIFN 57 N ORQUIT,STS,TYPE,OR0,OR3,CODE,ORIG,ORSAVE 58 I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG,OREBUILD=1 Q 59 S:'ORDA ORDA=1 S ORSAVE=ORIFN 60 S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)) D STARTDT^ORCSAVE2(ORIFN) 61 S TYPE=$P(OR3,U,11),ORIG=+$P(OR3,U,5),CODE="NW" 62 I TYPE=1,ORIG,$D(^OR(100,ORIG,4)) S CODE="XO",^OR(100,ORIG,6)=$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW 63 D PKGSTUFF^ORCSEND1(+$P(OR0,U,14)) Q:$G(ORQUIT) 64 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) 65 D NEW^ORMBLD(ORIFN,CODE) S ORIFN=ORSAVE,STS=$P($G(^OR(100,ORIFN,3)),U,3) 66 I (STS=1)!(STS=13) S ORERR="1^"_$$WHY(ORIFN,1) D:'SIGNED&SIGNREQD NOSIG K:ORIG ^OR(100,ORIG,6) 67 I STS=11 S ORERR="1^ERROR" 68 Q 69 ; 70 DC ; -- DC order ORIFN 71 N PKG,CODE,ORCHLD,ORCHDA,STS,ORIDA,ORSAVE,OR3 72 I '$G(REASON),$G(NATURE)="D" S REASON=+$O(^ORD(100.03,"C","ORDUP",0)) 73 S:$G(REASON) ^OR(100,ORIFN,6)=$S($G(NATURE):NATURE,$L($G(NATURE)):$O(^ORD(100.02,"C",NATURE,0)),1:"")_"^^^"_+REASON_U_$P(^ORD(100.03,+REASON,0),U) 74 I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q 75 S $P(^OR(100,ORIFN,6),U,2,3)=$S($G(DGPMT):"",1:DUZ)_U_ORNOW,ORSAVE=ORIFN S:'$G(REASON) REASON=$P(^(6),U,4) 76 S STS=$P($G(^OR(100,ORIFN,3)),U,3),PKG=$P($G(^(0)),U,14),PKG=$$NMSP^ORCD(PKG),CODE=$S(PKG="LR":"CA",(PKG="PS")&(STS=5):"CA",(PKG="FH")&(STS=8):"CA",1:"DC") 77 D:ORDA RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) 78 DC1 I $O(^OR(100,ORIFN,2,0)) D G DC2 ; DC children 79 . S ORCHLD=0 F S ORCHLD=$O(^OR(100,ORIFN,2,ORCHLD)) Q:ORCHLD'>0 I $$VALID^ORCACT0(ORCHLD,"DC") D Q:$G(ORERR) 80 . . S ORCHDA=$S(ORDA:$$ACTION^ORCSAVE("DC",ORCHLD,ORNP),1:0) 81 . . D:ORCHDA SIGN^ORCSAVE2(ORCHLD,,,"",ORCHDA) ;Sig on Parent only 82 . . D MSG^ORMBLD((ORCHLD_";"_ORCHDA),CODE,$G(REASON)) 83 . . I "^1^13^"'[(U_$P(^OR(100,ORCHLD,3),U,3)_U) S ORERR="1^"_$$WHY(ORCHLD,ORCHDA) 84 . ;D:'$G(ORERR) STATUS^ORCSAVE2(ORIFN,1) 85 . S:$G(ORERR) ^OR(100,ORIFN,8,ORDA,1)=$P(ORERR,U,2) 86 D MSG^ORMBLD((ORIFN_";"_ORDA),CODE,$G(REASON)) 87 DC2 S ORIFN=ORSAVE,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3) 88 I STS'=1,STS'=13,STS'=2 D Q 89 . S ORERR="1^"_$S(ORDA:$$WHY(ORIFN,ORDA),1:"Unable to discontinue") 90 . I ORDA,'SIGNED&SIGNREQD D NOSIG ; sig no longer reqd 91 . K ^OR(100,ORIFN,6) 92 S $P(^OR(100,ORIFN,3),U,7)=$S(ORDA:ORDA,'$$ACTV^ORX1($G(NATURE)):0,1:$P(OR3,U,7)) 93 D CANCEL(ORIFN),SETALL^ORDD100(ORIFN) 94 I $P(OR3,U,11)=2 D ; dc a renewal 95 . N ORIG,ORIG3,NATR S ORIG=$P(OR3,U,5),ORIG3=$G(^OR(100,ORIG,3)) Q:'ORIG 96 . I CODE="CA" S $P(^OR(100,ORIG,3),U,6)="" Q ;pend - remove fwd ptr 97 . Q:"^1^7^12^13^"[(U_$P(ORIG3,U,3)_U) S NATR=$O(^ORD(100.02,"C","A",0)) 98 . S ^OR(100,ORIG,6)=NATR_U_DUZ_U_ORNOW_"^^Renewal cancelled" 99 . D MSG^ORMBLD(ORIG,"DC") I "^1^13^"'[$P(^OR(100,ORIG,3),U,3) K ^(6) Q 100 . S:'$$ACTV^ORX1(NATR) $P(^OR(100,ORIG,3),U,7)=0 101 Q 102 ; 103 CANCEL(IFN) ; -- Cancel any outstanding actions for order IFN 104 N I S I=0 105 F S I=$O(^OR(100,IFN,8,I)) Q:I'>0 I $P(^(I,0),U,15)=11 S $P(^(0),U,15)=13 D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,I) ; cancelled, sig not reqd now 106 Q 107 ; 108 HD ; -- Hold order ORIFN 109 N STS,ORSAVE I 'ORDA S ORERR="1^Unable to hold" Q 110 I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q 111 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) 112 S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"HD") S ORIFN=ORSAVE 113 S STS=$P($G(^OR(100,ORIFN,3)),U,3) I STS=3 S $P(^(3),U,7)=ORDA D SET^ORDD100(ORIFN,ORDA) 114 I STS'=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG 115 Q 116 ; 117 RL ; -- Release hold on order ORIFN 118 N STS,ORSAVE,ORHD I 'ORDA S ORERR="1^Unable to release hold" Q 119 I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q 120 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) 121 S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"RL") S ORIFN=ORSAVE 122 S STS=$P($G(^OR(100,ORIFN,3)),U,3),ORHD=+$P($G(^(3)),U,7) 123 I STS'=3 S $P(^OR(100,ORIFN,3),U,7)=ORDA,$P(^(8,ORHD,2),U,1,2)=ORNOW_U_DUZ D SET^ORDD100(ORIFN,ORDA) 124 I STS=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG 125 Q 126 ; 127 FL ; -- Flag order ORIFN 128 Q 129 ; 130 UF ; -- Unflag order ORIFN 131 Q 132 ; 133 CM ; -- Add Ward comments to order ORIFN 134 Q 135 ; 136 VR ; -- Verify order ORIFN 137 I 'ORDA!(SIGSTS=2) S ORERR="1^Unable to verify" Q 138 I "^N^C^R^"'[(U_$G(ORVER)_U) S ORERR="1^Unable to verify" Q 139 D VERIFY^ORCSAVE2(ORIFN,ORDA,ORVER,DUZ,ORNOW) 140 ; -- send HL7 msg to Pharmacy if Nurse-Verified, [Sts=pending] 141 Q:ORVER'="N" N ORSTS,ORPKG,ORX 142 S ORX=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2) Q:ORX'="NW"&(ORX'="XX") 143 S ORPKG=+$P($G(^OR(100,ORIFN,0)),U,14),ORSTS=$P($G(^(3)),U,3) 144 ;I ORSTS=5!$L($T(ZV^ORMPS)),$$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN) 145 I $$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN) 146 Q 147 ; 148 NEEDSIG() ; -- Msg 149 Q "1^This order requires a signature." 150 ; 151 WHY(IFN,DA) ; -- Return reason request was rejected 152 N X S X=$G(^OR(100,IFN,8,DA,1)) 153 S:'$L(X) X="Unable to "_$S(ACTION="HD":"hold",ACTION="RL":"release hold",ACTION="DC":"discontinue",ACTION="XX":"change",ACTION="RN":"renew",1:"release") 154 Q X 155 ; 156 NOSIG ; -- Mark order as Sig not Req'd due to cancel/reject 157 D SIGN^ORCSAVE2(ORIFN,"","",5,ORDA) S SIGNREQD=0 158 Q 159 ; 160 READY(IFN,ACT) ; -- Ready to release? 161 N X,Y,OR0,OR3,ORA 162 I ACTION="VR" S Y=1 G RQ ; no action to release 163 I 'ACT,ACTION="DC" S Y=1 G RQ ; cancel a duplicate 164 S Y=0,OR0=$G(^OR(100,IFN,0)),OR3=$G(^(3)),ORA=$G(^(8,ACT,0)) 165 I $P(ORA,U,15)=11 S Y=1 G RQ ; unreleased 166 I $P(ORA,U,15)=10 D G RQ ; delayed 167 . I $G(^DPT(+ORVP,.105)),$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO" S Y=1 Q 168 . Q:'RELSTS N ORIG S ORIG=+$P(OR3,U,5) 169 . I 'SIGNED,$L($G(NATURE)) S $P(ORA,U,17)=DUZ,$P(ORA,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0))),^OR(100,IFN,8,ACT,0)=ORA 170 . Q:$P(OR3,U,11)'=1!('ORIG) ;dc original if signed edit 171 . D STATUS^ORCSAVE2(ORIG,12) 172 . S ^OR(100,ORIG,6)=+$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW 173 . S $P(^OR(100,ORIG,3),U,7)=0,$P(^(8,1,0),U,15)=12 D:$P($G(^(0)),U,4)=2 SIGN^ORCSAVE2(ORIG,,,5,1) 174 I $P(OR3,U,3)=11,$P(ORA,U,2)="NW" S Y=1 ; Action Sts = "" (old) 175 RQ I Y=1 D EN^ORWPFSS4(+IFN) ; Associate PFSS Account Reference with order, Patch OR*3.0*228 176 Q Y -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSEND1.m
r613 r623 1 ORCSEND1 ;SLC/MKB-Release cont ;11/22/06 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,45,61,79,94,116,138,158,149,187,215,243**;Dec 17, 1997;Build 242 3 ; 4 PKGSTUFF(PKG) ; Package code 5 S PKG=$$GET1^DIQ(9.4,+PKG_",",1) Q:'$L(PKG) 6 D:$L($T(@PKG)) @PKG 7 Q 8 LR ; Spawn child orders if continuous schedule 9 N ORSTRT,ORPARENT,OR0,ORNP,ORDIALOG,ORL,ORX,ORTIME,ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE,ORPCOLL,ORS1,ORS2,P,ORCHLD,ORDG,ORLAST,ORDUZ,ORLOG,ORCOLLCT,STS 10 S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),ORL=$P(OR0,U,10) 11 D SCHEDULE(ORIFN,"LR",.ORSTRT) I ORSTRT'>1 D Q 12 . N START S START=$O(ORSTRT(0)) Q:START=$P($G(^OR(100,+ORIFN,0)),U,8) 13 . D DATES^ORCSAVE2(+ORIFN,START) ;update start date from schedule 14 S ORNP=+$P(OR0,U,4),ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7),ORDG=+$P(OR0,U,11) 15 D GETDLG1^ORCD(ORDIALOG),GETORDER(ORIFN),GETIMES^ORCDLR1 16 K ORDIALOG($$PTR^ORCD("OR GTX ADMIN SCHEDULE"),1),ORDIALOG($$PTR^ORCD("OR GTX DURATION"),1) 17 S ORPITEM=$$PTR^ORCD("OR GTX ORDERABLE ITEM") 18 S ORPSAMP=$$PTR^ORCD("OR GTX COLLECTION SAMPLE") 19 S ORPSPEC=$$PTR^ORCD("OR GTX SPECIMEN") 20 S ORPURG=$$PTR^ORCD("OR GTX LAB URGENCY") 21 S ORPCOMM=$$PTR^ORCD("OR GTX WORD PROCESSING 1") 22 S ORPTYPE=$$PTR^ORCD("OR GTX COLLECTION TYPE") 23 S ORPCOLL=$$PTR^ORCD("OR GTX START DATE/TIME") 24 LR1 S ORS1=0 F S ORS1=$O(ORX(ORS1)) Q:ORS1'>0 D 25 . F P=ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE S ORDIALOG(P,1)=$G(ORX(ORS1,P)) ;set values to next instance 26 . S ORCOLLCT=$G(ORDIALOG(ORPTYPE,1)) 27 . S ORS2=0 F S ORS2=$O(ORSTRT(ORS2)) Q:ORS2'>0 D 28 .. S ORDIALOG(ORPCOLL,1)=ORS2 ;,ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12) 29 .. I ORCOLLCT="LC" S ORDIALOG(ORPTYPE,1)=$S($$LABCOLL^ORCDLR1(ORS2):"LC",1:"WC") 30 .. I ORCOLLCT="I" S ORDIALOG(ORPTYPE,1)=$S($$IMMCOLL^ORCDLR1(ORS2):"I",1:"WC") 31 .. D CHILD^ORCSEND3() 32 S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD 33 S ORIFN=ORPARENT,ORQUIT=1,STS=$P(^OR(100,ORIFN,3),U,3) 34 I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders" 35 D RELEASE^ORCSAVE2(ORPARENT,1,ORNOW,DUZ,$G(NATURE)) 36 Q 37 SCHEDULE(IFN,PKG,ORY,STRT) ; Returns list of start time(s) from schedule 38 N I,X,PSJSD,PSJFD,PSJW,PSJNE,PSJPP,PSJX,PSJAT,PSJM,PSJTS,PSJY,PSJAX,PSJSCH,PSJOSD,PSJOFD,PSJC,ORDUR 39 S PSJSD=$S(+$G(STRT):STRT,1:$P($G(^OR(100,+IFN,0)),U,8)) I 'PSJSD S ORY=-1 Q 40 S ORY=1,ORY(PSJSD)="" ;1st occurrance 41 S I=$O(^OR(100,+IFN,4.5,"ID","SCHEDULE",0)) Q:'I Q:'$L($G(PKG)) 42 S X=$G(^OR(100,+IFN,4.5,I,1)),PSJX=$S(X:$$GET1^DIQ(51.1,+X_",",.01),1:X) 43 S PSJW=+$G(ORL),PSJNE="",PSJPP=PKG D ENSV^PSJEEU Q:'$L($G(PSJX)) 44 I $G(PSJTS)'="C",$G(PSJTS)'="D" Q ;not continuous or day-of-week 45 S PSJSCH=PSJX,I=$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) Q:'I 46 S ORDUR=$G(^OR(100,+IFN,4.5,+I,1)) 47 S:ORDUR PSJFD=$$FMADD^XLFDT(PSJSD,+ORDUR,,-1) 48 I 'ORDUR S X=+$E(ORDUR,2,9) D 49 . I PSJM S PSJFD=$$FMADD^XLFDT(PSJSD,,,(PSJM*X)-1) ;X_#times 50 . E D ;no freq in minutes --> day of week 51 .. N DAYS,LOCMX,SCHMX 52 .. S LOCMX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q") 53 .. K ^TMP($J,"ORCSEND1 SCHEDULE") 54 .. D ZERO^PSS51P1(PSJY,,,,"ORCSEND1 SCHEDULE") 55 .. S SCHMX=+$G(^TMP($J,"ORCSEND1 SCHEDULE",PSJY,2.5)) 56 .. K ^TMP($J,"ORCSEND1 SCHEDULE") 57 .. ;S SCHMX=$P(^PS(51.1,PSJY,0),U,7) 58 .. S DAYS=$S('SCHMX:LOCMX,LOCMX<SCHMX:LOCMX,1:SCHMX) 59 .. S PSJFD=$$FMADD^XLFDT(PSJSD,DAYS,,-1) 60 D ENSPU^PSJEEU K ORY 61 I ORDUR M ORY=PSJC Q 62 S ORY=$S(PSJC<$E(ORDUR,2,9):PSJC,1:$E(ORDUR,2,9)) 63 N NXT 64 S NXT=0 F I=1:1:ORY S NXT=$O(PSJC(NXT)) Q:'NXT S ORY(NXT)=PSJC(NXT) 65 Q 66 GETORDER(IFN) ; Set ORX(Inst,Ptr)=Value 67 N I,X,Y,PTR,INST,TYPE 68 S I=0 F S I=$O(^OR(100,IFN,4.5,I)) Q:I'>0 S X=$G(^(I,0)),Y=$G(^(1)) D 69 . S PTR=+$P(X,U,2),INST=+$P(X,U,3),TYPE=$P($G(^ORD(101.41,PTR,1)),U) 70 . I TYPE'="W" S ORX(INST,PTR)=Y Q 71 . S ORX(INST,PTR)="^OR(100,"_IFN_",4.5,"_I_",2)" 72 Q 73 PTR(X) ; Returns ptr of prompt X in Order Dialog file 74 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0)) 75 PS ; spawn child orders if multiple doses 76 PSJ ; (Inpt only) 77 PSS ; 78 N ORPARENT,OR0,ORNP,ORDIALOG,ORDUZ,ORLOG,ORL,ORDG,ORCAT,ORX,ORP,ORI,STS 79 N ORDOSE,ORT,ORSCH,ORDUR,ORSTRT,ORFRST,ORCONJ,ORID,ORDD,ORSTR,ORDGNM 80 N ORSTART,ORCHLD,ORLAST,ORSIG,OROI,ID,OR3,ORIG,CODE,ORPKG,ORENEW,I,ORADMIN 81 S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORPARENT,0)),OR3=$G(^(3)) 82 Q:$P(OR0,U,12)'="I" S ORCAT="I",ORNP=+$P(OR0,U,4) 83 S ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7) 84 S ORL=$P(OR0,U,10),ORDG=+$P(OR0,U,11),ORPKG=+$P(OR0,U,14) 85 D GETDLG1^ORCD(ORDIALOG),GETORDER(ORPARENT) 86 S ORDOSE=$$PTR("INSTRUCTIONS"),ORT=$$PTR("ROUTE") 87 S ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION") 88 S ORCONJ=$$PTR("AND/THEN") D STRT S ORSTART=$G(ORSTRT("BEG")) 89 S ORADMIN=$$PTR("ADMIN TIMES") 90 D DATES^ORCSAVE2(ORPARENT,ORSTART) Q:$$DOSES(ORPARENT)'>1 91 S ORFRST=$$PTR("NOW"),ORSIG=$$PTR("SIG") 92 S ORID=$$PTR("DOSE"),ORDD=$$PTR("DISPENSE DRUG") 93 S ORSTR=$$PTR("STRENGTH"),ORDGNM=$$PTR("DRUG NAME") 94 I $P(OR3,U,11)=2,$O(^OR(100,+$P(OR3,U,5),2,0)) D 95 . S ORENEW=+$P(OR3,U,5),I=0 96 . I $$VALUE^ORX8(ORENEW,"NOW") S I=$O(^OR(100,ORENEW,2,0)) 97 . F S I=$O(^OR(100,ORENEW,2,I)) Q:I<1 S ORENEW(I)="" 98 PS1 F ORP="ORDERABLE ITEM","URGENCY","WORD PROCESSING 1" D 99 . N PTR S PTR=$$PTR(ORP) Q:PTR'>0 Q:'$D(ORX(1,PTR)) 100 . S ORDIALOG(PTR,1)=ORX(1,PTR) S:$E(ORP)="O" OROI=ORX(1,PTR) 101 S ORI=$$FRSTDOSE I $G(ORX(1,ORFRST)) D 102 . F ORP=ORDOSE,ORT,ORID S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP) 103 . S ID=$G(ORX(ORI,ORID)) S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6) 104 . S ORDIALOG(ORSCH,1)="NOW",ORSTART=$$NOW^XLFDT 105 . D SIG,CHILD^ORCSEND3(ORSTART) 106 F D S ORI=$O(ORX(ORI)) Q:ORI'>0 107 . F ORP=ORDOSE,ORT,ORSCH,ORDUR,ORID,ORADMIN S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP) K:'$D(ORX(ORI,ORP)) ORDIALOG(ORP,1) 108 . K ORDIALOG(ORDD,1) S ID=$G(ORX(ORI,ORID)) 109 . S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6) 110 . S ORSTART=$G(ORSTRT(ORI)) 111 . D SIG,CHILD^ORCSEND3(ORSTART) 112 S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD 113 S ORIFN=ORPARENT,ORQUIT=1,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3) 114 I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders" 115 D RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$G(NATURE)) K ^TMP("ORWORD",$J) 116 S $P(^OR(100,ORIFN,3),U,8)=1 ;veil parent order - set stop date/time? 117 Q:(STS=1)!(STS=13)!(STS=11) ;unsuccessful 118 PS2 ; ck if parent is unsigned or edit 119 I $P($G(^OR(100,ORIFN,8,1,0)),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;clear ES 120 Q:$P(OR3,U,11)'=1 S ORIG=$P(OR3,U,5) Q:ORIG'>0 121 S CODE=$S($P($G(^OR(100,ORIG,3)),U,3)=5:"CA",1:"DC") 122 D MSG^ORMBLD(ORIG,CODE) I "^1^13^"[(U_$P($G(^OR(100,ORIG,3)),U,3)_U) D 123 . N NATR S NATR=+$O(^ORD(100.02,"C","C",0)) 124 . S $P(^OR(100,ORIG,3),U,3)=12,$P(^(3),U,7)=0,^(6)=NATR_U_DUZ_U_ORNOW 125 . D CANCEL^ORCSEND(ORIG) ;ck for unrel actions 126 Q 127 DOSES(IFN) ; count number of doses in order 128 N I,CNT S CNT=0 129 S I=0 F S I=$O(^OR(100,+$G(IFN),4.5,"ID","INSTR",I)) Q:I'>0 I $L($G(^OR(100,+$G(IFN),4.5,I,1))) S CNT=CNT+1 130 S I=+$O(^OR(100,+$G(IFN),4.5,"ID","NOW",0)) I I,$G(^OR(100,+$G(IFN),4.5,I,1)) S CNT=CNT+1 131 Q CNT 132 FRSTDOSE() ; Return instance of first dose 133 N I,Y S I=0,Y=1 134 F S I=$O(ORX(I)) Q:I'>0 I $D(ORX(I,ORDOSE)) S Y=I Q 135 Q Y 136 SIG ; Build text of instructions 137 N ORDRUG,ID,DOSE,ORI,ORX K ^TMP("ORWORD",$J,ORSIG,1) 138 S ORDRUG=$G(ORDIALOG(ORDD,1)),ID=$G(ORDIALOG(ORID,1)) 139 S DOSE=$G(ORDIALOG(ORDOSE,1)),ORI=1 140 S ORX=$$DOSE^ORCDPS2_$$RTE^ORCDPS2_$$SCH^ORCDPS2_$$DUR^ORCDPS2 141 S ^TMP("ORWORD",$J,ORSIG,1,0)="^^1^1^"_DT_U,^(1,0)=ORX 142 S ORDIALOG(ORSIG,1)=$NA(^TMP("ORWORD",$J,ORSIG,1)) 143 S ORDIALOG(ORDOSE,"FORMAT")="@" 144 K ORDIALOG(ORSTR,1),ORDIALOG(ORDGNM,1) 145 I ORDRUG,'ID D ;set strength or drug name 146 . N STR,ITM S STR=$P(ID,"&",7)_$P(ID,"&",8) 147 . I STR'>0 S ORDIALOG(ORDGNM,1)=$$GET1^DIQ(50,+ORDRUG_",",.01) Q 148 . S ITM=$P($G(^ORD(101.43,+$G(OROI),0)),U) 149 . S:ITM'[STR ORDIALOG(ORSTR,1)=STR 150 Q 151 STRT ; Build ORSTRT(inst)=date.time array of start times by dose 152 N OI,PSOI,XD,XH,XM,XS,ORWD,ORI,SCH,ORSD,X,ORD K ORSTRT 153 S OI=$G(ORX(1,$$PTR^ORCD("OR GTX ORDERABLE ITEM"))) 154 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),(XD,XH,XM,XS)=0 155 S ORWD=+$G(^SC(+$G(ORL),42)) ;ward 156 S ORI=0 F S ORI=$O(ORX(ORI)) Q:ORI<1 D 157 . S SCH=$G(ORX(ORI,ORSCH)),ORSD="" S:'$L(SCH) X=$$NOW^XLFDT 158 . S:$L(SCH) ORSD=$$STARTSTP^PSJORPOE(+ORVP,SCH,PSOI,ORWD),X=$P(ORSD,U,4) 159 . S ORSTRT(ORI)=$$FMADD^XLFDT(X,XD,XH,XM,XS) ;START+OFFSET 160 . ; update OFFSET for next THEN dose 161 . D DUR(ORI) I $G(ORX(ORI,ORCONJ))="T" D 162 .. I $G(ORD("XD"))<1,$G(ORD("XH"))<1,$G(ORD("XM"))<1,$G(ORD("XS"))<1 S ORD("XD")=+$P(ORSD,U,3) ;default duration 163 .. N I,Y F I="XD","XH","XM","XS" S Y=@I,@I=Y+$G(ORD(I)) 164 .. K ORD 165 ; find beginning date.time for parent 166 S ORI=0,X=9999999 F S ORI=$O(ORSTRT(ORI)) Q:ORI<1 I ORSTRT(ORI)<X S X=ORSTRT(ORI) 167 S ORSTRT("BEG")=X 168 Q 169 DUR(I) ; Accumulate duration in ORD("Xt") for offsetting next THEN dose 170 N X,Y S X=$$FMDUR^ORCDPS3($G(ORX(I,ORDUR))) 171 I X["S",+X>$G(ORD("XS")) S ORD("XS")=+X 172 I X["'",+X>$G(ORD("XM")) S ORD("XM")=+X 173 I X["H",+X>$G(ORD("XH")) S ORD("XH")=+X 174 S Y=$S(X["D":+X,X["W":+X*7,X["M":+X*30,1:0) 175 I Y,Y>$G(ORD("XD")) S ORD("XD")=Y 176 Q 177 VBEC ; Spawn VBECS children 178 D:$L($T(EN^ORCSEND2)) EN^ORCSEND2 179 Q 1 ORCSEND1 ;SLC/MKB-Release cont ;11/25/02 09:48 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,45,61,79,94,116,138,158,149,187,215**;Dec 17, 1997 3 ; 4 PKGSTUFF(PKG) ; Package code 5 S PKG=$$GET1^DIQ(9.4,+PKG_",",1) Q:'$L(PKG) 6 D:$L($T(@PKG)) @PKG 7 Q 8 LR ; Spawn child orders if continuous schedule 9 N ORSTRT,ORPARENT,OR0,ORNP,ORDIALOG,ORL,ORX,ORTIME,ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE,ORPCOLL,ORS1,ORS2,P,ORCHLD,ORDG,ORLAST,ORDUZ,ORLOG,ORCOLLCT,STS 10 S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),ORL=$P(OR0,U,10) 11 D SCHEDULE(ORIFN,"LR",.ORSTRT) I ORSTRT'>1 D Q 12 . N START S START=$O(ORSTRT(0)) Q:START=$P($G(^OR(100,+ORIFN,0)),U,8) 13 . D DATES^ORCSAVE2(+ORIFN,START) ;update start date from schedule 14 S ORNP=+$P(OR0,U,4),ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7),ORDG=+$P(OR0,U,11) 15 D GETDLG1^ORCD(ORDIALOG),GETORDER(ORIFN),GETIMES^ORCDLR1 16 K ORDIALOG($$PTR^ORCD("OR GTX ADMIN SCHEDULE"),1),ORDIALOG($$PTR^ORCD("OR GTX DURATION"),1) 17 S ORPITEM=$$PTR^ORCD("OR GTX ORDERABLE ITEM") 18 S ORPSAMP=$$PTR^ORCD("OR GTX COLLECTION SAMPLE") 19 S ORPSPEC=$$PTR^ORCD("OR GTX SPECIMEN") 20 S ORPURG=$$PTR^ORCD("OR GTX LAB URGENCY") 21 S ORPCOMM=$$PTR^ORCD("OR GTX WORD PROCESSING 1") 22 S ORPTYPE=$$PTR^ORCD("OR GTX COLLECTION TYPE") 23 S ORPCOLL=$$PTR^ORCD("OR GTX START DATE/TIME") 24 LR1 S ORS1=0 F S ORS1=$O(ORX(ORS1)) Q:ORS1'>0 D 25 . F P=ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE S ORDIALOG(P,1)=$G(ORX(ORS1,P)) ;set values to next instance 26 . S ORCOLLCT=$G(ORDIALOG(ORPTYPE,1)) 27 . S ORS2=0 F S ORS2=$O(ORSTRT(ORS2)) Q:ORS2'>0 D 28 .. S ORDIALOG(ORPCOLL,1)=ORS2 ;,ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12) 29 .. I ORCOLLCT="LC" S ORDIALOG(ORPTYPE,1)=$S($$LABCOLL^ORCDLR1(ORS2):"LC",1:"WC") 30 .. I ORCOLLCT="I" S ORDIALOG(ORPTYPE,1)=$S($$IMMCOLL^ORCDLR1(ORS2):"I",1:"WC") 31 .. D CHILD() 32 S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD 33 S ORIFN=ORPARENT,ORQUIT=1,STS=$P(^OR(100,ORIFN,3),U,3) 34 I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders" 35 D RELEASE^ORCSAVE2(ORPARENT,1,ORNOW,DUZ,$G(NATURE)) 36 Q 37 SCHEDULE(IFN,PKG,ORY,STRT) ; Returns list of start time(s) from schedule 38 N I,X,PSJSD,PSJFD,PSJW,PSJNE,PSJPP,PSJX,PSJAT,PSJM,PSJTS,PSJY,PSJAX,PSJSCH,PSJOSD,PSJOFD,PSJC,ORDUR 39 S PSJSD=$S(+$G(STRT):STRT,1:$P($G(^OR(100,+IFN,0)),U,8)) I 'PSJSD S ORY=-1 Q 40 S ORY=1,ORY(PSJSD)="" ;1st occurrance 41 S I=$O(^OR(100,+IFN,4.5,"ID","SCHEDULE",0)) Q:'I Q:'$L($G(PKG)) 42 S X=$G(^OR(100,+IFN,4.5,I,1)),PSJX=$S(X:$$GET1^DIQ(51.1,+X_",",.01),1:X) 43 S PSJW=+$G(ORL),PSJNE="",PSJPP=PKG D ENSV^PSJEEU Q:'$L($G(PSJX)) 44 I $G(PSJTS)'="C",$G(PSJTS)'="D" Q ;not continuous or day-of-week 45 S PSJSCH=PSJX,I=$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) Q:'I 46 S ORDUR=$G(^OR(100,+IFN,4.5,+I,1)) 47 S:ORDUR PSJFD=$$FMADD^XLFDT(PSJSD,+ORDUR,,-1) 48 I 'ORDUR S X=+$E(ORDUR,2,9) D 49 . I PSJM S PSJFD=$$FMADD^XLFDT(PSJSD,,,(PSJM*X)-1) ;X_#times 50 . E D ;no freq in minutes --> day of week 51 .. N DAYS,LOCMX,SCHMX 52 .. S LOCMX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q") 53 .. S SCHMX=$P(^PS(51.1,PSJY,0),U,7) 54 .. S DAYS=$S('SCHMX:LOCMX,LOCMX<SCHMX:LOCMX,1:SCHMX) 55 .. S PSJFD=$$FMADD^XLFDT(PSJSD,DAYS,,-1) 56 D ENSPU^PSJEEU K ORY 57 I ORDUR M ORY=PSJC Q 58 S ORY=$S(PSJC<$E(ORDUR,2,9):PSJC,1:$E(ORDUR,2,9)) 59 N NXT 60 S NXT=0 F I=1:1:ORY S NXT=$O(PSJC(NXT)) Q:'NXT S ORY(NXT)=PSJC(NXT) 61 Q 62 GETORDER(IFN) ; Set ORX(Inst,Ptr)=Value 63 N I,X,Y,PTR,INST,TYPE 64 S I=0 F S I=$O(^OR(100,IFN,4.5,I)) Q:I'>0 S X=$G(^(I,0)),Y=$G(^(1)) D 65 . S PTR=+$P(X,U,2),INST=+$P(X,U,3),TYPE=$P($G(^ORD(101.41,PTR,1)),U) 66 . I TYPE'="W" S ORX(INST,PTR)=Y Q 67 . S ORX(INST,PTR)="^OR(100,"_IFN_",4.5,"_I_",2)" 68 Q 69 PTR(X) ; Returns ptr of prompt X in Order Dialog file 70 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0)) 71 CHILD(STRT) ; Create child order, send to package 72 N ORAPPT 73 K ORIFN D EN^ORCSAVE Q:'$G(ORIFN) D STARTDT^ORCSAVE2(ORIFN) 74 I $G(STRT) D DATES^ORCSAVE2(ORIFN,STRT) 75 S ORCHLD=+$G(ORCHLD)+1,^OR(100,ORPARENT,2,ORIFN,0)=ORIFN,ORLAST=ORIFN 76 S ORAPPT=$P($G(^OR(100,ORPARENT,0)),U,18) 77 S $P(^OR(100,ORIFN,0),U,18)=ORAPPT,$P(^(3),U,9)=ORPARENT 78 I $G(PKG)="LR" S $P(^OR(100,ORIFN,8,1,0),U,4)=8 K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;signature tracked on parent order only, for Labs 79 I $G(PKG)?1"PS".E D 80 . N X0,OLD S X0=$G(^OR(100,ORPARENT,8,1,0)) 81 . I $P(X0,U,4)'=2 D SIGN^ORCSAVE2(ORIFN,+$P(X0,U,5),ORNOW,$P(X0,U,4),1) 82 . I $D(^OR(100,ORPARENT,9)) M ^OR(100,ORIFN,9)=^OR(100,ORPARENT,9) 83 . I $G(ORENEW) S OLD=$O(ORENEW(0)) I OLD S $P(^OR(100,OLD,3),U,6)=ORIFN,$P(^OR(100,ORIFN,3),U,5)=OLD,$P(^(3),U,11)=2 K ORENEW(OLD) 84 D RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$G(NATURE)),NEW^ORMBLD(ORIFN) 85 Q 86 PS ; spawn child orders if multiple doses 87 PSJ ; (Inpt only) 88 PSS ; 89 N ORPARENT,OR0,ORNP,ORDIALOG,ORDUZ,ORLOG,ORL,ORDG,ORCAT,ORX,ORP,ORI,STS 90 N ORDOSE,ORT,ORSCH,ORDUR,ORSTRT,ORFRST,ORCONJ,ORID,ORDD,ORSTR,ORDGNM 91 N ORSTART,ORCHLD,ORLAST,ORSIG,OROI,ID,OR3,ORIG,CODE,ORPKG,ORENEW,I 92 S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORPARENT,0)),OR3=$G(^(3)) 93 Q:$P(OR0,U,12)'="I" S ORCAT="I",ORNP=+$P(OR0,U,4) 94 S ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7) 95 S ORL=$P(OR0,U,10),ORDG=+$P(OR0,U,11),ORPKG=+$P(OR0,U,14) 96 D GETDLG1^ORCD(ORDIALOG),GETORDER(ORPARENT) 97 S ORDOSE=$$PTR("INSTRUCTIONS"),ORT=$$PTR("ROUTE") 98 S ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION") 99 S ORCONJ=$$PTR("AND/THEN") D STRT S ORSTART=$G(ORSTRT("BEG")) 100 D DATES^ORCSAVE2(ORPARENT,ORSTART) Q:$$DOSES(ORPARENT)'>1 101 S ORFRST=$$PTR("NOW"),ORSIG=$$PTR("SIG") 102 S ORID=$$PTR("DOSE"),ORDD=$$PTR("DISPENSE DRUG") 103 S ORSTR=$$PTR("STRENGTH"),ORDGNM=$$PTR("DRUG NAME") 104 I $P(OR3,U,11)=2,$O(^OR(100,+$P(OR3,U,5),2,0)) D 105 . S ORENEW=+$P(OR3,U,5),I=0 106 . I $$VALUE^ORX8(ORENEW,"NOW") S I=$O(^OR(100,ORENEW,2,0)) 107 . F S I=$O(^OR(100,ORENEW,2,I)) Q:I<1 S ORENEW(I)="" 108 PS1 F ORP="ORDERABLE ITEM","URGENCY","WORD PROCESSING 1" D 109 . N PTR S PTR=$$PTR(ORP) Q:PTR'>0 Q:'$D(ORX(1,PTR)) 110 . S ORDIALOG(PTR,1)=ORX(1,PTR) S:$E(ORP)="O" OROI=ORX(1,PTR) 111 S ORI=$$FRSTDOSE I $G(ORX(1,ORFRST)) D 112 . F ORP=ORDOSE,ORT,ORID S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP) 113 . S ID=$G(ORX(ORI,ORID)) S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6) 114 . S ORDIALOG(ORSCH,1)="NOW",ORSTART=$$NOW^XLFDT 115 . D SIG,CHILD(ORSTART) 116 F D S ORI=$O(ORX(ORI)) Q:ORI'>0 117 . F ORP=ORDOSE,ORT,ORSCH,ORDUR,ORID S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP) K:'$D(ORX(ORI,ORP)) ORDIALOG(ORP,1) 118 . K ORDIALOG(ORDD,1) S ID=$G(ORX(ORI,ORID)) 119 . S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6) 120 . S ORSTART=$G(ORSTRT(ORI)) 121 . D SIG,CHILD(ORSTART) 122 S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD 123 S ORIFN=ORPARENT,ORQUIT=1,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3) 124 I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders" 125 D RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$G(NATURE)) K ^TMP("ORWORD",$J) 126 S $P(^OR(100,ORIFN,3),U,8)=1 ;veil parent order - set stop date/time? 127 Q:(STS=1)!(STS=13)!(STS=11) ;unsuccessful 128 PS2 ; ck if parent is unsigned or edit 129 I $P($G(^OR(100,ORIFN,8,1,0)),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;clear ES 130 Q:$P(OR3,U,11)'=1 S ORIG=$P(OR3,U,5) Q:ORIG'>0 131 S CODE=$S($P($G(^OR(100,ORIG,3)),U,3)=5:"CA",1:"DC") 132 D MSG^ORMBLD(ORIG,CODE) I "^1^13^"[(U_$P($G(^OR(100,ORIG,3)),U,3)_U) D 133 . N NATR S NATR=+$O(^ORD(100.02,"C","C",0)) 134 . S $P(^OR(100,ORIG,3),U,3)=12,$P(^(3),U,7)=0,^(6)=NATR_U_DUZ_U_ORNOW 135 . D CANCEL^ORCSEND(ORIG) ;ck for unrel actions 136 Q 137 DOSES(IFN) ; count number of doses in order 138 N I,CNT S CNT=0 139 S I=0 F S I=$O(^OR(100,+$G(IFN),4.5,"ID","INSTR",I)) Q:I'>0 I $L($G(^OR(100,+$G(IFN),4.5,I,1))) S CNT=CNT+1 140 S I=+$O(^OR(100,+$G(IFN),4.5,"ID","NOW",0)) I I,$G(^OR(100,+$G(IFN),4.5,I,1)) S CNT=CNT+1 141 Q CNT 142 FRSTDOSE() ; Return instance of first dose 143 N I,Y S I=0,Y=1 144 F S I=$O(ORX(I)) Q:I'>0 I $D(ORX(I,ORDOSE)) S Y=I Q 145 Q Y 146 SIG ; Build text of instructions 147 N ORDRUG,ID,DOSE,ORI,ORX K ^TMP("ORWORD",$J,ORSIG,1) 148 S ORDRUG=$G(ORDIALOG(ORDD,1)),ID=$G(ORDIALOG(ORID,1)) 149 S DOSE=$G(ORDIALOG(ORDOSE,1)),ORI=1 150 S ORX=$$DOSE^ORCDPS2_$$RTE^ORCDPS2_$$SCH^ORCDPS2_$$DUR^ORCDPS2 151 S ^TMP("ORWORD",$J,ORSIG,1,0)="^^1^1^"_DT_U,^(1,0)=ORX 152 S ORDIALOG(ORSIG,1)=$NA(^TMP("ORWORD",$J,ORSIG,1)) 153 S ORDIALOG(ORDOSE,"FORMAT")="@" 154 K ORDIALOG(ORSTR,1),ORDIALOG(ORDGNM,1) 155 I ORDRUG,'ID D ;set strength or drug name 156 . N STR,ITM S STR=$P(ID,"&",7)_$P(ID,"&",8) 157 . I STR'>0 S ORDIALOG(ORDGNM,1)=$$GET1^DIQ(50,+ORDRUG_",",.01) Q 158 . S ITM=$P($G(^ORD(101.43,+$G(OROI),0)),U) 159 . S:ITM'[STR ORDIALOG(ORSTR,1)=STR 160 Q 161 STRT ; Build ORSTRT(inst)=date.time array of start times by dose 162 N OI,PSOI,XD,XH,XM,XS,ORWD,ORI,SCH,ORSD,X,ORD K ORSTRT 163 S OI=$G(ORX(1,$$PTR^ORCD("OR GTX ORDERABLE ITEM"))) 164 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),(XD,XH,XM,XS)=0 165 S ORWD=+$G(^SC(+$G(ORL),42)) ;ward 166 S ORI=0 F S ORI=$O(ORX(ORI)) Q:ORI<1 D 167 . S SCH=$G(ORX(ORI,ORSCH)),ORSD="" S:'$L(SCH) X=$$NOW^XLFDT 168 . S:$L(SCH) ORSD=$$STARTSTP^PSJORPOE(+ORVP,SCH,PSOI,ORWD),X=$P(ORSD,U,4) 169 . S ORSTRT(ORI)=$$FMADD^XLFDT(X,XD,XH,XM,XS) ;START+OFFSET 170 . ; update OFFSET for next THEN dose 171 . D DUR(ORI) I $G(ORX(ORI,ORCONJ))="T" D 172 .. I $G(ORD("XD"))<1,$G(ORD("XH"))<1,$G(ORD("XM"))<1,$G(ORD("XS"))<1 S ORD("XD")=+$P(ORSD,U,3) ;default duration 173 .. N I,Y F I="XD","XH","XM","XS" S Y=@I,@I=Y+$G(ORD(I)) 174 .. K ORD 175 ; find beginning date.time for parent 176 S ORI=0,X=9999999 F S ORI=$O(ORSTRT(ORI)) Q:ORI<1 I ORSTRT(ORI)<X S X=ORSTRT(ORI) 177 S ORSTRT("BEG")=X 178 Q 179 DUR(I) ; Accumulate duration in ORD("Xt") for offsetting next THEN dose 180 N X,Y S X=$$FMDUR^ORCDPS3($G(ORX(I,ORDUR))) 181 I X["S",+X>$G(ORD("XS")) S ORD("XS")=+X 182 I X["'",+X>$G(ORD("XM")) S ORD("XM")=+X 183 I X["H",+X>$G(ORD("XH")) S ORD("XH")=+X 184 S Y=$S(X["D":+X,X["W":+X*7,X["M":+X*30,1:0) 185 I Y,Y>$G(ORD("XD")) S ORD("XD")=Y 186 Q 187 VBEC ; Spawn VBECS children 188 D:$L($T(EN^ORCSEND2)) EN^ORCSEND2 189 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCXPND1.m
r613 r623 1 ORCXPND1 ; SLC/MKB - Expanded Display cont ; 04/25/2007 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,67,75,89,92,94,148,159,188,172,215,243**;Dec 17, 1997;Build 242 3 ; 4 ; External References 5 ; DBIA 2387 ^LAB(60 6 ; DBIA 3420 ^DPT( file #2 7 ; DBIA 10035 ^DPT( file #2 8 ; DBIA 10037 EN^DGRPD 9 ; DBIA 700 DIS^DGRPDB 10 ; DBIA 2926 RT^GMRCGUIA 11 ; DBIA 2925 DT^GMRCSLM2 ^TMP("GMRCR" 12 ; DBIA 2503 RR^LR7OR1 ^TMP("LRRR" 13 ; DBIA 2951 EN1^LR7OSBR ^TMP("LRC" 14 ; DBIA 2952 EN^LR7OSMZ0 15 ; DBIA 2400 OEL^PSOORRL ^TMP("PS" 16 ; DBIA 2877 EN3^RAO7PC3 17 ; DBIA 2877 EN30^RAO7PC3 18 ; DBIA 1252 $$OUTPTPR^SDUTL3 19 ; DBIA 1252 $$OUTPTTM^SDUTL3 20 ; DBIA 2832 RPC^TIUSRV 21 ; DBIA 10061 DEM^VADPT 22 ; DBIA 10061 KVAR^VADPT 23 ; DBIA 10061 OAD^VADPT 24 ; DBIA 10103 $$FMTE^XLFDT 25 ; DBIA 4408 DISP^DGIBDSP 26 ; 27 COVER ; -- Cover Sheet 28 N PKG S PKG=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4) 29 D ALLERGY^ORCXPND2:PKG="GMRA",NOTES:PKG="TIU" 30 Q 31 NOTES ; -- Progress Notes 32 N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J) 33 D RPC^TIUSRV(.ORY,ID) 34 S I=0 F S I=$O(@ORY@(I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0)) 35 K @ORY 36 Q 37 PROBLEMS ; -- Problem List 38 D PL^ORCXPND4 39 Q 40 MEDS ; -- Pharmacy 41 ;N NODE,ORIFN 42 K ^TMP("PS",$J) 43 D OEL^PSOORRL(+ORVP,ID) ;S NODE=$G(^TMP("PS",$J,0)),ORIFN=+$P(NODE,U,11) 44 S ID=+$P($G(^TMP("PS",$J,0)),U,11) D ORDERS ;DBIA 2400 45 ;D @($S($P($G(^OR(100,ORIFN,0)),U,11)=$O(^ORD(100.98,"B","IV RX",0)):"IV",1:"DRUG")_"^ORCXPND2") 46 K ^TMP("PS",$J) 47 Q 48 LABS ; -- Laboratory [RESULTS ONLY for ID=OE order #] 49 N ORIFN,X,SUB,TEST,NAME,SS,IDE,IVDT,TST,CCNT,ORCY,IG,TCNT 50 K ^TMP("LRRR",$J) ;DBIA 2503 51 I (ID?2.5U1" "2N1" "1.N1"-"7N1"."1.4N)!(ID?2.5U1" "2N1" "1.N1"-"7N) D AP^ORCXPND3 Q ;ID=Accession #-Date/time specimen taken 52 S ORIFN=+ID,IDE=$G(^OR(100,+ID,4)) Q:'$L(IDE) ; OE# -> Lab# 53 I +IDE D RR^LR7OR1(+ORVP,IDE) I '$D(^TMP("LRRR",$J,+ORVP)) S $P(IDE,";",1,3)=";;" ;Order possibly purged, reset to lookup on file 63 54 I '+IDE,$P(IDE,";",5) D RR^LR7OR1(+ORVP,,9999999-$P(IDE,";",5),9999999-$P(IDE,";",5),$P(IDE,";",4)) 55 K ORCY D TEXT^ORQ12(.ORCY,ORIFN,80) 56 S IG=0 F S IG=$O(ORCY(IG)) Q:IG<1 S X=ORCY(IG) D ITEM^ORCXPND(X) 57 D BLANK^ORCXPND I '$D(^TMP("LRRR",$J,+ORVP)) S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q 58 M TEST=^TMP("LRRR",$J,+ORVP) S CCNT=0,SS="" 59 F S SS=$O(TEST(SS)) Q:SS="" S IVDT=0 F S IVDT=$O(TEST(SS,IVDT)) Q:'IVDT D 60 . I SS="BB" D 61 .. I $$GET^XPAR("DIV^SYS^PKG","OR VBECS ON",1,"Q"),$L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface 62 ... K ^TMP("ORLRC",$J) 63 ... D EN^ORWLR1(DFN) 64 ... I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..." 65 ... N I S I=0 F S I=$O(^TMP("ORLRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X 66 ... K ^TMP("ORLRC",$J) 67 .. K ^TMP("LRC",$J) D EN1^LR7OSBR(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q ;DBIA 2951 68 ... N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X 69 ... K ^TMP("LRC",$J) 70 . I SS="MI" K ^TMP("LRC",$J) D EN^LR7OSMZ0(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q 71 .. N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X 72 .. K ^TMP("LRC",$J) 73 . I SS="CH" D Q 74 .. S (TCNT,TST)=0 F S TST=$O(TEST(SS,IVDT,TST)) Q:TST="" S CCNT=0,TCNT=TCNT+1 D 75 ... I TCNT=1 D 76 .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Collection time: "_$$FMTE^XLFDT(9999999-IVDT,1) 77 .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT," ")_$$S(3,CCNT,"Test Name")_$$S(29,CCNT,"Result")_$$S(39,CCNT,"Units")_$$S(55,CCNT,"Range") D:$D(IOUON) SETVIDEO^ORCXPND(LCNT,1,70,IOUON,IOUOFF) 78 ... I TST S X=TEST(SS,IVDT,TST),CCNT=0 I +X D 79 .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT,$P(^LAB(60,+X,0),U))_$$S(26,CCNT,$J($P(X,U,2),7))_$$S(34,CCNT,$S($L($P(X,U,3)):$P(X,U,3),1:""))_$$S(39,CCNT,$P(X,U,4))_$$S(45,CCNT,$J($P(X,U,5),15)) 80 .... I $L($P(X,U,3)),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOINHI,IOINORM) 81 .... I $P(X,U,3)["*",$D(IOBON),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOBON_IOINHI,IOBOFF_IOINORM) 82 ... I TST="N" S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Comments: " D 83 .... N CMT S CMT=0 F S CMT=$O(TEST(SS,IVDT,"N",CMT)) Q:'CMT S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" "_TEST(SS,IVDT,"N",CMT) 84 K ^TMP("LRRR",$J) 85 Q 86 ; 87 DELAY ; -- Delayed Orders 88 NEW ; -- New Orders 89 ORDERS ; -- Orders 90 I '$G(ORESULTS) D ORDERS^ORCXPND2 Q 91 ; -- Results Display (Add more packages as available) 92 N PKG,TAB,ORIFN 93 S PKG=+$P($G(^OR(100,+ID,0)),"^",14),PKG=$$NMSP^ORCD(PKG) 94 S TAB=$S(PKG="LR":"LABS",PKG="GMRC":"CONSULTS",PKG="RA":"XRAYS",1:"") 95 I '$L(TAB)!(ID'>0) D Q ; no display available 96 . N ORY,I D TEXT^ORQ12(.ORY,+ID,80) 97 . S I=0 F S I=$O(ORY(I)) Q:I'>0 D ITEM^ORCXPND(ORY(I)) 98 . D BLANK^ORCXPND 99 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="There are no results to report." 100 I $O(^OR(100,+ID,2,0)) S ORIFN=+ID,ID=0 F S ID=$O(^OR(100,ORIFN,2,ID)) Q:ID<1 I $D(^OR(100,ID,0)) D @TAB 101 I '$O(^OR(100,+ID,2,0)) D @TAB 102 Q 103 REPORTS ; -- Patient Profiles 104 D EN^ORCXPNDR ; Reports 105 Q 106 CONSULTS ; -- Consults 107 N I,X,SUB,ORTX ;,VALMAR 108 I $G(ORTAB)="CONSULTS" S X=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4) 109 E D TEXT^ORQ12(.ORTX,+ID) S X=ORTX(1),ID=+$G(^OR(100,+ID,4)) ; OE->GMRC order# 110 D ITEM^ORCXPND(X),BLANK^ORCXPND 111 I ID'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q 112 I '$G(ORESULTS) D ;DT action 113 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Consult No.: "_ID 114 . N GMRCOER S GMRCOER=2 D DT^GMRCSLM2(ID) S SUB="DT" ;DBIA 2925 115 I $G(ORESULTS) D RT^GMRCGUIA(ID,"^TMP(""GMRCR"",$J,""RT"")") S SUB="RT" 116 S I=0 F S I=$O(^TMP("GMRCR",$J,SUB,I)) Q:I'>0 S X=$G(^(I,0)),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;DBIA 2925 117 K ^TMP("GMRCR",$J) 118 Q 119 XRAYS ; -- Radiology 120 I '$G(ORESULTS) S ID=+ORVP_U_$TR(ID,"-","^") D EN3^RAO7PC3(ID) 121 I $G(ORESULTS) S ID=+$G(^OR(100,+ID,4)) D EN30^RAO7PC3(ID) 122 N CASE,PROC,PSET S PSET=$D(^TMP($J,"RAE3",+ORVP,"PRINT_SET")) 123 S CASE=0 F S CASE=$O(^TMP($J,"RAE3",+ORVP,CASE)) Q:CASE'>0 D 124 . I PSET S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,"")) D ITEM^ORCXPND(PROC) Q 125 . S PROC="" F S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC)) Q:PROC="" D ITEM^ORCXPND(PROC),BLANK^ORCXPND,XRPT,BLANK^ORCXPND 126 I PSET S CASE=$O(^TMP($J,"RAE3",+ORVP,0)),PROC=$O(^(CASE,"")) D BLANK^ORCXPND,XRPT,BLANK^ORCXPND ;printset=list all procs, then one report 127 K ^TMP($J,"RAE3",+ORVP),^UTILITY($J,"W") 128 S VALM("RM")=81 129 Q 130 ; 131 XRPT ; -- Body of Report for CASE, PROC 132 N ORD,X,I 133 S ORD=$S($L($G(^TMP($J,"RAE3",+ORVP,"ORD"))):^("ORD"),$L($G(^("ORD",CASE))):^(CASE),1:"") I $L(ORD),ORD'=PROC S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Proc Ord: "_ORD 134 S I=1 F S I=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC,I)) Q:I'>0 S X=^(I),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;Skip pt ID on line 1 135 Q 136 ; 137 SUMMRIES ; -- Discharge Summaries 138 N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J) 139 D RPC^TIUSRV(.ORY,ID) 140 S I=0 F S I=$O(@ORY@(I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0)) 141 K @ORY 142 Q 143 PTINQ ; Print Patient Inquiry in List Manager 144 N DFN,ORI,X 145 S DFN=+ORVP 146 D DGINQ(DFN) 147 S ORI=4,LCNT=0 148 F S ORI=$O(^TMP("ORDATA",$J,1,ORI)) Q:'ORI S X=^(ORI) D 149 . S LCNT=LCNT+1 150 . S ^TMP("ORXPND",$J,LCNT,0)=X 151 K ^TMP("ORDATA",$J,1) 152 Q 153 ; 154 DGINQ(DFN) ; Patient Inquiry 155 D START^ORWRP(80,"DGINQB^ORCXPND1(DFN)") 156 Q 157 DGINQB(DFN) ; Build Patient Inquiry 158 N CONTACT,ORDOC,ORTEAM,ORVP,XQORNOD,ORSSTRT,ORSSTOPT,VAOA 159 S ORVP=DFN_";DPT(",XQORNOD=1 160 D EN^DGRPD ; MAS Patient Inquiry 161 ; 162 S ORDOC=$$OUTPTPR^SDUTL3(DFN) 163 S ORTEAM=$$OUTPTTM^SDUTL3(DFN) 164 I ORDOC!ORTEAM D 165 . W !!,"Primary Care Information:" 166 . I ORDOC W !,"Primary Practitioner: ",$P(ORDOC,"^",2) 167 . I ORTEAM W !,"Primary Care Team: ",$P(ORTEAM,"^",2) 168 W !!,"Health Insurance Information:" 169 D DISP^DGIBDSP ;DBIA #4408 170 W !!,"Service Connection/Rated Disabilities:" 171 D DIS^DGRPDB 172 F CONTACT="N","S" D 173 .S VAOA("A")=$S(CONTACT="N":"",1:3) 174 .D OAD^VADPT ; Get NOK Information 175 .I VAOA(9)]"" D 176 .. W !!,$S(CONTACT="N":"Next of Kin Information:",1:"Secondary Next of Kin Information:") 177 .. W !,"Name: ",VAOA(9) ; NOK Name 178 .. I VAOA(10)]"" W " (",VAOA(10),")" ; Relationship 179 .. I VAOA(1)]"" W !?7,VAOA(1) ; Address Line 1 180 .. I VAOA(2)]"" W !?7,VAOA(2) ; Line 2 181 .. I VAOA(3)]"" W !?7,VAOA(3) ; Line 3 182 .. I VAOA(4)]"" D 183 .. . W !?7,VAOA(4) ; City 184 .. . I VAOA(5)]"" W ", "_$P(VAOA(5),"^",2) ; State 185 .. . W " ",$P(VAOA(11),"^",2) ; Zip+4 186 .. I VAOA(8)]"" W !!?7,"Phone number: ",VAOA(8) ; Phone 187 .. I CONTACT="N",$P($G(^DPT(DFN,.21)),U,11)]"" W !?7,"Work phone number: ",$P(^DPT(DFN,.21),U,11) 188 .. I CONTACT="S",$P($G(^DPT(DFN,.211)),U,11)]"" W !?7,"Work phone number: ",$P(^DPT(DFN,.211),U,11) 189 D KVAR^VADPT 190 Q 191 TRIM(X) ; Trim Spaces 192 S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X)) 193 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1)) 194 Q X 195 S(X,Y,Z) ; Pad Over 196 ; X=Column # 197 ; Y=Current Length 198 ; Z=Text 199 ; SP=Text Sent 200 ; CCNT=Line Position After Input Text 201 I '$D(Z) Q "" 202 N SP S SP=Z I X,Y,X>Y S SP=$E(" ",1,X-Y)_Z 203 S CCNT=$$INC(CCNT,SP) 204 Q SP 205 INC(X,Y) ; Character Position Count 206 ; X=Current Count 207 ; Y=Text 208 N INC S INC=X+$L(Y) 209 Q INC 1 ORCXPND1 ; SLC/MKB - Expanded Display cont ; 02/20/2003 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,67,75,89,92,94,148,159,188,172,215**;Dec 17, 1997 3 ; 4 ; External References 5 ; DBIA 2387 ^LAB(60 6 ; DBIA 3420 ^DPT( file #2 7 ; DBIA 10035 ^DPT( file #2 8 ; DBIA 10037 EN^DGRPD 9 ; DBIA 700 DIS^DGRPDB 10 ; DBIA 2926 RT^GMRCGUIA 11 ; DBIA 2925 DT^GMRCSLM2 ^TMP("GMRCR" 12 ; DBIA 10146 DISP^IBCNS 13 ; DBIA 2503 RR^LR7OR1 ^TMP("LRRR" 14 ; DBIA 2951 EN1^LR7OSBR ^TMP("LRC" 15 ; DBIA 2952 EN^LR7OSMZ0 16 ; DBIA 2400 OEL^PSOORRL ^TMP("PS" 17 ; DBIA 2877 EN3^RAO7PC3 18 ; DBIA 2877 EN30^RAO7PC3 19 ; DBIA 1252 $$OUTPTPR^SDUTL3 20 ; DBIA 1252 $$OUTPTTM^SDUTL3 21 ; DBIA 2832 RPC^TIUSRV 22 ; DBIA 10061 DEM^VADPT 23 ; DBIA 10061 KVAR^VADPT 24 ; DBIA 10061 OAD^VADPT 25 ; DBIA 10103 $$FMTE^XLFDT 26 ; DBIA 4408 DISP^DGIBDSP 27 ; 28 COVER ; -- Cover Sheet 29 N PKG S PKG=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4) 30 D ALLERGY^ORCXPND2:PKG="GMRA",NOTES:PKG="TIU" 31 Q 32 NOTES ; -- Progress Notes 33 N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J) 34 D RPC^TIUSRV(.ORY,ID) 35 S I=0 F S I=$O(@ORY@(I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0)) 36 K @ORY 37 Q 38 PROBLEMS ; -- Problem List 39 D PL^ORCXPND4 40 Q 41 MEDS ; -- Pharmacy 42 ;N NODE,ORIFN 43 D OEL^PSOORRL(+ORVP,ID) ;S NODE=$G(^TMP("PS",$J,0)),ORIFN=+$P(NODE,U,11) 44 S ID=+$P($G(^TMP("PS",$J,0)),U,11) D ORDERS ;DBIA 2400 45 ;D @($S($P($G(^OR(100,ORIFN,0)),U,11)=$O(^ORD(100.98,"B","IV RX",0)):"IV",1:"DRUG")_"^ORCXPND2") 46 K ^TMP("PS",$J) 47 Q 48 LABS ; -- Laboratory [RESULTS ONLY for ID=OE order #] 49 N ORIFN,X,SUB,TEST,NAME,SS,IDE,IVDT,TST,CCNT,ORCY,IG,TCNT 50 K ^TMP("LRRR",$J) ;DBIA 2503 51 S ORIFN=+ID,IDE=$G(^OR(100,+ID,4)) Q:'$L(IDE) ; OE# -> Lab# 52 I +IDE D RR^LR7OR1(+ORVP,IDE) I '$D(^TMP("LRRR",$J,+ORVP)) S $P(IDE,";",1,3)=";;" ;Order possibly purged, reset to lookup on file 63 53 I '+IDE,$P(IDE,";",5) D RR^LR7OR1(+ORVP,,9999999-$P(IDE,";",5),9999999-$P(IDE,";",5),$P(IDE,";",4)) 54 K ORCY D TEXT^ORQ12(.ORCY,ORIFN,80) 55 S IG=0 F S IG=$O(ORCY(IG)) Q:IG<1 S X=ORCY(IG) D ITEM^ORCXPND(X) 56 D BLANK^ORCXPND I '$D(^TMP("LRRR",$J,+ORVP)) S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q 57 M TEST=^TMP("LRRR",$J,+ORVP) S CCNT=0,SS="" 58 F S SS=$O(TEST(SS)) Q:SS="" S IVDT=0 F S IVDT=$O(TEST(SS,IVDT)) Q:'IVDT D 59 . I SS="BB" D 60 .. I $L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface 61 ... K ^TMP("ORLRC",$J) 62 ... D EN^ORWLR1(DFN) 63 ... I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..." 64 ... N I S I=0 F S I=$O(^TMP("ORLRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X 65 ... K ^TMP("ORLRC",$J) 66 .. K ^TMP("LRC",$J) D EN1^LR7OSBR(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q ;DBIA 2951 67 ... N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X 68 ... K ^TMP("LRC",$J) 69 . I SS="MI" K ^TMP("LRC",$J) D EN^LR7OSMZ0(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q 70 .. N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X 71 .. K ^TMP("LRC",$J) 72 . I SS="CH" D Q 73 .. S (TCNT,TST)=0 F S TST=$O(TEST(SS,IVDT,TST)) Q:TST="" S CCNT=0,TCNT=TCNT+1 D 74 ... I TCNT=1 D 75 .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Collection time: "_$$FMTE^XLFDT(9999999-IVDT,1) 76 .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT," ")_$$S(3,CCNT,"Test Name")_$$S(29,CCNT,"Result")_$$S(39,CCNT,"Units")_$$S(55,CCNT,"Range") D:$D(IOUON) SETVIDEO^ORCXPND(LCNT,1,70,IOUON,IOUOFF) 77 ... I TST S X=TEST(SS,IVDT,TST),CCNT=0 I +X D 78 .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT,$P(^LAB(60,+X,0),U))_$$S(26,CCNT,$J($P(X,U,2),7))_$$S(34,CCNT,$S($L($P(X,U,3)):$P(X,U,3),1:""))_$$S(39,CCNT,$P(X,U,4))_$$S(45,CCNT,$J($P(X,U,5),15)) 79 .... I $L($P(X,U,3)),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOINHI,IOINORM) 80 .... I $P(X,U,3)["*",$D(IOBON),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOBON_IOINHI,IOBOFF_IOINORM) 81 ... I TST="N" S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Comments: " D 82 .... N CMT S CMT=0 F S CMT=$O(TEST(SS,IVDT,"N",CMT)) Q:'CMT S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" "_TEST(SS,IVDT,"N",CMT) 83 K ^TMP("LRRR",$J) 84 Q 85 ; 86 DELAY ; -- Delayed Orders 87 NEW ; -- New Orders 88 ORDERS ; -- Orders 89 I '$G(ORESULTS) D ORDERS^ORCXPND2 Q 90 ; -- Results Display (Add more packages as available) 91 N PKG,TAB,ORIFN 92 S PKG=+$P($G(^OR(100,+ID,0)),"^",14),PKG=$$NMSP^ORCD(PKG) 93 S TAB=$S(PKG="LR":"LABS",PKG="GMRC":"CONSULTS",PKG="RA":"XRAYS",1:"") 94 I '$L(TAB)!(ID'>0) D Q ; no display available 95 . N ORY,I D TEXT^ORQ12(.ORY,+ID,80) 96 . S I=0 F S I=$O(ORY(I)) Q:I'>0 D ITEM^ORCXPND(ORY(I)) 97 . D BLANK^ORCXPND 98 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="There are no results to report." 99 I $O(^OR(100,+ID,2,0)) S ORIFN=+ID,ID=0 F S ID=$O(^OR(100,ORIFN,2,ID)) Q:ID<1 I $D(^OR(100,ID,0)) D @TAB 100 I '$O(^OR(100,+ID,2,0)) D @TAB 101 Q 102 REPORTS ; -- Patient Profiles 103 D EN^ORCXPNDR ; Reports 104 Q 105 CONSULTS ; -- Consults 106 N I,X,SUB,ORTX ;,VALMAR 107 I $G(ORTAB)="CONSULTS" S X=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4) 108 E D TEXT^ORQ12(.ORTX,+ID) S X=ORTX(1),ID=+$G(^OR(100,+ID,4)) ; OE->GMRC order# 109 D ITEM^ORCXPND(X),BLANK^ORCXPND 110 I ID'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q 111 I '$G(ORESULTS) D ;DT action 112 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Consult No.: "_ID 113 . N GMRCOER S GMRCOER=2 D DT^GMRCSLM2(ID) S SUB="DT" ;DBIA 2925 114 I $G(ORESULTS) D RT^GMRCGUIA(ID,"^TMP(""GMRCR"",$J,""RT"")") S SUB="RT" 115 S I=0 F S I=$O(^TMP("GMRCR",$J,SUB,I)) Q:I'>0 S X=$G(^(I,0)),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;DBIA 2925 116 K ^TMP("GMRCR",$J) 117 Q 118 XRAYS ; -- Radiology 119 I '$G(ORESULTS) S ID=+ORVP_U_$TR(ID,"-","^") D EN3^RAO7PC3(ID) 120 I $G(ORESULTS) S ID=+$G(^OR(100,+ID,4)) D EN30^RAO7PC3(ID) 121 N CASE,PROC,PSET S PSET=$D(^TMP($J,"RAE3",+ORVP,"PRINT_SET")) 122 S CASE=0 F S CASE=$O(^TMP($J,"RAE3",+ORVP,CASE)) Q:CASE'>0 D 123 . I PSET S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,"")) D ITEM^ORCXPND(PROC) Q 124 . S PROC="" F S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC)) Q:PROC="" D ITEM^ORCXPND(PROC),BLANK^ORCXPND,XRPT,BLANK^ORCXPND 125 I PSET S CASE=$O(^TMP($J,"RAE3",+ORVP,0)),PROC=$O(^(CASE,"")) D BLANK^ORCXPND,XRPT,BLANK^ORCXPND ;printset=list all procs, then one report 126 K ^TMP($J,"RAE3",+ORVP),^UTILITY($J,"W") 127 S VALM("RM")=81 128 Q 129 ; 130 XRPT ; -- Body of Report for CASE, PROC 131 N ORD,X,I 132 S ORD=$S($L($G(^TMP($J,"RAE3",+ORVP,"ORD"))):^("ORD"),$L($G(^("ORD",CASE))):^(CASE),1:"") I $L(ORD),ORD'=PROC S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Proc Ord: "_ORD 133 S I=1 F S I=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC,I)) Q:I'>0 S X=^(I),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;Skip pt ID on line 1 134 Q 135 ; 136 SUMMRIES ; -- Discharge Summaries 137 N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J) 138 D RPC^TIUSRV(.ORY,ID) 139 S I=0 F S I=$O(@ORY@(I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0)) 140 K @ORY 141 Q 142 PTINQ ; Print Patient Inquiry in List Manager 143 N DFN,ORI,X 144 S DFN=+ORVP 145 D DGINQ(DFN) 146 S ORI=4,LCNT=0 147 F S ORI=$O(^TMP("ORDATA",$J,1,ORI)) Q:'ORI S X=^(ORI) D 148 . S LCNT=LCNT+1 149 . S ^TMP("ORXPND",$J,LCNT,0)=X 150 K ^TMP("ORDATA",$J,1) 151 Q 152 ; 153 DGINQ(DFN) ; Patient Inquiry 154 D START^ORWRP(80,"DGINQB^ORCXPND1(DFN)") 155 Q 156 DGINQB(DFN) ; Build Patient Inquiry 157 N ORDOC,ORTEAM,ORVP,XQORNOD,ORSSTRT,ORSSTOP,X,VAOA 158 S ORVP=DFN_";DPT(",XQORNOD=1 159 D EN^DGRPD ; MAS Patient Inquiry 160 ; 161 S ORDOC=$$OUTPTPR^SDUTL3(DFN) 162 S ORTEAM=$$OUTPTTM^SDUTL3(DFN) 163 I ORDOC!ORTEAM D 164 . W !!,"Primary Care Information:" 165 . I ORDOC W !,"Primary Practitioner: ",$P(ORDOC,"^",2) 166 . I ORTEAM W !,"Primary Care Team: ",$P(ORTEAM,"^",2) 167 W !!,"Health Insurance Information:" 168 I $L($T(DISP^DGIBDSP)) D DISP^DGIBDSP ;DBIA #4408 169 E D DISP^IBCNS 170 W !!,"Service Connection/Rated Disabilities:" 171 D DIS^DGRPDB 172 D OAD^VADPT ; Get NOK Information 173 I VAOA(9)]"" D 174 . W !!,"Next of Kin Information:" 175 . W !,"Name: ",VAOA(9) ; NOK Name 176 . I VAOA(10)]"" W " (",VAOA(10),")" ; Relationship 177 . I VAOA(1)]"" W !?7,VAOA(1) ; Address Line 1 178 . I VAOA(2)]"" W !?7,VAOA(2) ; Line 2 179 . I VAOA(3)]"" W !?7,VAOA(3) ; Line 3 180 . I VAOA(4)]"" D 181 . . W !?7,VAOA(4) ; City 182 . . I VAOA(5)]"" W ", "_$P(VAOA(5),"^",2) ; State 183 . . W " ",$P(VAOA(11),"^",2) ; Zip+4 184 . I VAOA(8)]"" W !!?7,"Phone number: ",VAOA(8) ; Phone 185 . I $P($G(^DPT(DFN,.21)),U,11)]"" W !?7,"Work phone number: ",$P(^DPT(DFN,.21),U,11) 186 D KVAR^VADPT 187 Q 188 TRIM(X) ; Trim Spaces 189 S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X)) 190 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1)) 191 Q X 192 S(X,Y,Z) ; Pad Over 193 ; X=Column # 194 ; Y=Current Length 195 ; Z=Text 196 ; SP=Text Sent 197 ; CCNT=Line Position After Input Text 198 I '$D(Z) Q "" 199 N SP S SP=Z I X,Y,X>Y S SP=$E(" ",1,X-Y)_Z 200 S CCNT=$$INC(CCNT,SP) 201 Q SP 202 INC(X,Y) ; Character Position Count 203 ; X=Current Count 204 ; Y=Text 205 N INC S INC=X+$L(Y) 206 Q INC -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCXPND3.m
r613 r623 1 ORCXPND3 ; SLC/MKB,dcm - Expanded display of Reports ;2/21/01 14:07 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**25,30,43,85,172,243**;Dec 17, 1997;Build 242 3 ; 4 AP ; -- Retrieve AP results for a specific date/time specimen taken 5 ; [alert follow-up, from LABS^ORCXPND1] 6 N ORACCNO,ORDTSTKN S ORACCNO=$P(ID,"-"),ORDTSTKN=$P(ID,"-",2) 7 I (ORACCNO["CY"!(ORACCNO["SP")!(ORACCNO["EM")!(ORACCNO["AU"))&($L(ORACCNO)>0) D ;check for valid accession # 8 . N ORLRDFN,ORLRSS S ORLRDFN=$$LRDFN^LR7OR1(DFN),ORLRSS=$P($G(XQADATA),U) ;DBIA/ICR #2503 9 . K ^TMP("ORAP",$J) D EN^LR7OSAP4("^TMP(""ORAP"",$J)",ORLRDFN,ORLRSS,ORDTSTKN) 10 . I '$O(^TMP("ORAP",$J,0)) S ^TMP("ORAP",$J,1,0)="",^TMP("ORAP",$J,2,0)="No Anatomic Pathology report available..." 11 . N I S I=0 F S I=$O(^TMP("ORAP",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X 12 . K ^TMP("ORAP",$J) 13 Q 14 ; 15 LRA ; -- Anatomic Pathology Report 16 N DFN,Y,I,LRLLOC,LRQ 17 D TIT^ORCXPNDR("Anatomic Path Report") Q:$$OS^ORCXPNDR() 18 D PREP^ORCXPNDR 19 D RPT^ORWRP(.Y,ID,3) 20 D ITEM^ORCXPND("Anatomic Path Report") 21 S I=3 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORDATA",$J,1,I) 22 K ^TMP("ORDATA",$J) 23 Q 24 ; 25 LRAA ; -- Alternate Anatomic Path Report 26 N DFN,Y,I,LRLLOC,LRQ 27 D TIT^ORCXPNDR("Alternate Anatomic Path Report") Q:$$OS^ORCXPNDR() 28 D PREP^ORCXPNDR I $$OS^ORCXPNDR() Q 29 D AP^LR7OSUM(ID) 30 D ITEM^ORCXPND("Anatomic Pathology Report") 31 I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="No Anatomic Pathology reports available..." 32 S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0) 33 K ^TMP("LRC",$J) 34 Q 35 ; 36 LRB1 ; -- Blood Bank Report 37 N DFN,Y,I,LRBLOOD,LRCAPA,LRDT0,LRLABKY,LRLLOC,LRO,LRPCEVSO,LRPLASMA,LRSERUM,LRT,LRUNKNOW,LRURINE,LRVIDO,LRVIDOF 38 D TIT^ORCXPNDR("Blood Bank Report") Q:$$OS^ORCXPNDR() 39 D PREP^ORCXPNDR 40 D RPT^ORWRP(.Y,ID,2) 41 D ITEM^ORCXPND("Blood Bank Report") 42 S I=5 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORDATA",$J,1,I) 43 K ^TMP("ORDATA",$J) 44 Q 45 ; 46 LRB ; -- A better Blood Bank Report 47 N DFN,ORY,I,SUBHEAD 48 D TIT^ORCXPNDR("Blood Bank Report") 49 S DFN=ID 50 D PREP^ORCXPNDR 51 I $$GET^XPAR("DIV^SYS^PKG","OR VBECS ON",1,"Q"),$L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface 52 . K ^TMP("ORLRC",$J) 53 . D EN^ORWLR1(DFN) 54 . I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..." 55 . D ITEM^ORCXPND("Blood Bank Report"),BLANK^ORCXPND 56 . S I=0 F S I=$O(^TMP("ORLRC",$J,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORLRC",$J,I,0) 57 . K ^TMP("ORLRC",$J) 58 S SUBHEAD("BLOOD BANK")="" 59 D EN^LR7OSUM(.ORY,DFN,,,,,.SUBHEAD) 60 I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="No Blood Bank report available..." 61 D ITEM^ORCXPND("Blood Bank Report"),BLANK^ORCXPND 62 S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0) 63 K ^TMP("LRC",$J),^TMP("LRH",$J) 64 Q 65 ; 66 LRC ; -- Lab Cumulative 67 N DFN,ORY,I,BEG,END,OREND,ORSSTRT,ORSSTOP 68 D TIT^ORCXPNDR("Lab Cumulative") 69 S DFN=ID 70 D RANGE($S($G(ORWARD):7,1:180)) Q:OREND S BEG=+ORSSTRT,END=+ORSSTOP 71 D PREP^ORCXPNDR 72 D EN^LR7OSUM(.ORY,DFN,BEG,END) 73 D ITEM^ORCXPND("Lab Cumulative"),BLANK^ORCXPND 74 S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0) 75 K ^TMP("LRC",$J),^TMP("LRH",$J) 76 Q 77 ; 78 LRG ; -- Graph Lab Tests 79 N DFN,Y,I,X,BCNT,LRSS,LRCW,LRFLAG,LRCTRL,LRNSET,N,LOW,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,OREND,ORSSTRT,ORSSTOP 80 D TIT^ORCXPNDR("Graph Lab Tests") Q:$$OS^ORCXPNDR() 81 D RANGE($S($G(ORWARD):7,1:180)) Q:OREND 82 S LRSS="CH",LRCW=8,LRFLAG="",LRCTRL=0,(LRNSET,N)=80 83 D L2^LRDIST4 Q:'$D(LRTEST) 84 D PREP^ORCXPNDR 85 D RPT^ORWRP(.Y,ID,8,,,,+ORSSTRT,+ORSSTOP) 86 D ITEM^ORCXPND("Lab Graph") 87 S I=4,BCNT=0 88 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D 89 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q 90 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 91 K ^TMP("ORDATA",$J) 92 Q 93 ; 94 LRI ; -- Interim Lab Results 95 N ORX,DFN,Y,I,X,BCNT,LREDT,LRIDT,LRLLT,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,OREND,ORSSTRT,ORSSTOP 96 D TIT^ORCXPNDR("Lab Interim Results") Q:$$OS^ORCXPNDR() 97 D RANGE($S($G(ORWARD):7,1:180)) Q:OREND 98 D SET^LRRP4 99 D PREP^ORCXPNDR 100 D RPT^ORWRP(.Y,ID,3,,,,+ORSSTRT,+ORSSTOP) 101 D ITEM^ORCXPND("Lab Interim Report") 102 S I=0,BCNT=0 103 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D 104 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q 105 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 106 K ^TMP("ORDATA",$J) 107 Q 108 ; 109 LRGEN ;Lab Results by Test 110 N DFN,Y,I,II,X,BCNT,LRPRETTY,LREDT,LRLLT,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,LRCW,LREND,LRTP,LRIX,LRWPL,LRIDT,LRSC,DIC,LRTSTS,LRORD,LRTEST,LRSUB,LRHDR,LRSSP,LRHI,LRLO 111 N LBL,LRBLOOD,LRDAT,LRDFN,LRDPF,LRDT0,LREX,LRFFLG,LRFOOT,LRLAB,LRLABKY,LRND,LRNG,LRNOP,LRNOTE,LRODT0,LRONESPC,LRONETST,LRPAGE,LRPARAM,LRPLASMA,LRPP,LRSERUM,LRPS,LRTN,LRUNKNOW,LRURINE,LRWRD,LRX,LRY 112 N AGE,I,INC,LRIDT1,LRSV,OREND,ORSSTRT,ORSSTOP 113 K ^TMP("LR",$J) 114 D TIT^ORCXPNDR("Lab Results by Test") Q:$$OS^ORCXPNDR() 115 D RANGE($S($G(ORWARD):7,1:180)) Q:OREND 116 D SET^LRGEN 117 Q:LREND!'LRTSTS 118 D PREP^ORCXPNDR 119 D RPT^ORWRP(.Y,ID,16,,,,+ORSSTRT,+ORSSTOP) 120 D ITEM^ORCXPND("Lab Results by Test") 121 S I=1,BCNT=0 122 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D 123 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q 124 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 125 K ^TMP("ORDATA",$J) 126 Q 127 ; 128 STAT ; -- Lab test status 129 N DFN,Y,I,X,BCNT,OREND,ORSSTRT,ORSSTOP 130 D TIT^ORCXPNDR("Lab Test Status") Q:$$OS^ORCXPNDR() 131 D RANGE($S($G(ORWARD):7,1:180)) Q:$G(OREND) 132 D PREP^ORCXPNDR 133 D RPT^ORWRP(.Y,ID,9,,,,+ORSSTRT,+ORSSTOP) 134 D ITEM^ORCXPND("Lab Test Status") 135 S I=0,BCNT=0 136 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=$S($D(^(I))#2:^(I),$D(^(I,0))#2:^(0),1:"") D 137 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q 138 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 139 K ^TMP("ORDATA",$J) 140 Q 141 ; 142 RANGE(BEG) ;Get date range for report 143 ;BEG=# of days (T-BEG) for start default 144 ;Output: ORSSTRT=Start date/time 145 ; ORSSTOP=Stop date/time 146 ; OREND=1 if user '^'s out, so look for it! 147 S BEG=$$FMADD^XLFDT(DT,-$G(BEG)),END=$$NOW^XLFDT 148 D RANGE^ORPRS01(BEG,END) 149 Q 150 ; 151 MED(MED) ; -- Medicine Summary of Patient Procedures 152 N DFN,Y,I,X,BCNT,OREND,PROCID 153 D TIT^ORCXPNDR("Summary of Patient Procedures") Q:$$OS^ORCXPNDR() 154 D PREP^ORCXPNDR 155 S DFN=+ID,PROCID=$P(MED,"~",2) 156 D RPT^ORWRP(.Y,DFN,19,,,PROCID) 157 D ITEM^ORCXPND("Summary of Patient Procedures") 158 S I=4,BCNT=0 159 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D 160 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q 161 . I $E(X,1,4)="Pg. " Q 162 . I X["PHYSICIANS' SIGNATURE" Q 163 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 164 K ^TMP("ORDATA",$J) 165 Q 1 ORCXPND3 ; SLC/MKB,dcm - Expanded display of Reports ;2/21/01 14:07 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**25,30,43,85,172**;Dec 17, 1997 3 LRA ; -- Anatomic Pathology Report 4 N DFN,Y,I,LRLLOC,LRQ 5 D TIT^ORCXPNDR("Anatomic Path Report") Q:$$OS^ORCXPNDR() 6 D PREP^ORCXPNDR 7 D RPT^ORWRP(.Y,ID,3) 8 D ITEM^ORCXPND("Anatomic Path Report") 9 S I=3 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORDATA",$J,1,I) 10 K ^TMP("ORDATA",$J) 11 Q 12 ; 13 LRAA ; -- Alternate Anatomic Path Report 14 N DFN,Y,I,LRLLOC,LRQ 15 D TIT^ORCXPNDR("Alternate Anatomic Path Report") Q:$$OS^ORCXPNDR() 16 D PREP^ORCXPNDR I $$OS^ORCXPNDR() Q 17 D AP^LR7OSUM(ID) 18 D ITEM^ORCXPND("Anatomic Pathology Report") 19 I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="No Anatomic Pathology reports available..." 20 S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0) 21 K ^TMP("LRC",$J) 22 Q 23 LRB1 ; -- Blood Bank Report 24 N DFN,Y,I,LRBLOOD,LRCAPA,LRDT0,LRLABKY,LRLLOC,LRO,LRPCEVSO,LRPLASMA,LRSERUM,LRT,LRUNKNOW,LRURINE,LRVIDO,LRVIDOF 25 D TIT^ORCXPNDR("Blood Bank Report") Q:$$OS^ORCXPNDR() 26 D PREP^ORCXPNDR 27 D RPT^ORWRP(.Y,ID,2) 28 D ITEM^ORCXPND("Blood Bank Report") 29 S I=5 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORDATA",$J,1,I) 30 K ^TMP("ORDATA",$J) 31 Q 32 ; 33 LRB ; -- A better Blood Bank Report 34 N DFN,ORY,I,SUBHEAD 35 D TIT^ORCXPNDR("Blood Bank Report") 36 S DFN=ID 37 D PREP^ORCXPNDR 38 I $L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface 39 . K ^TMP("ORLRC",$J) 40 . D EN^ORWLR1(DFN) 41 . I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..." 42 . D ITEM^ORCXPND("Blood Bank Report"),BLANK^ORCXPND 43 . S I=0 F S I=$O(^TMP("ORLRC",$J,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORLRC",$J,I,0) 44 . K ^TMP("ORLRC",$J) 45 S SUBHEAD("BLOOD BANK")="" 46 D EN^LR7OSUM(.ORY,DFN,,,,,.SUBHEAD) 47 I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="No Blood Bank report available..." 48 D ITEM^ORCXPND("Blood Bank Report"),BLANK^ORCXPND 49 S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0) 50 K ^TMP("LRC",$J),^TMP("LRH",$J) 51 Q 52 LRC ; -- Lab Cumulative 53 N DFN,ORY,I,BEG,END,OREND,ORSSTRT,ORSSTOP 54 D TIT^ORCXPNDR("Lab Cumulative") 55 S DFN=ID 56 D RANGE($S($G(ORWARD):7,1:180)) Q:OREND S BEG=+ORSSTRT,END=+ORSSTOP 57 D PREP^ORCXPNDR 58 D EN^LR7OSUM(.ORY,DFN,BEG,END) 59 D ITEM^ORCXPND("Lab Cumulative"),BLANK^ORCXPND 60 S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0) 61 K ^TMP("LRC",$J),^TMP("LRH",$J) 62 Q 63 ; 64 LRG ; -- Graph Lab Tests 65 N DFN,Y,I,X,BCNT,LRSS,LRCW,LRFLAG,LRCTRL,LRNSET,N,LOW,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,OREND,ORSSTRT,ORSSTOP 66 D TIT^ORCXPNDR("Graph Lab Tests") Q:$$OS^ORCXPNDR() 67 D RANGE($S($G(ORWARD):7,1:180)) Q:OREND 68 S LRSS="CH",LRCW=8,LRFLAG="",LRCTRL=0,(LRNSET,N)=80 69 D L2^LRDIST4 Q:'$D(LRTEST) 70 D PREP^ORCXPNDR 71 D RPT^ORWRP(.Y,ID,8,,,,+ORSSTRT,+ORSSTOP) 72 D ITEM^ORCXPND("Lab Graph") 73 S I=4,BCNT=0 74 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D 75 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q 76 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 77 K ^TMP("ORDATA",$J) 78 Q 79 ; 80 LRI ; -- Interim Lab Results 81 N ORX,DFN,Y,I,X,BCNT,LREDT,LRIDT,LRLLT,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,OREND,ORSSTRT,ORSSTOP 82 D TIT^ORCXPNDR("Lab Interim Results") Q:$$OS^ORCXPNDR() 83 D RANGE($S($G(ORWARD):7,1:180)) Q:OREND 84 D SET^LRRP4 85 D PREP^ORCXPNDR 86 D RPT^ORWRP(.Y,ID,3,,,,+ORSSTRT,+ORSSTOP) 87 D ITEM^ORCXPND("Lab Interim Report") 88 S I=0,BCNT=0 89 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D 90 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q 91 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 92 K ^TMP("ORDATA",$J) 93 Q 94 LRGEN ;Lab Results by Test 95 N DFN,Y,I,II,X,BCNT,LRPRETTY,LREDT,LRLLT,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,LRCW,LREND,LRTP,LRIX,LRWPL,LRIDT,LRSC,DIC,LRTSTS,LRORD,LRTEST,LRSUB,LRHDR,LRSSP,LRHI,LRLO 96 N LBL,LRBLOOD,LRDAT,LRDFN,LRDPF,LRDT0,LREX,LRFFLG,LRFOOT,LRLAB,LRLABKY,LRND,LRNG,LRNOP,LRNOTE,LRODT0,LRONESPC,LRONETST,LRPAGE,LRPARAM,LRPLASMA,LRPP,LRSERUM,LRPS,LRTN,LRUNKNOW,LRURINE,LRWRD,LRX,LRY 97 N AGE,I,INC,LRIDT1,LRSV,OREND,ORSSTRT,ORSSTOP 98 K ^TMP("LR",$J) 99 D TIT^ORCXPNDR("Lab Results by Test") Q:$$OS^ORCXPNDR() 100 D RANGE($S($G(ORWARD):7,1:180)) Q:OREND 101 D SET^LRGEN 102 Q:LREND!'LRTSTS 103 D PREP^ORCXPNDR 104 D RPT^ORWRP(.Y,ID,16,,,,+ORSSTRT,+ORSSTOP) 105 D ITEM^ORCXPND("Lab Results by Test") 106 S I=1,BCNT=0 107 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D 108 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q 109 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 110 K ^TMP("ORDATA",$J) 111 Q 112 ; 113 STAT ; -- Lab test status 114 N DFN,Y,I,X,BCNT,OREND,ORSSTRT,ORSSTOP 115 D TIT^ORCXPNDR("Lab Test Status") Q:$$OS^ORCXPNDR() 116 D RANGE($S($G(ORWARD):7,1:180)) Q:$G(OREND) 117 D PREP^ORCXPNDR 118 D RPT^ORWRP(.Y,ID,9,,,,+ORSSTRT,+ORSSTOP) 119 D ITEM^ORCXPND("Lab Test Status") 120 S I=0,BCNT=0 121 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=$S($D(^(I))#2:^(I),$D(^(I,0))#2:^(0),1:"") D 122 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q 123 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 124 K ^TMP("ORDATA",$J) 125 Q 126 RANGE(BEG) ;Get date range for report 127 ;BEG=# of days (T-BEG) for start default 128 ;Output: ORSSTRT=Start date/time 129 ; ORSSTOP=Stop date/time 130 ; OREND=1 if user '^'s out, so look for it! 131 S BEG=$$FMADD^XLFDT(DT,-$G(BEG)),END=$$NOW^XLFDT 132 D RANGE^ORPRS01(BEG,END) 133 Q 134 MED(MED) ; -- Medicine Summary of Patient Procedures 135 N DFN,Y,I,X,BCNT,OREND,PROCID 136 D TIT^ORCXPNDR("Summary of Patient Procedures") Q:$$OS^ORCXPNDR() 137 D PREP^ORCXPNDR 138 S DFN=+ID,PROCID=$P(MED,"~",2) 139 D RPT^ORWRP(.Y,DFN,19,,,PROCID) 140 D ITEM^ORCXPND("Summary of Patient Procedures") 141 S I=4,BCNT=0 142 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D 143 . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q 144 . I $E(X,1,4)="Pg. " Q 145 . I X["PHYSICIANS' SIGNATURE" Q 146 . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 147 K ^TMP("ORDATA",$J) 148 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD2.m
r613 r623 1 ORD2 ; DRIVER FOR COMPILED XREFS FOR FILE #100 ; 1 1/08/091 ORD2 ; DRIVER FOR COMPILED XREFS FOR FILE #100 ; 12/25/06 2 2 ; 3 3 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD21.m
r613 r623 1 ORD21 ; COMPILED XREF FOR FILE #100 ; 1 1/08/091 ORD21 ; COMPILED XREF FOR FILE #100 ; 12/25/06 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD210.m
r613 r623 1 ORD210 ; COMPILED XREF FOR FILE #100.001 ; 1 1/08/091 ORD210 ; COMPILED XREF FOR FILE #100.001 ; 12/25/06 2 2 ; 3 3 S DA(1)=DA S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD211.m
r613 r623 1 ORD211 ; COMPILED XREF FOR FILE #100.002 ; 1 1/08/091 ORD211 ; COMPILED XREF FOR FILE #100.002 ; 12/25/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD212.m
r613 r623 1 ORD212 ; COMPILED XREF FOR FILE #100.008 ; 1 1/08/091 ORD212 ; COMPILED XREF FOR FILE #100.008 ; 12/25/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD213.m
r613 r623 1 ORD213 ; COMPILED XREF FOR FILE #100.04 ; 1 1/08/091 ORD213 ; COMPILED XREF FOR FILE #100.04 ; 12/25/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD214.m
r613 r623 1 ORD214 ; COMPILED XREF FOR FILE #100.045 ; 1 1/08/091 ORD214 ; COMPILED XREF FOR FILE #100.045 ; 12/25/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD215.m
r613 r623 1 ORD215 ; COMPILED XREF FOR FILE #100.051 ; 1 1/08/091 ORD215 ; COMPILED XREF FOR FILE #100.051 ; 12/25/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD216.m
r613 r623 1 ORD216 ; COMPILED XREF FOR FILE #100.09 ; 1 1/08/091 ORD216 ; COMPILED XREF FOR FILE #100.09 ; 12/25/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD22.m
r613 r623 1 ORD22 ; COMPILED XREF FOR FILE #100.001 ; 1 1/08/091 ORD22 ; COMPILED XREF FOR FILE #100.001 ; 12/25/06 2 2 ; 3 3 S DA(1)=DA S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD23.m
r613 r623 1 ORD23 ; COMPILED XREF FOR FILE #100.002 ; 1 1/08/091 ORD23 ; COMPILED XREF FOR FILE #100.002 ; 12/25/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD24.m
r613 r623 1 ORD24 ; COMPILED XREF FOR FILE #100.008 ; 1 1/08/091 ORD24 ; COMPILED XREF FOR FILE #100.008 ; 12/25/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD25.m
r613 r623 1 ORD25 ; COMPILED XREF FOR FILE #100.04 ; 1 1/08/091 ORD25 ; COMPILED XREF FOR FILE #100.04 ; 12/25/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD26.m
r613 r623 1 ORD26 ; COMPILED XREF FOR FILE #100.045 ; 1 1/08/091 ORD26 ; COMPILED XREF FOR FILE #100.045 ; 12/25/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD27.m
r613 r623 1 ORD27 ; COMPILED XREF FOR FILE #100.051 ; 1 1/08/091 ORD27 ; COMPILED XREF FOR FILE #100.051 ; 12/25/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD28.m
r613 r623 1 ORD28 ; COMPILED XREF FOR FILE #100.09 ; 1 1/08/091 ORD28 ; COMPILED XREF FOR FILE #100.09 ; 12/25/06 2 2 ; 3 3 S DA=0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD29.m
r613 r623 1 ORD29 ; COMPILED XREF FOR FILE #100 ; 1 1/08/091 ORD29 ; COMPILED XREF FOR FILE #100 ; 12/25/06 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV03.m
r613 r623 1 ORDV03 ; slc/dcm - OE/RR Report Extracts ;10/8/03 11:17 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,208,215,243**;Dec 17, 1997;Build 242 3 RI(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology impression 4 ;External Calls: MAIN^GMTSRAE(1) 5 ; 6 ; ^TMP("GMTSRAD",$J) used via DBIA 4333 7 ; ^TMP("RAE",$J) used via DBIA 3968 8 N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO 9 Q:'$L(OREXT) 10 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 11 Q:'$L($T(@GO)) 12 S IOST=$G(IOST),GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS2=ORALPHA,GMTS1=OROMEGA 13 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 14 K ^TMP("ORDATA",$J),^TMP("RAE",$J) ;DBIA 3968 15 D @GO 16 S ORDT=GMTS1,ORCNT=0 17 F S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0)!(ORDT>GMTS2) D 18 . S ORJ=0 F S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ I $G(^(ORJ,0)) S ORX0=^(0) D 19 .. S ORCNT=ORCNT+1 20 .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE) 21 .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Station ID 22 .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date 23 .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure 24 .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$P(ORX0,U,4) ;report status 25 .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code 26 .. D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6)),6) ;impression 27 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ^TMP("ORDATA",$J,ORCNT,"WP",8)="8^[+]" ;flag for detail 28 K ^TMP("RAE",$J) 29 S ROOT=$NA(^TMP("ORDATA",$J)) 30 Q 31 RR(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology report 32 ;External Calls: MAIN^GMTSRAE(2) 33 I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 34 . N BEG,END,MAX 35 . Q:'$G(ORALPHA) Q:'$G(OROMEGA) 36 . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999) 37 . S BEG=9999999-OROMEGA,END=9999999-ORALPHA 38 . D GCPR^OMGCOAS1(DFN,"RR",BEG,END,MAX) 39 N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO,ORMORE 40 Q:'$L(OREXT) 41 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 42 Q:'$L($T(@GO)) 43 K ^TMP("ORDATA",$J) 44 S GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS1=OROMEGA,GMTS2=ORALPHA 45 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 46 I '$L($T(GCPR^OMGCOAS1)) D 47 . K ^TMP("RAE",$J) 48 . D @GO 49 S ORDT=GMTS1,ORCNT=0 50 F S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0) D 51 . S ORJ=0 F S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ D 52 .. S ORCNT=ORCNT+1,ORMORE=0 53 .. S ORX0=$G(^TMP("RAE",$J,ORDT,ORJ,0)) 54 .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE) 55 .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID 56 .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date 57 .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure 58 .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$S($L($P(ORX0,U,4)):$P(ORX0,U,4),1:"No Report") ;report status 59 .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code 60 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"S",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"S")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;reason for study 61 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"H",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"H")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",7,1)),7) ;clinical history 62 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",8,1)),8) ;impression 63 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"R",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"R")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",9,1)),9) ;report 64 .. I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",10)="10^[+]" ;flag for detail 65 K ^TMP("RAE",$J) 66 S ROOT=$NA(^TMP("ORDATA",$J)) 67 Q 68 RRDOD(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology report 69 ;External Calls: MAIN^GMTSRAE(2) 70 ; 71 I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 72 . N BEG,END,MAX 73 . Q:'$G(ORALPHA) Q:'$G(OROMEGA) 74 . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999) 75 . S BEG=9999999-OROMEGA,END=9999999-ORALPHA 76 . D GCPR^OMGCOAS1(DFN,"RR",BEG,END,MAX) 77 ; 78 N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO,ORMORE 79 Q:'$L(OREXT) 80 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 81 Q:'$L($T(@GO)) 82 K ^TMP("ORDATA",$J) 83 S GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS1=OROMEGA,GMTS2=ORALPHA 84 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 85 I '$L($T(GCPR^OMGCOAS1)) D 86 . K ^TMP("RAE",$J) 87 . D @GO 88 S ORDT=GMTS1,ORCNT=0 89 F S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0) D 90 . S ORJ=0 F S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ D 91 .. S ORCNT=ORCNT+1,ORMORE=0 92 .. S ORX0=$G(^TMP("RAE",$J,ORDT,ORJ,0)) 93 .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE) 94 .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID 95 .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date 96 .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure 97 .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$S($L($P(ORX0,U,4)):$P(ORX0,U,4),1:"No Report") ;report status 98 .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code 99 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"H",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"H")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;clinical history 100 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",7,1)),7) ;impression 101 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"R",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"R")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",8,1)),8) ;report 102 .. I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",9)="9^[+]" ;flag for detail 103 K ^TMP("RAE",$J) 104 S ROOT=$NA(^TMP("ORDATA",$J)) 105 Q 106 RS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology status 107 ;External calls: GET^GMTSRAD 108 N ORSITE,SITE,CNT,ORDT,ORDA,ORDA2,REC,GMTSEND,GMTSBEG,GO,STAT 109 Q:'$L(OREXT) 110 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 111 Q:'$L($T(@GO)) 112 S GMTSBEG=ORDBEG,GMTSEND=ORDEND 113 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 114 K ^TMP("GMTSRAD",$J) ;DBIA 4333 115 D @GO 116 S CNT=0,ORDT=OROMEGA 117 F S ORDT=$O(^TMP("GMTSRAD",$J,ORDT)) Q:(ORDT'>0)!(ORDT>ORALPHA)!(CNT'<ORMAX) D 118 .S ORDA=0 119 .F S ORDA=$O(^TMP("GMTSRAD",$J,ORDT,ORDA)) Q:'ORDA!(CNT'<ORMAX) D 120 ..S ORDA2=0 121 ..F S ORDA2=$O(^TMP("GMTSRAD",$J,ORDT,ORDA,ORDA2)) Q:'ORDA2!(CNT'<ORMAX) S REC=^(ORDA2),STAT=$P(REC,"^",2) D 122 ...S CNT=CNT+1 123 ...S SITE=$S($L($G(^TMP("GMTSRAD",$J,ORDT,ORDA,ORDA2,"facility"))):^("facility"),1:ORSITE) 124 ...S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE 125 ...S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$$DATE^ORDVU($P(REC,"^")) 126 ...S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$S(STAT="d":"Discontinued",STAT="c":"Complete",STAT="h":"Hold",STAT="p":"Pending",STAT="a":"Active",STAT="s":"Scheduled",STAT="u":"Unreleased",1:STAT) 127 ...S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(REC,"^",3) 128 ...S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$$DATE^ORDVU($P(REC,"^",4)) 129 ...S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P(REC,"^",5) 130 S ROOT=$NA(^TMP("ORDATA",$J)) 131 Q 132 RAD1 ;Get radiology impression 133 D MAIN^GMTSRAE(1) 134 Q 135 RAD2 ;Get radiology report 136 D MAIN^GMTSRAE(2) 137 Q 1 ORDV03 ; slc/dcm - OE/RR Report Extracts ;10/8/03 11:17 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,208,215**;Dec 17, 1997 3 RI(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology impression 4 ;External Calls: MAIN^GMTSRAE(1) 5 ; 6 ; ^TMP("GMTSRAD",$J) used via DBIA 4333 7 ; ^TMP("RAE",$J) used via DBIA 3968 8 ; 9 I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 10 . N BEG,END,MAX 11 . Q:'$G(ORALPHA) Q:'$G(OROMEGA) 12 . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999) 13 . S BEG=9999999-OROMEGA,END=9999999-ORALPHA 14 . D GCPR^OMGCOAS1(DFN,"RI",BEG,END,MAX) 15 ; 16 N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO 17 Q:'$L(OREXT) 18 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 19 Q:'$L($T(@GO)) 20 S IOST=$G(IOST),GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS2=ORALPHA,GMTS1=OROMEGA 21 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 22 K ^TMP("ORDATA",$J) 23 I '$L($T(GCPR^OMGCOAS1)) D 24 . K ^TMP("RAE",$J) ;DBIA 3968 25 . D @GO 26 S ORDT=GMTS1,ORCNT=0 27 F S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0)!(ORDT>GMTS2) D 28 . S ORJ=0 F S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ I $G(^(ORJ,0)) S ORX0=^(0) D 29 .. S ORCNT=ORCNT+1 30 .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE) 31 .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Station ID 32 .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date 33 .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure 34 .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$P(ORX0,U,4) ;report status 35 .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code 36 .. D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6)),6) ;impression 37 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ^TMP("ORDATA",$J,ORCNT,"WP",8)="8^[+]" ;flag for detail 38 K ^TMP("RAE",$J) 39 S ROOT=$NA(^TMP("ORDATA",$J)) 40 Q 41 RR(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology report 42 ;External Calls: MAIN^GMTSRAE(2) 43 ; 44 I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 45 . N BEG,END,MAX 46 . Q:'$G(ORALPHA) Q:'$G(OROMEGA) 47 . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999) 48 . S BEG=9999999-OROMEGA,END=9999999-ORALPHA 49 . D GCPR^OMGCOAS1(DFN,"RR",BEG,END,MAX) 50 ; 51 N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO,ORMORE 52 Q:'$L(OREXT) 53 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 54 Q:'$L($T(@GO)) 55 K ^TMP("ORDATA",$J) 56 S GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS1=OROMEGA,GMTS2=ORALPHA 57 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 58 I '$L($T(GCPR^OMGCOAS1)) D 59 . K ^TMP("RAE",$J) 60 . D @GO 61 S ORDT=GMTS1,ORCNT=0 62 F S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0) D 63 . S ORJ=0 F S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ D 64 .. S ORCNT=ORCNT+1,ORMORE=0 65 .. S ORX0=$G(^TMP("RAE",$J,ORDT,ORJ,0)) 66 .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE) 67 .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID 68 .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date 69 .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure 70 .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$S($L($P(ORX0,U,4)):$P(ORX0,U,4),1:"No Report") ;report status 71 .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code 72 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"H",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"H")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;clinical history 73 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",7,1)),7) ;impression 74 .. I $O(^TMP("RAE",$J,ORDT,ORJ,"R",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"R")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",8,1)),8) ;report 75 .. I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",9)="9^[+]" ;flag for detail 76 K ^TMP("RAE",$J) 77 S ROOT=$NA(^TMP("ORDATA",$J)) 78 Q 79 RS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology status 80 ;External calls: GET^GMTSRAD 81 ; 82 I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 83 . N BEG,END,MAX 84 . Q:'$G(ORALPHA) Q:'$G(OROMEGA) 85 . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999) 86 . S BEG=9999999-OROMEGA,END=9999999-ORALPHA 87 . D GCPR^OMGCOAS1(DFN,"RS",BEG,END,MAX) 88 ; 89 N ORSITE,SITE,CNT,ORDT,ORDA,ORDA2,REC,GMTSEND,GMTSBEG,GO,STAT 90 Q:'$L(OREXT) 91 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 92 Q:'$L($T(@GO)) 93 S GMTSBEG=ORDBEG,GMTSEND=ORDEND 94 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 95 I '$L($T(GCPR^OMGCOAS1)) D 96 . K ^TMP("GMTSRAD",$J) ;DBIA 4333 97 . D @GO 98 S CNT=0,ORDT=OROMEGA 99 F S ORDT=$O(^TMP("GMTSRAD",$J,ORDT)) Q:(ORDT'>0)!(ORDT>ORALPHA)!(CNT'<ORMAX) D 100 .S ORDA=0 101 .F S ORDA=$O(^TMP("GMTSRAD",$J,ORDT,ORDA)) Q:'ORDA!(CNT'<ORMAX) D 102 ..S ORDA2=0 103 ..F S ORDA2=$O(^TMP("GMTSRAD",$J,ORDT,ORDA,ORDA2)) Q:'ORDA2!(CNT'<ORMAX) S REC=^(ORDA2),STAT=$P(REC,"^",2) D 104 ...S CNT=CNT+1 105 ...S SITE=$S($L($G(^TMP("GMTSRAD",$J,ORDT,ORDA,ORDA2,"facility"))):^("facility"),1:ORSITE) 106 ...S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE 107 ...S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$$DATE^ORDVU($P(REC,"^")) 108 ...S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$S(STAT="d":"Discontinued",STAT="c":"Complete",STAT="h":"Hold",STAT="p":"Pending",STAT="a":"Active",STAT="s":"Scheduled",STAT="u":"Unreleased",1:STAT) 109 ...S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(REC,"^",3) 110 ...S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$$DATE^ORDVU($P(REC,"^",4)) 111 ...S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P(REC,"^",5) 112 S ROOT=$NA(^TMP("ORDATA",$J)) 113 Q 114 RAD1 ;Get radiology impression 115 D MAIN^GMTSRAE(1) 116 Q 117 RAD2 ;Get radiology report 118 D MAIN^GMTSRAE(2) 119 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV04.m
r613 r623 1 ORDV04 ; SLC/DAN/dcm - OE/RR ;7/21/04 15:32 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,148,160,208,195,241,215,274,256,243**;Dec 17,1997;Build 242 3 ;OE/RR COMPONENT 4 ; 5 ; ^TMP("GMPLHS",$J) DBIA 1183 6 ; ^UTILITY & ^TMP("GMRVD") DBIA 10061 7 ; 8 ORC(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; Current Orders 9 ;Calls EN^ORQ1, ^OR(100 10 N ORCNT,ORJ,ORSITE,SITE,ORX0,ORLIST,GO 11 Q:'$L(OREXT) 12 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 13 Q:'$L($T(@GO)) 14 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 15 K ^TMP("ORR",$J),^TMP("ORDATA",$J) 16 D @GO 17 I '$D(^TMP("ORR",$J)) Q 18 S ORCNT=0,ORJ=0 19 F S ORJ=$O(^TMP("ORR",$J,ORLIST,ORJ)) Q:'+ORJ!(ORCNT'<ORMAX) S ORX0=^(ORJ) D 20 . S ORCNT=ORCNT+1,SITE=$S($L($G(^TMP("ORR",$J,ORLIST,ORJ,"facility"))):^("facility"),1:ORSITE) 21 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",1)="1^"_SITE ;Station ID 22 . D SPMRG^ORDVU("^TMP(""ORR"","_$J_","""_ORLIST_""","_ORJ_",""TX"")","^TMP(""ORDATA"","_$J_","""_ORLIST_""","_ORJ_",""WP"",2)",2) ;order text 23 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",3)="3^"_$P(ORX0,"^",6) ; status 24 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",4)="4^"_$$DATE^ORDVU($P(ORX0,"^",4)) ;start date 25 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",5)="5^"_$$DATE^ORDVU($P(ORX0,"^",5)) ;stop date 26 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",7)="7^"_$P(^TMP("ORR",$J,ORLIST,ORJ),U) ;Order Number 27 . I $O(^TMP("ORR",$J,ORLIST,ORJ,"TX",1)) S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",6)="6^[+]" ;flag for details 28 K ^TMP("ORR",$J) 29 S ROOT=$NA(^TMP("ORDATA",$J)) 30 Q 31 ORCVA ;Current Orders 32 N ORVP 33 S ORVP=DFN_";DPT(" 34 I '$D(^OR(100,"AC",ORVP)) Q 35 D EN^ORQ1(ORVP,,2,,ORDBEG,ORDEND,1) ;get current orders. ORLIST is set in ORQ1 36 Q 37 PLAILALL(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Problem list API returns ALL problems 38 N GO 39 Q:'$L(OREXT) 40 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 41 Q:'$L($T(@GO)) 42 D PLAIL 43 Q 44 PLALL ;All Problems 45 D GETLIST^GMPLHS(DFN,"ALL") 46 Q 47 PLAILI(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Problem list API returns INACTIVE problems 48 N GO 49 Q:'$L(OREXT) 50 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 51 Q:'$L($T(@GO)) 52 D PLAIL 53 Q 54 PLI ;Inactive Problems 55 D GETLIST^GMPLHS(DFN,"I") 56 Q 57 PLAILA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Problem list API returns ACTIVE problems 58 N GO 59 Q:'$L(OREXT) 60 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 61 Q:'$L($T(@GO)) 62 D PLAIL 63 Q 64 PLA ;Active Problems 65 D GETLIST^GMPLHS(DFN,"A") 66 Q 67 PLAIL ;problems(active, inactive or all) 68 ;External calls to ^GMPLHS 69 ; input: 70 ; STATUS = "A" active problems 71 ; STATUS = "I" inactive problems 72 ; STATUS = "ALL" all problems 73 ; 74 I $L($T(GCPR^OMGCOAS1)) D Q ; Call if FHIE station 200 75 . S ORDBEG=0,ORDEND=9999999,ORMAX=99999 76 . D GCPR^OMGCOAS1(DFN,"PLL",ORDBEG,ORDEND,ORMAX) 77 . S ROOT=$NA(^TMP("ORDATA",$J)) 78 N ORPROBNO,ORXREC0,ORLOC,I,K,X,ORSITE,SITE,ORMORE 79 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 80 K ^TMP("ORDATA",$J),^TMP("GMPLHS",$J) ;DBIA #1183 81 D @GO 82 I '$D(^TMP("GMPLHS",$J)) Q 83 S ORPROBNO=0 84 F I=1:1 S ORPROBNO=$O(^TMP("GMPLHS",$J,ORPROBNO)) Q:'ORPROBNO D 85 . S ORXREC0=$G(^TMP("GMPLHS",$J,ORPROBNO,0)),ORMORE=0 86 . S SITE=$S($L($G(^TMP("GMPLHS",$J,ORPROBNO,"facility"))):^("facility"),1:ORSITE) 87 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",1)="1^"_SITE ;Station ID 88 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",2)="2^"_$P(ORXREC0,U,5) ;status 89 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",3)="3^"_$G(^TMP("GMPLHS",$J,ORPROBNO,"N")) ;provider narrative 90 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",4)="4^"_$$DATE^ORDVU($P(ORXREC0,U,6)) ;onset date 91 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",5)="5^"_$$DATE^ORDVU($P(ORXREC0,U,2)) ;last modified date 92 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",6)="6^"_$P(ORXREC0,U,7) ;provider 93 . S ORLOC=0,K=0 94 . F S ORLOC=$O(^TMP("GMPLHS",$J,ORPROBNO,"C",ORLOC)) Q:'ORLOC D 95 .. S X=0 96 .. F S X=$O(^TMP("GMPLHS",$J,ORPROBNO,"C",ORLOC,X)) Q:'X D 97 ... S K=K+1,ORMORE=1 98 ... S ^TMP("ORDATA",$J,ORPROBNO,"WP",7,K)="7^"_$P($G(^TMP("GMPLHS",$J,ORPROBNO,"C",ORLOC,X,0)),U) ;note narrative 99 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",8)="8^"_$P(ORXREC0,U,14) ;exposures 100 . I ORMORE S ^TMP("ORDATA",$J,ORPROBNO,"WP",9)="9^[+]" ;flag for details 101 K ^TMP("GMPLHS",$J) 102 S ROOT=$NA(^TMP("ORDATA",$J)) 103 Q 104 SR(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Surgery Report 105 ;Call ^ORDV04A 106 N ORCNT 107 S ORCNT=0 108 K ^TMP("ORDATA",$J) 109 D ENSR^ORDV04A 110 S ROOT=$NA(^TMP("ORDATA",$J)) 111 Q 112 VS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; get vital Signs 113 D VS^ORDV04A 114 Q 115 TIUPRG(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; TIU version of progress reports 116 ;Calls to TIUSRVLO,TIUSRVR1,VASITE 117 I $L($T(GCPR^OMGCOAS1)) D Q ; Call if FHIE station 200 118 . D GCPR^OMGCOAS1(DFN,"PN",ORDBEG,ORDEND,ORMAX) 119 . S ROOT=$NA(^TMP("ORDATA",$J)) 120 N ORDT,DATE,ORCI,ORGLOB,ORGLOBA,ORTEMP,ORSITE,SITE,I,ORNODE,GO,ORIMAG 121 Q:'$L(OREXT) 122 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 123 Q:'$L($T(@GO)) 124 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 125 D @GO 126 I '$D(@ORGLOB) Q 127 S ORNODE=0,ORCI=0 128 K ^TMP("ORDATA",$J) 129 F S ORNODE=$O(@ORGLOB@(ORNODE)) Q:'ORNODE!(ORCI'<ORMAX) D 130 . S ORTEMP=@ORGLOB@(ORNODE) 131 . S ORIMAG=$P($$RESOLVE^TIUSRVLO($P(ORTEMP,U)),U,10) 132 . S DATE=$P(ORTEMP,U,3) ;date 133 . S SITE=$S($L($G(@ORGLOB@(ORNODE,"facility"))):^("facility"),1:ORSITE) 134 . S ^TMP("ORDATA",$J,ORNODE,"WP",1)="1^"_SITE ;Station ID 135 . S ^TMP("ORDATA",$J,ORNODE,"WP",2)="2^"_$P(ORTEMP,U) ;TIU ien 136 . S ^TMP("ORDATA",$J,ORNODE,"WP",3)="3^"_$$DATE^ORDVU(DATE) ;date 137 . S ^TMP("ORDATA",$J,ORNODE,"WP",4)="4^"_$P(ORTEMP,U,2) ;type 138 . S ^TMP("ORDATA",$J,ORNODE,"WP",5)="5^"_$P($P(ORTEMP,U,5),";",2) ;author 139 . S ORCI=ORCI+1 140 . D TGET^TIUSRVR1(.ORGLOBA,$P(ORTEMP,U)) ;Call back to get note text 141 . D SPMRG^ORDVU($NA(@ORGLOBA),$NA(^TMP("ORDATA",$J,ORNODE,"WP",6)),6) ;Notes Text 142 . I $O(@ORGLOBA@(0)) S ^TMP("ORDATA",$J,ORNODE,"WP",7)="7^[+]" 143 . S ^TMP("ORDATA",$J,ORNODE,"WP",8)="8^"_ORIMAG 144 . K @ORGLOBA 145 K @ORGLOB 146 S ROOT=$NA(^TMP("ORDATA",$J)) 147 Q 148 TPRG ;TIU Progress Notes 149 D CONTEXT^TIUSRVLO(.ORGLOB,3,5,DFN,ORDBEG,ORDEND,,ORMAX) 150 Q 151 TIUDCS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; Discharge Summaries 152 ;Calls VASITE, DIQ1, TIUSRVLO 153 I $L($T(GCPR^OMGCOAS1)) D Q ; Call if FHIE station 200 154 . D GCPR^OMGCOAS1(DFN,"DS",ORDBEG,ORDEND,ORMAX) 155 . S ROOT=$NA(^TMP("ORDATA",$J)) 156 N ORGLOB,ORGLOBA,ORI,ORNODE,ORICDIEN,ORARRAY,ORTEMP,ORSITE,SITE,DIC,DR,DIQ,DA,GO 157 Q:'$L(OREXT) 158 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 159 Q:'$L($T(@GO)) 160 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 161 D @GO 162 I '$D(@ORGLOB) Q 163 K ^TMP("ORDATA",$J) 164 S ORNODE=0,ORI=0 165 F S ORNODE=$O(@ORGLOB@(ORNODE)) Q:'ORNODE!(ORI'<ORMAX) D 166 . S ORTEMP=@ORGLOB@(ORNODE) 167 . S SITE=$S($L($G(@ORGLOB@(ORNODE,"facility"))):^("facility"),1:ORSITE) 168 . S ^TMP("ORDATA",$J,ORNODE,"WP",1)="1^"_SITE ;Station ID 169 . K ORARRAY S DIC=8925,DA=$P(ORTEMP,U),DR=".05;.07;.08;1202;1502",DIQ="ORARRAY" 170 . D EN^DIQ1 171 . S DIQ="ORARRAY(8925,"_DA_")" 172 . S ^TMP("ORDATA",$J,ORNODE,"WP",2)="2^"_$$DATEMMM^ORDVU($G(@DIQ@(.07))) ;episode begin date/time 173 . S ^TMP("ORDATA",$J,ORNODE,"WP",3)="3^"_$$DATEMMM^ORDVU($G(@DIQ@(.08))) ;episode end date/time 174 . S ^TMP("ORDATA",$J,ORNODE,"WP",4)="4^"_$G(@DIQ@(1202)) ;author/dicator 175 . S ^TMP("ORDATA",$J,ORNODE,"WP",5)="5^"_$G(@DIQ@(1502)) ;signed by 176 . S ^TMP("ORDATA",$J,ORNODE,"WP",6)="6^"_$G(@DIQ@(.05)) ;status 177 . S ORI=ORI+1 178 . D TGET^TIUSRVR1(.ORGLOBA,$P(ORTEMP,U)) ;Call to get summary text 179 . D SPMRG^ORDVU($NA(@ORGLOBA),$NA(^TMP("ORDATA",$J,ORNODE,"WP",7)),7) ;summary Text 180 . I $O(@ORGLOBA@(0)) S ^TMP("ORDATA",$J,ORNODE,"WP",8)="8^[+]" ;detail flag 181 . K @ORGLOBA 182 K @ORGLOB 183 S ROOT=$NA(^TMP("ORDATA",$J)) 184 Q 185 TDCS ;TIU Discharge Summary 186 D CONTEXT^TIUSRVLO(.ORGLOB,244,5,DFN,ORDBEG,ORDEND,,ORMAX) 187 Q 1 ORDV04 ; SLC/DAN - OE/RR ;7/21/04 15:32 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,148,160,208,195,241,215,274**;Dec 17,1997;Build 20 3 ;OE/RR COMPONENT 4 ; 5 ; ^TMP("GMPLHS",$J) used per DBIA 1183 6 ; ^UTILITY and ^TMP("GMRVD") used per DBIA 10061 7 ; 8 ORC(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; Current Orders 9 ;External calls to EN^ORQ1, ^OR(100 10 N ORCNT,ORJ,ORSITE,SITE,ORX0,ORLIST,GO 11 Q:'$L(OREXT) 12 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 13 Q:'$L($T(@GO)) 14 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 15 K ^TMP("ORR",$J),^TMP("ORDATA",$J) 16 D @GO 17 I '$D(^TMP("ORR",$J)) Q 18 S ORCNT=0,ORJ=0 19 F S ORJ=$O(^TMP("ORR",$J,ORLIST,ORJ)) Q:'+ORJ!(ORCNT'<ORMAX) S ORX0=^(ORJ) D 20 . S ORCNT=ORCNT+1,SITE=$S($L($G(^TMP("ORR",$J,ORLIST,ORJ,"facility"))):^("facility"),1:ORSITE) 21 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",1)="1^"_SITE ;Station ID 22 . D SPMRG^ORDVU("^TMP(""ORR"","_$J_","""_ORLIST_""","_ORJ_",""TX"")","^TMP(""ORDATA"","_$J_","""_ORLIST_""","_ORJ_",""WP"",2)",2) ;order text 23 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",3)="3^"_$P(ORX0,"^",6) ; status 24 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",4)="4^"_$$DATE^ORDVU($P(ORX0,"^",4)) ;start date 25 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",5)="5^"_$$DATE^ORDVU($P(ORX0,"^",5)) ;stop date 26 . S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",7)="7^"_$P(^TMP("ORR",$J,ORLIST,ORJ),U) ;Order Number 27 . I $O(^TMP("ORR",$J,ORLIST,ORJ,"TX",1)) S ^TMP("ORDATA",$J,ORLIST,ORJ,"WP",6)="6^[+]" ;flag for details 28 K ^TMP("ORR",$J) 29 S ROOT=$NA(^TMP("ORDATA",$J)) 30 Q 31 ORCVA ;VA call to get Current Orders 32 N ORVP 33 S ORVP=DFN_";DPT(" 34 I '$D(^OR(100,"AC",ORVP)) Q 35 D EN^ORQ1(ORVP,,2,,ORDBEG,ORDEND,1) ;get current orders. ORLIST is set in ORQ1 36 Q 37 PLAILALL(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Problem list API returns ALL problems 38 N GO 39 Q:'$L(OREXT) 40 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 41 Q:'$L($T(@GO)) 42 D PLAIL 43 Q 44 PLALL ;Jump here for All Problems 45 D GETLIST^GMPLHS(DFN,"ALL") 46 Q 47 PLAILI(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Problem list API returns INACTIVE problems 48 N GO 49 Q:'$L(OREXT) 50 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 51 Q:'$L($T(@GO)) 52 D PLAIL 53 Q 54 PLI ;Jump here for Inactive Problems 55 D GETLIST^GMPLHS(DFN,"I") 56 Q 57 PLAILA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Problem list API returns ACTIVE problems 58 N GO 59 Q:'$L(OREXT) 60 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 61 Q:'$L($T(@GO)) 62 D PLAIL 63 Q 64 PLA ;Jump here for Active Problems 65 D GETLIST^GMPLHS(DFN,"A") 66 Q 67 PLAIL ;problems(active, inactive or all) 68 ;External calls to ^GMPLHS 69 ; input: 70 ; STATUS = "A" to produce active problems 71 ; STATUS = "I" to produce inactive problems 72 ; STATUS = "ALL" to produce all problems 73 ; 74 N ORPROBNO,ORXREC0,ORLOC,I,K,X,ORSITE,SITE,ORMORE 75 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 76 K ^TMP("ORDATA",$J),^TMP("GMPLHS",$J) ;DBIA #1183 77 D @GO 78 I '$D(^TMP("GMPLHS",$J)) Q 79 S ORPROBNO=0 80 F I=1:1:ORMAX S ORPROBNO=$O(^TMP("GMPLHS",$J,ORPROBNO)) Q:'ORPROBNO D 81 . S ORXREC0=$G(^TMP("GMPLHS",$J,ORPROBNO,0)),ORMORE=0 82 . S SITE=$S($L($G(^TMP("GMPLHS",$J,ORPROBNO,"facility"))):^("facility"),1:ORSITE) 83 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",1)="1^"_SITE ;Station ID 84 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",2)="2^"_$P(ORXREC0,U,5) ;status 85 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",3)="3^"_$G(^TMP("GMPLHS",$J,ORPROBNO,"N")) ;provider narrative 86 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",4)="4^"_$$DATE^ORDVU($P(ORXREC0,U,6)) ;onset date 87 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",5)="5^"_$$DATE^ORDVU($P(ORXREC0,U,2)) ;last modified date 88 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",6)="6^"_$P(ORXREC0,U,7) ;provider 89 . S ORLOC=0,K=0 90 . F S ORLOC=$O(^TMP("GMPLHS",$J,ORPROBNO,"C",ORLOC)) Q:'ORLOC D 91 .. S X=0 92 .. F S X=$O(^TMP("GMPLHS",$J,ORPROBNO,"C",ORLOC,X)) Q:'X D 93 ... S K=K+1,ORMORE=1 94 ... S ^TMP("ORDATA",$J,ORPROBNO,"WP",7,K)="7^"_$P($G(^TMP("GMPLHS",$J,ORPROBNO,"C",ORLOC,X,0)),U) ;note narrative 95 . S ^TMP("ORDATA",$J,ORPROBNO,"WP",8)="8^"_$P(ORXREC0,U,14) ;exposures 96 . I ORMORE S ^TMP("ORDATA",$J,ORPROBNO,"WP",9)="9^[+]" ;flag for details 97 K ^TMP("GMPLHS",$J) 98 S ROOT=$NA(^TMP("ORDATA",$J)) 99 Q 100 SR(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Surgery Report 101 ;External call to ^ORDV04A (external calls are noted in that routine) 102 N ORCNT 103 S ORCNT=0 104 K ^TMP("ORDATA",$J) 105 D ENSR^ORDV04A 106 S ROOT=$NA(^TMP("ORDATA",$J)) 107 Q 108 VS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; get vital Signs 109 ;External calls to GMRVUT0 110 I $L($T(GCPR^OMGCOAS1)) D Q ; OMGCOAS1 routine only on Station 200 111 . D GCPR^OMGCOAS1(DFN,"VIT",ORDBEG,ORDEND,ORMAX) 112 . S ROOT=$NA(^TMP("ORDATA",$J)) 113 N ORDT,I,TYPE,IEN,GMRVSTR,ORSITE,SITE,PLACE,GO 114 Q:'$L(OREXT) 115 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 116 Q:'$L($T(@GO)) 117 K ^UTILITY($J,"GMRVD"),^TMP("ORDATA",$J) 118 S GMRVSTR="T;P;R;BP;HT;WT;PN;PO2;CVP;CG",GMRVSTR(0)=ORDBEG_"^"_ORDEND_"^"_ORMAX_"^"_1 119 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 120 D @GO 121 S ORDT=0 122 F I=1:1 S ORDT=$O(^UTILITY($J,"GMRVD",ORDT)) Q:'+ORDT!(I>ORMAX) D ;DBIA 10061 123 . S SITE=$S($L($G(^TMP("GMRVD",$J,ORDT,"facility"))):^("facility"),1:ORSITE) ;DBIA 10061 124 . S ^TMP("ORDATA",$J,"WP",ORDT,1)="1^"_SITE 125 . S ^TMP("ORDATA",$J,"WP",ORDT,2)="2^"_$$DATE^ORDVU(9999999-ORDT) ;date vitals taken 126 . S TYPE="" 127 . F S TYPE=$O(^UTILITY($J,"GMRVD",ORDT,TYPE)) Q:TYPE="" D 128 .. S IEN=$O(^UTILITY($J,"GMRVD",ORDT,TYPE,0)) Q:'IEN 129 .. S PLACE=$S(TYPE="T":3,TYPE="P":4,TYPE="R":5,TYPE="BP":6,TYPE="HT":7,TYPE="WT":8,TYPE="PN":9,TYPE="PO2":10,TYPE="CVP":11,TYPE="CG":12,1:13) 130 .. S ^TMP("ORDATA",$J,"WP",ORDT,PLACE)=PLACE_"^"_$P($G(^UTILITY($J,"GMRVD",ORDT,TYPE,IEN)),"^",8) ;Get value of vitals from global 131 K ^UTILITY($J,"GMRVD") 132 S ROOT=$NA(^TMP("ORDATA",$J)) 133 Q 134 TIUPRG(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; TIU version of progress reports 135 ;External calls to TIUSRVLO,TIUSRVR1,VASITE 136 I $L($T(GCPR^OMGCOAS1)) D Q ; Call if FHIE station 200 137 . D GCPR^OMGCOAS1(DFN,"PN",ORDBEG,ORDEND,ORMAX) 138 . S ROOT=$NA(^TMP("ORDATA",$J)) 139 N ORDT,DATE,ORCI,ORGLOB,ORGLOBA,ORTEMP,ORSITE,SITE,I,ORNODE,GO,ORIMAG 140 Q:'$L(OREXT) 141 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 142 Q:'$L($T(@GO)) 143 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 144 D @GO 145 I '$D(@ORGLOB) Q 146 S ORNODE=0,ORCI=0 147 K ^TMP("ORDATA",$J) 148 F S ORNODE=$O(@ORGLOB@(ORNODE)) Q:'ORNODE!(ORCI'<ORMAX) D 149 . S ORTEMP=@ORGLOB@(ORNODE) 150 . S ORIMAG=$P($$RESOLVE^TIUSRVLO($P(ORTEMP,U)),U,10) 151 . S DATE=$P(ORTEMP,U,3) ;date 152 . S SITE=$S($L($G(@ORGLOB@(ORNODE,"facility"))):^("facility"),1:ORSITE) 153 . S ^TMP("ORDATA",$J,ORNODE,"WP",1)="1^"_SITE ;Station ID 154 . S ^TMP("ORDATA",$J,ORNODE,"WP",2)="2^"_$P(ORTEMP,U) ;TIU ien 155 . S ^TMP("ORDATA",$J,ORNODE,"WP",3)="3^"_$$DATE^ORDVU(DATE) ;date 156 . S ^TMP("ORDATA",$J,ORNODE,"WP",4)="4^"_$P(ORTEMP,U,2) ;type 157 . S ^TMP("ORDATA",$J,ORNODE,"WP",5)="5^"_$P($P(ORTEMP,U,5),";",2) ;author 158 . S ORCI=ORCI+1 159 . D TGET^TIUSRVR1(.ORGLOBA,$P(ORTEMP,U)) ;Call back to get note text 160 . D SPMRG^ORDVU($NA(@ORGLOBA),$NA(^TMP("ORDATA",$J,ORNODE,"WP",6)),6) ;Notes Text 161 . I $O(@ORGLOBA@(0)) S ^TMP("ORDATA",$J,ORNODE,"WP",7)="7^[+]" 162 . S ^TMP("ORDATA",$J,ORNODE,"WP",8)="8^"_ORIMAG 163 . K @ORGLOBA 164 K @ORGLOB 165 S ROOT=$NA(^TMP("ORDATA",$J)) 166 Q 167 TPRG ;Jump here for Tiu Progress Notes 168 D CONTEXT^TIUSRVLO(.ORGLOB,3,5,DFN,ORDBEG,ORDEND,,ORMAX) 169 Q 170 TIUDCS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; Discharge Summaries 171 ;External calls to VASITE, DIQ1, TIUSRVLO 172 I $L($T(GCPR^OMGCOAS1)) D Q ; Call if FHIE station 200 173 . D GCPR^OMGCOAS1(DFN,"DS",ORDBEG,ORDEND,ORMAX) 174 . S ROOT=$NA(^TMP("ORDATA",$J)) 175 N ORGLOB,ORGLOBA,ORI,ORNODE,ORICDIEN,ORARRAY,ORTEMP,ORSITE,SITE,DIC,DR,DIQ,DA,GO 176 Q:'$L(OREXT) 177 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 178 Q:'$L($T(@GO)) 179 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 180 D @GO 181 I '$D(@ORGLOB) Q 182 K ^TMP("ORDATA",$J) 183 S ORNODE=0,ORI=0 184 F S ORNODE=$O(@ORGLOB@(ORNODE)) Q:'ORNODE!(ORI'<ORMAX) D 185 . S ORTEMP=@ORGLOB@(ORNODE) 186 . S SITE=$S($L($G(@ORGLOB@(ORNODE,"facility"))):^("facility"),1:ORSITE) 187 . S ^TMP("ORDATA",$J,ORNODE,"WP",1)="1^"_SITE ;Station ID 188 . K ORARRAY S DIC=8925,DA=$P(ORTEMP,U),DR=".05;.07;.08;1202;1502",DIQ="ORARRAY" 189 . D EN^DIQ1 190 . S DIQ="ORARRAY(8925,"_DA_")" 191 . S ^TMP("ORDATA",$J,ORNODE,"WP",2)="2^"_$$DATEMMM^ORDVU($G(@DIQ@(.07))) ;episode begin date/time 192 . S ^TMP("ORDATA",$J,ORNODE,"WP",3)="3^"_$$DATEMMM^ORDVU($G(@DIQ@(.08))) ;episode end date/time 193 . S ^TMP("ORDATA",$J,ORNODE,"WP",4)="4^"_$G(@DIQ@(1202)) ;author/dicator 194 . S ^TMP("ORDATA",$J,ORNODE,"WP",5)="5^"_$G(@DIQ@(1502)) ;signed by 195 . S ^TMP("ORDATA",$J,ORNODE,"WP",6)="6^"_$G(@DIQ@(.05)) ;status 196 . S ORI=ORI+1 197 . D TGET^TIUSRVR1(.ORGLOBA,$P(ORTEMP,U)) ;Call back to get summary text 198 . D SPMRG^ORDVU($NA(@ORGLOBA),$NA(^TMP("ORDATA",$J,ORNODE,"WP",7)),7) ;summary Text 199 . I $O(@ORGLOBA@(0)) S ^TMP("ORDATA",$J,ORNODE,"WP",8)="8^[+]" ;detail flag 200 . K @ORGLOBA 201 K @ORGLOB 202 S ROOT=$NA(^TMP("ORDATA",$J)) 203 Q 204 TDCS ;Jump here for TIU Discharge Summary 205 D CONTEXT^TIUSRVLO(.ORGLOB,244,5,DFN,ORDBEG,ORDEND,,ORMAX) 206 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV04A.m
r613 r623 1 ORDV04A ; SLC/DAN/dcm - OE/RR ;7/30/01 14:33 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,243**;Dec 17,1997;Build 242 3 ; 4 Q 5 ENSR ; Entry point for component 6 ;External calls to ^GMTSROB, ^DIQ, ^GMTSORC, ^DIWP 7 ;External references to ^SRF, ^DD, ^ICPT 8 N GMIDT,GMN,SURG 9 I '$D(^SRF("B",DFN)) Q 10 S GMN=0 F S GMN=$O(^SRF("B",DFN,GMN)) Q:GMN'>0 D SORT 11 I '$D(SURG) Q 12 S GMIDT=0 F S GMIDT=$O(SURG(GMIDT)) Q:GMIDT'>0!(ORCNT'<ORMAX) S GMN=SURG(GMIDT) D EXTRCT 13 Q 14 ; 15 SORT ; Sort surgeries by inverted date 16 N GMDT 17 S GMDT=$P(^SRF(GMN,0),U,9) I GMDT>ORDBEG&(GMDT<ORDEND) D 18 . F Q:'$D(SURG(9999999-GMDT)) S GMDT=GMDT+.0001 19 . S SURG(9999999-GMDT)=GMN 20 Q 21 EXTRCT ; Extract surgical case record 22 N X,GMI,GMDT,OPPRC,POSDX,PREDX,SPEC,STATUS,SURGEON,VER 23 N DCTDTM,TRSDTM,Y,C,DIWL,DIWF,ORSITE,ORMORE,SITE 24 S ORCNT=ORCNT+1,ORMORE=0 25 S GMDT=$$DATE^ORDVU($P(^SRF(GMN,0),U,9)) 26 D STATUS^GMTSROB S:'$D(STATUS) STATUS="UNKNOWN" 27 S X=$P(^SRF(GMN,0),U,4) I X>0 S Y=X,C=$P(^DD(130,.04,0),U,2) D Y^DIQ S SPEC=Y K Y 28 I $D(^SRF(GMN,.1)) S X=$P(^SRF(GMN,.1),U,4) I X>0 S Y=X,C=$P(^DD(130,.14,0),U,2) D Y^DIQ S SURGEON=Y K Y 29 S VER=$S($G(^SRF(GMN,"VER"))'="Y":"(Unverified)",1:"") 30 S PREDX(0)=$S($G(^SRF(GMN,33))]"":$P(^(33),U),1:"") S GMI=0 F S GMI=$O(^SRF(GMN,14,GMI)) Q:GMI'>0 S PREDX(GMI)=$P(^SRF(GMN,14,GMI,0),U) 31 S POSDX(0)=$S($G(^SRF(GMN,34))]"":$P(^(34),U),1:"") S GMI=0 F S GMI=$O(^SRF(GMN,15,GMI)) Q:GMI'>0 S POSDX(GMI)=$P(^SRF(GMN,15,GMI,0),U) 32 S OPPRC(0)=$P($G(^SRF(GMN,"OP")),U,1,2) S:$P(OPPRC(0),U,2)]"" $P(OPPRC(0),U,2)=$P($$CPT^ICPTCOD($P($G(^SRF(GMN,"OP")),U,2)),U,3) D 33 . S GMI=0 F S GMI=$O(^SRF(GMN,13,GMI)) Q:GMI'>0 S OPPRC(GMI)=$P($G(^SRF(GMN,13,GMI,0)),U)_U_$G(^SRF(GMN,13,GMI,2)) S:$P(OPPRC(GMI),U,2)]"" $P(OPPRC(GMI),U,2)=$P($$CPT^ICPTCOD($P($G(^SRF(GMN,13,GMI,2)),U)),U,3) 34 S X=$P($G(^SRF(GMN,31)),U,6) S:X>0 DCTDTM=$$DATE^ORDVU(X) 35 S X=$P($G(^SRF(GMN,31)),U,7) S:X>0 TRSDTM=$$DATE^ORDVU(X) 36 S DIWL=0,DIWF="N",ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 37 K ^UTILITY($J,"W") 38 I $D(^SRF(GMN,12)) F GMI=1:1:$P(^SRF(GMN,12,0),U,4) S X=^SRF(GMN,12,GMI,0) D ^DIWP 39 S SITE=ORSITE 40 S ^TMP("ORDATA",$J,GMIDT,"WP",1)="1^"_SITE ;Station ID 41 S ^TMP("ORDATA",$J,GMIDT,"WP",2)="2^"_GMDT ; date 42 ; 43 ; Operative Procedure(s) 44 S GMI="" F S GMI=$O(OPPRC(GMI)) Q:GMI="" D S:GMI ORMORE=1 45 . S ^TMP("ORDATA",$J,GMIDT,"WP",3,GMI)="3^"_$P(OPPRC(GMI),U)_$S($P(OPPRC(GMI),U,2)]"":" - "_$P(OPPRC(GMI),U,2),1:"") 46 ; 47 S ^TMP("ORDATA",$J,GMIDT,"WP",4)="4^"_$G(SPEC) ;surgical specialty 48 ; 49 S ^TMP("ORDATA",$J,GMIDT,"WP",5)="5^"_$G(SURGEON) ; surgeon 50 S ^TMP("ORDATA",$J,GMIDT,"WP",6)="6^"_$G(STATUS) ; op status 51 ; 52 ; Pre-operative diagnosis 53 S GMI="" F S GMI=$O(PREDX(GMI)) Q:GMI="" D S:GMI ORMORE=1 54 . S ^TMP("ORDATA",$J,GMIDT,"WP",7,GMI)="7^"_PREDX(GMI) 55 ; 56 ; Post-operative diagnosis 57 S GMI="" F S GMI=$O(POSDX(GMI)) Q:GMI="" D S:GMI ORMORE=1 58 . S ^TMP("ORDATA",$J,GMIDT,"WP",8,GMI)="8^"_POSDX(GMI) 59 ; 60 ; Lab work? Y/N 61 S ^TMP("ORDATA",$J,GMIDT,"WP",9)="9^"_$S($O(^SRF(GMN,9,0)):"Yes",1:"No") 62 S ^TMP("ORDATA",$J,GMIDT,"WP",10)="10^"_$G(DCTDTM) ; dictation time 63 S ^TMP("ORDATA",$J,GMIDT,"WP",11)="11^"_$G(TRSDTM) ; transcription time 64 ; 65 ; surgeon's dictation 66 I $D(^UTILITY($J,"W")) D S ORMORE=1 67 . K ^TMP("ORHSSRT",$J) 68 . F GMI=1:1:^UTILITY($J,"W",DIWL) D 69 .. S ^TMP("ORHSSRT",$J,GMIDT,"WP",GMI)=^UTILITY($J,"W",DIWL,GMI,0) 70 . D SPMRG^ORDVU($NA(^TMP("ORHSSRT",$J,GMIDT,"WP")),$NA(^TMP("ORDATA",$J,GMIDT,"WP",12)),12) 71 . K ^UTILITY($J,"W") 72 . K ^TMP("ORHSSRT",$J) 73 I ORMORE S ^TMP("ORDATA",$J,GMIDT,"WP",13)="13^[+]" ;flag for detail 74 Q 75 VS ;Continuation of Vitals Extract (from ORDV04) 76 ;Calls GMRVUT0 77 I $L($T(GCPR^OMGCOAS1)) D Q ; OMGCOAS1 routine only on Station 200 78 . D GCPR^OMGCOAS1(DFN,"VIT",ORDBEG,ORDEND,ORMAX) 79 . S ROOT=$NA(^TMP("ORDATA",$J)) 80 N ORDT,I,TYPE,IEN,GMRVSTR,ORSITE,SITE,PLACE,GO,X,QUALIF,NODE,UNITS,UCNT,QCNT,ORI 81 Q:'$L(OREXT) 82 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 83 Q:'$L($T(@GO)) 84 K ^UTILITY($J,"GMRVD"),^TMP("ORDATA",$J) 85 S GMRVSTR="T;P;R;BP;HT;WT;PN;PO2;CVP;CG",GMRVSTR(0)=ORDBEG_"^"_ORDEND_"^"_ORMAX_"^"_1 86 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 87 D @GO 88 S ORDT=0 89 F I=1:1 S ORDT=$O(^UTILITY($J,"GMRVD",ORDT)) Q:'+ORDT!(I>ORMAX) D ;DBIA 4791 90 . S SITE=$S($L($G(^TMP("GMRVD",$J,ORDT,"facility"))):^("facility"),1:ORSITE) 91 . S ^TMP("ORDATA",$J,"WP",ORDT,1)="1^"_SITE 92 . S ^TMP("ORDATA",$J,"WP",ORDT,2)="2^"_$$DATE^ORDVU(9999999-ORDT) ;date vitals taken 93 . K UNITS,QUALIF 94 . S TYPE="",(UCNT,QCNT)=1,UNITS(UCNT)="",QUALIF(QCNT)="",QUALIF="" 95 . F S TYPE=$O(^UTILITY($J,"GMRVD",ORDT,TYPE)) Q:TYPE="" D 96 .. S IEN=$O(^UTILITY($J,"GMRVD",ORDT,TYPE,0)) Q:'IEN S NODE=$G(^(IEN)) 97 .. S PLACE=$S(TYPE="T":3,TYPE="P":4,TYPE="R":5,TYPE="BP":6,TYPE="HT":7,TYPE="WT":8,TYPE="PN":9,TYPE="PO2":10,TYPE="CVP":11,TYPE="CG":12,1:0) 98 .. I PLACE S ^TMP("ORDATA",$J,"WP",ORDT,PLACE)=PLACE_"^"_$P(NODE,"^",8) ;Get value of vitals from global 99 .. S X=$$UNITMAP(TYPE) S:$L(UNITS(UCNT))>60 UCNT=UCNT+1,UNITS(UCNT)="" S UNITS(UCNT)=$S($L(UNITS(UCNT)):UNITS(UCNT)_","_$$MAP(TYPE)_":",1:$$MAP(TYPE)_":")_X ;Units 100 .. I TYPE="PO2" D 101 ... I $L($P(NODE,"^",15)) S ^TMP("ORDATA",$J,"WP",ORDT,13)=13_"^"_$P($G(^UTILITY($J,"GMRVD",ORDT,TYPE,IEN)),"^",15) ; Flow Rate 102 ... I $L($P(NODE,"^",16)) S ^TMP("ORDATA",$J,"WP",ORDT,14)=14_"^"_$P($G(^UTILITY($J,"GMRVD",ORDT,TYPE,IEN)),"^",16) ; O2 Concentration 103 .. I $L($P(NODE,"^",17)) S X=$P(NODE,"^",17) D 104 ... I QUALIF'[($$MAP(TYPE)_":"_X) D 105 .... S QUALIF=$S($L(QUALIF):QUALIF_" , "_$$MAP(TYPE)_":",1:$$MAP(TYPE)_":")_X ; Qualifier 106 .... S:$L(QUALIF(QCNT))>60 QCNT=QCNT+1,QUALIF(QCNT)="" 107 .... S QUALIF(QCNT)=$S($L(QUALIF(QCNT)):QUALIF(QCNT)_" , "_$$MAP(TYPE)_":",1:$$MAP(TYPE)_":")_X ; Qualifier 108 .. I TYPE="WT",$L($P(NODE,"^",14)) D 109 ... S ^TMP("ORDATA",$J,"WP",ORDT,16)=16_"^"_$P(NODE,"^",14) ; BMI 110 . I $O(QUALIF(0)) D 111 .. S ORI=0 F S ORI=$O(QUALIF(ORI)) Q:'ORI D 112 ... S ^TMP("ORDATA",$J,"WP",ORDT,15,ORI)="15^"_QUALIF(ORI) 113 . I $O(UNITS(0)) D 114 .. S ORI=0 F S ORI=$O(UNITS(ORI)) Q:'ORI D 115 ... S ^TMP("ORDATA",$J,"WP",ORDT,17,ORI)="17^"_UNITS(ORI) 116 K ^UTILITY($J,"GMRVD") 117 S ROOT=$NA(^TMP("ORDATA",$J)) 118 Q 119 MAP(TEXT) ;Map test code to abbreviation 120 Q:'$L($G(TEXT)) "" 121 I TEXT="T" Q "TEMP" 122 I TEXT="P" Q "PULSE" 123 I TEXT="R" Q "RESP" 124 I TEXT="BP" Q "BP" 125 I TEXT="HT" Q "HT" 126 I TEXT="WT" Q "WT" 127 I TEXT="PN" Q "PAIN" 128 I TEXT="PO2" Q "POx" 129 I TEXT="CVP" Q "CVP" 130 I TEXT="CG" Q "C/G" 131 Q TEXT 132 UNITMAP(TEXT) ;Map units to abbreviation 133 Q:'$L($G(TEXT)) "" 134 I TEXT="T" Q "F" 135 I TEXT="P" Q "/min" 136 I TEXT="R" Q " /min" 137 I TEXT="BP" Q "mmHg" 138 I TEXT="HT" Q "in" 139 I TEXT="WT" Q "lb" 140 I TEXT="PN" Q "" 141 I TEXT="PO2" Q "%SpO2" 142 I TEXT="CVP" Q "cmH2O" 143 I TEXT="CG" Q " in" 144 Q "" 1 ORDV04A ;SLC/DAN - OE/RR ;7/30/01 14:33 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109**;Dec 17,1997 3 ; 4 Q 5 ENSR ; Entry point for component 6 ;External calls to ^GMTSROB, ^DIQ, ^GMTSORC, ^DIWP 7 ;External references to ^SRF, ^DD, ^ICPT 8 N GMIDT,GMN,SURG 9 I '$D(^SRF("B",DFN)) Q 10 S GMN=0 F S GMN=$O(^SRF("B",DFN,GMN)) Q:GMN'>0 D SORT 11 I '$D(SURG) Q 12 S GMIDT=0 F S GMIDT=$O(SURG(GMIDT)) Q:GMIDT'>0!(ORCNT'<ORMAX) S GMN=SURG(GMIDT) D EXTRCT 13 Q 14 ; 15 SORT ; Sort surgeries by inverted date 16 N GMDT 17 S GMDT=$P(^SRF(GMN,0),U,9) I GMDT>ORDBEG&(GMDT<ORDEND) D 18 . F Q:'$D(SURG(9999999-GMDT)) S GMDT=GMDT+.0001 19 . S SURG(9999999-GMDT)=GMN 20 Q 21 EXTRCT ; Extract surgical case record 22 N X,GMI,GMDT,OPPRC,POSDX,PREDX,SPEC,STATUS,SURGEON,VER 23 N DCTDTM,TRSDTM,Y,C,DIWL,DIWF,ORSITE,ORMORE,SITE 24 S ORCNT=ORCNT+1,ORMORE=0 25 S GMDT=$$DATE^ORDVU($P(^SRF(GMN,0),U,9)) 26 D STATUS^GMTSROB S:'$D(STATUS) STATUS="UNKNOWN" 27 S X=$P(^SRF(GMN,0),U,4) I X>0 S Y=X,C=$P(^DD(130,.04,0),U,2) D Y^DIQ S SPEC=Y K Y 28 I $D(^SRF(GMN,.1)) S X=$P(^SRF(GMN,.1),U,4) I X>0 S Y=X,C=$P(^DD(130,.14,0),U,2) D Y^DIQ S SURGEON=Y K Y 29 S VER=$S($G(^SRF(GMN,"VER"))'="Y":"(Unverified)",1:"") 30 S PREDX(0)=$S($G(^SRF(GMN,33))]"":$P(^(33),U),1:"") S GMI=0 F S GMI=$O(^SRF(GMN,14,GMI)) Q:GMI'>0 S PREDX(GMI)=$P(^SRF(GMN,14,GMI,0),U) 31 S POSDX(0)=$S($G(^SRF(GMN,34))]"":$P(^(34),U),1:"") S GMI=0 F S GMI=$O(^SRF(GMN,15,GMI)) Q:GMI'>0 S POSDX(GMI)=$P(^SRF(GMN,15,GMI,0),U) 32 S OPPRC(0)=$P($G(^SRF(GMN,"OP")),U,1,2) S:$P(OPPRC(0),U,2)]"" $P(OPPRC(0),U,2)=$P($$CPT^ICPTCOD($P($G(^SRF(GMN,"OP")),U,2)),U,3) D 33 . S GMI=0 F S GMI=$O(^SRF(GMN,13,GMI)) Q:GMI'>0 S OPPRC(GMI)=$P($G(^SRF(GMN,13,GMI,0)),U)_U_$G(^SRF(GMN,13,GMI,2)) S:$P(OPPRC(GMI),U,2)]"" $P(OPPRC(GMI),U,2)=$P($$CPT^ICPTCOD($P($G(^SRF(GMN,13,GMI,2)),U)),U,3) 34 S X=$P($G(^SRF(GMN,31)),U,6) S:X>0 DCTDTM=$$DATE^ORDVU(X) 35 S X=$P($G(^SRF(GMN,31)),U,7) S:X>0 TRSDTM=$$DATE^ORDVU(X) 36 S DIWL=0,DIWF="N",ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 37 K ^UTILITY($J,"W") 38 I $D(^SRF(GMN,12)) F GMI=1:1:$P(^SRF(GMN,12,0),U,4) S X=^SRF(GMN,12,GMI,0) D ^DIWP 39 S SITE=ORSITE 40 S ^TMP("ORDATA",$J,GMIDT,"WP",1)="1^"_SITE ;Station ID 41 S ^TMP("ORDATA",$J,GMIDT,"WP",2)="2^"_GMDT ; date 42 ; 43 ; Operative Procedure(s) 44 S GMI="" F S GMI=$O(OPPRC(GMI)) Q:GMI="" D S:GMI ORMORE=1 45 . S ^TMP("ORDATA",$J,GMIDT,"WP",3,GMI)="3^"_$P(OPPRC(GMI),U)_$S($P(OPPRC(GMI),U,2)]"":" - "_$P(OPPRC(GMI),U,2),1:"") 46 ; 47 S ^TMP("ORDATA",$J,GMIDT,"WP",4)="4^"_$G(SPEC) ;surgical specialty 48 ; 49 S ^TMP("ORDATA",$J,GMIDT,"WP",5)="5^"_$G(SURGEON) ; surgeon 50 S ^TMP("ORDATA",$J,GMIDT,"WP",6)="6^"_$G(STATUS) ; op status 51 ; 52 ; Pre-operative diagnosis 53 S GMI="" F S GMI=$O(PREDX(GMI)) Q:GMI="" D S:GMI ORMORE=1 54 . S ^TMP("ORDATA",$J,GMIDT,"WP",7,GMI)="7^"_PREDX(GMI) 55 ; 56 ; Post-operative diagnosis 57 S GMI="" F S GMI=$O(POSDX(GMI)) Q:GMI="" D S:GMI ORMORE=1 58 . S ^TMP("ORDATA",$J,GMIDT,"WP",8,GMI)="8^"_POSDX(GMI) 59 ; 60 ; Lab work? Y/N 61 S ^TMP("ORDATA",$J,GMIDT,"WP",9)="9^"_$S($O(^SRF(GMN,9,0)):"Yes",1:"No") 62 S ^TMP("ORDATA",$J,GMIDT,"WP",10)="10^"_$G(DCTDTM) ; dictation time 63 S ^TMP("ORDATA",$J,GMIDT,"WP",11)="11^"_$G(TRSDTM) ; transcription time 64 ; 65 ; surgeon's dictation 66 I $D(^UTILITY($J,"W")) D S ORMORE=1 67 . K ^TMP("ORHSSRT",$J) 68 . F GMI=1:1:^UTILITY($J,"W",DIWL) D 69 .. S ^TMP("ORHSSRT",$J,GMIDT,"WP",GMI)=^UTILITY($J,"W",DIWL,GMI,0) 70 . D SPMRG^ORDVU($NA(^TMP("ORHSSRT",$J,GMIDT,"WP")),$NA(^TMP("ORDATA",$J,GMIDT,"WP",12)),12) 71 . K ^UTILITY($J,"W") 72 . K ^TMP("ORHSSRT",$J) 73 I ORMORE S ^TMP("ORDATA",$J,GMIDT,"WP",13)="13^[+]" ;flag for detail 74 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV06.m
r613 r623 1 ORDV06 ; slc/dkm - OE/RR Report Extracts ;10/8/03 11:17 2 ;;3.0;ORDER ENTRY RESULTS REPORTING;**109,118,167,208,215,274,243**;Dec 17, 1997;Build 242 3 ;Pharmacy Extracts 4 RXA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Active Outpatient Pharmacy 5 ;Call to PSOHCSUM 6 ; 7 I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 8 . N BEG,END,MAX 9 . S BEG=0,END=9999999,MAX=9999 10 . D GCPR^OMGCOAS1(DFN,"RXA",BEG,END,MAX) 11 ; 12 N ORRXSTAT,GO,PSOACT 13 Q:'$L(OREXT) 14 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 15 Q:'$L($T(@GO)) 16 S PSOACT=1,ORRXSTAT="^ACTIVE^ACTIVE/SUSP^" 17 D GET 18 Q 19 RXOP(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;All Outpatient Pharmacy 20 ;Call to PSOHCSUM 21 ; 22 I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 23 . N BEG,END,MAX 24 . S BEG=0,END=9999999,MAX=9999 25 . D GCPR^OMGCOAS1(DFN,"RXOP",BEG,END,MAX) 26 ; 27 N ORRXSTAT,GO 28 Q:'$L(OREXT) 29 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 30 Q:'$L($T(@GO)) 31 S ORRXSTAT="" 32 D GET 33 Q 34 GET N J,ORDT,ORI,ORDRGIEN,ORDRG,ORRXNO,ORSTAT,ORQTY,OREXP,ORISSUE,ORLAST,ORREF,ORPRVD,ORCOST,ORSIG 35 N ECD,GMR,GMW,IX,PSOBEGIN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE 36 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 37 S PSOBEGIN=0 38 K ^TMP("ORDATA",$J) 39 I '$L($T(GCPR^OMGCOAS1)) D 40 . K ^TMP("PSOO",$J) 41 . D @GO 42 S (ORDT,ORI)=0 43 F S ORDT=$O(^TMP("PSOO",$J,ORDT)) Q:(ORDT'>0) S ORX0=$G(^(ORDT,0)) I ORX0'="" D 44 . I $L(ORRXSTAT),ORRXSTAT'[(U_$P($P(ORX0,U,5),";",2)) Q ;Check status 45 . S ORI=ORI+1 46 . S SITE=$S($L($G(^TMP("PSOO",$J,ORDT,"facility"))):^("facility"),1:ORSITE) 47 . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID 48 . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P($P(ORX0,U,3),";",2) ;Drug Name 49 . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P($P(ORX0,U,3),";") ;Drug IEN 50 . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,6) ;RX # 51 . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P($P(ORX0,U,5),";",2) ;Status 52 . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P(ORX0,U,7) ;Quantity 53 . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,11)) ;Exp/Cancel Date 54 . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$$DATE^ORDVU($P(ORX0,U)) ;Issue Date 55 . S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Last Fill Date 56 . S ^TMP("ORDATA",$J,ORDT,"WP",10)="10^"_$P(ORX0,U,8) ;#Refills 57 . S ^TMP("ORDATA",$J,ORDT,"WP",11)="11^"_$P($P(ORX0,U,4),";",2) ;Provider 58 . S ^TMP("ORDATA",$J,ORDT,"WP",12)="12^"_$P(ORX0,U,10) ;Cost-fill 59 . S ^TMP("ORDATA",$J,ORDT,"WP",15)="15^"_$P(ORX0,U,9) ;PharmID 60 . S ^TMP("ORDATA",$J,ORDT,"WP",16)="16^"_$P(ORX0,U,11) ;Order Number 61 . S J=0 62 . F S J=$O(^TMP("PSOO",$J,ORDT,J)) Q:'J D 63 ..S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",14,J)="14^"_X 64 K ^TMP("PSOO",$J) 65 S ROOT=$NA(^TMP("ORDATA",$J)) 66 Q 67 RXAV(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Active IV Pharmacy 68 ;Call to ENHS^PSJEEU0 69 N ORIVSTAT,GO 70 Q:'$L(OREXT) 71 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 72 Q:'$L($T(@GO)) 73 S ORIVSTAT="^ACTIVE^" 74 D GET1 75 Q 76 RXIV(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; All IV Pharmcy 77 ;Call to ENHS^PSJEEU0 78 N ORIVSTAT,GO 79 Q:'$L(OREXT) 80 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 81 Q:'$L($T(@GO)) 82 S ORIVSTAT="" 83 D GET1 84 Q 85 GET1 N ORDT,ORI,ORX0,ORIDRG,ORDRGIEN,ORDRG,ORDOSE,ORREC,ORSTAT,ORSTRTDT,ORSTOPDT,ORROUT,ORSIG,ORWII,ORMORE 86 N GMI,GMTSIDT,MAX,ON,PS,PSIVREA,PSJEDT,PSJNKF,PSJPFWD,TN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE 87 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 88 S PSJEDT=1,PSJNKF=1 89 K ^TMP("ORDATA",$J),^UTILITY("PSG",$J),^UTILITY("PSIV",$J) 90 D @GO 91 S ORDT=-9999999,ORI=0 92 F S ORDT=$O(^UTILITY("PSIV",$J,ORDT)) Q:(ORDT="") S ORX0=$G(^(ORDT,0)) I ORX0'="" D 93 . I $L(ORIVSTAT),ORIVSTAT'[(U_$P($P(ORX0,U,4),";",2)_U) Q ;Check status 94 . S ORMORE=0,SITE=$S($L($G(^UTILITY("PSIV",$J,ORDT,"facility"))):^("facility"),1:ORSITE) 95 . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID 96 . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$$DATE^ORDVU($P(ORX0,U)) ;Start Date 97 . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Stop Date 98 . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,5) ;Rate 99 . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P(ORX0,U,6) ;Schedule JEH 100 . S ORIDRG=0 101 . F S ORIDRG=$O(^UTILITY("PSIV",$J,ORDT,"A",ORIDRG)) Q:'ORIDRG S ORREC=$G(^(ORIDRG)) S:ORIDRG>1 ORMORE=1 D ;Additives 102 .. S ^TMP("ORDATA",$J,ORDT,"WP",2,ORIDRG)="2^"_$P($P(ORREC,U),";",2)_" "_$P(ORREC,U,2) ;Additive Dose 103 . S ORIDRG=0 104 . F S ORIDRG=$O(^UTILITY("PSIV",$J,ORDT,"S",ORIDRG)) Q:'ORIDRG S ORREC=$G(^(ORIDRG)) S:ORIDRG>1 ORMORE=1 D ;Solutions 105 .. S ^TMP("ORDATA",$J,ORDT,"WP",3,ORIDRG)="3^"_$P($P(ORREC,U),";",2)_" "_$P(ORREC,U,2) ;Solution Dose 106 . I ORMORE S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^[+]" ;flag for detail 107 K ^UTILITY("PSG",$J),^UTILITY("PSIV",$J) 108 S ROOT=$NA(^TMP("ORDATA",$J)) 109 Q 110 RXUD(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; Get Unit Dose Pharmacy Component 111 ;Call to ENHS^PSJEEU0 112 N J,ORDT,ORI,ORX0,ORDRGIEN,ORDRG,ORDOSE,ORSTAT,ORSTRTDT,ORSTOPDT,ORROUT,ORSIG,GO 113 N GMI,IX,MAX,ON,PS,PSIVREA,PSJEDT,PSJNKF,PSJPFWD,GMR,TN,UDS,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE 114 Q:'$L(OREXT) 115 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 116 Q:'$L($T(@GO)) 117 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 118 S PSJEDT=1,PSJNKF=1 119 K ^TMP("ORDATA",$J),^UTILITY("PSG",$J),^UTILITY("PSIV",$J) 120 D @GO 121 S ORDT=-9999999,ORI=0 122 F S ORDT=$O(^UTILITY("PSG",$J,ORDT)) Q:(ORDT="") S ORX0=$G(^(ORDT)) I ORX0'="" D 123 . S SITE=$S($L($G(^UTILITY("PSG",$J,ORDT,"facility"))):^("facility"),1:ORSITE) 124 . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID 125 . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P($P(ORX0,U,3),":") ;DRUG IEN 126 . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P($P(ORX0,U,3),";",2) ;Drug Name 127 . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,6) ;Dose 128 . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P($P(ORX0,U,5),";",2) ;Status 129 . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$$DATE^ORDVU($P(ORX0,U)) ;START Date 130 . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Stop Date 131 . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$P($P(ORX0,U,7),";",3) ;Route 132 . S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^"_$P(ORX0,U,8) ;SIG 133 K ^UTILITY("PSG",$J),^UTILITY("PSIV",$J) 134 S ROOT=$NA(^TMP("ORDATA",$J)) 135 Q 1 ORDV06 ; slc/dkm - OE/RR Report Extracts ;10/8/03 11:17 2 ;;3.0;ORDER ENTRY RESULTS REPORTING;**109,118,167,208,215,274**;Dec 17, 1997;Build 20 3 ;Pharmacy Extracts 4 RXA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Active Outpatient Pharmacy 5 ;Call to PSOHCSUM 6 ; 7 I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 8 . N BEG,END,MAX 9 . S BEG=0,END=9999999,MAX=9999 10 . D GCPR^OMGCOAS1(DFN,"RXA",BEG,END,MAX) 11 ; 12 N ORRXSTAT,GO,PSOACT 13 Q:'$L(OREXT) 14 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 15 Q:'$L($T(@GO)) 16 S PSOACT=1,ORRXSTAT="^ACTIVE^ACTIVE/SUSP^" 17 D GET 18 Q 19 RXOP(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;All Outpatient Pharmacy 20 ;Call to PSOHCSUM 21 ; 22 I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 23 . N BEG,END,MAX 24 . S BEG=0,END=9999999,MAX=9999 25 . D GCPR^OMGCOAS1(DFN,"RXOP",BEG,END,MAX) 26 ; 27 N ORRXSTAT,GO 28 Q:'$L(OREXT) 29 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 30 Q:'$L($T(@GO)) 31 S ORRXSTAT="" 32 D GET 33 Q 34 GET N J,ORDT,ORI,ORDRGIEN,ORDRG,ORRXNO,ORSTAT,ORQTY,OREXP,ORISSUE,ORLAST,ORREF,ORPRVD,ORCOST,ORSIG 35 N ECD,GMR,GMW,IX,PSOBEGIN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE 36 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 37 S PSOBEGIN=0 38 K ^TMP("ORDATA") 39 I '$L($T(GCPR^OMGCOAS1)) D 40 . K ^TMP("PSOO",$J) 41 . D @GO 42 S (ORDT,ORI)=0 43 F S ORDT=$O(^TMP("PSOO",$J,ORDT)) Q:(ORDT'>0) S ORX0=$G(^(ORDT,0)) I ORX0'="" D 44 . I $L(ORRXSTAT),ORRXSTAT'[(U_$P($P(ORX0,U,5),";",2)) Q ;Check status 45 . S ORI=ORI+1 46 . S SITE=$S($L($G(^TMP("PSOO",$J,ORDT,"facility"))):^("facility"),1:ORSITE) 47 . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID 48 . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P($P(ORX0,U,3),";",2) ;Drug Name 49 . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P($P(ORX0,U,3),";") ;Drug IEN 50 . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,6) ;RX # 51 . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P($P(ORX0,U,5),";",2) ;Status 52 . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P(ORX0,U,7) ;Quantity 53 . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,11)) ;Exp/Cancel Date 54 . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$$DATE^ORDVU($P(ORX0,U)) ;Issue Date 55 . S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Last Fill Date 56 . S ^TMP("ORDATA",$J,ORDT,"WP",10)="10^"_$P(ORX0,U,8) ;#Refills 57 . S ^TMP("ORDATA",$J,ORDT,"WP",11)="11^"_$P($P(ORX0,U,4),";",2) ;Provider 58 . S ^TMP("ORDATA",$J,ORDT,"WP",12)="12^"_$P(ORX0,U,10) ;Cost-fill 59 . S ^TMP("ORDATA",$J,ORDT,"WP",15)="15^"_$P(ORX0,U,9) ;PharmID 60 . S ^TMP("ORDATA",$J,ORDT,"WP",16)="16^"_$P(ORX0,U,11) ;Order Number 61 . S J=0 62 . F S J=$O(^TMP("PSOO",$J,ORDT,J)) Q:'J S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",14,J)="14^"_X 63 . I $O(^TMP("PSOO",$J,ORDT,1)) S ^TMP("ORDATA",$J,ORDT,"WP",13)="13^[+]" ;flag for detail 64 K ^TMP("PSOO",$J) 65 S ROOT=$NA(^TMP("ORDATA",$J)) 66 Q 67 RXAV(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Active IV Pharmacy 68 ;Call to ENHS^PSJEEU0 69 N ORIVSTAT,GO 70 Q:'$L(OREXT) 71 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 72 Q:'$L($T(@GO)) 73 S ORIVSTAT="^ACTIVE^" 74 D GET1 75 Q 76 RXIV(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; All IV Pharmcy 77 ;Call to ENHS^PSJEEU0 78 N ORIVSTAT,GO 79 Q:'$L(OREXT) 80 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 81 Q:'$L($T(@GO)) 82 S ORIVSTAT="" 83 D GET1 84 Q 85 GET1 N ORDT,ORI,ORX0,ORIDRG,ORDRGIEN,ORDRG,ORDOSE,ORREC,ORSTAT,ORSTRTDT,ORSTOPDT,ORROUT,ORSIG,ORWII,ORMORE 86 N GMI,GMTSIDT,MAX,ON,PS,PSIVREA,PSJEDT,PSJNKF,PSJPFWD,TN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE 87 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 88 S PSJEDT=1,PSJNKF=1 89 K ^TMP("ORDATA"),^UTILITY("PSG",$J),^UTILITY("PSIV",$J) 90 D @GO 91 S ORDT=-9999999,ORI=0 92 F S ORDT=$O(^UTILITY("PSIV",$J,ORDT)) Q:(ORDT="") S ORX0=$G(^(ORDT,0)) I ORX0'="" D 93 . I $L(ORIVSTAT),ORIVSTAT'[(U_$P($P(ORX0,U,4),";",2)_U) Q ;Check status 94 . S ORMORE=0,SITE=$S($L($G(^UTILITY("PSIV",$J,ORDT,"facility"))):^("facility"),1:ORSITE) 95 . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID 96 . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;Start Date 97 . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Stop Date 98 . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,5) ;Rate 99 . S ORIDRG=0 100 . F S ORIDRG=$O(^UTILITY("PSIV",$J,ORDT,"A",ORIDRG)) Q:'ORIDRG S ORREC=$G(^(ORIDRG)) S:ORIDRG>1 ORMORE=1 D ;Additives 101 .. S ^TMP("ORDATA",$J,ORDT,"WP",5,ORIDRG)="5^"_$P($P(ORREC,U),";",2)_" "_$P(ORREC,U,2) ;Additive Dose 102 . S ORIDRG=0 103 . F S ORIDRG=$O(^UTILITY("PSIV",$J,ORDT,"S",ORIDRG)) Q:'ORIDRG S ORREC=$G(^(ORIDRG)) S:ORIDRG>1 ORMORE=1 D ;Solutions 104 .. S ^TMP("ORDATA",$J,ORDT,"WP",6,ORIDRG)="6^"_$P($P(ORREC,U),";",2)_" "_$P(ORREC,U,2) ;Solution Dose 105 . I ORMORE S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^[+]" ;flag for detail 106 K ^UTILITY("PSG",$J),^UTILITY("PSIV",$J) 107 S ROOT=$NA(^TMP("ORDATA",$J)) 108 Q 109 RXUD(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; Get Unit Dose Pharmacy Component 110 ;Call to ENHS^PSJEEU0 111 N J,ORDT,ORI,ORX0,ORDRGIEN,ORDRG,ORDOSE,ORSTAT,ORSTRTDT,ORSTOPDT,ORROUT,ORSIG,GO 112 N GMI,IX,MAX,ON,PS,PSIVREA,PSJEDT,PSJNKF,PSJPFWD,GMR,TN,UDS,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE 113 Q:'$L(OREXT) 114 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 115 Q:'$L($T(@GO)) 116 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 117 S PSJEDT=1,PSJNKF=1 118 K ^TMP("ORDATA",$J),^UTILITY("PSG",$J),^UTILITY("PSIV",$J) 119 D @GO 120 S ORDT=-9999999,ORI=0 121 F S ORDT=$O(^UTILITY("PSG",$J,ORDT)) Q:(ORDT="") S ORX0=$G(^(ORDT)) I ORX0'="" D 122 . S SITE=$S($L($G(^UTILITY("PSG",$J,ORDT,"facility"))):^("facility"),1:ORSITE) 123 . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID 124 . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P($P(ORX0,U,3),":") ;DRUG IEN 125 . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P($P(ORX0,U,3),";",2) ;Drug Name 126 . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,6) ;Dose 127 . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P($P(ORX0,U,5),";",2) ;Status 128 . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$$DATE^ORDVU($P(ORX0,U)) ;START Date 129 . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Stop Date 130 . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$P($P(ORX0,U,7),";",3) ;Route 131 . S J=0,ORI=ORI+1 132 . F S J=$O(^UTILITY("PSG",$J,ORDT,J)) Q:'J S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",10,J)="10^"_X ;SIG 133 . I $O(^UTILITY("PSG",$J,ORDT,1)) S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^[+]" ;flag for detail 134 K ^UTILITY("PSG",$J),^UTILITY("PSIV",$J) 135 S ROOT=$NA(^TMP("ORDATA",$J)) 136 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV06A.m
r613 r623 1 ORDV06A 2 ;;3.0;ORDER ENTRY RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 3 4 NVA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 GET 22 23 24 25 K ^TMP("ORDATA",$J)26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 1 ORDV06A ; slc/dcm - OE/RR Report Extracts ;3/8/04 11:17 2 ;;3.0;ORDER ENTRY RESULTS REPORTING;**215**;Dec 17, 1997 3 ;Pharmacy Extracts 4 NVA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;All Outpatient Pharmacy 5 ;Call to PSOHCSUM 6 ;^TMP("PSOO",$J,"NVA",n,0)=Herbal/OTC/Non VA Medication^status (active or discontinued)^start date(fm format)^cprs order # (ptr to 100) 7 ; ^date/time documented (fm format)^documented by (ptr to 200_";"_.01)^dc date/time(fm format) 8 ;^TMP("PSOO",$J,"NVA",n,1,0)=dosage^med route^schedule (previous 3 fields are Instructions)^drug (file #50_";"_.01)^clinic (file #44_";"_.01) 9 ;^TMP("PSOO",$J,"NVA",n,"DSC",nn,0)=statement/explanation/comments 10 I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 11 . N BEG,END,MAX 12 . S BEG=0,END=9999999,MAX=9999 13 . D GCPR^OMGCOAS1(DFN,"RXOP",BEG,END,MAX) 14 ; 15 N GO 16 Q:'$L(OREXT) 17 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 18 Q:'$L($T(@GO)) 19 D GET 20 Q 21 GET N J,ORDT,ORDRGIEN,ORDRG,ORRXNO,ORSTAT,ORQTY,OREXP,ORISSUE,ORLAST,ORREF,ORPRVD,ORCOST,ORSIG,ORX0,ORX1 22 N ECD,GMR,GMW,IX,PSOBEGIN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE 23 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 24 S PSOBEGIN=0 25 K ^TMP("ORDATA") 26 I '$L($T(GCPR^OMGCOAS1)) D 27 . K ^TMP("PSOO",$J) 28 . D @GO 29 S ORDT=0 30 F S ORDT=$O(^TMP("PSOO",$J,"NVA",ORDT)) Q:(ORDT'>0) S ORX0=$G(^(ORDT,0)) I ORX0'="" S ORX1=$G(^(1,0)) D 31 . S SITE=$S($L($G(^TMP("PSOO",$J,"NVA",ORDT,"facility"))):^("facility"),1:ORSITE) 32 . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID 33 . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P(ORX0,U) ;Herbal/OTC/Non VA Medication 34 . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P(ORX0,U,2) ;Status 35 . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$$DATE^ORDVU($P(ORX0,U,3)) ;Start Date 36 . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$$DATE^ORDVU($P(ORX0,U,5)) ;Date Documented 37 . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P($P(ORX0,U,6),";",2) ;Documented By 38 . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,7)) ;Date DC'd 39 . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$P(ORX1,U)_" "_$P(ORX1,U,2)_" "_$P(ORX1,U,3) ;SIG dose + route + schedule 40 . S J=0 41 . F S J=$O(^TMP("PSOO",$J,"NVA",ORDT,"DSC",J)) Q:'J S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",10,J)="10^"_X 42 . I $O(^TMP("PSOO",$J,"NVA",ORDT,"DSC",1)) S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^[+]" ;flag for detail 43 K ^TMP("PSOO",$J) 44 S ROOT=$NA(^TMP("ORDATA",$J)) 45 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV08.m
r613 r623 1 ORDV08 ;DAN/SLC Testing new component ;8/22/01 11:30 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,243**;Dec 17,1997;Build 242 3 ; 4 RIM(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology report 5 ;External Calls: MAIN^GMTSRAE(2),RPT^ORWRA 6 N ORX0,ORCNT,ORSITE,SITE,GO,ORMORE,ORROOT 7 Q:'$L(OREXT) 8 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 9 Q:'$L($T(@GO)) 10 K ^TMP("ORDATA",$J),^TMP("ORXPND",$J) 11 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 12 D @GO 13 S ORCNT=0 14 F S ORCNT=$O(^TMP($J,"ORAEXAMS",ORCNT)) Q:'ORCNT D 15 . S ORMORE=0 16 . S ORX0=$G(^TMP($J,"ORAEXAMS",ORCNT)) 17 . D RPT^ORWRA(.ORROOT,DFN,$P(ORX0,U)) 18 . S SITE=$S($L($G(^TMP($J,"ORAEXAMS",ORCNT,"facility"))):^("facility"),1:ORSITE) 19 . S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID 20 . S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U,2)) ;date 21 . S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,3) ;procedure 22 . S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$P(ORX0,U,5) ;report status 23 . S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,4) ;Case # 24 . I $O(^TMP("ORXPND",$J,0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORXPND",$J)),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;clinical history 25 . I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",7)="7^[+]" ;flag for detail 26 . S ^TMP("ORDATA",$J,ORCNT,"WP",8)="8^"_$P(ORX0,U,14) ;Image available 27 . S ^TMP("ORDATA",$J,ORCNT,"WP",9)="9^"_"i"_$P(ORX0,U,1) ;EXAM ID 28 K ^TMP("RAE",$J),^TMP("ORXPND",$J) 29 S ROOT=$NA(^TMP("ORDATA",$J)) 30 Q 31 ; 32 IGET ;Get imaging exams 33 N ORROOT,ORRADATA,I,ID 34 S ORRADATA=$NA(^TMP($J,"RAE1",DFN)) 35 S ORROOT=$NA(^TMP($J,"ORAEXAMS")) 36 K @ORRADATA,@ORROOT 37 D EN1^RAO7PC1(DFN,ORDBEG,ORDEND,ORMAX) ;call to Radiology to get exams 38 S I=0,ID="" 39 F S ID=$O(@ORRADATA@(ID)) Q:ID="" D 40 . S I=I+1 41 . S @ORROOT@(I)=ID_U_(9999999.9999-ID)_U_@ORRADATA@(ID) 42 K @ORRADATA 43 Q 44 ; 45 MPRO(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Medicine Procedures 46 N ORSITE,ORI,ORREC,ORMORE,ORDATE,SITE,ORARRAY,ORPROC,ORSUM 47 Q:'$L(OREXT) 48 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 49 Q:'$L($T(@GO)) 50 K ^TMP("ORDATA",$J),^TMP("ORTEMP",$J),^TMP("MCAR",$J) 51 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 52 D @GO 53 S ORI=0 54 F S ORI=$O(^TMP("MCAR",$J,ORI)) Q:'ORI!(ORI>ORMAX) D 55 .K ^TMP("ORTEMP",$J) D GETREC^ORDV08A(ORI,80,20,56,3) 56 .S SITE=$S($L($G(^TMP("MCAR",$J,ORI,"facility"))):^("facility"),1:ORSITE) 57 .S ^TMP("ORDATA",$J,ORI,"WP",1)="1^"_SITE ;Site ID 58 .S ^TMP("ORDATA",$J,ORI,"WP",2)="2^"_$$DATEMMM^ORDVU(ORDATE) ;Procedure date/time 59 .S ^TMP("ORDATA",$J,ORI,"WP",3)="3^"_ORPROC ;Procedure Name 60 .S ^TMP("ORDATA",$J,ORI,"WP",4)="4^"_$S(ORSUM'="":ORSUM,1:"No Summary") ;Summary 61 .I $D(^TMP("ORTEMP",$J)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORTEMP",$J)),$NA(^TMP("ORDATA",$J,ORI,"WP",5,1)),5) ;Detailed Report 62 .I ORMORE S ^TMP("ORDATA",$J,ORI,"WP",6)="6^[+]" ;Detailed report flag 63 .Q 64 K ^TMP("ORTEMP",$J),^TMP("MCAR",$J) 65 S ROOT=$NA(^TMP("ORDATA",$J)) 66 Q 67 MGET ;Get medicine results 68 D HSUM^GMTSMCMA(DFN,ORDBEG,ORDEND,ORMAX,"","F") 69 Q 70 DIETNS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Nutrition assessment 71 ;External Calls:SITE^VASITE, NUTR^ORWRP1, LISTNUTR^ORWPR1,FMTE^XLFDT 72 N ORSITE,ORARRAY,ORID,ORCNT,ORMORE,GO,ORDT 73 Q:'$L(OREXT) 74 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 75 Q:'$L($T(@GO)) 76 K ^TMP("ORDATA",$J),^TMP("ORXPND",$J) 77 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 78 D @GO 79 S ORCNT=0,ORDT=OROMEGA 80 F S ORDT=$O(^TMP($J,"FHADT",DFN,ORDT)) Q:(ORDT'>0)!(ORDT>ORALPHA)!(ORCNT>ORMAX) D 81 . S ORID=$$FMTE^XLFDT(9999999-ORDT,2) ;convert inverse date to external date 82 . S ORCNT=ORCNT+1,ORMORE=0 83 . D NUTR^ORWRP1(.ORARRAY,DFN,ORID) 84 . S ORSITE=$S($L($G(^TMP($J,"FHADT",ORDT,"facility"))):^("facility"),1:ORSITE) 85 . S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_ORSITE ;Site ID 86 . S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_ORID ;assessment date/time 87 . I $O(^TMP("ORXPND",$J,0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORXPND",$J)),$NA(^TMP("ORDATA",$J,ORCNT,"WP",3,1)),3) ;assessment report 88 . I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^[+]" ;flag for detail 89 K ^TMP($J,"FHADT"),^TMP("ORXPND",$J) 90 S ROOT=$NA(^TMP("ORDATA",$J)) 91 Q 92 ; 93 GETNS ;Get nutritional assessments 94 D LISTNUTR^ORWRP1(.ORARRAY,DFN) 95 Q 1 ORDV08 ;DAN/SLC Testing new component ;8/22/01 11:30 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120**;Dec 17,1997 3 ; 4 RIM(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology report 5 ;External Calls: MAIN^GMTSRAE(2),RPT^ORWRA 6 N ORX0,ORCNT,ORSITE,SITE,GO,ORMORE,ORROOT 7 Q:'$L(OREXT) 8 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 9 Q:'$L($T(@GO)) 10 K ^TMP("ORDATA",$J),^TMP("ORXPND",$J) 11 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 12 D @GO 13 S ORCNT=0 14 F S ORCNT=$O(^TMP($J,"ORAEXAMS",ORCNT)) Q:'ORCNT D 15 . S ORMORE=0 16 . S ORX0=$G(^TMP($J,"ORAEXAMS",ORCNT)) 17 . D RPT^ORWRA(.ORROOT,DFN,$P(ORX0,U)) 18 . S SITE=$S($L($G(^TMP($J,"ORAEXAMS",ORCNT,"facility"))):^("facility"),1:ORSITE) 19 . S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID 20 . S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U,2)) ;date 21 . S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,3) ;procedure 22 . S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$P(ORX0,U,5) ;report status 23 . S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,4) ;Case # 24 . I $O(^TMP("ORXPND",$J,0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORXPND",$J)),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;clinical history 25 . I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",7)="7^[+]" ;flag for detail 26 . S ^TMP("ORDATA",$J,ORCNT,"WP",8)="8^"_$P(ORX0,U,14) ;Image available 27 K ^TMP("RAE",$J),^TMP("ORXPND",$J) 28 S ROOT=$NA(^TMP("ORDATA",$J)) 29 Q 30 ; 31 IGET ;Get imaging exams 32 N ORROOT,ORRADATA,I,ID 33 S ORRADATA=$NA(^TMP($J,"RAE1",DFN)) 34 S ORROOT=$NA(^TMP($J,"ORAEXAMS")) 35 K @ORRADATA,@ORROOT 36 D EN1^RAO7PC1(DFN,ORDBEG,ORDEND,ORMAX) ;call to Radiology to get exams 37 S I=0,ID="" 38 F S ID=$O(@ORRADATA@(ID)) Q:ID="" D 39 . S I=I+1 40 . S @ORROOT@(I)=ID_U_(9999999.9999-ID)_U_@ORRADATA@(ID) 41 K @ORRADATA 42 Q 43 ; 44 MPRO(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Medicine Procedures 45 N ORSITE,ORI,ORREC,ORMORE,ORDATE,SITE,ORARRAY,ORPROC,ORSUM 46 Q:'$L(OREXT) 47 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 48 Q:'$L($T(@GO)) 49 K ^TMP("ORDATA",$J),^TMP("ORTEMP",$J),^TMP("MCAR",$J) 50 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 51 D @GO 52 S ORI=0 53 F S ORI=$O(^TMP("MCAR",$J,ORI)) Q:'ORI!(ORI>ORMAX) D 54 .K ^TMP("ORTEMP",$J) D GETREC^ORDV08A(ORI,80,20,56,3) 55 .S SITE=$S($L($G(^TMP("MCAR",$J,ORI,"facility"))):^("facility"),1:ORSITE) 56 .S ^TMP("ORDATA",$J,ORI,"WP",1)="1^"_SITE ;Site ID 57 .S ^TMP("ORDATA",$J,ORI,"WP",2)="2^"_$$DATEMMM^ORDVU(ORDATE) ;Procedure date/time 58 .S ^TMP("ORDATA",$J,ORI,"WP",3)="3^"_ORPROC ;Procedure Name 59 .S ^TMP("ORDATA",$J,ORI,"WP",4)="4^"_$S(ORSUM'="":ORSUM,1:"No Summary") ;Summary 60 .I $D(^TMP("ORTEMP",$J)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORTEMP",$J)),$NA(^TMP("ORDATA",$J,ORI,"WP",5,1)),5) ;Detailed Report 61 .I ORMORE S ^TMP("ORDATA",$J,ORI,"WP",6)="6^[+]" ;Detailed report flag 62 .Q 63 K ^TMP("ORTEMP",$J),^TMP("MCAR",$J) 64 S ROOT=$NA(^TMP("ORDATA",$J)) 65 Q 66 MGET ;Get medicine results 67 D HSUM^GMTSMCMA(DFN,ORDBEG,ORDEND,ORMAX,"","F") 68 Q 69 DIETNS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Nutrition assessment 70 ;External Calls:SITE^VASITE, NUTR^ORWRP1, LISTNUTR^ORWPR1,FMTE^XLFDT 71 N ORSITE,ORARRAY,ORID,ORCNT,ORMORE,GO,ORDT 72 Q:'$L(OREXT) 73 S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) 74 Q:'$L($T(@GO)) 75 K ^TMP("ORDATA",$J),^TMP("ORXPND",$J) 76 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) 77 D @GO 78 S ORCNT=0,ORDT=OROMEGA 79 F S ORDT=$O(^TMP($J,"FHADT",DFN,ORDT)) Q:(ORDT'>0)!(ORDT>ORALPHA)!(ORCNT>ORMAX) D 80 . S ORID=$$FMTE^XLFDT(9999999-ORDT,2) ;convert inverse date to external date 81 . S ORCNT=ORCNT+1,ORMORE=0 82 . D NUTR^ORWRP1(.ORARRAY,DFN,ORID) 83 . S ORSITE=$S($L($G(^TMP($J,"FHADT",ORDT,"facility"))):^("facility"),1:ORSITE) 84 . S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_ORSITE ;Site ID 85 . S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_ORID ;assessment date/time 86 . I $O(^TMP("ORXPND",$J,0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORXPND",$J)),$NA(^TMP("ORDATA",$J,ORCNT,"WP",3,1)),3) ;assessment report 87 . I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^[+]" ;flag for detail 88 K ^TMP($J,"FHADT"),^TMP("ORXPND",$J) 89 S ROOT=$NA(^TMP("ORDATA",$J)) 90 Q 91 ; 92 GETNS ;Get nutritional assessments 93 D LISTNUTR^ORWRP1(.ORARRAY,DFN) 94 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREVNTX.m
r613 r623 1 OREVNTX ; SLC/MKB - Event delayed orders RPC's ; 5/4/07 11:34am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,243**;Dec 17, 1997;Build 242 3 ; 4 PAT(ORY,DFN) ; -- Returns currently delayed events for patient DFN 5 N EVT,CNT,X,Y S DFN=+$G(DFN),(EVT,CNT)=0 6 F S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1 S Y=+$O(^(EVT,0)) D 7 . I $G(^ORE(100.2,Y,1)) K ^ORE(100.2,"AE",DFN,EVT,Y) Q 8 . Q:$$LAPSED(Y) ;I $$EMPTY(Y) D CANCEL(Y) Q 9 . Q:$O(^ORE(100.2,"DAD",Y,0)) ;has children 10 . S X=$P($G(^ORD(100.5,EVT,0)),U,8),X="Delayed "_$$LOWER^VALM1(X) 11 . S CNT=CNT+1,ORY(CNT)=Y_U_X 12 S:CNT ORY(0)=CNT 13 Q 14 ; 15 EXISTS(DFN,EVT) ; -- Returns 1 if patient DFN has delayed orders for EVT, 16 ; or 2 if parent/sibling event has delayed orders, else 0 17 ; 18 N X,Y,I S Y=0 I '$G(DFN)!'$G(EVT) G EXQ 19 I $O(^ORE(100.2,"AE",+DFN,+EVT,0)) S Y=1 G EXQ 20 S X=+$P($G(^ORD(100.5,+EVT,0)),U,12) I X D G EXQ ;ck parent,siblings 21 . I $O(^ORE(100.2,"AE",+DFN,X,0)) S Y=2 Q 22 . S I=0 F S I=+$O(^ORD(100.5,"DAD",X,I)) Q:I<1 I $O(^ORE(100.2,"AE",+DFN,I,0)) S Y=2 Q 23 EXQ Q Y 24 ; 25 LIST(ORY,DFN) ; -- Returns all processed events for patient DFN as 26 ; ORY(#) = PatEvtIEN ^ Display Text ^ EvtDateTime 27 ; in reverse chronological order 28 N IDT,DA,CNT,X0,X1,EVT,DC,X 29 S DFN=+$G(DFN),(IDT,CNT)=0 30 F S IDT=$O(^ORE(100.2,"AC",DFN,IDT)) Q:IDT<1 D 31 . S DA=0 F S DA=+$O(^ORE(100.2,"AC",DFN,IDT,DA)) Q:DA<1 D 32 .. S X0=$G(^ORE(100.2,DA,0)),X1=$G(^(1)) Q:$P(X1,U,5) ;has parent 33 .. S EVT=+$P(X0,U,2),DC=+$P(X1,U,3) 34 .. I '$P(X0,U,4),'$O(^ORE(100.2,DA,2,0)),'$O(^ORE(100.2,DA,3,0)),'$D(^OR(100,"AEVNT",DFN_";DPT(",DA)) Q ;no orders 35 .. S I=+$O(^ORE(100.2,DA,10,"B"),-1),X=$P($G(^(I,0)),U,2) I X="LP"!(X="CA") Q ;lapsed or cancelled 36 .. ;Q if not current admission? 37 .. S X=$S(EVT:$P($G(^ORD(100.5,EVT,0)),U,8),DC:$P($G(^ORD(100.6,DC,0)),U,5),1:"UNSPECIFIED EVENT") 38 .. S X=$$LOWER^VALM1(X),CNT=CNT+1,ORY(CNT)=DA_U_X_U_$P(X1,U) 39 S:CNT ORY(0)=CNT 40 Q 41 ; 42 COMP(PTEVT) ; -- Returns 1 or 0, if PTEVT has been completed 43 N Y,I S Y=$S($G(^ORE(100.2,+$G(PTEVT),1)):1,1:0) 44 I Y S I=+$O(^ORE(100.2,+$G(PTEVT),10,0)) S:$P($G(^(I,0)),U,2)="CA" Y=0 45 Q Y 46 ; 47 ACTIVE(ORY,TYPE) ; -- Returns all active events [of TYPE] from #100.5 48 ; where TYPE=string containing any of the codes from the TYPE field 49 N NM,IEN,CNT,X0,X S CNT=0,TYPE=$G(TYPE) 50 S NM="" F S NM=$O(^ORD(100.5,"C",NM)) Q:NM="" D 51 . S IEN=0 F S IEN=+$O(^ORD(100.5,"C",NM,IEN)) Q:IEN<1 D 52 .. S X0=$G(^ORD(100.5,IEN,0)) I '$L($P(X0,U,2)) D ;Child event 53 ... S X=$P(X0,U,12) S:X $P(X0,U,2)=$P($G(^ORD(100.5,+X,0)),U,2) 54 .. I $L(TYPE),TYPE'[$P(X0,U,2) Q 55 .. Q:$O(^ORD(100.5,"DAD",IEN,0)) ;Parent event 56 .. S CNT=CNT+1,ORY(CNT)=IEN_U_X0 57 S:CNT ORY(0)=CNT 58 Q 59 ; 60 NAME(PTEVT) ; -- Return name of Patient Event 61 N X,Y,Z S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2),Z=$G(^(1)) 62 S:X Y=$P($G(^ORD(100.5,X,0)),U,8) 63 I 'X S X=+$P(Z,U,3),Y=$P($G(^ORD(100.6,X,0)),U,5) 64 S Y=$S('Z:"Delayed ",1:"")_$$LOWER^VALM1(Y) 65 Q Y 66 ; 67 SHORTNM(PTEVT) ; -- Return Short Name of Patient Event 68 ; or first 15 characters of Event Name if unspecified 69 N X,Y,Y0 S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) I X D 70 . S Y0=$G(^ORD(100.5,X,0)),Y=$P(Y0,U,10) 71 . S:'$L(Y) Y=$E($P(Y0,U,8),1,15) 72 I 'X S X=+$P($G(^ORE(100.2,+$G(PTEVT),1)),U,3),Y=$E($P($G(^ORD(100.6,X,0)),U,5),1,15) 73 Q Y 74 ; 75 EVT(PTEVT) ; -- Return Event ptr #100.5, given PTEVT ptr #100.2 76 Q +$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) 77 ; 78 DC(PTEVT) ; -- Return DC Rule ptr #100.6, given PTEVT ptr #100.2 79 I $P($G(^ORE(100.2,+$G(PTEVT),1)),U,5) S PTEVT=$P(^(1),U,5) ;use parent 80 Q +$P($G(^ORE(100.2,+$G(PTEVT),1)),U,3) 81 ; 82 TYPE(PTEVT) ; -- Return Type of Patient Event (i.e. A/D/T) 83 N X,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) 84 I $P($G(^ORD(100.5,X,0)),U,12) S X=$P(^(0),U,12) ;use parent 85 S Y=$S(X:$P($G(^ORD(100.5,X,0)),U,2),1:"DC") 86 Q Y 87 ; 88 DIV(PTEVT) ; -- Return Division for PTEVT 89 N X,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) 90 I $P($G(^ORD(100.5,X,0)),U,12) S X=$P(^(0),U,12) ;use parent 91 S Y=+$P($G(^ORD(100.5,X,0)),U,3) S:Y<1 Y=+$G(DUZ(2)) 92 Q Y 93 ; 94 LOC(PTEVT) ; -- Return Default Ordering Location for PTEVT 95 N X,X0,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) 96 S X0=$G(^ORD(100.5,X,0)),Y=+$P(X0,U,9)_";SC(" 97 I Y<1,$P(X0,U,12) S Y=+$P($G(^ORD(100.5,+$P(X0,U,12),0)),U,9)_";SC(" 98 S:Y<1 Y=$G(ORL) 99 Q Y 100 ; 101 EMPTY(PTEVT) ; -- Returns 1 or 0, if PTEVT has delayed orders 102 N Y,OR0,PAT,TYPE,PSO,IFN,STS S Y=1 I '$G(PTEVT) Q Y 103 S OR0=$G(^ORE(100.2,+PTEVT,0)),PAT=+$P(OR0,U)_";DPT(" 104 S TYPE=$$TYPE(PTEVT) I TYPE="D" S PSO=+$O(^DIC(9.4,"C","PSO",0)) 105 S IFN=0 F S IFN=$O(^OR(100,"AEVNT",PAT,PTEVT,IFN)) Q:IFN<1 D Q:'Y 106 . S STS=$P($G(^OR(100,IFN,3)),U,3) I STS=10 S Y=0 Q 107 . ;I IFN=+$P(OR0,U,4),STS=11!(STS=6) S Y=0 Q 108 . I TYPE="D",$P($G(^OR(100,IFN,0)),U,14)=PSO,STS=5!(STS=6) S Y=0 Q 109 I Y,$D(^ORE(100.2,"DAD",PTEVT)) D ;ck child events 110 . N CHLD S CHLD=0 111 . F S CHLD=+$O(^ORE(100.2,"DAD",PTEVT,CHLD)) Q:CHLD<1 D Q:'Y 112 .. S IFN=0 F S IFN=$O(^OR(100,"AEVNT",PAT,CHLD,IFN)) Q:IFN<1 I $P($G(^OR(100,IFN,3)),U,3)=10 S Y=0 Q 113 Q Y 114 ; 115 EVTORDER(ORDER) ; -- Returns 1 or 0, if ORDER is for event 116 ; Will return 0 if action DA is included but not NW 117 N X0,X,Y S X0=$G(^OR(100,+ORDER,0)),X=+$P(ORDER,";",2),Y=0 118 I $P(X0,U,17),X'>1 D 119 . I $P($G(^ORE(100.2,+$P(X0,U,17),0)),U,4)=+ORDER S Y=1 Q 120 . S DAD=+$P($G(^ORE(100.2,+$P(X0,U,17),1)),U,5) ;has parent? 121 . I DAD,$P($G(^ORE(100.2,DAD,0)),U,4)=+ORDER S Y=1 122 Q Y 123 ; 124 MANREL(ORDER) ; -- Returns 1 or 0, if ORDER was manually released 125 N EVT,Y,RELDT,TYPE,EVTDT S Y=0 126 S EVT=+$P($G(^OR(100,+ORDER,0)),U,17),RELDT=+$P($G(^(8,1,0)),U,16) 127 G:EVT<1 MNQ G:RELDT<1 MNQ ;not delayed or released 128 I '$D(^ORE(100.2,EVT,2,+ORDER)) S Y=1 G MNQ ;not rel'd by event 129 S TYPE=$$TYPE(EVT),EVTDT=+$G(^ORE(100.2,EVT,1)) 130 I TYPE="M",$$FMDIFF^XLFDT(EVTDT,RELDT,2)<300 S Y=1 131 MNQ Q Y 132 ; 133 CANCEL(PTEVT) ; -- Cancel empty PTEVT, event order 134 S PTEVT=+$G(PTEVT) D DONE(PTEVT),ACTLOG(PTEVT,"CA") 135 N IFN,DAD S IFN=+$P($G(^ORE(100.2,PTEVT,0)),U,4) 136 I IFN<1 D ;ck for parent w/event order 137 . S DAD=+$P($G(^ORE(100.2,PTEVT,1)),U,5) Q:DAD<1 138 . Q:'$G(^ORE(100.2,DAD,1)) ;parent still active 139 . S IFN=+$P($G(^ORE(100.2,DAD,0)),U,4) 140 I IFN D:'$$DCD^ORCACT2(IFN) CLRDLY^ORCACT2(IFN) ;cancel event order 141 Q 142 ; 143 DONE(PTEVT,WHEN,MVT,OR) ; -- Terminate PTEVT 144 Q:'$G(PTEVT) Q:'$D(^ORE(100.2,PTEVT,0)) 145 N X0,X1,PAT,EVT,DAD 146 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) D D1 147 S DAD=$P(X1,U,5) I DAD,$$ALLDONE(DAD) S PTEVT=DAD D D1 Q 148 S DAD=PTEVT,PTEVT=0 ;if PTEVT=parent, terminate children too 149 F S PTEVT=+$O(^ORE(100.2,"DAD",DAD,PTEVT)) Q:PTEVT<1 D D1 150 Q 151 D1 S X0=$G(^ORE(100.2,+PTEVT,0)),X1=$G(^(1)) Q:'$L(X0) 152 S PAT=+$P(X0,U),EVT=+$P(X0,U,2) ;,ORD=+$P(X0,U,4) 153 S $P(X1,U,1,2)=WHEN_U_$G(MVT),$P(X1,U,4)=$G(OR),^ORE(100.2,PTEVT,1)=X1 154 S ^ORE(100.2,"AC",PAT,9999999-WHEN,PTEVT)="" 155 S:$G(OR) ^ORE(100.2,"ASR",OR,PTEVT)="" 156 K:EVT ^ORE(100.2,"AE",PAT,EVT,PTEVT) 157 Q 158 ; 159 ALLDONE(DAD) ; -- Returns 1 or 0, if all child events are done 160 N I,Y S Y=1,I=0 161 F S I=+$O(^ORE(100.2,"DAD",+$G(DAD),I)) Q:I<1 I '$G(^ORE(100.2,I,1)) S Y=0 Q 162 Q Y 163 ; 164 CHGEVT(IFN,NEWEVT) ; -- Change the Patient Event for order IFN to NEWEVT 165 ; Includes adding or removing event pointer to order 166 Q:'$G(IFN) N PAT,OLDEVT,OR3 S:$G(NEWEVT) NEWEVT=+NEWEVT 167 S PAT=$P($G(^OR(100,+IFN,0)),U,2),OLDEVT=$P($G(^(0)),U,17),OR3=$G(^(3)) 168 Q:OLDEVT=NEWEVT K:OLDEVT ^OR(100,"AEVNT",PAT,OLDEVT,+IFN) 169 S $P(^OR(100,+IFN,0),U,17)=NEWEVT S:NEWEVT ^OR(100,"AEVNT",PAT,NEWEVT,+IFN)="" 170 I NEWEVT,$P(OR3,U,3)'=10 S $P(^OR(100,+IFN,3),U,3)=10,$P(^(8,1,0),U,15)=10 171 I 'NEWEVT,$P(OR3,U,3)=10 S $P(^OR(100,+IFN,3),U,3)=11,$P(^(8,1,0),U,15)=11 D SET^ORDD100(+IFN,1) 172 Q 173 ; 174 ACTLOG(PTEVT,ACTION,EVTYPE,SAVE) ; -- Log a note for ACTION on PTEVT 175 ; SAVE => new data in VAIP() will be saved 176 Q:'$G(PTEVT) Q:'$D(^ORE(100.2,PTEVT,0)) Q:'$L($G(ACTION)) 177 N I,HDR,LAST,TOTAL,DA,ORNOW,MVT 178 F I=1:1:10 L +^ORE(100.2,PTEVT,10,0):1 Q:$T H 2 179 Q:'$T "^" S HDR=$G(^ORE(100.2,PTEVT,10,0)) S:'$L(HDR) HDR="^100.25DA^^" 180 S TOTAL=+$P(HDR,U,4),LAST=+$O(^ORE(100.2,PTEVT,10,"B"),-1) 181 S I=LAST F I=(I+1):1 Q:'$D(^ORE(100.2,PTEVT,10,I,0)) 182 S DA=I,$P(HDR,U,3,4)=DA_U_(TOTAL+1) 183 S ^ORE(100.2,PTEVT,10,0)=HDR L -^ORE(100.2,PTEVT,10,0) 184 S ORNOW=+$$NOW^XLFDT,^ORE(100.2,PTEVT,10,"B",ORNOW,DA)="" 185 S ^ORE(100.2,PTEVT,10,DA,0)=ORNOW_U_ACTION_U_$S(ACTION="LP":"",1:$G(DUZ))_U_$G(EVTYPE) 186 S MVT=+$P($G(^ORE(100.2,PTEVT,1)),U,2) 187 S:MVT ^ORE(100.2,"ADT",MVT,ORNOW,PTEVT,DA)="" 188 I $G(SAVE),$G(VAIP(4)) S $P(^ORE(100.2,PTEVT,10,DA,0),U,5,7)=+VAIP(4)_U_+VAIP(8)_U_+VAIP(5) 189 Q 190 ; 191 LAPSED(PTEVT) ; -- Ck if PTEVT has lapsed, if so lapse all orders 192 N Y,X0,EVT,ENTERED,DAYS S Y=0 193 I $G(^ORE(100.2,PTEVT,1)) G LPQ ;already terminated 194 S X0=$G(^ORE(100.2,PTEVT,0)),EVT=+$P(X0,U,2),ENTERED=+$P(X0,U,5) 195 S:$P($G(^ORD(100.5,EVT,0)),U,12) EVT=+$P(^(0),U,12) ;parent 196 S DAYS=+$P($G(^ORD(100.5,EVT,0)),U,6) I DAYS<1 G LPQ ;doesn't lapse 197 I ENTERED>$$FMADD^XLFDT(DT,(0-DAYS)) G LPQ ;not lapsed yet 198 D LP1(PTEVT) S Y=1 ;lapse orders, event 199 N J S J=0 F S J=$O(^ORE(100.2,"DAD",PTEVT,J)) Q:'J D LP1(J) 200 LPQ Q Y 201 ; 202 LP1(PTEVT) ; -- Lapse orders, event PTEVT 203 N X0,PAT,IFN,STS 204 S X0=$G(^ORE(100.2,PTEVT,0)),PAT=+$P(X0,U)_";DPT(" 205 S IFN=0 F S IFN=$O(^OR(100,"AEVNT",PAT,PTEVT,IFN)) Q:IFN<1 D 206 . S STS=$P($G(^OR(100,IFN,3)),U,3) I (STS=10)!(STS=11)!(IFN=+$P(X0,U,4)) D 207 .. D STATUS^ORCSAVE2(IFN,14) 208 .. D ALPS^ORCSAVE2(IFN,1,"DELAYED ORDER") 209 .. S $P(^OR(100,IFN,8,1,0),U,15)="" D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,1) 210 D DONE(PTEVT),ACTLOG(PTEVT,"LP") 211 Q 1 OREVNTX ; SLC/MKB - Event delayed orders RPC's ; 08 May 2002 2:12 PM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141**;Dec 17, 1997 3 ; 4 PAT(ORY,DFN) ; -- Returns currently delayed events for patient DFN 5 N EVT,CNT,X,Y S DFN=+$G(DFN),(EVT,CNT)=0 6 F S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1 S Y=+$O(^(EVT,0)) D 7 . I $G(^ORE(100.2,Y,1)) K ^ORE(100.2,"AE",DFN,EVT,Y) Q 8 . Q:$$LAPSED(Y) ;I $$EMPTY(Y) D CANCEL(Y) Q 9 . Q:$O(^ORE(100.2,"DAD",Y,0)) ;has children 10 . S X=$P($G(^ORD(100.5,EVT,0)),U,8),X="Delayed "_$$LOWER^VALM1(X) 11 . S CNT=CNT+1,ORY(CNT)=Y_U_X 12 S:CNT ORY(0)=CNT 13 Q 14 ; 15 EXISTS(DFN,EVT) ; -- Returns 1 if patient DFN has delayed orders for EVT, 16 ; or 2 if parent/sibling event has delayed orders, else 0 17 ; 18 N X,Y,I S Y=0 I '$G(DFN)!'$G(EVT) G EXQ 19 I $O(^ORE(100.2,"AE",+DFN,+EVT,0)) S Y=1 G EXQ 20 S X=+$P($G(^ORD(100.5,+EVT,0)),U,12) I X D G EXQ ;ck parent,siblings 21 . I $O(^ORE(100.2,"AE",+DFN,X,0)) S Y=2 Q 22 . S I=0 F S I=+$O(^ORD(100.5,"DAD",X,I)) Q:I<1 I $O(^ORE(100.2,"AE",+DFN,I,0)) S Y=2 Q 23 EXQ Q Y 24 ; 25 LIST(ORY,DFN) ; -- Returns all processed events for patient DFN as 26 ; ORY(#) = PatEvtIEN ^ Display Text ^ EvtDateTime 27 ; in reverse chronological order 28 N IDT,DA,CNT,X0,X1,EVT,DC,X 29 S DFN=+$G(DFN),(IDT,CNT)=0 30 F S IDT=$O(^ORE(100.2,"AC",DFN,IDT)) Q:IDT<1 D 31 . S DA=0 F S DA=+$O(^ORE(100.2,"AC",DFN,IDT,DA)) Q:DA<1 D 32 .. S X0=$G(^ORE(100.2,DA,0)),X1=$G(^(1)) Q:$P(X1,U,5) ;has parent 33 .. S EVT=+$P(X0,U,2),DC=+$P(X1,U,3) 34 .. I '$P(X0,U,4),'$O(^ORE(100.2,DA,2,0)),'$O(^ORE(100.2,DA,3,0)),'$D(^OR(100,"AEVNT",DFN_";DPT(",DA)) Q ;no orders 35 .. S I=+$O(^ORE(100.2,DA,10,"B"),-1),X=$P($G(^(I,0)),U,2) I X="LP"!(X="CA") Q ;lapsed or cancelled 36 .. ;Q if not current admission? 37 .. S X=$S(EVT:$P($G(^ORD(100.5,EVT,0)),U,8),DC:$P($G(^ORD(100.6,DC,0)),U,5),1:"UNSPECIFIED EVENT") 38 .. S X=$$LOWER^VALM1(X),CNT=CNT+1,ORY(CNT)=DA_U_X_U_$P(X1,U) 39 S:CNT ORY(0)=CNT 40 Q 41 ; 42 COMP(PTEVT) ; -- Returns 1 or 0, if PTEVT has been completed 43 N Y,I S Y=$S($G(^ORE(100.2,+$G(PTEVT),1)):1,1:0) 44 I Y S I=+$O(^ORE(100.2,+$G(PTEVT),10,0)) S:$P($G(^(I,0)),U,2)="CA" Y=0 45 Q Y 46 ; 47 ACTIVE(ORY,TYPE) ; -- Returns all active events [of TYPE] from #100.5 48 ; where TYPE=string containing any of the codes from the TYPE field 49 N NM,IEN,CNT,X0,X S CNT=0,TYPE=$G(TYPE) 50 S NM="" F S NM=$O(^ORD(100.5,"C",NM)) Q:NM="" D 51 . S IEN=0 F S IEN=+$O(^ORD(100.5,"C",NM,IEN)) Q:IEN<1 D 52 .. S X0=$G(^ORD(100.5,IEN,0)) I '$L($P(X0,U,2)) D ;Child event 53 ... S X=$P(X0,U,12) S:X $P(X0,U,2)=$P($G(^ORD(100.5,+X,0)),U,2) 54 .. I $L(TYPE),TYPE'[$P(X0,U,2) Q 55 .. Q:$O(^ORD(100.5,"DAD",IEN,0)) ;Parent event 56 .. S CNT=CNT+1,ORY(CNT)=IEN_U_X0 57 S:CNT ORY(0)=CNT 58 Q 59 ; 60 NAME(PTEVT) ; -- Return name of Patient Event 61 N X,Y,Z S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2),Z=$G(^(1)) 62 S:X Y=$P($G(^ORD(100.5,X,0)),U,8) 63 I 'X S X=+$P(Z,U,3),Y=$P($G(^ORD(100.6,X,0)),U,5) 64 S Y=$S('Z:"Delayed ",1:"")_$$LOWER^VALM1(Y) 65 Q Y 66 ; 67 SHORTNM(PTEVT) ; -- Return Short Name of Patient Event 68 ; or first 15 characters of Event Name if unspecified 69 N X,Y,Y0 S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) I X D 70 . S Y0=$G(^ORD(100.5,X,0)),Y=$P(Y0,U,10) 71 . S:'$L(Y) Y=$E($P(Y0,U,8),1,15) 72 I 'X S X=+$P($G(^ORE(100.2,+$G(PTEVT),1)),U,3),Y=$E($P($G(^ORD(100.6,X,0)),U,5),1,15) 73 Q Y 74 ; 75 EVT(PTEVT) ; -- Return Event ptr #100.5, given PTEVT ptr #100.2 76 Q +$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) 77 ; 78 DC(PTEVT) ; -- Return DC Rule ptr #100.6, given PTEVT ptr #100.2 79 I $P($G(^ORE(100.2,+$G(PTEVT),1)),U,5) S PTEVT=$P(^(1),U,5) ;use parent 80 Q +$P($G(^ORE(100.2,+$G(PTEVT),1)),U,3) 81 ; 82 TYPE(PTEVT) ; -- Return Type of Patient Event (i.e. A/D/T) 83 N X,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) 84 I $P($G(^ORD(100.5,X,0)),U,12) S X=$P(^(0),U,12) ;use parent 85 S Y=$S(X:$P($G(^ORD(100.5,X,0)),U,2),1:"DC") 86 Q Y 87 ; 88 DIV(PTEVT) ; -- Return Division for PTEVT 89 N X,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) 90 I $P($G(^ORD(100.5,X,0)),U,12) S X=$P(^(0),U,12) ;use parent 91 S Y=+$P($G(^ORD(100.5,X,0)),U,3) S:Y<1 Y=+$G(DUZ(2)) 92 Q Y 93 ; 94 LOC(PTEVT) ; -- Return Default Ordering Location for PTEVT 95 N X,X0,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) 96 S X0=$G(^ORD(100.5,X,0)),Y=+$P(X0,U,9)_";SC(" 97 I Y<1,$P(X0,U,12) S Y=+$P($G(^ORD(100.5,+$P(X0,U,12),0)),U,9)_";SC(" 98 S:Y<1 Y=$G(ORL) 99 Q Y 100 ; 101 EMPTY(PTEVT) ; -- Returns 1 or 0, if PTEVT has delayed orders 102 N Y,OR0,PAT,TYPE,PSO,IFN,STS S Y=1 I '$G(PTEVT) Q Y 103 S OR0=$G(^ORE(100.2,+PTEVT,0)),PAT=+$P(OR0,U)_";DPT(" 104 S TYPE=$$TYPE(PTEVT) I TYPE="D" S PSO=+$O(^DIC(9.4,"C","PSO",0)) 105 S IFN=0 F S IFN=$O(^OR(100,"AEVNT",PAT,PTEVT,IFN)) Q:IFN<1 D Q:'Y 106 . S STS=$P($G(^OR(100,IFN,3)),U,3) I STS=10 S Y=0 Q 107 . ;I IFN=+$P(OR0,U,4),STS=11!(STS=6) S Y=0 Q 108 . I TYPE="D",$P($G(^OR(100,IFN,0)),U,14)=PSO,STS=5!(STS=6) S Y=0 Q 109 I Y,$D(^ORE(100.2,"DAD",PTEVT)) D ;ck child events 110 . N CHLD S CHLD=0 111 . F S CHLD=+$O(^ORE(100.2,"DAD",PTEVT,CHLD)) Q:CHLD<1 D Q:'Y 112 .. S IFN=0 F S IFN=$O(^OR(100,"AEVNT",PAT,CHLD,IFN)) Q:IFN<1 I $P($G(^OR(100,IFN,3)),U,3)=10 S Y=0 Q 113 Q Y 114 ; 115 EVTORDER(ORDER) ; -- Returns 1 or 0, if ORDER is for event 116 ; Will return 0 if action DA is included but not NW 117 N X0,X,Y S X0=$G(^OR(100,+ORDER,0)),X=+$P(ORDER,";",2),Y=0 118 I $P(X0,U,17),X'>1 D 119 . I $P($G(^ORE(100.2,+$P(X0,U,17),0)),U,4)=+ORDER S Y=1 Q 120 . S DAD=+$P($G(^ORE(100.2,+$P(X0,U,17),1)),U,5) ;has parent? 121 . I DAD,$P($G(^ORE(100.2,DAD,0)),U,4)=+ORDER S Y=1 122 Q Y 123 ; 124 MANREL(ORDER) ; -- Returns 1 or 0, if ORDER was manually released 125 N EVT,Y,RELDT,TYPE,EVTDT S Y=0 126 S EVT=+$P($G(^OR(100,+ORDER,0)),U,17),RELDT=+$P($G(^(8,1,0)),U,16) 127 G:EVT<1 MNQ G:RELDT<1 MNQ ;not delayed or released 128 I '$D(^ORE(100.2,EVT,2,+ORDER)) S Y=1 G MNQ ;not rel'd by event 129 S TYPE=$$TYPE(EVT),EVTDT=+$G(^ORE(100.2,EVT,1)) 130 I TYPE="M",$$FMDIFF^XLFDT(EVTDT,RELDT,2)<300 S Y=1 131 MNQ Q Y 132 ; 133 CANCEL(PTEVT) ; -- Cancel empty PTEVT, event order 134 S PTEVT=+$G(PTEVT) D DONE(PTEVT),ACTLOG(PTEVT,"CA") 135 N IFN,DAD S IFN=+$P($G(^ORE(100.2,PTEVT,0)),U,4) 136 I IFN<1 D ;ck for parent w/event order 137 . S DAD=+$P($G(^ORE(100.2,PTEVT,1)),U,5) Q:DAD<1 138 . Q:'$G(^ORE(100.2,DAD,1)) ;parent still active 139 . S IFN=+$P($G(^ORE(100.2,DAD,0)),U,4) 140 I IFN D:'$$DCD^ORCACT2(IFN) CLRDLY^ORCACT2(IFN) ;cancel event order 141 Q 142 ; 143 DONE(PTEVT,WHEN,MVT,OR) ; -- Terminate PTEVT 144 Q:'$G(PTEVT) Q:'$D(^ORE(100.2,PTEVT,0)) 145 N X0,X1,PAT,EVT,DAD 146 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) D D1 147 S DAD=$P(X1,U,5) I DAD,$$ALLDONE(DAD) S PTEVT=DAD D D1 Q 148 S DAD=PTEVT,PTEVT=0 ;if PTEVT=parent, terminate children too 149 F S PTEVT=+$O(^ORE(100.2,"DAD",DAD,PTEVT)) Q:PTEVT<1 D D1 150 Q 151 D1 S X0=$G(^ORE(100.2,+PTEVT,0)),X1=$G(^(1)) Q:'$L(X0) 152 S PAT=+$P(X0,U),EVT=+$P(X0,U,2) ;,ORD=+$P(X0,U,4) 153 S $P(X1,U,1,2)=WHEN_U_$G(MVT),$P(X1,U,4)=$G(OR),^ORE(100.2,PTEVT,1)=X1 154 S ^ORE(100.2,"AC",PAT,9999999-WHEN,PTEVT)="" 155 S:$G(OR) ^ORE(100.2,"ASR",OR,PTEVT)="" 156 K:EVT ^ORE(100.2,"AE",PAT,EVT,PTEVT) 157 Q 158 ; 159 ALLDONE(DAD) ; -- Returns 1 or 0, if all child events are done 160 N I,Y S Y=1,I=0 161 F S I=+$O(^ORE(100.2,"DAD",+$G(DAD),I)) Q:I<1 I '$G(^ORE(100.2,I,1)) S Y=0 Q 162 Q Y 163 ; 164 CHGEVT(IFN,NEWEVT) ; -- Change the Patient Event for order IFN to NEWEVT 165 ; Includes adding or removing event pointer to order 166 Q:'$G(IFN) N PAT,OLDEVT,OR3 S:$G(NEWEVT) NEWEVT=+NEWEVT 167 S PAT=$P($G(^OR(100,+IFN,0)),U,2),OLDEVT=$P($G(^(0)),U,17),OR3=$G(^(3)) 168 Q:OLDEVT=NEWEVT K:OLDEVT ^OR(100,"AEVNT",PAT,OLDEVT,+IFN) 169 S $P(^OR(100,+IFN,0),U,17)=NEWEVT S:NEWEVT ^OR(100,"AEVNT",PAT,NEWEVT,+IFN)="" 170 I NEWEVT,$P(OR3,U,3)'=10 S $P(^OR(100,+IFN,3),U,3)=10,$P(^(8,1,0),U,15)=10 171 I 'NEWEVT,$P(OR3,U,3)=10 S $P(^OR(100,+IFN,3),U,3)=11,$P(^(8,1,0),U,15)=11 D SET^ORDD100(+IFN,1) 172 Q 173 ; 174 ACTLOG(PTEVT,ACTION,EVTYPE,SAVE) ; -- Log a note for ACTION on PTEVT 175 ; SAVE => new data in VAIP() will be saved 176 Q:'$G(PTEVT) Q:'$D(^ORE(100.2,PTEVT,0)) Q:'$L($G(ACTION)) 177 N I,HDR,LAST,TOTAL,DA,ORNOW,MVT 178 F I=1:1:10 L +^ORE(100.2,PTEVT,10,0):1 Q:$T H 2 179 Q:'$T "^" S HDR=$G(^ORE(100.2,PTEVT,10,0)) S:'$L(HDR) HDR="^100.25DA^^" 180 S TOTAL=+$P(HDR,U,4),LAST=+$O(^ORE(100.2,PTEVT,10,"B"),-1) 181 S I=LAST F I=(I+1):1 Q:'$D(^ORE(100.2,PTEVT,10,I,0)) 182 S DA=I,$P(HDR,U,3,4)=DA_U_(TOTAL+1) 183 S ^ORE(100.2,PTEVT,10,0)=HDR L -^ORE(100.2,PTEVT,10,0) 184 S ORNOW=+$$NOW^XLFDT,^ORE(100.2,PTEVT,10,"B",ORNOW,DA)="" 185 S ^ORE(100.2,PTEVT,10,DA,0)=ORNOW_U_ACTION_U_$S(ACTION="LP":"",1:$G(DUZ))_U_$G(EVTYPE) 186 S MVT=+$P($G(^ORE(100.2,PTEVT,1)),U,2) 187 S:MVT ^ORE(100.2,"ADT",MVT,ORNOW,PTEVT,DA)="" 188 I $G(SAVE),$G(VAIP(4)) S $P(^ORE(100.2,PTEVT,10,DA,0),U,5,7)=+VAIP(4)_U_+VAIP(8)_U_+VAIP(5) 189 Q 190 ; 191 LAPSED(PTEVT) ; -- Ck if PTEVT has lapsed, if so lapse all orders 192 N Y,X0,EVT,ENTERED,DAYS S Y=0 193 I $G(^ORE(100.2,PTEVT,1)) G LPQ ;already terminated 194 S X0=$G(^ORE(100.2,PTEVT,0)),EVT=+$P(X0,U,2),ENTERED=+$P(X0,U,5) 195 S:$P($G(^ORD(100.5,EVT,0)),U,12) EVT=+$P(^(0),U,12) ;parent 196 S DAYS=+$P($G(^ORD(100.5,EVT,0)),U,6) I DAYS<1 G LPQ ;doesn't lapse 197 I ENTERED>$$FMADD^XLFDT(DT,(0-DAYS)) G LPQ ;not lapsed yet 198 D LP1(PTEVT) S Y=1 ;lapse orders, event 199 LPQ Q Y 200 ; 201 LP1(PTEVT) ; -- Lapse orders, event PTEVT 202 N X0,PAT,IFN,STS 203 S X0=$G(^ORE(100.2,PTEVT,0)),PAT=+$P(X0,U)_";DPT(" 204 S IFN=0 F S IFN=$O(^OR(100,"AEVNT",PAT,PTEVT,IFN)) Q:IFN<1 D 205 . S STS=$P($G(^OR(100,IFN,3)),U,3) I (STS=10)!(STS=11)!(IFN=+$P(X0,U,4)) D 206 .. D STATUS^ORCSAVE2(IFN,14) 207 .. S $P(^OR(100,IFN,8,1,0),U,15)="" D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,1) 208 D DONE(PTEVT),ACTLOG(PTEVT,"LP") 209 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREVNTX1.m
r613 r623 1 OREVNTX1 ; SLC/JLI - Event delayed orders RPC's ;9/19/02 13:35 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,149,243**;Dec 17, 1997;Build 242 3 ; 4 PUTEVNT(ORY,DFN,EVT,ORIFN) ; Save new patient delayed events to file 100.2 5 S ORY=$$NEW^OREVNT(DFN,EVT,ORIFN) 6 Q 7 ; 8 GTEVT(ORY,PTEVT) ; Return Event infomation based on PTEVT ptr #100.2 9 ;EVTID ptr #100.5 10 Q:'+PTEVT 11 N EVTID,EVTTYPE,EVTNAME,EVTDISP,EVTDLG,PRTEVT 12 S (EVTTYPE,EVTNAME,EVTDISP,PRTEVT)="" 13 S EVTDLG=0 14 I '$P(^ORE(100.2,+$G(PTEVT),0),U,2) Q 15 S EVTID=$$EVT^OREVNTX(PTEVT) 16 S PRTEVT=$P(^ORD(100.5,EVTID,0),U,12) 17 I PRTEVT S EVTTYPE=$P(^ORD(100.5,PRTEVT,0),U,2) 18 E S EVTTYPE=$P(^ORD(100.5,EVTID,0),U,2) 19 I $D(^ORD(100.5,EVTID,0)) D 20 . S EVTNAME=$P(^ORD(100.5,EVTID,0),U,1) 21 . S EVTDISP=$P(^ORD(100.5,EVTID,0),U,8) 22 . S EVTDLG=$P(^ORD(100.5,EVTID,0),U,4) 23 S ORY=EVTTYPE_U_EVTID_U_EVTNAME_U_EVTDISP_U_EVTDLG 24 Q 25 GTEVT1(ORY,EVT) ; Return Event information based on EVT ptr #100.5 26 ;EVT ptr #100.5 27 Q:'+EVT 28 N EVTTYPE,EVTNAME,EVTDISP,EVTDLG,PRTEVT 29 S (EVTDLG,PRTEVT)=0 30 S PRTEVT=$P(^ORD(100.5,+EVT,0),U,12) 31 I PRTEVT>0 S EVTTYPE=$P(^ORD(100.5,PRTEVT,0),U,2) 32 E S EVTTYPE=$P(^ORD(100.5,+EVT,0),U,2) 33 S EVTNAME=$P($G(^ORD(100.5,+EVT,0)),U,1) 34 S EVTDISP=$P($G(^ORD(100.5,+EVT,0)),U,8) 35 S EVTDLG=$P($G(^ORD(100.5,+EVT,0)),U,4) 36 S ORY=EVTTYPE_U_EVT_U_EVTNAME_U_EVTDISP_U_EVTDLG 37 Q 38 ; 39 EVT(ORY,PTEVT) ; Return Event ptr #100.5, given PTEVT ptr #100.2 40 Q:'+PTEVT 41 S ORY=$$EVT^OREVNTX(PTEVT) 42 Q 43 ; 44 EXISTS(ORY,DFN,EVT) ;Returns PtEvtID ptr #100.2 if patient already has delayed orders 45 I '+EVT S ORY=0 Q 46 N PTEVT S (PTEVT,ORY)=0 47 S PTEVT=$O(^ORE(100.2,"AE",+DFN,+EVT,PTEVT)) 48 I PTEVT>0 S ORY=PTEVT 49 Q 50 ; 51 TYPEXT(ORY,DFN,EVT) ; does EVT has delayed orders? 52 ; 1 if Patient DFN has delayed orders for EVT 53 ; 2 if Parent/Sibling event has delayed orders 54 ; 0 if No delayed orders for EVT 55 Q:'+EVT 56 S ORY=$$EXISTS^OREVNTX(DFN,EVT) 57 Q 58 ; 59 MATCH(ORY,DFN,EVT) ;If Pt's current data match selected event 60 ;DFN: patient DFN 61 ;EVT: ptr to #100.5 62 S ORY=0 63 Q:('+DFN)!('+EVT) 64 S ORY=$$MATCH^OREVNT(DFN,EVT) 65 N TS,TSNM 66 S TS=$S($G(ORTS):+ORTS,1:+$G(^DPT(DFN,.103))) 67 S TSNM=$P($G(^DIC(45.7,TS,0)),U) 68 S:ORY ORY=ORY_U_TSNM 69 Q 70 ; 71 NAME(ORY,PTEVT) ; Return Event name from #100.5, given PTEVT ptr #100.2 72 I PTEVT'>0 S ORY="" Q 73 S ORY=$$NAME^OREVNTX(PTEVT) 74 Q 75 ; 76 DIV(ORY,PTEVT) ; Return division for PTEVT ptr #100.2 77 Q:'+PTEVT 78 S ORY=$$DIV^OREVNTX(PTEVT) 79 Q 80 ; 81 DIV1(ORY,EVT) ; Return division for EVT ptr #100.5 82 Q:'+EVT 83 S ORY=+$P($G(^ORD(100.5,+EVT,0)),U,3) S:ORY<1 ORY=+$G(DUZ(2)) 84 Q 85 ; 86 LOC(ORY,PTEVT) ; Return default hospital location ^SC( for PTEVT ptr #100.2 87 Q:'+PTEVT 88 S ORY=$$LOC^OREVNTX(PTEVT) 89 S ORY=+ORY 90 Q 91 ; 92 LOC1(ORY,EVT) ; Return default hospital location ^SC( for EVT ptr #100.5 93 Q:'+EVT 94 S ORY=+$P($G(^ORD(100.5,+EVT,0)),U,9) S:ORY<1 ORY=+$G(ORL) 95 Q 96 ; 97 CHGEVT(ORY,NEWEVT,ORIDS) ; Change order's event 98 N ORI 99 S ORI=0 100 F S ORI=$O(ORIDS(ORI)) Q:'+ORI D 101 . D CHGEVT^OREVNTX(+$G(ORIDS(ORI)),NEWEVT) 102 Q 103 ; 104 EMPTY(ORY,PTEVT) ; Return 1 if PTEVT doesn't have any orders 105 Q:'+PTEVT 106 S ORY=$$EMPTY^OREVNTX(PTEVT) 107 Q 108 ; 109 DELPTEVT(ORY,PTEVT) ; Delete Patient Event in #100.2 110 Q:'+PTEVT 111 D CANCEL^OREVNTX(PTEVT) 112 Q 113 ; 114 UPDTOR(ORY,PTIFN,ORIFN,PTEVT) ; If delayed order was DCed, then update the EVENT and "AEVNT" 115 Q ;Don't ever need to do this! 116 CURSPE(ORY,PTIFN) ; Return current treating specialty 117 Q:'PTIFN 118 N SPEC S SPEC=$$PT^DGPMOBS(PTIFN),ORY="" 119 I SPEC'<0 S ORY=$P(SPEC,U,3)_U_$P(SPEC,U,2)_U_$P(SPEC,U) ;name^ien^obs flag 120 Q 121 DFLTEVT(ORY,PVIFN) ; Return default release event based on provider IFN 122 N CMEVTLST,IDX 123 S CMEVTLST="",IDX=0 124 D GETLST^OREV3(.CMEVTLST) 125 F S IDX=$O(CMEVTLST(IDX)) Q:'IDX D 126 . I $P($G(CMEVTLST(IDX)),U,2) S ORY=$P($G(CMEVTLST(IDX)),U) Q 127 Q 128 CMEVTS(ORY,CLOC) ;Return common event list 129 N IDX,X0,X,LOC 130 S:CLOC>0 LOC=CLOC 131 S IDX=0,ORY="" 132 D GETLST^OREV3(.ORY) 133 F S IDX=$O(ORY(IDX)) Q:'IDX D 134 . S X0="" 135 . S:$L($G(^ORD(100.5,+ORY(IDX),0))) X0=$G(^(0)) 136 . I '$L($P(X0,U,2)) D 137 .. S X=$P(X0,U,12) S:X $P(X0,U,2)=$P($G(^ORD(100.5,+X,0)),U,2) 138 . S:$L(X0) ORY(IDX)=+ORY(IDX)_U_X0 139 Q 140 ; 141 DELDFLT(ORY,PVIFN) ; Delete default release event 142 Q:'PVIFN 143 N ORERR 144 S ORERR="" 145 D DEL^XPAR(PVIFN_";VA(200,","OREVNT DEFAULT",1,.ORERR) 146 Q 147 WRLSTED(LST,LOC,EVTID) ; Return list of dialogs for writing event delayed orders 148 ; .Y(n): DlgName^ListBox Text 149 WRLST1 N ANENT 150 S LOC=+$G(LOC)_";SC(" I 'LOC S LOC="" 151 S ANENT="ALL^USR.`"_DUZ_"^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"") 152 N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP 153 S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS EVENT LIST",EVTID,"I") Q:'MNU 154 S SEQ=0 F S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ D 155 . S IEN=0 F S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN D 156 . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4) 157 . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5) 158 . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5) 159 . . S:'$L(TXT) TXT=$P(X,U,2) 160 . . I TYP="M" S:'FID FID=1001 161 . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT 162 Q 163 ; 164 GETDLG(LST,DLGID) ; Return dialog infomation based on the DLGID 165 N DIEN,DFID,DTXT,DTYP,DGRP,X0,X5 166 S DLGID=+DLGID 167 Q:'DLGID 168 S X0=^ORD(101.41,DLGID,0),X5=$G(^(5)) 169 S DGRP=+$P(X0,U,5),DFID=+$P(X5,U,5),DTXT=$P(X5,U,4),DTYP=$P(X0,U,4) 170 S:'$L(DTXT) DTXT=$P(X0,U,2) 171 I $P(X0,U,4)="M" S:'DFID DFID=1001 172 S LST=DLGID_";"_DFID_";"_DGRP_";"_DTYP_U_DTXT 173 Q 174 DONE(LST,PTEVT) ; Terminate PTEvt 175 Q:'PTEVT 176 D DONE^OREVNTX(PTEVT) 177 D ACTLOG^OREVNTX(PTEVT,"MN") 178 Q 179 SETDFLT(ORY,EVT) ;Set personal default event 180 N ERR,VAL S ERR="" 181 Q:'$D(^ORD(100.5,EVT,0)) 182 S VAL=$P(^ORD(100.5,EVT,0),U) 183 D EN^XPAR(DUZ_";VA(200,","OREVNT DEFAULT",1,VAL,ERR) 184 S ORY=ERR 185 Q 186 CPACT(ORY,EVT) ; Return True/False to display active orders for copy 187 ; EVT ptr to #100.5 188 Q:'EVT 189 S ORY=0 190 Q:'$D(^ORD(100.5,EVT,0)) 191 S ORY=$P(^ORD(100.5,EVT,0),U,11) 192 Q 193 PRMPTID(ORY,PRTNM) ;Return event prompt IEN for OR GTX EVENT 194 S:$D(^ORD(101.41,"B","OR GTX EVENT")) ORY=$O(^("OR GTX EVENT",0)) 195 Q 196 ISDCOD(ORY,ORIFN) ;True: the order need to be filtered out 197 N PAS,X3,X0,ORGRPLST,THEGRP,IDX,ODGRP 198 S (ORY,IDX)=0 199 Q:'$D(^OR(100,+ORIFN,0)) 200 S X0=$G(^OR(100,+ORIFN,0)) 201 S ODGRP=$P(X0,U,11) 202 D GETLST^XPAR(.ORGRPLST,"ALL","OREVNT EXCLUDE DGRP") 203 F S IDX=$O(ORGRPLST(IDX)) Q:'IDX!ORY D 204 . S THEGRP=$P($G(ORGRPLST(IDX)),U,2) 205 . I $$GRPCHK(THEGRP,ODGRP) S ORY=1 206 I ORY Q 207 S PAS=";1;" 208 S:$D(^OR(100,+ORIFN,3)) X3=^OR(100,+ORIFN,3) 209 S:(PAS'[(";"_$P(X3,U,3)_";")) ORY=0 210 Q 211 DEFLTS(ORY,EVTID) ;Return default specialty for EVTID(#100.5) 212 Q:'+EVTID 213 N PRTEVT 214 S PRTEVT=0 215 S PRTEVT=$P(^ORD(100.5,+EVTID,0),U,12) 216 I PRTEVT>0 S EVTID=PRTEVT 217 S ORY=$$DEFTS^ORCDADT(EVTID) 218 Q 219 ; 220 MULTS(ORY,EVTID) ;Return specialty list for the EVTID(#100.5) 221 Q:'+EVTID 222 N I,CNT,X,Y S (I,CNT)=0 223 N PRTEVT 224 S PRTEVT=0 225 S PRTEVT=$P(^ORD(100.5,+EVTID,0),U,12) 226 I PRTEVT>0 S EVTID=PRTEVT 227 F S I=$O(^ORD(100.5,+$G(EVTID),"TS",I)) Q:I<1 S X=+$G(^(I,0)) D 228 . S Y=$$GET1^DIQ(45.7,X_",",.01) 229 . S CNT=CNT+1,ORY(CNT)=X_U_Y 230 Q 231 ; 232 PRTIDS(ORY,IDS) ;Return some prompt ids from #101.41 233 ; treating specialty Id^attending provider id 234 N IDX,ORTS,ORATT 235 S (ORY,ORTS,ORATT)="" 236 S IDX=$O(^ORD(101.41,"B","OR GTX TREATING SPECIALTY",0)) 237 S:$D(^ORD(101.41,IDX,1)) ORTS=$P($G(^ORD(101.41,IDX,1)),U,2,3) 238 S IDX=$O(^ORD(101.41,"B","OR GTX PROVIDER",0)) 239 S:$D(^ORD(101.41,IDX,1)) ORATT=$P($G(^ORD(101.41,IDX,1)),U,2,3) 240 S ORY=ORTS_"~"_ORATT 241 Q 242 ; 243 DFLTDLG(ORY,EVTID) ;Return event default dialog IEN 244 S ORY=0 245 Q:'$D(^ORD(100.5,+EVTID,0)) 246 S ORY=$P(^ORD(100.5,+EVTID,0),U,4) 247 Q 248 AUTHMREL(ORY,USER) ;1: user can manual release delayed orders 0: can't 249 S ORY=$$CANREL^OREV3 250 Q 251 HAVEPRT(ORY,PTEVT) ;return parent patient event from #100.2 252 Q:'+PTEVT 253 S ORY="" 254 S:$L($G(^ORE(100.2,PTEVT,1))) ORY=$P(^(1),U,5) 255 Q 256 GRPCHK(DG,AGRP) ;If an order's group belong to DG group 257 N RST 258 S RST=0 259 N ORGRP 260 D GRP^ORQ1(DG) 261 S RST=$S($D(ORGRP(AGRP)):1,1:0) 262 Q RST 263 ODPTEVID(ORY,ORID) ;Return PtEvtID based on the ORID 264 Q:'$D(^OR(100,+ORID,0)) 265 S ORY=$P($G(^OR(100,+ORID,0)),U,17) 266 Q 267 COMP(ORY,PTEVT) ;Return 1 or 0 if PTEVT completed or not 268 Q:'+PTEVT 269 S ORY=$$COMP^OREVNTX(+PTEVT) 270 Q 271 ISHDORD(ORY,ORID) ;Return 1 if it's on-hold med order 272 Q:'+ORID 273 Q:'$D(^OR(100,+ORID,0)) 274 N STS,HDSTS,ODGP,INPT,OUPT,MEDS,IVMD 275 S HDSTS=$O(^ORD(100.01,"B","HOLD",0)) 276 S STS=$P($G(^OR(100,+ORID,3)),U,3) 277 S INPT=$O(^ORD(100.98,"B","UD RX",0)) 278 S OUPT=$O(^ORD(100.98,"B","O RX",0)) 279 S MEDS=$O(^ORD(100.98,"B","RX",0)) 280 S IVMD=$O(^ORD(100.98,"B","IV RX",0)) 281 S ODGP=$P(^OR(100,+ORID,0),U,11) 282 I (U_INPT_U_OUPT_U_MEDS_U_IVMD_U[U_ODGP_U),(HDSTS=STS) S ORY=1 283 Q 284 ISPASS(ORY,PTEVTID,EVTTYPE) ;Return 1 if it's a pass event 285 S ORY=$$EVT^OREVNTX(PTEVTID) 286 S ORY=$P($G(^ORD(100.5,+ORY,0)),U,7) 287 I EVTTYPE="T",ORY,ORY<4 S ORY=1 288 E S ORY=0 289 Q 290 ISPASS1(ORY,EVTID,EVTTYPE) ;Return 1 if it's a pass event 291 S ORY=$P($G(^ORD(100.5,+EVTID,0)),U,7) 292 I EVTTYPE="T",ORY,ORY<4 S ORY=1 293 E S ORY=0 294 Q 295 DLGIEN(ORY,DLGNAME) ;Return Order Dialog IEN based on name 296 Q:'$D(^ORD(101.41,"B",DLGNAME)) 297 S ORY=$O(^ORD(101.41,"B",DLGNAME,0)) 298 Q 299 GETSTS(ORY,ORDID) ;Return Order status 300 Q:'+ORDID 301 Q:'$D(^OR(100,+ORDID,0)) 302 S ORY=$P($G(^OR(100,+ORDID,3)),U,3) 303 Q 1 OREVNTX1 ; SLC/JLI - Event delayed orders RPC's ;9/19/02 13:35 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,149**;Dec 17, 1997 3 ; 4 PUTEVNT(ORY,DFN,EVT,ORIFN) ; Save new patient delayed events to file 100.2 5 S ORY=$$NEW^OREVNT(DFN,EVT,ORIFN) 6 Q 7 ; 8 GTEVT(ORY,PTEVT) ; Return Event infomation based on PTEVT ptr #100.2 9 ;EVTID ptr #100.5 10 Q:'+PTEVT 11 N EVTID,EVTTYPE,EVTNAME,EVTDISP,EVTDLG,PRTEVT 12 S (EVTTYPE,EVTNAME,EVTDISP,PRTEVT)="" 13 S EVTDLG=0 14 I '$P(^ORE(100.2,+$G(PTEVT),0),U,2) Q 15 S EVTID=$$EVT^OREVNTX(PTEVT) 16 S PRTEVT=$P(^ORD(100.5,EVTID,0),U,12) 17 I PRTEVT S EVTTYPE=$P(^ORD(100.5,PRTEVT,0),U,2) 18 E S EVTTYPE=$P(^ORD(100.5,EVTID,0),U,2) 19 I $D(^ORD(100.5,EVTID,0)) D 20 . S EVTNAME=$P(^ORD(100.5,EVTID,0),U,1) 21 . S EVTDISP=$P(^ORD(100.5,EVTID,0),U,8) 22 . S EVTDLG=$P(^ORD(100.5,EVTID,0),U,4) 23 S ORY=EVTTYPE_U_EVTID_U_EVTNAME_U_EVTDISP_U_EVTDLG 24 Q 25 GTEVT1(ORY,EVT) ; Return Event information based on EVT ptr #100.5 26 ;EVT ptr #100.5 27 Q:'+EVT 28 N EVTTYPE,EVTNAME,EVTDISP,EVTDLG,PRTEVT 29 S (EVTDLG,PRTEVT)=0 30 S PRTEVT=$P(^ORD(100.5,+EVT,0),U,12) 31 I PRTEVT>0 S EVTTYPE=$P(^ORD(100.5,PRTEVT,0),U,2) 32 E S EVTTYPE=$P(^ORD(100.5,+EVT,0),U,2) 33 S EVTNAME=$P($G(^ORD(100.5,+EVT,0)),U,1) 34 S EVTDISP=$P($G(^ORD(100.5,+EVT,0)),U,8) 35 S EVTDLG=$P($G(^ORD(100.5,+EVT,0)),U,4) 36 S ORY=EVTTYPE_U_EVT_U_EVTNAME_U_EVTDISP_U_EVTDLG 37 Q 38 ; 39 EVT(ORY,PTEVT) ; Return Event ptr #100.5, given PTEVT ptr #100.2 40 Q:'+PTEVT 41 S ORY=$$EVT^OREVNTX(PTEVT) 42 Q 43 ; 44 EXISTS(ORY,DFN,EVT) ;Returns PtEvtID ptr #100.2 if patient already has delayed orders 45 I '+EVT S ORY=0 Q 46 N PTEVT S (PTEVT,ORY)=0 47 S PTEVT=$O(^ORE(100.2,"AE",+DFN,+EVT,PTEVT)) 48 I PTEVT>0 S ORY=PTEVT 49 Q 50 ; 51 TYPEXT(ORY,DFN,EVT) ; does EVT has delayed orders? 52 ; 1 if Patient DFN has delayed orders for EVT 53 ; 2 if Parent/Sibling event has delayed orders 54 ; 0 if No delayed orders for EVT 55 Q:'+EVT 56 S ORY=$$EXISTS^OREVNTX(DFN,EVT) 57 Q 58 ; 59 MATCH(ORY,DFN,EVT) ;If Pt's current data match selected event 60 ;DFN: patient DFN 61 ;EVT: ptr to #100.5 62 S ORY=0 63 Q:('+DFN)!('+EVT) 64 S ORY=$$MATCH^OREVNT(DFN,EVT) 65 N TS,TSNM 66 S TS=$S($G(ORTS):+ORTS,1:+$G(^DPT(DFN,.103))) 67 S TSNM=$P($G(^DIC(45.7,TS,0)),U) 68 S:ORY ORY=ORY_U_TSNM 69 Q 70 ; 71 NAME(ORY,PTEVT) ; Return Event name from #100.5, given PTEVT ptr #100.2 72 I PTEVT'>0 S ORY="" Q 73 S ORY=$$NAME^OREVNTX(PTEVT) 74 Q 75 ; 76 DIV(ORY,PTEVT) ; Return division for PTEVT ptr #100.2 77 Q:'+PTEVT 78 S ORY=$$DIV^OREVNTX(PTEVT) 79 Q 80 ; 81 DIV1(ORY,EVT) ; Return division for EVT ptr #100.5 82 Q:'+EVT 83 S ORY=+$P($G(^ORD(100.5,+EVT,0)),U,3) S:ORY<1 ORY=+$G(DUZ(2)) 84 Q 85 ; 86 LOC(ORY,PTEVT) ; Return default hospital location ^SC( for PTEVT ptr #100.2 87 Q:'+PTEVT 88 S ORY=$$LOC^OREVNTX(PTEVT) 89 S ORY=+ORY 90 Q 91 ; 92 LOC1(ORY,EVT) ; Return default hospital location ^SC( for EVT ptr #100.5 93 Q:'+EVT 94 S ORY=+$P($G(^ORD(100.5,+EVT,0)),U,9) S:ORY<1 ORY=+$G(ORL) 95 Q 96 ; 97 CHGEVT(ORY,NEWEVT,ORIDS) ; Change order's event 98 N ORI 99 S ORI=0 100 F S ORI=$O(ORIDS(ORI)) Q:'+ORI D 101 . D CHGEVT^OREVNTX(+$G(ORIDS(ORI)),NEWEVT) 102 Q 103 ; 104 EMPTY(ORY,PTEVT) ; Return 1 if PTEVT doesn't have any orders 105 Q:'+PTEVT 106 S ORY=$$EMPTY^OREVNTX(PTEVT) 107 Q 108 ; 109 DELPTEVT(ORY,PTEVT) ; Delete Patient Event in #100.2 110 Q:'+PTEVT 111 D CANCEL^OREVNTX(PTEVT) 112 Q 113 ; 114 UPDTOR(ORY,PTIFN,ORIFN,PTEVT) ; If delayed order was DCed, then update the EVENT and "AEVNT" 115 Q ;Don't ever need to do this! 116 CURSPE(ORY,PTIFN) ; Return current treating specialty 117 Q:'PTIFN 118 N SPCID 119 I $D(^DPT(PTIFN,.103)) D 120 . S SPCID=$G(^DPT(PTIFN,.103)) 121 . S:SPCID ORY=$P($G(^DIC(45.7,SPCID,0)),U)_U_SPCID 122 Q 123 DFLTEVT(ORY,PVIFN) ; Return default release event based on provider IFN 124 N CMEVTLST,IDX 125 S CMEVTLST="",IDX=0 126 D GETLST^OREV3(.CMEVTLST) 127 F S IDX=$O(CMEVTLST(IDX)) Q:'IDX D 128 . I $P($G(CMEVTLST(IDX)),U,2) S ORY=$P($G(CMEVTLST(IDX)),U) Q 129 Q 130 CMEVTS(ORY,CLOC) ;Return common event list 131 N IDX,X0,X,LOC 132 S:CLOC>0 LOC=CLOC 133 S IDX=0,ORY="" 134 D GETLST^OREV3(.ORY) 135 F S IDX=$O(ORY(IDX)) Q:'IDX D 136 . S X0="" 137 . S:$L($G(^ORD(100.5,+ORY(IDX),0))) X0=$G(^(0)) 138 . I '$L($P(X0,U,2)) D 139 .. S X=$P(X0,U,12) S:X $P(X0,U,2)=$P($G(^ORD(100.5,+X,0)),U,2) 140 . S:$L(X0) ORY(IDX)=+ORY(IDX)_U_X0 141 Q 142 ; 143 DELDFLT(ORY,PVIFN) ; Delete default release event 144 Q:'PVIFN 145 N ORERR 146 S ORERR="" 147 D DEL^XPAR(PVIFN_";VA(200,","OREVNT DEFAULT",1,.ORERR) 148 Q 149 WRLSTED(LST,LOC,EVTID) ; Return list of dialogs for writing event delayed orders 150 ; .Y(n): DlgName^ListBox Text 151 WRLST1 N ANENT 152 S LOC=+$G(LOC)_";SC(" I 'LOC S LOC="" 153 S ANENT="ALL^USR.`"_DUZ_"^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"") 154 N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP 155 S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS EVENT LIST",EVTID,"I") Q:'MNU 156 S SEQ=0 F S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ D 157 . S IEN=0 F S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN D 158 . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4) 159 . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5) 160 . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5) 161 . . S:'$L(TXT) TXT=$P(X,U,2) 162 . . I TYP="M" S:'FID FID=1001 163 . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT 164 Q 165 ; 166 GETDLG(LST,DLGID) ; Return dialog infomation based on the DLGID 167 N DIEN,DFID,DTXT,DTYP,DGRP,X0,X5 168 S DLGID=+DLGID 169 Q:'DLGID 170 S X0=^ORD(101.41,DLGID,0),X5=$G(^(5)) 171 S DGRP=+$P(X0,U,5),DFID=+$P(X5,U,5),DTXT=$P(X5,U,4),DTYP=$P(X0,U,4) 172 S:'$L(DTXT) DTXT=$P(X0,U,2) 173 I $P(X0,U,4)="M" S:'DFID DFID=1001 174 S LST=DLGID_";"_DFID_";"_DGRP_";"_DTYP_U_DTXT 175 Q 176 DONE(LST,PTEVT) ; Terminate PTEvt 177 Q:'PTEVT 178 D DONE^OREVNTX(PTEVT) 179 D ACTLOG^OREVNTX(PTEVT,"MN") 180 Q 181 SETDFLT(ORY,EVT) ;Set personal default event 182 N ERR,VAL S ERR="" 183 Q:'$D(^ORD(100.5,EVT,0)) 184 S VAL=$P(^ORD(100.5,EVT,0),U) 185 D EN^XPAR(DUZ_";VA(200,","OREVNT DEFAULT",1,VAL,ERR) 186 S ORY=ERR 187 Q 188 CPACT(ORY,EVT) ; Return True/False to display active orders for copy 189 ; EVT ptr to #100.5 190 Q:'EVT 191 S ORY=0 192 Q:'$D(^ORD(100.5,EVT,0)) 193 S ORY=$P(^ORD(100.5,EVT,0),U,11) 194 Q 195 PRMPTID(ORY,PRTNM) ;Return event prompt IEN for OR GTX EVENT 196 S:$D(^ORD(101.41,"B","OR GTX EVENT")) ORY=$O(^("OR GTX EVENT",0)) 197 Q 198 ISDCOD(ORY,ORIFN) ;True: the order need to be filtered out 199 N PAS,X3,X0,ORGRPLST,THEGRP,IDX,ODGRP 200 S (ORY,IDX)=0 201 Q:'$D(^OR(100,+ORIFN,0)) 202 S X0=$G(^OR(100,+ORIFN,0)) 203 S ODGRP=$P(X0,U,11) 204 D GETLST^XPAR(.ORGRPLST,"ALL","OREVNT EXCLUDE DGRP") 205 F S IDX=$O(ORGRPLST(IDX)) Q:'IDX!ORY D 206 . S THEGRP=$P($G(ORGRPLST(IDX)),U,2) 207 . I $$GRPCHK(THEGRP,ODGRP) S ORY=1 208 I ORY Q 209 S PAS=";1;" 210 S:$D(^OR(100,+ORIFN,3)) X3=^OR(100,+ORIFN,3) 211 S:(PAS'[(";"_$P(X3,U,3)_";")) ORY=0 212 Q 213 DEFLTS(ORY,EVTID) ;Return default specialty for EVTID(#100.5) 214 Q:'+EVTID 215 N PRTEVT 216 S PRTEVT=0 217 S PRTEVT=$P(^ORD(100.5,+EVTID,0),U,12) 218 I PRTEVT>0 S EVTID=PRTEVT 219 S ORY=$$DEFTS^ORCDADT(EVTID) 220 Q 221 ; 222 MULTS(ORY,EVTID) ;Return specialty list for the EVTID(#100.5) 223 Q:'+EVTID 224 N I,CNT,X,Y S (I,CNT)=0 225 N PRTEVT 226 S PRTEVT=0 227 S PRTEVT=$P(^ORD(100.5,+EVTID,0),U,12) 228 I PRTEVT>0 S EVTID=PRTEVT 229 F S I=$O(^ORD(100.5,+$G(EVTID),"TS",I)) Q:I<1 S X=+$G(^(I,0)) D 230 . S Y=$$GET1^DIQ(45.7,X_",",.01) 231 . S CNT=CNT+1,ORY(CNT)=X_U_Y 232 Q 233 ; 234 PRTIDS(ORY,IDS) ;Return some prompt ids from #101.41 235 ; treating specialty Id^attending provider id 236 N IDX,ORTS,ORATT 237 S (ORY,ORTS,ORATT)="" 238 S IDX=$O(^ORD(101.41,"B","OR GTX TREATING SPECIALTY",0)) 239 S:$D(^ORD(101.41,IDX,1)) ORTS=$P($G(^ORD(101.41,IDX,1)),U,2,3) 240 S IDX=$O(^ORD(101.41,"B","OR GTX PROVIDER",0)) 241 S:$D(^ORD(101.41,IDX,1)) ORATT=$P($G(^ORD(101.41,IDX,1)),U,2,3) 242 S ORY=ORTS_"~"_ORATT 243 Q 244 ; 245 DFLTDLG(ORY,EVTID) ;Return event default dialog IEN 246 S ORY=0 247 Q:'$D(^ORD(100.5,+EVTID,0)) 248 S ORY=$P(^ORD(100.5,+EVTID,0),U,4) 249 Q 250 AUTHMREL(ORY,USER) ;1: user can manual release delayed orders 0: can't 251 S ORY=$$CANREL^OREV3 252 Q 253 HAVEPRT(ORY,PTEVT) ;return parent patient event from #100.2 254 Q:'+PTEVT 255 S ORY="" 256 S:$L($G(^ORE(100.2,PTEVT,1))) ORY=$P(^(1),U,5) 257 Q 258 GRPCHK(DG,AGRP) ;If an order's group belong to DG group 259 N RST 260 S RST=0 261 N ORGRP 262 D GRP^ORQ1(DG) 263 S RST=$S($D(ORGRP(AGRP)):1,1:0) 264 Q RST 265 ODPTEVID(ORY,ORID) ;Return PtEvtID based on the ORID 266 Q:'$D(^OR(100,+ORID,0)) 267 S ORY=$P($G(^OR(100,+ORID,0)),U,17) 268 Q 269 COMP(ORY,PTEVT) ;Return 1 or 0 if PTEVT completed or not 270 Q:'+PTEVT 271 S ORY=$$COMP^OREVNTX(+PTEVT) 272 Q 273 ISHDORD(ORY,ORID) ;Return 1 if it's on-hold med order 274 Q:'+ORID 275 Q:'$D(^OR(100,+ORID,0)) 276 N STS,HDSTS,ODGP,INPT,OUPT,MEDS,IVMD 277 S HDSTS=$O(^ORD(100.01,"B","HOLD",0)) 278 S STS=$P($G(^OR(100,+ORID,3)),U,3) 279 S INPT=$O(^ORD(100.98,"B","UD RX",0)) 280 S OUPT=$O(^ORD(100.98,"B","O RX",0)) 281 S MEDS=$O(^ORD(100.98,"B","RX",0)) 282 S IVMD=$O(^ORD(100.98,"B","IV RX",0)) 283 S ODGP=$P(^OR(100,+ORID,0),U,11) 284 I (U_INPT_U_OUPT_U_MEDS_U_IVMD_U[U_ODGP_U),(HDSTS=STS) S ORY=1 285 Q 286 ISPASS(ORY,PTEVTID,EVTTYPE) ;Return 1 if it's a pass event 287 S ORY=$$EVT^OREVNTX(PTEVTID) 288 S ORY=$P($G(^ORD(100.5,+ORY,0)),U,7) 289 I EVTTYPE="T",ORY,ORY<4 S ORY=1 290 E S ORY=0 291 Q 292 ISPASS1(ORY,EVTID,EVTTYPE) ;Return 1 if it's a pass event 293 S ORY=$P($G(^ORD(100.5,+EVTID,0)),U,7) 294 I EVTTYPE="T",ORY,ORY<4 S ORY=1 295 E S ORY=0 296 Q 297 DLGIEN(ORY,DLGNAME) ;Return Order Dialog IEN based on name 298 Q:'$D(^ORD(101.41,"B",DLGNAME)) 299 S ORY=$O(^ORD(101.41,"B",DLGNAME,0)) 300 Q 301 GETSTS(ORY,ORDID) ;Return Order status 302 Q:'+ORDID 303 Q:'$D(^OR(100,+ORDID,0)) 304 S ORY=$P($G(^OR(100,+ORDID,3)),U,3) 305 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORIMO.m
r613 r623 1 ORIMO ;SLC/JDL - Inpatient medication on outpatient. ; 02/12/2007 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**187,190,195,215,243**;Dec 17, 1997;Build 242 3 IMOLOC(ORY,ORLOC,ORDFN) ;ORY>=0: LOC is an IMO authorized location 4 S ORY=-1 5 N PACH 6 S PACH=$$PATCH^XPDUTL("PSJ*5.0*111") 7 Q:'PACH 8 I $L($TEXT(SDIMO^SDAMA203)) D 9 . ;#DBIA 4133 10 . S ORY=$$SDIMO^SDAMA203(ORLOC,ORDFN) 11 . ;if RSA returns an error then check against Clinic Loc. 12 . I ORY=-3 D 13 . .I $P($G(^SC(ORLOC,0)),U,3)'="C" Q 14 . .I $D(^SC("AE",1,ORLOC))=1 S ORY=1 15 . K SDIMO(1) 16 Q 17 ; 18 IMOOD(ORY,ORDERID) ;Is it an IMO order? 19 Q:'$D(^OR(100,+ORDERID,0)) 20 N PIMO,DGRP,IMOGRP,ISIMO 21 S (PIMO,DGRP,ISIMO)=0 22 I $P($G(^OR(100,+ORDERID,0)),U,18)>0 S PIMO=1 23 S DGRP=$P($G(^OR(100,+ORDERID,0)),U,11) 24 S IMOGRP=$O(^ORD(100.98,"B","CLINIC ORDERS","")) 25 I DGRP=IMOGRP S ISIMO=1 26 I PIMO,ISIMO S ORY=1 27 Q 28 ; 29 ISCLOC(ORY,ALOC) ;Is it a clinical location 30 S ORY=0 31 Q:'$D(^SC(+ALOC,0)) 32 I $P(^SC(+ALOC,0),U,3)="C" S ORY=1 33 Q 34 ISIVQO(ORY,DLGID) ;Is it an IV quick order 35 S ORY=0 36 Q:'$D(^ORD(101.41,DLGID,0)) 37 N IVGRP,DLGTYP,DLGGRP 38 S IVGRP=$O(^ORD(100.98,"B","IV RX",0)) 39 S DLGTYP=$P($G(^ORD(101.41,DLGID,0)),U,4) 40 S DLGGRP=$P($G(^ORD(101.41,DLGID,0)),U,5) 41 I (DLGTYP="Q"),(DLGGRP=IVGRP) S ORY=1 42 Q 1 ORIMO ;SLC/JDL - Inpatient medication on outpatient. ; 07/07/2005 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**187,190,195,215**;Dec 17, 1997 3 IMOLOC(ORY,ORLOC,ORDFN) ;ORY>=0: LOC is an IMO authorized location 4 S ORY=-1 5 N PACH 6 S PACH=$$PATCH^XPDUTL("PSJ*5.0*111") 7 Q:'PACH 8 I $L($TEXT(SDIMO^SDAMA203)) D 9 . ;I $P($G(^SC(ORLOC,0)),U,3)'="C" Q 10 . ;I $D(^SC("AE",1,ORLOC))=1 S ORY=1 11 . ;#DBIA 4133 12 . S ORY=$$SDIMO^SDAMA203(ORLOC,ORDFN) 13 . K SDIMO(1) 14 Q 15 ; 16 IMOOD(ORY,ORDERID) ;Is it an IMO order? 17 Q:'$D(^OR(100,+ORDERID,0)) 18 N PIMO,DGRP,IMOGRP,ISIMO 19 S (PIMO,DGRP,ISIMO)=0 20 I $P($G(^OR(100,+ORDERID,0)),U,18)>0 S PIMO=1 21 S DGRP=$P($G(^OR(100,+ORDERID,0)),U,11) 22 S IMOGRP=$O(^ORD(100.98,"B","CLINIC ORDERS","")) 23 I DGRP=IMOGRP S ISIMO=1 24 I PIMO,ISIMO S ORY=1 25 Q 26 ; 27 ISCLOC(ORY,ALOC) ;Is it a clinical location 28 S ORY=0 29 Q:'$D(^SC(+ALOC,0)) 30 I $P(^SC(+ALOC,0),U,3)="C" S ORY=1 31 Q 32 ISIVQO(ORY,DLGID) ;Is it an IV quick order 33 S ORY=0 34 Q:'$D(^ORD(101.41,DLGID,0)) 35 N IVGRP,DLGTYP,DLGGRP 36 S IVGRP=$O(^ORD(100.98,"B","IV RX",0)) 37 S DLGTYP=$P($G(^ORD(101.41,DLGID,0)),U,4) 38 S DLGGRP=$P($G(^ORD(101.41,DLGID,0)),U,5) 39 I (DLGTYP="Q"),(DLGGRP=IVGRP) S ORY=1 40 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKCHK.m
r613 r623 1 ORKCHK ; slc/CLA - Main routine called by OE/RR to initiate order checks ; 9/21/07 11:54am2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,94,105,123,232,267,243**;Dec 17, 1997;Build 242 3 EN(ORKY,ORKDFN,ORKA,ORKMODE) 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 OI2DD(ORPSA,OROI,ORPSPKG) 130 131 132 133 134 135 136 CHKRMT 137 138 139 140 141 142 143 144 145 146 147 . S ORKY(IFN)="^99^2^Remote Order Checking not available - checks doneon local data only"148 149 150 151 152 153 . S I=0 F S I=$O(ORARR(I)) Q:'I S IFN=IFN+1,ORKY(IFN)=I_"^99^2^Remote Order Checking not available - checks done on local data only"154 155 1 ORKCHK ; slc/CLA - Main routine called by OE/RR to initiate order checks ; 1/16/07 6:28am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,94,105,123,232,267**;Dec 17, 1997;Build 6 3 EN(ORKY,ORKDFN,ORKA,ORKMODE) ;initiate order checking 4 ;ORKY: array of returned msgs in format: ornum^orderchk ien^clin danger^msg 5 ;ORKDFN: patient dfn 6 ;ORKA: array of order information in the format: 7 ; orderable item ien| 8 ; display group-filler app| 9 ; nat'l id^nat'l text^nat'l code sys^local id^local text^local code sys| 10 ; effective d/t| 11 ; order number| 12 ; filler data (LR: specimen ien, PS: meds prev ordered during this session in format med1^med2^...) 13 ;ORKMODE: mode/event trigger (DISPLAY,SELECT,ACCEPT,SESSION,ALL,NOTIF) 14 ; PS: meds previously ordered during this session med1^med2^... 15 ; 16 N ORKQ,ORKN S ORKQ=0,ORKN=1 17 S:+$G(ORKDFN)<1 ORKY(ORKN)="^^^Order Checking Unavailable - invalid patient id",ORKQ=1,ORKN=ORKN+1 18 S:'$L($G(ORKMODE)) ORKY(ORKN)="^^^Order Checking Unavailable - invalid mode/event",ORKQ=1,ORKN=ORKN+1 19 Q:$G(ORKQ)=1 20 Q:+$G(ORKA)<1 21 N ORKX,ORKS,DNGR,ORENT,ORKENT,ORKNENT,ORNUM,ORKOFF,ORKTMODE 22 N ORKADUZ,ORKNDUZ,ORKI,ORKPRIM,ORKNMSG,ORKMSG,ORKLOG,ORKLD,ORKLI,ORKOI 23 N ORKDG,ORKLPS,ORKPSA,ORKCNT,ORKDGI 24 ; 25 ;save array of orders for use in session processing: 26 M ^TMP("ORKA",$J)=ORKA 27 ; 28 ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be 29 ;reliably determined, and many simultaneous outpt locations can occur): 30 N DFN,ORKLOC 31 S DFN=ORKDFN,VA200="" D OERR^VADPT 32 S ORKLOC=+$G(^DIC(42,+VAIN(4),44)) 33 K VA200,VAIN 34 ; 35 ;get user's service/section flag: 36 N ORKSRV 37 S ORKSRV=$$GET1^DIQ(200,DUZ,29,"I") I +ORKSRV>0 S ORKSRV=$P(ORKSRV,U) 38 ; 39 ;log order check debug messages (or not) 40 S ORKLOG=$$GET^XPAR("DIV^SYS^PKG","ORK DEBUG ENABLE/DISABLE",1,"I") 41 I $G(ORKLOG)="D" K ^XTMP("ORKLOG") S ^XTMP("ORKLOG",0)="" 42 I +$P($G(^XTMP("ORKLOG",0)),U,3)>5000 K ^XTMP("ORKLOG") 43 ; 44 ;if SESSION mode & pharmacy order occurred in session get unsigned med orders 45 I ORKMODE="SESSION" D 46 .S ORKDG=$P(ORKA(1),"|",2) 47 .I $E($G(ORKDG),1,2)="PS" D 48 ..S ORKDGI=0,ORKDGI=$O(^ORD(100.98,"B","PHARMACY",ORKDGI)) 49 ..K ^TMP("ORR",$J) 50 ..D EN^ORQ1(DFN_";DPT(",ORKDGI,11,"","","",0,0) 51 ..;store unsigned med orders in ^TMP("ORR",$J for processing in ORKPS 52 ; 53 ;main processing loop: 54 S ORKX="" F S ORKX=$O(ORKA(ORKX)) Q:ORKX="" D 55 .S ORKOI=$P(ORKA(ORKX),"|") 56 .; 57 .;log debug msgs if parameter is enabled: 58 .I $G(ORKLOG)="E" D 59 ..S ORKLD=$$NOW^XLFDT 60 ..S ORKLI=0 61 ..I +$P($G(^XTMP("ORKLOG",0)),U,3)<1 S $P(^XTMP("ORKLOG",0),U,3)=0 62 ..S ORKCNT=$P(^XTMP("ORKLOG",0),U,3)+1 63 ..S ^XTMP("ORKLOG",0)=$$FMADD^XLFDT(ORKLD,3,"","","")_U_ORKLD_U_ORKCNT 64 ..S ^XTMP("ORKLOG",ORKLD,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)=ORKA(ORKX) 65 .; 66 .S ORKDG=$P(ORKA(ORKX),"|",2),ORKTMODE="" 67 .S ORKENT="USR^LOC.`"_+$G(ORKLOC)_"^SRV.`"_+$G(ORKSRV)_"^DIV^SYS^PKG" 68 .Q:'$L($G(ORKDG)) 69 .; 70 .;if pharmacy order and multiple pharmacy orders in session add data node: 71 .I $E(ORKDG,1,2)="PS",($L($G(ORKPSA))) D 72 ..S $P(ORKA(ORKX),"|",6)=ORKPSA 73 .; 74 .S ORNUM=$P(ORKA(ORKX),"|",5) 75 .; get correct DUZ for notification processing if in NOTIF mode: 76 .I ORKMODE="NOTIF" D 77 ..S:+$G(ORNUM)>0 ORKNDUZ=$$ORDERER^ORQOR2(ORNUM) ;ordering provider 78 ..S:+$G(ORNUM)<1 ORKNDUZ=$P($$PRIM^ORQPTQ4(ORKDFN),U) ;prim provider 79 ..I +$G(ORKNDUZ)>0 D 80 ...S ORKSRV=$$GET1^DIQ(200,ORKNDUZ,29,"I") I +ORKSRV>0 S ORKSRV=$P(ORKSRV,U) 81 ...S ORKNENT="USR.`"_+ORKNDUZ_"^LOC.`"_+$G(ORKLOC)_"^SRV.`"_+$G(ORKSRV)_"^DIV^SYS^PKG" 82 ..S:+$G(ORKNDUZ)<1 ORKNENT="LOC.`"_+$G(ORKLOC)_"^DIV^SYS^PKG" 83 .S ORENT=$S(ORKMODE="NOTIF":ORKNENT,1:ORKENT) 84 .; 85 .;If the order is a delayed release order (NOTIF) process all nodes. 86 .;If it is a renewal, edit or delayed signature order (ALL) process all 87 .;modes except SESSION which gets processed just before signature: 88 .I ORKMODE="NOTIF"!(ORKMODE="ALL") S ORKTMODE=ORKMODE D 89 ..D EN^ORKCHK3(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) ;DISPLAY 90 ..D EN^ORKCHK4(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) ;SELECT 91 ..D EN^ORKCHK5(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) ;ACCEPT 92 ..I ORKMODE="NOTIF" D EN^ORKCHK6(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) ;SESSION 93 ..S ORKMODE=ORKTMODE 94 .; 95 .;Process regular orders/modes: 96 .I '$L($G(ORKTMODE)) D 97 ..I ORKMODE="DISPLAY" D EN^ORKCHK3(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) 98 ..I ORKMODE="SELECT" D EN^ORKCHK4(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) 99 ..I ORKMODE="ACCEPT" D EN^ORKCHK5(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) 100 ..I ORKMODE="SESSION" D EN^ORKCHK6(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) 101 ; 102 ;set messages into sorting array then into ORKY ORKS("ORK",clinical danger level,oi,msg)=ornum^order check ien^clin danger level^message 103 S ORKX="",ORKI=1 104 F S ORKX=$O(ORKS("ORK",ORKX)) Q:ORKX="" D 105 .S ORKY(ORKI)=$E(ORKS("ORK",ORKX),1,250) 106 .; 107 .;log debug msgs if parameter is enabled: 108 .I $G(ORKLOG)="E" D 109 ..S ORKLI=$G(ORKLI)+1 110 ..S ^XTMP("ORKLOG",$$NOW^XLFDT,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)=ORKY(ORKI) 111 ..S $P(^XTMP("ORKLOG",0),U,3)=$P($G(^XTMP("ORKLOG",0)),U,3)+1 112 .; 113 .;send moderate and high danger order checks for delayed orders as notifications: 114 .I ORKMODE="NOTIF" S DNGR=$P(ORKY(ORKI),U,3) I $G(DNGR)<3 D 115 ..S ORKADUZ="",ORNUM=$P(ORKY(ORKI),U) 116 ..S:+$G(ORKNDUZ)>0 ORKADUZ(ORKNDUZ)="" 117 ..S ORKNMSG="Order check: "_$P(ORKY(ORKI),U,4) 118 ..D EN^ORB3(54,ORKDFN,$G(ORNUM),.ORKADUZ,ORKNMSG,"") 119 .S ORKI=ORKI+1 120 ; 121 K ^TMP("ORKA",$J),^TMP("ORR",$J) 122 I $G(ORKLOG)="E" D 123 .S ORKLI=$G(ORKLI)+1 124 .S ^XTMP("ORKLOG",$$NOW^XLFDT,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)="LEAVING ORDER CHECKING" 125 .S $P(^XTMP("ORKLOG",0),U,3)=$P($G(^XTMP("ORKLOG",0)),U,3)+1 126 D CHKRMT 127 Q 128 ; 129 OI2DD(ORPSA,OROI,ORPSPKG) ;rtn dispense drugs for a PS OI 130 N PSOI 131 Q:'$D(^ORD(101.43,OROI,0)) 132 S PSOI=$P($P(^ORD(101.43,OROI,0),U,2),";") 133 Q:+$G(PSOI)<1 134 D DRG^PSSUTIL1(.ORPSA,PSOI,ORPSPKG) 135 Q 136 CHKRMT ; 137 N I,ORQFLAG 138 S ORQFLAG=1 139 S I=0 F S I=$O(ORKA(I)) Q:'I I $E($P(ORKA(I),"|",2),1,2)="PS"!($E($P(ORKA(I),"|",2),1,2)="RA") S ORQFLAG=0 140 Q:$G(ORQFLAG) 141 Q:'$$HAVEHDR^ORRDI1 142 Q:$$LDPTTVAL^ORRDI2($G(DFN)) 143 Q:$P($G(^XTMP("ORRDI","PSOO",ORKDFN,0)),U,3)'<0&($P($G(^XTMP("ORRDI","ART",ORKDFN,0)),U,3)'<0) 144 I $G(ORKMODE)="ACCEPT" D 145 . N IFN 146 . S IFN=$O(ORKY(""),-1)+1 147 . S ORKY(IFN)="^99^2^Order check performed on local data only" 148 . K ^TMP($J,"ORRDI") S ^TMP($J,"ORRDI",ORKDFN)=1 149 I $G(ORKMODE)="SESSION" D 150 . N I,IFN,ORARR 151 . S IFN=$O(ORKY(""),-1) 152 . S I=0 F S I=$O(ORKY(I)) Q:'I S ORARR(+ORKY(I))="" 153 . S I=0 F S I=$O(ORARR(I)) Q:'I S IFN=IFN+1,ORKY(IFN)=I_"^99^2^Order check performed on local data only." 154 . K ^TMP($J,"ORRDI") S ^TMP($J,"ORRDI",ORKDFN)=1 155 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKLR.m
r613 r623 1 ORKLR ; slc/CLA - Order checking support procedure for lab orders ;7/23/96 14:31 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,51,92,105,243**;Dec 17, 1997;Build 242 3 Q 4 DUP(ORKLR,OI,ORDFN,NEWORDT,SPECIMEN) ; return duplicate lab order info 5 N ORL,DDT,ODT,ORN,ORNC,LRID,DGIEN,ORPANEL 6 ;get lab id from orderable item (OI): 7 S LRID=$P(^ORD(101.43,OI,0),U,2) S:$L($G(LRID)) ORL(LRID_";"_SPECIMEN)="" 8 ;expand into child-level lab identifiers if children exist for this OI: 9 ;if children found, set panel flag to '1': 10 S LRID="" F S LRID=$O(^ORD(101.43,OI,10,"AID",LRID)) Q:LRID="" S ORL(LRID_";"_SPECIMEN)="",ORPANEL=1 11 ;get duplicate date range-beginning date/time for this OI: 12 S DDT=$P($$DUPRANGE^ORQOR2(OI,"LR",NEWORDT,ORDFN),U) 13 Q:DDT=0 ;if dup range for this OI = zero, don't process dup order oc 14 ; 15 ;get all lab orders since dup beg d/t: 16 S DGIEN=0,DGIEN=$O(^ORD(100.98,"B","LAB",DGIEN)) 17 K ^TMP("ORR",$J) 18 D EN^ORQ1(ORDFN_";DPT(",DGIEN,1,"",DDT,NEWORDT,1,0) 19 N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0 20 S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 21 F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D 22 .S X=^TMP("ORR",$J,HOR,SEQ),ORN=+$P(X,U),ODT=$P(X,U,4) 23 .Q:+$G(ORN)=+$G(ORIFN) ;quit current order # = dup order # 24 .;break into child orders if they exist: 25 .I $D(^OR(100,ORN,2,0)) D ;child orders exist 26 ..S ORNC=0 F S ORNC=$O(^OR(100,ORN,2,ORNC)) Q:ORNC="" D 27 ...Q:+$G(ORNC)=+$G(ORIFN) ;quit current order # = dup order # 28 ...D DUP2(.ORKLR,ORNC,ODT,.ORL,$G(ORPANEL)) 29 .I '$D(^OR(100,ORN,2,0)) D DUP2(.ORKLR,ORN,ODT,.ORL,$G(ORPANEL)) 30 K ^TMP("ORR",$J) 31 Q 32 DUP2(ORKLR,ORN,ODT,ORL,ORPANEL) ;second part of dup lab order check 33 N ORS,ORST,ORSI,ORSP,OROI,LRID,LRIDX,LRIDXC,EXDT,INVDT,RCNT,ORY,ORX,ORQ 34 S ORS=$$STATUS^ORQOR2(ORN),ORSI=$P(ORS,U),ORST=$P(ORS,U,2) 35 ;quit if order status is canceled/discontinued/expired/lapsed/changed/delayed: 36 I (ORSI=13)!(ORSI=1)!(ORSI=7)!(ORSI=14)!(ORSI=12)!(ORSI=10) Q 37 ; 38 ;get specimen for this order: 39 S ORSP=$$VALUE^ORCSAVE2(ORN,"SPECIMEN") 40 Q:'$L($G(ORSP)) ;quit if no specimen found 41 ;get orderable item for this order: 42 S OROI=$$OI^ORQOR2(ORN) 43 Q:'$L($G(OROI)) ;quit if no orderable item found 44 ;get lab id and check against ordered array ORL 45 S:$L($G(^ORD(101.43,OROI,0))) LRIDX=$P(^ORD(101.43,OROI,0),U,2)_";"_ORSP I $L($G(LRIDX)) D 46 .S LRID="" F S LRID=$O(ORL(LRID)) Q:LRID="" I LRID=LRIDX D ;dup! 47 ..; 48 ..;quit if order results entered in lab as "cancelled": 49 ..D ORDER^ORQQLR(.ORY,ORDFN,ORN) 50 ..S ORX=0 F S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1 D 51 ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1 52 ..Q:+$G(ORQ)=1 ;quit if lab test cancelled in lab 53 ..; 54 ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT 55 ..;get most recent lab results: 56 ..S RCNT=$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP) 57 ..; 58 ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]" 59 ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$P(RCNT,U,2)_"*" 60 ;get children lab ids and check against ordered array ORL 61 S LRIDX="" F S LRIDX=$O(^ORD(101.43,OROI,10,"AID",LRIDX)) Q:LRIDX="" D 62 .S LRIDXC=LRIDX_";"_ORSP 63 .S LRID="" F S LRID=$O(ORL(LRID)) Q:LRID="" I LRID=LRIDXC D ;dup! 64 ..; 65 ..D ORDER^ORQQLR(.ORY,ORDFN,ORN) 66 ..S ORX=0 F S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1 D 67 ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1 68 ..Q:+$G(ORQ)=1 ;quit if lab test cancelled in lab 69 ..; 70 ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT 71 ..;get most recent lab results: 72 ..S RCNT=$S($G(ORPANEL)=1:"",1:$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP)) 73 ..; 74 ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]" 75 ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$P(RCNT,U,2)_"*" 76 Q 77 RECNTWBC(ORDFN,ORDAYS) ;extrinsic function to return most recent WBC within <ORDAYS> in format: 78 ;test id^result units flag ref range collection d/t 79 N BDT,CDT,ORY,ORX,ORZ,X,TEST,ORI,ORJ,WBCRSLT,LABFILE,SPECFILE 80 Q:'$L($G(ORDFN)) "0^" 81 D NOW^%DTC 82 I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","") 83 K % 84 S:'$L($G(BDT)) BDT=1 ;if no ORDAYS, set BDT to '1' to search all days 85 S LABFILE=$$TERMLKUP^ORB31(.ORY,"WBC") 86 Q:'$D(ORY) "0^" ;quit if no link between WBC and local lab test 87 Q:$G(LABFILE)'=60 "0^" 88 S SPECFILE=$$TERMLKUP^ORB31(.ORX,"BLOOD SPECIMEN") 89 Q:'$D(ORX) "0^" ;quit if no link between BLOOD SPECIMEN and local spec 90 Q:$G(SPECFILE)'=61 "0^" 91 F ORI=1:1:ORY I +$G(WBCRSLT)<1 D 92 .S TEST=$P(ORY(ORI),U) 93 .Q:+$G(TEST)<1 94 .F ORJ=1:1:ORX I +$G(WBCRSLT)<1 D 95 ..S SPECIMEN=$P(ORX(ORJ),U) 96 ..Q:+$G(SPECIMEN)<1 97 ..S ORZ=$$LOCL^ORQQLR1(ORDFN,TEST,SPECIMEN) 98 ..Q:'$L($G(ORZ)) 99 ..S CDT=$P(ORZ,U,7) 100 ..I CDT'<BDT S WBCRSLT=1 101 Q:+$G(WBCRSLT)<1 "0^" 102 Q $P(ORZ,U,3)_U_$P(ORZ,U,3)_" "_$P(ORZ,U,4)_" "_$P(ORZ,U,5)_" ("_$P(ORZ,U,6)_") "_$$FMTE^XLFDT(CDT,"2P") 103 ; 104 CLOZLABS(ORDFN,ORDAYS,ORCLOZ) ;extrinsic function rtns "1" if clozapine ordered and WBC labs results within past ORDAYS, "0" if not 105 ;result format: clozapine/mapped labs flag^recent WBC flag;recent WBC 106 ; result^recent ANC flag;recent ANC result^formatted WBC and ANC results 107 ; 108 N BDT,WBC,WBCSPEC,WBCRSLT,WBCCDT,WBCF,ANC,ANCSPEC,ANCRSLT,ANCCDT,ANCF 109 Q:'$L($G(ORDFN)) "0^" 110 I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT($$NOW^XLFDT,"-"_ORDAYS,"","","") 111 S:'$L($G(BDT)) BDT=1 ;if no ORDAYS, set BDT to '1' to search all days 112 ; 113 K LAB 114 D EN^PSODRG(ORCLOZ) ;pharmacy api rtns Lab file ptrs for WBC, ANC 115 Q:$G(LAB("NOT"))=0 "0^" ;medication is not clozapine 116 ;Q:$G(LAB("BAD TEST"))=0 "0^" ;one or both lab tests aren't mapped 117 ;S WBC=$G(LAB("WBC")),WBCSPEC=$P(WBC,U,2),WBC=$P(WBC,U) 118 ;S ANC=$G(LAB("ANC")),ANCSPEC=$P(ANC,U,2),ANC=$P(ANC,U) 119 ; 120 K ^TMP($J,"PSO") 121 D CL1^YSCLTST2(ORDFN,ORDAYS) 122 I $D(^TMP($J,"PSO")) D 123 .N INVDT 124 .S INVDT=$O(^TMP($J,"PSO",0)) 125 .Q:'INVDT 126 .S WBC=$P($G(^TMP($J,"PSO",INVDT)),U)/1000 127 .S ANC=$P($G(^TMP($J,"PSO",INVDT)),U,2)/1000 128 .I WBC S WBCF=1 129 .I ANC S ANCF=1 130 .I $L(WBC)=1 S WBC=WBC_".0" 131 .I $L(ANC)=1 S ANC=ANC_".0" 132 .S WBCRSLT="WBC "_WBC_" ["_$$FMTE^XLFDT(9999999-INVDT,"""2P""")_"]" 133 .S ANCRSLT="ANC "_ANC_" ["_$$FMTE^XLFDT(9999999-INVDT,"""2P""")_"]" 134 ; 135 K LAB 136 Q "1^"_$G(WBCF,0)_";"_$G(WBC)_"^"_$G(ANCF,0)_";"_$G(ANC)_"^"_$G(WBCRSLT)_" "_$G(ANCRSLT) 1 ORKLR ; slc/CLA - Order checking support procedure for lab orders ;7/23/96 14:31 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,51,92,105**;Dec 17, 1997 3 Q 4 DUP(ORKLR,OI,ORDFN,NEWORDT,SPECIMEN) ; return duplicate lab order info 5 N ORL,DDT,ODT,ORN,ORNC,LRID,DGIEN,ORPANEL 6 ;get lab id from orderable item (OI): 7 S LRID=$P(^ORD(101.43,OI,0),U,2) S:$L($G(LRID)) ORL(LRID_";"_SPECIMEN)="" 8 ;expand into child-level lab identifiers if children exist for this OI: 9 ;if children found, set panel flag to '1': 10 S LRID="" F S LRID=$O(^ORD(101.43,OI,10,"AID",LRID)) Q:LRID="" S ORL(LRID_";"_SPECIMEN)="",ORPANEL=1 11 ;get duplicate date range-beginning date/time for this OI: 12 S DDT=$P($$DUPRANGE^ORQOR2(OI,"LR",NEWORDT,ORDFN),U) 13 Q:DDT=0 ;if dup range for this OI = zero, don't process dup order oc 14 ; 15 ;get all lab orders since dup beg d/t: 16 S DGIEN=0,DGIEN=$O(^ORD(100.98,"B","LAB",DGIEN)) 17 K ^TMP("ORR",$J) 18 D EN^ORQ1(ORDFN_";DPT(",DGIEN,1,"",DDT,NEWORDT,1,0) 19 N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0 20 S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 21 F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D 22 .S X=^TMP("ORR",$J,HOR,SEQ),ORN=+$P(X,U),ODT=$P(X,U,4) 23 .Q:+$G(ORN)=+$G(ORIFN) ;quit current order # = dup order # 24 .;break into child orders if they exist: 25 .I $D(^OR(100,ORN,2,0)) D ;child orders exist 26 ..S ORNC=0 F S ORNC=$O(^OR(100,ORN,2,ORNC)) Q:ORNC="" D 27 ...Q:+$G(ORNC)=+$G(ORIFN) ;quit current order # = dup order # 28 ...D DUP2(.ORKLR,ORNC,ODT,.ORL,$G(ORPANEL)) 29 .I '$D(^OR(100,ORN,2,0)) D DUP2(.ORKLR,ORN,ODT,.ORL,$G(ORPANEL)) 30 K ^TMP("ORR",$J) 31 Q 32 DUP2(ORKLR,ORN,ODT,ORL,ORPANEL) ;second part of dup lab order check 33 N ORS,ORST,ORSI,ORSP,OROI,LRID,LRIDX,LRIDXC,EXDT,INVDT,RCNT,ORY,ORX,ORQ 34 S ORS=$$STATUS^ORQOR2(ORN),ORSI=$P(ORS,U),ORST=$P(ORS,U,2) 35 ;quit if order status is canceled/discontinued/expired/lapsed/changed/delayed: 36 I (ORSI=13)!(ORSI=1)!(ORSI=7)!(ORSI=14)!(ORSI=12)!(ORSI=10) Q 37 ; 38 ;get specimen for this order: 39 S ORSP=$$VALUE^ORCSAVE2(ORN,"SPECIMEN") 40 Q:'$L($G(ORSP)) ;quit if no specimen found 41 ;get orderable item for this order: 42 S OROI=$$OI^ORQOR2(ORN) 43 Q:'$L($G(OROI)) ;quit if no orderable item found 44 ;get lab id and check against ordered array ORL 45 S:$L($G(^ORD(101.43,OROI,0))) LRIDX=$P(^ORD(101.43,OROI,0),U,2)_";"_ORSP I $L($G(LRIDX)) D 46 .S LRID="" F S LRID=$O(ORL(LRID)) Q:LRID="" I LRID=LRIDX D ;dup! 47 ..; 48 ..;quit if order results entered in lab as "cancelled": 49 ..D ORDER^ORQQLR(.ORY,ORDFN,ORN) 50 ..S ORX=0 F S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1 D 51 ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1 52 ..Q:+$G(ORQ)=1 ;quit if lab test cancelled in lab 53 ..; 54 ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT 55 ..;get most recent lab results: 56 ..S RCNT=$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP) 57 ..; 58 ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]" 59 ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$P(RCNT,U,2)_"*" 60 ;get children lab ids and check against ordered array ORL 61 S LRIDX="" F S LRIDX=$O(^ORD(101.43,OROI,10,"AID",LRIDX)) Q:LRIDX="" D 62 .S LRIDXC=LRIDX_";"_ORSP 63 .S LRID="" F S LRID=$O(ORL(LRID)) Q:LRID="" I LRID=LRIDXC D ;dup! 64 ..; 65 ..D ORDER^ORQQLR(.ORY,ORDFN,ORN) 66 ..S ORX=0 F S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1 D 67 ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1 68 ..Q:+$G(ORQ)=1 ;quit if lab test cancelled in lab 69 ..; 70 ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT 71 ..;get most recent lab results: 72 ..S RCNT=$S($G(ORPANEL)=1:"",1:$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP)) 73 ..; 74 ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]" 75 ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$P(RCNT,U,2)_"*" 76 Q 77 RECNTWBC(ORDFN,ORDAYS) ;extrinsic function to return most recent WBC within <ORDAYS> in format: 78 ;test id^result units flag ref range collection d/t 79 N BDT,CDT,ORY,ORX,ORZ,X,TEST,ORI,ORJ,WBCRSLT,LABFILE,SPECFILE 80 Q:'$L($G(ORDFN)) "0^" 81 D NOW^%DTC 82 I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","") 83 K % 84 S:'$L($G(BDT)) BDT=1 ;if no ORDAYS, set BDT to '1' to search all days 85 S LABFILE=$$TERMLKUP^ORB31(.ORY,"WBC") 86 Q:'$D(ORY) "0^" ;quit if no link between WBC and local lab test 87 Q:$G(LABFILE)'=60 "0^" 88 S SPECFILE=$$TERMLKUP^ORB31(.ORX,"BLOOD SPECIMEN") 89 Q:'$D(ORX) "0^" ;quit if no link between BLOOD SPECIMEN and local spec 90 Q:$G(SPECFILE)'=61 "0^" 91 F ORI=1:1:ORY I +$G(WBCRSLT)<1 D 92 .S TEST=$P(ORY(ORI),U) 93 .Q:+$G(TEST)<1 94 .F ORJ=1:1:ORX I +$G(WBCRSLT)<1 D 95 ..S SPECIMEN=$P(ORX(ORJ),U) 96 ..Q:+$G(SPECIMEN)<1 97 ..S ORZ=$$LOCL^ORQQLR1(ORDFN,TEST,SPECIMEN) 98 ..Q:'$L($G(ORZ)) 99 ..S CDT=$P(ORZ,U,7) 100 ..I CDT'<BDT S WBCRSLT=1 101 Q:+$G(WBCRSLT)<1 "0^" 102 Q $P(ORZ,U,3)_U_$P(ORZ,U,3)_" "_$P(ORZ,U,4)_" "_$P(ORZ,U,5)_" ("_$P(ORZ,U,6)_") "_$$FMTE^XLFDT(CDT,"2P") 103 ; 104 CLOZLABS(ORDFN,ORDAYS,ORCLOZ) ;extrinsic function rtns "1" if clozapine ordered and WBC labs results within past ORDAYS, "0" if not 105 ;result format: clozapine/mapped labs flag^recent WBC flag;recent WBC 106 ; result^recent ANC flag;recent ANC result^formatted WBC and ANC results 107 ; 108 N BDT,WBC,WBCSPEC,WBCRSLT,WBCCDT,WBCF,ANC,ANCSPEC,ANCRSLT,ANCCDT,ANCF 109 Q:'$L($G(ORDFN)) "0^" 110 I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT($$NOW^XLFDT,"-"_ORDAYS,"","","") 111 S:'$L($G(BDT)) BDT=1 ;if no ORDAYS, set BDT to '1' to search all days 112 ; 113 K LAB 114 D EN^PSODRG(ORCLOZ) ;pharmacy api rtns Lab file ptrs for WBC, ANC 115 Q:$G(LAB("NOT"))=0 "0^" ;medication is not clozapine 116 Q:$G(LAB("BAD TEST"))=0 "0^" ;one or both lab tests aren't mapped 117 S WBC=$G(LAB("WBC")),WBCSPEC=$P(WBC,U,2),WBC=$P(WBC,U) 118 S ANC=$G(LAB("ANC")),ANCSPEC=$P(ANC,U,2),ANC=$P(ANC,U) 119 ; 120 S WBCRSLT=$$LOCL^ORQQLR1(ORDFN,WBC,WBCSPEC) 121 S WBCCDT=$P(WBCRSLT,U,7) 122 S WBC=$P(WBCRSLT,U,3) 123 I $L(WBC) D 124 .S WBCRSLT="WBC: "_WBC_" ["_$$FMTE^XLFDT(WBCCDT,"""2P""")_"]" 125 E S WBCRSLT="WBC: no results found" 126 I $L(WBC),(WBCCDT>BDT) S WBCF=1 127 S:$G(WBCF)'=1 WBCF=0 128 ; 129 S ANCRSLT=$$LOCL^ORQQLR1(ORDFN,ANC,ANCSPEC) 130 S ANCCDT=$P(ANCRSLT,U,7) 131 S ANC=$P(ANCRSLT,U,3) 132 I $L(ANC),(ANCCDT=WBCCDT) D ;ANC from same collection d/t as WBC 133 .S ANC=(WBC*ANC)/100 134 .S ANCRSLT="ANC: "_ANC_" ["_$$FMTE^XLFDT(ANCCDT,"""2P""")_"]" 135 E S ANCRSLT="ANC: no results found" 136 I $L(ANC),(ANCCDT>BDT) S ANCF=1 137 S:$G(ANCF)'=1 ANCF=0 138 ; 139 K LAB 140 Q "1^"_WBCF_";"_WBC_"^"_ANCF_";"_ANC_"^"_WBCRSLT_" "_ANCRSLT -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORLP.m
r613 r623 1 ORLP ; SLC/CLA - Manager for Team List options ; 5/30/08 6:28am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**47,90,98,243**;Dec 17, 1997;Build 242 3 ; 4 CLEAR ; From TM, MERG^ORLP1, END^ORLP0. 5 K ^XUTL("OR",$J,"ORLP"),^("ORV"),^("ORU"),^("ORW") S ORCNT=0 6 Q 7 ; 8 TM ; From option ORLP TEAM ADD - create/add a team list. 9 N ORLTYP 10 D CLEAR 11 W @IOF,!,"A team list is a list containing patients related to several providers.",!,"These providers are the list's users. You may now create a new team list" 12 W !,"or add autolinks, users and/or patients to an existing team list. Autolinks",!,"automatically add or remove patients with ADT movements. Users on the list" 13 W !,"may receive notifications regarding patients on the same list. Please prefix",!,"your list name with 'TEAM' or 'SERVICE' (e.g. TEAM7B, SERVICECARDIOLOGY.)",! 14 D ASKLIST,END 15 Q 16 ; 17 ASKLIST ; Ask for team list. 18 ; NOTE: For new entries, TYPE field is required and trigger 19 ; stuffs CREATOR field with DUZ of current user. 20 ; 21 AL N DLAYGO,DIC,DIE,DIK,DR,ORFLAG,ORLTNAM,OROWNER,ORROOT,ORDA,ORYY 22 N DIR S DIR(0)="FAO^3:30",DIR("A")="Enter team list name: " 23 D ^DIR 24 I '$D(X)!$D(DIRUT) K DIR,DIRUT Q 25 S ORLTNAM=$$CHKNAM(Y) ; Check for duplication. 26 K DIR 27 N DIC S X=$G(X),(ORROOT,DIC)="^OR(100.21,",DLAYGO=100.21,DIC(0)="LEFQZ" D ^DIC 28 I '$D(X)!(+Y<0)!$D(DIRUT) K DIRUT Q ; User aborted or problem. 29 I +Y,'+$G(^OR(100.21,+Y,11)) S ^OR(100.21,+Y,11)="0^" 30 ; Check for "Personal" lists (and not a new entry): 31 I ORLTNAM>0,(+Y>0),$P($G(^OR(100.21,+Y,0)),U,2)="P" W !!," Personal lists cannot be edited here.",! G AL 32 S (ORYY,TEAM)=Y,ORDA=+Y,TEAM(0)=Y(0),^TMP("ORLP",$J,"TLIST")=+Y K DIC 33 ; Check for entry of team type (new team entry): 34 I $P(TEAM,U,3) D Q 35 .I $P(TEAM(0),U,2)="" D 36 ..SET Y=TEAM,Y(0)=TEAM(0) ; Reassign in case DIE previously called. 37 ..N DIE S DIE=ORROOT,DA=+Y,DR="1 Enter type: ~R" D ^DIE I $O(Y(0)) S DIK=DIE D ^DIK Q 38 .S (ORLTYP,OROWNER)="" 39 .S ORLTYP=$P(^OR(100.21,+TEAM,0),U,2) Q:'$L(ORLTYP) 40 .; Check for "P" type, ask for user/owner input: 41 .I ORLTYP="P" D OWNER^ORLP1 ; Sets OROWNER variable. 42 .I (ORLTYP="P")&(OROWNER="") S DIK=ORROOT,DA=ORDA D ^DIK Q 43 .; 44 .; Allow further editing of autolink type teams: 45 .I ORLTYP["A" S:'$D(^OR(100.21,+TEAM,2,0)) ^(0)="^100.213AVI^^" D Q 46 .. D ASKLINK,ASKUSER,ASKDEV,ASKSUB 47 .; 48 .; Proceed with editing for "TM" type teams: 49 .D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV 50 ; 51 ; For existing teams, display team type: 52 W !," Type: "_$S($P(Y(0),U,2)="TM":"Manual Team List",$P(Y(0),U,2)="TA":"Autolinked Team List",$P(Y(0),U,2)="MRAL":"Manual Removal Autolinked Team List",1:"(Unknown)") 53 ; 54 ; Lock before allowing editing: 55 I $O(^OR(100.21,+TEAM,10,0)) L +^OR(100.21,+TEAM):3 I '$T W !?5," Another user is editing this entry." Q 56 ; 57 ; Allow applicable editing for all types but "TM" teams: 58 I $P(TEAM(0),U,2)'="TM" D 59 . D ASKLINK,ASKUSER,ASKDEV 60 . ; 61 . ; Editing of "subscription" attribute for "TA" and "MRAL" teams: 62 . I $P(TEAM(0),U,2)["A" D 63 . . D ASKSUB 64 ; 65 ; Proceed with editing for "TM" type teams: 66 I $P(TEAM(0),U,2)="TM" D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV 67 Q 68 ; 69 ASKLINK ; Ask for autolinks. 70 N DIC,DA,DLAYGO,Y,DUOUT,LVP,LVPT,LNAME 71 W ! 72 F K DIC,DA,DUOUT D I LVP<1 Q 73 .S DLAYGO=100.21,DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",2,",DIC(0)="AELMQZ",DIC("A")=" Enter team autolink: " 74 .D ^DIC S LVP=Y I Y<1 Q 75 .I $P($G(Y),U,3)=1 D 76 ..S LNAME=Y(0,0) 77 ..I LVP["VA(200" F D Q:'$D(Y) 78 ...S DA(1)=+TEAM,DIE="^OR(100.21,"_DA(1)_",2,",DA(1)=+TEAM,DA=+LVP,DR="1R" D ^DIE I $D(Y) W !," This field is required in order for Provider autolinks to work correctly.",!," Please answer the question." 79 ..S LVPT=$P($G(^OR(100.21,+TEAM,2,+LVP,0)),U,2) 80 ..; For clinics, take a fork in the road: 81 ..I $P($P(LVP,U,2),";",2)="SC(" D BYCL(LVP) Q 82 ..; For autolinks besides clinics, truck on: 83 ..D ADDLPTS 84 Q 85 ; 86 ADDLPTS ; Add patients linked to autolink. 87 W ! 88 W !," [ADT movements linked to " 89 W !," ",LNAME 90 W !," will now automatically add patients to this list.]" 91 S LINK=$P(LVP,U,2),FILE="^"_$P(LINK,";",2),X="",CNT=0 92 W !!," Adding patients linked to ",LNAME,"..." 93 W ! 94 I FILE="^DIC(42," D LOOPTS("CN",LNAME) Q 95 I FILE="^DG(405.4," D LOOPTS("RM",LNAME) Q 96 I FILE="^VA(200," D Q 97 . ; Variable LVPT determines if provider pointer is for: 98 . ; B - Both Primary and Attending 99 . ; A - Attending 100 . ; P - Primary 101 . I LVPT["B" D LOOPTS("APR",+LINK) N CNTAPR S CNTAPR=CNT,CNT=0 D LOOPTS("AAP",+LINK) Q 102 . I LVPT["P" D LOOPTS("APR",+LINK) Q 103 . I LVPT["A" D LOOPTS("AAP",+LINK) 104 I FILE="^DIC(45.7," D LOOPTS("ATR",+LINK) Q 105 Q 106 ; 107 BYCL(CLINIC) ; SLC/PKS - 6/99 - Return list of clinic patients by enrollment. 108 ; 109 ; Called by ASKLINK. 110 ; 111 ; Variables used: 112 ; 113 ; CLINIC = Clinic to search. 114 ; ORLIST = Array, returned by call to PTCL^SCAPMC. 115 ; ORERR = Array for errors, returned by call to PTCL^SCAPMC. 116 ; ORRET = Flag for problem with PTCL^SCAPMC call. 117 ; RESULT = Holds result of PTCL^SCAPMC call (1=OK, 0=error). 118 ; RCD = Holder for each record in ^TMP of PTCL^SCAPMC. 119 ; DFN = Patient IEN. 120 ; ALCNT = Count of autolink patients added. 121 ; DUPCNT = Count of duplicate patients already on list. 122 ; X = Temp value holder variable. 123 ; 124 N DIC,DA,DO,DD,ORLIST,ORERR,RESULT,RCD,DFN,ALCNT,DUPCNT,X,ORRET 125 ; 126 ; Assign clinic variable: 127 S CLINIC=$P(CLINIC,"^",2) 128 S CLINIC=$P(CLINIC,";") 129 ; 130 ; Keep user informed: 131 W ! 132 W !," [Patient enrollments linked to " 133 W !," ",LNAME 134 W !," will now automatically add patients to this list.]" 135 W ! 136 W !," Adding patients enrolled in ",LNAME,"..." 137 W ! 138 ; 139 ; Process the Autolink entries: 140 K ^TMP("SC TMP LIST") ; Clean up potential leftover data. 141 S ORRET=1 142 S RESULT=$$PTCL^SCAPMC(CLINIC,,.ORLIST,.ORERR) 143 I $L($G(RESULT)) D ; Make sure something was returned. 144 .I RESULT>0 S ORRET=0 ; Was return value 1 or more? 145 I ORRET W !," Error in processing - patients will not be added." Q ; Abort if there's a problem. 146 ; Clinic patients should now be in ^TMP("SC TMP LIST",$J file. 147 ; 148 ; Write the patients to the OE/RR LIST file: 149 S ALCNT=0 ; Initialize autolink counter. 150 S DUPCNT=0 ; Initialize duplicate counter. 151 S RCD=0 ; Initialize to start with first data record. 152 F S RCD=$O(^TMP("SC TMP LIST",$J,RCD)) Q:'RCD D ; Each record. 153 .S DFN=$P(^TMP("SC TMP LIST",$J,RCD),"^") ; Patient IEN. 154 .S X=DFN_";DPT(" ; Add ";DPT(" to patient string. 155 .I $D(^OR(100.21,+TEAM,10,"B",X)) S DUPCNT=DUPCNT+1 Q ; This patient already on list - increment dupe counter. 156 .S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^" 157 .K DIC,DA,DO,DD 158 .S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L" 159 .D FILE^DICN 160 .I +X S ALCNT=ALCNT+1 ; Increment counter. 161 .Q ; Loop for each record in ^TMP file. 162 ; 163 ; Give user the results: 164 I ALCNT>0 W !," "_ALCNT_" patient(s) added to list." 165 I ALCNT=0 W !," No linked patients found." 166 I DUPCNT>0 W !," "_DUPCNT_" patient(s) already on list." 167 W ! 168 K ^TMP("SC TMP LIST",$J) ; Clean up ^TMP file entries. 169 ; 170 Q 171 ; 172 LOOPTS(REF,DEX) ; 173 S ORLPT=0 F S ORLPT=$O(^DPT(REF,DEX,ORLPT)) Q:ORLPT'>0 S X=ORLPT_";DPT(" D ADDLOOP 174 I $D(LVPT),LVPT["B"!(LVPT']"") Q:REF="APR" 175 I +X W !,$S(+CNT:" "_(+$G(CNTAPR)+(+CNT))_" patient(s) added.",1:" Linked patients already on list.") 176 E W " No linked patients found." 177 W ! 178 K DEX,FILE,MSG,REF,X,Y 179 Q 180 ; 181 ASKUSER ; From ASKLIST - ask for providers/users. 182 Q:$D(DTOUT)!($D(DUOUT)) 183 W ! 184 S:'$D(^OR(100.21,+TEAM,1,0)) ^(0)="^100.212PA^^" 185 K DIC,DA 186 S DLAYGO=100.212,DA(1)=+TEAM 187 S DIC("P")="100.212PA",DIC="^OR(100.21,"_DA(1)_",1,",DIC(0)="AELMQ" 188 S DIC("A")=" Enter team provider/user: " 189 ; SLC/PKS - Next line added on 4/11/2000: 190 S DIC("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)" 191 F D Q:Y<1 192 .D ^DIC 193 .I '(Y<1) W ! 194 K DIC,DA,DLAYGO 195 Q 196 ; 197 ASKDEV ; From ASKLIST - ask for device. 198 ; 199 ; New, by PKS - 7/29/99: 200 Q:$D(DTOUT)!($D(DUOUT)) ; Previous interaction fail? 201 W ! 202 N DIE,DR 203 S DIE="^OR(100.21," 204 S DA=+TEAM 205 S DR="1.5 Enter device: " 206 D ^DIE ; Writes to DEVICE field. 207 K DIE 208 Q 209 ; 210 ASKSUB ; From ASKLIST - Ask re: subscription status. 211 ; (PKS - 8/1999) 212 ; 213 Q:$D(DTOUT)!($D(DUOUT)) ; Previous interaction fail? 214 W ! 215 N DIE,DR 216 S DIE="^OR(100.21," 217 S DA=+TEAM 218 S DR="1.7 Enter subscription status: " 219 D ^DIE ; Writes to SUBSCRIBE field. 220 K DIE 221 ; 222 Q 223 ; 224 STOR ; From SEQ^ORLP0 - store list in 100.21. 225 Q:'$D(DUZ)!('ORCNT) 226 I '$D(TEAM),($D(Y)#2) S TEAM=Y 227 S DLAYGO=100.21 228 L +^OR(100.21,+TEAM) 229 S (CNT,ORLI)=0 F ORLJ=1:1 S ORLI=$O(^XUTL("OR",$J,"ORLP",ORLI)) Q:ORLI<1 I $D(^(ORLI,0)) S X=^(0),X=$P(X,U,3) D ADDLOOP 230 I $G(X)>0 S MSG=$S(CNT=0:" Patient(s) already on list.",1:" "_CNT_" patient(s) added.") W !?5,MSG 231 E W !?5," No patients found." 232 I CNT>0 W !?5," Storing list " W:$D(TEAM) $P(TEAM,U,2)," " W "for future reference..." 233 L -^OR(100.12,+TEAM) 234 Q 235 ; 236 ADDLOOP ; From STOR, LOOPTS - add patients. 237 Q:$D(^OR(100.21,+TEAM,10,"B",X)) ; Quit if on list. 238 S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^" 239 K DIC,DA,DO,DD 240 S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L" 241 D FILE^DICN I Y>0 S:$D(CNT) CNT=CNT+1 242 Q 243 ; 244 CHKNAM(X) ; Check for duplicate entry. 245 N DIC 246 S X=$G(X) 247 S DIC="^OR(100.21," 248 D ^DIC 249 S X=+Y 250 Q X 251 ; 252 END ; 253 I $G(TEAM) L -^OR(100.21,+TEAM) 254 ; 255 END1 K %,CNT,DA,DD,DIC,DO,DIE,DIK,DIR,DR,LINK,ORCNT,ORLI,ORLJ,ORLPT,SEL,TEAM,X,Y,ORBSTG,ORBROOT,DTOUT 256 Q 257 ; 1 ORLP ; SLC/CLA - Manager for Team List options ; [1/12/01 1:54pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**47,90,98**;Dec 17, 1997 3 ; 4 CLEAR ; From TM, MERG^ORLP1, END^ORLP0. 5 K ^XUTL("OR",$J,"ORLP"),^("ORV"),^("ORU"),^("ORW") S ORCNT=0 6 Q 7 ; 8 TM ; From option ORLP TEAM ADD - create/add a team list. 9 N ORLTYP 10 D CLEAR 11 W @IOF,!,"A team list is a list containing patients related to several providers.",!,"These providers are the list's users. You may now create a new team list" 12 W !,"or add autolinks, users and/or patients to an existing team list. Autolinks",!,"automatically add or remove patients with ADT movements. Users on the list" 13 W !,"may receive notifications regarding patients on the same list. Please prefix",!,"your list name with 'TEAM' or 'SERVICE' (e.g. TEAM7B, SERVICECARDIOLOGY.)",! 14 D ASKLIST,END 15 Q 16 ; 17 ASKLIST ; Ask for team list. 18 ; NOTE: For new entries, TYPE field is required and trigger 19 ; stuffs CREATOR field with DUZ of current user. 20 ; 21 AL N DLAYGO,DIC,DIE,DIK,DR,ORFLAG,ORLTNAM,OROWNER,ORROOT,ORDA,ORYY 22 N DIR S DIR(0)="FAO^3:30",DIR("A")="Enter team list name: " 23 D ^DIR 24 I '$D(X)!$D(DIRUT) K DIR,DIRUT Q 25 S ORLTNAM=$$CHKNAM(Y) ; Check for duplication. 26 K DIR 27 N DIC S X=$G(X),(ORROOT,DIC)="^OR(100.21,",DLAYGO=100.21,DIC(0)="LEFQZ" D ^DIC 28 I '$D(X)!(+Y<0)!$D(DIRUT) K DIRUT Q ; User aborted or problem. 29 ; Check for "Personal" lists (and not a new entry): 30 I ORLTNAM>0,(+Y>0),$P($G(^OR(100.21,+Y,0)),U,2)="P" W !!," Personal lists cannot be edited here.",! G AL 31 S (ORYY,TEAM)=Y,ORDA=+Y,TEAM(0)=Y(0),^TMP("ORLP",$J,"TLIST")=+Y K DIC 32 ; Check for entry of team type (new team entry): 33 I $P(TEAM,U,3) D Q 34 .I $P(TEAM(0),U,2)="" D 35 ..SET Y=TEAM,Y(0)=TEAM(0) ; Reassign in case DIE previously called. 36 ..N DIE S DIE=ORROOT,DA=+Y,DR="1 Enter type: ~R" D ^DIE I $O(Y(0)) S DIK=DIE D ^DIK Q 37 .S (ORLTYP,OROWNER)="" 38 .S ORLTYP=$P(^OR(100.21,+TEAM,0),U,2) Q:'$L(ORLTYP) 39 .; Check for "P" type, ask for user/owner input: 40 .I ORLTYP="P" D OWNER^ORLP1 ; Sets OROWNER variable. 41 .I (ORLTYP="P")&(OROWNER="") S DIK=ORROOT,DA=ORDA D ^DIK Q 42 .; 43 .; Allow further editing of autolink type teams: 44 .I ORLTYP["A" S:'$D(^OR(100.21,+TEAM,2,0)) ^(0)="^100.213AVI^^" D Q 45 .. D ASKLINK,ASKUSER,ASKDEV,ASKSUB 46 .; 47 .; Proceed with editing for "TM" type teams: 48 .D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV 49 ; 50 ; For existing teams, display team type: 51 W !," Type: "_$S($P(Y(0),U,2)="TM":"Manual Team List",$P(Y(0),U,2)="TA":"Autolinked Team List",$P(Y(0),U,2)="MRAL":"Manual Removal Autolinked Team List",1:"(Unknown)") 52 ; 53 ; Lock before allowing editing: 54 I $O(^OR(100.21,+TEAM,10,0)) L +^OR(100.21,+TEAM):3 I '$T W !?5," Another user is editing this entry." Q 55 ; 56 ; Allow applicable editing for all types but "TM" teams: 57 I $P(TEAM(0),U,2)'="TM" D 58 . D ASKLINK,ASKUSER,ASKDEV 59 . ; 60 . ; Editing of "subscription" attribute for "TA" and "MRAL" teams: 61 . I $P(TEAM(0),U,2)["A" D 62 . . D ASKSUB 63 ; 64 ; Proceed with editing for "TM" type teams: 65 I $P(TEAM(0),U,2)="TM" D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV 66 Q 67 ; 68 ASKLINK ; Ask for autolinks. 69 N DIC,DA,DLAYGO,Y,DUOUT,LVP,LVPT,LNAME 70 W ! 71 F K DIC,DA,DUOUT D I LVP<1 Q 72 .S DLAYGO=100.21,DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",2,",DIC(0)="AELMQZ",DIC("A")=" Enter team autolink: " 73 .D ^DIC S LVP=Y I Y<1 Q 74 .I $P($G(Y),U,3)=1 D 75 ..S LNAME=Y(0,0) 76 ..I LVP["VA(200" F D Q:'$D(Y) 77 ...S DA(1)=+TEAM,DIE="^OR(100.21,"_DA(1)_",2,",DA(1)=+TEAM,DA=+LVP,DR="1R" D ^DIE I $D(Y) W !," This field is required in order for Provider autolinks to work correctly.",!," Please answer the question." 78 ..S LVPT=$P($G(^OR(100.21,+TEAM,2,+LVP,0)),U,2) 79 ..; For clinics, take a fork in the road: 80 ..I $P($P(LVP,U,2),";",2)="SC(" D BYCL(LVP) Q 81 ..; For autolinks besides clinics, truck on: 82 ..D ADDLPTS 83 Q 84 ; 85 ADDLPTS ; Add patients linked to autolink. 86 W ! 87 W !," [ADT movements linked to " 88 W !," ",LNAME 89 W !," will now automatically add patients to this list.]" 90 S LINK=$P(LVP,U,2),FILE="^"_$P(LINK,";",2),X="",CNT=0 91 W !!," Adding patients linked to ",LNAME,"..." 92 W ! 93 I FILE="^DIC(42," D LOOPTS("CN",LNAME) Q 94 I FILE="^DG(405.4," D LOOPTS("RM",LNAME) Q 95 I FILE="^VA(200," D Q 96 . ; Variable LVPT determines if provider pointer is for: 97 . ; B - Both Primary and Attending 98 . ; A - Attending 99 . ; P - Primary 100 . I LVPT["B" D LOOPTS("APR",+LINK) N CNTAPR S CNTAPR=CNT,CNT=0 D LOOPTS("AAP",+LINK) Q 101 . I LVPT["P" D LOOPTS("APR",+LINK) Q 102 . I LVPT["A" D LOOPTS("AAP",+LINK) 103 I FILE="^DIC(45.7," D LOOPTS("ATR",+LINK) Q 104 Q 105 ; 106 BYCL(CLINIC) ; SLC/PKS - 6/99 - Return list of clinic patients by enrollment. 107 ; 108 ; Called by ASKLINK. 109 ; 110 ; Variables used: 111 ; 112 ; CLINIC = Clinic to search. 113 ; ORLIST = Array, returned by call to PTCL^SCAPMC. 114 ; ORERR = Array for errors, returned by call to PTCL^SCAPMC. 115 ; ORRET = Flag for problem with PTCL^SCAPMC call. 116 ; RESULT = Holds result of PTCL^SCAPMC call (1=OK, 0=error). 117 ; RCD = Holder for each record in ^TMP of PTCL^SCAPMC. 118 ; DFN = Patient IEN. 119 ; ALCNT = Count of autolink patients added. 120 ; DUPCNT = Count of duplicate patients already on list. 121 ; X = Temp value holder variable. 122 ; 123 N DIC,DA,DO,DD,ORLIST,ORERR,RESULT,RCD,DFN,ALCNT,DUPCNT,X,ORRET 124 ; 125 ; Assign clinic variable: 126 S CLINIC=$P(CLINIC,"^",2) 127 S CLINIC=$P(CLINIC,";") 128 ; 129 ; Keep user informed: 130 W ! 131 W !," [Patient enrollments linked to " 132 W !," ",LNAME 133 W !," will now automatically add patients to this list.]" 134 W ! 135 W !," Adding patients enrolled in ",LNAME,"..." 136 W ! 137 ; 138 ; Process the Autolink entries: 139 K ^TMP("SC TMP LIST") ; Clean up potential leftover data. 140 S ORRET=1 141 S RESULT=$$PTCL^SCAPMC(CLINIC,,.ORLIST,.ORERR) 142 I $L($G(RESULT)) D ; Make sure something was returned. 143 .I RESULT>0 S ORRET=0 ; Was return value 1 or more? 144 I ORRET W !," Error in processing - patients will not be added." Q ; Abort if there's a problem. 145 ; Clinic patients should now be in ^TMP("SC TMP LIST",$J file. 146 ; 147 ; Write the patients to the OE/RR LIST file: 148 S ALCNT=0 ; Initialize autolink counter. 149 S DUPCNT=0 ; Initialize duplicate counter. 150 S RCD=0 ; Initialize to start with first data record. 151 F S RCD=$O(^TMP("SC TMP LIST",$J,RCD)) Q:'RCD D ; Each record. 152 .S DFN=$P(^TMP("SC TMP LIST",$J,RCD),"^") ; Patient IEN. 153 .S X=DFN_";DPT(" ; Add ";DPT(" to patient string. 154 .I $D(^OR(100.21,+TEAM,10,"B",X)) S DUPCNT=DUPCNT+1 Q ; This patient already on list - increment dupe counter. 155 .S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^" 156 .K DIC,DA,DO,DD 157 .S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L" 158 .D FILE^DICN 159 .I +X S ALCNT=ALCNT+1 ; Increment counter. 160 .Q ; Loop for each record in ^TMP file. 161 ; 162 ; Give user the results: 163 I ALCNT>0 W !," "_ALCNT_" patient(s) added to list." 164 I ALCNT=0 W !," No linked patients found." 165 I DUPCNT>0 W !," "_DUPCNT_" patient(s) already on list." 166 W ! 167 K ^TMP("SC TMP LIST",$J) ; Clean up ^TMP file entries. 168 ; 169 Q 170 ; 171 LOOPTS(REF,DEX) ; 172 S ORLPT=0 F S ORLPT=$O(^DPT(REF,DEX,ORLPT)) Q:ORLPT'>0 S X=ORLPT_";DPT(" D ADDLOOP 173 I $D(LVPT),LVPT["B"!(LVPT']"") Q:REF="APR" 174 I +X W !,$S(+CNT:" "_(+$G(CNTAPR)+(+CNT))_" patient(s) added.",1:" Linked patients already on list.") 175 E W " No linked patients found." 176 W ! 177 K DEX,FILE,MSG,REF,X,Y 178 Q 179 ; 180 ASKUSER ; From ASKLIST - ask for providers/users. 181 Q:$D(DTOUT)!($D(DUOUT)) 182 W ! 183 S:'$D(^OR(100.21,+TEAM,1,0)) ^(0)="^100.212PA^^" 184 K DIC,DA 185 S DLAYGO=100.212,DA(1)=+TEAM 186 S DIC("P")="100.212PA",DIC="^OR(100.21,"_DA(1)_",1,",DIC(0)="AELMQ" 187 S DIC("A")=" Enter team provider/user: " 188 ; SLC/PKS - Next line added on 4/11/2000: 189 S DIC("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)" 190 F D Q:Y<1 191 .D ^DIC 192 .I '(Y<1) W ! 193 K DIC,DA,DLAYGO 194 Q 195 ; 196 ASKDEV ; From ASKLIST - ask for device. 197 ; 198 ; New, by PKS - 7/29/99: 199 Q:$D(DTOUT)!($D(DUOUT)) ; Previous interaction fail? 200 W ! 201 N DIE,DR 202 S DIE="^OR(100.21," 203 S DA=+TEAM 204 S DR="1.5 Enter device: " 205 D ^DIE ; Writes to DEVICE field. 206 K DIE 207 Q 208 ; 209 ASKSUB ; From ASKLIST - Ask re: subscription status. 210 ; (PKS - 8/1999) 211 ; 212 Q:$D(DTOUT)!($D(DUOUT)) ; Previous interaction fail? 213 W ! 214 N DIE,DR 215 S DIE="^OR(100.21," 216 S DA=+TEAM 217 S DR="1.7 Enter subscription status: " 218 D ^DIE ; Writes to SUBSCRIBE field. 219 K DIE 220 ; 221 Q 222 ; 223 STOR ; From SEQ^ORLP0 - store list in 100.21. 224 Q:'$D(DUZ)!('ORCNT) 225 I '$D(TEAM),($D(Y)#2) S TEAM=Y 226 S DLAYGO=100.21 227 L +^OR(100.21,+TEAM) 228 S (CNT,ORLI)=0 F ORLJ=1:1 S ORLI=$O(^XUTL("OR",$J,"ORLP",ORLI)) Q:ORLI<1 I $D(^(ORLI,0)) S X=^(0),X=$P(X,U,3) D ADDLOOP 229 I $G(X)>0 S MSG=$S(CNT=0:" Patient(s) already on list.",1:" "_CNT_" patient(s) added.") W !?5,MSG 230 E W !?5," No patients found." 231 I CNT>0 W !?5," Storing list " W:$D(TEAM) $P(TEAM,U,2)," " W "for future reference..." 232 L -^OR(100.12,+TEAM) 233 Q 234 ; 235 ADDLOOP ; From STOR, LOOPTS - add patients. 236 Q:$D(^OR(100.21,+TEAM,10,"B",X)) ; Quit if on list. 237 S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^" 238 K DIC,DA,DO,DD 239 S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L" 240 D FILE^DICN I Y>0 S:$D(CNT) CNT=CNT+1 241 Q 242 ; 243 CHKNAM(X) ; Check for duplicate entry. 244 N DIC 245 S X=$G(X) 246 S DIC="^OR(100.21," 247 D ^DIC 248 S X=+Y 249 Q X 250 ; 251 END ; 252 I $G(TEAM) L -^OR(100.21,+TEAM) 253 ; 254 END1 K %,CNT,DA,DD,DIC,DO,DIE,DIK,DIR,DR,LINK,ORCNT,ORLI,ORLJ,ORLPT,SEL,TEAM,X,Y,ORBSTG,ORBROOT,DTOUT 255 Q 256 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLDPS.m
r613 r623 1 ORMBLDPS ;SLC/MKB-Build outgoing Pharmacy ORM msgs ;6/16/08 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,38,54,86,97,94,116,129,141,190,195,237,254,243**;Dec 17, 1997;Build 242 3 PTR(NAME) ; -- Returns ptr value of prompt in Dialog file 4 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) 5 ; 6 NVA ; -- new Non-VA Meds order 7 N NVA S NVA=1 8 OUT ; -- new Outpt Meds order [same as UD, +3 fields] 9 UD ; -- new Inpt (Unit Dose) Meds order 10 N ADMIN,OI,DRUG,INSTR,DOSE,ROUTE,SCHED,DUR,URG,PROVCOMM,PI,DISPENSE,X,Y,I,J,K,L,QT1,QT2,QT3,QT4,QT6,QT9,CONJ,ORC,SC,OUTPT,OITXT,OITXT2 11 N QT7,SCHTYPE 12 S OUTPT=$S($P(OR0,U,12)="O":1,1:0) ;outpt flag 13 S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different 14 S OI=$$PTR("ORDERABLE ITEM"),DRUG=$$PTR("DISPENSE DRUG") 15 S INSTR=$$PTR("INSTRUCTIONS"),SCHED=$$PTR("SCHEDULE"),ADMIN=$$PTR("ADMIN TIMES") 16 S SCHTYPE=$$PTR("SCHEDULE TYPE") 17 S DUR=$$PTR("DURATION"),URG=$$PTR("URGENCY"),DOSE=$$PTR("DOSE") 18 S ROUTE=$$PTR("ROUTE"),PROVCOMM=$$PTR("WORD PROCESSING 1") 19 S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN") 20 S J=1,ORC(J)=$P(ORMSG(4),"|",1,7)_"|" 21 I +$G(NVA)=1 G NVA1 22 UD1 S I=0 F S I=$O(ORDIALOG(INSTR,I)) Q:I'>0 D 23 . S X=$G(ORDIALOG(DOSE,I)) 24 . ;S QT1=$S($L(X):$P(X,"&",1,4)_"&"_$P(X,"&",6),1:"") 25 . S QT2=$$ESC($G(ORDIALOG(SCHED,I)))_$S(OUTPT:"",1:"&"_$G(ORDIALOG(ADMIN,I))) 26 . S QT3=$$HL7DUR 27 . S QT1=$S($L(X):$P(X,"&",1,6),1:"") 28 . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2) 29 . S QT7=$G(ORDIALOG(SCHTYPE,I)) 30 . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~" 31 . S J=J+1,ORC(J)=QT1_U_QT2_U_QT3_"^^^"_QT6_U_QT7_U_$$INSTR_U_QT9 32 ; 33 NVA1 I +$G(NVA)=1 D 34 . S I=1 ;only one dosage possible for non-va meds 35 . S QT2=$G(ORDIALOG(SCHED,I)),QT3=$$HL7DUR,X=$G(ORDIALOG(DOSE,I)) 36 . S QT1=$S($L(X):$P(X,"&",1,6),1:"") 37 . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2) 38 . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~" 39 . S J=J+1,ORC(J)=QT1_U_$$ESC(QT2)_U_QT3_"^^^"_QT6_"^^"_$$INSTR_U_QT9 40 ; 41 I $L($P(OR0,U,8)) S $P(ORC(2),U,4)=$$FMTHL7^XLFDT($P(OR0,U,8)) S:J<2 J=2 42 S J=J+1,ORC(J)="|"_$P(ORMSG(4),"|",9,999),ORC=J,X="ORMSG(4)",ORMSG(4)="",I=0 43 F J=1:1:ORC S Y=ORC(J) D ;add to ORMSG(4) 44 . I $L(@X)+$L(Y)'>245 S @X=@X_Y 45 . E S L=245-$L(@X),@X=@X_$E(Y,1,L),I=I+1,X="ORMSG(4,"_I_")",@X=$E(Y,L+1,$L(Y)) 46 I $G(ORDIALOG(DRUG,1)) S X=$$ENDCM^PSJORUTL(ORDIALOG(DRUG,1)),DISPENSE=$P(X,U,3)_"^^99NDF^"_ORDIALOG(DRUG,1)_"^^99PSD" 47 S OITXT=$$USID^ORMBLD($G(ORDIALOG(OI,1))) 48 S OITXT2=$P(OITXT,U,1,4)_U_$$ESC($P(OITXT,U,5))_U_$P(OITXT,U,6,99) 49 S ORMSG(5)="RXO|"_OITXT2_"|||||||||"_$G(DISPENSE) 50 UD2 I $G(OUTPT) D 51 . N QTY,REFS,DSPY 52 . S QTY=$$PTR("QUANTITY"),REFS=$$PTR("REFILLS"),DSPY=$$PTR("DAYS SUPPLY") 53 . S ORMSG(5)=ORMSG(5)_"|"_$G(ORDIALOG(QTY,1))_"||"_$G(ORDIALOG(REFS,1))_"||||D"_$G(ORDIALOG(DSPY,1)) 54 S I=5 I $L($G(ORDIALOG(PROVCOMM,1))) D 55 . S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,0)) Q:'J 56 . S I=6,ORMSG(6)="NTE|6|P|"_$$ESC($G(^TMP("ORWORD",$J,PROVCOMM,1,J,0))) 57 . S K=0 F S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,J)) Q:J'>0 S K=K+1,ORMSG(6,K)=$G(^(J,0)) 58 I $G(OUTPT),$L($G(ORDIALOG(PI,1))) D 59 . S J=$O(^TMP("ORWORD",$J,PI,1,0)) Q:'J 60 . S I=I+1,ORMSG(I)="NTE|7|P|"_$G(^TMP("ORWORD",$J,PI,1,J,0)) 61 . S K=0 F S J=$O(^TMP("ORWORD",$J,PI,1,J)) Q:J'>0 S K=K+1,ORMSG(I,K)=$G(^(J,0)) 62 UD3 S J=0 F S J=$O(ORDIALOG(ROUTE,J)) Q:J'>0 S I=I+1,ORMSG(I)=$$RXR($G(ORDIALOG(ROUTE,J))) 63 I $D(^OR(100,IFN,9)) D ORDCHKS 64 S I=I+1,ORMSG(I)=$$ZRX(IFN,OUTPT) 65 I $G(OUTPT) D ;add SC data 66 . N OR5 S OR5=$G(^OR(100,IFN,5)) 67 . I $L(OR5),OR5'?5"^" S I=I+1,ORMSG(I)="ZSC|"_$TR(OR5,"^","|") Q 68 . S SC=$$PTR("SERVICE CONNECTED") S:$D(ORDIALOG(SC,1)) I=I+1,ORMSG(I)="ZSC|"_$S(ORDIALOG(SC,1):"SC",1:"NSC") 69 ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project 70 D DG1^ORWDBA3($G(IFN),"I",I) 71 I $P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS" D 72 . S I=I+1 D ZRN(IFN,.ORMSG,I) 73 Q 74 ; 75 INSTR() ; -- Return text instructions for QT-8, instance I 76 N Y S Y=$P($G(ORDIALOG(DOSE,I)),"&",5) 77 I $G(ORDIALOG(DRUG,1)),$L(Y) Q $$ESC(Y) 78 S Y=$G(ORDIALOG(INSTR,I)) I $G(OUTPT) D 79 . N UNITS,UNT S UNITS=$$PTR("FREE TEXT"),UNT=$G(ORDIALOG(UNITS,I)) 80 . S:$L(UNT) Y=Y_" "_UNT ;old format 81 Q $$ESC(Y) 82 ; 83 HL7DUR() ; -- Returns HL7 form of duration X 84 N X,X1,X2,Y S X=$G(ORDIALOG(DUR,I)) 85 S X1=+$G(X),Y="" G:X1'>0 HDQ 86 S X2=$$UP^XLFSTR($P(X,X1,2)) S:$E(X2)=" " X2=$E(X2,2,99) 87 S Y=$S($E(X2,1,2)="MO":"L",'$L(X2):"D",1:$E(X2))_X1 88 HDQ Q Y 89 ; 90 IV ; -- new IV Meds order 91 N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,WP,QT,I,X1,X2,INST 92 N IVLIMIT ; duratioin or total volume for IV order 93 N IVTYPE,IVZRX,X,CNT,ROUTE,ORBCMA,DFN 94 S IVLIMIT=$$PTR("DURATION") 95 S IVTYPE=$G(ORDIALOG(+$$PTR("IV TYPE"),1)) 96 I IVTYPE="",$P($G(^OR(100,IFN,3)),U,11)="B" D 97 .S IVTYPE=$$MOB^ORMBLDP1(IFN,+$P($G(^OR(100,IFN,0)),U,2)) 98 .D RESP^ORCSAVE2(IFN,"OR GTX IV TYPE",IVTYPE) 99 S RATE=$$PTR("INFUSION RATE"),ADDS=$$PTR("ADDITIVE") 100 S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS") 101 S WP=$$PTR("WORD PROCESSING 1"),VOL=$$PTR("VOLUME") 102 S SCHTYPE=$$PTR("SCHEDULE TYPE") 103 S SOLN=$$PTR("ORDERABLE ITEM"),URG=+$G(ORDIALOG($$PTR("URGENCY"),1)) 104 ;I IVTYPE="",$G(ORDIALOG(+$$PTR("SCHEDULE"),1))="" S IVTYPE="C" 105 I IVTYPE="I" S QT=U_$$ESC($G(ORDIALOG(+$$PTR("SCHEDULE"),1)))_"&"_$G(ORDIALOG(+$$PTR("ADMIN TIMES"),1))_"^^^^" 106 I IVTYPE="C" S QT="^^^^^" 107 ;S QT=U_$G(ORDIALOG(+$$PTR("SCHEDULE"),1))_"^^^^" 108 S:URG QT=QT_$P($G(^ORD(101.42,URG,0)),U,2) 109 S $P(ORMSG(4),"|",8)=QT 110 S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different 111 S RATE=$G(ORDIALOG(RATE,1)) S:$E(RATE,$L(RATE))=" " RATE=$E(RATE,1,($L(RATE)-1)) S ORMSG(5)="RXO|^^^PS-1^IV^99OTH|"_$$ESC(RATE) ;strip any trailing spaces 112 S IVLIMIT=$G(ORDIALOG(IVLIMIT,1)) 113 I $L(IVLIMIT) S IVLIMIT=$$HL7IVLMT^ORMBLDP1(IVLIMIT),ORMSG(5)="RXO|^^"_IVLIMIT_"^PS-1^IV^99OTH|"_RATE 114 S I=5 I $L($G(ORDIALOG(WP,1))) D 115 . N J,K S J=$O(^TMP("ORWORD",$J,WP,1,0)) Q:'J 116 . S I=6,ORMSG(6)="NTE|6|P|"_$$ESC($G(^TMP("ORWORD",$J,WP,1,J,0))) 117 . S K=0 F S J=$O(^TMP("ORWORD",$J,WP,1,J)) Q:J'>0 S K=K+1,ORMSG(6,K)=^(J,0) 118 ;S I=I+1,ORMSG(I)=$$RXR(+$$PTR("ROUTE")) 119 S ROUTE=+$$PTR("ROUTE") 120 S I=I+1,ORMSG(I)=$$RXR($G(ORDIALOG(ROUTE,1))) 121 IV1 S INST=0 F S INST=$O(ORDIALOG(SOLN,INST)) Q:INST'>0 D 122 . S X1="B",X2=+$G(ORDIALOG(SOLN,INST)) 123 . I $P($G(^ORD(101.43,X2,"PS")),U,4) S X1=X1_"A" ;pre-mix 124 . S I=I+1,ORMSG(I)="RXC|"_X1_"|"_$$USID^ORMBLD(X2)_"|"_$G(ORDIALOG(VOL,INST))_"|"_$$HL7UNIT("ML") 125 I $O(ORDIALOG(ADDS,0)) D 126 . S INST=0 F S INST=$O(ORDIALOG(ADDS,INST)) Q:INST'>0 D 127 . . S X1=$G(ORDIALOG(ADDS,INST)),X2=$G(ORDIALOG(UNITS,INST)) 128 . . S I=I+1,ORMSG(I)="RXC|A|"_$$USID^ORMBLD(X1)_"|"_$G(ORDIALOG(STR,INST))_"|"_$$HL7UNIT(X2) 129 I $D(^OR(100,IFN,9)) D ORDCHKS 130 S IVZRX=$$ZRX(IFN,0) 131 S CNT=0 132 F X=1:1:$L(IVZRX) I $E(IVZRX,X)="|" S CNT=CNT+1 133 I CNT<6 F X=CNT:1:5 S IVZRX=IVZRX_"|" 134 S I=I+1,ORMSG(I)=IVZRX_IVTYPE 135 ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project 136 D DG1^ORWDBA3($G(IFN),"I",I) 137 Q 138 ; 139 RXR(ROUTE) ; -- Returns RXR segment 140 N IEN,NAME 141 I +ROUTE=0 Q "RXR|^^^^^99PSR" 142 K ^TMP($J,"ORMBLDPS RXR") 143 D ALL^PSS51P2(+ROUTE,,,,"ORMBLDPS RXR") 144 S NAME=^TMP($J,"ORMBLDPS RXR",+ROUTE,.01) 145 ;N NAME S NAME=$$GET1^DIQ(51.2,+ROUTE_",",.01) 146 K ^TMP($J,"ORMBLDPS RXR") 147 Q "RXR|^^^"_+ROUTE_U_NAME_"^99PSR" 148 ; 149 ZRX(IFN,OUTPT) ; -- Returns ZRX segment 150 N NATURE,TYPE,ORIG,PSORIG,ROUTING,ZRX 151 S TYPE=$P($G(^OR(100,IFN,3)),U,11),NATURE=$P($G(^(8,1,0)),U,12) 152 S:NATURE NATURE=$P($G(^ORD(100.02,+NATURE,0)),U,2) ;code 153 S PSORIG="" I (TYPE=1)!(TYPE=2) D 154 . S ORIG=$P($G(^OR(100,IFN,3)),U,5),PSORIG=$G(^OR(100,+ORIG,4)) 155 . I PSORIG'>0 S PSORIG="",TYPE=0 ;edit of unreleased order 156 S ZRX="ZRX|"_PSORIG_"|"_NATURE_"|"_$S(TYPE=1:"E",TYPE=2:"R",1:"N") 157 S ROUTING=$G(ORDIALOG($$PTR("ROUTING"),1)) 158 ;AGP FIX FOR PROBLEM WITH ROUTING BE SET TO DAY SUPPLY ONCE ROOT CAUSE 159 ;IS FOUND THIS CODE WILL BE REMOVE 160 I OUTPT=1,ROUTING'="",ROUTING>0 S ROUTING="M" 161 I $G(OUTPT) S ZRX=ZRX_"|"_ROUTING_$S($L($P($G(^OR(100,ORIFN,8,1,2)),"^",3)):"|||1",1:"") 162 Q ZRX 163 ; 164 ZRN(IFN,ORMSG,I) ; -- Set ZRN segment 165 N ST,ZRN,J,K,TXT 166 S ORMSG(I)="ZRN|N|" 167 S ST=$$PTR("STATEMENTS") 168 I $L($G(ORDIALOG(ST,1))) D 169 . S J=$O(^TMP("ORWORD",$J,ST,1,0)) Q:'J 170 . S K=0,TXT=$G(^TMP("ORWORD",$J,ST,1,J,0)) 171 . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT 172 . F S J=$O(^TMP("ORWORD",$J,ST,1,J)) Q:J'>0 S TXT=$G(^(J,0)) D 173 . . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT 174 Q 175 ; 176 ORDCHKS ; -- Include order checks in OBX segments 177 N OC,X,X1 S OC=0 178 F S OC=$O(^OR(100,IFN,9,OC)) Q:OC'>0 S X=$G(^(OC,0)),X1=$G(^(1)) D 179 . S I=I+1,ORMSG(I)="OBX|"_OC_"|TX|^^^"_+X_"^^99OCX||"_$$ESC($S($L(X1):X1,1:$P(X,U,3)))_"|||||||||"_$$FMTHL7^XLFDT($P(X,U,6))_"||"_$P(X,U,5) 180 . I $L($P(X,U,4)) S I=I+1,ORMSG(I)="NTE|"_OC_"|P|"_$$ESC($P(X,U,4)) 181 Q 182 ; 183 HL7UNIT(X) ; -- Return coded element for volume/strength units 184 N I,UNIT,Y 185 F I=1:1:$L(X) I $E(X,I)?1A Q ; first letter 186 S UNIT=$$UP^XLFSTR($E(X,I,$L(X))),Y="" 187 F I=1:1:14 S X=$P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL","^",I) I UNIT=X S Y="^^^PSIV-"_I_U_UNIT_"^99OTH" Q 188 Q Y 189 ; 190 VER(IFN) ; -- Send msg for nurse-verified orders 191 N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="I" ;Inpt only 192 S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2)) 193 S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),$P(OR0,U,12),+$P(OR0,U,10)) 194 S ORMSG(4)="ORC|ZV|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS||||||||"_DUZ_"||||"_$$FMTHL7^XLFDT($$NOW^XLFDT) 195 D MSG^XQOR("OR EVSEND PS",.ORMSG) 196 Q 197 ; 198 REF(IFN,ROUTING,CLINIC) ; -- Send msg for refill request 199 N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="O" 200 S:'$G(CLINIC) CLINIC=$S($G(ORL):+ORL,1:+$P(OR0,U,10)) 201 S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2)) 202 S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),"O",CLINIC) 203 S ORMSG(4)="ORC|ZF|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS|||||||"_DUZ_"||"_$G(ORNP)_"|||"_$$FMTHL7^XLFDT($$NOW^XLFDT) 204 S ORMSG(5)="ZRX||||"_ROUTING 205 D MSG^XQOR("OR EVSEND PS",.ORMSG) 206 Q 207 ESC(STR) ; 208 Q $$ESC^ORHLESC(STR,"~|\&^") 1 ORMBLDPS ;SLC/MKB-Build outgoing Pharmacy ORM msgs ;11:26 AM 2 Apr 2001 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,38,54,86,97,94,116,129,141,190,195,237,254**;Dec 17, 1997 3 PTR(NAME) ; -- Returns ptr value of prompt in Dialog file 4 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) 5 ; 6 NVA ; -- new Non-VA Meds order 7 N NVA S NVA=1 8 OUT ; -- new Outpt Meds order 9 ; fall through to UD: same msg, +3 fields 10 UD ; -- new Inpt (Unit Dose) Meds order 11 N OI,DRUG,INSTR,DOSE,ROUTE,SCHED,DUR,URG,PROVCOMM,PI,DISPENSE,X,Y,I,J,K,L,QT1,QT2,QT3,QT4,QT6,QT9,CONJ,ORC,SC,OUTPT 12 S OUTPT=$S($P(OR0,U,12)="O":1,1:0) ;outpt flag 13 S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different 14 S OI=$$PTR("ORDERABLE ITEM"),DRUG=$$PTR("DISPENSE DRUG") 15 S INSTR=$$PTR("INSTRUCTIONS"),SCHED=$$PTR("SCHEDULE") 16 S DUR=$$PTR("DURATION"),URG=$$PTR("URGENCY"),DOSE=$$PTR("DOSE") 17 S ROUTE=$$PTR("ROUTE"),PROVCOMM=$$PTR("WORD PROCESSING 1") 18 S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN") 19 S J=1,ORC(J)=$P(ORMSG(4),"|",1,7)_"|" 20 I +$G(NVA)=1 G NVA1 21 UD1 S I=0 F S I=$O(ORDIALOG(INSTR,I)) Q:I'>0 D 22 . S QT2=$G(ORDIALOG(SCHED,I)),QT3=$$HL7DUR,X=$G(ORDIALOG(DOSE,I)) 23 . ;S QT1=$S($L(X):$P(X,"&",1,4)_"&"_$P(X,"&",6),1:"") 24 . S QT1=$S($L(X):$P(X,"&",1,6),1:"") 25 . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2) 26 . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~" 27 . S J=J+1,ORC(J)=QT1_U_QT2_U_QT3_"^^^"_QT6_"^^"_$$INSTR_U_QT9 28 ; 29 NVA1 I +$G(NVA)=1 D 30 . S I=1 ;only one dosage possible for non-va meds 31 . S QT2=$G(ORDIALOG(SCHED,I)),QT3=$$HL7DUR,X=$G(ORDIALOG(DOSE,I)) 32 . S QT1=$S($L(X):$P(X,"&",1,6),1:"") 33 . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2) 34 . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~" 35 . S J=J+1,ORC(J)=QT1_U_QT2_U_QT3_"^^^"_QT6_"^^"_$$INSTR_U_QT9 36 ; 37 I $L($P(OR0,U,8)) S $P(ORC(2),U,4)=$$FMTHL7^XLFDT($P(OR0,U,8)) S:J<2 J=2 38 S J=J+1,ORC(J)="|"_$P(ORMSG(4),"|",9,999),ORC=J,X="ORMSG(4)",ORMSG(4)="",I=0 39 F J=1:1:ORC S Y=ORC(J) D ;add to ORMSG(4) 40 . I $L(@X)+$L(Y)'>245 S @X=@X_Y 41 . E S L=245-$L(@X),@X=@X_$E(Y,1,L),I=I+1,X="ORMSG(4,"_I_")",@X=$E(Y,L+1,$L(Y)) 42 I $G(ORDIALOG(DRUG,1)) S X=$$ENDCM^PSJORUTL(ORDIALOG(DRUG,1)),DISPENSE=$P(X,U,3)_"^^99NDF^"_ORDIALOG(DRUG,1)_"^^99PSD" 43 S ORMSG(5)="RXO|"_$$USID^ORMBLD($G(ORDIALOG(OI,1)))_"|||||||||"_$G(DISPENSE) 44 UD2 I $G(OUTPT) D 45 . N QTY,REFS,DSPY 46 . S QTY=$$PTR("QUANTITY"),REFS=$$PTR("REFILLS"),DSPY=$$PTR("DAYS SUPPLY") 47 . S ORMSG(5)=ORMSG(5)_"|"_$G(ORDIALOG(QTY,1))_"||"_$G(ORDIALOG(REFS,1))_"||||D"_$G(ORDIALOG(DSPY,1)) 48 S I=5 I $L($G(ORDIALOG(PROVCOMM,1))) D 49 . S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,0)) Q:'J 50 . S I=6,ORMSG(6)="NTE|6|P|"_$G(^TMP("ORWORD",$J,PROVCOMM,1,J,0)) 51 . S K=0 F S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,J)) Q:J'>0 S K=K+1,ORMSG(6,K)=$G(^(J,0)) 52 I $G(OUTPT),$L($G(ORDIALOG(PI,1))) D 53 . S J=$O(^TMP("ORWORD",$J,PI,1,0)) Q:'J 54 . S I=I+1,ORMSG(I)="NTE|7|P|"_$G(^TMP("ORWORD",$J,PI,1,J,0)) 55 . S K=0 F S J=$O(^TMP("ORWORD",$J,PI,1,J)) Q:J'>0 S K=K+1,ORMSG(I,K)=$G(^(J,0)) 56 UD3 S J=0 F S J=$O(ORDIALOG(ROUTE,J)) Q:J'>0 S I=I+1,ORMSG(I)=$$RXR($G(ORDIALOG(ROUTE,J))) 57 I $D(^OR(100,IFN,9)) D ORDCHKS 58 S I=I+1,ORMSG(I)=$$ZRX(IFN) 59 I $G(OUTPT) D ;add SC data 60 . N OR5 S OR5=$G(^OR(100,IFN,5)) 61 . I $L(OR5),OR5'?5"^" S I=I+1,ORMSG(I)="ZSC|"_$TR(OR5,"^","|") Q 62 . S SC=$$PTR("SERVICE CONNECTED") S:$D(ORDIALOG(SC,1)) I=I+1,ORMSG(I)="ZSC|"_$S(ORDIALOG(SC,1):"SC",1:"NSC") 63 ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project 64 D DG1^ORWDBA3($G(IFN),"I",I) 65 I $P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS" D 66 . S I=I+1 D ZRN(IFN,.ORMSG,I) 67 Q 68 ; 69 INSTR() ; -- Return text instructions for QT-8, instance I 70 N Y S Y=$P($G(ORDIALOG(DOSE,I)),"&",5) 71 I $G(ORDIALOG(DRUG,1)),$L(Y) Q Y 72 S Y=$G(ORDIALOG(INSTR,I)) I $G(OUTPT) D 73 . N UNITS,UNT S UNITS=$$PTR("FREE TEXT"),UNT=$G(ORDIALOG(UNITS,I)) 74 . S:$L(UNT) Y=Y_" "_UNT ;old format 75 Q Y 76 ; 77 HL7DUR() ; -- Returns HL7 form of duration X 78 N X,X1,X2,Y S X=$G(ORDIALOG(DUR,I)) 79 S X1=+$G(X),Y="" G:X1'>0 HDQ 80 S X2=$$UP^XLFSTR($P(X,X1,2)) S:$E(X2)=" " X2=$E(X2,2,99) 81 S Y=$S($E(X2,1,2)="MO":"L",'$L(X2):"D",1:$E(X2))_X1 82 HDQ Q Y 83 ; 84 IV ; -- new IV Meds order 85 N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,WP,QT,I,X1,X2,INST 86 N IVLIMIT ; duratioin or total volume for IV order 87 S IVLIMIT=$$PTR("DURATION") 88 S RATE=$$PTR("INFUSION RATE"),ADDS=$$PTR("ADDITIVE") 89 S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS") 90 S WP=$$PTR("WORD PROCESSING 1"),VOL=$$PTR("VOLUME") 91 S SOLN=$$PTR("ORDERABLE ITEM"),URG=+$G(ORDIALOG($$PTR("URGENCY"),1)) 92 S QT=U_$G(ORDIALOG(+$$PTR("SCHEDULE"),1))_"^^^^" 93 S:URG QT=QT_$P($G(^ORD(101.42,URG,0)),U,2) S $P(ORMSG(4),"|",8)=QT 94 S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different 95 S RATE=$G(ORDIALOG(RATE,1)) S:$E(RATE,$L(RATE))=" " RATE=$E(RATE,1,($L(RATE)-1)) S ORMSG(5)="RXO|^^^PS-1^IV^99OTH|"_RATE ;strip any trailing spaces 96 S IVLIMIT=$G(ORDIALOG(IVLIMIT,1)) 97 I $L(IVLIMIT) S IVLIMIT=$$HL7IVLMT(IVLIMIT),ORMSG(5)="RXO|^^"_IVLIMIT_"^PS-1^IV^99OTH|"_RATE 98 S I=5 I $L($G(ORDIALOG(WP,1))) D 99 . N J,K S J=$O(^TMP("ORWORD",$J,WP,1,0)) Q:'J 100 . S I=6,ORMSG(6)="NTE|6|P|"_$G(^TMP("ORWORD",$J,WP,1,J,0)) 101 . S K=0 F S J=$O(^TMP("ORWORD",$J,WP,1,J)) Q:J'>0 S K=K+1,ORMSG(6,K)=^(J,0) 102 IV1 S INST=0 F S INST=$O(ORDIALOG(SOLN,INST)) Q:INST'>0 D 103 . S X1="B",X2=+$G(ORDIALOG(SOLN,INST)) 104 . I $P($G(^ORD(101.43,X2,"PS")),U,4) S X1=X1_"A" ;pre-mix 105 . S I=I+1,ORMSG(I)="RXC|"_X1_"|"_$$USID^ORMBLD(X2)_"|"_$G(ORDIALOG(VOL,INST))_"|"_$$HL7UNIT("ML") 106 I $O(ORDIALOG(ADDS,0)) D 107 . S INST=0 F S INST=$O(ORDIALOG(ADDS,INST)) Q:INST'>0 D 108 . . S X1=$G(ORDIALOG(ADDS,INST)),X2=$G(ORDIALOG(UNITS,INST)) 109 . . S I=I+1,ORMSG(I)="RXC|A|"_$$USID^ORMBLD(X1)_"|"_$G(ORDIALOG(STR,INST))_"|"_$$HL7UNIT(X2) 110 I $D(^OR(100,IFN,9)) D ORDCHKS 111 S I=I+1,ORMSG(I)=$$ZRX(IFN) 112 ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project 113 D DG1^ORWDBA3($G(IFN),"I",I) 114 Q 115 ; 116 RXR(ROUTE) ; -- Returns RXR segment 117 N NAME S NAME=$$GET1^DIQ(51.2,+ROUTE_",",.01) 118 Q "RXR|^^^"_+ROUTE_U_NAME_"^99PSR" 119 ; 120 ZRX(IFN) ; -- Returns ZRX segment 121 N NATURE,TYPE,ORIG,PSORIG,ZRX 122 S TYPE=$P($G(^OR(100,IFN,3)),U,11),NATURE=$P($G(^(8,1,0)),U,12) 123 S:NATURE NATURE=$P($G(^ORD(100.02,+NATURE,0)),U,2) ;code 124 S PSORIG="" I (TYPE=1)!(TYPE=2) D 125 . S ORIG=$P($G(^OR(100,IFN,3)),U,5),PSORIG=$G(^OR(100,+ORIG,4)) 126 . I PSORIG'>0 S PSORIG="",TYPE=0 ;edit of unreleased order 127 S ZRX="ZRX|"_PSORIG_"|"_NATURE_"|"_$S(TYPE=1:"E",TYPE=2:"R",1:"N") 128 I $G(OUTPT) S ZRX=ZRX_"|"_$G(ORDIALOG($$PTR("ROUTING"),1))_$S($L($P($G(^OR(100,ORIFN,8,1,2)),"^",3)):"|||1",1:"") 129 Q ZRX 130 ; 131 ZRN(IFN,ORMSG,I) ; -- Set ZRN segment 132 N ST,ZRN,J,K,TXT 133 S ORMSG(I)="ZRN|N|" 134 S ST=$$PTR("STATEMENTS") 135 I $L($G(ORDIALOG(ST,1))) D 136 . S J=$O(^TMP("ORWORD",$J,ST,1,0)) Q:'J 137 . S K=0,TXT=$G(^TMP("ORWORD",$J,ST,1,J,0)) 138 . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT 139 . F S J=$O(^TMP("ORWORD",$J,ST,1,J)) Q:J'>0 S TXT=$G(^(J,0)) D 140 . . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT 141 Q 142 ; 143 ORDCHKS ; -- Include order checks in OBX segments 144 N OC,X,X1 S OC=0 145 F S OC=$O(^OR(100,IFN,9,OC)) Q:OC'>0 S X=$G(^(OC,0)),X1=$G(^(1)) D 146 . S I=I+1,ORMSG(I)="OBX|"_OC_"|TX|^^^"_+X_"^^99OCX||"_$S($L(X1):X1,1:$P(X,U,3))_"|||||||||"_$$FMTHL7^XLFDT($P(X,U,6))_"||"_$P(X,U,5) 147 . I $L($P(X,U,4)) S I=I+1,ORMSG(I)="NTE|"_OC_"|P|"_$P(X,U,4) 148 Q 149 ; 150 HL7UNIT(X) ; -- Return coded element for volume/strength units 151 N I,UNIT,Y 152 F I=1:1:$L(X) I $E(X,I)?1A Q ; first letter 153 S UNIT=$$UP^XLFSTR($E(X,I,$L(X))),Y="" 154 F I=1:1:13 S X=$P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM","^",I) I UNIT=X S Y="^^^PSIV-"_I_U_UNIT_"^99OTH" Q 155 Q Y 156 ; 157 HL7TIME(X) ; -- Return HL7 formatted duration 158 N I,Y S Y="" 159 F I=1:1:$L(X) I $E(X,I)?1A S Y=$$UP^XLFSTR($E(X,I)) Q ; first letter 160 S Y=Y_+X 161 Q Y 162 ; 163 VER(IFN) ; -- Send msg for nurse-verified orders 164 N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="I" ;Inpt only 165 S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2)) 166 S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),$P(OR0,U,12),+$P(OR0,U,10)) 167 S ORMSG(4)="ORC|ZV|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS||||||||"_DUZ_"||||"_$$FMTHL7^XLFDT($$NOW^XLFDT) 168 D MSG^XQOR("OR EVSEND PS",.ORMSG) 169 Q 170 ; 171 REF(IFN,ROUTING,CLINIC) ; -- Send msg for refill request 172 N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="O" 173 S:'$G(CLINIC) CLINIC=$S($G(ORL):+ORL,1:+$P(OR0,U,10)) 174 S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2)) 175 S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),"O",CLINIC) 176 S ORMSG(4)="ORC|ZF|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS|||||||"_DUZ_"||"_$G(ORNP)_"|||"_$$FMTHL7^XLFDT($$NOW^XLFDT) 177 S ORMSG(5)="ZRX||||"_ROUTING 178 D MSG^XQOR("OR EVSEND PS",.ORMSG) 179 Q 180 HL7IVLMT(STR) ; 181 N VAL,UNIT,IVLMT,TVAL,LEN 182 S (UNIT,IVLMT)="",VAL=0 183 I $E($$LOW^XLFSTR(STR))="f" D 184 . S VAL=$P(STR," ",2) 185 . S UNIT=$E($P(STR," ",3)) 186 I $E($$LOW^XLFSTR(STR))="w" D 187 . S TVAL=$P(STR," ",4) ;pull data in total example 0.5ml 188 . S VAL=+TVAL ;this will strip out leading zero and alpha 00.5L becomes .5 or 05.5 becomes 5.5 189 . S LEN=$F(TVAL,VAL) ;get length up to alphas or trailing zeros 190 . I $P(VAL,".")="" S VAL=0_VAL ;make sure decimal values have only one leading zero .5 becomes 0.5. 191 . F S UNIT=$E(TVAL,LEN) Q:((UNIT'=0)&(UNIT'=".")) D ;get first alpha m or l 192 . . S LEN=LEN+1 193 I $L(UNIT),$L(VAL) S IVLMT=$$LOW^XLFSTR(UNIT)_VAL 194 Q IVLMT 195 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLDRA.m
r613 r623 1 ORMBLDRA ; SLC/MKB - Build outgoing Radiology ORM msgs ;05/30/06 11:30AM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**75,97,190,195,243**;Dec 17, 1997;Build 242 3 HL7DATE(DATE) ; -- FM -> HL7 format 4 Q $$FMTHL7^XLFDT(DATE) ;**97 5 ; 6 PTR(NAME) ; -- Returns ptr value of prompt in Dialog file 7 Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) 8 ; 9 EN ; -- Segments for new Radiology order 10 N ORSEX,OI,START,IP,URG,ILOC,MODE,CATG,PREOP,PREG,MODS,CLHIST,PROV,REASON,QT,I,J,Z,J0,LIN,RA75 11 S OI=$G(ORDIALOG($$PTR("ORDERABLE ITEM"),1)) 12 S START=$P($G(^OR(100,IFN,0)),U,8),IP=$G(ORDIALOG($$PTR("YES/NO"),1)) 13 S URG=$P($G(^ORD(101.42,+$G(ORDIALOG($$PTR("URGENCY"),1)),0)),U,2) 14 S ILOC=$G(ORDIALOG($$PTR("IMAGING LOCATION"),1)) 15 S MODE=$G(ORDIALOG($$PTR("MODE OF TRANSPORT"),1)) 16 S CATG=$G(ORDIALOG($$PTR("CATEGORY"),1)) 17 S PREOP=$G(ORDIALOG($$PTR("PRE-OP SCHEDULED DATE/TIME"),1)) 18 S PREG=$G(ORDIALOG($$PTR("PREGNANT"),1)) 19 S REASON=$G(ORDIALOG($$PTR("STUDY REASON"),1)) 20 S MODS=$$PTR("MODIFIERS"),CLHIST=$$PTR("WORD PROCESSING 1") 21 S MODS=$$MULT(MODS) S:ILOC ILOC=ILOC_U_$P($G(^RA(79.1,+ILOC,0)),U) 22 S MODE=$S(MODE="A":"WALK",MODE="P":"PORT",MODE="S":"CART",1:"WHLC") 23 S PREG=$S(PREG="Y":"YES",PREG="N":"NO",1:"UNKNOWN") 24 S QT="^^^"_$$HL7DATE(START)_"^^"_URG,$P(ORMSG(4),"|",8)=QT 25 S PROV=+$G(ORDIALOG($$PTR("PROVIDER"),1)) S:PROV $P(ORMSG(4),"|",12)=PROV 26 S RA75=$$PATCH^XPDUTL("RA*5.0*75") 27 S ORMSG(5)="OBR||||"_$$USID^ORMBLD(OI)_"||||||||"_$S(IP:"isolation",1:"")_"||||||"_MODS_"|"_ILOC_"|||||||||||"_MODE,I=5 28 I +RA75 S $P(ORMSG(5),"|",32)=U_REASON 29 ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project 30 D DG1^ORWDBA3($G(IFN),"I",I) 31 OBX S J0=0 32 I 'RA75 D 33 . S I=I+1,ORMSG(I)="OBX|1|TX|2000.02^CLINICAL HISTORY^AS4|1|"_"REASON FOR STUDY: "_REASON 34 . S $P(LIN,"-",55)="" 35 . S I=I+1,ORMSG(I)="OBX|2|TX|2000.02^CLINICAL HISTORY^AS4|1|"_LIN 36 . S J0=2 37 S J=0 F S J=$O(^TMP("ORWORD",$J,CLHIST,1,J)) Q:J'>0 S I=I+1,J0=J0+1,ORMSG(I)="OBX|"_J0_"|TX|2000.02^CLINICAL HISTORY^AS4|1|"_^(J,0) 38 S ORSEX=$P($G(^DPT(+ORVP,0)),U,2) 39 S:ORSEX="F" I=I+1,ORMSG(I)="OBX|1|TX|2000.33^PREGNANT^AS4||"_PREG 40 S:PREOP I=I+1,ORMSG(I)="OBX|1|TS|^PRE-OP SCHEDULED DATE/TIME||"_$$HL7DATE(PREOP) 41 I "CS"[CATG S Z=$$PTR("CONTRACT/SHARING SOURCE"),I=I+1,ORMSG(I)="OBX|1|CE|34^CONTRACT/SHARING SOURCE^99DD||"_+$G(ORDIALOG(Z,1))_U_$P($G(^DIC(34,+$G(ORDIALOG(Z,1)),0)),U) 42 I CATG="R" S Z=$$PTR("RESEARCH SOURCE"),I=I+1,ORMSG(I)="OBX|1|TX|^RESEARCH SOURCE||"_$G(ORDIALOG(Z,1)) 43 Q 44 MULT(M) ; -- Returns string of MODIFIER~MODIFIER~... 45 N I,X S X="" Q:'$O(ORDIALOG(M,0)) X 46 S I=$O(ORDIALOG(M,0)),X=$P($G(^RAMIS(71.2,+ORDIALOG(M,I),0)),U) 47 F S I=$O(ORDIALOG(M,I)) Q:I'>0 S X=X_"~"_$P($G(^RAMIS(71.2,+ORDIALOG(M,I),0)),U) 48 Q X 1 ORMBLDRA ; SLC/MKB - Build outgoing Radiology ORM msgs ;11/17/00 11:14 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**75,97,190,195**;Dec 17, 1997 3 HL7DATE(DATE) ; -- FM -> HL7 format 4 Q $$FMTHL7^XLFDT(DATE) ;**97 5 ; 6 PTR(NAME) ; -- Returns ptr value of prompt in Dialog file 7 Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) 8 ; 9 EN ; -- Segments for new Radiology order 10 N ORSEX,OI,START,IP,URG,ILOC,MODE,CATG,PREOP,PREG,MODS,CLHIST,PROV,QT,I,J,Z 11 S OI=$G(ORDIALOG($$PTR("ORDERABLE ITEM"),1)) 12 S START=$P($G(^OR(100,IFN,0)),U,8),IP=$G(ORDIALOG($$PTR("YES/NO"),1)) 13 S URG=$P($G(^ORD(101.42,+$G(ORDIALOG($$PTR("URGENCY"),1)),0)),U,2) 14 S ILOC=$G(ORDIALOG($$PTR("IMAGING LOCATION"),1)) 15 S MODE=$G(ORDIALOG($$PTR("MODE OF TRANSPORT"),1)) 16 S CATG=$G(ORDIALOG($$PTR("CATEGORY"),1)) 17 S PREOP=$G(ORDIALOG($$PTR("PRE-OP SCHEDULED DATE/TIME"),1)) 18 S PREG=$G(ORDIALOG($$PTR("PREGNANT"),1)) 19 S MODS=$$PTR("MODIFIERS"),CLHIST=$$PTR("WORD PROCESSING 1") 20 S MODS=$$MULT(MODS) S:ILOC ILOC=ILOC_U_$P($G(^RA(79.1,+ILOC,0)),U) 21 S MODE=$S(MODE="A":"WALK",MODE="P":"PORT",MODE="S":"CART",1:"WHLC") 22 S PREG=$S(PREG="Y":"YES",PREG="N":"NO",1:"UNKNOWN") 23 S QT="^^^"_$$HL7DATE(START)_"^^"_URG,$P(ORMSG(4),"|",8)=QT 24 S PROV=+$G(ORDIALOG($$PTR("PROVIDER"),1)) S:PROV $P(ORMSG(4),"|",12)=PROV 25 S ORMSG(5)="OBR||||"_$$USID^ORMBLD(OI)_"||||||||"_$S(IP:"isolation",1:"")_"||||||"_MODS_"|"_ILOC_"|||||||||||"_MODE,I=5 26 ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project 27 D DG1^ORWDBA3($G(IFN),"I",I) 28 OBX S J=0 F S J=$O(^TMP("ORWORD",$J,CLHIST,1,J)) Q:J'>0 S I=I+1,ORMSG(I)="OBX|"_J_"|TX|2000.02^CLINICAL HISTORY^AS4|1|"_^(J,0) 29 S ORSEX=$P($G(^DPT(+ORVP,0)),U,2) 30 S:ORSEX="F" I=I+1,ORMSG(I)="OBX|1|TX|2000.33^PREGNANT^AS4||"_PREG 31 S:PREOP I=I+1,ORMSG(I)="OBX|1|TS|^PRE-OP SCHEDULED DATE/TIME||"_$$HL7DATE(PREOP) 32 I "CS"[CATG S Z=$$PTR("CONTRACT/SHARING SOURCE"),I=I+1,ORMSG(I)="OBX|1|CE|34^CONTRACT/SHARING SOURCE^99DD||"_+$G(ORDIALOG(Z,1))_U_$P($G(^DIC(34,+$G(ORDIALOG(Z,1)),0)),U) 33 I CATG="R" S Z=$$PTR("RESEARCH SOURCE"),I=I+1,ORMSG(I)="OBX|1|TX|^RESEARCH SOURCE||"_$G(ORDIALOG(Z,1)) 34 Q 35 ; 36 MULT(M) ; -- Returns string of MODIFIER~MODIFIER~... 37 N I,X S X="" Q:'$O(ORDIALOG(M,0)) X 38 S I=$O(ORDIALOG(M,0)),X=$P($G(^RAMIS(71.2,+ORDIALOG(M,I),0)),U) 39 F S I=$O(ORDIALOG(M,I)) Q:I'>0 S X=X_"~"_$P($G(^RAMIS(71.2,+ORDIALOG(M,I),0)),U) 40 Q X -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMEVNT.m
r613 r623 1 ORMEVNT ;SLC/MKB-Trigger HL7 msg off MAS events ;3/31/04 09:21 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**24,45,70,79,141,165,177,186,195,278,243**;Dec 17, 1997;Build 242 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 EN1 ; -- tasked entry point 6 Q:'$G(DFN) Q:$D(DGPMPC) Q:DGPMT=4!(DGPMT=5) ;skip lodger mvts 7 N ZTDESC,ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTSK,I 8 S ZTDESC="Auto-DC and/or Release orders on MAS movement",ZTIO="" 9 S ZTRTN="EN^ORMEVNT",ZTDTH=$H,ZTSAVE("^UTILITY(""DGPM"",$J,")="" 10 F I="DFN","DGPMDA","DGPMA","DGPMP","DGPMT" S ZTSAVE(I)="" 11 D ^%ZTLOAD ;D EN^ORYDGPM 12 Q 13 ; 14 EN ; -- main entry point 15 S:$D(ZTQUEUED) ZTREQ="@" 16 Q:'$G(DFN) Q:$D(DGPMPC) Q:DGPMT=4!(DGPMT=5) 17 I '$G(DGPMP) S ^XTMP("OREVENT",DFN,DGPMDA,0)=DT_U_$$FMADD^XLFDT(DT,2)_U_"Event process flag" ;195 18 I $G(DGPMP),$D(^XTMP("OREVENT",DFN,DGPMDA)) D EN1 Q ;195 edits processed after new JEH 19 N XQORQUIT,XQORPOP,DTOUT,DUOUT,DIRUT,DIROUT ;protect protocol context 20 N VAIP,DONE,ORVP,ORWARD,ORTS,ORL,ORDIV,ORLAST,X,Y,I,ORCURRNT,OREVENT,ORDCRULE,ORACT,ORPRINT 21 S VAIP("E")=DGPMDA D IN5^VADPT M ORVP=VAIP I '$G(DGPMA) D Q ;deleted 22 . N LAST,OREVT S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1 23 . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)) 24 . D ACTLOG^OREVNTX(OREVT,"DL") 25 A ; 26 S ORVP=+DFN_";DPT(",ORTS=+$G(^DPT(DFN,.103)),ORWARD=$G(^(.1)) 27 S ORWARD=$S($L(ORWARD):+$O(^DIC(42,"B",ORWARD,0)),1:0) 28 S ORL=$S(ORWARD:+$G(^DIC(42,ORWARD,44))_";SC(",1:""),ORDIV=$$DIV(+ORL) 29 S ORLAST("TS")=$$PREVTS,X=+VAIP(15,4) F I="WD","LOC","DIV" S ORLAST(I)="" 30 S:X ORLAST("WD")=X,Y=+$G(^DIC(42,X,44)),ORLAST("LOC")=Y_";SC(",ORLAST("DIV")=$$DIV(Y) 31 N OREVNTLK S OREVNTLK="" ;JEH 32 S ORCURRNT=$$CURRENT,OREVENT=$$PATEVT,ORACT=$S($G(DGPMP):"ED",1:"NW") ; Lock 33 I OREVENT=-1 D EN1 Q ;195 Can't lock, retry 34 S OREVNTLK=OREVENT ; save routine copy of ifn JEH 35 I $G(DGPMP),$D(^ORE(100.2,"ADT",DGPMDA)) D ;edited 36 . N LAST,OREVT,DA,X,I S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1 37 . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)),DA=+$O(^(OREVT,0)) 38 . S X=$G(^ORE(100.2,OREVT,10,DA,0)) ;last activity on movement 39 . I $P(X,U,5)=+$G(VAIP(4)),$P(X,U,6)=+$G(VAIP(8)),$P(X,U,7)=+$G(VAIP(5)) S DONE=1 Q ;no change 40 . I 'OREVENT D ACTLOG^OREVNTX(OREVT,"ED",$$TYPE(DGPMT),1) S DONE=1 41 I $G(DONE) D FINISHED Q ; unlock and clean up before quit IFNjeh 42 B ; 43 I '$G(DGPMP),ORCURRNT D ;new mvt - autoDC 44 . I $D(^ORE(100.2,"ADT",DGPMDA)) D Q:$G(DONE) ;ReEntered 45 .. N LAST,OREVT S DONE=0 46 .. S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1),OREVT=+$O(^(LAST,0)) 47 .. Q:+ORVP'=+$G(^ORE(100.2,OREVT,0)) ;diff pat -> diff mvt 48 .. S ORACT="RE",DONE=1 Q:OREVENT ;log on new event instead 49 .. D ACTLOG^OREVNTX(OREVT,ORACT,$$TYPE(DGPMT),1) 50 . I DGPMT=3 D COMP("ALG") ;keep until GMRA*4*15 gets out 51 . S ORDCRULE=$$DCEVT D:ORDCRULE AUTODC^ORMEVNT1(ORDCRULE,$P(DGPMA,U)) 52 . I DGPMT=1!(DGPMT=2&("^13^40^"[("^"_$P(DGPMA,U,18)_"^"))) I $G(^XTMP("ORDCOBS-"_+ORVP,0)) D REINST ;186 TO ASIH tran mvmt 53 C ; 54 I OREVENT D ;release delayed orders, complete event 55 . D RELEASE^ORMEVNT1(OREVENT),DONE^OREVNTX(OREVENT,$P(DGPMA,U),DGPMDA) 56 . I '$G(VAIP(1)) M VAIP=ORVP ;reset for ACTLOG use 57 . D ACTLOG^OREVNTX(OREVENT,ORACT,$$TYPE(DGPMT),1) 58 . I DGPMT=1,'$P($G(^ORE(100.2,+OREVENT,0)),U,3) S $P(^(0),U,3)=DGPMDA 59 . ;D UNLEVT^ORX2(OREVENT) 60 I $O(ORPRINT(0)),$G(ORL) D PRINTS^ORWD1(.ORPRINT,+ORL) 61 I DGPMT=3,ORCURRNT,'$G(DGPMP) D DISCH ;lapse remaining events 62 I '$G(DFN),$G(ORVP) S DFN=+ORVP ;just in case 63 FINISHED ; unlock and clean up JEH 64 D:$G(OREVNTLK) UNLEVT^ORX2(OREVNTLK) K ^XTMP("OREVENT",DFN,DGPMDA) ;195 65 Q 66 ; 67 CURRENT() ; -- Returns 1 or 0, if DGPMDA is the latest movement 68 N Y,LAST,LASTYPE,LASTDT S Y=0 69 S LAST=+VAIP(14),LASTDT=+VAIP(14,1),LASTYPE=+VAIP(14,2) 70 ; VAIP(14) = last physical movement for the admission 71 I DGPMT=6 D G CQ 72 . N CA,IDT I LAST,LASTDT>+VAIP(3) Q ;last physical mvt 73 . S CA=+VAIP(13),IDT=9999999.9999999-VAIP(3) 74 . I '$O(^DGPM("ATS",DFN,CA,IDT),-1) S Y=1 Q ;last TS mvt 75 I DGPMT=3 D ;get last mvt overall 76 . N VAIP,Y S VAIP("D")="LAST" D IN5^VADPT 77 . S LAST=+VAIP(14),LASTYPE=+VAIP(14,2) ;reset 78 I LAST=DGPMDA S Y=1 G CQ ;primary mvt 79 I $D(^UTILITY("DGPM",$J,LASTYPE,LAST)) S Y=1 ;secondary mvt 80 CQ Q Y 81 ; 82 PREVTS() ; -- Returns previous treating specialty 83 N TS,TSP,CA,ID,LAST,Y 84 S TS=+$O(^UTILITY("DGPM",$J,6,0)),TSP=$G(^(TS,"P")) 85 I $G(TSP) S Y=+$P(TSP,U,9) G PRVQ ;edited TS mvt 86 ; look for TS mvt since last phys mvt 87 S CA=$P(DGPMA,U,14),ID=9999999.9999999-DGPMA 88 S LAST=+$O(^DGPM("ATS",DFN,CA,ID)),Y=$S(LAST:+$O(^(LAST,0)),1:+VAIP(15,6)) 89 PRVQ Q Y 90 ; 91 TYPE(X) ; -- Return type of event from MAS code 92 N Y S Y=$S(X=1:"A",X=2:"T",X=3:"D",X=6:"S",1:"") 93 Q Y 94 ; 95 DIV(LOC) ; -- Return Institution file #4 ptr for LOC 96 N X0,Y S X0=$G(^SC(+LOC,0)) 97 S Y=$S($P(X0,U,4):$P(X0,U,4),$P(X0,U,15):$$SITE^VASITE(DT,$P(X0,U,15)),1:+$G(DUZ(2))) 98 Q Y 99 ; 100 PATEVT() ; -- Find match to new data in Patient Event file 101 N TYPE,MVTYPE,EVT,IFN,X0,Y S Y="" G:'$G(ORCURRNT) PTQ 102 S TYPE=$S(DGPMT=1:"A",DGPMT=3:"D",DGPMT=2!(DGPMT=6):"T",1:""),EVT=0 103 S MVTYPE=$P(DGPMA,U,18),TYPE(1)="",MVTYPE(1)="" 104 I DGPMT=2,MVTYPE=13 S TYPE(1)="A",MVTYPE(1)=40 ;To ASIH 105 I DGPMT=3,MVTYPE=41 S TYPE(1)="T",MVTYPE(1)=14 ;From ASIH 106 I DGPMT'=3,$$GET1^DIQ(45.7,+$G(ORTS)_",","SPECIALTY:SERVICE")="NHCU" S TYPE(1)=$S(TYPE="A":"T",1:"A") ;DBIA #1154 107 F S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1 S IFN=+$O(^(EVT,0)) D Q:Y 108 . Q:$$LAPSED^OREVNTX(+IFN) Q:$P($G(^ORE(100.2,IFN,1)),U,5) 109 . S X0=$G(^ORD(100.5,EVT,0)) Q:$P(X0,U,3)'=ORDIV 110 . I $P(X0,U,2)'=TYPE,$P(X0,U,2)'=TYPE(1) Q ;Xaction type 111 . I $P(X0,U,7),$P(X0,U,7)'=MVTYPE,$P(X0,U,7)'=MVTYPE(1) Q ;Mvt type 112 . I $O(^ORD(100.5,EVT,"TS",0)) Q:'$D(^("B",ORTS)) Q:ORTS=ORLAST("TS")&(ORDIV=ORLAST("DIV")) 113 . I $O(^ORD(100.5,EVT,"LOC",0)) Q:'$D(^("B",ORWARD)) Q:ORWARD=ORLAST("WD") 114 . S Y=+IFN ;ok 115 I Y S:'$$LCKEVT^ORX2(Y) Y=-1 ;195 Lock event if possible 116 PTQ Q Y 117 ; 118 DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV,ORTS,ORL 119 N MVTYPE,DIV,XFER,ORY,EXC,OBS 120 S OBS=$S(DGPMT=3:$$MVT^DGPMOBS(DGPMDA),1:0) ;observation mvt 121 S MVTYPE=+$P(DGPMA,U,18) S:MVTYPE=41 MVTYPE=14 S:MVTYPE=40 MVTYPE=13 ;ASIH- 186 122 S XFER=$S(DGPMT=2:1,DGPMT=6:1,MVTYPE'=14:0,OBS:0,1:1) 123 I DGPMT=2,MVTYPE=13,$G(^XTMP("ORDCOBS-"_+ORVP,"READMIT")) S ORY=0 K ^XTMP("ORDCOBS-"_+ORVP,"READMIT") G DCQ ;186 Obs readmit from ASIH don't auto-dc 124 I XFER,ORLAST("TS")'=ORTS,$D(^ORD(100.6,"AC",ORDIV,20)) S MVTYPE=20 ;TS 125 S DIV=ORDIV I DGPMT=3,MVTYPE'=14 S DIV=ORLAST("DIV") ;discharge 126 S ORY=+$O(^ORD(100.6,"AC",ORDIV,MVTYPE,0)) K:ORY<1&(DGPMT=3)&(OBS) ^XTMP("ORDCOBS-"_+ORVP) G:ORY<1 DCQ ;186, If obs, no active rule, no reinstate 127 I MVTYPE=20,$D(^ORD(100.6,ORY,4,ORLAST("TS"),1,ORTS))!(ORTS=ORLAST("TS")) S ORY=0 G DCQ 128 I MVTYPE=4 D G DCQ ;ck Div and Loc multiples 129 . I ORLAST("DIV")'=ORDIV S:'$D(^ORD(100.6,ORY,6,ORLAST("DIV"))) ORY=0 Q 130 . N OLD,INCL S INCL=0 ;ck incl loc's 131 . F OLD=+ORLAST("LOC"),"ALL" I $D(^ORD(100.6,ORY,5,"ADC",OLD,+ORL))!$D(^("ALL")) S INCL=1 Q 132 . S:'INCL ORY=0 133 I DGPMT=3,OBS D ;readmitting from observation? 134 . N TORY 135 . S TORY=ORY 136 . S EXC=+$P($G(^ORD(100.6,ORY,0)),U,6) S:EXC=2 ORY=0 ;ignore rule 137 . I EXC=1,'$D(ZTQUEUED),$$READMIT S ORY=0 138 . I ORY=0 D DCGEN^ORMEVNT2,TIMER^ORMEVNT2 S:"^14^41^"[("^"_$P(DGPMA,U,18)_"^") ^XTMP("ORDCOBS-"_+ORVP,"READMIT")=1 ;177,186 139 . K:ORY ^XTMP("ORDCOBS-"_+ORVP) ;have rule -> dc, don't reinstate meds 140 DCQ Q ORY 141 ; 142 READMIT() ; -- Return 1 or 0, if patient is being readmitted 143 N X,Y,DIR 144 S DIR(0)="YA",DIR("A")="Will the patient be re-admitted immediately? " 145 S DIR("?")="Enter YES if the patient is to be admitted to the hospital immediately following this discharge from observation." 146 D ^DIR S:$D(DTOUT)!$D(DUOUT) Y="^" 147 Q Y 148 ; 149 COMP(ORDG) ; -- Complete orders on event [Keep until GMRA*4*15] 150 N ORI,ORLIST,ORIFN,OREDT 151 I 'ORDG S:ORDG?1.U ORDG=+$O(^ORD(100.98,"B",ORDG,0)) Q:ORDG'>0 152 D EN^ORQ1(ORVP,ORDG,2) S ORI=0,OREDT=$P(DGPMA,U) 153 F S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI'>0 S ORIFN=^(ORI) D STATUS^ORCSAVE2(+ORIFN,2) S:$G(OREDT) $P(^OR(100,+ORIFN,3),U)=OREDT,$P(^(6),U,6)=OREDT 154 Q 155 ; 156 LOC(NODE) ; -- Returns [new] patient location from NODE 157 N X,Y S X=$P($G(NODE),U,6) 158 I X'>0 S X=$P($G(^DPT(+ORVP,.1)),U) S:$L(X) X=$O(^DIC(42,"B",X,0)) 159 S Y=+$G(^DIC(42,+X,44))_";SC(" 160 Q Y 161 ; 162 DISCH ; -- Lapse/cancel outstanding events on discharge 163 D DISCH^ORMEVNT2 ;195 Code moved to ORMEVNT2 for space considerations 164 Q 165 ; 166 XTMP ; -- Save ORIFN to possibly reinstate on admission 167 ; Also uses ORVP, DGPMDA 168 Q:'$G(DGPMDA) Q:'$G(ORIFN) Q:'$G(ORVP) 169 N ORNOW S ORNOW=+$$NOW^XLFDT 170 I $G(^XTMP("ORDCOBS-"_+ORVP,0)),+^(0)<ORNOW K ^XTMP("ORDCOBS-"_+ORVP) 171 I '$G(^XTMP("ORDCOBS-"_+ORVP,0)) D 172 . N ORNOW1H S ORNOW1H=$$FMADD^XLFDT(ORNOW,,1) 173 . S ^XTMP("ORDCOBS-"_+ORVP,0)=ORNOW1H_U_ORNOW_"^InptMeds AutoDC'd on Discharge from Observation" 174 S ^XTMP("ORDCOBS-"_+ORVP,+ORIFN)=$G(^OR(100,+ORIFN,4)) 175 S ^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE")=DGPMDA 176 Q 177 ; 178 REINST ; -- Reinstate meds from observation 179 I '$L($T(ENR^PSJOERI)) K ^XTMP("ORDCOBS-"_+ORVP) Q ;DBIA 3598 180 N ORIDT,ORLASTDC,X0,ORIFN,PSIFN 181 S ORIDT=+$O(^DGPM("ATID3",+ORVP,0)) S:DGPMT=2 ORIDT=$O(^DGPM("ATID3",+ORVP,ORIDT)) Q:ORIDT<1 S ORLASTDC=+$O(^(ORIDT,0)) ;186 If reinstating for transfer TO ASIH then skip pseudo discharge for WHILE ASIH 182 Q:$G(^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE"))'=ORLASTDC S X0=$G(^(0)) 183 I $P(X0,U)<$$NOW^XLFDT K ^XTMP("ORDCOBS-"_+ORVP) Q ;readmit after one hour 177 184 S ORIFN=0 F S ORIFN=+$O(^XTMP("ORDCOBS-"_+ORVP,ORIFN)) Q:ORIFN<1 S PSIFN=$G(^(ORIFN)) D:PSIFN ENR^PSJOERI(+ORVP,PSIFN,+ORWARD) ;DBIA 3598 185 K ^XTMP("ORDCOBS-"_+ORVP) 186 Q 187 ; 188 ; -- Moved code: 189 EXP(ORDER,ORSTOP) G EXP^ORMEVNT1 190 ACTIVE(ORDER,ORSTRT) G ACT^ORMEVNT1 191 PURGE(ORDER) G PUR^ORMEVNT1 1 ORMEVNT ;SLC/MKB-Trigger HL7 msg off MAS events ;3/31/04 09:21 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**24,45,70,79,141,165,177,186,195**;Dec 17, 1997 3 ; 4 EN1 ; -- tasked entry point 5 Q:'$G(DFN) Q:$D(DGPMPC) Q:DGPMT=4!(DGPMT=5) ;skip lodger mvts 6 N ZTDESC,ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTSK,I 7 S ZTDESC="Auto-DC and/or Release orders on MAS movement",ZTIO="" 8 S ZTRTN="EN^ORMEVNT",ZTDTH=$H,ZTSAVE("^UTILITY(""DGPM"",$J,")="" 9 F I="DFN","DGPMDA","DGPMA","DGPMP","DGPMT" S ZTSAVE(I)="" 10 D ^%ZTLOAD ;D EN^ORYDGPM 11 Q 12 ; 13 EN ; -- main entry point 14 S:$D(ZTQUEUED) ZTREQ="@" 15 Q:'$G(DFN) Q:$D(DGPMPC) Q:DGPMT=4!(DGPMT=5) 16 I '$G(DGPMP) S ^XTMP("OREVENT",DFN,DGPMDA,0)=DT_U_$$FMADD^XLFDT(DT,2)_U_"Event process flag" ;195 17 I $G(DGPMP),$D(^XTMP("OREVENT",DFN,DGPMDA)) D EN1 ;195 edits processed after new 18 N XQORQUIT,XQORPOP,DTOUT,DUOUT,DIRUT,DIROUT ;protect protocol context 19 N VAIP,DONE,ORVP,ORWARD,ORTS,ORL,ORDIV,ORLAST,X,Y,I,ORCURRNT,OREVENT,ORDCRULE,ORACT,ORPRINT 20 S VAIP("E")=DGPMDA D IN5^VADPT M ORVP=VAIP I '$G(DGPMA) D Q ;deleted 21 . N LAST,OREVT S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1 22 . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)) 23 . D ACTLOG^OREVNTX(OREVT,"DL") 24 A ; 25 S ORVP=+DFN_";DPT(",ORTS=+$G(^DPT(DFN,.103)),ORWARD=$G(^(.1)) 26 S ORWARD=$S($L(ORWARD):+$O(^DIC(42,"B",ORWARD,0)),1:0) 27 S ORL=$S(ORWARD:+$G(^DIC(42,ORWARD,44))_";SC(",1:""),ORDIV=$$DIV(+ORL) 28 S ORLAST("TS")=$$PREVTS,X=+VAIP(15,4) F I="WD","LOC","DIV" S ORLAST(I)="" 29 S:X ORLAST("WD")=X,Y=+$G(^DIC(42,X,44)),ORLAST("LOC")=Y_";SC(",ORLAST("DIV")=$$DIV(Y) 30 S ORCURRNT=$$CURRENT,OREVENT=$$PATEVT,ORACT=$S($G(DGPMP):"ED",1:"NW") 31 I OREVENT=-1 D EN1 Q ;195 Can't lock, retry 32 I $G(DGPMP),$D(^ORE(100.2,"ADT",DGPMDA)) D Q:$G(DONE) ;edited 33 . N LAST,OREVT,DA,X,I S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1 34 . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)),DA=+$O(^(OREVT,0)) 35 . S X=$G(^ORE(100.2,OREVT,10,DA,0)) ;last activity on movement 36 . I $P(X,U,5)=+$G(VAIP(4)),$P(X,U,6)=+$G(VAIP(8)),$P(X,U,7)=+$G(VAIP(5)) S DONE=1 Q ;no change 37 . I 'OREVENT D ACTLOG^OREVNTX(OREVT,"ED",$$TYPE(DGPMT),1) S DONE=1 38 B ; 39 I '$G(DGPMP),ORCURRNT D ;new mvt - autoDC 40 . I $D(^ORE(100.2,"ADT",DGPMDA)) D Q:$G(DONE) ;ReEntered 41 .. N LAST,OREVT S DONE=0 42 .. S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1),OREVT=+$O(^(LAST,0)) 43 .. Q:+ORVP'=+$G(^ORE(100.2,OREVT,0)) ;diff pat -> diff mvt 44 .. S ORACT="RE",DONE=1 Q:OREVENT ;log on new event instead 45 .. D ACTLOG^OREVNTX(OREVT,ORACT,$$TYPE(DGPMT),1) 46 . I DGPMT=3 D COMP("ALG") ;keep until GMRA*4*15 gets out 47 . S ORDCRULE=$$DCEVT D:ORDCRULE AUTODC^ORMEVNT1(ORDCRULE,$P(DGPMA,U)) 48 . I DGPMT=1!(DGPMT=2&("^13^40^"[("^"_$P(DGPMA,U,18)_"^"))) I $G(^XTMP("ORDCOBS-"_+ORVP,0)) D REINST ;186 TO ASIH tran mvmt 49 C ; 50 I OREVENT D ;release delayed orders, complete event 51 . D RELEASE^ORMEVNT1(OREVENT),DONE^OREVNTX(OREVENT,$P(DGPMA,U),DGPMDA) 52 . I '$G(VAIP(1)) M VAIP=ORVP ;reset for ACTLOG use 53 . D ACTLOG^OREVNTX(OREVENT,ORACT,$$TYPE(DGPMT),1) 54 . I DGPMT=1,'$P($G(^ORE(100.2,+OREVENT,0)),U,3) S $P(^(0),U,3)=DGPMDA 55 . ;D UNLEVT^ORX2(OREVENT) 56 I $O(ORPRINT(0)),$G(ORL) D PRINTS^ORWD1(.ORPRINT,+ORL) 57 I DGPMT=3,ORCURRNT,'$G(DGPMP) D DISCH ;lapse remaining events 58 I '$G(DFN),$G(ORVP) S DFN=+ORVP ;just in case 59 D:$G(OREVENT) UNLEVT^ORX2(OREVENT) K ^XTMP("OREVENT",DFN,DGPMDA) ;195 60 Q 61 ; 62 CURRENT() ; -- Returns 1 or 0, if DGPMDA is the latest movement 63 N Y,LAST,LASTYPE,LASTDT S Y=0 64 S LAST=+VAIP(14),LASTDT=+VAIP(14,1),LASTYPE=+VAIP(14,2) 65 ; VAIP(14) = last physical movement for the admission 66 I DGPMT=6 D G CQ 67 . N CA,IDT I LAST,LASTDT>+VAIP(3) Q ;last physical mvt 68 . S CA=+VAIP(13),IDT=9999999.9999999-VAIP(3) 69 . I '$O(^DGPM("ATS",DFN,CA,IDT),-1) S Y=1 Q ;last TS mvt 70 I DGPMT=3 D ;get last mvt overall 71 . N VAIP,Y S VAIP("D")="LAST" D IN5^VADPT 72 . S LAST=+VAIP(14),LASTYPE=+VAIP(14,2) ;reset 73 I LAST=DGPMDA S Y=1 G CQ ;primary mvt 74 I $D(^UTILITY("DGPM",$J,LASTYPE,LAST)) S Y=1 ;secondary mvt 75 CQ Q Y 76 ; 77 PREVTS() ; -- Returns previous treating specialty 78 N TS,TSP,CA,ID,LAST,Y 79 S TS=+$O(^UTILITY("DGPM",$J,6,0)),TSP=$G(^(TS,"P")) 80 I $G(TSP) S Y=+$P(TSP,U,9) G PRVQ ;edited TS mvt 81 ; look for TS mvt since last phys mvt 82 S CA=$P(DGPMA,U,14),ID=9999999.9999999-DGPMA 83 S LAST=+$O(^DGPM("ATS",DFN,CA,ID)),Y=$S(LAST:+$O(^(LAST,0)),1:+VAIP(15,6)) 84 PRVQ Q Y 85 ; 86 TYPE(X) ; -- Return type of event from MAS code 87 N Y S Y=$S(X=1:"A",X=2:"T",X=3:"D",X=6:"S",1:"") 88 Q Y 89 ; 90 DIV(LOC) ; -- Return Institution file #4 ptr for LOC 91 N X0,Y S X0=$G(^SC(+LOC,0)) 92 S Y=$S($P(X0,U,4):$P(X0,U,4),$P(X0,U,15):$$SITE^VASITE(DT,$P(X0,U,15)),1:+$G(DUZ(2))) 93 Q Y 94 ; 95 PATEVT() ; -- Find match to new data in Patient Event file 96 N TYPE,MVTYPE,EVT,IFN,X0,Y S Y="" G:'$G(ORCURRNT) PTQ 97 S TYPE=$S(DGPMT=1:"A",DGPMT=3:"D",DGPMT=2!(DGPMT=6):"T",1:""),EVT=0 98 S MVTYPE=$P(DGPMA,U,18),TYPE(1)="",MVTYPE(1)="" 99 I DGPMT=2,MVTYPE=13 S TYPE(1)="A",MVTYPE(1)=40 ;To ASIH 100 I DGPMT=3,MVTYPE=41 S TYPE(1)="T",MVTYPE(1)=14 ;From ASIH 101 I DGPMT'=3,$$GET1^DIQ(45.7,+$G(ORTS)_",","SPECIALTY:SERVICE")="NHCU" S TYPE(1)=$S(TYPE="A":"T",1:"A") ;DBIA #1154 102 F S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1 S IFN=+$O(^(EVT,0)) D Q:Y 103 . Q:$$LAPSED^OREVNTX(+IFN) Q:$P($G(^ORE(100.2,IFN,1)),U,5) 104 . S X0=$G(^ORD(100.5,EVT,0)) Q:$P(X0,U,3)'=ORDIV 105 . I $P(X0,U,2)'=TYPE,$P(X0,U,2)'=TYPE(1) Q ;Xaction type 106 . I $P(X0,U,7),$P(X0,U,7)'=MVTYPE,$P(X0,U,7)'=MVTYPE(1) Q ;Mvt type 107 . I $O(^ORD(100.5,EVT,"TS",0)) Q:'$D(^("B",ORTS)) Q:ORTS=ORLAST("TS")&(ORDIV=ORLAST("DIV")) 108 . I $O(^ORD(100.5,EVT,"LOC",0)) Q:'$D(^("B",ORWARD)) Q:ORWARD=ORLAST("WD") 109 . S Y=+IFN ;ok 110 I Y S:'$$LCKEVT^ORX2(Y) Y=-1 ;195 Lock event if possible 111 PTQ Q Y 112 ; 113 DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV,ORTS,ORL 114 N MVTYPE,DIV,XFER,ORY,EXC,OBS 115 S OBS=$S(DGPMT=3:$$MVT^DGPMOBS(DGPMDA),1:0) ;observation mvt 116 S MVTYPE=+$P(DGPMA,U,18) S:MVTYPE=41 MVTYPE=14 S:MVTYPE=40 MVTYPE=13 ;ASIH- 186 117 S XFER=$S(DGPMT=2:1,DGPMT=6:1,MVTYPE'=14:0,OBS:0,1:1) 118 I DGPMT=2,MVTYPE=13,$G(^XTMP("ORDCOBS-"_+ORVP,"READMIT")) S ORY=0 K ^XTMP("ORDCOBS-"_+ORVP,"READMIT") G DCQ ;186 Obs readmit from ASIH don't auto-dc 119 I XFER,ORLAST("TS")'=ORTS,$D(^ORD(100.6,"AC",ORDIV,20)) S MVTYPE=20 ;TS 120 S DIV=ORDIV I DGPMT=3,MVTYPE'=14 S DIV=ORLAST("DIV") ;discharge 121 S ORY=+$O(^ORD(100.6,"AC",ORDIV,MVTYPE,0)) K:ORY<1&(DGPMT=3)&(OBS) ^XTMP("ORDCOBS-"_+ORVP) G:ORY<1 DCQ ;186, If obs, no active rule, no reinstate 122 I MVTYPE=20,$D(^ORD(100.6,ORY,4,ORLAST("TS"),1,ORTS))!(ORTS=ORLAST("TS")) S ORY=0 G DCQ 123 I MVTYPE=4 D G DCQ ;ck Div and Loc multiples 124 . I ORLAST("DIV")'=ORDIV S:'$D(^ORD(100.6,ORY,6,ORLAST("DIV"))) ORY=0 Q 125 . N OLD,INCL S INCL=0 ;ck incl loc's 126 . F OLD=+ORLAST("LOC"),"ALL" I $D(^ORD(100.6,ORY,5,"ADC",OLD,+ORL))!$D(^("ALL")) S INCL=1 Q 127 . S:'INCL ORY=0 128 I DGPMT=3,OBS D ;readmitting from observation? 129 . N TORY 130 . S TORY=ORY 131 . S EXC=+$P($G(^ORD(100.6,ORY,0)),U,6) S:EXC=2 ORY=0 ;ignore rule 132 . I EXC=1,'$D(ZTQUEUED),$$READMIT S ORY=0 133 . I ORY=0 D DCGEN^ORMEVNT2,TIMER^ORMEVNT2 S:"^14^41^"[("^"_$P(DGPMA,U,18)_"^") ^XTMP("ORDCOBS-"_+ORVP,"READMIT")=1 ;177,186 134 . K:ORY ^XTMP("ORDCOBS-"_+ORVP) ;have rule -> dc, don't reinstate meds 135 DCQ Q ORY 136 ; 137 READMIT() ; -- Return 1 or 0, if patient is being readmitted 138 N X,Y,DIR 139 S DIR(0)="YA",DIR("A")="Will the patient be re-admitted immediately? " 140 S DIR("?")="Enter YES if the patient is to be admitted to the hospital immediately following this discharge from observation." 141 D ^DIR S:$D(DTOUT)!$D(DUOUT) Y="^" 142 Q Y 143 ; 144 COMP(ORDG) ; -- Complete orders on event [Keep until GMRA*4*15] 145 N ORI,ORLIST,ORIFN,OREDT 146 I 'ORDG S:ORDG?1.U ORDG=+$O(^ORD(100.98,"B",ORDG,0)) Q:ORDG'>0 147 D EN^ORQ1(ORVP,ORDG,2) S ORI=0,OREDT=$P(DGPMA,U) 148 F S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI'>0 S ORIFN=^(ORI) D STATUS^ORCSAVE2(+ORIFN,2) S:$G(OREDT) $P(^OR(100,+ORIFN,3),U)=OREDT,$P(^(6),U,6)=OREDT 149 Q 150 ; 151 LOC(NODE) ; -- Returns [new] patient location from NODE 152 N X,Y S X=$P($G(NODE),U,6) 153 I X'>0 S X=$P($G(^DPT(+ORVP,.1)),U) S:$L(X) X=$O(^DIC(42,"B",X,0)) 154 S Y=+$G(^DIC(42,+X,44))_";SC(" 155 Q Y 156 ; 157 DISCH ; -- Lapse/cancel outstanding events on discharge 158 D DISCH^ORMEVNT2 ;195 Code moved to ORMEVNT2 for space considerations 159 Q 160 ; 161 XTMP ; -- Save ORIFN to possibly reinstate on admission 162 ; Also uses ORVP, DGPMDA 163 Q:'$G(DGPMDA) Q:'$G(ORIFN) Q:'$G(ORVP) 164 N ORNOW S ORNOW=+$$NOW^XLFDT 165 I $G(^XTMP("ORDCOBS-"_+ORVP,0)),+^(0)<ORNOW K ^XTMP("ORDCOBS-"_+ORVP) 166 I '$G(^XTMP("ORDCOBS-"_+ORVP,0)) D 167 . N ORNOW1H S ORNOW1H=$$FMADD^XLFDT(ORNOW,,1) 168 . S ^XTMP("ORDCOBS-"_+ORVP,0)=ORNOW1H_U_ORNOW_"^InptMeds AutoDC'd on Discharge from Observation" 169 S ^XTMP("ORDCOBS-"_+ORVP,+ORIFN)=$G(^OR(100,+ORIFN,4)) 170 S ^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE")=DGPMDA 171 Q 172 ; 173 REINST ; -- Reinstate meds from observation 174 I '$L($T(ENR^PSJOERI)) K ^XTMP("ORDCOBS-"_+ORVP) Q 175 N ORIDT,ORLASTDC,X0,ORIFN,PSIFN 176 S ORIDT=+$O(^DGPM("ATID3",+ORVP,0)) S:DGPMT=2 ORIDT=$O(^DGPM("ATID3",+ORVP,ORIDT)) Q:ORIDT<1 S ORLASTDC=+$O(^(ORIDT,0)) ;186 If reinstating for transfer TO ASIH then skip pseudo discharge for WHILE ASIH 177 Q:$G(^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE"))'=ORLASTDC S X0=$G(^(0)) 178 I $P(X0,U)<$$NOW^XLFDT K ^XTMP("ORDCOBS-"_+ORVP) Q ;readmit after one hour 177 179 S ORIFN=0 F S ORIFN=+$O(^XTMP("ORDCOBS-"_+ORVP,ORIFN)) Q:ORIFN<1 S PSIFN=$G(^(ORIFN)) D:PSIFN ENR^PSJOERI(+ORVP,PSIFN,+ORWARD) 180 K ^XTMP("ORDCOBS-"_+ORVP) 181 Q 182 ; 183 ; -- Moved code: 184 EXP(ORDER,ORSTOP) G EXP^ORMEVNT1 185 ACTIVE(ORDER,ORSTRT) G ACT^ORMEVNT1 186 PURGE(ORDER) G PUR^ORMEVNT1 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMFH.m
r613 r623 1 ORMFH 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,73,92,215,243**;Dec 17, 1997;Build 242 3 4 EN 5 6 7 8 9 10 11 12 ZP 13 14 15 16 17 ZR 18 19 20 21 ZU 22 23 24 25 OK 26 27 28 29 30 31 32 XX 33 34 35 SN 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 DIET 53 54 55 56 57 58 59 60 61 62 63 64 65 66 SN1 67 68 69 70 71 72 73 74 75 76 TRAY 77 78 79 80 81 82 83 84 85 86 87 88 89 90 IP 91 92 93 94 95 96 97 98 TF 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 UNITS(X) 119 120 121 122 123 NPO 124 125 126 127 128 129 130 131 ADDL 132 133 134 135 136 137 DATES 138 139 140 141 142 143 SC 144 SR 145 146 147 148 149 150 151 152 153 154 155 156 157 158 OC 159 160 161 162 163 164 165 CR 166 167 168 169 OD 170 171 172 173 174 DR 175 176 177 178 UA 179 180 181 182 UC 183 UD 184 185 186 187 188 189 UPDATE(ORSTS,ORACT) 190 191 192 193 194 195 196 197 198 199 IORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0200 201 202 203 PTR(NAME) 204 1 ORMFH ;SLC/MKB - Process Dietetics ORM msgs ;5/5/05 13:18 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,73,92,215**;Dec 17, 1997 3 ; 4 EN ; -- entry point for FH messages 5 I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q 6 I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q 7 S ORLOG=+$E($$NOW^XLFDT,1,12) S:'$G(ORDUZ) ORDUZ=DUZ S:'$G(ORNP) ORNP=ORDUZ 8 S:$G(DGPMT) ORNATR="A",OREASON=$S(DGPMT=1:"Admission",DGPMT=3:"Discharge",1:"Transfer"),ORDUZ="" 9 D @ORDCNTRL 10 Q 11 ; 12 ZP ; -- Purged 13 Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) 14 K ^OR(100,+ORIFN,4) I "^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ; Remove pkg reference, sts=lapsed if still active 15 Q 16 ; 17 ZR ; -- Purged as requested [ack] 18 D DELETE^ORCSAVE2(+ORIFN) 19 Q 20 ; 21 ZU ; -- Unable to purge [ack] 22 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity 23 Q 24 ; 25 OK ; -- Order accepted, FH order # assigned [ack] 26 N ORSTS S ^OR(100,+ORIFN,4)=PKGIFN ; FH identifier 27 I "DN"'[$E(PKGIFN) S ORSTS=6 ;not Diet or NPO 28 E S ORSTS=$S($P($G(^OR(100,+ORIFN,0)),U,8)>ORLOG:8,1:6) 29 D STATUS^ORCSAVE2(+ORIFN,ORSTS) 30 Q 31 ; 32 XX ; -- Edited backdoor order (OP recurring meals only) 33 D XX^ORMFH1 Q 34 ; 35 SN ; -- New backdoor order: return NA msg w/ORIFN 36 N ODS,ODT,OBR,ORDIALOG,X,I,OI,SEG,ORNEW,ORPARAM,ORTIME,ORSTS,ORDG,ORP,ORTRAIL 37 ;I '$D(^VA(200,+ORNP,0)) S ORERR="Missing or invalid ordering provider"Q 38 ; Don't require provider until Nature of Order is added 39 I '$G(DGPMT),'$D(^VA(200,+ORDUZ,0)) S ORERR="Missing or invalid entering person" Q 40 I 'ORSTRT S ORERR="Missing effective date/time" Q 41 ;I '$G(ORL) S ORERR="Missing or invalid patient location" Q 42 D EN1^FHWOR8(ORL,.ORPARAM) 43 S ODS=$O(@ORMSG@(+ORC)) I 'ODS S ORERR="Incomplete message" Q 44 S ODS=ODS_U_@ORMSG@(ODS),ORSTS=6 I '$L(ORNATR),ORCAT="I" S ORNATR="S" 45 I $E($P(ODS,U,2),1,3)="OBR" S OBR=ODS D IP G SN1 46 I $E($P(ODS,U,2),1,3)="ODT" S ODT=ODS D TRAY G SN1 47 I $E($P(ODS,U,2),1,3)'="ODS" S ORERR="Missing or invalid ODS segment" Q 48 I $P(ODS,"|",2)="ZE" D TF G SN1 49 I $P(ODS,"|",4)?1"^^^FH-6".E D ADDL G SN1 50 I ORCAT'="I" D OPM^ORMFH1 G SN1 51 I $P(ODS,"|",4)?1"^^^FH-5".E D NPO G SN1 52 DIET ; Diet order 53 S ORDIALOG=$O(^ORD(101.41,"AB","FHW1",0)),ORTRAIL="Diet" 54 D GETDLG1^ORCD(ORDIALOG) S:ORSTRT>ORLOG ORSTS=8 55 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT 56 S:ORSTOP ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP 57 S X=$P(ODS,"|",2),ORDIALOG($$PTR("DELIVERY"),1)=$S($L(X)=1:X,1:$E(X,2)) 58 ; Comments ?? 59 S X=$$ORDITEM^ORM($P(ODS,"|",4)) 60 I 'X S ORERR="Missing or invalid diet modification" Q 61 S I=1,OI=$$PTR("ORDERABLE ITEM"),ORDIALOG(OI,I)=X 62 I $O(@ORMSG@(+ODS)) F S ODS=$O(@ORMSG@(+ODS)) Q:ODS'>0 S SEG=$E(@ORMSG@(+ODS),1,3) Q:SEG="ORC" Q:SEG="MSH" I SEG="ODS" D Q:$D(ORERR) 63 . S X=$$ORDITEM^ORM($P(@ORMSG@(+ODS),"|",4)) 64 . I 'X S ORERR="Missing or invalid diet modification" Q 65 . S I=I+1,ORDIALOG(OI,I)=X 66 SN1 ; continue ... save order, post message 67 Q:$D(ORERR) 68 D EN^ORCSAVE I '$G(ORIFN) S ORERR="Cannot create new order" Q 69 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) 70 D:'$P($G(^OR(100,ORIFN,0)),U,8) DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP) 71 D STATUS^ORCSAVE2(ORIFN,ORSTS) 72 I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy 73 S ^OR(100,ORIFN,4)=PKGIFN 74 Q 75 ; 76 TRAY ; Early/Late tray 77 I 'ORSTOP S ORERR="Missing stop date" Q 78 S ORDIALOG=$O(^ORD(101.41,"AB","FHW2",0)) D GETDLG1^ORCD(ORDIALOG),EN2^ORCDFH 79 S ORDIALOG($$PTR("START DATE"),1)=ORSTRT 80 S ORDIALOG($$PTR("STOP DATE"),1)=ORSTOP 81 N DAYS,SCH S DAYS="",SCH=$P(ORQT,U,2) 82 I $L(SCH),SCH'="ONCE" F I=1:1:$L(SCH,"~") S X=+$P($P(SCH,"~",I),"J",2),DAYS=DAYS_$E("MTWRFSX",X) 83 S:$L(DAYS) ORDIALOG($$PTR("SCHEDULE"),1)=DAYS 84 S OI=+$O(^ORD(101.43,"S.E/L T",$P(ODT,"|",2)_" TRAY",0)),ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI 85 S X=$P($P(ODT,"|",3),U,4),ORDIALOG($$PTR("MEAL"),1)=$E(X) 86 S ORDIALOG($$PTR("MEAL TIME"),1)=$P($G(ORTIME(OI,$E(X),+$E(X,3))),U,2) 87 S:$L($P(ODT,"|",4)) ORDIALOG($$PTR("YES/NO"),1)=1 88 Q 89 ; 90 IP ; Isolation/Precautions 91 N IP S IP=+$P($P(OBR,"|",13),U,4) 92 I IP'>0 S ORERR="Missing or invalid isolation type" Q 93 S ORDIALOG=$O(^ORD(101.41,"AB","FHW3",0)) D GETDLG1^ORCD(ORDIALOG) 94 S ORDIALOG($$PTR("ISOLATION TYPE"),1)=IP 95 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$O(^ORD(101.43,"S.PREC","ISOLATION PROCEDURES",0)) 96 Q 97 ; 98 TF ; Tubefeeding 99 N OI,STR,INSTR,CMMT,I,X,X4,XI,ZQT,QT,QTY,DUR 100 S ORDIALOG=$O(^ORD(101.41,"AB","FHW8",0)) D GETDLG1^ORCD(ORDIALOG) 101 S OI=$$PTR("ORDERABLE ITEM"),STR=$$PTR("STRENGTH FH") 102 S INSTR=$$PTR("INSTRUCTIONS"),CMMT=$$PTR("FREE TEXT 1") 103 ; Comments ?? 104 S I=0 F D S ODS=$O(@ORMSG@(+ODS)) Q:ODS'>0 Q:$E(@ORMSG@(ODS),1,3)="ORC" S ODS=ODS_U_@ORMSG@(ODS) 105 . Q:$E($P(ODS,U,2),1,3)'="ODS" ; not ODS segment 106 . S X=$P(ODS,"|",4),X4=$P(X,U,4) ; OI 107 . S:X4["-" $P(X,U,4)=+X4,X4=+$P(X4,"-",2) ; strength 108 . S XI=$$ORDITEM^ORM(X) I 'XI S ORERR="Missing or invalid tubefeeding product" Q 109 . S ZQT=$O(@ORMSG@(+ODS)) I 'ZQT S ORERR="Missing QT information" Q 110 . S QT=$P(@ORMSG@(ZQT),"|",3),DUR=$P(QT,U,3) 111 . S QTY=+QT_" "_$$UNITS($P($P(QT,U),"&",2))_"/"_$P(QT,U,2) 112 . S:$L(DUR) QTY=QTY_" X "_+$E(DUR,2,99)_$S($E(DUR)="H":"HR",1:"") 113 . S I=I+1,ORDIALOG(OI,I)=XI,ORDIALOG(STR,I)=X4,ORDIALOG(INSTR,I)=QTY 114 . S:$L($P(ODS,"|",5)) ORDIALOG(CMMT,I)=$P(ODS,"|",5) 115 I ORCAT="O",ORQT["~" D DATES 116 Q 117 ; 118 UNITS(X) ; -- Returns name of unit X 119 N Y S X=$E(X) 120 S Y=$S(X="K":"KCAL",X="C":"CC",X="M":"ML",X="O":"OZ",X="U":"UNITS",X="T":"TBSP",X="G":"GM",1:"") 121 Q Y 122 ; 123 NPO ; NPO <uses FHW1 dialog - FHW4 now a quick order> 124 S ORDIALOG=$O(^ORD(101.41,"AB","FHW1",0)) D GETDLG1^ORCD(ORDIALOG) 125 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$O(^ORD(101.43,"S.DIET","NPO",0)) 126 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT S:ORSTRT>ORLOG ORSTS=8 127 S:ORSTOP ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP 128 S:$L($P(ODS,"|",5)) ORDIALOG($$PTR("FREE TEXT 1"),1)=$P(ODS,"|",5) 129 Q 130 ; 131 ADDL ; Additional order 132 S ORDIALOG=$O(^ORD(101.41,"AB","FHW7",0)) D GETDLG1^ORCD(ORDIALOG) 133 S ORDIALOG($$PTR("FREE TEXT 1"),1)=$P(ODS,"|",5) 134 I ORCAT="O",ORQT["~" D DATES 135 Q 136 ; 137 DATES ; -- pull dates out of ORQT 138 N P,I,X S P=$$PTR("DATE/TIME") 139 F I=1:1:$L(ORQT,"~") S X=$P(ORQT,"~",I),ORDIALOG(P,I)=$$HL7TFM^XLFDT($P(X,U,4)) 140 S ORSTRT=$G(ORDIALOG(P,1)),ORSTOP=$G(ORDIALOG(P,I)) 141 Q 142 ; 143 SC ; -- Status Change 144 SR ; -- Status Update [ack] 145 N ORSTS,OROLD S OROLD=$P($G(^OR(100,+ORIFN,3)),U,3) 146 D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) 147 S ORSTS=$S(ORDSTS="DC":1,ORDSTS="IP":6,ORDSTS="ZE":7,ORDSTS="SC":8,1:"") 148 D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) 149 I ORDSTS="DC",'$D(^OR(100,+ORIFN,6)) D ;set 6-node 150 . I ORNATR'="A","DN"[$E(PKGIFN) S ORNATR="C" S:'$L(OREASON) OREASON="Replaced with new diet order" S:ORDUZ<1 ORDUZ="" 151 . S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON 152 I OROLD=1,ORSTS=6 D ; reactivate 153 . N X S $P(^OR(100,+ORIFN,3),U,7)=1,X=$P(^(0),U,9) K ^(6) 154 . I 'ORSTOP,X S $P(^OR(100,+ORIFN,0),U,9)="" K ^OR(100,"AE",X,+ORIFN) 155 . D SETALL^ORDD100(+ORIFN) 156 Q 157 ; 158 OC ; -- Cancelled <E/L Trays only> / [ack] 159 G:ORTYPE="ORR" UA ;rejected new order 160 I $P($G(^OR(100,+ORIFN,3)),U,3)=6,$P(^(0),U,8)<ORLOG G OD 161 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON 162 D UPDATE(13,"DC") 163 Q 164 ; 165 CR ; -- Cancelled as requested [ack] 166 D STATUS^ORCSAVE2(+ORIFN,13) 167 Q 168 ; 169 OD ; -- Discontinued <Tubefeedings only> 170 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON 171 D UPDATE(1,"DC") 172 Q 173 ; 174 DR ; -- Discontinued as requested [ack] 175 D STATUS^ORCSAVE2(+ORIFN,1) 176 Q 177 ; 178 UA ; -- Unable to Accept [ack] 179 S:'$L(ORNATR) ORNATR="X" ;Rejected 180 S ^OR(100,+ORIFN,6)=+$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON 181 D STATUS^ORCSAVE2(+ORIFN,13) 182 UC ; -- Unable to Cancel [ack] 183 UD ; -- Unable to Discontinue [ack] 184 N DA S DA=$P(ORIFN,";",2) I DA D 185 . S:$G(OREJECT) $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ; request rejected 186 . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON 187 Q 188 ; 189 UPDATE(ORSTS,ORACT) ; -- continue processing 190 N ORX,DA,ORP D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) 191 D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS) 192 S ORX=$$CREATE^ORX1(ORNATR) D:ORX 193 . S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ) 194 . I DA'>0 S ORERR="Cannot create new order action" Q 195 . D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR) 196 . D SIGSTS^ORCSAVE2(+ORIFN,DA) 197 . I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL) 198 . S $P(^OR(100,+ORIFN,3),U,7)=DA 199 I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 200 D:ORACT="DC" CANCEL^ORCSEND(+ORIFN) 201 Q 202 ; 203 PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41 204 Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMFN.m
r613 r623 1 ORMFN ; SLC/MKB - MFN msg router ;11/21/2006 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,97,94,176,215,243**;Dec 17, 1997;Build 242 3 EN(MSG) ; -- main entry point for OR ITEM RECEIVE 4 N ORMSG,ORNMSP,ORDG,MSH,MFI,MFE,ZPKG,ZSY,NTE,ORMFE,ORDITEM,ORACTION,ORDIFN,ORFIEN,ORFLD,ORFDA,NUM,VALUE,X,Y,DA,DIC,DIK,SYS,ZLC,LAST,NAME,ID,INACTIVE,I,ORY,NEXT,DD,DO 5 S ORMSG=$G(MSG,"MSG") Q:'$O(@ORMSG@(0)) ; msg array root 6 N ORNOW S ORNOW=$$NOW^XLFDT ;M ^XTMP("OR ITEM RECEIVE",ORNOW)=@ORMSG 7 MSH S MSH=0 F S MSH=$O(@ORMSG@(MSH)) Q:MSH'>0 Q:$E(@ORMSG@(MSH),1,3)="MSH" 8 Q:'MSH S MSH=MSH_U_@ORMSG@(MSH) 9 S X=$P(MSH,"|",3) S:X="RADIOLOGY" X="IMAGING" 10 S ORDG=$O(^ORD(100.98,"B",X,0)),ORNMSP=$$NMSP(X) Q:'$L(ORNMSP) 11 S MFI=$O(@ORMSG@(+MSH)) Q:$E(@ORMSG@(MFI),1,3)'="MFI" ; error 12 MFE S MFE=+MFI ; ** loop through each MFE segment 13 F S MFE=$O(@ORMSG@(+MFE)) Q:MFE'>0 I $E(@ORMSG@(MFE),1,3)="MFE" D 14 . K ORFLD,ORFDA 15 . S MFE=MFE_U_@ORMSG@(MFE),ORMFE=$P(MFE,"|",2),INACTIVE=$P(MFE,"|",4) 16 . S ORDITEM=$P(MFE,"|",5),NAME=$TR($P(ORDITEM,U,5),"~"," ") 17 . S ID=$P(ORDITEM,U,4)_";"_$P(ORDITEM,U,6) 18 . S ORDIFN=+$O(^ORD(101.43,"ID",ID,0)),ORFIEN=ORDIFN_"," 19 . S ORACTION=$S(ORMFE="MAD":1,(ORMFE="MAC")&('ORDIFN):1,(ORMFE="MUP")&('ORDIFN):1,'ORDIFN:0,ORMFE="MAC":2,ORMFE="MUP":2,ORMFE="MDC":3,ORMFE="MDL":3,1:0) ; 1=add, 2=change, 3=delete (inactivate) 20 . Q:'ORACTION ; 0=error 21 . I ORACTION=3 S ORFDA(101.43,ORFIEN,.1)=$S(INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:$$NOW^XLFDT) D FILE^DIE("K","ORFDA") Q 22 ADD . I ORACTION=1,'ORDIFN D Q:'ORDIFN ;create item if it doesn't exist 23 . . S ORDIFN=$$CREATE(NAME),ORFIEN=ORDIFN_"," 24 . . S ORFDA(101.43,ORFIEN,5)=+ORDG 25 . S ORFLD(.01)=NAME,ORFLD(1.1)=NAME,ORFLD(2)=ID,ORFLD(3)=$P(ORDITEM,U) 26 . S SYS=$P(ORDITEM,U,3),ORFLD(4)=$S(+SYS=99:$E(SYS,3,99),1:SYS) 27 . S ORFLD(.1)=$S(ORMFE="MAC":"@",(ORMFE="MUP")&('INACTIVE):"@",INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:"") 28 . F NUM=.01,.1,1.1,2,3,4 S VALUE=$S(ORFLD(NUM)="":"@",1:ORFLD(NUM)) D VAL^DIE(101.43,ORFIEN,NUM,"F",VALUE,.ORY,"ORFDA") 29 ZPKG . S LAST=+MFE,ZPKG=$O(@ORMSG@(+MFE)) 30 . I ZPKG,$E(@ORMSG@(ZPKG),1,3)=("Z"_ORNMSP) S ZPKG=ZPKG_U_@ORMSG@(ZPKG),LAST=+ZPKG D @ORNMSP ; ZXX segment 31 . D FILE^DIE("K","ORFDA") ; file data 32 ZLC . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZLC" D 33 . . N COMP,CID,CODE,CSYS 34 . . K DA,^ORD(101.43,ORDIFN,10) ;S DIC("P")=$P(^DD(101.43,10,0),U,2) 35 . . S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",10,",DIC(0)="L",ZLC=LAST 36 . . F S ZLC=$O(@ORMSG@(ZLC)) Q:ZLC'>0 Q:$E(@ORMSG@(ZLC),1,3)'="ZLC" D 37 . . . S COMP=$P(@ORMSG@(ZLC),"|",5),X=$P(COMP,U,5) I X="" S LAST=ZLC Q 38 . . . S CID=$P(COMP,U,4)_";"_$P(COMP,U,6) K DIC("DR"),DO,DD 39 . . . S CODE=$P(COMP,U),CSYS=$P(COMP,U,3) S:+CSYS=99 CSYS=$E(CSYS,3,99) 40 . . . S DIC("DR")="2///^S X=CID;3///^S X=CODE;4///^S X=CSYS" 41 . . . D FILE^DICN S LAST=ZLC 42 ZSY . I $D(^ORD(101.43,ORDIFN,2)) D ; kill old ones first 43 . . S DA(1)=ORDIFN,DIK="^ORD(101.43,"_DA(1)_",2," 44 . . S DA=0 F S DA=$O(^ORD(101.43,DA(1),2,DA)) Q:DA'>0 D ^DIK 45 . . K ^ORD(101.43,ORDIFN,2),DIK,DA 46 . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZSY" D 47 . . K DA,DIC S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",2," 48 . . S DIC(0)="L",ZSY=LAST ;,DIC("P")=$P(^DD(101.43,1,0),U,2) 49 . . F S ZSY=$O(@ORMSG@(+ZSY)) Q:ZSY'>0 Q:$E(@ORMSG@(ZSY),1,3)'="ZSY" D 50 . . . S X=$P(@ORMSG@(ZSY),"|",3),LAST=ZSY 51 . . . K DD,DO D:$L(X) FILE^DICN 52 NTE . K ^ORD(101.43,ORDIFN,8) ; replace text 53 . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="NTE" D 54 . . S NTE=LAST,DA=0 55 . . F S NTE=$O(@ORMSG@(NTE)) Q:NTE'>0 Q:$E(@ORMSG@(NTE),1,3)'="NTE" S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=$P(@ORMSG@(NTE),"|",4) I $O(@ORMSG@(NTE,0)) D 56 . . . S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=@ORMSG@(NTE,I) 57 . . S ^ORD(101.43,ORDIFN,8,0)="^^"_DA_U_DA_U_DT_U 58 Q 59 ; 60 NMSP(NAME) ; -- returns namespace for package 61 I NAME="RADIOLOGY" Q "RA" 62 I NAME="IMAGING" Q "RA" 63 I NAME="LABORATORY" Q "LR" 64 I NAME="DIETETICS" Q "FH" 65 I NAME="PHARMACY" Q "PS" 66 I NAME="CONSULTS" Q "CS" 67 I NAME="PROCEDURES" Q "CS" 68 Q "" 69 ; 70 CREATE(X) ; -- Create new item in #101.43 71 Q:'$L($G(X)) 0 N HDR,LAST,TOTAL,I 72 L +^ORD(101.43,0):1 Q:'$T 0 73 S HDR=$G(^ORD(101.43,0)) Q:HDR="" 0 74 S LAST=$P(HDR,U,3),TOTAL=$P(HDR,U,4) 75 F I=(LAST+1):1 Q:'$D(^ORD(101.43,I,0)) 76 S ^ORD(101.43,I,0)=X,X=$E(X,1,30),^ORD(101.43,"B",$$UP^XLFSTR(X),I)="" 77 S $P(^ORD(101.43,0),U,3,4)=I_U_(TOTAL+1) 78 L -^ORD(101.43,0) 79 Q I 80 ; 81 FH ; -- Dietetics 82 S X=$P(ZPKG,"|",2),ORFLD(111.1)=$S(X="":"@",1:X) 83 S X=$P(ZPKG,"|",3),ORFLD(111.2)=$S(X="":"@",1:X) 84 S X=$P(ZPKG,"|",5),ORFLD(111.3)=$S(X="":"@",1:X) 85 F NUM=111.1,111.2,111.3 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA") 86 K ^ORD(101.43,ORDIFN,8) S X=$P(ZPKG,"|",4) 87 I $L(X) S ^ORD(101.43,ORDIFN,8,0)="^^1^1^"_DT_U,^(1,0)=X 88 Q 89 ; 90 LR ; -- Laboratory 91 S X=$P(ZPKG,"|",2),ORFLD(60.1)=$S(X="":"@",1:X) 92 S X=$P(ZPKG,"|",3),ORFLD(60.2)=$S(X="":"@",1:X) 93 ;S X=$P(ZPKG,"|",4),ORFLD(60.3)=$S(X="":"@",1:X) 94 S X=$P(ZPKG,"|",5),ORFLD(60.6)=$S(X="":"@",1:X) 95 S X=$P(ZPKG,"|",6),ORFLD(60.4)=$S(X="":"@",1:X) 96 S X=$P(ZPKG,"|",7),ORFLD(60.5)=$S(X="":"@",1:X) 97 S X=$P(ZPKG,"|",8),ORFLD(6)=$S(X="":"@",1:X) 98 S X=$P(ZPKG,"|",9),ORFLD(60.7)=$S(X="":"@",1:X) 99 F NUM=6,60.1,60.2,60.4,60.5,60.6,60.7 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA") 100 Q 101 ; 102 PS ; -- Pharmacy 103 N ROUTE 104 S X=$P(ZPKG,"|",2) 105 ;S ORFDA(101.43,ORFIEN,50.1)=$S(X'["I":0,$L($P($P(ORDITEM,U,5),"~",3)):2,1:1) 106 S ORFDA(101.43,ORFIEN,50.1)=$S(X["V":2,X["I":1,1:0) ;inpt or iv med 107 S ORFDA(101.43,ORFIEN,50.2)=(X["O") ;outpt med 108 S ORFDA(101.43,ORFIEN,50.3)=(X["B") ;fluid base/soln 109 S ORFDA(101.43,ORFIEN,50.4)=(X["A") ;fluid additive 110 S ORFDA(101.43,ORFIEN,50.5)=(X["S") ;supply item 111 S ORFDA(101.43,ORFIEN,50.7)=(X["N") ;non-VA med 112 S X=$P(ZPKG,"|",3),ORFDA(101.43,ORFIEN,50.6)=$S(X:1,1:0) 113 ;Check for default med route 114 ;S ROUTE=$$MEDROUTE 115 ;I ROUTE>0 S ORFDA(101.43,ORFIEN,50.8)=ROUTE 116 Q 117 ; 118 MEDROUTE() ; 119 N CNT,ROUTE 120 S CNT=0,ROUTE=0 121 F S CNT=$O(@ORMSG@(CNT)) Q:CNT'>0 D 122 .I $P($G(@ORMSG@(CNT)),"|")'="ZPB" Q 123 .S ROUTE=+$P($G(@ORMSG@(CNT)),"|",4) 124 Q ROUTE 125 ; 126 RA ; -- Radiology/Nuc Medicine 127 S X=$P(ZPKG,"|",4),ORFLD(6)=$S(X="":"@",1:X) 128 S X=$P(ZPKG,"|",5),ORFLD(71.1)=$S(X="":"@",1:X) 129 S X=$P(ZPKG,"|",7),ORFLD(71.2)=$S(X="":"@",1:X) 130 S X=$P(ZPKG,"|",2),ORFLD(71.3)=$S(X="":"@",1:X) 131 S ORFLD(71.4)=$S($P(ZPKG,"|",6)="Y":1,1:0) 132 S ORFLD(7)=$S($P(ZPKG,"|",3)="Y":2,1:1) 133 F NUM=6,7,71.1,71.2,71.3,71.4 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA") 134 Q 135 ; 136 CS ; -- Consults/Requests 137 S X=$P(ZPKG,"|",2),ORFLD(123.1)=$S(X="":"@",1:X) 138 D VAL^DIE(101.43,ORFIEN,123.1,"F",ORFLD(123.1),.ORY,"ORFDA") 139 Q 1 ORMFN ; SLC/MKB - MFN msg router ;04:29 PM 19 Dec 2000 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,97,94,176,215**;Dec 17, 1997 3 EN(MSG) ; -- main entry point for OR ITEM RECEIVE 4 N ORMSG,ORNMSP,ORDG,MSH,MFI,MFE,ZPKG,ZSY,NTE,ORMFE,ORDITEM,ORACTION,ORDIFN,ORFIEN,ORFLD,ORFDA,NUM,VALUE,X,Y,DA,DIC,DIK,SYS,ZLC,LAST,NAME,ID,INACTIVE,I,ORY,NEXT,DD,DO 5 S ORMSG=$G(MSG,"MSG") Q:'$O(@ORMSG@(0)) ; msg array root 6 N ORNOW S ORNOW=$$NOW^XLFDT ;M ^XTMP("OR ITEM RECEIVE",ORNOW)=@ORMSG 7 MSH S MSH=0 F S MSH=$O(@ORMSG@(MSH)) Q:MSH'>0 Q:$E(@ORMSG@(MSH),1,3)="MSH" 8 Q:'MSH S MSH=MSH_U_@ORMSG@(MSH) 9 S X=$P(MSH,"|",3) S:X="RADIOLOGY" X="IMAGING" 10 S ORDG=$O(^ORD(100.98,"B",X,0)),ORNMSP=$$NMSP(X) Q:'$L(ORNMSP) 11 S MFI=$O(@ORMSG@(+MSH)) Q:$E(@ORMSG@(MFI),1,3)'="MFI" ; error 12 MFE S MFE=+MFI ; ** loop through each MFE segment 13 F S MFE=$O(@ORMSG@(+MFE)) Q:MFE'>0 I $E(@ORMSG@(MFE),1,3)="MFE" D 14 . K ORFLD,ORFDA 15 . S MFE=MFE_U_@ORMSG@(MFE),ORMFE=$P(MFE,"|",2),INACTIVE=$P(MFE,"|",4) 16 . S ORDITEM=$P(MFE,"|",5),NAME=$TR($P(ORDITEM,U,5),"~"," ") 17 . S ID=$P(ORDITEM,U,4)_";"_$P(ORDITEM,U,6) 18 . S ORDIFN=+$O(^ORD(101.43,"ID",ID,0)),ORFIEN=ORDIFN_"," 19 . S ORACTION=$S(ORMFE="MAD":1,(ORMFE="MAC")&('ORDIFN):1,(ORMFE="MUP")&('ORDIFN):1,'ORDIFN:0,ORMFE="MAC":2,ORMFE="MUP":2,ORMFE="MDC":3,ORMFE="MDL":3,1:0) ; 1=add, 2=change, 3=delete (inactivate) 20 . Q:'ORACTION ; 0=error 21 . I ORACTION=3 S ORFDA(101.43,ORFIEN,.1)=$S(INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:$$NOW^XLFDT) D FILE^DIE("K","ORFDA") Q 22 ADD . I ORACTION=1,'ORDIFN D Q:'ORDIFN ;create item if it doesn't exist 23 . . S ORDIFN=$$CREATE(NAME),ORFIEN=ORDIFN_"," 24 . . S ORFDA(101.43,ORFIEN,5)=+ORDG 25 . S ORFLD(.01)=NAME,ORFLD(1.1)=NAME,ORFLD(2)=ID,ORFLD(3)=$P(ORDITEM,U) 26 . S SYS=$P(ORDITEM,U,3),ORFLD(4)=$S(+SYS=99:$E(SYS,3,99),1:SYS) 27 . S ORFLD(.1)=$S(ORMFE="MAC":"@",(ORMFE="MUP")&('INACTIVE):"@",INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:"") 28 . F NUM=.01,.1,1.1,2,3,4 S VALUE=$S(ORFLD(NUM)="":"@",1:ORFLD(NUM)) D VAL^DIE(101.43,ORFIEN,NUM,"F",VALUE,.ORY,"ORFDA") 29 ZPKG . S LAST=+MFE,ZPKG=$O(@ORMSG@(+MFE)) 30 . I ZPKG,$E(@ORMSG@(ZPKG),1,3)=("Z"_ORNMSP) S ZPKG=ZPKG_U_@ORMSG@(ZPKG),LAST=+ZPKG D @ORNMSP ; ZXX segment 31 . D FILE^DIE("K","ORFDA") ; file data 32 ZLC . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZLC" D 33 . . N COMP,CID,CODE,CSYS 34 . . K DA,^ORD(101.43,ORDIFN,10) ;S DIC("P")=$P(^DD(101.43,10,0),U,2) 35 . . S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",10,",DIC(0)="L",ZLC=LAST 36 . . F S ZLC=$O(@ORMSG@(ZLC)) Q:ZLC'>0 Q:$E(@ORMSG@(ZLC),1,3)'="ZLC" D 37 . . . S COMP=$P(@ORMSG@(ZLC),"|",5),X=$P(COMP,U,5) I X="" S LAST=ZLC Q 38 . . . S CID=$P(COMP,U,4)_";"_$P(COMP,U,6) K DIC("DR"),DO,DD 39 . . . S CODE=$P(COMP,U),CSYS=$P(COMP,U,3) S:+CSYS=99 CSYS=$E(CSYS,3,99) 40 . . . S DIC("DR")="2///^S X=CID;3///^S X=CODE;4///^S X=CSYS" 41 . . . D FILE^DICN S LAST=ZLC 42 ZSY . I $D(^ORD(101.43,ORDIFN,2)) D ; kill old ones first 43 . . S DA(1)=ORDIFN,DIK="^ORD(101.43,"_DA(1)_",2," 44 . . S DA=0 F S DA=$O(^ORD(101.43,DA(1),2,DA)) Q:DA'>0 D ^DIK 45 . . K ^ORD(101.43,ORDIFN,2),DIK,DA 46 . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZSY" D 47 . . K DA,DIC S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",2," 48 . . S DIC(0)="L",ZSY=LAST ;,DIC("P")=$P(^DD(101.43,1,0),U,2) 49 . . F S ZSY=$O(@ORMSG@(+ZSY)) Q:ZSY'>0 Q:$E(@ORMSG@(ZSY),1,3)'="ZSY" D 50 . . . S X=$P(@ORMSG@(ZSY),"|",3),LAST=ZSY 51 . . . K DD,DO D:$L(X) FILE^DICN 52 NTE . K ^ORD(101.43,ORDIFN,8) ; replace text 53 . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="NTE" D 54 . . S NTE=LAST,DA=0 55 . . F S NTE=$O(@ORMSG@(NTE)) Q:NTE'>0 Q:$E(@ORMSG@(NTE),1,3)'="NTE" S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=$P(@ORMSG@(NTE),"|",4) I $O(@ORMSG@(NTE,0)) D 56 . . . S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=@ORMSG@(NTE,I) 57 . . S ^ORD(101.43,ORDIFN,8,0)="^^"_DA_U_DA_U_DT_U 58 Q 59 ; 60 NMSP(NAME) ; -- returns namespace for package 61 I NAME="RADIOLOGY" Q "RA" 62 I NAME="IMAGING" Q "RA" 63 I NAME="LABORATORY" Q "LR" 64 I NAME="DIETETICS" Q "FH" 65 I NAME="PHARMACY" Q "PS" 66 I NAME="CONSULTS" Q "CS" 67 I NAME="PROCEDURES" Q "CS" 68 Q "" 69 ; 70 CREATE(X) ; -- Create new item in #101.43 71 Q:'$L($G(X)) 0 N HDR,LAST,TOTAL,I 72 L +^ORD(101.43,0):1 Q:'$T 0 73 S HDR=$G(^ORD(101.43,0)) Q:HDR="" 0 74 S LAST=$P(HDR,U,3),TOTAL=$P(HDR,U,4) 75 F I=(LAST+1):1 Q:'$D(^ORD(101.43,I,0)) 76 S ^ORD(101.43,I,0)=X,X=$E(X,1,30),^ORD(101.43,"B",$$UP^XLFSTR(X),I)="" 77 S $P(^ORD(101.43,0),U,3,4)=I_U_(TOTAL+1) 78 L -^ORD(101.43,0) 79 Q I 80 ; 81 FH ; -- Dietetics 82 S X=$P(ZPKG,"|",2),ORFLD(111.1)=$S(X="":"@",1:X) 83 S X=$P(ZPKG,"|",3),ORFLD(111.2)=$S(X="":"@",1:X) 84 S X=$P(ZPKG,"|",5),ORFLD(111.3)=$S(X="":"@",1:X) 85 F NUM=111.1,111.2,111.3 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA") 86 K ^ORD(101.43,ORDIFN,8) S X=$P(ZPKG,"|",4) 87 I $L(X) S ^ORD(101.43,ORDIFN,8,0)="^^1^1^"_DT_U,^(1,0)=X 88 Q 89 ; 90 LR ; -- Laboratory 91 S X=$P(ZPKG,"|",2),ORFLD(60.1)=$S(X="":"@",1:X) 92 S X=$P(ZPKG,"|",3),ORFLD(60.2)=$S(X="":"@",1:X) 93 ;S X=$P(ZPKG,"|",4),ORFLD(60.3)=$S(X="":"@",1:X) 94 S X=$P(ZPKG,"|",5),ORFLD(60.6)=$S(X="":"@",1:X) 95 S X=$P(ZPKG,"|",6),ORFLD(60.4)=$S(X="":"@",1:X) 96 S X=$P(ZPKG,"|",7),ORFLD(60.5)=$S(X="":"@",1:X) 97 S X=$P(ZPKG,"|",8),ORFLD(6)=$S(X="":"@",1:X) 98 S X=$P(ZPKG,"|",9),ORFLD(60.7)=$S(X="":"@",1:X) 99 F NUM=6,60.1,60.2,60.4,60.5,60.6,60.7 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA") 100 Q 101 ; 102 PS ; -- Pharmacy 103 S X=$P(ZPKG,"|",2) 104 ;S ORFDA(101.43,ORFIEN,50.1)=$S(X'["I":0,$L($P($P(ORDITEM,U,5),"~",3)):2,1:1) 105 S ORFDA(101.43,ORFIEN,50.1)=$S(X["V":2,X["I":1,1:0) ;inpt or iv med 106 S ORFDA(101.43,ORFIEN,50.2)=(X["O") ;outpt med 107 S ORFDA(101.43,ORFIEN,50.3)=(X["B") ;fluid base/soln 108 S ORFDA(101.43,ORFIEN,50.4)=(X["A") ;fluid additive 109 S ORFDA(101.43,ORFIEN,50.5)=(X["S") ;supply item 110 S ORFDA(101.43,ORFIEN,50.7)=(X["N") ;non-VA med 111 S X=$P(ZPKG,"|",3),ORFDA(101.43,ORFIEN,50.6)=$S(X:1,1:0) 112 Q 113 ; 114 RA ; -- Radiology/Nuc Medicine 115 S X=$P(ZPKG,"|",4),ORFLD(6)=$S(X="":"@",1:X) 116 S X=$P(ZPKG,"|",5),ORFLD(71.1)=$S(X="":"@",1:X) 117 S X=$P(ZPKG,"|",7),ORFLD(71.2)=$S(X="":"@",1:X) 118 S X=$P(ZPKG,"|",2),ORFLD(71.3)=$S(X="":"@",1:X) 119 S ORFLD(71.4)=$S($P(ZPKG,"|",6)="Y":1,1:0) 120 S ORFLD(7)=$S($P(ZPKG,"|",3)="Y":2,1:1) 121 F NUM=6,7,71.1,71.2,71.3,71.4 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA") 122 Q 123 ; 124 CS ; -- Consults/Requests 125 S X=$P(ZPKG,"|",2),ORFLD(123.1)=$S(X="":"@",1:X) 126 D VAL^DIE(101.43,ORFIEN,123.1,"F",ORFLD(123.1),.ORY,"ORFDA") 127 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMGMRC.m
r613 r623 1 ORMGMRC ; SLC/MKB - Process Consult ORM msgs ;12/13/20062 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,26,68,92,153,174,195,255,243**;Dec 17, 1997;Build 242 3 EN 4 5 6 7 8 9 10 11 12 13 14 ZP 15 16 17 18 19 ZR 20 21 22 23 ZU 24 25 26 27 OK 28 29 30 31 32 33 XX 34 35 36 37 38 39 40 41 42 D PXRMKILL^ORDD100(ORIFN,ORVP,ORLOG); JEH 25543 44 45 46 47 48 49 50 51 D PXRMADD^ORDD100(ORIFN,ORVP,ORLOG); JEH 25552 53 54 55 SN 56 57 58 59 60 61 SN1 62 63 64 65 66 67 68 69 70 71 72 DLG 73 74 75 76 77 78 79 80 81 82 83 84 85 D1 86 87 88 89 90 91 92 93 94 95 96 97 98 99 OBR() 100 101 102 103 104 SC 105 106 107 108 STATUS(X) 109 110 111 RE 112 113 114 115 116 117 118 119 120 121 122 123 UA 124 125 OC 126 127 128 129 UD 130 131 132 133 134 135 OD 136 137 138 139 140 DR 141 142 143 144 UPDATE(ORACT) 145 146 147 148 149 150 151 152 153 154 155 156 157 PTR(X) 158 1 ORMGMRC ; SLC/MKB - Process Consult ORM msgs ;7/14/04 13:29 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,26,68,92,153,174,195,255**;Dec 17, 1997 3 EN ; -- entry point for GMRC messges 4 I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q 5 I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q 6 S:ORDCNTRL="OC"&(ORTYPE="ORR") ORDCNTRL="UA" ;new code 7 N ORSTS,OREASON1,NTE S ORSTS=$$STATUS(ORDSTS) 8 S:'ORLOG ORLOG=$$NOW^XLFDT S:'ORDUZ ORDUZ=DUZ S:$G(DGPMT) ORDUZ="" 9 S OREASON=$P(OREASON,U,5),NTE=$O(@ORMSG@(+ORC)),OREASON1="" 10 I NTE,$E(@ORMSG@(NTE),1,3)="NTE" S OREASON1=$P(@ORMSG@(NTE),"|",4) 11 D @ORDCNTRL 12 Q 13 ; 14 ZP ; -- Purged 15 Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) 16 K ^OR(100,+ORIFN,4) I "^3^5^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ; Remove pkg reference, sts=lapsed if still active 17 Q 18 ; 19 ZR ; -- Purged as requested [ack] 20 D DELETE^ORCSAVE2(+ORIFN) 21 Q 22 ; 23 ZU ; -- Unable to purge [ack] 24 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity 25 Q 26 ; 27 OK ; -- Order accepted, GMRC order # assigned [ack] 28 S ^OR(100,+ORIFN,4)=PKGIFN S:'$G(ORSTS) ORSTS=5 29 D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 5=pending 30 D DATES^ORCSAVE2(+ORIFN,+$E($$NOW^XLFDT,1,12)) 31 Q 32 ; 33 XX ; -- Change order 34 N ORDIALOG,ORDG,ORDA,ORX,ORP,ORSIG S:'$L(ORNATR) ORNATR="S" 35 D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) S ORIFN=+ORIFN 36 S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON1,ORLOG,ORDUZ) 37 I ORDA'>0 S ORERR="Cannot create new order action" Q 38 ; -Update sts of order to active, last action to dc/edit: 39 S ORX=+$P($G(^OR(100,ORIFN,3)),U,7) S:ORX'>0 ORX=+$O(^(8,ORDA),-1) 40 I $D(^OR(100,ORIFN,8,ORX,0)),$P(^(0),U,15)="" S $P(^(0),U,15)=12 41 S $P(^OR(100,ORIFN,3),U,7)=ORDA D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS) 42 D PXRMKILL^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255 43 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) 44 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd 45 S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0) 46 D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG 47 ; -Update responses, get/save new order text: 48 K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA) 49 S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA 50 K:OREASON="RESUBMIT" ^OR(100,ORIFN,6) ;clear previous DC data 51 D PXRMADD^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255 52 I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) 53 Q 54 ; 55 SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg 56 N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W" 57 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q 58 I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q 59 I '$G(ORL) S ORERR="Missing or invalid patient location" Q 60 D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) 61 SN1 D EN^ORCSAVE K ^TMP("ORWORD",$J) ; setting status, xrefs 62 I '$G(ORIFN) S ORERR="Cannot create new order" Q 63 ;Save DG1 and ZCL segments of HL7 message from backdoor orders 64 D BDOSTR^ORWDBA3 65 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) 66 S:'ORSTRT ORSTRT=$$NOW^XLFDT D DATES^ORCSAVE2(+ORIFN,ORSTRT) 67 D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS) 68 I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy 69 S ^OR(100,ORIFN,4)=PKGIFN 70 Q 71 ; 72 DLG ; -- Build ORDIALOG(),ORDG from msg 73 N OBR,USID,TYPE,OI,ZSV,J,OBX,WP,I 74 S OBR=$$OBR I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q 75 S USID=$P(@ORMSG@(OBR),"|",5),TYPE=$S(USID["99CON":"CONSULT",1:"REQUEST") 76 S ORDIALOG=$O(^ORD(101.41,"AB","GMRCOR "_TYPE,0)) 77 D GETDLG1^ORCD(ORDIALOG) 78 S ORDIALOG($$PTR("URGENCY"),1)=ORURG 79 S OI=$$ORDITEM^ORM(USID) I 'OI S ORERR="Invalid consult or procedure" Q 80 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI 81 S ZSV=$O(@ORMSG@(OBR)) I ZSV,$E(@ORMSG@(ZSV),1,3)="ZSV" D 82 . N X1,X2 S X1=$P(@ORMSG@(ZSV),"|",2),X2=$P(@ORMSG@(ZSV),"|",3) 83 . I TYPE="REQUEST" S ORDIALOG($$PTR("REQUEST SERVICE"),1)=+$P(X1,U,4) 84 . I TYPE="CONSULT",$L(X2) S ORDIALOG($$PTR("FREE TEXT OI"),1)=X2 85 D1 S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT) 86 S J=$P(@ORMSG@(OBR),"|",19),ORDIALOG($$PTR("PLACE OF CONSULTATION"),1)=$S(J="OC":"C",1:J) 87 S ORDIALOG($$PTR("PROVIDER"),1)=$P(@ORMSG@(OBR),"|",20) 88 S OBX=OBR F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC" Q:J="MSH" I J="OBX" D 89 . N SEG,NAME,VALUE S SEG=@ORMSG@(OBX) 90 . S NAME=$$UP^XLFSTR($P($P(SEG,"|",4),U,2)),VALUE=$P(SEG,"|",6) 91 . I NAME="PROVISIONAL DIAGNOSIS" D Q 92 .. S:$P(SEG,"|",3)="CE" ORDIALOG($$PTR("CODE"),1)=$P(VALUE,U),VALUE=$P(VALUE,U,2) 93 .. S ORDIALOG($$PTR("FREE TEXT"),1)=VALUE 94 . S WP=$$PTR("WORD PROCESSING 1"),I=1,^TMP("ORWORD",$J,WP,1,I,0)=VALUE 95 . S J=0 F S J=$O(@ORMSG@(OBX,J)) Q:J'>0 S I=I+1,^TMP("ORWORD",$J,WP,1,I,0)=@ORMSG@(OBX,J) 96 S:$G(I) ^TMP("ORWORD",$J,WP,1,0)="^^"_I_U_I_U_DT_U,ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)" 97 Q 98 ; 99 OBR() ; -- Return subscript of RXE segment 100 N X,I,SEG S X="",I=+ORC 101 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="OBR" S X=I Q 102 Q X 103 ; 104 SC ; -- Status changed (i.e. scheduled) 105 S:'$G(ORSTS) ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 6=active 106 Q 107 ; 108 STATUS(X) ; -- Returns ptr to Order Status file #100.01 109 Q $S(X="DC":1,X="CM":2,X="HD":3,X="IP":5,X="SC":6,X="A":9,X="RP":12,X="CA":13,X="ZC":8,1:5) 110 ; 111 RE ; -- Completed, w/results 112 N I,SEG,DA,DR,DIE,X,Y 113 S:'$G(ORSTS) ORSTS=2 D STATUS^ORCSAVE2(+ORIFN,ORSTS) 114 S X="",DA=+ORIFN,DIE="^OR(100," 115 S DR="71////"_+$E($$NOW^XLFDT,1,12) D ^DIE 116 S I=+ORC,X="" F S I=$O(@ORMSG@(I)) Q:I<1 S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC" I $E(SEG,1,3)="OBX",$P(SEG,"|",4)["SIG FINDINGS" S X=$P(SEG,"|",6) Q 117 S $P(^OR(100,DA,7),U,2)=$S(X="Y":1,1:"") 118 S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4) 119 I $P(ORC,"|",17)["MAINTENANCE" Q ;group update - no CM ack needed 120 I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov 121 Q 122 ; 123 UA ; -- Unable to Accept [ack] 124 S ORDUZ="" I '$L(OREASON1),$L(OREASON) S OREASON1=OREASON 125 OC ; -- Cancelled/Denied 126 S:'$L(ORNATR) ORNATR="X" ;Rejected 127 S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_ORDUZ_U_ORLOG_U_U_OREASON1 128 D STATUS^ORCSAVE2(+ORIFN,13) I ORDCNTRL="OC" D UPDATE("DC") Q 129 UD ; -- Unable to discontinue [ack] 130 N DA S DA=$P(ORIFN,";",2) I DA D 131 . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected 132 . S:$L(OREASON1) ^OR(100,+ORIFN,8,DA,1)=OREASON1 133 Q 134 ; 135 OD ; -- Discontinued 136 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON1 137 D STATUS^ORCSAVE2(+ORIFN,1),UPDATE("DC"):$L(ORNATR) 138 Q 139 ; 140 DR ; -- Discontinued [ack] 141 D STATUS^ORCSAVE2(+ORIFN,1) 142 Q 143 ; 144 UPDATE(ORACT) ; -- continue processing 145 N ORX,ORDA,ORP 146 S ORX=$$CREATE^ORX1(ORNATR) D:ORX 147 . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON1,ORLOG,ORDUZ) 148 . I ORDA'>0 S ORERR="Cannot create new order action" Q 149 . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) 150 . D SIGSTS^ORCSAVE2(+ORIFN,ORDA) 151 . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) 152 . S $P(^OR(100,+ORIFN,3),U,7)=ORDA 153 I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 154 D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN) 155 Q 156 ; 157 PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41 158 Q $O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0)) -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMLR.m
r613 r623 1 ORMLR ; SLC/MKB - Process Lab ORM msgs ;11:59 AM 26 Jul 2000 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,92,153,174,195,243**;Dec 17, 1997;Build 242 3 EN ; -- entry point for LR messages 4 I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q 5 I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP" D Q:$L($G(ORERR)) 6 . I 'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q 7 . S ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12) 8 S OREASON=$$REASON I 'ORNATR,OREASON S ORNATR=+$P($G(^ORD(100.03,+OREASON,0)),U,7) 9 D @ORDCNTRL 10 Q 11 ; 12 STATUS(X) ; -- Returns Order Status for HL7 code X 13 N Y S Y=$S(X="DC":1,X="CM":2,X="IP":5,X="SC":6,X="ZS":9,X="CA":13,1:"") 14 Q Y 15 ; 16 OK ; -- Order accepted, LR order # assigned [ack] 17 S ^OR(100,+ORIFN,4)=PKGIFN ; LR identifier 18 D STATUS^ORCSAVE2(+ORIFN,5) ; pending 19 Q 20 ; 21 ZC ; -- Convert existing 2.5 orders to 3.0 format 22 S ORNATR="" I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D Q ;create 23 . K ORIFN D SN Q:'$G(ORIFN) S ORDCNTRL="SN" 24 . I ORSTOP,ORSTOP<$$NOW^XLFDT S $P(^OR(100,+ORIFN,3),U)=ORSTOP 25 N ORDIALOG,I,X,OBR,NTE S ORIFN=+ORIFN 26 S I=+ORC F S I=$O(@ORMSG@(I)) Q:'I S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" Q:SEG="MSH" I SEG="OBR" S OBR=I Q 27 I '$G(OBR) S ORERR="Missing OBR segment" Q 28 S ORDIALOG=+$O(^ORD(101.41,"AB","LR OTHER LAB TESTS",0)) 29 D GETDLG1^ORCD(ORDIALOG) 30 S X=$$FIND^ORM(OBR,5),X=$$ORDITEM^ORM(X) I 'X S ORERR="Invalid test" Q 31 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=X,X=$$FIND^ORM(OBR,16) 32 S ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4) 33 S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):+$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4)) 34 S X=$$FIND^ORM(OBR,28),ORDIALOG($$PTR("LAB URGENCY"),1)=+$P($P(X,U,6),";",2) 35 S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP") 36 ZC1 S NTE=$O(@ORMSG@(OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D 37 . N LCNT,WP S WP=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J) 38 . S LCNT=1,^TMP("ORWORD",$J,WP,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4) 39 . S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORWORD",$J,WP,1,LCNT,0)=@ORMSG@(NTE,I) 40 . S ^TMP("ORWORD",$J,WP,1,0)="^^"_LCNT_U_LCNT_U_DT_U 41 . S ORDIALOG(WP,1)="^TMP(""ORWORD"","_$J_","_WP_",1)" 42 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT 43 S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41," 44 D RESPONSE^ORCSAVE ; save ORDIALOG() into ^(4.5) 45 K ^TMP("ORWORD",$J) 46 Q 47 ; 48 SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg 49 N X,ORDIALOG,ORDG,OBR,NTE,CMMT,OI,LCNT,I,ORSTS,LRSUB,ORNEW,ORP 50 I ORDUZ,'$D(^VA(200,+ORDUZ,0)) S ORERR="Invalid entering person" Q 51 ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q 52 ;S LRSUB=$E($P($P(@ORMSG@(+ORC),"|",4),U,2),3,4),ORDG=$$DGRP(LRSUB) 53 S ORDIALOG="LR OTHER LAB TESTS" ; $S(LRSUB="AP",LRSUB="BB") 54 S ORDIALOG=$O(^ORD(101.41,"AB",ORDIALOG,0)) D GETDLG1^ORCD(ORDIALOG) 55 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT 56 S CMMT=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J) 57 SN1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q 58 S X=$$FIND^ORM(OBR,5),OI=$$ORDITEM^ORM(X) I 'OI S ORERR="Invalid test" Q 59 S LRSUB=$P(^ORD(101.43,OI,"LR"),U,6),ORDG=$$DGRP(LRSUB) 60 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI 61 I LRSUB="BB" S ORDIALOG($$PTR("QUANTITY"),1)=+ORQT G SN2 62 S X=$$FIND^ORM(OBR,16),ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4) 63 S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4)) 64 S X=+$P($P($$FIND^ORM(OBR,28),U,6),";",2),ORDIALOG($$PTR("LAB URGENCY"),1)=$S(X:X,1:9) 65 S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP") 66 SN2 S NTE=$O(@ORMSG@(+OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D 67 . S LCNT=1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4) 68 . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=@ORMSG@(NTE,I) 69 . S ^TMP("ORWORD",$J,CMMT,1,0)="^^"_LCNT_U_LCNT_U_DT_U,ORDIALOG(CMMT,1)="^TMP(""ORWORD"",$J,"_CMMT_",1)" 70 SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J) 71 I '$G(ORIFN) S ORERR="Cannot create new order" Q 72 ;Save DG1 and ZCL segments of HL7 message from backdoor orders 73 D BDOSTR^ORWDBA3 74 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) 75 D:ORSTOP DATES^ORCSAVE2(ORIFN,,ORSTOP) ;Start date in order itself 76 S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS) 77 I ORDCNTRL="SN",$G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) 78 S ^OR(100,ORIFN,4)=PKGIFN 79 Q 80 ; 81 PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41 82 Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) 83 ; 84 DGRP(DG) ; -- Returns Display Group ptr based on Lab section 85 N Y S:'$L($G(DG)) DG="CH" S Y=$O(^ORD(100.98,"B",DG,0)) 86 S:'Y Y=$O(^ORD(100.98,"B","LAB",0)) 87 Q Y 88 ; 89 XX ; -- Changed: NOT IN USE 90 D XX^ORMLR1 91 Q 92 ; 93 XR ; -- Changed [ack]: NOT IN USE 94 N ORIG 95 S ^OR(100,+ORIFN,4)=PKGIFN,ORIG=$P(^(3),U,5) 96 D:ORIG STATUS^ORCSAVE2(ORIG,12) 97 D STATUS^ORCSAVE2(+ORIFN,5) ; pending 98 Q 99 ; 100 ZP ; -- Purged 101 Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) 102 S $P(^OR(100,+ORIFN,4),";",1,3)=";;" I "^5^6^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,$S($P(^(4),";",5):2,1:14)) ; Remove pkg reference, sts=lapsed if still active 103 Q 104 ; 105 ZR ; -- Purged as requested [ack] 106 D DELETE^ORCSAVE2(+ORIFN) 107 Q 108 ; 109 ZU ; -- Unable to purge [ack] 110 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity 111 Q 112 ; 113 SC ; -- Status changed (collected) 114 N ORSTS D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) 115 S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) 116 S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,1,1)=$P(OREASON,U,2) 117 Q 118 ; 119 RE ; -- Completed, w/results 120 N ORSTS,ORX,I,SEG,DONE,X,Y,ORABN,ORFIND,LRSA,LRSB 121 S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) 122 S ^OR(100,+ORIFN,4)=PKGIFN,ORX="" D ;get Results D/T [from OBR] 123 . N OBR S OBR=+$O(@ORMSG@(+ORC)),X="" 124 . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23) 125 . S X=$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) 126 . S $P(^OR(100,+ORIFN,7),U)=X,^OR(100,"ARS",ORVP,9999999-X,+ORIFN)="" 127 D RR^LR7OR1(DFN,PKGIFN) 128 S ORABN="",ORFIND="" 129 I $D(^TMP("LRRR",$J)) D 130 . N IDT,DNAM,ORSLT 131 . S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,"CH",IDT)) Q:'IDT D 132 .. S DNAM=0 F S DNAM=$O(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM)) Q:'DNAM D 133 ... S ORSLT=$G(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM)) 134 ... I '$L($P(ORSLT,U,3)) Q 135 ... S ORABN=1,ORFIND=$S($L(ORFIND):(ORFIND_", "),1:"") 136 ... S ORFIND=ORFIND_$P(ORSLT,U,15)_"="_$P(ORSLT,U,2) 137 . Q 138 K ^TMP("LRRR",$J),^TMP("LRX",$J) 139 S $P(^OR(100,+ORIFN,7),U,2,3)=ORABN_U_ORFIND 140 S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4) 141 I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov 142 Q 143 ; 144 OC ; -- Cancelled 145 G:ORTYPE="ORR" UA S:ORNATR=+$O(^ORD(100.02,"C","A",0)) ORDUZ="" 146 S ^OR(100,+ORIFN,6)=ORNATR_U_ORDUZ_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80) 147 D UPDATE(1,"DC") 148 Q 149 ; 150 CR ; -- Cancelled [ack] 151 D STATUS^ORCSAVE2(+ORIFN,1) 152 Q 153 ; 154 UA ; -- Unable to accept [ack] 155 UX ; -- Unable to change [ack]: NOT IN USE 156 S:'ORNATR ORNATR=$O(^ORD(100.02,"C","X",0)) ;rejected 157 S ^OR(100,+ORIFN,6)=ORNATR_U_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80) 158 D STATUS^ORCSAVE2(+ORIFN,13) 159 UC ; -- Unable to cancel [ack] 160 DE ; -- Data Error [ack] 161 N DA S DA=$P(ORIFN,";",2) Q:'DA 162 S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected 163 S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,DA,1)=$E($P(OREASON,U,2),1,240) 164 Q 165 ; 166 UPDATE(ORSTS,ORACT) ; -- continue processing 167 N DA,ORX,ORCMMT,ORP 168 D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) 169 D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS) 170 S ORCMMT=$E($P(OREASON,U,2),1,240),ORX=$$CREATE^ORX1(ORNATR) D:ORX 171 . S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,ORCMMT,ORLOG,ORDUZ) 172 . I DA'>0 S ORERR="Cannot create new order action" Q 173 . D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR) 174 . D SIGSTS^ORCSAVE2(+ORIFN,DA) 175 . I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL) 176 . S $P(^OR(100,+ORIFN,3),U,7)=DA 177 I '$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 178 D:ORACT="DC" CANCEL^ORCSEND(+ORIFN) 179 Q 180 ; 181 REASON() ; -- Get reason from OREASON or NTE segments 182 N NTE,CMMT,X,Y,I,L 183 S NTE=+$O(@ORMSG@(+ORC)),CMMT=$P(OREASON,U,4,5) 184 G:'NTE RQ G:$E(@ORMSG@(NTE),1,3)'="NTE" RQ ; no add'l comments 185 S Y=$P(@ORMSG@(NTE),"|",4),I=0 186 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S X=$G(@ORMSG@(NTE,I)),L=$L(Y)+1+$L(X) S:L'>240 Y=Y_" "_X I L>240 S Y=Y_" "_$E(X,1,239-$L(Y)) Q 187 S $P(CMMT,U,2)=Y 188 RQ Q CMMT 1 ORMLR ; SLC/MKB - Process Lab ORM msgs ;11:59 AM 26 Jul 2000 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,92,153,174,195**;Dec 17, 1997 3 EN ; -- entry point for LR messages 4 I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q 5 I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP" D Q:$L($G(ORERR)) 6 . I 'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q 7 . S ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12) 8 S OREASON=$$REASON I 'ORNATR,OREASON S ORNATR=+$P($G(^ORD(100.03,+OREASON,0)),U,7) 9 D @ORDCNTRL 10 Q 11 ; 12 STATUS(X) ; -- Returns Order Status for HL7 code X 13 N Y S Y=$S(X="DC":1,X="CM":2,X="IP":5,X="SC":6,X="ZS":9,X="CA":13,1:"") 14 Q Y 15 ; 16 OK ; -- Order accepted, LR order # assigned [ack] 17 S ^OR(100,+ORIFN,4)=PKGIFN ; LR identifier 18 D STATUS^ORCSAVE2(+ORIFN,5) ; pending 19 Q 20 ; 21 ZC ; -- Convert existing 2.5 orders to 3.0 format 22 S ORNATR="" I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D Q ;create 23 . K ORIFN D SN Q:'$G(ORIFN) S ORDCNTRL="SN" 24 . I ORSTOP,ORSTOP<$$NOW^XLFDT S $P(^OR(100,+ORIFN,3),U)=ORSTOP 25 N ORDIALOG,I,X,OBR,NTE S ORIFN=+ORIFN 26 S I=+ORC F S I=$O(@ORMSG@(I)) Q:'I S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" Q:SEG="MSH" I SEG="OBR" S OBR=I Q 27 I '$G(OBR) S ORERR="Missing OBR segment" Q 28 S ORDIALOG=+$O(^ORD(101.41,"AB","LR OTHER LAB TESTS",0)) 29 D GETDLG1^ORCD(ORDIALOG) 30 S X=$$FIND^ORM(OBR,5),X=$$ORDITEM^ORM(X) I 'X S ORERR="Invalid test" Q 31 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=X,X=$$FIND^ORM(OBR,16) 32 S ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4) 33 S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):+$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4)) 34 S X=$$FIND^ORM(OBR,28),ORDIALOG($$PTR("LAB URGENCY"),1)=+$P($P(X,U,6),";",2) 35 S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP") 36 ZC1 S NTE=$O(@ORMSG@(OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D 37 . N LCNT,WP S WP=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J) 38 . S LCNT=1,^TMP("ORWORD",$J,WP,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4) 39 . S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORWORD",$J,WP,1,LCNT,0)=@ORMSG@(NTE,I) 40 . S ^TMP("ORWORD",$J,WP,1,0)="^^"_LCNT_U_LCNT_U_DT_U 41 . S ORDIALOG(WP,1)="^TMP(""ORWORD"","_$J_","_WP_",1)" 42 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT 43 S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41," 44 D RESPONSE^ORCSAVE ; save ORDIALOG() into ^(4.5) 45 K ^TMP("ORWORD",$J) 46 Q 47 ; 48 SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg 49 N X,ORDIALOG,ORDG,OBR,NTE,CMMT,OI,LCNT,I,ORSTS,LRSUB,ORNEW,ORP 50 I ORDUZ,'$D(^VA(200,+ORDUZ,0)) S ORERR="Invalid entering person" Q 51 ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q 52 S LRSUB=$E($P($P(@ORMSG@(+ORC),"|",4),U,2),3,4),ORDG=$$DGRP(LRSUB) 53 S ORDIALOG="LR OTHER LAB TESTS" ; $S(LRSUB="AP",LRSUB="BB") 54 S ORDIALOG=$O(^ORD(101.41,"AB",ORDIALOG,0)) D GETDLG1^ORCD(ORDIALOG) 55 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT 56 S CMMT=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J) 57 SN1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q 58 S X=$$FIND^ORM(OBR,5),OI=$$ORDITEM^ORM(X) I 'OI S ORERR="Invalid test" Q 59 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI 60 I LRSUB="BB" S ORDIALOG($$PTR("QUANTITY"),1)=+ORQT G SN2 61 S X=$$FIND^ORM(OBR,16),ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4) 62 S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4)) 63 S X=+$P($P($$FIND^ORM(OBR,28),U,6),";",2),ORDIALOG($$PTR("LAB URGENCY"),1)=$S(X:X,1:9) 64 S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP") 65 SN2 S NTE=$O(@ORMSG@(+OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D 66 . S LCNT=1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4) 67 . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=@ORMSG@(NTE,I) 68 . S ^TMP("ORWORD",$J,CMMT,1,0)="^^"_LCNT_U_LCNT_U_DT_U,ORDIALOG(CMMT,1)="^TMP(""ORWORD"",$J,"_CMMT_",1)" 69 SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J) 70 I '$G(ORIFN) S ORERR="Cannot create new order" Q 71 ;Save DG1 and ZCL segments of HL7 message from backdoor orders 72 D BDOSTR^ORWDBA3 73 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) 74 D:ORSTOP DATES^ORCSAVE2(ORIFN,,ORSTOP) ;Start date in order itself 75 S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS) 76 I ORDCNTRL="SN",$G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) 77 S ^OR(100,ORIFN,4)=PKGIFN 78 Q 79 ; 80 PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41 81 Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) 82 ; 83 DGRP(DG) ; -- Returns Display Group ptr based on Lab section 84 N Y S:'$L($G(DG)) DG="CH" S Y=$O(^ORD(100.98,"B",DG,0)) 85 S:'Y Y=$O(^ORD(100.98,"B","LAB",0)) 86 Q Y 87 ; 88 XX ; -- Changed: NOT IN USE 89 D XX^ORMLR1 90 Q 91 ; 92 XR ; -- Changed [ack]: NOT IN USE 93 N ORIG 94 S ^OR(100,+ORIFN,4)=PKGIFN,ORIG=$P(^(3),U,5) 95 D:ORIG STATUS^ORCSAVE2(ORIG,12) 96 D STATUS^ORCSAVE2(+ORIFN,5) ; pending 97 Q 98 ; 99 ZP ; -- Purged 100 Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) 101 S $P(^OR(100,+ORIFN,4),";",1,3)=";;" I "^5^6^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,$S($P(^(4),";",5):2,1:14)) ; Remove pkg reference, sts=lapsed if still active 102 Q 103 ; 104 ZR ; -- Purged as requested [ack] 105 D DELETE^ORCSAVE2(+ORIFN) 106 Q 107 ; 108 ZU ; -- Unable to purge [ack] 109 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity 110 Q 111 ; 112 SC ; -- Status changed (collected) 113 N ORSTS D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) 114 S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) 115 S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,1,1)=$P(OREASON,U,2) 116 Q 117 ; 118 RE ; -- Completed, w/results 119 N ORSTS,ORX,I,SEG,DONE,X,Y,ORABN,ORFIND,LRSA,LRSB 120 S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) 121 S ^OR(100,+ORIFN,4)=PKGIFN,ORX="" D ;get Results D/T [from OBR] 122 . N OBR S OBR=+$O(@ORMSG@(+ORC)),X="" 123 . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23) 124 . S X=$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) 125 . S $P(^OR(100,+ORIFN,7),U)=X,^OR(100,"ARS",ORVP,9999999-X,+ORIFN)="" 126 D RR^LR7OR1(DFN,PKGIFN) 127 S ORABN="",ORFIND="" 128 I $D(^TMP("LRRR",$J)) D 129 . N IDT,DNAM,ORSLT 130 . S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,"CH",IDT)) Q:'IDT D 131 .. S DNAM=0 F S DNAM=$O(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM)) Q:'DNAM D 132 ... S ORSLT=$G(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM)) 133 ... I '$L($P(ORSLT,U,3)) Q 134 ... S ORABN=1,ORFIND=$S($L(ORFIND):(ORFIND_", "),1:"") 135 ... S ORFIND=ORFIND_$P(ORSLT,U,15)_"="_$P(ORSLT,U,2) 136 . Q 137 K ^TMP("LRRR",$J),^TMP("LRX",$J) 138 S $P(^OR(100,+ORIFN,7),U,2,3)=ORABN_U_ORFIND 139 S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4) 140 I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov 141 Q 142 ; 143 OC ; -- Cancelled 144 G:ORTYPE="ORR" UA S:ORNATR=+$O(^ORD(100.02,"C","A",0)) ORDUZ="" 145 S ^OR(100,+ORIFN,6)=ORNATR_U_ORDUZ_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80) 146 D UPDATE(1,"DC") 147 Q 148 ; 149 CR ; -- Cancelled [ack] 150 D STATUS^ORCSAVE2(+ORIFN,1) 151 Q 152 ; 153 UA ; -- Unable to accept [ack] 154 UX ; -- Unable to change [ack]: NOT IN USE 155 S:'ORNATR ORNATR=$O(^ORD(100.02,"C","X",0)) ;rejected 156 S ^OR(100,+ORIFN,6)=ORNATR_U_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80) 157 D STATUS^ORCSAVE2(+ORIFN,13) 158 UC ; -- Unable to cancel [ack] 159 DE ; -- Data Error [ack] 160 N DA S DA=$P(ORIFN,";",2) Q:'DA 161 S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected 162 S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,DA,1)=$E($P(OREASON,U,2),1,240) 163 Q 164 ; 165 UPDATE(ORSTS,ORACT) ; -- continue processing 166 N DA,ORX,ORCMMT,ORP 167 D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) 168 D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS) 169 S ORCMMT=$E($P(OREASON,U,2),1,240),ORX=$$CREATE^ORX1(ORNATR) D:ORX 170 . S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,ORCMMT,ORLOG,ORDUZ) 171 . I DA'>0 S ORERR="Cannot create new order action" Q 172 . D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR) 173 . D SIGSTS^ORCSAVE2(+ORIFN,DA) 174 . I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL) 175 . S $P(^OR(100,+ORIFN,3),U,7)=DA 176 I 'ORX,'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 177 D:ORACT="DC" CANCEL^ORCSEND(+ORIFN) 178 Q 179 ; 180 REASON() ; -- Get reason from OREASON or NTE segments 181 N NTE,CMMT,X,Y,I,L 182 S NTE=+$O(@ORMSG@(+ORC)),CMMT=$P(OREASON,U,4,5) 183 G:'NTE RQ G:$E(@ORMSG@(NTE),1,3)'="NTE" RQ ; no add'l comments 184 S Y=$P(@ORMSG@(NTE),"|",4),I=0 185 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S X=$G(@ORMSG@(NTE,I)),L=$L(Y)+1+$L(X) S:L'>240 Y=Y_" "_X I L>240 S Y=Y_" "_$E(X,1,239-$L(Y)) Q 186 S $P(CMMT,U,2)=Y 187 RQ Q CMMT -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS.m
r613 r623 1 ORMPS ; SLC/MKB - Process Pharmacy ORM msgs ;02/06/2007 10:32 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,54,62,86,92,94,116,138,152,141,165,149,213,195,243**;Dec 17, 1997;Build 242 3 ; 4 EN ; -- entry point 5 I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q 6 I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q 7 N ORSTS,RXE,ZRX,ORWHO,ORNOW 8 S ORSTS=$$STATUS(ORDSTS),RXE=$$RXE,ZRX=$$ZRX D QT^ORMPS1 ;QT in RXE 9 S ORNOW=+$E($$NOW^XLFDT,1,12),ORWHO=+$P(ZRX,"|",6) S:'ORWHO ORWHO=DUZ 10 S:ORLOG ORLOG=+$E(ORLOG,1,12) ;no seconds 11 S:'$L(ORNATR) ORNATR=$P(ZRX,"|",3) S:OREASON["^" OREASON=$P(OREASON,U,5) 12 I ORNATR="D",'$L(OREASON) S OREASON="DUPLICATE" 13 D @ORDCNTRL 14 Q 15 ; 16 ZV ; -- Verified 17 N ORUSR,ORVER,ORDA,ORES,ORI 18 S ORUSR=+$P(ORC,"|",12),ORVER="N" Q:'ORUSR 19 S ORDA=+$P($G(^OR(100,+ORIFN,3)),U,7),ORES(+ORIFN_";"_ORDA)="" 20 Q:$P($G(^OR(100,+ORIFN,8,ORDA,0)),U,8) ;already verified 21 D REPLCD^ORCACT1 ;get unverified replaced orders 22 S ORI="" F S ORI=$O(ORES(ORI)) Q:ORI="" D 23 . S ORDA=+$P(ORI,";",2) 24 . D VERIFY^ORCSAVE2(+ORI,ORDA,"N",ORUSR,ORLOG) 25 Q 26 ; 27 ZP ; -- Purged 28 Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) 29 K ^OR(100,+ORIFN,4) I "^3^5^6^15^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ;Remove pkg reference, sts=lapsed if still active 30 Q 31 ; 32 ZR ; -- Purged as requested [ack] 33 D DELETE^ORCSAVE2(+ORIFN) 34 Q 35 ; 36 ZU ; -- Unable to purge [ack] 37 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ;update Last Activity 38 Q 39 ; 40 XR ; -- Changed as requested [ack] 41 N ORIG S ORIG=$P(^OR(100,+ORIFN,3),U,5) I ORIG,$P(^OR(100,ORIG,3),U,3)'=12 D STATUS^ORCSAVE2(ORIG,12) 42 OK ; -- Order accepted, PS order # assigned [ack] 43 S ^OR(100,+ORIFN,4)=PKGIFN ;PS identifier 44 D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) 45 Q 46 ; 47 ZC ; -- convert orders 48 N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT 49 I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q 50 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q 51 I 'RXE S ORERR="Missing or invalid RXE segment" Q 52 S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J) 53 D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") 54 ZC1 ; continue 55 Q:$D(ORERR) I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D Q ;create 56 . K ORIFN D SN1 Q:'$G(ORIFN) S ORDCNTRL="SN" 57 . I ORSTOP,ORSTOP<ORNOW S $P(^OR(100,ORIFN,3),U)=ORSTOP 58 S ORIFN=+ORIFN D RESPONSE^ORCSAVE K ^TMP("ORWORD",$J) 59 S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41," 60 D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP),STATUS^ORCSAVE2(ORIFN,ORSTS):ORSTS 61 Q 62 ; 63 SN ; -- New backdoor order, return OE# via NA msg 64 I $$FINISHED^ORMPS2 D RO^ORMPS2 Q ;change action instead 65 N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT,ZSC 66 I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q 67 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q 68 ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q 69 I 'RXE S ORERR="Missing or invalid RXE segment" Q 70 S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J),ORIFN 71 D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR) 72 SN1 ; save order 73 D EN^ORCSAVE I '$G(ORIFN) S ORERR="Cannot create new order" G SNQ 74 D BDOSTR^ORWDBA3 ;DG1 & ZCL data 75 S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4) I ORIG D ;set fwd/bwd ptrs 76 . S TYPE=$S(TYPE="R":2,1:1) Q:'$D(^OR(100,ORIG,0)) 77 . S $P(^OR(100,ORIFN,3),U,5)=ORIG,$P(^(3),U,11)=TYPE 78 . S $P(^OR(100,ORIG,3),U,6)=ORIFN,EVNT=$P(^(0),U,17) 79 . I $L(EVNT),TYPE=1 S $P(^OR(100,ORIFN,0),U,17)=EVNT 80 . I TYPE=2,$G(ORCAT)="I" S ORSTRT=ORLOG D PARENT^ORMPS3 ;ck if complex 81 I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS3 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,ORIFN,5)=$TR($P(ZSC,"|",2,9),"|","^") ;1 or 0 instead of [N]SC 82 SN2 D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP) 83 D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS) 84 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR) 85 ; if unsigned edit, leave ORIFN unsigned & mark ORIG as Sig Not Req'd 86 S ORSIG=1 ;$S('ORIG:1,TYPE'=1:1,$P($G(^OR(100,ORIG,8,1,0)),U,4)'=2:1,1:0) 87 D SIGSTS^ORCSAVE2(ORIFN,1):ORSIG,SIGN^ORCSAVE2(ORIG,,,5,1):'ORSIG 88 I ORDCNTRL="SN" D ;print 89 . S:ORNATR="" $P(^OR(100,ORIFN,8,1,0),U,12)="" ;CHCS/OP orders 90 . S ORP(1)=ORIFN_";1"_$S(ORNATR="":"^^^^1",$G(ORL):"^1",1:"") 91 . I ORP(1)["^" D PRINTS^ORWD1(.ORP,+$G(ORL)) 92 S ^OR(100,ORIFN,4)=PKGIFN 93 SNQ K ^TMP("ORWORD",$J) 94 Q 95 ; 96 XX ; -- Changed (new order not necessary) 97 Q:$P($G(^OR(100,+ORIFN,3)),U,3)=5 ;pending - update when finished 98 I '$$CHANGED^ORMPS2 D SC Q ;ck sts/dates only 99 RO ; -- Replacement order (finished) 100 S:ORNATR="" ORNATR="S" D RO^ORMPS2 101 Q 102 ; 103 SC ; -- Status changed (verified, expired, suspended, renewed, reinstate) 104 N OR0,OR3,ZSC,DONE S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)) 105 I "^1^13^"[(U_$P(OR3,U,3)_U),ORSTS=7 Q ;retain DC status 106 I $P(OR3,U,3)=5,ORSTS=6 D Q:$G(DONE) 107 . I $$CHANGED^ORMPS2 S ORNATR="S" D RO^ORMPS2 S DONE=1 Q 108 . I $P(ZRX,"|",7)="TPN",+$P(OR0,U,11)'=$O(^ORD(100.98,"B","TPN",0)) D 109 .. N DA,DR,DIE,ORDG S ORDG=+$O(^ORD(100.98,"B","TPN",0)) 110 .. S DA=+ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE 111 . I $P(OR3,U,11)=2,$P(OR0,U,12)="I" S ORSTRT=+$P($G(^OR(100,+ORIFN,8,1,0)),U,16) ;use Release Date for inpt renewals 112 I $P(OR0,U,12)="I",$P(ZRX,"|",4)="R",+$P(ZRX,"|",2)=+ORIFN S ORSTRT=$P(OR0,U,8) ;keep orig start when renewed 113 I ORSTS=7,ORSTOP S $P(^OR(100,+ORIFN,6),U,6)=ORSTOP ;save exp date 114 I ORSTS=1 D EXPDT 115 D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) 116 D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) 117 I ORSTS=$P(OR3,U,3),ORSTOP'=$P(OR0,U,9) D SETALL^ORDD100(+ORIFN) ;AC xrf 118 S ^OR(100,+ORIFN,4)=PKGIFN 119 I "^1^13^"[(U_$P(OR3,U,3)_U),"^3^5^6^15^"[(U_ORSTS_U) D ;reinstated 120 . I $P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="DC" S ^(2)=ORNOW_U_ORWHO ; When^Who reinstated order 121 . S I="?" F S I=$O(^OR(100,+ORIFN,8,I),-1) Q:'+I I $P(^(I,0),U,15)="" S $P(^OR(100,+ORIFN,3),U,7)=I Q ;138 Finds current action 122 . K ^OR(100,+ORIFN,6) D SETALL^ORDD100(+ORIFN) 123 D UPD^ORMPS3 ;update some responses 124 Q 125 ; 126 STATUS(X) ; -- HL7 order status 127 N Y S Y=$S(X="IP":5,X="CM":6,X="DC":1,X="ZE":7,X="HD":3,X="ZX":11,X="RP":12,X="ZZ":15,X="ZS":6,X="ZU":6,1:"") 128 Q Y 129 ; 130 DE ; -- Data Errors 131 Q 132 ; 133 UA ; -- Unable to accept [ack] 134 UX ; -- Unable to change [ack] 135 S:'$L(ORNATR) ORNATR="X" ;Rejected 136 S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORNOW_U_U_OREASON 137 I $P($G(^OR(100,+ORIFN,3)),U,11)=2 N ORIG S ORIG=$P(^(3),U,5) S:ORIG $P(^OR(100,ORIG,3),U,6)="" ;remove fwd ptr if pending renewal 138 D STATUS^ORCSAVE2(+ORIFN,13) 139 UC ; -- Unable to cancel [ack] 140 UD ; -- Unable to discontinue [ack] 141 UH ; -- Unable to hold [ack] 142 UR ; -- Unable to release hold [ack] 143 N ORDA S ORDA=+$P(ORIFN,";",2) I ORDA D 144 . S $P(^OR(100,+ORIFN,8,ORDA,0),U,15)=13 ;request rejected 145 . S:$L(OREASON) ^OR(100,+ORIFN,8,ORDA,1)=OREASON 146 Q 147 ; 148 OC ; -- Cancelled (before pharmacist's verification) 149 G:ORTYPE="ORR" UA S:ORNATR="A" ORWHO="" 150 S:'ORSTS ORSTS=13 S:ORSTS=12 ORNATR="S" 151 S $P(^OR(100,+ORIFN,6),U,1,5)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_OREASON 152 I $P($G(^OR(100,+ORIFN,3)),U,11)=2 N ORIG S ORIG=$P(^(3),U,5) S:ORIG $P(^OR(100,ORIG,3),U,6)="" ;remove fwd ptr when pending renewal cancelled 153 S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW 154 D EXPDT,UPDATE(ORSTS,"DC") 155 Q 156 ; 157 CR ; -- Cancelled [ack] 158 D EXPDT ;save exp date, if past 159 D STATUS^ORCSAVE2(+ORIFN,13) S ^OR(100,+ORIFN,4)=PKGIFN 160 Q 161 ; 162 OD ; -- Discontinued (cancelled after pharmacist's verification) 163 S:'ORSTS ORSTS=1 S:ORSTS=12 ORNATR="C" 164 I ORNATR="A" S ORWHO="" I $G(DGPMT)=3,$$MVT^DGPMOBS(DGPMDA) D XTMP^ORMEVNT ;save order# 165 S $P(^OR(100,+ORIFN,6),U,1,5)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_OREASON 166 S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW 167 D EXPDT,UPDATE(ORSTS,"DC") 168 Q 169 ; 170 DR ; -- Discontinued [ack] 171 D EXPDT ;save exp date, if past 172 D STATUS^ORCSAVE2(+ORIFN,1) S ^OR(100,+ORIFN,4)=PKGIFN 173 Q 174 ; 175 EXPDT ; -- save exp date when dc'd 176 N STOP S STOP=$P($G(^OR(100,+ORIFN,0)),U,9) 177 I STOP,STOP<ORNOW,'$P($G(^OR(100,+ORIFN,6)),U,6) S $P(^(6),U,6)=STOP 178 Q 179 ; 180 OH ; -- Held 181 S:'ORSTS ORSTS=3 D UPDATE(ORSTS,"HD") 182 Q 183 ; 184 HR ; -- Held [ack] 185 D STATUS^ORCSAVE2(+ORIFN,3) 186 Q 187 ; 188 RL ; -- Released hold 189 OE ; -- Released hold 190 N ORDA S ORDA=+$P(^OR(100,+ORIFN,3),U,7) 191 I $P($G(^OR(100,+ORIFN,8,ORDA,0)),U,2)="HD" S $P(^(2),U,1,2)=ORNOW_U_ORWHO 192 S:'$G(ORSTS) ORSTS=6 D UPDATE(ORSTS,"RL") 193 Q 194 ; 195 OR ; -- Released / [ack] 196 S:'ORSTS ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS) 197 D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) 198 Q 199 ; 200 UPDATE(ORSTS,ORACT) ; -- continue 201 N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS) 202 D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) 203 S ORX=$$CREATE^ORX1(ORNATR) D:ORX 204 . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORNOW,ORWHO) 205 . I ORDA'>0 S ORERR="Cannot create new order action" Q 206 . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORNOW,ORWHO,ORNATR) 207 . D SIGSTS^ORCSAVE2(+ORIFN,ORDA) 208 . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) 209 . S $P(^OR(100,+ORIFN,3),U,7)=ORDA 210 I ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 211 D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN) 212 Q 213 ; 214 RXO() ; -- RXO segment 215 N I,X S X="",I=$O(@ORMSG@(+ORC)) 216 I I,$E(@ORMSG@(I),1,3)="RXO" S X=I_U_@ORMSG@(I) 217 Q X 218 ; 219 RXE() ; -- RXE segment 220 N X,I,SEG S X="",I=+ORC 221 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXE" S X=I_U_@ORMSG@(I) Q 222 Q X 223 ; 224 RXR() ; -- RXR segment 225 N X,I,SEG S X="",I=+RXE 226 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXR" S X=I_U_@ORMSG@(I) Q 227 Q X 228 ; 229 RXC() ; -- [First] RXC segment 230 N X,I,SEG S X="",I=+RXE 231 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXC" S X=I Q 232 Q X 233 ; 234 ZRX() ; -- ZRX segment 235 N X,I,SEG S X="",I=+ORC 236 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="ZRX" S X=I_U_@ORMSG@(I) Q 237 Q X 1 ORMPS ; SLC/MKB - Process Pharmacy ORM msgs ;12/3/03 10:32 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,54,62,86,92,94,116,138,152,141,165,149,213,195**;Dec 17, 1997 3 ; 4 EN ; -- entry point 5 I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q 6 I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q 7 N ORSTS,RXE,ZRX,ORWHO,ORNOW 8 S ORSTS=$$STATUS(ORDSTS),RXE=$$RXE,ZRX=$$ZRX D QT^ORMPS1 ;QT in RXE 9 S ORNOW=+$E($$NOW^XLFDT,1,12),ORWHO=+$P(ZRX,"|",6) S:'ORWHO ORWHO=DUZ 10 S:ORLOG ORLOG=+$E(ORLOG,1,12) ;no seconds 11 S:'$L(ORNATR) ORNATR=$P(ZRX,"|",3) S:OREASON["^" OREASON=$P(OREASON,U,5) 12 I ORNATR="D",'$L(OREASON) S OREASON="DUPLICATE" 13 D @ORDCNTRL 14 Q 15 ; 16 ZV ; -- Verified 17 N ORUSR,ORVER,ORDA,ORES,ORI 18 S ORUSR=+$P(ORC,"|",12),ORVER="N" Q:'ORUSR 19 S ORDA=+$P($G(^OR(100,+ORIFN,3)),U,7),ORES(+ORIFN_";"_ORDA)="" 20 Q:$P($G(^OR(100,+ORIFN,8,ORDA,0)),U,8) ;already verified 21 D REPLCD^ORCACT1 ;get unverified replaced orders 22 S ORI="" F S ORI=$O(ORES(ORI)) Q:ORI="" D 23 . S ORDA=+$P(ORI,";",2) 24 . D VERIFY^ORCSAVE2(+ORI,ORDA,"N",ORUSR,ORLOG) 25 Q 26 ; 27 ZP ; -- Purged 28 Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) 29 K ^OR(100,+ORIFN,4) I "^3^5^6^15^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ;Remove pkg reference, sts=lapsed if still active 30 Q 31 ; 32 ZR ; -- Purged as requested [ack] 33 D DELETE^ORCSAVE2(+ORIFN) 34 Q 35 ; 36 ZU ; -- Unable to purge [ack] 37 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ;update Last Activity 38 Q 39 ; 40 XR ; -- Changed as requested [ack] 41 N ORIG S ORIG=$P(^OR(100,+ORIFN,3),U,5) I ORIG,$P(^OR(100,ORIG,3),U,3)'=12 D STATUS^ORCSAVE2(ORIG,12) 42 OK ; -- Order accepted, PS order # assigned [ack] 43 S ^OR(100,+ORIFN,4)=PKGIFN ;PS identifier 44 D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) 45 Q 46 ; 47 ZC ; -- convert orders 48 N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT 49 I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q 50 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q 51 I 'RXE S ORERR="Missing or invalid RXE segment" Q 52 S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J) 53 D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") 54 ZC1 ; continue 55 Q:$D(ORERR) I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D Q ;create 56 . K ORIFN D SN1 Q:'$G(ORIFN) S ORDCNTRL="SN" 57 . I ORSTOP,ORSTOP<ORNOW S $P(^OR(100,ORIFN,3),U)=ORSTOP 58 S ORIFN=+ORIFN D RESPONSE^ORCSAVE K ^TMP("ORWORD",$J) 59 S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41," 60 D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP),STATUS^ORCSAVE2(ORIFN,ORSTS):ORSTS 61 Q 62 ; 63 SN ; -- New backdoor order, return OE# via NA msg 64 I $$FINISHED^ORMPS2 D RO^ORMPS2 Q ;change action instead 65 N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT,ZSC 66 I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q 67 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q 68 ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q 69 I 'RXE S ORERR="Missing or invalid RXE segment" Q 70 S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J),ORIFN 71 D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR) 72 SN1 ; save order 73 D EN^ORCSAVE I '$G(ORIFN) S ORERR="Cannot create new order" G SNQ 74 D BDOSTR^ORWDBA3 ;DG1 & ZCL data 75 S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4) I ORIG D ;set fwd/bwd ptrs 76 . S TYPE=$S(TYPE="R":2,1:1) Q:'$D(^OR(100,ORIG,0)) 77 . S $P(^OR(100,ORIFN,3),U,5)=ORIG,$P(^(3),U,11)=TYPE 78 . S $P(^OR(100,ORIG,3),U,6)=ORIFN,EVNT=$P(^(0),U,17) 79 . I $L(EVNT),TYPE=1 S $P(^OR(100,ORIFN,0),U,17)=EVNT 80 . I TYPE=2,$G(ORCAT)="I" S ORSTRT=ORLOG D PARENT^ORMPS3 ;ck if complex 81 I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS1 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,ORIFN,5)=$TR($P(ZSC,"|",2,7),"|","^") ;1 or 0 instead of [N]SC 82 SN2 D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP) 83 D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS) 84 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR) 85 ; if unsigned edit, leave ORIFN unsigned & mark ORIG as Sig Not Req'd 86 S ORSIG=$S('ORIG:1,TYPE'=1:1,$P($G(^OR(100,ORIG,8,1,0)),U,4)'=2:1,1:0) 87 D SIGSTS^ORCSAVE2(ORIFN,1):ORSIG,SIGN^ORCSAVE2(ORIG,,,5,1):'ORSIG 88 I ORDCNTRL="SN" D ;print 89 . S:ORNATR="" $P(^OR(100,ORIFN,8,1,0),U,12)="" ;CHCS/OP orders 90 . S ORP(1)=ORIFN_";1"_$S(ORNATR="":"^^^^1",$G(ORL):"^1",1:"") 91 . I ORP(1)["^" D PRINTS^ORWD1(.ORP,+$G(ORL)) 92 S ^OR(100,ORIFN,4)=PKGIFN 93 SNQ K ^TMP("ORWORD",$J) 94 Q 95 ; 96 XX ; -- Changed (new order not necessary) 97 Q:$P($G(^OR(100,+ORIFN,3)),U,3)=5 ;pending - update when finished 98 I '$$CHANGED^ORMPS2 D SC Q ;ck sts/dates only 99 RO ; -- Replacement order (finished) 100 S:ORNATR="" ORNATR="S" D RO^ORMPS2 101 Q 102 ; 103 SC ; -- Status changed (verified, expired, suspended, renewed, reinstate) 104 N OR0,OR3,ZSC,DONE S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)) 105 I $P(OR3,U,3)=5,ORSTS=6 D Q:$G(DONE) 106 . I $$CHANGED^ORMPS2 S ORNATR="S" D RO^ORMPS2 S DONE=1 Q 107 . I $P(ZRX,"|",7)="TPN",+$P(OR0,U,11)'=$O(^ORD(100.98,"B","TPN",0)) D 108 .. N DA,DR,DIE,ORDG S ORDG=+$O(^ORD(100.98,"B","TPN",0)) 109 .. S DA=+ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE 110 . I $P(OR3,U,11)=2,$P(OR0,U,12)="I" S ORSTRT=+$P($G(^OR(100,+ORIFN,8,1,0)),U,16) ;use Release Date for inpt renewals 111 I $P(OR0,U,12)="I",$P(ZRX,"|",4)="R",+$P(ZRX,"|",2)=+ORIFN S ORSTRT=$P(OR0,U,8) ;keep orig start when renewed 112 D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) 113 D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) 114 I ORSTS=$P(OR3,U,3),ORSTOP'=$P(OR0,U,9) D SETALL^ORDD100(+ORIFN) ;AC xrf 115 S ^OR(100,+ORIFN,4)=PKGIFN 116 I "^1^13^"[(U_$P(OR3,U,3)_U),"^3^5^6^15^"[(U_ORSTS_U) D ;reinstated 117 . I $P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="DC" S ^(2)=ORNOW_U_ORWHO ; When^Who reinstated order 118 . S I="?" F S I=$O(^OR(100,+ORIFN,8,I),-1) Q:'+I I $P(^(I,0),U,15)="" S $P(^OR(100,+ORIFN,3),U,7)=I Q ;138 Finds current action 119 . K ^OR(100,+ORIFN,6) D SETALL^ORDD100(+ORIFN) 120 I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS1 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,+ORIFN,5)=$TR($P(ZSC,"|",2,7),"|","^") ;1 or 0 instead of [N]SC 121 Q 122 ; 123 STATUS(X) ; -- HL7 order status 124 N Y S Y=$S(X="IP":5,X="CM":6,X="DC":1,X="ZE":7,X="HD":3,X="ZX":11,X="RP":12,X="ZZ":15,X="ZS":6,X="ZU":6,1:"") 125 Q Y 126 ; 127 DE ; -- Data Errors 128 Q 129 ; 130 UA ; -- Unable to accept [ack] 131 UX ; -- Unable to change [ack] 132 S:'$L(ORNATR) ORNATR="X" ;Rejected 133 S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORNOW_U_U_OREASON 134 I $P($G(^OR(100,+ORIFN,3)),U,11)=2 N ORIG S ORIG=$P(^(3),U,5) S:ORIG $P(^OR(100,ORIG,3),U,6)="" ;remove fwd ptr if pending renewal 135 D STATUS^ORCSAVE2(+ORIFN,13) 136 UC ; -- Unable to cancel [ack] 137 UD ; -- Unable to discontinue [ack] 138 UH ; -- Unable to hold [ack] 139 UR ; -- Unable to release hold [ack] 140 N ORDA S ORDA=+$P(ORIFN,";",2) I ORDA D 141 . S $P(^OR(100,+ORIFN,8,ORDA,0),U,15)=13 ;request rejected 142 . S:$L(OREASON) ^OR(100,+ORIFN,8,ORDA,1)=OREASON 143 Q 144 ; 145 OC ; -- Cancelled (before pharmacist's verification) 146 G:ORTYPE="ORR" UA S:ORNATR="A" ORWHO="" 147 S:'ORSTS ORSTS=13 S:ORSTS=12 ORNATR="S" 148 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_OREASON 149 I $P($G(^OR(100,+ORIFN,3)),U,11)=2 N ORIG S ORIG=$P(^(3),U,5) S:ORIG $P(^OR(100,ORIG,3),U,6)="" ;remove fwd ptr when pending renewal cancelled 150 S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW 151 D UPDATE(ORSTS,"DC") 152 Q 153 ; 154 CR ; -- Cancelled [ack] 155 D STATUS^ORCSAVE2(+ORIFN,13) S ^OR(100,+ORIFN,4)=PKGIFN 156 Q 157 ; 158 OD ; -- Discontinued (cancelled after pharmacist's verification) 159 S:'ORSTS ORSTS=1 S:ORSTS=12 ORNATR="C" 160 I ORNATR="A" S ORWHO="" I $G(DGPMT)=3,$$MVT^DGPMOBS(DGPMDA) D XTMP^ORMEVNT ;save order# 161 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_OREASON 162 S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW 163 D UPDATE(ORSTS,"DC") 164 Q 165 ; 166 DR ; -- Discontinued [ack] 167 D STATUS^ORCSAVE2(+ORIFN,1) S ^OR(100,+ORIFN,4)=PKGIFN 168 Q 169 ; 170 OH ; -- Held 171 S:'ORSTS ORSTS=3 D UPDATE(ORSTS,"HD") 172 Q 173 ; 174 HR ; -- Held [ack] 175 D STATUS^ORCSAVE2(+ORIFN,3) 176 Q 177 ; 178 RL ; -- Released hold 179 OE ; -- Released hold 180 N ORDA S ORDA=+$P(^OR(100,+ORIFN,3),U,7) 181 I $P($G(^OR(100,+ORIFN,8,ORDA,0)),U,2)="HD" S $P(^(2),U,1,2)=ORNOW_U_ORWHO 182 S:'$G(ORSTS) ORSTS=6 D UPDATE(ORSTS,"RL") 183 Q 184 ; 185 OR ; -- Released / [ack] 186 S:'ORSTS ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS) 187 D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) 188 Q 189 ; 190 UPDATE(ORSTS,ORACT) ; -- continue 191 N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS) 192 D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) 193 S ORX=$$CREATE^ORX1(ORNATR) D:ORX 194 . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORNOW,ORWHO) 195 . I ORDA'>0 S ORERR="Cannot create new order action" Q 196 . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORNOW,ORWHO,ORNATR) 197 . D SIGSTS^ORCSAVE2(+ORIFN,ORDA) 198 . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) 199 . S $P(^OR(100,+ORIFN,3),U,7)=ORDA 200 I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 201 D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN) 202 Q 203 ; 204 RXO() ; -- RXO segment 205 N I,X S X="",I=$O(@ORMSG@(+ORC)) 206 I I,$E(@ORMSG@(I),1,3)="RXO" S X=I_U_@ORMSG@(I) 207 Q X 208 ; 209 RXE() ; -- RXE segment 210 N X,I,SEG S X="",I=+ORC 211 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXE" S X=I_U_@ORMSG@(I) Q 212 Q X 213 ; 214 RXR() ; -- RXR segment 215 N X,I,SEG S X="",I=+RXE 216 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXR" S X=I_U_@ORMSG@(I) Q 217 Q X 218 ; 219 RXC() ; -- [First] RXC segment 220 N X,I,SEG S X="",I=+RXE 221 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXC" S X=I Q 222 Q X 223 ; 224 ZRX() ; -- ZRX segment 225 N X,I,SEG S X="",I=+ORC 226 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="ZRX" S X=I_U_@ORMSG@(I) Q 227 Q X -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS1.m
r613 r623 1 ORMPS1 ;SLC/MKB - Process Pharmacy ORM msgs cont ; 3/27/08 7:38am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**86,92,94,116,134,152,158,149,190,195,215,265,275,243**;Dec 17, 1997;Build 242 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 UDOSE ; -- new Unit Dose order 5 N ADMIN,QT,DRUG,INSTR,DOSE,RTE,SCH,OI,URG,WP,DUR,STR,DRGNM,X,PSOI,PSDD,S0,ID,LDOSE,XC,NTE,S0,RXR 6 S ORDIALOG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) 7 I $G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0)) 8 E S ORDG=+$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",0)) 9 S ORPKG=+$$PKG("PSJ") 10 D GETDLG1^ORCD(ORDIALOG) S QT=$G(ORQT(1)) 11 S DRUG=$$PTR("DISPENSE DRUG"),INSTR=$$PTR("INSTRUCTIONS") 12 S DOSE=$$PTR("DOSE"),RTE=$$PTR("ROUTE") 13 S SCH=$$PTR("SCHEDULE"),ADMIN=$$PTR("ADMIN TIMES") 14 S OI=$$PTR("ORDERABLE ITEM"),URG=$$PTR("URGENCY") 15 S WP=$$PTR("WORD PROCESSING 1"),DUR=$$PTR("DURATION") 16 S STR=$$PTR("STRENGTH"),DRGNM=$$PTR("DRUG NAME") 17 UD1 S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5) 18 I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q 19 S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD 20 S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5) 21 S ID=$P(QT,U),LDOSE=$P(QT,U,8) I 'ID,S0 D 22 . N UNT,PTRN S UNT=$P(S0,"&",2),PTRN="1.N1"""_UNT_"""" 23 . I LDOSE?@PTRN S $P(ID,"&",1,2)=+LDOSE_"&"_UNT Q ;pre-POE orders 24 . S:$P(PSOI,U,2)'[S0 ORDIALOG(STR,1)=$TR(S0,"&") 25 I 'ID,'S0 S ORDIALOG(DRGNM,1)=$$UNESC^ORMPS2($P(PSDD,U,2)) 26 S:$L(ID) ORDIALOG(DOSE,1)=$$UNESC^ORMPS2($P(ID,"&",1,4)_"&"_LDOSE_"&"_+PSDD_"&"_S0) 27 I LDOSE="" D I LDOSE="" S ORERR="Unable to determine instructions" Q 28 . I $G(RXC)'>0 D Q ;look for units/dose 29 .. S LDOSE=$P(ID,"&",3),X=$P(ID,"&",4) I 'LDOSE S LDOSE="" Q 30 .. S:'$L(X) X=$$UNESC^ORMPS2($P($$FIND^ORM(+RXE,7),U,5)) S:$L(X) LDOSE=LDOSE_" "_X 31 .. S ORDIALOG(DRGNM,1)=$$UNESC^ORMPS2($P(PSDD,U,2)) ;force use of DD 32 . F D Q:LDOSE'="" S RXC=$O(@ORMSG@(RXC)) Q:'RXC Q:$E(@ORMSG@(RXC),1,3)'="RXC" 33 .. S XC=@ORMSG@(RXC) Q:+$P($P(XC,"|",3),U,4)'=+PSOI 34 .. S LDOSE=$P(XC,"|",4)_$P($P(XC,"|",5),U,5) ;strength_units 35 S ORDIALOG(INSTR,1)=$$UNESC^ORMPS2(LDOSE) 36 UD2 S NTE=$$NTE^ORMPS3(21) I NTE D 37 . N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4)) 38 . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I)) 39 . S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U 40 . S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)" 41 S RXR=$$RXR^ORMPS I 'RXR S ORERR="Missing or invalid RXR segment" Q 42 S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4),ORDIALOG(URG,1)=ORURG 43 S X=$P(QT,U,2) 44 S ORDIALOG(SCH,1)=$$UNESC^ORMPS2($P(X,"&")) 45 S:$L($P(X,"&",2)) ORDIALOG(ADMIN,1)=$P(X,"&",2) 46 S X=$P(QT,U,3) I $L(X) D ;set only if previous order had duration 47 . N IFN S IFN=$S($G(ORIFN):+ORIFN,$P(ZRX,"|",2):+$P(ZRX,"|",2),1:0) 48 . S:$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) ORDIALOG(DUR,1)=$$DURATION^ORMPS3(X) 49 D DOSETEXT^ORCDPS2 ;reset Instructions text, SIG 50 D UNESCARR^ORMPS2("ORDIALOG") 51 Q 52 OUT ; -- new Outpt order 53 N OI,SIG,INSTR,DOSE,RTE,SCH,DUR,SC,STR,DRUG,PI,CONJ,PSOI,PSDD,S0,X,I,RXR,J,NTE,ZSC,CNT,PC 54 S ORDIALOG=+$O(^ORD(101.41,"AB","PSO OERR",0)) 55 S ORDG=+$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",0)) 56 S ORPKG=+$$PKG("PSO") D GETDLG1^ORCD(ORDIALOG) 57 S OI=$$PTR("ORDERABLE ITEM"),SIG=$$PTR("SIG") 58 S INSTR=$$PTR("INSTRUCTIONS"),DOSE=$$PTR("DOSE") 59 S SCH=$$PTR("SCHEDULE"),DUR=$$PTR("DURATION") 60 S RTE=$$PTR("ROUTE"),SC=$$PTR("SERVICE CONNECTED") 61 S STR=$$PTR("STRENGTH"),DRUG=$$PTR("DISPENSE DRUG") 62 S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN") 63 S PC=$$PTR("WORD PROCESSING 1") 64 S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5) 65 I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q 66 S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD 67 S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5) 68 I S0,$P(PSOI,U,2)'[S0 S ORDIALOG(STR,1)=$TR(S0,"&") 69 I 'S0,'$G(ORQT(1)) S ORDIALOG($$PTR("DRUG NAME"),1)=$$UNESC^ORMPS2($P(PSDD,U,2)) 70 OUT1 S ORDIALOG($$PTR("QUANTITY"),1)=$$FIND^ORM(+RXE,11) 71 S ORDIALOG($$PTR("REFILLS"),1)=$$FIND^ORM(+RXE,13) 72 S X=$$FIND^ORM(+RXE,23) S:$E(X)="D" X=+$E(X,2,99) 73 S:X ORDIALOG($$PTR("DAYS SUPPLY"),1)=X 74 I ZRX S X=$P(ZRX,"|",5) S:$L(X) ORDIALOG($$PTR("ROUTING"),1)=X 75 S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG F I=1:1:ORQT D 76 . S ORDIALOG(INSTR,I)=$$UNESC^ORMPS2($P(ORQT(I),U,8)),X=$P(ORQT(I),U) 77 . S:$L(X) ORDIALOG(DOSE,I)=$$UNESC^ORMPS2($P(X,"&",1,4)_"&"_$P(ORQT(I),U,8)_"&"_+PSDD_"&"_S0) 78 . S X=$P(ORQT(I),U,2) S:$L(X) ORDIALOG(SCH,I)=$$UNESC^ORMPS2(X) 79 . S X=$P(ORQT(I),U,3) S:$L(X) ORDIALOG(DUR,I)=$$DURATION^ORMPS3(X) 80 . S X=$P(ORQT(I),U,9) S:$L(X) ORDIALOG(CONJ,I)=$S(X="S":"T",1:X) 81 S RXR=$$RXR^ORMPS I RXR S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4) D 82 . S I=1,J=+RXR ;look for multiple RXR's 83 . F S J=$O(@ORMSG@(J)) Q:J'>0 S RXR=@ORMSG@(J) Q:$E(RXR,1,3)'="RXR" S I=I+1,ORDIALOG(RTE,I)=$P($P(RXR,"|",2),U,4) 84 OUT2 S NTE=$$NTE^ORMPS3(6) I NTE D ;Prov Comm ;D:'NTE PCOMM^ORMPS2 85 . S CNT=1,^TMP("ORWORD",$J,PC,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4)) 86 . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,PC,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I)) 87 . S ^TMP("ORWORD",$J,PC,1,0)="^^"_CNT_U_CNT_U_DT_U 88 . S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)",ORDIALOG(PC,"FORMAT")="@" ;keep, don't show 89 . N XCNT,XCOMM,XCOMMENT,XORCOMM,XXCNT,XORIFN 90 . S XORIFN=$G(ORIFN) S:XORIFN="" XORIFN=$P(RXR,"|",2) Q:XORIFN="" 91 . S XCOMM=$O(^OR(100,+XORIFN,4.5,"ID","COMMENT",0)) Q:XCOMM="" 92 . S XCNT=0 F S XCNT=$O(^TMP("ORWORD",$J,PC,1,XCNT)) Q:XCNT="" S XCOMMENT=^TMP("ORWORD",$J,PC,1,XCNT,0) D 93 .. S XORCOMM=$G(^OR(100,+XORIFN,4.5,XCOMM,2,XCNT,0)),XXCNT=0 94 .. I XORCOMM="" F S XXCNT=$O(^OR(100,+XORIFN,4.5,XCOMM,2,XXCNT)) Q:XXCNT="" S XORCOMM=$G(^(XXCNT,0)) Q:XORCOMM'="" 95 .. I $G(XCOMMENT)=$G(XORCOMM) S ORDIALOG(PC,"FORMAT")="@" 96 S NTE=$$NTE^ORMPS3(7) I NTE D ;Pat Instr 97 . S CNT=1,^TMP("ORWORD",$J,PI,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4)) 98 . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,PI,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I)) 99 . S ^TMP("ORWORD",$J,PI,1,0)="^^"_CNT_U_CNT_U_DT_U 100 . S ORDIALOG(PI,1)="^TMP(""ORWORD"",$J,"_PI_",1)" 101 S NTE=$$NTE^ORMPS3(21) I NTE D ;Sig 102 . S CNT=1,^TMP("ORWORD",$J,SIG,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4)) 103 . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,SIG,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I)) 104 . S ^TMP("ORWORD",$J,SIG,1,0)="^^"_CNT_U_CNT_U_DT_U 105 . S ORDIALOG(SIG,1)="^TMP(""ORWORD"",$J,"_SIG_",1)" 106 . S ORDIALOG(PI,"FORMAT")="@" ;PI already included in Sig 107 OUT3 I '$G(ORQT(1))!('NTE) D DOSETEXT^ORCDPS2 ;reset Instructions text, Sig 108 S ZSC=$$ZSC^ORMPS3,X=$P(ZSC,"|",2) I X?2.3U S ORDIALOG(SC,1)=$S(X="SC":1,1:0) 109 Q 110 IV ; -- new IV order 111 N IVTYP,IVTYPE S IVTYP=$P(ZRX,"|",7) I IVTYP="",$$NUMADDS^ORMPS3'>1 G UDOSE 112 N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,X,X1,X2,I,J,TYPE,OI,WP,NTE,SCH,DAYS,ROUTE,ADMIN 113 N RXR 114 S ORDIALOG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0)) 115 I +$G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0)) 116 E S ORDG=+$O(^ORD(100.98,"B",$S($P(ZRX,"|",7)="TPN":"TPN",1:"IV RX"),0)) 117 S ORPKG=+$$PKG("PSJ") D GETDLG1^ORCD(ORDIALOG) 118 S SOLN=$$PTR("ORDERABLE ITEM"),VOL=$$PTR("VOLUME"),SCH=$$PTR("SCHEDULE") 119 S RATE=$$PTR("INFUSION RATE") S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG 120 S WP=$$PTR("WORD PROCESSING 1"),ADDS=$$PTR("ADDITIVE") 121 S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS") 122 S DAYS=$$PTR("DURATION"),IVTYPE=$$PTR("IV TYPE"),ADMIN=$$PTR("ADMIN TIMES") 123 IV1 S NTE=$$NTE^ORMPS3(21) I NTE D 124 . N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4)) 125 . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I)) 126 . S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U 127 . S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)" 128 N ORDAYS S ORDAYS="" 129 S:$D(RXO) ORDAYS=$P($P(RXO,"|",2),"^",3) 130 S:$L(ORDAYS) ORDAYS=$$IVLIM^ORMPS2(ORDAYS) 131 S:$L(ORDAYS) ORDIALOG(DAYS,1)=ORDAYS 132 S ORDIALOG(IVTYPE,1)=IVTYP 133 S X=$P($$FIND^ORM(+RXE,25),U,5) 134 S ORDIALOG(RATE,1)=$$FIND^ORM(+RXE,24)_$S($L(X):" "_X,1:""),(I,J)=0 135 F D S RXC=$O(@ORMSG@(RXC)) Q:'RXC Q:$E(@ORMSG@(RXC),1,3)'="RXC" 136 . S X=@ORMSG@(RXC),TYPE=$P(X,"|",2),OI=$$ORDITEM^ORM($P(X,"|",3)) Q:'OI 137 . S X1=$P(X,"|",4),X2=$P($P(X,"|",5),U,5) 138 . I $E(TYPE)="B" S J=J+1,ORDIALOG(SOLN,J)=OI,ORDIALOG(VOL,J)=X1 Q 139 . S I=I+1,ORDIALOG(ADDS,I)=OI,ORDIALOG(STR,I)=X1,ORDIALOG(UNITS,I)=X2 140 IV2 ; 141 S RXR=$$RXR^ORMPS 142 S ROUTE=$P(RXR,"|",2) 143 S ORDIALOG($$PTR("ROUTE"),1)=$P(ROUTE,U,4) 144 I IVTYP="I" S X=$P($G(ORQT(1)),U,2) D 145 .S:$L($P(X,"&")) ORDIALOG(SCH,1)=$P(X,"&") 146 .S:$L($P(X,"&",2)) ORDIALOG(ADMIN,1)=$P(X,"&",2) 147 D UNESCARR^ORMPS2("ORDIALOG") 148 Q 149 PKG(NMSP) ; -- Return Package file ptr for NMSP 150 N I S I=0 151 F S I=+$O(^DIC(9.4,"C",NMSP,I)) Q:I<1 Q:'$O(^(I,0)) ;no Addl Prefs 152 Q I 153 PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41 154 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) 155 QT ; -- Unpiece the Q/T field from RXE 156 I 'RXE S ORQT(1)=ORQT,ORQT=1 Q ; nothing to reset 157 N X,Y,I,J,P,SEG,DONE K ORQT 158 S SEG=$G(@ORMSG@(+RXE)),X=$P(SEG,"|",2),(I,J,P,DONE)=0 159 F D Q:DONE 160 . S P=P+1,Y=$P(X,"~",P) I Y="" S DONE=1 Q 161 . I P<$L(X,"~") S I=I+1,ORQT(I)=Y Q 162 . I $L(SEG,"|")>2 S I=I+1,ORQT(I)=Y,DONE=1 Q 163 . S J=+$O(@ORMSG@(+RXE,J)) I J'>0 S I=I+1,ORQT(I)=Y,DONE=1 Q 164 . S SEG=$G(@ORMSG@(+RXE,J)),X=$P(SEG,"|"),P=1,I=I+1,ORQT(I)=Y_$P(X,"~") 165 S ORQT=I Q:'ORQT ; else reset ORSTRT, ORSTOP, ORURG 166 S ORSTRT=$P(ORQT(1),U,4),ORSTOP=$P(ORQT(ORQT),U,5),ORURG=$P(ORQT(1),U,6) 167 S:ORSTRT ORSTRT=$$FMDATE^ORM(ORSTRT) S:ORSTOP ORSTOP=$$FMDATE^ORM(ORSTOP) S:$L(ORURG) ORURG=$$URGENCY^ORM(ORURG) 168 Q 1 ORMPS1 ;SLC/MKB - Process Pharmacy ORM msgs cont ;12/9/04 12:01 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**86,92,94,116,134,152,158,149,190,195,215,265,275**;Dec 17, 1997;Build 7 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 UDOSE ; -- new Unit Dose order 5 N QT,DRUG,INSTR,DOSE,RTE,SCH,OI,URG,WP,DUR,STR,DRGNM,X,PSOI,PSDD,S0,ID,LDOSE,XC,NTE,S0,RXR 6 S ORDIALOG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) 7 I $G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0)) 8 E S ORDG=+$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",0)) 9 S ORPKG=+$$PKG("PSJ") 10 D GETDLG1^ORCD(ORDIALOG) S QT=$G(ORQT(1)) 11 S DRUG=$$PTR("DISPENSE DRUG"),INSTR=$$PTR("INSTRUCTIONS") 12 S DOSE=$$PTR("DOSE"),RTE=$$PTR("ROUTE"),SCH=$$PTR("SCHEDULE") 13 S OI=$$PTR("ORDERABLE ITEM"),URG=$$PTR("URGENCY") 14 S WP=$$PTR("WORD PROCESSING 1"),DUR=$$PTR("DURATION") 15 S STR=$$PTR("STRENGTH"),DRGNM=$$PTR("DRUG NAME") 16 UD1 S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5) 17 I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q 18 S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD 19 S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5) 20 S ID=$P(QT,U),LDOSE=$P(QT,U,8) I 'ID,S0 D 21 . N UNT,PTRN S UNT=$P(S0,"&",2),PTRN="1.N1"""_UNT_"""" 22 . I LDOSE?@PTRN S $P(ID,"&",1,2)=+LDOSE_"&"_UNT Q ;pre-POE orders 23 . S:$P(PSOI,U,2)'[S0 ORDIALOG(STR,1)=$TR(S0,"&") 24 I 'ID,'S0 S ORDIALOG(DRGNM,1)=$P(PSDD,U,2) 25 S:$L(ID) ORDIALOG(DOSE,1)=$P(ID,"&",1,4)_"&"_LDOSE_"&"_+PSDD_"&"_S0 26 I LDOSE="" D I LDOSE="" S ORERR="Unable to determine instructions" Q 27 . I $G(RXC)'>0 D Q ;look for units/dose 28 .. S LDOSE=$P(ID,"&",3),X=$P(ID,"&",4) I 'LDOSE S LDOSE="" Q 29 .. S:'$L(X) X=$P($$FIND^ORM(+RXE,7),U,5) S:$L(X) LDOSE=LDOSE_" "_X 30 .. S ORDIALOG(DRGNM,1)=$P(PSDD,U,2) ;force use of DD 31 . F D Q:LDOSE'="" S RXC=$O(@ORMSG@(RXC)) Q:'RXC Q:$E(@ORMSG@(RXC),1,3)'="RXC" 32 .. S XC=@ORMSG@(RXC) Q:+$P($P(XC,"|",3),U,4)'=+PSOI 33 .. S LDOSE=$P(XC,"|",4)_$P($P(XC,"|",5),U,5) ;strength_units 34 S ORDIALOG(INSTR,1)=LDOSE 35 UD2 S NTE=$$NTE(21) I NTE D 36 . N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$P(@ORMSG@(NTE),"|",4) 37 . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=@ORMSG@(NTE,I) 38 . S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U 39 . S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)" 40 S RXR=$$RXR^ORMPS I 'RXR S ORERR="Missing or invalid RXR segment" Q 41 S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4),ORDIALOG(URG,1)=ORURG 42 S ORDIALOG(SCH,1)=$P(QT,U,2),X=$P(QT,U,3) 43 I $L(X) D ;set only if previous order had duration 44 . N IFN S IFN=$S($G(ORIFN):+ORIFN,$P(ZRX,"|",2):+$P(ZRX,"|",2),1:0) 45 . S:$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) ORDIALOG(DUR,1)=$$DURATION(X) 46 D DOSETEXT^ORCDPS2 ;reset Instructions text, SIG 47 Q 48 OUT ; -- new Outpt order 49 N OI,SIG,INSTR,DOSE,RTE,SCH,DUR,SC,STR,DRUG,PI,CONJ,PSOI,PSDD,S0,X,I,RXR,J,NTE,ZSC,CNT,PC 50 S ORDIALOG=+$O(^ORD(101.41,"AB","PSO OERR",0)) 51 S ORDG=+$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",0)) 52 S ORPKG=+$$PKG("PSO") D GETDLG1^ORCD(ORDIALOG) 53 S OI=$$PTR("ORDERABLE ITEM"),SIG=$$PTR("SIG") 54 S INSTR=$$PTR("INSTRUCTIONS"),DOSE=$$PTR("DOSE") 55 S SCH=$$PTR("SCHEDULE"),DUR=$$PTR("DURATION") 56 S RTE=$$PTR("ROUTE"),SC=$$PTR("SERVICE CONNECTED") 57 S STR=$$PTR("STRENGTH"),DRUG=$$PTR("DISPENSE DRUG") 58 S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN") 59 S PC=$$PTR("WORD PROCESSING 1") 60 S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5) 61 I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q 62 S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD 63 S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5) 64 I S0,$P(PSOI,U,2)'[S0 S ORDIALOG(STR,1)=$TR(S0,"&") 65 I 'S0,'$G(ORQT(1)) S ORDIALOG($$PTR("DRUG NAME"),1)=$P(PSDD,U,2) 66 OUT1 S ORDIALOG($$PTR("QUANTITY"),1)=$$FIND^ORM(+RXE,11) 67 S ORDIALOG($$PTR("REFILLS"),1)=$$FIND^ORM(+RXE,13) 68 S X=$$FIND^ORM(+RXE,23) S:$E(X)="D" X=+$E(X,2,99) 69 S:X ORDIALOG($$PTR("DAYS SUPPLY"),1)=X 70 I ZRX S X=$P(ZRX,"|",5) S:$L(X) ORDIALOG($$PTR("ROUTING"),1)=X 71 S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG F I=1:1:ORQT D 72 . S ORDIALOG(INSTR,I)=$P(ORQT(I),U,8),X=$P(ORQT(I),U) 73 . S:$L(X) ORDIALOG(DOSE,I)=$P(X,"&",1,4)_"&"_$P(ORQT(I),U,8)_"&"_+PSDD_"&"_S0 74 . S X=$P(ORQT(I),U,2) S:$L(X) ORDIALOG(SCH,I)=X 75 . S X=$P(ORQT(I),U,3) S:$L(X) ORDIALOG(DUR,I)=$$DURATION(X) 76 . S X=$P(ORQT(I),U,9) S:$L(X) ORDIALOG(CONJ,I)=$S(X="S":"T",1:X) 77 S RXR=$$RXR^ORMPS I RXR S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4) D 78 . S I=1,J=+RXR ;look for multiple RXR's 79 . F S J=$O(@ORMSG@(J)) Q:J'>0 S RXR=@ORMSG@(J) Q:$E(RXR,1,3)'="RXR" S I=I+1,ORDIALOG(RTE,I)=$P($P(RXR,"|",2),U,4) 80 OUT2 S NTE=$$NTE(6) D:'NTE PCOMM^ORMPS2 I NTE D ;Prov Comm 81 . S CNT=1,^TMP("ORWORD",$J,PC,1,CNT,0)=$P(@ORMSG@(NTE),"|",4) 82 . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,PC,1,CNT,0)=@ORMSG@(NTE,I) 83 . S ^TMP("ORWORD",$J,PC,1,0)="^^"_CNT_U_CNT_U_DT_U 84 . S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)" 85 . N XCNT,XCOMM,XCOMMENT,XORCOMM,XXCNT,XORIFN 86 . S (XCOMM,XORCOMM)="" 87 . S XORIFN=$G(ORIFN) I XORIFN="" S XORIFN=$P(RXR,"|",2) 88 . Q:XORIFN="" 89 . S XCOMM=$O(^OR(100,+XORIFN,4.5,"ID","COMMENT",XCOMM)) Q:XCOMM="" 90 . S XCNT=0 F S XCNT=$O(^TMP("ORWORD",$J,PC,1,XCNT)) Q:XCNT="" S XCOMMENT=$G(^TMP("ORWORD",$J,PC,1,XCNT,0)) D 91 . . S XORCOMM=$G(^OR(100,+XORIFN,4.5,XCOMM,2,XCNT,0)) 92 . . S XXCNT=0 93 . . I XORCOMM="" F S XXCNT=$O(^OR(100,+XORIFN,4.5,XCOMM,2,XXCNT)) Q:XXCNT="" S XORCOMM=$G(^OR(100,+XORIFN,4.5,XCOMM,2,XXCNT,0)) Q:XORCOMM'="" 94 . . I $G(XCOMMENT)=$G(XORCOMM) S ORDIALOG(PC,"FORMAT")="@" 95 S NTE=$$NTE(7) I NTE D ;Pat Instr 96 . S CNT=1,^TMP("ORWORD",$J,PI,1,CNT,0)=$P(@ORMSG@(NTE),"|",4) 97 . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,PI,1,CNT,0)=@ORMSG@(NTE,I) 98 . S ^TMP("ORWORD",$J,PI,1,0)="^^"_CNT_U_CNT_U_DT_U 99 . S ORDIALOG(PI,1)="^TMP(""ORWORD"",$J,"_PI_",1)" 100 S NTE=$$NTE(21) I NTE D ;Sig 101 . S CNT=1,^TMP("ORWORD",$J,SIG,1,CNT,0)=$P(@ORMSG@(NTE),"|",4) 102 . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,SIG,1,CNT,0)=@ORMSG@(NTE,I) 103 . S ^TMP("ORWORD",$J,SIG,1,0)="^^"_CNT_U_CNT_U_DT_U 104 . S ORDIALOG(SIG,1)="^TMP(""ORWORD"",$J,"_SIG_",1)" 105 . S ORDIALOG(PI,"FORMAT")="@" ;PI already included in Sig 106 OUT3 I '$G(ORQT(1))!('NTE) D DOSETEXT^ORCDPS2 ;reset Instructions text, Sig 107 S ZSC=$$ZSC,X=$P(ZSC,"|",2) I X?2.3U S ORDIALOG(SC,1)=$S(X="SC":1,1:0) 108 Q 109 IV ; -- new IV order 110 N IVTYP S IVTYP=$P(ZRX,"|",7) I IVTYP="",$$NUMADDS'>1 G UDOSE 111 N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,X,X1,X2,I,J,TYPE,OI,WP,NTE,SCH,DAYS 112 S ORDIALOG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0)) 113 I +$G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0)) 114 E S ORDG=+$O(^ORD(100.98,"B",$S($P(ZRX,"|",7)="TPN":"TPN",1:"IV RX"),0)) 115 S ORPKG=+$$PKG("PSJ") D GETDLG1^ORCD(ORDIALOG) 116 S SOLN=$$PTR("ORDERABLE ITEM"),VOL=$$PTR("VOLUME"),SCH=$$PTR("SCHEDULE") 117 S RATE=$$PTR("INFUSION RATE") S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG 118 S WP=$$PTR("WORD PROCESSING 1"),ADDS=$$PTR("ADDITIVE") 119 S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS") 120 S DAYS=$$PTR("DURATION") 121 IV1 S NTE=$$NTE(21) I NTE D 122 . N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$P(@ORMSG@(NTE),"|",4) 123 . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=@ORMSG@(NTE,I) 124 . S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U 125 . S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)" 126 N ORDAYS S ORDAYS="" 127 S:$D(RXO) ORDAYS=$P($P(RXO,"|",2),"^",3) 128 S:$L(ORDAYS) ORDAYS=$$IVLIM^ORMPS2(ORDAYS) 129 S:$L(ORDAYS) ORDIALOG(DAYS,1)=ORDAYS 130 S X=$P($$FIND^ORM(+RXE,25),U,5) 131 S ORDIALOG(RATE,1)=$$FIND^ORM(+RXE,24)_$S($L(X):" "_X,1:""),(I,J)=0 132 F D S RXC=$O(@ORMSG@(RXC)) Q:'RXC Q:$E(@ORMSG@(RXC),1,3)'="RXC" 133 . S X=@ORMSG@(RXC),TYPE=$P(X,"|",2),OI=$$ORDITEM^ORM($P(X,"|",3)) Q:'OI 134 . S X1=$P(X,"|",4),X2=$P($P(X,"|",5),U,5) 135 . I $E(TYPE)="B" S J=J+1,ORDIALOG(SOLN,J)=OI,ORDIALOG(VOL,J)=X1 Q 136 . S I=I+1,ORDIALOG(ADDS,I)=OI,ORDIALOG(STR,I)=X1,ORDIALOG(UNITS,I)=X2 137 I IVTYP="" S X=$P($G(ORQT(1)),U,2) S:$L(X) ORDIALOG(SCH,1)=X 138 Q 139 NTE(ID) ; -- Return subscript of NTE segment for RXE-<ID> 140 N I,SEG,Y S Y="",I=+RXE S:'$G(ID) ID=21 141 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=@ORMSG@(I) Q:$E(SEG,1,3)="ORC" I $P(SEG,"|",1,2)=("NTE|"_ID) S Y=I Q 142 Q Y 143 ZSC() ; -- Return subscript of ZSC segment 144 N I,SEG,Y S Y="",I=+RXE 145 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="ZSC" S Y=I_U_@ORMSG@(I) Q 146 Q Y 147 NUMADDS() ; -- count number of additives to determine type 148 N CNT,I,X S CNT=0,I=+RXE 149 F S I=$O(@ORMSG@(I)) Q:I'>0 S X=@ORMSG@(I) Q:$P(X,"|")="ORC" I $E(X,1,6)="RXC|A|" S CNT=CNT+1 150 Q CNT 151 PKG(NMSP) ; -- Return Package file ptr for NMSP 152 N I S I=0 153 F S I=+$O(^DIC(9.4,"C",NMSP,I)) Q:I<1 Q:'$O(^(I,0)) ;no Addl Prefs DBIA #2058 154 Q I 155 PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41 156 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) 157 DURATION(X) ; -- Returns "# units" from U# format 158 N Y,Y1,Y2 I X'?.1U1.N Q "" 159 S Y1=$E(X),Y2=+$E(X,2,$L(X)) I X=+X S Y1="D",Y2=+X 160 S Y=Y2_" "_$S(Y1="L":"MONTH",Y1="W":"WEEK",Y1="H":"HOUR",Y1="M":"MINUTE",Y1="S":"SECOND",1:"DAY")_$S(Y2>1:"S",1:"") 161 Q Y 162 QT ; -- Unpiece the Q/T field from RXE 163 I 'RXE S ORQT(1)=ORQT,ORQT=1 Q ; nothing to reset 164 N X,Y,I,J,P,SEG,DONE K ORQT 165 S SEG=$G(@ORMSG@(+RXE)),X=$P(SEG,"|",2),(I,J,P,DONE)=0 166 F D Q:DONE 167 . S P=P+1,Y=$P(X,"~",P) I Y="" S DONE=1 Q 168 . I P<$L(X,"~") S I=I+1,ORQT(I)=Y Q 169 . I $L(SEG,"|")>2 S I=I+1,ORQT(I)=Y,DONE=1 Q 170 . S J=+$O(@ORMSG@(+RXE,J)) I J'>0 S I=I+1,ORQT(I)=Y,DONE=1 Q 171 . S SEG=$G(@ORMSG@(+RXE,J)),X=$P(SEG,"|"),P=1,I=I+1,ORQT(I)=Y_$P(X,"~") 172 S ORQT=I Q:'ORQT ; else reset ORSTRT, ORSTOP, ORURG 173 S ORSTRT=$P(ORQT(1),U,4),ORSTOP=$P(ORQT(ORQT),U,5),ORURG=$P(ORQT(1),U,6) 174 S:ORSTRT ORSTRT=$$FMDATE^ORM(ORSTRT) S:ORSTOP ORSTOP=$$FMDATE^ORM(ORSTOP) S:$L(ORURG) ORURG=$$URGENCY^ORM(ORURG) 175 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS2.m
r613 r623 1 ORMPS2 ;SLC/MKB - Process Pharmacy ORM msgs cont ;04/01/2008 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,129,134,186,190,195,215,265,243**;Dec 17, 1997;Build 242 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 FINISHED() ; -- new order [SN^ORMPS] due to finishing? 6 N Y,ORIG,TYPE,ORIG4 S Y=0 7 S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4),ORIG4=$G(^OR(100,ORIG,4)) 8 I ORIG,TYPE="E",ORIG4?1.N1"P"!(ORIG4?1.N1"S") S ORIFN=+ORIG,Y=1 9 Q Y 10 ; 11 WPX() ; -- Compare comments in @ORMSG@(NTE) with order ORIFN 12 ; Returns 1 if different, or 0 if same 13 N NTE,SPINST,Y,X S Y=0 14 S NTE=+$$NTE^ORMPS3(21),SPINST=$S(NTE:$$NTXT^ORMPS3(NTE),1:"") 15 S X=$$VALTXT^ORMPS3(+ORIFN,"COMMENT") 16 I $TR(X," ")'=$TR(SPINST," ") S Y=1 ;comp text w/o spaces 17 WQ Q Y 18 ; 19 IVX() ; -- Compare ORMSG to Inpt order ORIFN if IV, return 0 if 'diff or 'IV 20 N Y,RXC,DG,OI,PSOI,XC,X,RATE,RXR,ORA,ORB,ORX,I,J,OI0,INST,VOL,STR,UNT 21 S RXC=$$RXC^ORMPS,Y=0 I RXC'>0 Q Y ;not IV of any kind 22 S DG=+$P($G(^OR(100,+ORIFN,0)),U,11),DG=$P($G(^ORD(100.98,DG,0)),U,3) 23 I DG'="IV RX",DG'="TPN" D Q Y ;not fluid 24 . I $P(ZRX,"|",7)'="" S Y=1 Q 25 . I $$NUMADDS^ORMPS3>1 S Y=1 Q 26 . S OI=$$VALUE("ORDERABLE"),PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) 27 . S XC=@ORMSG@(RXC) I PSOI'=$P(XC,U,4) S Y=1 Q 28 . N X1,X2,X3 S X1=$P(XC,"|",4),X2=$P($P(XC,"|",5),U,5) 29 . S X3=$$VALUE("INSTR") I (X1_X2)'=X3,(X1_" "_X2)'=X3 S Y=1 Q 30 IV1 S RATE=$$FIND^ORM(+RXE,24),UNT=$P($$FIND^ORM(+RXE,25),U,5) 31 S:$L(UNT) RATE=RATE_" "_UNT S X=$$VALUE("RATE") I RATE'=X D Q:Y Y 32 . S:RATE["@" RATE=$P(RATE,"@") S:X["@" X=$P(X,"@") ;rate@labels 33 . I RATE'=X S Y=1 Q 34 I $P(ZRX,"|",7)'=$$VALUE("TYPE") S Y=1 Q Y 35 S RXR=$$RXR^ORMPS 36 I $P($P(RXR,"|",2),U,4)'=$$VALUE("ROUTE") S Y=1 Q Y 37 S ORB=+$$PTR("ORDERABLE ITEM"),ORA=+$$PTR("ADDITIVE"),I=+RXC 38 F S XC=@ORMSG@(I) Q:$E(XC,1,3)'="RXC" D S I=$O(@ORMSG@(I)) Q:I'>0 39 . S ORX($P(XC,"|",2),+$P(XC,U,4))=$P(XC,"|",4)_U_$P($P(XC,"|",5),U,5) 40 . ;ORX("A",PSOI)=str^units or ORX("B",PSOI)=volume^units 41 F I="STRENGTH","UNITS","VOLUME" D ;ORX(I,inst)=value 42 . S J=0 F S J=$O(^OR(100,+ORIFN,4.5,"ID",I,J)) Q:J'>0 D 43 .. S INST=+$P($G(^OR(100,+ORIFN,4.5,J,0)),U,3) 44 .. S:INST ORX(I,INST)=$G(^OR(100,+ORIFN,4.5,J,1)) 45 S I=0 F S I=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D Q:Y 46 . S OI0=$G(^OR(100,+ORIFN,4.5,I,0)),OI=+$G(^(1)) 47 . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) 48 . I $P(OI0,U,2)=ORA,$G(ORX("A",PSOI)) D Q 49 .. S INST=$P(OI0,U,3),STR=+ORX("A",PSOI),UNT=$P(ORX("A",PSOI),U,2) 50 .. I STR'=$G(ORX("STRENGTH",INST)) S Y=1 Q 51 .. I UNT'=$G(ORX("UNITS",INST)) S Y=1 Q 52 .. K ORX("A",PSOI) ;same 53 . I $P(OI0,U,2)=ORB,$G(ORX("B",PSOI)) D Q 54 .. S INST=$P(OI0,U,3),VOL=+$G(ORX("B",PSOI)) 55 .. I VOL'=$G(ORX("VOLUME",INST)) S Y=1 Q 56 .. K ORX("B",PSOI) ;same 57 . S Y=1 58 I $O(ORX("A",0))!$O(ORX("B",0)) S Y=1 ;leftover items - changed 59 Q Y 60 ; 61 CHANGED() ; -- Compare ORMSG to order ORIFN, return 1 if different 62 N I,X,Y,X1,NTE,SIG,PI,TRXO S Y=0 63 I $G(ORCAT)="I" D G CHQ 64 . I $$WPX S Y=1 Q ;Special Instructions 65 . S X=$$VALUE("DAYS") ;duration 66 . I $G(X)'="" D I $G(X)'=X1 S Y=1 Q 67 . .S X=$$HL7IVLMT^ORMBLDP1(X) 68 . .S TRXO=$$RXO^ORMPS,X1=$P($P($G(TRXO),"|",2),U,3) 69 . .;S X1=$$DURATION^ORMPS3($P($P(TRXO,"|",2),U,3)) 70 . I $$IVX S Y=1 Q ;IV fields 71 ;S X=+$P($P(RXE,"|",3),U,4) I X'=+$$VALUE("DRUG") S Y=1 G CHQ 72 I +$P(RXE,"|",11)'=+$$VALUE("QTY") S Y=1 G CHQ 73 I +$P(RXE,"|",13)'=+$$VALUE("REFILLS") S Y=1 G CHQ 74 ;S X=$P(RXE,"|",23) S:$E(X)="D" X=+$E(X,2,99) I X'=+$$VALUE("SUPPLY") S Y=1 G CHQ 75 ;I $P(ZRX,"|",5)'=$$VALUE("PICKUP") S Y=1 G CHQ 76 S NTE=$$NTE^ORMPS3(21),SIG=+$O(^OR(100,+ORIFN,4.5,"ID","SIG",0)) ;verb 77 I NTE,SIG,$P($P(@ORMSG@(NTE),"|",4)," ")'=$P($G(^OR(100,+ORIFN,4.5,SIG,2,1,0))," ") S Y=1 G CHQ 78 S NTE=$$NTE^ORMPS3(7),PI=+$O(^OR(100,+ORIFN,4.5,"ID","PI",0)) 79 I (NTE&'PI)!('NTE&PI) Q 1 ;added or deleted 80 I NTE,PI D G CHQ ;compare text 81 . S PI=$$VALTXT^ORMPS3(+ORIFN,PI)_$$VALTXT^ORMPS3(+ORIFN,"COMMENT") 82 . S NTE=$$NTXT^ORMPS3(NTE) 83 . I $TR(NTE," ")'=$TR(PI," ") S Y=1 Q ;comp text w/o spaces 84 CHQ Q Y 85 ; 86 VALUE(ID) ; -- Return value of ID in ^OR(100,+ORIFN,4.5,"ID") 87 N I,Y I '$L($G(ID)) Q "" 88 S I=+$O(^OR(100,+ORIFN,4.5,"ID",ID,0)) 89 S Y=$G(^OR(100,+ORIFN,4.5,I,1)) 90 Q Y 91 ; 92 PTR(X) ; -- Return ptr to prompt OR GTX X 93 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) 94 ; 95 RO ; -- Replacement order (finished) 96 N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORDA,ORX,ORSIG,ORP,ZSC,NEWSTS 97 N ADMIN,IVTYPE 98 K ^TMP("ORWORD",$J) 99 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q 100 I 'RXE S ORERR="Missing or invalid RXE segment" Q 101 S RXO=$$RXO^ORMPS,RXC=$$RXC^ORMPS,ORIFN=+$G(ORIFN) 102 I ORIFN'>0 S ORERR="Missing or invalid order number" Q 103 D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR) 104 ;Check keep Admin Time with order if not define in the RXE segment on 105 ;verify 106 I RXC,$$VALUE("TYPE")="I" S ORDIALOG($$PTR("ADMIN TIMES"),1)=$$VALUE("ADMIN") 107 S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,"",ORNOW,ORWHO) 108 I ORDA'>0 S ORERR="Cannot create new order action" Q 109 RO1 ; -Update sts of order to active, last action to dc/edit: 110 S ORX=ORDA F S ORX=+$O(^OR(100,ORIFN,8,ORX),-1) Q:ORX'>0 I $D(^(ORX,0)),$P(^(0),U,15)="" Q ;ORX=last released action 111 S:ORX $P(^OR(100,ORIFN,8,ORX,0),U,15)=12 ;dc/edit 112 S $P(^OR(100,ORIFN,3),U,7)=ORDA,NEWSTS=$S('$G(ORSTS):0,ORSTS=$P(^(3),U,3):0,1:1) K ^(6) 113 D STATUS^ORCSAVE2(ORIFN,ORSTS):NEWSTS,SETALL^ORDD100(ORIFN):'NEWSTS 114 D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP) 115 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORWHO,ORNATR) 116 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd 117 S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0) 118 D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG 119 RO2 ; -Update responses, get/save new order text: 120 K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA) 121 S $P(^OR(100,ORIFN,0),U,5)=ORDIALOG_";ORD(101.41,",$P(^(0),U,14)=ORPKG 122 ;I $P(^OR(100,ORIFN,0),U,11)'=ORDG D ;update DG,xrefs 123 ;AGP Changes to handle IMO IV orders CPRS 26v43 124 I $P(^OR(100,ORIFN,0),U,11)'=ORDG,$P(^OR(100,ORIFN,0),U,11)'=$O(^ORD(100.98,"B","CLINIC ORDERS","")) D 125 . N DA,DR,DIE 126 . S DA=ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE 127 S ^OR(100,ORIFN,4)=PKGIFN,$P(^(8,ORDA,0),U,14)=ORDA 128 S ORIFN=ORIFN_";"_ORDA,ORDCNTRL="SN" ;to send NA msg back 129 I $G(ORL) S ORP(1)=ORIFN_"^1" D PRINTS^ORWD1(.ORP,+ORL) 130 I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS3 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,+ORIFN,5)=$TR($P(ZSC,"|",2,9),"|","^") ;1 or 0 instead of [N]SC in #100 131 Q 132 IVLIM(IVDUR) ; 133 I $L(IVDUR) D 134 . N DURU,DURV S DURU="",DURV=0 135 . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR)) 136 . I IVDUR["dose" S DURV=$E(IVDUR,6,$L(IVDUR)),IVDUR="for a total of "_+DURV_$S(+DURV=1:" doses",+DURV>1:" doses",1:" dose") Q 137 . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day") 138 . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour") 139 . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml" 140 . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L" 141 Q IVDUR 142 UNESC(STRING) ; 143 Q $$UNESC^ORHLESC(STRING) 144 UNESCARR(ARR) ; 145 N I S I="" F S I=$O(@ARR@(I)) Q:'$L(I) D 146 .N IND S IND=$S(ARR["(":$E(ARR,0,$L(ARR)-1)_","""_I_""")",1:ARR_"("""_I_""")") 147 .N TYPE S TYPE=$D(@ARR@(I)) 148 .I TYPE=11!(TYPE=10) D UNESCARR(IND) 149 .I TYPE=1!(TYPE=11) S @ARR@(I)=$$UNESC(@ARR@(I)) 150 Q 151 PCOMM ; -- Get Provider Comments from previous order, when changed 152 N OLD,I 153 S OLD=+$G(ORIFN) I OLD<1 S OLD=+$P(ZRX,"|",2) Q:OLD<1 154 S I=+$O(^OR(100,OLD,4.5,"ID","COMMENT",0)) Q:I<1 155 Q:'$O(^OR(100,OLD,4.5,I,2,0)) ;none 156 M ^TMP("ORWORD",$J,PC,1)=^OR(100,OLD,4.5,I,2) 157 S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)" 158 S ORDIALOG(PC,"FORMAT")="@" ;text in Sig already 159 Q 1 ORMPS2 ;SLC/MKB - Process Pharmacy ORM msgs cont ; 1/26/07 11:58am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,129,134,186,190,195,215,265**;Dec 17, 1997;Build 17 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 FINISHED() ; -- new order [SN^ORMPS] due to finishing? 6 N Y,ORIG,TYPE,ORIG4 S Y=0 7 S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4),ORIG4=$G(^OR(100,ORIG,4)) 8 I ORIG,TYPE="E",ORIG4?1.N1"P"!(ORIG4?1.N1"S") S ORIFN=+ORIG,Y=1 9 Q Y 10 ; 11 WPX() ; -- Compare comments in @ORMSG@(NTE) with order ORIFN 12 ; Returns 1 if different, or 0 if same 13 N NTE,SPINST,Y,I,J,X,X1 S Y=0 14 S NTE=+$$NTE^ORMPS1(21),SPINST=$S(NTE:$P(@ORMSG@(NTE),"|",4),1:"") 15 S I=+$O(^OR(100,+ORIFN,4.5,"ID","COMMENT",0)) I I'>0 S:$L(SPINST) Y=1 G WQ 16 S X=$G(^OR(100,+ORIFN,4.5,I,2,1,0)) ;1st line 17 I '$O(^OR(100,+ORIFN,4.5,I,2,1)) S:X'=SPINST Y=1 G WQ 18 S J=1 F S J=$O(^OR(100,+ORIFN,4.5,I,2,J)) Q:J'>0 S X1=$G(^(J,0)) D Q:$L(X)'<240 19 . I ($L(X)+$L(X1)+1)'>240 S X=X_" "_X1 Q 20 . S X=X_" "_$E(X1,1,239-$L(X)) 21 S:X'=SPINST Y=1 ;changed 22 WQ Q Y 23 ; 24 IVX() ; -- Compare ORMSG to Inpt order ORIFN if IV, return 0 if 'diff or 'IV 25 N Y,RXC,DG,OI,PSOI,XC,RATE,ORA,ORB,ORX,I,J,OI0,INST,VOL,STR,UNT 26 S RXC=$$RXC^ORMPS,Y=0 I RXC'>0 Q Y ;not IV of any kind 27 S DG=+$P($G(^OR(100,+ORIFN,0)),U,11),DG=$P($G(^ORD(100.98,DG,0)),U,3) 28 I DG'="IV RX",DG'="TPN" D Q Y ;not fluid 29 . I $P(ZRX,"|",7)'="" S Y=1 Q 30 . I $$NUMADDS^ORMPS1>1 S Y=1 Q 31 . S OI=$$VALUE("ORDERABLE"),PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) 32 . S XC=@ORMSG@(RXC) I PSOI'=$P(XC,U,4) S Y=1 Q 33 . N X1,X2,X3 S X1=$P(XC,"|",4),X2=$P($P(XC,"|",5),U,5) 34 . S X3=$$VALUE("INSTR") I (X1_X2)'=X3,(X1_" "_X2)'=X3 S Y=1 Q 35 IV1 S RATE=$$FIND^ORM(+RXE,24),UNT=$P($$FIND^ORM(+RXE,25),U,5) 36 S:$L(UNT) RATE=RATE_" "_UNT I RATE'=$$VALUE("RATE") S Y=1 Q Y 37 S ORB=+$$PTR("ORDERABLE ITEM"),ORA=+$$PTR("ADDITIVE"),I=+RXC 38 F S XC=@ORMSG@(I) Q:$E(XC,1,3)'="RXC" D S I=$O(@ORMSG@(I)) Q:I'>0 39 . S ORX($P(XC,"|",2),+$P(XC,U,4))=$P(XC,"|",4)_U_$P($P(XC,"|",5),U,5) 40 . ;ORX("A",PSOI)=str^units or ORX("B",PSOI)=volume^units 41 F I="STRENGTH","UNITS","VOLUME" D ;ORX(I,inst)=value 42 . S J=0 F S J=$O(^OR(100,+ORIFN,4.5,"ID",I,J)) Q:J'>0 D 43 .. S INST=+$P($G(^OR(100,+ORIFN,4.5,J,0)),U,3) 44 .. S:INST ORX(I,INST)=$G(^OR(100,+ORIFN,4.5,J,1)) 45 S I=0 F S I=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D Q:Y 46 . S OI0=$G(^OR(100,+ORIFN,4.5,I,0)),OI=+$G(^(1)) 47 . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) 48 . I $P(OI0,U,2)=ORA,$G(ORX("A",PSOI)) D Q 49 .. S INST=$P(OI0,U,3),STR=+ORX("A",PSOI),UNT=$P(ORX("A",PSOI),U,2) 50 .. I STR'=$G(ORX("STRENGTH",INST)) S Y=1 Q 51 .. I UNT'=$G(ORX("UNITS",INST)) S Y=1 Q 52 .. K ORX("A",PSOI) ;same 53 . I $P(OI0,U,2)=ORB,$G(ORX("B",PSOI)) D Q 54 .. S INST=$P(OI0,U,3),VOL=+$G(ORX("B",PSOI)) 55 .. I VOL'=$G(ORX("VOLUME",INST)) S Y=1 Q 56 .. K ORX("B",PSOI) ;same 57 . S Y=1 58 I $O(ORX("A",0))!$O(ORX("B",0)) S Y=1 ;leftover items - changed 59 Q Y 60 ; 61 CHANGED() ; -- Compare ORMSG to order ORIFN, return 1 if different 62 N X,Y,X1,ZSC,NTE,SIG,PI S Y=0 63 I $G(ORCAT)="I" D G CHQ 64 . I $$WPX S Y=1 Q ;Special Instructions 65 . ;S X=$$VALUE("DAYS") ;duration 66 . ;I X S X1=$$DURATION^ORMPS1($P($G(ORQT(1)),U,3)) I X'=X1 S Y=1 Q 67 . I $$IVX S Y=1 Q ;IV fields 68 S X=$P($P(RXE,"|",3),U,4) I X'=$$VALUE("DRUG") S Y=1 G CHQ 69 I $P(RXE,"|",11)'=$$VALUE("QTY") S Y=1 G CHQ 70 I $P(RXE,"|",13)'=$$VALUE("REFILLS") S Y=1 G CHQ 71 S X=$P(RXE,"|",23) S:$E(X)="D" X=+$E(X,2,99) I X'=$$VALUE("SUPPLY") S Y=1 G CHQ 72 I $P(ZRX,"|",5)'=$$VALUE("PICKUP") S Y=1 G CHQ 73 S NTE=$$NTE^ORMPS1(21),SIG=+$O(^OR(100,+ORIFN,4.5,"ID","SIG",0)) ;verb 74 I NTE,SIG,$P($P(@ORMSG@(NTE),"|",4)," ")'=$P($G(^OR(100,+ORIFN,4.5,SIG,2,1,0))," ") S Y=1 G CHQ 75 S NTE=$$NTE^ORMPS1(7),PI=+$O(^OR(100,+ORIFN,4.5,"ID","PI",0)) 76 I (NTE&'PI)!('NTE&PI) Q 1 ;added or deleted 77 I NTE,PI,$P(@ORMSG@(NTE),"|",4)'=$G(^OR(100,+ORIFN,4.5,PI,2,1,0)) S Y=1 G CHQ 78 Q:'$P($G(^OR(100,+ORIFN,8,0)),U,3) 79 N LSTACT,PREPRV,CURPRV S LSTACT="?",(PREPRV,CURPRV)=0 80 F S LSTACT=$O(^OR(100,+ORIFN,8,LSTACT),-1) Q:LSTACT 81 S PREPRV=$P($G(^OR(100,+ORIFN,8,LSTACT,0)),U,3) 82 S CURPRV=$P($G(ORC),"|",13) 83 I (PREPRV'=CURPRV) S Y=1 G CHQ 84 CHQ Q Y 85 ; 86 VALUE(ID) ; -- Return value of ID in ^OR(100,+ORIFN,4.5,"ID") 87 N I,Y I '$L($G(ID)) Q "" 88 S I=+$O(^OR(100,+ORIFN,4.5,"ID",ID,0)) 89 S Y=$G(^OR(100,+ORIFN,4.5,I,1)) 90 Q Y 91 ; 92 PTR(X) ; -- Return ptr to prompt OR GTX X 93 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) 94 ; 95 RO ; -- Replacement order (finished) 96 ; 97 N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORDA,ORX,ORSIG,ORP,ZSC,NEWSTS 98 K ^TMP("ORWORD",$J) 99 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q 100 I 'RXE S ORERR="Missing or invalid RXE segment" Q 101 S RXO=$$RXO^ORMPS,RXC=$$RXC^ORMPS,ORIFN=+$G(ORIFN) 102 I ORIFN'>0 S ORERR="Missing or invalid order number" Q 103 D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR) 104 S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,"",ORNOW,ORWHO) 105 I ORDA'>0 S ORERR="Cannot create new order action" Q 106 RO1 ; -Update sts of order to active, last action to dc/edit: 107 S ORX=ORDA F S ORX=+$O(^OR(100,ORIFN,8,ORX),-1) Q:ORX'>0 I $D(^(ORX,0)),$P(^(0),U,15)="" Q ;ORX=last released action 108 S:ORX $P(^OR(100,ORIFN,8,ORX,0),U,15)=12 ;dc/edit 109 S $P(^OR(100,ORIFN,3),U,7)=ORDA,NEWSTS=$S('$G(ORSTS):0,ORSTS=$P(^(3),U,3):0,1:1) K ^(6) 110 D STATUS^ORCSAVE2(ORIFN,ORSTS):NEWSTS,SETALL^ORDD100(ORIFN):'NEWSTS 111 D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP) 112 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORWHO,ORNATR) 113 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd 114 S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0) 115 D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG 116 RO2 ; -Update responses, get/save new order text: 117 K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA) 118 S $P(^OR(100,ORIFN,0),U,5)=ORDIALOG_";ORD(101.41,",$P(^(0),U,14)=ORPKG 119 ;I $P(^OR(100,ORIFN,0),U,11)'=ORDG D ;update DG,xrefs 120 ;AGP Changes to handle IMO IV orders CPRS 26v43 121 I $P(^OR(100,ORIFN,0),U,11)'=ORDG,$P(^OR(100,ORIFN,0),U,11)'=$O(^ORD(100.98,"B","CLINIC ORDERS","")) D 122 . N DA,DR,DIE 123 . S DA=ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE 124 S ^OR(100,ORIFN,4)=PKGIFN,$P(^(8,ORDA,0),U,14)=ORDA 125 S ORIFN=ORIFN_";"_ORDA,ORDCNTRL="SN" ;to send NA msg back 126 I $G(ORL) S ORP(1)=ORIFN_"^1" D PRINTS^ORWD1(.ORP,+ORL) 127 I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS1 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,+ORIFN,5)=$TR($P(ZSC,"|",2,7),"|","^") ;1 or 0 instead of [N]SC in #100 128 Q 129 IVLIM(IVDUR) ; 130 I $L(IVDUR) D 131 . N DURU,DURV S DURU="",DURV=0 132 . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR)) 133 . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day") 134 . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour") 135 . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml" 136 . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L" 137 Q IVDUR 138 PCOMM ; -- Get Provider Comments from previous order, when changed 139 N OLD,I 140 S OLD=+$G(ORIFN) I OLD<1 S OLD=+$P(ZRX,"|",2) Q:OLD<1 141 S I=+$O(^OR(100,OLD,4.5,"ID","COMMENT",0)) Q:I<1 142 Q:'$O(^OR(100,OLD,4.5,I,2,0)) ;none 143 M ^TMP("ORWORD",$J,PC,1)=^OR(100,OLD,4.5,I,2) 144 S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)" 145 S ORDIALOG(PC,"FORMAT")="@" ;text in Sig already 146 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS3.m
r613 r623 1 ORMPS3 ;SLC/MKB - Process Pharmacy ORM msgs cont ;05/08/2008 10:32 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**213,243**;Dec 17, 1997;Build 242 3 ; 4 PTR(X) ; -- Return ptr to prompt OR GTX X 5 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) 6 ; 7 PARENT ; -- create parent order for backdoor complex renewals 8 ; Expects ORIFN, ORIG, ORDIALOG() 9 ;Q:'$$PATCH^XPDUTL("PSJ*5.0*110") 10 N ORIGDAD,ORIFNDAD,HDR S ORIGDAD=$P($G(^OR(100,ORIG,3)),U,9) 11 Q:ORIGDAD<1 Q:$$DOSES^ORCACT4(ORIGDAD)'>1 ;cont if complex 12 S ORIFNDAD=$P($G(^OR(100,ORIGDAD,3)),U,6) I ORIFNDAD<1 D G P1 13 . N ORIFN D EN^ORCSAVE Q:ORIFN<1 14 . S $P(^OR(100,ORIFN,3),U,5)=ORIGDAD,$P(^(3),U,8)=1,$P(^(3),U,11)=2 15 . S $P(^OR(100,ORIGDAD,3),U,6)=ORIFN,ORIFNDAD=ORIFN 16 . D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR) 17 . D SIGSTS^ORCSAVE2(ORIFN,1),DATES^ORCSAVE2(ORIFN,ORSTRT) 18 . I $P(^OR(100,ORIFN,8,1,0),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;sign children instead 19 . ;STATUS updated in SN2^ORMPS from child orders 20 P0 ; -- just add conjunction, new dose if DAD already exists 21 N INST,DA,PTR,ID,P,I,J,X 22 S INST=$$DOSES^ORCACT4(ORIFNDAD),DA=$O(^OR(100,ORIFNDAD,4.5,"A"),-1) 23 S PTR=$$PTR("AND/THEN"),ID="CONJ",DA=DA+1 24 S ^OR(100,ORIFNDAD,4.5,DA,0)=U_PTR_U_INST_U_ID,^(1)="A" 25 S ^OR(100,ORIFNDAD,4.5,"ID","CONJ",DA)="",INST=INST+1 26 F P="INSTRUCTIONS","ROUTE","SCHEDULE","DURATION","DOSE","DISPENSE DRUG" D 27 . S PTR=$$PTR(P) Q:'$L($G(ORDIALOG(PTR,1))) 28 . S DA=DA+1,ID=$P($G(^ORD(101.41,PTR,1)),U,3) 29 . S ^OR(100,ORIFNDAD,4.5,DA,0)=U_PTR_U_INST_U_ID,^(1)=ORDIALOG(PTR,1) 30 . S ^OR(100,ORIFNDAD,4.5,"ID",ID,DA)="" 31 S $P(^OR(100,ORIFNDAD,4.5,0),U,3,4)=DA_U_DA 32 S P=$$PTR("SIG"),DA=+$O(^OR(100,ORIFNDAD,4.5,"ID","SIG",0)) 33 S I=+$O(^OR(100,ORIFNDAD,4.5,DA,2,""),-1),X=$G(^(I,0)) S:$L(X) X=X_" AND",^(0)=X 34 S J=0 F S J=$O(^TMP("ORWORD",$J,PTR,1,J)) Q:J<1 S I=I+1,^OR(100,ORIFNDAD,4.5,DA,2,I,0)=^TMP("ORWORD",$J,PTR,1,J,0) 35 S $P(^OR(100,ORIFNDAD,4.5,DA,2,0),U,3,4)=I_U_I 36 ; -- rebuild order text w/new SIG 37 K ^TMP("ORWORD",$J,PTR) M ^TMP("ORWORD",$J,PTR,1)=^OR(100,ORIFNDAD,4.5,DA,2) 38 K ^OR(100,ORIFNDAD,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFNDAD_";1") 39 P1 ; -- set up links 40 S $P(^OR(100,ORIFN,3),U,9)=ORIFNDAD 41 S HDR=$G(^OR(100,ORIFNDAD,2,0)),^(0)="^100.002PA^"_ORIFN_U_($P(HDR,U,4)+1),^(ORIFN,0)=ORIFN 42 Q 43 ; 44 NTE(ID) ; -- Return subscript of NTE|ID segment 45 N I,SEG,Y S Y="",I=+RXE S:'$G(ID) ID=21 46 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=@ORMSG@(I) Q:$E(SEG,1,3)="ORC" I $P(SEG,"|",1,2)=("NTE|"_ID) S Y=I Q 47 Q Y 48 ; 49 NTXT(NTE) ; -- Return string of text in ORMSG(NTE) 50 N Y,I S NTE=+$G(NTE) 51 S Y=$P($G(@ORMSG@(NTE)),"|",4),Y=$$UNESC^ORHLESC(Y) 52 S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I<1 S Y=Y_" "_$$UNESC^ORHLESC(@ORMSG@(NTE,I)) 53 Q Y 54 ; 55 ZSC() ; -- Return subscript of ZSC segment 56 N I,SEG,Y S Y="",I=+RXE 57 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="ZSC" S Y=I_U_@ORMSG@(I) Q 58 Q Y 59 ; 60 NUMADDS() ; -- count number of additives to determine type 61 N CNT,I,X S CNT=0,I=+RXE 62 F S I=$O(@ORMSG@(I)) Q:I'>0 S X=@ORMSG@(I) Q:$P(X,"|")="ORC" I $E(X,1,6)="RXC|A|" S CNT=CNT+1 63 Q CNT 64 ; 65 DURATION(X) ; -- Returns "# units" from U# format 66 N Y,Y1,Y2 I X'?.1U1.N Q "" 67 S Y1=$E(X),Y2=+$E(X,2,$L(X)) I X=+X S Y1="D",Y2=+X 68 S Y=Y2_" "_$S(Y1="L":"MONTH",Y1="W":"WEEK",Y1="H":"HOUR",Y1="M":"MINUTE",Y1="S":"SECOND",1:"DAY")_$S(Y2>1:"S",1:"") 69 Q Y 70 ; 71 UPD ; -- Compare ORMSG to order, update responses [from SC^ORMPS] 72 ; Also expects ORIFN,ORNP,ORCAT,OR3,RXE,ZRX,PKGIFN 73 N X,I,ORDER,ZSC,NTE,PI 74 S ORDER=+$G(ORIFN),I=+$P(ORIFN,";",2) I I<1 D 75 . S I=+$P(OR3,U,7) Q:I 76 . S I=$O(^OR(100,+ORIFN,8,"A"),-1) 77 S X=+$P($G(^OR(100,+ORIFN,8,I,0)),U,3) S:X'=ORNP $P(^(0),U,3)=ORNP 78 S X=+$P($P(RXE,"|",3),U,4) 79 I X,X'=+$$VALUE(ORDER,"DRUG") D RESP^ORCSAVE2(ORDER,"OR GTX DISPENSE DRUG",X) 80 I $G(ORCAT)="I" D Q 81 . S X=$P($P($P(RXE,"|",2),U,2),"&",2) 82 . I X'=$$VALUE(ORDER,"ADMIN") D RESP^ORCSAVE2(ORDER,"OR GTX ADMIN TIMES",X) 83 . ;SCHEDULE TYPE 84 . S X=$P($P(RXE,"|",2),U,7) 85 . I X'=$$VALUE(ORDER,"SCHTYPE") D RESP^ORCSAVE2(ORDER,"OR GTX SCHEDULE TYPE",X) 86 . I $S(X="P":1,X="O":1,X="OC":1,1:0) D 87 . .D RESP^ORCSAVE2(ORDER,"OR GTX ADMIN TIMES","") 88 I $G(PKGIFN)'["N" D ;Rx only, not non-VA 89 . S X=$P(RXE,"|",23) S:$E(X)="D" X=+$E(X,2,99) 90 . I +X'=+$$VALUE(ORDER,"SUPPLY") D RESP^ORCSAVE2(ORDER,"OR GTX DAYS SUPPLY",X) 91 . I $P(ZRX,"|",5)'=$$VALUE(ORDER,"PICKUP") D RESP^ORCSAVE2(ORDER,"OR GTX ROUTING",$P(ZRX,"|",5)) 92 . S NTE=$$NTE(7),PI=+$O(^OR(100,ORDER,4.5,"ID","PI",0)) 93 . I NTE,PI,$$NTXT(NTE)'=$$VALTXT(ORDER,PI) D 94 .. N CNT K ^OR(100,ORDER,4.5,PI,2) 95 .. S CNT=1,^OR(100,ORDER,4.5,PI,2,1,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4)) 96 .. S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I<1 S CNT=CNT+1,^OR(100,ORDER,4.5,PI,2,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I)) 97 .. S ^OR(100,ORDER,4.5,PI,2,0)="^^"_CNT_U_CNT_U_DT_U 98 S ZSC=$$ZSC I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,ORDER,5)=$TR($P(ZSC,"|",2,7),"|","^") ;1 or 0 instead of [N]SC 99 Q 100 ; 101 VALUE(IFN,ID,INST) ; -- Returns value of prompt by identifier ID 102 I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q "" 103 N I,Y S I=0,Y="" S:'$G(INST) INST=1 104 F S I=$O(^OR(100,IFN,4.5,"ID",ID,I)) Q:I'>0 I $P($G(^OR(100,IFN,4.5,+I,0)),U,3)=INST S Y=$G(^(1)) Q 105 Q Y 106 ; 107 VALTXT(IFN,ID) ; -- Return string of text for prompt ID [assumes single instance] 108 ; ID may be identifier name or Response IEN 109 N Y,DA,I S IFN=+$G(IFN),ID=$G(ID) 110 S DA=$S($G(ID):+ID,$L(ID):+$O(^OR(100,IFN,4.5,"ID",ID,0)),1:0) 111 S I=+$O(^OR(100,IFN,4.5,DA,2,0)),Y=$G(^(I,0)) 112 F S I=$O(^OR(100,IFN,4.5,DA,2,I)) Q:I<1 S Y=Y_" "_$G(^(I,0)) 113 Q Y 1 ORMPS3 ;SLC/MKB - Process Pharmacy ORM msgs cont ;12/3/03 10:32 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**213**;Dec 17, 1997 3 ; 4 PTR(X) ; -- Return ptr to prompt OR GTX X 5 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) 6 ; 7 PARENT ; -- create parent order for backdoor complex renewals 8 ; Expects ORIFN, ORIG, ORDIALOG() 9 ;Q:'$$PATCH^XPDUTL("PSJ*5.0*110") 10 N ORIGDAD,ORIFNDAD,HDR S ORIGDAD=$P($G(^OR(100,ORIG,3)),U,9) 11 Q:ORIGDAD<1 Q:$$DOSES^ORCACT4(ORIGDAD)'>1 ;cont if complex 12 S ORIFNDAD=$P($G(^OR(100,ORIGDAD,3)),U,6) I ORIFNDAD<1 D G P1 13 . N ORIFN D EN^ORCSAVE Q:ORIFN<1 14 . S $P(^OR(100,ORIFN,3),U,5)=ORIGDAD,$P(^(3),U,8)=1,$P(^(3),U,11)=2 15 . S $P(^OR(100,ORIGDAD,3),U,6)=ORIFN,ORIFNDAD=ORIFN 16 . D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR) 17 . D SIGSTS^ORCSAVE2(ORIFN,1),DATES^ORCSAVE2(ORIFN,ORSTRT) 18 . I $P(^OR(100,ORIFN,8,1,0),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;sign children instead 19 . ;STATUS updated in SN2^ORMPS from child orders 20 P0 ; -- just add conjunction, new dose if DAD already exists 21 N INST,DA,PTR,ID,P,I,J,X 22 S INST=$$DOSES^ORCACT4(ORIFNDAD),DA=$O(^OR(100,ORIFNDAD,4.5,"A"),-1) 23 S PTR=$$PTR("AND/THEN"),ID="CONJ",DA=DA+1 24 S ^OR(100,ORIFNDAD,4.5,DA,0)=U_PTR_U_INST_U_ID,^(1)="A" 25 S ^OR(100,ORIFNDAD,4.5,"ID","CONJ",DA)="",INST=INST+1 26 F P="INSTRUCTIONS","ROUTE","SCHEDULE","DURATION","DOSE","DISPENSE DRUG" D 27 . S PTR=$$PTR(P) Q:'$L($G(ORDIALOG(PTR,1))) 28 . S DA=DA+1,ID=$P($G(^ORD(101.41,PTR,1)),U,3) 29 . S ^OR(100,ORIFNDAD,4.5,DA,0)=U_PTR_U_INST_U_ID,^(1)=ORDIALOG(PTR,1) 30 . S ^OR(100,ORIFNDAD,4.5,"ID",ID,DA)="" 31 S $P(^OR(100,ORIFNDAD,4.5,0),U,3,4)=DA_U_DA 32 S P=$$PTR("SIG"),DA=+$O(^OR(100,ORIFNDAD,4.5,"ID","SIG",0)) 33 S I=+$O(^OR(100,ORIFNDAD,4.5,DA,2,""),-1),X=$G(^(I,0)) S:$L(X) X=X_" AND",^(0)=X 34 S J=0 F S J=$O(^TMP("ORWORD",$J,PTR,1,J)) Q:J<1 S I=I+1,^OR(100,ORIFNDAD,4.5,DA,2,I,0)=^TMP("ORWORD",$J,PTR,1,J,0) 35 S $P(^OR(100,ORIFNDAD,4.5,DA,2,0),U,3,4)=I_U_I 36 ; -- rebuild order text w/new SIG 37 K ^TMP("ORWORD",$J,PTR) M ^TMP("ORWORD",$J,PTR,1)=^OR(100,ORIFNDAD,4.5,DA,2) 38 K ^OR(100,ORIFNDAD,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFNDAD_";1") 39 P1 ; -- set up links 40 S $P(^OR(100,ORIFN,3),U,9)=ORIFNDAD 41 S HDR=$G(^OR(100,ORIFNDAD,2,0)),^(0)="^100.002PA^"_ORIFN_U_($P(HDR,U,4)+1),^(ORIFN,0)=ORIFN 42 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMRA.m
r613 r623 1 ORMRA ; SLC/MKB/RV - Process Radiology ORM msgs ;2/21/02 15:44 [05/30/06 12:30pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,53,92,110,136,153,174,195,243**;Dec 17, 1997;Build 242 3 ;DBIA 2968 allows for reading ^DIC(34 4 EN ; -- entry point for RA messages 5 I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q 6 I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q 7 S OREASON=$S($P(OREASON,U,6)="99RAR":$P(OREASON,U,5),1:$P(OREASON,U,2)) 8 S:'ORDUZ ORDUZ=DUZ S:'ORLOG ORLOG=+$E($$NOW^XLFDT,1,12) 9 D @ORDCNTRL 10 Q 11 ; 12 ZP ; -- Purged 13 Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) K ^OR(100,+ORIFN,4) 14 ; - Set status=lapsed, if still active 15 I "^3^5^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(ORIFN,14) 16 Q 17 ; 18 ZR ; -- Purged as requested [ack] 19 D DELETE^ORCSAVE2(+ORIFN) 20 Q 21 ; 22 ZU ; -- Unable to purge [ack] 23 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity 24 Q 25 ; 26 OK ; -- Order accepted, RA order # assigned [ack] 27 N ORSTS,OBR S ^OR(100,+ORIFN,4)=PKGIFN,ORSTS=5 ; 5=pending 28 ; Ck if also scheduled, else quit 29 S OBR=$O(@ORMSG@(+ORC)) G:'OBR OKQ G:$E(@ORMSG@(OBR),1,3)'="OBR" OKQ 30 S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37)) 31 D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT) 32 OKQ D STATUS^ORCSAVE2(ORIFN,ORSTS) 33 ;Save the Radiology pre-certification Account Reference in the PV1 34 ;segment of the HL7 message from the Radiology package to the Order 35 ;File (#100). Support for Patch OR*3.0*228 36 I +$$SWSTAT^IBBAPI() D PRECERT^ORWPFSS2 ;IA #4663 37 Q 38 ; 39 XX ; -- Change order 40 N ORDIALOG,ORDG,ORDA,ORX,ORP S:'$L(ORNATR) ORNATR="S" 41 D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) S ORIFN=+ORIFN 42 S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON,ORLOG,ORDUZ) 43 I ORDA'>0 S ORERR="Cannot create new order action" Q 44 ; -Update sts of order to active, last action to dc/edit: 45 S ORX=+$P($G(^OR(100,ORIFN,3)),U,7) 46 S:$P($G(^OR(100,ORIFN,8,ORX,0)),U,15)="" $P(^(0),U,15)=12 47 S $P(^OR(100,ORIFN,3),U,7)=ORDA D STATUS^ORCSAVE2(ORIFN,6) 48 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) 49 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd 50 S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0) 51 D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG 52 ; -Update responses, get/save new order text: 53 K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA) 54 S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA 55 I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) 56 Q 57 ; 58 SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg 59 N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W" 60 I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q 61 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q 62 I '$G(ORL) S ORERR="Missing or invalid patient location" Q 63 D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) 64 SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J) 65 I '$G(ORIFN) S ORERR="Cannot create new order" Q 66 ;Save DG1 and ZCL segments of HL7 message from backdoor orders 67 D BDOSTR^ORWDBA3 68 ;Save the Radiology pre-certification Account Reference in the PV1 69 ;segment of the HL7 message from the Radiology package to the Order 70 ;File (#100). Support for Patch OR*3.0*228 71 I +$$SWSTAT^IBBAPI() D PRECERT^ORWPFSS2 ;IA #4663 72 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) 73 D STATUS^ORCSAVE2(ORIFN,5) S ^OR(100,ORIFN,4)=PKGIFN 74 I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy 75 Q 76 ; 77 DLG ; -- Build ORDIALOG() from msg 78 N OBR,OI,MODS,J,X,Y,ILOC,MODE,CH,CHI,OBX,NTE,REASON 79 S ORDIALOG=$O(^ORD(101.41,"AB","RA OERR EXAM",0)) 80 D GETDLG1^ORCD(ORDIALOG) 81 S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT) 82 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT 83 S ORDIALOG($$PTR("URGENCY"),1)=ORURG 84 S:$P(ORC,"|",12) ORDIALOG($$PTR("PROVIDER"),1)=+$P(ORC,"|",12) 85 D1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q 86 S OI=$$ORDITEM^ORM($P(@ORMSG@(OBR),"|",5)) 87 I 'OI S ORERR="Invalid procedure" Q 88 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI 89 S ORDG=$P($G(^ORD(101.43,+OI,"RA")),U,3) S:$L(ORDG) ORDG=+$O(^ORD(100.98,"B",ORDG,0)) I 'ORDG S ORDG=$P(^ORD(101.41,+ORDIALOG,0),U,5) ; Im Type 90 S MODS=$P(@ORMSG@(OBR),"|",19) I $L(MODS) D 91 . F J=1:1:$L(MODS,"~") S X=$P(MODS,"~",J) I $L(X) S Y=$O(^RAMIS(71.2,"B",X,0)) S:Y ORDIALOG($$PTR("MODIFIERS"),J)=Y 92 S ILOC=+$P(@ORMSG@(OBR),"|",20),MODE=$P(@ORMSG@(OBR),"|",31),REASON=$P($P(@ORMSG@(OBR),"|",32),U,2) 93 S:ILOC ORDIALOG($$PTR("IMAGING LOCATION"),1)=ILOC 94 S ORDIALOG($$PTR("MODE OF TRANSPORT"),1)=$S(MODE="WALK":"A",MODE="CART":"S",1:$E(MODE)) 95 S:$L(REASON) ORDIALOG($$PTR("STUDY REASON"),1)=REASON 96 I ORDCNTRL="XX" S NTE=+$O(@ORMSG@(OBR)) I NTE,$E($G(@ORMSG@(NTE)),1,3)="NTE" S OREASON=$P(@ORMSG@(NTE),"|",4) ;Tech's Comments 97 D2 ; might the procedure be scheduled at this point ?? Not in spec 98 S CH=$$PTR("WORD PROCESSING 1"),CHI=0 99 S OBX=OBR F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC" Q:J="MSH" I J="OBX" D 100 . N NAME,VALUE,X0 S VALUE=$P(@ORMSG@(OBX),"|",6) 101 . S NAME=$$UP^XLFSTR($P($P(@ORMSG@(OBX),"|",4),U,2)) 102 . I NAME="CONTRACT/SHARING SOURCE" S X0=$G(^DIC(34,+VALUE,0)) S:$L(X0) ORDIALOG($$PTR(NAME),1)=+VALUE,ORDIALOG($$PTR("CATEGORY"),1)=$P(X0,U,2) Q 103 . I NAME="RESEARCH SOURCE" S ORDIALOG($$PTR(NAME),1)=VALUE,ORDIALOG($$PTR("CATEGORY"),1)="R" Q 104 . I NAME="PREGNANT" S ORDIALOG($$PTR(NAME),1)=VALUE Q 105 . I NAME="PRE-OP SCHEDULED DATE/TIME" S ORDIALOG($$PTR(NAME),1)=$$FMDATE^ORM(VALUE) Q 106 . S CHI=CHI+1,^TMP("ORWORD",$J,CH,1,CHI,0)=VALUE 107 S:CHI ^TMP("ORWORD",$J,CH,1,0)="^^"_CHI_U_CHI_U_DT_U,ORDIALOG(CH,1)="^TMP(""ORWORD"",$J,"_CH_",1)" 108 Q 109 ; 110 PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41 111 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0)) 112 ; 113 SC ; -- Status changed (scheduled, registered, or unverified) 114 N ORSTS,OBR,OR3 ;110 115 S ORSTS=$S(ORDSTS="ZR":6,ORDSTS="ZU":6,1:8),OR3=$G(^OR(100,+ORIFN,3)) ;110 116 G:ORSTS=6 SCQ ;136 Done if active, else get scheduled data 117 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q 118 S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37)) 119 D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT) 120 I $P(OR3,U,3)=3,$P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="HD" D RL ;If status is hold and current action is hold then release. Added with 110 121 SCQ D STATUS^ORCSAVE2(ORIFN,ORSTS) 122 Q 123 ; 124 RE ; -- Completed, w/results 125 N I,SEG,OBX 126 D STATUS^ORCSAVE2(ORIFN,2) 127 S OBX="" D ;get Results D/T [from OBR] 128 . N DA,DR,DIE,X,Y,OBR 129 . S DA=+ORIFN,DIE="^OR(100,",OBR=+$O(@ORMSG@(+ORC)),X="" 130 . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23) 131 . S DR="71////"_$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) D ^DIE 132 S I=+ORC F S I=$O(@ORMSG@(I)) Q:I<1 S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC" I $E(SEG,1,3)="OBX" S OBX=I_U_SEG Q ;first one 133 S $P(^OR(100,+ORIFN,7),U,2)=$S($P(OBX,"|",9)="A":1,1:"") 134 S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4) 135 I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov 136 Q 137 ; 138 OH ; -- Held 139 D UPDATE(3,"HD") 140 Q 141 ; 142 OC ; -- Cancelled/Unable to accept [ack] 143 UA ; -- Unable to accept [ack] 144 S:'$L(ORNATR) ORNATR="X" ;Rejected 145 S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON 146 D STATUS^ORCSAVE2(ORIFN,13) 147 UD ; -- Unable to discontinue [ack] 148 N DA S DA=+$P(ORIFN,";",2) I DA D 149 . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;Request rejected 150 . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON 151 Q 152 ; 153 OD ; -- Discontinued 154 S:$G(DGPMT) ORDUZ="" ;auto-dc on movement 155 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON 156 D UPDATE(1,"DC") 157 Q 158 ; 159 DR ; -- Discontinued [ack] 160 D STATUS^ORCSAVE2(ORIFN,1) 161 Q 162 ; 163 UPDATE(ORSTS,ORACT) ; -- continue processing 164 N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS) 165 S ORX=$$CREATE^ORX1(ORNATR) D:ORX 166 . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ) 167 . I ORDA'>0 S ORERR="Cannot create new order action" Q 168 . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) 169 . D SIGSTS^ORCSAVE2(+ORIFN,ORDA) 170 . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) 171 . S $P(^OR(100,+ORIFN,3),U,7)=ORDA 172 I 'ORX D ;no new action created 173 . ;I ORACT="DC" S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0 Q 174 . S:ORACT="HD"&$L(OREASON) ^OR(100,+ORIFN,8,1,1)=OREASON ;pend/sch only 175 I ORACT="DC" D CANCEL^ORCSEND(+ORIFN) S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0 176 Q 177 ; 178 RL ;Release hold --entire section added with patch 110 179 S ^OR(100,+ORIFN,8,$P(OR3,U,7),2)=ORLOG_"^"_ORDUZ ;Set release hold date/time and release hold user 180 S ORNATR=$S($L(ORNATR):ORNATR,1:$P(^OR(100,+ORIFN,8,$P(OR3,U,7),0),U,12)) ;set nature of order for release equal to nature of order for hold if it doesn't exist 181 I $G(ORSTS)="" S ORSTS=6 182 D UPDATE(ORSTS,"RL") 183 Q 1 ORMRA ; SLC/MKB - Process Radiology ORM msgs ;2/21/02 15:44 [3/4/04 10:43am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,53,92,110,136,153,174,195,228**;Dec 17, 1997 3 ;DBIA 2968 allows for reading ^DIC(34 4 EN ; -- entry point for RA messages 5 I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q 6 I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q 7 S OREASON=$S($P(OREASON,U,6)="99RAR":$P(OREASON,U,5),1:$P(OREASON,U,2)) 8 S:'ORDUZ ORDUZ=DUZ S:'ORLOG ORLOG=+$E($$NOW^XLFDT,1,12) 9 D @ORDCNTRL 10 Q 11 ; 12 ZP ; -- Purged 13 Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) K ^OR(100,+ORIFN,4) 14 ; - Set status=lapsed, if still active 15 I "^3^5^6^8^"[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) D STATUS^ORCSAVE2(ORIFN,14) 16 Q 17 ; 18 ZR ; -- Purged as requested [ack] 19 D DELETE^ORCSAVE2(+ORIFN) 20 Q 21 ; 22 ZU ; -- Unable to purge [ack] 23 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity 24 Q 25 ; 26 OK ; -- Order accepted, RA order # assigned [ack] 27 N ORSTS,OBR S ^OR(100,+ORIFN,4)=PKGIFN,ORSTS=5 ; 5=pending 28 ; Ck if also scheduled, else quit 29 S OBR=$O(@ORMSG@(+ORC)) G:'OBR OKQ G:$E(@ORMSG@(OBR),1,3)'="OBR" OKQ 30 S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37)) 31 D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT) 32 OKQ D STATUS^ORCSAVE2(ORIFN,ORSTS) 33 ;Save the Radiology pre-certification Account Reference in the PV1 34 ;segment of the HL7 message from the Radiology package to the Order 35 ;File (#100). Support for Patch OR*3.0*228 36 D PRECERT^ORWPFSS2 37 Q 38 ; 39 XX ; -- Change order 40 N ORDIALOG,ORDG,ORDA,ORX,ORP S:'$L(ORNATR) ORNATR="S" 41 D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) S ORIFN=+ORIFN 42 S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON,ORLOG,ORDUZ) 43 I ORDA'>0 S ORERR="Cannot create new order action" Q 44 ; -Update sts of order to active, last action to dc/edit: 45 S ORX=+$P($G(^OR(100,ORIFN,3)),U,7) 46 S:$P($G(^OR(100,ORIFN,8,ORX,0)),U,15)="" $P(^(0),U,15)=12 47 S $P(^OR(100,ORIFN,3),U,7)=ORDA D STATUS^ORCSAVE2(ORIFN,6) 48 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) 49 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd 50 S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0) 51 D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG 52 ; -Update responses, get/save new order text: 53 K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA) 54 S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA 55 I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) 56 Q 57 ; 58 SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg 59 N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W" 60 I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q 61 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q 62 I '$G(ORL) S ORERR="Missing or invalid patient location" Q 63 D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) 64 SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J) 65 I '$G(ORIFN) S ORERR="Cannot create new order" Q 66 ;Save DG1 and ZCL segments of HL7 message from backdoor orders 67 D BDOSTR^ORWDBA3 68 ;Save the Rediology pre-certification Account Reference in the PV1 69 ;segment of the HL7 message from the Radiology package to the Order 70 ;File (#100). Support for Patch OR*3.0*228 71 D PRECERT^ORWPFSS2 72 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) 73 D STATUS^ORCSAVE2(ORIFN,5) S ^OR(100,ORIFN,4)=PKGIFN 74 I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy 75 Q 76 ; 77 DLG ; -- Build ORDIALOG() from msg 78 N OBR,OI,MODS,J,X,Y,ILOC,MODE,CH,CHI,OBX,NTE 79 S ORDIALOG=$O(^ORD(101.41,"AB","RA OERR EXAM",0)) 80 D GETDLG1^ORCD(ORDIALOG) 81 S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT) 82 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT 83 S ORDIALOG($$PTR("URGENCY"),1)=ORURG 84 S:$P(ORC,"|",12) ORDIALOG($$PTR("PROVIDER"),1)=+$P(ORC,"|",12) 85 D1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q 86 S OI=$$ORDITEM^ORM($P(@ORMSG@(OBR),"|",5)) 87 I 'OI S ORERR="Invalid procedure" Q 88 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI 89 S ORDG=$P($G(^ORD(101.43,+OI,"RA")),U,3) S:$L(ORDG) ORDG=+$O(^ORD(100.98,"B",ORDG,0)) I 'ORDG S ORDG=$P(^ORD(101.41,+ORDIALOG,0),U,5) ; Im Type 90 S MODS=$P(@ORMSG@(OBR),"|",19) I $L(MODS) D 91 . F J=1:1:$L(MODS,"~") S X=$P(MODS,"~",J) I $L(X) S Y=$O(^RAMIS(71.2,"B",X,0)) S:Y ORDIALOG($$PTR("MODIFIERS"),J)=Y 92 S ILOC=+$P(@ORMSG@(OBR),"|",20),MODE=$P(@ORMSG@(OBR),"|",31) 93 S:ILOC ORDIALOG($$PTR("IMAGING LOCATION"),1)=ILOC 94 S ORDIALOG($$PTR("MODE OF TRANSPORT"),1)=$S(MODE="WALK":"A",MODE="CART":"S",1:$E(MODE)) 95 I ORDCNTRL="XX" S NTE=+$O(@ORMSG@(OBR)) I NTE,$E($G(@ORMSG@(NTE)),1,3)="NTE" S OREASON=$P(@ORMSG@(NTE),"|",4) ;Tech's Comments 96 D2 ; might the procedure be scheduled at this point ?? Not in spec 97 S CH=$$PTR("WORD PROCESSING 1"),CHI=0 98 S OBX=OBR F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC" Q:J="MSH" I J="OBX" D 99 . N NAME,VALUE,X0 S VALUE=$P(@ORMSG@(OBX),"|",6) 100 . S NAME=$$UP^XLFSTR($P($P(@ORMSG@(OBX),"|",4),U,2)) 101 . I NAME="CONTRACT/SHARING SOURCE" S X0=$G(^DIC(34,+VALUE,0)) S:$L(X0) ORDIALOG($$PTR(NAME),1)=+VALUE,ORDIALOG($$PTR("CATEGORY"),1)=$P(X0,U,2) Q 102 . I NAME="RESEARCH SOURCE" S ORDIALOG($$PTR(NAME),1)=VALUE,ORDIALOG($$PTR("CATEGORY"),1)="R" Q 103 . I NAME="PREGNANT" S ORDIALOG($$PTR(NAME),1)=VALUE Q 104 . I NAME="PRE-OP SCHEDULED DATE/TIME" S ORDIALOG($$PTR(NAME),1)=$$FMDATE^ORM(VALUE) Q 105 . S CHI=CHI+1,^TMP("ORWORD",$J,CH,1,CHI,0)=VALUE 106 S:CHI ^TMP("ORWORD",$J,CH,1,0)="^^"_CHI_U_CHI_U_DT_U,ORDIALOG(CH,1)="^TMP(""ORWORD"",$J,"_CH_",1)" 107 Q 108 ; 109 PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41 110 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0)) 111 ; 112 SC ; -- Status changed (scheduled, registered, or unverified) 113 N ORSTS,OBR,OR3 ;110 114 S ORSTS=$S(ORDSTS="ZR":6,ORDSTS="ZU":6,1:8),OR3=$G(^OR(100,+ORIFN,3)) ;110 115 G:ORSTS=6 SCQ ;136 Done if active, else get scheduled data 116 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q 117 S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37)) 118 D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT) 119 I $P(OR3,U,3)=3,$P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="HD" D RL ;If status is hold and current action is hold then release. Added with 110 120 SCQ D STATUS^ORCSAVE2(ORIFN,ORSTS) 121 Q 122 ; 123 RE ; -- Completed, w/results 124 N I,SEG,OBX 125 D STATUS^ORCSAVE2(ORIFN,2) 126 S OBX="" D ;get Results D/T [from OBR] 127 . N DA,DR,DIE,X,Y,OBR 128 . S DA=+ORIFN,DIE="^OR(100,",OBR=+$O(@ORMSG@(+ORC)),X="" 129 . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23) 130 . S DR="71////"_$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) D ^DIE 131 S I=+ORC F S I=$O(@ORMSG@(I)) Q:I<1 S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC" I $E(SEG,1,3)="OBX" S OBX=I_U_SEG Q ;first one 132 S $P(^OR(100,+ORIFN,7),U,2)=$S($P(OBX,"|",9)="A":1,1:"") 133 S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4) 134 I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov 135 Q 136 ; 137 OH ; -- Held 138 D UPDATE(3,"HD") 139 Q 140 ; 141 OC ; -- Cancelled/Unable to accept [ack] 142 UA ; -- Unable to accept [ack] 143 S:'$L(ORNATR) ORNATR="X" ;Rejected 144 S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON 145 D STATUS^ORCSAVE2(ORIFN,13) 146 UD ; -- Unable to discontinue [ack] 147 N DA S DA=+$P(ORIFN,";",2) I DA D 148 . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;Request rejected 149 . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON 150 Q 151 ; 152 OD ; -- Discontinued 153 S:$G(DGPMT) ORDUZ="" ;auto-dc on movement 154 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON 155 D UPDATE(1,"DC") 156 Q 157 ; 158 DR ; -- Discontinued [ack] 159 D STATUS^ORCSAVE2(ORIFN,1) 160 Q 161 ; 162 UPDATE(ORSTS,ORACT) ; -- continue processing 163 N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS) 164 S ORX=$$CREATE^ORX1(ORNATR) D:ORX 165 . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ) 166 . I ORDA'>0 S ORERR="Cannot create new order action" Q 167 . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) 168 . D SIGSTS^ORCSAVE2(+ORIFN,ORDA) 169 . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) 170 . S $P(^OR(100,+ORIFN,3),U,7)=ORDA 171 I 'ORX D ;no new action created 172 . I ORACT="DC" S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0 Q 173 . S:ORACT="HD"&$L(OREASON) ^OR(100,+ORIFN,8,1,1)=OREASON ;pend/sch only 174 D:ORACT="DC" CANCEL^ORCSEND(+ORIFN) 175 Q 176 ; 177 RL ;Release hold --entire section added with patch 110 178 S ^OR(100,+ORIFN,8,$P(OR3,U,7),2)=ORLOG_"^"_ORDUZ ;Set release hold date/time and release hold user 179 S ORNATR=$S($L(ORNATR):ORNATR,1:$P(^OR(100,+ORIFN,8,$P(OR3,U,7),0),U,12)) ;set nature of order for release equal to nature of order for hold if it doesn't exist 180 I $G(ORSTS)="" S ORSTS=6 181 D UPDATE(ORSTS,"RL") 182 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMTIM02.m
r613 r623 1 ORMTIM02 ; JM/SLC-ISC - PERFORM MISC TIME BASED ACTIVITIES ;05/02/06 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**253,243**;Dec 17, 1997;Build 242 3 ; 4 Q 5 MISC ; Perform misc time based activities 6 ; 7 D UNSIGNED ; Generate alerts for unsigned orders that have slipped through the cracks 8 D INIT^ORWGTASK(0) ; check to run rebuild of cache for graphing 9 ; 10 Q 11 ; 12 UNSIGNED ; Generate alerts for unsigned orders that were not alerted by CPRS 13 ; This happens when CPRS crashes - through network connection drops or other causes 14 N ORZPAT,ORZDATE,ORZIEN,ORZSUB,ORZSDATE,%DT,X,Y,ORZTIME,ORZNOW,ORZPURGE 15 N ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA,ORZREC8,ORZSIGDT,ORZSTS,ORZWHEN,ORMARKID 16 N MINTIME,XTMPDAYS,XTMPHOUR,MINDAYS 17 S ORN=12,ORMARKID="ORMTIME_UNSGNORD" 18 ; 19 S MINTIME=60 ; Order must be unsigned for 60 Minutes before generating an alert 20 S MINDAYS=90 ; Order must have been generated within the last 90 days 21 ; 22 S XTMPDAYS=10 ; Keep ^XTMP record for 10 days - reset timeframe with each run 23 S XTMPHOUR=48 ; Each order that's verified as having generated an alert has a flag set in 24 ; ^XTMP that's kept for 48 hours. When flag is gone, must recheck alert status 25 ; 26 S X="T-"_MINDAYS 27 D ^%DT S ORZSDATE=9999999-Y 28 S %DT="ST",X="NOW" D ^%DT 29 S ORZNOW=Y 30 S ORZTIME=$$FMADD^XLFDT(ORZNOW,0,0,-MINTIME,0) ; Order must have existed for ORZTIME minutes 31 S ORZPURGE=$$FMADD^XLFDT(ORZNOW,XTMPDAYS,0,0,0) ; Purge all marked flags if not run in XTMPDAYS days 32 S ^XTMP(ORMARKID,0)=ORZPURGE_U_ORZNOW_U_"Unsigned Orders Reviewed by ORMTIME" 33 S ORZPURGE=$$FMADD^XLFDT(ORZNOW,0,XTMPHOUR,0,0) ; Purge each marked flag XTMPHOUR hours after creation 34 K MINTIME,MINDAYS,XTMPDAYS,XTMPHOUR,X,Y,%DT ; Kill non-namespaced vars 35 S ORZPAT="" F S ORZPAT=$O(^OR(100,"AS",ORZPAT)) Q:'ORZPAT D 36 . Q:$P(^DPT(+ORZPAT,0),U,21) ; Quit if test patient 37 . S ORZDATE=0 F S ORZDATE=$O(^OR(100,"AS",ORZPAT,ORZDATE)) Q:'ORZDATE I ORZDATE<ORZSDATE D 38 . . S ORZIEN=0 F S ORZIEN=$O(^OR(100,"AS",ORZPAT,ORZDATE,ORZIEN)) Q:'ORZIEN D 39 . . . S ORZSUB=0 F S ORZSUB=$O(^OR(100,"AS",ORZPAT,ORZDATE,ORZIEN,ORZSUB)) Q:'ORZSUB D 40 . . . . I $D(^OR(100,ORZIEN,8,ORZSUB,0)) D 41 . . . . . S ORZREC8=^OR(100,ORZIEN,8,ORZSUB,0) 42 . . . . . S ORZSIGDT=$P(ORZREC8,U,6) I $L(ORZSIGDT)>0 Q ; Can't have a sign date/time 43 . . . . . S ORZSTS=$P(ORZREC8,U,4) I ORZSTS'=2 Q ; must be in an unsigned state 44 . . . . . S ORZWHEN=$P(ORZREC8,U) I ORZWHEN>ORZTIME Q ; must have been unsigned for MINTIME 45 . . . . . S ORBDFN=+ORZPAT 46 . . . . . S ORNUM=ORZIEN_";"_ORZSUB 47 . . . . . I $$NEEDALRT($P(ORZREC8,U,3),ORBDFN,ORNUM) D ; must not have already generated an alert 48 . . . . . . S (ORBADUZ,ORBPMSG,ORBPDATA)="" 49 . . . . . . D DOALERT^ORB3 50 . . . . . . D MARK(ORNUM) ; Alert sent, don't send another one 51 D CLEAN 52 Q 53 ; 54 NEEDALRT(PROVIDER,DFN,ORNUM) ; Returns true if order needs an alert 55 ; 56 I $$MARKED(ORNUM) Q 0 ; If already checked, return 57 ; 58 N RESULT,SUROGATE 59 S RESULT=1 60 I $$HASALERT(PROVIDER,DFN) S RESULT=0 I 1 61 E D 62 . S SUROGATE=$P($$GETSURO^XQALSURO(PROVIDER),U,1) 63 . I +SUROGATE,$$HASALERT(SUROGATE,DFN) S RESULT=0 64 I 'RESULT D MARK(ORNUM) 65 Q RESULT 66 ; 67 HASALERT(USER,PATIENT) ; Returns true if alert exists for user and patient 68 N RESULT,ALERTID,DATE 69 S RESULT=0,ALERTID="OR,"_PATIENT_",12" 70 I $D(^XTV(8992,"AXQAN",ALERTID,USER)) D ;DBIA# 2689 71 . S DATE=$O(^XTV(8992,"AXQAN",ALERTID,USER,0)) 72 . I $G(DATE)>0 S RESULT=1 73 Q RESULT 74 ; 75 MARKED(ORNUM) ; Returns true if the order has been marked as not needing an alert 76 I $D(^XTMP(ORMARKID,"A",ORNUM))>0 Q 1 77 Q 0 78 ; 79 MARK(ORNUM) ; Marks an order as already having been alerted 80 S ^XTMP(ORMARKID,"A",ORNUM)="" 81 S ^XTMP(ORMARKID,"B",ORZPURGE,ORNUM)="" 82 Q 83 CLEAN ; Clean up old entries in ^XTMP 84 N IDX,ORNUM 85 S IDX=0 86 F S IDX=$O(^XTMP(ORMARKID,"B",IDX)) Q:((+IDX=0)!(IDX>ORZNOW)) D 87 . S ORNUM=0 88 . F S ORNUM=$O(^XTMP(ORMARKID,"B",IDX,ORNUM)) Q:+ORNUM=0 D 89 . . K ^XTMP(ORMARKID,"A",ORNUM) 90 . . K ^XTMP(ORMARKID,"B",IDX,ORNUM) 91 Q 1 ORMTIM02 ; JM/SLC-ISC - PERFORM MISC TIME BASED ACTIVITIES ;05/02/06 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**253**;Dec 17, 1997 3 ; 4 Q 5 MISC ; Perform misc time based activities 6 ; 7 D UNSIGNED ; Generate alerts for unsigned orders that have slipped through the cracks 8 ; 9 Q 10 ; 11 UNSIGNED ; Generate alerts for unsigned orders that were not alerted by CPRS 12 ; This happens when CPRS crashes - through network connection drops or other causes 13 N ORZPAT,ORZDATE,ORZIEN,ORZSUB,ORZSDATE,%DT,X,Y,ORZTIME,ORZNOW,ORZPURGE 14 N ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA,ORZREC8,ORZSIGDT,ORZSTS,ORZWHEN,ORMARKID 15 N MINTIME,XTMPDAYS,XTMPHOUR,MINDAYS 16 S ORN=12,ORMARKID="ORMTIME_UNSGNORD" 17 ; 18 S MINTIME=60 ; Order must be unsigned for 60 Minutes before generating an alert 19 S MINDAYS=90 ; Order must have been generated within the last 90 days 20 ; 21 S XTMPDAYS=10 ; Keep ^XTMP record for 10 days - reset timeframe with each run 22 S XTMPHOUR=48 ; Each order that's verified as having generated an alert has a flag set in 23 ; ^XTMP that's kept for 48 hours. When flag is gone, must recheck alert status 24 ; 25 S X="T-"_MINDAYS 26 D ^%DT S ORZSDATE=9999999-Y 27 S %DT="ST",X="NOW" D ^%DT 28 S ORZNOW=Y 29 S ORZTIME=$$FMADD^XLFDT(ORZNOW,0,0,-MINTIME,0) ; Order must have existed for ORZTIME minutes 30 S ORZPURGE=$$FMADD^XLFDT(ORZNOW,XTMPDAYS,0,0,0) ; Purge all marked flags if not run in XTMPDAYS days 31 S ^XTMP(ORMARKID,0)=ORZPURGE_U_ORZNOW_U_"Unsigned Orders Reviewed by ORMTIME" 32 S ORZPURGE=$$FMADD^XLFDT(ORZNOW,0,XTMPHOUR,0,0) ; Purge each marked flag XTMPHOUR hours after creation 33 K MINTIME,MINDAYS,XTMPDAYS,XTMPHOUR,X,Y,%DT ; Kill non-namespaced vars 34 S ORZPAT="" F S ORZPAT=$O(^OR(100,"AS",ORZPAT)) Q:'ORZPAT D 35 . Q:$P(^DPT(+ORZPAT,0),U,21) ; Quit if test patient 36 . S ORZDATE=0 F S ORZDATE=$O(^OR(100,"AS",ORZPAT,ORZDATE)) Q:'ORZDATE I ORZDATE<ORZSDATE D 37 . . S ORZIEN=0 F S ORZIEN=$O(^OR(100,"AS",ORZPAT,ORZDATE,ORZIEN)) Q:'ORZIEN D 38 . . . S ORZSUB=0 F S ORZSUB=$O(^OR(100,"AS",ORZPAT,ORZDATE,ORZIEN,ORZSUB)) Q:'ORZSUB D 39 . . . . I $D(^OR(100,ORZIEN,8,ORZSUB,0)) D 40 . . . . . S ORZREC8=^OR(100,ORZIEN,8,ORZSUB,0) 41 . . . . . S ORZSIGDT=$P(ORZREC8,U,6) I $L(ORZSIGDT)>0 Q ; Can't have a sign date/time 42 . . . . . S ORZSTS=$P(ORZREC8,U,4) I ORZSTS'=2 Q ; must be in an unsigned state 43 . . . . . S ORZWHEN=$P(ORZREC8,U) I ORZWHEN>ORZTIME Q ; must have been unsigned for MINTIME 44 . . . . . S ORBDFN=+ORZPAT 45 . . . . . S ORNUM=ORZIEN_";"_ORZSUB 46 . . . . . I $$NEEDALRT($P(ORZREC8,U,3),ORBDFN,ORNUM) D ; must not have already generated an alert 47 . . . . . . S (ORBADUZ,ORBPMSG,ORBPDATA)="" 48 . . . . . . D DOALERT^ORB3 49 . . . . . . D MARK(ORNUM) ; Alert sent, don't send another one 50 D CLEAN 51 Q 52 ; 53 NEEDALRT(PROVIDER,DFN,ORNUM) ; Returns true if order needs an alert 54 ; 55 I $$MARKED(ORNUM) Q 0 ; If already checked, return 56 ; 57 N RESULT,SUROGATE 58 S RESULT=1 59 I $$HASALERT(PROVIDER,DFN) S RESULT=0 I 1 60 E D 61 . S SUROGATE=$P($$GETSURO^XQALSURO(PROVIDER),U,1) 62 . I +SUROGATE,$$HASALERT(SUROGATE,DFN) S RESULT=0 63 I 'RESULT D MARK(ORNUM) 64 Q RESULT 65 ; 66 HASALERT(USER,PATIENT) ; Returns true if alert exists for user and patient 67 N RESULT,ALERTID,DATE 68 S RESULT=0,ALERTID="OR,"_PATIENT_",12" 69 I $D(^XTV(8992,"AXQAN",ALERTID,USER)) D ;DBIA# 2689 70 . S DATE=$O(^XTV(8992,"AXQAN",ALERTID,USER,0)) 71 . I $G(DATE)>0 S RESULT=1 72 Q RESULT 73 ; 74 MARKED(ORNUM) ; Returns true if the order has been marked as not needing an alert 75 I $D(^XTMP(ORMARKID,"A",ORNUM))>0 Q 1 76 Q 0 77 ; 78 MARK(ORNUM) ; Marks an order as already having been alerted 79 S ^XTMP(ORMARKID,"A",ORNUM)="" 80 S ^XTMP(ORMARKID,"B",ORZPURGE,ORNUM)="" 81 Q 82 CLEAN ; Clean up old entries in ^XTMP 83 N IDX,ORNUM 84 S IDX=0 85 F S IDX=$O(^XTMP(ORMARKID,"B",IDX)) Q:((+IDX=0)!(IDX>ORZNOW)) D 86 . S ORNUM=0 87 . F S ORNUM=$O(^XTMP(ORMARKID,"B",IDX,ORNUM)) Q:+ORNUM=0 D 88 . . K ^XTMP(ORMARKID,"A",ORNUM) 89 . . K ^XTMP(ORMARKID,"B",IDX,ORNUM) 90 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMTIME.m
r613 r623 1 ORMTIME ; SLC/RJS - PROCESS TIME BASED EVENT ;9/29/99 09:35 [2/1/00 9:30am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**40,253,243**;Dec 17, 1997;Build 242 3 ; 4 EN ; Main entry tag. 5 ; 6 N OCXPSDT,OCXZTSK,OCXERR,OCXORMTR,OCXSTDT,OCXLOCK,OCXPAR 7 K ^TMP("OCXORMTIME",$J) 8 S OCXLOCK=0 9 S OCXORMTR="ORMTIME: Startup" 10 S OCXSTDT=$$EDATE($$IDATE("NOW")) 11 S ^TMP("OCXORMTIME",$J,"STATUS")="ORMTIME: Attempting to lock ^OR(100,""AE"") at "_OCXSTDT_"." 12 L +^OR(100,"AE"):10 13 I D 14 .S OCXLOCK=1 15 .D SCAN 16 .L -^OR(100,"AE") 17 .K ^TMP("OCXORMTIME") 18 .S OCXPAR=$$IDATE2("NOW") 19 .D PUT^XPAR("SYS","ORM ORMTIME LAST RUN",1,OCXPAR,.OCXERR) 20 S:'OCXLOCK ^TMP("OCXORMTIME",$J,"STATUS")="ORMTIME: Unable to lock ^OR(100,""AE"") at "_OCXSTDT_" attempt." 21 Q 22 ; 23 SCAN ; Call ORMTIM01 for order checking, etc. ORMTIM02 for misc time based tasks 24 ; 25 D SCAN^ORMTIM01 26 D MISC^ORMTIM02 27 D TASK^ORTSKLPS 28 Q 29 ; 30 EDATE(Y) X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y 31 ; 32 IDATE(X) N %DT,Y S %DT="F" D ^%DT Q Y 33 ; 34 IDATE2(X) N %DT,Y S %DT="TF" D ^%DT Q Y 35 ; 36 REQUEUE(ORMQT) ; Code formerly queued ORMTIME tasks in Taskman. 37 ; 38 ; (This tag kept for compatibility with outside calls.) 39 ; 40 Q 41 ; 42 STATUS ; Check status of last ORMTIME run. 43 ; 44 N ORMLAST 45 ; 46 ; Get date/time of last ORMTIME run: 47 S ORMLAST=$$GET^XPAR("SYS","ORM ORMTIME LAST RUN",1,"I") 48 S ORMLAST=$$EDATE(ORMLAST) ; Convert to external format for display. 49 ; 50 ; Present information to user: 51 W ! 52 W !," ORMTIME last ran "_ORMLAST_"." 53 W ! 54 ; 55 Q 56 ; 57 BULL ; Send a bulletin if ORMTIME's last run is greater than 24 hours. 58 ; 59 N DIC,ORMMSG,X,XMSUB,XMTEXT,XMY,XMZ,Y,ORMLAST 60 ; 61 ; Don't send bulletin if ORMTIME STATUS mail group does not exist: 62 S DIC=3.8,DIC(0)="",X="ORMTIME STATUS" 63 D ^DIC Q:(+Y<0) 64 ; 65 S ORMLAST=$$GET^XPAR("SYS","ORM ORMTIME LAST RUN",1,"I") 66 I $$FMDIFF^XLFDT($$IDATE2("NOW"),ORMLAST,2)>86400 D 67 .S XMY("G.ORMTIME STATUS")="" 68 .S XMSUB=" ORMTIME Warning" 69 .S ORMMSG(1,0)=" " 70 .S ORMMSG(2,0)=" The ORMTIME process last ran more than 24 hours ago. " 71 .S ORMMSG(3,0)=" " 72 .S ORMMSG(4,0)=" The ORMTIME background job handles activating and expiring orders," 73 .S ORMMSG(5,0)=" some time based notifications, as well as purging of temporary CPRS" 74 .S ORMMSG(6,0)=" data. It is important that it runs regularly." 75 .S ORMMSG(7,0)=" " 76 .S ORMMSG(8,0)=" Assure that the scheduled option, ORMTIME RUN, is correctly implemented." 77 .S ORMMSG(9,0)=" " 78 .S XMTEXT="ORMMSG(" 79 .D ^XMD 80 Q 81 ; 1 ORMTIME ; SLC/RJS - PROCESS TIME BASED EVENT ;9/29/99 09:35 [2/1/00 9:30am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**40,253**;Dec 17, 1997 3 ; 4 EN ; Main entry tag. 5 ; 6 N OCXPSDT,OCXZTSK,OCXERR,OCXORMTR,OCXSTDT,OCXLOCK,OCXPAR 7 K ^TMP("OCXORMTIME",$J) 8 S OCXLOCK=0 9 S OCXORMTR="ORMTIME: Startup" 10 S OCXSTDT=$$EDATE($$IDATE("NOW")) 11 S ^TMP("OCXORMTIME",$J,"STATUS")="ORMTIME: Attempting to lock ^OR(100,""AE"") at "_OCXSTDT_"." 12 L +^OR(100,"AE"):10 13 I D 14 .S OCXLOCK=1 15 .D SCAN 16 .L -^OR(100,"AE") 17 .K ^TMP("OCXORMTIME") 18 .S OCXPAR=$$IDATE2("NOW") 19 .D PUT^XPAR("SYS","ORM ORMTIME LAST RUN",1,OCXPAR,.OCXERR) 20 S:'OCXLOCK ^TMP("OCXORMTIME",$J,"STATUS")="ORMTIME: Unable to lock ^OR(100,""AE"") at "_OCXSTDT_" attempt." 21 Q 22 ; 23 SCAN ; Call ORMTIM01 for order checking, etc. ORMTIM02 for misc time based tasks 24 ; 25 D SCAN^ORMTIM01 26 D MISC^ORMTIM02 27 Q 28 ; 29 EDATE(Y) X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y 30 ; 31 IDATE(X) N %DT,Y S %DT="F" D ^%DT Q Y 32 ; 33 IDATE2(X) N %DT,Y S %DT="TF" D ^%DT Q Y 34 ; 35 REQUEUE(ORMQT) ; Code formerly queued ORMTIME tasks in Taskman. 36 ; 37 ; (This tag kept for compatibility with outside calls.) 38 ; 39 Q 40 ; 41 STATUS ; Check status of last ORMTIME run. 42 ; 43 N ORMLAST 44 ; 45 ; Get date/time of last ORMTIME run: 46 S ORMLAST=$$GET^XPAR("SYS","ORM ORMTIME LAST RUN",1,"I") 47 S ORMLAST=$$EDATE(ORMLAST) ; Convert to external format for display. 48 ; 49 ; Present information to user: 50 W ! 51 W !," ORMTIME last ran "_ORMLAST_"." 52 W ! 53 ; 54 Q 55 ; 56 BULL ; Send a bulletin if ORMTIME's last run is greater than 24 hours. 57 ; 58 N DIC,ORMMSG,X,XMSUB,XMTEXT,XMY,XMZ,Y,ORMLAST 59 ; 60 ; Don't send bulletin if ORMTIME STATUS mail group does not exist: 61 S DIC=3.8,DIC(0)="",X="ORMTIME STATUS" 62 D ^DIC Q:(+Y<0) 63 ; 64 S ORMLAST=$$GET^XPAR("SYS","ORM ORMTIME LAST RUN",1,"I") 65 I $$FMDIFF^XLFDT($$IDATE2("NOW"),ORMLAST,2)>86400 D 66 .S XMY("G.ORMTIME STATUS")="" 67 .S XMSUB=" ORMTIME Warning" 68 .S ORMMSG(1,0)=" " 69 .S ORMMSG(2,0)=" The ORMTIME process last ran more than 24 hours ago. " 70 .S ORMMSG(3,0)=" " 71 .S ORMMSG(4,0)=" The ORMTIME background job handles activating and expiring orders," 72 .S ORMMSG(5,0)=" some time based notifications, as well as purging of temporary CPRS" 73 .S ORMMSG(6,0)=" data. It is important that it runs regularly." 74 .S ORMMSG(7,0)=" " 75 .S ORMMSG(8,0)=" Assure that the scheduled option, ORMTIME RUN, is correctly implemented." 76 .S ORMMSG(9,0)=" " 77 .S XMTEXT="ORMMSG(" 78 .D ^XMD 79 Q 80 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRF.m
r613 r623 1 ORPRF ;SLC/JLI-Patient record flag ;6/14/06 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**173,187,190,215,243**;Dec 17, 1997;Build 242 3 ; 4 FMT(ROOT) ; Format - Convert record flag data to displayable data 5 ; Sets ^TMP("ORPRF",$J,NN) with flag data for multiple flags 6 N IDX,IX,CNT 7 S (IDX,CNT)=0 8 F S IDX=$O(ROOT(IDX)) Q:'IDX D 9 . S ^TMP("ORPRF",$J,IDX,"FLAG")=$P($G(ROOT(IDX,"FLAG")),U,2) 10 . S ^TMP("ORPRF",$J,IDX,"CATEGORY")=$P($G(ROOT(IDX,"CATEGORY")),U,2) 11 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Name: "_$P($G(ROOT(IDX,"FLAG")),U,2) 12 . I $D(ROOT(IDX,"NARR")) D 13 . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=" " 14 . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Narrative: " 15 . . S IX=0 F S IX=$O(ROOT(IDX,"NARR",IX)) Q:'IX D 16 . . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=$G(ROOT(IDX,"NARR",IX,0)) 17 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=" " 18 . ; -- Assignment Details: 19 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Type: "_$P($G(ROOT(IDX,"FLAGTYPE")),U,2) 20 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Category: "_$P($G(ROOT(IDX,"CATEGORY")),U,2) 21 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Status: "_"Active" 22 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Initial Assigned Date: "_$P($G(ROOT(IDX,"ASSIGNDT")),U,2) 23 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Approved by: "_$P($G(ROOT(IDX,"APPRVBY")),U,2) 24 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Next Review Date: "_$P($G(ROOT(IDX,"REVIEWDT")),U,2) 25 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Owner Site: "_$P($G(ROOT(IDX,"OWNER")),U,2) 26 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Originating Site: "_$P($G(ROOT(IDX,"ORIGSITE")),U,2) 27 K ROOT 28 Q 29 ; 30 HASFLG(ORY,PTDFN) ;Does patient PTDFN has flags 31 ; DBIA 3860: $$GETACT^DGPFAPI(PTDFN,.FLGDATA) 32 ; Returns array ORY listing active assigned flags 33 ; Array ORY has form: 34 ; ORY(flagID) = flagID^flagname,CAT1 35 ; where CAT1 is 1 if flag is cat 1, 0 if cat 2 36 ; ORY = Num of items returned in array ORY = num of flags 37 I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q 38 N IDY,PRFARR,CAT1 39 K ^TMP("ORPRF",$J) 40 S ORY=$$GETACT^DGPFAPI(PTDFN,"PRFARR") 41 Q:'ORY 42 D FMT(.@("PRFARR")) ; Sets ^TMP("ORPRF" 43 S IDY=0 F S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY D 44 . S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG")) 45 . S CAT1=0 46 . I $G(^TMP("ORPRF",$J,IDY,"CATEGORY"))="I (NATIONAL)" S CAT1=1 47 . S ORY(IDY)=ORY(IDY)_U_CAT1 48 Q 49 ; 50 HASFLG1(ORY,PTDFN) ; Does patient PTDFN have **Cat I** flags 51 ; Returns array ORY listing active assigned Cat I flags 52 ; Array ORY has form: 53 ; ORY(flagID) = flagID^flagname 54 ; ORY = Num of Cat I flags 55 ; If pt has no Cat I flags ORY = 0 and no flags are returned. 56 ; Also calls FMT^ORPRF, which sets ^TMP("ORPRF" for Cat I flags 57 ; 58 I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q 59 N FLAGID,PRFARR,CAT1CNT,ACTFLGS 60 K ^TMP("ORPRF",$J) 61 S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR") 62 I 'ACTFLGS S ORY=0 Q 63 S (FLAGID,CAT1CNT)=0 64 F S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID D 65 . I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S CAT1CNT=CAT1CNT+1 Q 66 . K PRFARR(FLAGID) 67 I 'CAT1CNT S ORY=0 Q 68 D FMT(.@("PRFARR")) 69 S IDY=0 F S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY D 70 . S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG")) 71 S ORY=CAT1CNT 72 Q 73 ; 74 HASCAT1(HASCAT1,PTDFN) ;Does patient have Category I flags (no arrays) 75 ; Returns boolean HASCAT1 = 0 or 1 76 ; Does NOT set arrays or TMP globals 77 N FLAGID,PRFARR,ACTFLGS 78 S (HASCAT1,FLAGID)=0 79 S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR") I 'ACTFLGS G HASCAT1X 80 F S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID D Q:HASCAT1 81 . I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S HASCAT1=1 82 HASCAT1X ; 83 Q 84 ; 85 TRIGRPOP(POPUP,PTDFN) ;Should the flag display pop up upon patient selection 86 ; for patient PTDFN? 87 ;As of 1/10/06, returns POPUP as: 88 ; 1 if pt has any active flags, either Cat I or Cat II 89 ; 0 otherwise 90 N PRFARR 91 S POPUP=$S($$GETACT^DGPFAPI(PTDFN,"PRFARR"):1,1:0) 92 Q 93 ; 94 GETFLG(ORY,PTDFN,FLAGID) ;Return detailed flag info for flag FLAGID 95 I '$D(^TMP("ORPRF",$J,FLAGID)) Q 96 N IX,CNT 97 S (IX,CNT)=0 98 F S IX=$O(^TMP("ORPRF",$J,FLAGID,IX)) Q:'IX D 99 . S CNT=CNT+1,ORY(CNT)=$G(^TMP("ORPRF",$J,FLAGID,IX)) 100 Q 101 ; 102 CLEAR(ORY) ;Clear up the temp global 103 K ^TMP("ORPRF",$J) 104 Q 105 ; 1 ORPRF ;SLC/JLI-Patient record flag ;1/10/06 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**173,187,190,215**;Dec 17, 1997 3 ; 4 FMT(ROOT) ; Format - Convert record flag data to displayable data 5 ; Sets ^TMP("ORPRF",$J,NN) with flag data for multiple flags 6 N IDX,IX,CNT 7 S (IDX,CNT)=0 8 F S IDX=$O(ROOT(IDX)) Q:'IDX D 9 . S ^TMP("ORPRF",$J,IDX,"FLAG")=$P($G(ROOT(IDX,"FLAG")),U,2) 10 . S ^TMP("ORPRF",$J,IDX,"CATEGORY")=$P($G(ROOT(IDX,"CATEGORY")),U,2) 11 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Name: "_$P($G(ROOT(IDX,"FLAG")),U,2) 12 . I $D(ROOT(IDX,"NARR")) D 13 . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=" " 14 . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Narrative: " 15 . . S IX=0 F S IX=$O(ROOT(IDX,"NARR",IX)) Q:'IX D 16 . . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=$G(ROOT(IDX,"NARR",IX,0)) 17 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=" " 18 . ; -- Assignment Details: 19 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Type: "_$P($G(ROOT(IDX,"FLAGTYPE")),U,2) 20 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Category: "_$P($G(ROOT(IDX,"CATEGORY")),U,2) 21 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Status: "_"Active" 22 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Initial Assigned Date: "_$P($G(ROOT(IDX,"ASSIGNDT")),U,2) 23 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Approved by: "_$P($G(ROOT(IDX,"APPRVBY")),U,2) 24 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Next Review Date: "_$P($G(ROOT(IDX,"REVIEWDT")),U,2) 25 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Owner Site: "_$P($G(ROOT(IDX,"OWNER")),U,2) 26 . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Originating Site: "_$P($G(ROOT(IDX,"ORIGSITE")),U,2) 27 K ROOT 28 Q 29 ; 30 HASFLG(ORY,PTDFN) ;Does patient PTDFN has flags 31 ; DBIA 3860: $$GETACT^DGPFAPI(PTDFN,.FLGDATA) 32 ; Returns array ORY listing active assigned flags 33 ; Array ORY has form: 34 ; ORY(flagID) = flagID^flagname 35 ; ORY = Num of items returned in array ORY = num of flags 36 I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q 37 N IDY,PRFARR 38 K ^TMP("ORPRF",$J) 39 S ORY=$$GETACT^DGPFAPI(PTDFN,"PRFARR") 40 Q:'ORY 41 D FMT(.@("PRFARR")) ; Sets ^TMP("ORPRF" 42 S IDY=0 F S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY D 43 . S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG")) 44 Q 45 ; 46 HASFLG1(ORY,PTDFN) ; Does patient PTDFN have **Cat I** flags 47 ; Returns array ORY listing active assigned Cat I flags 48 ; Array ORY has form: 49 ; ORY(flagID) = flagID^flagname 50 ; ORY = Num of Cat I flags 51 ; If pt has no Cat I flags ORY = 0 and no flags are returned. 52 ; Also calls FMT^ORPRF, which sets ^TMP("ORPRF" for Cat I flags 53 ; 54 I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q 55 N FLAGID,PRFARR,CAT1CNT,ACTFLGS 56 K ^TMP("ORPRF",$J) 57 S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR") 58 I 'ACTFLGS S ORY=0 Q 59 S (FLAGID,CAT1CNT)=0 60 F S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID D 61 . I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S CAT1CNT=CAT1CNT+1 Q 62 . K PRFARR(FLAGID) 63 I 'CAT1CNT S ORY=0 Q 64 D FMT(.@("PRFARR")) 65 S IDY=0 F S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY D 66 . S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG")) 67 S ORY=CAT1CNT 68 Q 69 ; 70 HASCAT1(HASCAT1,PTDFN) ;Does patient have Category I flags (no arrays) 71 ; Returns boolean HASCAT1 = 0 or 1 72 ; Does NOT set arrays or TMP globals 73 N FLAGID,PRFARR,ACTFLGS 74 S (HASCAT1,FLAGID)=0 75 S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR") I 'ACTFLGS G HASCAT1X 76 F S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID D Q:HASCAT1 77 . I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S HASCAT1=1 78 HASCAT1X ; 79 Q 80 ; 81 TRIGRPOP(POPUP,PTDFN) ;Should the flag display pop up upon patient selection 82 ; for patient PTDFN? 83 ;As of 1/10/06, returns POPUP as: 84 ; 1 if pt has any active flags, either Cat I or Cat II 85 ; 0 otherwise 86 N PRFARR 87 S POPUP=$S($$GETACT^DGPFAPI(PTDFN,"PRFARR"):1,1:0) 88 Q 89 ; 90 GETFLG(ORY,PTDFN,FLAGID) ;Return detailed flag info for flag FLAGID 91 I '$D(^TMP("ORPRF",$J,FLAGID)) Q 92 N IX,CNT 93 S (IX,CNT)=0 94 F S IX=$O(^TMP("ORPRF",$J,FLAGID,IX)) Q:'IX D 95 . S CNT=CNT+1,ORY(CNT)=$G(^TMP("ORPRF",$J,FLAGID,IX)) 96 Q 97 ; 98 CLEAR(ORY) ;Clear up the temp global 99 K ^TMP("ORPRF",$J) 100 Q 101 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRPM.m
r613 r623 1 ORPRPM ;DAN/SLC Performance Measure; ;4/8/04 10:20 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**107,114,119,196,190,243**;Dec 17, 1997;Build 242 3 ; 4 ;DBIA SECTION 5 ;4195 - EN^PSOTPCUL 6 ; 7 ;This routine will print a report indicating the percent of 8 ;orders entered for a provider by a provider holding the ORES key. 9 ;The data for the report will be stored in ^TMP as follows: 10 ;^TMP($J,"SUM",Provider Name,Patient Status)=Total # of order (universe)^Denominator^Numerator^Verbal^Written^Telephone^Policy^Electronically entered^Student entered^Outpatient narcotic orders 11 ;Where Patient Status is I for inpatient or O for outpatient. 12 ; 13 N DIR,ORSD,ORED,ORPROV,ORTYPE,ORPT,ORREP,ORPIECE,Y,DIRUT,DUOUT,DTOUT,ZTRTN,ORDT,ORIEN,ORACT0,ORPVID,PG,REPDT,ORSTOP,ORI,ORJ,ORPAT,ORTOT,ORSTOT,X,ORPVNM,ORORD,ORPTST,ORP,ORWROTE,ORNS,ORFS,ORPFILE 14 D GETDATE K DIR Q:$D(DIRUT) ;quit if no dates selected ;get start and end dates 15 D GETPROV K DIR Q:'$D(ORPROV)!($G(ORPROV)'="ALL"&($D(ORPROV)'=11))!($D(DUOUT))!($D(DTOUT)) ;quit if user didn't select all providers or if didn't choose individual providers or if user timed out or up-arrowed out 16 D GETOTHER Q:$D(DIRUT) ;quit if any questions were unanswered in this section 17 I DUZ=1395 D DQ Q 18 S ZTRTN="DQ^ORPRPM" D QUE^ORUTL1(ZTRTN,"CPRS Performance Monitor") 19 Q 20 ; 21 GETDATE ;Prompt for start and end dates 22 S DIR(0)="DO^:DT:AE",DIR("A")="Enter starting date",DIR("?")="Enter date to begin searching from" D ^DIR Q:$D(DIRUT) S ORSD=Y 23 S DIR(0)="DOA^"_ORSD_":DT:AE",DIR("A")="Enter ending date: ",DIR("?")="Enter date to stop searching. Must be between "_$$FMTE^XLFDT(ORSD,2)_" and "_$$FMTE^XLFDT(DT,2) D ^DIR Q:$D(DIRUT) 24 S ORED=Y_.24,ORSD=ORSD-.1 ;Set end date to end of day, start date back to include current day 25 Q ;End GETDATE 26 ; 27 GETPROV ;Allow selection of all/single/multiple providers 28 ;return ORPROV="ALL" for all providers or ORPROV array for individual providers 29 S DIR(0)="Y",DIR("A")="Do you want ALL providers to appear on this report",DIR("B")="Y",DIR("?")="Enter Yes to search for all providers. Enter No to select individual providers" D ^DIR Q:$D(DIRUT) S ORPROV=$S(Y=1:"ALL",1:"") Q:ORPROV="ALL" 30 K DIR ;clear DIR variables before getting individual providers 31 F D Q:$D(DIRUT) ;quit when finished selecting 32 .S DIR(0)="PO^200:AEQM",DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))",DIR("A")="Select "_$S($D(ORPROV)=11:"another ",1:"")_"provider" 33 .S DIR("?")="Select providers to appear on report. Return when finished, ^ to stop processing" D ^DIR Q:$D(DIRUT) S ORPROV(+Y)="" 34 Q ;End GETPROV 35 ; 36 GETOTHER ;Get order type, patient type, and summary only report response 37 ;Get order type first 38 S DIR(0)="S^A:All orders;P:Pharmacy orders only",DIR("A")="Select order category",DIR("B")="P",DIR("?")="Enter P to see pharmacy orders only. Enter A to see all orders. Enter ^ to quit" D ^DIR Q:$D(DIRUT) S ORTYPE=Y 39 K DIR 40 ;Get patient status 41 S DIR(0)="S^I:Inpatient;O:Outpatient;B:Both",DIR("A")="Select patient status",DIR("B")="B",DIR("?")="Enter patient status at time of order. Enter ^ to quit" D ^DIR Q:$D(DIRUT) S ORPT=Y 42 K DIR 43 ;Ask if user desires facility subtotal, summary, detail, or both (detail and summary) reports 44 S DIR(0)="S^S:Summary (includes provider details);D:Detail (includes order details);B:Both (Summary & Detail);T:Summary Report Totals Only (no provider details)",DIR("A")="Select report",DIR("B")="S" 45 D ^DIR Q:$D(DIRUT) S ORREP=Y,ORFS=0 I Y="T" S ORREP="S",ORFS=1 46 K DIR 47 Q ;End GETOTHER 48 ; 49 DQ ;Come here to do build and print from QUE^ORUTL either direct or tasked 50 U IO K ^TMP($J) ;clean out temp space 51 S ORDT=ORSD F S ORDT=$O(^OR(100,"AF",ORDT)) Q:'ORDT!(ORDT>ORED) S ORIEN="" F S ORIEN=$O(^OR(100,"AF",ORDT,ORIEN)) Q:'ORIEN I $O(^OR(100,"AF",ORDT,ORIEN,0))=1 I $D(^OR(100,ORIEN,8,1,0)) D CHECK 52 D PRINT^ORPRPM1 53 K ^TMP($J) 54 Q 55 ; 56 CHECK ;If order matches requirements then save 57 S ORPFILE=$P($G(^OR(100,ORIEN,0)),"^",2) Q:ORPFILE="" ;Quit if no object of order 58 I $P(ORPFILE,";",2)["DPT" Q:$P($G(^DPT(+$P($G(^OR(100,ORIEN,0)),"^",2),0)),"^",21) ;Quit if test patient 59 Q:+$P($G(^OR(100,ORIEN,3)),"^",11)'=0 ;190 quit if order type not standard 60 S ORPTST=$P($G(^OR(100,ORIEN,0)),"^",12) ;patient status (in/out) 61 I ORPT'="B" Q:ORPTST'=ORPT ;Quit if patient status is not 'both' and status doesn't match selected status 62 S ORNS=$$NMSP^ORCD($P($G(^OR(100,ORIEN,0)),"^",14)) 63 I ORTYPE'="A"&(ORNS'="PS") Q ;if not getting all types of orders then quit if order is not from pharmacy 64 I ORPTST="O",ORNS="PS",$G(^OR(100,ORIEN,4))=+$G(^OR(100,ORIEN,4)),$L($T(EN^PSOTPCUL)) Q:$$EN^PSOTPCUL($G(^OR(100,ORIEN,4))) ;196 Don't count if outpatient pharm order is a transitional pharmacy benefit order 65 S ORACT0=$G(^OR(100,ORIEN,8,1,0)),ORORD=$P(ORACT0,"^",12) ;ORORD holds nature of order ien 66 S ORPVID=$P(ORACT0,"^",3) I ORPROV'="ALL" Q:'$D(ORPROV(ORPVID)) ;quit if ordering provider doesn't match user selected provider 67 S ORPVNM=$P($G(^VA(200,ORPVID,0)),"^") ;get provider name 68 Q:'$D(^XUSEC("ORES",ORPVID)) ;quit if ordering provider doesn't have ORES key DBIA # 10076 allows direct read of XUSEC 69 Q:"^1^2^3^5^8^"'[("^"_ORORD_"^") ;quit if NATURE OF ORDER is not verbal, written, telephoned, policy, or electronically entered 70 D COUNT ;Count order 71 Q 72 ; 73 COUNT ;This section determines how the order should be counted 74 N OREB,ORPIECE 75 D ADD(1) ;Add one to universe (total # of orders) 76 S OREB=$P(ORACT0,"^",13) ;Entered by 77 S ^TMP($J,"DET",ORPVNM,ORIEN)=$D(^XUSEC("ORES",OREB))&(OREB=ORPVID) ;Mark "HAS ORES" column for detailed listing if entered by = provider and has ORES key 78 I OREB=ORPVID D ADD(2),ADD(3) Q ;if order entered by provider then add one to denominator and numerator 79 I ORNS="PS" I $$OIDEA=1 D ADD(10) Q ;If order requires wet signature add one to narcotic group 80 I $$STUDENT D ADD(9) Q ;If order entered by student add one to student group 81 S ORPIECE=$S(ORORD=1:4,ORORD=2:5,ORORD=3:6,ORORD=8:7,1:8) D ADD(ORPIECE) ;add to exceptions group for orders not entered by provider 82 I ORORD'=5 D ADD(2) ;Add to denominator if not policy order 83 Q 84 ; 85 ADD(PIECE) ;Add one to storage 86 S $P(^TMP($J,"SUM",ORPVNM,ORPTST),"^",PIECE)=$P($G(^TMP($J,"SUM",ORPVNM,ORPTST)),"^",PIECE)+1 Q 87 ; 88 OIDEA() ;Check to see if pharmacy order requires wet signature 89 ;dbia 3373 allows call to pharmacy API or dbia 221 allows direct read of ^PSDRUG if routine doesn't exist yet 90 N OI,PSOI,SIGREQ,PSSXOLP,PSSXOLPD,PSSXOLPX,PSSXNODD,PSSPKLX 91 Q:ORPTST'="O" 0 ;quit if inpatient 92 S OI=$$VALUE^ORX8(ORIEN,"ORDERABLE") ;get orderable item 93 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) I PSOI'>0 Q 0 ;quit if no pharmacy orderable item 94 I $L($T(OIDEA^PSSUTLA1)) S SIGREQ=$$OIDEA^PSSUTLA1(PSOI,"O") Q:SIGREQ=1 1 Q 0 ;If SIGREQ = 1 then wet signature required 95 S (PSSXOLPD,PSSXNODD)=0 96 S PSSPKLX=0 97 K ^TMP($J,"ORPRPM ASP") 98 D ASP^PSS50(PSOI,,,"ORPRPM ASP") 99 F PSSXOLP=0:0 S PSSXOLP=$O(^TMP($J,"ORPRPM ASP","")) Q:'PSSXOLP!(PSSXOLPD=1) D 100 .K ^TMP($J,"ORPRPM DATA") D DATA^PSS50(PSSXOLP,,(DT-1),,,"ORPRPM DATA") I +^TMP($J,"ORPRPM DATA",0)<0 Q 101 .I 'PSSPKLX,$G(^TMP($J,"ORPRPM DATA",63))'["O" K ^TMP($J,"ORPRPM DATA") Q 102 .I PSSPKLX I $G(^TMP($J,"ORPRPM DATA",63))'["U",$G(^TMP($J,"ORPRPM DATA",63))'["I" Q 103 .S PSSXNODD=1 104 .S PSSXOLPX=$G(^TMP($J,"ORPRPM DATA",3)) 105 .I PSSXOLPX[1!(PSSXOLPX[2)!((PSSXOLPX[3)&(PSSXOLPX["A")) S PSSXOLPD=1 Q 106 .I PSSXOLPX[3!(PSSXOLPX[4)!(PSSXOLPX[5) S PSSXOLPD=2 107 I PSSXOLPD=0,'PSSXNODD S PSSXOLPD="" 108 K ^TMP($J,"ORPRPM ASP") 109 K ^TMP($J,"ORPRPM DATA") 110 Q PSSXOLPD 111 ; 112 STUDENT() ;Check to see if entered by is a student 113 ;Check USER CLASS for membership in "STUDENT" CLASS - DBIA 2324 114 ;Then check PROVIDER CLASS in NEW PERSON file for "STUDENT" - DBIA 10060 115 N ORCLASS,ORSUB,EXPIRE,ORUSR 116 D WHATIS^USRLM(OREB,"ORCLASS") ;API to get user class membership 117 S ORSUB=0,ORUSR=0 F S ORSUB=$O(ORCLASS(ORSUB)) Q:ORSUB=""!ORUSR D 118 .I $$UP^XLFSTR(ORSUB)'["STUDENT" Q ;User not a member of student class 119 .I ORDT'<+$P(ORCLASS(ORSUB),"^",4) S EXPIRE=$S(+$P(ORCLASS(ORSUB),"^",5):$P(ORCLASS(ORSUB),"^",5),1:9999999) I ORDT'>EXPIRE S ORUSR=1 ;member of student class and within date range for class 120 I ORUSR Q 1 ;User identified as a student 121 K ORCLASS 122 S DIC=200,DR=53.5,DA=OREB,DIQ="ORCLASS",DIQ(0)="E" D EN^DIQ1 123 I $G(ORCLASS(200,OREB,53.5,"E"))["STUDENT" Q 1 ;Provider class set to student 124 Q 0 ;User not a student 1 ORPRPM ;DAN/SLC Performance Measure; ;10/7/04 09:08 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**107,114,119,196,190,225**;Dec 17, 1997 3 ; 4 ;DBIA SECTION 5 ;4195 - EN^PSOTPCUL 6 ;3744 - $$TESTPAT^VADPT 7 ;10060- Reference to file 200 8 ; 9 ;This routine will print a report indicating the percent of 10 ;orders entered for a provider by a provider holding the ORES key. 11 ;The data for the report will be stored in ^TMP as follows: 12 ;^TMP($J,"SUM",Provider Name,Patient Status)=Total # of order (universe)^Denominator^Numerator^Verbal^Written^Telephone^Policy^Electronically entered^Student entered^Outpatient narcotic orders 13 ;Where Patient Status is I for inpatient or O for outpatient. 14 ; 15 N DIR,ORSD,ORED,ORPROV,ORTYPE,ORPT,ORREP,ORPIECE,Y,DIRUT,DUOUT,DTOUT,ZTRTN,ORDT,ORIEN,ORACT0,ORPVID,PG,REPDT,ORSTOP,ORI,ORJ,ORPAT,ORTOT,ORSTOT,X,ORPVNM,ORORD,ORPTST,ORP,ORWROTE,ORNS,ORFS,ORPFILE 16 D GETDATE K DIR Q:$D(DIRUT) ;quit if no dates selected ;get start and end dates 17 D GETPROV K DIR Q:'$D(ORPROV)!($G(ORPROV)'="ALL"&($D(ORPROV)'=11))!($D(DUOUT))!($D(DTOUT)) ;quit if user didn't select all providers or if didn't choose individual providers or if user timed out or up-arrowed out 18 D GETOTHER Q:$D(DIRUT) ;quit if any questions were unanswered in this section 19 S ZTRTN="DQ^ORPRPM" D QUE^ORUTL1(ZTRTN,"CPRS Performance Monitor") 20 Q 21 ; 22 GETDATE ;Prompt for start and end dates 23 S DIR(0)="DO^:DT:AE",DIR("A")="Enter starting date",DIR("?")="Enter date to begin searching from" D ^DIR Q:$D(DIRUT) S ORSD=Y 24 S DIR(0)="DOA^"_ORSD_":DT:AE",DIR("A")="Enter ending date: ",DIR("?")="Enter date to stop searching. Must be between "_$$FMTE^XLFDT(ORSD,2)_" and "_$$FMTE^XLFDT(DT,2) D ^DIR Q:$D(DIRUT) 25 S ORED=Y_.24,ORSD=ORSD-.1 ;Set end date to end of day, start date back to include current day 26 Q ;End GETDATE 27 ; 28 GETPROV ;Allow selection of all/single/multiple providers 29 ;return ORPROV="ALL" for all providers or ORPROV array for individual providers 30 S DIR(0)="Y",DIR("A")="Do you want ALL providers to appear on this report",DIR("B")="Y",DIR("?")="Enter Yes to search for all providers. Enter No to select individual providers" D ^DIR Q:$D(DIRUT) S ORPROV=$S(Y=1:"ALL",1:"") Q:ORPROV="ALL" 31 K DIR ;clear DIR variables before getting individual providers 32 F D Q:$D(DIRUT) ;quit when finished selecting 33 .S DIR(0)="PO^200:AEQM",DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))",DIR("A")="Select "_$S($D(ORPROV)=11:"another ",1:"")_"provider" 34 .S DIR("?")="Select providers to appear on report. Return when finished, ^ to stop processing" D ^DIR Q:$D(DIRUT) S ORPROV(+Y)="" 35 Q ;End GETPROV 36 ; 37 GETOTHER ;Get order type, patient type, and summary only report response 38 ;Get order type first 39 S DIR(0)="S^A:All orders;P:Pharmacy orders only",DIR("A")="Select order category",DIR("B")="P",DIR("?")="Enter P to see pharmacy orders only. Enter A to see all orders. Enter ^ to quit" D ^DIR Q:$D(DIRUT) S ORTYPE=Y 40 K DIR 41 ;Get patient status 42 S DIR(0)="S^I:Inpatient;O:Outpatient;B:Both",DIR("A")="Select patient status",DIR("B")="B",DIR("?")="Enter patient status at time of order. Enter ^ to quit" D ^DIR Q:$D(DIRUT) S ORPT=Y 43 K DIR 44 ;Ask if user desires facility subtotal, summary, detail, or both (detail and summary) reports 45 S DIR(0)="S^S:Summary (includes provider details);D:Detail (includes order details);B:Both (Summary & Detail);T:Summary Report Totals Only (no provider details)",DIR("A")="Select report",DIR("B")="S" 46 D ^DIR Q:$D(DIRUT) S ORREP=Y,ORFS=0 I Y="T" S ORREP="S",ORFS=1 47 K DIR 48 Q ;End GETOTHER 49 ; 50 DQ ;Come here to do build and print from QUE^ORUTL either direct or tasked 51 U IO K ^TMP($J) ;clean out temp space 52 S ORDT=ORSD F S ORDT=$O(^OR(100,"AF",ORDT)) Q:'ORDT!(ORDT>ORED) S ORIEN="" F S ORIEN=$O(^OR(100,"AF",ORDT,ORIEN)) Q:'ORIEN I $O(^OR(100,"AF",ORDT,ORIEN,0))=1 I $D(^OR(100,ORIEN,8,1,0)) D CHECK 53 D PRINT^ORPRPM1 54 K ^TMP($J) 55 Q 56 ; 57 CHECK ;If order matches requirements then save 58 S ORPFILE=$P($G(^OR(100,ORIEN,0)),"^",2) Q:ORPFILE="" ;Quit if no object of order 59 I $P(ORPFILE,";",2)["DPT" Q:$$TESTPAT^VADPT(+$P($G(^OR(100,ORIEN,0)),"^",2)) ;225 Quit if test patient 60 Q:+$P($G(^OR(100,ORIEN,3)),"^",11)'=0 ;190 quit if order type not standard 61 Q:$P(^ORD(100.98,$P(^OR(100,ORIEN,0),U,11),0),U)="NON-VA MEDICATIONS" ;225 Quit if Non-VA med entry 62 S ORPTST=$P($G(^OR(100,ORIEN,0)),"^",12) ;patient status (in/out) 63 I ORPT'="B" Q:ORPTST'=ORPT ;Quit if patient status is not 'both' and status doesn't match selected status 64 S ORNS=$$NMSP^ORCD($P($G(^OR(100,ORIEN,0)),"^",14)) 65 I ORTYPE'="A"&(ORNS'="PS") Q ;if not getting all types of orders then quit if order is not from pharmacy 66 I ORPTST="O",ORNS="PS",$G(^OR(100,ORIEN,4))=+$G(^OR(100,ORIEN,4)),$L($T(EN^PSOTPCUL)) Q:$$EN^PSOTPCUL($G(^OR(100,ORIEN,4))) ;196 Don't count if outpatient pharm order is a transitional pharmacy benefit order 67 S ORACT0=$G(^OR(100,ORIEN,8,1,0)),ORORD=$P(ORACT0,"^",12) ;ORORD holds nature of order ien 68 S ORPVID=$P(ORACT0,"^",3) I ORPROV'="ALL" Q:'$D(ORPROV(ORPVID)) ;quit if ordering provider doesn't match user selected provider 69 S ORPVNM=$$GET1^DIQ(200,ORPVID_",",.01) ;225 get provider name 70 Q:'$D(^XUSEC("ORES",ORPVID)) ;quit if ordering provider doesn't have ORES key DBIA # 10076 allows direct read of XUSEC 71 Q:"^1^2^3^5^8^"'[("^"_ORORD_"^") ;quit if NATURE OF ORDER is not verbal, written, telephoned, policy, or electronically entered 72 D COUNT ;Count order 73 Q 74 ; 75 COUNT ;This section determines how the order should be counted 76 N OREB,ORPIECE 77 D ADD(1) ;Add one to universe (total # of orders) 78 S OREB=$P(ORACT0,"^",13) ;Entered by 79 S ^TMP($J,"DET",ORPVNM,ORIEN)=$D(^XUSEC("ORES",OREB))&(OREB=ORPVID) ;Mark "HAS ORES" column for detailed listing if entered by = provider and has ORES key 80 I OREB=ORPVID D ADD(2),ADD(3) Q ;if order entered by provider then add one to denominator and numerator 81 I ORNS="PS" I $$OIDEA=1 D ADD(10) Q ;If order requires wet signature add one to narcotic group 82 I $$STUDENT D ADD(9) Q ;If order entered by student add one to student group 83 S ORPIECE=$S(ORORD=1:4,ORORD=2:5,ORORD=3:6,ORORD=8:7,1:8) D ADD(ORPIECE) ;add to exceptions group for orders not entered by provider 84 I ORORD'=5 D ADD(2) ;Add to denominator if not policy order 85 Q 86 ; 87 ADD(PIECE) ;Add one to storage 88 S $P(^TMP($J,"SUM",ORPVNM,ORPTST),"^",PIECE)=$P($G(^TMP($J,"SUM",ORPVNM,ORPTST)),"^",PIECE)+1 Q 89 ; 90 OIDEA() ;Check to see if pharmacy order requires wet signature 91 ;dbia 3373 allows call to pharmacy API or dbia 221 allows direct read of ^PSDRUG if routine doesn't exist yet 92 N OI,PSOI,SIGREQ,PSSXOLP,PSSXOLPD,PSSXOLPX,PSSXNODD,PSSPKLX 93 Q:ORPTST'="O" 0 ;quit if inpatient 94 S OI=$$VALUE^ORX8(ORIEN,"ORDERABLE") ;get orderable item 95 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) I PSOI'>0 Q 0 ;quit if no pharmacy orderable item 96 I $L($T(OIDEA^PSSUTLA1)) S SIGREQ=$$OIDEA^PSSUTLA1(PSOI,"O") Q:SIGREQ=1 1 Q 0 ;If SIGREQ = 1 then wet signature required 97 S (PSSXOLPD,PSSXNODD)=0 98 S PSSPKLX=0 99 F PSSXOLP=0:0 S PSSXOLP=$O(^PSDRUG("ASP",PSOI,PSSXOLP)) Q:'PSSXOLP!(PSSXOLPD=1) D 100 .I $P($G(^PSDRUG(PSSXOLP,"I")),"^"),$P($G(^("I")),"^")<DT Q 101 .I 'PSSPKLX,$P($G(^PSDRUG(PSSXOLP,2)),"^",3)'["O" Q 102 .I PSSPKLX I $P($G(^PSDRUG(PSSXOLP,2)),"^",3)'["U",$P($G(^(2)),"^",3)'["I" Q 103 .S PSSXNODD=1 104 .S PSSXOLPX=$P($G(^PSDRUG(PSSXOLP,0)),"^",3) 105 .I PSSXOLPX[1!(PSSXOLPX[2)!((PSSXOLPX[3)&(PSSXOLPX["A")) S PSSXOLPD=1 Q 106 .I PSSXOLPX[3!(PSSXOLPX[4)!(PSSXOLPX[5) S PSSXOLPD=2 107 I PSSXOLPD=0,'PSSXNODD S PSSXOLPD="" 108 Q PSSXOLPD 109 ; 110 STUDENT() ;Check to see if entered by is a student 111 ;Check USER CLASS for membership in "STUDENT" CLASS - DBIA 2324 112 ;Then check PROVIDER CLASS in NEW PERSON file for "STUDENT" - DBIA 10060 113 N ORCLASS,ORSUB,EXPIRE,ORUSR 114 D WHATIS^USRLM(OREB,"ORCLASS") ;API to get user class membership 115 S ORSUB=0,ORUSR=0 F S ORSUB=$O(ORCLASS(ORSUB)) Q:ORSUB=""!ORUSR D 116 .I $$UP^XLFSTR(ORSUB)'["STUDENT" Q ;User not a member of student class 117 .I ORDT'<+$P(ORCLASS(ORSUB),"^",4) S EXPIRE=$S(+$P(ORCLASS(ORSUB),"^",5):$P(ORCLASS(ORSUB),"^",5),1:9999999) I ORDT'>EXPIRE S ORUSR=1 ;member of student class and within date range for class 118 I ORUSR Q 1 ;User identified as a student 119 K ORCLASS 120 S DIC=200,DR=53.5,DA=OREB,DIQ="ORCLASS",DIQ(0)="E" D EN^DIQ1 121 I $G(ORCLASS(200,OREB,53.5,"E"))["STUDENT" Q 1 ;Provider class set to student 122 Q 0 ;User not a student -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRS07.m
r613 r623 1 ORPRS07 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**281**;Dec 17, 1997;Build 14 3 EN 4 5 6 7 MAIN(ORVP) 8 9 10 11 12 13 14 15 16 17 18 19 EXIT 20 21 22 23 24 25 26 OUTPUT 27 28 29 30 31 32 33 34 35 REPORT(ORVP) 36 37 38 39 . S XQORNOD=$P(ORSRPT(ORSJ),U,2)_";ORD(101,",ORMETHOD=$G(^ORD(101,+XQORNOD,101.05,20,1))40 . I $D(ORSSTRT)>9,+XQORNOD S ORSSTRT=+$G(ORSSTRT(+XQORNOD)),ORH=$P($G(ORSSTRT(+XQORNOD)),U,2)41 . I $D(ORSSTOP)>9,+XQORNOD S ORSSTOP=+$G(ORSSTOP(+XQORNOD)),ORH2=$P($G(ORSSTOP(+XQORNOD)),U,2)42 43 44 45 46 DEVICE 47 48 49 50 51 52 QUE 53 54 55 56 57 58 NOQUE 59 60 61 62 1 ORPRS07 ; slc/dcm - Managing multiple reportz ;6/10/97 15:43 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 3 EN ;Entry point 4 N ORVP 5 D MAIN("") 6 Q 7 MAIN(ORVP) ; Controls branching 8 N DFN,DIC,GMTYP,I,ORANSI,ORDG,OREND,ORH,ORH2,ORPRES,ORSCPAT,ORSDG 9 N ORSHORT,ORSRI,ORSRPT,ORSSTOP,ORSSTRT,ORTIT,ORWHL,VAROOT,XQORSPEW,X,Y 10 N ORAGE,ORATTEND,ORDOB,ORL,ORNP,ORPD,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD 11 N ORSDG,ORURMBD,ORX,ORCONT,OROPREF 12 I '+$G(ORVP) D P^ORPRS01 Q:$D(ORSCPAT)'>9 13 S ORANSI=0,XQORFLG("SH")=1 14 S (ORANSI,OREND,X)=0 15 I +$G(ORSCPAT)=1,+$G(ORSCPAT(1)) S ORVP=+$G(ORSCPAT(1))_";DPT(",Y=+ORVP D HOMO^ORUDPA 16 S DIC=101 S X="ORS REPORT MENU" D EN^XQOR 17 K VA200,VAERR,VAIN,VADM 18 Q 19 EXIT ; Queue output 20 N DUOUT,ORSRI,ORSRPT,ZTDESC,ZTRTN,ZTSAVE S OREND=+$G(OREND) 21 S ORSRI=0 F S ORSRI=$O(Y(ORSRI)) Q:ORSRI'>0 S ORSRPT=ORSRI,ORSRPT(ORSRI)=Y(ORSRI) 22 I $S($D(XQORPOP):1,$G(OREND)=1:1,$D(DUOUT):1,$D(DIROUT):1,'$D(ORSRPT):1,'$D(ORSCPAT)&'+$G(ORVP):1,1:0) Q 23 S (ZTSAVE("OR*"),ZTSAVE("GM*"),ZTSAVE("LR*"))="",IO("Q")=1 24 S ZTRTN="OUTPUT^ORPRS07",ZTDESC="Results Reporting" W ! D DEVICE 25 Q 26 OUTPUT ; Loops through ORSRPT( and queues each report 27 N DIROUT,DIRUT,ORH,ORH2,ORMETHOD,ORSEND,ORSHORT,ORSI,ORSJ,ORSRI,ORTIT,ORWHL,X 28 N XQORNOD,XQORSPEW,XY,ORSLTR,ORSPNM,ORDG,ORION S ORION=$G(ION) 29 I +$G(ORVP) D REPORT(ORVP) K OROLOC,ORSSTOP,ORSSTRT,VAROOT,VA,X1 Q 30 S ORSI=0 F S ORSI=$O(ORSCPAT(ORSI)) Q:ORSI'>0!($G(DIROUT))!($$S^%ZTLOAD) S:'$O(ORSCPAT(ORSI)) ORSEND=1 D 31 . S ORVP=+ORSCPAT(ORSI)_";DPT(",ORSPNM=$P(ORSCPAT(ORSI),U,2) 32 . D REPORT(ORVP) 33 K ORNO,ORSPG 34 Q 35 REPORT(ORVP) ; Loops through ORSRPT( and prints all reports for ea patient 36 N ORSJ,ORSSTFLG,XQORNOD 37 U IO 38 S ORSJ=0 F S ORSJ=$O(ORSRPT(ORSJ)) Q:ORSJ'>0!+$G(DIROUT)!$G(OREND) D 39 . S XQORNOD=$P(ORSRPT(ORSJ),U,2),ORMETHOD=$G(^ORD(101,+XQORNOD,101.05,20,1)) 40 . I $D(ORSSTRT)>9,+XQORNOD S ORSSTRT=+$G(ORSSTRT(XQORNOD)),ORH=$P($G(ORSSTRT(XQORNOD)),U,2) 41 . I $D(ORSSTOP)>9,+XQORNOD S ORSSTOP=+$G(ORSSTOP(XQORNOD)),ORH2=$P($G(ORSSTOP(XQORNOD)),U,2) 42 . I $D(ORSDG(+XQORNOD)) S ORDG=$G(ORSDG(+XQORNOD)) 43 . I $L(ORMETHOD) X ORMETHOD I $G(ION)'=ORION S IOP=ORION D ^%ZIS 44 . I +$G(ORSSTFLG) D STOP^ORPRS01 S ORSSTFLG=0 45 Q 46 DEVICE ; Device Handling/Output control 47 N IO,IOP,%ZIS 48 S %ZIS="Q",%ZIS("B")="HOME" D ^%ZIS Q:POP 49 I +$G(ORSRPT)>1,(IO'=IO(0)),'$D(IO("Q")) W !,"Printing of multiple reports requires queueing.",! 50 D @$S(+$G(ORSRPT)>1&(IO'=IO(0)):"QUE",$D(IO("Q")):"QUE",1:"NOQUE") 51 Q 52 QUE ; Set ZT parameters and tasks ZTRTN 53 N ZTIO K IO("Q") 54 S ZTIO=ION 55 D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!") 56 K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE D ^%ZISC 57 Q 58 NOQUE ; Calls ZTRTN in interactive mode 59 I IO'=IO(0) U IO 60 D @ZTRTN 61 D ^%ZISC 62 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ11.m
r613 r623 1 ORQ11 ;slc/dcm-Get patient orders in context ;3/31/04 09:57 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,78,99,94,148,141,177,186,190,195,215,243**;Dec 17, 1997;Build 242 3 LOOP ; -- main loop through "ACT" x-ref 4 I $G(XREF)="AW" D AW Q 5 I $G(FLG)=27 D EXPD^ORQ12 Q 6 K ^TMP("ORGOTIT",$J) 7 AWIN ;Jump in here to add active orders to AW context 8 N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X ;195 9 S NOW=+$E($$NOW^XLFDT,1,12),TM=SDATE 10 F S TM=$O(^OR(100,"ACT",PAT,TM)) Q:'TM!(TM>EDATE) S TO=0 F S TO=$O(^OR(100,"ACT",PAT,TM,TO)) Q:'TO I $D(ORGRP(TO)) D 11 . S IFN=0 F S IFN=$O(^OR(100,"ACT",PAT,TM,TO,IFN)) Q:'IFN I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT),$D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D 12 .. S ACTOR=0 F S ACTOR=$O(^OR(100,"ACT",PAT,TM,TO,IFN,ACTOR)) Q:ACTOR<1 I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13!(FLG=1) S X8=^(0),X7=$G(^(7)) D LP1 13 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 14 Q 15 AW ; -- loop through "AW" x-ref 16 K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J) 17 N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X ;195 18 S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE 19 F S TO=$O(^OR(100,"AW",PAT,TO)) Q:'TO I $D(ORGRP(TO)) S TM=EDATE F S TM=$O(^OR(100,"AW",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TM<EDATE) D 20 . S IFN=0 F S IFN=$O(^OR(100,"AW",PAT,TO,TM,IFN)) Q:'IFN I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT) D 21 .. S ^TMP("ORSORT",$J,9999999-TM,TO,IFN)="" 22 S TM=0 F S TM=$O(^TMP("ORSORT",$J,TM)) Q:'TM S TO=0 F S TO=$O(^TMP("ORSORT",$J,TM,TO)) Q:'TO D 23 . S IFN=0 F S IFN=$O(^TMP("ORSORT",$J,TM,TO,IFN)) Q:'IFN I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D 24 .. S ACTOR=0 F S ACTOR=$O(^OR(100,"ACT",PAT,9999999-$P(X0,U,7),TO,IFN,ACTOR)) Q:ACTOR<1 I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0),X7=$G(^(7)) D LP1 25 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 26 I +$$GET^XPAR("SYS","OR ORDER SUMMARY CONTEXT",1,"I")=2 S SDATE=9999999-SDATE,EDATE=9999999-EDATE D AWIN 27 K ^TMP("ORSORT",$J),^TMP("ORGOTIT",$J) 28 Q 29 LP1 ; -- main secondary loop 30 N STS ;195 31 N TAG 32 Q:$P(X3,U,8) Q:$P(X3,U,3)=99 S STS=$P(X3,U,3) 33 I '$G(GETKID),$P(X3,U,9),'$P($G(^OR(100,$P(X3,U,9),3)),U,8),FLG'=11 Q 34 I $L($P(X0,U,17)),"^10^11^"[(U_STS_U) S X=$$LAPSED^OREVNTX($P(X0,U,17)) 35 S TAG=$S(FLG=2:"CUR1",FLG=4:"COM1",FLG=5:"EXG1",FLG=7:"PEN1",FLG=8:"UVR1",FLG=9:"UVN1",FLG=10:"UVC1",FLG=12:"FLG1",FLG=13:"VP1",FLG=14:"VPU1",FLG=18:"HLD1",FLG=20:"CHT1",FLG=21:"CHTSUM",FLG=22:"LPS1",FLG=23:"AVT1",1:"ALL1") 36 I TAG="ALL1" S TAG=$S(FLG=3:"DC1",FLG=28:"DC1",1:"ALL1") 37 D @TAG 38 Q 39 ; ** FLG context specific loops: 40 ; 41 ALL1 ; 1 -- secondary pass for All, Recent Orders, Unsigned 42 D GET^ORQ12(IFN,ORLIST,DETAIL,$G(ACTOR)) 43 Q 44 ; 45 CUR ; 2 -- Active/Current 46 N X,X0,X1,X2,X3,X8,%H,YD,%,TM,IFN,ACTOR,NORX,OIEN,OACT 47 I $G(GROUP)=$O(^ORD(100.98,"B","ALL SERVICES",0)),$G(ORWARD),$G(DGPMT)'=1 S NORX=$O(^ORD(100.98,"B","O RX",0)) ;K:X ORGRP(X) ; 177 screen out Outpt Meds if inpt 48 S X2=+$$GET^XPAR("SYS","ORPF ACTIVE ORDERS CONTEXT HRS",1,"I"),X=$H,X=+X*24+($P(X,",",2)/3600),X1=X-X2,X3=X1#24,X1=X1\24,X2=$J(X3*3600,0,0),%H=X1_","_X2 D YMD^%DTC S YD=+(X_%) 49 S TM=SDATE F S TM=$O(^OR(100,"AC",PAT,TM)) Q:TM<1!(TM>EDATE) S IFN=0 F S IFN=$O(^OR(100,"AC",PAT,TM,IFN)) Q:IFN<1 I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D 50 . Q:'$D(ORGRP($P(X0,U,11))) S ACTOR=0 51 . F S ACTOR=$O(^OR(100,"AC",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 I $D(^OR(100,IFN,8,ACTOR,0)) S X8=^(0) D 52 .. I "^10^12^"[(U_$P(X8,U,15)_U) K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q 53 .. I $P(X8,U,15)=13,$P(X8,U)<YD K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q 54 .. I $P(X8,U,15)="",ACTOR'=$P(X3,U,7) K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q 55 .. ;AGP waiting for approval change to remove duplicate orders for DC reason 56 .. ;I ACTOR>0,$P($G(^OR(100,IFN,8,ACTOR,0)),U,2)="DC" S OIEN=IFN,OACT=ACTOR 57 .. ;I OIEN=IFN,OACT>ACTOR K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q 58 .. D LP1 59 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 60 Q 61 CUR1 ; 2 -- secondary pass for Active/Current 62 N STOP S STOP=$P(X0,U,9) 63 I STS=10 K ^OR(100,"AC",PAT,TM,IFN) Q ;no delayed orders 64 I $P(X8,U,4)=2,$P(X8,U,15)=11 G CURX ;incl all unsig/unrel actions 65 I '$D(YD),"^1^2^7^12^13^14^"[(U_STS_U) K ^OR(100,"AC",PAT,TM,IFN) Q 66 I $D(YD),"^1^2^7^12^13^14^"[(U_STS_U),STOP<YD K ^OR(100,"AC",PAT,TM,IFN) Q 67 I $G(NORX),NORX=$P(X0,U,11) Q ;skip Rx for inpatients 68 CURX D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 69 Q 70 ; 71 DC1 ; 3 -- secondary pass for DC 72 I FLG=28 D GETEIE^ORQ12(IFN,ORLIST,DETAIL,ACTOR) Q 73 I STS=1!(STS=13)!(STS=12) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 74 Q 75 ; 76 COM1 ; 4 -- secondary pass for Completed/Expired 77 N STOP S STOP=$P(X0,U,9) 78 I STS=2!(STS=7)!($L(STOP)&(STOP<NOW)&(STS'=1)&(STS'=13)&(STS'=12)) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 79 Q 80 ; 81 EXG ; 5 -- Expiring 82 N ORNG,ORDT,ORDW,ORHOL,X,Y,%DT,DIC,TMW,NOW ;195 83 F ORNG=1:1 D I ORHOL=0,ORDW=0 Q 84 . S ORDT=$$FMADD^XLFDT(DT,ORNG),ORDW=$S($H-4+ORNG#7>4:1,1:0) 85 . S DIC="^HOLIDAY(",X=$P(ORDT,".") 86 . D ^DIC S ORHOL=$S(+$G(Y)>0:1,1:0) 87 S %DT="",X="T+"_ORNG D ^%DT 88 S TMW=Y_".9999",NOW=+$E($$NOW^XLFDT,1,12) 89 D CUR ;D LOOP 90 Q 91 EXG1 ; 5 -- secondary pass for Expiring 92 N STOP S STOP=$P(X0,U,9) 93 I STS'=1,STS'=2,STS'=7,STS'>9,STOP>NOW,STOP'>TMW D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 94 Q 95 ; 96 ACT ; 6 -- Recent Activity (Order Summary) 97 ;N ORLSIGN S ORLSIGN=$$GET^XPAR("ALL","OR ORDER REVIEW DT","`"_+PAT,"Q") 98 N TM,IFN,X0,X3,ACTOR,X8 99 S TM=SDATE F S TM=$O(^OR(100,"AR",PAT,TM)) Q:TM<1!(TM>EDATE) D 100 . S IFN=0 F S IFN=$O(^OR(100,"AR",PAT,TM,IFN)) Q:IFN<1 S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)) I $D(ORGRP(+$P(X0,U,11))) D 101 .. S ACTOR=0 F S ACTOR=$O(^OR(100,"AR",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 I $D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0) D LP1 102 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 103 Q 104 ; 105 PEN1 ; 7 -- secondary pass for Pending 106 I STS=5 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 107 Q 108 ; 109 UVR1 ; 8 -- secondary pass for Unverified 110 ; Include if: unverified, released, inpt, not repl/canc/lapsed 111 I '$P(X8,U,9),'$P(X8,U,11),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 112 Q 113 ; 114 UVN1 ; 9 -- secondary pass for Unverified/Nurse 115 ; Include if: unverified, released, inpt, not repl/canc/lapsed 116 I '$P(X8,U,9),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 117 Q 118 ; 119 UVC1 ; 10 -- secondary pass for Unverified/Clerk 120 ; Include if: unverified, released, inpt, not repl/canc/lapsed 121 I '$P(X8,U,11),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 122 Q 123 ; 124 INPT() ; -- Returns 1 or 0, if inpt order using X0=^OR(100,IFN,0) 125 I ($P(X0,U,12)="I")!($$TYPE^OREVNTX($P(X0,U,17))="D") Q 1 126 ;I $P($G(^SC(+$P(X0,U,10),0)),U,3)="W" Q 1 127 Q 0 128 ; 129 SIG ; 11 -- Unsigned 130 N TM,IFN,X0,X3,ACTOR S TM=SDATE 131 F S TM=$O(^OR(100,"AS",PAT,TM)) Q:TM<1!(TM>EDATE) S IFN=0 F S IFN=$O(^OR(100,"AS",PAT,TM,IFN)) Q:IFN<1 D 132 . S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)) 133 . I X0="" K ^OR(100,"AS",PAT,TM,IFN) Q ;deleted 134 . Q:'$D(ORGRP(+$P(X0,U,11))) ;not a selected DispGrp 135 . S ACTOR=0 F S ACTOR=$O(^OR(100,"AS",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 D 136 .. I $P($G(^OR(100,IFN,8,ACTOR,0)),U,4)'=2 K ^OR(100,"AS",PAT,TM,IFN,ACTOR) Q ;signed or deleted 137 .. D LP1 138 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 139 Q 140 ; 141 FLG1 ; 12 -- secondary pass for Flagged 142 I +$G(^OR(100,IFN,8,ACTOR,3)) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 143 Q 144 ; 145 VP1 ; 13 -- secondary pass for Verbal/Phone 146 N ORNATR S ORNATR=$P(X8,U,12) 147 I ORNATR,"PV"[$P($G(^ORD(100.02,+ORNATR,0)),U,2) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;STS'=12 148 Q 149 ; 150 VPU1 ; 14 -- secondary pass for Verbal/Phone Unsigned 151 N ORNATR S ORNATR=$P(X8,U,12) 152 I ORNATR,"PV"[$P($G(^ORD(100.02,+ORNATR,0)),U,2),'$P(X8,U,5),$P(X8,U,4)=2 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;STS'=12 153 Q 154 ; 155 HLD1 ; 18 -- secondary pass for On Hold 156 I STS=3 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 157 Q 158 ; 159 NEW ; 19 -- New Orders, plus other unsigned orders by current provider 160 N IFN,ACTOR,TM,X0,X3,X8,ORENT,ORPAR 161 S IFN=0 F S IFN=$O(^TMP("ORNEW",$J,IFN)) Q:IFN'>0 D ;New orders 162 . S ACTOR=0 F S ACTOR=$O(^TMP("ORNEW",$J,IFN,ACTOR)) Q:ACTOR'>0 D 163 .. Q:'$D(^OR(100,IFN,0)) Q:'$D(^(8,ACTOR,0)) ;deleted 164 .. D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 165 G:'$D(^XUSEC("ORES",DUZ)) NW1 ;ck parameter for add'l orders 166 S ORENT="ALL"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+^(5),1:"") 167 S ORPAR=$$GET^XPAR(ORENT,"OR UNSIGNED ORDERS ON EXIT") 168 I ORPAR S TM=SDATE F S TM=$O(^OR(100,"AS",PAT,TM)) Q:TM<1!(TM>EDATE) D 169 . S IFN=0 F S IFN=$O(^OR(100,"AS",PAT,TM,IFN)) Q:IFN<1 D 170 .. S ACTOR=0 F S ACTOR=$O(^OR(100,"AS",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 D 171 ... Q:$D(^TMP("ORNEW",$J,IFN,ACTOR)) ;already included 172 ... S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)),X8=$G(^(8,ACTOR,0)) 173 ... I $S(ORPAR=1&($P(X8,U,3)=DUZ):1,ORPAR=2:1,1:0) D LP1 174 NW1 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 175 Q 176 ; 177 CHT1 ; 20 -- secondary pass for Chart Review 178 ; Include if: unverified, released, inpt, not repl/canc/lapsed 179 I '$P(X8,U,19),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 180 Q 181 ; 182 CHTSUM ; 21 -- secondary pass for Chart copy summary 183 ; Included based on Nature of Order 184 N XP,NAT 185 S XP=+$$GET^XPAR("SYS","OR PRINT ALL ORDERS CHART SUM",1,"I") 186 I XP=2 D Q ;depends on Nature of Order 187 . S NAT=$P($G(^OR(100,IFN,6)),U) 188 . I 'NAT S NAT=$P(X8,U,12) 189 . I NAT,$$CHART^ORX1(NAT) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 190 I XP=0 D Q ;If original printed, print on sum 191 . I X7 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 192 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;XP=1 gets All orders 193 Q 194 ; 195 LPS1 ; 22 -- secondary pass for Lapsed 196 I STS=14 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 197 Q 198 ; 199 AVT1 ; 23 -- secondary pass for Active/Pending sts only 200 I (STS=6)!(STS=5) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 201 Q 202 ; 203 QUIT ; -- stop 204 Q 1 ORQ11 ;slc/dcm-Get patient orders in context ;3/31/04 09:57 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,78,99,94,148,141,177,186,190,195,215**;Dec 17, 1997 3 LOOP ; -- main loop through "ACT" x-ref 4 I $G(XREF)="AW" D AW Q 5 I $G(FLG)=27 D EXPD^ORQ12 Q 6 K ^TMP("ORGOTIT",$J) 7 AWIN ;Jump in here to add active orders to AW context 8 N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X ;195 9 S NOW=+$E($$NOW^XLFDT,1,12),TM=SDATE 10 F S TM=$O(^OR(100,"ACT",PAT,TM)) Q:'TM!(TM>EDATE) S TO=0 F S TO=$O(^OR(100,"ACT",PAT,TM,TO)) Q:'TO I $D(ORGRP(TO)) D 11 . S IFN=0 F S IFN=$O(^OR(100,"ACT",PAT,TM,TO,IFN)) Q:'IFN I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT),$D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D 12 .. S ACTOR=0 F S ACTOR=$O(^OR(100,"ACT",PAT,TM,TO,IFN,ACTOR)) Q:ACTOR<1 I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13!(FLG=1) S X8=^(0),X7=$G(^(7)) D LP1 13 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 14 Q 15 AW ; -- loop through "AW" x-ref 16 K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J) 17 N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X ;195 18 S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE 19 F S TO=$O(^OR(100,"AW",PAT,TO)) Q:'TO I $D(ORGRP(TO)) S TM=EDATE F S TM=$O(^OR(100,"AW",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TM<EDATE) D 20 . S IFN=0 F S IFN=$O(^OR(100,"AW",PAT,TO,TM,IFN)) Q:'IFN I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT) D 21 .. S ^TMP("ORSORT",$J,9999999-TM,TO,IFN)="" 22 S TM=0 F S TM=$O(^TMP("ORSORT",$J,TM)) Q:'TM S TO=0 F S TO=$O(^TMP("ORSORT",$J,TM,TO)) Q:'TO D 23 . S IFN=0 F S IFN=$O(^TMP("ORSORT",$J,TM,TO,IFN)) Q:'IFN I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D 24 .. S ACTOR=0 F S ACTOR=$O(^OR(100,"ACT",PAT,9999999-$P(X0,U,7),TO,IFN,ACTOR)) Q:ACTOR<1 I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0),X7=$G(^(7)) D LP1 25 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 26 I +$$GET^XPAR("SYS","OR ORDER SUMMARY CONTEXT",1,"I")=2 S SDATE=9999999-SDATE,EDATE=9999999-EDATE D AWIN 27 K ^TMP("ORSORT",$J),^TMP("ORGOTIT",$J) 28 Q 29 LP1 ; -- main secondary loop 30 N STS ;195 31 N TAG 32 Q:$P(X3,U,8) Q:$P(X3,U,3)=99 S STS=$P(X3,U,3) 33 I '$G(GETKID),$P(X3,U,9),'$P($G(^OR(100,$P(X3,U,9),3)),U,8),FLG'=11 Q 34 I $L($P(X0,U,17)),"^10^11^"[(U_STS_U) S X=$$LAPSED^OREVNTX($P(X0,U,17)) 35 S TAG=$S(FLG=2:"CUR1",FLG=4:"COM1",FLG=5:"EXG1",FLG=7:"PEN1",FLG=8:"UVR1",FLG=9:"UVN1",FLG=10:"UVC1",FLG=12:"FLG1",FLG=13:"VP1",FLG=14:"VPU1",FLG=18:"HLD1",FLG=20:"CHT1",FLG=21:"CHTSUM",FLG=22:"LPS1",FLG=23:"AVT1",1:"ALL1") 36 I TAG="ALL1" S TAG=$S(FLG=3:"DC1",FLG=28:"DC1",1:"ALL1") 37 D @TAG 38 Q 39 ; ** FLG context specific loops: 40 ; 41 ALL1 ; 1 -- secondary pass for All, Recent Orders, Unsigned 42 D GET^ORQ12(IFN,ORLIST,DETAIL,$G(ACTOR)) 43 Q 44 ; 45 CUR ; 2 -- Active/Current 46 N X,X0,X1,X2,X3,%H,YD,%,TM,IFN,ACTOR,OIEN,OACT 47 I $G(GROUP)=$O(^ORD(100.98,"B","ALL SERVICES",0)),$G(ORWARD),$G(DGPMT)'=1 S X=$O(^ORD(100.98,"B","O RX",0)) K:X ORGRP(X) ; 177 screen out Outpt Meds if inpt 48 S X2=+$$GET^XPAR("SYS","ORPF ACTIVE ORDERS CONTEXT HRS",1,"I"),X=$H,X=+X*24+($P(X,",",2)/3600),X1=X-X2,X3=X1#24,X1=X1\24,X2=$J(X3*3600,0,0),%H=X1_","_X2 D YMD^%DTC S YD=+(X_%) 49 S TM=SDATE F S TM=$O(^OR(100,"AC",PAT,TM)) Q:TM<1!(TM>EDATE) S IFN=0 F S IFN=$O(^OR(100,"AC",PAT,TM,IFN)) Q:IFN<1 I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D 50 . Q:'$D(ORGRP($P(X0,U,11))) S ACTOR=0 51 . F S ACTOR=$O(^OR(100,"AC",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 I $D(^OR(100,IFN,8,ACTOR,0)) S X=^(0) D 52 .. I "^10^12^"[(U_$P(X,U,15)_U) K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q 53 .. I $P(X,U,15)=13,$P(X,U)<YD K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q 54 .. I $P(X,U,15)="",ACTOR'=$P(X3,U,7) K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q 55 .. ;AGP waiting for approval change to remove duplicate orders for DC reason 56 .. ;I ACTOR>0,$P($G(^OR(100,IFN,8,ACTOR,0)),U,2)="DC" S OIEN=IFN,OACT=ACTOR 57 .. ;I OIEN=IFN,OACT>ACTOR K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q 58 .. D LP1 59 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 60 Q 61 CUR1 ; 2 -- secondary pass for Active/Current 62 N STOP S STOP=$P(X0,U,9) 63 I STS=10 K ^OR(100,"AC",PAT,TM,IFN) Q ;no delayed orders 64 I '$D(YD),"^1^2^7^12^13^14^"[(U_STS_U) K ^OR(100,"AC",PAT,TM,IFN) Q 65 I $D(YD),"^1^2^7^12^13^14^"[(U_STS_U),STOP<YD K ^OR(100,"AC",PAT,TM,IFN) Q 66 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 67 Q 68 ; 69 DC1 ; 3 -- secondary pass for DC 70 I FLG=28 D GETEIE^ORQ12(IFN,ORLIST,DETAIL,ACTOR) Q 71 I STS=1!(STS=13)!(STS=12) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 72 Q 73 ; 74 COM1 ; 4 -- secondary pass for Completed/Expired 75 N STOP S STOP=$P(X0,U,9) 76 I STS=2!(STS=7)!($L(STOP)&(STOP<NOW)&(STS'=1)&(STS'=13)&(STS'=12)) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 77 Q 78 ; 79 EXG ; 5 -- Expiring 80 N ORNG,ORDT,ORDW,ORHOL,X,Y,%DT,DIC,TMW,NOW ;195 81 F ORNG=1:1 D I ORHOL=0,ORDW=0 Q 82 . S ORDT=$$FMADD^XLFDT(DT,ORNG),ORDW=$S($H-4+ORNG#7>4:1,1:0) 83 . S DIC="^HOLIDAY(",X=$P(ORDT,".") 84 . D ^DIC S ORHOL=$S(+$G(Y)>0:1,1:0) 85 S %DT="",X="T+"_ORNG D ^%DT 86 S TMW=Y_".9999",NOW=+$E($$NOW^XLFDT,1,12) 87 D CUR ;D LOOP 88 Q 89 EXG1 ; 5 -- secondary pass for Expiring 90 N STOP S STOP=$P(X0,U,9) 91 I STS'=1,STS'=2,STS'=7,STS'>9,STOP>NOW,STOP'>TMW D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 92 Q 93 ; 94 ACT ; 6 -- Recent Activity (Order Summary) 95 ;N ORLSIGN S ORLSIGN=$$GET^XPAR("ALL","OR ORDER REVIEW DT","`"_+PAT,"Q") 96 N TM,IFN,X0,X3,ACTOR,X8 97 S TM=SDATE F S TM=$O(^OR(100,"AR",PAT,TM)) Q:TM<1!(TM>EDATE) D 98 . S IFN=0 F S IFN=$O(^OR(100,"AR",PAT,TM,IFN)) Q:IFN<1 S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)) I $D(ORGRP(+$P(X0,U,11))) D 99 .. S ACTOR=0 F S ACTOR=$O(^OR(100,"AR",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 I $D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0) D LP1 100 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 101 Q 102 ; 103 PEN1 ; 7 -- secondary pass for Pending 104 I STS=5 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 105 Q 106 ; 107 UVR1 ; 8 -- secondary pass for Unverified 108 ; Include if: unverified, released, inpt, not repl/canc/lapsed 109 I '$P(X8,U,9),'$P(X8,U,11),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 110 Q 111 ; 112 UVN1 ; 9 -- secondary pass for Unverified/Nurse 113 ; Include if: unverified, released, inpt, not repl/canc/lapsed 114 I '$P(X8,U,9),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 115 Q 116 ; 117 UVC1 ; 10 -- secondary pass for Unverified/Clerk 118 ; Include if: unverified, released, inpt, not repl/canc/lapsed 119 I '$P(X8,U,11),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 120 Q 121 ; 122 INPT() ; -- Returns 1 or 0, if inpt order using X0=^OR(100,IFN,0) 123 I ($P(X0,U,12)="I")!($P(X0,U,17)="D") Q 1 124 I $P($G(^SC(+$P(X0,U,10),0)),U,3)="W" Q 1 125 Q 0 126 ; 127 SIG ; 11 -- Unsigned 128 N TM,IFN,X0,X3,ACTOR S TM=SDATE 129 F S TM=$O(^OR(100,"AS",PAT,TM)) Q:TM<1!(TM>EDATE) S IFN=0 F S IFN=$O(^OR(100,"AS",PAT,TM,IFN)) Q:IFN<1 D 130 . S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)) 131 . I X0="" K ^OR(100,"AS",PAT,TM,IFN) Q ;deleted 132 . Q:'$D(ORGRP(+$P(X0,U,11))) ;not a selected DispGrp 133 . S ACTOR=0 F S ACTOR=$O(^OR(100,"AS",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 D 134 .. I $P($G(^OR(100,IFN,8,ACTOR,0)),U,4)'=2 K ^OR(100,"AS",PAT,TM,IFN,ACTOR) Q ;signed or deleted 135 .. D LP1 136 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 137 Q 138 ; 139 FLG1 ; 12 -- secondary pass for Flagged 140 I +$G(^OR(100,IFN,8,ACTOR,3)) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 141 Q 142 ; 143 VP1 ; 13 -- secondary pass for Verbal/Phone 144 N ORNATR S ORNATR=$P(X8,U,12) 145 I ORNATR,"PV"[$P($G(^ORD(100.02,+ORNATR,0)),U,2) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;STS'=12 146 Q 147 ; 148 VPU1 ; 14 -- secondary pass for Verbal/Phone Unsigned 149 N ORNATR S ORNATR=$P(X8,U,12) 150 I ORNATR,"PV"[$P($G(^ORD(100.02,+ORNATR,0)),U,2),'$P(X8,U,5),$P(X8,U,4)=2 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;STS'=12 151 Q 152 ; 153 HLD1 ; 18 -- secondary pass for On Hold 154 I STS=3 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 155 Q 156 ; 157 NEW ; 19 -- New Orders, plus other unsigned orders by current provider 158 N IFN,ACTOR,TM,X0,X3,X8,ORENT,ORPAR 159 S IFN=0 F S IFN=$O(^TMP("ORNEW",$J,IFN)) Q:IFN'>0 D ;New orders 160 . S ACTOR=0 F S ACTOR=$O(^TMP("ORNEW",$J,IFN,ACTOR)) Q:ACTOR'>0 D 161 .. Q:'$D(^OR(100,IFN,0)) Q:'$D(^(8,ACTOR,0)) ;deleted 162 .. D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 163 G:'$D(^XUSEC("ORES",DUZ)) NW1 ;ck parameter for add'l orders 164 S ORENT="ALL"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+^(5),1:"") 165 S ORPAR=$$GET^XPAR(ORENT,"OR UNSIGNED ORDERS ON EXIT") 166 I ORPAR S TM=SDATE F S TM=$O(^OR(100,"AS",PAT,TM)) Q:TM<1!(TM>EDATE) D 167 . S IFN=0 F S IFN=$O(^OR(100,"AS",PAT,TM,IFN)) Q:IFN<1 D 168 .. S ACTOR=0 F S ACTOR=$O(^OR(100,"AS",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 D 169 ... Q:$D(^TMP("ORNEW",$J,IFN,ACTOR)) ;already included 170 ... S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)),X8=$G(^(8,ACTOR,0)) 171 ... I $S(ORPAR=1&($P(X8,U,3)=DUZ):1,ORPAR=2:1,1:0) D LP1 172 NW1 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 173 Q 174 ; 175 CHT1 ; 20 -- secondary pass for Chart Review 176 ; Include if: unverified, released, inpt, not repl/canc/lapsed 177 I '$P(X8,U,19),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 178 Q 179 ; 180 CHTSUM ; 21 -- secondary pass for Chart copy summary 181 ; Included based on Nature of Order 182 N XP,NAT 183 S XP=+$$GET^XPAR("SYS","OR PRINT ALL ORDERS CHART SUM",1,"I") 184 I XP=2 D Q ;depends on Nature of Order 185 . S NAT=$P($G(^OR(100,IFN,6)),U) 186 . I 'NAT S NAT=$P(X8,U,12) 187 . I NAT,$$CHART^ORX1(NAT) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 188 I XP=0 D Q ;If original printed, print on sum 189 . I X7 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 190 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;XP=1 gets All orders 191 Q 192 ; 193 LPS1 ; 22 -- secondary pass for Lapsed 194 I STS=14 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 195 Q 196 ; 197 AVT1 ; 23 -- secondary pass for Active/Pending sts only 198 I (STS=6)!(STS=5) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) 199 Q 200 ; 201 QUIT ; -- stop 202 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ12.m
r613 r623 1 ORQ12 ; slc/dcm - Get patient orders in context ;06/29/06 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,78,92,116,190,220,215,243**;Dec 17, 1997;Build 242 3 GET(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array 4 ; IFN=ifn of order 5 ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST) 6 ; DETAIL=see description in ^ORQ1 7 ; 8 N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD 9 S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))="" 10 I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q 11 S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6)) 12 S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3) 13 S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"") ;.01^abbr 14 S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9) 15 ; S FLAGREA=$P(X6,U,7) 16 S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT 17 D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT 18 Q 19 ; 20 TEXT(ORTX,ORIFN,WIDTH) ; -- Returns text of order ORIFN in ORTX(#) 21 N OR0,OR3,OR6,X,Y,FIRST,ORI,ORJ,DLG,ORX,ORACT,ORTA 22 K ORTX S:'$G(WIDTH) WIDTH=244 23 S ORACT=+$P(ORIFN,";",2),ORIFN=+ORIFN 24 I ORACT<1 S ORACT=+$P($G(^OR(100,ORIFN,3)),U,7) S:'ORACT ORACT=1 25 ;D:$O(^OR(100,ORIFN,1,0)) CNV^ORY92(ORIFN) ;convert text otf 26 S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)),ORX=$G(^(8,ORACT,0)) 27 S ORTX=1,ORTX(1)="" 28 I $P($G(OR0),U,11)'="",($P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS") S X="Non-VA" D ADD 29 G:$G(ORIGVIEW)>1 T1 30 S:$P(OR0,U,14)=$O(^DIC(9.4,"C","OR",0)) ORTX(1)=">>" ;generic 31 S X=$$ACTION($P(ORX,U,2)) D:$L(X) ADD 32 I $P(ORX,U,2)="NW",$P(OR3,U,11),'$G(ORIGVIEW) D ; Changed or Renewed 33 . I $P(OR3,U,11)=2 S X="Renew" D ADD Q 34 . N ORIG,ORIGTA S ORIG=+$P(OR3,U,5) Q:'ORIG Q:$P(OR3,U,11)'=1 35 . S X="Change" D ADD S ORI=0 36 . I $G(IOST)'="P-OTHER" D 37 . .S ORIGTA=$$LASTXT(ORIG) ;D:$O(^OR(100,ORIG,1,0)) CNV^ORY92(ORIG) 38 . .F S ORI=$O(^OR(100,ORIG,8,ORIGTA,.1,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) S:$E(X,1,3)=">> " X=$E(X,4,999) D ADD 39 . .S X=" to" D ADD 40 T1 S ORTA=+$P(ORX,U,14),FIRST=+$O(^OR(100,ORIFN,8,ORTA,.1,0)) 41 S ORI=0 F S ORI=$O(^OR(100,ORIFN,8,ORTA,.1,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) S:(FIRST=ORI)&($E(X,1,3)=">> ") X=$E(X,4,999) D:$L(X) ADD 42 Q:$G(ORIGVIEW)>1 ;contents of global only 43 S DLG=$P(OR0,U,5) K Y I DLG,$P(DLG,";",2)["101.41",$D(^ORD(101.41,+DLG,9)) X ^(9) I $L($G(Y)) S X=Y D ADD ; additional text 44 ; I $P(OR3,U,11)=2 S X="(Renewal)" D ADD 45 I $P(ORX,U,4)=2 S X="*UNSIGNED*" D ADD 46 I $P(ORX,U,2)="DC"!("^1^13^"[(U_$P(OR3,U,3)_U)),$L(OR6) S X=" <"_$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),1:"")_">" D:$L(X)>3 ADD ; DC Reason 47 I $D(XQAID),$G(ORFLG)=12 S ORX=$G(^OR(100,ORIFN,8,ORACT,3)) I $P(ORX,U) S X=" Flagged "_$$DATETIME($P(ORX,U,3))_$S($P(ORX,U,4):" by "_$$NAME($P(ORX,U,4)),1:"")_": "_$P(ORX,U,5) D ADD ; Flagged - show in FUP 48 Q 49 ; 50 LASTXT(IFN) ; -- Returns action with latest text for order IFN 51 N I,Y S Y=1 52 S I=0 F S I=$O(^OR(100,IFN,8,I)) Q:I'>0 S:$O(^(I,.1,0)) Y=I 53 Q Y 54 ; 55 LAST(CODE) ; -- Return DA of last occurence of CODE action 56 N DA 57 I '$L($G(CODE)) S DA=$O(^OR(100,ORIFN,8,"A"),-1) ; last entry 58 E S DA=$O(^OR(100,ORIFN,8,"C",CODE,"?"),-1) ; last CODE entry 59 Q DA 60 ; 61 ACTION(X) ; -- Returns text of action X 62 N Y 63 S Y=$S(X="DC":"Discontinue",X="HD":"Hold",X="RL"&'$G(ORIGVIEW):"Release Hold of",X="FL":"Flag",X="UF":"Unflag",X="RN"&'$G(ORIGVIEW):"Renew",1:"") 64 Q Y 65 ; 66 DATETIME(X) ; -- Returns date/time in format 00/00/00@00:00am 67 N Y,D,T,T1,Z 68 S D=$P(X,"."),T=$E($P(X,".",2)_"0000",1,4),T1=$E(T,1,2),Z="AM" 69 S:T1>12 T1=T1-12,Z="PM" 70 S Y=$E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))_"@"_T1_":"_$E(T,3,4)_Z 71 Q Y 72 ; 73 NAME(X) ; -- Returns name as Lname,F 74 N Y,Z S Z=$P($G(^VA(200,+X,0)),U) Q:Z="" "" 75 S Y=$P(Z,",")_"," F I=$F(Z,","):1:$L(Z) I $E(Z,I)'=" " S Y=Y_$E(Z,I) Q 76 S Y=$$LOWER^VALM1(Y) ; mixed case 77 Q Y 78 ; 79 ADD ; -- Add text X to ORTX() 80 N I,Y S Y=$L(ORTX(ORTX)) S:Y Y=Y+1 ;allow for space 81 I $E(X)=" ",Y S ORTX=ORTX+1,ORTX(ORTX)="",Y=0,X=$E(X,2,999) ;new line 82 I Y+$L(X)'>WIDTH S ORTX(ORTX)=ORTX(ORTX)_$S(Y:" ",1:"")_X Q 83 F I=1:1:$L(X," ") S Z=$P(X," ",I) D:(Y+$L(Z))>WIDTH S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_Z,Y=$L(ORTX(ORTX)) S:Y Y=Y+1 84 . I $L(Z)>WIDTH F S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_$E(Z,1,WIDTH-Y),Z=$E(Z,WIDTH-Y+1,999) Q:$L(Z)'>WIDTH S ORTX=ORTX+1,Y=0 85 . S ORTX=ORTX+1,Y=0 86 Q 87 ; 88 EXPD ; -- loop through ^XTMP("ORAE" to get expired orders 89 K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J) 90 N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X,ORREP 91 S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE 92 F S TO=$O(^XTMP("ORAE",PAT,TO)) Q:'TO I $D(ORGRP(TO)) S TM=EDATE F S TM=$O(^XTMP("ORAE",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TM<EDATE) D 93 . S IFN=0 F S IFN=$O(^XTMP("ORAE",PAT,TO,TM,IFN)) Q:'IFN I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT) D 94 .. S USTS=$P(^OR(100,IFN,3),U,3) 95 .. Q:+$G(USTS)'=7 ;quit if order no longer expired 96 .. S ORREP=$P(^OR(100,IFN,3),U,6) 97 .. Q:+$G(ORREP)>0 ;quit if order has been replaced 98 .. S ^TMP("ORSORT",$J,9999999-TM,TO,IFN)="" 99 S TM=0 F S TM=$O(^TMP("ORSORT",$J,TM)) Q:'TM S TO=0 F S TO=$O(^TMP("ORSORT",$J,TM,TO)) Q:'TO D 100 .S IFN=0 F S IFN=$O(^TMP("ORSORT",$J,TM,TO,IFN)) Q:'IFN I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D 101 ..S ACTOR=+$P(X3,U,7) D LP1^ORQ11 102 ..;S ACTOR=0 F S ACTOR=$O(^OR(100,"ACT",PAT,9999999-$P(X0,U,7),TO,IFN,ACTOR)) Q:ACTOR<1 I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0),X7=$G(^(7)) D LP1^ORQ11 103 S ^TMP("ORR",$J,ORLIST,"TOT")=$G(ORLST) 104 K ^TMP("ORSORT",$J),^TMP("ORGOTIT",$J) 105 Q 106 GETEIE(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array 107 ; IFN=ifn of order 108 ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST) 109 ; DETAIL=see description in ^ORQ1 110 ; 111 N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD,DCREAS 112 S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6)) 113 S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3) 114 S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"") 115 S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9) 116 S DCREAS=$P($G(X6),U,4) Q:DCREAS'>0 117 I DCREAS'=$O(^ORD(100.03,"B","Entered in error","")) Q 118 S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))="" 119 I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q 120 S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT 121 D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT 122 Q 1 ORQ12 ; slc/dcm - Get patient orders in context ;12/19/05 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,78,92,116,190,220,215**;Dec 17, 1997 3 GET(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array 4 ; IFN=ifn of order 5 ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST) 6 ; DETAIL=see description in ^ORQ1 7 ; 8 N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD 9 S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))="" 10 I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q 11 S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6)) 12 S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3) 13 S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"") ;.01^abbr 14 S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9) 15 ; S FLAGREA=$P(X6,U,7) 16 S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT 17 D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT 18 Q 19 ; 20 TEXT(ORTX,ORIFN,WIDTH) ; -- Returns text of order ORIFN in ORTX(#) 21 N OR0,OR3,OR6,X,Y,FIRST,ORI,ORJ,DLG,ORX,ORACT,ORTA 22 K ORTX S:'$G(WIDTH) WIDTH=244 23 S ORACT=+$P(ORIFN,";",2),ORIFN=+ORIFN 24 I ORACT<1 S ORACT=+$P($G(^OR(100,ORIFN,3)),U,7) S:'ORACT ORACT=1 25 ;D:$O(^OR(100,ORIFN,1,0)) CNV^ORY92(ORIFN) ;convert text otf 26 S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)),ORX=$G(^(8,ORACT,0)) 27 S ORTX=1,ORTX(1)="" 28 I $P($G(OR0),U,11)'="",($P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS") S X="Non-VA" D ADD 29 G:$G(ORIGVIEW)>1 T1 30 S:$P(OR0,U,14)=$O(^DIC(9.4,"C","OR",0)) ORTX(1)=">>" ;generic 31 S X=$$ACTION($P(ORX,U,2)) D:$L(X) ADD 32 I $P(ORX,U,2)="NW",$P(OR3,U,11),'$G(ORIGVIEW) D ; Changed or Renewed 33 . I $P(OR3,U,11)=2 S X="Renew" D ADD Q 34 . N ORIG,ORIGTA S ORIG=+$P(OR3,U,5) Q:'ORIG Q:$P(OR3,U,11)'=1 35 . S X="Change" D ADD S ORI=0 36 . I $G(IOST)'="P-OTHER" D 37 . .S ORIGTA=$$LASTXT(ORIG) ;D:$O(^OR(100,ORIG,1,0)) CNV^ORY92(ORIG) 38 . .F S ORI=$O(^OR(100,ORIG,8,ORIGTA,.1,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) S:$E(X,1,3)=">> " X=$E(X,4,999) D ADD 39 . .S X=" to" D ADD 40 T1 S ORTA=+$P(ORX,U,14),FIRST=+$O(^OR(100,ORIFN,8,ORTA,.1,0)) 41 S ORI=0 F S ORI=$O(^OR(100,ORIFN,8,ORTA,.1,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) S:(FIRST=ORI)&($E(X,1,3)=">> ") X=$E(X,4,999) D:$L(X) ADD 42 Q:$G(ORIGVIEW)>1 ;contents of global only 43 S DLG=$P(OR0,U,5) K Y I DLG,$P(DLG,";",2)["101.41",$D(^ORD(101.41,+DLG,9)) X ^(9) I $L($G(Y)) S X=Y D ADD ; additional text 44 ; I $P(OR3,U,11)=2 S X="(Renewal)" D ADD 45 I $P(ORX,U,4)=2 S X="*UNSIGNED*" D ADD 46 I $P(ORX,U,2)="DC"!("^1^13^"[(U_$P(OR3,U,3)_U)),$L(OR6) S X=" <"_$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),1:"")_">" D:$L(X)>3 ADD ; DC Reason 47 I $D(XQAID),$G(ORFLG)=12 S ORX=$G(^OR(100,ORIFN,8,ORACT,3)) I $P(ORX,U) S X=" Flagged "_$$DATETIME($P(ORX,U,3))_$S($P(ORX,U,4):" by "_$$NAME($P(ORX,U,4)),1:"")_": "_$P(ORX,U,5) D ADD ; Flagged - show in FUP 48 Q 49 ; 50 LASTXT(IFN) ; -- Returns action with latest text for order IFN 51 N I,Y S Y=1 52 S I=0 F S I=$O(^OR(100,IFN,8,I)) Q:I'>0 S:$O(^(I,.1,0)) Y=I 53 Q Y 54 ; 55 LAST(CODE) ; -- Return DA of last occurence of CODE action 56 N DA 57 I '$L($G(CODE)) S DA=$O(^OR(100,ORIFN,8,"A"),-1) ; last entry 58 E S DA=$O(^OR(100,ORIFN,8,"C",CODE,"?"),-1) ; last CODE entry 59 Q DA 60 ; 61 ACTION(X) ; -- Returns text of action X 62 N Y 63 S Y=$S(X="DC":"Discontinue",X="HD":"Hold",X="RL"&'$G(ORIGVIEW):"Release Hold of",X="FL":"Flag",X="UF":"Unflag",X="RN"&'$G(ORIGVIEW):"Renew",1:"") 64 Q Y 65 ; 66 DATETIME(X) ; -- Returns date/time in format 00/00/00@00:00am 67 N Y,D,T,T1,Z 68 S D=$P(X,"."),T=$E($P(X,".",2)_"0000",1,4),T1=$E(T,1,2),Z="AM" 69 S:T1>12 T1=T1-12,Z="PM" 70 S Y=$E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))_"@"_T1_":"_$E(T,3,4)_Z 71 Q Y 72 ; 73 NAME(X) ; -- Returns name as Lname,F 74 N Y,Z S Z=$P($G(^VA(200,+X,0)),U) Q:Z="" "" 75 S Y=$P(Z,",")_"," F I=$F(Z,","):1:$L(Z) I $E(Z,I)'=" " S Y=Y_$E(Z,I) Q 76 S Y=$$LOWER^VALM1(Y) ; mixed case 77 Q Y 78 ; 79 ADD ; -- Add text X to ORTX() 80 N I,Y S Y=$L(ORTX(ORTX)) S:Y Y=Y+1 ;allow for space 81 I $E(X)=" ",Y S ORTX=ORTX+1,ORTX(ORTX)="",Y=0,X=$E(X,2,999) ;new line 82 I Y+$L(X)'>WIDTH S ORTX(ORTX)=ORTX(ORTX)_$S(Y:" ",1:"")_X Q 83 F I=1:1:$L(X," ") S Z=$P(X," ",I) D:(Y+$L(Z))>WIDTH S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_Z,Y=$L(ORTX(ORTX)) S:Y Y=Y+1 84 . I $L(Z)>WIDTH F S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_$E(Z,1,WIDTH-Y),Z=$E(Z,WIDTH-Y+1,999) Q:$L(Z)'>WIDTH S ORTX=ORTX+1,Y=0 85 . S ORTX=ORTX+1,Y=0 86 Q 87 ; 88 EXPD ; -- loop through ^XTMP("ORAE" to get expired orders 89 K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J) 90 N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X,ORREP 91 S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE 92 F S TO=$O(^XTMP("ORAE",PAT,TO)) Q:'TO I $D(ORGRP(TO)) S TM=EDATE F S TM=$O(^XTMP("ORAE",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TM<EDATE) D 93 . S IFN=0 F S IFN=$O(^XTMP("ORAE",PAT,TO,TM,IFN)) Q:'IFN I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT) D 94 .. S USTS=$P(^OR(100,IFN,3),U,3) 95 .. Q:+$G(USTS)'=7 ;quit if order no longer expired 96 .. S ORREP=$P(^OR(100,IFN,3),U,6) 97 .. Q:+$G(ORREP)>0 ;quit if order has been replaced 98 .. S ^TMP("ORSORT",$J,9999999-TM,TO,IFN)="" 99 S TM=0 F S TM=$O(^TMP("ORSORT",$J,TM)) Q:'TM S TO=0 F S TO=$O(^TMP("ORSORT",$J,TM,TO)) Q:'TO D 100 . S IFN=0 F S IFN=$O(^TMP("ORSORT",$J,TM,TO,IFN)) Q:'IFN I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D 101 .. S ACTOR=0 F S ACTOR=$O(^OR(100,"ACT",PAT,9999999-$P(X0,U,7),TO,IFN,ACTOR)) Q:ACTOR<1 I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0),X7=$G(^(7)) D LP1^ORQ11 102 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST 103 K ^TMP("ORSORT",$J),^TMP("ORGOTIT",$J) 104 Q 105 GETEIE(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array 106 ; IFN=ifn of order 107 ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST) 108 ; DETAIL=see description in ^ORQ1 109 ; 110 N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD,DCREAS 111 S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6)) 112 S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3) 113 S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"") 114 S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9) 115 S DCREAS=$P($G(X6),U,4) Q:DCREAS'>0 116 I DCREAS'=$O(^ORD(100.03,"B","Entered in error","")) Q 117 S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))="" 118 I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q 119 S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT 120 D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT 121 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ2.m
r613 r623 1 ORQ2 ; SLC/MKB/GSS - Detailed Order Report ;10/10/2006 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,56,75,94,141,213,195,243**;Dec 17, 1997;Build 242 3 DETAIL(ORY,ORIFN) ; -- Returns details of order ORIFN in ORY(#) 4 N X,X2,I,CNT,ORDIALOG,OR0,OR3,OR6,SEQ,ITEM,PRMT,MULT,FIRST,TITLE,INST,DIWL,DIWR,DIWF,ACTION,VAIN,ORIGVIEW,ORNMSP,ORYT 5 S CNT=0,ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)) 6 K @ORY,ORYT S ORIGVIEW=1 D TEXT^ORQ12(.ORYT,+ORIFN_";"_+$P(OR3,U,7),80) ;CurrTx 7 M @ORY=ORYT ;Move text to global 8 S I=0 F CNT=1:1 S I=$O(ORYT(I)) Q:I'>0 D:$D(IORVON) SETVIDEO(I,1,$L(ORYT(I)),IORVON,IORVOFF) 9 S CNT=CNT+1,@ORY@(CNT)=" " ;blank 10 D1 I $O(^OR(100,+ORIFN,2,0)) D 11 . S CNT=CNT+1,@ORY@(CNT)="Sub Orders:" 12 . D:$D(IOUON) SETVIDEO(CNT,1,11,IOUON,IOUOFF) 13 . N IFN S IFN=0 14 . F S IFN=+$O(^OR(100,+ORIFN,2,IFN)) Q:IFN<1 I $D(^OR(100,IFN,0)) D SUB(IFN) 15 . S CNT=CNT+1,@ORY@(CNT)=" " ;blank 16 I $P(OR3,U,9),$D(^OR(100,+$P(OR3,U,9),0)) D 17 . S CNT=CNT+1,@ORY@(CNT)="Parent Order:" 18 . D:$D(IOUON) SETVIDEO(CNT,1,12,IOUON,IOUOFF) 19 . D SUB(+$P(OR3,U,9)) 20 . S CNT=CNT+1,@ORY@(CNT)=" " ;blank 21 I $P(OR3,U,11)=1,$P(OR3,U,5) D ;Changed - show previous order 22 . S CNT=CNT+1,@ORY@(CNT)="Previous Order:" 23 . D:$D(IOUON) SETVIDEO(CNT,1,15,IOUON,IOUOFF) ;prev order original text 24 . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,+$P(OR3,U,5),55) 25 . S CNT=CNT+1,@ORY@(CNT)=" Order Text: "_$G(ORZ(1)) 26 . S I=1 F S I=$O(ORZ(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I)) 27 D2 S CNT=CNT+1,@ORY@(CNT)="Activity:" 28 D:$D(IOUON) SETVIDEO(CNT,1,9,IOUON,IOUOFF) 29 S DIWL=1,DIWR=64,DIWF="C64",ORI=0 K ^UTILITY($J,"W") 30 F S ORI=$O(^OR(100,ORIFN,8,ORI)) Q:ORI'>0 S ACTION=$G(^(ORI,0)) D ACT^ORQ20 31 I "^1^12^13^"[(U_$P(OR3,U,3)_U),$L(OR6),$P(ACTION,U,2)'="DC" D DC^ORQ20 32 I $P(OR3,U,3)=2,$P(OR6,U,6) S CNT=CNT+1,@ORY@(CNT)=$$DATE^ORQ20($P(OR6,U,6))_" Completed"_$S($P(OR6,U,7):" by "_$$USER^ORQ20($P(OR6,U,7)),1:"") 33 S CNT=CNT+1,@ORY@(CNT)=" " ;blank 34 D3 S CNT=CNT+1,@ORY@(CNT)="Current Data:" 35 D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF) 36 D VA I $G(VAIN(2)) S CNT=CNT+1,@ORY@(CNT)="Current Primary Provider: "_$P(VAIN(2),"^",2) 37 I $G(VAIN(11)) S CNT=CNT+1,@ORY@(CNT)="Current Attending Physician: "_$P(VAIN(11),"^",2) 38 S CNT=CNT+1,@ORY@(CNT)="Treating Specialty: "_$P($G(^DIC(45.7,+$P(OR0,U,13),0)),U) 39 S CNT=CNT+1,@ORY@(CNT)="Ordering Location: "_$P($G(^SC(+$P(OR0,U,10),0)),U) 40 S CNT=CNT+1,@ORY@(CNT)="Start Date/Time: "_$S($P(OR0,U,8):$$DATE^ORQ20($P(OR0,U,8)),1:"") 41 I $P(OR3,U,5),$P(OR3,U,11)=2 S X=$$ORIG(ORIFN),@ORY@(CNT)=@ORY@(CNT)_" (originally "_$$DATE^ORQ20(X)_")" 42 S CNT=CNT+1,@ORY@(CNT)="Stop Date/Time: "_$S($P(OR0,U,9):$$DATE^ORQ20($P(OR0,U,9)),1:"") 43 I $P(OR3,U,3)=1,$P(OR6,U,6) S @ORY@(CNT)=@ORY@(CNT)_" (expired "_$$DATE^ORQ20($P(OR6,U,6))_")" 44 S CNT=CNT+1,@ORY@(CNT)="Current Status: "_$S($D(^ORD(100.01,+$P(OR3,U,3),0)):$P(^(0),"^"),1:"-") 45 I $$GET^XPAR("ALL","ORPF SHOW STATUS DESCRIPTION",1,"I"),$P(OR3,U,3),$D(^ORD(100.01,$P(OR3,U,3),0)) N J S J=0 F S J=$O(^ORD(100.01,$P(OR3,U,3),1,J)) Q:J<1 S CNT=CNT+1,@ORY@(CNT)=" "_^(J,0) 46 S CNT=CNT+1,@ORY@(CNT)="Order #"_ORIFN 47 S CNT=CNT+1,@ORY@(CNT)=" " ;blank 48 D4 S CNT=CNT+1,@ORY@(CNT)="Order:" D:$D(IOUON) SETVIDEO(CNT,1,6,IOUON,IOUOFF) 49 S ORNMSP=$$NMSP^ORCD($P(OR0,U,14)) 50 I '$O(^OR(100,ORIFN,4.5,0)),ORNMSP="RA" D RAD^ORQ21("") Q 51 S ORDIALOG=$P(OR0,U,5) Q:$P(ORDIALOG,";",2)="ORD(101," ; 2.5 order 52 D GETDLG^ORCD(+ORDIALOG),GETORDER^ORCD(ORIFN) 53 S DIWL=1,DIWR=50,DIWF="C50" 54 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D 55 . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)) Q:$P(ITEM,U,11) ; child 56 . S PRMT=$P(ITEM,U,2),MULT=$P(ITEM,U,7) Q:$P(ITEM,U,9)["*" ;hide 57 . S FIRST=$O(ORDIALOG(PRMT,0)) Q:'FIRST ; no values 58 . S TITLE=$S(MULT&$L($G(ORDIALOG(PRMT,"TTL"))):ORDIALOG(PRMT,"TTL"),1:ORDIALOG(PRMT,"A")) 59 . S TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE)) 60 . S INST=0 F S INST=$O(ORDIALOG(PRMT,INST)) Q:INST'>0 D 61 . . I $E(ORDIALOG(PRMT,0))="W" D WP Q 62 . . K ^UTILITY($J,"W") S X=$$EXT^ORCD(PRMT,INST) I TITLE["Infusion Rate"&(X'="")&(X'["ml/hr") S TITLE="Infuse Over Time:",TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE)) 63 . . D ^DIWP 64 . . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PRMT)) CHILDREN(PRMT) 65 . . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$S((INST=FIRST)&(I=1):TITLE,1:$$REPEAT^XLFSTR(" ",30))_^(I,0) 66 I ORNMSP="GMRC",$G(^OR(100,ORIFN,4)) S CNT=CNT+1,@ORY@(CNT)="Consult No.: "_+^(4) 67 S CNT=CNT+1,@ORY@(CNT)=" " ;blank 68 D RAD^ORQ21(1):ORNMSP="RA",MED^ORQ21:ORNMSP="PS" ;add'l data 69 D BA^ORQ21 ;call for CIDC data 70 D5 I $O(^OR(100,+ORIFN,9,0)) D 71 . N CK,OK,X0,X,CDL,I S CNT=CNT+1,@ORY@(CNT)="Order Checks:" 72 . D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF) 73 . S CK=0 F S CK=$O(^OR(100,+ORIFN,9,CK)) Q:CK'>0 S X0=$G(^(CK,0)),X=$G(^(1)) D 74 .. S CDL=$$CDL($P(X0,U,2)) I $P(X0,U,6),'$D(OK) S OK=$P(X0,U,4,6) 75 .. I $L(X)'>68 S CNT=CNT+1,@ORY@(CNT)=CDL_X Q 76 .. S DIWL=1,DIWR=68,DIWF="C68" K ^UTILITY($J,"W") D ^DIWP 77 .. S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=CDL_^(I,0),CDL=" " 78 . Q:'$L($G(OK)) S CNT=CNT+1,@ORY@(CNT)="Override: "_$S($P(OK,U,2):$$USER^ORQ20($P(OK,U,2))_" on ",1:"")_$$DATE^ORQ20($P(OK,U,3)) 79 . I $L($P(OK,U))'>68 S CNT=CNT+1,@ORY@(CNT)=" "_$P(OK,U) Q 80 . S DIWL=1,DIWR=68,DIWF="C68",X=$P(OK,U) K ^UTILITY($J,"W") D ^DIWP 81 . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(I,0) 82 K ^TMP("ORWORD",$J),^UTILITY($J,"W") 83 Q 84 ; 85 SUB(IFN) ; -- add suborder or parent 86 N ORCY,STS,STRT,IG D TEXT^ORQ12(.ORCY,IFN,58) 87 S STS=$G(^ORD(100.01,+$P($G(^OR(100,IFN,3)),U,3),.1)) 88 S STRT=$P(^OR(100,IFN,0),U,8) S:STRT'="" STRT=$$DATE^ORQ20(STRT) 89 S IG=0 F S IG=$O(ORCY(IG)) Q:IG<1 S CNT=CNT+1,@ORY@(CNT)=$J(STS,4)_" "_ORCY(IG)_" "_STRT,(STS,STRT)=" " 90 Q 91 ; 92 WP ; -- add word-processing 93 N WP,ORI,X M WP=@ORDIALOG(PRMT,INST) 94 S CNT=CNT+1,@ORY@(CNT)=TITLE 95 S ORI=0 F S ORI=$O(WP(ORI)) Q:ORI'>0 S X=WP(ORI,0) S:X'="" CNT=CNT+1,@ORY@(CNT)=" "_X 96 Q 97 ; 98 CHILDREN(PARENT) ; -- add children 99 N SEQ,DA,ITM,PRMT,TYPE,X 100 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D 101 . S ITM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITM,U,2) 102 . Q:$G(ORDIALOG(PRMT,INST))="" Q:$P(ITM,U,9)["*" ;no value or hide 103 . S TYPE=$E(ORDIALOG(PRMT,0)) D:TYPE="W" WP 104 . I TYPE'="W" D 105 . . S X=$$EXT^ORCD(PRMT,INST) 106 . . I $L(X,"|")=2 S X=$$REPLACE^ORHLESC(X,"|","||") 107 . . D ^DIWP 108 Q 109 ; 110 SETVIDEO(LINE,COL,WIDTH,ON,OFF) ; -- set video attributes 111 S ORY("VIDEO",LINE,COL,WIDTH)=ON 112 S ORY("VIDEO",LINE,COL+WIDTH,0)=OFF 113 Q 114 ; 115 VA ; -- Call VADPT 116 N ORY,DFN,Y S DFN=+$P(OR0,"^",2) D OERR^VADPT 117 Q 118 ; 119 CDL(X) ; -- Returns Clinical Danger Level X 120 N Y S Y=$S(X=1:"HIGH:",X=2:"MODERATE:",X=3:"LOW:",1:"NONE:") 121 S Y=$E(Y_" ",1,12) 122 Q Y 123 ; 124 ORIG(IFN) ; -- Return original start date of [renewal] order 125 N I,Y,X3,DONE 126 S I=IFN,Y=$P($G(^OR(100,IFN,0)),U,8),DONE=0 127 F S X3=$G(^OR(100,I,3)) D Q:DONE 128 . I $P(X3,U,11)=2,$P(X3,U,5) S I=$P(X3,U,5) Q ;loop 129 . S Y=$P($G(^OR(100,I,0)),U,8),DONE=1 130 Q Y 1 ORQ2 ; SLC/MKB/GSS - Detailed Order Report ;7/1/04 10:58 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,56,75,94,141,213,195**;Dec 17, 1997 3 DETAIL(ORY,ORIFN) ; -- Returns details of order ORIFN in ORY(#) 4 N X,X2,I,CNT,ORDIALOG,OR0,OR3,OR6,SEQ,ITEM,PRMT,MULT,FIRST,TITLE,INST,DIWL,DIWR,DIWF,ACTION,VAIN,ORIGVIEW,ORNMSP,ORYT 5 S CNT=0,ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)) 6 K @ORY,ORYT S ORIGVIEW=1 D TEXT^ORQ12(.ORYT,+ORIFN_";"_+$P(OR3,U,7),80) ;CurrTx 7 M @ORY=ORYT ;Move text to global 8 S I=0 F CNT=1:1 S I=$O(ORYT(I)) Q:I'>0 D:$D(IORVON) SETVIDEO(I,1,$L(ORYT(I)),IORVON,IORVOFF) 9 S CNT=CNT+1,@ORY@(CNT)=" " ;blank 10 D1 I $O(^OR(100,+ORIFN,2,0)) D 11 . S CNT=CNT+1,@ORY@(CNT)="Sub Orders:" 12 . D:$D(IOUON) SETVIDEO(CNT,1,11,IOUON,IOUOFF) 13 . N IFN S IFN=0 14 . F S IFN=+$O(^OR(100,+ORIFN,2,IFN)) Q:IFN<1 I $D(^OR(100,IFN,0)) D SUB(IFN) 15 . S CNT=CNT+1,@ORY@(CNT)=" " ;blank 16 I $P(OR3,U,9),$D(^OR(100,+$P(OR3,U,9),0)) D 17 . S CNT=CNT+1,@ORY@(CNT)="Parent Order:" 18 . D:$D(IOUON) SETVIDEO(CNT,1,12,IOUON,IOUOFF) 19 . D SUB(+$P(OR3,U,9)) 20 . S CNT=CNT+1,@ORY@(CNT)=" " ;blank 21 I $P(OR3,U,11)=1,$P(OR3,U,5) D ;Changed - show previous order 22 . S CNT=CNT+1,@ORY@(CNT)="Previous Order:" 23 . D:$D(IOUON) SETVIDEO(CNT,1,15,IOUON,IOUOFF) ;prev order original text 24 . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,+$P(OR3,U,5),55) 25 . S CNT=CNT+1,@ORY@(CNT)=" Order Text: "_$G(ORZ(1)) 26 . S I=1 F S I=$O(ORZ(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I)) 27 D2 S CNT=CNT+1,@ORY@(CNT)="Activity:" 28 D:$D(IOUON) SETVIDEO(CNT,1,9,IOUON,IOUOFF) 29 S DIWL=1,DIWR=64,DIWF="C64",ORI=0 K ^UTILITY($J,"W") 30 F S ORI=$O(^OR(100,ORIFN,8,ORI)) Q:ORI'>0 S ACTION=$G(^(ORI,0)) D ACT^ORQ20 31 I "^1^12^13^"[(U_$P(OR3,U,3)_U),$L(OR6),$P(ACTION,U,2)'="DC" D DC^ORQ20 32 I $P(OR3,U,3)=2,$P(OR6,U,6) S CNT=CNT+1,@ORY@(CNT)=$$DATE^ORQ20($P(OR6,U,6))_" Completed"_$S($P(OR6,U,7):" by "_$$USER^ORQ20($P(OR6,U,7)),1:"") 33 S CNT=CNT+1,@ORY@(CNT)=" " ;blank 34 D3 S CNT=CNT+1,@ORY@(CNT)="Current Data:" 35 D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF) 36 D VA I $G(VAIN(2)) S CNT=CNT+1,@ORY@(CNT)="Current Primary Provider: "_$P(VAIN(2),"^",2) 37 I $G(VAIN(11)) S CNT=CNT+1,@ORY@(CNT)="Current Attending Physician: "_$P(VAIN(11),"^",2) 38 S CNT=CNT+1,@ORY@(CNT)="Treating Specialty: "_$P($G(^DIC(45.7,+$P(OR0,U,13),0)),U) 39 S CNT=CNT+1,@ORY@(CNT)="Ordering Location: "_$P($G(^SC(+$P(OR0,U,10),0)),U) 40 S CNT=CNT+1,@ORY@(CNT)="Start Date/Time: "_$S($P(OR0,U,8):$$DATE^ORQ20($P(OR0,U,8)),1:"") 41 I $P(OR3,U,5),$P(OR3,U,11)=2 S X=$$ORIG(ORIFN),@ORY@(CNT)=@ORY@(CNT)_" (originally "_$$DATE^ORQ20(X)_")" 42 S CNT=CNT+1,@ORY@(CNT)="Stop Date/Time: "_$S($P(OR0,U,9):$$DATE^ORQ20($P(OR0,U,9)),1:"") 43 S CNT=CNT+1,@ORY@(CNT)="Current Status: "_$S($D(^ORD(100.01,+$P(OR3,U,3),0)):$P(^(0),"^"),1:"-") 44 I $$GET^XPAR("ALL","ORPF SHOW STATUS DESCRIPTION",1,"I"),$P(OR3,U,3),$D(^ORD(100.01,$P(OR3,U,3),0)) N J S J=0 F S J=$O(^ORD(100.01,$P(OR3,U,3),1,J)) Q:J<1 S CNT=CNT+1,@ORY@(CNT)=" "_^(J,0) 45 S CNT=CNT+1,@ORY@(CNT)="Order #"_ORIFN 46 S CNT=CNT+1,@ORY@(CNT)=" " ;blank 47 D4 S CNT=CNT+1,@ORY@(CNT)="Order:" D:$D(IOUON) SETVIDEO(CNT,1,6,IOUON,IOUOFF) 48 S ORNMSP=$$NMSP^ORCD($P(OR0,U,14)) 49 I '$O(^OR(100,ORIFN,4.5,0)),ORNMSP="RA" D RAD^ORQ21("") Q 50 S ORDIALOG=$P(OR0,U,5) Q:$P(ORDIALOG,";",2)="ORD(101," ; 2.5 order 51 D GETDLG^ORCD(+ORDIALOG),GETORDER^ORCD(ORIFN) 52 S DIWL=1,DIWR=50,DIWF="C50" 53 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D 54 . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)) Q:$P(ITEM,U,11) ; child 55 . S PRMT=$P(ITEM,U,2),MULT=$P(ITEM,U,7) Q:$P(ITEM,U,9)["*" ;hide 56 . S FIRST=$O(ORDIALOG(PRMT,0)) Q:'FIRST ; no values 57 . S TITLE=$S(MULT&$L($G(ORDIALOG(PRMT,"TTL"))):ORDIALOG(PRMT,"TTL"),1:ORDIALOG(PRMT,"A")) 58 . S TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE)) 59 . S INST=0 F S INST=$O(ORDIALOG(PRMT,INST)) Q:INST'>0 D 60 . . I $E(ORDIALOG(PRMT,0))="W" D WP Q 61 . . K ^UTILITY($J,"W") S X=$$EXT^ORCD(PRMT,INST) D ^DIWP 62 . . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PRMT)) CHILDREN(PRMT) 63 . . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$S((INST=FIRST)&(I=1):TITLE,1:$$REPEAT^XLFSTR(" ",30))_^(I,0) 64 I ORNMSP="GMRC",$G(^OR(100,ORIFN,4)) S CNT=CNT+1,@ORY@(CNT)="Consult No.: "_+^(4) 65 S CNT=CNT+1,@ORY@(CNT)=" " ;blank 66 D RAD^ORQ21(1):ORNMSP="RA",MED^ORQ21:ORNMSP="PS" ;add'l data 67 D BA^ORQ21 ;call for CIDC data 68 D5 I $O(^OR(100,+ORIFN,9,0)) D 69 . N CK,OK,X0,X,CDL,I S CNT=CNT+1,@ORY@(CNT)="Order Checks:" 70 . D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF) 71 . S CK=0 F S CK=$O(^OR(100,+ORIFN,9,CK)) Q:CK'>0 S X0=$G(^(CK,0)),X=$G(^(1)) D 72 .. S CDL=$$CDL($P(X0,U,2)) I $P(X0,U,6),'$D(OK) S OK=$P(X0,U,4,6) 73 .. I $L(X)'>68 S CNT=CNT+1,@ORY@(CNT)=CDL_X Q 74 .. S DIWL=1,DIWR=68,DIWF="C68" K ^UTILITY($J,"W") D ^DIWP 75 .. S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=CDL_^(I,0),CDL=" " 76 . Q:'$L($G(OK)) S CNT=CNT+1,@ORY@(CNT)="Override: "_$S($P(OK,U,2):$$USER^ORQ20($P(OK,U,2))_" on ",1:"")_$$DATE^ORQ20($P(OK,U,3)) 77 . I $L($P(OK,U))'>68 S CNT=CNT+1,@ORY@(CNT)=" "_$P(OK,U) Q 78 . S DIWL=1,DIWR=68,DIWF="C68",X=$P(OK,U) K ^UTILITY($J,"W") D ^DIWP 79 . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(I,0) 80 K ^TMP("ORWORD",$J),^UTILITY($J,"W") 81 Q 82 ; 83 SUB(IFN) ; -- add suborder or parent 84 N ORCY,STS,STRT,IG D TEXT^ORQ12(.ORCY,IFN,58) 85 S STS=$G(^ORD(100.01,+$P($G(^OR(100,IFN,3)),U,3),.1)) 86 S STRT=$P(^OR(100,IFN,0),U,8) S:STRT'="" STRT=$$DATE^ORQ20(STRT) 87 S IG=0 F S IG=$O(ORCY(IG)) Q:IG<1 S CNT=CNT+1,@ORY@(CNT)=$J(STS,4)_" "_ORCY(IG)_" "_STRT,(STS,STRT)=" " 88 Q 89 ; 90 WP ; -- add word-processing 91 N WP,ORI,X M WP=@ORDIALOG(PRMT,INST) 92 S CNT=CNT+1,@ORY@(CNT)=TITLE 93 S ORI=0 F S ORI=$O(WP(ORI)) Q:ORI'>0 S X=WP(ORI,0) S:X'="" CNT=CNT+1,@ORY@(CNT)=" "_X 94 Q 95 ; 96 CHILDREN(PARENT) ; -- add children 97 N SEQ,DA,ITM,PRMT,TYPE,X 98 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D 99 . S ITM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITM,U,2) 100 . Q:$G(ORDIALOG(PRMT,INST))="" Q:$P(ITM,U,9)["*" ;no value or hide 101 . S TYPE=$E(ORDIALOG(PRMT,0)) D:TYPE="W" WP 102 . I TYPE'="W" S X=$$EXT^ORCD(PRMT,INST) D ^DIWP 103 Q 104 ; 105 SETVIDEO(LINE,COL,WIDTH,ON,OFF) ; -- set video attributes 106 S ORY("VIDEO",LINE,COL,WIDTH)=ON 107 S ORY("VIDEO",LINE,COL+WIDTH,0)=OFF 108 Q 109 ; 110 VA ; -- Call VADPT 111 N ORY,DFN,Y S DFN=+$P(OR0,"^",2) D OERR^VADPT 112 Q 113 ; 114 CDL(X) ; -- Returns Clinical Danger Level X 115 N Y S Y=$S(X=1:"HIGH:",X=2:"MODERATE:",X=3:"LOW:",1:"NONE:") 116 S Y=$E(Y_" ",1,12) 117 Q Y 118 ; 119 ORIG(IFN) ; -- Return original start date of [renewal] order 120 N I,Y,X3,DONE 121 S I=IFN,Y=$P($G(^OR(100,IFN,0)),U,8),DONE=0 122 F S X3=$G(^OR(100,I,3)) D Q:DONE 123 . I $P(X3,U,11)=2,$P(X3,U,5) S I=$P(X3,U,5) Q ;loop 124 . S Y=$P($G(^OR(100,I,0)),U,8),DONE=1 125 Q Y -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ20.m
r613 r623 1 ORQ20 ; SLC/MKB - Detailed Order Report cont ;3/6/08 10:25 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,92,94,116,141,177,186,190,215,243**;Dec 17, 1997;Build 242 3 ACT ; -- add Activity [from ^ORQ2] 4 N ORACT S ORACT=$P(ACTION,U,2) 5 I ORACT'="NW",$P(ACTION,U,4)=5,$P(ACTION,U,15)=13 Q ;skip canc actions 6 N NVA,USER S:$P(^ORD(100.98,$P(^OR(100,+ORIFN,0),U,11),0),U)="NON-VA MEDICATIONS" NVA=1 7 S CNT=CNT+1,@ORY@(CNT)=$$DATE($P(ACTION,U))_" "_$$ACTION(ORACT) 8 I $P(ACTION,U,13) S @ORY@(CNT)=@ORY@(CNT)_" entered by "_$$USER(+$P(ACTION,U,13)) 9 I ORACT="NW" D ;Show original order text 10 . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,ORIFN_";1",80) 11 . S CNT=CNT+1,@ORY@(CNT)=" Order Text: "_$G(ORZ(1)) 12 . S I=1 F S I=$O(ORZ(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I)) 13 I ORACT="XX" D ;Changed - show new text 14 . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,ORIFN_";"_ORI,80) 15 . S CNT=CNT+1,@ORY@(CNT)=" Changed to: "_$G(ORZ(1)) 16 . S I=1 F S I=$O(ORZ(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I)) 17 A1 I $P(ACTION,U,12) D ;Nature of Order/Release 18 . N ORZ S ORZ=$G(^ORD(100.02,+$P(ACTION,U,12),0)) 19 . S CNT=CNT+1,@ORY@(CNT)=" Nature of Order: "_$P(ORZ,U) 20 . I $P(OR0,U,17),(ORACT="NW") Q ;see event 21 . I "^V^P^"[(U_$P(ORZ,U,2)_U),$P(ACTION,U,16) S CNT=CNT+1,@ORY@(CNT)=" Released by: "_$$USER(+$P(ACTION,U,17))_" on "_$$DATE($P(ACTION,U,16)) 22 I $P(OR0,U,17)&(ORACT="NW") D ;Delayed Release Event 23 . N EVT,X,ORV,I S EVT=+$P(OR0,U,17),X=$$NAME^OREVNTX(EVT) 24 . S:$E(X,1,8)="Delayed " X=$E(X,9,99) 25 . I $G(^ORE(100.2,EVT,1)),'$P(ACTION,U,16) S X=X_" on "_$$DATE(+^(1)) 26 . S CNT=CNT+1,@ORY@(CNT)=" Delayed Until: "_X Q:'$P(ACTION,U,16) 27 . D EVENT(.ORV) S CNT=CNT+1,@ORY@(CNT)=" Released by: "_ORV(1) 28 . S I=1 F S I=$O(ORV(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORV(I)) 29 A2 I $P(ACTION,U,5) S CNT=CNT+1,@ORY@(CNT)=$S($P(ACTION,U,4)=7:" Dig",1:" Elec")_" Signature: "_$$USER(+$P(ACTION,U,5))_" on "_$$DATE($P(ACTION,U,6)) 30 I '$P(ACTION,U,5)!($P(ACTION,U,3)'=$P(ACTION,U,5)),'$$SERVCORR S CNT=CNT+1,@ORY@(CNT)=" "_$S($D(NVA):"Documented by:",1:"Ordered by: ")_" "_$$USER(+$P(ACTION,U,3)) 31 I '$P(ACTION,U,5),$L($P(ACTION,U,4)) D 32 .I $P(ACTION,U,4)=0 D 33 ..S USER=$$USER(+$P(ACTION,U,7)) 34 ..S CNT=CNT+1 35 ..I USER'="" S @ORY@(CNT)=" Released by: "_USER_" on "_$$DATE($P(ACTION,U,16)) 36 ..I USER="" S @ORY@(CNT)=" Released: "_$$DATE($P(ACTION,U,16)) 37 .S CNT=CNT+1,@ORY@(CNT)=" Signature: "_$$SIG($P(ACTION,U,4)) ;186 38 ;I '$P(ACTION,U,5),$L($P(ACTION,U,4)) S:$P(ACTION,U,4)=0 CNT=CNT+1,@ORY@(CNT)=" Released by: "_$$USER(+$P(ACTION,U,7))_" on "_$$DATE($P(ACTION,U,16)) S CNT=CNT+1,@ORY@(CNT)=" Signature: "_$$SIG($P(ACTION,U,4)) ;186 39 I $P(ACTION,U,9) S CNT=CNT+1,@ORY@(CNT)=" Nurse Verified: "_$S($P(ACTION,U,8):$$USER(+$P(ACTION,U,8))_" on ",1:"")_$$DATE($P(ACTION,U,9)) 40 I $P(ACTION,U,11) S CNT=CNT+1,@ORY@(CNT)=" Clerk Verified: "_$S($P(ACTION,U,10):$$USER(+$P(ACTION,U,10))_" on ",1:"")_$$DATE($P(ACTION,U,11)) 41 I $P(ACTION,U,19) S CNT=CNT+1,@ORY@(CNT)=" Chart Reviewed: "_$S($P(ACTION,U,18):$$USER(+$P(ACTION,U,18))_" on ",1:"")_$$DATE($P(ACTION,U,19)) 42 A3 I $P(ACTION,U,2)="DC",$L(OR6) S X=$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),$P(OR6,U):$P($G(^ORD(100.02,+$P(OR6,U),0)),U),1:"") S:$L(X) CNT=CNT+1,@ORY@(CNT)=" Reason for DC: "_X 43 I $L($G(^OR(100,ORIFN,8,ORI,1))) S X=^(1) D ;add backdoor comments 44 . N LBL,I S LBL="" 45 . I $P(ACTION,U,15)="",$P(ACTION,U,2)'="DC" S LBL=" Comments: " ;DC shown above 46 . I $P(ACTION,U,15)=13,$P(ACTION,U,2)'="NW" S LBL=" Cancelled: " ;NW shown in ORQ2 47 . Q:'$L(LBL) I $L(X)'>56 S CNT=CNT+1,@ORY@(CNT)=LBL_X Q 48 . S DIWL=1,DIWR=56,DIWF="C56" K ^UTILITY($J,"W") D ^DIWP 49 . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=LBL_^(I,0),LBL=" " 50 I $D(^OR(100,ORIFN,8,ORI,5)) D ;Ward comments 51 . N X,ORJ K ^UTILITY($J,"W") 52 . S ORJ=0 F S ORJ=$O(^OR(100,ORIFN,8,ORI,5,ORJ)) Q:ORJ'>0 S X=^(ORJ,0) D ^DIWP 53 . S ORJ=0 F S ORJ=$O(^UTILITY($J,"W",DIWL,ORJ)) Q:ORJ'>0 S CNT=CNT+1,@ORY@(CNT)=$S(ORJ=1:" Ward/Clinic Cmmts: ",1:" ")_^(ORJ,0) 54 . K ^UTILITY($J,"W") 55 A4 I $P(ACTION,U,2)="HD",$G(^OR(100,ORIFN,8,ORI,2)) S X2=^(2),CNT=CNT+1,@ORY@(CNT)=" Hold Released: "_$$FMTE^XLFDT($P(X2,U),"2P")_" by "_$$USER($P(X2,U,2)) 56 I $D(^OR(100,ORIFN,8,ORI,3)) D ;Un-/Flagged 57 . N X S X=$G(^OR(100,ORIFN,8,ORI,3)) 58 . S CNT=CNT+1,@ORY@(CNT)=" Flagged by: "_$$USER(+$P(X,U,4))_" on "_$$DATE($P(X,U,3)) 59 . S CNT=CNT+1,@ORY@(CNT)=" "_$P(X,U,5) 60 . Q:X S CNT=CNT+1,@ORY@(CNT)=" Unflagged by: "_$$USER(+$P(X,U,7))_" on "_$$DATE($P(X,U,6)) 61 . S CNT=CNT+1,@ORY@(CNT)=" "_$P(X,U,8) 62 Q 63 ; 64 DC ; -- Add Reason for DC 65 S CNT=CNT+1,@ORY@(CNT)=$$DATE($P(OR6,U,3))_$S($P(OR6,U,8):" Auto-",1:" ")_"Discontinued" 66 I $P(OR6,U,8) D Q 67 . N EVT,PKG,ORV,I 68 . S EVT=$P(OR6,U,8),PKG=$P($G(^ORE(100.2,+EVT,3,ORIFN,0)),U,2) 69 . S @ORY@(CNT)=@ORY@(CNT)_" by "_$S(PKG="FH":"DIETETICS",PKG="LR":"LABORATORY",PKG="PS":"PHARMACY",1:"CPRS") 70 . D EVENT(.ORV,1) S CNT=CNT+1,@ORY@(CNT)=" Patient Movement: "_ORV(1) 71 . S I=1 F S I=$O(ORV(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORV(I)) 72 I $P(OR6,U,2),$P($G(^ORD(100.02,+$P(OR6,U),0)),U,2)'="A" S @ORY@(CNT)=@ORY@(CNT)_" by "_$$USER($P(OR6,U,2)) ;don't show user name if auto-dc 73 N X S X=$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),$P(OR6,U):$P($G(^ORD(100.02,+$P(OR6,U),0)),U),1:"") S:$L(X) CNT=CNT+1,@ORY@(CNT)=" Reason for DC: "_X 74 Q 75 ; 76 ACTION(CODE) ; -- Return name of action CODE 77 N NAME S NAME=$S(CODE="NW":"New Order",CODE="DC":"Discontinue",CODE="HD":"Hold",CODE="RL":"Release Hold",CODE="RN":"Renewal",CODE="XX":"Change",1:"") 78 I CODE="NW",$P(OR3,U,11) S NAME=NAME_$S($P(OR3,U,11)=1:" (Change)",$P(OR3,U,11)=2:" (Renewal)",1:"") 79 Q NAME 80 ; 81 XACT(X) ; -- Return name of transaction code X 82 N Y S X=$G(X) 83 S Y=$S(X="XX":"Edited",X="DC":"Discontinued",X="HD":"Held",X="RL":"Hold Released",X="FW":"Forwarded",X="CA":"Cancelled",1:"") 84 Q Y 85 ; 86 DATE(X) ; -- Return date formatted as 00/00/0000 00:00 87 N T,Y S T=$P(X,".",2)_"0000" 88 S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) 89 I T S Y=Y_" "_$E(T,1,2)_":"_$E(T,3,4) 90 Q Y 91 ; 92 USER(X) ; -- Returns NAME (TITLE) of New Person X 93 N X0,Y S X0=$G(^VA(200,+X,0)),Y=$P(X0,U) 94 S:$P(X0,U,9) Y=Y_" ("_$E($P($G(^DIC(3.1,+$P(X0,U,9),0)),U),1,15)_")" 95 Q Y 96 ; 97 SIG(X) ; -- Returns text of signature status X 98 N Y S Y="" 99 I X=0 S Y="ON CHART WITH WRITTEN ORDERS" 100 I X=1 S Y="ELECTRONICALLY SIGNED" 101 I X=2 S Y="NOT SIGNED" 102 I X=3 S Y="NOT REQUIRED" 103 I X=4 S Y="ON CHART WITH PRINTED ORDERS" 104 I X=5 S Y="NOT REQUIRED DUE TO SERVICE CANCEL/LAPSE" 105 I X=6 S Y="SERVICE CORRECTION TO SIGNED ORDER" 106 Q Y 107 ; 108 SERVCORR() ; -- Returns 1 or 0, if current ACTION is a serv corr change 109 N Y,NATURE,I,X S Y=0 110 G:ORACT'="XX" SCQ 111 S NATURE=+$P(ACTION,U,12),NATURE=$P($G(^ORD(100.02,NATURE,0)),U,2) 112 I "^S^I^"'[(U_NATURE_U) G SCQ 113 S I=$O(^OR(100,ORIFN,8,ORI),-1),X=$G(^(I,0)) 114 I $P(X,U,3)'=$P(ACTION,U,3),$P(X,U,5)'=$P(ACTION,U,3) G SCQ ;show prov 115 S Y=1 116 SCQ Q Y 117 ; 118 EVENT(ORTX,DC) ; -- Returns patient event info for EVT 119 N EVT1,REL,X,Y,I,ORMAX 120 S ORTX(1)="" ;177 121 S EVT1=$G(^ORE(100.2,EVT,1)),REL=$G(^ORE(100.2,EVT,2,ORIFN,0)) 122 ; Return event data if AutoDC or auto-released by an event: 123 I $G(DC)!(REL&'$L($P(REL,U,2))&($P(EVT1,U,2)!$P(EVT1,U,4))) D Q 124 . S Y=$S($P(EVT1,U,5):$P(EVT1,U,5),1:EVT) ;parent owns Activity 125 . S Y=+$O(^ORE(100.2,+Y,10,0)),Y=$G(^(Y,0)),X=$P(Y,U,4) Q:'$L(X) 126 . S X=$S(X="A":"ADMISSION",X="T":"TRANSFER",X="D":"DISCHARGE",X="S":"SPECIALTY CHANGE",1:$S($P(EVT1,U)>$$DPI^ORUTL1("SR*3.0*157"):"IN TO O.R.",1:"OUT OF O.R."))_" on "_$$DATE($P(EVT1,U)) ;243 127 . S ORTX(1)=X,ORTX=1,ORMAX=56 128 . I $P(Y,U,6) S X=$S($P(Y,U,4)="D":"from ",1:"to ")_$$GET1^DIQ(45.7,+$P(Y,U,6)_",",.01) D TXT^ORCHTAB 129 . I $P(Y,U,7) S X="on "_$$GET1^DIQ(42,+$P(Y,U,7)_",",.01) D TXT^ORCHTAB 130 S X=$$USER(+$P(ACTION,U,17))_" on "_$$DATE($P(ACTION,U,16)) 131 I ORIFN'=+$P($G(^ORE(100.2,EVT,0)),U,4),$P(REL,U,2)="MN" S X=X_" (manually released)" 132 S ORTX(1)=X 133 Q 1 ORQ20 ; SLC/MKB - Detailed Order Report cont ;7/23/03 12:29 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,92,94,116,141,177,186,190,215**;Dec 17, 1997 3 ACT ; -- add Activity [from ^ORQ2] 4 N ORACT S ORACT=$P(ACTION,U,2) 5 N NVA S:$P(^ORD(100.98,$P(^OR(100,+ORIFN,0),U,11),0),U)="NON-VA MEDICATIONS" NVA=1 6 S CNT=CNT+1,@ORY@(CNT)=$$DATE($P(ACTION,U))_" "_$$ACTION(ORACT) 7 I $P(ACTION,U,13) S @ORY@(CNT)=@ORY@(CNT)_" entered by "_$$USER(+$P(ACTION,U,13)) 8 I ORACT="NW" D ;Show original order text 9 . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,ORIFN_";1",80) 10 . S CNT=CNT+1,@ORY@(CNT)=" Order Text: "_$G(ORZ(1)) 11 . S I=1 F S I=$O(ORZ(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I)) 12 I ORACT="XX" D ;Changed - show new text 13 . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,ORIFN_";"_ORI,80) 14 . S CNT=CNT+1,@ORY@(CNT)=" Changed to: "_$G(ORZ(1)) 15 . S I=1 F S I=$O(ORZ(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I)) 16 A1 I $P(ACTION,U,12) D ;Nature of Order/Release 17 . N ORZ S ORZ=$G(^ORD(100.02,+$P(ACTION,U,12),0)) 18 . S CNT=CNT+1,@ORY@(CNT)=" Nature of Order: "_$P(ORZ,U) 19 . I $P(OR0,U,17),(ORACT="NW") Q ;see event 20 . I "^V^P^"[(U_$P(ORZ,U,2)_U),$P(ACTION,U,16) S CNT=CNT+1,@ORY@(CNT)=" Released by: "_$$USER(+$P(ACTION,U,17))_" on "_$$DATE($P(ACTION,U,16)) 21 I $P(OR0,U,17)&(ORACT="NW") D ;Delayed Release Event 22 . N EVT,X,ORV,I S EVT=+$P(OR0,U,17),X=$$NAME^OREVNTX(EVT) 23 . S:$E(X,1,8)="Delayed " X=$E(X,9,99) 24 . I $G(^ORE(100.2,EVT,1)),'$P(ACTION,U,16) S X=X_" on "_$$DATE(+^(1)) 25 . S CNT=CNT+1,@ORY@(CNT)=" Delayed Until: "_X Q:'$P(ACTION,U,16) 26 . D EVENT(.ORV) S CNT=CNT+1,@ORY@(CNT)=" Released by: "_ORV(1) 27 . S I=1 F S I=$O(ORV(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORV(I)) 28 A2 I $P(ACTION,U,5) S CNT=CNT+1,@ORY@(CNT)=$S($P(ACTION,U,4)=7:" Dig",1:" Elec")_" Signature: "_$$USER(+$P(ACTION,U,5))_" on "_$$DATE($P(ACTION,U,6)) 29 I '$P(ACTION,U,5)!($P(ACTION,U,3)'=$P(ACTION,U,5)),'$$SERVCORR S CNT=CNT+1,@ORY@(CNT)=" "_$S($D(NVA):"Documented by:",1:"Ordered by: ")_" "_$$USER(+$P(ACTION,U,3)) 30 I '$P(ACTION,U,5),$L($P(ACTION,U,4)) S:$P(ACTION,U,4)=0 CNT=CNT+1,@ORY@(CNT)=" Released by: "_$$USER(+$P(ACTION,U,7))_" on "_$$DATE($P(ACTION,U,16)) S CNT=CNT+1,@ORY@(CNT)=" Signature: "_$$SIG($P(ACTION,U,4)) ;186 31 I $P(ACTION,U,9) S CNT=CNT+1,@ORY@(CNT)=" Nurse Verified: "_$S($P(ACTION,U,8):$$USER(+$P(ACTION,U,8))_" on ",1:"")_$$DATE($P(ACTION,U,9)) 32 I $P(ACTION,U,11) S CNT=CNT+1,@ORY@(CNT)=" Clerk Verified: "_$S($P(ACTION,U,10):$$USER(+$P(ACTION,U,10))_" on ",1:"")_$$DATE($P(ACTION,U,11)) 33 I $P(ACTION,U,19) S CNT=CNT+1,@ORY@(CNT)=" Chart Reviewed: "_$S($P(ACTION,U,18):$$USER(+$P(ACTION,U,18))_" on ",1:"")_$$DATE($P(ACTION,U,19)) 34 A3 I $P(ACTION,U,2)="DC",$L(OR6) S X=$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),$P(OR6,U):$P($G(^ORD(100.02,+$P(OR6,U),0)),U),1:"") S:$L(X) CNT=CNT+1,@ORY@(CNT)=" Reason for DC: "_X 35 I $L($G(^OR(100,ORIFN,8,ORI,1))) S X=^(1) D ;add backdoor comments 36 . N LBL,I S LBL="" 37 . I $P(ACTION,U,15)="",$P(ACTION,U,2)'="DC" S LBL=" Comments: " ;DC shown above 38 . I $P(ACTION,U,15)=13,$P(ACTION,U,2)'="NW" S LBL=" Cancelled: " ;NW shown in ORQ2 39 . Q:'$L(LBL) I $L(X)'>56 S CNT=CNT+1,@ORY@(CNT)=LBL_X Q 40 . S DIWL=1,DIWR=56,DIWF="C56" K ^UTILITY($J,"W") D ^DIWP 41 . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=LBL_^(I,0),LBL=" " 42 I $D(^OR(100,ORIFN,8,ORI,5)) D ;Ward comments 43 . N X,ORJ K ^UTILITY($J,"W") 44 . S ORJ=0 F S ORJ=$O(^OR(100,ORIFN,8,ORI,5,ORJ)) Q:ORJ'>0 S X=^(ORJ,0) D ^DIWP 45 . S ORJ=0 F S ORJ=$O(^UTILITY($J,"W",DIWL,ORJ)) Q:ORJ'>0 S CNT=CNT+1,@ORY@(CNT)=$S(ORJ=1:" Ward/Clinic Cmmts: ",1:" ")_^(ORJ,0) 46 . K ^UTILITY($J,"W") 47 A4 I $P(ACTION,U,2)="HD",$G(^OR(100,ORIFN,8,ORI,2)) S X2=^(2),CNT=CNT+1,@ORY@(CNT)=" Hold Released: "_$$FMTE^XLFDT($P(X2,U),"2P")_" by "_$$USER($P(X2,U,2)) 48 I $D(^OR(100,ORIFN,8,ORI,3)) D ;Un-/Flagged 49 . N X S X=$G(^OR(100,ORIFN,8,ORI,3)) 50 . S CNT=CNT+1,@ORY@(CNT)=" Flagged by: "_$$USER(+$P(X,U,4))_" on "_$$DATE($P(X,U,3)) 51 . S CNT=CNT+1,@ORY@(CNT)=" "_$P(X,U,5) 52 . Q:X S CNT=CNT+1,@ORY@(CNT)=" Unflagged by: "_$$USER(+$P(X,U,7))_" on "_$$DATE($P(X,U,6)) 53 . S CNT=CNT+1,@ORY@(CNT)=" "_$P(X,U,8) 54 Q 55 ; 56 DC ; -- Add Reason for DC 57 S CNT=CNT+1,@ORY@(CNT)=$$DATE($P(OR6,U,3))_$S($P(OR6,U,8):" Auto-",1:" ")_"Discontinued" 58 I $P(OR6,U,8) D Q 59 . N EVT,PKG,ORV,I 60 . S EVT=$P(OR6,U,8),PKG=$P($G(^ORE(100.2,+EVT,3,ORIFN,0)),U,2) 61 . S @ORY@(CNT)=@ORY@(CNT)_" by "_$S(PKG="FH":"DIETETICS",PKG="LR":"LABORATORY",PKG="PS":"PHARMACY",1:"CPRS") 62 . D EVENT(.ORV,1) S CNT=CNT+1,@ORY@(CNT)=" Patient Movement: "_ORV(1) 63 . S I=1 F S I=$O(ORV(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORV(I)) 64 I $P(OR6,U,2),$P($G(^ORD(100.02,+$P(OR6,U),0)),U,2)'="A" S @ORY@(CNT)=@ORY@(CNT)_" by "_$$USER($P(OR6,U,2)) ;don't show user name if auto-dc 65 N X S X=$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),$P(OR6,U):$P($G(^ORD(100.02,+$P(OR6,U),0)),U),1:"") S:$L(X) CNT=CNT+1,@ORY@(CNT)=" Reason for DC: "_X 66 Q 67 ; 68 ACTION(CODE) ; -- Return name of action CODE 69 N NAME S NAME=$S(CODE="NW":"New Order",CODE="DC":"Discontinue",CODE="HD":"Hold",CODE="RL":"Release Hold",CODE="RN":"Renewal",CODE="XX":"Change",1:"") 70 I CODE="NW",$P(OR3,U,11) S NAME=NAME_$S($P(OR3,U,11)=1:" (Change)",$P(OR3,U,11)=2:" (Renewal)",1:"") 71 Q NAME 72 ; 73 XACT(X) ; -- Return name of transaction code X 74 N Y S X=$G(X) 75 S Y=$S(X="XX":"Edited",X="DC":"Discontinued",X="HD":"Held",X="RL":"Hold Released",X="FW":"Forwarded",X="CA":"Cancelled",1:"") 76 Q Y 77 ; 78 DATE(X) ; -- Return date formatted as 00/00/0000 00:00 79 N T,Y S T=$P(X,".",2)_"0000" 80 S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) 81 I T S Y=Y_" "_$E(T,1,2)_":"_$E(T,3,4) 82 Q Y 83 ; 84 USER(X) ; -- Returns NAME (TITLE) of New Person X 85 N X0,Y S X0=$G(^VA(200,+X,0)),Y=$P(X0,U) 86 S:$P(X0,U,9) Y=Y_" ("_$E($P($G(^DIC(3.1,+$P(X0,U,9),0)),U),1,15)_")" 87 Q Y 88 ; 89 SIG(X) ; -- Returns text of signature status X 90 N Y S Y="" 91 I X=0 S Y="ON CHART WITH WRITTEN ORDERS" 92 I X=1 S Y="ELECTRONICALLY SIGNED" 93 I X=2 S Y="NOT SIGNED" 94 I X=3 S Y="NOT REQUIRED" 95 I X=4 S Y="ON CHART WITH PRINTED ORDERS" 96 I X=5 S Y="NOT REQUIRED DUE TO SERVICE CANCEL" 97 I X=6 S Y="SERVICE CORRECTION TO SIGNED ORDER" 98 Q Y 99 ; 100 SERVCORR() ; -- Returns 1 or 0, if current ACTION is a serv corr change 101 N Y,NATURE,I,X S Y=0 102 G:ORACT'="XX" SCQ 103 S NATURE=+$P(ACTION,U,12),NATURE=$P($G(^ORD(100.02,NATURE,0)),U,2) 104 I "^S^I^"'[(U_NATURE_U) G SCQ 105 S I=$O(^OR(100,ORIFN,8,ORI),-1),X=$G(^(I,0)) 106 I $P(X,U,3)'=$P(ACTION,U,3),$P(X,U,5)'=$P(ACTION,U,3) G SCQ ;show prov 107 S Y=1 108 SCQ Q Y 109 ; 110 EVENT(ORTX,DC) ; -- Returns patient event info for EVT 111 N EVT1,REL,X,Y,I,ORMAX 112 S ORTX(1)="" ;177 113 S EVT1=$G(^ORE(100.2,EVT,1)),REL=$G(^ORE(100.2,EVT,2,ORIFN,0)) 114 ; Return event data if AutoDC or auto-released by an event: 115 I $G(DC)!(REL&'$L($P(REL,U,2))&($P(EVT1,U,2)!$P(EVT1,U,4))) D Q 116 . S Y=$S($P(EVT1,U,5):$P(EVT1,U,5),1:EVT) ;parent owns Activity 117 . S Y=+$O(^ORE(100.2,+Y,10,0)),Y=$G(^(Y,0)),X=$P(Y,U,4) Q:'$L(X) 118 . S X=$S(X="A":"ADMISSION",X="T":"TRANSFER",X="D":"DISCHARGE",X="S":"SPECIALTY CHANGE",1:"OUT OF O.R.")_" on "_$$DATE($P(EVT1,U)) 119 . S ORTX(1)=X,ORTX=1,ORMAX=56 120 . I $P(Y,U,6) S X=$S($P(Y,U,4)="D":"from ",1:"to ")_$$GET1^DIQ(45.7,+$P(Y,U,6)_",",.01) D TXT^ORCHTAB 121 . I $P(Y,U,7) S X="on "_$$GET1^DIQ(42,+$P(Y,U,7)_",",.01) D TXT^ORCHTAB 122 S X=$$USER(+$P(ACTION,U,17))_" on "_$$DATE($P(ACTION,U,16)) 123 I ORIFN'=+$P($G(^ORE(100.2,EVT,0)),U,4),$P(REL,U,2)="MN" S X=X_" (manually released)" 124 S ORTX(1)=X 125 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ21.m
r613 r623 1 ORQ21 ; SLC/MKB/GSS - Detailed Order Report cont ; 12/28/2006 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,190,195,215,243**;Dec 17, 1997;Build 242 3 ; 4 ; DBIA 2400 OEL^PSOORRL ^TMP("PS",$J) 5 ; DBIA 2266 EN30^RAO7PC1 ^TMP($J,"RAE2") 6 ; 7 RAD(TCOM) ; -- add RA data for 2.5 orders 8 N RAIFN,CASE,PROC,ORD,ORI,X,ORTTL,ORB 9 S RAIFN=$G(^OR(100,ORIFN,4)) Q:RAIFN'>0 10 D EN30^RAO7PC1(RAIFN) Q:'$D(^TMP($J,"RAE2",+ORVP)) ;DBIA 2266 11 S ORD=$G(^TMP($J,"RAE2",+ORVP,"ORD")),CASE=$O(^(0)) Q:'CASE S PROC=$O(^(CASE,"")) 12 I '$G(TCOM) D ;else add only Tech Comments 13 . S CNT=CNT+1,@ORY@(CNT)=$$LJ^XLFSTR("Procedure:",30)_$S($L(ORD):ORD,1:PROC) 14 . S ORI=0,ORTTL="Procedure Modifiers: ",ORB=1 15 . F S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"M",ORI)) Q:ORI'>0 S CNT=CNT+1,@ORY@(CNT)=ORTTL_^(ORI),ORTTL=$$REPEAT^XLFSTR(" ",30) 16 . S CNT=CNT+1,@ORY@(CNT)="History and Reason for Exam:" 17 . F S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"H",ORI)) Q:ORI'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(ORI) 18 RAD1 I $L($G(^TMP($J,"RAE2",+ORVP,CASE,PROC,"TCOM",1))) S X=^(1) D 19 . N DIWL,DIWR,DIWF,I K ^UTILITY($J,"W") 20 . S DIWL=1,DIWR=72,DIWF="C72" D ^DIWP 21 . S CNT=CNT+1,@ORY@(CNT)="Technologist's Comment:",ORB=1 22 . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(I,0) 23 I $D(^TMP($J,"RAE2",+ORVP,CASE,PROC,"CM")) D 24 . S ORTTL="Contrast Media used: ",ORI=0,ORB=1 25 . F S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"CM",ORI)) Q:ORI<1 S CNT=CNT+1,@ORY@(CNT)=ORTTL_$P(^(ORI),U,2),ORTTL=$$REPEAT^XLFSTR(" ",30) 26 K ^TMP($J,"RAE2",+ORVP),^UTILITY($J,"W") 27 S:$G(ORB) CNT=CNT+1,@ORY@(CNT)=" " ;blank 28 Q 29 ; 30 MED ; -- Add Pharmacy order data 31 Q:$G(^OR(100,ORIFN,4))["N" ;non-VA med -- no refill history 32 N TYPE,NODE,RXN,OR5,STAT S TYPE=$P(OR0,U,12) 33 I '$D(^TMP("PS",$J,0)) D ;get PS data / DBIA 2400 34 . N PSIFN S PSIFN=$G(^OR(100,ORIFN,4)) 35 . S:TYPE="O" PSIFN=$TR(PSIFN,"S","P")_$S(PSIFN?1.N:"R",1:"") 36 . D OEL^PSOORRL(+ORVP,PSIFN_";"_TYPE) ;DBIA 2400 37 S NODE=$G(^TMP("PS",$J,0)),RXN=$G(^("RXN",0)),STAT=$P(NODE,U,6) 38 I '$L(NODE) K ^TMP("PS",$J) Q ;error 39 I $O(^TMP("PS",$J,"DD",0)) D ;Disp Drugs 40 . N I,X,Y S X="Dispense Drugs (units/dose): ",I=0 41 . F S I=$O(^TMP("PS",$J,"DD",I)) Q:I'>0 S Y=$G(^(I,0)) S:Y CNT=CNT+1,@ORY@(CNT)=X_$$GET1^DIQ(50,+Y_",",.01)_" ("_$P(Y,U,2)_")" 42 S:$P(NODE,U,9) CNT=CNT+1,@ORY@(CNT)="Total Dose: "_$P(NODE,U,9) 43 M1 I TYPE="I" D ;admin data 44 . N I,X,Y I $O(^TMP("PS",$J,"B",0)) D 45 .. S X="IV Print Name: ",I=0 46 .. F S I=$O(^TMP("PS",$J,"B",I)) Q:I<1 S Y=$G(^(I,0)) S:$L(Y) CNT=CNT+1,@ORY@(CNT)=X_$P(Y,U),X=$$REPEAT^XLFSTR(" ",30) I $L($P(Y,U,3)) S CNT=CNT+1,@ORY@(CNT)=X_" "_$P(Y,U,3) 47 . S I=+$O(^TMP("PS",$J,"SCH",0)),X=$P($G(^(I,0)),U,2) 48 . S:$L(X) CNT=CNT+1,@ORY@(CNT)="Schedule Type: "_X 49 . S X="Administration Times: ",I=0 50 . F S I=$O(^TMP("PS",$J,"ADM",I)) Q:I'>0 S Y=$G(^(I,0)) S:$L(Y) CNT=CNT+1,@ORY@(CNT)=X_Y,X=$$REPEAT^XLFSTR(" ",30) 51 M2 I TYPE="O" D ;fill history 52 . N FILLD,RET,X,Y,I 53 . S:$P(NODE,U,12) CNT=CNT+1,@ORY@(CNT)="Last Filled: "_$$FMTE^XLFDT($P(NODE,U,12),2) 54 . S CNT=CNT+1,@ORY@(CNT)="Refills Remaining: "_$P(NODE,U,4) 55 . I $P(RXN,U,6)!$G(^TMP("PS",$J,"REF",0)) S X="Filled: " D 56 .. I $P(RXN,U,6) S FILLD=$P(RXN,U,6)_"^^^"_$P(RXN,U,7)_U_$P(RXN,U,3,4) D FILLED("R") 57 .. S RET=$G(^TMP("PS",$J,"RXN","RSTC")) I RET'="" D RETURNS(RET) 58 .. S I=0 F S I=$O(^TMP("PS",$J,"REF",I)) Q:I'>0 D 59 ... S FILLD=$G(^(I,0)) D FILLED("R") 60 ... S RET=$G(^TMP("PS",$J,"REF",I,"RSTC")) I RET'="" D RETURNS(RET) 61 . I $G(^TMP("PS",$J,"PAR",0)) S I=0,X="Partial Fills: " F S I=$O(^TMP("PS",$J,"PAR",I)) Q:I'>0 S FILLD=$G(^(I,0)) D FILLED("P") 62 . S:RXN CNT=CNT+1,@ORY@(CNT)="Prescription#: "_$P(RXN,U) 63 M3 S:$P(RXN,U,5) CNT=CNT+1,@ORY@(CNT)="Pharmacist: "_$P($G(^VA(200,+$P(RXN,U,5),0)),U) 64 I $G(STAT)="ACTIVE/SUSP" S CNT=CNT+1,@ORY@(CNT)="Prescription Status: "_STAT_" - Order is active. Fill or Refill has been requested." 65 S:$P(NODE,U,13) CNT=CNT+1,@ORY@(CNT)="NOT TO BE GIVEN" K ^TMP("PS",$J) 66 S CNT=CNT+1,@ORY@(CNT)=" " ;blank 67 S OR5=$G(^OR(100,ORIFN,5)) I $L(OR5) D ;SC data 68 . N X,Y,I 69 . S CNT=CNT+1,@ORY@(CNT)=" " ;blank line 70 . S CNT=CNT+1,@ORY@(CNT)="First Party Pay Exemptions" 71 . S X="For conditions related to: " 72 . F I=1:1:8 S Y=$P(OR5,U,I) I Y S CNT=CNT+1,@ORY@(CNT)=X_$$SC(I),X=$$REPEAT^XLFSTR(" ",30) 73 Q 74 ; 75 BA ;Billing Aware data display 76 N DXIEN,DXV,ICD9,ICDR,OCT,ORFMDAT 77 S OCT=0,X="" 78 ; Get the date of the order for CSV/CTD usage 79 S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIFN) 80 ; $O through diagnoses for an order 81 F S OCT=$O(^OR(100,ORIFN,5.1,OCT)) Q:OCT'?1N.N D 82 . ; DXIEN=Dx IEN 83 . S DXIEN=+^OR(100,ORIFN,5.1,OCT,0) 84 . ; Get Dx record for date ORFMDAT 85 . S ICDR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) 86 . ; Get Dx verbiage and ICD code 87 . S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2) 88 . S X=" " 89 . I OCT=1 D 90 .. S CNT=CNT+1,@ORY@(CNT)=" " ;blank line 91 .. S CNT=CNT+1,@ORY@(CNT)="Clinical Indicators" 92 .. S X="Diagnosis of: " 93 . S X=X_ICD9_" - "_DXV,CNT=CNT+1,@ORY@(CNT)=X 94 I OCT'="" D ;if there are diagnoses show Treatment Factors 95 . S X="For conditions related to: " 96 . F I=1:1:8 S Y=$P(^OR(100,ORIFN,5.2),U,I) I Y D 97 .. S CNT=CNT+1,@ORY@(CNT)=X_$$SC(I),X=$$REPEAT^XLFSTR(" ",30) 98 Q 99 ; 100 FILLED(TYPE) ; -- add FILLD data 101 N Y S Y=$$FMTE^XLFDT($P(FILLD,U),2)_" ("_$$ROUTING($P(FILLD,U,5))_")" 102 S:TYPE="R"&$P(FILLD,U,4) Y=Y_" released "_$$FMTE^XLFDT($P(FILLD,U,4),2) 103 S:TYPE="P"&$P(FILLD,U,3) Y=Y_" Qty: "_$P(FILLD,U,3) 104 S CNT=CNT+1,@ORY@(CNT)=X_Y,X=$$REPEAT^XLFSTR(" ",30) 105 S:$L($P(FILLD,U,6)) CNT=CNT+1,@ORY@(CNT)=X_$P(FILLD,U,6) 106 Q 107 RETURNS(NODE) ; add Return to Stock Data 108 N DATE,NAME,TEXT,X 109 S DATE=$$FMTE^XLFDT($P(NODE,U)) 110 S NAME=$P(^VA(200,$P(NODE,U,2),0),U) 111 S X=$$REPEAT^XLFSTR(" ",13) 112 S TEXT="Return to Stock: "_X_DATE_" by "_NAME 113 S CNT=CNT+1,@ORY@(CNT)=TEXT 114 S X=$$REPEAT^XLFSTR(" ",30) 115 S TEXT=X_"Comments: "_$P(NODE,U,3) 116 S CNT=CNT+1,@ORY@(CNT)=TEXT 117 Q 118 ; 119 ROUTING(X) ; -- Returns external form 120 N Y S Y=$S($G(X)="M":"Mail",$G(X)="W":"Window",1:$G(X)) 121 Q Y 122 ; 123 SC(J) ; -- Returns name of SC field by piece number 124 I '$G(J) Q "" 125 I J=1 Q "SERVICE CONNECTED CONDITION" 126 I J=2 Q "MILITARY SEXUAL TRAUMA" 127 I J=3 Q "AGENT ORANGE EXPOSURE" 128 I J=4 Q "IONIZING RADIATION EXPOSURE" 129 I J=5 Q "ENVIRONMENTAL CONTAMINANTS" 130 I J=6 Q "HEAD OR NECK CANCER" 131 I J=7 Q "COMBAT VETERAN" 132 I J=8 Q "SHIPBOARD HAZARD AND DEFENSE" 133 Q "" 1 ORQ21 ; SLC/MKB/GSS - Detailed Order Report cont ; 10/6/2005 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,190,195,215**;Dec 17, 1997 3 ; 4 ; DBIA 2400 OEL^PSOORRL ^TMP("PS",$J) 5 ; DBIA 2266 EN30^RAO7PC1 ^TMP($J,"RAE2") 6 ; 7 RAD(TCOM) ; -- add RA data for 2.5 orders 8 N RAIFN,CASE,PROC,ORD,ORI,X,ORTTL,ORB 9 S RAIFN=$G(^OR(100,ORIFN,4)) Q:RAIFN'>0 10 D EN30^RAO7PC1(RAIFN) Q:'$D(^TMP($J,"RAE2",+ORVP)) ;DBIA 2266 11 S ORD=$G(^TMP($J,"RAE2",+ORVP,"ORD")),CASE=$O(^(0)) Q:'CASE S PROC=$O(^(CASE,"")) 12 I '$G(TCOM) D ;else add only Tech Comments 13 . S CNT=CNT+1,@ORY@(CNT)=$$LJ^XLFSTR("Procedure:",30)_$S($L(ORD):ORD,1:PROC) 14 . S ORI=0,ORTTL="Procedure Modifiers: ",ORB=1 15 . F S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"M",ORI)) Q:ORI'>0 S CNT=CNT+1,@ORY@(CNT)=ORTTL_^(ORI),ORTTL=$$REPEAT^XLFSTR(" ",30) 16 . S CNT=CNT+1,@ORY@(CNT)="History and Reason for Exam:" 17 . F S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"H",ORI)) Q:ORI'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(ORI) 18 RAD1 I $L($G(^TMP($J,"RAE2",+ORVP,CASE,PROC,"TCOM",1))) S X=^(1) D 19 . N DIWL,DIWR,DIWF,I K ^UTILITY($J,"W") 20 . S DIWL=1,DIWR=72,DIWF="C72" D ^DIWP 21 . S CNT=CNT+1,@ORY@(CNT)="Technologist's Comment:",ORB=1 22 . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(I,0) 23 I $D(^TMP($J,"RAE2",+ORVP,CASE,PROC,"CM")) D 24 . S ORTTL="Contrast Media used: ",ORI=0,ORB=1 25 . F S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"CM",ORI)) Q:ORI<1 S CNT=CNT+1,@ORY@(CNT)=ORTTL_$P(^(ORI),U,2),ORTTL=$$REPEAT^XLFSTR(" ",30) 26 K ^TMP($J,"RAE2",+ORVP),^UTILITY($J,"W") 27 S:$G(ORB) CNT=CNT+1,@ORY@(CNT)=" " ;blank 28 Q 29 ; 30 MED ; -- Add Pharmacy order data 31 Q:$G(^OR(100,ORIFN,4))["N" ;non-VA med -- no refill history 32 N TYPE,NODE,RXN,OR5,STAT S TYPE=$P(OR0,U,12) 33 I '$D(^TMP("PS",$J,0)) D ;get PS data / DBIA 2400 34 . N PSIFN S PSIFN=$G(^OR(100,ORIFN,4)) 35 . S:TYPE="O" PSIFN=$TR(PSIFN,"S","P")_$S(PSIFN?1.N:"R",1:"") 36 . D OEL^PSOORRL(+ORVP,PSIFN_";"_TYPE) ;DBIA 2400 37 S NODE=$G(^TMP("PS",$J,0)),RXN=$G(^("RXN",0)),STAT=$P(NODE,U,6) 38 I '$L(NODE) K ^TMP("PS",$J) Q ;error 39 I $O(^TMP("PS",$J,"DD",0)) D ;Disp Drugs 40 . N I,X,Y S X="Dispense Drugs (units/dose): ",I=0 41 . F S I=$O(^TMP("PS",$J,"DD",I)) Q:I'>0 S Y=$G(^(I,0)) S:Y CNT=CNT+1,@ORY@(CNT)=X_$$GET1^DIQ(50,+Y_",",.01)_" ("_$P(Y,U,2)_")" 42 S:$P(NODE,U,9) CNT=CNT+1,@ORY@(CNT)="Total Dose: "_$P(NODE,U,9) 43 M1 I TYPE="I" D ;admin data 44 . N I,X,Y I $O(^TMP("PS",$J,"B",0)) D 45 .. S X="IV Print Name: ",I=0 46 .. F S I=$O(^TMP("PS",$J,"B",I)) Q:I<1 S Y=$G(^(I,0)) S:$L(Y) CNT=CNT+1,@ORY@(CNT)=X_$P(Y,U),X=$$REPEAT^XLFSTR(" ",30) I $L($P(Y,U,3)) S CNT=CNT+1,@ORY@(CNT)=X_" "_$P(Y,U,3) 47 . S I=+$O(^TMP("PS",$J,"SCH",0)),X=$P($G(^(I,0)),U,2) 48 . S:$L(X) CNT=CNT+1,@ORY@(CNT)="Schedule Type: "_X 49 . S X="Administration Times: ",I=0 50 . F S I=$O(^TMP("PS",$J,"ADM",I)) Q:I'>0 S Y=$G(^(I,0)) S:$L(Y) CNT=CNT+1,@ORY@(CNT)=X_Y,X=$$REPEAT^XLFSTR(" ",30) 51 M2 I TYPE="O" D ;fill history 52 . N FILLD,X,Y,I 53 . S:$P(NODE,U,12) CNT=CNT+1,@ORY@(CNT)="Last Filled: "_$$FMTE^XLFDT($P(NODE,U,12),2) 54 . S CNT=CNT+1,@ORY@(CNT)="Refills Remaining: "_$P(NODE,U,4) 55 . I $P(RXN,U,6)!$G(^TMP("PS",$J,"REF",0)) S X="Filled: " D 56 .. I $P(RXN,U,6) S FILLD=$P(RXN,U,6)_"^^^"_$P(RXN,U,7)_U_$P(RXN,U,3,4) D FILLED("R") 57 .. S I=0 F S I=$O(^TMP("PS",$J,"REF",I)) Q:I'>0 S FILLD=$G(^(I,0)) D FILLED("R") 58 . I $G(^TMP("PS",$J,"PAR",0)) S I=0,X="Partial Fills: " F S I=$O(^TMP("PS",$J,"PAR",I)) Q:I'>0 S FILLD=$G(^(I,0)) D FILLED("P") 59 . S:RXN CNT=CNT+1,@ORY@(CNT)="Prescription#: "_$P(RXN,U) 60 M3 S:$P(RXN,U,5) CNT=CNT+1,@ORY@(CNT)="Pharmacist: "_$P($G(^VA(200,+$P(RXN,U,5),0)),U) 61 I $G(STAT)="ACTIVE/SUSP" S CNT=CNT+1,@ORY@(CNT)="Prescription Status: "_STAT_" - Order is active. Fill or Refill has been requested." 62 S:$P(NODE,U,13) CNT=CNT+1,@ORY@(CNT)="NOT TO BE GIVEN" K ^TMP("PS",$J) 63 S CNT=CNT+1,@ORY@(CNT)=" " ;blank 64 S OR5=$G(^OR(100,ORIFN,5)) I $L(OR5) D ;SC data 65 . N X,Y,I 66 . S CNT=CNT+1,@ORY@(CNT)=" " ;blank line 67 . S CNT=CNT+1,@ORY@(CNT)="First Party Pay Exemptions" 68 . S X="For conditions related to: " 69 . F I=1:1:7 S Y=$P(OR5,U,I) I Y S CNT=CNT+1,@ORY@(CNT)=X_$$SC(I),X=$$REPEAT^XLFSTR(" ",30) 70 Q 71 ; 72 BA ;Billing Aware data display 73 N DXIEN,DXV,ICD9,ICDR,OCT,ORFMDAT 74 S OCT=0,X="" 75 ; Get the date of the order for CSV/CTD usage 76 S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIFN) 77 ; $O through diagnoses for an order 78 F S OCT=$O(^OR(100,ORIFN,5.1,OCT)) Q:OCT'?1N.N D 79 . ; DXIEN=Dx IEN 80 . S DXIEN=+^OR(100,ORIFN,5.1,OCT,0) 81 . ; Get Dx record for date ORFMDAT 82 . S ICDR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) 83 . ; Get Dx verbiage and ICD code 84 . S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2) 85 . S X=" " 86 . I OCT=1 D 87 .. S CNT=CNT+1,@ORY@(CNT)=" " ;blank line 88 .. S CNT=CNT+1,@ORY@(CNT)="Clinical Indicators" 89 .. S X="Diagnosis of: " 90 . S X=X_ICD9_" - "_DXV,CNT=CNT+1,@ORY@(CNT)=X 91 I OCT'="" D ;if there are diagnoses show Treatment Factors 92 . S X="For conditions related to: " 93 . F I=1:1:7 S Y=$P(^OR(100,ORIFN,5.2),U,I) I Y D 94 .. S CNT=CNT+1,@ORY@(CNT)=X_$$SC(I),X=$$REPEAT^XLFSTR(" ",30) 95 Q 96 ; 97 FILLED(TYPE) ; -- add FILLD data 98 N Y S Y=$$FMTE^XLFDT($P(FILLD,U),2)_" ("_$$ROUTING($P(FILLD,U,5))_")" 99 S:TYPE="R"&$P(FILLD,U,4) Y=Y_" released "_$$FMTE^XLFDT($P(FILLD,U,4),2) 100 S:TYPE="P"&$P(FILLD,U,3) Y=Y_" Qty: "_$P(FILLD,U,3) 101 S CNT=CNT+1,@ORY@(CNT)=X_Y,X=$$REPEAT^XLFSTR(" ",30) 102 S:$L($P(FILLD,U,6)) CNT=CNT+1,@ORY@(CNT)=X_$P(FILLD,U,6) 103 Q 104 ; 105 ROUTING(X) ; -- Returns external form 106 N Y S Y=$S($G(X)="M":"Mail",$G(X)="W":"Window",1:$G(X)) 107 Q Y 108 ; 109 SC(J) ; -- Returns name of SC field by piece number 110 I '$G(J) Q "" 111 I J=1 Q "SERVICE CONNECTED CONDITION" 112 I J=2 Q "MILITARY SEXUAL TRAUMA" 113 I J=3 Q "AGENT ORANGE EXPOSURE" 114 I J=4 Q "IONIZING RADIATION EXPOSURE" 115 I J=5 Q "ENVIRONMENTAL CONTAMINANTS" 116 I J=6 Q "HEAD OR NECK CANCER" 117 I J=7 Q "COMBAT VETERAN" 118 Q "" -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPT.m
r613 r623 1 ORQPT ; SLC/MKB - Patient Selection ; 4/18/07 7:20am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**52,82,85,215,243**;Dec 17, 1997;Build 242 3 ; 4 ; Ref. to ^UTILITY via IA 10061 5 ; SLC/PKS - 3/2000: Modified to deal with "Combinations." 6 ; 7 EN ; -- main entry point for OR PATIENT SELECTION 8 I $G(ORVP),'($D(ORPNM)&$D(ORSSN)) K ORVP ; reset 9 D EN^VALM("OR PATIENT SELECTION") 10 Q 11 ; 12 HDR ; -- header code 13 N X I '$G(ORVP) S X="** No patient selected **" 14 E S X=$G(ORPNM)_" "_$G(ORSSN) 15 S VALMHDR(1)="Current patient: "_X 16 Q 17 ; 18 INIT ; -- init variables and list array 19 ; Modifications for multiple "Combination" lists by PKS. 20 ; 21 ; PARAM herein might end up as: ORLP DEFAULT CLINIC WEDNESDAY 22 ; (Param Name and current DOW) 23 ; ORY might end up passed as: 5^5^C;1;T-360;T+60;A 24 ; (#lines^#pts^source;serviceSection;startDate;stopDate;sort) 25 ; 26 N ORY,ORX,PARAM,ORYZB,ORYZE 27 ; 28 ;added by CLA 12/12/96 - gets SERVICE/SECTION of user: 29 N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) 30 ; 31 S ORY=$$GET^XPAR("USR^SRV.`"_$G(ORSRV),"ORLP DEFAULT LIST SOURCE",1,"I") ; Gets default list source for this user. 32 I $L(ORY) D S ORY=ORY_";"_ORX 33 . ; PKS: Set "PARAM" var to parameter name in param def file: 34 . S PARAM="ORLP DEFAULT "_$S(ORY="T":"TEAM",ORY="S":"SPECIALTY",ORY="P":"PROVIDER",ORY="W":"WARD",ORY="C":"CLINIC",ORY="M":"COMBINATION",1:"") 35 . S:ORY="C" PARAM=PARAM_" "_$$UP^XLFSTR($$DOW^XLFDT(DT)) ; For clinics, add current DOW. 36 . S ORX=$$GET^XPAR("USR^SRV.`"_$G(ORSRV),PARAM,1,"I") ; Source param. 37 . ; Next lines modified by PKS for "Combinations" and dates: 38 . I (ORY="C")!(ORY="M") D 39 . . S ORYZB=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC START DATE",1,"I")) ; Gets clinic start date. 40 . . I ORYZB="T+0" S ORYZB=$$FMTE^XLFDT(DT,ORYZB) 41 . . S ORX=ORX_";"_ORYZB 42 . . S ORYZE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC STOP DATE",1,"I")) ; Add ";" & stop date. 43 . . I ORYZE="T+0" S ORYZE=$$FMTE^XLFDT(DT,ORYZE) 44 . . S ORX=ORX_";"_ORYZE 45 S $P(ORY,";",5)=$$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") ; Add default sort order. 46 ; 47 ; Call tag that builds the actual Patient Selection List: 48 D BUILD(ORY) 49 Q 50 ; 51 DEFAULT() ; -- Returns default action 52 I '$P($G(^TMP("OR",$J,"PATIENTS",0)),U,2) Q "Change View" 53 I XQORM("B")="Quit" Q "Close" 54 Q "Next Screen" 55 ; 56 MSG() ; -- Lmgr msg bar 57 Q "Enter the number of the patient chart to be opened" 58 ; 59 HELP ; -- help code 60 N X D FULL^VALM1 S VALMBCK="R" 61 W !!,"Enter the display number of the patient whose chart you wish to open" 62 W !,"or enter a patient name, SSN, or initial/last 4 combination. To" 63 W !,"change the list of patients displayed on this screen, enter CV. To" 64 W !,"have the new list automatically displayed when selecting a new patient," 65 W !,"enter SV. Enter FD to search by patient name or identifier." 66 W !!,"Press <return> to continue ..." R X:DTIME 67 Q 68 ; 69 EXIT ; -- exit code 70 K ^TMP("OR",$J,"PATIENTS"),XQORM("ALT") 71 Q 72 ; 73 BUILD(LIST) ; -- build list in ^TMP("OR",$J,"PATIENTS") 74 N ORI,ORX,ORY,LCNT,NUM,DFN,NAME,TYPE,PTR,BEG,END,SORT,DOB,RBED,%DT,X,Y,TITLE,PTID,SENS 75 S TYPE=$E(LIST),PTR=+$P(LIST,";",2),SORT=$P(LIST,";",5) 76 ; Next 5 lines added by PKS: 77 I ((SORT="S")&(TYPE'="M")) S SORT="A" ; Reset invalid sorts. 78 I TYPE="M" D ; Deal with combinations. 79 .I ((SORT="P")!(SORT="A")!(SORT="S")) Q ; P,A,S are acceptable. 80 .S SORT="A" ; Default. 81 S $P(LIST,";",5)=SORT ; Reset in case of change. 82 S BEG=$P(LIST,";",3) I $L(BEG) S X=BEG,%DT="X" D ^%DT S BEG=Y 83 S END=$P(LIST,";",4) I $L(END) S X=END,%DT="X" D ^%DT S END=Y 84 I TYPE="T" D TEAMPTS^ORQPTQ1(.ORY,PTR) S TITLE="Team "_$P($G(^OR(100.21,+PTR,0)),U) 85 I TYPE="P" D PROVPTS^ORQPTQ2(.ORY,PTR) S TITLE="Provider "_$P($G(^VA(200,+PTR,0)),U) 86 I TYPE="S" D SPECPTS^ORQPTQ2(.ORY,PTR) S TITLE="Specialty "_$P($G(^DIC(45.7,+PTR,0)),U) 87 I TYPE="W" D WARDPTS^ORQPTQ2(.ORY,PTR) S TITLE="Ward "_$P($G(^DIC(42,+PTR,0)),U) 88 I TYPE="C" D CLINPTS^ORQPTQ2(.ORY,PTR,BEG,END) S TITLE="Clinic "_$P($G(^SC(+PTR,0)),U) 89 ; Next line added by PKS for "Combinations:" 90 I TYPE="M" N MSG D COMBPTS^ORQPTQ6(1,PTR,BEG,END) S TITLE="Combination List" ; Sets MSG,LCNT,NUM, and writes ^TMP("OR",$J,"PATIENTS"). 91 ; Next section added by PKS for "Combinations:" 92 I TYPE="M" D G BQ ; Check MSG var, then go to BQ tag. 93 .I MSG'="" D ; Did call to COMBPTS assign an error message? 94 ..S LCNT=1,NUM=0 ; Set defaults. 95 ..S ^TMP("OR",$J,"PATIENTS",1,0)=" "_MSG ; Write error msg. 96 D CLEAN^VALM10 S (LCNT,NUM)=0 ; All but "M" types reset, go on to B1. 97 ; 98 B1 S ORI=0 F S ORI=$O(ORY(ORI)) Q:ORI'>0 I ORY(ORI) D ; sort 99 . S DFN=+ORY(ORI) 100 . ;sort logic added by CLA 7/23/97: 101 . S ORX="" 102 . I SORT="P",(TYPE="C") S ORX=$P($G(ORY(ORI)),U,4) D 103 .. S $P(ORX,".",2)=$E($P(ORX,".",2)_"000",1,4) 104 ..S ORX=ORX_U_$P(ORY(ORI),U,2) 105 . I SORT="R",(TYPE'="C") S ORX=$P($G(^DPT(+ORY(ORI),.101)),U)_U_$P(ORY(ORI),U,2) 106 . I SORT="T" S ORX="" ; Need to add terminal digit sorting. 107 . ; If no sort specified, default to alphabetic (plus app't if clinic type): 108 . I ORX="" S ORX=$P(ORY(ORI),U,2)_U_$P($G(ORY(ORI)),U,4) 109 . S ^TMP("OR",$J,"PATIENTS","B",ORX_DFN)=ORY(ORI) ; DFN ^ Name 110 I '$D(^TMP("OR",$J,"PATIENTS")) D G BQ 111 . N MSG 112 . S MSG="No patients found" 113 . S LCNT=1,NUM=0 114 . I $D(ORY(1)) S MSG=$P(ORY(1),"^",2) ; error message from search 115 . S ^TMP("OR",$J,"PATIENTS",1,0)=" "_MSG 116 B2 S ORX="" F S ORX=$O(^TMP("OR",$J,"PATIENTS","B",ORX)) Q:ORX="" S ORY=^(ORX) D 117 . S DFN=+ORY,NAME=$P(ORY,U,2) 118 . S DOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3)) 119 . S:(TYPE'="C") RBED=$P($G(^DPT(DFN,.101)),U) 120 . I (TYPE="C") S RBED=$S(SORT="P":$$FMTE^XLFDT($P(ORX,U)),1:$$FMTE^XLFDT($P(^TMP("OR",$J,"PATIENTS","B",ORX),U,4))) 121 . ;Q:RBED="" removed by CLA 7/23/97 to prevent blank lines 122 . S LCNT=LCNT+1,NUM=NUM+1 123 . S ^TMP("OR",$J,"PATIENTS","IDX",NUM)=ORY ; DFN ^ NAME 124 . ; Next lines modified/added by PKS on 1/24/2001: 125 . ; Check for "sensitive" patients: 126 . S PTID="" 127 . S PTID=$$ID(DFN) 128 . S SENS=$$SSN^DPTLK1(DFN) 129 . I SENS["*" S PTID="" 130 . S DOB=$$DOB^DPTLK1(DFN) 131 . S ^TMP("OR",$J,"PATIENTS",LCNT,0)=$$LJ^XLFSTR(NUM,5)_$$LJ^XLFSTR(NAME,31)_$$LJ^XLFSTR(PTID,10)_$$LJ^XLFSTR(DOB,15)_$G(RBED) 132 . D CNTRL^VALM10(LCNT,1,5,IOINHI,IOINORM) 133 BQ S ^TMP("OR",$J,"PATIENTS",0)=LCNT_U_NUM_U_$G(LIST) ; #lines^#pts^context 134 S ^TMP("OR",$J,"PATIENTS","#")=$O(^ORD(101,"B","ORQPT SELECT PATIENT",0))_"^1:"_NUM 135 S RBED=$S(TYPE="C":"Appointment Date",TYPE="M":"Source Other",1:"Room-Bed") 136 D CHGCAP^VALM("ROOM-BED",RBED) K VALMHDR 137 S VALMCNT=LCNT,VALMBG=1,VALMBCK="R" S:$L($G(TITLE)) VALM("TITLE")=TITLE 138 Q 139 ; 140 ID(DFN) ; -- Returns short ID for patient ID 141 N ID S ID=$P($G(^DPT(DFN,.36)),U,4) ; short ID 142 I '$L(ID) S ID=$E($P($G(^DPT(DFN,0)),U,9),6,9) ; last 4 of SSN 143 Q "("_$E(NAME)_ID_")" 144 ; 145 APPT(DFN,CLINIC,FROM,TO) ; -- Return [next?] clinic appointment 146 ; returns date/time next appt or "", returns "^error message" on error 147 N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J) ;IA 10061 148 S VASD("F")=FROM,VASD("T")=TO,VASD("C",CLINIC)="" 149 D SDA^ORQRY01(.ERR,.ERRMSG) 150 I ERR K ^UTILITY("VASD",$J) Q ERRMSG 151 S NEXT=+$O(^UTILITY("VASD",$J,0)),NEXT=$P($G(^(NEXT,"I")),U) 152 K ^UTILITY("VASD",$J) 153 Q NEXT 154 ; 155 ALT ; -- XQORM("ALT") code to search File 2 for patient X 156 N DIC,DFN,Y,ORX S ORX=X D FULL^VALM1 157 S DIC=2,DIC(0)="EQM",X=$S($D(XQORMRCL):" ",1:ORX) 158 D ^DIC I Y'>0 S VALMBCK="R" Q ;S XQORMERR=1 Q 159 S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q 160 S DFN=+Y G:DFN'=+$G(ORVP) SLCT1 ; set patient variables 161 Q 162 ; 163 FIND ; -- find patient in ^DPT 164 N X,Y,DIC,ORX,DFN 165 S DIC=2,DIC(0)="AEQM" D FULL^VALM1 166 D ^DIC I Y'>0 S VALMBCK="R" Q 167 S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q 168 S DFN=+Y G:DFN'=+$G(ORVP) SLCT1 ; set patient variables 169 Q 170 ; 171 SELECT ; -- select patient from list 172 N NMBR,X,Y,Z,DIC,DFN,ORX S NMBR=+$P(XQORNOD(0),"=",2) 173 S Y=$G(^TMP("OR",$J,"PATIENTS","IDX",NMBR)),DFN=+Y 174 I 'DFN W $C(7),!!,NMBR_" is not a valid selection.",! S VALMBCK="" H 1 Q 175 ;W " "_$P(Y,U,2) S ^DISV(DUZ,"^DPT(")=DFN 176 D FULL^VALM1 S DIC=2,DIC(0)="EQM",X="`"_DFN D ^DIC I Y<0 S VALMBCK="R" Q 177 S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q 178 SLCT1 ; -- may enter here with DFN from FIND 179 N VADM,VAEL,VAIN,VA,VAERR,LOC,ORCNV 180 D OERR^VADPT,ELIG^VADPT 181 S LOC=+$G(^DIC(42,+VAIN(4),44))_";SC(" I 'LOC,'$D(XQAID) D 182 . I $G(NMBR) N X S X=$$CONTEXT^ORQPT1 I $E(X)="C" S LOC=$P(X,";",2)_";SC(" Q:LOC ; use clinic if selected from list, else ask 183 . S LOC="" ;,X=$$LOCATION^ORCMENU1(1) S:X LOC=X 184 S ORL=LOC,ORL(0)=$P($G(^SC(+ORL,0)),U),ORL(1)=VAIN(5) 185 S ORVP=DFN_";DPT(",ORPNM=VADM(1),ORSSN=$P(VADM(2),U,2) 186 S ORDOB=$P(VADM(3),U,2),ORAGE=VADM(4),ORSEX=$P(VADM(5),U) 187 S ORTS=+VAIN(3),ORWARD=VAIN(4),ORATTEND=+VAIN(11),ORSC=$G(VAEL(3)) 188 I $P($G(^DGSL(38.1,+ORVP,0)),"^",2),($G(^DPT(+ORVP,.1))]""!$D(^XUSEC("DG SENSITIVITY",DUZ))) D 189 . ; if senstive patient and (patient inpatient or user holds key) 190 . ; prevents sensitive patient warning from scrolling off screen 191 . N X 192 . W !!,"Press <return> to continue ..." 193 . R X:DTIME 194 SLCT2 ; -- convert patient's orders, if not already done 195 Q 196 ; 197 OK(DATE) ; -- Patient is deceased; ok to continue? 198 N X,Y,DIR S DIR(0)="YA",DIR("B")="NO" 199 S DIR("A")="Do you wish to continue? " 200 W $C(7),!!,"This patient died "_$$FMTE^XLFDT(DATE)_"!" 201 D ^DIR 202 Q +Y 1 ORQPT ; SLC/MKB - Patient Selection ;3/16/05 08:28 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**52,82,85,215**;Dec 17, 1997 3 ; 4 ; Ref. to ^UTILITY via IA 10061 5 ; SLC/PKS - 3/2000: Modified to deal with "Combinations." 6 ; 7 EN ; -- main entry point for OR PATIENT SELECTION 8 I $G(ORVP),'($D(ORPNM)&$D(ORSSN)) K ORVP ; reset 9 D EN^VALM("OR PATIENT SELECTION") 10 Q 11 ; 12 HDR ; -- header code 13 N X I '$G(ORVP) S X="** No patient selected **" 14 E S X=$G(ORPNM)_" "_$G(ORSSN) 15 S VALMHDR(1)="Current patient: "_X 16 Q 17 ; 18 INIT ; -- init variables and list array 19 ; Modifications for multiple "Combination" lists by PKS. 20 ; 21 ; PARAM herein might end up as: ORLP DEFAULT CLINIC WEDNESDAY 22 ; (Param Name and current DOW) 23 ; ORY might end up passed as: 5^5^C;1;T-360;T+60;A 24 ; (#lines^#pts^source;serviceSection;startDate;stopDate;sort) 25 ; 26 N ORY,ORX,PARAM,ORYZB,ORYZE 27 ; 28 ;added by CLA 12/12/96 - gets SERVICE/SECTION of user: 29 N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) 30 ; 31 S ORY=$$GET^XPAR("USR^SRV.`"_$G(ORSRV),"ORLP DEFAULT LIST SOURCE",1,"I") ; Gets default list source for this user. 32 I $L(ORY) D S ORY=ORY_";"_ORX 33 . ; PKS: Set "PARAM" var to parameter name in param def file: 34 . S PARAM="ORLP DEFAULT "_$S(ORY="T":"TEAM",ORY="S":"SPECIALTY",ORY="P":"PROVIDER",ORY="W":"WARD",ORY="C":"CLINIC",ORY="M":"COMBINATION",1:"") 35 . S:ORY="C" PARAM=PARAM_" "_$$UP^XLFSTR($$DOW^XLFDT(DT)) ; For clinics, add current DOW. 36 . S ORX=$$GET^XPAR("USR^SRV.`"_$G(ORSRV),PARAM,1,"I") ; Source param. 37 . ; Next lines modified by PKS for "Combinations" and dates: 38 . I (ORY="C")!(ORY="M") D 39 . . S ORYZB=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC START DATE",1,"I")) ; Gets clinic start date. 40 . . I ORYZB="T+0" S ORYZB=$$FMTE^XLFDT(DT,ORYZB) 41 . . S ORX=ORX_";"_ORYZB 42 . . S ORYZE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC STOP DATE",1,"I")) ; Add ";" & stop date. 43 . . I ORYZE="T+0" S ORYZE=$$FMTE^XLFDT(DT,ORYZE) 44 . . S ORX=ORX_";"_ORYZE 45 S $P(ORY,";",5)=$$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") ; Add default sort order. 46 ; 47 ; Call tag that builds the actual Patient Selection List: 48 D BUILD(ORY) 49 Q 50 ; 51 DEFAULT() ; -- Returns default action 52 I '$P($G(^TMP("OR",$J,"PATIENTS",0)),U,2) Q "Change View" 53 I XQORM("B")="Quit" Q "Close" 54 Q "Next Screen" 55 ; 56 MSG() ; -- Lmgr msg bar 57 Q "Enter the number of the patient chart to be opened" 58 ; 59 HELP ; -- help code 60 N X D FULL^VALM1 S VALMBCK="R" 61 W !!,"Enter the display number of the patient whose chart you wish to open" 62 W !,"or enter a patient name, SSN, or initial/last 4 combination. To" 63 W !,"change the list of patients displayed on this screen, enter CV. To" 64 W !,"have the new list automatically displayed when selecting a new patient," 65 W !,"enter SV. Enter FD to search by patient name or identifier." 66 W !!,"Press <return> to continue ..." R X:DTIME 67 Q 68 ; 69 EXIT ; -- exit code 70 K ^TMP("OR",$J,"PATIENTS"),XQORM("ALT") 71 Q 72 ; 73 BUILD(LIST) ; -- build list in ^TMP("OR",$J,"PATIENTS") 74 N ORI,ORX,ORY,LCNT,NUM,DFN,NAME,TYPE,PTR,BEG,END,SORT,DOB,RBED,%DT,X,Y,TITLE,PTID,SENS 75 S TYPE=$E(LIST),PTR=+$P(LIST,";",2),SORT=$P(LIST,";",5) 76 ; Next 5 lines added by PKS: 77 I ((SORT="S")&(TYPE'="M")) S SORT="A" ; Reset invalid sorts. 78 I TYPE="M" D ; Deal with combinations. 79 .I ((SORT="P")!(SORT="A")!(SORT="S")) Q ; P,A,S are acceptable. 80 .S SORT="A" ; Default. 81 S $P(LIST,";",5)=SORT ; Reset in case of change. 82 S BEG=$P(LIST,";",3) I $L(BEG) S X=BEG,%DT="X" D ^%DT S BEG=Y 83 S END=$P(LIST,";",4) I $L(END) S X=END,%DT="X" D ^%DT S END=Y 84 I TYPE="T" D TEAMPTS^ORQPTQ1(.ORY,PTR) S TITLE="Team "_$P($G(^OR(100.21,+PTR,0)),U) 85 I TYPE="P" D PROVPTS^ORQPTQ2(.ORY,PTR) S TITLE="Provider "_$P($G(^VA(200,+PTR,0)),U) 86 I TYPE="S" D SPECPTS^ORQPTQ2(.ORY,PTR) S TITLE="Specialty "_$P($G(^DIC(45.7,+PTR,0)),U) 87 I TYPE="W" D WARDPTS^ORQPTQ2(.ORY,PTR) S TITLE="Ward "_$P($G(^DIC(42,+PTR,0)),U) 88 I TYPE="C" D CLINPTS^ORQPTQ2(.ORY,PTR,BEG,END) S TITLE="Clinic "_$P($G(^SC(+PTR,0)),U) 89 ; Next line added by PKS for "Combinations:" 90 I TYPE="M" N MSG D COMBPTS^ORQPTQ6(1,PTR,BEG,END) S TITLE="Combination List" ; Sets MSG,LCNT,NUM, and writes ^TMP("OR",$J,"PATIENTS"). 91 ; Next section added by PKS for "Combinations:" 92 I TYPE="M" D G BQ ; Check MSG var, then go to BQ tag. 93 .I MSG'="" D ; Did call to COMBPTS assign an error message? 94 ..S LCNT=1,NUM=0 ; Set defaults. 95 ..S ^TMP("OR",$J,"PATIENTS",1,0)=" "_MSG ; Write error msg. 96 D CLEAN^VALM10 S (LCNT,NUM)=0 ; All but "M" types reset, go on to B1. 97 ; 98 B1 S ORI=0 F S ORI=$O(ORY(ORI)) Q:ORI'>0 I ORY(ORI) D ; sort 99 . S DFN=+ORY(ORI) 100 . ;sort logic added by CLA 7/23/97: 101 . S ORX="" 102 . I SORT="P",(TYPE="C") S ORX=$P($G(ORY(ORI)),U,4) D 103 .. S $P(ORX,".",2)=$E($P(ORX,".",2)_"000",1,4) 104 ..S ORX=ORX_U_$P(ORY(ORI),U,2) 105 . I SORT="R",(TYPE'="C") S ORX=$P($G(^DPT(+ORY(ORI),.101)),U)_U_$P(ORY(ORI),U,2) 106 . I SORT="T" S ORX="" ; Need to add terminal digit sorting. 107 . ; If no sort specified, default to alphabetic (plus app't if clinic type): 108 . I ORX="" S ORX=$P(ORY(ORI),U,2)_U_$P($G(ORY(ORI)),U,4) 109 . S ^TMP("OR",$J,"PATIENTS","B",ORX_DFN)=ORY(ORI) ; DFN ^ Name 110 I '$D(^TMP("OR",$J,"PATIENTS")) D G BQ 111 . N MSG 112 . S MSG="No patients found" 113 . S LCNT=1,NUM=0 114 . I $D(ORY(1)) S MSG=$P(ORY(1),"^",2) ; error message from search 115 . S ^TMP("OR",$J,"PATIENTS",1,0)=" "_MSG 116 B2 S ORX="" F S ORX=$O(^TMP("OR",$J,"PATIENTS","B",ORX)) Q:ORX="" S ORY=^(ORX) D 117 . S DFN=+ORY,NAME=$P(ORY,U,2) 118 . S DOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3)) 119 . S:(TYPE'="C") RBED=$P($G(^DPT(DFN,.101)),U) 120 . I (TYPE="C") S RBED=$S(SORT="P":$$FMTE^XLFDT($P(ORX,U)),1:$$FMTE^XLFDT($P(^TMP("OR",$J,"PATIENTS","B",ORX),U,4))) 121 . ;Q:RBED="" removed by CLA 7/23/97 to prevent blank lines 122 . S LCNT=LCNT+1,NUM=NUM+1 123 . S ^TMP("OR",$J,"PATIENTS","IDX",NUM)=ORY ; DFN ^ NAME 124 . ; Next lines modified/added by PKS on 1/24/2001: 125 . ; Check for "sensitive" patients: 126 . S PTID="" 127 . S PTID=$$ID(DFN) 128 . S SENS=$$SSN^DPTLK1(DFN) 129 . I SENS["*" S PTID="" 130 . S DOB=$$DOB^DPTLK1(DFN) 131 . S ^TMP("OR",$J,"PATIENTS",LCNT,0)=$$LJ^XLFSTR(NUM,5)_$$LJ^XLFSTR(NAME,31)_$$LJ^XLFSTR(PTID,10)_$$LJ^XLFSTR(DOB,15)_$G(RBED) 132 . D CNTRL^VALM10(LCNT,1,5,IOINHI,IOINORM) 133 BQ S ^TMP("OR",$J,"PATIENTS",0)=LCNT_U_NUM_U_$G(LIST) ; #lines^#pts^context 134 S ^TMP("OR",$J,"PATIENTS","#")=$O(^ORD(101,"B","ORQPT SELECT PATIENT",0))_"^1:"_NUM 135 S RBED=$S(TYPE="C":"Appointment Date",TYPE="M":"Source Other",1:"Room-Bed") 136 D CHGCAP^VALM("ROOM-BED",RBED) K VALMHDR 137 S VALMCNT=LCNT,VALMBG=1,VALMBCK="R" S:$L($G(TITLE)) VALM("TITLE")=TITLE 138 Q 139 ; 140 ID(DFN) ; -- Returns short ID for patient ID 141 N ID S ID=$P($G(^DPT(DFN,.36)),U,4) ; short ID 142 I '$L(ID) S ID=$E($P($G(^DPT(DFN,0)),U,9),6,9) ; last 4 of SSN 143 Q "("_$E(NAME)_ID_")" 144 ; 145 APPT(DFN,CLINIC,FROM,TO) ; -- Return [next?] clinic appointment 146 ; returns date/time next appt or "", returns "^error message" on error 147 N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J) ;IA 10061 148 S VASD("F")=FROM,VASD("T")=TO,VASD("C",CLINIC)="" 149 D SDA^ORQRY01(.ERR,.ERRMSG) 150 I ERR K ^UTILITY("VASD",$J) Q ERRMSG 151 S NEXT=+$O(^UTILITY("VASD",$J,0)),NEXT=$P($G(^(NEXT,"I")),U) 152 K ^UTILITY("VASD",$J) 153 Q NEXT 154 ; 155 ALT ; -- XQORM("ALT") code to search File 2 for patient X 156 N DIC,DFN,Y,ORX S ORX=X D FULL^VALM1 157 S DIC=2,DIC(0)="EQM",X=$S($D(XQORMRCL):" ",1:ORX) 158 D ^DIC I Y'>0 S VALMBCK="R" Q ;S XQORMERR=1 Q 159 S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q 160 S DFN=+Y G:DFN'=+$G(ORVP) SLCT1 ; set patient variables 161 Q 162 ; 163 FIND ; -- find patient in ^DPT 164 N X,Y,DIC,ORX,DFN 165 S DIC=2,DIC(0)="AEQM" D FULL^VALM1 166 D ^DIC I Y'>0 S VALMBCK="R" Q 167 S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q 168 S DFN=+Y G:DFN'=+$G(ORVP) SLCT1 ; set patient variables 169 Q 170 ; 171 SELECT ; -- select patient from list 172 N NMBR,X,Y,Z,DIC,DFN,ORX S NMBR=+$P(XQORNOD(0),"=",2) 173 S Y=$G(^TMP("OR",$J,"PATIENTS","IDX",NMBR)),DFN=+Y 174 I 'DFN W $C(7),!!,NMBR_" is not a valid selection.",! S VALMBCK="" H 1 Q 175 ;W " "_$P(Y,U,2) S ^DISV(DUZ,"^DPT(")=DFN 176 D FULL^VALM1 S DIC=2,DIC(0)="EQM",X="`"_DFN D ^DIC I Y<0 S VALMBCK="R" Q 177 S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q 178 SLCT1 ; -- may enter here with DFN from FIND 179 N VADM,VAEL,VAIN,VA,VAERR,LOC,ORCNV 180 D OERR^VADPT,ELIG^VADPT 181 S LOC=+$G(^DIC(42,+VAIN(4),44))_";SC(" I 'LOC,'$D(XQAID) D 182 . I $G(NMBR) N X S X=$$CONTEXT^ORQPT1 I $E(X)="C" S LOC=$P(X,";",2)_";SC(" Q:LOC ; use clinic if selected from list, else ask 183 . S LOC="" ;,X=$$LOCATION^ORCMENU1(1) S:X LOC=X 184 S ORL=LOC,ORL(0)=$P($G(^SC(+ORL,0)),U),ORL(1)=VAIN(5) 185 S ORVP=DFN_";DPT(",ORPNM=VADM(1),ORSSN=$P(VADM(2),U,2) 186 S ORDOB=$P(VADM(3),U,2),ORAGE=VADM(4),ORSEX=$P(VADM(5),U) 187 S ORTS=+VAIN(3),ORWARD=VAIN(4),ORATTEND=+VAIN(11),ORSC=$G(VAEL(3)) 188 I $P($G(^DGSL(38.1,+ORVP,0)),"^",2),($G(^DPT(+ORVP,.1))]""!$D(^XUSEC("DG SENSITIVITY",DUZ))) D 189 . ; if senstive patient and (patient inpatient or user holds key) 190 . ; prevents sensitive patient warning from scrolling off screen 191 . N X 192 . W !!,"Press <return> to continue ..." 193 . R X:DTIME 194 SLCT2 ; -- convert patient's orders, if not already done 195 S ORCNV=$$OTF^OR3CONV(+ORVP) Q:'ORCNV I ORCNV>0 W !,"DONE" H 1 Q 196 I ORCNV<0 W $C(7),!!,$P(ORCNV,U,2) H 2 S VALMBCK="R" Q 197 Q 198 ; 199 OK(DATE) ; -- Patient is deceased; ok to continue? 200 N X,Y,DIR S DIR(0)="YA",DIR("B")="NO" 201 S DIR("A")="Do you wish to continue? " 202 W $C(7),!!,"This patient died "_$$FMTE^XLFDT(DATE)_"!" 203 D ^DIR 204 Q +Y -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPTQ1.m
r613 r623 1 ORQPTQ1 ; SLC/CLA - Functs which return OR patient lists and sources pt 1 ; 8/20/07 5:43am2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,74,63,91,85,139,243**;Dec 17, 1997;Build 242 3 VAMCPTS(Y) 4 5 6 7 8 VAMCLONG(Y,DIR,FROM) 9 10 11 12 13 14 15 16 17 18 DEFTM(ORY) 19 20 21 22 23 TEAMS(ORY) 24 25 26 27 28 29 .I $P($G(^OR(100.21,ORTM,11)),U)'=0!($D(^OR(100.21,ORTM,1,$G(DUZ,0))))S ORY(I)=ORTM_U_ORTMN,I=I+130 31 32 TEAMPTS(ORY,TEAM,TMPFLAG) 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 TEAMPR(ORY,PROV) 56 57 58 59 60 61 62 63 64 TEAMPR2(ORY,PROV) 65 66 67 68 69 70 71 72 73 74 75 76 TEAMPROV(ORY,TEAM) 77 78 79 80 81 82 83 84 85 TPROVPT(PROV) 86 87 88 89 90 91 92 93 94 95 96 97 98 99 TMSPT(ORY,PT) 100 101 102 103 104 105 106 107 108 109 110 TPTPR(ORY,PT) 111 112 113 114 115 116 117 118 119 120 PERSPR(ORY) 121 122 123 124 125 126 127 128 129 PRIMPT(ORY,ORPT) 130 131 132 133 134 135 136 137 138 139 140 141 142 PROVPT(ORY,ORPT) 143 144 145 146 PPLINK(ORPROV,ORPT) 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 PDLINK(ORDEV,ORPT) 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 PCMMLINK(ORPROV,ORPT) 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 PUNSIGN(ORY,ORBDFN) 197 198 199 200 201 202 203 204 205 206 207 208 209 1 ORQPTQ1 ; SLC/CLA - Functs which return OR patient lists and sources pt 1 ;12/15/97 [ 04/02/97 3:32 PM ] [6/6/01 11:34am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,74,63,91,85,139**;Dec 17, 1997 3 VAMCPTS(Y) ; RETURN LIST OF PATIENTS IN VAMC: DFN^NAME 4 N I,J,V 5 S I=1 6 S J=0 F S J=$O(^DPT("B",J)) Q:J="" S V=0,V=$O(^DPT("B",J,V)) S Y(I)=V_"^"_J,I=I+1 7 Q 8 VAMCLONG(Y,DIR,FROM) ; return a bolus of patients in VAMC: DFN^NAME 9 N I,IEN,CNT S CNT=44 10 I DIR=0 D ; Forward direction 11 . F I=1:1:CNT S FROM=$O(^DPT("B",FROM)) Q:FROM="" D 12 . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM 13 . I +$G(Y(CNT))="" S Y(I)="" 14 I DIR=1 D ; Reverse direction 15 . F I=1:1:CNT S FROM=$O(^DPT("B",FROM),-1) Q:FROM="" D 16 . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM 17 Q 18 DEFTM(ORY) ; return current user's default team list 19 Q:'$D(DUZ) 20 N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) 21 S ORY=$$GET^XPAR("USR^SRV.`"_+$G(ORSRV),"ORLP DEFAULT TEAM",1,"B") 22 Q 23 TEAMS(ORY) ; return list of teams for a system 24 ; Also called under DBIA # 2692. 25 N ORTM,I,ORTMN 26 S ORTMN="",I=1 27 F S ORTMN=$O(^OR(100.21,"B",ORTMN)) Q:ORTMN="" D 28 .S ORTM="",ORTM=$O(^OR(100.21,"B",ORTMN,ORTM)) Q:ORTM="" 29 .S ORY(I)=ORTM_U_ORTMN,I=I+1 30 S:+$G(ORY(1))<1 ORY(1)="^No teams found." 31 Q 32 TEAMPTS(ORY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS IN A TEAM 33 ; Also called under DBIA # 2692. 34 ; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx" 35 ; global root string passed in ORY, and builds the returned 36 ; list in that global instead of to a memory array. 37 N DOTMP,NEWTMP 38 S DOTMP=0 39 I $G(TMPFLAG) D ; Was value passed? 40 .I TMPFLAG S DOTMP=1 ; Is value TRUE? 41 I +$G(TEAM)<1 D 42 .I DOTMP S NEWTMP=ORY_1_")",@NEWTMP="^No team identified" Q 43 .I 'DOTMP S ORY(1)="^No team identified" Q 44 N ORI,ORPT,I 45 S I=0 46 S ORI=0 F S ORI=$O(^OR(100.21,+TEAM,10,ORI)) Q:ORI<1 D 47 .S ORPT=^OR(100.21,+TEAM,10,ORI,0) 48 .I DOTMP D 49 ..S I=I+1,NEWTMP=ORY_+I_")" 50 ..S @NEWTMP=+ORPT_U_$P(^DPT(+ORPT,0),U) 51 .I 'DOTMP S I=I+1,ORY(I)=+ORPT_U_$P(^DPT(+ORPT,0),U) 52 I DOTMP S:I<1 NEWTMP=ORY_1_")",@NEWTMP="^No patients found." 53 I 'DOTMP S:I<1 ORY(1)="^No patients found." 54 Q 55 TEAMPR(ORY,PROV) ; return list of teams linked to a provider 56 I +$G(PROV)<1 S ORY(1)="^No provider identified" Q 57 N ORTM,I,ORTMN 58 S ORTM="",I=1 59 F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D 60 .S ORTMN=$P(^OR(100.21,ORTM,0),U) 61 .S ORY(I)=ORTM_U_ORTMN,I=I+1 62 S:+$G(ORY(1))<1 ORY(1)="^No teams found." 63 Q 64 TEAMPR2(ORY,PROV) ; return list of teams linked to a provider 65 ; This tag added by PKS/slc - 8/1999. 66 I +$G(PROV)<1 S ORY(1)="^No provider identified" Q 67 N ORTM,ORDATA,ORTMN,ORTYPE,I 68 S ORTM="",I=1 69 F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D 70 .S ORDATA=^OR(100.21,ORTM,0) ; Get value. 71 .S ORTMN=$P(ORDATA,U) ; Team List name. 72 .S ORTYPE=$P(ORDATA,U,2) ; Team List type. 73 .S ORY(I)=ORTM_U_ORTMN_U_ORTYPE,I=I+1 74 S:+$G(ORY(1))<1 ORY(1)="^No teams found." 75 Q 76 TEAMPROV(ORY,TEAM) ; return list of providers linked to a team 77 I +$G(TEAM)<1 S ORY(1)="^No team identified" 78 N PROV,I,SEQ 79 S I=1 80 S SEQ=0 F S SEQ=$O(^OR(100.21,+TEAM,1,SEQ)) Q:SEQ<1 D 81 .S PROV=^OR(100.21,+TEAM,1,SEQ,0) I $L(PROV) D 82 ..S ORY(I)=+PROV_U_$P(^VA(200,+PROV,0),U),I=I+1 83 S:+$G(ORY(1))<1 ORY(1)="^No providers found." 84 Q 85 TPROVPT(PROV) ;return list of patients linked to a provider via teams 86 ; Modified by PKS: 8/1999. 87 I +$G(PROV)<1 S ^TMP("ORLPUPT",$J,"^No provider identified")="" 88 N ORTM,ORTMN,ORI,ORPT 89 S ORTM="" 90 F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D ; Teams. 91 .S ORTMN=$P(^OR(100.21,+ORTM,0),U,1) ; Get name of Team List. 92 .S ORI=0 F S ORI=$O(^OR(100.21,+ORTM,10,ORI)) Q:ORI<1 D 93 ..S ORPT=^OR(100.21,+ORTM,10,ORI,0) 94 ..S ^TMP("ORLPUPT",$J,+ORPT_U_$P(^DPT(+ORPT,0),U))="" 95 ..; Next line added by PKS: 96 ..S ^TMP("ORLPUPT",$J,"B",ORTMN,$P(^DPT(+ORPT,0),U)_U_+ORPT)="" 97 I '$D(^TMP("ORLPUPT",$J)) S ^TMP("ORLPUPT",$J,"^No patients found.")="" 98 Q 99 TMSPT(ORY,PT) ;return list of teams linked to a patient (patient is active) 100 I +$G(PT)<1 S ORY(1)="^No patient identified" Q 101 N ORTM,I,ORTMN,ORTMTYP 102 S ORTM="",I=1 103 F S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1 D 104 .S ORTMN=$P(^OR(100.21,ORTM,0),U) 105 .S ORTMTYP=$P(^OR(100.21,ORTM,0),U,2) I $L(ORTMTYP) D 106 ..S ORTMTYP=$$EXTERNAL^DILFD(100.21,1,"",ORTMTYP,"") 107 .S ORY(I)=ORTM_U_ORTMN_U_$S($L(ORTMTYP):ORTMTYP,1:"no type"),I=I+1 108 S:+$G(ORY(1))<1 ORY(1)="^No teams found." 109 Q 110 TPTPR(ORY,PT) ;return list of providers linked to a patient via teams 111 I +$G(PT)<1 S ORY(1)="^No patient identified" Q 112 N ORTM,PROV,SEQ 113 S ORTM="" 114 F S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1 D 115 .S SEQ=0 F S SEQ=$O(^OR(100.21,+ORTM,1,SEQ)) Q:SEQ<1 D 116 ..S PROV=^OR(100.21,+ORTM,1,SEQ,0) I $L(PROV) D 117 ...S ORY(+PROV)=+PROV_U_$P(^VA(200,+PROV,0),U) 118 S:'$D(ORY) ORY(1)="^No providers found." 119 Q 120 PERSPR(ORY) ; return list of personal lists linked to current user 121 N ORTM,I,ORTMN 122 S ORTM="",I=1 123 F S ORTM=$O(^OR(100.21,"C",DUZ,ORTM)) Q:+$G(ORTM)<1 D 124 .Q:$P(^OR(100.21,ORTM,0),U,2)'="P" ;quit if not a personal list 125 .S ORTMN=$P(^OR(100.21,ORTM,0),U) 126 .S ORY(I)=ORTM_U_ORTMN,I=I+1 127 S:+$G(ORY(1))<1 ORY(1)="^No personal lists found." 128 Q 129 PRIMPT(ORY,ORPT) ; return patient's PCMM primary care team 130 I +$G(ORPT)<1 S ORY(1)="^No patient identified" 131 N ORQPUR,ORQERROR,ORQLST,ORQERR,ORQDT,ORIDT,ORADT,ORX 132 S ORQPUR(2)="" ;"2" is the ien for purpose "primary care" [^SD(403.47] 133 D NOW^%DTC S ORQDT("BEGIN")=%-.0001,ORQDT("END")=%+.0001,ORQDT("INCL")=0 134 S ORQERROR=$$TMPT^SCAPMC(.ORPT,"ORQDT","ORQPUR","ORQLST","ORQERR") 135 I ORQERROR=0 S ORY="^Error in search for primary care team." 136 I +$G(ORQLST(1))>0 D 137 .S ORX=ORQLST(1),ORADT=$P(ORX,U,4),ORIDT=$P(ORX,U,5) 138 .I ($G(ORADT)>$G(ORIDT)) S ORY=$P(ORX,U)_U_$P(ORX,U,2) 139 S:+$G(ORY)<1 ORY="^No primary care team found." 140 K % 141 Q 142 PROVPT(ORY,ORPT) ; return PCMM primary provider for a patient 143 I +$G(ORPT)<1 S ORY(1)="^No patient identified" 144 S ORY(1)=$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1) 145 Q 146 PPLINK(ORPROV,ORPT) ; returns '1' if patient is linked to provider 147 N ORX,ORPP 148 S ORX="",ORPP=0 149 I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0 150 I $D(^DPT("APR",ORPROV,ORPT)) Q "1^PRIM" ;provider is patient's primary 151 I $D(^DPT("AAP",ORPROV,ORPT)) Q "1^ATTD" ;provider is patient's attending 152 ;is provider and patient on the same team: 153 D TPROVPT(ORPROV) 154 F S ORX=$O(^TMP("ORLPUPT",$J,ORX)) Q:ORX="" D 155 .I +ORX=ORPT S ORPP="1^OERRTM" Q 156 K ^TMP("ORLPUPT",$J) 157 ; 158 ;If not linked already, see if linked via PCMM: 159 I ORPP=0 S ORPP=$$PCMMLINK(ORPROV,ORPT) 160 ; 161 Q ORPP 162 PDLINK(ORDEV,ORPT) ; returns '1' if patient is linked to device via team 163 ;ORDEV can be either ien or device name 164 N ORY,ORX,ORTM,ORDP,ORTMDEV,ORDEVIEN 165 S ORDP=0 166 I (+$G(ORPT)<1)!($L($G(ORDEV))<1) Q 0 167 ; Are device and patient on the same team?: 168 I '$D(^%ZIS(1,ORDEV,0)) D ;ORDEV is not an ien 169 .S ORDEVIEN=0,ORDEVIEN=$O(^%ZIS(1,"B",$P(ORDEV,U),ORDEVIEN)) 170 .S ORDEV=ORDEVIEN 171 Q:+$G(ORDEV)<1 0 172 D TMSPT(.ORY,ORPT) 173 S ORX="" F S ORX=$O(ORY(ORX)) Q:ORX="" D 174 .S ORTM=ORY(ORX) 175 .I $D(^OR(100.21,+ORTM,0)),$P(^(0),U,4)=ORDEV S ORDP=1 Q 176 Q ORDP 177 PCMMLINK(ORPROV,ORPT) ;returns '1' if patient is linked to provider via PCMM 178 N ORPP,ORPCMM,ORPCP 179 S ORPP=0 180 I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0 181 ; 182 ;provider is patient's PCMM primary care practitioner: 183 I ORPROV=+$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1) Q "1^PCP" ;DBIA #1252 184 ; 185 ;provider is patient's PCMM associate provider: 186 I ORPROV=+$$OUTPTAP^SDUTL3(ORPT,$$NOW^XLFDT) Q "1^AP" ;DBIA #1252 187 ; 188 ;provider is linked to patient via PCMM team position assignment: 189 S ORPCMM=$$PRPT^SCAPMC(ORPT,,,,,,"^TMP(""ORPCMMLK"",$J)",) ;DBIA #1916 190 S ORPCP=0 191 F S ORPCP=$O(^TMP("ORPCMMLK",$J,"SCPR",ORPCP)) Q:'ORPCP!ORPP=1 D 192 .I ORPROV=ORPCP S ORPP="1^PCMMTM" 193 K ^TMP("ORPCMMLK",$J) 194 ; 195 Q ORPP 196 PUNSIGN(ORY,ORBDFN) ;rtns array of providers with unsigned orders for pt 197 N ORDG,ORX,ORZ,ORDNUM 198 S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien 199 K ^TMP("ORR",$J) 200 ;get unsigned orders: 201 D EN^ORQ1(ORBDFN_";DPT(",ORDG,11,"","","",0,0) 202 S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" 203 I +$G(^TMP("ORR",$J,ORX,"TOT"))>0 D 204 .S ORX="" F S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" D 205 ..S ORZ="" F S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:+$G(ORZ)<1 D 206 ...S ORDNUM=^TMP("ORR",$J,ORX,ORZ) 207 ...S ORY(+$$UNSIGNOR^ORQOR2(+ORDNUM))="" 208 K ^TMP("ORR",$J) 209 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQAL.m
r613 r623 1 ORQQAL ; slc/CLA,JFR - Functions which return patient allergy data ;6/8/06 14:11 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,85,162,190,216,232,243**;Dec 17, 1997;Build 242 3 LIST(ORAY,ORPT) ; RETURN PATIENT'S ALLERGY/ADVERSE REACTION INFO: 4 ; null:no allergy assessment, 0:no known allergies, 1:pt has allergies 5 ; if 1 also get: allergen/reactant^reaction/symptom^severity^allergy ien 6 N I,J,K 7 S I=1,J=0,K=0 8 D EN1^GMRAOR1(ORPT,"GMRARXN") 9 I $G(GMRARXN)="" S ORAY(I)="^No Allergy Assessment" 10 I $G(GMRARXN)=0 S ORAY(I)="^No Known Allergies" 11 I $G(GMRARXN)=1 F S J=$O(GMRARXN(J)) Q:J="" S ORAY(I)=$P(GMRARXN(J),"^",3)_"^"_$P(GMRARXN(J),"^")_"^"_$P(GMRARXN(J),"^",2) D SIGNS S I=I+1 12 S:'$D(ORAY(1)) ORAY(1)="^No allergies found." 13 K GMRARXN 14 Q 15 SIGNS S K=0,N=0 F S K=$O(GMRARXN(J,"S",K)) Q:K'>0 D 16 .I N=0 S ORAY(I)=ORAY(I)_"^"_$P(GMRARXN(J,"S",K),";") 17 .E S ORAY(I)=ORAY(I)_";"_$P(GMRARXN(J,"S",K),";") 18 .S N=N+1 19 Q 20 LRPT(ORAY,ORPT) ; RETURN PT'S ALLERGY/ADVERSE REACTION INFO IN REPORT FORMAT: 21 ; null:no allergy assessment, 0:no known allergies, 1:pt has allergies 22 ; if 1 also get: allergen/reactant^reaction/symptom^severity^allergy ien 23 N I,J,K,SEVER,CR,GMRAIDT ;216 24 S CR=$CHAR(13) 25 S I=1,J=0,K=0,SEVER="",GMRAIDT=1 ;216 26 D EN1^GMRAOR1(ORPT,"GMRARXN") 27 I $G(GMRARXN)="" S ORAY(I)="No Allergy Assessment" 28 I $G(GMRARXN)=0 S ORAY(I)="No Known Allergies" 29 I $G(GMRARXN)=1 F S J=$O(GMRARXN(J)) Q:J="" D 30 .S SEVER=$P(GMRARXN(J),U,2) 31 .S ORAY(I)=$P(GMRARXN(J),U)_" "_$S($L($G(SEVER)):"[Severity: "_SEVER_"]",1:""),I=I+1 32 .S K=0,N=0 F S K=$O(GMRARXN(J,"S",K)) Q:K'>0 D 33 ..I N=0 S ORAY(I)=" Signs/symptoms: "_$P(GMRARXN(J,"S",K),";") 34 ..E S ORAY(I)=" "_$P(GMRARXN(J,"S",K),";") 35 ..I $P(GMRARXN(J,"S",K),";",2) S ORAY(I)=ORAY(I)_" ("_$$FMTE^XLFDT($P(GMRARXN(J,"S",K),";",2),2)_")" ;216 36 ..S N=N+1,I=I+1 37 .S ORAY(I)=" ",I=I+1 38 S:'$D(ORAY(1)) ORAY(1)="No allergies found." 39 K GMRARXN 40 Q 41 RXN(ORAY,ORPT,SRC,NDF,PSDRUG) ; RETURN TRUE OR FALSE IF PATIENT IS ALLERGIC TO AGENT 42 ; SRC: ALLERGEN SOURCE (CM=CONTRAST MEDIA, DR=DRUG) 43 ; NDF: IF SRC=DR, NDF=Nat'l Drug File ien ELSE NDF="" 44 ; PSDRUG:IF SRC=DR, PSDRUG=(local) Drug file ien ELSE PSDRUG="" 45 S ORAY=$$ORCHK^GMRAOR(ORPT,SRC,NDF) 46 I SRC="DR",ORAY=1 D ;drug ingredient allergy found 47 .S I=1,J=0 F S J=$O(GMRAING(J)) Q:J="" D 48 ..I I=1 S ORAY=ORAY_U_GMRAING(J) 49 ..E S ORAY=ORAY_";"_GMRAING(J) 50 ..S I=I+1 51 I SRC="DR",ORAY=2 D ;drug class allergy found 52 .S CL="",I=1,J=0 F S J=$O(GMRADRCL(J)) Q:J="" D 53 ..; per test sites 3/17/04 - no oc for pt allergy to entire HERBS class: 54 ..Q:$P(GMRADRCL(J),U)="HA000" 55 ..I I=1 S ORAY=ORAY_U_$P(GMRADRCL(J),U,2) 56 ..E S CL=$P(GMRADRCL(J),U,2) I ORAY'[CL S ORAY=ORAY_";"_CL 57 ..S I=I+1 58 I SRC="DR",(+$G(ORAY)<1) D MEDCLASS(.ORAY,ORPT,PSDRUG) 59 K I,J,GMRADRCL,GMRAING,CL 60 Q 61 MEDCLASS(ORAY,DFN,PSDRUG) ;check for allergens with medications in same VA drug class 62 N ORVACLS,CL,X,I,RET,TYP 63 S TYP="DR" 64 Q:+$G(PSDRUG)<1 65 ;S ORVACLS=$P(^PSDRUG(PSDRUG,0),U,2) 66 S ORVACLS=$$CLASS50^ORPEAPI(PSDRUG) 67 Q:$L(ORVACLS)<4 68 Q:$G(ORVACLS)="HA000" ;don't process herbal drug class for order checks 69 S CL=$S($E(ORVACLS,1,4)="CN10":5,1:4) ;look at 5 chars if ANALGESICS 70 D GETDATA^GMRAOR(DFN) 71 Q:'$D(^TMP("GMRAOC",$J,"APC")) 72 S I="" F S I=$O(^TMP("GMRAOC",$J,"APC",I)) Q:'$L(I) D 73 .I $E(I,1,CL)=$E(ORVACLS,1,CL) S X=I 74 I $L($G(X)) D 75 .N IEN,NAME 76 .D IEN^PSN50P65(,X,"ORQQAL") 77 .S IEN=$O(^TMP($J,"ORQQAL","B",X,0)) 78 .I 'IEN S ORAY="2"_U_X Q 79 .S NAME=$G(^TMP($J,"ORQQAL",IEN,1)) 80 .I '$L(NAME) S ORAY="2"_U_X Q 81 .S ORAY="2"_U_NAME_": ("_$G(^TMP("GMRAOC",$J,"APC",X))_")" 82 K ^TMP("GMRAOC",$J) 83 Q 84 DETAIL(ORAY,DFN,ALLR,ID) ; RETURN DETAILED ALLERGY INFO FOR SPECIFIED ALLERGIC REACTION: 85 D EN1^GMRAOR2(ALLR,"GMRACT") 86 N CR,OX,OH S CR=$CHAR(13),I=1 87 S ORAY(I)=" Causative agent: "_$P(GMRACT,U),I=I+1 88 S ORAY(I)=" Nature of Reaction: "_$S($P(GMRACT,U,6)="ALLERGY":"Allergy",$P(GMRACT,U,6)="PHARMACOLOGIC":"Adverse Reaction",$P(GMRACT,U,6)="UNKNOWN":"Unknown",1:""),I=I+1 ;216 89 S ORAY(I)=" ",I=I+1 90 I $D(GMRACT("S",1)) D SYMP 91 I $D(GMRACT("V",1)) D CLAS 92 S ORAY(I)=" Originator: "_$P(GMRACT,U,2)_$S($L($P(GMRACT,U,3)):" ("_$P(GMRACT,U,3)_")",1:""),I=I+1 ;216 93 S ORAY(I)=" Originated: "_$P(GMRACT,U,10),I=I+1 ;216 94 I $D(GMRACT("O",1)) D OBS 95 S ORAY(I)=" Verified: "_$S($P(GMRACT,U,4)="VERIFIED":$P(GMRACT,U,8),1:"No"),I=I+1 ;216 96 S ORAY(I)="Observed/Historical: "_$S($P(GMRACT,U,5)="OBSERVED":"Observed",$P(GMRACT,U,5)="HISTORICAL":"Historical",1:""),I=I+1 97 I $D(GMRACT("C",1)) D COM 98 K GMRACT 99 Q 100 SYMP S K=0,N=0 F S K=$O(GMRACT("S",K)) Q:K'>0 D 101 .I N=0 S ORAY(I)=" Signs/symptoms: "_GMRACT("S",K),I=I+1 102 .E S ORAY(I)=" "_GMRACT("S",K),I=I+1 103 .S N=N+1 104 S ORAY(I)=" ",I=I+1 105 K N,K 106 Q 107 CLAS S K=0,N=0 F S K=$O(GMRACT("V",K)) Q:K'>0 D 108 .I N=0 S ORAY(I)=" Drug Classes: "_$P(GMRACT("V",K),U,2),I=I+1 109 .E S ORAY(I)=" "_$P(GMRACT("V",K),U,2),I=I+1 110 .S N=N+1 111 S ORAY(I)=" ",I=I+1 112 K N,K 113 Q 114 OBS S K=0,N=0 F S K=$O(GMRACT("O",K)) Q:K'>0 D 115 .I N=0 D 116 ..S Y=$P(GMRACT("O",K),U) D DD^%DT 117 ..S ORAY(I)=" Obs dates/severity: "_Y_" "_$P(GMRACT("O",K),U,2),I=I+1 118 .E D 119 ..S Y=$P(GMRACT("O",K),U) D DD^%DT 120 ..S ORAY(I)=" "_Y_" "_$P(GMRACT("O",K),U,2),I=I+1 121 .S N=N+1 122 S ORAY(I)=" ",I=I+1 123 K N,K,Y 124 Q 125 COM S K=0,N=0,ORAY(I)=" ",I=I+1 126 F S K=$O(GMRACT("C",K)) Q:K'>0 D 127 .I N=0 S ORAY(I)="Comments:",I=I+1 128 .S Y=$P(GMRACT("C",K),U) D DD^%DT 129 .S ORAY(I)=" "_Y_" by "_$P(GMRACT("C",K),U,2),I=I+1 130 .I $D(GMRACT("C",K,1,0)) S L=0 F S L=$O(GMRACT("C",K,L)) Q:L'>0 D 131 ..S ORAY(I)=GMRACT("C",K,L,0),I=I+1 132 .S N=N+1 133 S ORAY(I)=" ",I=I+1 134 K N,K,L,Y 135 Q 1 ORQQAL ; slc/CLA,JFR - Functions which return patient allergy data ;6/8/06 14:11 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,85,162,190,216,232**;Dec 17, 1997;Build 19 3 LIST(ORAY,ORPT) ; RETURN PATIENT'S ALLERGY/ADVERSE REACTION INFO: 4 ; null:no allergy assessment, 0:no known allergies, 1:pt has allergies 5 ; if 1 also get: allergen/reactant^reaction/symptom^severity^allergy ien 6 N I,J,K 7 S I=1,J=0,K=0 8 D EN1^GMRAOR1(ORPT,"GMRARXN") 9 I $G(GMRARXN)="" S ORAY(I)="^No Allergy Assessment" 10 I $G(GMRARXN)=0 S ORAY(I)="^No Known Allergies" 11 I $G(GMRARXN)=1 F S J=$O(GMRARXN(J)) Q:J="" S ORAY(I)=$P(GMRARXN(J),"^",3)_"^"_$P(GMRARXN(J),"^")_"^"_$P(GMRARXN(J),"^",2) D SIGNS S I=I+1 12 S:'$D(ORAY(1)) ORAY(1)="^No allergies found." 13 K GMRARXN 14 Q 15 SIGNS S K=0,N=0 F S K=$O(GMRARXN(J,"S",K)) Q:K'>0 D 16 .I N=0 S ORAY(I)=ORAY(I)_"^"_$P(GMRARXN(J,"S",K),";") 17 .E S ORAY(I)=ORAY(I)_";"_$P(GMRARXN(J,"S",K),";") 18 .S N=N+1 19 Q 20 LRPT(ORAY,ORPT) ; RETURN PT'S ALLERGY/ADVERSE REACTION INFO IN REPORT FORMAT: 21 ; null:no allergy assessment, 0:no known allergies, 1:pt has allergies 22 ; if 1 also get: allergen/reactant^reaction/symptom^severity^allergy ien 23 N I,J,K,SEVER,CR,GMRAIDT ;216 24 S CR=$CHAR(13) 25 S I=1,J=0,K=0,SEVER="",GMRAIDT=1 ;216 26 D EN1^GMRAOR1(ORPT,"GMRARXN") 27 I $G(GMRARXN)="" S ORAY(I)="No Allergy Assessment" 28 I $G(GMRARXN)=0 S ORAY(I)="No Known Allergies" 29 I $G(GMRARXN)=1 F S J=$O(GMRARXN(J)) Q:J="" D 30 .S SEVER=$P(GMRARXN(J),U,2) 31 .S ORAY(I)=$P(GMRARXN(J),U)_" "_$S($L($G(SEVER)):"[Severity: "_SEVER_"]",1:""),I=I+1 32 .S K=0,N=0 F S K=$O(GMRARXN(J,"S",K)) Q:K'>0 D 33 ..I N=0 S ORAY(I)=" Signs/symptoms: "_$P(GMRARXN(J,"S",K),";") 34 ..E S ORAY(I)=" "_$P(GMRARXN(J,"S",K),";") 35 ..I $P(GMRARXN(J,"S",K),";",2) S ORAY(I)=ORAY(I)_" ("_$$FMTE^XLFDT($P(GMRARXN(J,"S",K),";",2),2)_")" ;216 36 ..S N=N+1,I=I+1 37 .S ORAY(I)=" ",I=I+1 38 S:'$D(ORAY(1)) ORAY(1)="No allergies found." 39 K GMRARXN 40 Q 41 RXN(ORAY,ORPT,SRC,NDF,PSDRUG) ; RETURN TRUE OR FALSE IF PATIENT IS ALLERGIC TO AGENT 42 ; SRC: ALLERGEN SOURCE (CM=CONTRAST MEDIA, DR=DRUG) 43 ; NDF: IF SRC=DR, NDF=Nat'l Drug File ien ELSE NDF="" 44 ; PSDRUG:IF SRC=DR, PSDRUG=(local) Drug file ien ELSE PSDRUG="" 45 S ORAY=$$ORCHK^GMRAOR(ORPT,SRC,NDF) 46 I SRC="DR",ORAY=1 D ;drug ingredient allergy found 47 .S I=1,J=0 F S J=$O(GMRAING(J)) Q:J="" D 48 ..I I=1 S ORAY=ORAY_U_GMRAING(J) 49 ..E S ORAY=ORAY_";"_GMRAING(J) 50 ..S I=I+1 51 I SRC="DR",ORAY=2 D ;drug class allergy found 52 .S CL="",I=1,J=0 F S J=$O(GMRADRCL(J)) Q:J="" D 53 ..; per test sites 3/17/04 - no oc for pt allergy to entire HERBS class: 54 ..Q:$P(GMRADRCL(J),U)="HA000" 55 ..I I=1 S ORAY=ORAY_U_$P(GMRADRCL(J),U,2) 56 ..E S CL=$P(GMRADRCL(J),U,2) I ORAY'[CL S ORAY=ORAY_";"_CL 57 ..S I=I+1 58 I SRC="DR",(+$G(ORAY)<1) D MEDCLASS(.ORAY,ORPT,PSDRUG) 59 K I,J,GMRADRCL,GMRAING,CL 60 Q 61 MEDCLASS(ORAY,DFN,PSDRUG) ;check for allergens with medications in same VA drug class 62 N ORVACLS,CL,X,I,RET,TYP 63 S TYP="DR" 64 Q:+$G(PSDRUG)<1 65 S ORVACLS=$P(^PSDRUG(PSDRUG,0),U,2) 66 Q:$L(ORVACLS)<4 67 Q:$G(ORVACLS)="HA000" ;don't process herbal drug class for order checks 68 S CL=$S($E(ORVACLS,1,4)="CN10":5,1:4) ;look at 5 chars if ANALGESICS 69 D GETDATA^GMRAOR(DFN) 70 Q:'$D(^TMP("GMRAOC",$J,"APC")) 71 S I="" F S I=$O(^TMP("GMRAOC",$J,"APC",I)) Q:'$L(I) D 72 .I $E(I,1,CL)=$E(ORVACLS,1,CL) S X=I 73 I $L($G(X)) D 74 .N IEN,NAME 75 .D IEN^PSN50P65(,X,"ORQQAL") 76 .S IEN=$O(^TMP($J,"ORQQAL","B",X,0)) 77 .I 'IEN S ORAY="2"_U_X Q 78 .S NAME=$G(^TMP($J,"ORQQAL",IEN,1)) 79 .I '$L(NAME) S ORAY="2"_U_X Q 80 .S ORAY="2"_U_NAME_": ("_$G(^TMP("GMRAOC",$J,"APC",X))_")" 81 K ^TMP("GMRAOC",$J) 82 Q 83 DETAIL(ORAY,DFN,ALLR,ID) ; RETURN DETAILED ALLERGY INFO FOR SPECIFIED ALLERGIC REACTION: 84 D EN1^GMRAOR2(ALLR,"GMRACT") 85 N CR,OX,OH S CR=$CHAR(13),I=1 86 S ORAY(I)=" Causative agent: "_$P(GMRACT,U),I=I+1 87 S ORAY(I)=" Nature of Reaction: "_$S($P(GMRACT,U,6)="ALLERGY":"Allergy",$P(GMRACT,U,6)="PHARMACOLOGIC":"Adverse Reaction",$P(GMRACT,U,6)="UNKNOWN":"Unknown",1:""),I=I+1 ;216 88 S ORAY(I)=" ",I=I+1 89 I $D(GMRACT("S",1)) D SYMP 90 I $D(GMRACT("V",1)) D CLAS 91 S ORAY(I)=" Originator: "_$P(GMRACT,U,2)_$S($L($P(GMRACT,U,3)):" ("_$P(GMRACT,U,3)_")",1:""),I=I+1 ;216 92 S ORAY(I)=" Originated: "_$P(GMRACT,U,10),I=I+1 ;216 93 I $D(GMRACT("O",1)) D OBS 94 S ORAY(I)=" Verified: "_$S($P(GMRACT,U,4)="VERIFIED":$P(GMRACT,U,8),1:"No"),I=I+1 ;216 95 S ORAY(I)="Observed/Historical: "_$S($P(GMRACT,U,5)="OBSERVED":"Observed",$P(GMRACT,U,5)="HISTORICAL":"Historical",1:""),I=I+1 96 I $D(GMRACT("C",1)) D COM 97 K GMRACT 98 Q 99 SYMP S K=0,N=0 F S K=$O(GMRACT("S",K)) Q:K'>0 D 100 .I N=0 S ORAY(I)=" Signs/symptoms: "_GMRACT("S",K),I=I+1 101 .E S ORAY(I)=" "_GMRACT("S",K),I=I+1 102 .S N=N+1 103 S ORAY(I)=" ",I=I+1 104 K N,K 105 Q 106 CLAS S K=0,N=0 F S K=$O(GMRACT("V",K)) Q:K'>0 D 107 .I N=0 S ORAY(I)=" Drug Classes: "_$P(GMRACT("V",K),U,2),I=I+1 108 .E S ORAY(I)=" "_$P(GMRACT("V",K),U,2),I=I+1 109 .S N=N+1 110 S ORAY(I)=" ",I=I+1 111 K N,K 112 Q 113 OBS S K=0,N=0 F S K=$O(GMRACT("O",K)) Q:K'>0 D 114 .I N=0 D 115 ..S Y=$P(GMRACT("O",K),U) D DD^%DT 116 ..S ORAY(I)=" Obs dates/severity: "_Y_" "_$P(GMRACT("O",K),U,2),I=I+1 117 .E D 118 ..S Y=$P(GMRACT("O",K),U) D DD^%DT 119 ..S ORAY(I)=" "_Y_" "_$P(GMRACT("O",K),U,2),I=I+1 120 .S N=N+1 121 S ORAY(I)=" ",I=I+1 122 K N,K,Y 123 Q 124 COM S K=0,N=0,ORAY(I)=" ",I=I+1 125 F S K=$O(GMRACT("C",K)) Q:K'>0 D 126 .I N=0 S ORAY(I)="Comments:",I=I+1 127 .S Y=$P(GMRACT("C",K),U) D DD^%DT 128 .S ORAY(I)=" "_Y_" by "_$P(GMRACT("C",K),U,2),I=I+1 129 .I $D(GMRACT("C",K,1,0)) S L=0 F S L=$O(GMRACT("C",K,L)) Q:L'>0 D 130 ..S ORAY(I)=GMRACT("C",K,L,0),I=I+1 131 .S N=N+1 132 S ORAY(I)=" ",I=I+1 133 K N,K,L,Y 134 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL1.m
r613 r623 1 ORQQPL1 ; ALB/PDR/REV - PROBLEM LIST FOR CPRS GUI ; 02/12/08 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,148,173,203,206,249,243**;Dec 17, 1997;Build 242 3 ; 4 ;------------------------- GET PROBLEM FROM LEXICON ------------------- 5 ; 6 LEXSRCH(LIST,FROM,N,VIEW,ORDATE) ; Get candidate Problems from LEX file 7 N LEX,VAL,VAL1,COD,CIEN,SYS,MAX,NAME 8 S:'+$G(ORDATE) ORDATE=DT 9 S:'$G(N) N=100 10 S:'$L($G(VIEW)) VIEW="PL1" 11 D CONFIG^LEXSET("GMPL",VIEW,ORDATE) 12 D LOOK^LEXA(FROM,"GMPL",N,"",ORDATE) 13 S S=0 14 F S S=$O(LEX("LIST",S)) Q:S<1 D 15 . S VAL1=LEX("LIST",S) 16 . S COD="",CIEN="",SYS="",NAME="" 17 . I $L(VAL1,"CPT-4 ")>1 D 18 .. S SYS="ICD-9-CM " 19 .. S COD="799.9" 20 .. S CIEN="" 21 .. S NAME=$P(VAL1," (CPT-4") 22 . I $L(VAL1,"DSM-IV ")>1 D 23 .. S SYS="DSM-IV " 24 .. S COD=$P($P(VAL1,SYS,2),")") 25 .. S:COD["/" COD=$P(COD,"/",1) 26 .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80) 27 .. S NAME=$P(VAL1," (DSM-IV") 28 .. ; 29 . I $L(VAL1,"(TITLE 38 ")>1 D 30 .. S SYS="TITLE 38 " 31 .. S COD=$P($P(VAL1,SYS,2),")") 32 .. S:COD["/" COD=$P(COD,"/",1) 33 .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80) 34 .. S NAME=$P(VAL1,"(TITLE 38 ") 35 .. ; 36 . I $L(VAL1,"ICD-9-CM ")>1 D 37 .. S SYS="ICD-9-CM " 38 .. S COD=$P($P(VAL1,SYS,2),")") 39 .. S:COD["/" COD=$P(COD,"/",1) 40 .. S CIEN=+$$CODEN^ICDCODE(COD,80) 41 .. S NAME=$P(VAL1," (ICD-9-CM") 42 . I $L(NAME)=0 S NAME=$P($P(VAL1," (")," *") 43 . ; 44 . ; jeh Clean left over codes 45 . S NAME=$P(NAME," (CPT-4") 46 . S NAME=$P(NAME," (DSM-IV") 47 . S NAME=$P(NAME,"(TITLE 38 ") 48 . S NAME=$P(NAME," (ICD-9-CM") 49 . ; 50 . S VAL=NAME_U_COD_U_CIEN_U_SYS ; ien^.01^icd^icdifn^system 51 . S LIST(S)=VAL 52 . S MAX=S 53 I $G(MAX)'="" S LIST(MAX+1)=$G(LEX("MAT")) 54 K ^TMP("LEXSCH",$J) 55 Q 56 ; 57 ICDREC(COD) ; 58 N CODIEN 59 I COD="" Q "" 60 S COD=$P($P(COD,U),"/") 61 S CODIEN=+$O(^ICD9("AB",COD_" ",0)) 62 S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",COD_"0 ",0)) 63 Q CODIEN 64 ;Q $O(^ICD9("BA",COD,"")) 65 ; 66 CPTREC(COD) ; 67 I COD="" Q "" 68 Q $O(^ICPT("BA",COD,"")) 69 ; 70 EDLOAD(RETURN,DA,GMPROV,GMPVAMC) ; LOAD EDIT ARRAYS 71 ; DA=problem IFN 72 N I,GMPFLD,GMPORIG,GMPL 73 D GETFLDS^GMPLEDT3(DA) 74 S I=0 75 D LOADFLDS(.RETURN,"GMPFLD","NEW",.I) 76 D LOADFLDS(.RETURN,"GMPORIG","ORG",.I) 77 K GMPFLD,GMPORIG,GMPL ; should not have to do this 78 Q 79 ; 80 LOADFLDS(RETURN,NAM,TYP,I) ; LOAD FIELDS FOR TYPE OF ARRAY 81 N S,V,CVP,PN,PID 82 S S="",V=$C(254) 83 F S S=$O(@NAM@(S)) Q:S=10 D 84 . S RETURN(I)=TYP_V_S_V_@NAM@(S) 85 . S I=I+1 86 S S="" 87 F S S=$O(@NAM@(10,S)) Q:S="" D 88 . S CVP=@NAM@(10,S) 89 . S PN="" ; provider name 90 . S PID=$P(CVP,U,6) ; provider id 91 . I PID'="" S PN=$$GET1^DIQ(200,PID,.01) ; get provider name 92 . S RETURN(I)=TYP_V_"10,"_S_V_CVP_U_PN 93 . S I=I+1 94 Q 95 ; 96 EDSAVE(RETURN,GMPIFN,GMPROV,GMPVAMC,UT,EDARRAY) ; SAVE EDITED RES 97 ; RETURN - boolean, 1 success, 0 failure 98 ; EDARRAY - array used for indirect sets of GMPORIG() and GMPFLDS() 99 ; 100 N GMPFLD,GMPORIG,S,GMPLUSER 101 S RETURN=1 ; initialize for success 102 I UT S GMPLUSER=1 103 ; 104 ;S GMPLUSER=1 105 S S="" 106 F S S=$O(EDARRAY(S)) Q:S="" D 107 . S @EDARRAY(S) 108 I $D(GMPFLD(10,"NEW"))>9 D I 'RETURN Q ; Bail Out if no lock 109 . L +^AUPNPROB(GMPIFN,11):10 ; given bogus nature of this lock, should be able to get 110 . I '$T S RETURN=0 111 ; 112 D EN^GMPLSAVE ; save the data 113 K GMPFLD,GMPORIG 114 ; 115 L -^AUPNPROB(GMPIFN,11) ; free this instance of lock (in case it was set) 116 S RETURN=1 117 Q 118 ; 119 UPDATE(ORRETURN,UPDARRAY) ; UPDATE A PROBLEM RECORD 120 ; Does essentially same job as EDSAVE above, however does not handle edits to comments 121 ; or addition of multiple comments. 122 ; Use initially just for status updates. 123 ; 124 N S,GMPL,GMPORIG ; last 2 vars created in nested call 125 S S="" 126 F S S=$O(UPDARRAY(S)) Q:S="" D 127 . S @UPDARRAY(S) 128 D UPDATE^GMPLUTL(.ORARRAY,.ORRETURN) 129 K ORARRAY 130 ; broker wont pick up root node RETURN 131 S ORRETURN(1)=ORRETURN(0) ; error text 132 S ORRETURN(0)=ORRETURN ; gmpdfn 133 I ORRETURN(0)="" S ORRETURN=1 ; insurance ? need 134 Q 135 ; 136 ADDSAVE(RETURN,GMPDFN,GMPROV,GMPVAMC,ADDARRAY) ; SAVE NEW RECORD 137 ; RETURN - Problem IFN if success, 0 otherwise 138 ; ADDARRAY - array used for indirect sets of GMPFLDS() 139 ; 140 N DA,GMPFLD,GMPORIG,S 141 S RETURN=0 ; 142 L +^AUPNPROB(0):10 143 Q:'$T ; bail out if no lock 144 ; 145 S S="" 146 F S S=$O(ADDARRAY(S)) Q:S="" D 147 . S @ADDARRAY(S) 148 ; 149 D NEW^GMPLSAVE 150 ; 151 S RETURN=DA 152 ; 153 L -^AUPNPROB(0) 154 S RETURN=1 155 Q 156 ; 157 INITUSER(RETURN,ORDUZ) ; INITIALIZE FOR NEW USER 158 ; taken from INIT^GMPLMGR 159 ; leave GMPLUSER on symbol table - is evaluated in EDITSAVE 160 ; 161 N X,PV,CTXT,GMPLPROV 162 S GMPLUSER=$$CLINUSER(DUZ) 163 S CTXT=$$GET^XPAR("ALL","ORCH CONTEXT PROBLEMS",1) 164 S X=$G(^GMPL(125.99,1,0)) ; IN1+6^GMPLMGR 165 S RETURN(0)=GMPLUSER ; problem list user, or other user 166 S RETURN(1)=$$VIEW^GMPLX1(DUZ) ; GMPLVIEW("VIEW") - users default view 167 S RETURN(2)=+$P(X,U,2) ; verify transcribed problems 168 S RETURN(3)=+$P(X,U,3) ; prompt for chart copy 169 S RETURN(4)=+$P(X,U,4) ; use lexicon 170 S RETURN(5)=$S($P(X,U,5)="R":1,1:0) ; chron or reverse chron listing 171 S RETURN(6)=$S($P($G(CTXT),";",3)'="":$P($G(CTXT),";",3),1:"A") 172 S GMPLPROV=$P($G(CTXT),";",5) 173 I +GMPLPROV>0,$D(^VA(200,GMPLPROV)) D 174 . S RETURN(7)=GMPLPROV_U_$P(^VA(200,GMPLPROV,0),U) 175 E S RETURN(7)="0^All" 176 S RETURN(8)=$$SERVICE^GMPLX1(DUZ) ; user's service/section 177 ; Guessing from what I see in the data that $$VIEW^GMPLX1 actually returns a composite 178 ; of default view (in/out patient)/(c1/c2... if out patient i.e. GMPLVIEW("CLIN")) or 179 ; /(s1/s2... if in patient i.e. GMPLVIEW("SERV")) 180 ; Going with this assumption for now: 181 I $L(RETURN(1),"/")>1 D 182 . S PV=RETURN(1) 183 . S RETURN(1)=$P(PV,"/") 184 . I RETURN(1)="C" S GMPLVIEW("CLIN")=$P(PV,"/",2,99) 185 . I RETURN(1)="S" S GMPLVIEW("SERV")=$P(PV,"/",2,99) 186 S RETURN(9)=$G(GMPLVIEW("SERV")) ; ??? Where from - see tech doc 187 S RETURN(10)=$G(GMPLVIEW("CLIN")) ; ??? Where from - see tech doc 188 S RETURN(11)="" 189 S RETURN(12)=+$P($G(CTXT),";",4) ; should comments display? 190 K GMPLVIEW 191 Q 192 ; 193 CLINUSER(ORDUZ) ;is this a clinical user? 194 N ORUSER 195 S ORUSER=0 196 I $D(^XUSEC("ORES",ORDUZ)) S ORUSER=1 197 I $D(^XUSEC("ORELSE",ORDUZ)) S ORUSER=1 198 I $D(^XUSEC("PROVIDER",ORDUZ)) S ORUSER=1 199 Q ORUSER 200 ; 201 INITPT(RETURN,DFN) ; GET PATIENT PARAMETERS 202 Q:+$G(DFN)=0 203 N GMPSC,GMPAGTOR,GMPION,GMPGULF,GMPHNC,GMPMST,GMPCV,GMPSHD 204 ; 205 S RETURN(0)=DUZ(2) ; facility # 206 D DEM^VADPT ; get death indicator 207 S RETURN(1)=$G(VADM(6)) ; death indicator 208 D VADPT^GMPLX1(DFN) ; get eligibilities 209 S RETURN(2)=$P(GMPSC,U) ; service connected 210 S RETURN(3)=$G(GMPAGTOR) ; agent orange exposure 211 S RETURN(4)=$G(GMPION) ; ionizing radiation exposure 212 S RETURN(5)=$G(GMPGULF) ; gulf war exposure 213 S RETURN(6)=VA("BID") ; need this to reconstitute GMPDFN on return 214 S RETURN(7)=$G(GMPHNC) ; head/neck cancer 215 S RETURN(8)=$G(GMPMST) ; MST 216 S RETURN(9)=$G(GMPCV) ; CV 217 S RETURN(10)=$G(GMPSHD) ; SHAD 218 Q 219 ; 220 PROVSRCH(LST,FLAG,N,FROM,PART) ; Get candidate Rroviders from person file 221 N LV,NS,RV,IEN 222 S RV=$NAME(LV("DILIST","ID")) 223 IF +$G(N)=0 S N=50 224 S FLAG=$G(FLAG),N=$G(N),FROM=$G(FROM),PART=$G(PART) 225 D LIST^DIC(200,"",".01;1",FLAG,N,FROM,PART,"","","","LV") 226 S NS="" 227 F S NS=$O(LV("DILIST",1,NS)) Q:NS="" D 228 . S IEN="" 229 . S IEN=$O(^VA(200,"B",@RV@(NS,.01),IEN)) ; compliments of PROV^ORQPTQ 230 . S LST(NS)=IEN_U_@RV@(NS,.01) ; initials_U_@RV@(NS,1) 231 Q 232 ; 233 CLINSRCH(Y,X) ; Get LIST OF CLINICS 234 ; Note: This comes from CLIN^ORQPTQ2, where it was commented out in place of 235 ; a call to ^XPAR. I would have just used CLIN^ORQPTQ2, but it didn't work - at 236 ; least on SLC OEX directory. 237 ; X has no purpose other than to satisfy apparent rpc and tcallv requirement for args 238 N I,NAME,IEN 239 S I=1,IEN=0,NAME="" 240 ;access to SC global granted under DBIA #518: 241 F S NAME=$O(^SC("B",NAME)) Q:NAME="" S IEN=$O(^(NAME,0)) D 242 . I $P(^SC(IEN,0),"^",3)="C" S Y(I)=IEN_"^"_NAME,I=I+1 243 Q 244 ; 245 SRVCSRCH(Y,FROM,DIR,ALL) ; GET LIST OF SERVICES 246 N I,IEN,CNT S I=0,CNT=44 247 F Q:I=CNT S FROM=$O(^DIC(49,"B",FROM),DIR) Q:FROM="" D 248 . S IEN=$O(^DIC(49,"B",FROM,0)) I '$G(ALL),$P(^DIC(49,IEN,0),U,9)'="C" Q 249 . S I=I+1,Y(I)=IEN_"^"_FROM 250 Q 251 ; 252 DUP(Y,DFN,TERM,TEXT) ;Check for duplicate problem 253 S Y=$$DUPL^GMPLX(DFN,TERM,TEXT) Q:+Y=0 254 I $P(^AUPNPROB(Y,1),U,2)="H" S Y=0 Q 255 S Y=Y_U_$P(^AUPNPROB(Y,0),U,12) 256 Q 1 ORQQPL1 ; ALB/PDR/REV - PROBLEM LIST FOR CPRS GUI ;03/12/02 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,148,173,203,206,249**;Dec 17, 1997 3 ; 4 ;------------------------- GET PROBLEM FROM LEXICON ------------------- 5 ; 6 LEXSRCH(LIST,FROM,N,VIEW,ORDATE) ; Get candidate Problems from LEX file 7 N LEX,VAL,VAL1,COD,CIEN,SYS,MAX,NAME 8 S:'+$G(ORDATE) ORDATE=DT 9 S:'$G(N) N=100 10 S:'$L($G(VIEW)) VIEW="PL1" 11 D CONFIG^LEXSET("GMPL",VIEW,ORDATE) 12 D LOOK^LEXA(FROM,"GMPL",N,"",ORDATE) 13 S S=0 14 F S S=$O(LEX("LIST",S)) Q:S<1 D 15 . S VAL1=LEX("LIST",S) 16 . S COD="",CIEN="",SYS="",NAME="" 17 . I $L(VAL1,"CPT-4 ")>1 D 18 .. ;S SYS="CPT-4 " 19 .. ;S COD=$P($P(VAL1,SYS,2),")") 20 .. ;S:COD["/" COD=$P(COD,"/",1) 21 .. ;. S CIEN=$$CODEN^ICPTCOD(COD) 22 .. S SYS="ICD-9-CM " 23 .. S COD="799.9" 24 .. S CIEN="" 25 .. S NAME=$P(VAL1," (CPT-4") 26 . I $L(VAL1,"DSM-IV ")>1 D 27 .. S SYS="DSM-IV " 28 .. S COD=$P($P(VAL1,SYS,2),")") 29 .. S:COD["/" COD=$P(COD,"/",1) 30 .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80) 31 .. S NAME=$P(VAL1," (DSM-IV") 32 .. ; 33 . I $L(VAL1,"(TITLE 38 ")>1 D 34 .. S SYS="TITLE 38 " 35 .. S COD=$P($P(VAL1,SYS,2),")") 36 .. S:COD["/" COD=$P(COD,"/",1) 37 .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80) 38 .. S NAME=$P(VAL1,"(TITLE 38 ") 39 .. ; 40 . I $L(VAL1,"ICD-9-CM ")>1 D 41 .. S SYS="ICD-9-CM " 42 .. S COD=$P($P(VAL1,SYS,2),")") 43 .. S:COD["/" COD=$P(COD,"/",1) 44 .. S CIEN=+$$CODEN^ICDCODE(COD,80) 45 .. S NAME=$P(VAL1," (ICD-9-CM") 46 . I $L(NAME)=0 S NAME=$P($P(VAL1," (")," *") 47 . ; 48 . ; jeh Clean left over codes 49 . S NAME=$P(NAME," (CPT-4") 50 . S NAME=$P(NAME," (DSM-IV") 51 . S NAME=$P(NAME,"(TITLE 38 ") 52 . S NAME=$P(NAME," (ICD-9-CM") 53 . ; 54 . S VAL=NAME_U_COD_U_CIEN_U_SYS ; ien^.01^icd^icdifn^system 55 . S LIST(S)=VAL 56 . S MAX=S 57 I $G(MAX)'="" S LIST(MAX+1)=$G(LEX("MAT")) 58 Q 59 ; 60 ICDREC(COD) ; 61 N CODIEN 62 I COD="" Q "" 63 S COD=$P($P(COD,U),"/") 64 S CODIEN=+$O(^ICD9("AB",COD_" ",0)) 65 S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",COD_"0 ",0)) 66 Q CODIEN 67 ;Q $O(^ICD9("BA",COD,"")) 68 ; 69 CPTREC(COD) ; 70 I COD="" Q "" 71 Q $O(^ICPT("BA",COD,"")) 72 ; 73 EDLOAD(RETURN,DA,GMPROV,GMPVAMC) ; LOAD EDIT ARRAYS 74 ; DA=problem IFN 75 N I,GMPFLD,GMPORIG,GMPL 76 D GETFLDS^GMPLEDT3(DA) 77 S I=0 78 D LOADFLDS(.RETURN,"GMPFLD","NEW",.I) 79 D LOADFLDS(.RETURN,"GMPORIG","ORG",.I) 80 K GMPFLD,GMPORIG,GMPL ; should not have to do this 81 Q 82 ; 83 LOADFLDS(RETURN,NAM,TYP,I) ; LOAD FIELDS FOR TYPE OF ARRAY 84 N S,V,CVP,PN,PID 85 S S="",V=$C(254) 86 F S S=$O(@NAM@(S)) Q:S=10 D 87 . S RETURN(I)=TYP_V_S_V_@NAM@(S) 88 . S I=I+1 89 S S="" 90 F S S=$O(@NAM@(10,S)) Q:S="" D 91 . S CVP=@NAM@(10,S) 92 . S PN="" ; provider name 93 . S PID=$P(CVP,U,6) ; provider id 94 . I PID'="" S PN=$$GET1^DIQ(200,PID,.01) ; get provider name 95 . S RETURN(I)=TYP_V_"10,"_S_V_CVP_U_PN 96 . S I=I+1 97 Q 98 ; 99 EDSAVE(RETURN,GMPIFN,GMPROV,GMPVAMC,UT,EDARRAY) ; SAVE EDITED RES 100 ; RETURN - boolean, 1 success, 0 failure 101 ; EDARRAY - array used for indirect sets of GMPORIG() and GMPFLDS() 102 ; 103 N GMPFLD,GMPORIG,S,GMPLUSER 104 S RETURN=1 ; initialize for success 105 I UT S GMPLUSER=1 106 ; 107 ;S GMPLUSER=1 108 S S="" 109 F S S=$O(EDARRAY(S)) Q:S="" D 110 . S @EDARRAY(S) 111 I $D(GMPFLD(10,"NEW"))>9 D I 'RETURN Q ; Bail Out if no lock 112 . L +^AUPNPROB(GMPIFN,11):10 ; given bogus nature of this lock, should be able to get 113 . I '$T S RETURN=0 114 ; 115 D EN^GMPLSAVE ; save the data 116 K GMPFLD,GMPORIG 117 ; 118 L -^AUPNPROB(GMPIFN,11) ; free this instance of lock (in case it was set) 119 S RETURN=1 120 Q 121 ; 122 UPDATE(ORRETURN,UPDARRAY) ; UPDATE A PROBLEM RECORD 123 ; Does essentially same job as EDSAVE above, however does not handle edits to comments 124 ; or addition of multiple comments. 125 ; Use initially just for status updates. 126 ; 127 N S,GMPL,GMPORIG ; last 2 vars created in nested call 128 S S="" 129 F S S=$O(UPDARRAY(S)) Q:S="" D 130 . S @UPDARRAY(S) 131 D UPDATE^GMPLUTL(.ORARRAY,.ORRETURN) 132 K ORARRAY 133 ; broker wont pick up root node RETURN 134 S ORRETURN(1)=ORRETURN(0) ; error text 135 S ORRETURN(0)=ORRETURN ; gmpdfn 136 I ORRETURN(0)="" S ORRETURN=1 ; insurance ? need 137 Q 138 ; 139 ADDSAVE(RETURN,GMPDFN,GMPROV,GMPVAMC,ADDARRAY) ; SAVE NEW RECORD 140 ; RETURN - Problem IFN if success, 0 otherwise 141 ; ADDARRAY - array used for indirect sets of GMPFLDS() 142 ; 143 N DA,GMPFLD,GMPORIG,S 144 S RETURN=0 ; 145 L +^AUPNPROB(0):10 146 Q:'$T ; bail out if no lock 147 ; 148 S S="" 149 F S S=$O(ADDARRAY(S)) Q:S="" D 150 . S @ADDARRAY(S) 151 ; 152 D NEW^GMPLSAVE 153 ; 154 S RETURN=DA 155 ; 156 L -^AUPNPROB(0) 157 S RETURN=1 158 Q 159 ; 160 INITUSER(RETURN,ORDUZ) ; INITIALIZE FOR NEW USER 161 ; taken from INIT^GMPLMGR 162 ; leave GMPLUSER on symbol table - is evaluated in EDITSAVE 163 ; 164 N X,PV,CTXT,GMPLPROV 165 S GMPLUSER=$$CLINUSER(DUZ) 166 S CTXT=$$GET^XPAR("ALL","ORCH CONTEXT PROBLEMS",1) 167 S X=$G(^GMPL(125.99,1,0)) ; IN1+6^GMPLMGR 168 S RETURN(0)=GMPLUSER ; problem list user, or other user 169 S RETURN(1)=$$VIEW^GMPLX1(DUZ) ; GMPLVIEW("VIEW") - users default view 170 S RETURN(2)=+$P(X,U,2) ; verify transcribed problems 171 S RETURN(3)=+$P(X,U,3) ; prompt for chart copy 172 S RETURN(4)=+$P(X,U,4) ; use lexicon 173 S RETURN(5)=$S($P(X,U,5)="R":1,1:0) ; chron or reverse chron listing 174 S RETURN(6)=$S($P($G(CTXT),";",3)'="":$P($G(CTXT),";",3),1:"A") 175 S GMPLPROV=$P($G(CTXT),";",5) 176 I +GMPLPROV>0,$D(^VA(200,GMPLPROV)) D 177 . S RETURN(7)=GMPLPROV_U_$P(^VA(200,GMPLPROV,0),U) 178 E S RETURN(7)="0^All" 179 S RETURN(8)=$$SERVICE^GMPLX1(DUZ) ; user's service/section 180 ; Guessing from what I see in the data that $$VIEW^GMPLX1 actually returns a composite 181 ; of default view (in/out patient)/(c1/c2... if out patient i.e. GMPLVIEW("CLIN")) or 182 ; /(s1/s2... if in patient i.e. GMPLVIEW("SERV")) 183 ; Going with this assumption for now: 184 I $L(RETURN(1),"/")>1 D 185 . S PV=RETURN(1) 186 . S RETURN(1)=$P(PV,"/") 187 . I RETURN(1)="C" S GMPLVIEW("CLIN")=$P(PV,"/",2,99) 188 . I RETURN(1)="S" S GMPLVIEW("SERV")=$P(PV,"/",2,99) 189 S RETURN(9)=$G(GMPLVIEW("SERV")) ; ??? Where from - see tech doc 190 S RETURN(10)=$G(GMPLVIEW("CLIN")) ; ??? Where from - see tech doc 191 S RETURN(11)="" 192 S RETURN(12)=+$P($G(CTXT),";",4) ; should comments display? 193 K GMPLVIEW 194 Q 195 ; 196 CLINUSER(ORDUZ) ;is this a clinical user? 197 N ORUSER 198 S ORUSER=0 199 I $D(^XUSEC("ORES",ORDUZ)) S ORUSER=1 200 I $D(^XUSEC("ORELSE",ORDUZ)) S ORUSER=1 201 I $D(^XUSEC("PROVIDER",ORDUZ)) S ORUSER=1 202 Q ORUSER 203 ; 204 INITPT(RETURN,DFN) ; GET PATIENT PARAMETERS 205 Q:+$G(DFN)=0 206 N GMPSC,GMPAGTOR,GMPION,GMPGULF,GMPHNC,GMPMST 207 ; 208 S RETURN(0)=DUZ(2) ; facility # 209 D DEM^VADPT ; get death indicator 210 S RETURN(1)=$G(VADM(6)) ; death indicator 211 D VADPT^GMPLX1(DFN) ; get eligibilities 212 S RETURN(2)=$P(GMPSC,U) ; service connected 213 S RETURN(3)=$G(GMPAGTOR) ; agent orange exposure 214 S RETURN(4)=$G(GMPION) ; ionizing radiation exposure 215 S RETURN(5)=$G(GMPGULF) ; gulf war exposure 216 S RETURN(6)=VA("BID") ; need this to reconstitute GMPDFN on return 217 S RETURN(7)=$G(GMPHNC) ; head/neck cancer 218 S RETURN(8)=$G(GMPMST) ; MST 219 Q 220 ; 221 PROVSRCH(LST,FLAG,N,FROM,PART) ; Get candidate Rroviders from person file 222 N LV,NS,RV,IEN 223 S RV=$NAME(LV("DILIST","ID")) 224 IF +$G(N)=0 S N=50 225 S FLAG=$G(FLAG),N=$G(N),FROM=$G(FROM),PART=$G(PART) 226 D LIST^DIC(200,"",".01;1",FLAG,N,FROM,PART,"","","","LV") 227 S NS="" 228 F S NS=$O(LV("DILIST",1,NS)) Q:NS="" D 229 . S IEN="" 230 . S IEN=$O(^VA(200,"B",@RV@(NS,.01),IEN)) ; compliments of PROV^ORQPTQ 231 . S LST(NS)=IEN_U_@RV@(NS,.01) ; initials_U_@RV@(NS,1) 232 Q 233 ; 234 CLINSRCH(Y,X) ; Get LIST OF CLINICS 235 ; Note: This comes from CLIN^ORQPTQ2, where it was commented out in place of 236 ; a call to ^XPAR. I would have just used CLIN^ORQPTQ2, but it didn't work - at 237 ; least on SLC OEX directory. 238 ; X has no purpose other than to satisfy apparent rpc and tcallv requirement for args 239 N I,NAME,IEN 240 S I=1,IEN=0,NAME="" 241 ;access to SC global granted under DBIA #518: 242 F S NAME=$O(^SC("B",NAME)) Q:NAME="" S IEN=$O(^(NAME,0)) D 243 . I $P(^SC(IEN,0),"^",3)="C" S Y(I)=IEN_"^"_NAME,I=I+1 244 Q 245 ; 246 SRVCSRCH(Y,FROM,DIR,ALL) ; GET LIST OF SERVICES 247 N I,IEN,CNT S I=0,CNT=44 248 F Q:I=CNT S FROM=$O(^DIC(49,"B",FROM),DIR) Q:FROM="" D 249 . S IEN=$O(^DIC(49,"B",FROM,0)) I '$G(ALL),$P(^DIC(49,IEN,0),U,9)'="C" Q 250 . S I=I+1,Y(I)=IEN_"^"_FROM 251 Q 252 ; 253 DUP(Y,DFN,TERM,TEXT) ;Check for duplicate problem 254 S Y=$$DUPL^GMPLX(DFN,TERM,TEXT) Q:+Y=0 255 I $P(^AUPNPROB(Y,1),U,2)="H" S Y=0 Q 256 S Y=Y_U_$P(^AUPNPROB(Y,0),U,12) 257 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL3.m
r613 r623 1 ORQQPL3 ; ALB/PDR/REV ; Problem List RPC's ; 8-OCT-1998 09:08:49.29 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173,243**;Dec 17, 1997;Build 242 3 ; 4 ;---------------- LIST PATIENT PROBLEMS ------------------------ 5 ; 6 PROBL(ROOT,DFN,CONTEXT) ; GET LIST OF PATIENT PROBLEMS 7 N DIWL,DIWR,DIWF 8 N ST,ORI,ORX 9 S (LCNT,NUM)=0 10 S DIWL=1,DIWR=48,DIWF="C48" 11 S CONTEXT=";;"_$G(CONTEXT) 12 I CONTEXT=";;" S CONTEXT=";;A" 13 S ST=$P(CONTEXT,";",3) 14 ; 15 I ST="R" D DELLIST(.ROOT,+DFN) ; show deleted only 16 I ST'="R" D LIST(.ROOT,+DFN,ST) ; show others - don't trust ELSE here 17 ; 18 I ROOT(0)<1 D 19 . S LCNT=1 20 . S ROOT(1)=" "_$$PAD^ORCHTAB("No data available.",49)_"|" 21 Q 22 ; 23 ; 24 LIST(GMPL,GMPDFN,GMPSTAT) ; -- Returns list of problems for patient GMPDFN 25 ; in GMPL(#)=ifn^status^description^ICD^onset^last modified^SC^SpExp^Condition^Loc^ 26 ; loc.type^prov^service 27 ; & GMPL(0)=number of problems returned 28 ; This is virtually same as LIST^GMPLUTL2 except that it appends the 29 ; condition - T)ranscribed or P)ermanent,location,loc type,provider, service. 30 ; 31 N I,IFN,CNT,GMPL0,GMPL1,SP,ST,NUM,ONSET,ICD,LASTMOD,PRIO,DTREC 32 N SC,ORLIST,ORVIEW,GMPARAM,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT 33 N SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,ORICD186,INACT 34 Q:$G(GMPDFN)'>0 35 S CNT=0,SP="" 36 S GMPARAM("QUIET")=1 37 S GMPARAM("REV")=$P($G(^GMPL(125.99,1,0)),U,5)="R" 38 S ORVIEW("ACT")=GMPSTAT 39 S ORVIEW("PROV")=0 40 S ORVIEW("VIEW")="" 41 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") 42 ; 43 D GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW) 44 ; 45 F NUM=0:0 S NUM=$O(ORLIST(NUM)) Q:NUM'>0 D 46 . S IFN=+ORLIST(NUM) Q:IFN'>0 47 . S INACT="" 48 . S GMPL0=$G(^AUPNPROB(IFN,0)) 49 . S GMPL1=$G(^AUPNPROB(IFN,1)) 50 . S HASCMT=($D(^AUPNPROB(IFN,11,0))>0) 51 . S CNT=CNT+1 52 . I +ORICD186 D 53 . . S ICD=$$CODEC^ICDCODE(+GMPL0) 54 . . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#" 55 . E D 56 . . S ICD=$P($G(^ICD9(+GMPL0,0)),U) 57 . S LASTMOD=$P(GMPL0,U,3) 58 . S ST=$P(GMPL0,U,12) 59 . S ONSET=$P(GMPL0,U,13) 60 . S SC=$S(+$P(GMPL1,U,10):"SC",$P(GMPL1,U,10)=0:"NSC",1:"") 61 . S AO=$S(+$P(GMPL1,U,11):"/AO",1:"") 62 . S IR=$S(+$P(GMPL1,U,12):"/IR",1:"") 63 . S ENV=$S(+$P(GMPL1,U,13):"/EC",1:"") 64 . S HNC=$S(+$P(GMPL1,U,15):"/HNC",1:"") 65 . S MST=$S(+$P(GMPL1,U,16):"/MST",1:"") 66 . S CV=$S(+$P(GMPL1,U,17):"/CV",1:"") 67 . S SHD=$S(+$P(GMPL1,U,18):"/SHD",1:"") 68 . S SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD 69 . S LOC=$P(GMPL1,U,8) 70 . S DTREC=$P(GMPL1,U,9) 71 . S LT="" 72 . I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3),LOC=LOC_";"_$P($G(^SC(LOC,0)),U,1) 73 . S PROV=$P(GMPL1,U,5) ; responsible provider 74 . I PROV'="" S PROV=PROV_";"_$P($G(^VA(200,PROV,0)),U,1) 75 . S SERV=$P(GMPL1,U,6) 76 . I SERV=0 S SERV="" ; not sure how it gets set to 0, but need consistency in GUI 77 . I SERV'="" S SERV=SERV_";"_$P($G(^DIC(49,SERV,0)),U,1) 78 . S SP="" 79 . F I=11,12,13 S:$P(GMPL1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P") 80 . S PRIO=$P(GMPL1,U,14) 81 . S LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET 82 . S LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$P(GMPL1,U,2) 83 . S LIN=LIN_U_LOC_U_LT_U_PROV_U_SERV_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT 84 . S GMPL(CNT)=LIN 85 S GMPL(0)=CNT 86 Q 87 ; 88 ; 89 ;------------------------------------- GET LIST OF DELETED PROBLEMS ----------------------------- 90 ; 91 DELLIST(RETURN,GMPDFN) ; GET LIST OF DELETED PROBLEMS 92 ; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2 93 N S,IFN,I,L0,L1,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC 94 N SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,ORICD186,INACT 95 S I=0,S="" 96 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") 97 F S S=$O(^AUPNPROB("ACTIVE",GMPDFN,S)) Q:S="" D 98 . S IFN="" 99 . F S IFN=$O(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN)) Q:IFN="" D 100 .. I $P($G(^AUPNPROB(IFN,1)),U,2)="H" D 101 ... S L0=$G(^AUPNPROB(IFN,0)) 102 ... Q:L0="" 103 ... S INACT="" 104 ... S L1=$G(^AUPNPROB(IFN,1)) 105 ... S ST=$P(L0,U,12) 106 ... S TXT=$$PROBTEXT^GMPLX(IFN) 107 ... I +ORICD186 D 108 ... . S ICD=$$CODEC^ICDCODE(+L0) 109 ... . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#" 110 ... E D 111 ... . S ICD=$P($G(^ICD9(+L0,0)),U) 112 ... S ONSET=$P(L0,U,13) 113 ... S MOD=$P(L0,U,3) 114 ... S SC=$S(+$P(L1,U,10):"SC",$P(L1,U,10)=0:"NSC",1:"") 115 ... S AO=$S(+$P(L1,U,11):"/AO",1:"") 116 ... S IR=$S(+$P(L1,U,12):"/IR",1:"") 117 ... S ENV=$S(+$P(L1,U,13):"/EC",1:"") 118 ... S HNC=$S(+$P(L1,U,15):"/HNC",1:"") 119 ... S MST=$S(+$P(L1,U,16):"/MST",1:"") 120 ... S CV=$S(+$P(L1,U,17):"/CV",1:"") 121 ... S SHD=$S(+$P(L1,U,18):"/SHD",1:"") 122 ... S SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD 123 ... S SP=$$GETSP 124 ... S LOC=$P(L1,U,8) 125 ... S LT="" 126 ... I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3) 127 ... S PROV=$P(L1,U,5) ; responsible provider 128 ... S SERV=$P(L1,U,6) 129 ... S PRIO=$P(L1,U,14) 130 ... S HASCMT=($D(^AUPNPROB(IFN,11,0))>0) 131 ... S DTREC=$P(L1,U,9) 132 ... S I=I+1 133 ... S RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET 134 ... S RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$P(L1,U,2) 135 ... S RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV 136 ... S RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT 137 S RETURN(0)=I 138 Q 139 ; 140 GETSP() ; GET EXPOSURES 141 N I 142 S SP="" 143 F I=11,12,13 S:$P(L1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P") 144 Q SP 145 ; 146 ; adapted from ^GMPLBLD3 ;9/96 147 ; 148 ; ----------------------- GET USER PROBLEM CATEGORIES -------------- 149 ; 150 CAT(TMP,ORDUZ,CLIN) ; Get user category list 151 N GSEQ,GCNT,GROUP,HDR,IFN,LCNT,ITEM,TG,GMPLSLST 152 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing 153 S TG=$NAME(TMP) ; put list in local 154 K @TG 155 S (GSEQ,GCNT,LCNT)=0 156 ; 157 S GMPLSLST=$$GETUSLST(DUZ,CLIN) ; get approp list for user 158 ; Build multiple of category\problems 159 ; Iterate categories 160 F S GSEQ=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ)) Q:GSEQ'>0 D 161 . S IFN=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0)) Q:IFN'>0 162 . S ITEM=$G(^GMPL(125.1,IFN,0)) 163 . S GROUP=+$P(ITEM,U,3) 164 . S HDR=GROUP_U_$P(ITEM,U,4,5) 165 . S GCNT=GCNT+1 166 . S @TG@(GCNT)=HDR ; put category into temp global 167 Q 168 ; 169 GETUSLST(ORDUZ,CLIN) ; GET AN APPROPRIATE CATEGORY LIST FOR THE USER 170 N GMPLSLST 171 S GMPLSLST=$P($G(^VA(200,DUZ,125)),U,2) 172 ;I 'GMPLSLST D 173 I 'GMPLSLST,CLIN,$D(^GMPL(125,"C",+CLIN)) S GMPLSLST=$O(^(+CLIN,0)) 174 ;. S GMPLSLST=$O(^VA(200,DUZ,+CLIN,0)) ;$O(^(+CLIN,0)) 175 Q GMPLSLST 176 ; 177 ;----------------------- USER PROBLEM LIST -------------------------- 178 ; 179 PROB(TMP,GROUP) ; Get user problem list for given group 180 N PSEQ,PCNT,IFN,ITEM,TG,CODE,TEXT,ORICD186 181 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing 182 S TG=$NAME(TMP) ; put list in local 183 K @TG 184 S LCNT=0 185 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") 186 ; 187 ; iterate through problems in category 188 S (PSEQ,PCNT)=0 189 F S PSEQ=$O(^GMPL(125.12,"C",GROUP,PSEQ)) Q:PSEQ'>0 D 190 . S IFN=$O(^GMPL(125.12,"C",GROUP,PSEQ,0)) Q:IFN'>0 191 . S ITEM=$G(^GMPL(125.12,IFN,0)) 192 . S TEXT=$P(ITEM,U,4) 193 . ; SEE DD for GMPL(125.12,4 : 194 . ; "...code which is to be displayed... generally assumed to be ICD" 195 . S CODE=$P(ITEM,U,5) 196 . I +ORICD186,'+$$STATCHK^ICDAPIU(CODE,DT) Q 197 . S PCNT=PCNT+1 198 . ; RETURN: 199 . ; PROBLEM^DISPLAY TEXT^CODE^CODE IFN 200 . I +ORICD186 D 201 . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$CODEN^ICDCODE(CODE,80) 202 . E D 203 . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$ICDCODE(CODE) 204 Q 205 ; 206 ICDCODE(COD) ; RETURN INTERNAL ICD FOR EXTERNAL CODE (obsolete after CSV patches released - RV) 207 N CODIEN 208 I COD="" Q "" 209 S CODIEN=+$O(^ICD9("AB",$P(COD,U)_" ",0)) 210 S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",$P(COD,U)_"0 ",0)) 211 Q CODIEN 212 ; 213 ;------------------ Filter Providers --------------------- 214 ; 215 GETRPRV(RETURN,INP) ; GET LIST OF RESPONSIBLE PROVIDERS FROM PRBLM LIST 216 ; RETURN - aa list of responsible providers from which to select for filtering 217 ; INP - array of problem list providers to select from 218 ; 219 N S 220 S S="" 221 F I=1:1 S S=$O(INP(S)) Q:S="" D 222 . I INP(S)'="",$G(^VA(200,INP(S),0))'="" D Q ; get next 223 .. S RETURN(I)=INP(S)_U_$P(^VA(200,INP(S),0),U) 224 S RETURN(0)="-1"_U_"<None recorded>" ; return empty provider 225 Q 226 ; 227 ;---------------------------------------------------- GET FILTERED CLINIC LIST ------------------------ 228 ; 229 GETCLIN(RETURN,INP) ; Get FILTERED LIST OF CLINICS 230 ; RETURN NAMES FOR LIST OF CLINICS PASSED IN 231 N I,S 232 S S="" 233 F I=1:1 S S=$O(INP(S)) Q:S="" D 234 . I INP(S)'="",$G(^SC(INP(S),0))'="" D Q ; get next 235 .. S RETURN(I)=INP(S)_U_$P(^SC(INP(S),0),U,1) 236 ;. S RETURN(I)="-1"_U_"None" ; return empty location 237 Q 238 ; 239 GETSRVC(RETURN,INP) ; GET FILTERED LIST OF INPATIENT SERVICES 240 ; RETURN NAMES FOR LIST OF IEN PASSED IN 241 N I,S 242 S S="" 243 F I=1:1 S S=$O(INP(S)) Q:S="" D 244 . I INP(S)'="",$G(^DIC(49,INP(S),0))'="" D Q ; get next 245 .. S RETURN(I)=INP(S)_U_$P(^DIC(49,INP(S),0),U,1) 246 ;. S RETURN(I)="-1"_U_"None" ; return empty service 247 Q 1 ORQQPL3 ; ALB/PDR/REV ; Problem List RPC's ; 8-OCT-1998 09:08:49.29 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173**;Dec 17, 1997 3 ; 4 ;---------------- LIST PATIENT PROBLEMS ------------------------ 5 ; 6 PROBL(ROOT,DFN,CONTEXT) ; GET LIST OF PATIENT PROBLEMS 7 N DIWL,DIWR,DIWF 8 N ST,ORI,ORX 9 S (LCNT,NUM)=0 10 S DIWL=1,DIWR=48,DIWF="C48" 11 S CONTEXT=";;"_$G(CONTEXT) 12 I CONTEXT=";;" S CONTEXT=";;A" 13 S ST=$P(CONTEXT,";",3) 14 ; 15 I ST="R" D DELLIST(.ROOT,+DFN) ; show deleted only 16 I ST'="R" D LIST(.ROOT,+DFN,ST) ; show others - don't trust ELSE here 17 ; 18 I ROOT(0)<1 D 19 . S LCNT=1 20 . S ROOT(1)=" "_$$PAD^ORCHTAB("No data available.",49)_"|" 21 Q 22 ; 23 ; 24 LIST(GMPL,GMPDFN,GMPSTAT) ; -- Returns list of problems for patient GMPDFN 25 ; in GMPL(#)=ifn^status^description^ICD^onset^last modified^SC^SpExp^Condition^Loc^ 26 ; loc.type^prov^service 27 ; & GMPL(0)=number of problems returned 28 ; This is virtually same as LIST^GMPLUTL2 except that it appends the 29 ; condition - T)ranscribed or P)ermanent,location,loc type,provider, service. 30 ; 31 N I,IFN,CNT,GMPL0,GMPL1,SP,ST,NUM,ONSET,ICD,LASTMOD,PRIO,DTREC 32 N SC,ORLIST,ORVIEW,GMPARAM,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT 33 N SCCOND,AO,IR,ENV,HNC,MST,ORICD186,INACT 34 Q:$G(GMPDFN)'>0 35 S CNT=0,SP="" 36 S GMPARAM("QUIET")=1 37 S GMPARAM("REV")=$P($G(^GMPL(125.99,1,0)),U,5)="R" 38 S ORVIEW("ACT")=GMPSTAT 39 S ORVIEW("PROV")=0 40 S ORVIEW("VIEW")="" 41 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") 42 ; 43 D GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW) 44 ; 45 F NUM=0:0 S NUM=$O(ORLIST(NUM)) Q:NUM'>0 D 46 . S IFN=+ORLIST(NUM) Q:IFN'>0 47 . S INACT="" 48 . S GMPL0=$G(^AUPNPROB(IFN,0)) 49 . S GMPL1=$G(^AUPNPROB(IFN,1)) 50 . S HASCMT=($D(^AUPNPROB(IFN,11,0))>0) 51 . S CNT=CNT+1 52 . I +ORICD186 D 53 . . S ICD=$$CODEC^ICDCODE(+GMPL0) 54 . . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#" 55 . E D 56 . . S ICD=$P($G(^ICD9(+GMPL0,0)),U) 57 . S LASTMOD=$P(GMPL0,U,3) 58 . S ST=$P(GMPL0,U,12) 59 . S ONSET=$P(GMPL0,U,13) 60 . S SC=$S(+$P(GMPL1,U,10):"SC",$P(GMPL1,U,10)=0:"NSC",1:"") 61 . S AO=$S(+$P(GMPL1,U,11):"/AO",1:"") 62 . S IR=$S(+$P(GMPL1,U,12):"/IR",1:"") 63 . S ENV=$S(+$P(GMPL1,U,13):"/EC",1:"") 64 . S HNC=$S(+$P(GMPL1,U,15):"/HNC",1:"") 65 . S MST=$S(+$P(GMPL1,U,16):"/MST",1:"") 66 . S SCCOND=SC_AO_IR_ENV_HNC_MST 67 . S LOC=$P(GMPL1,U,8) 68 . S DTREC=$P(GMPL1,U,9) 69 . S LT="" 70 . I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3),LOC=LOC_";"_$P($G(^SC(LOC,0)),U,1) 71 . S PROV=$P(GMPL1,U,5) ; responsible provider 72 . I PROV'="" S PROV=PROV_";"_$P($G(^VA(200,PROV,0)),U,1) 73 . S SERV=$P(GMPL1,U,6) 74 . I SERV=0 S SERV="" ; not sure how it gets set to 0, but need consistency in GUI 75 . I SERV'="" S SERV=SERV_";"_$P($G(^DIC(49,SERV,0)),U,1) 76 . S SP="" 77 . F I=11,12,13 S:$P(GMPL1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P") 78 . S PRIO=$P(GMPL1,U,14) 79 . S LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET 80 . S LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$P(GMPL1,U,2) 81 . S LIN=LIN_U_LOC_U_LT_U_PROV_U_SERV_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT 82 . S GMPL(CNT)=LIN 83 S GMPL(0)=CNT 84 Q 85 ; 86 ; 87 ;------------------------------------- GET LIST OF DELETED PROBLEMS ----------------------------- 88 ; 89 DELLIST(RETURN,GMPDFN) ; GET LIST OF DELETED PROBLEMS 90 ; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2 91 N S,IFN,I,L0,L1,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC 92 N SCCOND,AO,IR,ENV,HNC,MST,ORICD186,INACT 93 S I=0,S="" 94 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") 95 F S S=$O(^AUPNPROB("ACTIVE",GMPDFN,S)) Q:S="" D 96 . S IFN="" 97 . F S IFN=$O(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN)) Q:IFN="" D 98 .. I $P($G(^AUPNPROB(IFN,1)),U,2)="H" D 99 ... S L0=$G(^AUPNPROB(IFN,0)) 100 ... Q:L0="" 101 ... S INACT="" 102 ... S L1=$G(^AUPNPROB(IFN,1)) 103 ... S ST=$P(L0,U,12) 104 ... S TXT=$$PROBTEXT^GMPLX(IFN) 105 ... I +ORICD186 D 106 ... . S ICD=$$CODEC^ICDCODE(+L0) 107 ... . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#" 108 ... E D 109 ... . S ICD=$P($G(^ICD9(+L0,0)),U) 110 ... S ONSET=$P(L0,U,13) 111 ... S MOD=$P(L0,U,3) 112 ... S SC=$S(+$P(L1,U,10):"SC",$P(L1,U,10)=0:"NSC",1:"") 113 ... S AO=$S(+$P(L1,U,11):"/AO",1:"") 114 ... S IR=$S(+$P(L1,U,12):"/IR",1:"") 115 ... S ENV=$S(+$P(L1,U,13):"/EC",1:"") 116 ... S HNC=$S(+$P(L1,U,15):"/HNC",1:"") 117 ... S MST=$S(+$P(L1,U,16):"/MST",1:"") 118 ... S SCCOND=SC_AO_IR_ENV_HNC_MST 119 ... S SP=$$GETSP 120 ... S LOC=$P(L1,U,8) 121 ... S LT="" 122 ... I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3) 123 ... S PROV=$P(L1,U,5) ; responsible provider 124 ... S SERV=$P(L1,U,6) 125 ... S PRIO=$P(L1,U,14) 126 ... S HASCMT=($D(^AUPNPROB(IFN,11,0))>0) 127 ... S DTREC=$P(L1,U,9) 128 ... S I=I+1 129 ... S RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET 130 ... S RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$P(L1,U,2) 131 ... S RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV 132 ... S RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT 133 S RETURN(0)=I 134 Q 135 ; 136 GETSP() ; GET EXPOSURES 137 N I 138 S SP="" 139 F I=11,12,13 S:$P(L1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P") 140 Q SP 141 ; 142 ; adapted from ^GMPLBLD3 ;9/96 143 ; 144 ; ----------------------- GET USER PROBLEM CATEGORIES -------------- 145 ; 146 CAT(TMP,ORDUZ,CLIN) ; Get user category list 147 N GSEQ,GCNT,GROUP,HDR,IFN,LCNT,ITEM,TG,GMPLSLST 148 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing 149 S TG=$NAME(TMP) ; put list in local 150 K @TG 151 S (GSEQ,GCNT,LCNT)=0 152 ; 153 S GMPLSLST=$$GETUSLST(DUZ,CLIN) ; get approp list for user 154 ; Build multiple of category\problems 155 ; Iterate categories 156 F S GSEQ=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ)) Q:GSEQ'>0 D 157 . S IFN=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0)) Q:IFN'>0 158 . S ITEM=$G(^GMPL(125.1,IFN,0)) 159 . S GROUP=+$P(ITEM,U,3) 160 . S HDR=GROUP_U_$P(ITEM,U,4,5) 161 . S GCNT=GCNT+1 162 . S @TG@(GCNT)=HDR ; put category into temp global 163 Q 164 ; 165 GETUSLST(ORDUZ,CLIN) ; GET AN APPROPRIATE CATEGORY LIST FOR THE USER 166 N GMPLSLST 167 S GMPLSLST=$P($G(^VA(200,DUZ,125)),U,2) 168 ;I 'GMPLSLST D 169 I 'GMPLSLST,CLIN,$D(^GMPL(125,"C",+CLIN)) S GMPLSLST=$O(^(+CLIN,0)) 170 ;. S GMPLSLST=$O(^VA(200,DUZ,+CLIN,0)) ;$O(^(+CLIN,0)) 171 Q GMPLSLST 172 ; 173 ;----------------------- USER PROBLEM LIST -------------------------- 174 ; 175 PROB(TMP,GROUP) ; Get user problem list for given group 176 N PSEQ,PCNT,IFN,ITEM,TG,CODE,TEXT,ORICD186 177 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing 178 S TG=$NAME(TMP) ; put list in local 179 K @TG 180 S LCNT=0 181 S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") 182 ; 183 ; iterate through problems in category 184 S (PSEQ,PCNT)=0 185 F S PSEQ=$O(^GMPL(125.12,"C",GROUP,PSEQ)) Q:PSEQ'>0 D 186 . S IFN=$O(^GMPL(125.12,"C",GROUP,PSEQ,0)) Q:IFN'>0 187 . S ITEM=$G(^GMPL(125.12,IFN,0)) 188 . S TEXT=$P(ITEM,U,4) 189 . ; SEE DD for GMPL(125.12,4 : 190 . ; "...code which is to be displayed... generally assumed to be ICD" 191 . S CODE=$P(ITEM,U,5) 192 . I +ORICD186,'+$$STATCHK^ICDAPIU(CODE,DT) Q 193 . S PCNT=PCNT+1 194 . ; RETURN: 195 . ; PROBLEM^DISPLAY TEXT^CODE^CODE IFN 196 . I +ORICD186 D 197 . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$CODEN^ICDCODE(CODE,80) 198 . E D 199 . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$ICDCODE(CODE) 200 Q 201 ; 202 ICDCODE(COD) ; RETURN INTERNAL ICD FOR EXTERNAL CODE (obsolete after CSV patches released - RV) 203 N CODIEN 204 I COD="" Q "" 205 S CODIEN=+$O(^ICD9("AB",$P(COD,U)_" ",0)) 206 S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",$P(COD,U)_"0 ",0)) 207 Q CODIEN 208 ; 209 ;------------------ Filter Providers --------------------- 210 ; 211 GETRPRV(RETURN,INP) ; GET LIST OF RESPONSIBLE PROVIDERS FROM PRBLM LIST 212 ; RETURN - aa list of responsible providers from which to select for filtering 213 ; INP - array of problem list providers to select from 214 ; 215 N S 216 S S="" 217 F I=1:1 S S=$O(INP(S)) Q:S="" D 218 . I INP(S)'="",$G(^VA(200,INP(S),0))'="" D Q ; get next 219 .. S RETURN(I)=INP(S)_U_$P(^VA(200,INP(S),0),U) 220 S RETURN(0)="-1"_U_"<None recorded>" ; return empty provider 221 Q 222 ; 223 ;---------------------------------------------------- GET FILTERED CLINIC LIST ------------------------ 224 ; 225 GETCLIN(RETURN,INP) ; Get FILTERED LIST OF CLINICS 226 ; RETURN NAMES FOR LIST OF CLINICS PASSED IN 227 N I,S 228 S S="" 229 F I=1:1 S S=$O(INP(S)) Q:S="" D 230 . I INP(S)'="",$G(^SC(INP(S),0))'="" D Q ; get next 231 .. S RETURN(I)=INP(S)_U_$P(^SC(INP(S),0),U,1) 232 ;. S RETURN(I)="-1"_U_"None" ; return empty location 233 Q 234 ; 235 GETSRVC(RETURN,INP) ; GET FILTERED LIST OF INPATIENT SERVICES 236 ; RETURN NAMES FOR LIST OF IEN PASSED IN 237 N I,S 238 S S="" 239 F I=1:1 S S=$O(INP(S)) Q:S="" D 240 . I INP(S)'="",$G(^DIC(49,INP(S),0))'="" D Q ; get next 241 .. S RETURN(I)=INP(S)_U_$P(^DIC(49,INP(S),0),U,1) 242 ;. S RETURN(I)="-1"_U_"None" ; return empty service 243 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPXRM.m
r613 r623 1 ORQQPXRM ; SLC/PJH - Functions for reminder data ;12/04/2007 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,187,190,215,243**;Dec 17, 1997;Build 242 3 ; 4 ;ORQQPXRM DIALOG ACTIVE 5 ACTIVE(ORY,ORLIST) D ACTIVE^PXRMRPCC(.ORY,.ORLIST) Q ; DBIA 3080 6 ; 7 ;ORQQPXRM REMINDER EVALUATION 8 ALIST(ORY,ORPT,ORLIST) D ALIST^PXRMRPCA(.ORY,.ORPT,.ORLIST) Q ; DBIA 3078 9 ; 10 ;ORQQPXRM REMINDERS APPLICABLE 11 APPL(ORY,ORPT,ORLOC) D EVALCOVR^ORQQPX(.ORY,ORPT,ORLOC) Q 12 ;D APPL^PXRMRPCA(.ORY,ORPT,ORLOC) Q ; DBIA 3078 13 ; 14 ;ORQQPXRM REMINDER CATEGORIES 15 CATEGORY(ORY,ORPT,ORLOC) ; 16 D CATEGORY^PXRMRPCA(.ORY,ORPT,ORLOC) Q ; DBIA 3078 17 ; 18 ;ORQQPXRM REMINDER DIALOG 19 DIALOG(ORY,ORREM,DFN) ; 20 ; DBIA 3080 21 N DIEN 22 D DIALOG^PXRMRPCC(.ORY,ORREM,DFN) 23 ;I $G(DFN)'="" D DIALOG^PXRMRPCC(.ORY,ORREM,DFN) 24 ;I $G(DFN)="" D DIALOG^PXRMRPCC(.ORY,ORREM) 25 I $P($G(ORY(1)),U)=-1 Q 26 S DIEN=$G(^PXD(811.9,ORREM,51)) 27 S ORY(0)=0_U_+$P($G(^PXRMD(801.41,DIEN,0)),U,17) 28 Q 29 ; 30 ;ORQQPXRM EDUCATION SUBTOPICS 31 EDS(ORY,OREDU) D EDS^PXRMRPCB(.ORY,OREDU) Q ; DBIA 3079 32 ; 33 ;ORQQPXRM EDUCATION SUMMARY 34 EDL(ORY,OREM) D EDL^PXRMRPCB(.ORY,OREM) Q ; DBIA 3079 35 ; 36 ;ORQQPXRM EDUCATION TOPIC 37 EDU(ORY,OREDU) D EDU^PXRMRPCB(.ORY,OREDU) Q ; DBIA 3079 38 ; 39 ;ORQQPXRM PROGRESS NOTE HEADER 40 HDR(ORY,ORLOC) D HDR^PXRMRPCC(.ORY,ORLOC) Q ; DBIA 3080 41 ; 42 ;ORQQPXRM REMINDERS UNEVALUATED 43 LIST(ORY,ORPT,ORLOC) D GETLIST^ORQQPX(.ORY,ORLOC) Q 44 ;D LIST^PXRMRPCA(.ORY,ORPT,ORLOC) Q ; DBIA 3078 45 ; 46 ;ORQQPXRM MENTAL HEALTH 47 MH(ORY,OTEST) ; 48 D MH^PXRMRPCC(.ORY,OTEST) ; DBIA 3080 49 S ORY(0)=0 50 I $$PATCH^XPDUTL("YS*5.01*85") S ORY(0)=1 51 Q 52 ; 53 MHDLL(ORY,DFN,INPUTS) ; 54 N CNT,CNT1,ORRESULT,ORSCORES,TEXT 55 F TEXT="RESULTS","SCORES" D 56 .S CNT=0,CNT1=0 57 .F S CNT=$O(INPUTS(TEXT,CNT)) Q:CNT="" D 58 ..S CNT1=CNT1+1 59 ..I TEXT="RESULTS" S ORRESULT(CNT1)=$G(INPUTS(TEXT,CNT)) 60 ..I TEXT="SCORES" S ORSCORES(CNT1)=$G(INPUTS(TEXT,CNT)) 61 D MHDLL^PXRMDRSG(.ORY,.ORRESULT,.ORSCORES,DFN) 62 Q 63 ; 64 MHDLLDMS(ORY) ; 65 ;Returns a one if CPRS should used the MH dll. Returns a 0 if CPRS 66 ;should not used the MH dll. 67 S ORY=1 68 I '$$PATCH^XPDUTL("YS*5.01*85") S ORY=0 Q 69 I '$$PATCH^XPDUTL("PXRM*2.0*6") S ORY=0 Q 70 I $$GET^XPAR("SYS","OR USE MH DLL")<1 S ORY=0 Q 71 Q 72 ; 73 ;ORQQPXRM MENTAL HEALTH RESULTS 74 MHR(ORY,RESULT,ORES) ; 75 ; DBIA 3080 76 D MHR^PXRMRPCC(.ORY,RESULT,.ORES) 77 Q 78 ; 79 ;ORQQPXRM MENTAL HEALTH SAVE 80 MHS(ORY,ORES) D MHS^PXRMRPCC(.ORY,.ORES) Q ; DBIA 3080 81 ; 82 MHV(ORY,DFN,NAME,ANS) ; 83 N ORDATA,ORES,X 84 S ORY(0)=0 85 I '$$PATCH^XPDUTL("YS*5.01*85") S ORY(0)=2 Q 86 I '$L(ANS) Q 87 S ORES("DFN")=DFN,ORES("CODE")=NAME 88 F X=1:1:$L(ANS) I $E(ANS,X)'="X" D 89 .;I $E(ANS,X)="T" S $E(ANS,X)=1 90 .;I $E(ANS,X)="F" S $E(ANS,X)=2 91 .S ORES(X)=X_U_$E(ANS,X) 92 D CHECKCR^YTQPXRM4(.ORDATA,.ORES) 93 I $G(ORDATA(2))="OK" S ORY(0)=1 Q 94 S ORY(1)=$P($G(ORDATA(2)),U,2) 95 Q 96 ; 97 ;ORQQPXRM MST UPDATE 98 MST(ORY,ORPT,ORDATE,ORSTAT,ORPROV,ORFTYP,ORFIEN,ORRES) ; 99 D MST^PXRMRPCC(.ORY,ORPT,ORDATE,ORSTAT,ORPROV,ORFTYP,ORFIEN,ORRES) Q 100 ; 101 ;ORQQPXRM WOMEN HEALTH RESULT 102 WH(ORY,ORRESULT) ; 103 D WH^PXRMRPCC(.ORY,.ORRESULT) Q 104 ; 105 WHLETTER(ORY,ORIEN) ; 106 D LETTER^WVRPCNO1(.ORY,ORIEN) Q 107 ; 108 WHREPORT(ORY,ORIEN) ; 109 D RESULTS^WVALERTF(.ORY,ORIEN) Q 110 ; 111 ;ORQQPXRM DIALOG PROMPTS 112 PROMPT(ORY,ORDLG,ORDCUR,ORFTYP) ; 113 D PROMPT^PXRMRPCC(.ORY,ORDLG,ORDCUR,ORFTYP) Q ; DBIA 3080 114 ; 115 ;ORQQPXRM REMINDER DETAIL 116 REMDET(ORY,ORPT,ORIEN) D REMDET^PXRMRPCA(.ORY,ORPT,ORIEN) Q ; DBIA 3078 117 ; 118 ;ORQQPXRM REMINDER INQUIRY 119 RES(ORY,ORREM) D RES^PXRMRPCC(.ORY,ORREM) Q ; DBIA 3080 120 ; 121 ;ORQQPXRM REMINDER WEB 122 WEB(ORY,ORREM) D WEB^PXRMRPCA(.ORY,ORREM) Q ; DBIA 3078 123 ; 124 ;PXRM REMINDER DIALOG (TIU) 125 TDIALOG(ORY,ORDLG,DFN) ; 126 D DIALOG^PXRMRPCD(.ORY,ORDLG,DFN) 127 I $P($G(ORY(1)),U)=-1 Q 128 S ORY(0)=0_U_+$P($G(^PXRMD(801.41,ORDLG,0)),U,17) 129 Q 130 ; 131 ACT(REM) ;ORQQPX SEARCH ITEMS - XPAR value screen for active reminders 132 ;Treat a null value as inactive 133 I 'REM Q 0 134 ;Treat a non-existen entry as inactive 135 I $G(^PXD(811.9,REM,0))="" Q 0 136 ;Check IF inactive flag is set 137 I ($T(INACTIVE^PXRM)'=""),$$INACTIVE^PXRM(REM) Q 0 ; DBIA 2182 138 ;Otherwise active 139 Q 1 140 ; 141 REMVER(ORLIST) ; 142 S ORLIST=$$VERSION^XPDUTL("PXRM") 143 Q 144 ; 145 GEC(ORRESULT,IEN,DFN,VISIT,NOTEIEN) ; 146 D API^PXRMGECU(.ORRESULT,IEN,DFN,VISIT,1,NOTEIEN) 147 Q 148 ; 149 GECF(RESULT,DFN,FIN) ; 150 D FINISHED^PXRMGECU(DFN,FIN) 151 Q 152 ; 153 GECP(RESULT,DFN) ; 154 S RESULT=$$STATUS^PXRMGECU(DFN) 155 Q 156 ; 1 ORQQPXRM ; SLC/PJH - Functions for reminder data ;7/21/2005 [2/4/04 10:24am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,187,190,215**;Dec 17, 1997 3 ; 4 ;ORQQPXRM DIALOG ACTIVE 5 ACTIVE(ORY,ORLIST) D ACTIVE^PXRMRPCC(.ORY,.ORLIST) Q ; DBIA 3080 6 ; 7 ;ORQQPXRM REMINDER EVALUATION 8 ALIST(ORY,ORPT,ORLIST) D ALIST^PXRMRPCA(.ORY,.ORPT,.ORLIST) Q ; DBIA 3078 9 ; 10 ;ORQQPXRM REMINDERS APPLICABLE 11 APPL(ORY,ORPT,ORLOC) D EVALCOVR^ORQQPX(.ORY,ORPT,ORLOC) Q 12 ;D APPL^PXRMRPCA(.ORY,ORPT,ORLOC) Q ; DBIA 3078 13 ; 14 ;ORQQPXRM REMINDER CATEGORIES 15 CATEGORY(ORY,ORPT,ORLOC) ; 16 D CATEGORY^PXRMRPCA(.ORY,ORPT,ORLOC) Q ; DBIA 3078 17 ; 18 ;ORQQPXRM REMINDER DIALOG 19 DIALOG(ORY,ORREM,DFN) ; 20 ; DBIA 3080 21 N DIEN 22 I $G(DFN)'="" D DIALOG^PXRMRPCC(.ORY,ORREM,DFN) 23 I $G(DFN)="" D DIALOG^PXRMRPCC(.ORY,ORREM) 24 I $P($G(ORY(1)),U)=-1 Q 25 S DIEN=$G(^PXD(811.9,ORREM,51)) 26 S ORY(0)=0_U_+$P($G(^PXRMD(801.41,DIEN,0)),U,17) 27 Q 28 ; 29 ;ORQQPXRM EDUCATION SUBTOPICS 30 EDS(ORY,OREDU) D EDS^PXRMRPCB(.ORY,OREDU) Q ; DBIA 3079 31 ; 32 ;ORQQPXRM EDUCATION SUMMARY 33 EDL(ORY,OREM) D EDL^PXRMRPCB(.ORY,OREM) Q ; DBIA 3079 34 ; 35 ;ORQQPXRM EDUCATION TOPIC 36 EDU(ORY,OREDU) D EDU^PXRMRPCB(.ORY,OREDU) Q ; DBIA 3079 37 ; 38 ;ORQQPXRM PROGRESS NOTE HEADER 39 HDR(ORY,ORLOC) D HDR^PXRMRPCC(.ORY,ORLOC) Q ; DBIA 3080 40 ; 41 ;ORQQPXRM REMINDERS UNEVALUATED 42 LIST(ORY,ORPT,ORLOC) D GETLIST^ORQQPX(.ORY,ORLOC) Q 43 ;D LIST^PXRMRPCA(.ORY,ORPT,ORLOC) Q ; DBIA 3078 44 ; 45 ;ORQQPXRM MENTAL HEALTH 46 MH(ORY,OTEST) ; 47 D MH^PXRMRPCC(.ORY,OTEST) ; DBIA 3080 48 S ORY(0)=0 49 I $$PATCH^XPDUTL("YS*5.01*85") S ORY(0)=1 50 Q 51 ; 52 ;ORQQPXRM MENTAL HEALTH RESULTS 53 MHR(ORY,RESULT,ORES) ; 54 ; DBIA 3080 55 D MHR^PXRMRPCC(.ORY,RESULT,.ORES) 56 Q 57 ; 58 ;ORQQPXRM MENTAL HEALTH SAVE 59 MHS(ORY,ORES) D MHS^PXRMRPCC(.ORY,.ORES) Q ; DBIA 3080 60 ; 61 MHV(ORY,DFN,NAME,ANS) ; 62 N ORDATA,ORES,X 63 S ORY(0)=0 64 I '$$PATCH^XPDUTL("YS*5.01*85") S ORY(0)=2 Q 65 I '$L(ANS) Q 66 S ORES("DFN")=DFN,ORES("CODE")=NAME 67 F X=1:1:$L(ANS) I $E(ANS,X)'="X" D 68 .;I $E(ANS,X)="T" S $E(ANS,X)=1 69 .;I $E(ANS,X)="F" S $E(ANS,X)=2 70 .S ORES(X)=X_U_$E(ANS,X) 71 D CHECKCR^YTQPXRM4(.ORDATA,.ORES) 72 I $G(ORDATA(2))="OK" S ORY(0)=1 Q 73 S ORY(1)=$P($G(ORDATA(2)),U,2) 74 Q 75 ; 76 ;ORQQPXRM MST UPDATE 77 MST(ORY,ORPT,ORDATE,ORSTAT,ORPROV,ORFTYP,ORFIEN,ORRES) ; 78 D MST^PXRMRPCC(.ORY,ORPT,ORDATE,ORSTAT,ORPROV,ORFTYP,ORFIEN,ORRES) Q 79 ; 80 ;ORQQPXRM WOMEN HEALTH RESULT 81 WH(ORY,ORRESULT) ; 82 D WH^PXRMRPCC(.ORY,.ORRESULT) Q 83 ; 84 WHLETTER(ORY,ORIEN) ; 85 D LETTER^WVRPCNO1(.ORY,ORIEN) Q 86 ; 87 WHREPORT(ORY,ORIEN) ; 88 D RESULTS^WVALERTF(.ORY,ORIEN) Q 89 ; 90 ;ORQQPXRM DIALOG PROMPTS 91 PROMPT(ORY,ORDLG,ORDCUR,ORFTYP) ; 92 D PROMPT^PXRMRPCC(.ORY,ORDLG,ORDCUR,ORFTYP) Q ; DBIA 3080 93 ; 94 ;ORQQPXRM REMINDER DETAIL 95 REMDET(ORY,ORPT,ORIEN) D REMDET^PXRMRPCA(.ORY,ORPT,ORIEN) Q ; DBIA 3078 96 ; 97 ;ORQQPXRM REMINDER INQUIRY 98 RES(ORY,ORREM) D RES^PXRMRPCC(.ORY,ORREM) Q ; DBIA 3080 99 ; 100 ;ORQQPXRM REMINDER WEB 101 WEB(ORY,ORREM) D WEB^PXRMRPCA(.ORY,ORREM) Q ; DBIA 3078 102 ; 103 ;PXRM REMINDER DIALOG (TIU) 104 TDIALOG(ORY,ORDLG,DFN) ; 105 D DIALOG^PXRMRPCD(.ORY,ORDLG,DFN) 106 I $P($G(ORY(1)),U)=-1 Q 107 S ORY(0)=0_U_+$P($G(^PXRMD(801.41,ORDLG,0)),U,17) 108 Q 109 ; 110 ACT(REM) ;ORQQPX SEARCH ITEMS - XPAR value screen for active reminders 111 ;Treat a null value as inactive 112 I 'REM Q 0 113 ;Treat a non-existen entry as inactive 114 I $G(^PXD(811.9,REM,0))="" Q 0 115 ;Check IF inactive flag is set 116 I ($T(INACTIVE^PXRM)'=""),$$INACTIVE^PXRM(REM) Q 0 ; DBIA 2182 117 ;Otherwise active 118 Q 1 119 ; 120 REMVER(ORLIST) ; 121 S ORLIST=$$VERSION^XPDUTL("PXRM") 122 Q 123 ; 124 GEC(ORRESULT,IEN,DFN,VISIT,NOTEIEN) ; 125 I $$VERSION^XPDUTL("PXRM")["2.0" D API^PXRMGECU(.ORRESULT,IEN,DFN,VISIT,1,NOTEIEN) 126 Q 127 ; 128 GECF(RESULT,DFN,FIN) ; 129 I $$VERSION^XPDUTL("PXRM")["2.0" D FINISHED^PXRMGECU(DFN,FIN) 130 Q 131 ; 132 GECP(RESULT,DFN) ; 133 I $$VERSION^XPDUTL("PXRM")["2.0",$G(DFN)'="" S RESULT=$$STATUS^PXRMGECU(DFN) 134 Q 135 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORUDPA.m
r613 r623 1 ORUDPA ; slc/dcm,RWF - Object (patient) lookup ;10/7/91 15:21 ; 3/7/08 5:22am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**16,243**;Dec 17, 1997;Build 242 3 ENT ; 4 ;Entry: none Exit: DFN,ORACTION,ORAGE,ORDOB,ORL,ORNP,ORPD,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORVP,ORWARD,VADPT("V"),VAERR 5 D PATIENT^ORU1(.Y) 6 Q 7 EN2 ; 8 S (ORVP,X)="",DIC(0)="EMQZI",DIC=2 9 R !,"Select PATIENT NAME: ",X:DTIME 10 I X=""!(X["^") S Y=-1 G END1 11 S:'$D(DIC(0)) DIC(0)="EMQZI" 12 S DIC="^DPT(" D ^DIC I $E(X)="^" S:X="^^" DIROUT=1 G END1 13 I Y>0 S ORVP=+Y_";DPT(" Q:$D(ORUS) G END1 14 Q 15 END1 ; 16 I Y>0 S ^TMP("OR",$J,"PAT",1)=ORVP,^TMP("OR",$J,"PAT","B",ORVP,1)="" 17 END ;from ORUHDR 18 Q:Y<0 19 I ORVP[";DPT(" D HOMO 20 K VA,VAROOT,VA200,VAIN,VAINDT,VAERR,VADM,DIC Q 21 ; 22 GPD ; 23 N GMRVSTR 24 K ORPD 25 S (ORSEQ,ORPD)=0,DFN=+ORVP 26 I $D(^GMRD(120.51)) S X="GMRVUTL",GMRVSTR="WT" X ^%ZOSF("TEST") I $T D EN6^GMRVUTL S ORPD=+$P(X,U,8)\1 27 S:ORPD'>0 ORPD="NF" 28 K ORSEQ 29 Q 30 HOMO ; 31 N XQORFLG,ORCNV 32 S DFN=+Y,VA200=1 K VAINDT 33 D OERR^VADPT,GPD 34 S ORPNM=VADM(1),ORSSN=VA("PID"),ORDOB=$P(VADM(3),"^",2),ORAGE=VADM(4),ORSEX=$P(VADM(5),"^"),ORTS=+VAIN(3),ORTS=$S(ORTS:ORTS,1:""),(ORATTEND,ORNP)=+VAIN(2),ORWARD=VAIN(4),ORL(1)=VAIN(5),(ORPV,ORL,ORL(0),ORL(2))="" 35 I +$P(ORWARD,"^") S X=+ORWARD I $D(^DIC(42,+X,44)) S X=$P(^(44),"^") I X,$D(^SC(X,0)) S ORL=X_";SC(",ORL(0)=$S($L($P(^(0),"^",2)):$P(^(0),"^",2),1:$E($P(^(0),"^"),1,4)),ORL(2)=ORL 36 Q 1 ORUDPA ; slc/dcm,RWF - Object (patient) lookup ;10/7/91 15:21 ; 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**16**;Dec 17, 1997 3 ENT ; 4 ;Entry: none Exit: DFN,ORACTION,ORAGE,ORDOB,ORL,ORNP,ORPD,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORVP,ORWARD,VADPT("V"),VAERR 5 D PATIENT^ORU1(.Y) 6 Q 7 EN2 ; 8 S (ORVP,X)="",DIC(0)="EMQZI",DIC=2 9 R !,"Select PATIENT NAME: ",X:DTIME 10 I X=""!(X["^") S Y=-1 G END1 11 S:'$D(DIC(0)) DIC(0)="EMQZI" 12 S DIC="^DPT(" D ^DIC I $E(X)="^" S:X="^^" DIROUT=1 G END1 13 I Y>0 S ORVP=+Y_";DPT(" Q:$D(ORUS) G END1 14 Q 15 END1 ; 16 I Y>0 S ^TMP("OR",$J,"PAT",1)=ORVP,^TMP("OR",$J,"PAT","B",ORVP,1)="" 17 END ;from ORUHDR 18 Q:Y<0 19 I ORVP[";DPT(" D HOMO 20 K VA,VAROOT,VA200,VAIN,VAINDT,VAERR,VADM,DIC Q 21 ; 22 GPD ; 23 K ORPD 24 S (ORSEQ,ORPD)=0,DFN=+ORVP 25 I $D(^GMRD(120.51)) S X="GMRVUTL" X ^%ZOSF("TEST") I $T D EN4^GMRVUTL S ORPD=+X\1 26 S:ORPD'>0 ORPD="NF" 27 K ORSEQ 28 Q 29 HOMO ; 30 N XQORFLG,ORCNV 31 S DFN=+Y,VA200=1 K VAINDT 32 D OERR^VADPT,GPD 33 S ORPNM=VADM(1),ORSSN=VA("PID"),ORDOB=$P(VADM(3),"^",2),ORAGE=VADM(4),ORSEX=$P(VADM(5),"^"),ORTS=+VAIN(3),ORTS=$S(ORTS:ORTS,1:""),(ORATTEND,ORNP)=+VAIN(2),ORWARD=VAIN(4),ORL(1)=VAIN(5),(ORPV,ORL,ORL(0),ORL(2))="" 34 I +$P(ORWARD,"^") S X=+ORWARD I $D(^DIC(42,+X,44)) S X=$P(^(44),"^") I X,$D(^SC(X,0)) S ORL=X_";SC(",ORL(0)=$S($L($P(^(0),"^",2)):$P(^(0),"^",2),1:$E($P(^(0),"^"),1,4)),ORL(2)=ORL 35 S ORCNV=$$OTF^OR3CONV(+ORVP) Q:'ORCNV 36 I ORCNV>0 W !,"DONE" H 1 Q 37 I ORCNV<0 W $C(7),!!,$P(ORCNV,U,2) H 2 S VALMBCK="R" Q 38 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORUTL1.m
r613 r623 1 ORUTL1 ; slc/dcm - OE/RR Utilities ;5/30/07 13:46 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,66,243**;Dec 17, 1997;Build 242 3 LOC ;Hospital Location Look-up 4 N DIC,ORIA,ORRA 5 S DIC=44,DIC(0)="AEQM",DIC("S")="I '$P($G(^(""OOS"")),""^"")" 6 D ^DIC 7 I Y<1 Q 8 I $D(^SC(+Y,"I")) S ORIA=+^("I"),ORRA=$P(^("I"),U,2) 9 I $S('$D(ORIA):0,'ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1) W $C(7),!," This location has been inactivated.",! K ORL G LOC 10 Q 11 QUE(ZTRTN,ZTDESC,ZTSAVE,ORIOPTR,ZTDTH,%ZIS,QUE,ECHO,ORION) ;Device Handling 12 IO ;This entry point replaced by QUE, but left for backwards compatibility 13 Q:'$D(ZTRTN) 14 N IO,ION,IOP,IOPAR,IOT,ZTSK,ZTIO,POP 15 I $G(QUE),'$L($G(ORIOPTR)) Q 16 I $L($G(ORIOPTR)),$G(QUE),$D(ORION) S ZTIO=ORION G IOQ 17 S:'($D(%ZIS)#2) %ZIS="Q" 18 I $G(QUE) S:%ZIS'["Q" %ZIS=%ZIS_"Q" S %ZIS("S")="I $S($G(^%ZIS(2,+$G(^(""SUBTYPE"")),0))'[""C-"":1,1:0)",%ZIS("B")="" 19 I $L($G(ORIOPTR)) S IOP=ORIOPTR 20 D ^%ZIS 21 I POP S OREND=1 Q 22 S ZTIO=ION 23 IOQ I $G(QUE)!$D(IO("Q")) D Q 24 . S:'$D(ZTSAVE) ZTSAVE("O*")="" 25 . D ^%ZTLOAD 26 . I $D(ZTSK),'$D(ECHO) W !,"REQUEST QUEUED" 27 . I '$D(ZTSK) S OREND=1 28 . D ^%ZISC 29 D @ZTRTN 30 D ^%ZISC 31 Q 32 ; 33 DPI(PATCH) ;Function returns date patch installed - added in patch 243 34 ;PATCH is set to patch designation, for example, "SR*3.0*157" 35 ;Output is the fileman date/time that patch was installed on this system 36 ;A return value of -1 is given if patch hasn't been installed 37 N ORVALUE,ORDAT,ORERR,VER,PKG,DATE,NUM 38 S DATE=-1 39 I '$$PATCH^XPDUTL(PATCH) Q DATE ;If patch hasn't been installed yet quit 40 S ORVALUE=$P(PATCH,"*") ;Package 41 D FIND^DIC(9.4,,,"MO",.ORVALUE,,,,,"ORDAT","ORERR") 42 S PKG=$G(ORDAT("DILIST",2,1)) I 'PKG Q DATE 43 S ORVALUE=$P(PATCH,"*",2) ;Version 44 D FIND^DIC(9.49,(","_PKG_","),,"X",.ORVALUE,,,,,"ORDAT","ORERR") 45 S VER=$G(ORDAT("DILIST",2,1)) I 'VER Q DATE 46 S ORVALUE=$P(PATCH,"*",3) ;Patch number 47 D FIND^DIC(9.4901,(","_VER_","_PKG_","),,,.ORVALUE,,,,,"ORDAT","ORERR") 48 S NUM=$G(ORDAT("DILIST",2,1)) I 'NUM Q DATE 49 S DATE=$$GET1^DIQ(9.4901,(NUM_","_VER_","_PKG_","),.02,"I") 50 Q DATE 1 ORUTL1 ; slc/dcm - OE/RR Utilities ;6/7/91 08:47 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,66**;Dec 17, 1997 3 LOC ;Hospital Location Look-up 4 N DIC,ORIA,ORRA 5 S DIC=44,DIC(0)="AEQM",DIC("S")="I '$P($G(^(""OOS"")),""^"")" 6 D ^DIC 7 I Y<1 Q 8 I $D(^SC(+Y,"I")) S ORIA=+^("I"),ORRA=$P(^("I"),U,2) 9 I $S('$D(ORIA):0,'ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1) W $C(7),!," This location has been inactivated.",! K ORL G LOC 10 Q 11 QUE(ZTRTN,ZTDESC,ZTSAVE,ORIOPTR,ZTDTH,%ZIS,QUE,ECHO,ORION) ;Device Handling 12 IO ;This entry point replaced by QUE, but left for backwards compatibility 13 Q:'$D(ZTRTN) 14 N IO,ION,IOP,IOPAR,IOT,ZTSK,ZTIO,POP 15 I $G(QUE),'$L($G(ORIOPTR)) Q 16 I $L($G(ORIOPTR)),$G(QUE),$D(ORION) S ZTIO=ORION G IOQ 17 S:'($D(%ZIS)#2) %ZIS="Q" 18 I $G(QUE) S:%ZIS'["Q" %ZIS=%ZIS_"Q" S %ZIS("S")="I $S($G(^%ZIS(2,+$G(^(""SUBTYPE"")),0))'[""C-"":1,1:0)",%ZIS("B")="" 19 I $L($G(ORIOPTR)) S IOP=ORIOPTR 20 D ^%ZIS 21 I POP S OREND=1 Q 22 S ZTIO=ION 23 IOQ I $G(QUE)!$D(IO("Q")) D Q 24 . S:'$D(ZTSAVE) ZTSAVE("O*")="" 25 . D ^%ZTLOAD 26 . I $D(ZTSK),'$D(ECHO) W !,"REQUEST QUEUED" 27 . I '$D(ZTSK) S OREND=1 28 . D ^%ZISC 29 D @ZTRTN 30 D ^%ZISC 31 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWCIRN.m
r613 r623 1 ORWCIRN ; slc/dcm,REV - Functions for GUI CIRN ACTIONS ;22-NOV-1999 07:27:24 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,101,109,132,141,160,208,239,215,243**;October 28, 1997;Build 242 3 ; 4 FACLIST(ORY,ORDFN) ; Return list of remote facilities for patient 5 ;Check to see if CIRN PD/MPI installed 6 N X,ORSITES,I,IFN,LOCAL,CTR,HDRFLG 7 S X="MPIF001" X ^%ZOSF("TEST") 8 I '$T S ORY(0)="-1^CIRN MPI not installed." Q 9 S X="VAFCTFU1" X ^%ZOSF("TEST") 10 I '$T S ORY(0)="-1^Remote data view not installed." Q 11 S X=$$GET^XPAR("ALL","ORWRP CIRN REMOTE DATA ALLOW",1,"I") 12 I 'X S ORY(0)="-1^Remote access not allowed" Q 13 D TFL^VAFCTFU1(.ORY,ORDFN) 14 S I=0 F S I=$O(ORY(I)) Q:'I I $P(ORY(I),"^",5)="OTHER",'($P(ORY(I),"^")="200HD") K ORY(I) ;Screen out Type 'OTHER' locations 15 S HDRFLG=0 16 I $$GET^XPAR("ALL","ORWRP CIRN SITES ALL",1,"I") D 17 . S (CTR,I)=0 18 . F S I=$O(ORY(I)) Q:'I S $P(ORY(I),"^",5)=1,CTR=CTR+1 D 19 .. I $P(ORY(I),"^")=200 S $P(ORY(I),"^",2)="DEPT. OF DEFENSE" 20 .. I $P(ORY(I),"^")="200HD" D 21 ... I +$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")=0 K ORY(I) S CTR=CTR-1 Q 22 ... S HDRFLG=I ; Remove commented out code to enable HDR + 1 other site. 23 D GETLST^XPAR(.ORSITES,"ALL","ORWRP CIRN SITES","I") 24 S (CTR,I)=0,LOCAL=$P($$SITE^VASITE,"^",3) 25 F S I=$O(ORY(I)) Q:'I D 26 . I +ORY(I)=+LOCAL K ORY(I) Q 27 . S IFN=$$IEN^XUAF4(ORY(I)),CTR=CTR+1 28 . I IFN,$G(ORSITES(IFN)) S $P(ORY(I),"^",5)=1 I $P(ORY(I),"^")=200 S $P(ORY(I),"^",2)="DEPT. OF DEFENSE" 29 . I IFN,$G(ORSITES(IFN)),$P(ORY(I),"^")="200HD" D 30 .. I +$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")=0 K ORY(I) S CTR=CTR-1 Q 31 .. S HDRFLG=I ; Remove commented out code to enable HDR + 1 other site. 32 I '$L($O(ORY(""))) S ORY(0)="-1^Only local data exists for this patient" 33 I $G(HDRFLG),CTR'>1 K ORY(HDRFLG) S ORY(0)="-1^Only HDR has data for this patient" 34 Q 35 RESTRICT(ORY,PATID) ;Check for sensitive patient 36 N DFN,ICN,SITE 37 I '$G(PATID) S ORY(1)="-1",ORY(2)="Invalid Patient ID" Q 38 S ICN=$P(PATID,";",2) 39 I 'ICN S ORY(1)="-1",ORY(2)="Invalid ICN" Q 40 S SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3) 41 S DFN=+$$GETDFN^MPIF001(ICN) 42 I DFN<0 S ORY(1)="-1",ORY(2)="Patient not found on remote system ("_SITE_")" Q 43 D PTSEC^DGSEC4(.ORY,DFN) 44 Q 45 CHKLNK(ORY) ;Check for active HL7 TCP link on local system 46 S ORY=$$STAT^HLCSLM 47 Q 48 WEBADDR(ORY,PATID) ;Get VistaWeb Address 49 S ORY=$$GET^XPAR("ALL","ORWRP VISTAWEB ADDRESS",1,"I") 50 I ORY="" S ORY="https://vistaweb.med.va.gov" Q 51 I ORY="https://vistaweb.med.va.gov" Q 52 S ORY=ORY_"?q9gtw0="_$P($$SITE^VASITE,"^",3)_"&xqi4z="_PATID_"&yiicf="_DUZ 53 Q 54 AUTORDV(ORY) ;Get parameter value for ORWRP CIRN AUTOMATIC 55 S ORY=+$$GET^XPAR("ALL","ORWRP CIRN AUTOMATIC",1,"I") 56 Q 57 HDRON(ORY) ;Get parameter value for ORWRP HDR ON 58 S ORY=+$$GET^XPAR("ALL","ORWRP HDR ON",1,"I") 59 Q 1 ORWCIRN ; slc/dcm,REV - Functions for GUI CIRN ACTIONS ;22-NOV-1999 07:27:24 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,101,109,132,141,160,208,239,215**;October 28, 1997 3 ; 4 FACLIST(ORY,ORDFN) ; Return list of remote facilities for patient 5 ;Check to see if CIRN PD/MPI installed 6 N X,ORSITES,I,IFN,LOCAL,CTR,HDRFLG 7 S X="MPIF001" X ^%ZOSF("TEST") 8 I '$T S ORY(0)="-1^CIRN MPI not installed." Q 9 S X="VAFCTFU1" X ^%ZOSF("TEST") 10 I '$T S ORY(0)="-1^Remote data view not installed." Q 11 S X=$$GET^XPAR("ALL","ORWRP CIRN REMOTE DATA ALLOW",1,"I") 12 I 'X S ORY(0)="-1^Remote access not allowed" Q 13 D TFL^VAFCTFU1(.ORY,ORDFN) 14 S I=0 F S I=$O(ORY(I)) Q:'I I $P(ORY(I),"^",5)="OTHER",'($P(ORY(I),"^")="200HD") K ORY(I) ;Screen out Type 'OTHER' locations 15 S HDRFLG=0 16 I $$GET^XPAR("ALL","ORWRP CIRN SITES ALL",1,"I") D 17 . S (CTR,I)=0 18 . F S I=$O(ORY(I)) Q:'I S $P(ORY(I),"^",5)=1,CTR=CTR+1 D 19 .. I $P(ORY(I),"^")=200 S $P(ORY(I),"^",2)="DEPT. OF DEFENSE" 20 .. I $P(ORY(I),"^")="200HD" D 21 ... I +$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")=0 K ORY(I) S CTR=CTR-1 Q 22 ... S HDRFLG=I ; Remove commented out code to enable HDR + 1 other site. 23 D GETLST^XPAR(.ORSITES,"ALL","ORWRP CIRN SITES","I") 24 S (CTR,I)=0,LOCAL=$P($$SITE^VASITE,"^",3) 25 F S I=$O(ORY(I)) Q:'I D 26 . I +ORY(I)=+LOCAL K ORY(I) Q 27 . S IFN=$$IEN^XUAF4(ORY(I)),CTR=CTR+1 28 . I IFN,$G(ORSITES(IFN)) S $P(ORY(I),"^",5)=1 I $P(ORY(I),"^")=200 S $P(ORY(I),"^",2)="DEPT. OF DEFENSE" 29 . I IFN,$G(ORSITES(IFN)),$P(ORY(I),"^")="200HD" D 30 .. I +$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")=0 K ORY(I) S CTR=CTR-1 Q 31 .. S HDRFLG=I ; Remove commented out code to enable HDR + 1 other site. 32 I '$L($O(ORY(""))) S ORY(0)="-1^Only local data exists for this patient" 33 I $G(HDRFLG),CTR'>1 K ORY(HDRFLG) S ORY(0)="-1^Only HDR has data for this patient" 34 Q 35 RESTRICT(ORY,PATID) ;Check for sensitive patient 36 N DFN,ICN,SITE 37 I '$G(PATID) S ORY(1)="-1",ORY(2)="Invalid Patient ID" Q 38 S ICN=$P(PATID,";",2) 39 I 'ICN S ORY(1)="-1",ORY(2)="Invalid ICN" Q 40 S SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3) 41 S DFN=+$$GETDFN^MPIF001(ICN) 42 I DFN<0 S ORY(1)="-1",ORY(2)="Patient not found on remote system ("_SITE_")" Q 43 D PTSEC^DGSEC4(.ORY,DFN) 44 Q 45 CHKLNK(ORY) ;Check for active HL7 TCP link on local system 46 S ORY=$$STAT^HLCSLM 47 Q 48 VISTAWEB(ORY) ;Check VistaWeb Parameter 49 S ORY=+$$GET^XPAR("ALL","ORWRP VISTAWEB",1,"I") 50 Q 51 WEBCH(ORY,ORVALUE) ;Change value of ORWRP VISTAWEB parameter 52 D PUT^XPAR(DUZ_";VA(200,","ORWRP VISTAWEB",1,ORVALUE) 53 Q 54 WEBADDR(ORY,PATID) ;Get VistaWeb Address 55 S ORY=$$GET^XPAR("ALL","ORWRP VISTAWEB ADDRESS",1,"I") 56 I ORY="" S ORY="https://vistaweb.med.va.gov" Q 57 I ORY="https://vistaweb.med.va.gov" Q 58 S ORY=ORY_"?q9gtw0="_$P($$SITE^VASITE,"^",3)_"&xqi4z="_PATID_"&yiicf="_DUZ 59 Q 60 AUTORDV(ORY) ;Get parameter value for ORWRP CIRN AUTOMATIC 61 S ORY=+$$GET^XPAR("ALL","ORWRP CIRN AUTOMATIC",1,"I") 62 Q 63 HDRON(ORY) ;Get parameter value for ORWRP HDR ON 64 S ORY=+$$GET^XPAR("ALL","ORWRP HDR ON",1,"I") 65 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWCV.m
r613 r623 1 ORWCV ; SLC/KCM - Background Cover Sheet Load; ; 3/6/08 6:34am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,209,214,195,215,260,243**;Dec 17, 1997;Build 242 3 ; 4 ; DBIA 4011 Access ^XWB(8994) 5 ; DBIA 4313 Direct R/W permission to capacity mgmt global ^KMPTMP("KMPDT") 6 ; DBIA 10061 Reference to ^UTILITY 7 ; 8 START(VAL,DFN,IP,HWND,LOC,NODO,NEWREM) ; start cover sheet build in background 9 N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,SECT,BACK,X,I,ORLIST,STR,FILE,NODE,ORHTIME,ORX 10 ; Capacity planning timing code uses ORHTIME 11 S ORHTIME=$H 12 S LOC=$G(LOC),NODO=";"_$G(NODO),NEWREM=+$G(NEWREM) 13 D GETLST^XPAR(.ORX,"SYS^PKG","ORWOR COVER RETRIEVAL NEW","Q") 14 S I=0 F S I=$O(ORX(I)) Q:'I I $D(^ORD(101.24,+ORX(I),0)) S SECT(+$P(^(0),"^",2))=$P(ORX(I),"^",2) 15 D GETLST^XPAR(.ORLIST,"ALL","ORWCV1 COVERSHEET LIST") 16 S (VAL,BACK,STR,FILE)="" 17 F S I=$O(ORLIST(I)) Q:'I I $D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0) D 18 . Q:$P(X0,"^",8)'="C" 19 . S X=$P(X0,"^",2) 20 . I NODO[(";"_X_";") Q ; if in NODO, dont do section 21 . S STR=STR_X_";" 22 . I '$G(SECT(X)) S VAL=VAL_X_";" ; load section in foreground 23 . E S BACK=BACK_X_";",FILE=FILE_$P(ORLIST(I),"^",2)_";" ; load section in background 24 Q:BACK="" 25 S ZTIO="ORW THREAD RESOURCE",ZTRTN="BUILD^ORWCV",ZTDTH=$H 26 S (ZTSAVE("DFN"),ZTSAVE("IP"),ZTSAVE("HWND"),ZTSAVE("NEWREM"),ZTSAVE("LOC"),ZTSAVE("BACK"),ZTSAVE("FILE"))="" 27 S ZTDESC="CPRS GUI Background Data Retrieval" 28 D ^%ZTLOAD I '$D(ZTSK) S VAL=STR Q 29 S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN 30 K ^XTMP(NODE) 31 S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"Background CPRS "_ZTSK 32 ; Start capacity planning timing clock - will be stopped in POLL code 33 I +$G(^KMPTMP("KMPD-CPRS")) S ^KMPTMP("KMPDT","ORWCV",NODE)=$G(ORHTIME)_"^^"_$G(DUZ)_"^"_$G(IO("CLNM")) 34 Q 35 BUILD ; called in background by task manager, expects DFN, JobID 36 N NODE,IFLE,ORFNUM,ID,ENT,RTN,INODE,PARAM1,PARAM2,DETAIL,X0,X2 37 S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN 38 I $D(ZTQUEUED) S ZTREQ="@" 39 I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE) Q ; client no longer polling 40 I '$D(^XTMP(NODE,0)) Q ; XTMP node has been purged 41 L +^XTMP(NODE) 42 S ^XTMP(NODE,"DFN")=DFN 43 ;N $ETRAP,$ESTACK 44 ;S $ETRAP="D ERR^ORWCV Q" 45 I $L($G(FILE),";")>0 F IFLE=1:1:$L(FILE,";") S ORFNUM=$P(FILE,";",IFLE) Q:'$D(^ORD(101.24,+ORFNUM,0)) S X0=^(0),X2=$G(^(2)) D 46 . S ID=$P(X0,"^",2),ENT=$P(X0,"^",6),RTN=$P(X0,"^",5),PARAM1=$P(X2,"^"),PARAM2=$P(X2,"^",2),INODE=$P(X2,"^",5),DETAIL="" 47 . I $P(X0,"^",18) S DETAIL=$P($G(^ORD(101.24,+$P(X0,"^",18),0)),"^",13),DETAIL=$P($G(^XWB(8994,+DETAIL,0)),"^") ;DBIA 4011 48 . I '$L(INODE) Q 49 . I '$L(ENT) S LST(IFLE)="0^ERROR: Missing ENTRY POINT field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q 50 . I '$L(RTN) S LST(IFLE)="0^ERROR: Missing ROUTINE field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q 51 . I '$L($T(@(ENT_"^"_RTN))) S LST(IFLE)="0^ERROR: "_ENT_"~"_RTN_" does not exist. See file 101.24 entry: "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q 52 . I ID=50 D:$L($T(STRT3^AWCMCPR1)) STRT3^AWCMCPR1 D D:$L($T(END^AWCMCPR1)) END^AWCMCPR1 Q ;Special case for reminders 53 .. I $G(NEWREM) D APPL^ORQQPXRM(.LST,DFN,LOC) I 1 54 .. E D @(ENT_"^"_RTN_"(.LST,DFN)") 55 .. D LST2XTMP(INODE) 56 . I $L(PARAM1),$L(PARAM2) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1,PARAM2)"),LST2XTMP(INODE) Q 57 . I $L(PARAM1) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1)"),LST2XTMP(INODE) Q 58 . D @(ENT_"^"_RTN_"(.LST,DFN)"),LST2XTMP(INODE) 59 S ^XTMP(NODE,"DONE")=1 60 I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE) 61 L -^XTMP(NODE) 62 Q 63 ERR ;Error trap 64 S $ETRAP="D UNWIND^ORWCV Q" 65 I $D(NODE) D 66 . I $D(INODE) S LST(0)="",LST(1)="0^ERROR DURING COVER SHEET BUILD:"_$ZERROR D LST2XTMP(INODE) 67 . S ^XTMP(NODE,"DONE")=1 68 . L -^XTMP(NODE) 69 D @^%ZOSF("ERRTN") ;file error 70 S $ECODE=",UOR70 error during Cover Sheet build," 71 Q 72 UNWIND ;Unwind Error stack 73 Q:$ESTACK>1 ;pop the stack 74 ;add additional code here, if needed 75 Q 76 LST2XTMP(ID) ; put the list in ^XTMP(NODE,ID) 77 I $G(^XTMP(NODE,"STOP")) Q 78 N I 79 I $L($G(DETAIL)) S I=0 F S I=$O(LST(I)) Q:'I S $P(LST(I),"^",12)=DETAIL 80 K ^XTMP(NODE,ID) M ^XTMP(NODE,ID)=LST S ^XTMP(NODE,ID)=1 K LST 81 Q 82 POLL(LST,DFN,IP,HWND) ; poll for completed cover sheet parts 83 N I,ILST,ID,NODE,DONE 84 S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0 85 I '$D(^XTMP(NODE,"DFN")) Q 86 I ^XTMP(NODE,"DFN")'=DFN S LST(1)="~DONE=1" Q 87 I $G(^XTMP(NODE,"DONE")) S ILST=ILST+1,LST(ILST)="~DONE=1",DONE=1 88 F ID="PROB","CWAD","MEDS","RMND","LABS","VITL","VSIT" D 89 . I '$G(^XTMP(NODE,ID)) Q 90 . S ILST=ILST+1,LST(ILST)="~"_ID 91 . S I=0 F S I=$O(^XTMP(NODE,ID,I)) Q:'I S ILST=ILST+1,LST(ILST)="i"_^(I) 92 . K ^XTMP(NODE,ID) 93 ; Stop capacity planning timing clock - was started in START code 94 I DONE K ^XTMP(NODE) I +$G(^KMPTMP("KMPD-CPRS")) S $P(^KMPTMP("KMPDT","ORWCV",NODE),"^",2)=$H 95 Q 96 STOP(OK,DFN,IP,HWND) ; stop cover sheet data retrieval 97 S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0 98 S ^XTMP(NODE,"STOP")=1,OK=1 99 L +^XTMP(NODE) 100 I $G(^XTMP(NODE,"DONE")) K ^XTMP(NODE) 101 L -^XTMP(NODE) 102 Q 103 CLEAN ; clean up ^XTMP nodes 104 S X="ORWCV" 105 F S X=$O(^XTMP(X)) Q:$E(X,1,5)'="ORWCV" W !,X K ^XTMP(X) 106 Q 107 LAB(LST,DFN) ; return labs for patient 108 D:$L($T(STRT2^AWCMCPR1)) STRT2^AWCMCPR1 109 D LIST^ORQOR1(.LST,DFN,"LAB",4,"T-"_$$RNGLAB(DFN),"T","AW",1) 110 D:$L($T(END^AWCMCPR1)) END^AWCMCPR1 111 Q 112 ; 113 VST1(ORVISIT,DFN,BEG,END,SKIP) ; 114 N ERR,ERRMSG 115 S ERR=0 ; kludge to return errors 116 Q:'$G(DFN) 117 D VST(.ORVISIT,DFN,.BEG,.END,$G(SKIP),.ERR,.ERRMSG) 118 I ERR K ORVISIT S ORVISIT(1)=ERRMSG 119 Q 120 ; 121 TEST ;D VST(.ZZZ,76,2950101,3050401,777,1,1) 122 Q 123 VST(ORVISIT,DFN,BEG,END,SKIP,ERR,ERRMSG) ; return appts/admissions for patient 124 N CHECKERR,VAERR,VASD,BDT,COUNT,DTM,EDT,LOC,NOW,ORQUERY,ORLST,STI,STS,TODAY,I,J,K,XI,XE,X 125 S CHECKERR=($G(ERR)=0) ; kludge to check for errors 126 S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1) 127 I '$G(BEG) S BEG=$$X2FM($$RNGVBEG) 128 I '$G(END) S END=$$X2FM($$RNGVEND)+0.2359 129 S COUNT=0 130 K ^TMP("ORVSTLIST",$J) 131 S VAERR=0 132 I END>NOW D Q:VAERR ; get future encounters, past cancels/no-shows from VADPT 133 . S VASD("F")=BEG 134 . S VASD("T")=END 135 . S VASD("W")="123456789" 136 . D SDA^ORQRY01(.ERR,.ERRMSG) 137 . I CHECKERR,ERR K ^UTILITY("VASD",$J) S ORVISIT(1)=ERRMSG Q ;IA 10061 138 . S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D 139 . . S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E") 140 . . S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3) 141 . . S LOC=$P(XE,U,2),STS=$P(XE,U,3) 142 . . I DTM<TODAY,(STI=""!(STI["I")!(STI="NT")) Q ; no prior kept appts 143 . . S ^TMP("ORVSTLIST",$J,DTM,"A",1)="A;"_DTM_";"_IEN_U_DTM_U_LOC_U_STS 144 . K ^UTILITY("VASD",$J) 145 I BEG'>NOW D ;past encounters from ACRP Toolkit - set in CALLBACK 146 . S BDT=BEG 147 . S EDT=$S(END<NOW:END,1:NOW) 148 . D OPEN^SDQ(.ORQUERY) 149 . I '$$ERRCHK^SDQUT() D INDEX^SDQ(.ORQUERY,"PATIENT/DATE","SET") 150 . I '$$ERRCHK^SDQUT() D PAT^SDQ(.ORQUERY,DFN,"SET") 151 . I '$$ERRCHK^SDQUT() D DATE^SDQ(.ORQUERY,BDT,EDT,"SET") 152 . I '$$ERRCHK^SDQUT() D 153 . . S ORLST=$NA(^TMP("ORVSTLIST",$J)) 154 . . D SCANCB^SDQ(.ORQUERY,"D CALLBACK^ORWCV(Y,Y0,.ORLST,.ORSTOP)","SET") 155 . I '$$ERRCHK^SDQUT() D ACTIVE^SDQ(.ORQUERY,"TRUE","SET") 156 . I '$$ERRCHK^SDQUT() D SCAN^SDQ(.ORQUERY,"FORWARD") 157 . D CLOSE^SDQ(.ORQUERY) 158 ; 159 I '$G(SKIP) D 160 . N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,EARLY,DONE ; admits 161 . S EARLY=$$X2FM($$RNGVBEG),DONE=0 162 . S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D Q:DONE 163 . . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D Q:DONE 164 . . . S X0=^DGPM(MOV,0),MTIM=$P(X0,U) 165 . . . I MTIM<EARLY S DONE=1 Q 166 . . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1) 167 . . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44)) 168 . . . S ^TMP("ORVSTLIST",$J,MTIM,"I",1)="I;"_MTIM_";"_HLOC_U_MTIM_U_"Inpatient Stay"_U_XLOC_U_XTYP 169 ; 170 S COUNT=0 171 S I=0 F S I=$O(^TMP("ORVSTLIST",$J,I)) Q:'I D 172 . S J="" F S J=$O(^TMP("ORVSTLIST",$J,I,J)) Q:J="" D 173 . . S K=0 F S K=$O(^TMP("ORVSTLIST",$J,I,J,K)) Q:'K D 174 . . . S COUNT=COUNT+1 175 . . . S ORVISIT(COUNT)=^TMP("ORVSTLIST",$J,I,J,K) 176 K ^TMP("ORVSTLIST",$J) 177 Q 178 CALLBACK(IEN,NODE0,ARRAY,STOP) ; called back from ACRP Toolkit for encounters 179 ; 180 ; IEN and NODE0 relate to Outpatient Encounter File 181 ; set STOP to 1 if need to quit 182 ; 183 N COUNT,DTM,LOC,OOS,TYPE,XSTAT,XLOC 184 S DTM=+NODE0,COUNT=1 185 S LOC=$P(NODE0,"^",4) 186 S XLOC=$P($G(^SC(+LOC,0)),U),OOS=$G(^("OOS")) 187 I OOS Q ; ignore OOS locations 188 I $P(NODE0,"^",6) Q ; not parent encounter 189 S XSTAT=$P($G(^SD(409.63,+$P(NODE0,"^",12),0)),"^") 190 S TYPE=$S($P(NODE0,"^",8)=1:"A",1:"V") 191 I TYPE="V",$D(@ARRAY@(DTM,"V")) S COUNT=$O(@ARRAY@(DTM,"V","A"),-1)+1 ; same d/t 192 S @ARRAY@(DTM,TYPE,COUNT)=TYPE_";"_DTM_";"_LOC_U_DTM_U_XLOC_U_XSTAT 193 Q 194 DTLVST(RPT,DFN,IEN,APPTINFO) ; return progress notes / discharge summary 195 N VISIT 196 I $P(APPTINFO,";")="A" D Q 197 . S VISIT=$$APPT2VST^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3)) 198 . I VISIT=0 S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3)) 199 . D DETNOTE^ORQQVS(.RPT,DFN,VISIT) 200 I $P(APPTINFO,";")="V" D Q 201 . S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3)) 202 . D DETNOTE^ORQQVS(.RPT,DFN,VISIT) 203 I $P(APPTINFO,";")="I" D Q 204 . S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3)) 205 . D DETSUM^ORQQVS(.RPT,DFN,VISIT) 206 . K ^TMP("PXKENC",$J) 207 Q 208 X2FM(X) ; return FM date given relative date 209 N %DT S %DT="TS" D ^%DT 210 Q Y 211 RNGLAB(DFN) ; return days back for patient 212 N INPT,PAR 213 S INPT=0 I $L($G(^DPT(DFN,.1))) S INPT=1 214 S PAR="ORQQLR DATE RANGE "_$S(INPT:"INPT",1:"OUTPT") 215 Q $$GET^XPAR("ALL",PAR,1,"I") 216 ; 217 RNGVBEG() ; return start date for encounters 218 Q $$GET^XPAR("ALL","ORQQCSDR CS RANGE START",1,"I") 219 ; 220 RNGVEND() ; return stop date for encounters 221 Q $$GET^XPAR("ALL","ORQQCSDR CS RANGE STOP",1,"I") 222 ; 223 RANGES(REC,DFN) ; return ranges given a patient 224 N REC 225 S REC=$$RNGLAB(DFN)_U_$$RNGVBEG_U_$$RNGVEND 226 Q 1 ORWCV ; SLC/KCM - Background Cover Sheet Load; ;11/2/06 15:07 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,209,214,195,215,260**;Dec 17, 1997;Build 26 3 ; 4 ; DBIA 4011 Access ^XWB(8994) 5 ; DBIA 4313 Direct R/W permission to capacity mgmt global ^KMPTMP("KMPDT") 6 ; DBIA 10061 Reference to ^UTILITY 7 ; 8 START(VAL,DFN,IP,HWND,LOC,NODO,NEWREM) ; start cover sheet build in background 9 N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,SECT,BACK,X,I,ORLIST,STR,FILE,NODE,ORHTIME,ORX 10 ; Capacity planning timing code uses ORHTIME 11 S ORHTIME=$H 12 S LOC=$G(LOC),NODO=";"_$G(NODO),NEWREM=+$G(NEWREM) 13 D GETLST^XPAR(.ORX,"SYS^PKG","ORWOR COVER RETRIEVAL NEW","Q") 14 S I=0 F S I=$O(ORX(I)) Q:'I I $D(^ORD(101.24,+ORX(I),0)) S SECT(+$P(^(0),"^",2))=$P(ORX(I),"^",2) 15 D GETLST^XPAR(.ORLIST,"ALL","ORWCV1 COVERSHEET LIST") 16 S (VAL,BACK,STR,FILE)="" 17 F S I=$O(ORLIST(I)) Q:'I I $D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0) D 18 . Q:$P(X0,"^",8)'="C" 19 . S X=$P(X0,"^",2) 20 . I NODO[(";"_X_";") Q ; if in NODO, dont do section 21 . S STR=STR_X_";" 22 . I '$G(SECT(X)) S VAL=VAL_X_";" ; load section in foreground 23 . E S BACK=BACK_X_";",FILE=FILE_$P(ORLIST(I),"^",2)_";" ; load section in background 24 Q:BACK="" 25 S ZTIO="ORW THREAD RESOURCE",ZTRTN="BUILD^ORWCV",ZTDTH=$H 26 S (ZTSAVE("DFN"),ZTSAVE("IP"),ZTSAVE("HWND"),ZTSAVE("NEWREM"),ZTSAVE("LOC"),ZTSAVE("BACK"),ZTSAVE("FILE"))="" 27 S ZTDESC="CPRS GUI Background Data Retrieval" 28 D ^%ZTLOAD I '$D(ZTSK) S VAL=STR Q 29 S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN 30 K ^XTMP(NODE) 31 S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"Background CPRS "_ZTSK 32 ; Start capacity planning timing clock - will be stopped in POLL code 33 I +$G(^KMPTMP("KMPD-CPRS")) S ^KMPTMP("KMPDT","ORWCV",NODE)=$G(ORHTIME)_"^^"_$G(DUZ)_"^"_$G(IO("CLNM")) 34 Q 35 BUILD ; called in background by task manager, expects DFN, JobID 36 N NODE,IFLE,ORFNUM,ID,ENT,RTN,INODE,PARAM1,PARAM2,DETAIL,X0,X2 37 S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN 38 I $D(ZTQUEUED) S ZTREQ="@" 39 I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE) Q ; client no longer polling 40 I '$D(^XTMP(NODE,0)) Q ; XTMP node has been purged 41 L +^XTMP(NODE) 42 S ^XTMP(NODE,"DFN")=DFN 43 ;N $ETRAP,$ESTACK 44 ;S $ETRAP="D ERR^ORWCV Q" 45 I $L($G(FILE),";")>0 F IFLE=1:1:$L(FILE,";") S ORFNUM=$P(FILE,";",IFLE) Q:'$D(^ORD(101.24,+ORFNUM,0)) S X0=^(0),X2=$G(^(2)) D 46 . S ID=$P(X0,"^",2),ENT=$P(X0,"^",6),RTN=$P(X0,"^",5),PARAM1=$P(X2,"^"),PARAM2=$P(X2,"^",2),INODE=$P(X2,"^",5),DETAIL="" 47 . I $P(X0,"^",18) S DETAIL=$P($G(^ORD(101.24,+$P(X0,"^",18),0)),"^",13),DETAIL=$P($G(^XWB(8994,+DETAIL,0)),"^") ;DBIA 4011 48 . I '$L(INODE) Q 49 . I '$L(ENT) S LST(IFLE)="0^ERROR: Missing ENTRY POINT field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q 50 . I '$L(RTN) S LST(IFLE)="0^ERROR: Missing ROUTINE field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q 51 . I '$L($T(@(ENT_"^"_RTN))) S LST(IFLE)="0^ERROR: "_ENT_"~"_RTN_" does not exist. See file 101.24 entry: "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q 52 . I ID=50 D:$L($T(STRT3^AWCMCPR1)) STRT3^AWCMCPR1 D D:$L($T(END^AWCMCPR1)) END^AWCMCPR1 Q ;Special case for reminders 53 .. I $G(NEWREM) D APPL^ORQQPXRM(.LST,DFN,LOC) I 1 54 .. E D @(ENT_"^"_RTN_"(.LST,DFN)") 55 .. D LST2XTMP(INODE) 56 . I $L(PARAM1),$L(PARAM2) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1,PARAM2)"),LST2XTMP(INODE) Q 57 . I $L(PARAM1) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1)"),LST2XTMP(INODE) Q 58 . D @(ENT_"^"_RTN_"(.LST,DFN)"),LST2XTMP(INODE) 59 S ^XTMP(NODE,"DONE")=1 60 I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE) 61 L -^XTMP(NODE) 62 Q 63 ERR ;Error trap 64 S $ETRAP="D UNWIND^ORWCV Q" 65 I $D(NODE) D 66 . I $D(INODE) S LST(0)="",LST(1)="0^ERROR DURING COVER SHEET BUILD:"_$ZERROR D LST2XTMP(INODE) 67 . S ^XTMP(NODE,"DONE")=1 68 . L -^XTMP(NODE) 69 D @^%ZOSF("ERRTN") ;file error 70 S $ECODE=",UOR70 error during Cover Sheet build," 71 Q 72 UNWIND ;Unwind Error stack 73 Q:$ESTACK>1 ;pop the stack 74 ;add additional code here, if needed 75 Q 76 LST2XTMP(ID) ; put the list in ^XTMP(NODE,ID) 77 I $G(^XTMP(NODE,"STOP")) Q 78 N I 79 I $L($G(DETAIL)) S I=0 F S I=$O(LST(I)) Q:'I S $P(LST(I),"^",12)=DETAIL 80 K ^XTMP(NODE,ID) M ^XTMP(NODE,ID)=LST S ^XTMP(NODE,ID)=1 K LST 81 Q 82 POLL(LST,DFN,IP,HWND) ; poll for completed cover sheet parts 83 N I,ILST,ID,NODE,DONE 84 S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0 85 I '$D(^XTMP(NODE,"DFN")) Q 86 I ^XTMP(NODE,"DFN")'=DFN S LST(1)="~DONE=1" Q 87 I $G(^XTMP(NODE,"DONE")) S ILST=ILST+1,LST(ILST)="~DONE=1",DONE=1 88 F ID="PROB","CWAD","MEDS","RMND","LABS","VITL","VSIT" D 89 . I '$G(^XTMP(NODE,ID)) Q 90 . S ILST=ILST+1,LST(ILST)="~"_ID 91 . S I=0 F S I=$O(^XTMP(NODE,ID,I)) Q:'I S ILST=ILST+1,LST(ILST)="i"_^(I) 92 . K ^XTMP(NODE,ID) 93 ; Stop capacity planning timing clock - was started in START code 94 I DONE K ^XTMP(NODE) I +$G(^KMPTMP("KMPD-CPRS")) S $P(^KMPTMP("KMPDT","ORWCV",NODE),"^",2)=$H 95 Q 96 STOP(OK,DFN,IP,HWND) ; stop cover sheet data retrieval 97 S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0 98 S ^XTMP(NODE,"STOP")=1,OK=1 99 L +^XTMP(NODE) 100 I $G(^XTMP(NODE,"DONE")) K ^XTMP(NODE) 101 L -^XTMP(NODE) 102 Q 103 CLEAN ; clean up ^XTMP nodes 104 S X="ORWCV" 105 F S X=$O(^XTMP(X)) Q:$E(X,1,5)'="ORWCV" W !,X K ^XTMP(X) 106 Q 107 LAB(LST,DFN) ; return labs for patient 108 D:$L($T(STRT2^AWCMCPR1)) STRT2^AWCMCPR1 109 D LIST^ORQOR1(.LST,DFN,"LAB",4,"T-"_$$RNGLAB(DFN),"T","AW",1) 110 D:$L($T(END^AWCMCPR1)) END^AWCMCPR1 111 Q 112 ; 113 VST1(ORVISIT,DFN,BEG,END,SKIP) ; 114 N ERR,ERRMSG 115 S ERR=0 ; kludge to return errors 116 D VST(.ORVISIT,DFN,.BEG,.END,$G(SKIP),.ERR,.ERRMSG) 117 I ERR K ORVISIT S ORVISIT(1)=ERRMSG 118 Q 119 ; 120 TEST ;D VST(.ZZZ,76,2950101,3050401,777,1,1) 121 Q 122 VST(ORVISIT,DFN,BEG,END,SKIP,ERR,ERRMSG) ; return appts/admissions for patient 123 N CHECKERR,VAERR,VASD,BDT,COUNT,DTM,EDT,LOC,NOW,ORQUERY,ORLST,STI,STS,TODAY,I,J,K,XI,XE,X 124 S CHECKERR=($G(ERR)=0) ; kludge to check for errors 125 S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1) 126 I '$G(BEG) S BEG=$$X2FM($$RNGVBEG) 127 I '$G(END) S END=$$X2FM($$RNGVEND)+0.2359 128 S COUNT=0 129 K ^TMP("ORVSTLIST",$J) 130 S VAERR=0 131 I END>NOW D Q:VAERR ; get future encounters, past cancels/no-shows from VADPT 132 . S VASD("F")=BEG 133 . S VASD("T")=END 134 . S VASD("W")="123456789" 135 . D SDA^ORQRY01(.ERR,.ERRMSG) 136 . I CHECKERR,ERR K ^UTILITY("VASD",$J) S ORVISIT(1)=ERRMSG Q ;IA 10061 137 . S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D 138 . . S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E") 139 . . S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3) 140 . . S LOC=$P(XE,U,2),STS=$P(XE,U,3) 141 . . I DTM<TODAY,(STI=""!(STI["I")!(STI="NT")) Q ; no prior kept appts 142 . . S ^TMP("ORVSTLIST",$J,DTM,"A",1)="A;"_DTM_";"_IEN_U_DTM_U_LOC_U_STS 143 . K ^UTILITY("VASD",$J) 144 I BEG'>NOW D ;past encounters from ACRP Toolkit - set in CALLBACK 145 . S BDT=BEG 146 . S EDT=$S(END<NOW:END,1:NOW) 147 . D OPEN^SDQ(.ORQUERY) 148 . I '$$ERRCHK^SDQUT() D INDEX^SDQ(.ORQUERY,"PATIENT/DATE","SET") 149 . I '$$ERRCHK^SDQUT() D PAT^SDQ(.ORQUERY,DFN,"SET") 150 . I '$$ERRCHK^SDQUT() D DATE^SDQ(.ORQUERY,BDT,EDT,"SET") 151 . I '$$ERRCHK^SDQUT() D 152 . . S ORLST=$NA(^TMP("ORVSTLIST",$J)) 153 . . D SCANCB^SDQ(.ORQUERY,"D CALLBACK^ORWCV(Y,Y0,.ORLST,.ORSTOP)","SET") 154 . I '$$ERRCHK^SDQUT() D ACTIVE^SDQ(.ORQUERY,"TRUE","SET") 155 . I '$$ERRCHK^SDQUT() D SCAN^SDQ(.ORQUERY,"FORWARD") 156 . D CLOSE^SDQ(.ORQUERY) 157 ; 158 I '$G(SKIP) D 159 . N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,EARLY,DONE ; admits 160 . S EARLY=$$X2FM($$RNGVBEG),DONE=0 161 . S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D Q:DONE 162 . . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D Q:DONE 163 . . . S X0=^DGPM(MOV,0),MTIM=$P(X0,U) 164 . . . I MTIM<EARLY S DONE=1 Q 165 . . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1) 166 . . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44)) 167 . . . S ^TMP("ORVSTLIST",$J,MTIM,"I",1)="I;"_MTIM_";"_HLOC_U_MTIM_U_"Inpatient Stay"_U_XLOC_U_XTYP 168 ; 169 S COUNT=0 170 S I=0 F S I=$O(^TMP("ORVSTLIST",$J,I)) Q:'I D 171 . S J="" F S J=$O(^TMP("ORVSTLIST",$J,I,J)) Q:J="" D 172 . . S K=0 F S K=$O(^TMP("ORVSTLIST",$J,I,J,K)) Q:'K D 173 . . . S COUNT=COUNT+1 174 . . . S ORVISIT(COUNT)=^TMP("ORVSTLIST",$J,I,J,K) 175 K ^TMP("ORVSTLIST",$J) 176 Q 177 CALLBACK(IEN,NODE0,ARRAY,STOP) ; called back from ACRP Toolkit for encounters 178 ; 179 ; IEN and NODE0 relate to Outpatient Encounter File 180 ; set STOP to 1 if need to quit 181 ; 182 N COUNT,DTM,LOC,OOS,TYPE,XSTAT,XLOC 183 S DTM=+NODE0,COUNT=1 184 S LOC=$P(NODE0,"^",4) 185 S XLOC=$P($G(^SC(+LOC,0)),U),OOS=$G(^("OOS")) 186 I OOS Q ; ignore OOS locations 187 I $P(NODE0,"^",6) Q ; not parent encounter 188 S XSTAT=$P($G(^SD(409.63,+$P(NODE0,"^",12),0)),"^") 189 S TYPE=$S($P(NODE0,"^",8)=1:"A",1:"V") 190 I TYPE="V",$D(@ARRAY@(DTM,"V")) S COUNT=$O(@ARRAY@(DTM,"V","A"),-1)+1 ; same d/t 191 S @ARRAY@(DTM,TYPE,COUNT)=TYPE_";"_DTM_";"_LOC_U_DTM_U_XLOC_U_XSTAT 192 Q 193 DTLVST(RPT,DFN,IEN,APPTINFO) ; return progress notes / discharge summary 194 N VISIT 195 I $P(APPTINFO,";")="A" D Q 196 . S VISIT=$$APPT2VST^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3)) 197 . I VISIT=0 S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3)) 198 . D DETNOTE^ORQQVS(.RPT,DFN,VISIT) 199 I $P(APPTINFO,";")="V" D Q 200 . S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3)) 201 . D DETNOTE^ORQQVS(.RPT,DFN,VISIT) 202 I $P(APPTINFO,";")="I" D Q 203 . S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3)) 204 . D DETSUM^ORQQVS(.RPT,DFN,VISIT) 205 . K ^TMP("PXKENC",$J) 206 Q 207 X2FM(X) ; return FM date given relative date 208 N %DT S %DT="TS" D ^%DT 209 Q Y 210 RNGLAB(DFN) ; return days back for patient 211 N INPT,PAR 212 S INPT=0 I $L($G(^DPT(DFN,.1))) S INPT=1 213 S PAR="ORQQLR DATE RANGE "_$S(INPT:"INPT",1:"OUTPT") 214 Q $$GET^XPAR("ALL",PAR,1,"I") 215 ; 216 RNGVBEG() ; return start date for encounters 217 Q $$GET^XPAR("ALL","ORQQCSDR CS RANGE START",1,"I") 218 ; 219 RNGVEND() ; return stop date for encounters 220 Q $$GET^XPAR("ALL","ORQQCSDR CS RANGE STOP",1,"I") 221 ; 222 RANGES(REC,DFN) ; return ranges given a patient 223 N REC 224 S REC=$$RNGLAB(DFN)_U_$$RNGVBEG_U_$$RNGVEND 225 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWD.m
r613 r623 1 ORWD ; SLC/KCM - Utilities for Windows Dialogs ;7/2/01 13:312 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242 3 4 DT(Y,X) 5 6 7 PROVKEY(VAL,USERID) 8 9 10 11 KEY(VAL,KEYNAME,USERID) 12 13 14 OI(Y,XREF,DIR,FROM) 15 16 17 18 19 20 21 22 23 24 25 26 27 ODEF(Y,DLG) 28 29 30 31 32 33 34 35 36 37 DEF(Y,DLG) 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 FORMID(VAL,ORIFN) 55 56 57 58 59 60 61 62 GET4EDIT(LST,ORIFN) 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 EXTDT(X) 80 81 82 83 WRLST(Y,TYP) 84 85 86 87 88 89 90 91 92 93 SAVE(Y,DFN,ORNP,LOC,DLG,ORWDACT,RSP) 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 SIGN(ERRLST,DFN,ORNP,LOC,ORWSIGN) 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 VALIDACT(VAL,ORIFN,ACTION) 126 127 128 129 130 SAVEACT(LST,ORIFN,ACTION,REASON,DFN,ORNP,LOC) 131 132 133 134 135 136 137 138 139 140 141 . D CANCEL^ORCSAVE2(ORIFN)142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 1 ORWD ; SLC/KCM - Utilities for Windows Dialogs ;7/26/96 17:53 [ 11/19/96 4:27 PM ] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 3 ; 4 DT(Y,X) ; Returns internal Fileman Date/Time 5 N %DT S %DT="TS" D ^%DT 6 Q 7 PROVKEY(VAL,USERID) ; Returns 1 if user possesses the provider key 8 N NAM S NAM=$P(^VA(200,USERID,0),U,1) 9 S VAL=$D(^VA(200,"AK.PROVIDER",NAM,USERID)) 10 Q 11 KEY(VAL,KEYNAME,USERID) ; Returns 1 if user possesses the key 12 S VAL=0 I $D(^XUSEC(KEYNAME,USERID)) S VAL=1 13 Q 14 OI(Y,XREF,DIR,FROM) ; Return a bolus of orderable items 15 ; .Return Array, Cross Reference (S.xxx), Direction, Starting Text 16 N I,IEN,CNT S CNT=44 17 ; 18 I DIR=0 D ; Forward direction 19 . F I=1:1:CNT S FROM=$O(^ORD(101.43,XREF,FROM)) Q:FROM="" D 20 . . S Y(I)=$O(^ORD(101.43,XREF,FROM,0))_"^"_FROM 21 . I $G(Y(CNT))="" S Y(I)="" 22 ; 23 I DIR=1 D ; Reverse direction 24 . F I=1:1:CNT S FROM=$O(^ORD(101.43,XREF,FROM),-1) Q:FROM="" D 25 . . S Y(I)=$O(^ORD(101.43,XREF,FROM,0))_"^"_FROM 26 Q 27 ODEF(Y,DLG) ; Return the definition for a dialog 28 Q:'$L(DLG) 29 S DLG=+$O(^ORD(101.41,"B",DLG,0)) 30 Q:$D(^ORD(101.41,DLG,50))<10 31 N I,IEN,IDX 32 S I=0,IDX=0 33 S Y(0)=$P($G(^ORD(101.41,DLG,5)),"^",4) 34 F S I=$O(^ORD(101.41,DLG,50,"AC",I)) Q:I="" S IEN=$O(^(I,0)) D 35 . S IDX=IDX+1,Y(IDX)=$G(^ORD(101.41,DLG,50,IEN,0)) 36 Q 37 DEF(Y,DLG) ; Return format mapping for a dialog 38 ; Y(n): CtrlName^DlgPtr^FmtSeq^Fmt^Omit^Lead^Trail^Mult?^chd1~chd2~... 39 I DLG="NOT IMPLEMENTED" S Y(0)="0^0" Q ; for testing 40 S DLG=$O(^ORD(101.41,"B",DLG,0)) 41 N I,J,K,N,X0,X2,XW,DPTR 42 S Y(0)=$P(^ORD(101.41,DLG,0),U,5)_U_DLG 43 S I=0,N=0 44 F S I=$O(^ORD(101.41,DLG,10,I)) Q:I'>0 D 45 . S X0=$G(^ORD(101.41,DLG,10,I,0)),DPTR=$P(X0,U,2) 46 . S X2=$G(^ORD(101.41,DLG,10,I,2)) 47 . S XW=$G(^ORD(101.41,DLG,10,I,"W")) 48 . S N=N+1,Y(N)=$P(XW,U,1)_U_DPTR_U_X2,CHLD="" 49 . S J=0 F S J=$O(^ORD(101.41,DLG,10,"DAD",DPTR,J)) Q:'J D 50 . . S K=0 F S K=$O(^ORD(101.41,DLG,10,"DAD",DPTR,J,K)) Q:'K D 51 . . . S CHLD=CHLD_$P(^ORD(101.41,DLG,10,K,0),U,2)_"~" 52 . S $P(Y(N),U,8)=CHLD 53 Q 54 FORMID(VAL,ORIFN) ; procedure 55 ; Returns the Dialog Form ID 56 N X 57 S VAL=0,X=$P(^OR(100,+ORIFN,0),U,5) 58 Q:$P(X,";",2)'="ORD(101.41," 59 S VAL=+$P($G(^ORD(101.41,+X,5)),U,5) 60 ; I X S VAL=$P($G(^XTV(8989.52,+X,0)),U,2) 61 Q 62 GET4EDIT(LST,ORIFN) ; procedure 63 ; return responses in format that can be used by dialog 64 N ILST,PRMT,INST,DLG,ORDIALOG S ILST=0 65 I '$D(ORIFN) S LST=0 Q 66 S ORIFN=+ORIFN,DLG=+$P(^OR(100,ORIFN,0),U,5) 67 D GETDLG1^ORCD(DLG),GETORDER^ORCD("^OR(100,"_ORIFN_",4.5)") 68 S PRMT=0 F S PRMT=$O(ORDIALOG(PRMT)) Q:'PRMT D 69 . S INST=0 F S INST=$O(ORDIALOG(PRMT,INST)) Q:'INST D 70 . . S ILST=ILST+1,LST(ILST)="~"_PRMT_U_INST_U_$P(ORDIALOG(PRMT),U,3) 71 . . S ILST=ILST+1,LST(ILST)="d"_ORDIALOG(PRMT,INST) 72 . . I $E(ORDIALOG(PRMT,INST))=U D ; load word processing 73 . . . N I,REF S I=0,REF=ORDIALOG(PRMT,INST) 74 . . . F S I=$O(@REF@(I)) Q:'I S ILST=ILST+1,LST(ILST)="t"_^(I,0) 75 . . E S $P(LST(ILST),U,2)=$$EXT^ORCD(PRMT,INST) ; load external value 76 . . I "R"[$E(ORDIALOG(PRMT,0)) D 77 . . . S $P(LST(ILST),U,2)=$$UP^XLFSTR($$FMTE^XLFDT(ORDIALOG(PRMT,INST))) 78 Q 79 EXTDT(X) ; Return an external date time that can be interpreted by %DT 80 I $E(X)="T" Q "TODAY"_$E(X,2,255) 81 I $E(X)="V" Q "NEXT VISIT"_$E(X,2,255) 82 Q "" 83 WRLST(Y,TYP) ; Return list of dialogs for writing orders 84 ; .Y(n): DlgName^ListBox Text 85 ; TYP: 'I' = inpatient, 'O' = outpatient 86 N PAR,ERR,SEQ,IEN,I,X 87 S PAR=$S(TYP="I":"ORW ADDORD INPT",1:"ORW ADDORD OUTPT") 88 D GETLST^XPAR(.X,"ALL",PAR,"Q",.ERR) Q:ERR 89 S I=0 F S I=$O(X(I)) Q:'I D 90 . S SEQ=$P(X(I),U,1),IEN=$P(X(I),U,2) 91 . S Y(SEQ)=$P(^ORD(101.41,IEN,0),U,1)_U_$P($G(^(5)),U,4) 92 Q 93 SAVE(Y,DFN,ORNP,LOC,DLG,ORWDACT,RSP) ; procedure 94 ; Save order 95 N ORDIALOG,ORL,ORVP,ORIFN,ORDUZ,ORSTS,ORDG,OREVENT,ORCAT,ORDA 96 I $P(^ORD(101.41,+DLG,0),U)="PSO OERR" S ORCAT="O" 97 I $P(^ORD(101.41,+DLG,0),U)="PSJ OR PAT OE" S ORCAT="I" 98 S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(",ORL=ORL(2) 99 D GETDLG^ORCD(DLG) 100 M ORDIALOG=RSP S ORDIALOG=DLG 101 I ORWDACT="N" D 102 . D EN^ORCSAVE 103 . S Y="" I ORIFN D GETBYIFN^ORWORR(.Y,ORIFN) 104 I $P(ORWDACT,U,1)="E" D 105 . S ORIFN=+$P(ORWDACT,U,2) D XX^ORCSAVE 106 . S Y="" S ORIFN=+$P(ORWDACT,U,2)_";"_ORDA D GETBYIFN^ORWORR(.Y,ORIFN) 107 Q 108 SIGN(ERRLST,DFN,ORNP,LOC,ORWSIGN) ; procedure 109 ; Sign orders (ORIFN;ACT^RELSTS^SIGSTS^NATR) 110 N ORVP,ORL,IDX,ANERROR,ERRCNT 111 S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(",ORL=ORL(2),ERRCNT=0 112 I '$D(^XUSEC("ORES",DUZ)) S ERRLST(1)=0_U_"Must have ORES key." Q 113 S IDX=0 F S IDX=$O(ORWSIGN(IDX)) Q:'IDX S X=ORWSIGN(IDX) D 114 . ; ** change NATR when GUI changed to pass Nature in 4th piece 115 . S ORIFN=$P(X,U),RELSTS=$P(X,U,2),SIGSTS=$P(X,U,3),NATR="E" ;$P(X,U,4) 116 . I SIGSTS=2 D NOTIF^ORCSIGN S ANERROR="" 117 . I SIGSTS'=2 D EN^ORCSEND(ORIFN,"",SIGSTS,RELSTS,NATR,"",.ANERROR) 118 . I $L(ANERROR) D Q ; don't print if an error occurred 119 . . S ERRCNT=ERRCNT+1,ERRLST(ERRCNT)=$P(ORWSIGN(IDX),U)_U_ANERROR 120 . . K ORWSIGN(IDX) 121 . I RELSTS=0 K ORWSIGN(IDX) Q ; don't print if unreleased 122 . S ORWSIGN(IDX)=$P(ORWSIGN(IDX),U) 123 D PRINTS^ORWD1(.ORWSIGN,LOC) 124 Q 125 VALIDACT(VAL,ORIFN,ACTION) ;procedure 126 ; Return 1 if action is valid for this order, otherwise 0^error 127 S VAL=$$VALID^ORCACT0(ORIFN,ACTION,.ERR) 128 I VAL=0 S VAL=VAL_U_ERR 129 Q 130 SAVEACT(LST,ORIFN,ACTION,REASON,DFN,ORNP,LOC) ;procedure 131 ; Save this action for the order (it is still unsigned/unreleased) 132 N ORDIALOG,ORL,ORVP,ORDUZ,ORSTS,ORDG,OREVENT,ACTDA,SIGSTS,RELSTS,ASTS 133 S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(" 134 S SIGSTS=2,RELSTS=11 135 I '$P(ORIFN,";",2) S $P(ORIFN,";",2)=1 136 I (ACTION="FL")!(ACTION="UF")!(ACTION="WC") S SIGSTS=3,RELSTS="" 137 S ASTS=$P(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),0),U,15) 138 I ACTION="DC",((ASTS=10)!(ASTS=11)) D Q ; exit here if DELETE 139 . D GETBYIFN^ORWORR(.LST,ORIFN) 140 . S $P(LST(1),U,1)="~0",LST(2)="tDELETED - "_$E(LST(2),2,245) 141 . D DELETE^ORCSAVE2(ORIFN) 142 ; 143 ; the only valid action for ActDA>1 is deletion, so only orders 144 ; identified by ORIFN;1 should reach this point 145 ; 146 I $P(ORIFN,";",2)>1 S $ECODE=",Uorder action invalid," Q 147 I ACTION="FL" S $P(^OR(100,+ORIFN,6),U,1)=1 148 I ACTION="UF" S $P(^OR(100,+ORIFN,6),U,1)=0 149 I ACTION'="RN" D 150 . S ACTDA=$$ACTION^ORCSAVE(ACTION,+ORIFN,ORNP,REASON) 151 I ACTION="RN" D 152 . N ORDA,ORDIALOG,PRMT,SAVIFN,X0 153 . S SAVIFN=+ORIFN,X0=^OR(100,+ORIFN,0) 154 . I $P(X0,U,5)["101.41," D ; version 3 155 . . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12) 156 . . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN) 157 . E D ; version 2.5 generic 158 . . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0)) 159 . . D GETDLG^ORCD(ORDIALOG) 160 . . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0)) 161 . . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1)) 162 . . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1) 163 . . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) 164 . . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9) 165 . D RN^ORCSAVE I 'ORIFN S $ECODE=",UCPRS renew order," 166 . S ACTDA=ORDA,ORIFN=SAVIFN 167 I (ACTION="FL")!(ACTION="UF") S ACTDA=1 168 D GETBYIFN^ORWORR(.LST,+ORIFN_";"_ACTDA) 169 S $P(LST(1),U,12)=ACTDA 170 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDAL32.m
r613 r623 1 ORWDAL32 ; SLC/REV - Allergy calls to support windows ;5/31/05 14:14 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,190,195,233,243**;Dec 17, 1997;Build 242 3 ; 4 DEF(LST) ; Get dialog data for allergies 5 N ILST,I,X S ILST=0 6 S LST($$NXT)="~Allergy Types" D ALLGYTYP 7 S LST($$NXT)="~Reactions" D ALLGYTYP 8 S LST($$NXT)="~Nature of Reaction" D NATREACT 9 S LST($$NXT)="~Top Ten" D TOPTEN 10 S LST($$NXT)="~Observ/Hist" D OBSHIST 11 S LST($$NXT)="~Severity" D SEVERITY 12 Q 13 GMRASITE(ORY) ;Return GMRA Site Params 14 N GMRASITE 15 D SITE^GMRAUTL 16 S ORY=$G(^GMRD(120.84,GMRASITE,0)) 17 Q 18 TOPTEN ; Get top ten symptoms from Allergy Site Parameters file 19 N X0,I,CNT,GMRASITE S I=0,X0="",CNT=0 ;233 20 D SITE^GMRAUTL ;233 21 F S I=$O(^GMRD(120.84,GMRASITE,1,I)),CNT=CNT+1 Q:+I=0!(CNT>10) D ;233 22 . S X0=^GMRD(120.84,GMRASITE,1,I,0) Q:'$D(^GMRD(120.83,X0)) Q:$P(^GMRD(120.83,X0,0),"^")="OTHER REACTION" ;233 Don't send this entry 23 . ;233 Don't send if inactive term 24 . I $L($T(SCREEN^XTID)) Q:$$SCREEN^XTID(120.83,.01,X0_",") 25 . S LST($$NXT)="i"_X0_U_$P($G(^GMRD(120.83,X0,0)),U,1) 26 Q 27 ALLSRCH(Y,X) ; Return list of partial matches ; CHANGED TO PRODUCE TREEVIEW IN GUI 28 N ORX,ROOT,XP,CNT,ORFILE,ORSRC,ORIEN,ORREAX S ORIEN=0,CNT=0,ORSRC=0,ORFILE="" 29 S ORX=X,X=$$UP^XLFSTR(X) 30 F ROOT="^GMRD(120.82,""B"")","^GMRD(120.82,""D"")",$$B^PSNAPIS,$$T^PSNAPIS,"^PSDRUG(""B"")","^PSDRUG(""C"")","^PS(50.416,""P"")","^PS(50.605,""C"")" D 31 . S ORSRC=$G(ORSRC)+1,ORFILE=$P(ROOT,",",1)_")",ORSRC(ORSRC)=$P($T(FILENAME+ORSRC),";;",2) 32 . I (ORSRC'=2),(ORSRC'=6) S CNT=CNT+1,Y(CNT)=ORSRC_U_ORSRC(ORSRC)_U_U_U_"TOP"_U_"+" 33 . I ORSRC=1!(ORSRC=2) D 34 .. I $D(@ROOT@(X)) D 35 ... I ORSRC=1,X="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry 36 ... S ORIEN=$O(@ROOT@(X,0)) 37 ... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.82,.01,ORIEN_",") Q ;233 Is term active? 38 ... I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_X_">"_ROOT 39 ... I ORSRC'=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_X_ROOT 40 ... S Y(CNT)=Y(CNT)_U_$P($G(^GMRD(120.82,+Y(CNT),0)),U,2)_U_$S(ORSRC=2:1,1:ORSRC) 41 .. S XP=X F S XP=$O(@ROOT@(XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X D 42 ... I ORSRC=1,XP="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry 43 ... S ORIEN=$O(@ROOT@(XP,0)) 44 ... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.82,.01,ORIEN_",") Q ;233 Is term active? 45 ... I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_XP_">"_ROOT ; partial matches 46 ... I ORSRC'=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_XP_ROOT 47 ... S Y(CNT)=Y(CNT)_U_$P($G(^GMRD(120.82,+Y(CNT),0)),U,2)_U_$S(ORSRC=2:1,1:ORSRC) 48 . I (ORSRC>2),(ORSRC'=4),(ORSRC'=5),(ORSRC'=6) D 49 .. N CODE,LIST,VAL,NAME 50 .. S CODE=$S(ORSRC=3:"S VAL=$$TGTOG2^PSNAPIS(X,.LIST)",ORSRC=4:"D TRDNAME(X,.LIST)",ORSRC=7:"D INGSRCH(X,.LIST)",ORSRC=8:"D CLASRCH(X,.LIST)",1:"") Q:'$L(CODE) 51 .. X CODE I $D(LIST) S ORIEN=0 F S ORIEN=$O(LIST(ORIEN)) Q:'ORIEN D 52 ... S NAME=$P(LIST(ORIEN),U,2) 53 ... Q:$E($P(LIST(ORIEN),U,2),1,$L(X))'=X 54 ... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID($S(ORSRC=3:50.6,(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,ORIEN_",") Q 55 ... S CNT=CNT+1,Y(CNT)=ORIEN_U_NAME_ROOT_U_"D"_U_ORSRC 56 . I ORSRC=4 D 57 .. N CODE,LIST,VAL,NAME 58 .. S CODE="D TRDNAME(X,.LIST)" 59 .. X CODE I $D(LIST) S ORIEN=0 F S ORIEN=$O(LIST(ORIEN)) Q:'ORIEN D 60 ... S NAME=$P(LIST(ORIEN),U,2) 61 ... Q:$E($P(LIST(ORIEN),U,2),1,$L(X))'=X 62 ... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(50.6,.01,+LIST(ORIEN)_",") Q 63 ... S CNT=CNT+1,Y(CNT)=+LIST(ORIEN)_U_NAME_ROOT_U_"D"_U_ORSRC 64 Q 65 FILENAME ; Display text of filenames for search treeview 66 ;;VA Allergies File 67 ;;VA Allergies File (Synonyms) SPACER ONLY - NOT DISPLAYED 68 ;;National Drug File - Generic Drug Name 69 ;;National Drug file - Trade Name 70 ;;Local Drug File 71 ;;Local Drug File (Synonyms) SPACER ONLY - NOT DISPLAYED 72 ;;Drug Ingredients File 73 ;;VA Drug Class File 74 ;; 75 NATREACT ; Get the NATURE OF REACTION types 76 ;Removing "R^Adverse Reaction" from choices below until we can add it as a choice in the nature of reaction/mechanism file 77 F X="A^Allergy","P^Pharmacological","U^Unknown" D 78 . S LST($$NXT)="i"_X 79 Q 80 ALLGYTYP ; Get the allergy types 81 F X="D^Drug","F^Food","O^Other","DF^Drug,Food","DO^Drug,Other","FO^Food,Other","DFO^Drug,Food,Other" D 82 . S LST($$NXT)="i"_X 83 Q 84 OBSHIST ; Observed or historical 85 F X="o^Observed","h^Historical" D 86 . S LST($$NXT)="i"_X 87 Q 88 SEVERITY ; Severity 89 F X="3^Severe","2^Moderate","1^Mild" D 90 . S LST($$NXT)="i"_X 91 Q 92 SYMPTOMS(Y,FROM,DIR) ; Return a subset of symptoms 93 ; .Return Array, Starting Text, Direction 94 N I,IEN,CNT,X,NAME,SUB S I=0,CNT=44 ;233 95 K ^TMP($J,"SIGNS") ;233 96 ;The following lines were added in 233. Now accounts for synonyms 97 M ^TMP($J,"SIGNS","B")=^GMRD(120.83,"B") ;233 98 S SYN="" F S SYN=$O(^GMRD(120.83,"D",SYN)) Q:SYN="" S SUB=0 F S SUB=$O(^GMRD(120.83,"D",SYN,SUB)) Q:'+SUB D ;233 99 .S NAME=$P(^GMRD(120.83,SUB,0),U) S ^TMP($J,"SIGNS","B",(SYN_$C(9)_"<"_NAME_">"_U_NAME),SUB)="" ;233 100 F Q:I'<CNT S FROM=$O(^TMP($J,"SIGNS","B",FROM),DIR) Q:FROM="" D ;233 101 . I FROM="OTHER REACTION" Q ;Don't send this entry 102 . S IEN=0 F S IEN=$O(^TMP($J,"SIGNS","B",FROM,IEN)) Q:'IEN D ;233 103 . . I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.83,.01,IEN_",") Q ;233 Is term active 104 . . S I=I+1 105 . . S Y(I)=IEN_U_FROM 106 Q 107 NXT() ; Increment index of LST 108 S ILST=ILST+1 109 Q ILST 110 EDITLOAD(Y,ORALIEN) ; Load an allergy/adverse reaction for editing 111 Q:+$G(ORALIEN)=0 112 N ORNODE,I 113 S ORNODE=$NAME(^TMP("GMRA",$J)),I=0 114 ;following patch check is made via GUI RPC call to ORWU PATCH instead 115 ;I '$$PATCH^XPDUTL("GMRA*4.0*21") S @ORNODE@(0)="-1^Not yet implemented",Y=ORNODE Q 116 D GETREC^GMRAGUI(ORALIEN,ORNODE) 117 S Y=ORNODE 118 Q 119 EDITSAVE(ORY,ORALIEN,ORDFN,OREDITED) ; Save Edit/Add of an allergy/adverse reaction 120 ;following patch check is made via GUI RPC call to ORWU PATCH instead 121 ;I '$$PATCH^XPDUTL("GMRA*4.0*21") S Y="-1^Not yet implemented" Q 122 N ORNODE 123 S ORNODE=$NAME(^TMP("GMRA",$J)) 124 K @ORNODE M @ORNODE=OREDITED 125 S ORY=0 126 I $G(@ORNODE@("GMRAERR"))="YES" D EIE^GMRAGUI1(ORALIEN,ORDFN,ORNODE) Q ;Handle entered in error 127 I $G(@ORNODE@("GMRANKA"))="YES" D NKA^GMRAGUI1 Q 128 D UPDATE^GMRAGUI1(ORALIEN,ORDFN,ORNODE) Q ;Add/edit reactions 129 Q 130 SENDBULL(Y,ORDUZ,ORDFN,ORTEXT,ORCMTS) ; Send bulletin if user attempts free-text entry 131 I '$D(ORCMTS) D 132 . S Y=$$SENDREQ^GMRAPES0(ORDUZ,ORDFN,ORTEXT) 133 E D 134 . S Y=$$SENDREQ^GMRAPES0(ORDUZ,ORDFN,ORTEXT,.ORCMTS) 135 Q 136 INGSRCH(NAME,LIST) ; 137 K ^TMP($J,"ORWDAL32") 138 D NAME^PSN50P41(NAME,"ORWDAL32") 139 I $D(^TMP($J,"ORWDAL32","P")) D 140 . N I S I="" F S I=$O(^TMP($J,"ORWDAL32","P",I)) Q:I="" D 141 .. N J S J=0 F S J=$O(^TMP($J,"ORWDAL32","P",I,J)) Q:'J S LIST(J)=J_U_I 142 K ^TMP($J,"ORWDAL32") 143 Q 144 CLASRCH(NAME,LIST) ; 145 K ^TMP($J,"ORWDAL32") 146 D C^PSN50P65(,NAME,"ORWDAL32") 147 I $D(^TMP($J,"ORWDAL32","C")) D 148 . N I S I="" F S I=$O(^TMP($J,"ORWDAL32","C",I)) Q:I="" D 149 .. N J S J=0 F S J=$O(^TMP($J,"ORWDAL32","C",I,J)) Q:'J S LIST(J)=J_U_$G(^TMP($J,"ORWDAL32",J,1)) 150 K ^TMP($J,"ORWDAL32") 151 Q 152 TRDNAME(NAME,LIST) ; 153 K ^TMP($J,"ORWDAL32") 154 D ALL^PSN5067(,NAME,,"ORWDAL32") 155 I $D(^TMP($J,"ORWDAL32","B")) D 156 . N I S I="" F S I=$O(^TMP($J,"ORWDAL32","B",I)) Q:I="" D 157 .. N J,K S J=$O(^TMP($J,"ORWDAL32","B",I,0)) Q:'J S K=$$TGTOG^PSNAPIS(I),LIST(J)=K_U_$G(^TMP($J,"ORWDAL32",J,4)) 158 K ^TMP($J,"ORWDAL32") 159 Q 1 ORWDAL32 ; SLC/REV - Allergy calls to support windows ;5/31/05 14:14 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,190,195,233**;Dec 17, 1997 3 ; 4 DEF(LST) ; Get dialog data for allergies 5 N ILST,I,X S ILST=0 6 S LST($$NXT)="~Allergy Types" D ALLGYTYP 7 S LST($$NXT)="~Reactions" D ALLGYTYP 8 S LST($$NXT)="~Nature of Reaction" D NATREACT 9 S LST($$NXT)="~Top Ten" D TOPTEN 10 S LST($$NXT)="~Observ/Hist" D OBSHIST 11 S LST($$NXT)="~Severity" D SEVERITY 12 Q 13 GMRASITE(ORY) ;Return GMRA Site Params 14 N GMRASITE 15 D SITE^GMRAUTL 16 S ORY=$G(^GMRD(120.84,GMRASITE,0)) 17 Q 18 TOPTEN ; Get top ten symptoms from Allergy Site Parameters file 19 N X0,I,CNT,GMRASITE S I=0,X0="",CNT=0 ;233 20 D SITE^GMRAUTL ;233 21 F S I=$O(^GMRD(120.84,GMRASITE,1,I)),CNT=CNT+1 Q:+I=0!(CNT>10) D ;233 22 . S X0=^GMRD(120.84,GMRASITE,1,I,0) Q:'$D(^GMRD(120.83,X0)) Q:$P(^GMRD(120.83,X0,0),"^")="OTHER REACTION" ;233 Don't send this entry 23 . I $L($T(SCREEN^XTID)) Q:$$SCREEN^XTID(120.83,.01,X0_",") ;233 Don't send if inactive term 24 . S LST($$NXT)="i"_X0_U_$P($G(^GMRD(120.83,X0,0)),U,1) 25 Q 26 ALLSRCH(Y,X) ; Return list of partial matches ; CHANGED TO PRODUCE TREEVIEW IN GUI 27 N ORX,ROOT,XP,CNT,ORFILE,ORSRC,ORIEN,ORREAX S ORIEN=0,CNT=0,ORSRC=0,ORFILE="",ORREAX="" 28 S ORX=X,X=$$UP^XLFSTR(X) 29 F ROOT="^GMRD(120.82,""B"")","^GMRD(120.82,""D"")",$$B^PSNAPIS,$$T^PSNAPIS,"^PSDRUG(""B"")","^PSDRUG(""C"")","^PS(50.416,""P"")","^PS(50.605,""C"")" D 30 . S ORSRC=ORSRC+1,ORFILE=$P(ROOT,",",1)_")",ORSRC(ORSRC)=$P($T(FILENAME+ORSRC),";;",2) 31 . I (ORSRC'=2),(ORSRC'=6) S CNT=CNT+1,Y(CNT)=ORSRC_U_ORSRC(ORSRC)_U_U_U_"TOP"_U_"+" 32 . I $D(@ROOT@(X)) D 33 . . I ORSRC=1,X="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry 34 . . I ORSRC=5!(ORSRC=6) Q ;233 don't send file 50 entries 35 . . S ORIEN=$O(@ROOT@(X,0)) 36 . . I $L($T(SCREEN^XTID)) I $$SCREEN^XTID($S(ORSRC=1!(ORSRC=2):120.82,ORSRC=3!(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,$S(ORSRC=4:$$TGTOG^PSNAPIS(X)_",",1:ORIEN_",")) Q ;233 Is term active? 37 . . I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_X_">"_ROOT 38 . . E I ORSRC=6 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^PSDRUG(+ORIEN,0)),U,1)_" <"_X_">"_ROOT 39 . . E S CNT=CNT+1,Y(CNT)=ORIEN_U_X_ROOT 40 . . S ORREAX=$S($P(Y(CNT),U,3)?1"GMR".E:$P($G(^GMRD(120.82,+Y(CNT),0)),U,2),1:"D") 41 . . S Y(CNT)=Y(CNT)_U_ORREAX_U_$S(ORSRC=2:1,ORSRC=6:5,1:ORSRC) 42 . S XP=X F S XP=$O(@ROOT@(XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X D 43 . . I ORSRC=1,XP="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry 44 . . I ORSRC=5!(ORSRC=6) Q ;233 Don't send file 50 entries 45 . . S ORIEN=$O(@ROOT@(XP,0)) 46 . . I $L($T(SCREEN^XTID)) I $$SCREEN^XTID($S(ORSRC=1!(ORSRC=2):120.82,ORSRC=3!(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,$S(ORSRC=4:$$TGTOG^PSNAPIS(XP)_",",1:ORIEN_",")) Q ;233 Is term active? 47 . . I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_XP_">"_ROOT ; partial matches 48 . . E I ORSRC=6 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^PSDRUG(+ORIEN,0)),U,1)_" <"_XP_">"_ROOT ; partial matches 49 . . E S CNT=CNT+1,Y(CNT)=ORIEN_U_XP_ROOT 50 . . S ORREAX=$S($P(Y(CNT),U,3)?1"GMR".E:$P($G(^GMRD(120.82,+Y(CNT),0)),U,2),1:"D") 51 . . S Y(CNT)=Y(CNT)_U_ORREAX_U_$S(ORSRC=2:1,ORSRC=6:5,1:ORSRC) 52 Q 53 FILENAME ; Display text of filenames for search treeview 54 ;;VA Allergies File 55 ;;VA Allergies File (Synonyms) SPACER ONLY - NOT DISPLAYED 56 ;;National Drug File - Generic Drug Name 57 ;;National Drug file - Trade Name 58 ;;Local Drug File 59 ;;Local Drug File (Synonyms) SPACER ONLY - NOT DISPLAYED 60 ;;Drug Ingredients File 61 ;;VA Drug Class File 62 ;; 63 NATREACT ; Get the NATURE OF REACTION types 64 ;Removing "R^Adverse Reaction" from choices below until we can add it as a choice in the nature of reaction/mechanism file 65 F X="A^Allergy","P^Pharmacological","U^Unknown" D 66 . S LST($$NXT)="i"_X 67 Q 68 ALLGYTYP ; Get the allergy types 69 F X="D^Drug","F^Food","O^Other","DF^Drug,Food","DO^Drug,Other","FO^Food,Other","DFO^Drug,Food,Other" D 70 . S LST($$NXT)="i"_X 71 Q 72 OBSHIST ; Observed or historical 73 F X="o^Observed","h^Historical" D 74 . S LST($$NXT)="i"_X 75 Q 76 SEVERITY ; Severity 77 F X="3^Severe","2^Moderate","1^Mild" D 78 . S LST($$NXT)="i"_X 79 Q 80 SYMPTOMS(Y,FROM,DIR) ; Return a subset of symptoms 81 ; .Return Array, Starting Text, Direction 82 N I,IEN,CNT,X,NAME,SUB S I=0,CNT=44 ;233 83 K ^TMP($J,"SIGNS") ;233 84 ;The following lines were added in 233. Now accounts for synonyms 85 M ^TMP($J,"SIGNS","B")=^GMRD(120.83,"B") ;233 86 S SYN="" F S SYN=$O(^GMRD(120.83,"D",SYN)) Q:SYN="" S SUB=0 F S SUB=$O(^GMRD(120.83,"D",SYN,SUB)) Q:'+SUB D ;233 87 .S NAME=$P(^GMRD(120.83,SUB,0),U) S ^TMP($J,"SIGNS","B",(SYN_$C(9)_"<"_NAME_">"_U_NAME),SUB)="" ;233 88 F Q:I'<CNT S FROM=$O(^TMP($J,"SIGNS","B",FROM),DIR) Q:FROM="" D ;233 89 . I FROM="OTHER REACTION" Q ;Don't send this entry 90 . S IEN=0 F S IEN=$O(^TMP($J,"SIGNS","B",FROM,IEN)) Q:'IEN D ;233 91 . . I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.83,.01,IEN_",") Q ;233 Is term active 92 . . S I=I+1 93 . . S Y(I)=IEN_U_FROM 94 Q 95 NXT() ; Increment index of LST 96 S ILST=ILST+1 97 Q ILST 98 EDITLOAD(Y,ORALIEN) ; Load an allergy/adverse reaction for editing 99 Q:+$G(ORALIEN)=0 100 N ORNODE,I 101 S ORNODE=$NAME(^TMP("GMRA",$J)),I=0 102 ;following patch check is made via GUI RPC call to ORWU PATCH instead 103 ;I '$$PATCH^XPDUTL("GMRA*4.0*21") S @ORNODE@(0)="-1^Not yet implemented",Y=ORNODE Q 104 D GETREC^GMRAGUI(ORALIEN,ORNODE) 105 S Y=ORNODE 106 Q 107 EDITSAVE(ORY,ORALIEN,ORDFN,OREDITED) ; Save Edit/Add of an allergy/adverse reaction 108 ;following patch check is made via GUI RPC call to ORWU PATCH instead 109 ;I '$$PATCH^XPDUTL("GMRA*4.0*21") S Y="-1^Not yet implemented" Q 110 N ORNODE 111 S ORNODE=$NAME(^TMP("GMRA",$J)) 112 K @ORNODE M @ORNODE=OREDITED 113 S ORY=0 114 I $G(@ORNODE@("GMRAERR"))="YES" D EIE^GMRAGUI1(ORALIEN,ORDFN,ORNODE) Q ;Handle entered in error 115 I $G(@ORNODE@("GMRANKA"))="YES" D NKA^GMRAGUI1 Q 116 D UPDATE^GMRAGUI1(ORALIEN,ORDFN,ORNODE) Q ;Add/edit reactions 117 Q 118 SENDBULL(Y,ORDUZ,ORDFN,ORTEXT,ORCMTS) ; Send bulletin if user attempts free-text entry 119 I '$D(ORCMTS) D 120 . S Y=$$SENDREQ^GMRAPES0(ORDUZ,ORDFN,ORTEXT) 121 E D 122 . S Y=$$SENDREQ^GMRAPES0(ORDUZ,ORDFN,ORTEXT,.ORCMTS) 123 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA1.m
r613 r623 1 ORWDBA1 ;; SLC OIFO/DKK/GSS - Order Dialogs Billing Awareness;[10/21/03 3:16pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,195,229,215,243**;Dec 17, 1997;Build 242 3 ; 4 ; External References 5 ; DBIA 406 CL^SDCO21 - call to determine Treatment Factors 6 ; 7 ;Ref to ^DIC(9.4 - DBIA ___ 8 ;BA refers to Billing Awareness Project 9 ;CIDC refers to Clinical Indicator Data Capture (same project 3/10/2004) 10 ;Treatment Factors (TxF) refer to SC,AO,IR,EC,MST,HNC,CV,SHD 11 ; 12 GETORDX(Y,ORIEN) ; Retrieve Diagnoses for an order - RPC 13 ; Input: 14 ; ORIEN Order Internal ID# 15 ; Output: 16 ; Y Array of Diagnoses (Dx) - Y(#)=#^DxInt#^ICD9^DxDesc^TxF 17 ; Variables used: 18 ; CT Counter for # of Dx related to order 19 ; DXIEN Dx internal ID 20 ; DXN Internal (to ^OR(100)) sequence # for Dx storage 21 ; DXREC Dx record from Order file 22 ; DXV Dx description 23 ; ICD9 External ICD9 # 24 ; TXFACTRS Treatment Factors (TxF) 25 ; 26 N CT,DXIEN,DXN,DXREC,DXV,ICD9,ICDR,ORFMDAT,TXFACTRS 27 S (CT,DXN)=0 28 I '$G(^OR(100,ORIEN,0)) S Y=-1 29 I '$D(^OR(100,ORIEN,5.1,1,0)) S Y=0 30 E D S Y=CT 31 . ; Get order date for CSV/CTD/HIPAA usage 32 . S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIEN) 33 . ; Go through all Dx's for an order 34 . F S DXN=$O(^OR(100,ORIEN,5.1,DXN)) Q:DXN'?1N.N D 35 .. ; Get diagnosis record and IEN 36 .. S DXREC=$G(^OR(100,ORIEN,5.1,DXN,0)),DXIEN=$P(DXREC,U) 37 .. S ICDR=$$ICDDX^ICDCODE($G(DXIEN),ORFMDAT) 38 .. S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2) 39 .. ; Convert internal to external Treatment Factors 40 .. S TXFACTRS=$$TFGBLGUI(^OR(100,ORIEN,5.2)) 41 .. S CT=CT+1,Y(CT)=DXN_U_$G(DXIEN)_U_ICD9_U_DXV_U_TXFACTRS 42 Q 43 ; 44 SCLST(Y,DFN,ORLST) ; RPC for compiling appropriate TxF's 45 ; RPC titled ORWDBA1 SCLST 46 ; 47 ; Y = Returned value 48 ; DFN = Patient IEN 49 ; ORLST = List of orders 50 ; 51 ; call for BA/TF 52 N GMRCPROS,ORD,ORI,ORPKG 53 D CPLSTBA(.Y,DFN,.ORLST) 54 Q 55 ; 56 CPLSTBA(TEST,PTIFN,ORIFNS) ; set-up SC/TFs for BA 57 ; 58 ; TEST = Returned value 59 ; PTIFN = Patient IEN 60 ; ORIFNS = List of orders 61 ; 62 S ORI="" 63 ; 64 ; define array of packages for which BA data collected (SC/CIs) 65 ; GMRC = Consult/Request Tracking (#128) - Prosthetics 66 ; LR = Lab Services (#26) - Lab 67 ; PSO = Outpt Pharmacy (#112) - Outpt Pharmacy (orig. Co-Pay) 68 ; RA = Radiology/Nuclear Medicine (#31) - Radiology 69 ; 70 S ORPKG(+$O(^DIC(9.4,"C","PSO",0)))=1 71 ; See ISWITCH^ORWDBA7 for insurance/Ed switch, i.e., $$CIDC^IBBAPI 72 ; Also check provider switch via 'OR BILLING AWARENESS BY USER' 73 I $$BASTAT&$$CIDC^IBBAPI(DFN)&$$GET^XPAR(DUZ_";VA(200,","OR BILLING AWARENESS BY USER",1,"Q") F I=1:1 S ORPKG=$P("GMRC;LR;RA",";",I) Q:ORPKG="" D 74 . S ORPKG(+$O(^DIC(9.4,"C",ORPKG,0)))=1 ; ^DIC(9.4) is package file 75 ; 76 ; get Treatment Factors (TxF) for patient 77 D SCPRE(.DR,DFN) 78 ; 79 ; set TxF's if order is for a package for which BA data is collected 80 F S ORI=$O(ORLST(ORI)) Q:'ORI S ORD=+ORLST(ORI) D 81 . I $G(^OR(100,ORD,0))="" Q 82 . I $P($G(^OR(100,ORD,0)),U,14)="" Q 83 . I $D(TEST(ORD))!'$D(ORPKG($P($G(^OR(100,ORD,0)),U,14))) Q 84 . I $E($P(ORIFNS(ORI),";",2))>1 Q ;canceled order (2) & ? (3) 85 . S TEST(ORD)=ORLST(ORI)_DR 86 Q 87 ; 88 SCPRE(DR,DFN) ; Dialog validation, to ask BA questions 89 ; 90 ; DR = return value 91 ; DFN = input patient IEN 92 ; 93 Q:$G(DFN)="" 94 N CPNODE,CT,I,ORX,ORSDCARY,TF,X 95 K ORSDCARY 96 S (CPNODE,DR,ORX,TF)="",CT=0,X="T" 97 ; Call API to acquire Treatment Factors in force 98 D NOW^%DTC,CL^SDCO21(DFN,%,"",.ORSDCARY) ;DBIA 406 99 ; Retrved array order: AO,IR,SC,EC,MST,HNC,CV,SHD e.g., ORSDCARY(3) for SC 100 ; Convert to ^OR/CPRS GUI order: SC,MST,AO,IR,EC,HNC,CV,SHD 101 F I=3,5,1,2,4,6,7,8 S TF=0,CT=CT+1 S:$D(ORSDCARY(I)) TF=1 S $P(CPNODE,U,CT)=TF 102 ; 103 S X=$S($P(CPNODE,U)=1:"SC",1:""),DR=$S($L(X):DR_U_X,1:DR) 104 S X=$S($P(CPNODE,U,2)=1:"MST",1:""),DR=$S($L(X):DR_U_X,1:DR) 105 S X=$S($P(CPNODE,U,3)=1:"AO",1:""),DR=$S($L(X):DR_U_X,1:DR) 106 S X=$S($P(CPNODE,U,4)=1:"IR",1:""),DR=$S($L(X):DR_U_X,1:DR) 107 S X=$S($P(CPNODE,U,5)=1:"EC",1:""),DR=$S($L(X):DR_U_X,1:DR) 108 S X=$S($P(CPNODE,U,6)=1:"HNC",1:""),DR=$S($L(X):DR_U_X,1:DR) 109 S X=$S($P(CPNODE,U,7)=1:"CV",1:""),DR=$S($L(X):DR_U_X,1:DR) 110 S X=$S($P(CPNODE,U,8)=1:"SHD",1:""),DR=$S($L(X):DR_U_X,1:DR) 111 ; 112 ; TxF's for patient (TxF's include SC,AO,IR,EC,MST,HNC,CV,SHD) where 113 ; SC = Service Connected 114 ; AO = Agent Orange 115 ; IR = Ionizing Radiation 116 ; EC = Environmental Contaminants 117 ; MST = Military Sexual Trauma 118 ; HNC = Head and Neck Cancer 119 ; CV = Combat Veteran 120 ; SHD = Shipboard Disability 121 F I="SC","AO","IR","EC","MST","HNC","CV","SHD" D 122 . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"") 123 Q 124 ; 125 ORPKGTYP(Y,ORLST) ; Build BA supported packages array 126 ; GMRC=Prosthetics, LR=Lab, PSO=Pharmacy, RA=Radiology 127 N OIREC,OIV,OIVN 128 ; 129 F I=1:1 S ORPKG=$P("GMRC;LR;PSO;RA",";",I) Q:ORPKG="" D 130 . S ORPKG(+$O(^DIC(9.4,"C",ORPKG,0)))=ORPKG ; ^DIC(9.4) is package file 131 ; 132 S GMRCPROS=+$O(^DIC(9.4,"C","GMRC",0)) 133 ; see if order is for a package which BA supports 134 D ORPKG1(.Y,.ORLST) 135 Q 136 ; 137 ORPKG1(TEST,ORIFNS) ; Order for package BA supports? TEST(ORI)=1 is YES 138 S U="^",ORI="" 139 F I=1:1:5 S OIV(I)=$P("PROSTHETICS REQUEST^EYEGLASS REQUEST^CONTACT LENS REQUEST^HOME OXYGEN REQUEST^AMPUTEE/PROSTHETICS CLINIC",U,I) 140 F S ORI=$O(ORIFNS(ORI)) Q:'ORI S ORD=+ORIFNS(ORI),TEST(ORI)=0 D 141 . I ORD=0 Q ;document/note not an order 142 . ;I ORD="CONSULT_DX" S TEST(ORI)=1 Q ;consult dx prev entered 143 . I '$D(^OR(100,ORD,0)) Q ;invalid order # 144 . I $P(^OR(100,ORD,0),U,14)'?1N.N Q ;invalid order # or entry 145 . I $E($P(ORIFNS(ORI),";",2))>1 Q ;canceled order (2) & ? (3) 146 . I $D(^OR(100,ORD,5.1,1,0)) S TEST(ORI)=1 Q ; 147 . I '$D(ORPKG($P(^OR(100,ORD,0),U,14))) Q ;pkg not supported 148 . ; IPt OPt (ask BA questions?) 149 . ; Pros Y Y GMRC 150 . ; Rad Y Y RA 151 . ; Lab N Y LR 152 . ; Phrm Y Y PSO 153 . ; Pt Class = 'I' or 'O' in ^OR 154 . I $P(^OR(100,ORD,0),U,12)="I"&(ORPKG($P(^OR(100,ORD,0),U,14))="LR") Q 155 . I $P(^OR(100,ORD,0),U,14)=GMRCPROS D Q ;check for Pros consult order 156 .. S OIREC=$G(^ORD(101.43,$G(^OR(100,ORD,4.5,1,1)),0)),OIVN="" 157 .. F S OIVN=$O(OIV(OIVN)) Q:OIVN="" I OIV(OIVN)=$E($P(OIREC,U),1,$L(OIV(OIVN))) S TEST(ORI)=1 Q 158 . S TEST(ORI)=1 ;order is for a supported pkg (also note Pros ck above) 159 Q 160 ; 161 BASTATUS(Y) ;RPC to retrieve the status of the Billing Awareness software 162 ; Y = Returned Value (1=BA usable, 0=BA not-usable) 163 ; Check for installation of CIDC ancillary build 164 S Y=$D(^XPD(9.7,"B","PX CLINICAL INDICATOR DATA CAPTURE 1.0")) 165 Q:'Y 166 ; Check if system parameter switch set 167 S Y=$$CHKPS1^ORWDBA5 168 Q 169 ; 170 BASTAT() ; Internal version of BASTATUS 171 ; Returns 0 if disabled or 1 if enabled 172 Q $$CHKPS1^ORWDBA5 173 ; 174 RCVORCI(Y,DIAG) ;Receive order related Clinical Indicators & Diagnoses from GUI 175 ; Store data in ^OR(100,ODN,5.1) & ^OR(100,0DN,5.2) 176 ; 177 N DXIEN,ODN,ORIEN,SCI,OCDXCT,OCT 178 S ODN="",OCDXCT=0,Y="" 179 F S ODN=$O(DIAG(ODN)) Q:ODN="" D 180 . S ORIEN=$P(DIAG(ODN),";",1) ;Order IEN 181 . I ORIEN'?1N.N S Y=0 Q 182 . K ^OR(100,ORIEN,5.1) ;Clear currently stored diagnosis for rewrite 183 . ; Data from Delphi format: ORIEN;11CNNNCNN^exDx1^exDx2^exDx3^exDx4 184 . ; Convert 8 Tx Factors 185 . S SCI=$$TFGUIGBL($RE($E($RE($P(DIAG(ODN),U)),1,8))) 186 . S ^OR(100,ORIEN,5.2)=SCI ;Store TFs (SC,MST,AO,IR,EC,HNC,CV,SHD) 187 . ; Get order date for CSV/CTD/HIPAA 188 . S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIEN) 189 . ; Go through the diagnoses entered 190 . F OCT=2:1 Q:$P(DIAG(ODN),U,OCT)="" D 191 .. S DXIEN=$P($$ICDDX^ICDCODE($P(DIAG(ODN),U,OCT),ORFMDAT),U,1) ;Dx IEN 192 .. I DXIEN=-1!(DXIEN="") Q ;No or invalid code passed in 193 .. S OCDXCT=OCDXCT+1 194 .. S ^OR(100,ORIEN,5.1,0)="^100.051PA^"_OCDXCT_U_OCDXCT ;Set 5.1 zero node 195 .. S ^OR(100,ORIEN,5.1,OCDXCT,0)=DXIEN ;Store a diagnosis for order 196 .. S ^OR(100,ORIEN,5.1,"B",DXIEN,OCDXCT)="" ;Index diagnosis for order 197 S:Y="" Y=1 198 Q 199 ; 200 TFSTGS ; Set Treatment Factor strings sequence order 201 ; TFGBL is order of TxFs in ^OR(100,ORIEN,5) & ^OR(100,ORIEN,5.2) 202 ; TFGUI is order of TxFs to/from GUI 203 ; TFTBL is order of TxFs for table SD008 (used in ZCL segment) 204 ; NOTE: change examples in TFGUIGBL and TFGBLGUI if order changed 205 S TFGBL="SC^MST^AO^IR^EC^HNC^CV^SHD" 206 S TFGUI="SC^AO^IR^EC^MST^HNC^CV^SHD" 207 S TFTBL="AO^IR^SC^EC^MST^HNC^CV^SHD" 208 Q 209 ; 210 TFGUIGBL(GUI) ;Convert Treatment Factors from GUI to Global order & format 211 ; 212 ; Input: GUI in CNU?NCU: C=checked, N=not checked, U=unchecked 213 ; Output: GBL in 1^^^0^?^1^0^ (global) format (reordered for storage) 214 ; 215 N GBL,J,NTF,TF,TFGBL,TFGUI,TFTBL 216 S GBL="",NTF=8 ;NTF=# of Treatment Factors (TxF) 217 ;I $L(GUI)'=NTF Q -1 ;invalid # of TxF 218 ; Get Treatment Factor sequence order strings 219 D TFSTGS 220 ; Convert from GBL to GUI format and sequence 221 F J=1:1:NTF S TF=$E(GUI,J) D 222 . S TF($P(TFGUI,U,J))=$S(TF="C":1,TF="U":0,TF="?":"?",1:"") 223 F J=1:1:NTF S GBL=GBL_U_TF($P(TFGBL,U,J)) 224 Q $P(GBL,U,2,NTF+1) 225 ; 226 TFGBLGUI(GBL) ;Convert Treatment Factors from Global to GUI order & format 227 ; 228 ; Input: GBL in 1^0^1^1^^0^?^ (global) format 229 ; Output: GUI in CCCNUU? (GUI) format (also reordered) 230 ; 231 N GUI,J,NTF,TF,TFGBL,TFGUI,TFTBL 232 S GUI="",NTF=8 ;NCI=# of TxF 233 ; Get Treatment Factor sequence order strings 234 D TFSTGS 235 ; Convert from GUI to GBL format and sequence 236 F J=1:1:NTF S TF=$P(GBL,U,J) D 237 . S TF($P(TFGBL,U,J))=$S(TF=1:"C",TF=0:"U",TF="?":"?",1:"N") 238 F J=1:1:NTF S GUI=GUI_TF($P(TFGUI,U,J)) 239 Q GUI 240 ; 241 PRVKEY(X) ;Check for active & provider key - to be deleted in CPRS v26 242 N PTD 243 Q:'+$G(X) 0 244 Q:$G(^VA(200,X,0))="" 0 245 S PTD=+$P(^VA(200,X,0),"^",11) 246 I $$DT^XLFDT'<PTD,PTD>0 Q 0 247 Q:$D(^XUSEC("PROVIDER",X)) 1 248 Q 0 249 ; 250 ORESKEY(X) ;Does 'X' hold ORES key, returns: 1=true, 0=false 251 Q:'+$G(X) 0 252 Q:$D(^XUSEC("ORES",X)) 1 253 Q 0 1 ORWDBA1 ;; SLC OIFO/DKK/GSS - Order Dialogs Billing Awareness;[10/21/03 3:16pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,195,229,215**;Dec 17, 1997 3 ; 4 ; External References 5 ; DBIA 406 CL^SDCO21 - call to determine Treatment Factors 6 ; 7 ;Ref to ^DIC(9.4 - DBIA ___ 8 ;BA refers to Billing Awareness Project 9 ;CIDC refers to Clinical Indicator Data Capture (same project 3/10/2004) 10 ;Treatment Factors (TxF) refer to SC,AO,IR,EC,MST,HNC,CV 11 ; 12 GETORDX(Y,ORIEN) ; Retrieve Diagnoses for an order - RPC 13 ; Input: 14 ; ORIEN Order Internal ID# 15 ; Output: 16 ; Y Array of Diagnoses (Dx) - Y(#)=#^DxInt#^ICD9^DxDesc^TxF 17 ; Variables used: 18 ; CT Counter for # of Dx related to order 19 ; DXIEN Dx internal ID 20 ; DXN Internal (to ^OR(100)) sequence # for Dx storage 21 ; DXREC Dx record from Order file 22 ; DXV Dx description 23 ; ICD9 External ICD9 # 24 ; TXFACTRS Treatment Factors (TxF) 25 ; 26 N CT,DXIEN,DXN,DXREC,DXV,ICD9,ICDR,ORFMDAT,TXFACTRS 27 S (CT,DXN)=0 28 I '$G(^OR(100,ORIEN,0)) S Y=-1 29 I '$D(^OR(100,ORIEN,5.1,1,0)) S Y=0 30 E D S Y=CT 31 . ; Get order date for CSV/CTD/HIPAA usage 32 . S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIEN) 33 . ; Go through all Dx's for an order 34 . F S DXN=$O(^OR(100,ORIEN,5.1,DXN)) Q:DXN'?1N.N D 35 .. ; Get diagnosis record and IEN 36 .. S DXREC=$G(^OR(100,ORIEN,5.1,DXN,0)),DXIEN=$P(DXREC,U) 37 .. S ICDR=$$ICDDX^ICDCODE($G(DXIEN),ORFMDAT) 38 .. S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2) 39 .. ; Convert internal to external Treatment Factors 40 .. S TXFACTRS=$$TFGBLGUI(^OR(100,ORIEN,5.2)) 41 .. S CT=CT+1,Y(CT)=DXN_U_$G(DXIEN)_U_ICD9_U_DXV_U_TXFACTRS 42 Q 43 ; 44 SCLST(Y,DFN,ORLST) ; RPC for compiling appropriate TxF's 45 ; RPC titled ORWDBA1 SCLST 46 ; 47 ; Y = Returned value 48 ; DFN = Patient IEN 49 ; ORLST = List of orders 50 ; 51 ; call for BA/TF 52 N GMRCPROS,ORD,ORI,ORPKG 53 D CPLSTBA(.Y,DFN,.ORLST) 54 Q 55 ; 56 CPLSTBA(TEST,PTIFN,ORIFNS) ; set-up SC/TFs for BA 57 ; 58 ; TEST = Returned value 59 ; PTIFN = Patient IEN 60 ; ORIFNS = List of orders 61 ; 62 S ORI="" 63 ; 64 ; define array of packages for which BA data collected (SC/CIs) 65 ; GMRC = Consult/Request Tracking (#128) - Prosthetics 66 ; LR = Lab Services (#26) - Lab 67 ; PSO = Outpt Pharmacy (#112) - Outpt Pharmacy (orig. Co-Pay) 68 ; RA = Radiology/Nuclear Medicine (#31) - Radiology 69 ; 70 F I=1:1 S ORPKG=$P("GMRC;LR;PSO;RA",";",I) Q:ORPKG="" D 71 . S ORPKG(+$O(^DIC(9.4,"C",ORPKG,0)))=1 ; ^DIC(9.4) is package file 72 ; 73 ; get Treatment Factors (TxF) for patient 74 D SCPRE(.DR,DFN) 75 ; 76 ; set TxF's if order is for a package for which BA data is collected 77 F S ORI=$O(ORLST(ORI)) Q:'ORI S ORD=+ORLST(ORI) D 78 . I $G(^OR(100,ORD,0))="" Q 79 . I $D(TEST(ORD))!'$D(ORPKG($P($G(^OR(100,ORD,0)),U,14))) Q 80 . S TEST(ORD)=ORLST(ORI)_DR 81 Q 82 ; 83 SCPRE(DR,DFN) ; Dialog validation, to ask BA questions 84 ; 85 ; DR = return value 86 ; DFN = input patient IEN 87 ; 88 Q:$G(DFN)="" 89 N CPNODE,CT,I,ORX,ORSDCARY,TF,X 90 K ORSDCARY 91 S (CPNODE,DR,ORX,TF)="",CT=0,X="T" 92 ; Call API to acquire Treatment Factors in force 93 D NOW^%DTC,CL^SDCO21(DFN,%,"",.ORSDCARY) ;DBIA 406 94 ; Retrved array order: AO,IR,SC,EC,MST,HNC,CV, e.g., ORSDCARY(3) for SC 95 ; Convert to ^OR/CPRS GUI order: SC,MST,AO,IR,EC,HNC,CV 96 F I=3,5,1,2,4,6,7 S TF=0,CT=CT+1 S:$D(ORSDCARY(I)) TF=1 S $P(CPNODE,U,CT)=TF 97 ; 98 S X=$S($P(CPNODE,U)=1:"SC",1:""),DR=$S($L(X):DR_U_X,1:DR) 99 S X=$S($P(CPNODE,U,2)=1:"MST",1:""),DR=$S($L(X):DR_U_X,1:DR) 100 S X=$S($P(CPNODE,U,3)=1:"AO",1:""),DR=$S($L(X):DR_U_X,1:DR) 101 S X=$S($P(CPNODE,U,4)=1:"IR",1:""),DR=$S($L(X):DR_U_X,1:DR) 102 S X=$S($P(CPNODE,U,5)=1:"EC",1:""),DR=$S($L(X):DR_U_X,1:DR) 103 S X=$S($P(CPNODE,U,6)=1:"HNC",1:""),DR=$S($L(X):DR_U_X,1:DR) 104 S X=$S($P(CPNODE,U,7)=1:"CV",1:""),DR=$S($L(X):DR_U_X,1:DR) 105 ; 106 ; TxF's for patient (TxF's include SC,AO,IR,EC,MST,HNC,CV) where 107 ; SC = Service Connected 108 ; AO = Agent Orange 109 ; IR = Ionizing Radiation 110 ; EC = Environmental Contaminants 111 ; MST = Military Sexual Trauma 112 ; HNC = Head and Neck Cancer 113 ; CV = Combat Veteran 114 F I="SC","AO","IR","EC","MST","HNC","CV" D 115 . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"") 116 Q 117 ; 118 ORPKGTYP(Y,ORLST) ; Build BA supported packages array 119 ; GMRC=Prosthetics, LR=Lab, PSO=Pharmacy, RA=Radiology 120 N OIREC,OIV,OIVN 121 F I=1:1 S ORPKG=$P("GMRC;LR;PSO;RA",";",I) Q:ORPKG="" D 122 . S ORPKG(+$O(^DIC(9.4,"C",ORPKG,0)))=ORPKG ; ^DIC(9.4) is package file 123 S GMRCPROS=+$O(^DIC(9.4,"C","GMRC",0)) 124 ; see if order is for a package which BA supports 125 D ORPKG1(.Y,.ORLST) 126 Q 127 ; 128 ORPKG1(TEST,ORIFNS) ; Order for package BA supports? TEST(ORI)=1 is YES 129 S U="^",ORI="" 130 F I=1:1:5 S OIV(I)=$P("PROSTHETICS REQUEST^EYEGLASS REQUEST^CONTACT LENS REQUEST^HOME OXYGEN REQUEST^AMPUTEE/PROSTHETICS CLINIC",U,I) 131 F S ORI=$O(ORIFNS(ORI)) Q:'ORI S ORD=+ORIFNS(ORI),TEST(ORI)=0 D 132 . I ORD=0 Q ;document/note not an order 133 . ;I ORD="CONSULT_DX" S TEST(ORI)=1 Q ;consult dx prev entered 134 . I '$D(^OR(100,ORD,0)) Q ;invalid order # 135 . I $P(^OR(100,ORD,0),U,14)'?1N.N Q ;invalid order # or entry 136 . I $E($P(ORIFNS(ORI),";",2))>1 Q ;canceled order (2) & ? (3) 137 . I $D(^OR(100,ORD,5.1,1,0)) S TEST(ORI)=1 Q ; 138 . I '$D(ORPKG($P(^OR(100,ORD,0),U,14))) Q ;pkg not supported 139 . ; IPt OPt (ask BA questions?) 140 . ; Pros Y Y GMRC 141 . ; Rad Y Y RA 142 . ; Lab N Y LR 143 . ; Phrm Y Y PSO 144 . ; Pt Class = 'I' or 'O' in ^OR 145 . I $P(^OR(100,ORD,0),U,12)="I"&(ORPKG($P(^OR(100,ORD,0),U,14))="LR") Q 146 . I $P(^OR(100,ORD,0),U,14)=GMRCPROS D Q ;check for Pros consult order 147 .. S OIREC=$G(^ORD(101.43,$G(^OR(100,ORD,4.5,1,1)),0)),OIVN="" 148 .. F S OIVN=$O(OIV(OIVN)) Q:OIVN="" I OIV(OIVN)=$E($P(OIREC,U),1,$L(OIV(OIVN))) S TEST(ORI)=1 Q 149 . S TEST(ORI)=1 ;order is for a supported pkg (also note Pros ck above) 150 Q 151 ; 152 BASTATUS(Y) ;RPC to retrieve the status of the Billing Awareness software 153 ; Y = Returned Value (1=BA usable, 0=BA not-usable) 154 ; Check for installation of CIDC ancillary build 155 S Y=$D(^XPD(9.7,"B","PX CLINICAL INDICATOR DATA CAPTURE 1.0")) 156 Q:'Y 157 ; Check if system parameter switch set 158 S Y=$$CHKPS1^ORWDBA5 159 Q 160 ; 161 BASTAT() ; Internal version of BASTATUS 162 ; Returns 0 if disabled or 1 if enabled 163 Q $$CHKPS1^ORWDBA5 164 ; 165 RCVORCI(Y,DIAG) ;Receive order related Clinical Indicators & Diagnoses from GUI 166 ; Store data in ^OR(100,ODN,5.1) & ^OR(100,0DN,5.2) 167 ; 168 N DXIEN,ODN,ORIEN,SCI,OCDXCT,OCT 169 S ODN="",OCDXCT=0,Y="" 170 F S ODN=$O(DIAG(ODN)) Q:ODN="" D 171 . S ORIEN=$P(DIAG(ODN),";",1) ;Order IEN 172 . I ORIEN'?1N.N S Y=0 Q 173 . K ^OR(100,ORIEN,5.1) ;Clear currently stored diagnosis for rewrite 174 . ; Data from Delphi format: ORIEN;11CNNNCNN^exDx1^exDx2^exDx3^exDx4 175 . ; Convert 7 Tx Factors 176 . S SCI=$$TFGUIGBL($RE($E($RE($P(DIAG(ODN),U)),1,7))) 177 . S ^OR(100,ORIEN,5.2)=SCI ;Store TFs (SC,MST,AO,IR,EC..) 178 . ; Get order date for CSV/CTD/HIPAA 179 . S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIEN) 180 . ; Go through the diagnoses entered 181 . F OCT=2:1 Q:$P(DIAG(ODN),U,OCT)="" D 182 .. S DXIEN=$P($$ICDDX^ICDCODE($P(DIAG(ODN),U,OCT),ORFMDAT),U,1) ;Dx IEN 183 .. I DXIEN=-1!(DXIEN="") Q ;No or invalid code passed in 184 .. S OCDXCT=OCDXCT+1 185 .. S ^OR(100,ORIEN,5.1,0)="^100.051PA^"_OCDXCT_U_OCDXCT ;Set 5.1 zero node 186 .. S ^OR(100,ORIEN,5.1,OCDXCT,0)=DXIEN ;Store a diagnosis for order 187 .. S ^OR(100,ORIEN,5.1,"B",DXIEN,OCDXCT)="" ;Index diagnosis for order 188 S:Y="" Y=1 189 Q 190 ; 191 TFSTGS ; Set Treatment Factor strings sequence order 192 ; TFGBL is order of TxFs in ^OR(100,ORIEN,5) & ^OR(100,ORIEN,5.2) 193 ; TFGUI is order of TxFs to/from GUI 194 ; TFTBL is order of TxFs for table SD008 (used in ZCL segment) 195 ; NOTE: change examples in TFGUIGBL and TFGBLGUI if order changed 196 S TFGBL="SC^MST^AO^IR^EC^HNC^CV" 197 S TFGUI="SC^AO^IR^EC^MST^HNC^CV" 198 S TFTBL="AO^IR^SC^EC^MST^HNC^CV" 199 Q 200 ; 201 TFGUIGBL(GUI) ;Convert Treatment Factors from GUI to Global order & format 202 ; 203 ; Input: GUI in CNU?NCU: C=checked, N=not checked, U=unchecked 204 ; Output: GBL in 1^^^0^?^1^0 (global) format (reordered for storage) 205 ; 206 N GBL,J,NTF,TF,TFGBL,TFGUI,TFTBL 207 S GBL="",NTF=7 ;NTF=# of Treatment Factors (TxF) 208 ;I $L(GUI)'=NTF Q -1 ;invalid # of TxF 209 ; Get Treatment Factor sequence order strings 210 D TFSTGS 211 ; Convert from GBL to GUI format and sequence 212 F J=1:1:NTF S TF=$E(GUI,J) D 213 . S TF($P(TFGUI,U,J))=$S(TF="C":1,TF="U":0,TF="?":"?",1:"") 214 F J=1:1:NTF S GBL=GBL_U_TF($P(TFGBL,U,J)) 215 Q $P(GBL,U,2,NTF+1) 216 ; 217 TFGBLGUI(GBL) ;Convert Treatment Factors from Global to GUI order & format 218 ; 219 ; Input: GBL in 1^0^1^1^^0^? (global) format 220 ; Output: GUI in CCCNUU? (GUI) format (also reordered) 221 ; 222 N GUI,J,NTF,TF,TFGBL,TFGUI,TFTBL 223 S GUI="",NTF=7 ;NCI=# of TxF 224 ; Get Treatment Factor sequence order strings 225 D TFSTGS 226 ; Convert from GUI to GBL format and sequence 227 F J=1:1:NTF S TF=$P(GBL,U,J) D 228 . S TF($P(TFGBL,U,J))=$S(TF=1:"C",TF=0:"U",TF="?":"?",1:"N") 229 F J=1:1:NTF S GUI=GUI_TF($P(TFGUI,U,J)) 230 Q GUI 231 ; 232 PRVKEY(X) ;Check for active & provider key - to be deleted in CPRS v26 233 N PTD 234 Q:'+$G(X) 0 235 Q:$G(^VA(200,X,0))="" 0 236 S PTD=+$P(^VA(200,X,0),"^",11) 237 I $$DT^XLFDT'<PTD,PTD>0 Q 0 238 Q:$D(^XUSEC("PROVIDER",X)) 1 239 Q 0 240 ; 241 ORESKEY(X) ;Does 'X' hold ORES key, returns: 1=true, 0=false 242 Q:'+$G(X) 0 243 Q:$D(^XUSEC("ORES",X)) 1 244 Q 0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA3.m
r613 r623 1 ORWDBA3 ; SLC/GSS Billing Awareness (CIDC) [8/20/03 9:19am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,195,243**;Dec 17, 1997;Build 242 3 ; 4 ORFMDAT(ORDFN) ; Return date in FM format regarding order for CSV/CTD/HIPAA 5 ; Pass in Order IEN 6 Q ($P($G(^OR(100,ORDFN,8,1,0)),"^",16)\1) 7 ; 8 DISPLAY ; Display of BA data from original copied order (ORIT = ORIEN) 9 ; Displayed in window with all order info and user can accept/edit 10 ; Note: TxF = Treatment Factor 11 ; BA data (Dx,TxF's) not editable but in signature window, not in above 12 ; ORIT defined in ORWDXM1, DISPLAY called from ORWDXM2 13 ; 14 ; Input: 15 ; ORIT, ILST, and LST() from ORWDXM* routines 16 ; Output: 17 ; ILST and LST() appropriately incremented/populated for order display 18 ; Variables: 19 ; CUN = TxF's in C, U, or N format 20 ; I = counter 21 ; ILST = line counter, initially from ORWDXM* routines 22 ; LST() = array of lines to output, initially from ORWDXM* routines 23 ; NTF = # of Treatment Factors 24 ; ORITARY = ORIT array of 1 needed to access GETTFCI^ORWDBA4 25 ; SPCS = # of characters to space to left of ':' 26 ; TF1 = first TxF output? (0/1) 27 ; TFGBL = TxF's in Global stored order 28 ; TFGUI = TxF's in GUI returned order 29 ; TFV = TxF verbiage 30 ; 31 N CUN,I,NTF,ORITARY,SPCS,TF1,TFGBL,TFGUI,TFV,Y 32 S NTF=8,SPCS=28,ORITARY(1)=+ORIT 33 ; Get Y(+ORIT) string in ORIEN^CUUUCCN^Dx1^Desc1^Dx2^Desc2^... format 34 D GETTFCI^ORWDBA4(.Y,.ORITARY) 35 S CUN=$P($G(Y(1)),U,2) ;CUN = Treatment Factors in CUN syntax 36 ; First output Diagnosis information - if any 37 F I=3:2:9 I $P($G(Y(1)),U,I)'="" D 38 . S ILST=ILST+1,LST(ILST)=$S(I=3:"Diagnoses",1:"") 39 . S LST(ILST)=LST(ILST)_":"_$P(Y(1),U,I)_" - "_$P(Y(1),U,I+1) 40 . D FRMTLST 41 ; Get GUI and GBL Treatment Factor sequence strings 42 D TFSTGS^ORWDBA1 43 ; Assumes SC will always be first in sequence! - not likely to change 44 S ILST=ILST+1 45 S LST(ILST)="Service Connected:"_$S($E(CUN)="C":"YES",1:"NO") 46 D FRMTLST 47 S ILST=ILST+1,LST(ILST)="Treatment Factors:" 48 ; If no TxF's (no 'C'hecked) {SC output above} then output '<none>' 49 I '$F($E(CUN,2,NTF),"C") S LST(ILST)=LST(ILST)_"<none>" D FRMTLST Q 50 S TF1=0 ;No TxF yet output 51 ; Verbiage for TxF's 52 S TFV("MST")="MILITARY SEXUAL TRAUMA",TFV("AO")="AGENT ORANGE" 53 S TFV("IR")="IONIZING RADIATION",TFV("EC")="ENVIRONMENTAL CONTAMINANTS" 54 S TFV("HNC")="HEAD AND NECK CANCER",TFV("CV")="COMBAT VETERAN" 55 S TFV("SHD")="SHIPBOARD HAZARD" 56 ; Output Checked TxF's 57 F I=2:1:NTF I $E(CUN,I)="C" D 58 . I 'TF1 S LST(ILST)=LST(ILST)_TFV($P(TFGUI,U,I)),TF1=1 D FRMTLST Q 59 . S ILST=ILST+1,LST(ILST)=":"_TFV($P(TFGUI,U,I)) D FRMTLST 60 Q 61 ; 62 FRMTLST ; Format the variable LST(ILST) for DISPLAY tag 63 S LST(ILST)=$J($P(LST(ILST),":"),SPCS)_": "_$P(LST(ILST),":",2) 64 Q 65 ; 66 HINTS(Y) ; Return HINTS for ORBA Treatment Factors - used by Delphi 67 ; The hints returned in the Y array will be used in the CPRS GUI and 68 ; displayed on fly-over of the cursor over the TxF text in the window 69 ; 70 ; Input 71 ; <none> 72 ; Output 73 ; Y array of the hints for TxF's> Y(#)=TxFA ^ TxF line # ^ hint text 74 ; where TxFA is Treatment Factor acronym, e.g., CV=Combat Veteran 75 ; Variables 76 ; CT = line number count, used in Y(#) where #=CT 77 ; I = incrementor index # 78 ; ORTFIEN = the IEN for the TxF in the Help Frame (^DIC(9.2)) file 79 ; TF = TxF acronym 80 ; TFLN = TxF text line number, e.g., ^DIC(9.2,ORTFIEN,1,TFLN,0) 81 ; TFS = string of TxF acronyms 82 ; TFV = TxF description/text 83 ; 84 N CT,I,ORTFIEN,TF,TFLN,TFS,TFV 85 ; 86 S TFS="SC^MST^AO^IR^EC^HNC^CV^SHD",CT=0 87 ; Get next TxF from TFS 88 F I=1:1 S TF=$P(TFS,U,I) Q:TF="" D 89 . S ORTFIEN=$O(^DIC(9.2,"B","ORBA-"_TF,"")),TFV="",TFLN=0 90 . ; Get next line of hint text 91 . F S TFLN=$O(^DIC(9.2,ORTFIEN,1,TFLN)) Q:'TFLN D 92 .. S CT=CT+1,Y(CT)=TF_U_TFLN_U_^DIC(9.2,ORTFIEN,1,TFLN,0) 93 Q 94 ; 95 DG1(ORDFN,COUNTER,CTVALUE) ; Create DG1 segment(s) & make call for ZCL seg. 96 ; 97 ; Input 98 ; ORDFN Internal Order ID# 99 ; COUNTER Variable used as counter from calling routine 100 ; CTVALUE Value of COUNTER when DG1 called 101 ; Output 102 ; DG1 & ZCL HL7 segments 103 ; 104 I $$BASTAT^ORWDBA1=0 Q ;BA not used 105 N DG13,DXIEN,DXR,DXV,FROMFILE,ICD9,OCT,OREC,ORFMDAT 106 ; zero order count variable 107 S OCT=0 108 ; Get the date of order (for CSV/CTD usage) 109 S ORFMDAT=$$ORFMDAT(ORDFN) 110 ; Get the diagnoses for an order 111 F S OCT=$O(^OR(100,ORDFN,5.1,OCT)) Q:OCT'?1N.N D 112 . S OREC=^OR(100,ORDFN,5.1,OCT,0) 113 . S DXIEN=$P(OREC,U) ; DXIEN=pointer to diagnosis (ICD9) file #80 114 . ; the DXIEN pointer should point to a valid diagnosis (after all is 115 . ; was previously entered .. but just in case ...) 116 . S (DXV,ICD9)="" 117 . I DXIEN'="" D 118 .. S DXR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) Q:+DXR=-1 119 .. ; Get diagnosis verbiage and ICD code 120 .. S DXV=$P(DXR,U,4),ICD9=$P(DXR,U,2) 121 . S FROMFILE=80 122 . S DG13=DXIEN_U_DXV_U_FROMFILE_U_ICD9_U_DXV_U_"ICD9" 123 . S CTVALUE=CTVALUE+1 124 . S ORMSG(CTVALUE)="DG1"_"|"_OCT_"||"_DG13_"|||||||||||||" 125 . D ZCL 126 S @COUNTER=CTVALUE 127 Q 128 ; 129 ZCL ;create all the ZCL segments (currently 8 TxF's) for order number OCT 130 ; 131 N I,J,TABLE,TF,TFGBL,TFGUI,TFTBL,TFIN,TFS,VALUE 132 D TFSTGS^ORWDBA1 ;set string sequence of treatment factors 133 ; TFS is TxF data in ^OR(100,ORIEN,5.2) order 134 S TFS=$G(^OR(100,ORDFN,5.2)),TABLE="" 135 ; conversion order from ^OR stored data and Table SD008 for HL7 msg 136 ; convert so that the ZCL segments will be in Table SD008 order (1-8) 137 F I=1:1:8 S TF=$P(TFTBL,U,I) F J=1:1:8 I $P(TFGBL,U,J)=TF S TABLE=TABLE_J Q 138 F TFIN=1:1:8 D 139 . ; ORMSG counter incremented 140 . S CTVALUE=CTVALUE+1 141 . ; TF VALUE=0 for no or 1 for yes (only if not req. is it null) 142 . S VALUE=$P(TFS,U,$E(TABLE,TFIN)) 143 . I VALUE="?" S VALUE=0 ;temp fix if sending '?' to ancillary??? 144 . ; for Table SD008: OCT=Set ID, SCIN=O/P Classif. Type, VALUE=Value 145 . S ORMSG(CTVALUE)="ZCL|"_OCT_"|"_TFIN_"|"_VALUE 146 Q 147 ; 148 BDOSTR ;Store backdoor order DG1 and ZCL messages from HL7 149 ;Processes one order per entry into BDOSTR, e.g., ROUT(1) 150 ;Depends upon ORM* routines to set-up a number of variables including 151 ; ORMSG array and ORIFN. 152 ;ORM* routines calling BDOSTR: ORMGMRC, ORMLR, ORMPS, & ORMRA 153 ; 154 ; Input: HL7 messages and related data 155 ; Output: ROUT array in Delphi GUI format, i.e. 156 ; OrderIEN;11CNNNCNN^exDx1^exDx2^exDx3^exDx4 157 ; 158 ; Variables Used 159 ; DG1 = sequential numbered array with a value of DXIEN 160 ; I,J = counters 161 ; GUITF = GUI order treatment factors (TxF) 162 ; NDX = number of diagnoses being passed 163 ; NTF = number of TxF 164 ; OBX = @ORMSG Dx array element # (max of 4 diagnoses stored) 165 ; REC = set to sequential HL7 messages, contains HL7 message data 166 ; ROUT = record sent for storage processing to RCVORCI 167 ; TF = individual TxF values 168 ; TFGBL = TxF acronyms in ^ delimited string in ^OR sequence 169 ; TFGUI = TxF acronyms in ^ delimited string in from GUI sequence 170 ; TFTBL = TxF acronyms in ^ delimited string in Table SD008 sequence 171 ; VAL = individual TxF values 172 ; ZCL = TxF in Table SD008 format and sequence 173 ; 174 ; See if CIDC master switch set, if not then no DG1/ZCL seg, to store 175 I $$BASTAT^ORWDBA1=0 Q ;CIDC (nee BA) not used 176 ; 177 N CPNODE,CT,DG1,I,J,GUITF,NDX,NTF,OBX,REC,ROUT,ORSDCARY,SDCARYA 178 N TF,TFGBL,TFGUI,TFTBL,VAL,X,ZCL 179 ; 180 K ORSDCARY,SDCARYA 181 D TFSTGS^ORWDBA1 ;set string sequence of treatment factors 182 S (CT,NDX,OBX)=0,NTF=8,(CPNODE,GUITF,TF,Y,ZCL)="",X="T" 183 ; Call API to acquire Treatment Factors in force 184 D NOW^%DTC,CL^SDCO21(DFN,%,"",.ORSDCARY) ;DBIA 406 185 ; Retrved array order: AO,IR,SC,EC,MST,HNC,CV,SHD, e.g., ORSDCARY(3) for SC 186 ; Convert to character array, e.g., SDCARYA("SC")="" 187 F I=1:1:NTF S:$D(ORSDCARY(I)) SDCARYA($P("AO^IR^SC^EC^MST^HNC^CV^SHD",U,I))="" 188 ; Process only four DG1 segments and first set of ZCL segments 189 F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) I J="DG1"!(J="ZCL"&($P(@ORMSG@(OBX),"|",2)=1)) D 190 . S REC=@ORMSG@(OBX) 191 . ; Setting DG1(#)=DXIEN where # is Dx sequence # (1=primary) 192 . I J="DG1"&(NDX<4) S DG1($P(REC,"|",2))=$P(REC,U,4),NDX=NDX+1 Q 193 . ; Create ZCL string of TxFs, e.g., 1101011 194 . I J="ZCL" D 195 .. S:$P(REC,"|",4)="" $P(REC,"|",4)=" " 196 .. S $E(ZCL,$P(REC,"|",3))=$P(REC,"|",4) 197 ; convert order and format from Table SD008 to GUI 198 F I=1:1:NTF S TF=$P(TFGUI,U,I) F J=1:1:NTF I $P(TFTBL,U,J)=TF D 199 . ; If patient does not have that Tx Factor (TF) then ghost in GUI ("N") 200 . I '$D(SDCARYA(TF)) S GUITF=GUITF_"N" Q 201 . ; If patient has TF then format for GUI (C=ck'd, U=unck'd, ?=not ans) 202 . S VAL=$E(ZCL,J),GUITF=GUITF_$S(VAL=1:"C",VAL=0:"U",1:"?") 203 ; Create output string in a format that can be stored by RCVORCI^ORWDBA1 204 S ROUT(1)=ORIFN_";11"_GUITF_U_$G(DG1(1))_U_$G(DG1(2))_U_$G(DG1(3))_U_$G(DG1(4)) 205 ; Store diagnoses and treatment factors 206 D RCVORCI^ORWDBA1(Y,.ROUT) 207 Q 208 ; 209 ERRMSG(VISIT) ; Error handling and message 210 ; to be determined 211 Q 1 ORWDBA3 ; SLC/GSS Billing Awareness (CIDC) [8/20/03 9:19am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,195**;Dec 17, 1997 3 ; 4 ORFMDAT(ORDFN) ; Return date in FM format regarding order for CSV/CTD/HIPAA 5 ; Pass in Order IEN 6 Q ($P($G(^OR(100,ORDFN,8,1,0)),"^",16)\1) 7 ; 8 DISPLAY ; Display of BA data from original copied order (ORIT = ORIEN) 9 ; Displayed in window with all order info and user can accept/edit 10 ; Note: TxF = Treatment Factor 11 ; BA data (Dx,TxF's) not editable but in signature window, not in above 12 ; ORIT defined in ORWDXM1, DISPLAY called from ORWDXM2 13 ; 14 ; Input: 15 ; ORIT, ILST, and LST() from ORWDXM* routines 16 ; Output: 17 ; ILST and LST() appropriately incremented/populated for order display 18 ; Variables: 19 ; CUN = TxF's in C, U, or N format 20 ; I = counter 21 ; ILST = line counter, initially from ORWDXM* routines 22 ; LST() = array of lines to output, initially from ORWDXM* routines 23 ; NTF = # of Treatment Factors 24 ; ORITARY = ORIT array of 1 needed to access GETTFCI^ORWDBA4 25 ; SPCS = # of characters to space to left of ':' 26 ; TF1 = first TxF output? (0/1) 27 ; TFGBL = TxF's in Global stored order 28 ; TFGUI = TxF's in GUI returned order 29 ; TFV = TxF verbiage 30 ; 31 N CUN,I,NTF,ORITARY,SPCS,TF1,TFGBL,TFGUI,TFV,Y 32 S NTF=7,SPCS=28,ORITARY(1)=+ORIT 33 ; Get Y(+ORIT) string in ORIEN^CUUUCCN^Dx1^Desc1^Dx2^Desc2^... format 34 D GETTFCI^ORWDBA4(.Y,.ORITARY) 35 S CUN=$P($G(Y(1)),U,2) ;CUN = Treatment Factors in CUN syntax 36 ; First output Diagnosis information - if any 37 F I=3:2:9 I $P($G(Y(1)),U,I)'="" D 38 . S ILST=ILST+1,LST(ILST)=$S(I=3:"Diagnoses",1:"") 39 . S LST(ILST)=LST(ILST)_":"_$P(Y(1),U,I)_" - "_$P(Y(1),U,I+1) 40 . D FRMTLST 41 ; Get GUI and GBL Treatment Factor sequence strings 42 D TFSTGS^ORWDBA1 43 ; Assumes SC will always be first in sequence! - not likely to change 44 S ILST=ILST+1 45 S LST(ILST)="Service Connected:"_$S($E(CUN)="C":"YES",1:"NO") 46 D FRMTLST 47 S ILST=ILST+1,LST(ILST)="Treatment Factors:" 48 ; If no TxF's (no 'C'hecked) {SC output above} then output '<none>' 49 I '$F($E(CUN,2,NTF),"C") S LST(ILST)=LST(ILST)_"<none>" D FRMTLST Q 50 S TF1=0 ;No TxF yet output 51 ; Verbiage for TxF's 52 S TFV("MST")="MILITARY SEXUAL TRAUMA",TFV("AO")="AGENT ORANGE" 53 S TFV("IR")="IONIZING RADIATION",TFV("EC")="ENVIRONMENTAL CONTAMINANTS" 54 S TFV("HNC")="HEAD AND NECK CANCER",TFV("CV")="COMBAT VETERAN" 55 ; Output Checked TxF's 56 F I=2:1:NTF I $E(CUN,I)="C" D 57 . I 'TF1 S LST(ILST)=LST(ILST)_TFV($P(TFGUI,U,I)),TF1=1 D FRMTLST Q 58 . S ILST=ILST+1,LST(ILST)=":"_TFV($P(TFGUI,U,I)) D FRMTLST 59 Q 60 ; 61 FRMTLST ; Format the variable LST(ILST) for DISPLAY tag 62 S LST(ILST)=$J($P(LST(ILST),":"),SPCS)_": "_$P(LST(ILST),":",2) 63 Q 64 ; 65 HINTS(Y) ; Return HINTS for ORBA Treatment Factors - used by Delphi 66 ; The hints returned in the Y array will be used in the CPRS GUI and 67 ; displayed on fly-over of the cursor over the TxF text in the window 68 ; 69 ; Input 70 ; <none> 71 ; Output 72 ; Y array of the hints for TxF's> Y(#)=TxFA ^ TxF line # ^ hint text 73 ; where TxFA is Treatment Factor acronym, e.g., CV=Combat Veteran 74 ; Variables 75 ; CT = line number count, used in Y(#) where #=CT 76 ; I = incrementor index # 77 ; ORTFIEN = the IEN for the TxF in the Help Frame (^DIC(9.2)) file 78 ; TF = TxF acronym 79 ; TFLN = TxF text line number, e.g., ^DIC(9.2,ORTFIEN,1,TFLN,0) 80 ; TFS = string of TxF acronyms 81 ; TFV = TxF description/text 82 ; 83 N CT,I,ORTFIEN,TF,TFLN,TFS,TFV 84 ; 85 S TFS="SC^MST^AO^IR^EC^HNC^CV",CT=0 86 ; Get next TxF from TFS 87 F I=1:1 S TF=$P(TFS,U,I) Q:TF="" D 88 . S ORTFIEN=$O(^DIC(9.2,"B","ORBA-"_TF,"")),TFV="",TFLN=0 89 . ; Get next line of hint text 90 . F S TFLN=$O(^DIC(9.2,ORTFIEN,1,TFLN)) Q:'TFLN D 91 .. S CT=CT+1,Y(CT)=TF_U_TFLN_U_^DIC(9.2,ORTFIEN,1,TFLN,0) 92 Q 93 ; 94 DG1(ORDFN,COUNTER,CTVALUE) ; Create DG1 segment(s) & make call for ZCL seg. 95 ; 96 ; Input 97 ; ORDFN Internal Order ID# 98 ; COUNTER Variable used as counter from calling routine 99 ; CTVALUE Value of COUNTER when DG1 called 100 ; Output 101 ; DG1 & ZCL HL7 segments 102 ; 103 I $$BASTAT^ORWDBA1=0 Q ;BA not used 104 N DG13,DXIEN,DXR,DXV,FROMFILE,ICD9,OCT,OREC,ORFMDAT 105 ; zero order count variable 106 S OCT=0 107 ; Get the date of order (for CSV/CTD usage) 108 S ORFMDAT=$$ORFMDAT(ORDFN) 109 ; Get the diagnoses for an order 110 F S OCT=$O(^OR(100,ORDFN,5.1,OCT)) Q:OCT'?1N.N D 111 . S OREC=^OR(100,ORDFN,5.1,OCT,0) 112 . S DXIEN=$P(OREC,U) ; DXIEN=pointer to diagnosis (ICD9) file #80 113 . ; the DXIEN pointer should point to a valid diagnosis (after all is 114 . ; was previously entered .. but just in case ...) 115 . S (DXV,ICD9)="" 116 . I DXIEN'="" D 117 .. S DXR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) Q:+DXR=-1 118 .. ; Get diagnosis verbiage and ICD code 119 .. S DXV=$P(DXR,U,4),ICD9=$P(DXR,U,2) 120 . S FROMFILE=80 121 . S DG13=DXIEN_U_DXV_U_FROMFILE_U_ICD9_U_DXV_U_"ICD9" 122 . S CTVALUE=CTVALUE+1 123 . S ORMSG(CTVALUE)="DG1"_"|"_OCT_"||"_DG13_"|||||||||||||" 124 . D ZCL 125 S @COUNTER=CTVALUE 126 Q 127 ; 128 ZCL ;create all the ZCL segments (currently 7 TxF's) for order number OCT 129 ; 130 N I,J,TABLE,TF,TFGBL,TFGUI,TFTBL,TFIN,TFS,VALUE 131 D TFSTGS^ORWDBA1 ;set string sequence of treatment factors 132 ; TFS is TxF data in ^OR(100,ORIEN,5.2) order 133 S TFS=$G(^OR(100,ORDFN,5.2)),TABLE="" 134 ; conversion order from ^OR stored data and Table SD008 for HL7 msg 135 ; convert so that the ZCL segments will be in Table SD008 order (1-7) 136 F I=1:1:7 S TF=$P(TFTBL,U,I) F J=1:1:7 I $P(TFGBL,U,J)=TF S TABLE=TABLE_J Q 137 F TFIN=1:1:7 D 138 . ; ORMSG counter incremented 139 . S CTVALUE=CTVALUE+1 140 . ; TF VALUE=0 for no or 1 for yes (only if not req. is it null) 141 . S VALUE=$P(TFS,U,$E(TABLE,TFIN)) 142 . I VALUE="?" S VALUE=0 ;temp fix if sending '?' to ancillary??? 143 . ; for Table SD008: OCT=Set ID, SCIN=O/P Classif. Type, VALUE=Value 144 . S ORMSG(CTVALUE)="ZCL|"_OCT_"|"_TFIN_"|"_VALUE 145 Q 146 ; 147 BDOSTR ;Store backdoor order DG1 and ZCL messages from HL7 148 ;Processes one order per entry into BDOSTR, e.g., ROUT(1) 149 ;Depends upon ORM* routines to set-up a number of variables including 150 ; ORMSG array and ORIFN. 151 ;ORM* routines calling BDOSTR: ORMGMRC, ORMLR, ORMPS, & ORMRA 152 ; 153 ; Input: HL7 messages and related data 154 ; Output: ROUT array in Delphi GUI format, i.e. 155 ; OrderIEN;11CNNNCNN^exDx1^exDx2^exDx3^exDx4 156 ; 157 ; Variables Used 158 ; DG1 = sequential numbered array with a value of DXIEN 159 ; I,J = counters 160 ; GUITF = GUI order treatment factors (TxF) 161 ; NDX = number of diagnoses being passed 162 ; NTF = number of TxF 163 ; OBX = @ORMSG Dx array element # (max of 4 diagnoses stored) 164 ; REC = set to sequential HL7 messages, contains HL7 message data 165 ; ROUT = record sent for storage processing to RCVORCI 166 ; TF = individual TxF values 167 ; TFGBL = TxF acronyms in ^ delimited string in ^OR sequence 168 ; TFGUI = TxF acronyms in ^ delimited string in from GUI sequence 169 ; TFTBL = TxF acronyms in ^ delimited string in Table SD008 sequence 170 ; VAL = individual TxF values 171 ; ZCL = TxF in Table SD008 format and sequence 172 ; 173 ; See if CIDC master switch set, if not then no DG1/ZCL seg, to store 174 I $$BASTAT^ORWDBA1=0 Q ;CIDC (nee BA) not used 175 ; 176 N CPNODE,CT,DG1,I,J,GUITF,NDX,NTF,OBX,REC,ROUT,ORSDCARY,SDCARYA 177 N TF,TFGBL,TFGUI,TFTBL,VAL,X,ZCL 178 ; 179 K ORSDCARY,SDCARYA 180 D TFSTGS^ORWDBA1 ;set string sequence of treatment factors 181 S (CT,NDX,OBX)=0,NTF=7,(CPNODE,GUITF,TF,Y,ZCL)="",X="T" 182 ; Call API to acquire Treatment Factors in force 183 D NOW^%DTC,CL^SDCO21(DFN,%,"",.ORSDCARY) ;DBIA 406 184 ; Retrved array order: AO,IR,SC,EC,MST,HNC,CV, e.g., ORSDCARY(3) for SC 185 ; Convert to character array, e.g., SDCARYA("SC")="" 186 F I=1:1:NTF S:$D(ORSDCARY(I)) SDCARYA($P("AO^IR^SC^EC^MST^HNC^CV",U,I))="" 187 ; Process only four DG1 segments and first set of ZCL segments 188 F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) I J="DG1"!(J="ZCL"&($P(@ORMSG@(OBX),"|",2)=1)) D 189 . S REC=@ORMSG@(OBX) 190 . ; Setting DG1(#)=DXIEN where # is Dx sequence # (1=primary) 191 . I J="DG1"&(NDX<4) S DG1($P(REC,"|",2))=$P(REC,U,4),NDX=NDX+1 Q 192 . ; Create ZCL string of TxFs, e.g., 1101011 193 . I J="ZCL" D 194 .. S:$P(REC,"|",4)="" $P(REC,"|",4)=" " 195 .. S $E(ZCL,$P(REC,"|",3))=$P(REC,"|",4) 196 ; convert order and format from Table SD008 to GUI 197 F I=1:1:NTF S TF=$P(TFGUI,U,I) F J=1:1:NTF I $P(TFTBL,U,J)=TF D 198 . ; If patient does not have that Tx Factor (TF) then ghost in GUI ("N") 199 . I '$D(SDCARYA(TF)) S GUITF=GUITF_"N" Q 200 . ; If patient has TF then format for GUI (C=ck'd, U=unck'd, ?=not ans) 201 . S VAL=$E(ZCL,J),GUITF=GUITF_$S(VAL=1:"C",VAL=0:"U",1:"?") 202 ; Create output string in a format that can be stored by RCVORCI^ORWDBA1 203 S ROUT(1)=ORIFN_";11"_GUITF_U_$G(DG1(1))_U_$G(DG1(2))_U_$G(DG1(3))_U_$G(DG1(4)) 204 ; Store diagnoses and treatment factors 205 D RCVORCI^ORWDBA1(Y,.ROUT) 206 Q 207 ; 208 ERRMSG(VISIT) ; Error handling and message 209 ; to be determined 210 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA4.m
r613 r623 1 ORWDBA4 ; SLC/GU Billing Awareness - Phase II [11/26/04 15:44] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195,243**;Dec 17, 1997;Build 242 3 ; 4 ;Miscellaneous CIDC functions utility. 5 ; 6 ;External References used by this routine 7 ; $$GETS^DIQ DBIA 2056 8 ; GETS^DIQ DBIA 2056 9 ; $$ICDDX^ICDCODE DBIA 3990 10 ; $$TFGBLGUI^ORWDBA1 DBIA none listed 11 ; $$SETDXD^ORWDBA2 DBIA none listed 12 ; $$NOW^XLFDT DBIA 10103 13 ; $$GET^XPAR DBIA 2263 14 ; 15 GETTFCI(Y,ORIEN) ;Get Treatment Factors Clinical Indicators 16 ;Input Variable: 17 ; ORIEN Order Internal Entry Number (array variable) 18 ;Ouput Variable: 19 ; Y Y(AI)=Order_IEN^Treatment_Factors^ICD9^ICD9_Description 20 ; There can be up to 4 ICD9 codes and thier descriptions 21 ; ICD901^DESC01^ICD902^DESC02^ICD903^DESC03^ICD904^DESC04 22 ;Local Variables: 23 ; AI Array Index 24 ; CI Clinical Index 25 ; TF Treatment Factors 26 ; TFCI Treatment Factors Clinical Indicators 27 N AI,CI,CNT,DXS,TF,TFCI 28 S U="^",(CNT,TF)="" 29 F S CNT=$O(ORIEN(CNT)) Q:CNT="" D 30 . S TF=$$GTF(ORIEN(CNT)) 31 . S DXS=$$GDCD(ORIEN(CNT)) 32 . I TF="NNNNNNNN"&(DXS="") Q 33 . S TFCI(CNT)=ORIEN(CNT)_U_TF_$S(DXS="":"",1:U_DXS) 34 M Y=TFCI 35 Q 36 ; 37 GTF(IEN) ;Get Treatment Factors 38 ;Gets the Treatment Factors for the current order converted to the 39 ;format used by the CPRS GUI display. 40 ; 41 ;Input Variable: 42 ; IEN Internal Entry Number 43 ;Local Variables: 44 ; ORTF Order Record Treatment Factors 45 ; OREM Order Record Error Message 46 ; OTF Order Treatment Factors 47 ; (Converted to GUI values and returned) 48 N ORTF,OREM,OTF 49 S OTF="" 50 D GETS^DIQ(100,IEN,"90;91;92;93;94;95;96;98","I","ORTF","OREM") 51 S OTF=$G(ORTF(100,IEN_",",90,"I")) 52 S OTF=OTF_U_$G(ORTF(100,IEN_",",91,"I")) 53 S OTF=OTF_U_$G(ORTF(100,IEN_",",92,"I")) 54 S OTF=OTF_U_$G(ORTF(100,IEN_",",93,"I")) 55 S OTF=OTF_U_$G(ORTF(100,IEN_",",94,"I")) 56 S OTF=OTF_U_$G(ORTF(100,IEN_",",95,"I")) 57 S OTF=OTF_U_$G(ORTF(100,IEN_",",96,"I")) 58 S OTF=OTF_U_$G(ORTF(100,IEN_",",98,"I")) 59 S OTF=$$TFGBLGUI^ORWDBA1(OTF) 60 I OTF'="NNNNNNNN" Q OTF 61 S OTF="" 62 K ORTF,OREM 63 D GETS^DIQ(100,IEN,"51;52;53;54;55;56;57;58","I","ORTF","OREM") 64 S OTF=$G(ORTF(100,IEN_",",51,"I")) 65 S OTF=OTF_U_$G(ORTF(100,IEN_",",52,"I")) 66 S OTF=OTF_U_$G(ORTF(100,IEN_",",53,"I")) 67 S OTF=OTF_U_$G(ORTF(100,IEN_",",54,"I")) 68 S OTF=OTF_U_$G(ORTF(100,IEN_",",55,"I")) 69 S OTF=OTF_U_$G(ORTF(100,IEN_",",56,"I")) 70 S OTF=OTF_U_$G(ORTF(100,IEN_",",57,"I")) 71 S OTF=OTF_U_$G(ORTF(100,IEN_",",58,"I")) 72 S OTF=$$TFGBLGUI^ORWDBA1(OTF) 73 Q OTF 74 ; 75 GDCD(IEN) ;Get Diagnoses Codes / Description 76 ;Builds and returns a text string delimited by the "^". The text string 77 ;made from the ICD9 codes associated with the current order and thier 78 ;descriptions pulled from the ICD DIAGNOSIS file #80. The string can 79 ;contain up to four diagnoses codes and thier descriptions. The string 80 ;with all four possiable diagnoses codes is formatted: 81 ;ICD901^DESC01^ICD902^DESC02^ICD903^DESC03^ICD904^DESC04 82 ; 83 ;Input Variable: 84 ; IEN 85 ;Local Variables: 86 ; DCD Diagnosis Code Description (retrun variable) 87 ; DXDT Diagnosis Date (either Order date or system date) 88 ; DXD Diagnosis Description 89 ; DXIEN Diagnosis Internal Entry Number 90 ; ICD9 ICD9 code (for GUI display) 91 ; IENS Internale Entry Number Sequence 92 ; (Array index variable for data returned from lookup) 93 ; ORRF Order Record Found (returned data from lookup) 94 ; OREM Order Record Error Message 95 N DCD,DXDT,DXD,DXIEN,ICD9,IENS,ORRF,OREM 96 S DCD="" 97 D GETS^DIQ(100,IEN,".8*;5.1*","I","ORRF","OREM") 98 I $D(ORRF) D 99 . S DXDT="" 100 . I $D(ORRF(100.008)) S DXDT=$G(ORRF(100.008,"1,"_IEN_",",.01,"I")) 101 . I DXDT="" S DXDT=$$NOW^XLFDT 102 . I $D(ORRF(100.051)) D 103 .. S IENS="" F S IENS=$O(ORRF(100.051,IENS)) Q:IENS="" D 104 ... I ORRF(100.051,IENS,.01,"I")="" S DCD=DCD_U Q 105 ... S DXIEN=ORRF(100.051,IENS,.01,"I") 106 ... S ICD9=$$GET1^DIQ(80,DXIEN,.01,"") 107 ... S DXD=$$SETDXD^ORWDBA2($P($$ICDDX^ICDCODE(ICD9,DT),U,4)) 108 ... S DCD=$S(DCD="":ICD9_U_DXD,1:DCD_U_ICD9_U_DXD) 109 Q DCD 110 ; 111 GETBAUSR(Y,ORCIEN) ;GUI RPC CALL 112 ;Get Billing Awareness By User parameter value 113 ;Gets and returns the value of the Enabled Billing Awareness By User 114 ;parameter assigned to a provider. 115 ;Input Variable: 116 ; ORCIEN Ordering Clinician's Internal Entry Number 117 ;Output Variable: 118 ; Y Parameter value, 1 if enabled, 0 if disabled 119 S Y=$$GET^XPAR(ORCIEN_";VA(200,","OR BILLING AWARENESS BY USER",1,"Q") 120 Q 1 ORWDBA4 ; SLC/GU Billing Awareness - Phase II [11/26/04 15:44] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195**;Dec 17, 1997 3 ; 4 ;Miscellaneous CIDC functions utility. 5 ; 6 ;External References used by this routine 7 ; $$GETS^DIQ DBIA 2056 8 ; GETS^DIQ DBIA 2056 9 ; $$ICDDX^ICDCODE DBIA 3990 10 ; $$TFGBLGUI^ORWDBA1 DBIA none listed 11 ; $$SETDXD^ORWDBA2 DBIA none listed 12 ; $$NOW^XLFDT DBIA 10103 13 ; $$GET^XPAR DBIA 2263 14 ; 15 GETTFCI(Y,ORIEN) ;Get Treatment Factors Clinical Indicators 16 ;Input Variable: 17 ; ORIEN Order Internal Entry Number (array variable) 18 ;Ouput Variable: 19 ; Y Y(AI)=Order_IEN^Treatment_Factors^ICD9^ICD9_Description 20 ; There can be up to 4 ICD9 codes and thier descriptions 21 ; ICD901^DESC01^ICD902^DESC02^ICD903^DESC03^ICD904^DESC04 22 ;Local Variables: 23 ; AI Array Index 24 ; CI Clinical Index 25 ; TF Treatment Factors 26 ; TFCI Treatment Factors Clinical Indicators 27 N AI,CI,CNT,DXS,TF,TFCI 28 S U="^",(CNT,TF)="" 29 F S CNT=$O(ORIEN(CNT)) Q:CNT="" D 30 . S TF=$$GTF(ORIEN(CNT)) 31 . S DXS=$$GDCD(ORIEN(CNT)) 32 . I TF="NNNNNNN"&(DXS="") Q 33 . S TFCI(CNT)=ORIEN(CNT)_U_TF_$S(DXS="":"",1:U_DXS) 34 M Y=TFCI 35 Q 36 ; 37 GTF(IEN) ;Get Treatment Factors 38 ;Gets the Treatment Factors for the current order converted to the 39 ;format used by the CPRS GUI display. 40 ; 41 ;Input Variable: 42 ; IEN Internal Entry Number 43 ;Local Variables: 44 ; ORTF Order Record Treatment Factors 45 ; OREM Order Record Error Message 46 ; OTF Order Treatment Factors 47 ; (Converted to GUI values and returned) 48 N ORTF,OREM,OTF 49 S OTF="" 50 D GETS^DIQ(100,IEN,"90;91;92;93;94;95;96","I","ORTF","OREM") 51 S OTF=$G(ORTF(100,IEN_",",90,"I")) 52 S OTF=OTF_U_$G(ORTF(100,IEN_",",91,"I")) 53 S OTF=OTF_U_$G(ORTF(100,IEN_",",92,"I")) 54 S OTF=OTF_U_$G(ORTF(100,IEN_",",93,"I")) 55 S OTF=OTF_U_$G(ORTF(100,IEN_",",94,"I")) 56 S OTF=OTF_U_$G(ORTF(100,IEN_",",95,"I")) 57 S OTF=OTF_U_$G(ORTF(100,IEN_",",96,"I")) 58 S OTF=$$TFGBLGUI^ORWDBA1(OTF) 59 I OTF'="NNNNNNN" Q OTF 60 S OTF="" 61 K ORTF,OREM 62 D GETS^DIQ(100,IEN,"51;52;53;54;55;56;57","I","ORTF","OREM") 63 S OTF=$G(ORTF(100,IEN_",",51,"I")) 64 S OTF=OTF_U_$G(ORTF(100,IEN_",",52,"I")) 65 S OTF=OTF_U_$G(ORTF(100,IEN_",",53,"I")) 66 S OTF=OTF_U_$G(ORTF(100,IEN_",",54,"I")) 67 S OTF=OTF_U_$G(ORTF(100,IEN_",",55,"I")) 68 S OTF=OTF_U_$G(ORTF(100,IEN_",",56,"I")) 69 S OTF=OTF_U_$G(ORTF(100,IEN_",",57,"I")) 70 S OTF=$$TFGBLGUI^ORWDBA1(OTF) 71 Q OTF 72 ; 73 GDCD(IEN) ;Get Diagnoses Codes / Description 74 ;Builds and returns a text string delimited by the "^". The text string 75 ;made from the ICD9 codes associated with the current order and thier 76 ;descriptions pulled from the ICD DIAGNOSIS file #80. The string can 77 ;contain up to four diagnoses codes and thier descriptions. The string 78 ;with all four possiable diagnoses codes is formatted: 79 ;ICD901^DESC01^ICD902^DESC02^ICD903^DESC03^ICD904^DESC04 80 ; 81 ;Input Variable: 82 ; IEN 83 ;Local Variables: 84 ; DCD Diagnosis Code Description (retrun variable) 85 ; DXDT Diagnosis Date (either Order date or system date) 86 ; DXD Diagnosis Description 87 ; DXIEN Diagnosis Internal Entry Number 88 ; ICD9 ICD9 code (for GUI display) 89 ; IENS Internale Entry Number Sequence 90 ; (Array index variable for data returned from lookup) 91 ; ORRF Order Record Found (returned data from lookup) 92 ; OREM Order Record Error Message 93 N DCD,DXDT,DXD,DXIEN,ICD9,IENS,ORRF,OREM 94 S DCD="" 95 D GETS^DIQ(100,IEN,".8*;5.1*","I","ORRF","OREM") 96 I $D(ORRF) D 97 . S DXDT="" 98 . I $D(ORRF(100.008)) S DXDT=$G(ORRF(100.008,"1,"_IEN_",",.01,"I")) 99 . I DXDT="" S DXDT=$$NOW^XLFDT 100 . I $D(ORRF(100.051)) D 101 .. S IENS="" F S IENS=$O(ORRF(100.051,IENS)) Q:IENS="" D 102 ... I ORRF(100.051,IENS,.01,"I")="" S DCD=DCD_U Q 103 ... S DXIEN=ORRF(100.051,IENS,.01,"I") 104 ... S ICD9=$$GET1^DIQ(80,DXIEN,.01,"") 105 ... S DXD=$$SETDXD^ORWDBA2($P($$ICDDX^ICDCODE(ICD9,DT),U,4)) 106 ... S DCD=$S(DCD="":ICD9_U_DXD,1:DCD_U_ICD9_U_DXD) 107 Q DCD 108 ; 109 GETBAUSR(Y,ORCIEN) ;GUI RPC CALL 110 ;Get Billing Awareness By User parameter value 111 ;Gets and returns the value of the Enabled Billing Awareness By User 112 ;parameter assigned to a provider. 113 ;Input Variable: 114 ; ORCIEN Ordering Clinician's Internal Entry Number 115 ;Output Variable: 116 ; Y Parameter value, 1 if enabled, 0 if disabled 117 S Y=$$GET^XPAR(ORCIEN_";VA(200,","OR BILLING AWARENESS BY USER",1,"Q") 118 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA7.m
r613 r623 1 ORWDBA7 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195,215,243**;Dec 17, 1997;Build 242 3 4 BDOEDIT 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 S ANCILARY=$P($G(^DIC(9.4,$P($G(^OR(100,ORIFN,0)),U,14),0)),U,2) 39 40 41 42 43 44 45 46 47 48 49 50 51 OUTPUT 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 CKROUTAG(TAGROU) 70 71 72 73 TFGBLTBL(GBL) 74 75 ; AO^IR^SC^EC^MST^HNC^CV^SHD('^' delimited string) format76 77 ; Input: GBL in 1^1^0^0^^^0^(global) format78 ; Output: TBL in 0^0^1^^1^^0^(TBL) format (also reordered)79 80 81 S TBL="",NTF=8;NCI=# of TxF82 83 84 85 86 87 88 89 90 91 92 VAR 93 94 95 96 97 98 99 100 ISWITCH(Y,DFN) 101 102 103 104 GETIEN9(Y,ICD9) 105 106 107 108 CONDTLD 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 . F EYE=1:1:8S TF=$P(^OR(100,ORIFN,5.2),U,EYE) I TF D133 134 135 1 ORWDBA7 ;;SLC/GSS Billing Awareness (CIDC-Clinical Indicators Data Capture) 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195,215**;Dec 17, 1997 3 ; 4 BDOEDIT ; Backdoor entered orders edit in CPRS - entry point 5 ; Data Flow> Ancillary creates a back door order which is incomplete 6 ; and thus edited in CPRS GUI. The ancillary needs to know 7 ; what Dx and TF's are edited thus this tag calls three 8 ; ancillary APIs, passing the Dx and TF data to them. 9 ; 10 ; Variable Description 11 ; ANCILARY Acronym of ancillary/package relative to order 12 ; DXN Diagnosis sequence number in ^OR file 13 ; MSG Error message 14 ; ORDX Array of diagnoses (1-n) with value from ICD file (#80) 15 ; ORIFN Order internal reference number (defined in ORCSEND) 16 ; ORITEM Package reference or ^OR(100,ORIFN,4) 17 ; ORSCEI String of Treatment Factors in table SD008 order/format 18 ; PTIEN Patient IEN 19 ; TAGROU Tag^Routine of ancillary routine to store edited data 20 ; TFO Treatment Factors in ^OR (GBL) order 21 ; 22 ; If CIDC master switch set, then no back door orders to store 23 I $$BASTAT^ORWDBA1=0 Q ;CIDC (nee BA) not used 24 ; If ORIFN not defined (God only knows why) then log error and quit 25 I '$D(ORIFN) S MSG="ORIFN not defined" D VAR,EN^ORERR(MSG,"",.VAR) Q 26 ; 27 N ANCILARY,DXN,MSG,ORDX,ORITEM,ORSCEI,PTIEN,RT,SUCCESS,TAGROU,TFO,VAR 28 ; 29 S DXN=0,(RT,SUCCESS)="",PTIEN=+$P($G(^OR(100,ORIFN,0)),U,2) 30 ; Package (ancillary) reference data 31 S ORITEM=$G(^OR(100,ORIFN,4)) 32 ; Create an array (ORDX) of diagnoses 33 F S DXN=$O(^OR(100,ORIFN,5.1,DXN)) Q:'DXN D 34 . S ORDX(DXN)=$G(^OR(100,ORIFN,5.1,DXN,0)) 35 ; Treatment Factors - converted and reformatted 36 S ORSCEI=$$TFGBLTBL($G(^OR(100,ORIFN,5.2))) 37 ; Get the acronym of the package generating this order 38 S ANCILARY=$P($G(^DIC(9.4,$P($G(^OR(100,ORIFN,0)),U,14),0)),U,2) ;D??? 39 ; Send data to the appropriate ancillary API based on package 40 D OUTPUT 41 ; If ancillary routine or tag w/in the routine doesn't exist check 42 I 'RT D 43 . S MSG="NON-EXISTANT ROUTINE/TAG FOR "_ANCILARY 44 . D VAR,EN^ORERR(MSG,"",.VAR) 45 ; If we don't get back a thumbs-up from the ancillary re: the order data 46 I 'SUCCESS,RT D 47 . S MSG="ANCILLARY API RETURNED ERROR FOR CPRS EDITED BACK DOOR DATA" 48 . D VAR,EN^ORERR(MSG,"",.VAR) 49 Q 50 ; 51 OUTPUT ; Call ancillary's API to store data after checking for it's existence 52 ; 53 ; Laboratory 54 I ANCILARY?1"LR".U D Q 55 . S RT=$$CKROUTAG("UPDOR^LRBEBA4") Q:'RT 56 . S SUCCESS=$$UPDOR^LRBEBA4(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI) ;IA 4775 57 ; 58 ; Pharmacy 59 I ANCILARY?1"PS".U D Q 60 . S RT=$$CKROUTAG("EN^PSOHLNE3") Q:'RT 61 . S SUCCESS=$$EN^PSOHLNE3(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI) ;IA 4666 62 ; 63 ; Radiolgy 64 I ANCILARY?1"RA".U D Q 65 . S RT=$$CKROUTAG("CPRSUPD^RABWORD1") Q:'RT 66 . S SUCCESS=$$CPRSUPD^RABWORD1(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI) ;IA 4771 67 Q 68 ; 69 CKROUTAG(TAGROU) ;Check if valid tag and routine 70 ; Temporary check until all the ancillaries have their API's built 71 Q $L($T(@TAGROU)) 72 ; 73 TFGBLTBL(GBL) ;Convert Tx Factors from Global to TBL (HL7) order & format 74 ; Note: this does not set Tx Factors in ZCL segment format but rather 75 ; AO^IR^SC^EC^MST^HNC^CV ('^' delimited string) format 76 ; 77 ; Input: GBL in 1^1^0^0^^^0 (global) format 78 ; Output: TBL in 0^0^1^^1^^0 (TBL) format (also reordered) 79 ; 80 N J,NTF,TBL,TF,TFGBL,TFGUI,TFTBL 81 S TBL="",NTF=7 ;NCI=# of TxF 82 ; Get Treatment Factor sequence order strings 83 D TFSTGS^ORWDBA1 84 ; Convert from GBL to TBL format and sequence 85 F J=1:1:NTF S TF=$P(GBL,U,J) D 86 . ;OK..just in case there is a '?' we'll return a null for a '?' 87 . S TF($P(TFGBL,U,J))=$S(TF=1:1,TF=0:0,TF="?":"",1:"") 88 F J=1:1:NTF S TBL=TBL_U_TF($P(TFTBL,U,J)) 89 ; Remove the first '^' and pass TBL formatted TF's 90 Q $E(TBL,2,99) 91 ; 92 VAR ;Create VAR array for tracking error in ^ORYX("ORERR",err#) 93 S VAR("DFN")=PTIEN 94 S VAR("ORITEM")=ORITEM 95 S VAR("ORIFN")=ORIFN 96 M VAR("ORDX")=ORDX 97 S VAR("ORSCEI")=ORSCEI 98 Q 99 ; 100 ISWITCH(Y,DFN) ;Return 0 if don't ask (no ins) or 1 to ask CIDC quest (yes ins) 101 S Y=$$CIDC^IBBAPI(DFN) 102 Q 103 ; 104 GETIEN9(Y,ICD9) ;Return IEN for an ICD9 code (RPC: ORWDBA7 GETIEN9) 105 S Y=$P($$CODEN^ICDCODE(ICD9,80),"~") 106 Q 107 ; 108 CONDTLD ;Consult Detailed Display Compile for CIDC/BA (called by GMRCSLM2) 109 ; Input: ORIFN and GMRCCT defined in GMRCSLM2 110 ; Output: CIDCARY = array of CIDC display lines for GMRCSLM2 display 111 N BGNRCCT,DXIEN,DXOF,DXV,EYE,ICD9,ICDR,LINE,OCT,ORFMDAT,TF 112 S BGNRCCT=GMRCCT,OCT=0 113 ; Get the date of the order for CSV/CTD usage 114 S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIFN) 115 ; $O through diagnoses for an order 116 F S OCT=$O(^OR(100,ORIFN,5.1,OCT)) Q:OCT'?1N.N D 117 . S DXOF=" " 118 . ; DXIEN=Dx IEN 119 . S DXIEN=+^OR(100,ORIFN,5.1,OCT,0) 120 . ; Get Dx record for date ORFMDAT 121 . S ICDR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) 122 . ; Get Dx verbiage and ICD code 123 . S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2) 124 . I OCT=1 D 125 .. S CIDCARY(GMRCCT,0)=" ",GMRCCT=GMRCCT+1 ;blank line 126 .. S CIDCARY(GMRCCT,0)="Clinical Indicators",GMRCCT=GMRCCT+1 127 .. S DXOF="Diagnosis of: " 128 . S LINE=DXOF_ICD9_" - "_DXV 129 . S CIDCARY(GMRCCT,0)=LINE,GMRCCT=GMRCCT+1 130 I OCT'="" D ;if there are diagnoses then show Treatment Factors 131 . S LINE="For conditions related to: " 132 . F EYE=1:1:7 S TF=$P(^OR(100,ORIFN,5.2),U,EYE) I TF D 133 .. S CIDCARY(GMRCCT,0)=LINE_$$SC^ORQ21(EYE) 134 .. S X=$$REPEAT^XLFSTR(" ",30),GMRCCT=GMRCCT+1 135 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDFH.m
r613 r623 1 ORWDFH 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,141,187,215,243**;Dec 17, 1997;Build 242 3 TXT(LST,DFN) 4 5 6 7 8 9 10 11 12 FUT(LST,DFN) 13 14 15 16 17 18 19 20 PARAM(ORLST,ORVP,ORLOC) 21 22 23 24 25 26 27 28 29 30 31 I +$G(^SC(ORLOC,42)) S ORLOC=$G(^SC(ORLOC,42))_";DIC(42"32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 ATTR(REC,OI) 52 53 54 55 DIETS(Y,FROM,DIR) 56 57 58 59 60 61 62 63 64 65 66 67 68 OPDIETS(ORY,FROM,DIR) 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 TFPROD(Y) 86 87 88 89 90 91 92 93 94 95 96 QTY2CC(VAL,PRD,STR,QTY) 97 98 99 100 101 102 103 104 FINDTYP(VAL,DGRP) 105 106 107 108 ISOIEN(VAL) 109 110 111 CURISO(VAL,ORVP) 112 113 114 115 ISOLIST(LST) 116 117 118 119 120 MILTM(X) 121 122 123 124 125 126 127 ASKLATE(REC,DFN,ORIFN) 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 ADDLATE(REC,ORVP,ORNP,ORL,MEAL,TIME,BAG) 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 CURMEALS(ORY,ORDFN,ORMEAL) 161 162 163 164 165 166 167 168 169 NFSLOC(ORLOC) 170 171 OPLOCOK(ORY,ORLOC) 172 173 174 1 ORWDFH ; SLC/KCM/JLI - Diet Order calls for Windows Dialogs ;12/12/00 14:44 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,141,187,215**;Dec 17, 1997 3 TXT(LST,DFN) ; Return text of current & future diets for a patient 4 S LST(1)="Current Diet: "_$$DIET^ORCDFH(DFN) 5 N FUTLST D FUT(.FUTLST,DFN) I $D(FUTLST)>1 D 6 . S LST(2)="Future Diet Orders:",ILST=2 7 . S I=0 F S I=$O(FUTLST(I)) Q:'I D 8 . . S X=$$FMTE^XLFDT(I,2)_" "_$P(FUTLST(I),U,2) 9 . . S LST(ILST)=$S(ILST=2:"Future Diet Orders: "_X,1:" "_X) 10 . . S ILST=ILST+1 11 Q 12 FUT(LST,DFN) ; Return a list of future diet orders 13 N DGRP,NXTDT,ORIFN,ORVP,ORTX 14 S ORVP=DFN_";DPT(",DGRP=$O(^ORD(100.98,"B","DO",0)),NXTDT=$$NOW^XLFDT 15 F S NXTDT=$O(^OR(100,"AW",ORVP,DGRP,NXTDT)) Q:NXTDT'>0 D 16 . S ORIFN=+$O(^OR(100,"AW",ORVP,DGRP,NXTDT,0)) 17 . I $P($G(^OR(100,ORIFN,3)),U,3)'=8 Q ; only scheduled diets 18 . D TEXT^ORQ12(.ORTX,ORIFN) S LST(NXTDT)=NXTDT_U_$G(ORTX(1)) 19 Q 20 PARAM(ORLST,ORVP,ORLOC) ; Return dietetics parameters for a patient at a location 21 ; ORLOC: hospital location ptr to ^SC #44 22 ; ORLST(1)=EB1^EB2^EB3^LB1^LB2^LB3^EN1^EN2^...LE2^LE3 23 ; ORLST(2)=BAB^BAE^NAB^NAE^EAB^EAE^BegB^BegN^BegE^Bagged 24 ; ORLST(3)=type of service^RegIEN^NPOIEN^EarlyIEN^LateIEN^TFIFN 25 ; ORLST(4)=max days in future for outpatient recurring meals 26 ; ORLST(5)=default outpatient diet 27 Q:'+ORVP 28 N X,IEN,CURTM 29 S ORVP=+ORVP_";DPT(",ORLOC=+ORLOC 30 S CURTM=$$NOW^XLFDT 31 I $D(^SC(ORLOC,42)) S ORLOC=$G(^SC(ORLOC,42))_";DIC(42" 32 E S ORLOC=ORLOC_";SC(" 33 D EN1^FHWOR8(ORLOC,.ORLST) 34 ; 35 I '$L($G(ORLST(3))) S ORLST(3)="T" 36 S $P(ORLST(3),U,2)=$O(^ORD(101.43,"S.DIET","REGULAR",0)) 37 S $P(ORLST(3),U,3)=$O(^ORD(101.43,"S.DIET","NPO",0)) 38 S $P(ORLST(3),U,4)=$O(^ORD(101.43,"S.E/L T","EARLY TRAY",0)) 39 S $P(ORLST(3),U,5)=$O(^ORD(101.43,"S.E/L T","LATE TRAY",0)) 40 N TF S TF=$$CURRENT^ORCDFH("TF") I $L(TF,";")=1 S TF=TF_";1" 41 I TF,'$$FUTURE^ORCDFH("EFFECTIVE DATE/TIME") S $P(ORLST(3),U,6)=TF 42 I $$VERSION^XPDUTL("FH")>5 D 43 . S ORLST(4)=$$MAXDAYS^FHOMAPI(ORLOC) 44 . D DIETLST^FHOMAPI Q:'$G(FHDIET(1)) 45 . S IEN=$O(^ORD(101.43,"ID",$P(FHDIET(1),U,1)_";99FHD",0)) Q:+IEN=0 46 . S X=^ORD(101.43,"S.DIET",$P(FHDIET(1),U,2),IEN) 47 . I +$P(X,U,3),$P(X,U,3)<CURTM Q 48 . I $P($G(^ORD(101.43,IEN,"FH")),U)'="D",($P($G(^(0)),U)'="NPO") Q 49 . S ORLST(5)=+$G(IEN) 50 Q 51 ATTR(REC,OI) ; Return OI^Text^Type^Precedence^AskExpire for a diet 52 I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT S REC="0^"_$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." Q 53 S REC=OI_U_$P($G(^ORD(101.43,OI,0)),U)_U_$G(^("FH")) 54 Q 55 DIETS(Y,FROM,DIR) ; Return a subset of active diets, including NPO 56 ; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name 57 N I,IEN,CNT,X,CURTM 58 S I=0,CNT=44,CURTM=$$NOW^XLFDT 59 F Q:I'<CNT S FROM=$O(^ORD(101.43,"S.DIET",FROM),DIR) Q:FROM="" D 60 . S IEN=0 F S IEN=$O(^ORD(101.43,"S.DIET",FROM,IEN)) Q:'IEN D 61 . . S X=^ORD(101.43,"S.DIET",FROM,IEN) 62 . . I +$P(X,U,3),$P(X,U,3)<CURTM Q 63 . . I $P($G(^ORD(101.43,IEN,"FH")),U)'="D",($P($G(^(0)),U)'="NPO") Q 64 . . S I=I+1 65 . . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2) 66 . . E S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4) 67 Q 68 OPDIETS(ORY,FROM,DIR) ;Return a list of up to 5 outpatient diets from file 119.9 69 N X,I,J,IEN,CURTM,SYNCNT,SYNTOT,FHDIET 70 D DIETLST^FHOMAPI 71 S CURTM=$$NOW^XLFDT,I=0,SYNTOT=1 72 F S I=$O(FHDIET(I)) Q:'I D 73 . S IEN=$O(^ORD(101.43,"ID",$P(FHDIET(I),U,1)_";99FHD",0)) Q:+IEN=0 74 . S X=^ORD(101.43,"S.DIET",$P(FHDIET(I),U,2),IEN) 75 . I +$P(X,U,3),$P(X,U,3)<CURTM Q 76 . I $P($G(^ORD(101.43,IEN,"FH")),U)'="D",($P($G(^(0)),U)'="NPO") Q 77 . S X=$P(^ORD(101.43,IEN,0),U,1) 78 . S SYNCNT=$P($G(^ORD(101.43,IEN,2,0)),U,4),J=0 79 . S ORY(X)=IEN_U_X_U_X 80 . I +SYNCNT D Q 81 . . S SYNTOT=SYNTOT+SYNCNT 82 . . F S J=$O(^ORD(101.43,IEN,2,J)) Q:'J D 83 . . . S ORY(^ORD(101.43,IEN,2,J,0))=IEN_U_^ORD(101.43,IEN,2,J,0)_$C(9)_"<"_X_">"_U_X 84 Q 85 TFPROD(Y) ; Return a list of active tubefeeding products 86 N I,IEN,NAM,X,CURTM 87 S I=0,NAM="",CURTM=$$NOW^XLFDT 88 F S NAM=$O(^ORD(101.43,"S.TF",NAM)) Q:NAM="" D 89 . S IEN=0 F S IEN=$O(^ORD(101.43,"S.TF",NAM,IEN)) Q:'IEN D 90 . . S X=^ORD(101.43,"S.TF",NAM,IEN) 91 . . I +$P(X,U,3),$P(X,U,3)<CURTM Q 92 . . S I=I+1 93 . . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2) 94 . . E S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4) 95 Q 96 QTY2CC(VAL,PRD,STR,QTY) ; Return cc's given a product, strength, & quantity 97 N X,VQTY,DUR 98 S VQTY=$$VALIDQTY^ORCDFHTF(QTY) I '$L(VQTY)!('PRD)!('STR) S VAL="" Q 99 S PRD=+$P($G(^ORD(101.43,PRD,0)),U,2) 100 S DUR=$P(VQTY," X ",2) I $L(DUR) S DUR=$S(DUR["H":"H",1:"X")_+DUR 101 S X=+VQTY_"&"_$E($P(VQTY," ",2))_U_$P($P(VQTY,"/",2)," ")_U_DUR 102 S VAL=$$QUAN^FHWOR5R(PRD_"-"_STR,X)_U_VQTY 103 Q 104 FINDTYP(VAL,DGRP) ; Return type of dietetics order based on display group 105 S VAL=$P($G(^ORD(100.98,DGRP,0)),U,3) 106 S:VAL="D AO" VAL="A" S VAL=$E(VAL) 107 Q 108 ISOIEN(VAL) ; Return IEN for the Isolation/Precaution orderable item 109 S VAL=$O(^ORD(101.43,"S.PREC","ISOLATION PROCEDURES",0)) 110 Q 111 CURISO(VAL,ORVP) ; Return a patient's current isolation 112 S ORVP=ORVP_";DPT(" S VAL=$P($$IP^ORMBLD,U,2) 113 I '$L(VAL) S VAL="<none>" 114 Q 115 ISOLIST(LST) ; Return list of active isolations/precautions 116 N I,X,IEN 117 S I=0,X="" F S X=$O(^FH(119.4,"B",X)) Q:X="" S IEN=$O(^(X,0)) D 118 . I '$D(^FH(119.4,IEN,"I")) S I=I+1,LST(I)=IEN_U_X 119 Q 120 MILTM(X) ; return military time for am/pm time 121 N TM 122 S TM=$P(X,":",1)_+$P(X,":",2) 123 I X["P",TM<1200 S TM=TM+1200 124 I X["A",TM>1200 S TM=TM-1200 125 Q TM 126 ; 127 ASKLATE(REC,DFN,ORIFN) ; Return info for ordering late tray for diet order 128 ; REC=0 or 1^meal^bagged^time^time^time 129 S REC=0 Q:'$G(ORIFN) Q:$E($$VALUE^ORX8(ORIFN,"ORDERABLE",1,"E"),1,3)="NPO" 130 N X,Y,%DT,STRT,DATE,ORPARAM,I,MEAL,MEALTIME 131 S X=$O(^OR(100,ORIFN,4.5,"ID","START",0)),X=$G(^OR(100,ORIFN,4.5,+X,1)) 132 Q:X="" S %DT="TX" D ^%DT Q:Y'>0 Q:$P(Y,".")>DT ;invalid or future 133 S DATE=$P(Y,"."),STRT=+$E($P(Y,".",2)_"0000",1,4),MEAL=0 134 D EN^FHWOR8(DFN,.ORPARAM) Q:'$D(ORPARAM(2)) 135 F I=1,3,5 I $P(ORPARAM(2),U,I)<STRT,STRT<$P(ORPARAM(2),U,I+1) S MEAL=I Q 136 S MEAL=$S(MEAL=1:4,MEAL=3:10,MEAL=5:16,1:0) Q:'MEAL 137 S MEALTIME=$P(ORPARAM(1),U,MEAL,MEAL+2) 138 S MEAL=$S(MEAL=4:"B",MEAL=10:"N",MEAL=16:"E",1:"") 139 F I=1:1:3 S X=$$MILTM($P(MEAL,U,I)) I X<STRT S $P(MEAL,U,I)="" 140 S REC="1"_U_MEAL_U_$P(ORPARAM(2),U,10)_U_MEALTIME 141 I $P(REC,U,2,4)="^^" S REC=0 142 Q 143 ADDLATE(REC,ORVP,ORNP,ORL,MEAL,TIME,BAG) ; Add late tray order 144 N ORIFN,ORNEW,ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORCHECK,ORLOG 145 N ORDIALOG,ORDG,ORTYPE,DA,FIRST,TRAY 146 S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2) 147 S ORTYPE="D",FIRST=1,ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12) 148 S TRAY=+$O(^ORD(101.43,"S.E/L T","LATE TRAY",0)) 149 S ORDIALOG=$O(^ORD(101.41,"AB","FHW2",0)) 150 D GETDLG^ORCD(ORDIALOG) 151 S ORDIALOG($$PTR^ORCD("OR GTX MEAL"),1)=MEAL 152 S ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)=TRAY 153 S ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1)=DT 154 S ORDIALOG($$PTR^ORCD("OR GTX STOP DATE"),1)=DT 155 S ORDIALOG($$PTR^ORCD("OR GTX MEAL TIME"),1)=TIME 156 S ORDIALOG($$PTR^ORCD("OR GTX YES/NO"),1)=BAG 157 D EN^ORCSAVE 158 S REC="" I ORIFN D GETBYIFN^ORWORR(.REC,ORIFN) 159 Q 160 CURMEALS(ORY,ORDFN,ORMEAL) ;Return current list of recurring meals for AO and TF orders 161 N I,Y,X S I=0 162 S ORMEAL=$G(ORMEAL,"") 163 D EN2^FHWOR8(ORDFN,ORMEAL,.ORY) 164 F S I=$O(ORY(I)) Q:'I D 165 . S X=$P(ORY(I),U,2) 166 . S Y=$P(ORY(I),U,1) D DD^%DT S $P(ORY(I),U,2)=Y 167 . S $P(ORY(I),U,3)=$S(X="B":"Breakfast",X="N":"Noon",X="E":"Evening",1:"") 168 Q 169 NFSLOC(ORLOC) ;Get NUTRITION LOCATION name for HOSPITAL LOCATION 170 Q $$NFSLOC^FHOMAPI(ORLOC) 171 OPLOCOK(ORY,ORLOC) ; OK to order OP Meals from this location 172 I 'ORLOC S ORY=0 Q 173 S ORY=$S($L($$NFSLOC^FHOMAPI(ORLOC))>0:1,1:0) 174 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDGX.m
r613 r623 1 ORWDGX ; SLC/KCM - Generic Orders calls for Windows Dialogs [ 08/05/96 8:21 AM ] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242 3 ; 4 ACT() N X,RSLT S X=^(0),RSLT=1 5 I "DQ"'[$P(X,U,4) S RSLT=0 6 S X1=$O(^ORD(100.98,"B","ACTIVITY",0)) 7 S X2=$O(^ORD(100.98,"B","NURSING",0)) 8 I "DQ"'[$P(X,U,4) S RSLT=0 9 I RSLT,((U_X1_U_X2_U)'[(U_$P(X,U,5)_U)) S RSLT=0 10 Q RSLT 11 NURS() N X,RSLT S X=^(0),RSLT=1 12 I "DQ"'[$P(X,U,4) S RSLT=0 13 I RSLT,($P(X,U,5)'=$O(^ORD(100.98,"B","NURSING",0))) S RSLT=0 14 Q RSLT 15 OITEXT(Y,DLG) ; Return Orderable Item Text given dialog or quick order 16 S Y=$P(^ORD(101.41,DLG,0),U,2) 17 Q 18 LOAD(LST,PAR) ; Load a list of activity orders 19 N I,ILST,DLG,NAM,TLST 20 D GETLST^XPAR(.TLST,"ALL",PAR) 21 S I=0,ILST=0 F S I=$O(TLST(I)) Q:'I D 22 . S DLG=$P(TLST(I),U,2),NAM=$P(^ORD(101.41,+DLG,0),U,2) 23 . S ILST=ILST+1,LST(ILST)=DLG_U_NAM 24 Q 25 ; 26 N DLGTYP,OIDLG,FTDLG,OITYP,I,IFN 27 S DLGTYP=$P(^ORD(101.41,DLG,0),U,4) 28 S OIDLG=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) 29 S FTDLG=$O(^ORD(101.41,"B","OR GTX FREE TEXT OI",0)) 30 I DLGTYP="D" D 31 . S I=0,IFN=0 F S I=$O(^ORD(101.41,DLG,10,I)) S X=^(I,0) D Q:IFN 32 . . I $P(X,U,2)=OIDLG S IFN=I,OITYP="O" 33 . . I $P(X,U,2)=FTDLG S IFN=I,OITYP="F" 34 . S Y="" I $L($G(^ORD(101.41,DLG,10,IFN,7))) X ^(7) 35 . I OITYP="O" S Y=$P(^ORD(101.43,+Y,0),U,1) 36 Q 37 VMDEF(LST) ; Return dialog definition for vitals/measurements 38 N ILST S ILST=0 39 S LST($$NXT)="~Measurements" D MEASURE 40 S LST($$NXT)="~Schedules" D VMSCHED 41 Q 42 MEASURE ; Get measurements available 43 S X="" F S X=$O(^ORD(101.43,"S.V/M",X)) Q:X="" D 44 . S I=$O(^ORD(101.43,"S.V/M",X,0)),LST($$NXT)="i"_I_U_X 45 S LST($$NXT)="dTPR B/P" ; ** do this with a parameter 46 Q 47 VMSCHED ; Get vitals/measurements schedules 48 K ^TMP($J,"ORWDGX APGMRV") 49 D AP^PSS51P1("GMRV",,,,"ORWDGX APGMRV") 50 S X="" F S X=$O(^TMP($J,"ORWDGX APGMRV","APGMRV",X)) Q:X="" D 51 . S I=$O(^TMP($J,"ORWDGX APGMRV","APGMRV",X,0)),LST($$NXT)="i"_I_U_X 52 K ^TMP($J,"ORWDGX APGMRV") 53 Q 54 NXT() ; Increment index into LST 55 S ILST=ILST+1 56 Q ILST 1 ORWDGX ; SLC/KCM - Generic Orders calls for Windows Dialogs [ 08/05/96 8:21 AM ] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 3 ; 4 ACT() N X,RSLT S X=^(0),RSLT=1 5 I "DQ"'[$P(X,U,4) S RSLT=0 6 S X1=$O(^ORD(100.98,"B","ACTIVITY",0)) 7 S X2=$O(^ORD(100.98,"B","NURSING",0)) 8 I "DQ"'[$P(X,U,4) S RSLT=0 9 I RSLT,((U_X1_U_X2_U)'[(U_$P(X,U,5)_U)) S RSLT=0 10 Q RSLT 11 NURS() N X,RSLT S X=^(0),RSLT=1 12 I "DQ"'[$P(X,U,4) S RSLT=0 13 I RSLT,($P(X,U,5)'=$O(^ORD(100.98,"B","NURSING",0))) S RSLT=0 14 Q RSLT 15 OITEXT(Y,DLG) ; Return Orderable Item Text given dialog or quick order 16 S Y=$P(^ORD(101.41,DLG,0),U,2) 17 Q 18 LOAD(LST,PAR) ; Load a list of activity orders 19 N I,ILST,DLG,NAM,TLST 20 D GETLST^XPAR(.TLST,"ALL",PAR) 21 S I=0,ILST=0 F S I=$O(TLST(I)) Q:'I D 22 . S DLG=$P(TLST(I),U,2),NAM=$P(^ORD(101.41,+DLG,0),U,2) 23 . S ILST=ILST+1,LST(ILST)=DLG_U_NAM 24 Q 25 ; 26 N DLGTYP,OIDLG,FTDLG,OITYP,I,IFN 27 S DLGTYP=$P(^ORD(101.41,DLG,0),U,4) 28 S OIDLG=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) 29 S FTDLG=$O(^ORD(101.41,"B","OR GTX FREE TEXT OI",0)) 30 I DLGTYP="D" D 31 . S I=0,IFN=0 F S I=$O(^ORD(101.41,DLG,10,I)) S X=^(I,0) D Q:IFN 32 . . I $P(X,U,2)=OIDLG S IFN=I,OITYP="O" 33 . . I $P(X,U,2)=FTDLG S IFN=I,OITYP="F" 34 . S Y="" I $L($G(^ORD(101.41,DLG,10,IFN,7))) X ^(7) 35 . I OITYP="O" S Y=$P(^ORD(101.43,+Y,0),U,1) 36 Q 37 VMDEF(LST) ; Return dialog definition for vitals/measurements 38 N ILST S ILST=0 39 S LST($$NXT)="~Measurements" D MEASURE 40 S LST($$NXT)="~Schedules" D VMSCHED 41 Q 42 MEASURE ; Get measurements available 43 S X="" F S X=$O(^ORD(101.43,"S.V/M",X)) Q:X="" D 44 . S I=$O(^ORD(101.43,"S.V/M",X,0)),LST($$NXT)="i"_I_U_X 45 S LST($$NXT)="dTPR B/P" ; ** do this with a parameter 46 Q 47 VMSCHED ; Get vitals/measurements schedules 48 S X="" F S X=$O(^PS(51.1,"APGMRV",X)) Q:X="" D 49 . S I=$O(^PS(51.1,"APGMRV",X,0)),LST($$NXT)="i"_I_U_X 50 Q 51 NXT() ; Increment index into LST 52 S ILST=ILST+1 53 Q ILST -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR.m
r613 r623 1 ORWDLR ; SLC/KCM - Lab Calls [ 08/04/96 8:47 PM ] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242 3 ; 4 DEF(LST,ALOC) ; procedure 5 ; get dialog definition specific to lab 6 S ILST=0 7 S LST($$NXT)="~Collection Times" D COLLTM 8 S LST($$NXT)="~Send Patient Times" D SENDTM 9 S LST($$NXT)="~Default Urgency="_$$DEFURG^LR7OR3 10 ; S LST($$NXT)="~Urgencies Map" D URGMAP 11 S LST($$NXT)="~Schedules" D SCHED 12 S LST($$NXT)="~Common" D COMMON 13 Q 14 COLLTM ; get collection times 15 N TDAY,TMRW,IGNOR,CNT,ICTM,CTM,DOW,AMPM,DAY,TIME,FMDT 16 S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H 17 M TMRW=TDAY D INCDATE(.TMRW) 18 I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D 19 . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q") 20 . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q") 21 . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q") 22 . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q") 23 . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q") 24 . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q") 25 . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q") 26 . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q") 27 . S CNT=0 F Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0)))) D Q:CNT>6 28 . . D INCDATE(.TDAY) S CNT=CNT+1 29 . S CNT=0 F Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0)))) D Q:CNT>6 30 . . D INCDATE(.TMRW) S CNT=CNT+1 31 D GETLST^XPAR(.CTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") 32 S ICTM=0 F S ICTM=$O(CTM(ICTM)) Q:'ICTM D 33 . I $P(CTM(ICTM),U)>$P($H,",",2) D 34 . . S FMDT=TDAY 35 . . I +TDAY("H")=+$H S DAY="Today" 36 . . I TDAY("H")-$H=1 S DAY="Tomorrow" 37 . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW")) 38 . E D 39 . . S FMDT=TMRW 40 . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow") 41 . S AMPM=$S($P(CTM(ICTM),U,2)>1159:"PM",1:"AM") 42 . S FMDT=FMDT_"."_$P(CTM(ICTM),"^",2) 43 . S TIME=$P(CTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) 44 . S LST($$NXT)="iL"_FMDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")" 45 D NOW^%DTC 46 S LST($$NXT)="iW"_%_"^Now (Collect on ward)" 47 Q 48 SENDTM ; get send patient times 49 N X,X1,X2 50 S LST($$NXT)="iL"_DT_"^Today" 51 S X1=DT,X2=1 D C^%DTC 52 S LST($$NXT)="iL"_X_"^Tomorrow" 53 Q 54 INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE 55 N X,X1,X2,%H 56 S X1=ADATE,X2=1 D C^%DTC S ADATE=X 57 S ADATE("H")=ADATE("H")+1 58 S ADATE("DOW")=ADATE("H")#7 59 Q 60 DOWNAME(DOW) ; function 61 ; Returns Day of Week name (DOW should be $H#7) 62 I DOW=0 Q "Thursday" 63 I DOW=1 Q "Friday" 64 I DOW=2 Q "Saturday" 65 I DOW=3 Q "Sunday" 66 I DOW=4 Q "Monday" 67 I DOW=5 Q "Tuesday" 68 I DOW=6 Q "Wednesday" 69 Q "" 70 URGMAP ; return list of lab urgencies mapped to OE/RR urgencies 71 Q 72 N I,X 73 S I=0 F S I=$O(^LAB(62.05,I)) Q:'I S X=^(I,0) I '$P(X,U,3) D 74 . S LST($$NXT)="i"_I_"="_I_U_$P(X,U) 75 ; D GETLST^XPAR(.Y,"ALL","ORCDLR URGENCIES","N") 76 ; S URG=0 F S URG=$O(Y(URG)) Q:'URG S LST($$NXT)="i"_URG_"="_Y(URG) 77 Q 78 SCHED ; return list of schedules available for lab tests 79 N X,IEN 80 K ^TMP($J,"ORWDLR APLR") 81 D AP^PSS51P1("LR",,,,"ORWDLR APLR") 82 S X="" F S X=$O(^TMP($J,"ORWDLR APLR","APLR",X)) Q:X="" D 83 . S IEN=$O(^TMP($J,"ORWDLR APLR","APLR",X,"")) I IEN'>0 Q 84 . S LST($$NXT)="i"_IEN_U_X_U_$P($G(^TMP($J,"ORWDLR APLR",IEN,5)),U) 85 . I X="ONE TIME" S LST($$NXT)="d"_X 86 K ^TMP($J,"ORWDLR APLR") 87 Q 88 COMMON ; return list of commonly ordered lab tests 89 N TMPLST,IEN,I 90 D GETLST^XPAR(.TMPLST,"ALL","ORWD COMMON LAB INPT") 91 S I=0 F S I=$O(TMPLST(I)) Q:'I D 92 . S IEN=$P(TMPLST(I),U,2) 93 . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1) 94 Q 95 LOAD(LST,TESTID) ; procedure 96 ; Return sample, specimen, & urgency info about a lab test 97 N X,Y,ILST,PARAM S ILST=0 98 S LST($$NXT)="~Test Name="_$P(^ORD(101.43,TESTID,0),U,1) 99 I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage" 100 S I=0 F S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I S LST($$NXT)="t"_^(I,0) 101 S TESTID=+$P(^ORD(101.43,TESTID,0),U,2) 102 D TEST^LR7OR3(TESTID,.Y) 103 S PARAM="" F S PARAM=$O(Y(PARAM)) Q:PARAM="" D 104 . S LST($$NXT)="~"_PARAM_$S($D(Y(PARAM))>1:"",1:"="_$G(Y(PARAM))) 105 . I $D(Y(PARAM))>1 S I=0 F S I=$O(Y(PARAM,I)) Q:'I D 106 . . I PARAM="Specimens" S LST($$NXT)="i"_Y(PARAM,I) Q 107 . . I PARAM="Urgencies" S LST($$NXT)="i"_Y(PARAM,I) Q 108 . . S LST($$NXT)="i"_I_U_Y(PARAM,I) 109 . . I PARAM="CollSamp" D 110 . . . I $G(Y("Lab CollSamp")) S $P(LST(ILST),U,8)=1 111 . . . S X=+$P(Y(PARAM,I),U,3) 112 . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1) 113 . . I $D(Y(PARAM,I,"WP")) S J=0 F S J=$O(Y(PARAM,I,"WP",J)) Q:'J D 114 . . . S LST($$NXT)="t"_Y(PARAM,I,"WP",J,0) 115 Q 116 ALLSAMP(LST) ; procedure 117 ; returns all collection samples 118 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName 119 N SMP,SPC,ILST,IEN,X,X0 120 S ILST=0,LST($$NXT)="~CollSamp" 121 S SMP="" F S SMP=$O(^LAB(62,"B",SMP)) Q:SMP="" D 122 . S IEN=0 F S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN D 123 . . S X0=^LAB(62,IEN,0) 124 . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) 125 . . I $P(X0,U,2) D 126 . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) 127 . . . S SPC($P(X,U,4))=$P(X,U,10) 128 . . S LST($$NXT)=X 129 S LST($$NXT)="~Specimens" 130 S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) 131 Q 132 ABBSPEC(LST) ; procedure 133 ; returns specimens with abbreviation (uses 'E' xref) 134 N X,IEN,ILST S ILST=0 135 S X="" F S X=$O(^LAB(61,"E",X)) Q:X="" S IEN=$O(^(X,0)) D 136 . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1) 137 Q 138 NXT() ; called by TESTINFO, increments ILST 139 S ILST=ILST+1 140 Q ILST 141 STOP(VAL,X2) ; return a calculated stop date 142 N X1,X 143 S X1=DT D C^%DTC S VAL=X 144 Q 1 ORWDLR ; SLC/KCM - Lab Calls [ 08/04/96 8:47 PM ] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 3 ; 4 DEF(LST,ALOC) ; procedure 5 ; get dialog definition specific to lab 6 S ILST=0 7 S LST($$NXT)="~Collection Times" D COLLTM 8 S LST($$NXT)="~Send Patient Times" D SENDTM 9 S LST($$NXT)="~Default Urgency="_$$DEFURG^LR7OR3 10 ; S LST($$NXT)="~Urgencies Map" D URGMAP 11 S LST($$NXT)="~Schedules" D SCHED 12 S LST($$NXT)="~Common" D COMMON 13 Q 14 COLLTM ; get collection times 15 N TDAY,TMRW,IGNOR,CNT,ICTM,CTM,DOW,AMPM,DAY,TIME,FMDT 16 S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H 17 M TMRW=TDAY D INCDATE(.TMRW) 18 I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D 19 . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q") 20 . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q") 21 . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q") 22 . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q") 23 . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q") 24 . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q") 25 . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q") 26 . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q") 27 . S CNT=0 F Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0)))) D Q:CNT>6 28 . . D INCDATE(.TDAY) S CNT=CNT+1 29 . S CNT=0 F Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0)))) D Q:CNT>6 30 . . D INCDATE(.TMRW) S CNT=CNT+1 31 D GETLST^XPAR(.CTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") 32 S ICTM=0 F S ICTM=$O(CTM(ICTM)) Q:'ICTM D 33 . I $P(CTM(ICTM),U)>$P($H,",",2) D 34 . . S FMDT=TDAY 35 . . I +TDAY("H")=+$H S DAY="Today" 36 . . I TDAY("H")-$H=1 S DAY="Tomorrow" 37 . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW")) 38 . E D 39 . . S FMDT=TMRW 40 . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow") 41 . S AMPM=$S($P(CTM(ICTM),U,2)>1159:"PM",1:"AM") 42 . S FMDT=FMDT_"."_$P(CTM(ICTM),"^",2) 43 . S TIME=$P(CTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) 44 . S LST($$NXT)="iL"_FMDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")" 45 D NOW^%DTC 46 S LST($$NXT)="iW"_%_"^Now (Collect on ward)" 47 Q 48 SENDTM ; get send patient times 49 N X,X1,X2 50 S LST($$NXT)="iL"_DT_"^Today" 51 S X1=DT,X2=1 D C^%DTC 52 S LST($$NXT)="iL"_X_"^Tomorrow" 53 Q 54 INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE 55 N X,X1,X2,%H 56 S X1=ADATE,X2=1 D C^%DTC S ADATE=X 57 S ADATE("H")=ADATE("H")+1 58 S ADATE("DOW")=ADATE("H")#7 59 Q 60 DOWNAME(DOW) ; function 61 ; Returns Day of Week name (DOW should be $H#7) 62 I DOW=0 Q "Thursday" 63 I DOW=1 Q "Friday" 64 I DOW=2 Q "Saturday" 65 I DOW=3 Q "Sunday" 66 I DOW=4 Q "Monday" 67 I DOW=5 Q "Tuesday" 68 I DOW=6 Q "Wednesday" 69 Q "" 70 URGMAP ; return list of lab urgencies mapped to OE/RR urgencies 71 Q 72 N I,X 73 S I=0 F S I=$O(^LAB(62.05,I)) Q:'I S X=^(I,0) I '$P(X,U,3) D 74 . S LST($$NXT)="i"_I_"="_I_U_$P(X,U) 75 ; D GETLST^XPAR(.Y,"ALL","ORCDLR URGENCIES","N") 76 ; S URG=0 F S URG=$O(Y(URG)) Q:'URG S LST($$NXT)="i"_URG_"="_Y(URG) 77 Q 78 SCHED ; return list of schedules available for lab tests 79 N X,IEN 80 S X="" F S X=$O(^PS(51.1,"APLR",X)) Q:X="" S IEN=$O(^(X,0)) I IEN D 81 . S LST($$NXT)="i"_IEN_U_X_U_$P($G(^PS(51.1,IEN,0)),U,5) 82 . I X="ONE TIME" S LST($$NXT)="d"_X 83 Q 84 COMMON ; return list of commonly ordered lab tests 85 N TMPLST,IEN,I 86 D GETLST^XPAR(.TMPLST,"ALL","ORWD COMMON LAB INPT") 87 S I=0 F S I=$O(TMPLST(I)) Q:'I D 88 . S IEN=$P(TMPLST(I),U,2) 89 . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1) 90 Q 91 LOAD(LST,TESTID) ; procedure 92 ; Return sample, specimen, & urgency info about a lab test 93 N X,Y,ILST,PARAM S ILST=0 94 S LST($$NXT)="~Test Name="_$P(^ORD(101.43,TESTID,0),U,1) 95 I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage" 96 S I=0 F S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I S LST($$NXT)="t"_^(I,0) 97 S TESTID=+$P(^ORD(101.43,TESTID,0),U,2) 98 D TEST^LR7OR3(TESTID,.Y) 99 S PARAM="" F S PARAM=$O(Y(PARAM)) Q:PARAM="" D 100 . S LST($$NXT)="~"_PARAM_$S($D(Y(PARAM))>1:"",1:"="_$G(Y(PARAM))) 101 . I $D(Y(PARAM))>1 S I=0 F S I=$O(Y(PARAM,I)) Q:'I D 102 . . I PARAM="Specimens" S LST($$NXT)="i"_Y(PARAM,I) Q 103 . . I PARAM="Urgencies" S LST($$NXT)="i"_Y(PARAM,I) Q 104 . . S LST($$NXT)="i"_I_U_Y(PARAM,I) 105 . . I PARAM="CollSamp" D 106 . . . I $G(Y("Lab CollSamp")) S $P(LST(ILST),U,8)=1 107 . . . S X=+$P(Y(PARAM,I),U,3) 108 . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1) 109 . . I $D(Y(PARAM,I,"WP")) S J=0 F S J=$O(Y(PARAM,I,"WP",J)) Q:'J D 110 . . . S LST($$NXT)="t"_Y(PARAM,I,"WP",J,0) 111 Q 112 ALLSAMP(LST) ; procedure 113 ; returns all collection samples 114 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName 115 N SMP,SPC,ILST,IEN,X,X0 116 S ILST=0,LST($$NXT)="~CollSamp" 117 S SMP="" F S SMP=$O(^LAB(62,"B",SMP)) Q:SMP="" D 118 . S IEN=0 F S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN D 119 . . S X0=^LAB(62,IEN,0) 120 . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) 121 . . I $P(X0,U,2) D 122 . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) 123 . . . S SPC($P(X,U,4))=$P(X,U,10) 124 . . S LST($$NXT)=X 125 S LST($$NXT)="~Specimens" 126 S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) 127 Q 128 ABBSPEC(LST) ; procedure 129 ; returns specimens with abbreviation (uses 'E' xref) 130 N X,IEN,ILST S ILST=0 131 S X="" F S X=$O(^LAB(61,"E",X)) Q:X="" S IEN=$O(^(X,0)) D 132 . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1) 133 Q 134 NXT() ; called by TESTINFO, increments ILST 135 S ILST=ILST+1 136 Q ILST 137 STOP(VAL,X2) ; return a calculated stop date 138 N X1,X 139 S X1=DT D C^%DTC S VAL=X 140 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR32.m
r613 r623 1 ORWDLR32 ; SLC/KCM/REV/JDL - Lab Calls 6/28/2002 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141,215,250,243**;Dec 17, 1997;Build 242 3 ; 4 ; DBIA 2263 GETLST^XPAR ^TMP($J,"WC") 5 ; 6 DEF(LST,ALOC,ADIV) ; procedure 7 ; For Event Delay Order 8 ; ALOC: Delay Event's default location 9 ; ADIV: Delay Event's default division 10 ; get dialog definition specific to lab 11 S ILST=0 12 S LST($$NXT)="~ShortList" D SHORT 13 S LST($$NXT)="~Lab Collection Times" D LCOLLTM 14 S LST($$NXT)="~Ward Collection Times" D WCOLLTM 15 S LST($$NXT)="~Send Patient Times" D SENDTM 16 S LST($$NXT)="~Collection Types" D COLLTYP 17 S LST($$NXT)="~Default Urgency" D URGENCY 18 S LST($$NXT)="~Schedules" D SCHED 19 S LST($$NXT)="~Common" D COMMON 20 Q 21 SHORT ; from DEF, get short list of lab quick orders 22 N I,ORTMP,ORDG,A 23 S I=$O(^ORD(100.98,"B","LAB",0)) ; get IEN of parent lab 24 D DG^ORCHANG1(I,"BILD",.ORDG) ; find members groups for parent lab 25 S I=0 26 F S I=$O(ORDG(I)) Q:'I D ; loop through list of members groups 27 . I $E($P($G(^ORD(100.98,I,0)),"^",3),1,2)="VB" Q 28 . D GETQLST^ORWDXQ(.ORTMP,I,"Q") ;get quick order of each members groups 29 . S A=0 F S A=$O(ORTMP(A)) Q:'A D ; loop through returned quick orders and 30 . . S LST($$NXT)="i"_ORTMP(A) ; move quick orders to display list 31 . K ORTMP ; clean up for next members groups of quick orders 32 Q 33 LCOLLTM ; get collection times 34 N TDAY,TMRW,IGNOR,CNT,ICTM,ORCTM,DOW,AMPM,DAY,TIME,TXDT 35 S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H,TDAY("TX")="T" 36 M TMRW=TDAY D INCDATE(.TMRW) 37 I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D 38 . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q") 39 . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q") 40 . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q") 41 . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q") 42 . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q") 43 . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q") 44 . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q") 45 . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q") 46 . S CNT=0 F Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0)))) D Q:CNT>6 47 . . D INCDATE(.TDAY) S CNT=CNT+1 48 . S CNT=0 F Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0)))) D Q:CNT>6 49 . . D INCDATE(.TMRW) S CNT=CNT+1 50 I $G(ADIV) D GETLST^XPAR(.ORCTM,ADIV_";DIC(4,^SYS","LR PHLEBOTOMY COLLECTION","Q") 51 E D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") 52 ;S DUZ(2)=TMPDIV 53 S LST($$NXT)="iLNEXT^Next scheduled lab collection" 54 S ICTM=0 F S ICTM=$O(ORCTM(ICTM)) Q:'ICTM D 55 . I $P(ORCTM(ICTM),U)>$P($H,",",2) D 56 . . S TXDT=TDAY("TX") 57 . . I +TDAY("H")=+$H S DAY="Today" 58 . . I TDAY("H")-$H=1 S DAY="Tomorrow" 59 . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW")) 60 . E D 61 . . S TXDT=TMRW("TX") 62 . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow") 63 . S AMPM=$S($P(ORCTM(ICTM),U,2)>1159:"PM",1:"AM") 64 . S TXDT=TXDT_"@"_$P(ORCTM(ICTM),"^",2) 65 . S TIME=$P(ORCTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) 66 . S LST($$NXT)="iL"_TXDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")" 67 . S ^TMP($J,"WC",ILST)="iW"_TXDT_U_TIME_" "_AMPM_" ("_DAY_") Ward collect" ;DBIA 2263 68 ; D NOW^%DTC 69 ;S LST($$NXT)="iWNOW^Now (Collect on ward)" 70 S LST($$NXT)="iLO^Future" 71 Q 72 WCOLLTM ; get Ward Collect times 73 S I="" 74 F S I=$O(^TMP($J,"WC",I)) Q:I="" D 75 . S LST($$NXT)=^TMP($J,"WC",I) 76 S LST($$NXT)="iWNOW^Now (Collect on ward)" 77 ;S LST($$NXT)="iWO^Other" 78 K ^TMP($J,"WC") 79 Q 80 SENDTM ; get send patient times 81 ;N X,X1,X2 82 S LST($$NXT)="iLT^Today" 83 ;S X1=DT,X2=1 D C^%DTC 84 S LST($$NXT)="iLT+1^Tomorrow" 85 ;S LST($$NXT)="iLO^Other" 86 Q 87 COLLTYP ; Collection Types in effect for this division 88 N Y S Y="" 89 S LST($$NXT)="iLC^Lab Collect" 90 S LST($$NXT)="iWC^Ward Collect" 91 S LST($$NXT)="iSP^Send Patient to Lab" 92 I +$$ON^LR7OV4(DUZ(2)) S LST($$NXT)="iI^Immediate Collect" 93 S:$G(ALOC) Y=$$GET^XPAR("ALL^"_ALOC_";SC(","LR DEFAULT TYPE QUICK") 94 I $L(Y) S LST($$NXT)="d"_Y 95 Q 96 INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE 97 N X,X1,X2,%H 98 S X1=ADATE,X2=1 D C^%DTC S ADATE=X 99 S ADATE("H")=ADATE("H")+1 100 S ADATE("DOW")=ADATE("H")#7 101 S ADATE("TX")="T+"_($P(ADATE("TX"),"+",2)+1) 102 Q 103 DOWNAME(DOW) ; function 104 ; Returns Day of Week name (DOW should be $H#7) 105 I DOW=0 Q "Thursday" 106 I DOW=1 Q "Friday" 107 I DOW=2 Q "Saturday" 108 I DOW=3 Q "Sunday" 109 I DOW=4 Q "Monday" 110 I DOW=5 Q "Tuesday" 111 I DOW=6 Q "Wednesday" 112 Q "" 113 URGENCY ; return default urgency for lab 114 N URG 115 S URG=$$DEFURG^LR7OR3 116 S LST($$NXT)="i"_URG_U_$P(^LAB(62.05,URG,0),U,1) 117 S LST($$NXT)="d"_URG_U_$P(^LAB(62.05,URG,0),U,1) 118 Q 119 SCHED ; return list of schedules available for lab tests 120 N X,X0,IEN,TYPE,FREQ 121 K ^TMP($J,"ORWDLR32 APLR") 122 D AP^PSS51P1("LR",,,,"ORWDLR32 APLR") 123 S X="" F S X=$O(^TMP($J,"ORWDLR32 APLR","APLR",X)) Q:X="" D 124 .S IEN=$O(^TMP($J,"ORWDLR32 APLR","APLR",X,"")) I IEN'>0 Q 125 .S TYPE=$P($G(^TMP($J,"ORWDLR32 APLR",IEN,5)),U) 126 .S FREQ=+$G(^TMP($J,"ORWDLR32 APLR",IEN,2)) 127 .I ((TYPE="C")!(TYPE="D")),FREQ=0 Q 128 .S LST($$NXT)="i"_IEN_U_X_U_TYPE_U_FREQ 129 .I X="ONE TIME" S LST($$NXT)="d"_IEN_U_X 130 K ^TMP($J,"ORWDLR32 APLR") 131 Q 132 COMMON ; return list of commonly ordered lab tests 133 N ORLST,IEN,I 134 D GETLST^XPAR(.ORLST,"ALL","ORWD COMMON LAB INPT") ;DBIA 2263 135 S I=0 F S I=$O(ORLST(I)) Q:'I D 136 . S IEN=$P(ORLST(I),U,2) 137 . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1) 138 Q 139 LOAD(LST,TESTID) ; procedure 140 ; Return sample, specimen, & urgency info about a lab test 141 N I,J,X,X1,X4,ORY,ORLABID,ILST,PARAM 142 S ILST=0,X=$P(^ORD(101.43,TESTID,0),"^"),ORLABID=$P(^(0),U,2) 143 S LST($$NXT)="~Test Name" 144 S LST($$NXT)="d"_X 145 S LST($$NXT)="~Item ID" 146 S LST($$NXT)="d"_+ORLABID 147 S X1=$S($P($P(^ORD(101.43,TESTID,0),U,2),";",2)="99VBC":$O(^LAB(60,"B",$P(^ORD(101.43,TESTID,0),"^")_" - LAB",0)),1:$P($P(^ORD(101.43,TESTID,0),U,2),";",1)) Q:'X1 148 S X4=$P($G(^LAB(60,X1,0)),U,4) 149 S LST(ILST)=LST(ILST)_U_X4 150 I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage" 151 S I=0 F S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I S LST($$NXT)="t"_^(I,0) 152 S TESTID=+$P(^ORD(101.43,TESTID,0),U,2) 153 D TEST^LR7OR3(X1,.ORY) 154 S PARAM="" F S PARAM=$O(ORY(PARAM)) Q:PARAM="" D 155 . S LST($$NXT)="~"_PARAM 156 . I PARAM="ReqCom" D 157 . . S LST($$NXT)="d"_$G(ORY("ReqCom")) Q 158 . I PARAM="Default CollSamp" D 159 . . S LST($$NXT)="d"_$G(ORY("Default CollSamp")) Q 160 . I PARAM="Unique CollSamp" D 161 . . S LST($$NXT)="d"_$G(ORY("Unique CollSamp")) Q 162 . I PARAM="Default Urgency" D 163 . . S LST($$NXT)="d"_$G(ORY("Default Urgency")) Q 164 . I PARAM="Lab CollSamp" D 165 . . S LST($$NXT)="d"_$G(ORY("Lab CollSamp")) Q 166 . I $D(ORY(PARAM))>1 S I=0 F S I=$O(ORY(PARAM,I)) Q:'I D 167 . . I PARAM="Specimens" S LST($$NXT)="i"_ORY(PARAM,I) Q 168 . . I PARAM="Urgencies" S LST($$NXT)="i"_ORY(PARAM,I) Q 169 . . I PARAM="GenWardInstructions" S LST($$NXT)="t"_ORY(PARAM,I,0) Q 170 . . S LST($$NXT)="i"_I_U_ORY(PARAM,I) 171 . . I PARAM="CollSamp" D 172 . . . I $G(ORY("Lab CollSamp")) S $P(LST(ILST),U,8)=1 173 . . . S X=+$P(ORY(PARAM,I),U,3) 174 . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1) 175 . . I $D(ORY(PARAM,I,"WP")) S J=0 F S J=$O(ORY(PARAM,I,"WP",J)) Q:'J D 176 . . . S LST($$NXT)="t"_ORY(PARAM,I,"WP",J,0) 177 Q 178 ALLSAMP(LST) ; procedure 179 ; returns all collection samples 180 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName 181 N SMP,SPC,ILST,IEN,X,X0 182 S ILST=0,LST($$NXT)="~CollSamp" 183 S SMP="" F S SMP=$O(^LAB(62,"B",SMP)) Q:SMP="" D 184 . S IEN=0 F S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN D 185 . . S X0=^LAB(62,IEN,0) 186 . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) 187 . . I $P(X0,U,2) D 188 . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) 189 . . . S SPC($P(X,U,4))=$P(X,U,10) 190 . . S LST($$NXT)=X 191 S LST($$NXT)="~Specimens" 192 S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) 193 Q 194 ONESAMP(LST,IEN) ;Return data for one colelction sample 195 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName 196 N SPC,ILST,X,X0 197 Q:+$G(IEN)=0 198 S ILST=0,LST($$NXT)="~CollSamp" 199 S X0=^LAB(62,IEN,0) 200 S X="i1"_U_IEN_U_$P(X0,U,1)_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) 201 I $P(X0,U,2) D 202 . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) 203 . S SPC($P(X,U,4))=$P(X,U,10) 204 S LST($$NXT)=X 205 S LST($$NXT)="~Specimens" 206 S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) 207 Q 208 ONESPEC(LST,IEN) ;return one specimen 209 Q:(+$G(IEN)=0)!('$D(^LAB(61,IEN,0))) 210 S LST=IEN_U_$P(^LAB(61,IEN,0),U,1) 211 Q 212 ABBSPEC(LST) ; procedure 213 ; returns specimens with abbreviation (uses 'E' xref) 214 N X,IEN,ILST S ILST=0 215 S X="" F S X=$O(^LAB(61,"E",X)) Q:X="" S IEN=$O(^(X,0)) D 216 . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1) 217 Q 218 NXT() ; called by TESTINFO, increments ILST 219 S ILST=ILST+1 220 Q ILST 221 ; 1 ORWDLR32 ; SLC/KCM/REV/JDL - Lab Calls 6/28/2002 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141,215,250**;Dec 17, 1997;Build 1 3 ; 4 ; DBIA 2263 GETLST^XPAR ^TMP($J,"WC") 5 ; 6 DEF(LST,ALOC,ADIV) ; procedure 7 ; For Event Delay Order 8 ; ALOC: Delay Event's default location 9 ; ADIV: Delay Event's default division 10 ; get dialog definition specific to lab 11 S ILST=0 12 S LST($$NXT)="~ShortList" D SHORT 13 S LST($$NXT)="~Lab Collection Times" D LCOLLTM 14 S LST($$NXT)="~Ward Collection Times" D WCOLLTM 15 S LST($$NXT)="~Send Patient Times" D SENDTM 16 S LST($$NXT)="~Collection Types" D COLLTYP 17 S LST($$NXT)="~Default Urgency" D URGENCY 18 S LST($$NXT)="~Schedules" D SCHED 19 S LST($$NXT)="~Common" D COMMON 20 Q 21 SHORT ; from DEF, get short list of lab quick orders 22 N I,ORTMP,ORDG,A 23 S I=$O(^ORD(100.98,"B","LAB",0)) ; get IEN of parent lab 24 D DG^ORCHANG1(I,"BILD",.ORDG) ; find members groups for parent lab 25 S I=0 26 F S I=$O(ORDG(I)) Q:'I D ; loop through list of members groups 27 . D GETQLST^ORWDXQ(.ORTMP,I,"Q") ;get quick order of each members groups 28 . S A=0 F S A=$O(ORTMP(A)) Q:'A D ; loop through returned quick orders and 29 . . S LST($$NXT)="i"_ORTMP(A) ; move quick orders to display list 30 . K ORTMP ; clean up for next members groups of quick orders 31 Q 32 LCOLLTM ; get collection times 33 N TDAY,TMRW,IGNOR,CNT,ICTM,ORCTM,DOW,AMPM,DAY,TIME,TXDT 34 S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H,TDAY("TX")="T" 35 M TMRW=TDAY D INCDATE(.TMRW) 36 I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D 37 . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q") 38 . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q") 39 . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q") 40 . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q") 41 . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q") 42 . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q") 43 . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q") 44 . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q") 45 . S CNT=0 F Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0)))) D Q:CNT>6 46 . . D INCDATE(.TDAY) S CNT=CNT+1 47 . S CNT=0 F Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0)))) D Q:CNT>6 48 . . D INCDATE(.TMRW) S CNT=CNT+1 49 I $G(ADIV) D GETLST^XPAR(.ORCTM,ADIV_";DIC(4,^SYS","LR PHLEBOTOMY COLLECTION","Q") 50 E D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") 51 ;S DUZ(2)=TMPDIV 52 S LST($$NXT)="iLNEXT^Next scheduled lab collection" 53 S ICTM=0 F S ICTM=$O(ORCTM(ICTM)) Q:'ICTM D 54 . I $P(ORCTM(ICTM),U)>$P($H,",",2) D 55 . . S TXDT=TDAY("TX") 56 . . I +TDAY("H")=+$H S DAY="Today" 57 . . I TDAY("H")-$H=1 S DAY="Tomorrow" 58 . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW")) 59 . E D 60 . . S TXDT=TMRW("TX") 61 . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow") 62 . S AMPM=$S($P(ORCTM(ICTM),U,2)>1159:"PM",1:"AM") 63 . S TXDT=TXDT_"@"_$P(ORCTM(ICTM),"^",2) 64 . S TIME=$P(ORCTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) 65 . S LST($$NXT)="iL"_TXDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")" 66 . S ^TMP($J,"WC",ILST)="iW"_TXDT_U_TIME_" "_AMPM_" ("_DAY_") Ward collect" ;DBIA 2263 67 ; D NOW^%DTC 68 ;S LST($$NXT)="iWNOW^Now (Collect on ward)" 69 S LST($$NXT)="iLO^Future" 70 Q 71 WCOLLTM ; get Ward Collect times 72 S I="" 73 F S I=$O(^TMP($J,"WC",I)) Q:I="" D 74 . S LST($$NXT)=^TMP($J,"WC",I) 75 S LST($$NXT)="iWNOW^Now (Collect on ward)" 76 ;S LST($$NXT)="iWO^Other" 77 K ^TMP($J,"WC") 78 Q 79 SENDTM ; get send patient times 80 ;N X,X1,X2 81 S LST($$NXT)="iLT^Today" 82 ;S X1=DT,X2=1 D C^%DTC 83 S LST($$NXT)="iLT+1^Tomorrow" 84 ;S LST($$NXT)="iLO^Other" 85 Q 86 COLLTYP ; Collection Types in effect for this division 87 N Y S Y="" 88 S LST($$NXT)="iLC^Lab Collect" 89 S LST($$NXT)="iWC^Ward Collect" 90 S LST($$NXT)="iSP^Send Patient to Lab" 91 I +$$ON^LR7OV4(DUZ(2)) S LST($$NXT)="iI^Immediate Collect" 92 S:$G(ALOC) Y=$$GET^XPAR("ALL^"_ALOC_";SC(","LR DEFAULT TYPE QUICK") 93 I $L(Y) S LST($$NXT)="d"_Y 94 Q 95 INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE 96 N X,X1,X2,%H 97 S X1=ADATE,X2=1 D C^%DTC S ADATE=X 98 S ADATE("H")=ADATE("H")+1 99 S ADATE("DOW")=ADATE("H")#7 100 S ADATE("TX")="T+"_($P(ADATE("TX"),"+",2)+1) 101 Q 102 DOWNAME(DOW) ; function 103 ; Returns Day of Week name (DOW should be $H#7) 104 I DOW=0 Q "Thursday" 105 I DOW=1 Q "Friday" 106 I DOW=2 Q "Saturday" 107 I DOW=3 Q "Sunday" 108 I DOW=4 Q "Monday" 109 I DOW=5 Q "Tuesday" 110 I DOW=6 Q "Wednesday" 111 Q "" 112 URGENCY ; return default urgency for lab 113 N URG 114 S URG=$$DEFURG^LR7OR3 115 S LST($$NXT)="i"_URG_U_$P(^LAB(62.05,URG,0),U,1) 116 S LST($$NXT)="d"_URG_U_$P(^LAB(62.05,URG,0),U,1) 117 Q 118 SCHED ; return list of schedules available for lab tests 119 N X,X0,IEN 120 S X="" F S X=$O(^PS(51.1,"APLR",X)) Q:X="" S IEN=$O(^(X,0)) I IEN D 121 . S X0=$G(^PS(51.1,IEN,0)) Q:X0="" 122 . I (($P(X0,U,5)="C")!($P(X0,U,5)="D")),(+$P(X0,U,3)=0) Q 123 . S LST($$NXT)="i"_IEN_U_X_U_$P(X0,U,5)_U_$P(X0,U,3) 124 . I X="ONE TIME" S LST($$NXT)="d"_IEN_U_X 125 Q 126 COMMON ; return list of commonly ordered lab tests 127 N ORLST,IEN,I 128 D GETLST^XPAR(.ORLST,"ALL","ORWD COMMON LAB INPT") ;DBIA 2263 129 S I=0 F S I=$O(ORLST(I)) Q:'I D 130 . S IEN=$P(ORLST(I),U,2) 131 . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1) 132 Q 133 LOAD(LST,TESTID) ; procedure 134 ; Return sample, specimen, & urgency info about a lab test 135 N I,J,X,X1,X4,ORY,ORLABID,ILST,PARAM 136 S ILST=0 137 S LST($$NXT)="~Test Name" 138 S LST($$NXT)="d"_$P(^ORD(101.43,TESTID,0),U,1),ORLABID=$P(^(0),U,2) 139 S LST($$NXT)="~Item ID" 140 S LST($$NXT)="d"_+ORLABID 141 S X=$P(ORLABID,";",1),X1=$P(ORLABID,";",2) 142 I $E(X1,1,4)="99VB" S X1=$O(^LAB(60,"B","VBECS "_$P(^ORD(101.43,TESTID,0),"^"),0)) Q:'X1 S X=X1 143 S X4=$P($G(^LAB(60,X,0)),U,4) 144 S LST(ILST)=LST(ILST)_U_X4 145 I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage" 146 S I=0 F S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I S LST($$NXT)="t"_^(I,0) 147 S TESTID=+$P(^ORD(101.43,TESTID,0),U,2) 148 D TEST^LR7OR3(TESTID,.ORY) 149 S PARAM="" F S PARAM=$O(ORY(PARAM)) Q:PARAM="" D 150 . S LST($$NXT)="~"_PARAM 151 . I PARAM="ReqCom" D 152 . . S LST($$NXT)="d"_$G(ORY("ReqCom")) Q 153 . I PARAM="Default CollSamp" D 154 . . S LST($$NXT)="d"_$G(ORY("Default CollSamp")) Q 155 . I PARAM="Unique CollSamp" D 156 . . S LST($$NXT)="d"_$G(ORY("Unique CollSamp")) Q 157 . I PARAM="Default Urgency" D 158 . . S LST($$NXT)="d"_$G(ORY("Default Urgency")) Q 159 . I PARAM="Lab CollSamp" D 160 . . S LST($$NXT)="d"_$G(ORY("Lab CollSamp")) Q 161 . I $D(ORY(PARAM))>1 S I=0 F S I=$O(ORY(PARAM,I)) Q:'I D 162 . . I PARAM="Specimens" S LST($$NXT)="i"_ORY(PARAM,I) Q 163 . . I PARAM="Urgencies" S LST($$NXT)="i"_ORY(PARAM,I) Q 164 . . I PARAM="GenWardInstructions" S LST($$NXT)="t"_ORY(PARAM,I,0) Q 165 . . S LST($$NXT)="i"_I_U_ORY(PARAM,I) 166 . . I PARAM="CollSamp" D 167 . . . I $G(ORY("Lab CollSamp")) S $P(LST(ILST),U,8)=1 168 . . . S X=+$P(ORY(PARAM,I),U,3) 169 . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1) 170 . . I $D(ORY(PARAM,I,"WP")) S J=0 F S J=$O(ORY(PARAM,I,"WP",J)) Q:'J D 171 . . . S LST($$NXT)="t"_ORY(PARAM,I,"WP",J,0) 172 Q 173 ALLSAMP(LST) ; procedure 174 ; returns all collection samples 175 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName 176 N SMP,SPC,ILST,IEN,X,X0 177 S ILST=0,LST($$NXT)="~CollSamp" 178 S SMP="" F S SMP=$O(^LAB(62,"B",SMP)) Q:SMP="" D 179 . S IEN=0 F S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN D 180 . . S X0=^LAB(62,IEN,0) 181 . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) 182 . . I $P(X0,U,2) D 183 . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) 184 . . . S SPC($P(X,U,4))=$P(X,U,10) 185 . . S LST($$NXT)=X 186 S LST($$NXT)="~Specimens" 187 S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) 188 Q 189 ONESAMP(LST,IEN) ;Return data for one colelction sample 190 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName 191 N SPC,ILST,X,X0 192 Q:+$G(IEN)=0 193 S ILST=0,LST($$NXT)="~CollSamp" 194 S X0=^LAB(62,IEN,0) 195 S X="i1"_U_IEN_U_$P(X0,U,1)_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) 196 I $P(X0,U,2) D 197 . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) 198 . S SPC($P(X,U,4))=$P(X,U,10) 199 S LST($$NXT)=X 200 S LST($$NXT)="~Specimens" 201 S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) 202 Q 203 ONESPEC(LST,IEN) ;return one specimen 204 Q:(+$G(IEN)=0)!('$D(^LAB(61,IEN,0))) 205 S LST=IEN_U_$P(^LAB(61,IEN,0),U,1) 206 Q 207 ABBSPEC(LST) ; procedure 208 ; returns specimens with abbreviation (uses 'E' xref) 209 N X,IEN,ILST S ILST=0 210 S X="" F S X=$O(^LAB(61,"E",X)) Q:X="" S IEN=$O(^(X,0)) D 211 . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1) 212 Q 213 NXT() ; called by TESTINFO, increments ILST 214 S ILST=ILST+1 215 Q ILST 216 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR33.m
r613 r623 1 ORWDLR33 ; SLC/KCM/REV/JDL - Lab Calls ; 7/1/2002 11AM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141,243**;Dec 17, 1997;Build 242 3 ; 4 STOP(VAL,X2) ; return a calculated stop date 5 N X1,X 6 S X1=DT D C^%DTC S VAL=X 7 Q 8 MAXDAYS(Y,LOC,SCHED) ; Return max number of days for a continuing order 9 N TMP1,TMP2 10 K ^TMP($J,"ORWDLR33 MAXDAYS") 11 S TMP1=$$GET^XPAR("ALL^LOC.`"_+LOC,"LR MAX DAYS CONTINUOUS",1,"Q") 12 I +TMP1=0 S Y="-1" Q 13 I +$G(SCHED)>0 D ZERO^PSS51P1(SCHED,,,,"ORWDLR33 MAXDAYS") S TMP2=$G(^TMP($J,"ORWDLR33 MAXDAYS",SCHED,2.5)) K ^TMP($J,"ORWDLR33 MAXDAYS") 14 E S TMP2=0 15 I +TMP1=0,+TMP2>0 S Y=TMP2 Q 16 I +TMP2=0,+TMP1>0 S Y=TMP1 Q 17 S Y=$S(+TMP1>+TMP2:+TMP2,+TMP2>+TMP1:+TMP1,+TMP1=+TMP2:+TMP1,1:0) 18 K ^TMP($J,"ORWDLR33 MAXDAYS") 19 Q 20 ALLSPEC(Y,FROM,DIR) ; Return a set of specimens from topography file 21 N I,IEN,CNT S I=0,CNT=44 22 F Q:I'<CNT S FROM=$O(^LAB(61,"B",FROM),DIR) Q:FROM="" D 23 . S IEN=0 F S IEN=$O(^LAB(61,"B",FROM,IEN)) Q:'IEN D 24 . . S I=I+1,Y(I)=IEN_U_FROM_" ("_$P($G(^LAB(61,IEN,0)),U,2)_")" 25 Q 26 LABCOLTM(ORYN,ORDATE,ORLOC) ; Is this a routine lab collect time for this location? 27 N ORDA,ORTI,ORDOW,ORCTM,I,X,Y 28 S ORYN=0 Q:'$G(ORDATE)!($G(ORDATE)<0)!('$G(ORLOC)) 29 S ORDA=$P(ORDATE,".",1),ORTI=$P(ORDATE,".",2) 30 S I=0 F S I=$L(ORTI) Q:I>3 S ORTI=ORTI_"0" 31 S X=ORDA D DW^%DTC S ORDOW=X 32 D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") 33 S I=0 F S I=$O(ORCTM(I)) Q:'I D 34 . S:$P(ORCTM(I),U,2)=ORTI ORYN=1 35 Q:ORYN=0 36 I $G(ORLOC),$$GET^XPAR(ORLOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") S ORYN=1 Q 37 I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q"),$D(^HOLIDAY(ORDA,0)) S ORYN=0 Q 38 I $$GET^XPAR("ALL","LR COLLECT "_ORDOW,1,"Q") S ORYN=1 Q 39 S ORYN=0 40 Q 41 IMMCOLL(ORY) ; Return help screen showing immediate collect times 42 D SHOW^LR7OV4(DUZ(2),.ORY) 43 Q 44 ICDEFLT(ORY) ;Return default immediate collect time 45 S ORY=$$DEFTIME^LR7OV4(DUZ(2)) 46 Q 47 ICVALID(ORY,ORTIME) ;Is the time a valid immediate collect time? 48 S ORTIME=$P(ORTIME,".",1)_"."_$E($P(ORTIME,".",2),1,4) 49 S ORY=$$VALID^LR7OV4(DUZ(2),ORTIME) 50 Q 51 GETLABTM(ORY,ORDATE,ORLOC) ;Return list of lab collect times for a date and location 52 N ORDA,ORTI,ORNOW,ORDOW,ORCTM,ORTI,X,%,%H 53 S ORY(0)=0 Q:'$G(ORDATE)!($G(ORDATE)<0)!('$G(ORLOC)) 54 S ORDA=$P(ORDATE,".",1) 55 S ORNOW=$$NOW^XLFDT,ORTI=$P(ORNOW,".",2) 56 I ORDA<$P(ORNOW,".",1) S ORY(0)="-1^Dates in the past are not allowed." Q 57 I '+$$GET^XPAR(ORLOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D 58 . S X=ORDA D DW^%DTC S ORDOW=X 59 . I '+$$GET^XPAR("ALL","LR COLLECT "_ORDOW,1,"Q") S ORY(0)="-1^No collections on "_ORDOW Q 60 . I '+$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q"),$D(^HOLIDAY(ORDA,0)) S ORY(0)="-1^No holiday collections" Q 61 I +ORY(0)>-1 D 62 . D GETLST^XPAR(.ORY,"ALL","LR PHLEBOTOMY COLLECTION","Q") 63 . I +$G(ORY)=0 S ORY(0)="-1^No lab collect times defined for this division" Q 64 S I=0 F S I=$O(ORY(I)) Q:'I D 65 . D NOW^%DTC S ORTI=%,%H=+%H_","_+ORY(I) D YMD^%DTC 66 . I (ORDA=$P(ORTI,".",1)),(+(ORDA+%)<+ORTI) K ORY(I) S ORY=ORY-1 Q ; cutoff time has passed for this collect time 67 . S ORY(I)=$P(ORY(I),U,2) 68 I +$G(ORY)=0,('$D(ORY(0))) S ORY(0)="-1^All of today's collection times have passed." 69 Q 70 LCFUTR(ORDY,ORLOC,ORDIV) ;Get # of days for future Lab Collects 71 ; For Event Delay Order 72 ; --ORLOC Event default location 73 ; --ORDIV Event default division 74 S ORDY=0 75 Q:'$D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE")) 76 I $G(ORDIV) S ORDY=+$$GET^XPAR(+$G(ORLOC)_";SC("_"^"_+$G(ORDIV)_";DIC(4,^SYS^PKG","LR LAB COLLECT FUTURE",1,"I") 77 E S ORDY=+$$GET^XPAR(+$G(ORLOC)_";SC("_"^DIV^SYS^PKG","LR LAB COLLECT FUTURE",1,"I") 78 ;S DUZ(2)=TMPDIV 79 Q 80 LASTTIME(ORY) ; Get last collection time used from ^TMP("ORECALL",$J) array 81 N ORDIALOG,ORTYPE,ORTIME 82 S ORDIALOG=$O(^ORD(101.41,"B","LR OTHER LAB TESTS",0)) 83 S ORTYPE=$O(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0)) 84 S ORTIME=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) 85 S ORY=$$RECALL^ORCD(ORTYPE,1)_U_$$RECALL^ORCD(ORTIME,1) 86 Q 87 LCTOWC(ORTXT,ORLOC) ; return text instructing user when LC changed to WC on accept/release 88 N ORDIV,ORSVC 89 S ORDIV=DUZ(2) 90 S ORSVC=+$G(^VA(200,DUZ,5)) 91 I ORSVC S ORTXT=$$GET^XPAR(+$G(ORLOC)_";SC("_"^"_+$G(ORSVC)_";DIC(49,^"_+$G(ORDIV)_";DIC(4,^SYS^PKG","ORWLR LC CHANGED TO WC",1,"I") 92 E S ORTXT=$$GET^XPAR(+$G(ORLOC)_";SC("_"^SVC^"_+$G(ORDIV)_";DIC(4,^SYS^PKG","ORWLR LC CHANGED TO WC",1,"I") 93 Q 1 ORWDLR33 ; SLC/KCM/REV/JDL - Lab Calls ; 7/1/2002 11AM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141**;Dec 17, 1997 3 ; 4 STOP(VAL,X2) ; return a calculated stop date 5 N X1,X 6 S X1=DT D C^%DTC S VAL=X 7 Q 8 MAXDAYS(Y,LOC,SCHED) ; Return max number of days for a continuing order 9 N TMP1,TMP2 10 S TMP1=$$GET^XPAR("ALL^LOC.`"_+LOC,"LR MAX DAYS CONTINUOUS",1,"Q") 11 I +TMP1=0 S Y="-1" Q 12 I +$G(SCHED)>0 S TMP2=$P($G(^PS(51.1,SCHED,0)),U,7) 13 E S TMP2=0 14 I +TMP1=0,+TMP2>0 S Y=TMP2 Q 15 I +TMP2=0,+TMP1>0 S Y=TMP1 Q 16 S Y=$S(+TMP1>+TMP2:+TMP2,+TMP2>+TMP1:+TMP1,+TMP1=+TMP2:+TMP1,1:0) 17 Q 18 ALLSPEC(Y,FROM,DIR) ; Return a set of specimens from topography file 19 N I,IEN,CNT S I=0,CNT=44 20 F Q:I'<CNT S FROM=$O(^LAB(61,"B",FROM),DIR) Q:FROM="" D 21 . S IEN=0 F S IEN=$O(^LAB(61,"B",FROM,IEN)) Q:'IEN D 22 . . S I=I+1,Y(I)=IEN_U_FROM_" ("_$P($G(^LAB(61,IEN,0)),U,2)_")" 23 Q 24 LABCOLTM(ORYN,ORDATE,ORLOC) ; Is this a routine lab collect time for this location? 25 N ORDA,ORTI,ORDOW,ORCTM,I,X,Y 26 S ORYN=0 Q:'$G(ORDATE)!($G(ORDATE)<0)!('$G(ORLOC)) 27 S ORDA=$P(ORDATE,".",1),ORTI=$P(ORDATE,".",2) 28 S I=0 F S I=$L(ORTI) Q:I>3 S ORTI=ORTI_"0" 29 S X=ORDA D DW^%DTC S ORDOW=X 30 D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") 31 S I=0 F S I=$O(ORCTM(I)) Q:'I D 32 . S:$P(ORCTM(I),U,2)=ORTI ORYN=1 33 Q:ORYN=0 34 I $G(ORLOC),$$GET^XPAR(ORLOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") S ORYN=1 Q 35 I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q"),$D(^HOLIDAY(ORDA,0)) S ORYN=0 Q 36 I $$GET^XPAR("ALL","LR COLLECT "_ORDOW,1,"Q") S ORYN=1 Q 37 S ORYN=0 38 Q 39 IMMCOLL(ORY) ; Return help screen showing immediate collect times 40 D SHOW^LR7OV4(DUZ(2),.ORY) 41 Q 42 ICDEFLT(ORY) ;Return default immediate collect time 43 S ORY=$$DEFTIME^LR7OV4(DUZ(2)) 44 Q 45 ICVALID(ORY,ORTIME) ;Is the time a valid immediate collect time? 46 S ORTIME=$P(ORTIME,".",1)_"."_$E($P(ORTIME,".",2),1,4) 47 S ORY=$$VALID^LR7OV4(DUZ(2),ORTIME) 48 Q 49 GETLABTM(ORY,ORDATE,ORLOC) ;Return list of lab collect times for a date and location 50 N ORDA,ORTI,ORNOW,ORDOW,ORCTM,ORTI,X,%,%H 51 S ORY(0)=0 Q:'$G(ORDATE)!($G(ORDATE)<0)!('$G(ORLOC)) 52 S ORDA=$P(ORDATE,".",1) 53 S ORNOW=$$NOW^XLFDT,ORTI=$P(ORNOW,".",2) 54 I ORDA<$P(ORNOW,".",1) S ORY(0)="-1^Dates in the past are not allowed." Q 55 I '+$$GET^XPAR(ORLOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D 56 . S X=ORDA D DW^%DTC S ORDOW=X 57 . I '+$$GET^XPAR("ALL","LR COLLECT "_ORDOW,1,"Q") S ORY(0)="-1^No collections on "_ORDOW Q 58 . I '+$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q"),$D(^HOLIDAY(ORDA,0)) S ORY(0)="-1^No holiday collections" Q 59 I +ORY(0)>-1 D 60 . D GETLST^XPAR(.ORY,"ALL","LR PHLEBOTOMY COLLECTION","Q") 61 . I +$G(ORY)=0 S ORY(0)="-1^No lab collect times defined for this division" Q 62 S I=0 F S I=$O(ORY(I)) Q:'I D 63 . D NOW^%DTC S ORTI=%,%H=+%H_","_+ORY(I) D YMD^%DTC 64 . I (ORDA=$P(ORTI,".",1)),(+(ORDA+%)<+ORTI) K ORY(I) S ORY=ORY-1 Q ; cutoff time has passed for this collect time 65 . S ORY(I)=$P(ORY(I),U,2) 66 I +$G(ORY)=0,('$D(ORY(0))) S ORY(0)="-1^All of today's collection times have passed." 67 Q 68 LCFUTR(ORDY,ORLOC,ORDIV) ;Get # of days for future Lab Collects 69 ; For Event Delay Order 70 ; --ORLOC Event default location 71 ; --ORDIV Event default division 72 S ORDY=0 73 Q:'$D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE")) 74 I $G(ORDIV) S ORDY=+$$GET^XPAR(+$G(ORLOC)_";SC("_"^"_+$G(ORDIV)_";DIC(4,^SYS^PKG","LR LAB COLLECT FUTURE",1,"I") 75 E S ORDY=+$$GET^XPAR(+$G(ORLOC)_";SC("_"^DIV^SYS^PKG","LR LAB COLLECT FUTURE",1,"I") 76 ;S DUZ(2)=TMPDIV 77 Q 78 LASTTIME(ORY) ; Get last collection time used from ^TMP("ORECALL",$J) array 79 N ORDIALOG,ORTYPE,ORTIME 80 S ORDIALOG=$O(^ORD(101.41,"B","LR OTHER LAB TESTS",0)) 81 S ORTYPE=$O(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0)) 82 S ORTIME=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) 83 S ORY=$$RECALL^ORCD(ORTYPE,1)_U_$$RECALL^ORCD(ORTIME,1) 84 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDOR.m
r613 r623 1 ORWDOR ; SLC/KCM - Generic Orders calls for Windows Dialogs [ 08/05/96 8:21 AM ];03:50 PM 17 Jun 1998 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,164,253,243**;Dec 17, 1997;Build 242 3 NXT() ; -- returns next available index in return data array 4 S ILST=ILST+1 5 Q ILST 6 ; 7 VMSLCT(LST) ; return default lists for vitals dialog 8 N ILST S ILST=0 9 S LST($$NXT)="~Measurements" D MEAS 10 S LST($$NXT)="~Schedules" D SCHED 11 Q 12 MEAS ; called from VMSLCT 13 N I,X 14 S X="" F S X=$O(^ORD(101.43,"S.V/M",X)) Q:X="" D 15 . S I=$O(^ORD(101.43,"S.V/M",X,0)) 16 . S LST($$NXT)="i"_I_U_$P(^ORD(101.43,"S.V/M",X,I),U,2) 17 Q 18 SCHED ; called from VMSLCT 19 N X,I 20 K ^TMP($J,"ORWDGX APGMRV") 21 D AP^PSS51P1("GMRV",,,,"ORWDGX APGMRV") 22 S X="" F S X=$O(^TMP($J,"ORWDGX APGMRV","APGMRV",X)) Q:X="" D 23 . S I=$O(^TMP($J,"ORWDGX APGMRV","APGMRV",X,0)),LST($$NXT)="i"_I_U_X 24 K ^TMP($J,"ORWDGX APGMRV") 25 Q 26 VALNUM(ERR,X,DOM) ; return error if invalid number 27 N LOW,HIGH,DEC 28 S LOW=$P(DOM,":"),HIGH=$P(DOM,":",2),DEC=$P(DOM,":",3),ERR=0 29 I $L($P(X,"."))>24 S ERR="1^Exceeded maximum number of 24 characters" Q 30 I X'?.1"-".N.1".".N S ERR="1^Entry must be numeric" Q 31 I X>HIGH!(X<LOW) S ERR="1^Out of Range - value must be between "_LOW_" and "_HIGH_" inclusive" Q 32 I $L($P(+X,".",2))>DEC D 33 . I DEC=0 S ERR="1^No decimal places allowed" 34 . E I DEC=1 S ERR="1^Only one decimal place allowed" 35 . E S ERR="1^No more than "_DEC_" decimal places allowed" 36 Q 37 LKSCRN(ORLST,FROM,DIR,REF,GBL,SCR) ; Return a set of entries from xref in REF 38 ; .Y=returned list, FROM=text to $O from, DIR=$O direction, 39 ; REF=subscript indirection global ref including xref, 40 ; GBL=standard FM global ref, SCR=reference to screen in 101.41 41 N I,IEN,CNT,X,Y,D,ORTYPE 42 S I=0,CNT=44,SCR=$G(SCR) 43 I $L(SCR) S SCR=$G(^ORD(101.41,+SCR,10,+$P(SCR,":",2),4)) 44 S D=$P(REF,"""",2),ORTYPE="D" ;for OI screen 45 F Q:I'<CNT S FROM=$O(@REF@(FROM),DIR) Q:FROM="" D 46 . S IEN=0 F S IEN=$O(@REF@(FROM,IEN)) Q:'IEN D 47 . . ; if screen, set naked ref & Y, then execute screen 48 . . I $L(SCR) S Y=IEN,X=$P($G(@(GBL_"Y,0)")),U) X SCR Q:'$T 49 . . S I=I+1,ORLST(I)=IEN_"^"_FROM 50 Q 51 MNUTREE(LST,ROOT) ; return menu tree for a menu type dialog 52 N ILST S ILST=0 53 S ILST=ILST+1,LST(ILST)=ROOT_U_$P(^ORD(101.41,ROOT,0),U,2)_"^0^+" 54 D LSTCHLD(ROOT) 55 Q 56 LSTCHLD(PARENT) ; list descendends of this node (recursive) 57 N CHILD,I,J 58 S I=0 F S I=$O(^ORD(101.41,PARENT,10,"B",I)) Q:'I D 59 . S J=0 F S J=$O(^ORD(101.41,PARENT,10,"B",I,J)) Q:'J D 60 . . S CHILD=+$P(^ORD(101.41,PARENT,10,J,0),U,2) Q:'CHILD 61 . . ; also quit if child is not a generic order 62 . . S ILST=ILST+1,LST(ILST)=CHILD_U_$P(^ORD(101.41,CHILD,0),U,2)_U_PARENT 63 . . I $P(^ORD(101.41,CHILD,0),U,4)="M",$D(^ORD(101.41,CHILD,10))>1 D 64 . . . S LST(ILST)=LST(ILST)_"^+" 65 . . . D LSTCHLD(CHILD) 66 Q 1 ORWDOR ; SLC/KCM - Generic Orders calls for Windows Dialogs [ 08/05/96 8:21 AM ];03:50 PM 17 Jun 1998 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,164,253**;Dec 17, 1997 3 NXT() ; -- returns next available index in return data array 4 S ILST=ILST+1 5 Q ILST 6 ; 7 VMSLCT(LST) ; return default lists for vitals dialog 8 N ILST S ILST=0 9 S LST($$NXT)="~Measurements" D MEAS 10 S LST($$NXT)="~Schedules" D SCHED 11 Q 12 MEAS ; called from VMSLCT 13 N I,X 14 S X="" F S X=$O(^ORD(101.43,"S.V/M",X)) Q:X="" D 15 . S I=$O(^ORD(101.43,"S.V/M",X,0)) 16 . S LST($$NXT)="i"_I_U_$P(^ORD(101.43,"S.V/M",X,I),U,2) 17 Q 18 SCHED ; called from VMSLCT 19 N I,X 20 S X="" F S X=$O(^PS(51.1,"APGMRV",X)) Q:X="" D 21 . S I=$O(^PS(51.1,"APGMRV",X,0)),LST($$NXT)="i"_I_U_X 22 Q 23 VALNUM(ERR,X,DOM) ; return error if invalid number 24 N LOW,HIGH,DEC 25 S LOW=$P(DOM,":"),HIGH=$P(DOM,":",2),DEC=$P(DOM,":",3),ERR=0 26 I $L($P(X,"."))>24 S ERR="1^Exceeded maximum number of 24 characters" Q 27 I X'?.1"-".N.1".".N S ERR="1^Entry must be numeric" Q 28 I X>HIGH!(X<LOW) S ERR="1^Out of Range - value must be between "_LOW_" and "_HIGH_" inclusive" Q 29 I $L($P(+X,".",2))>DEC D 30 . I DEC=0 S ERR="1^No decimal places allowed" 31 . E I DEC=1 S ERR="1^Only one decimal place allowed" 32 . E S ERR="1^No more than "_DEC_" decimal places allowed" 33 Q 34 LKSCRN(ORLST,FROM,DIR,REF,GBL,SCR) ; Return a set of entries from xref in REF 35 ; .Y=returned list, FROM=text to $O from, DIR=$O direction, 36 ; REF=subscript indirection global ref including xref, 37 ; GBL=standard FM global ref, SCR=reference to screen in 101.41 38 N I,IEN,CNT,X,Y,D,ORTYPE 39 S I=0,CNT=44,SCR=$G(SCR) 40 I $L(SCR) S SCR=$G(^ORD(101.41,+SCR,10,+$P(SCR,":",2),4)) 41 S D=$P(REF,"""",2),ORTYPE="D" ;for OI screen 42 F Q:I'<CNT S FROM=$O(@REF@(FROM),DIR) Q:FROM="" D 43 . S IEN=0 F S IEN=$O(@REF@(FROM,IEN)) Q:'IEN D 44 . . ; if screen, set naked ref & Y, then execute screen 45 . . I $L(SCR) S Y=IEN,X=$P($G(@(GBL_"Y,0)")),U) X SCR Q:'$T 46 . . S I=I+1,ORLST(I)=IEN_"^"_FROM 47 Q 48 MNUTREE(LST,ROOT) ; return menu tree for a menu type dialog 49 N ILST S ILST=0 50 S ILST=ILST+1,LST(ILST)=ROOT_U_$P(^ORD(101.41,ROOT,0),U,2)_"^0^+" 51 D LSTCHLD(ROOT) 52 Q 53 LSTCHLD(PARENT) ; list descendends of this node (recursive) 54 N CHILD,I,J 55 S I=0 F S I=$O(^ORD(101.41,PARENT,10,"B",I)) Q:'I D 56 . S J=0 F S J=$O(^ORD(101.41,PARENT,10,"B",I,J)) Q:'J D 57 . . S CHILD=+$P(^ORD(101.41,PARENT,10,J,0),U,2) Q:'CHILD 58 . . ; also quit if child is not a generic order 59 . . S ILST=ILST+1,LST(ILST)=CHILD_U_$P(^ORD(101.41,CHILD,0),U,2)_U_PARENT 60 . . I $P(^ORD(101.41,CHILD,0),U,4)="M",$D(^ORD(101.41,CHILD,10))>1 D 61 . . . S LST(ILST)=LST(ILST)_"^+" 62 . . . D LSTCHLD(CHILD) 63 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS1.m
r613 r623 1 ORWDPS1 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog; 03/10/2008 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,132,141,163,215,255,243**;Dec 17, 1997;Build 242 3 ; 4 ODSLCT(LST,PSTYPE,DFN,LOC) ; return default lists for dialog 5 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) 6 N ILST S ILST=0 7 S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR 8 S ILST=ILST+1,LST(ILST)="~DispMsg" 9 S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG 10 ; 11 ; I PSTYPE="F" D Q ; IV Fluids 12 ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT 13 ; 14 I PSTYPE="O" D ; Outpatient 15 . S ILST=ILST+1,LST(ILST)="~Refills" 16 . S ILST=ILST+1,LST(ILST)="d0^0" 17 . S ILST=ILST+1,LST(ILST)="~Pickup" 18 . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC)) 19 . ; S ILST=ILST+1,LST(ILST)="~Supply" 20 . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN) 21 Q 22 PKI(ORY,OI,PSTYPE,ORVP,PKIACTIV) ; return DEA Schedule for drug 23 N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2,X 24 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) 25 S ILST=0 26 S ORWPSOI=0 27 S:+OI ORWPSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) 28 D START^PSSJORDF(ORWPSOI,$S(PSTYPE="U":"I",1:"O")) ; dflt route, schedule, etc. 29 I '$L($T(DOSE^PSSOPKI1)) D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses 30 I $L($T(DOSE^PSSOPKI1)) D DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses NEW PKI CODE from pharmacy 31 D EN^PSSDIN(ORWPSOI) ; nfi text 32 S ORY="" ;PKI 33 I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D 34 . I '$L(X2) Q 35 . I $G(PKIACTIV) S X=X2 36 S ORY=X 37 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) 38 Q 39 PRIOR ; from DLGSLCT, get list of allowed priorities 40 N X,XREF 41 S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ") 42 S X="" F S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X) D 43 . I XREF["PSJ",X'="ASAP",X'="ROUTINE",X'="STAT" Q 44 . S ILST=ILST+1,LST(ILST)="i"_$O(^ORD(101.42,XREF,X,0))_U_X 45 S ILST=ILST+1,LST(ILST)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE" 46 Q 47 DEFPICK(LOC) ; return default routing 48 N X,DLG,PRMT 49 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" 50 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) 51 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) 52 I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action 53 ; 54 ;S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I") 55 S X=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I") 56 I X="C" S X="C^in Clinic" G XPICK 57 I X="M" S X="M^by Mail" G XPICK 58 I X="W" S X="W^at Window" G XPICK 59 I X="N" S X="" G XPICK 60 I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") 61 XPICK Q X 62 ; 63 DEFSPLY(DFN) ; return default days supply for this patient 64 N ORWX 65 S ORWX("PATIENT")=DFN 66 D DSUP^PSOSIGDS(.ORWX) 67 Q $G(ORWX("DAYS SUPPLY")) 68 ; 69 DFLTSPLY(VAL,UPD,SCH,PAT,DRG) ; return days supply given quantity 70 ; VAL: default days supply 71 N ORWX,I 72 S ORWX("PATIENT")=PAT 73 I DRG S ORWX("DRUG")=DRG 74 F I=1:1:$L(UPD,U)-1 D 75 . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) 76 . S ORWX("SCHEDULE",I)=$P(SCH,U,I) 77 D DSUP^PSOSIGDS(.ORWX) 78 S VAL=$G(ORWX("DAYS SUPPLY")) 79 Q 80 DISPMSG() ; return 1 to suppress dispense message 81 Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I") 82 ; 83 DOWSCH(LST,DFN,LOCIEN) ; return all schedules 84 N CNT,FREQ,ILST,ORARRAY,WIEN 85 S WIEN=$$WARDIEN^ORWDPS32(+$G(LOCIEN)) 86 D SCHED^PSS51P1(WIEN,.ORARRAY) 87 S ILST=0 88 S CNT=0 F S CNT=$O(ORARRAY(CNT)) Q:CNT'>0 D 89 .S NODE=$G(ORARRAY(CNT)) 90 .I $P(NODE,U,4)="C" D 91 ..K ^TMP($J,"ORWDPS1 DOWSCH") 92 ..D ZERO^PSS51P1($P(NODE,U),,,,"ORWDPS1 DOWSCH") 93 ..S FREQ=$G(^TMP($J,"ORWDPS1 DOWSCH",$P(NODE,U),2)) 94 ..K ^TMP($J,"ORWDPS1 DOWSCH") 95 ..I +FREQ=0 Q 96 ..I +FREQ>1440 Q 97 ..S ILST=ILST+1,LST(ILST)=$P(ORARRAY(CNT),U,2,5) 98 Q 99 ; 100 SCHALL(LST,DFN,LOCIEN) ; return all schedules 101 N CNT,ILST,ORARRAY,WIEN 102 S WIEN=$$WARDIEN^ORWDPS32(+$G(LOCIEN)) 103 D SCHED^PSS51P1(WIEN,.ORARRAY) 104 S ILST=0 105 S CNT=0 F S CNT=$O(ORARRAY(CNT)) Q:CNT'>0 D 106 .S ILST=ILST+1,LST(ILST)=$P(ORARRAY(CNT),U,2,5) 107 Q 108 ; 109 FORMALT(ORLST,ORIEN,PSTYPE) ; return a list of formulary alternatives 110 N PSID,I 111 S ORIEN=+$P(^ORD(101.43,ORIEN,0),U,2) 112 D EN1^PSSUTIL1(.ORIEN,PSTYPE) 113 S PSID=0,I=0 114 F S PSID=$O(ORIEN(PSID)) Q:'PSID D 115 . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0)) 116 . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U) 117 Q 118 DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose 119 N I,OI,ORWLST,ILST S ILST=0 120 D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST) 121 S I=0 F S I=$O(ORWLST(I)) Q:'I D 122 . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0)) 123 . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U) 124 Q 125 QOMEDALT(ORY,ODIEN) ; 126 N ARRAY,IDIEN,ORDERID,PKG,PSTYPE,VALUE 127 S ORY=0,PKG=+$P(^ORD(101.41,ODIEN,0),U,7) 128 S PSTYPE=$S($$GET1^DIQ(9.4,PKG_",",1)="PSO":"O",1:"I") 129 S ORDERID=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM","")) Q:ORDERID'>0 130 S IDIEN=$O(^ORD(101.41,ODIEN,6,"D",ORDERID,"")) Q:IDIEN'>0 131 S VALUE=$G(^ORD(101.41,ODIEN,6,IDIEN,1)) Q:VALUE'>0 132 I $P($G(^ORD(101.43,VALUE,"PS")),U,6)=1 S ORY=VALUE 133 ;D FORMALT(.ARRAY,VALUE,PSTYPE) I $D(ARRAY)>0 S ORY=VALUE 134 ;I ORY=0,$P($G(^ORD(101.43,VALUE,"PS")),U,6)=1 S ORY=VALUE 135 Q 136 FAILDEA(FAIL,OI,ORNP,PSTYPE) ; return 1 if DEA check fails for this provider 137 N DEAFLG,PSOI,TPKG 138 S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2) 139 Q:TPKG'["PS" 140 S PSOI=+TPKG Q:PSOI'>0 141 I '$L($T(OIDEA^PSSUTLA1)) Q 142 S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0 143 I '$L($$DEA^XUSER(,+$G(ORNP))) S FAIL=1 144 Q 145 FDEA1(FAIL,OI,OITYPE,ORNP) ; only be called for an outpaitent and IV dialog 146 ;OI: IV Orderable Item 147 ;OITYPE: A:ADDITIVE S:SOLUTION 148 N DEAFLG,PSOI,TKPG 149 S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2) 150 Q:TPKG'["PS" 151 S PSOI=+TPKG Q:PSOI'>0 152 I '$L($T(IVDEA^PSSUTIL1)) Q 153 S DEAFLG=$$IVDEA^PSSUTIL1(PSOI,OITYPE) Q:DEAFLG'>0 154 I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1 155 Q 156 ; 157 CHK94(VAL) ; return 1 if patch 94 has been installed 158 S VAL=0 159 I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1 160 Q 161 LOCPICK(Y,LOC) ; return default Location level routing 162 S Y="" 163 S Y=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I") 164 I Y="C" S Y="C^in Clinic" 165 I Y="M" S Y="M^by Mail" 166 I Y="W" S Y="W^at Window" 167 I Y="N" S Y="" 168 Q 169 HASOIPI(Y,QOID) ; Check if QO put orderable item's PI into Sig 170 N PIIEN,OIX 171 S Y=0 172 Q:'$D(^ORD(101.41,QOID,0)) 173 S PIIEN=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",0)) 174 Q:'PIIEN 175 S OIX=0 176 Q:'$D(^ORD(101.41,QOID,6,"D")) 177 F S OIX=$O(^ORD(101.41,+QOID,6,"D",OIX)) Q:'OIX D 178 . I OIX=PIIEN S Y=1 Q 179 Q 180 HASROUTE(Y,QOID) ;Check if QO has a ROUTE defined 181 N ROUTID 182 S Y=0,ROUTID=0 183 S ROUTID=$O(^ORD(101.41,"B","OR GTX ROUTING",0)) 184 Q:'ROUTID 185 Q:'$D(^ORD(101.41,+QOID)) 186 I $D(^ORD(101.41,+QOID,6,"D",ROUTID)) S Y=1 187 Q 188 QOCHECK(ORY,DIEN) ; 189 N ARY,DG,FORMIEN,NAME,OI,OIIEN,ORDIALOG,ORPKG,TYPE 190 S ORPKG=$$NMSP^ORCD($P($G(^ORD(101.41,DIEN,0)),U,7)) Q:ORPKG'["PS" 191 S DG=$P(^ORD(101.41,DIEN,0),U,5) 192 S NAME=$P(^ORD(100.98,DIEN,0),U) 193 S TYPE=$S(NAME="INPATIENT MEDICATIONS":"I",NAME="OUTPATIENT MEDICATIONS":"O",1:"") 194 I TYPE="" Q 195 S ORDIALOG=$$DEFDLG^ORCD(DIEN) Q:ORDIALOG 196 D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD("^ORD(101.41,"_DIEN_",6)") 197 I $D(ORDIALOG)'>0 Q 198 S OI=$P($G(ORDIALOG("B","ORDERABLE")),U,2) Q:OI'>0 199 S OIIEN=$G(ORDIALOG(OI,1)) Q:OIIEN'>0 200 D FORMALT(.ARY,OIIEN,TYPE) I $D(ARY)'>0 Q 201 S ORY=OIIEN 202 Q 1 ORWDPS1 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog ; 10/04/2005 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,132,141,163,215,255**;Dec 17, 1997 3 ; 4 ODSLCT(LST,PSTYPE,DFN,LOC) ; return default lists for dialog 5 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) 6 N ILST S ILST=0 7 S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR 8 S ILST=ILST+1,LST(ILST)="~DispMsg" 9 S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG 10 ; 11 ; I PSTYPE="F" D Q ; IV Fluids 12 ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT 13 ; 14 I PSTYPE="O" D ; Outpatient 15 . S ILST=ILST+1,LST(ILST)="~Refills" 16 . S ILST=ILST+1,LST(ILST)="d0^0" 17 . S ILST=ILST+1,LST(ILST)="~Pickup" 18 . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC)) 19 . ; S ILST=ILST+1,LST(ILST)="~Supply" 20 . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN) 21 Q 22 PKI(ORY,OI,PSTYPE,ORVP,PKIACTIV) ; return DEA Schedule for drug 23 N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2,X 24 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) 25 S ILST=0 26 S ORWPSOI=0 27 S:+OI ORWPSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) 28 D START^PSSJORDF(ORWPSOI,$S(PSTYPE="U":"I",1:"O")) ; dflt route, schedule, etc. 29 I '$L($T(DOSE^PSSOPKI1)) D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses 30 I $L($T(DOSE^PSSOPKI1)) D DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses NEW PKI CODE from pharmacy 31 D EN^PSSDIN(ORWPSOI) ; nfi text 32 S ORY="" ;PKI 33 I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D 34 . I '$L(X2) Q 35 . I $G(PKIACTIV) S X=X2 36 S ORY=X 37 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) 38 Q 39 PRIOR ; from DLGSLCT, get list of allowed priorities 40 N X,XREF 41 S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ") 42 S X="" F S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X) D 43 . I XREF["PSJ",X'="ASAP",X'="ROUTINE",X'="STAT" Q 44 . S ILST=ILST+1,LST(ILST)="i"_$O(^ORD(101.42,XREF,X,0))_U_X 45 S ILST=ILST+1,LST(ILST)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE" 46 Q 47 DEFPICK(LOC) ; return default routing 48 N X,DLG,PRMT 49 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" 50 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) 51 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) 52 I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action 53 ; 54 ;S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I") 55 S X=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I") 56 I X="C" S X="C^in Clinic" G XPICK 57 I X="M" S X="M^by Mail" G XPICK 58 I X="W" S X="W^at Window" G XPICK 59 I X="N" S X="" G XPICK 60 I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") 61 XPICK Q X 62 ; 63 DEFSPLY(DFN) ; return default days supply for this patient 64 N ORWX 65 S ORWX("PATIENT")=DFN 66 D DSUP^PSOSIGDS(.ORWX) 67 Q $G(ORWX("DAYS SUPPLY")) 68 ; 69 DFLTSPLY(VAL,UPD,SCH,PAT,DRG) ; return days supply given quantity 70 ; VAL: default days supply 71 N ORWX,I 72 S ORWX("PATIENT")=PAT 73 I DRG S ORWX("DRUG")=DRG 74 F I=1:1:$L(UPD,U)-1 D 75 . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) 76 . S ORWX("SCHEDULE",I)=$P(SCH,U,I) 77 D DSUP^PSOSIGDS(.ORWX) 78 S VAL=$G(ORWX("DAYS SUPPLY")) 79 Q 80 DISPMSG() ; return 1 to suppress dispense message 81 Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I") 82 ; 83 SCHALL(LST) ; return all schedules 84 N ILST,SCH,IEN,EXP,TYP,X0 85 S ILST=0,SCH="" 86 F S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH="" D 87 . S IEN=0,EXP="" 88 . F S IEN=$O(^PS(51.1,"APPSJ",SCH,IEN)) Q:'IEN D Q:$L(EXP) 89 . . S X0=$G(^PS(51.1,IEN,0)),EXP=$P(X0,U,8),TYP=$P(X0,U,5) 90 . S ILST=ILST+1,LST(ILST)=SCH_U_EXP_U_TYP 91 Q 92 FORMALT(ORLST,ORIEN,PSTYPE) ; return a list of formulary alternatives 93 N PSID,I 94 S ORIEN=+$P(^ORD(101.43,ORIEN,0),U,2) 95 D EN1^PSSUTIL1(.ORIEN,PSTYPE) 96 S PSID=0,I=0 97 F S PSID=$O(ORIEN(PSID)) Q:'PSID D 98 . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0)) 99 . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U) 100 Q 101 DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose 102 N I,OI,ORWLST,ILST S ILST=0 103 D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST) 104 S I=0 F S I=$O(ORWLST(I)) Q:'I D 105 . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0)) 106 . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U) 107 Q 108 FAILDEA(FAIL,OI,ORNP,PSTYPE) ; return 1 if DEA check fails for this provider 109 N DEAFLG,PSOI,TPKG 110 S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2) 111 Q:TPKG'["PS" 112 S PSOI=+TPKG Q:PSOI'>0 113 I '$L($T(OIDEA^PSSUTLA1)) Q 114 S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0 115 I '$L($$DEA^XUSER(,+$G(ORNP))) S FAIL=1 116 Q 117 FDEA1(FAIL,OI,OITYPE,ORNP) ; only be called for an outpaitent and IV dialog 118 ;OI: IV Orderable Item 119 ;OITYPE: A:ADDITIVE S:SOLUTION 120 N DEAFLG,PSOI,TKPG 121 S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2) 122 Q:TPKG'["PS" 123 S PSOI=+TPKG Q:PSOI'>0 124 I '$L($T(IVDEA^PSSUTIL1)) Q 125 S DEAFLG=$$IVDEA^PSSUTIL1(PSOI,OITYPE) Q:DEAFLG'>0 126 I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1 127 Q 128 ; 129 CHK94(VAL) ; return 1 if patch 94 has been installed 130 S VAL=0 131 I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1 132 Q 133 LOCPICK(Y,LOC) ; return default Location level routing 134 S Y="" 135 S Y=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I") 136 I Y="C" S Y="C^in Clinic" 137 I Y="M" S Y="M^by Mail" 138 I Y="W" S Y="W^at Window" 139 I Y="N" S Y="" 140 Q 141 HASOIPI(Y,QOID) ; Check if QO put orderable item's PI into Sig 142 N PIIEN,OIX 143 S Y=0 144 Q:'$D(^ORD(101.41,QOID,0)) 145 S PIIEN=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",0)) 146 Q:'PIIEN 147 S OIX=0 148 Q:'$D(^ORD(101.41,QOID,6,"D")) 149 F S OIX=$O(^ORD(101.41,+QOID,6,"D",OIX)) Q:'OIX D 150 . I OIX=PIIEN S Y=1 Q 151 Q 152 HASROUTE(Y,QOID) ;Check if QO has a ROUTE defined 153 N ROUTID 154 S Y=0,ROUTID=0 155 S ROUTID=$O(^ORD(101.41,"B","OR GTX ROUTING",0)) 156 Q:'ROUTID 157 Q:'$D(^ORD(101.41,+QOID)) 158 I $D(^ORD(101.41,+QOID,6,"D",ROUTID)) S Y=1 159 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS2.m
r613 r623 1 ORWDPS2 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog;05/09/20072 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,116,125,131,132,148,141,195,215,258,243**;Dec 17, 1997;Build 242 3 4 OISLCT(LST,OI,PSTYPE,ORVP,NEEDPI,PKIACTIV) 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 PTINSTR 44 45 46 47 DOSAGE 48 49 50 51 52 53 DISPLST 54 55 56 57 58 59 60 ALLDOSE 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 BLDDOSE(X) 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 ROUTE 94 95 96 97 98 99 100 101 102 103 104 105 106 107 SCHED 108 109 110 GUIDE 111 112 113 114 115 116 OIMSG 117 118 119 ADMIN(REC,DFN,SCH,OI,LOC ,ADMIN); return administration time info120 121 122 123 I $L($G(^DPT(DFN,.1))) S REC=$$FIRST^ORCDPS3(DFN,LOC,OI,SCH,"",$G(ADMIN))124 125 REQST(VAL,DFN,SCH,OI,LOC,TXT) 126 127 128 129 130 131 132 133 DAY2QTY(VAL,DAY,UPD,SCH,DUR,PAT,DRG) 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 QTY2DAY(VAL,QTY,UPD,SCH,DUR,PAT,DRG) 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 MAXREF(VAL,PAT,DRG,SUP,OI,OUT) 168 169 170 171 172 173 174 175 176 177 178 179 SCHREQ(VAL,OI,RTE,DRG) 180 181 182 183 184 185 CHKPI(VAL,ODIFN) 186 187 188 189 190 191 192 193 194 CHKGRP(VAL,ORIFN) 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 QOGRP(VAL,QOIFN) 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 1 ORWDPS2 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,116,125,131,132,148,141,195,215,258**;Dec 17, 1997;Build 7 3 ; 4 OISLCT(LST,OI,PSTYPE,ORVP,NEEDPI,PKIACTIV) ; return for defaults for pharmacy orderable item 5 N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2 6 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) 7 S ILST=0 8 S ORWPSOI=0 9 S:+OI ORWPSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) 10 D START^PSSJORDF(ORWPSOI,$S(PSTYPE="U":"I",1:"O")) ; dflt route, schedule, etc. 11 I '$L($T(DOSE^PSSOPKI1)) D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses 12 I $L($T(DOSE^PSSOPKI1)) D DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses NEW PKI CODE from pharmacy 13 D EN^PSSDIN(ORWPSOI) ; nfi text 14 S ILST=ILST+1,LST(ILST)="~Medication" 15 S ILST=ILST+1,LST(ILST)="d"_OI_U_$S(+OI:$P(^ORD(101.43,OI,0),U),1:"") 16 S ILST=ILST+1,LST(ILST)="~Verb" 17 S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("MISC")),U) 18 S ILST=ILST+1,LST(ILST)="~Preposition" 19 S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("MISC")),U,2) 20 I $D(NEEDPI),(NEEDPI="Y") S ILST=ILST+1,LST(ILST)="~PtInstr" D PTINSTR 21 ;S:NEEDPI="Y" ILST=ILST+1,LST(ILST)="~PtInstr" D PTINSTR 22 S ILST=ILST+1,LST(ILST)="~AllDoses" D ALLDOSE ; must do before DOSAGE 23 S ILST=ILST+1,LST(ILST)="~Dosage" D DOSAGE 24 S ILST=ILST+1,LST(ILST)="~Dispense" D DISPLST 25 S ILST=ILST+1,LST(ILST)="~Route" D ROUTE 26 S ILST=ILST+1,LST(ILST)="~Schedule" D SCHED 27 S ILST=ILST+1,LST(ILST)="~Guideline" D GUIDE 28 S ILST=ILST+1,LST(ILST)="~Message" D OIMSG 29 S ILST=ILST+1,LST(ILST)="~DEASchedule" ;PKI 30 ;S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("DEA")),U) ;PKI 31 S ILST=ILST+1,LST(ILST)="d" ;PKI 32 I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D 33 . I '$L(X2) Q 34 . I $G(PKIACTIV)="Y" S X=X2 35 S LST(ILST)=LST(ILST)_X 36 I PSTYPE="U" D 37 . ; start, expires, next admin 38 I PSTYPE="O" D 39 . ; days supply, quantity, refills 40 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) 41 Q 42 ; 43 PTINSTR ; from OISLCT, set up patient instructions 44 N I 45 S I=0 F S I=$O(ORDOSE("PI",I)) Q:I'>0 S ILST=ILST+1,LST(ILST)="t"_ORDOSE("PI",I) 46 Q 47 DOSAGE ; from OISLCT, set up the list of dosages 48 ; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE) 49 ; must be called after ALLDOSE so ORWDOSES is set up 50 N I 51 S I=0 F S I=$O(ORWDOSES(I)) Q:I'>0 S ILST=ILST+1,LST(ILST)=ORWDOSES(I) 52 Q 53 DISPLST ; from OISLCT, set up list of dispense drugs 54 ; DrugIEN^Strength^Units^Name^Split 55 N DD 56 S DD=0 F S DD=$O(ORDOSE("DD",DD)) Q:'DD D 57 . S ILST=ILST+1 58 . S LST(ILST)="i"_DD_U_$P(ORDOSE("DD",DD),U,5,6)_U_$P(ORDOSE("DD",DD),U)_U_$P(ORDOSE("DD",DD),U,11) 59 Q 60 ALLDOSE ; from OISLCT, set up a list of all possible doses 61 ; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE) 62 N I,J,CONJ,DD,DRUG,DDNM,LDOSE,TEXT,STREN,UD,COST,NF,ID,X 63 S CONJ=$P($G(ORDOSE("MISC")),U,3),ORWDOSES=0 64 S:$L(CONJ) CONJ=" "_CONJ_" " S:'$L(CONJ) CONJ=" " 65 S I=0 F S I=$O(ORDOSE(I)) Q:I'>0 D 66 . S X=$$BLDDOSE(ORDOSE(I)) 67 . S ORWDOSES=ORWDOSES+1,ORWDOSES(ORWDOSES)=X 68 . S ILST=ILST+1 69 . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4) 70 . S J=0 F S J=$O(ORDOSE(I,J)) Q:J'>0 D 71 . . S X=$$BLDDOSE(ORDOSE(I,J)) 72 . . S ILST=ILST+1 73 . . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4) 74 Q 75 BLDDOSE(X) ; build dose info where X is ORDOSE node 76 ; from ALLDOSE 77 ; X=TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN 78 ; Y=iDrugName^Strength^NF^TDose&Units&U/D&Noun&LDose&Drug&Stren&Units^ 79 ; DoseText^CostText^MaxRefills^DispUnits^CanSplit 80 ; DRUG=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills^ 81 ; No TotalDose, use LocalDose 82 ; TotalDose & Strength, use LocalDose+Conjunction+Strength+Units 83 ; TotalDose, No Strength, use LocalDose+Conjunction+DispenseName 84 S DD=+$P(X,U,6),DRUG=ORDOSE("DD",DD),DDNM=$P(DRUG,U),ID=$P(X,U,1,6) 85 S LDOSE=$P(X,U,5),TEXT=LDOSE,STREN=$P(DRUG,U,5)_$P(DRUG,U,6) 86 S $P(ID,U,7)=$P(DRUG,U,5) S $P(ID,U,8)=$P(DRUG,U,6) ; add strength 87 I '$L($P(X,U)),$L($P(DRUG,U,5)) S TEXT=TEXT_CONJ_STREN 88 I '$L($P(X,U)),'$L($P(DRUG,U,5)) S TEXT=TEXT_CONJ_$P(DRUG,U) 89 S UD=$P(X,U,3),COST=$P(X,U,7),NF=$S($P(DRUG,U,3):"NF",1:"") 90 ;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4) 91 S Y="i"_DDNM_U_STREN_U_NF_U_$TR(ID,U,"&")_U_TEXT_U_COST_U_$P(DRUG,U,8)_U_$P(DRUG,U,4) 92 Q Y 93 ROUTE ; from OISLCT, get list of routes for the drug form 94 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX 95 N I,CNT,ABBR,IEN,ROUT,EXP,X 96 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 97 . S X=^TMP("PSJMR",$J,I) 98 . S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4) 99 . S ILST=ILST+1,LST(ILST)="i"_IEN_U_ROUT_U_ABBR_U_EXP_U_$P(X,U,5) 100 . I $P(X,U,6)="D",IEN S ILST=ILST+1,LST(ILST)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default 101 ; add abbreviations to list of routes, commented out for 15.5 on 102 ; S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 103 ; . S X=^TMP("PSJMR",$J,I) 104 ; . S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4) 105 ; . I $L(ABBR),(ABBR'=ROUT) S ILST=ILST+1,LST(ILST)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR_U_EXP 106 Q 107 SCHED ; from OISLCT, get default schedule for this medication 108 I $L($G(^TMP("PSJSCH",$J))) S ILST=ILST+1,LST(ILST)="d"_^($J) 109 Q 110 GUIDE ; from OISLCT, get guidelines associated with this medication 111 N IEN,I 112 S IEN=0 F S IEN=$O(^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN)) Q:'IEN D 113 . S I=0 F S I=$O(^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN,I)) Q:'I D 114 . . S ILST=ILST+1,LST(ILST)="t"_^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN,I) 115 Q 116 OIMSG ; from OISLCT, get the orderable item message for this medication 117 S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S ILST=ILST+1,LST(ILST)="t"_^(I,0) 118 Q 119 ADMIN(REC,DFN,SCH,OI,LOC) ; return administration time info 120 ; REC: StartText^StartTime^Duration^FirstAdmin 121 S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) 122 S LOC=+$G(^SC(LOC,42)),REC="" 123 I $L($G(^DPT(DFN,.1))) S REC=$$FIRST^ORCDPS3(DFN,LOC,OI,SCH) 124 Q 125 REQST(VAL,DFN,SCH,OI,LOC,TXT) ; return requested start time 126 ; VAL: FirstAdmin time 127 S VAL="" 128 Q:'$L($G(SCH)) Q:'$G(OI) 129 S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) 130 S LOC=+$G(^SC(LOC,42)) 131 S VAL=$P($$RESOLVE^PSJORPOE(DFN,SCH,OI,TXT,LOC),U,2) 132 Q 133 DAY2QTY(VAL,DAY,UPD,SCH,DUR,PAT,DRG) ; return qty for days supply 134 ; VAL: quantity 135 N ORWX,I,X,ADUR,ADURNM 136 S ORWX("DAYS SUPPLY")=DAY 137 S ORWX("PATIENT")=PAT 138 I DRG S ORWX("DRUG")=DRG 139 F I=1:1:$L(UPD,U)-1 D 140 . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) 141 . S ORWX("SCHEDULE",I)=$P(SCH,U,I) 142 . S ADUR=$P(DUR,U,I),ADURNM=$P($P(ADUR," ",2),"~") 143 . S:ADURNM="MONTHS" X=+ADUR_"L" 144 . S:ADURNM'="MONTHS" X=+ADUR_$E($P(ADUR," ",2)) 145 . I $L(X) S ORWX("DURATION",I)=X 146 . S X=$E($P(ADUR,"~",2)) 147 . I $L(X) S ORWX("CONJUNCTION",I)=X 148 D QTYX^PSOSIG(.ORWX) 149 S VAL=$G(ORWX("QTY")) 150 Q 151 QTY2DAY(VAL,QTY,UPD,SCH,DUR,PAT,DRG) ; return days supply given quantity 152 ; VAL: days supply 153 N ORWX,I,X,ADUR 154 S ORWX("QTY")=QTY 155 S ORWX("PATIENT")=PAT 156 I DRG S ORWX("DRUG")=DRG 157 F I=1:1:$L(UPD,U)-1 D 158 . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) 159 . S ORWX("SCHEDULE",I)=$P(SCH,U,I) 160 . S ADUR=$P(DUR,U,I),X=+ADUR_$E($P(ADUR," ",2)) 161 . I $L(X) S ORWX("DURATION",I)=X 162 . S X=$E($P(ADUR,"~",2)) 163 . I $L(X) S ORWX("CONJUNCTION",I)=X 164 D QTYX^PSOSIG(.ORWX) 165 S VAL=$G(ORWX("DAYS SUPPLY")) 166 Q 167 MAXREF(VAL,PAT,DRG,SUP,OI,OUT) ; return the maximum number of refills 168 ; PAT=Patient DFN, DRG=ptr50, SUP=days supply, OI=orderable item 169 ; VAL: maximum refills allowed 170 N ORWX 171 S ORWX("PATIENT")=PAT 172 I $G(DRG) S ORWX("DRUG")=+DRG 173 I $G(SUP) S ORWX("DAYS SUPPLY")=SUP 174 I $G(OI) S ORWX("ITEM")=+$P(^ORD(101.43,+OI,0),U,2) 175 I $G(OUT) S ORWX("DISCHARGE")=1 176 D MAX^PSOSIGDS(.ORWX) 177 S VAL=$G(ORWX("MAX")) 178 Q 179 SCHREQ(VAL,OI,RTE,DRG) ; return 1 if schedule is required 180 ; OI=orderable item, RTE=ptr route, DRG=ptr dispense drug 181 S VAL=1 182 Q:'$G(OI) Q:'$G(RTE) 183 S VAL=$$SCHREQ^PSJORPOE(RTE,OI,+$G(DRG)) 184 Q 185 CHKPI(VAL,ODIFN) ; return pre-existing patient instruct 186 N IDNUM,IDPI 187 S (IDNUM,IDPI)=0,VAL="" 188 I '$D(^OR(100,ODIFN,4.5,"ID","PI")) S VAL="" Q 189 F S IDNUM=$O(^OR(100,ODIFN,4.5,"ID","PI",IDNUM)) Q:'IDNUM D 190 . F S IDPI=$O(^OR(100,ODIFN,4.5,IDNUM,2,IDPI)) Q:'IDPI D 191 .. S VAL=VAL_^OR(100,ODIFN,4.5,IDNUM,2,IDPI,0) 192 K IDNUM,IDPI 193 Q 194 CHKGRP(VAL,ORIFN) ; 195 ;Inpatient Med Order Group or Clin Meds Group: return 1 196 ;If order belong to Outpatient Med Order Grpoup: return 2 197 ;Otherwise, return 0 198 S VAL=0 199 I '$L(ORIFN) Q 200 N UDGRP,IPGRP,OPGRP,ODGRP,ODID,CLMED 201 S ODID=+ORIFN 202 Q:ODID<1 203 S (UDGRP,IPGRP,OPGRP,ODGRP,CLMED)=0 204 S UDGRP=$O(^ORD(100.98,"B","UD RX",UDGRP)) 205 S OPGRP=$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",OPGRP)) 206 S IPGRP=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP)) 207 S CLMED=$O(^ORD(100.98,"B","CLINIC ORDERS",CLMED)) 208 S:IPGRP=0 IPGRP=$O(^ORD(100.98,"B","I RX",IPGRP)) 209 I $L($G(^OR(100,ODID,0)))<1 Q 210 S ODGRP=$P(^OR(100,ODID,0),U,11) 211 I (UDGRP=ODGRP)!(CLMED=ODGRP) S VAL=1 212 I IPGRP=ODGRP S VAL=1 213 I OPGRP=ODGRP S VAL=2 214 K UDGRP,ODGRP,OPGRP,IPGRP,ODID,CLMED 215 Q 216 QOGRP(VAL,QOIFN) ; 217 ;If quick order belong to Inpatient Med Order Group: return 1 218 ;Otherwise, return 0 219 S VAL=0 220 I '$L(QOIFN) Q 221 N UDGRP,IPGRP,QOGRP,QOID,CLMED 222 S QOID=+QOIFN 223 Q:QOID<1 224 S (UDGRP,IPGRP,QOGRP,CLMED)=0 225 S UDGRP=$O(^ORD(100.98,"B","UD RX",UDGRP)) 226 S IPGRP=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP)) 227 S CLMED=$O(^ORD(100.98,"B","CLINIC ORDERS",CLMED)) 228 S:IPGRP=0 IPGRP=$O(^ORD(100.98,"B","I RX",IPGRP)) 229 I $L($G(^ORD(101.41,QOID,0)))<1 Q 230 S QOGRP=$P(^ORD(101.41,QOID,0),U,5) 231 I UDGRP=QOGRP S VAL=1 232 I (IPGRP=QOGRP)!(CLMED=QOGRP) S VAL=1 233 K UDGRP,QOGRP,QOID,IPGRP,CLMED 234 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS32.m
r613 r623 1 ORWDPS32 ; SLC/KCM - Pharmacy Calls for GUI Dialog ; 02/11/2008 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,94,190,195,243**;Dec 17, 1997;Build 242 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 NXT() ; -- ret next available index in data array 5 S ILST=ILST+1 6 Q ILST 7 ; 8 DLGSLCT(LST,PSTYPE,DFN,LOCIEN) ; return def lists for dialog 9 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpt) 10 N ILST S ILST=0 11 I PSTYPE="F" D Q ; IV Fluids 12 . S LST($$NXT)="~ShortList" D SHORT 13 . S LST($$NXT)="~Priorities" D PRIOR 14 . ;S LST($$NXT)="~Schedules" D SCHED(LOCIEN) 15 . S LST($$NXT)="~Route" D IVROUTE 16 ; 17 S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpt 18 ;S LST($$NXT)="~Schedules" D SCHED(LOCIEN) 19 S LST($$NXT)="~Priorities" D PRIOR 20 I PSTYPE="O" D ; Outpt 21 . S LST($$NXT)="~Pickup" D PICKUP 22 . S LST($$NXT)="~SCStatus" D SCLIST 23 Q 24 SHORT ; from DLGSLCT, get short list of med quick orders 25 ; !!! change this so that it uses the ORWDXQ call!!! 26 N I,X,TMP 27 I PSTYPE="U" S X="UD RX" 28 I PSTYPE="F" S X="IV RX" 29 I PSTYPE="O" S X="O RX" 30 D GETQLST^ORWDXQ(.TMP,X,"iQ") 31 S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I) 32 Q 33 SCHEDA ; (similar to SCHED, but also rtns admin times) 34 N X,IEN,SCH,TIME 35 K ^TMP($J,"ORWDPS32 SCHEDA") 36 D AP^PSS51P1("PSJ",,,,"ORWDPS32 SCHEDA") 37 S SCH="" F S SCH=$O(^TMP($J,"ORWDPS32 SCHEDA","APPSJ",SCH)) Q:SCH="" D 38 .S IEN="" F S IEN=$O(^TMP($J,"ORWDPS32 SCHEDA","APPSJ",SCH,IEN)) Q:IEN'>0 D 39 ..S TIME=$G(^TMP($J,"ORWDPS32 SCHEDA",IEN,1)) 40 ..S X=$S($L(TIME):" ("_TIME_")",1:"") 41 ..S LST($$NXT)="i"_IEN_U_SCH_U_X 42 K ^TMP($J,"ORWDPS32 SCHEDA") 43 Q 44 ; 45 IVROUTE ; 46 N ABB,EXP,IEN,RTE 47 K ^TMP($J,"ORWDPS32 IVROUTE") 48 D ALL^PSS51P2(,"??",,1,"ORWDPS32 IVROUTE") 49 S RTE="" F S RTE=$O(^TMP($J,"ORWDPS32 IVROUTE","B",RTE)) Q:RTE="" D 50 .S IEN=$O(^TMP($J,"ORWDPS32 IVROUTE","IV",RTE,"")) Q:IEN'>0 51 .S ABB=$G(^TMP($J,"ORWDPS32 IVROUTE",IEN,1)) 52 .S EXP=$G(^TMP($J,"ORWDPS32 IVROUTE",IEN,4)) 53 .S LST($$NXT)="i"_IEN_U_RTE_U_ABB_U_EXP 54 K ^TMP($J,"ORWDPS32 IVROUTE") 55 Q 56 ; 57 ALLIVRTE(LST) ; 58 N ABB,CNT,EXP,IEN,RTE 59 K ^TMP($J,"ORWDPS32 ALLIVRTE") 60 S CNT=0 61 D ALL^PSS51P2(,"??",,1,"ORWDPS32 ALLIVRTE") 62 S RTE="" F S RTE=$O(^TMP($J,"ORWDPS32 ALLIVRTE","B",RTE)) Q:RTE="" D 63 .S IEN=$O(^TMP($J,"ORWDPS32 ALLIVRTE","IV",RTE,"")) Q:IEN'>0 64 .S ABB=$G(^TMP($J,"ORWDPS32 ALLIVRTE",IEN,1)) 65 .S EXP=$G(^TMP($J,"ORWDPS32 ALLIVRTE",IEN,4)) 66 .S CNT=CNT+1,LST(CNT)=IEN_U_RTE_U_ABB_U_U_U_U 67 K ^TMP($J,"ORWDPS32 IVROUTE") 68 Q 69 ; 70 ROUTE ; from OISLCT^ORWDPS32, get list of routes for the drug form 71 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX 72 N I,CNT,ABBR,IEN,ROUT,X 73 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 74 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) 75 . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR 76 . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default 77 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 78 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) 79 . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR 80 Q 81 ;similar to SCHED^ORWDPS32, also returns Admin Time for Patient ward location 82 ;AGP CPRS 27.72 THIS CODE IS NOT NEEDED ANYMORE 83 SCHED(LOCIEN) ; 84 N CNT,ORARRAY,SCH,IEN,EXP,TIME,TYP,X0,WIEN 85 ;K ^TMP($J,"ORWDPS32 SCHED1") 86 S WIEN=$$WARDIEN(+LOCIEN) 87 D SCHED^PSS51P1(WIEN,.ORARRAY) 88 S CNT=0 F S CNT=$O(ORARRAY(CNT)) Q:CNT'>0 D 89 .S LST($$NXT)="i"_$P(ORARRAY(CNT),U,2,5) 90 Q 91 ; 92 WARDIEN(LOCIEN) ; 93 N RESULT 94 S RESULT=0 95 I LOCIEN=0 Q RESULT 96 I $P($G(^SC(LOCIEN,42)),U)="" Q RESULT 97 S RESULT=+$P($G(^SC(LOCIEN,42)),U) 98 Q RESULT 99 PRIOR ; from DLGSLCT, get list of allowed priorities 100 N X,XREF 101 S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ") 102 S X="" F S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X) D 103 . S LST($$NXT)="i"_$O(^ORD(101.42,XREF,X,0))_U_X 104 S LST($$NXT)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE" 105 Q 106 PICKUP ; from DLGSLCT, get prescription routing 107 N X,EDITONLY 108 F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X 109 S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X 110 Q 111 DEFPICK() ; ret def routing 112 N X,DLG,PRMT 113 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" 114 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) 115 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) 116 I X'="" S EDITONLY=1 Q X ; EDITONLY used by def action 117 ; 118 S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I") 119 I X="C" S X="C^in Clinic" G XPICK 120 I X="M" S X="M^by Mail" G XPICK 121 I X="W" S X="W^at Window" G XPICK 122 I X="N" S X="" G XPICK 123 I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") 124 XPICK Q X 125 ; 126 SCLIST ; from DLGSLCT, get options for service connected 127 F X="0^No","1^Yes" S LST($$NXT)="i"_X 128 Q 129 ; 130 OISLCT(LST,OI,PSTYPE,ORVP) ; rtn for defaults for pharm OI 131 N ILST S ILST=0 132 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 133 S LST($$NXT)="~Dispense" D DISPDRG 134 S LST($$NXT)="~Instruct" D INSTRCT 135 S LST($$NXT)="~Route" D ROUTE 136 S LST($$NXT)="~Message" D MESSAGE 137 I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J) 138 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 139 Q 140 ; 141 DISPDRUG(LST,OI) ; list dispense drugs for an OI 142 N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG 143 Q 144 ; 145 DISPDRG ; from OISLCT, get disp drugs for this pharm OI 146 N I,ORTMP,ORX 147 S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",") 148 I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP) 149 I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) 150 S I="" F S I=$O(ORTMP(I)) Q:I="" D 151 . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF" 152 . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5) 153 . S LST($$NXT)="i"_ORTMP(I) 154 Q 155 INSTRCT ; from OISLCT, get list of potential instructs (based on drug form) 156 N INOUN,NOUN,IINS,INS,VERB,INSREC 157 D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2)) 158 I PSTYPE="U" Q ; don't use the instructions list for inpatients 159 S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D 160 . S INSREC=$G(^TMP("PSJINS",$J,IINS)) 161 . I '$D(VERB) S VERB=$P(INSREC,U) 162 . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2) 163 S LST($$NXT)="~Nouns" 164 S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D 165 . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U) 166 I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB 167 ; 168 Q 169 MIXED(X) ; Return mixed case 170 Q X 171 ; 172 MESSAGE ; message 173 S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0) 174 Q 175 ALLROUTE(LST) ; returns a list of all available med routes 176 N I,X,ILST 177 S ILST=0 178 K ^TMP($J,"ORWDPS32 ALLROUTE") 179 D ALL^PSS51P2(,"??",,,"ORWDPS32 ALLROUTE") 180 S I=0 F S I=$O(^TMP($J,"ORWDPS32 ALLROUTE",I)) Q:'I D 181 . I +$P(^TMP($J,"ORWDPS32 ALLROUTE",I,3),U)>0 S LST($$NXT)=I_U_^TMP($J,"ORWDPS32 ALLROUTE",I,.01)_U_^TMP($J,"ORWDPS32 ALLROUTE",I,1) 182 K ^TMP($J,"ORWDPS32 ALLROUTE") 183 Q 184 VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation 185 N ABBR,NAME,IEN 186 K ^TMP($J,"ORWDPS32 VALROUTE") 187 S X=$$UPPER(X) 188 D ALL^PSS51P2(,X,,1,"ORWDPS32 VALROUTE") 189 I $P(^TMP($J,"ORWDPS32 VALROUTE",0),U)=-1 K ^TMP($J,"ORWDPS32 VALROUTE") S REC=0 Q 190 S IEN=$O(^TMP($J,"ORWDPS32 VALROUTE","B",X,"")) 191 I IEN'>0 S IEN=$O(^TMP($J,"ORWDPS32 VALROUTE","C",X,"")) 192 I IEN'>0 S REC=0 Q 193 S NAME=$G(^TMP($J,"ORWDPS32 VALROUTE",IEN,.01)) 194 S ABBR=$G(^TMP($J,"ORWDPS32 VALROUTE",IEN,1)) 195 I '$L(ABBR) S ABBR=NAME 196 I ($$UPPER(NAME)'=X),($$UPPER(ABBR)'=X) S REC=0 K ^TMP($J,"ORWDPS32 VALROUTE") Q 197 S REC=IEN_U_ABBR 198 K ^TMP($J,"ORWDPS32 VALROUTE") 199 Q 200 AUTH(VAL,PRV) ; For inpatient meds, check restrictions 201 N NAME,AUTH,INACT,X S VAL=0 202 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) 203 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) 204 I 'AUTH!(INACT&(DT>INACT)) D Q 205 . S VAL="1^"_NAME_" is not authorized to write medication orders." 206 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q 207 . S VAL="1^OREMAS key holders may not enter medication orders." 208 Q 209 AUTHNVA(VAL,PRV) ; For Non-VA meds, check restrictions 210 N NAME,AUTH,INACT,X S VAL=0 211 I $D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS")=2 Q 212 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS") D Q 213 . S VAL="1^OREMAS key holders may not enter non-VA medication orders." 214 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) 215 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) 216 I 'AUTH!(INACT&(DT>INACT)) D Q 217 . S VAL="1^"_NAME_" is not authorized to write medication orders." 218 Q 219 ; 220 UPPER(X) ; return uppercase 221 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 222 ; 223 TRIM(X) ; trim leading and trailing spaces 224 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail 225 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead 226 Q X 227 ; 1 ORWDPS32 ; SLC/KCM - Pharmacy Calls for GUI Dialog ;08/04/96 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,94,190,195,237**;Dec 17, 1997 3 ; 4 NXT() ; -- ret next available index in data array 5 S ILST=ILST+1 6 Q ILST 7 ; 8 DLGSLCT(LST,PSTYPE) ; return def lists for dialog 9 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpt) 10 N ILST S ILST=0 11 I PSTYPE="F" D Q ; IV Fluids 12 . S LST($$NXT)="~ShortList" D SHORT 13 . S LST($$NXT)="~Priorities" D PRIOR 14 ; 15 S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpt 16 S LST($$NXT)="~Schedules" D SCHED 17 S LST($$NXT)="~Priorities" D PRIOR 18 I PSTYPE="O" D ; Outpt 19 . S LST($$NXT)="~Pickup" D PICKUP 20 . S LST($$NXT)="~SCStatus" D SCLIST 21 Q 22 SHORT ; from DLGSLCT, get short list of med quick orders 23 ; !!! change this so that it uses the ORWDXQ call!!! 24 N I,X,TMP 25 I PSTYPE="U" S X="UD RX" 26 I PSTYPE="F" S X="IV RX" 27 I PSTYPE="O" S X="O RX" 28 D GETQLST^ORWDXQ(.TMP,X,"iQ") 29 S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I) 30 Q 31 SCHED ; from DLGSLCT, get all pharm admin scheds 32 N X 33 S X="" F S X=$O(^PS(51.1,"APPSJ",X)) Q:X="" S LST($$NXT)="i"_X 34 Q 35 SCHEDA ; (similar to SCHED, but also rtns admin times) 36 N X,IEN,SCH 37 S SCH="" F S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH="" D 38 . S IEN=0 F S IEN=$O(^PS(51.1,"APPSJ",SCH,IEN)) Q:IEN'>0 D 39 . . S X=^PS(51.1,IEN,0) S X=$S($L($P(X,U,2)):" ("_$P(X,U,2)_")",1:"") 40 . . S LST($$NXT)="i"_IEN_U_SCH_X 41 Q 42 PRIOR ; from DLGSLCT, get list of allowed priorities 43 N X,XREF 44 S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ") 45 S X="" F S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X) D 46 . S LST($$NXT)="i"_$O(^ORD(101.42,XREF,X,0))_U_X 47 S LST($$NXT)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE" 48 Q 49 PICKUP ; from DLGSLCT, get prescription routing 50 N X,EDITONLY 51 F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X 52 S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X 53 Q 54 DEFPICK() ; ret def routing 55 N X,DLG,PRMT 56 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" 57 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) 58 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) 59 I X'="" S EDITONLY=1 Q X ; EDITONLY used by def action 60 ; 61 S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I") 62 I X="C" S X="C^in Clinic" G XPICK 63 I X="M" S X="M^by Mail" G XPICK 64 I X="W" S X="W^at Window" G XPICK 65 I X="N" S X="" G XPICK 66 I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") 67 XPICK Q X 68 ; 69 SCLIST ; from DLGSLCT, get options for service connected 70 F X="0^No","1^Yes" S LST($$NXT)="i"_X 71 Q 72 ; 73 OISLCT(LST,OI,PSTYPE,ORVP) ; rtn for defaults for pharm OI 74 N ILST S ILST=0 75 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 76 S LST($$NXT)="~Dispense" D DISPDRG 77 S LST($$NXT)="~Instruct" D INSTRCT 78 S LST($$NXT)="~Route" D ROUTE 79 S LST($$NXT)="~Message" D MESSAGE 80 I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J) 81 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 82 Q 83 ; 84 DISPDRUG(LST,OI) ; list dispense drugs for an OI 85 N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG 86 Q 87 ; 88 DISPDRG ; from OISLCT, get disp drugs for this pharm OI 89 N I,ORTMP,ORX 90 S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",") 91 I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP) 92 I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) 93 S I="" F S I=$O(ORTMP(I)) Q:I="" D 94 . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF" 95 . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5) 96 . S LST($$NXT)="i"_ORTMP(I) 97 Q 98 INSTRCT ; from OISLCT, get list of potential instructs (based on drug form) 99 N INOUN,NOUN,IINS,INS,VERB,INSREC 100 D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2)) 101 I PSTYPE="U" Q ; don't use the instructions list for inpatients 102 S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D 103 . S INSREC=$G(^TMP("PSJINS",$J,IINS)) 104 . I '$D(VERB) S VERB=$P(INSREC,U) 105 . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2) 106 S LST($$NXT)="~Nouns" 107 S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D 108 . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U) 109 I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB 110 ; 111 Q 112 MIXED(X) ; Return mixed case 113 Q X ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") 114 ; 115 ROUTE ; from OISLCT, get list of routes for the drug form 116 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX 117 N I,CNT,ABBR,IEN,ROUT,X 118 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 119 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) 120 . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR 121 . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default 122 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 123 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) 124 . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR 125 Q 126 MESSAGE ; message 127 S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0) 128 Q 129 ALLROUTE(LST) ; returns a list of all available med routes 130 N I,X,ILST S ILST=0 131 S I=0 F S I=$O(^PS(51.2,I)) Q:'I S X=^(I,0) D 132 . I $P(X,U,4) S LST($$NXT)=I_U_$P(X,U)_U_$P(X,U,3) 133 Q 134 VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation 135 N ORLST,ABBR 136 D FIND^DIC(51.2,"",1,"MO",X,1,,"I $P(^(0),U,4)=1",,"ORLST") 137 I 'ORLST("DILIST",0) S REC=0 Q 138 S X=$$UPPER(X),ABBR=ORLST("DILIST","ID",1,1) 139 I '$L(ABBR) S ABBR=ORLST("DILIST",1,1) 140 I ($$UPPER(ORLST("DILIST",1,1))'=X),($$UPPER(ABBR)'=X) S REC=0 Q 141 S REC=ORLST("DILIST",2,1)_U_ABBR 142 Q 143 AUTH(VAL,PRV) ; For inpatient meds, check restrictions 144 N NAME,AUTH,INACT,X S VAL=0 145 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) 146 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) 147 I 'AUTH!(INACT&(DT>INACT)) D Q 148 . S VAL="1^"_NAME_" is not authorized to write medication orders." 149 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q 150 . S VAL="1^OREMAS key holders may not enter medication orders." 151 Q 152 AUTHNVA(VAL,PRV) ; For Non-VA meds, check restrictions 153 N NAME,AUTH,INACT,X S VAL=0 154 I $D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS")=2 Q 155 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS") D Q 156 . S VAL="1^OREMAS key holders may not enter non-VA medication orders." 157 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) 158 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) 159 I 'AUTH!(INACT&(DT>INACT)) D Q 160 . S VAL="1^"_NAME_" is not authorized to write medication orders." 161 Q 162 DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug 163 N X S X=$$ENDCM^PSJORUTL(IEN) 164 S VAL=$P(X,U,2)_U_$P(X,U,4) 165 Q 166 MEDISIV(VAL,IEN) ; return true if orderable item is IV medication 167 S VAL=0 168 I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1 169 Q 170 ISSPLY(VAL,IEN) ; return true if orderable item is a supply 171 S VAL=0 172 I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1 173 Q 174 IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln 175 N I,PSOI,ORWY,AMT 176 S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2)_ORWTYP,VAL="" 177 D ENVOL^PSJORUT2(PSOI,.ORWY) 178 I ORWTYP="B" D 179 . S I=0 F S I=$O(ORWY(I)) Q:I'>0 S AMT(+ORWY(I))="" 180 . S AMT=0,VAL="ML" F S AMT=$O(AMT(AMT)) Q:AMT'>0 S VAL=VAL_U_AMT 181 I ORWTYP="A" D 182 . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2) 183 . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM" 184 Q 185 VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid 186 I $E($RE($$UPPER(X)),1,5)="RH/LM" S X=$E(X,1,$L(X)-5) 187 S X=$$TRIM(X) 188 D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0) 189 Q 190 UPPER(X) ; return uppercase 191 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 192 ; 193 TRIM(X) ; trim leading and trailing spaces 194 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail 195 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead 196 Q X 197 SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient 198 N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0 199 I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS 200 I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS 201 S VAL=1 202 XSCSTS Q 203 FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives 204 D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST) 205 S I=0 F S I=$O(ORLST(I)) Q:'I D 206 . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0)) 207 . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U) 208 Q 209 VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not 210 I '$L($T(EN^PSSGSGUI)) S OK=-1 Q 211 I $E($T(EN^PSSGSGUI),1,4)="EN(X" D 212 . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I")) 213 . K X S:$D(ORX) X=ORX 214 E D 215 . D EN^PSSGSGUI 216 S OK=$S($D(X):1,1:0) 217 Q 218 VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not 219 ; to be compatible with LM, make sure X is integer from 1 to 240 220 ; this is based on the input transform from 52,7 221 K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X 222 S OK=$S($D(X):1,1:0) 223 Q 224 DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY 225 N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O" 226 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) 227 S ORI=0 F S ORI=$O(ORTMP(ORI)) Q:'ORI S ORWDRG=+ORTMP(ORI) D 228 . S NDF=$G(^PSDRUG(+ORWDRG,"ND")),VAPN=$P(NDF,U,3),NDF=+NDF 229 . S X=$$DFSU^PSNAPIS(NDF,VAPN) 230 . S LSTA($P(X,U,4),$P(X,U,6))="" 231 . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))="" 232 S ORI="",ILST=0 F S ORI=$O(LSTA(ORI)) Q:ORI="" D 233 . S ORJ="" F S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ="" D 234 . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ 235 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS4.m
r613 r623 1 ORWDPS4 ;; SLC/JDL - Order Dialogs CO-PAY and Other;[12/31/01 6:38pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**116,125,131,141,173,187,190,195,215,243**;Dec 17, 1997;Build 242 3 ; 4 CPLST(TEST,PTIFN,ORIFNS) ; --Get CP questions 5 N ORIFN,ORDA,ORI,ORPSO,CPX 6 S ORI=0,ORPSO=+$O(^DIC(9.4,"C","PSO",0)) 7 F S ORI=$O(ORIFNS(ORI)) Q:'ORI D 8 .S ORIFN=+ORIFNS(ORI),ORDA=$P(ORIFNS(ORI),";",2) 9 .I $D(^OR(100,ORIFN,0)),($P(^OR(100,ORIFN,0),U,14)=ORPSO) D 10 ..N PRIO S PRIO=0 11 ..I $D(^OR(100,ORIFN,4.5,"ID","URGENCY")) S PRIO=$O(^("URGENCY",0)) 12 ..S PRIO=$G(^OR(100,ORIFN,4.5,+PRIO,1)) 13 ..Q:PRIO=99 14 ..S CPX=$$SC(ORIFN) 15 ..I $L(CPX)>1 S TEST(ORIFN)=ORIFN_";"_ORDA_CPX 16 K PTIFN,ORIFN,ORDA,ORI,CPX 17 Q 18 ; 19 CPINFO(Y,ORINFO) ; -- Save reponses to CP questions 20 Q:'$D(ORINFO) 21 N ORIFN,ORI,ORX,ANS S ORI=0 22 F S ORI=$O(ORINFO(ORI)) Q:'ORI D 23 .S ORIFN=$P($P(ORINFO(ORI),U,1),";",1) 24 .S ANS=$P(ORINFO(ORI),U,2) 25 .D REFMT(.ORX,ANS) 26 .D SC^ORCSAVE2(.ORX,ORIFN) 27 S Y=1 28 K ORIFN,ORX,ORI,ANS 29 Q 30 ; 31 SC(ORIFN) ; -- Dialog validation, to ask CP questions 32 ;Expects ORIFN and ORDA 33 ; 34 N DR S DR="" 35 I '$L($T(SCNEW^PSOCP))!('$G(ORIFN))!('$G(ORDA)) Q DR 36 I $P($G(^OR(100,ORIFN,8,ORDA,0)),U,2)'="NW" Q DR 37 ; 38 N OR3,ORDRUG,ORENEW,ORX,I,XACT,YACT,CPNODE,ASC,AAO,AIR,AEC,AMST,AHNC,ACV,ASHD 39 S ORX="",XACT="" 40 ;--Only new, renew, edited, copied outpatient order can continue... 41 ;AGP CHANGE 26.65, will returned service connection data for change orders 42 S OR3=$G(^OR(100,ORIFN,3)),XACT=$P(OR3,U,11) I (XACT'=0)&(XACT'=1)&((XACT'=2)&(XACT'="C")) Q DR 43 I (XACT=1)&($D(^OR(100,ORIFN,5))=0) Q DR 44 I $D(^OR(100,ORIFN,5))>0 D 45 .S CPNODE=$G(^OR(100,ORIFN,5)) 46 .S ASC=$S($L($P(CPNODE,"^",1)):"SC;"_$P(CPNODE,"^",1),1:"") 47 .S DR=$S($L(ASC):DR_U_ASC,1:DR) 48 .S AAO=$S($L($P(CPNODE,"^",3)):"AO;"_$P(CPNODE,"^",3),1:"") 49 .S DR=$S($L(AAO):DR_U_AAO,1:DR) 50 .S AIR=$S($L($P(CPNODE,"^",4)):"IR;"_$P(CPNODE,"^",4),1:"") 51 .S DR=$S($L(AIR):DR_U_AIR,1:DR) 52 .S AEC=$S($L($P(CPNODE,"^",5)):"EC;"_$P(CPNODE,"^",5),1:"") 53 .S DR=$S($L(AEC):DR_U_AEC,1:DR) 54 .S AMST=$S($L($P(CPNODE,"^",2)):"MST;"_$P(CPNODE,"^",2),1:"") 55 .S DR=$S($L(AMST):DR_U_AMST,1:DR) 56 .S AHNC=$S($L($P(CPNODE,"^",6)):"HNC;"_$P(CPNODE,"^",6),1:"") 57 .S DR=$S($L(AHNC):DR_U_AHNC,1:DR) 58 .S ACV=$S($L($P(CPNODE,"^",7)):"CV;"_$P(CPNODE,"^",7),1:"") 59 .S DR=$S($L(ACV):DR_U_ACV,1:DR) 60 .S ASHD=$S($L($P(CPNODE,"^",8)):"SHD;"_$P(CPNODE,"^",8),1:"") 61 .S DR=$S($L(ASHD):DR_U_ASHD,1:DR) 62 .D CPCOMP(.DR) 63 .K ASC,AAO,AIR,AEC,AMST,AHNC,CPNODE 64 I $L(DR)>0 Q DR 65 I XACT=2 S YACT=$P(OR3,U,5),ORENEW=$G(^OR(100,YACT,4)) ;get PS# if renewal 66 S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG") 67 D SCNEW^PSOCP(.ORX,+PTIFN,ORDRUG,$G(ORENEW)) I '$D(ORX) Q DR 68 F I="SC","AO","IR","EC","MST","HNC","CV","SHD" D 69 . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"") 70 Q DR 71 REFMT(ORX,INFO) ; 72 ;"U": Unchecked ("NO") 73 ;"C": Checked ("YES") 74 ;"N" : Question not asked 75 N RST,RST1 76 S RST="" 77 F I=1:1:$L(INFO) S RST=RST_U_$S($E(INFO,I)="U":0,$E(INFO,I)="C":1,1:"") 78 S RST1=$E(RST,2,$L(RST)) 79 S ORX("SC")=$P(RST1,U,1) 80 S ORX("MST")=$P(RST1,U,5) 81 S ORX("AO")=$P(RST1,U,2) 82 S ORX("IR")=$P(RST1,U,3) 83 S ORX("EC")=$P(RST1,U,4) 84 S ORX("HNC")=$P(RST1,U,6) 85 S ORX("CV")=$P(RST1,U,7) 86 S ORX("SHD")=$P(RST1,U,8) 87 K RST,RST1 88 Q 89 CPCOMP(PREX) ; -- Compare the existed exemptions with new exemption questions 90 N ORX1,ORDRUG1,CPI,LSTCP,TMPVAL 91 S LSTCP="" 92 S ORDRUG1=$$VALUE^ORCSAVE2(ORIFN,"DRUG") 93 D SCNEW^PSOCP(.ORX1,+PTIFN,ORDRUG1,$G(ORENEW)) I '$D(ORX1) Q 94 F CPI="SC","AO","IR","EC","MST","HNC","CV","SHD" D 95 . I $D(ORX1(CPI)) D 96 . . S TMPVAL="" 97 . . I $F(PREX,CPI) D 98 . . . S TMPVAL=+$E(PREX,$F(PREX,CPI)+1) 99 . . . I $L(TMPVAL),((TMPVAL=0)!(TMPVAL=1)) S TMPVAL=CPI_";"_TMPVAL 100 . . . E S TMPVAL=CPI 101 . . E S TMPVAL=CPI 102 . . S LSTCP=LSTCP_U_TMPVAL 103 S PREX=LSTCP 104 Q 105 IPOD4OP(ORY,ORID) ;True: is an Inpt (IV OI) order on an OutPatient 106 Q:'$D(^OR(100,+ORID,0)) 107 S ORY=0 108 N APKG,ADLG,ADG,APTCLS,RXDG,UDDLG,IPPKG 109 S (RXDG,UDDLG,IPPKG)=0 110 S RXDG=+$O(^ORD(100.98,"B","O RX",0)) 111 S UDDLG=+$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) 112 S IPPKG=+$O(^DIC(9.4,"B","INPATIENT MEDICATIONS",0)) 113 S ADLG=+$P($G(^OR(100,+ORID,0)),U,5) 114 S ADG=$P($G(^OR(100,+ORID,0)),U,11) 115 S APKG=$P($G(^OR(100,+ORID,0)),U,14) 116 S APTCLS=$P($G(^OR(100,+ORID,0)),U,12) 117 I ADG=RXDG,(ADLG=UDDLG),(APKG=IPPKG),(APTCLS="I") S ORY=1 118 Q 119 ; 120 UPDTDG(ORY,ORID) ;Update Inpt order for outpatient DG to Inpt DG 121 Q:'$D(^OR(100,+ORID,0)) 122 N UDDG 123 S UDDG=$O(^ORD(100.98,"B","UD RX",0)) 124 S $P(^OR(100,+ORID,0),U,11)=UDDG 125 Q 126 ISUDIV(ORY,ORIFN) ;True: OI of the order is for both UD and IV 127 N OI 128 S (OI,ORY)=0 129 S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1 130 I $O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORY=1 131 Q 1 ORWDPS4 ;; SLC/JDL - Order Dialogs CO-PAY and Other;[12/31/01 6:38pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**116,125,131,141,173,187,190,195,215**;Dec 17, 1997 3 ; 4 CPLST(TEST,PTIFN,ORIFNS) ; --Get CP questions 5 N ORIFN,ORDA,ORI,ORPSO,CPX 6 S ORI=0,ORPSO=+$O(^DIC(9.4,"C","PSO",0)) 7 F S ORI=$O(ORIFNS(ORI)) Q:'ORI D 8 .S ORIFN=+ORIFNS(ORI),ORDA=$P(ORIFNS(ORI),";",2) 9 .I $D(^OR(100,ORIFN,0)),($P(^OR(100,ORIFN,0),U,14)=ORPSO) D 10 ..N PRIO S PRIO=0 11 ..I $D(^OR(100,ORIFN,4.5,"ID","URGENCY")) S PRIO=$O(^("URGENCY",0)) 12 ..S PRIO=$G(^OR(100,ORIFN,4.5,+PRIO,1)) 13 ..Q:PRIO=99 14 ..S CPX=$$SC(ORIFN) 15 ..I $L(CPX)>1 S TEST(ORIFN)=ORIFN_";"_ORDA_CPX 16 K PTIFN,ORIFN,ORDA,ORI,CPX 17 Q 18 ; 19 CPINFO(Y,ORINFO) ; -- Save reponses to CP questions 20 Q:'$D(ORINFO) 21 N ORIFN,ORI,ORX,ANS S ORI=0 22 F S ORI=$O(ORINFO(ORI)) Q:'ORI D 23 .S ORIFN=$P($P(ORINFO(ORI),U,1),";",1) 24 .S ANS=$P(ORINFO(ORI),U,2) 25 .D REFMT(.ORX,ANS) 26 .D SC^ORCSAVE2(.ORX,ORIFN) 27 S Y=1 28 K ORIFN,ORX,ORI,ANS 29 Q 30 ; 31 SC(ORIFN) ; -- Dialog validation, to ask CP questions 32 ;Expects ORIFN and ORDA 33 ; 34 N DR S DR="" 35 I '$L($T(SCNEW^PSOCP))!('$G(ORIFN))!('$G(ORDA)) Q DR 36 I $P($G(^OR(100,ORIFN,8,ORDA,0)),U,2)'="NW" Q DR 37 ; 38 N OR3,ORDRUG,ORENEW,ORX,I,XACT,YACT,CPNODE,ASC,AAO,AIR,AEC,AMST,AHNC,ACV 39 S ORX="",XACT="" 40 ;--Only new, renew, edited, copied outpatient order can continue... 41 ;AGP CHANGE 26.65, will returned service connection data for change orders 42 S OR3=$G(^OR(100,ORIFN,3)),XACT=$P(OR3,U,11) I (XACT'=0)&(XACT'=1)&((XACT'=2)&(XACT'="C")) Q DR 43 I (XACT=1)&($D(^OR(100,ORIFN,5))=0) Q DR 44 I $D(^OR(100,ORIFN,5))>0 D 45 .S CPNODE=$G(^OR(100,ORIFN,5)) 46 .S ASC=$S($L($P(CPNODE,"^",1)):"SC;"_$P(CPNODE,"^",1),1:"") 47 .S DR=$S($L(ASC):DR_U_ASC,1:DR) 48 .S AAO=$S($L($P(CPNODE,"^",3)):"AO;"_$P(CPNODE,"^",3),1:"") 49 .S DR=$S($L(AAO):DR_U_AAO,1:DR) 50 .S AIR=$S($L($P(CPNODE,"^",4)):"IR;"_$P(CPNODE,"^",4),1:"") 51 .S DR=$S($L(AIR):DR_U_AIR,1:DR) 52 .S AEC=$S($L($P(CPNODE,"^",5)):"EC;"_$P(CPNODE,"^",5),1:"") 53 .S DR=$S($L(AEC):DR_U_AEC,1:DR) 54 .S AMST=$S($L($P(CPNODE,"^",2)):"MST;"_$P(CPNODE,"^",2),1:"") 55 .S DR=$S($L(AMST):DR_U_AMST,1:DR) 56 .S AHNC=$S($L($P(CPNODE,"^",6)):"HNC;"_$P(CPNODE,"^",6),1:"") 57 .S DR=$S($L(AHNC):DR_U_AHNC,1:DR) 58 .S ACV=$S($L($P(CPNODE,"^",7)):"CV;"_$P(CPNODE,"^",7),1:"") 59 .S DR=$S($L(ACV):DR_U_ACV,1:DR) 60 .D CPCOMP(.DR) 61 .K ASC,AAO,AIR,AEC,AMST,AHNC,CPNODE 62 I $L(DR)>0 Q DR 63 I XACT=2 S YACT=$P(OR3,U,5),ORENEW=$G(^OR(100,YACT,4)) ;get PS# if renewal 64 S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG") 65 D SCNEW^PSOCP(.ORX,+PTIFN,ORDRUG,$G(ORENEW)) I '$D(ORX) Q DR 66 F I="SC","AO","IR","EC","MST","HNC","CV" D 67 . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"") 68 Q DR 69 REFMT(ORX,INFO) ; 70 ;"U": Unchecked ("NO") 71 ;"C": Checked ("YES") 72 ;"N" : Question not asked 73 N RST,RST1 74 S RST="" 75 F I=1:1:$L(INFO) S RST=RST_U_$S($E(INFO,I)="U":0,$E(INFO,I)="C":1,1:"") 76 S RST1=$E(RST,2,$L(RST)) 77 S ORX("SC")=$P(RST1,U,1) 78 S ORX("MST")=$P(RST1,U,5) 79 S ORX("AO")=$P(RST1,U,2) 80 S ORX("IR")=$P(RST1,U,3) 81 S ORX("EC")=$P(RST1,U,4) 82 S ORX("HNC")=$P(RST1,U,6) 83 S ORX("CV")=$P(RST1,U,7) 84 K RST,RST1 85 Q 86 CPCOMP(PREX) ; -- Compare the existed exemptions with new exemption questions 87 N ORX1,ORDRUG1,CPI,LSTCP,TMPVAL 88 S LSTCP="" 89 S ORDRUG1=$$VALUE^ORCSAVE2(ORIFN,"DRUG") 90 D SCNEW^PSOCP(.ORX1,+PTIFN,ORDRUG1,$G(ORENEW)) I '$D(ORX1) Q 91 F CPI="SC","AO","IR","EC","MST","HNC","CV" D 92 . I $D(ORX1(CPI)) D 93 . . S TMPVAL="" 94 . . I $F(PREX,CPI) D 95 . . . S TMPVAL=+$E(PREX,$F(PREX,CPI)+1) 96 . . . I $L(TMPVAL),((TMPVAL=0)!(TMPVAL=1)) S TMPVAL=CPI_";"_TMPVAL 97 . . . E S TMPVAL=CPI 98 . . E S TMPVAL=CPI 99 . . S LSTCP=LSTCP_U_TMPVAL 100 S PREX=LSTCP 101 Q 102 IPOD4OP(ORY,ORID) ;True: is an Inpt (IV OI) order on an OutPatient 103 Q:'$D(^OR(100,+ORID,0)) 104 S ORY=0 105 N APKG,ADLG,ADG,APTCLS,RXDG,UDDLG,IPPKG 106 S (RXDG,UDDLG,IPPKG)=0 107 S RXDG=+$O(^ORD(100.98,"B","O RX",0)) 108 S UDDLG=+$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) 109 S IPPKG=+$O(^DIC(9.4,"B","INPATIENT MEDICATIONS",0)) 110 S ADLG=+$P($G(^OR(100,+ORID,0)),U,5) 111 S ADG=$P($G(^OR(100,+ORID,0)),U,11) 112 S APKG=$P($G(^OR(100,+ORID,0)),U,14) 113 S APTCLS=$P($G(^OR(100,+ORID,0)),U,12) 114 I ADG=RXDG,(ADLG=UDDLG),(APKG=IPPKG),(APTCLS="I") S ORY=1 115 Q 116 ; 117 UPDTDG(ORY,ORID) ;Update Inpt order for outpatient DG to Inpt DG 118 Q:'$D(^OR(100,+ORID,0)) 119 N UDDG 120 S UDDG=$O(^ORD(100.98,"B","UD RX",0)) 121 S $P(^OR(100,+ORID,0),U,11)=UDDG 122 Q 123 ISUDIV(ORY,ORIFN) ;True: OI of the order is for both UD and IV 124 N OI 125 S (OI,ORY)=0 126 S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1 127 I $O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORY=1 128 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDVAL.m
r613 r623 1 ORWDVAL ; SLC/KCM - Validate procedures 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242 3 ; 4 VALSCHED(ERR,SCHED) ; Validate a schedule 5 ; Set up 'interval^repeat count', if no interval assume QD 6 S ERR=0 7 S INTERVAL=$P(SCHED," ",1),REPEAT=$P(SCHED," ",2) 8 ;I '$O(^PS(51.1,"APLR",INTERVAL,0)) S ERR=1 Q 9 K ^TMP($J,"ORLIST") 10 D ZERO^PSS51P1(,INTERVAL,"LR",,"ORLIST") 11 I '$D(^TMP($J,"ORLIST","B",INTERVAL)) K ^TMP($J,"ORLIST") S ERR=1 Q 12 K ^TMP($J,"ORLIST") 13 I '(X?1"X"1.N) S ERR=1 Q 14 Q 15 STOPDT(ADATE,SCHED) ; Return stop date given a schedule 16 ; Look at max days continuous orders 17 ; set numdays to lesser of Xnn and LR MAX... 18 ; calculate stop date from collection time 19 Q 20 EXPSCHED(LST,SCHED,START,STOP,MAX) ; procedure 21 ; Expand schedule into start/stop times 22 N IEN,TYP,INTERVAL,REPEAT 23 D VALSCHED I ERR S LST="" 24 S INTERVAL=$P(SCHED," ",1),REPEAT=$E($P(SCHED," ",2),2,999) 25 K ^TMP($J,"ORWDVAL") D AP^PSS51P1("LR",INTERVAL,,,"ORWDVAL") 26 S IEN=$O(^TMP($J,"ORWDVAL","APLR",INTERVAL,0)) 27 S TYP=$P($G(^TMP($J,"ORWDVAL",IEN,5)),U) 28 S FREQ=$G(^TMP($J,"ORWDVAL",IEN,2)) 29 I TYP="C" D ; add interval until repeat count or stop time reached 30 . ; 31 I TYP="D" D ; from start time look for matching day of week & add 32 . ; 33 I TYP="O" D ; quit with just the start time 34 . ; 35 ; range, shift, dow-range ??? 36 K ^TMP($J,"ORWDVAL") 37 Q 38 DATE ; Validate a date/time (allow visits) 39 Q 1 ORWDVAL ; SLC/KCM - Validate procedures 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 3 ; 4 VALSCHED(ERR,SCHED) ; Validate a schedule 5 ; Set up 'interval^repeat count', if no interval assume QD 6 S ERR=0 7 S INTERVAL=$P(SCHED," ",1),REPEAT=$P(SCHED," ",2) 8 I '$O(^PS(51.1,"APLR",INTERVAL,0)) S ERR=1 Q 9 I '(X?1"X"1.N) S ERR=1 Q 10 Q 11 STOPDT(ADATE,SCHED) ; Return stop date given a schedule 12 ; Look at max days continuous orders 13 ; set numdays to lesser of Xnn and LR MAX... 14 ; calculate stop date from collection time 15 Q 16 EXPSCHED(LST,SCHED,START,STOP,MAX) ; procedure 17 ; Expand schedule into start/stop times 18 N IEN,TYP,INTERVAL,REPEAT 19 D VALSCHED I ERR S LST="" 20 S INTERVAL=$P(SCHED," ",1),REPEAT=$E($P(SCHED," ",2),2,999) 21 S IEN=$O(^PS(51.1,"APLR",INTERVAL,0)) 22 S TYP=$P(^PS(51.1,IEN,0),U,5),FREQ=$P(^(0),U,3) 23 I TYP="C" D ; add interval until repeat count or stop time reached 24 . ; 25 I TYP="D" D ; from start time look for matching day of week & add 26 . ; 27 I TYP="O" D ; quit with just the start time 28 . ; 29 ; range, shift, dow-range ??? 30 Q 31 DATE ; Validate a date/time (allow visits) 32 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX.m
r613 r623 1 ORWDX ; SLC/KCM/REV/JLI - Order dialog utilities ;11/28/2006 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,132,141,164,178,187,190,195,215,246,243**;Dec 17, 1997;Build 242 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ORDITM(Y,FROM,DIR,XREF) ; Subset of orderable items 6 ; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name 7 N I,IEN,CNT,X,DTXT,CURTM,DEFROUTE 8 S DEFROUTE="" 9 S I=0,CNT=44,CURTM=$$NOW^XLFDT 10 F Q:I'<CNT S FROM=$O(^ORD(101.43,XREF,FROM),DIR) Q:FROM="" D 11 . S IEN="" F S IEN=$O(^ORD(101.43,XREF,FROM,IEN),DIR) Q:'IEN D 12 . . S X=^ORD(101.43,XREF,FROM,IEN) 13 . . I +$P(X,U,3),$P(X,U,3)<CURTM Q 14 . . Q:$P(X,U,5) S I=I+1 15 . . I XREF="S.IVA RX"!(XREF="S.IVB RX") S DEFROUTE=$P($G(^ORD(101.43,IEN,"PS")),U,8) 16 . . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2)_U_DEFROUTE 17 . . E S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4)_U_DEFROUTE 18 Q 19 ODITMBC(Y,XREF,ODLST) ; 20 N CNT,NM,XRF 21 S CNT=0,NM=0,XRF=XREF 22 F S CNT=$O(ODLST(CNT)) Q:'CNT D FNDINFO(.Y,ODLST(CNT)) 23 Q 24 FNDINFO(Y,ODIEN) ; 25 D FNDINFO^ORWDX1(.Y,.ODIEN) 26 Q 27 DLGDEF(LST,DLG) ; Format mapping for a dlg 28 D DLGDEF^ORWDX1(.LST,.DLG) 29 Q 30 DLGQUIK(LST,QO) ;(NOT USED) 31 D LOADRSP(.LST,QO) 32 Q 33 LOADRSP(LST,RSPID,TRANS) ; Load responses from 101.41 or 100 34 ; RSPID: C123456;1-3243 = cached copy, 134-3234 = cached quick 35 ; X123456;1 = change order, 134 = quick dialog 36 N I,J,DLG,INST,ID,VAL,ILST,ROOT,ORLOC S ROOT="" 37 I RSPID["-" S ROOT="^TMP(""ORWDXMQ"",$J,"""_RSPID_""")" G XROOT^ORWDX2 38 I $E(RSPID)="X" S ROOT="^OR(100,"_+$P(RSPID,"X",2)_",4.5)" G XROOT^ORWDX2 39 I +RSPID=RSPID S ROOT="^ORD(101.41,"_+RSPID_",6)" G XROOT^ORWDX2 40 Q:ROOT="" 41 G XROOT^ORWDX2 42 SAVE(REC,ORVP,ORNP,ORL,DLG,ORDG,ORIT,ORIFN,ORDIALOG,ORDEA,ORAPPT,ORSRC,OREVTDF) ; 43 ; ORVP=DFN, ORNP=Provider, ORL=Location, DLG=Order Dialog, 44 ; ORDG=Display Group, ORIT=Quick Order Dialog, ORAPPT=Appointment 45 N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORLEAD,ORTRAIL,ORPKG,ORWP94,ORCATFN,OREVTYPE,ONPASS 46 N XCNT,XCOMM,XDONE,XX ;SBR 47 S (XCOMM,XCNT)="" ;SBR 48 I $G(ORIFN)'="" D ;SBR problem only occurs on change or renew orders 49 . S XCNT=$O(^OR(100,+ORIFN,4.5,"ID","COMMENT",XCNT)) ;SBR 50 . I XCNT'="" S XCOMM=$P($G(^OR(100,+ORIFN,4.5,XCNT,0)),"^",2) ;SBR 51 . I XCOMM'="" S XDONE=0,XX="" F S XX=$O(ORDIALOG("WP",XCOMM,1,XX)) Q:XX="" D ;SBR 52 . . I ORDIALOG("WP",XCOMM,1,XX,0)'="" S XDONE=1 Q ;SBR 53 . I XCOMM'="",'$G(XDONE),$D(ORDIALOG("WP",XCOMM)) K ORDIALOG("WP",XCOMM) ;SBR 54 S ORCATFN="" I $L($P(DLG,U,2)) S ORCATFN=$P(DLG,U,2),DLG=$P(DLG,U,1) 55 ;Remove treating facility if inpatient and IMO order 26.42 56 I $G(^DPT(ORVP,.1))'="",$P($G(^ORD(100.98,ORDG,0)),U)="CLINIC ORDERS" K ORDIALOG("ORTS") 57 I $G(ORDIALOG("ORTS")) S ORTS=ORDIALOG("ORTS") K ORDIALOG("ORTS") 58 I $G(ORDIALOG("ORSLOG")) S ORLOG=ORDIALOG("ORSLOG") K ORDIALOG("ORSLOG") 59 I $D(ORDIALOG("OREVENT")) S OREVENT=ORDIALOG("OREVENT") K ORDIALOG("OREVENT") 60 ;===================================================== 61 ; Changed for v26.27 (RV) 62 S ORCAT=$$INPT^ORCD,ORCAT=$S(ORCAT=1:"I",1:"O") 63 ;I $L($G(OREVENT)) D 64 ;. S ONPASS=0 65 ;. S OREVTYPE=$$TYPE^OREVNTX(OREVENT) 66 ;. I OREVTYPE="T" D ISPASS^OREVNTX1(.ONPASS,+OREVENT,"T") 67 ;. S ORCAT=$S(OREVTYPE="A":"I",OREVTYPE="T":"I",ONPASS=1:"O",1:"O") 68 ;E S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O") 69 ;===================================================== 70 I DLG="PS MEDS" S ORWP94=1 D 71 . I ORIT=$O(^ORD(101.41,"AB","PSO SUPPLY",0)) S DLG="PSO SUPPLY" 72 . I ORIT=$O(^ORD(101.41,"AB","PSO OERR",0)) S DLG="PSO OERR" 73 . I ORIT=$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) S DLG="PSJ OR PAT OE" 74 I DLG="PSO OERR" S ORCAT="O" I $G(OREVENT("EFFECTIVE")) D 75 . S ORDIALOG($O(^ORD(101.41,"B","OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:""),0)),1)=OREVENT("EFFECTIVE") 76 I DLG="PSJ OR PAT OE" S ORCAT="I" 77 S:DLG="FHW1" ORCAT="I" S:DLG?1"FHW "2.7U1" MEAL" ORCAT="O" 78 S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2) 79 I ORDG=$O(^ORD(100.98,"B","LAB",0)) D ;use section 80 . N OI,SUB S OI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)) 81 . S SUB=$P($G(^ORD(101.43,OI,"LR")),U,6),ORDG=$$DGRP^ORMLR(SUB) 82 K:'ORDG ORDG K:'ORIT ORIT ; Dgrp & Quick must be non-zero 83 M ORCHECK=ORDIALOG("ORCHECK") K ORDIALOG("ORCHECK") 84 S ORDIALOG=$O(^ORD(101.41,"AB",DLG,0)) 85 I 'ORDIALOG S ORDIALOG=$O(^ORD(101.41,"B",DLG,0)) 86 I $D(ORDIALOG("ORLEAD")) S ORLEAD=ORDIALOG("ORLEAD") 87 I $D(ORDIALOG("ORTRAIL")) S ORTRAIL=ORDIALOG("ORTRAIL") 88 D GETDLG1^ORCD(ORDIALOG) 89 I $L(ORCATFN) S ORCAT=ORCATFN 90 I $G(ORWP94) D 91 . N SIGPRMT S SIGPRMT=$O(^ORD(101.41,"B","OR GTX SIG",0)) 92 . N INSPRMT S INSPRMT=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0)) 93 . I $L($G(ORDIALOG(SIGPRMT,1))) S ORDIALOG(INSPRMT,"FORMAT")="@" 94 . I ORCAT="O" S ORPKG=$O(^DIC(9.4,"C","PSO",0)) 95 . I ORCAT="I" S ORPKG=$O(^DIC(9.4,"C","PSJ",0)) 96 S ORSRC=$G(ORSRC) 97 D DELPI^ORWDX1 ;delete empty PI 98 I $G(ORIFN)="" D ; new order 99 . D EN^ORCSAVE 100 . S REC="" I ORIFN D GETBYIFN^ORWORR(.REC,ORIFN) 101 . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^TMP("ORECALL",$J,ORDIALOG)=ORDIALOG 102 E D 103 . N OR0 104 . S OR0=$G(^OR(100,+ORIFN,0)),ORSTS=$P($G(^(3)),U,3),ORDG=$P(OR0,U,11) 105 . I $L($P(OR0,U,17)),ORSTS=10 S OREVENT=$P(OR0,U,17),OREVENT("TS")=$P(OR0,U,13) 106 . D XX^ORCSAVE ; edit order 107 . S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN) 108 Q 109 SENDED(ORWLST,ORIENS,TS,LOC) ; Release EDOs to svc 110 N OK,ORVP,ORWERR,ORSIGST,ORDA,ORNATURE,ORIX,X,PTEVT,ORIFN,J,EVENT,LOCK 111 S ORWERR="",ORIX=0,LOC=LOC_";SC(" 112 F S ORIX=$O(ORIENS(ORIX)) Q:'ORIX D 113 . S ORIFN=ORIENS(ORIX) 114 . S PTEVT=$P(^OR(100,+ORIFN,0),U,17) I PTEVT S LOCK=$$LCKEVT^ORX2(PTEVT) S:LOCK EVENT(PTEVT)="" I 'LOCK S ORWERR="1^delayed event is locked - another user is processing orders for this event" ;195 115 . S ORDA=$P(ORIFN,";",2) S:'ORDA ORDA=1 116 . S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2) 117 . I $D(^OR(100,+ORIFN,8,ORDA,0)) D 118 .. S ORSIGST=$P($G(^(0)),U,4) 119 .. S ORNATURE=$P($G(^(0)),U,12) 120 . S:$G(LOC) $P(^OR(100,+ORIFN,0),U,10)=LOC ;set location 121 . S:$G(TS) $P(^OR(100,+ORIFN,0),U,13)=TS ;set specialty 122 . S OK=$$LOCK1^ORX2(ORIFN) I 'OK S ORWERR="1^"_$P(OK,U,2) 123 . I OK,$G(LOCK) D EN2^ORCSEND(ORIENS(ORIX),ORSIGST,ORNATURE,.ORWERR),UNLK1^ORX2(ORIENS(ORIX)) ;add ,LOCK to if statement for 195 124 . S ORWLST(ORIX)=ORIENS(ORIX) 125 . I $L(ORWERR) S ORWLST(ORIX)=ORWLST(ORIX)_"^E^"_ORWERR Q 126 . E D 127 .. S PTEVT=$P($G(^OR(100,+ORIENS(ORIX),0)),U,17) 128 .. D:$$TYPE^OREVNTX(PTEVT)="M" SAVE^ORMEVNT1(ORIENS(ORIX),PTEVT,2) 129 . S X="RS" 130 . S $P(ORWLST(ORIX),U,2)=X 131 S J=0 F S J=$O(EVENT(J)) Q:'+J D UNLEVT^ORX2(J) ;195 132 Q 133 SEND(ORWLST,DFN,ORNP,ORL,ES,ORWREC) ; Sign 134 ; DFN=Patient, ORNP=Provider, ORL=Location, ES=Encrypted ES code 135 ; ORWREC(n)=ORIFN;Action^Signature Sts^Release Sts^Nature of Order 136 SEND1 N ORVP,ORWI,ORWERR,ORWREL,ORWSIG,ORWNATR,ORDERID,ORBEF,ORLR,ORLAB,X,I 137 S ORVP=DFN_";DPT(",ORL=ORL_";SC(",ORL(2)=ORL,ORWLST=0 138 F I="LR","VBEC" S X=+$O(^DIC(9.4,"C",I,0)) S:X ORLR(X)=1 139 S ORWI=0 F S ORWI=$O(ORWREC(ORWI)) Q:'ORWI D 140 . S X=ORWREC(ORWI),ORWERR="" 141 . S ORDERID=$P(X,U),ORWSIG=$P(X,U,2),ORWREL=$P(X,U,3),ORWNATR=$P(X,U,4) 142 . S ORBEF=0 143 . I '$D(^OR(100,+ORDERID,0)) Q 144 . I $D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) S ORBEF=$P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),U,15) 145 . S:$D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) ORWNATR=$S($P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),"^",4)=3:"",1:ORWNATR) 146 . S ORWERR=$$CHKACT^ORWDXR(ORDERID,ORWSIG,ORWREL,ORWNATR) 147 . I $L(ORWERR) S ORWERR="1^"_ORWERR 148 . I '$L(ORWERR) D 149 .. I $G(ORLR(+$P(^OR(100,+ORDERID,0),U,14))),'$G(ORLAB) D ; lab batch start 150 ... I $L($T(BHS^ORMBLD)) D BHS^ORMBLD(ORVP) S ORLAB=1 151 .. N OK S OK=$$LOCK1^ORX2(ORDERID) I 'OK S ORWERR="1^"_$P(OK,U,2) 152 .. I OK D EN^ORCSEND(ORDERID,"",ORWSIG,ORWREL,ORWNATR,"",.ORWERR),UNLK1^ORX2(ORDERID) 153 . S ORWLST(ORWI)=ORDERID,X="" 154 . I $L(ORWERR) S ORWLST(ORWI)=ORWLST(ORWI)_"^E^"_ORWERR Q 155 . I ORWREL,((ORBEF=10)!(ORBEF=11)),($P(^OR(100,+ORDERID,3),U,3)'=10) S X="R" 156 . I ORWSIG'=2 S X=X_"S" 157 . S $P(ORWLST(ORWI),U,2)=X 158 I $G(ORLAB) D BTS^ORMBLD(ORVP) 159 Q 160 DLGID(VAL,ORIFN) ; return dlg IEN for order 161 S VAL=$P(^OR(100,+ORIFN,0),U,5) 162 S VAL=$S($P(VAL,";",2)="ORD(101.41,":+VAL,1:0) 163 Q 164 FORMID(VAL,ORIFN) ; Base dlg FormID for an order 165 N DLG 166 S VAL=0,DLG=$P(^OR(100,+ORIFN,0),U,5) 167 Q:$P(DLG,";",2)'="ORD(101.41," 168 D FORMID^ORWDXM(.VAL,+DLG) 169 Q 170 AGAIN(VAL,DLG) ; return true to keep dlg for another order 171 S VAL=''$P($G(^ORD(101.41,DLG,0)),U,9) 172 Q 173 DGRP(VAL,DLG) ; Display grp pointer for a dlg 174 S DLG=$S($E(DLG)="`":+$P(DLG,"`",2),1:$O(^ORD(101.41,"AB",DLG,0))) ;kcm 175 S VAL=$P($G(^ORD(101.41,DLG,0)),U,5) 176 Q 177 DGNM(VAL,NM) ; Display grp pointer for name 178 S VAL=$O(^ORD(100.98,"B",NM,0)) 179 Q 180 WRLST(LST,LOC) ; List of dlgs for writing orders 181 G WRLST1^ORWDX1 182 MSG(LST,IEN) ; Msg text for orderable item 183 N I 184 S I=0 F S I=$O(^ORD(101.43,IEN,8,I)) Q:I'>0 S LST(I)=^(I,0) 185 Q 186 DISMSG(VAL,IEN) ; Disabled mge for ordering dlg 187 S VAL=$P($G(^ORD(101.41,+IEN,0)),U,3) 188 Q 189 LOCK(OK,DFN) ; Attempt to lock pt for ordering 190 S OK=$$LOCK^ORX2(DFN) 191 Q 192 UNLOCK(OK,DFN) ; Unlock pt for ordering 193 D UNLOCK^ORX2(DFN) S OK=1 194 Q 195 LOCKORD(OK,ORIFN) ; Attempt to lock order 196 S OK=$$LOCK1^ORX2(ORIFN) 197 Q 198 UNLKORD(OK,ORIFN) ; Unlock order 199 D UNLK1^ORX2(ORIFN) S OK=1 200 Q 1 ORWDX ; SLC/KCM/REV/JLI - Order dailog utilities ;4/21/07 19:18 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,132,141,164,178,187,190,195,215,269**;Dec 17, 1997;Build 28 3 ; Modified from FOIA VISTA, 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License as published by 8 ; the Free Software Foundation; either version 2 of the License, or 9 ; (at your option) any later version. 10 ; 11 NXT() ; -- Gets index in array 12 S ILST=ILST+1 13 Q ILST 14 ; 15 ORDITM(Y,FROM,DIR,XREF) ; Subset of orderable items 16 ; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name 17 N I,IEN,CNT,X,DTXT,CURTM 18 S I=0,CNT=44,CURTM=$$NOW^XLFDT 19 F Q:I'<CNT S FROM=$O(^ORD(101.43,XREF,FROM),DIR) Q:FROM="" D 20 . S IEN="" F S IEN=$O(^ORD(101.43,XREF,FROM,IEN),DIR) Q:'IEN D 21 . . S X=^ORD(101.43,XREF,FROM,IEN) 22 . . I +$P(X,U,3),$P(X,U,3)<CURTM Q 23 . . Q:$P(X,U,5) S I=I+1 24 . . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2) 25 . . E S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4) 26 Q 27 ODITMBC(Y,XREF,ODLST) ; 28 N CNT,NM,XRF 29 S CNT=0,NM=0,XRF=XREF 30 F S CNT=$O(ODLST(CNT)) Q:'CNT D FNDINFO(.Y,ODLST(CNT)) 31 Q 32 FNDINFO(Y,ODIEN) ; 33 D FNDINFO^ORWDX1(.Y,.ODIEN) 34 Q 35 DLGDEF(LST,DLG) ; Format mapping for a dlg 36 D DLGDEF^ORWDX1(.LST,.DLG) 37 Q 38 DLGQUIK(LST,QO) ;(NOT USED) 39 D LOADRSP(.LST,QO) 40 Q 41 LOADRSP(LST,RSPID) ; Load responses from 101.41 or 100 42 ; RSPID: C123456;1-3243 = cached copy, 134-3234 = cached quick 43 ; X123456;1 = change order, 134 = quick dialog 44 N I,J,DLG,INST,ID,VAL,ILST,ROOT S ROOT="" 45 I RSPID["-" S ROOT="^TMP(""ORWDXMQ"",$J,"""_RSPID_""")" G XROOT 46 I $E(RSPID)="X" S ROOT="^OR(100,"_+$P(RSPID,"X",2)_",4.5)" G XROOT 47 I +RSPID=RSPID S ROOT="^ORD(101.41,"_+RSPID_",6)" G XROOT 48 Q:ROOT="" 49 XROOT S (ILST,I)=0 F S I=$O(@ROOT@(I)) Q:I'>0 D 50 . S DLG=$P(@ROOT@(I,0),U,2),INST=$P(^(0),U,3) 51 . S ID=$P($G(^ORD(101.41,DLG,1)),U,3) 52 . I '$L(ID) S ID="ID"_DLG 53 . S VAL=$G(@ROOT@(I,1)) 54 . I $P($G(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE" S ID="ADDITIVE" 55 . I $E(RSPID)="C",(ID="START"),VAL Q ; skip literal start time on copy 56 . S LST($$NXT)="~"_DLG_U_INST_U_ID 57 . I $L(VAL) D 58 .. S LST($$NXT)="i"_VAL,LST($$NXT)="e"_$$EXTVAL(VAL,DLG) 59 . I $D(@ROOT@(I,2))>1 D 60 .. S J=0 F S J=$O(@ROOT@(I,2,J)) Q:J'>0 D 61 ... S LST($$NXT)="t"_$G(@ROOT@(I,2,J,0)) 62 I $E(ROOT,1,4)="^TMP" K ^TMP("ORWDXMQ",$J) 63 Q 64 SAVE(REC,ORVP,ORNP,ORL,DLG,ORDG,ORIT,ORIFN,ORDIALOG,ORDEA,ORAPPT,ORSRC,OREVTDF) ; 65 ; ORVP=DFN, ORNP=Provider, ORL=Location, DLG=Order Dialog, 66 ; ORDG=Display Group, ORIT=Quick Order Dialog, ORAPPT=Appointment 67 N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORLEAD,ORTRAIL,ORPKG,ORWP94,ORCATFN,OREVTYPE,ONPASS 68 ; JD FIX FOR WASHINGTON DC 69 ;I '$L(ORSRC)!($G(ORSRC)=" ")!($G(ORSRC)=0) S ORSRC=$P(ORVP,U,2) 70 ;S ORVP=$P(ORVP,U) 71 ; END FIX JD 72 S ORCATFN="" 73 I $L($P(DLG,U,2)) S ORCATFN=$P(DLG,U,2),DLG=$P(DLG,U,1) 74 ;Remove treating facility if inpatient and IMO order 26.42 75 I $G(^DPT(ORVP,.1))'="",$P($G(^ORD(100.98,ORDG,0)),U)="CLINIC ORDERS" K ORDIALOG("ORTS") 76 I $G(ORDIALOG("ORTS")) S ORTS=ORDIALOG("ORTS") K ORDIALOG("ORTS") 77 I $G(ORDIALOG("ORSLOG")) S ORLOG=ORDIALOG("ORSLOG") K ORDIALOG("ORSLOG") 78 I $D(ORDIALOG("OREVENT")) S OREVENT=ORDIALOG("OREVENT") K ORDIALOG("OREVENT") 79 ;======= 80 ; Changed for v26.27 (RV) 81 S ORCAT=$$INPT^ORCD,ORCAT=$S(ORCAT=1:"I",1:"O") 82 ;I $L($G(OREVENT)) D 83 ;. S ONPASS=0 84 ;. S OREVTYPE=$$TYPE^OREVNTX(OREVENT) 85 ;. I OREVTYPE="T" D ISPASS^OREVNTX1(.ONPASS,+OREVENT,"T") 86 ;. S ORCAT=$S(OREVTYPE="A":"I",OREVTYPE="T":"I",ONPASS=1:"O",1:"O") 87 ;E S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O") 88 ;======= 89 I DLG="PS MEDS" S ORWP94=1 D 90 . I ORIT=$O(^ORD(101.41,"AB","PSO SUPPLY",0)) S DLG="PSO SUPPLY" 91 . I ORIT=$O(^ORD(101.41,"AB","PSO OERR",0)) S DLG="PSO OERR" 92 . I ORIT=$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) S DLG="PSJ OR PAT OE" 93 I DLG="PSO OERR" S ORCAT="O" I $G(OREVENT("EFFECTIVE")) D 94 . S ORDIALOG($O(^ORD(101.41,"B","OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:""),0)),1)=OREVENT("EFFECTIVE") 95 I DLG="PSJ OR PAT OE" S ORCAT="I" 96 S:DLG="FHW1" ORCAT="I" S:DLG?1"FHW "2.7U1" MEAL" ORCAT="O" 97 S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2) 98 K:'ORDG ORDG K:'ORIT ORIT ; Dgrp & Quick must be non-zero 99 M ORCHECK=ORDIALOG("ORCHECK") K ORDIALOG("ORCHECK") 100 S ORDIALOG=$O(^ORD(101.41,"AB",DLG,0)) 101 I 'ORDIALOG S ORDIALOG=$O(^ORD(101.41,"B",DLG,0)) 102 I $D(ORDIALOG("ORLEAD")) S ORLEAD=ORDIALOG("ORLEAD") 103 I $D(ORDIALOG("ORTRAIL")) S ORTRAIL=ORDIALOG("ORTRAIL") 104 D GETDLG1^ORCD(ORDIALOG) 105 I $L(ORCATFN) S ORCAT=ORCATFN 106 I $G(ORWP94) D 107 . N SIGPRMT S SIGPRMT=$O(^ORD(101.41,"B","OR GTX SIG",0)) 108 . N INSPRMT S INSPRMT=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0)) 109 . I $L($G(ORDIALOG(SIGPRMT,1))) S ORDIALOG(INSPRMT,"FORMAT")="@" 110 . I ORCAT="O" S ORPKG=$O(^DIC(9.4,"C","PSO",0)) 111 . I ORCAT="I" S ORPKG=$O(^DIC(9.4,"C","PSJ",0)) 112 S ORSRC=$G(ORSRC) 113 D DELPI^ORWDX1 ;delete empty PI 114 I $G(ORIFN)="" D ; new order 115 . D EN^ORCSAVE 116 . S REC="" I ORIFN D GETBYIFN^ORWORR(.REC,ORIFN) 117 . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^TMP("ORECALL",$J,ORDIALOG)=ORDIALOG 118 E D 119 . N OR0 120 . S OR0=$G(^OR(100,+ORIFN,0)),ORSTS=$P($G(^(3)),U,3),ORDG=$P(OR0,U,11) 121 . I $L($P(OR0,U,17)),ORSTS=10 S OREVENT=$P(OR0,U,17),OREVENT("TS")=$P(OR0,U,13) 122 . D XX^ORCSAVE ; edit order 123 . S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN) 124 Q 125 SENDED(ORWLST,ORIENS,TS,LOC) ; Release EDOs to svc 126 N OK,ORVP,ORWERR,ORSIGST,ORDA,ORNATURE,ORIX,X,PTEVT,ORIFN,J,EVENT,LOCK 127 S ORWERR="",ORIX=0,LOC=LOC_";SC(" 128 F S ORIX=$O(ORIENS(ORIX)) Q:'ORIX D 129 . S ORIFN=ORIENS(ORIX) 130 . S PTEVT=$P(^OR(100,+ORIFN,0),U,17) I PTEVT S LOCK=$$LCKEVT^ORX2(PTEVT) S:LOCK EVENT(PTEVT)="" I 'LOCK S ORWERR="1^delayed event is locked - another user is processing orders for this event" ;195 131 . S ORDA=$P(ORIFN,";",2) S:'ORDA ORDA=1 132 . S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2) 133 . I $D(^OR(100,+ORIFN,8,ORDA,0)) D 134 .. S ORSIGST=$P($G(^(0)),U,4) 135 .. S ORNATURE=$P($G(^(0)),U,12) 136 . S:$G(LOC) $P(^OR(100,+ORIFN,0),U,10)=LOC ;set location 137 . S:$G(TS) $P(^OR(100,+ORIFN,0),U,13)=TS ;set specialty 138 . S OK=$$LOCK1^ORX2(ORIFN) I 'OK S ORWERR="1^"_$P(OK,U,2) 139 . I OK,$G(LOCK) D EN2^ORCSEND(ORIENS(ORIX),ORSIGST,ORNATURE,.ORWERR),UNLK1^ORX2(ORIENS(ORIX)) ;add ,LOCK to if statement for 195 140 . S ORWLST(ORIX)=ORIENS(ORIX) 141 . I $L(ORWERR) S ORWLST(ORIX)=ORWLST(ORIX)_"^E^"_ORWERR Q 142 . E D 143 .. S PTEVT=$P($G(^OR(100,+ORIENS(ORIX),0)),U,17) 144 .. D:$$TYPE^OREVNTX(PTEVT)="M" SAVE^ORMEVNT1(ORIENS(ORIX),PTEVT,2) 145 . S X="RS" 146 . S $P(ORWLST(ORIX),U,2)=X 147 S J=0 F S J=$O(EVENT(J)) Q:'+J D UNLEVT^ORX2(J) ;195 148 Q 149 SEND(ORWLST,DFN,ORNP,ORL,ES,ORWREC) ; Sign 150 ; DFN=Patient, ORNP=Provider, ORL=Location, ES=Encrypted ES code 151 ; ORWREC(n)=ORIFN;Action^Signature Sts^Release Sts^Nature of Order 152 SEND1 N ORVP,ORWI,ORWERR,ORWREL,ORWSIG,ORWNATR,ORDERID,ORBEF,ORLR,ORLAB,X,I 153 S ORVP=DFN_";DPT(",ORL=ORL_";SC(",ORL(2)=ORL,ORWLST=0 154 F I="LR","VBEC" S X=+$O(^DIC(9.4,"C",I,0)) S:X ORLR(X)=1 155 S ORWI=0 F S ORWI=$O(ORWREC(ORWI)) Q:'ORWI D 156 . S X=ORWREC(ORWI),ORWERR="" 157 . S ORDERID=$P(X,U),ORWSIG=$P(X,U,2),ORWREL=$P(X,U,3),ORWNATR=$P(X,U,4) 158 . S ORBEF=0 159 . I '$D(^OR(100,+ORDERID,0)) Q 160 . I $D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) S ORBEF=$P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),U,15) 161 . S:$D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) ORWNATR=$S($P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),"^",4)=3:"",1:ORWNATR) 162 . S ORWERR=$$CHKACT^ORWDXR(ORDERID,ORWSIG,ORWREL,ORWNATR) 163 . I $L(ORWERR) S ORWERR="1^"_ORWERR 164 . I '$L(ORWERR) D 165 .. I $G(ORLR(+$P(^OR(100,+ORDERID,0),U,14))),'$G(ORLAB) D ; lab batch start 166 ... I $L($T(BHS^ORMBLD)) D BHS^ORMBLD(ORVP) S ORLAB=1 167 .. N OK S OK=$$LOCK1^ORX2(ORDERID) I 'OK S ORWERR="1^"_$P(OK,U,2) 168 .. I OK D EN^ORCSEND(ORDERID,"",ORWSIG,ORWREL,ORWNATR,"",.ORWERR),UNLK1^ORX2(ORDERID) 169 .. S PSOSITE=$G(^SC(+ORL,"AFRXSITE")) ;+ORL is hospital location from ORWDX 170 .. Q:PSOSITE="" ;Quits with no autofinish if File#44 does not point to File#59 171 .. I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",1)="Y",$$GET1^DIQ(100,+ORDERID_",",12)="OUTPATIENT PHARMACY" D EN^PSOAFIN ;vfam 172 . S ORWLST(ORWI)=ORDERID,X="" 173 . I $L(ORWERR) S ORWLST(ORWI)=ORWLST(ORWI)_"^E^"_ORWERR Q 174 . I ORWREL,((ORBEF=10)!(ORBEF=11)),($P(^OR(100,+ORDERID,3),U,3)'=10) S X="R" 175 . I ORWSIG'=2 S X=X_"S" 176 . S $P(ORWLST(ORWI),U,2)=X 177 I $G(ORLAB) D BTS^ORMBLD(ORVP) 178 Q 179 EXTVAL(IVAL,DLG) ; External value given a dlg ptr 180 N ORDIALOG 181 S ORDIALOG(DLG,0)=$P($G(^ORD(101.41,DLG,1)),U,1,2) 182 S ORDIALOG(DLG,1)=IVAL 183 I $E(ORDIALOG(DLG,0))="R",(+IVAL'=IVAL) Q IVAL ; free text date/time 184 Q $$EXT^ORCD(DLG,1) ; all others 185 DLGID(VAL,ORIFN) ; return dlg IEN for order 186 S VAL=$P(^OR(100,+ORIFN,0),U,5) 187 S VAL=$S($P(VAL,";",2)="ORD(101.41,":+VAL,1:0) 188 Q 189 FORMID(VAL,ORIFN) ; Base dlg FormID for an order 190 N DLG 191 S VAL=0,DLG=$P(^OR(100,+ORIFN,0),U,5) 192 Q:$P(DLG,";",2)'="ORD(101.41," 193 D FORMID^ORWDXM(.VAL,+DLG) 194 Q 195 AGAIN(VAL,DLG) ; return true to keep dlg for another order 196 S VAL=''$P($G(^ORD(101.41,DLG,0)),U,9) 197 Q 198 DGRP(VAL,DLG) ; Display grp pointer for a dlg 199 S DLG=$S($E(DLG)="`":+$P(DLG,"`",2),1:$O(^ORD(101.41,"AB",DLG,0))) ;kcm 200 S VAL=$P($G(^ORD(101.41,DLG,0)),U,5) 201 Q 202 DGNM(VAL,NM) ; Display grp pointer for name 203 S VAL=$O(^ORD(100.98,"B",NM,0)) 204 Q 205 WRLST(LST,LOC) ; List of dlgs for writing orders 206 G WRLST1^ORWDX1 207 MSG(LST,IEN) ; Msg text for orderable item 208 N I 209 S I=0 F S I=$O(^ORD(101.43,IEN,8,I)) Q:I'>0 S LST(I)=^(I,0) 210 Q 211 DISMSG(VAL,IEN) ; Disabled mge for ordering dlg 212 S VAL=$P($G(^ORD(101.41,+IEN,0)),U,3) 213 Q 214 LOCK(OK,DFN) ; Attempt to lock pt for ordering 215 S OK=$$LOCK^ORX2(DFN) 216 Q 217 UNLOCK(OK,DFN) ; Unlock pt for ordering 218 D UNLOCK^ORX2(DFN) S OK=1 219 Q 220 LOCKORD(OK,ORIFN) ; Attempt to lock order 221 S OK=$$LOCK1^ORX2(ORIFN) 222 Q 223 UNLKORD(OK,ORIFN) ; Unlock order 224 D UNLK1^ORX2(ORIFN) S OK=1 225 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX1.m
r613 r623 1 ORWDX1 ; SLC/KCM/REV - Utilities for Order Dialogs ;06/06/2007 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,187,195,215,243**;Dec 17, 1997;Build 242 3 ; 4 WRLST(LST,LOC) ; Return list of dialogs for writing orders 5 ; .Y(n): DlgName^ListBox Text 6 WRLST1 N ANENT 7 S LOC=+$G(LOC)_";SC(" I 'LOC S LOC="" 8 S ANENT="ALL^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"") 9 D WRLSTB(.LST) Q:$D(LST)>1 ; check ORWDX WRITE ORDERS first 10 N ORX,X0,X5,ORERR,I,SEQ,IEN,DGRP,FID,TXT,TYP 11 D GETLST^XPAR(.ORX,ANENT,"ORWOR WRITE ORDERS LIST","Q",.ORERR) Q:ORERR 12 S I=0 F S I=$O(ORX(I)) Q:'I D 13 . S SEQ=+ORX(I),IEN=$P(ORX(I),U,2),X0=$G(^ORD(101.41,+IEN,0)),X5=$G(^(5)) 14 . S DGRP=+$P(X0,U,5),FID=+$P(X5,U,5),TXT=$P(X5,U,4),TYP=$P(X0,U,4) 15 . S:'$L(TXT) TXT=$P(X0,U,2) 16 . I $P(X0,U,4)="M" S:'FID FID=1001 17 . S LST(SEQ)=IEN_";"_FID_";"_DGRP_";"_TYP_U_TXT 18 Q 19 WRLSTB(LST) ; return menu from which Write Orders list is built 20 N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP 21 S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS LIST",1,"I") Q:'MNU 22 S SEQ=0 F S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ D 23 . S IEN=0 F S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN D 24 . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4) 25 . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5) 26 . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5) 27 . . S:'$L(TXT) TXT=$P(X,U,2) 28 . . I TYP="M" S:'FID FID=1001 29 . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT 30 Q 31 DELPI ; delete PI from ORDIALOG if PI = "" 32 ;Called from SAVE^ORWDX 33 N ORPI S ORPI=0 34 S ORPI=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",ORPI)) 35 Q:'$D(ORDIALOG(ORPI)) 36 I '$D(ORDIALOG(ORPI,1)) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) Q 37 N PINODE,PITX 38 S PITX="",PINODE=$G(ORDIALOG(ORPI,1)) 39 S PITX=$G(@PINODE@(1,0)) 40 S PITX=$TR(PITX," ","") 41 I '$L(PITX) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) Q 42 N ORSIG S ORSIG=+$O(^ORD(101.41,"B","OR GTX SIG",0)) 43 I $$STR^ORWDXR(ORSIG)[$$STR^ORWDXR(ORPI) S ORDIALOG(ORPI,"FORMAT")="@" 44 Q 45 FNDINFO(Y,ODIEN) ; 46 N ODI,CRTM,FRM,XX 47 S FRM="",CRTM=$$NOW^XLFDT 48 F S FRM=$O(^ORD(101.43,XRF,FRM)) Q:FRM="" D 49 . S ODI=0 F S ODI=$O(^ORD(101.43,XRF,FRM,ODI)) Q:'ODI D 50 .. S XX=^ORD(101.43,XRF,FRM,ODI) 51 .. I +$P(XX,U,3),$P(XX,U,3)<CRTM Q 52 .. I ODI=ODIEN D 53 ... S NM=NM+1 54 ... I 'XX S Y(NM)=ODIEN_U_$P(XX,U,2)_U_$P(XX,U,2) 55 ... E S Y(NM)=ODIEN_U_$P(XX,U,2)_$C(9)_"<"_$P(XX,U,4)_">"_U_$P(XX,U,4) 56 Q 57 DLGDEF(LST,DLG) ; Format mapping for a dlg 58 N I,IEN,ILST,X0,X2,XW S ILST=0 59 I $O(^ORD(101.41,"AB",DLG,0))>0 S DLG=$O(^ORD(101.41,"AB",DLG,0)) 60 E S DLG=$O(^ORD(101.41,"B",DLG,0)) 61 Q:'DLG 62 S I=0 F S I=$O(^ORD(101.41,DLG,10,I)) Q:I'>0 D 63 . S X0=$G(^ORD(101.41,DLG,10,I,0)),X2=$G(^(2)),IEN=+$P(X0,U,2) 64 . S ILST=ILST+1,LST(ILST)=U_IEN_U_$P(X2,U,1,7) 65 . I $P(X0,U,11) S $P(LST(ILST),U,11)=1 66 . S $P(LST(ILST),U)=$P($G(^ORD(101.41,IEN,1)),U,3) 67 . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDITIVE" S $P(LST(ILST),U)="ADDITIVE" 68 . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDL DIETS" S $P(LST(ILST),U)="ADDLDIETS" 69 . I $L($P(LST(ILST),U))=0 S $P(LST(ILST),U)="ID"_IEN 70 . I $D(^ORD(101.41,DLG,10,"DAD",IEN)) D 71 .. N SEQ,DA,CHILD S CHILD="" 72 .. S SEQ=0 F S SEQ=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ)) Q:'SEQ D 73 ... S DA=0 F S DA=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ,DA)) Q:'DA D 74 .... S CHILD=CHILD_+$P($G(^ORD(101.41,DLG,10,DA,0)),U,2)_"~" 75 .. S $P(LST(ILST),U,10)=CHILD 76 Q 77 ; 78 CHANGE(ORLST,ORCLST,DFN,ISIMO) ; 79 N CATCH,CHANGE,CNT,INP,INPDIEN,IVM,IVMDIEN,ORIEN,ORLOC,OR3,ORDG 80 N CIEN,DIAL,TDIAL,TDIEN,UDIEN,QORDDG,PACKIEN 81 S (INP,IVM,INPDIEN,IVMDIEN,UDIEN)=0 82 S (TDIAL,TDIEN)=0 83 S INP=$O(^ORD(101.41,"B","PSJ OR PAT OE","")) Q:INP'>0 84 S IVM=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE","")) Q:IVM'>0 85 S TDIAL=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDER","")) Q:TDIAL'>0 86 S INPDIEN=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS","")) Q:INPDIEN'>0 87 S IVMDIEN=$O(^ORD(100.98,"B","IV MEDICATIONS","")) Q:IVMDIEN'>0 88 S UDIEN=$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS","")) Q:UDIEN'>0 89 S TIEN=$O(^ORD(100.98,"B","NURSING","")) Q:TIEN'>0 90 S CIEN=$O(^ORD(100.98,"B","CLINIC ORDERS","")) Q:CIEN'>0 91 S CNT=0 F S CNT=$O(ORCLST(CNT)) Q:CNT'>0 D 92 .S CHANGE=0 93 .S ORIEN=$P($G(ORCLST(CNT)),U),ORIEN=$P(ORIEN,";") 94 .S ORDG=$P($G(^OR(100,ORIEN,0)),U,11) 95 .S ORLOC=$P($G(ORCLST(CNT)),U,2) 96 .S OR3=$G(^OR(100,ORIEN,3)) 97 .S DIAL=$P(OR3,U,4) 98 .;Remove Treating Speciality if the order location is the clinic 99 .I $P($G(^OR(100,ORIEN,0)),U,10)=(ORLOC_";SC("),$P($G(^SC(ORLOC,0)),U,3)="C" D Q 100 ..S $P(^OR(100,ORIEN,0),U,13)="" 101 .; 102 .;CHANGE PATIENT LOCATION AND PATIENT STATUS. 103 .S $P(^OR(100,ORIEN,0),U,10)=ORLOC_";SC(" 104 .S PACKIEN=$P(^OR(100,ORIEN,0),U,14) 105 .I $$GET1^DIQ(9.4,PACKIEN_",",1)'="PSO" S $P(^OR(100,ORIEN,0),U,12)="I" 106 .; 107 .;Check for IMO orders Nursing Dialog problem 108 .S CATCH=$P($G(^OR(100,ORIEN,0)),U,11) 109 .; 110 .S $P(^OR(100,ORIEN,0),U,11)=$S(DIAL=(IVM_";ORD(101.41,"):IVMDIEN,DIAL=(INP_";ORD(101.41,"):INPDIEN,DIAL=(TDIAL_";ORD(101.41,"):TIEN,1:CATCH) 111 .; 112 .;Check for Quick Order Dialog 113 .I CATCH=$P($G(^OR(100,ORIEN,0)),U,11),ISIMO=1 D 114 ..S QORDDG=$P($G(^ORD(101.41,+DIAL,0)),U,5) 115 ..I QORDDG=UDIEN!(QORDDG=INPDIEN) S $P(^OR(100,ORIEN,0),U,11)=INPDIEN,DIAL=(INP_";ORD(101.41,") Q 116 ..I QORDDG=IVMDIEN S $P(^OR(100,ORIEN,0),U,11)=IVMDIEN,DIAL=(IVM_";ORD(101.41,") Q 117 ..I QORDDG=TIEN S $P(^OR(100,ORIEN,0),U,11)=TIEN,DIAL=(TDIAL_";ORD(101.41,") Q 118 .; 119 .;Add treating spec if Inpatient order 120 .;I (ISIMO=1)&(DIAL=(IVM_";ORD(101.41,"))!(DIAL=(INP_";ORD(101.41,")) D 121 .;.S $P(^OR(100,ORIEN,0),U,13)=+$G(^DPT(DFN,.103)) 122 .I ISIMO=0 S $P(^OR(100,ORIEN,0),U,13)=+$G(^DPT(DFN,.103)) 123 Q 124 ; 125 STCHANGE(ORY,DFN,ORYARR) ; 126 N CNT,DONE,NODE,PHARMID,STR,STATUS 127 S ORY=0,DONE=0 128 I '$$PATCH^XPDUTL("PSS*1.0*93") Q 129 S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0!(DONE>0) D 130 . S NODE=$G(ORYARR(CNT)) 131 . S PHARMID=$P(NODE,U),STATUS=$P(NODE,U,2) 132 . I $$UP^XLFSTR(STATUS)'=$$STATUS^PSSORUTE(DFN,PHARMID) S ORY=1,DONE=1 133 Q 134 ORDMATCH(ORY,DFN,ORYARR) ; 135 N ACTION,CNT,IEN,MATCH,ORDERID,STATUS 136 S CNT=0,MATCH=1 137 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0!(MATCH=0) D 138 . S ORDERID=$P(ORYARR(CNT),U),STATUS=$P(ORYARR(CNT),U,2) 139 . I ORDERID=0,$G(ACTION)="" Q 140 . S IEN=$P(ORDERID,";"),ACTION=$P(ORDERID,";",2) 141 . I STATUS=$P($G(^OR(100,IEN,3)),U,3) Q 142 . I $P($G(^ORD(100.01,STATUS,0)),U)="DISCONTINUED/EDIT" Q 143 . ;S MATCH=0 144 . I $P($G(^OR(100,IEN,8,ACTION,0)),U,15)'=STATUS S MATCH=0 145 S ORY=MATCH 146 Q 147 ; 148 DCREN(ORY,ORYARR) ; 149 N ACT,CNT,CNT1,I,OR3,ORG,ORGID,ORID,TEXT,STATUS 150 S CNT1=0 151 S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0 D 152 .S ORGID=ORYARR(CNT) 153 .S ORID=+ORGID,ACT=$P(ORGID,";",2),TEXT="" 154 .S OR3=$G(^OR(100,ORID,3)) 155 .;Make sure current order status is pending 156 .I $P($G(^ORD(100.01,$P(OR3,U,3),0)),U)'="PENDING" Q 157 .S ORG=$P($G(OR3),U,5) Q:ORG'>0 158 .;do not add original order if it is expired 159 .S STATUS=$P(^OR(100,ORG,3),U,3) 160 .I $P($G(^ORD(100.01,STATUS,0)),U)="EXPIRED" Q 161 .;Do not add original order if Stop date has pass 162 .I $P(^OR(100,ORG,0),U,9)'>$$NOW^XLFDT Q 163 .;make sure current order is a renewed order 164 .I $P(OR3,U,11)'=2 Q 165 .S ACT=+$P($G(^OR(100,ORG,3)),U,7) 166 .S CNT1=CNT1+1,ORY(CNT1)=ORGID_U_$P(OR3,U,5)_";"_ACT_U_TEXT 167 Q 168 DCORIG(ORY,ORIEN) ; 169 S $P(^OR(100,+ORIEN,6),U,9)=1 170 Q 171 UNDCORIG(ORY,ORYARR) ; 172 N CNT 173 S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0 S $P(^OR(100,+ORYARR(CNT),6),U,9)=0 174 Q 175 PATWARD(ORY,DFN) ; 176 S ORY=0 177 I $G(^DPT(DFN,.1))'="" S ORY=1 178 Q 179 ISPEND(ORIFN) ;Is the order's status pending? 180 N ISPEND,PENDST,N3 S ISPEND=0 181 Q:'$D(^OR(100,+ORIFN,3)) 182 S PENDST=$O(^ORD(100.01,"B","PENDING",0)) 183 S N3=$G(^OR(100,+ORIFN,3)) 184 I $P(N3,U,3)=PENDST S ISPEND=1 185 Q ISPEND 1 ORWDX1 ; SLC/KCM/REV - Utilities for Order Dialogs ;10/14/05 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,187,195,215**;Dec 17, 1997 3 ; 4 WRLST(LST,LOC) ; Return list of dialogs for writing orders 5 ; .Y(n): DlgName^ListBox Text 6 WRLST1 N ANENT 7 S LOC=+$G(LOC)_";SC(" I 'LOC S LOC="" 8 S ANENT="ALL^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"") 9 D WRLSTB(.LST) Q:$D(LST)>1 ; check ORWDX WRITE ORDERS first 10 N ORX,X0,X5,ORERR,I,SEQ,IEN,DGRP,FID,TXT,TYP 11 D GETLST^XPAR(.ORX,ANENT,"ORWOR WRITE ORDERS LIST","Q",.ORERR) Q:ORERR 12 S I=0 F S I=$O(ORX(I)) Q:'I D 13 . S SEQ=+ORX(I),IEN=$P(ORX(I),U,2),X0=$G(^ORD(101.41,+IEN,0)),X5=$G(^(5)) 14 . S DGRP=+$P(X0,U,5),FID=+$P(X5,U,5),TXT=$P(X5,U,4),TYP=$P(X0,U,4) 15 . S:'$L(TXT) TXT=$P(X0,U,2) 16 . I $P(X0,U,4)="M" S:'FID FID=1001 17 . S LST(SEQ)=IEN_";"_FID_";"_DGRP_";"_TYP_U_TXT 18 Q 19 WRLSTB(LST) ; return menu from which Write Orders list is built 20 N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP 21 S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS LIST",1,"I") Q:'MNU 22 S SEQ=0 F S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ D 23 . S IEN=0 F S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN D 24 . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4) 25 . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5) 26 . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5) 27 . . S:'$L(TXT) TXT=$P(X,U,2) 28 . . I TYP="M" S:'FID FID=1001 29 . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT 30 Q 31 DELPI ; delete PI from ORDIALOG if PI = "" 32 ;Called from SAVE^ORWDX 33 N ORPI S ORPI=0 34 S ORPI=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",ORPI)) 35 Q:'$D(ORDIALOG(ORPI)) 36 I '$D(ORDIALOG(ORPI,1)) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) Q 37 N PINODE,PITX 38 S PITX="",PINODE=$G(ORDIALOG(ORPI,1)) 39 S PITX=$G(@PINODE@(1,0)) 40 S PITX=$TR(PITX," ","") 41 I '$L(PITX) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) 42 Q 43 FNDINFO(Y,ODIEN) ; 44 N ODI,CRTM,FRM,XX 45 S FRM="",CRTM=$$NOW^XLFDT 46 F S FRM=$O(^ORD(101.43,XRF,FRM)) Q:FRM="" D 47 . S ODI=0 F S ODI=$O(^ORD(101.43,XRF,FRM,ODI)) Q:'ODI D 48 .. S XX=^ORD(101.43,XRF,FRM,ODI) 49 .. I +$P(XX,U,3),$P(XX,U,3)<CRTM Q 50 .. I ODI=ODIEN D 51 ... S NM=NM+1 52 ... I 'XX S Y(NM)=ODIEN_U_$P(XX,U,2)_U_$P(XX,U,2) 53 ... E S Y(NM)=ODIEN_U_$P(XX,U,2)_$C(9)_"<"_$P(XX,U,4)_">"_U_$P(XX,U,4) 54 Q 55 DLGDEF(LST,DLG) ; Format mapping for a dlg 56 N I,IEN,ILST,X0,X2,XW S ILST=0 57 I $O(^ORD(101.41,"AB",DLG,0))>0 S DLG=$O(^ORD(101.41,"AB",DLG,0)) 58 E S DLG=$O(^ORD(101.41,"B",DLG,0)) 59 Q:'DLG 60 S I=0 F S I=$O(^ORD(101.41,DLG,10,I)) Q:I'>0 D 61 . S X0=$G(^ORD(101.41,DLG,10,I,0)),X2=$G(^(2)),IEN=+$P(X0,U,2) 62 . S ILST=ILST+1,LST(ILST)=U_IEN_U_$P(X2,U,1,7) 63 . I $P(X0,U,11) S $P(LST(ILST),U,11)=1 64 . S $P(LST(ILST),U)=$P($G(^ORD(101.41,IEN,1)),U,3) 65 . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDITIVE" S $P(LST(ILST),U)="ADDITIVE" 66 . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDL DIETS" S $P(LST(ILST),U)="ADDLDIETS" 67 . I $L($P(LST(ILST),U))=0 S $P(LST(ILST),U)="ID"_IEN 68 . I $D(^ORD(101.41,DLG,10,"DAD",IEN)) D 69 .. N SEQ,DA,CHILD S CHILD="" 70 .. S SEQ=0 F S SEQ=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ)) Q:'SEQ D 71 ... S DA=0 F S DA=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ,DA)) Q:'DA D 72 .... S CHILD=CHILD_+$P($G(^ORD(101.41,DLG,10,DA,0)),U,2)_"~" 73 .. S $P(LST(ILST),U,10)=CHILD 74 Q 75 ; 76 CHANGE(ORLST,ORCLST,DFN) ; 77 N CATCH,CNT,INP,INPDIEN,IVM,IVMDIEN,ORIEN,ORLOC,OR3,ORDG 78 N CIEN,DIAL,TDIAL,TDIEN,UDIEN,QORDDG 79 S (INP,IVM,INPDIEN,IVMDIEN,UDIEN)=0 80 S (TDIAL,TDIEN)=0 81 S INP=$O(^ORD(101.41,"B","PSJ OR PAT OE","")) Q:INP'>0 82 S IVM=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE","")) Q:IVM'>0 83 S TDIAL=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE","")) Q:TDIAL'>0 84 S INPDIEN=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS","")) Q:INPDIEN'>0 85 S IVMDIEN=$O(^ORD(100.98,"B","IV MEDICATIONS","")) Q:IVMDIEN'>0 86 S UDIEN=$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS","")) Q:UDIEN'>0 87 S TIEN=$O(^ORD(100.98,"B","NURSING","")) Q:TIEN'>0 88 S CIEN=$O(^ORD(100.98,"B","CLINIC ORDERS","")) Q:CIEN'>0 89 S CNT=0 F S CNT=$O(ORCLST(CNT)) Q:CNT'>0 D 90 .S CHANGE=0 91 .S ORIEN=$P($G(ORCLST(CNT)),U),ORIEN=$P(ORIEN,";") 92 .S ORDG=$P($G(^OR(100,ORIEN,0)),U,11) 93 .I ORDG'=INPDIEN,ORDG'=IVMDIEN,ORDG'=UDIEN,ORDG'=TIEN,ORDG'=CIEN Q 94 .S ORLOC=$P($G(ORCLST(CNT)),U,2) 95 .S OR3=$G(^OR(100,ORIEN,3)) 96 .S DIAL=$P(OR3,U,4) 97 . 98 .; 99 .I $P($G(^OR(100,ORIEN,0)),U,10)=(ORLOC_";SC(") D Q 100 ..;Remove treating spec. if IMO order 26.42 101 ..I $P($G(^OR(100,ORIEN,0)),U,11)=CIEN S $P(^OR(100,ORIEN,0),U,13)="" 102 .; 103 .;CHANGE PATIENT LOCATION AND PATIENT STATUS. 104 .S $P(^OR(100,ORIEN,0),U,10)=ORLOC_";SC(" 105 .S $P(^OR(100,ORIEN,0),U,12)="I" 106 .; 107 .;Check for IMO orders Nursing Dialog problem 108 .S CATCH=$P($G(^OR(100,ORIEN,0)),U,11) 109 .; 110 .S $P(^OR(100,ORIEN,0),U,11)=$S(DIAL=(IVM_";ORD(101.41,"):IVMDIEN,DIAL=(INP_";ORD(101.41,"):INPDIEN,DIAL=(TDIAL_";ORD(101.41,"):TIEN,1:CATCH) 111 .; 112 .;Check for Quick Order Dialog 113 .I CATCH=$P($G(^OR(100,ORIEN,0)),U,11) D 114 ..S QORDDG=$P($G(^ORD(101.41,+DIAL,0)),U,5) 115 ..I QORDDG=UDIEN!(QORDDG=INPDIEN) S $P(^OR(100,ORIEN,0),U,11)=INPDIEN,DIAL=(INP_";ORD(101.41,") Q 116 ..I QORDDG=IVMDIEN S $P(^OR(100,ORIEN,0),U,11)=IVMDIEN,DIAL=(IVM_";ORD(101.41,") Q 117 ..I QORDDG=TIEN S $P(^OR(100,ORIEN,0),U,11)=TIEN,DIAL=(TDIAL_";ORD(101.41,") Q 118 .; 119 .;Add treating spec if Inpatient order 120 .I (DIAL=(IVM_";ORD(101.41,"))!(DIAL=(INP_";ORD(101.41,")) D 121 ..S $P(^OR(100,ORIEN,0),U,13)=+$G(^DPT(DFN,.103)) 122 Q 123 ; 124 STCHANGE(ORY,DFN,ORYARR) ; 125 N CNT,DONE,NODE,PHARMID,STR,STATUS 126 S ORY=0,DONE=0 127 I '$$PATCH^XPDUTL("PSS*1.0*93") Q 128 S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0!(DONE>0) D 129 . S NODE=$G(ORYARR(CNT)) 130 . S PHARMID=$P(NODE,U),STATUS=$P(NODE,U,2) 131 . I $$UP^XLFSTR(STATUS)'=$$STATUS^PSSORUTE(DFN,PHARMID) S ORY=1,DONE=1 132 Q 133 DCREN(ORY,ORYARR) ; 134 N ACT,CNT,CNT1,I,OR3,ORG,ORGID,ORID,TEXT,STATUS 135 S CNT1=0 136 S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0 D 137 .S ORGID=ORYARR(CNT) 138 .S ORID=+ORGID,ACT=$P(ORGID,";",2),TEXT="" 139 .S OR3=$G(^OR(100,ORID,3)) 140 .;Make sure current order status is pending 141 .I $P($G(^ORD(100.01,$P(OR3,U,3),0)),U)'="PENDING" Q 142 .S ORG=$P($G(OR3),U,5) Q:ORG'>0 143 .;do not add original order if it is expired 144 .S STATUS=$P(^OR(100,ORG,3),U,3) 145 .I $P($G(^ORD(100.01,STATUS,0)),U)="EXPIRED" Q 146 .;make sure current order is a renewed order 147 .I $P(OR3,U,11)'=2 Q 148 .S ACT=+$P($G(^OR(100,ORG,3)),U,7) 149 .S CNT1=CNT1+1,ORY(CNT1)=ORGID_U_$P(OR3,U,5)_";"_ACT_U_TEXT 150 Q 151 PATWARD(ORY,DFN) ; 152 S ORY=0 153 I $G(^DPT(DFN,.1))'="" S ORY=1 154 Q 155 ISPEND(ORIFN) ;Is the order's status pending? 156 N ISPEND,PENDST,N3 S ISPEND=0 157 Q:'$D(^OR(100,+ORIFN,3)) 158 S PENDST=$O(^ORD(100.01,"B","PENDING",0)) 159 S N3=$G(^OR(100,+ORIFN,3)) 160 I $P(N3,U,3)=PENDST S ISPEND=1 161 Q ISPEND -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXA.m
r613 r623 1 ORWDXA ; SLC/KCM/JLI - Utilites for Order Actions; 10/07/2007 ; 2/7/08 11:48am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,141,149,187,213,195,215,243**;Dec 17, 1997;Build 242 3 ; 4 VALID(VAL,ORID,ACTION,ORNP,ORWNAT) ; Return error message if not valid action for order 5 N ORACT,ORVP,ORVER,ORIFN,PRTID S VAL="",PRTID=0 6 I +ORID=0 S VAL="This order has been deleted." Q 7 I '$D(^OR(100,+ORID,0)) S VAL="This order has been deleted!" Q 8 I ACTION="XFR",'$L($T(XFR^ORCACT01)) S ACTION="RW" ; for pre-POE 9 N ORNSS S ORNSS=1 10 I (ACTION="RN") D VALSCH^ORWNSS(.ORNSS,ORID) 11 I ORNSS=0 S VAL="This order contains an invalid administration schedule." Q 12 I (ACTION="RN") D ISVALIV^ORWDPS33(.VAL,ORID,ACTION) I $L(VAL)>0 Q 13 S ORIFN=ORID,ORVP=$P(^OR(100,+ORID,0),U,2) ; ORCACT0 expects defined 14 I (ACTION="RN") D Q:$L(VAL) ; ** There's got to be a better way! 15 . N DLG S DLG=$P(^OR(100,+ORID,0),U,5) Q:DLG'[";ORD(101.41," 16 . I $G(^ORD(101.41,+DLG,3))'["PROVIDER^ORCDPSIV" Q 17 . D AUTH^ORWDPS32(.VAL,ORNP) 18 . I VAL S VAL=$P(VAL,U,2) 19 . E S VAL="" 20 S ORVER=$S(ACTION="CR":"R",$D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:"^") 21 I ACTION="CR" S ACTION="VR" 22 I (ACTION="ES")!(ACTION="OC")!(ACTION="RS") S ORACT=ACTION ; why not defined??? 23 I (ACTION="VR"),'($D(^XUSEC("ORELSE",DUZ))!$D(^XUSEC("OREMAS",DUZ))) D Q 24 . S VAL="You are not authorized to verify these orders." 25 I $L(VAL) Q 26 N OIIEN,ISIV,IVOD 27 S (ISIV,OIIEN,IVOD)=0 28 I (ACTION="RW")!(ACTION="XX")!(ACTION="XFR") D Q:$L(VAL) 29 . S ISIV=$P(^OR(100,+ORID,0),U,11) 30 . I ISIV,($P(^ORD(100.98,ISIV,0),U,3)="IV RX") S IVOD=1 31 . D:'IVOD GTORITM^ORWDXR(.OIIEN,+ORID) 32 . D:OIIEN ISACTOI(.VAL,OIIEN) I $L(VAL)>0 Q 33 . N DLG,FRM 34 . S DLG=$P(^OR(100,+ORID,0),U,5),FRM=0 35 . I $P(DLG,";",2)'="ORD(101.41," S DLG=0 36 . I DLG D FORMID^ORWDXM(.FRM,+DLG) 37 . I '(DLG&FRM) D 38 . . S VAL="Copy & Change are not implemented for this order that predates CPRS." 39 N OREBUILD ; sometimes left defined by $$VALID 40 ;I (ACTION="RW")!(ACTION="XFR")!(ACTION="RN") D ISVALIV^ORWDPS33(.VAL,ORID,ACTION) I $L(VAL)>0 Q 41 I $$VALID^ORCACT0(ORID,ACTION,.VAL,$G(ORWNAT)) S VAL="" ; VAL=error 42 Q 43 ; 44 HOLD(REC,ORID,ORNP) ; Place an order on hold 45 N ACTDA 46 S ACTDA=$$ACTION^ORCSAVE("HD",+ORID,ORNP) 47 D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA) 48 Q 49 UNHOLD(REC,ORID,ORNP) ; Release an order from hold 50 N ACTDA 51 S ACTDA=$$ACTION^ORCSAVE("RL",+ORID,ORNP) 52 D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA) 53 Q 54 DC(REC,ORID,ORNP,ORL,REASON,DCORIG,ISNEWORD) ; Discontinue/Cancel/Delete an order 55 N NATURE,CREATE,PRINT,STATUS,ACTDA,SIGSTS 56 N X3,X8,CURRACT 57 Q:'+ORID 58 I $G(DCORIG)="" S DCORIG=0 59 S CURRACT=0 60 S ORL(2)=ORL_";SC(",ORL=ORL(2),NATURE="" 61 I REASON S NATURE=$P(^ORD(100.02,$P(^ORD(100.03,REASON,0),U,7),0),U,2) 62 S:NATURE="" NATURE="W" ; S:ORNP=DUZ NATURE="E" 63 ;change the way create work to support forcing signature for all DC 64 ;reasons 65 S CREATE=1,PRINT=$$PRINT^ORCACT2(NATURE) 66 ;S CREATE=$$CREATE^ORX1(NATURE) 67 S X3=$G(^OR(100,+ORID,3)) 68 S CURRACT=$P(X3,U,7) S:CURRACT<1 CURRACT=+$O(^OR(100,+ORID,8,"?"),-1) 69 I '$D(^OR(100,+ORID,8,+$P(ORID,";",2),0)) D 70 . S X8=$G(^OR(100,+ORID,8,CURRACT,0)) 71 . S SIGSTS=$P(X8,U,4) 72 . S $P(ORID,";",2)=CURRACT 73 E D 74 . S X8=^OR(100,+ORID,8,+$P(ORID,";",2),0) 75 . S SIGSTS=$P(X8,U,4) 76 I '$D(SIGSTS) S SIGSTS=1 77 S STATUS=$P($G(^OR(100,+ORID,8,+$P(ORID,";",2),0)),U,15) 78 I (STATUS=10)!(STATUS=11) D Q ; delete/cancel unreleased order 79 . N RPLORD 80 . S RPLORD=$P($G(^OR(100,+ORID,3)),U,5) ; replaced order 81 . D GETBYIFN^ORWORR(.REC,ORID) 82 . I STATUS=10,($P(X8,U,4)'=2) D ; CANCEL signed, delayed, unreleased 83 . . ; taken from CLRDLY^ORCACT2 84 . . I REASON D SET^ORCACT2(+ORID,NATURE,REASON,,DCORIG) 85 . . I 'REASON D SET^ORCACT2(+ORID,"M","","Delayed Order Cancelled",DCORIG) 86 . . D STATUS^ORCSAVE2(+ORID,13) S $P(^OR(100,+ORID,8,1,0),U,15)=13 87 . E D ; CANCEL OR DELETE unsigned, unreleased 88 . . I $P(X8,U,2)="DC" K ^OR(100,+ORID,6) 89 . . ; delete fwd ptr to order about to be deleted 90 . . I RPLORD,$P(X8,U,2)="NW" S $P(^OR(100,RPLORD,3),U,6)="" 91 . . ; delete ptr to order in Patient Event file #100.2 92 . . N EVT S EVT=$P($G(^OR(100,+ORID,0)),U,17) I EVT,EVT=+$O(^ORE(100.2,"AO",+ORID,0)) S $P(^ORE(100.2,EVT,0),U,4)="" K ^ORE(100.2,"AO",+ORID,EVT) 93 . . I $G(ISNEWORD) D DELETE^ORCSAVE2(ORID) 94 . . I '$G(ISNEWORD) D CANCEL^ORCSAVE2(ORID) 95 . I RPLORD,'(SIGSTS=1) S ORID=RPLORD ; for Renews & Changes, show replaced order 96 . I '$D(^OR(100,+ORID)) D 97 . . S $P(REC(1),U)="~0",REC(2)="tDELETED: "_$E(REC(2),2,245) 98 . E D 99 . . K REC 100 . . D GETBYIFN^ORWORR(.REC,+ORID_";"_$P($G(^OR(100,+ORID,3)),U,7)) 101 . S $P(REC(1),U,14)=2 ; DCType = deletion 102 S ACTDA=$$ACTION^ORCSAVE("DC",+ORID,ORNP) 103 D SET^ORCACT2(+ORID,NATURE,REASON,,DCORIG) 104 D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA) 105 S $P(REC(1),U,14)=$S(CREATE:1,1:3) ;DCType - 1=NewOrder, 3=NewStatus 106 N PKG 107 S PKG=$P($G(^OR(100,+ORID,0)),U,14) 108 S PKG=$$NMSP^ORCD(PKG) 109 I REASON=16&(PKG="PS") D 110 . N XMB 111 . S XMB="OR DRUG ORDER CANCELLED" 112 . S XMB(1)=$P($G(REC(2)),"tDiscontinue",2),XMB(4)=$P($G(^VA(200,DUZ,0)),U) 113 . S XMB(2)=+ORID 114 . S XMB(3)=+$P($G(^OR(100,+ORID,0)),U,2) 115 . S XMB(3)=$P($G(^DPT(XMB(3),0)),U) 116 . D ^XMB 117 Q 118 DCREQIEN(VAL) ; Return the IEN for Requesting Physician Cancelled reason 119 S VAL=$O(^ORD(100.03,"S","REQ",0)) 120 Q 121 COMPLETE(REC,ORID,ESCODE) ; Complete an order (generic orders) 122 ;N X S X=+$E($$NOW^XLFDT,1,12) 123 ;D DATES^ORCSAVE2(+ORID,,X) 124 ;D STATUS^ORCSAVE2(+ORID,2) 125 ; validate ESCode 126 D COMP^ORCSAVE2(ORID) 127 D GETBYIFN^ORWORR(.REC,ORID) 128 Q 129 VERIFY(REC,ORID,ESCODE,ORVER) ; Verify an order 130 ; validate ESCode 131 S ORVER=$G(ORVER,$S($D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:U)) 132 I ORVER'=U D 133 . N ORIFN,ORES,ORI 134 . ; to match 56, need to VERIFY any replaced orders: 135 . S ORIFN=ORID,ORES(ORIFN)="" D REPLCD^ORCACT1 136 . S ORI="" F S ORI=$O(ORES(ORI)) Q:ORI="" D EN^ORCSEND(ORI,"VR","",""),UNLK1^ORX2(+ORI):ORI'=ORID ;ORID locked prior 137 D GETBYIFN^ORWORR(.REC,ORID) 138 Q 139 ALERT(DUMMY,ORID,ORDUZ) ;send alert to user (ORDUZ) when order (ORID) resulted 140 ;if no user passed from GUI, use ordering provider: 141 I $G(ORDUZ)<1 S ORDUZ=+$$ORDERER^ORQOR2(+ORID) 142 I $L($G(ORDUZ))<1 S ORDUZ=DUZ 143 S DUMMY=1,$P(^OR(100,+ORID,3),U,10)=ORDUZ 144 Q 145 FLAG(REC,ORIFN,OREASON,ORNP) ; Flag an order 146 N ORB,ORVP,DA,ORPS 147 D BULLETIN 148 S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2) 149 K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON_$S($G(ORNP):"^^^^"_+ORNP,1:"") 150 D KILL^XM,MSG^ORCFLAG(ORIFN) 151 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity 152 I +$G(ORNP)<1 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3) 153 S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification 154 D GETBYIFN^ORWORR(.REC,ORIFN) 155 Q 156 BULLETIN ; Send flagged order bulletin (USED BY FLAG) 157 N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR 158 S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)) 159 ;CLA - 3/21/96: 160 S ORUSR=+$P(OR0,U,4) 161 S ORSRV=$G(^VA(200,ORUSR,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) 162 S ORENT="USR.`"_ORUSR_"^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG" 163 S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q") 164 Q:$G(BULL)'="Y" ;quit if parameter value is not 'Y'es 165 ; 166 S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(+$P(OR0,U,4))="" 167 S XMB(1)=$P(^DPT(+$P(OR0,U,2),0),U),XMB(2)=$P(^(0),U,9),XMB(3)="" ;sb AGE 168 S XMB(4)=$$FMTE^XLFDT($P(OR0,U,7)) 169 D TEXT^ORQ12(.ORDTXT,+ORIFN,80) 170 S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3)) 171 S XMB(8)=$$FMTE^XLFDT($P(OR0,U,8)),XMB(9)=$$FMTE^XLFDT($P(OR0,U,9)),XMB(10)=OREASON 172 S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U) 173 D EN^XMB 174 Q 175 UNFLAG(REC,ORIFN,OREASON) ; Unflag an order 176 N DA,ORB,ORNP,ORVP,ORPS 177 S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2) 178 S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON D MSG^ORCFLAG(ORIFN) 179 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity 180 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3) 181 S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification 182 D GETBYIFN^ORWORR(.REC,ORIFN) 183 Q 184 FLAGTXT(LST,ORID) ; Return flag reason 185 N FLAG 186 S FLAG=$G(^OR(100,+ORID,8,$P(ORID,";",2),3)) 187 S LST(1)="FLAGGED: "_$$FMTE^XLFDT($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U) 188 S LST(2)=$P(FLAG,U,5) ; reason 189 Q 190 WCGET(LST,ORID) ; Return ward comments 191 N I,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2) 192 S I=0 F S I=$O(^OR(100,ORIFN,8,ACT,5,I)) Q:'I S LST(I)=$G(^(I,0)) 193 Q 194 WCPUT(ERR,ORID,WCLST) ; Set ward comments for order 195 N DIERR,ERRLST,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2) 196 D WP^DIE(100.008,ACT_","_ORIFN_",",50,"","WCLST","ERRLST") 197 S ERR="" I $D(DIERR) S ERR="An error occurred while saving comments." 198 Q 199 OFCPLX(ORY,ORID,PRTORDER) ;Check if ORID is an child of the PRTORDER 200 N NUMCHDS,NOWID,NOWVAL,X3,ORDA,ISNOW 201 Q:'$D(^OR(100,+ORID,0)) 202 S ISNOW=0 203 D ISNOW^ORWDXR(.ISNOW,+ORID) 204 Q:ISNOW 205 N PKG 206 S PKG=$P($G(^OR(100,+ORID,0)),U,14) 207 S PKG=$$NMSP^ORCD(PKG) 208 I PKG'="PS" Q 209 I $L($G(^OR(100,+ORID,3))),('$L($P(^(3),U,9))) Q 210 S (NUMCHDS,NOWID,NOWVAL,X3,ORDA)=0 211 S PRTORDER=+$P(^(3),U,9) 212 S X3=$G(^OR(100,PRTORDER,3)),ORDA=$P(X3,U,7) 213 S PRTORDER=PRTORDER_";"_ORDA 214 S NUMCHDS=$P($G(^OR(100,+PRTORDER,2,0)),U,4) 215 I NUMCHDS>2 S ORY="COMPLEX-PSI"_U_PRTORDER 216 S:$D(^OR(100,+PRTORDER,4.5,"ID","NOW")) NOWID=$O(^("NOW",0)) 217 S:NOWID NOWVAL=$G(^OR(100,+PRTORDER,4.5,NOWID,1)) 218 I NOWVAL=1 Q 219 E S ORY="COMPLEX-PSI"_U_PRTORDER 220 Q 221 ISACTOI(ORY,OI) ;If it's an active orderable item 222 I $G(^ORD(101.43,+OI,.1)),^(.1)'>$$NOW^XLFDT D 223 . S ORY=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." 224 Q 1 ORWDXA ; SLC/KCM/JLI - Utilites for Order Actions; 2/10/03 9:13Am [6/7/05 2:09pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,141,149,187,213,195,215**;Dec 17, 1997 3 ; 4 VALID(VAL,ORID,ACTION,ORNP,ORWNAT) ; Return error message if not valid action for order 5 N ORACT,ORVP,ORVER,ORIFN,PRTID S VAL="",PRTID=0 6 I +ORID=0 S VAL="This order has been deleted." Q 7 I '$D(^OR(100,+ORID,0)) S VAL="This order has been deleted!" Q 8 I ACTION="XFR",'$L($T(XFR^ORCACT01)) S ACTION="RW" ; for pre-POE 9 N ORNSS S ORNSS=1 10 I (ACTION="RN") D VALSCH^ORWNSS(.ORNSS,ORID) 11 I ORNSS=0 S VAL="This order contains an invalid administration schedule." Q 12 S ORIFN=ORID,ORVP=$P(^OR(100,+ORID,0),U,2) ; ORCACT0 expects defined 13 I (ACTION="RN") D Q:$L(VAL) ; ** There's got to be a better way! 14 . N DLG S DLG=$P(^OR(100,+ORID,0),U,5) Q:DLG'[";ORD(101.41," 15 . I $G(^ORD(101.41,+DLG,3))'["PROVIDER^ORCDPSIV" Q 16 . D AUTH^ORWDPS32(.VAL,ORNP) 17 . I VAL S VAL=$P(VAL,U,2) 18 . E S VAL="" 19 S ORVER=$S(ACTION="CR":"R",$D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:"^") 20 I ACTION="CR" S ACTION="VR" 21 I (ACTION="ES")!(ACTION="OC")!(ACTION="RS") S ORACT=ACTION ; why not defined??? 22 I (ACTION="VR"),'($D(^XUSEC("ORELSE",DUZ))!$D(^XUSEC("OREMAS",DUZ))) D Q 23 . S VAL="You are not authorized to verify these orders." 24 I $L(VAL) Q 25 N OIIEN,ISIV,IVOD 26 S (ISIV,OIIEN,IVOD)=0 27 I (ACTION="RW")!(ACTION="XX")!(ACTION="XFR") D Q:$L(VAL) 28 . S ISIV=$P(^OR(100,+ORID,0),U,11) 29 . I ISIV,($P(^ORD(100.98,ISIV,0),U,3)="IV RX") S IVOD=1 30 . D:'IVOD GTORITM^ORWDXR(.OIIEN,+ORID) 31 . D:OIIEN ISACTOI(.VAL,OIIEN) I $L(VAL)>0 Q 32 . N DLG,FRM 33 . S DLG=$P(^OR(100,+ORID,0),U,5),FRM=0 34 . I $P(DLG,";",2)'="ORD(101.41," S DLG=0 35 . I DLG D FORMID^ORWDXM(.FRM,+DLG) 36 . I '(DLG&FRM) D 37 . . S VAL="Copy & Change are not implemented for this order that predates CPRS." 38 N OREBUILD ; sometimes left defined by $$VALID 39 I $$VALID^ORCACT0(ORID,ACTION,.VAL,$G(ORWNAT)) S VAL="" ; VAL=error 40 Q 41 HOLD(REC,ORID,ORNP) ; Place an order on hold 42 N ACTDA 43 S ACTDA=$$ACTION^ORCSAVE("HD",+ORID,ORNP) 44 D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA) 45 Q 46 UNHOLD(REC,ORID,ORNP) ; Release an order from hold 47 N ACTDA 48 S ACTDA=$$ACTION^ORCSAVE("RL",+ORID,ORNP) 49 D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA) 50 Q 51 DC(REC,ORID,ORNP,ORL,REASON) ; Discontinue/Cancel/Delete an order 52 N NATURE,CREATE,PRINT,STATUS,ACTDA,SIGSTS 53 N X3,X8,CURRACT 54 Q:'+ORID 55 S CURRACT=0 56 S ORL(2)=ORL_";SC(",ORL=ORL(2),NATURE="" 57 I REASON S NATURE=$P(^ORD(100.02,$P(^ORD(100.03,REASON,0),U,7),0),U,2) 58 S:NATURE="" NATURE="W" ; S:ORNP=DUZ NATURE="E" 59 ;change the way create work to support forcing signature for all DC 60 ;reasons 61 S CREATE=1,PRINT=$$PRINT^ORCACT2(NATURE) 62 ;S CREATE=$$CREATE^ORX1(NATURE) 63 S X3=$G(^OR(100,+ORID,3)) 64 S CURRACT=$P(X3,U,7) S:CURRACT<1 CURRACT=+$O(^OR(100,+ORID,8,"?"),-1) 65 I '$D(^OR(100,+ORID,8,+$P(ORID,";",2),0)) D 66 . S X8=$G(^OR(100,+ORID,8,CURRACT,0)) 67 . S SIGSTS=$P(X8,U,4) 68 . S $P(ORID,";",2)=CURRACT 69 E D 70 . S X8=^OR(100,+ORID,8,+$P(ORID,";",2),0) 71 . S SIGSTS=$P(X8,U,4) 72 I '$D(SIGSTS) S SIGSTS=1 73 S STATUS=$P($G(^OR(100,+ORID,8,+$P(ORID,";",2),0)),U,15) 74 I (STATUS=10)!(STATUS=11) D Q ; delete/cancel unreleased order 75 . N RPLORD 76 . S RPLORD=$P($G(^OR(100,+ORID,3)),U,5) ; replaced order 77 . D GETBYIFN^ORWORR(.REC,ORID) 78 . I STATUS=10,($P(X8,U,4)'=2) D ; CANCEL signed, delayed, unreleased 79 . . ; taken from CLRDLY^ORCACT2 80 . . I REASON D SET^ORCACT2(+ORID,NATURE,REASON) 81 . . I 'REASON D SET^ORCACT2(+ORID,"M","","Delayed Order Cancelled") 82 . . D STATUS^ORCSAVE2(+ORID,13) S $P(^OR(100,+ORID,8,1,0),U,15)=13 83 . E D ; DELETE unsigned, unreleased 84 . . I $P(X8,U,2)="DC" K ^OR(100,+ORID,6) 85 . . ; delete fwd ptr to order about to be deleted 86 . . I RPLORD,$P(X8,U,2)="NW" S $P(^OR(100,RPLORD,3),U,6)="" 87 . . ; delete ptr to order in Patient Event file #100.2 88 . . N EVT S EVT=$P($G(^OR(100,+ORID,0)),U,17) I EVT,EVT=+$O(^ORE(100.2,"AO",+ORID,0)) S $P(^ORE(100.2,EVT,0),U,4)="" K ^ORE(100.2,"AO",+ORID,EVT) 89 . . D DELETE^ORCSAVE2(ORID) 90 . I RPLORD,'(SIGSTS=1) S ORID=RPLORD ; for Renews & Changes, show replaced order 91 . I '$D(^OR(100,+ORID)) D 92 . . S $P(REC(1),U)="~0",REC(2)="tDELETED: "_$E(REC(2),2,245) 93 . E D 94 . . K REC 95 . . D GETBYIFN^ORWORR(.REC,+ORID_";"_$P($G(^OR(100,+ORID,3)),U,7)) 96 . S $P(REC(1),U,14)=2 ; DCType = deletion 97 S ACTDA=$$ACTION^ORCSAVE("DC",+ORID,ORNP) 98 D SET^ORCACT2(+ORID,NATURE,REASON) 99 D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA) 100 S $P(REC(1),U,14)=$S(CREATE:1,1:3) ;DCType - 1=NewOrder, 3=NewStatus 101 N PKG 102 S PKG=$P($G(^OR(100,+ORID,0)),U,14) 103 S PKG=$$NMSP^ORCD(PKG) 104 I REASON=16&(PKG="PS") D 105 . N XMB 106 . S XMB="OR DRUG ORDER CANCELLED" 107 . S XMB(1)=$P($G(REC(2)),"tDiscontinue",2),XMB(4)=$P($G(^VA(200,DUZ,0)),U) 108 . S XMB(2)=+ORID 109 . S XMB(3)=+$P($G(^OR(100,+ORID,0)),U,2) 110 . S XMB(3)=$P($G(^DPT(XMB(3),0)),U) 111 . D ^XMB 112 Q 113 DCREASON(LST) ; Return a list of DC reasons 114 N IEN,ILST,X 115 S ILST=1,LST(ILST)="~DCReason" 116 S IEN=0 F S IEN=$O(^ORD(100.03,IEN)) Q:'IEN S X=^(IEN,0) D 117 . I $P(X,U,4) Q ; inactive 118 . I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q ; not OR pkg 119 . I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q ; nature=auto 120 . S ILST=ILST+1,LST(ILST)="i"_IEN_U_$P(X,U) 121 S IEN=$O(^ORD(100.03,"C","ORREQ",0)) 122 I IEN S ILST=ILST+1,LST(ILST)="d"_IEN_U_$P(^ORD(100.03,IEN,0),U) 123 Q 124 DCREQIEN(VAL) ; Return the IEN for Requesting Physician Cancelled reason 125 S VAL=$O(^ORD(100.03,"S","REQ",0)) 126 Q 127 COMPLETE(REC,ORID,ESCODE) ; Complete an order (generic orders) 128 ;N X S X=+$E($$NOW^XLFDT,1,12) 129 ;D DATES^ORCSAVE2(+ORID,,X) 130 ;D STATUS^ORCSAVE2(+ORID,2) 131 ; validate ESCode 132 D COMP^ORCSAVE2(ORID) 133 D GETBYIFN^ORWORR(.REC,ORID) 134 Q 135 VERIFY(REC,ORID,ESCODE,ORVER) ; Verify an order 136 ; validate ESCode 137 S ORVER=$G(ORVER,$S($D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:U)) 138 I ORVER'=U D 139 . N ORIFN,ORES,ORI 140 . ; to match 56, need to VERIFY any replaced orders: 141 . S ORIFN=ORID,ORES(ORIFN)="" D REPLCD^ORCACT1 142 . S ORI="" F S ORI=$O(ORES(ORI)) Q:ORI="" D EN^ORCSEND(ORI,"VR","",""),UNLK1^ORX2(+ORI):ORI'=ORID ;ORID locked prior 143 D GETBYIFN^ORWORR(.REC,ORID) 144 Q 145 ALERT(DUMMY,ORID,ORDUZ) ;send alert to user (ORDUZ) when order (ORID) resulted 146 ;if no user passed from GUI, use ordering provider: 147 I $G(ORDUZ)<1 S ORDUZ=+$$ORDERER^ORQOR2(+ORID) 148 I $L($G(ORDUZ))<1 S ORDUZ=DUZ 149 S DUMMY=1,$P(^OR(100,+ORID,3),U,10)=ORDUZ 150 Q 151 FLAG(REC,ORIFN,OREASON,ORNP) ; Flag an order 152 N ORB,ORVP,DA,ORPS 153 D BULLETIN 154 S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2) 155 K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON 156 D KILL^XM,MSG^ORCFLAG(ORIFN) 157 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity 158 I +$G(ORNP)<1 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3) 159 S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification 160 D GETBYIFN^ORWORR(.REC,ORIFN) 161 Q 162 BULLETIN ; Send flagged order bulletin (USED BY FLAG) 163 N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR 164 S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)) 165 ;CLA - 3/21/96: 166 S ORUSR=+$P(OR0,U,4) 167 S ORSRV=$G(^VA(200,ORUSR,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) 168 S ORENT="USR.`"_ORUSR_"^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG" 169 S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q") 170 Q:$G(BULL)'="Y" ;quit if parameter value is not 'Y'es 171 ; 172 S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(+$P(OR0,U,4))="" 173 S XMB(1)=$P(^DPT(+$P(OR0,U,2),0),U),XMB(2)=$P(^(0),U,9),XMB(3)="" ;sb AGE 174 S XMB(4)=$$FMTE^XLFDT($P(OR0,U,7)) 175 D TEXT^ORQ12(.ORDTXT,+ORIFN,80) 176 S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3)) 177 S XMB(8)=$$FMTE^XLFDT($P(OR0,U,8)),XMB(9)=$$FMTE^XLFDT($P(OR0,U,9)),XMB(10)=OREASON 178 S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U) 179 D EN^XMB 180 Q 181 UNFLAG(REC,ORIFN,OREASON) ; Unflag an order 182 N DA,ORB,ORNP,ORVP,ORPS 183 S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2) 184 S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON D MSG^ORCFLAG(ORIFN) 185 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity 186 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3) 187 S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification 188 D GETBYIFN^ORWORR(.REC,ORIFN) 189 Q 190 FLAGTXT(LST,ORID) ; Return flag reason 191 N FLAG 192 S FLAG=$G(^OR(100,+ORID,8,$P(ORID,";",2),3)) 193 S LST(1)="FLAGGED: "_$$FMTE^XLFDT($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U) 194 S LST(2)=$P(FLAG,U,5) ; reason 195 Q 196 WCGET(LST,ORID) ; Return ward comments 197 N I,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2) 198 S I=0 F S I=$O(^OR(100,ORIFN,8,ACT,5,I)) Q:'I S LST(I)=$G(^(I,0)) 199 Q 200 WCPUT(ERR,ORID,WCLST) ; Set ward comments for order 201 N DIERR,ERRLST,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2) 202 D WP^DIE(100.008,ACT_","_ORIFN_",",50,"","WCLST","ERRLST") 203 S ERR="" I $D(DIERR) S ERR="An error occurred while saving comments." 204 Q 205 OFCPLX(ORY,ORID,PRTORDER) ;Check if ORID is an child of the PRTORDER 206 N NUMCHDS,NOWID,NOWVAL,X3,ORDA,ISNOW 207 Q:'$D(^OR(100,+ORID,0)) 208 S ISNOW=0 209 D ISNOW^ORWDXR(.ISNOW,+ORID) 210 Q:ISNOW 211 N PKG 212 S PKG=$P($G(^OR(100,+ORID,0)),U,14) 213 S PKG=$$NMSP^ORCD(PKG) 214 I PKG'="PS" Q 215 I $L($G(^OR(100,+ORID,3))),('$L($P(^(3),U,9))) Q 216 S (NUMCHDS,NOWID,NOWVAL,X3,ORDA)=0 217 S PRTORDER=+$P(^(3),U,9) 218 S X3=$G(^OR(100,PRTORDER,3)),ORDA=$P(X3,U,7) 219 S PRTORDER=PRTORDER_";"_ORDA 220 S NUMCHDS=$P($G(^OR(100,+PRTORDER,2,0)),U,4) 221 I NUMCHDS>2 S ORY="COMPLEX-PSI"_U_PRTORDER 222 S:$D(^OR(100,+PRTORDER,4.5,"ID","NOW")) NOWID=$O(^("NOW",0)) 223 S:NOWID NOWVAL=$G(^OR(100,+PRTORDER,4.5,NOWID,1)) 224 I NOWVAL=1 Q 225 E S ORY="COMPLEX-PSI"_U_PRTORDER 226 Q 227 ISACTOI(ORY,OI) ;If it's an active orderable item 228 I $G(^ORD(101.43,+OI,.1)),^(.1)'>$$NOW^XLFDT D 229 . S ORY=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." 230 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXC.m
r613 r623 1 ORWDXC ; SLC/KCM - Utilities for Order Checking 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,141,221,243**;Dec 17, 1997;Build 242 3 ; 4 ON(VAL) ; returns E if order checking enabled, otherwise D 5 S VAL=$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE") 6 Q 7 FILLID(VAL,DLG) ; Return the FillerID (namespace) for a dialog 8 N DGRP 9 S VAL="",DGRP=$P($G(^ORD(101.41,DLG,0)),U,5) Q:'DGRP 10 S DLG=$$DEFDLG^ORWDXQ(DGRP) 11 S VAL=$P($G(^ORD(101.41,DLG,0)),U,7),VAL=$$NMSP^ORCD(VAL) 12 I VAL="PS" D 13 . N X 14 . S X=$P($P($G(^ORD(100.98,DGRP,0)),U,3)," ") 15 . I $L(X) S VAL="PS"_$S(X="UD":"I",1:X) 16 Q 17 DISPLAY(LST,DFN,FID) ; Return list of Order Checks for a FillerID (namespace) 18 N I,ORX,ORY 19 S ORX=1,ORX(1)="|"_FID 20 D EN^ORKCHK(.ORY,DFN,.ORX,"DISPLAY") 21 S I=0 F S I=$O(ORY(I)) Q:I'>0 S LST(I)=$P(ORY(I),U,4) 22 Q 23 ACCEPT(LST,DFN,FID,STRT,ORL,OIL,ORIFN) ; Return list of Order Checks on Accept Order 24 ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo 25 N X,Y,USID,ORCHECK,ORI,ORX,ORY 26 ; convert relative start date to real start date 27 S ORL=ORL_";SC(",X=STRT,STRT="" 28 D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2 29 I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y 30 ; do the SELECT order checks 31 S ORI=0 F S ORI=$O(OIL(ORI)) Q:'ORI D 32 . S USID=$$USID(OIL(ORI)) 33 . S OIL(ORI,"USID")=USID 34 . S ORX=1,ORX(1)=+OIL(ORI)_"|"_FID_"|"_USID 35 . D EN^ORKCHK(.ORY,DFN,.ORX,"SELECT") 36 . I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK 37 . K ORX,ORY 38 ; do the ACCEPT order checks 39 S (ORI,ORX)=0 F S ORI=$O(OIL(ORI)) Q:'ORI D 40 . S ORX=ORX+1 41 . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_OIL(ORI,"USID")_"|"_STRT 42 . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3) 43 D EN^ORKCHK(.ORY,DFN,.ORX,"ACCEPT") 44 I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK 45 ; return ORCHECK as 1 dimensional list 46 D CHK2LST 47 Q 48 DELAY(LST,DFN,FID,STRT,ORL,OIL) ; Return list of Order Checks on Accept Delayed 49 ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo 50 N X,Y,ORCHECK,ORI,ORX,ORY 51 ; convert relative start date to real start date 52 S ORL=ORL_";SC(",X=STRT,STRT="" 53 D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2 54 I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y 55 ; do the ACCEPT order checks 56 S (ORI,ORX)=0 F S ORI=$O(OIL(ORI)) Q:'ORI D 57 . S ORX=ORX+1 58 . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_$$USID(OIL(ORI))_"|"_STRT 59 . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3) 60 D EN^ORKCHK(.ORY,DFN,.ORX,"ALL") 61 I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK 62 ; return ORCHECK as 1 dimensional list 63 D CHK2LST 64 Q 65 SESSION(LST,ORVP,ORLST) ; Return list of Order Checks on Release Order 66 N ORES,ORCHECK 67 S ORVP=+ORVP_";DPT(" 68 S I=0 F S I=$O(ORLST(I)) Q:'I D 69 . I +$P(ORLST(I),";",2)'=1 Q ; order not new 70 . I $P(ORLST(I),U,3)="0" Q ; order not being released 71 . S ORES($P(ORLST(I),U))="" 72 D SESSION^ORCHECK 73 D CHK2LST 74 Q 75 SAVECHK(OK,ORVP,RSN,LST) ; Save order checks for session 76 N ORCHECK,ORIFN S OK=1 77 D LST2CHK 78 I $L(RSN)>0 S ORCHECK("OK")=RSN 79 S ORIFN=0 F S ORIFN=$O(ORCHECK(ORIFN)) Q:'ORIFN D OC^ORCSAVE2 80 Q 81 DELORD(OK,ORIFN) ; Delete order 82 N STS,DIK,DA 83 S STS=$P(^OR(100,+ORIFN,8,1,0),U,15),OK=0 84 I (STS=10)!(STS=11) D Q ; makes sure it's an unreleased order 85 . S DA=+ORIFN,DIK="^OR(100," Q:'DA 86 . D ^DIK 87 . S OK=1 88 Q 89 USID(ORITMX) ; Return universal svc ID for an orderable item 90 ; ORITMX = OI^NMSP^PKGINFO 91 N RSLT,ORDRUG S RSLT="" 92 I $E($P(ORITMX,U,2),1,2)="PS" D 93 . I $P(ORITMX,U,2)="PSIV" D 94 . . N PSOI,TYPE,VOL S VOL="" 95 . . S PSOI=+$P($G(^ORD(101.43,+ORITMX,0)),U,2) 96 . . S TYPE=$P($P(ORITMX,U,3),";") 97 . . I TYPE="B" S VOL=$P($P(ORITMX,U,3),";",2) 98 . . D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORDRUG) 99 . . S ORDRUG=+ORDRUG 100 . E S ORDRUG=+$P(ORITMX,U,3) 101 . S RSLT=$$ENDCM^PSJORUTL(ORDRUG) 102 . S RSLT=$P(RSLT,U,3)_"^^99NDF^"_ORDRUG_U_$$NAME50^ORPEAPI(ORDRUG)_"^99PSD" 103 E S RSLT=$$USID^ORMBLD(+ORITMX) 104 I +$P(RSLT,U)=0,+($P(RSLT,U,4)=0) S RSLT="" ; has to be null (why?) 105 Q RSLT 106 ; 107 CHK2LST ; creates list that can be passed to broker from ORCHECK array 108 ; expects ORCHECK to be present and populates LST 109 N ORIFN,ORID,CDL,I,ILST S ILST=1 ;Start array at 1 always leaving room for RDI msg at top 110 S ORIFN="" F S ORIFN=$O(ORCHECK(ORIFN)) Q:ORIFN="" D 111 . S CDL=0 F S CDL=$O(ORCHECK(ORIFN,CDL)) Q:'CDL D 112 . . S I=0 F S I=$O(ORCHECK(ORIFN,CDL,I)) Q:'I D 113 . . . S ORID=ORIFN I +ORID,(+ORID=ORID) S ORID=ORID_";1" 114 . . . I '$P(ORCHECK(ORIFN,CDL,I),U,2) Q ; CDL="" means don't show 115 . . . I $P(ORCHECK(ORIFN,CDL,I),U,1)=99 S LST(1)=ORID_U_ORCHECK(ORIFN,CDL,I) Q ;Put RDI warning at the top 116 . . . S ILST=ILST+1,LST(ILST)=ORID_U_ORCHECK(ORIFN,CDL,I) 117 Q 118 LST2CHK ; create ORCHECK array from list passed by broker 119 N ORIFN,CDL,I,ILST S I=0 120 S ILST=0 F S ILST=$O(LST(ILST)) Q:'ILST D 121 . S X=LST(ILST) 122 . S ORIFN=$P(X,U),CDL=$P(X,U,3) 123 . I +$G(ORIFN)>0,+$G(CDL)>0 D ;cla 12/16/03 124 . . S I=I+1,ORCHECK(+ORIFN,CDL,I)=$P(X,U,2,4) 125 Q 1 ORWDXC ; SLC/KCM - Utilities for Order Checking 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,141,221**;Dec 17, 1997 3 ; 4 ON(VAL) ; returns E if order checking enabled, otherwise D 5 S VAL=$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE") 6 Q 7 FILLID(VAL,DLG) ; Return the FillerID (namespace) for a dialog 8 N DGRP 9 S VAL="",DGRP=$P($G(^ORD(101.41,DLG,0)),U,5) Q:'DGRP 10 S DLG=$$DEFDLG^ORWDXQ(DGRP) 11 S VAL=$P($G(^ORD(101.41,DLG,0)),U,7),VAL=$$NMSP^ORCD(VAL) 12 I VAL="PS" D 13 . N X 14 . S X=$P($P($G(^ORD(100.98,DGRP,0)),U,3)," ") 15 . I $L(X) S VAL="PS"_$S(X="UD":"I",1:X) 16 Q 17 DISPLAY(LST,DFN,FID) ; Return list of Order Checks for a FillerID (namespace) 18 N I,ORX,ORY 19 S ORX=1,ORX(1)="|"_FID 20 D EN^ORKCHK(.ORY,DFN,.ORX,"DISPLAY") 21 S I=0 F S I=$O(ORY(I)) Q:I'>0 S LST(I)=$P(ORY(I),U,4) 22 Q 23 ACCEPT(LST,DFN,FID,STRT,ORL,OIL,ORIFN) ; Return list of Order Checks on Accept Order 24 ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo 25 N X,Y,USID,ORCHECK,ORI,ORX,ORY 26 ; convert relative start date to real start date 27 S ORL=ORL_";SC(",X=STRT,STRT="" 28 D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2 29 I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y 30 ; do the SELECT order checks 31 S ORI=0 F S ORI=$O(OIL(ORI)) Q:'ORI D 32 . S USID=$$USID(OIL(ORI)) 33 . S OIL(ORI,"USID")=USID 34 . S ORX=1,ORX(1)=+OIL(ORI)_"|"_FID_"|"_USID 35 . D EN^ORKCHK(.ORY,DFN,.ORX,"SELECT") 36 . I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK 37 . K ORX,ORY 38 ; do the ACCEPT order checks 39 S (ORI,ORX)=0 F S ORI=$O(OIL(ORI)) Q:'ORI D 40 . S ORX=ORX+1 41 . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_OIL(ORI,"USID")_"|"_STRT 42 . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3) 43 D EN^ORKCHK(.ORY,DFN,.ORX,"ACCEPT") 44 I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK 45 ; return ORCHECK as 1 dimensional list 46 D CHK2LST 47 Q 48 DELAY(LST,DFN,FID,STRT,ORL,OIL) ; Return list of Order Checks on Accept Delayed 49 ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo 50 N X,Y,ORCHECK,ORI,ORX,ORY 51 ; convert relative start date to real start date 52 S ORL=ORL_";SC(",X=STRT,STRT="" 53 D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2 54 I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y 55 ; do the ACCEPT order checks 56 S (ORI,ORX)=0 F S ORI=$O(OIL(ORI)) Q:'ORI D 57 . S ORX=ORX+1 58 . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_$$USID(OIL(ORI))_"|"_STRT 59 . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3) 60 D EN^ORKCHK(.ORY,DFN,.ORX,"ALL") 61 I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK 62 ; return ORCHECK as 1 dimensional list 63 D CHK2LST 64 Q 65 SESSION(LST,ORVP,ORLST) ; Return list of Order Checks on Release Order 66 N ORES,ORCHECK 67 S ORVP=+ORVP_";DPT(" 68 S I=0 F S I=$O(ORLST(I)) Q:'I D 69 . I +$P(ORLST(I),";",2)'=1 Q ; order not new 70 . I $P(ORLST(I),U,3)="0" Q ; order not being released 71 . S ORES($P(ORLST(I),U))="" 72 D SESSION^ORCHECK 73 D CHK2LST 74 Q 75 SAVECHK(OK,ORVP,RSN,LST) ; Save order checks for session 76 N ORCHECK,ORIFN S OK=1 77 D LST2CHK 78 I $L(RSN)>0 S ORCHECK("OK")=RSN 79 S ORIFN=0 F S ORIFN=$O(ORCHECK(ORIFN)) Q:'ORIFN D OC^ORCSAVE2 80 Q 81 DELORD(OK,ORIFN) ; Delete order 82 N STS,DIK,DA 83 S STS=$P(^OR(100,+ORIFN,8,1,0),U,15),OK=0 84 I (STS=10)!(STS=11) D Q ; makes sure it's an unreleased order 85 . S DA=+ORIFN,DIK="^OR(100," Q:'DA 86 . D ^DIK 87 . S OK=1 88 Q 89 USID(ORITMX) ; Return universal svc ID for an orderable item 90 ; ORITMX = OI^NMSP^PKGINFO 91 N RSLT,ORDRUG S RSLT="" 92 I $E($P(ORITMX,U,2),1,2)="PS" D 93 . I $P(ORITMX,U,2)="PSIV" D 94 . . N PSOI,TYPE,VOL S VOL="" 95 . . S PSOI=+$P($G(^ORD(101.43,+ORITMX,0)),U,2) 96 . . S TYPE=$P($P(ORITMX,U,3),";") 97 . . I TYPE="B" S VOL=$P($P(ORITMX,U,3),";",2) 98 . . D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORDRUG) 99 . . S ORDRUG=+ORDRUG 100 . E S ORDRUG=+$P(ORITMX,U,3) 101 . S RSLT=$$ENDCM^PSJORUTL(ORDRUG) 102 . S RSLT=$P(RSLT,U,3)_"^^99NDF^"_ORDRUG_U_$P($G(^PSDRUG(ORDRUG,0)),U)_"^99PSD" 103 E S RSLT=$$USID^ORMBLD(+ORITMX) 104 I +$P(RSLT,U)=0,+($P(RSLT,U,4)=0) S RSLT="" ; has to be null (why?) 105 Q RSLT 106 ; 107 CHK2LST ; creates list that can be passed to broker from ORCHECK array 108 ; expects ORCHECK to be present and populates LST 109 N ORIFN,ORID,CDL,I,ILST S ILST=0 110 S ORIFN="" F S ORIFN=$O(ORCHECK(ORIFN)) Q:ORIFN="" D 111 . S CDL=0 F S CDL=$O(ORCHECK(ORIFN,CDL)) Q:'CDL D 112 . . S I=0 F S I=$O(ORCHECK(ORIFN,CDL,I)) Q:'I D 113 . . . S ORID=ORIFN I +ORID,(+ORID=ORID) S ORID=ORID_";1" 114 . . . I '$P(ORCHECK(ORIFN,CDL,I),U,2) Q ; CDL="" means don't show 115 . . . S ILST=ILST+1,LST(ILST)=ORID_U_ORCHECK(ORIFN,CDL,I) 116 Q 117 LST2CHK ; create ORCHECK array from list passed by broker 118 N ORIFN,CDL,I,ILST S I=0 119 S ILST=0 F S ILST=$O(LST(ILST)) Q:'ILST D 120 . S X=LST(ILST) 121 . S ORIFN=$P(X,U),CDL=$P(X,U,3) 122 . I +$G(ORIFN)>0,+$G(CDL)>0 D ;cla 12/16/03 123 . . S I=I+1,ORCHECK(+ORIFN,CDL,I)=$P(X,U,2,4) 124 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM1.m
r613 r623 1 ORWDXM1 ; SLC/KCM - Order Dialogs, Menus;2/19/03 ;5/27/2008 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,178,185,187,215,243**;Dec 17, 1997;Build 242 3 BLDQRSP(LST,ORIT,FLDS,ISIMO,ENCLOC) ; Build responses for an order 4 ; LST=QuickLevel^ResponseID(ORIT;$H)^Dialog^Type^FormID^DGrp 5 ; LST(n)=verify text or reject text 6 ; ORIT= ptr to 101.41 for quick order, 100 for copy 7 ; 1 2 3 4 5 6 7 8 11-20 8 ; FLDS=DFN^LOC^ORNP^INPT^SEX^AGE^EVENT^SC%^^^Key Variables... 9 ; ORIT=+ORIT: ptr to 101.41, $E(ORIT)=C: copy $E(ORIT)=X: change 10 ; !! SHOULD CHECK for PRE-CPRS ORDERS (treat as text?) 11 K ^TMP("ORWDXMQ",$J) 12 N ORWMODE ; 0:Dialog,Quick 1:copy order 2:change order 13 N TEMPCAT ; patient category from DPT file 14 N ISXFER ; Transfer order? 15 N ORIMO ;If IMO(inpatient medication on outpatient) 16 N TEMPORIT 17 N ADMLOC,PATLOC,ORDLOC,LEVEL,DELAY,SCHLOC,SCHTYP 18 S PATLOC=$P(FLDS,U,2) 19 S ORDLOC=$S(ORIT["C":+$P($G(^OR(100,+$P(ORIT,"C",2),0)),U,10),1:0) 20 S ORIMO=$G(ISIMO) 21 S ORWMODE=0,ISXFER="" 22 S:$E(ORIT)="C" ORWMODE=1 S:$E(ORIT)="T" ORWMODE=1,ISXFER=";T" ;treat xfer as copy for now 23 S:$E(ORIT)="X" ORWMODE=2 24 S TEMPORIT=ORIT 25 I ORWMODE S ORIT=$E(ORIT,2,999) 26 S LST(0)="" 27 D CHKDSBL^ORWDXM3(.LST,ORIT,ORWMODE) Q:+LST(0)=8 ;disable 28 D CHKVACT^ORWDXM3(.LST,ORIT,ORWMODE,$P(FLDS,U,3)) Q:+LST(0)=8 ;action 29 I ORWMODE=1 D CHKCOPY^ORWDXM3(.LST,ORIT,FLDS) Q:+LST(0)=8 ;no copy 30 I ORWMODE=2 D BLD4CHG^ORWDXM3(.LST,ORIT,FLDS) Q ;change 31 I 'ORWMODE,($P(^ORD(101.41,+ORIT,0),U,4)="D"),'($O(^DIC(9.4,"C","OR",0))[$P(^ORD(101.41,+ORIT,0),U,7)) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER) Q 32 ;radilogy vars 33 N ORIMTYPE 34 ;blood bank vars 35 N ORCOMP,ORTAS 36 ;lab vars 37 N LRFZX,LRFSAMP,LRFSPEC,LRFDATE,LRFURG,LRFSCH 38 N ORTIME,ORCOLLCT,ORMAX,ORTEST,ORIMTIME,ORSMAX,ORSTMS,ORSCH 39 ;pharmacy vars 40 N PSJNOPC,ORMORE,ORINPT,ORXNP,ORSCHED,ORQTY,ORNOUNS,ORXNP,OREFILLS 41 N ORCOMPLX,ORQTY,ORCOPAY,ORDRUG,ORWPSPIK,ORWPSWRG,ORSD,ORDSUP,ORWP94 42 ;dietetics vars 43 N ORPARAM,ORNPO,ORTIME,ORMEAL,ORTRAY,ORDATE 44 ;consults vars 45 N GMRCNOPD,GMRCNOAT,GMRCREAF 46 ; setup general env 47 N ORTYPE,ORVP,ORL,ORNP,ORSEX,ORAGE,ORWARD,OREVENT,ORDIV,ORSC,KEYVAR 48 N ORDG,ORDIALOG,ORCAT,FIRST,ORQUIT,X,ORTRAIL,ORLEAD,RSPREF,AUTOACK 49 N OREVNTYP 50 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0 51 S ORVP=$P(FLDS,U,1)_";DPT(",ORNP=+$P(FLDS,U,3),ORSC=$P(FLDS,U,8) 52 S ORL=$P(FLDS,U,2)_";SC(",ORL(2)=ORL 53 S ORSEX=$P(FLDS,U,5),ORAGE=$P(FLDS,U,6),ORTYPE="Q",FIRST=1 54 I $P(FLDS,U,4),$G(^SC(+ORL,42)) S ORWARD=+^SC(+ORL,42) 55 I $L($P(FLDS,U,7)) D 56 . S OREVENT=$P(FLDS,U,7) 57 . S OREVNTYP=$P(OREVENT,";",2) 58 . S OREVENT("TS")=$P(OREVENT,";",3) 59 . S OREVENT("EFFECTIVE")=$P(OREVENT,";",4) 60 . S OREVENT=+$P(OREVENT,";",1) 61 I 'ORWMODE D 62 . D SETKEYV^ORWDXM3($P(FLDS,U,11,20)) ; from menu path 63 . S KEYVAR=$$KEYVAR^ORWDXM3(ORIT) ; from entry action 64 . D SETKEYV^ORWDXM3(KEYVAR) 65 K ^TMP("ORWORD",$J) 66 ; init return record based on auto-accept 67 I ORWMODE S LST(0)="2^"_ORIT ;verify on copy 68 E S LST(0)=+$P($G(^ORD(101.41,ORIT,5)),U,8)_U_ORIT 69 S TEMPCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O") 70 I TEMPCAT="I",+$P(FLDS,U,4)=1,$E(TEMPORIT)="C",$P($G(^ORD(100.98,$P($G(^OR(100,+ORIT,0)),U,11),0)),U)="OUTPATIENT MEDICATIONS" S TEMPCAT="O" 71 I $L($G(OREVNTYP)) D 72 . S ORCAT=$S(OREVNTYP="A":"I",OREVNTYP="T":"I",OREVNTYP="O":TEMPCAT,OREVNTYP="M":TEMPCAT,OREVNTYP="C":TEMPCAT,1:"O") I $G(OREVENT) D 73 .. N X S X=$$EVT^OREVNTX(OREVENT),X=$P($G(^ORD(100.5,+X,0)),U,7) 74 .. I OREVNTYP="T",X,X<4 S ORCAT="O" ;To pass=outpt 75 .. I OREVNTYP="D",X=41 S ORCAT="I" ;From ASIH=inpt 76 E S ORCAT=TEMPCAT 77 D SETUP^ORWDXM4 Q:+LST(0)=8 78 S X="OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:"") 79 I ORWMODE,(ORDG=+$O(^ORD(100.98,"B","O RX",0))) D ;remove old values 80 . K ORDIALOG($$PTR^ORCD(X),1) 81 . I ORWMODE=2,$$DRAFT^ORWDX2(ORIT) Q ;keep comments 82 . K:ISXFER'["T" ORDIALOG($$PTR^ORCD("OR GTX WORD PROCESSING 1"),1) 83 D SETUPS^ORWDXM4 ;moved to save space, expects X 84 Q:+LST(0)=8 85 I $G(ORQUIT) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR) Q 86 N SEQ,DA,XCODE,MUSTASK,PROMPT,INST,KEY,IVFID 87 S IVFID=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0)) 88 S AUTOACK=$S($D(ORWPSWRG):0,1:1) 89 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:'SEQ D 90 . S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D 91 . . ; skip if this is a child prompt 92 . . I $P(^ORD(101.41,+ORDIALOG,10,DA,0),U,11) Q 93 . . ; set default for prompt, see if needs to be interactive 94 . . S PROMPT=$P(^ORD(101.41,+ORDIALOG,10,DA,0),U,2) 95 . . D SETITEM(DA,PROMPT,1,.MUSTASK) 96 . . I MUSTASK S AUTOACK=0 Q 97 . . ; iterate through the child items if parent and edit only 98 . . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) 99 . . N CSEQ,CDA,CPROMPT,INST,ORQUIT 100 . . S CSEQ=0 F S CSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ)) Q:'CSEQ D Q:$G(ORQUIT) 101 . . . S CDA=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ,0)) 102 . . . S CPROMPT=$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,2) 103 . . . ; if req & no instances then need interaction 104 . . . I $P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6),ORDIALOG'=IVFID,'$O(ORDIALOG(CPROMPT,0)) S AUTOACK=0 105 . . . S INST=0 F S INST=$O(ORDIALOG(CPROMPT,INST)) Q:'INST D 106 . . . . N ORASK D VBASK^ORWDXM4(INST) ; set ORASK for VBECS 107 . . . . ; set default for each child prompt, if necessary 108 . . . . D SETITEM(CDA,CPROMPT,INST,.MUSTASK) 109 . . . . ; if no val & child prmpt required then need interaction 110 . . . . I MUSTASK,$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6) S AUTOACK=0 111 N IVDLG 112 S IVDLG=$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0)) 113 I $$ISMED(ORIT),(ORDIALOG'=IVDLG),(ORCAT="I") D 114 . F P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED" K ORDIALOG($$PTR(P),1) 115 S KEY=$S(ORWMODE:"C",1:"")_ORIT_"-"_$P($H,",",2),SEQ=0 116 I $$ISINPMED(ORIT) D 117 .S LEVEL=$P(LST(0),U),DELAY=$S($P($G(OREVENT),";")>0:1,1:0) 118 .I LEVEL=2!(ISIMO) D ADMTIME^ORWDXM2(ORDLOC,PATLOC,ENCLOC,DELAY,ISIMO) 119 I ($$ISMED(ORIT)),'($$VALQO^ORWDXM3(ORIT)) S AUTOACK=0 120 S PROMPT=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:'PROMPT D 121 . I '$D(^ORD(101.41,ORDIALOG,10,"D",PROMPT)) K ORDIALOG(PROMPT) Q 122 . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D 123 . . S SEQ=SEQ+1,^TMP("ORWDXMQ",$J,KEY,SEQ,0)=U_PROMPT_U_INST 124 . . ; save word processing value 125 . . I $E(ORDIALOG(PROMPT,0))="W",$L(ORDIALOG(PROMPT,INST)) D 126 . . . M ^TMP("ORWDXMQ",$J,KEY,SEQ,2)=@ORDIALOG(PROMPT,INST) 127 . . ; save other value types 128 . . E S ^TMP("ORWDXMQ",$J,KEY,SEQ,1)=ORDIALOG(PROMPT,INST) 129 I AUTOACK D 130 . I ORWMODE S AUTOACK=2 131 . I 'ORWMODE,($P(^ORD(101.41,ORIT,0),U,8)!'LST(0)) S AUTOACK=2 132 ;I ($$ISMED(ORIT)),'($$VALQO^ORWDXM3(ORIT)) S AUTOACK=0 133 I ORIMO,ORWMODE S AUTOACK=2 134 ; added to accept Herbal/OTC/NonVA Med quick orders 135 I $L($G(^ORD(101.41,+ORIT,0))),($P(^ORD(100.98,$P(^ORD(101.41,+ORIT,0),U,5),0),U,3)="NV RX"),($P($G(^ORD(101.41,+ORIT,5)),U,8)) S AUTOACK=1 136 ;I $G(^OR(100,+ORIT,0)),$P($G(^ORD(101.41,+$P(^OR(100,+ORIT,0),U,5),0)),U,8),$D(ORDIALOG("B","HERBAL/OTC/NON VA MEDICATION")) S AUTOACK=1 137 I AUTOACK=2,$$ISMED(ORIT),(ORDIALOG=IVDLG),$$VERORD^ORWDXM3=0 S AUTOACK=0 138 I AUTOACK=2 D VERTXT^ORWDXM2 139 S LST(0)=AUTOACK_U_KEY_U_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR) 140 I $P(LST(0),U,4)="D" S $P(LST(0),U,4)="Q" 141 I ORWMODE=1 S $P(LST(0),U,4)="C" 142 K ^TMP("ORWORD",$J) 143 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J) 144 Q 145 SETITEM(DA,PROMPT,INST,MUSTASK) ; set default value & return if must prompt 146 N EDITONLY,Y,VALIV,XCODE 147 S MUSTASK=0,EDITONLY=0,VALIV=0 148 I $D(^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)) D 149 . I $E(ORDIALOG(PROMPT,0))="W" D 150 . . S ^TMP("ORWORD",$J,PROMPT,INST,1,0)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT) 151 . . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" 152 . E S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT) 153 I $D(^TMP("ORWDHTM",$J,ORIT,PROMPT)) D 154 . S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORIT,PROMPT) 155 . ; NEED TO CLEAN UP ^TMP("ORWDHTM") after process order set!!! 156 ; 157 ; skip if a value already exists for this prompt and not WP 158 Q:$D(ORDIALOG(PROMPT,INST))&($E(ORDIALOG(PROMPT,0))'="W") 159 ; execute default action if no value in QO, checking EDITONLY afterwards 160 I '$D(ORDIALOG(PROMPT,INST)) D 161 . ; 162 . ;Intermittent IV orders do not require a solution or an infusion rate 163 . I PROMPT=$$PTR("INFUSION RATE"),$$GETIVTYP^ORWDXM3="I" S VALIV=1 Q 164 . I PROMPT=$$PTR("ORDERABLE ITEM"),$$GETIVTYP^ORWDXM3="I" S VALIV=1 Q 165 . I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,DA,8))>9 D 166 . . M ^TMP("ORWORD",$J,PROMPT,INST)=^ORD(101.41,+ORDIALOG,10,DA,8) 167 . . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" 168 . E D 169 . . S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,7))) 170 . . I $L(XCODE) X XCODE S:$D(Y) ORDIALOG(PROMPT,INST)=Y 171 Q:VALIV=1 172 Q:$G(EDITONLY) 173 I 'ORWMODE,$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,8) Q 174 I ORWMODE,($P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,9)'["W"),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6)!$D(ORDIALOG(PROMPT,INST)) Q 175 I 'ORWMODE,LST(0),$D(ORDIALOG(PROMPT,INST)),($E(ORDIALOG(PROMPT,0))="W") Q 176 I 'ORWMODE,LST(0),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6) Q 177 S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,3))) 178 I $L(XCODE) X XCODE Q:'$T 179 S MUSTASK=1 180 Q 181 SUBCODE(X) ; substitute code 182 I X["$$REQDCOMM^ORCDLR" Q "I $$LRRQCM^ORWDXM2" 183 I X["$$ASKSAMP^ORCDLR" Q "I $$LRASMP^ORWDXM2" 184 I X["$$SCHEDULD^ORCDRA1" Q "I $$SCHEDULD^ORWDXM2" 185 I X["(^PSX(550,""C"")" Q "S Y=$E($$DEFPICK^ORWDPS32) K:'$L(Y) Y" 186 I X["I $$ASKURG^ORCDVBEC" Q "I 1" 187 I X["K:$G(ORASK)" Q "I $G(ORASK)" 188 Q X 189 PTR(NAME) ; -- Returns pointer to OR GTX NAME 190 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) 191 ; 192 ISINPMED(IFN) ; 193 N PKG,RESULT,Y 194 I 'ORWMODE S PKG=$P($G(^ORD(101.41,IFN,0)),U,7) 195 E S PKG=$P($G(^OR(100,+IFN,0)),U,14) 196 S Y=$$GET1^DIQ(9.4,+PKG_",",1) 197 S RESULT=$S($E(Y,1,3)="PSJ":1,1:0) 198 Q RESULT 199 ; 200 ISMED(IFN) ; return 1 if pharmacy order dlg used 201 N PKG 202 I 'ORWMODE S PKG=$P($G(^ORD(101.41,IFN,0)),U,7) 203 E S PKG=$P($G(^OR(100,+IFN,0)),U,14) 204 Q $$NMSP^ORCD(PKG)="PS" 205 SITEVAL() ;return 1 if site does want the reason for study to carry through from past orders of this ordering session 206 I $$GET^XPAR("ALL","OR RA RFS CARRY ON")=0 Q 0 207 Q 1 208 SVRPC(RET,X) ;RPC FOR SITEVAL 209 S RET=$$SITEVAL 210 Q 1 ORWDXM1 ; SLC/KCM - Order Dialogs, Menus;2/19/03 ;11/15/2005 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,178,185,187,215**;Dec 17, 1997 3 BLDQRSP(LST,ORIT,FLDS,ISIMO) ; Build responses for an order 4 ; LST=QuickLevel^ResponseID(ORIT;$H)^Dialog^Type^FormID^DGrp 5 ; LST(n)=verify text or reject text 6 ; ORIT= ptr to 101.41 for quick order, 100 for copy 7 ; 1 2 3 4 5 6 7 8 11-20 8 ; FLDS=DFN^LOC^ORNP^INPT^SEX^AGE^EVENT^SC%^^^Key Variables... 9 ; ORIT=+ORIT: ptr to 101.41, $E(ORIT)=C: copy $E(ORIT)=X: change 10 ; !! SHOULD CHECK for PRE-CPRS ORDERS (treat as text?) 11 K ^TMP("ORWDXMQ",$J) 12 N ORWMODE ; 0:Dialog,Quick 1:copy order 2:change order 13 N TEMPCAT ; patient category from DPT file 14 N ISXFER ; Transfer order? 15 N ORIMO ;If IMO(inpatient medication on outpatient) 16 N TEMPORIT 17 S ORIMO=$G(ISIMO) 18 S ORWMODE=0,ISXFER="" 19 S:$E(ORIT)="C" ORWMODE=1 S:$E(ORIT)="T" ORWMODE=1,ISXFER=";T" ;treat xfer as copy for now 20 S:$E(ORIT)="X" ORWMODE=2 21 S TEMPORIT=ORIT 22 I ORWMODE S ORIT=$E(ORIT,2,999) 23 S LST(0)="" 24 D CHKDSBL^ORWDXM3(.LST,ORIT,ORWMODE) Q:+LST(0)=8 ;disable 25 D CHKVACT^ORWDXM3(.LST,ORIT,ORWMODE,$P(FLDS,U,3)) Q:+LST(0)=8 ;action 26 I ORWMODE=1 D CHKCOPY^ORWDXM3(.LST,ORIT,FLDS) Q:+LST(0)=8 ;no copy 27 I ORWMODE=2 D BLD4CHG^ORWDXM3(.LST,ORIT,FLDS) Q ;change 28 I 'ORWMODE,($P(^ORD(101.41,+ORIT,0),U,4)="D"),'($O(^DIC(9.4,"C","OR",0))[$P(^ORD(101.41,+ORIT,0),U,7)) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER) Q 29 ;radilogy vars 30 N ORIMTYPE 31 ;blood bank vars 32 N ORCOMP,ORTAS 33 ;lab vars 34 N LRFZX,LRFSAMP,LRFSPEC,LRFDATE,LRFURG,LRFSCH 35 N ORTIME,ORCOLLCT,ORMAX,ORTEST,ORIMTIME,ORSMAX,ORSTMS,ORSCH 36 ;pharmacy vars 37 N PSJNOPC,ORMORE,ORINPT,ORXNP,ORSCHED,ORQTY,ORNOUNS,ORXNP,OREFILLS 38 N ORCOMPLX,ORQTY,ORCOPAY,ORDRUG,ORWPSPIK,ORWPSWRG,ORSD,ORDSUP,ORWP94 39 ;dietetics vars 40 N ORPARAM,ORNPO,ORTIME,ORMEAL,ORTRAY,ORDATE 41 ;consults vars 42 N GMRCNOPD,GMRCNOAT,GMRCREAF 43 ; setup general env 44 N ORTYPE,ORVP,ORL,ORNP,ORSEX,ORAGE,ORWARD,OREVENT,ORDIV,ORSC,KEYVAR 45 N ORDG,ORDIALOG,ORCAT,FIRST,ORQUIT,X,ORTRAIL,ORLEAD,RSPREF,AUTOACK 46 N OREVNTYP 47 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0 48 S ORVP=$P(FLDS,U,1)_";DPT(",ORNP=+$P(FLDS,U,3),ORSC=$P(FLDS,U,8) 49 S ORL=$P(FLDS,U,2)_";SC(",ORL(2)=ORL 50 S ORSEX=$P(FLDS,U,5),ORAGE=$P(FLDS,U,6),ORTYPE="Q",FIRST=1 51 I $P(FLDS,U,4),$G(^SC(+ORL,42)) S ORWARD=+^SC(+ORL,42) 52 I $L($P(FLDS,U,7)) D 53 . S OREVENT=$P(FLDS,U,7) 54 . S OREVNTYP=$P(OREVENT,";",2) 55 . S OREVENT("TS")=$P(OREVENT,";",3) 56 . S OREVENT("EFFECTIVE")=$P(OREVENT,";",4) 57 . S OREVENT=+$P(OREVENT,";",1) 58 I 'ORWMODE D 59 . D SETKEYV^ORWDXM3($P(FLDS,U,11,20)) ; from menu path 60 . S KEYVAR=$$KEYVAR^ORWDXM3(ORIT) ; from entry action 61 . D SETKEYV^ORWDXM3(KEYVAR) 62 K ^TMP("ORWORD",$J) 63 ; init return record based on auto-accept 64 I ORWMODE S LST(0)="2^"_ORIT ;verify on copy 65 E S LST(0)=+$P($G(^ORD(101.41,ORIT,5)),U,8)_U_ORIT 66 S TEMPCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O") 67 I TEMPCAT="I",+$P(FLDS,U,4)=1,$E(TEMPORIT)="C",$P($G(^ORD(100.98,$P($G(^OR(100,+ORIT,0)),U,11),0)),U)="OUTPATIENT MEDICATIONS" S TEMPCAT="O" 68 I $L($G(OREVNTYP)) D 69 . S ORCAT=$S(OREVNTYP="A":"I",OREVNTYP="T":"I",OREVNTYP="O":TEMPCAT,OREVNTYP="M":TEMPCAT,OREVNTYP="C":TEMPCAT,1:"O") I $G(OREVENT) D 70 .. N X S X=$$EVT^OREVNTX(OREVENT),X=$P($G(^ORD(100.5,+X,0)),U,7) 71 .. I OREVNTYP="T",X,X<4 S ORCAT="O" ;To pass=outpt 72 .. I OREVNTYP="D",X=41 S ORCAT="I" ;From ASIH=inpt 73 E S ORCAT=TEMPCAT 74 D SETUP^ORWDXM4 Q:+LST(0)=8 75 S X=$S($G(ORWP94):"OR GTX START DATE/TIME",1:"OR GTX START DATE") 76 I ORWMODE,(ORDG=+$O(^ORD(100.98,"B","O RX",0))) K ORDIALOG($$PTR^ORCD(X),1) 77 D SETUPS^ORWDXM4 ; moved to save space 78 Q:+LST(0)=8 79 I $G(ORQUIT) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR) Q 80 N SEQ,DA,XCODE,MUSTASK,PROMPT,INST,KEY,IVFID 81 S IVFID=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0)) 82 S AUTOACK=$S($D(ORWPSWRG):0,1:1) 83 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:'SEQ D 84 . S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D 85 . . ; skip if this is a child prompt 86 . . I $P(^ORD(101.41,+ORDIALOG,10,DA,0),U,11) Q 87 . . ; set default for prompt, see if needs to be interactive 88 . . S PROMPT=$P(^ORD(101.41,+ORDIALOG,10,DA,0),U,2) 89 . . D SETITEM(DA,PROMPT,1,.MUSTASK) 90 . . I MUSTASK S AUTOACK=0 Q 91 . . ; iterate through the child items if parent and edit only 92 . . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) 93 . . N CSEQ,CDA,CPROMPT,INST,ORQUIT 94 . . S CSEQ=0 F S CSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ)) Q:'CSEQ D Q:$G(ORQUIT) 95 . . . S CDA=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ,0)) 96 . . . S CPROMPT=$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,2) 97 . . . ; if req & no instances then need interaction 98 . . . I $P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6),ORDIALOG'=IVFID,'$O(ORDIALOG(CPROMPT,0)) S AUTOACK=0 99 . . . S INST=0 F S INST=$O(ORDIALOG(CPROMPT,INST)) Q:'INST D 100 . . . . N ORASK D VBASK^ORWDXM4(INST) ; set ORASK for VBECS 101 . . . . ; set default for each child prompt, if necessary 102 . . . . D SETITEM(CDA,CPROMPT,INST,.MUSTASK) 103 . . . . ; if no val & child prmpt required then need interaction 104 . . . . I MUSTASK,$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6) S AUTOACK=0 105 N IVDLG 106 S IVDLG=$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0)) 107 I $$ISMED(ORIT),(ORDIALOG'=IVDLG),(ORCAT="I") D 108 . F P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED" K ORDIALOG($$PTR(P),1) 109 S KEY=$S(ORWMODE:"C",1:"")_ORIT_"-"_$P($H,",",2),SEQ=0 110 S PROMPT=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:'PROMPT D 111 . I '$D(^ORD(101.41,ORDIALOG,10,"D",PROMPT)) K ORDIALOG(PROMPT) Q 112 . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D 113 . . S SEQ=SEQ+1,^TMP("ORWDXMQ",$J,KEY,SEQ,0)=U_PROMPT_U_INST 114 . . ; save word processing value 115 . . I $E(ORDIALOG(PROMPT,0))="W",$L(ORDIALOG(PROMPT,INST)) D 116 . . . M ^TMP("ORWDXMQ",$J,KEY,SEQ,2)=@ORDIALOG(PROMPT,INST) 117 . . ; save other value types 118 . . E S ^TMP("ORWDXMQ",$J,KEY,SEQ,1)=ORDIALOG(PROMPT,INST) 119 I AUTOACK D 120 . I ORWMODE S AUTOACK=2 121 . I 'ORWMODE,($P(^ORD(101.41,ORIT,0),U,8)!'LST(0)) S AUTOACK=2 122 I ($$ISMED(ORIT)),'($$VALQO^ORWDXM3(ORIT)) S AUTOACK=0 123 I ORIMO,ORWMODE S AUTOACK=2 124 ; added to accept Herbal/OTC/NonVA Med quick orders 125 I $L($G(^ORD(101.41,+ORIT,0))),($P(^ORD(100.98,$P(^ORD(101.41,+ORIT,0),U,5),0),U,3)="NV RX"),($P($G(^ORD(101.41,+ORIT,5)),U,8)) S AUTOACK=1 126 ;I $G(^OR(100,+ORIT,0)),$P($G(^ORD(101.41,+$P(^OR(100,+ORIT,0),U,5),0)),U,8),$D(ORDIALOG("B","HERBAL/OTC/NON VA MEDICATION")) S AUTOACK=1 127 I AUTOACK=2 D VERTXT^ORWDXM2 128 S LST(0)=AUTOACK_U_KEY_U_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR) 129 I $P(LST(0),U,4)="D" S $P(LST(0),U,4)="Q" 130 I ORWMODE=1 S $P(LST(0),U,4)="C" 131 K ^TMP("ORWORD",$J) 132 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J) 133 Q 134 SETITEM(DA,PROMPT,INST,MUSTASK) ; set default value & return if must prompt 135 N EDITONLY,Y,XCODE 136 S MUSTASK=0,EDITONLY=0 137 I $D(^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)) D 138 . I $E(ORDIALOG(PROMPT,0))="W" D 139 . . S ^TMP("ORWORD",$J,PROMPT,INST,1,0)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT) 140 . . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" 141 . E S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT) 142 I $D(^TMP("ORWDHTM",$J,ORIT,PROMPT)) D 143 . S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORIT,PROMPT) 144 . ; NEED TO CLEAN UP ^TMP("ORWDHTM") after process order set!!! 145 ; 146 ; skip if a value already exists for this prompt and not WP 147 Q:$D(ORDIALOG(PROMPT,INST))&($E(ORDIALOG(PROMPT,0))'="W") 148 ; execute default action if no value in QO, checking EDITONLY afterwards 149 I '$D(ORDIALOG(PROMPT,INST)) D 150 . I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,DA,8))>9 D 151 . . M ^TMP("ORWORD",$J,PROMPT,INST)=^ORD(101.41,+ORDIALOG,10,DA,8) 152 . . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" 153 . E D 154 . . S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,7))) 155 . . I $L(XCODE) X XCODE S:$D(Y) ORDIALOG(PROMPT,INST)=Y 156 Q:$G(EDITONLY) 157 I 'ORWMODE,$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,8) Q 158 I ORWMODE,($P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,9)'["W"),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6)!$D(ORDIALOG(PROMPT,INST)) Q 159 I 'ORWMODE,LST(0),$D(ORDIALOG(PROMPT,INST)),($E(ORDIALOG(PROMPT,0))="W") Q 160 I 'ORWMODE,LST(0),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6) Q 161 S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,3))) 162 I $L(XCODE) X XCODE Q:'$T 163 S MUSTASK=1 164 Q 165 SUBCODE(X) ; substitute code 166 I X["$$REQDCOMM^ORCDLR" Q "I $$LRRQCM^ORWDXM2" 167 I X["$$ASKSAMP^ORCDLR" Q "I $$LRASMP^ORWDXM2" 168 I X["$$SCHEDULD^ORCDRA1" Q "I $$SCHEDULD^ORWDXM2" 169 I X["(^PSX(550,""C"")" Q "S Y=$E($$DEFPICK^ORWDPS32) K:'$L(Y) Y" 170 I X["I $$ASKURG^ORCDVBEC" Q "I 1" 171 I X["K:$G(ORASK)" Q "I $G(ORASK)" 172 Q X 173 PTR(NAME) ; -- Returns pointer to OR GTX NAME 174 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) 175 ; 176 ISMED(IFN) ; return 1 if pharmacy order dlg used 177 N PKG 178 I 'ORWMODE S PKG=$P($G(^ORD(101.41,IFN,0)),U,7) 179 E S PKG=$P($G(^OR(100,+IFN,0)),U,14) 180 Q $$NMSP^ORCD(PKG)="PS" -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM2.m
r613 r623 1 ORWDXM2 ; SLC/KCM - Quick Orders ;04/25/2007 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,132,158,187,195,215,243**;Dec 17, 1997;Build 242 3 ; 4 ADMTIME(ORDLOC,PATLOC,ENCLOC,DELAY,ISIMO) ; 5 N ADMLOC,INST,SCHLOC,SCHTYPE 6 S ADMLOC=+$P($G(ORDIALOG("B","ADMINISTRATION TIMES")),U,2) 7 I ADMLOC>0,ORDLOC>0,PATLOC'=ORDLOC D Q 8 .S INST=0 F S INST=$O(ORDIALOG(ADMLOC,INST)) Q:+INST'>0 D 9 ..S ORDIALOG(ADMLOC,INST)="" 10 I ADMLOC>0,$S(ENCLOC'=PATLOC:1,ISIMO:1,DELAY:1,1:0) D Q 11 .S INST=0 F S INST=$O(ORDIALOG(ADMLOC,INST)) Q:+INST'>0 D 12 ..S ORDIALOG(ADMLOC,INST)="" 13 S SCHLOC=+$P($G(ORDIALOG("B","SCHEDULE TYPE")),U,2) Q:SCHLOC'>0 14 S INST=0 F S INST=$O(ORDIALOG(SCHLOC,INST)) Q:+INST'>0 D 15 .S SCHTYP=$G(ORDIALOG(SCHLOC,INST)) Q:SCHTYP="" 16 .I $S(SCHTYP="P":1,SCHTYP="O":1,SCHTYP="OC":1,1:0),ADMLOC>0 S ORDIALOG(ADMLOC,INST)="" 17 Q 18 ; 19 CLRRCL(OK) ; clear ORECALL 20 S OK=1 21 K ^TMP("ORECALL",$J),^TMP("ORWDXMQ",$J) 22 Q 23 VERTXT ; set verify text for order 24 N SEQ,DA,X,PROMPT,MULT,CHILD,INST,TITLE,TEMP,ILST,SPACES 25 N ISADMIN 26 S ILST=0,$P(SPACES," ",31)="" 27 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0 D 28 . S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D 29 . . S X0=$G(^ORD(101.41,+ORDIALOG,10,DA,0)) 30 . . S ISADMIN=$S(+OREVENT>0:0,ISIMO=1:0,$P($G(^ORD(101.41,$P(X0,U,2),0)),U)="OR GTX ADMIN TIMES":1,1:0) 31 . . I ISADMIN=1,ORDLOC>0,ORDLOC'=PATLOC Q 32 . . I $P(X0,U,9)["*",ISADMIN=0 Q 33 . . S PROMPT=$P(X0,U,2),MULT=$P(X0,U,7),CHILD=$P(X0,U,11) I CHILD,ISADMIN=0 Q 34 . . Q:'PROMPT S INST=$O(ORDIALOG(PROMPT,0)) Q:'INST ; no values 35 . . S TITLE=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A")) 36 . . I $E(ORDIALOG(PROMPT,0))="W" D 37 . . . N IWP,WP,CNT 38 . . . S IWP=0,CNT=0 39 . . . F S IWP=$O(^TMP("ORWORD",$J,PROMPT,INST,IWP)) Q:'IWP D 40 . . . . S CNT=CNT+1,WP(CNT)=^TMP("ORWORD",$J,PROMPT,INST,IWP,0) 41 . . . I CNT=1 S ILST=ILST+1,LST(ILST)=$J(TITLE,30)_WP(1) 42 . . . I CNT>1 D 43 . . . . S ILST=ILST+1,LST(ILST)=TITLE,IWP=0 44 . . . . F S IWP=$O(WP(IWP)) Q:'IWP S ILST=ILST+1,LST(ILST)=WP(IWP) 45 . . E D 46 . . . S TEMP=$$ITEM^ORCDLG(PROMPT,INST) I TEMP="" Q 47 . . . S ILST=ILST+1,LST(ILST)=$J(TITLE,30) 48 . . . ;S LST(ILST)=LST(ILST)_$$ITEM^ORCDLG(PROMPT,INST) 49 . . . S LST(ILST)=LST(ILST)_TEMP 50 . . Q:'MULT Q:'$O(ORDIALOG(PROMPT,INST)) ; done 51 . . F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 S ILST=ILST+1,LST(ILST)=SPACES_$$ITEM^ORCDLG(PROMPT,INST) 52 D DISPLAY^ORWDBA3 ;for display of Billing Aware data from orig order 53 Q 54 RA ; setup environment for radiology 55 ; -- get imaging types based on display group of quick order and 56 ; setup list of imaging locations based on imaging type 57 N ORY,ITYPE,IFN,CNT,ORIMLOC,PROMPT 58 S ORDIV=$$DIV^ORCDRA1,ITYPE=$P($G(^ORD(100.98,+ORDG,0)),U,3) 59 S ORIMTYPE=$O(^RA(79.2,"C",ITYPE,0)) 60 D EN4^RAO7PC1(ITYPE,"ORY") 61 S (IFN,CNT)=0 F S IFN=$O(ORY(IFN)) Q:IFN'>0 D 62 . S CNT=CNT+1,ORIMLOC(CNT)=ORY(IFN),ORIMLOC("B",$P(ORY(IFN),U,2))=IFN 63 I '$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q"),CNT>1 K ORIMLOC 64 E S ORIMLOC=CNT_"^1" 65 S PROMPT=$O(^ORD(101.41,"B","OR GTX IMAGING LOCATION",0)) 66 I $G(ORIMLOC) M ORDIALOG(PROMPT,"LIST")=ORIMLOC 67 Q 68 LR ; setup environment for lab 69 ; -- setup ORTIME, ORIMTIME & ORTEST arrays 70 ; setup ORMAX, ORDG, & ORCOLLCT variables 71 N PROMPT,INST,EDITONLY 72 D GETIMES^ORCDLR1 ; sets up ORTIME and ORIMTIME arrays 73 S ORMAX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q") 74 S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)),INST=1 75 D LRTEST ; sets up ORTEST array and ORDG 76 S PROMPT=$O(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0)) 77 I $D(ORDIALOG(PROMPT,1)) S ORCOLLCT=ORDIALOG(PROMPT,1) I 1 78 E S EDITONLY=0,ORCOLLCT=$$COLLTYPE^ORCDLR1 79 I ORCOLLCT="I" D 80 . S PROMPT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) 81 . D LRICTMOK 82 S PROMPT=$O(^ORD(101.41,"B","OR GTX ADMIN SCHEDULE",0)) 83 I $D(ORDIALOG(PROMPT,1)) S ORSCH=ORDIALOG(PROMPT,1) 84 Q 85 LRTEST ; -- Setup ORTEST() array of ordering parameters (copied from ORCDLR) 86 N OI,TST,DG 87 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI 88 I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST 89 S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB" 90 S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG 91 Q 92 LRRQCM() ; return true if lab test has required comments 93 I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 1 ; edit via WP 94 N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM,OI,TST 95 S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN") 96 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI 0 97 I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST 98 S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0)) 99 S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6) 100 S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19) 101 Q REQDCOMM 102 LRASMP() ; return true to ask collection sample (from ASKSAMP^ORCDLR) 103 N DEFSAMP,SAMP0 104 S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0)) 105 I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) Q 0 106 I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask 107 I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask 108 I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice 109 Q 1 110 LRICTMOK ; 111 Q:'$D(ORDIALOG(PROMPT,1)) 112 N ORY 113 D VALDT^ORWU(.ORY,ORDIALOG(PROMPT,1)) 114 I +$$VALID^LR7OV4(DUZ(2),ORY)=0 S ORDIALOG(PROMPT,1)="" 115 Q 116 DO ; setup environment for diet order 117 ; partially copied from EN^ORCDFH 118 I ORCAT'="I" D Q 119 . S ORQUIT=1 120 . S LST(0)="8^0" 121 . S LST(.5)="This type of diet may be entered for inpatients only." 122 D EN^FHWOR8(+ORVP,.ORPARAM) ; set FH ordering parameters 123 S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now 124 N PROMPT,OI ; set NPO flag if NPO diet 125 S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) 126 S OI=+$G(ORDIALOG(PROMPT,1)) 127 S ORNPO=($P($G(^ORD(101.43,OI,0)),U)="NPO") 128 S PROMPT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) 129 S X=$G(ORDIALOG(PROMPT,1)) I $L(X) D CNV^ORCDFH1 S ORDIALOG(PROMPT,1)=$G(X) 130 Q 131 EL ; setup environment for early/late tray 132 D EN^FHWOR8(+ORVP,.ORPARAM) ; set FH ordering parameters 133 S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now 134 D EN2^ORCDFH ; setup ORTIME array 135 N PROMPT ; set ORMEAL,ORTRAY 136 S PROMPT=$O(^ORD(101.41,"B","OR GTX MEAL",0)) 137 I $D(ORDIALOG(PROMPT,1)) S ORMEAL=ORDIALOG(PROMPT,1) 138 S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) 139 I $D(ORDIALOG(PROMPT,1)) S ORTRAY=ORDIALOG(PROMPT,1) 140 Q 141 UD ; setup environment for unit dose med 142 I $G(ORWP94) G PS^ORWDPS3 ; if patch 94 installed 143 ; 144 D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds 145 N PROMPT,OI 146 S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) 147 I $D(ORDIALOG(PROMPT,1)) S OI=ORDIALOG(PROMPT,1) D MEDACTV(1) Q:$G(ORQUIT) 148 D INSTR^ORCDPS(OI) ; sets up instructions, routes, etc. 149 D CHOICES^ORCDPS("U") ; gets list of dispense drugs 150 Q 151 IV ; setup environment for IV fluid 152 D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds 153 ; sets up list of volumes if only one solution 154 ; otherwise, let the dialog go interactive 155 N PROMPT,INST,CNT,OI 156 S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) 157 S (CNT,INST)=0 158 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D Q:$G(ORQUIT) 159 . S CNT=CNT+1 160 . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(3) ; check active solutions 161 I CNT=1 S INST=1 D VOLUME^ORCDPSIV 162 S PROMPT=$O(^ORD(101.41,"B","OR GTX ADDITIVE",0)) 163 S INST=0 164 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D Q:$G(ORQUIT) 165 . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(4) ; check active additives 166 Q 167 OP ; setup environment for outpatient pharmacy 168 I $G(ORWP94) G PS^ORWDPS3 ; if patch 94 installed 169 ; 170 D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds 171 N PROMPT,INST,CNT,OI 172 S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)),OI=0 173 I $D(ORDIALOG(PROMPT,1)) S OI=$G(ORDIALOG(PROMPT,1)) D MEDACTV(2) Q:$G(ORQUIT) 174 D:+OI INSTR^ORCDPS(OI) ; sets up instructions, routes, etc. 175 D CHOICES^ORCDPS("O") ; gets list of dispense drugs 176 ; get defaults for drug, refills if only one dispense drug 177 S PROMPT=$O(^ORD(101.41,"B","OR GTX DISPENSE DRUG",0)) 178 S (CNT,INST)=0 179 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST S CNT=CNT+1 180 I CNT=1 D 181 . S ORDRUG=+$G(ORDIALOG(PROMPT,1)),ORCOMPLX=0 182 . S OREFILLS=$P($G(ORDIALOG(PROMPT,"LIST","D",ORDRUG)),U,3) 183 . S:'$L(OREFILLS) OREFILLS=11 184 E S ORCOMPLX=1,OREFILLS=11 ; force interactive on complex order 185 S ORCOPAY=1 ; ask SC if can't determine copay 186 I $G(ORDRUG),$L($T(ASKSC^ORCDPS)) S ORCOPAY=$$ASKSC^ORCDPS 187 Q 188 AUTHMED ; sets ORQUIT if not authorized to write meds 189 N NOAUTH,NAME 190 D AUTH^ORWDPS32(.NOAUTH,ORNP) 191 I +NOAUTH D 192 . S ORQUIT=1 193 . S LST(0)="8^0" 194 . S NAME=$P($G(^VA(200,+ORNP,20)),U,2) 195 . I '$L(NAME) S NAME=$P($G(^VA(200,+ORNP,0)),U,1) 196 . S LST(.5)=NAME_" is not authorized to write med orders." 197 Q 198 MEDACTV(USAGE) ; sets ORQUIT if the orderable item is not active for a med 199 Q:'$G(OI) S USAGE=+$G(USAGE) 200 I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D Q 201 . S ORQUIT=1,LST(0)="8^0" 202 . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." 203 I USAGE,'$P($G(^ORD(101.43,OI,"PS")),U,USAGE) D Q 204 . S ORQUIT=1,LST(0)="8^0" 205 . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" may not be ordered as an "_$S(USAGE=1:"inpatient medication",USAGE=2:"outpatient medication",USAGE=3:"IV solution",1:"IV additive")_" anymore." 206 Q 207 SCHEDULD() ; Is patient scheduled for PREOP (Imaging) 208 I $G(ORDIALOG(PROMPT,1)) Q 1 ; don't ask - already have date 209 E Q 0 210 Q 1 ORWDXM2 ; SLC/KCM - Quick Orders ;11/25/02 09:49 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,132,158,187,195,215**;Dec 17, 1997 3 ; 4 CLRRCL(OK) ; clear ORECALL 5 S OK=1 6 K ^TMP("ORECALL",$J),^TMP("ORWDXMQ",$J) 7 Q 8 VERTXT ; set verify text for order 9 N SEQ,DA,X,PROMPT,MULT,CHILD,INST,TITLE,ILST,SPACES 10 S ILST=0,$P(SPACES," ",31)="" 11 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0 D 12 . S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D 13 . . S X0=$G(^ORD(101.41,+ORDIALOG,10,DA,0)) 14 . . Q:$P(X0,U,9)["*" ; hidden prompt 15 . . S PROMPT=$P(X0,U,2),MULT=$P(X0,U,7),CHILD=$P(X0,U,11) Q:CHILD 16 . . Q:'PROMPT S INST=$O(ORDIALOG(PROMPT,0)) Q:'INST ; no values 17 . . S TITLE=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A")) 18 . . I $E(ORDIALOG(PROMPT,0))="W" D 19 . . . N IWP,WP,CNT 20 . . . S IWP=0,CNT=0 21 . . . F S IWP=$O(^TMP("ORWORD",$J,PROMPT,INST,IWP)) Q:'IWP D 22 . . . . S CNT=CNT+1,WP(CNT)=^TMP("ORWORD",$J,PROMPT,INST,IWP,0) 23 . . . I CNT=1 S ILST=ILST+1,LST(ILST)=$J(TITLE,30)_WP(1) 24 . . . I CNT>1 D 25 . . . . S ILST=ILST+1,LST(ILST)=TITLE,IWP=0 26 . . . . F S IWP=$O(WP(IWP)) Q:'IWP S ILST=ILST+1,LST(ILST)=WP(IWP) 27 . . E D 28 . . . S ILST=ILST+1,LST(ILST)=$J(TITLE,30) 29 . . . S LST(ILST)=LST(ILST)_$$ITEM^ORCDLG(PROMPT,INST) 30 . . Q:'MULT Q:'$O(ORDIALOG(PROMPT,INST)) ; done 31 . . F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 S ILST=ILST+1,LST(ILST)=SPACES_$$ITEM^ORCDLG(PROMPT,INST) 32 D DISPLAY^ORWDBA3 ;for display of Billing Aware data from orig order 33 Q 34 RA ; setup environment for radiology 35 ; -- get imaging types based on display group of quick order and 36 ; setup list of imaging locations based on imaging type 37 N ORY,ITYPE,IFN,CNT,ORIMLOC,PROMPT 38 S ORDIV=$$DIV^ORCDRA1,ITYPE=$P($G(^ORD(100.98,+ORDG,0)),U,3) 39 S ORIMTYPE=$O(^RA(79.2,"C",ITYPE,0)) 40 D EN4^RAO7PC1(ITYPE,"ORY") 41 S (IFN,CNT)=0 F S IFN=$O(ORY(IFN)) Q:IFN'>0 D 42 . S CNT=CNT+1,ORIMLOC(CNT)=ORY(IFN),ORIMLOC("B",$P(ORY(IFN),U,2))=IFN 43 I '$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q"),CNT>1 K ORIMLOC 44 E S ORIMLOC=CNT_"^1" 45 S PROMPT=$O(^ORD(101.41,"AB","OR GTX IMAGING LOCATION",0)) 46 I $G(ORIMLOC) M ORDIALOG(PROMPT,"LIST")=ORIMLOC 47 Q 48 LR ; setup environment for lab 49 ; -- setup ORTIME, ORIMTIME & ORTEST arrays 50 ; setup ORMAX, ORDG, & ORCOLLCT variables 51 N PROMPT,INST,EDITONLY 52 D GETIMES^ORCDLR1 ; sets up ORTIME and ORIMTIME arrays 53 S ORMAX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q") 54 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)),INST=1 55 D LRTEST ; sets up ORTEST array and ORDG 56 S PROMPT=$O(^ORD(101.41,"AB","OR GTX COLLECTION TYPE",0)) 57 I $D(ORDIALOG(PROMPT,1)) S ORCOLLCT=ORDIALOG(PROMPT,1) I 1 58 E S EDITONLY=0,ORCOLLCT=$$COLLTYPE^ORCDLR1 59 I ORCOLLCT="I" D 60 . S PROMPT=$O(^ORD(101.41,"AB","OR GTX START DATE/TIME",0)) 61 . D LRICTMOK 62 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ADMIN SCHEDULE",0)) 63 I $D(ORDIALOG(PROMPT,1)) S ORSCH=ORDIALOG(PROMPT,1) 64 Q 65 LRTEST ; -- Setup ORTEST() array of ordering parameters (copied from ORCDLR) 66 N OI,TST,DG 67 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI 68 I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST 69 S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB" 70 S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG 71 Q 72 LRRQCM() ; return true if lab test has required comments 73 I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 1 ; edit via WP 74 N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM,OI,TST 75 S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN") 76 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI 0 77 I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST 78 S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0)) 79 S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6) 80 S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19) 81 Q REQDCOMM 82 LRASMP() ; return true to ask collection sample (from ASKSAMP^ORCDLR) 83 N DEFSAMP,SAMP0 84 S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0)) 85 I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) Q 0 86 I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask 87 I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask 88 I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice 89 Q 1 90 LRICTMOK ; 91 Q:'$D(ORDIALOG(PROMPT,1)) 92 N ORY 93 D VALDT^ORWU(.ORY,ORDIALOG(PROMPT,1)) 94 I +$$VALID^LR7OV4(DUZ(2),ORY)=0 S ORDIALOG(PROMPT,1)="" 95 Q 96 DO ; setup environment for diet order 97 ; partially copied from EN^ORCDFH 98 I ORCAT'="I" D Q 99 . S ORQUIT=1 100 . S LST(0)="8^0" 101 . S LST(.5)="This type of diet may be entered for inpatients only." 102 D EN^FHWOR8(+ORVP,.ORPARAM) ; set FH ordering parameters 103 S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now 104 N PROMPT,OI ; set NPO flag if NPO diet 105 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) 106 S OI=+$G(ORDIALOG(PROMPT,1)) 107 S ORNPO=($P($G(^ORD(101.43,OI,0)),U)="NPO") 108 Q 109 EL ; setup environment for early/late tray 110 D EN^FHWOR8(+ORVP,.ORPARAM) ; set FH ordering parameters 111 S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now 112 D EN2^ORCDFH ; setup ORTIME array 113 N PROMPT ; set ORMEAL,ORTRAY 114 S PROMPT=$O(^ORD(101.41,"AB","OR GTX MEAL",0)) 115 I $D(ORDIALOG(PROMPT,1)) S ORMEAL=ORDIALOG(PROMPT,1) 116 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) 117 I $D(ORDIALOG(PROMPT,1)) S ORTRAY=ORDIALOG(PROMPT,1) 118 Q 119 UD ; setup environment for unit dose med 120 I $G(ORWP94) G PS^ORWDPS3 ; if patch 94 installed 121 ; 122 D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds 123 N PROMPT,OI 124 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) 125 I $D(ORDIALOG(PROMPT,1)) S OI=ORDIALOG(PROMPT,1) D MEDACTV(1) Q:$G(ORQUIT) 126 D INSTR^ORCDPS(OI) ; sets up instructions, routes, etc. 127 D CHOICES^ORCDPS("U") ; gets list of dispense drugs 128 Q 129 IV ; setup environment for IV fluid 130 D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds 131 ; sets up list of volumes if only one solution 132 ; otherwise, let the dialog go interactive 133 N PROMPT,INST,CNT,OI 134 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) 135 S (CNT,INST)=0 136 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D Q:$G(ORQUIT) 137 . S CNT=CNT+1 138 . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(3) ; check active solutions 139 I CNT=1 S INST=1 D VOLUME^ORCDPSIV 140 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ADDITIVE",0)) 141 S INST=0 142 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D Q:$G(ORQUIT) 143 . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(4) ; check active additives 144 Q 145 OP ; setup environment for outpatient pharmacy 146 I $G(ORWP94) G PS^ORWDPS3 ; if patch 94 installed 147 ; 148 D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds 149 N PROMPT,INST,CNT,OI 150 S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)),OI=0 151 I $D(ORDIALOG(PROMPT,1)) S OI=$G(ORDIALOG(PROMPT,1)) D MEDACTV(2) Q:$G(ORQUIT) 152 D:+OI INSTR^ORCDPS(OI) ; sets up instructions, routes, etc. 153 D CHOICES^ORCDPS("O") ; gets list of dispense drugs 154 ; get defaults for drug, refills if only one dispense drug 155 S PROMPT=$O(^ORD(101.41,"AB","OR GTX DISPENSE DRUG",0)) 156 S (CNT,INST)=0 157 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST S CNT=CNT+1 158 I CNT=1 D 159 . S ORDRUG=+$G(ORDIALOG(PROMPT,1)),ORCOMPLX=0 160 . S OREFILLS=$P($G(ORDIALOG(PROMPT,"LIST","D",ORDRUG)),U,3) 161 . S:'$L(OREFILLS) OREFILLS=11 162 E S ORCOMPLX=1,OREFILLS=11 ; force interactive on complex order 163 S ORCOPAY=1 ; ask SC if can't determine copay 164 I $G(ORDRUG),$L($T(ASKSC^ORCDPS)) S ORCOPAY=$$ASKSC^ORCDPS 165 Q 166 AUTHMED ; sets ORQUIT if not authorized to write meds 167 N NOAUTH,NAME 168 D AUTH^ORWDPS32(.NOAUTH,ORNP) 169 I +NOAUTH D 170 . S ORQUIT=1 171 . S LST(0)="8^0" 172 . S NAME=$P($G(^VA(200,+ORNP,20)),U,2) 173 . I '$L(NAME) S NAME=$P($G(^VA(200,+ORNP,0)),U,1) 174 . S LST(.5)=NAME_" is not authorized to write med orders." 175 Q 176 MEDACTV(USAGE) ; sets ORQUIT if the orderable item is not active for a med 177 Q:'$G(OI) S USAGE=+$G(USAGE) 178 I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D Q 179 . S ORQUIT=1,LST(0)="8^0" 180 . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." 181 I USAGE,'$P($G(^ORD(101.43,OI,"PS")),U,USAGE) D Q 182 . S ORQUIT=1,LST(0)="8^0" 183 . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" may not be ordered as an "_$S(USAGE=1:"inpatient medication",USAGE=2:"outpatient medication",USAGE=3:"IV solution",1:"IV additive")_" anymore." 184 Q 185 SCHEDULD() ; Is patient scheduled for PREOP (Imaging) 186 I $G(ORDIALOG(PROMPT,1)) Q 1 ; don't ask - already have date 187 E Q 0 188 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM3.m
r613 r623 1 ORWDXM3 ; SLC/KCM/JLI - Quick Orders ;05/27/2008 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,185,187,190,195,215,243**;Dec 17, 1997;Build 242 3 ; 4 VALCOUNT(NAME,ORDIALOG) ; 5 N COUNT,IEN,NUM 6 S NUM=0,COUNT=0 7 S IEN=$P($G(ORDIALOG("B",NAME)),U,2) Q:IEN'>0 8 F S NUM=$O(ORDIALOG(IEN,NUM)) Q:+NUM'>0 S COUNT=COUNT+1 9 Q COUNT 10 ; 11 ISMISSFL(ORDIALOG,IVTYPE) ; 12 N ADDCNT,RESULT,STRCNT 13 S RESULT=0 14 S ADDCNT=$$VALCOUNT("ADDITIVE",.ORDIALOG) 15 S STRCNT=$$VALCOUNT("STRENGTH",.ORDIALOG) 16 I IVTYPE'="I",ADDCNT'=STRCNT S RESULT=1 17 I IVTYPE="I",ADDCNT=0 S RESULT=1 18 Q RESULT 19 ; 20 KEYVAR(DLG) ; Parse entry action for key variables & return in string 21 ; RV=CollTp^Samp^Spec^CollDt^Urg^Sched^NoComm^NoDiag^NoProv^NoRsn 22 N XCODE,RV,POS,Z 23 S XCODE=$G(^ORD(101.41,DLG,3)),RV="" 24 I '$L(XCODE) Q "" 25 S POS=$F(XCODE,"LRFZX=") I POS S $P(RV,U,1)=$$VALUE(XCODE,POS) 26 S POS=$F(XCODE,"LRFSAMP=") I POS S $P(RV,U,2)=$$VALUE(XCODE,POS) 27 S POS=$F(XCODE,"LRFSPEC=") I POS S $P(RV,U,3)=$$VALUE(XCODE,POS) 28 S POS=$F(XCODE,"LRFDATE=") I POS S $P(RV,U,4)=$$VALUE(XCODE,POS) 29 S POS=$F(XCODE,"LRFURG=") I POS S $P(RV,U,5)=$$VALUE(XCODE,POS) 30 S POS=$F(XCODE,"LRFSCH=") I POS S $P(RV,U,6)=$$VALUE(XCODE,POS) 31 S POS=$F(XCODE,"PSJNOPC=") I POS S $P(RV,U,7)=$$VALUE(XCODE,POS) 32 S POS=$F(XCODE,"GMRCNOPD=") I POS S $P(RV,U,8)=$$VALUE(XCODE,POS) 33 S POS=$F(XCODE,"GMRCNOAT=") I POS S $P(RV,U,9)=$$VALUE(XCODE,POS) 34 S POS=$F(XCODE,"GMRCREAF=") I POS S $P(RV,U,10)=$$VALUE(XCODE,POS) 35 S POS=$F(XCODE,"ORFORGET=") I POS D 36 . ; need to change this so that it is executed in SETKEYV so 37 . ; that it is executed each time menu is revisited 38 . N ORFORGET S ORFORGET=$$VALUE(XCODE,POS) 39 . I ORFORGET K ^TMP("ORECALL",$J,+ORFORGET) 40 . E K ^TMP("ORECALL",$J) 41 Q RV 42 VALUE(STR,BEG) ; Return value of "var=" (copied from ORCONVRT) 43 N X,Y,I S X=$E(STR,BEG,999),Y="" 44 S:$E(X)="""" X=$E(X,2,999) ; strip leading " 45 F I=1:1:$L(X) S Z=$E(X,I) Q:(Z=",")!(Z=" ")!(Z="""") S Y=Y_Z 46 Q $TR(Y,U,"") 47 ; 48 SETKEYV(X) ; Set the key variables based on contents of X 49 I $L($P(X,U,1)) S LRFZX=$P(X,U,1) 50 I $L($P(X,U,2)) S LRFSAMP=$P(X,U,2) 51 I $L($P(X,U,3)) S LRFSPEC=$P(X,U,3) 52 I $L($P(X,U,4)) S LRFDATE=$P(X,U,4) 53 I $L($P(X,U,5)) S LRFURG=$P(X,U,5) 54 I $L($P(X,U,6)) S LRFSCH=$P(X,U,6) 55 I $L($P(X,U,7)) S PSJNOPC=$P(X,U,7) 56 I $L($P(X,U,8)) S GMRCNOPD=$P(X,U,8) 57 I $L($P(X,U,9)) S GMRCNOAT=$P(X,U,9) 58 I $L($P(X,U,10)) S GMRCREAF=$P(X,U,10) 59 Q 60 DLGINFO(IEN,MODE) ; return information about a dialog 61 ; IEN=DlgIEN or ORIFN, MODE=0:Dlg,1:Copy,2:Change 62 ; RESULT=DlgIEN^DlgType^FormID^DGrp 63 ; If MODE="1;T",don't check "PS MEDS" for transfer order 64 ; PSMDGP=1: Unit/Dose Group 65 ; PSMDGP=2: OutPatient Group 66 N X0,DLGIEN,TYP,FID,DGRP,PSMDGP,ISXF 67 S PSMDGP=0,ISXF="" 68 S ISXF=$P(MODE,";",2) 69 S MODE=+MODE 70 S DLGIEN=IEN I MODE,(ISXF'="T") D 71 . S DLGIEN=+$P($G(^OR(100,+IEN,0)),U,5) 72 . I $P(^ORD(101.41,DLGIEN,0),U)="PS MEDS" D 73 . . N PTCAT S PTCAT=$P($G(^OR(100,+IEN,0)),U,12) 74 . . I PTCAT="I" S DLGIEN=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)),PSMDGP=1 75 . . I PTCAT="O" S DLGIEN=$O(^ORD(101.41,"B","PSO OERR",0)),PSMDGP=2 76 I MODE,(ISXF="T") S DLGIEN=+$P($G(^OR(100,+IEN,0)),U,5) 77 S X0=$G(^ORD(101.41,DLGIEN,0)),TYP=$P(X0,U,4),DGRP=$P(X0,U,5) 78 I MODE S DGRP=+$P($G(^OR(100,+IEN,0)),U,11) 79 ;JD NEW START 11/13/02 80 I DLGIEN=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) S PSMDGP=1 81 I DLGIEN=$O(^ORD(101.41,"B","PSO OERR",0)) S PSMDGP=2 82 ;JD NEW END 11/13/02 83 ; for copy or change, if the base dialog has changed, use it's info 84 I MODE,$G(ORDIALOG),(+DLGIEN'=+ORDIALOG),(PSMDGP=0) D 85 . S DLGIEN=+ORDIALOG,DGRP=$P(^ORD(101.41,+ORDIALOG,0),U,5) 86 D FORMID^ORWDXM(.FID,DLGIEN) 87 Q DLGIEN_U_TYP_U_FID_U_DGRP 88 ; 89 CHKDSBL(LST,ID,MODE) ; return message if dialog disabled 90 ; ID=DlgIEN or ORIFN, MODE=0:Dialog,1:Copy,2:Change 91 ; LST=QL_REJECT + disabled message or unchanged 92 S DLGIEN=+ID I MODE S DLGIEN=+$P($G(^OR(100,+ID,0)),U,5) 93 S X0=$G(^ORD(101.41,DLGIEN,0)),X=$P(X0,U,3) 94 I '$L(X),($P(X0,U,4)="Q") D ; check default dialog 95 . S DLGIEN=+$$DEFDLG^ORWDXQ($P(X0,U,5)) 96 . S X=$P($G(^ORD(101.41,DLGIEN,0)),U,3) 97 I $L(X) D 98 . I MODE D GETTXT^ORWORR(.LST,ID) S LST(.6)="",LST(.7)="Cannot "_$S(MODE=1:"Copy",1:"Change")_" -" 99 . S LST(0)="8^0",LST(.5)="Dialog Disabled: "_X 100 Q 101 CHKVACT(LST,ID,MODE,ORNP) ; return message if action not valid 102 ; ID=DlgIEN or ORIFN, MODE=0:Dialog,1:Copy,2:Change 103 ; LST=QL_REJECT + invalid action message or unchanged 104 Q:'MODE ; not an action on an order 105 N X,ACT S ACT=$S(MODE=1:"RW",MODE=2:"XX",1:"") 106 D VALID^ORWDXA(.X,ID,ACT,ORNP) 107 I $L(X) D GETTXT^ORWORR(.LST,ID) D 108 . S LST(0)="8^0",LST(.5)=X,LST(.6)="",LST(.7)="Cannot "_$S(MODE=1:"Copy",1:"Change")_" -" 109 Q 110 CHKCOPY(LST,ID,FLDS) ; return message if can't copy this order 111 ; ID=ORIFN;ACT FLDS=EventType in 7th piece 112 ; LST=QL_REJECT + cannot copy message or unchanged 113 I "^A^D^T^"'[(U_$E($P(FLDS,U,7))_U) Q ; not event delayed 114 N PKG S PKG=$P($G(^OR(100,+ID,0)),U,14) 115 S PKG=$$NMSP^ORCD(PKG) I PKG="OR"!(PKG="PS") Q ; xfer meds, generics 116 N ORWCAT S ORWCAT=$P($G(^OR(100,+ID,0)),U,12) 117 I ORWCAT="I",("^A^T^"[(U_$E($P(FLDS,U,7))_U)) Q ; admit, xfer inpt 118 I ORWCAT="O",$E($P(FLDS,U,7))="D" Q ; discharge outpt 119 D GETTXT^ORWORR(.LST,ID) 120 I ORWCAT="I" S LST(.5)="inpatient order to outpatient -" 121 I ORWCAT="O" S LST(.5)="outpatient order to inpatient -" 122 S:$D(LST(.5)) LST(.5)="Cannot copy the following "_LST(.5) 123 S LST(0)="8^0",LST(.7)="" 124 Q 125 BLD4CHG(LST,ID,FLDS) ; build responses for an edit 126 ; ID=ORIFN;ACT FLDS=unused right now 127 ; LST(0)=Qlvl^RespID(XOrderID)^DlgIEN^DlgType^FormID^DGrp 128 N OIDX,OI,CNT 129 S (OI,OIDX,CNT)=0 130 S:$D(^OR(100,+ID,4.5,"ID","ORDERABLE")) OIDX=$O(^OR(100,+ID,4.5,"ID","ORDERABLE",0)) 131 I $D(^OR(100,+ID,4.5,OIDX)) D 132 . F S CNT=$O(^OR(100,+ID,4.5,OIDX,CNT)) Q:'CNT D 133 . . S OI=^(CNT) D VALDOI 134 I +LST(0)=8 S LST(.5)="You can not change this order." Q 135 S LST(0)="0^X"_ID_U_$$DLGINFO(+ID,2) 136 S $P(LST(0),U,4)="X" 137 Q 138 GETIVTYP() ; 139 N RESULT,TYPEIEN 140 S RESULT="" 141 S TYPEIEN=$O(^ORD(101.41,"B","OR GTX IV TYPE","")) I TYPEIEN'>0 Q RESULT 142 S RESULT=$G(ORDIALOG(TYPEIEN,1)) 143 Q RESULT 144 ; 145 VALDOI ; Validate the Orderable Items 146 N ORQUIT,ORPS 147 I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D 148 . S ORQUIT=1 149 . S LST(0)="8^0" 150 I $D(ORQUIT) Q:ORQUIT 151 S ORPS=$G(^ORD(101.43,+OI,"PS")) 152 I $P(ORPS,U,1,4)="0^0^0^0",($P(ORPS,U,7)=0) S LST(0)="8^0" 153 Q 154 VERORD() ; 155 N INFUSE,INFUID,PASSIV,SUCC,TYPE 156 S SUCC=0 157 S TYPE=$$GETIVTYP 158 I TYPE="" Q SUCC 159 S PASSIV=$$IVRTECHK 160 I PASSIV=0 Q SUCC 161 S INFUID=$O(^ORD(101.41,"B","OR GTX INFUSION RATE",0)) 162 S INFUSE=$G(ORDIALOG(INFUID,1)) 163 S SUCC=$$VALINF(TYPE,INFUSE) 164 Q SUCC 165 ; 166 VALINF(TYPE,INFUSE) ; 167 N SUCC 168 S SUCC=0 169 I TYPE="I" D Q SUCC 170 .I INFUSE["INFUSE OVER" S SUCC=1 Q 171 .I $L(INFUSE)>4 Q 172 Q 1 173 ; 174 VALQO(IFN) ;Check to see if it's a good QO med 175 ;If it's an IV QO: check if infusion rate entered 176 ;If it's an UD QO: check if dosage entered 177 ;regular order treated as good QO 178 ; 179 I $P($G(^ORD(101.41,IFN,0)),U,4)'="Q" Q 1 180 N ODP,ODG,INFUID,INFUSE,DSAGEID,SUCC,PASSIV,TYPE 181 S SUCC=0 182 S ODP=+$P($G(^ORD(101.41,IFN,0)),U,7),ODG=+$P($G(^(0)),U,5) 183 S ODP=$$GET1^DIQ(9.4,+ODP_",",1),ODG=$P($G(^ORD(100.98,ODG,0)),U,3) 184 I ODP'["PS" Q 1 185 ;check infusion rate for IV QO 186 I ODG="IV RX"!(ODG="TPN") D 187 . S INFUID=$O(^ORD(101.41,"B","OR GTX INFUSION RATE",0)) 188 . S TYPE=$$GETIVTYP 189 . I TYPE="" Q 190 . I $D(ORDIALOG(INFUID,1)) D 191 . . I TYPE="I" D Q 192 . . . S INFUSE=$G(ORDIALOG(INFUID,1)) 193 . . . I INFUSE="" Q 194 . . . I INFUSE["INFUSE OVER" S SUCC=1 Q 195 . . . I $L(INFUSE)>4 Q 196 . . . I +INFUSE>0 S INFUSE="INFUSE OVER "_INFUSE_" Minutes" 197 . . . S ORDIALOG(INFUID,1)=INFUSE,SUCC=1 198 . . S SUCC=1 199 . I '$D(ORDIALOG(INFUID,1)),TYPE="I" S SUCC=1 200 . S PASSIV=$$IVRTECHK 201 . I SUCC=0 Q 202 . I PASSIV=0 S SUCC=0 203 . I SUCC=1,$$ISMISSFL(.ORDIALOG,TYPE)=1 S SUCC=0 204 ;check dosage for UD QO 205 I (ODP="PSJ")!(ODP="PSO"),ODG'="IV RX",ODG'="TPN" D 206 . S DSAGEID=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0)) 207 . I $D(ORDIALOG(DSAGEID,1)) S SUCC=1 208 Q SUCC 209 ; 210 IVRTECHK() ; 211 N RTIEN,RTVALUE,RESULT 212 N CNT,NUM,ORDERIDS,OIIEN,OTYPE,ROUTE 213 S CNT=0,RESULT=0 214 S RTIEN=+$P($G(ORDIALOG("B","ROUTE")),U,2) I RTIEN'>0 Q RESULT 215 S RTVALUE=+$G(ORDIALOG(RTIEN,1)) I RTVALUE'>0 Q RESULT 216 F OTYPE="SOLUTION","ADDITIVE" D 217 .S OIIEN=+$P($G(ORDIALOG("B",OTYPE)),U,2) I OIIEN>0 D 218 ..S NUM=0 F S NUM=$O(ORDIALOG(OIIEN,NUM)) Q:NUM'>0 I +$G(ORDIALOG(OIIEN,NUM))>0 D 219 ...S CNT=CNT+1,ORDERIDS(CNT)=ORDIALOG(OIIEN,NUM) 220 I $D(ORDERIDS)=0 Q 221 S ROUTE=$$IVQOVAL^ORWDPS33(.ORDERIDS,RTVALUE) 222 I ROUTE="" S ORDIALOG(RTIEN,1)=ROUTE 223 I ROUTE'="" S RESULT=1 224 ;K ^TMP($J,"ORWDXM3 IVRTECHK") 225 ;D ALL^PSS51P2(RTVALUE,,,,"ORWDXM3 IVRTECHK") 226 ;I +^TMP($J,"ORWDXM3 IVRTECHK",RTVALUE,6)'=1 S ORDIALOG(RTIEN,1)="",RESULT=0 227 ;K ^TMP($J,"ORWDXM3 IVRTECHK") 228 Q RESULT 229 ; 230 ISUDQO(ORY,DLGID) ;True: is unit dose quick order 231 S ORY=0 232 Q:'$D(^ORD(101.41,DLGID,0)) 233 N CLODGRP,UDGRP1,UDGRP2,DLGTYP,DLGGRP 234 S UDGRP1=$O(^ORD(100.98,"B","UD RX",0)) 235 S UDGRP2=$O(^ORD(100.98,"B","I RX",0)) 236 S CLODGRP=$O(^ORD(100.98,"B","CLINIC ORDERS","")) 237 S DLGTYP=$P($G(^ORD(101.41,DLGID,0)),U,4) 238 S DLGGRP=$P($G(^ORD(101.41,DLGID,0)),U,5) 239 I (DLGTYP="Q"),((DLGGRP=UDGRP1)!(DLGGRP=UDGRP2)!(DLGGRP=CLODGRP)) S ORY=1 240 Q 1 ORWDXM3 ; SLC/KCM/JLI - Quick Orders ;10:42 AM 6/20/2002 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,185,187,190,195,215**;Dec 17, 1997 3 ; 4 KEYVAR(DLG) ; Parse entry action for key variables & return in string 5 ; RV=CollTp^Samp^Spec^CollDt^Urg^Sched^NoComm^NoDiag^NoProv^NoRsn 6 N XCODE,RV,POS,Z 7 S XCODE=$G(^ORD(101.41,DLG,3)),RV="" 8 I '$L(XCODE) Q "" 9 S POS=$F(XCODE,"LRFZX=") I POS S $P(RV,U,1)=$$VALUE(XCODE,POS) 10 S POS=$F(XCODE,"LRFSAMP=") I POS S $P(RV,U,2)=$$VALUE(XCODE,POS) 11 S POS=$F(XCODE,"LRFSPEC=") I POS S $P(RV,U,3)=$$VALUE(XCODE,POS) 12 S POS=$F(XCODE,"LRFDATE=") I POS S $P(RV,U,4)=$$VALUE(XCODE,POS) 13 S POS=$F(XCODE,"LRFURG=") I POS S $P(RV,U,5)=$$VALUE(XCODE,POS) 14 S POS=$F(XCODE,"LRFSCH=") I POS S $P(RV,U,6)=$$VALUE(XCODE,POS) 15 S POS=$F(XCODE,"PSJNOPC=") I POS S $P(RV,U,7)=$$VALUE(XCODE,POS) 16 S POS=$F(XCODE,"GMRCNOPD=") I POS S $P(RV,U,8)=$$VALUE(XCODE,POS) 17 S POS=$F(XCODE,"GMRCNOAT=") I POS S $P(RV,U,9)=$$VALUE(XCODE,POS) 18 S POS=$F(XCODE,"GMRCREAF=") I POS S $P(RV,U,10)=$$VALUE(XCODE,POS) 19 S POS=$F(XCODE,"ORFORGET=") I POS D 20 . ; need to change this so that it is executed in SETKEYV so 21 . ; that it is executed each time menu is revisited 22 . N ORFORGET S ORFORGET=$$VALUE(XCODE,POS) 23 . I ORFORGET K ^TMP("ORECALL",$J,+ORFORGET) 24 . E K ^TMP("ORECALL",$J) 25 Q RV 26 VALUE(STR,BEG) ; Return value of "var=" (copied from ORCONVRT) 27 N X,Y,I S X=$E(STR,BEG,999),Y="" 28 S:$E(X)="""" X=$E(X,2,999) ; strip leading " 29 F I=1:1:$L(X) S Z=$E(X,I) Q:(Z=",")!(Z=" ")!(Z="""") S Y=Y_Z 30 Q $TR(Y,U,"") 31 ; 32 SETKEYV(X) ; Set the key variables based on contents of X 33 I $L($P(X,U,1)) S LRFZX=$P(X,U,1) 34 I $L($P(X,U,2)) S LRFSAMP=$P(X,U,2) 35 I $L($P(X,U,3)) S LRFSPEC=$P(X,U,3) 36 I $L($P(X,U,4)) S LRFDATE=$P(X,U,4) 37 I $L($P(X,U,5)) S LRFURG=$P(X,U,5) 38 I $L($P(X,U,6)) S LRFSCH=$P(X,U,6) 39 I $L($P(X,U,7)) S PSJNOPC=$P(X,U,7) 40 I $L($P(X,U,8)) S GMRCNOPD=$P(X,U,8) 41 I $L($P(X,U,9)) S GMRCNOAT=$P(X,U,9) 42 I $L($P(X,U,10)) S GMRCREAF=$P(X,U,10) 43 Q 44 DLGINFO(IEN,MODE) ; return information about a dialog 45 ; IEN=DlgIEN or ORIFN, MODE=0:Dlg,1:Copy,2:Change 46 ; RESULT=DlgIEN^DlgType^FormID^DGrp 47 ; If MODE="1;T",don't check "PS MEDS" for transfer order 48 ; PSMDGP=1: Unit/Dose Group 49 ; PSMDGP=2: OutPatient Group 50 N X0,DLGIEN,TYP,FID,DGRP,PSMDGP,ISXF 51 S PSMDGP=0,ISXF="" 52 S ISXF=$P(MODE,";",2) 53 S MODE=+MODE 54 S DLGIEN=IEN I MODE,(ISXF'="T") D 55 . S DLGIEN=+$P($G(^OR(100,+IEN,0)),U,5) 56 . I $P(^ORD(101.41,DLGIEN,0),U)="PS MEDS" D 57 . . N PTCAT S PTCAT=$P($G(^OR(100,+IEN,0)),U,12) 58 . . I PTCAT="I" S DLGIEN=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)),PSMDGP=1 59 . . I PTCAT="O" S DLGIEN=$O(^ORD(101.41,"B","PSO OERR",0)),PSMDGP=2 60 I MODE,(ISXF="T") S DLGIEN=+$P($G(^OR(100,+IEN,0)),U,5) 61 S X0=$G(^ORD(101.41,DLGIEN,0)),TYP=$P(X0,U,4),DGRP=$P(X0,U,5) 62 I MODE S DGRP=+$P($G(^OR(100,+IEN,0)),U,11) 63 ;JD NEW START 11/13/02 64 I DLGIEN=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) S PSMDGP=1 65 I DLGIEN=$O(^ORD(101.41,"B","PSO OERR",0)) S PSMDGP=2 66 ;JD NEW END 11/13/02 67 ; for copy or change, if the base dialog has changed, use it's info 68 I MODE,$G(ORDIALOG),(+DLGIEN'=+ORDIALOG),(PSMDGP=0) D 69 . S DLGIEN=+ORDIALOG,DGRP=$P(^ORD(101.41,+ORDIALOG,0),U,5) 70 D FORMID^ORWDXM(.FID,DLGIEN) 71 Q DLGIEN_U_TYP_U_FID_U_DGRP 72 ; 73 CHKDSBL(LST,ID,MODE) ; return message if dialog disabled 74 ; ID=DlgIEN or ORIFN, MODE=0:Dialog,1:Copy,2:Change 75 ; LST=QL_REJECT + disabled message or unchanged 76 S DLGIEN=+ID I MODE S DLGIEN=+$P($G(^OR(100,+ID,0)),U,5) 77 S X0=$G(^ORD(101.41,DLGIEN,0)),X=$P(X0,U,3) 78 I '$L(X),($P(X0,U,4)="Q") D ; check default dialog 79 . S DLGIEN=+$$DEFDLG^ORWDXQ($P(X0,U,5)) 80 . S X=$P($G(^ORD(101.41,DLGIEN,0)),U,3) 81 I $L(X) D 82 . I MODE D GETTXT^ORWORR(.LST,ID) S LST(.6)="",LST(.7)="Cannot "_$S(MODE=1:"Copy",1:"Change")_" -" 83 . S LST(0)="8^0",LST(.5)="Dialog Disabled: "_X 84 Q 85 CHKVACT(LST,ID,MODE,ORNP) ; return message if action not valid 86 ; ID=DlgIEN or ORIFN, MODE=0:Dialog,1:Copy,2:Change 87 ; LST=QL_REJECT + invalid action message or unchanged 88 Q:'MODE ; not an action on an order 89 N X,ACT S ACT=$S(MODE=1:"RW",MODE=2:"XX",1:"") 90 D VALID^ORWDXA(.X,ID,ACT,ORNP) 91 I $L(X) D GETTXT^ORWORR(.LST,ID) D 92 . S LST(0)="8^0",LST(.5)=X,LST(.6)="",LST(.7)="Cannot "_$S(MODE=1:"Copy",1:"Change")_" -" 93 Q 94 CHKCOPY(LST,ID,FLDS) ; return message if can't copy this order 95 ; ID=ORIFN;ACT FLDS=EventType in 7th piece 96 ; LST=QL_REJECT + cannot copy message or unchanged 97 I "^A^D^T^"'[(U_$E($P(FLDS,U,7))_U) Q ; not event delayed 98 N PKG S PKG=$P($G(^OR(100,+ID,0)),U,14) 99 S PKG=$$NMSP^ORCD(PKG) I PKG="OR"!(PKG="PS") Q ; xfer meds, generics 100 N ORWCAT S ORWCAT=$P($G(^OR(100,+ID,0)),U,12) 101 I ORWCAT="I",("^A^T^"[(U_$E($P(FLDS,U,7))_U)) Q ; admit, xfer inpt 102 I ORWCAT="O",$E($P(FLDS,U,7))="D" Q ; discharge outpt 103 D GETTXT^ORWORR(.LST,ID) 104 I ORWCAT="I" S LST(.5)="inpatient order to outpatient -" 105 I ORWCAT="O" S LST(.5)="outpatient order to inpatient -" 106 S:$D(LST(.5)) LST(.5)="Cannot copy the following "_LST(.5) 107 S LST(0)="8^0",LST(.7)="" 108 Q 109 BLD4CHG(LST,ID,FLDS) ; build responses for an edit 110 ; ID=ORIFN;ACT FLDS=unused right now 111 ; LST(0)=Qlvl^RespID(XOrderID)^DlgIEN^DlgType^FormID^DGrp 112 N OIDX,OI,CNT 113 S (OI,OIDX,CNT)=0 114 S:$D(^OR(100,+ID,4.5,"ID","ORDERABLE")) OIDX=$O(^OR(100,+ID,4.5,"ID","ORDERABLE",0)) 115 I $D(^OR(100,+ID,4.5,OIDX)) D 116 . F S CNT=$O(^OR(100,+ID,4.5,OIDX,CNT)) Q:'CNT D 117 . . S OI=^(CNT) D VALDOI 118 I +LST(0)=8 S LST(.5)="You can not change this order." Q 119 S LST(0)="0^X"_ID_U_$$DLGINFO(+ID,2) 120 S $P(LST(0),U,4)="X" 121 Q 122 VALDOI ; Validate the Orderable Items 123 N ORQUIT,ORPS 124 I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D 125 . S ORQUIT=1 126 . S LST(0)="8^0" 127 I $D(ORQUIT) Q:ORQUIT 128 S ORPS=$G(^ORD(101.43,+OI,"PS")) 129 I $P(ORPS,U,1,4)="0^0^0^0",($P(ORPS,U,7)=0) S LST(0)="8^0" 130 Q 131 VALQO(IFN) ;Check to see if it's a good QO med 132 ;If it's an IV QO: check if infusion rate entered 133 ;If it's an UD QO: check if dosage entered 134 ;regular order treated as good QO 135 ; 136 I $P($G(^ORD(101.41,IFN,0)),U,4)'="Q" Q 1 137 N ODP,ODG,INFUID,DSAGEID,SUCC 138 S SUCC=0 139 S ODP=+$P($G(^ORD(101.41,IFN,0)),U,7),ODG=+$P($G(^(0)),U,5) 140 S ODP=$$GET1^DIQ(9.4,+ODP_",",1),ODG=$P($G(^ORD(100.98,ODG,0)),U,3) 141 ;check infusion rate for IV QO 142 I ODG="IV RX"!(ODG="TPN") D 143 . S INFUID=$O(^ORD(101.41,"B","OR GTX INFUSION RATE",0)) 144 . I $D(ORDIALOG(INFUID,1)) S SUCC=1 145 ;check dosage for UD QO 146 I (ODP="PSJ")!(ODP="PSO"),ODG'="IV RX",ODG'="TPN" D 147 . S DSAGEID=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0)) 148 . I $D(ORDIALOG(DSAGEID,1)) S SUCC=1 149 Q SUCC 150 ISUDQO(ORY,DLGID) ;True: is unit dose quick order 151 S ORY=0 152 Q:'$D(^ORD(101.41,DLGID,0)) 153 N CLODGRP,UDGRP1,UDGRP2,DLGTYP,DLGGRP 154 S UDGRP1=$O(^ORD(100.98,"B","UD RX",0)) 155 S UDGRP2=$O(^ORD(100.98,"B","I RX",0)) 156 S CLODGRP=$O(^ORD(100.98,"B","CLINIC ORDERS","")) 157 S DLGTYP=$P($G(^ORD(101.41,DLGID,0)),U,4) 158 S DLGGRP=$P($G(^ORD(101.41,DLGID,0)),U,5) 159 I (DLGTYP="Q"),((DLGGRP=UDGRP1)!(DLGGRP=UDGRP2)!(DLGGRP=CLODGRP)) S ORY=1 160 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXR.m
r613 r623 1 ORWDXR ; SLC/KCM/JDL - Utilites for Order Actions ;5/30/06 14:50 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,134,141,149,187,190,213,243**;Dec 17, 1997;Build 242 3 ; 4 ACTDCREA(DCIEN) ; Valid DC Reason 5 N X 6 S X=$G(^ORD(100.03,DCIEN,0)) 7 I $P(X,U,4) Q 0 8 I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q 0 9 I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q 0 10 Q 1 11 ; 12 ISREL(VAL,ORIFN) ; Return true if an order has been released 13 N STS S STS=$P(^OR(100,+ORIFN,3),U,3) 14 S VAL=$S(STS=10:0,STS=11:0,1:1) ; false if delayed or unreleased order 15 Q 16 RENEW(REC,ORIFN,ORVP,ORNP,ORL,FLDS,CPLX,ORAPPT) ; Renew an order 17 N ORDG 18 N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORPKG 19 N ORDIALOG,PRMT,X0 20 N FSTDOSE,FST 21 S (FSTDOSE,FST)=0 22 I '$D(CPLX) S CPLX=0 23 I '$G(ORAPPT) S ORAPPT="" 24 S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2) 25 S X0=^OR(100,+ORIFN,0) 26 S ORDG=$P(X0,U,11) 27 S ORPKG=$P(X0,U,14) 28 I $D(FLDS("ORCHECK")) M ORCHECK=FLDS("ORCHECK") 29 I $P(X0,U,5)["101.41," D ; version 3 30 . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12) 31 . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN) 32 . I CPLX S FSTDOSE=$P($G(ORDIALOG("B","FIRST DOSE")),U,2) S:'FSTDOSE FSTDOSE=$$PTR^ORCD("OR GTX NOW") 33 . I FSTDOSE,$G(ORDIALOG(FSTDOSE,1)) K ORDIALOG(FSTDOSE,1) 34 E D ; version 2.5 generic 35 . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0)) 36 . D GETDLG^ORCD(ORDIALOG) 37 . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0)) 38 . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1)) 39 . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1) 40 . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) 41 . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9) 42 I +FLDS(1)=999 D ; generic order 43 . S ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)=$P(FLDS(1),U,2) 44 . S ORDIALOG($$PTR^ORCD("OR GTX STOP DATE/TIME"),1)=$P(FLDS(1),U,3) 45 I ($O(^ORD(101.41,"AB","PS MEDS",0))>0),(+FLDS(1)=130)!(+FLDS(1)=135)!(+FLDS(1)=140),'$L($G(ORDIALOG($$PTR^ORCD("OR GTX SIG"),1))) D 46 . N ORDOSE,ORDRUG,ORCAT,ORWPSOI,PROMPT,DRUG 47 . S ORCAT=$P($G(^OR(100,+ORIFN,0)),U,12) 48 . S PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS") 49 . S ORDRUG=$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1)) 50 . S ORWPSOI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)) 51 . I ORWPSOI S ORWPSOI=+$P($G(^ORD(101.43,+ORWPSOI,0)),U,2) 52 . D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,$S(ORCAT="I":"U",1:"O"),ORVP) ; dflt doses 53 . D D1^ORCDPS2 ; set up ORDOSE 54 . S DRUG=$G(ORDOSE("DD",+ORDRUG)) 55 . I DRUG,ORCAT="O" D RESETID^ORCDPS 56 . D SIG^ORCDPS2 57 I +FLDS(1)=140 D ; outpatient meds 58 . K ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1) ; remove effective dt 59 . S ORDIALOG($$PTR^ORCD("OR GTX REFILLS"),1)=$P(FLDS(1),U,4) 60 . S ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)=$P(FLDS(1),U,5) 61 . S PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1") 62 . K ^TMP("ORWORD",$J,PRMT,1) 63 . S I=1 F S I=$O(FLDS(I)) Q:'I S ^TMP("ORWORD",$J,PRMT,1,I-1,0)=FLDS(I) 64 . S ^TMP("ORWORD",$J,PRMT,1,0)=U_U_(I-1)_U_(I-1)_U_DT_U 65 . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1)) 66 . N SIG,PI,X S SIG=$$PTR^ORCD("OR GTX SIG") 67 . S PI=$$PTR^ORCD("OR GTX PATIENT INSTRUCTIONS"),X=$$STR(PI) 68 . I $L(X),$$STR(SIG)[X S ORDIALOG(PI,"FORMAT")="@" ;PI in Sig 69 D RN^ORCSAVE 70 S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN) 71 Q 72 RNWFLDS(LST,ORIFN) ; Return fields for renew action 73 ; LST(0)=RenewType^Start^Stop^Refills^Pickup LST(n)=Comments 74 N X0,DG,PKG,RNWTYPE,START,STOP,REFILLS,OROI 75 S ORIFN=+ORIFN,X0=^OR(100,ORIFN,0),DG=$P(X0,U,11),PKG=$P(X0,U,14) 76 S PKG=$E($P(^DIC(9.4,PKG,0),U,2),1,2),DG=$P(^ORD(100.98,DG,0),U,3) 77 S LST(0)=$S(PKG="OR":999,PKG="PS"&(DG="O RX"):140,PKG="PS"&(DG="UD RX"):130,PKG="PS"&(DG="NV RX"):145,1:0) 78 I +LST(0)=140 D 79 . S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP") 80 . ;D WPVAL(.LST,ORIFN,"COMMENT") 81 I +LST(0)=999 S LST(0)=LST(0)_U_$$VAL(ORIFN,"START")_U_$$VAL(ORIFN,"STOP") 82 ; make sure start/stop times are relative times, otherwise use NOW, no Stop 83 I +$P(LST(0),U,2) S $P(LST(0),U,2)="NOW" 84 I +$P(LST(0),U,3)!($P(LST(0),U,3)="0") S $P(LST(0),U,3)="" 85 ;NEW STUFF AFTER THIS LINE OR*3*243 86 S $P(LST(0),U,9)=0 87 S OROI=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",0)) 88 Q:'OROI 89 S OROI=$G(^OR(100,+ORIFN,4.5,OROI,1)) 90 Q:'OROI 91 S $P(LST(0),U,9)=$$ISCLOZ^ORALWORD(OROI) 92 ; add to LST node specifying if patient of ORIFN passes clozapine lab tests 93 I $P(LST(0),U,9) D 94 .N ORY,ORDFN,ORTMP 95 .S ORTMP=LST(0) 96 .K LST 97 .S LST(0)=ORTMP 98 .S ORDFN=$P(^OR(100,ORIFN,0),U,2) 99 .I $P(ORDFN,";",2)'="DPT(" Q 100 .S ORDFN=+ORDFN 101 .D ALLWORD^ORALWORD(.ORY,ORDFN,ORIFN,"E") 102 .M LST(1)=ORY 103 Q 104 VAL(ORIFN,ID) ; Return value for order response 105 N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0)) 106 Q $G(^OR(100,ORIFN,4.5,DA,1)) 107 WPVAL(TXT,ORIFN,ID) ; Return word processing value 108 N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0)) 109 S I=0 F S I=$O(^OR(100,ORIFN,4.5,DA,2,I)) Q:'I S TXT(I)=^(I,0) 110 Q 111 STR(PTR) ; -- Return word processing text as long string for comparison 112 N X,Y,I,ARRY 113 S ARRY=$G(ORDIALOG(+$G(PTR),1)) Q:'$L(ARRY) "" 114 S I=+$O(@ARRY@(0)),Y=$$UP^XLFSTR($G(@ARRY@(I,0))) 115 F S I=+$O(@ARRY@(I)) Q:'I S X=$G(@ARRY@(I,0)),Y=Y_$$UP^XLFSTR(X) 116 S Y=$TR(Y," ") ;remove all spaces, compare only text 117 Q Y 118 CHKACT(ORDERID,ORWSIG,ORWREL,ORWNATR) ; Return error if can't sign/release order 119 N ORACT,ORWERR 120 ; begin case 121 S ORACT="" 122 I (ORWSIG=1),$D(^XUSEC("ORES",DUZ)) S ORACT="ES" G XC1 123 I (ORWSIG=7),$D(^XUSEC("ORES",DUZ)) S ORACT="DS" G XC1 124 I ORWREL,(ORWNATR="W") S ORACT="OC" G XC1 125 I ORWREL S ORACT="RS" S:$P($G(^OR(100,+ORDERID,0)),U,16)<2 ORACT="ES" 126 XC1 ; end case 127 S ORWERR="" 128 I $L(ORACT),$$VALID^ORCACT0(ORDERID,ORACT,.ORWERR,ORWNATR) S ORWERR="" 129 Q ORWERR 130 GTORITM(Y,ORIFN) ;-- Get back the orderable item IEN 131 S ORIFN=+ORIFN 132 S Y=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE") 133 Q 134 GETPKG(Y,IFN) ;Get package for an order 135 N ORDERID,PKGID 136 Q:+IFN<1 137 S ORDERID=+IFN,Y="" 138 S PKGID=$P(^OR(100,ORDERID,0),U,14) 139 S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2) 140 Q 141 ISCPLX(ORY,ORID) ; 1: is complex order 0: is not 142 Q:'$D(^OR(100,+ORID,0)) 143 N PKG 144 S PKG=$P($G(^OR(100,+ORID,0)),U,14) 145 S PKG=$$NMSP^ORCD(PKG) 146 I PKG'="PS" Q 147 N NUMCHDS,NOWID,NOWVAL 148 S (NOWVAL,NOWID)=0 149 S NUMCHDS=$P($G(^OR(100,+ORID,2,0)),U,4) 150 I NUMCHDS>2 S ORY=1 Q 151 I NUMCHDS=2 D 152 . S ORY=1 153 . S:$D(^OR(100,+ORID,4.5,"ID","NOW")) NOWID=$O(^("NOW",0)) 154 . S:NOWID NOWVAL=$G(^OR(100,+ORID,4.5,NOWID,1)) 155 I NOWVAL=1 S ORY=0 Q 156 Q 157 ORCPLX(ORY,ORID,ORACT) ;Return children orders of the complex order 158 Q:'$D(^OR(100,+ORID,0)) 159 N PKG,LACT,OELACT,ISNOW 160 S PKG=$P($G(^OR(100,+ORID,0)),U,14) 161 S PKG=$$NMSP^ORCD(PKG) 162 I PKG'="PS" Q 163 N CHLDCNT,IDX,X3 164 S (CHLDCNT,IDX)=0 165 S:$L($G(^OR(100,+ORID,2,0))) CHLDCNT=$P(^(0),U,4) 166 I 'CHLDCNT Q 167 F S IDX=$O(^OR(100,+ORID,2,IDX)) Q:'IDX D 168 . S (LACT,OELACT,ISNOW)=0 169 . D ISNOW(.ISNOW,IDX) 170 . Q:ISNOW 171 . S X3=$G(^OR(100,IDX,3)) 172 . S LACT=$P(X3,U,7) 173 . F S OELACT=$O(^OR(100,IDX,8,OELACT),-1) Q:OELACT 174 . S:OELACT>LACT LACT=OELACT 175 . S ORY(IDX)=IDX_";"_LACT 176 Q 177 CANRN(ORY,ORID) ; Check conjunction for renew. 178 ; All conjunctioni = "And" return 1 179 ; Has a "Then" return 0 180 Q:'$G(^OR(100,+ORID,0)) 181 N PKG 182 S PKG=$P($G(^OR(100,+ORID,0)),U,14) 183 S PKG=$$NMSP^ORCD(PKG) 184 I PKG'="PS" Q 185 N INDX,INDY,CANRENEW 186 S INDX=0 187 S CANRENEW=1 188 N CHID 189 S CHID=0 F S CHID=$O(^OR(100,+ORID,2,CHID)) Q:'CHID D 190 . N ORSTS,ACTIVE S ORSTS=0 191 . S ORSTS=$P($G(^OR(100,CHID,3)),U,3) 192 . S ACTIVE=$O(^ORD(100.01,"B","ACTIVE",0)) 193 . I ACTIVE'=ORSTS S CANRENEW=0 194 I 'CANRENEW S ORY=CANRENEW Q 195 F S INDX=$O(^OR(100,+ORID,4.5,"ID","CONJ",INDX)) Q:'INDX D 196 . S INDY=0 F S INDY=$O(^OR(100,+ORID,4.5,INDX,INDY)) Q:'INDY D 197 . . I $G(^(INDY))="T" S CANRENEW=0 Q 198 . I CANRENEW=0 Q 199 S ORY=CANRENEW 200 Q 201 ISNOW(ORY,ORID) ; Is first time now order? 202 N SCH 203 Q:'$D(^OR(100,+ORID,0)) 204 S SCH="" 205 S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0)) 206 S:SCH SCH=$G(^OR(100,+ORID,4.5,SCH,1)) 207 S:SCH="NOW" ORY=1 208 Q 1 ORWDXR ; SLC/KCM/JDL - Utilites for Order Actions ;5/6/04 14:50 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,134,141,149,187,190,213**;Dec 17, 1997 3 ; 4 ISREL(VAL,ORIFN) ; Return true if an order has been released 5 N STS S STS=$P(^OR(100,+ORIFN,3),U,3) 6 S VAL=$S(STS=10:0,STS=11:0,1:1) ; false if delayed or unreleased order 7 Q 8 RENEW(REC,ORIFN,ORVP,ORNP,ORL,FLDS,CPLX,ORAPPT) ; Renew an order 9 N ORDG 10 N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORPKG 11 N ORDIALOG,PRMT,X0 12 N FSTDOSE,FST 13 S (FSTDOSE,FST)=0 14 I '$D(CPLX) S CPLX=0 15 I '$G(ORAPPT) S ORAPPT="" 16 S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2) 17 S X0=^OR(100,+ORIFN,0) 18 S ORDG=$P(X0,U,11) 19 S ORPKG=$P(X0,U,14) 20 I $D(FLDS("ORCHECK")) M ORCHECK=FLDS("ORCHECK") 21 I $P(X0,U,5)["101.41," D ; version 3 22 . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12) 23 . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN) 24 . I CPLX S FSTDOSE=$P($G(ORDIALOG("B","FIRST DOSE")),U,2) S:'FSTDOSE FSTDOSE=$$PTR^ORCD("OR GTX NOW") 25 . I FSTDOSE,$G(ORDIALOG(FSTDOSE,1)) K ORDIALOG(FSTDOSE,1) 26 E D ; version 2.5 generic 27 . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0)) 28 . D GETDLG^ORCD(ORDIALOG) 29 . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0)) 30 . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1)) 31 . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1) 32 . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) 33 . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9) 34 I +FLDS(1)=999 D ; generic order 35 . S ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)=$P(FLDS(1),U,2) 36 . S ORDIALOG($$PTR^ORCD("OR GTX STOP DATE/TIME"),1)=$P(FLDS(1),U,3) 37 I ($O(^ORD(101.41,"AB","PS MEDS",0))>0),(+FLDS(1)=130)!(+FLDS(1)=135)!(+FLDS(1)=140),'$L($G(ORDIALOG($$PTR^ORCD("OR GTX SIG"),1))) D 38 . N ORDOSE,ORDRUG,ORCAT,ORWPSOI,PROMPT,DRUG 39 . S ORCAT=$P($G(^OR(100,+ORIFN,0)),U,12) 40 . S PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS") 41 . S ORDRUG=$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1)) 42 . S ORWPSOI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)) 43 . I ORWPSOI S ORWPSOI=+$P($G(^ORD(101.43,+ORWPSOI,0)),U,2) 44 . D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,$S(ORCAT="I":"U",1:"O"),ORVP) ; dflt doses 45 . D D1^ORCDPS2 ; set up ORDOSE 46 . S DRUG=$G(ORDOSE("DD",+ORDRUG)) 47 . I DRUG,ORCAT="O" D RESETID^ORCDPS 48 . D SIG^ORCDPS2 49 I +FLDS(1)=140 D ; outpatient meds 50 . K ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1) ; remove effective dt 51 . S ORDIALOG($$PTR^ORCD("OR GTX REFILLS"),1)=$P(FLDS(1),U,4) 52 . S ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)=$P(FLDS(1),U,5) 53 . S PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1") 54 . K ^TMP("ORWORD",$J,PRMT,1) 55 . S I=1 F S I=$O(FLDS(I)) Q:'I S ^TMP("ORWORD",$J,PRMT,1,I-1,0)=FLDS(I) 56 . S ^TMP("ORWORD",$J,PRMT,1,0)=U_U_(I-1)_U_(I-1)_U_DT_U 57 . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1)) 58 D RN^ORCSAVE 59 S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN) 60 Q 61 RNWFLDS(LST,ORIFN) ; Return fields for renew action 62 ; LST(0)=RenewType^Start^Stop^Refills^Pickup LST(n)=Comments 63 N X0,DG,PKG,RNWTYPE,START,STOP,REFILLS 64 S ORIFN=+ORIFN,X0=^OR(100,ORIFN,0),DG=$P(X0,U,11),PKG=$P(X0,U,14) 65 S PKG=$E($P(^DIC(9.4,PKG,0),U,2),1,2),DG=$P(^ORD(100.98,DG,0),U,3) 66 S LST(0)=$S(PKG="OR":999,PKG="PS"&(DG="O RX"):140,PKG="PS"&(DG="UD RX"):130,PKG="PS"&(DG="NV RX"):145,1:0) 67 I +LST(0)=140 D 68 . S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP") 69 . D WPVAL(.LST,ORIFN,"COMMENT") 70 I +LST(0)=999 S LST(0)=LST(0)_U_$$VAL(ORIFN,"START")_U_$$VAL(ORIFN,"STOP") 71 ; make sure start/stop times are relative times, otherwise use NOW, no Stop 72 I +$P(LST(0),U,2) S $P(LST(0),U,2)="NOW" 73 I +$P(LST(0),U,3)!($P(LST(0),U,3)="0") S $P(LST(0),U,3)="" 74 Q 75 VAL(ORIFN,ID) ; Return value for order response 76 N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0)) 77 Q $G(^OR(100,ORIFN,4.5,DA,1)) 78 WPVAL(TXT,ORIFN,ID) ; Return word processing value 79 N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0)) 80 S I=0 F S I=$O(^OR(100,ORIFN,4.5,DA,2,I)) Q:'I S TXT(I)=^(I,0) 81 Q 82 CHKACT(ORDERID,ORWSIG,ORWREL,ORWNATR) ; Return error if can't sign/release order 83 N ORACT,ORWERR 84 ; begin case 85 S ORACT="" 86 I (ORWSIG=1),$D(^XUSEC("ORES",DUZ)) S ORACT="ES" G XC1 87 I (ORWSIG=7),$D(^XUSEC("ORES",DUZ)) S ORACT="DS" G XC1 88 I ORWREL,(ORWNATR="W") S ORACT="OC" G XC1 89 I ORWREL S ORACT="RS" S:$P($G(^OR(100,+ORDERID,0)),U,16)<2 ORACT="ES" 90 XC1 ; end case 91 S ORWERR="" 92 I $L(ORACT),$$VALID^ORCACT0(ORDERID,ORACT,.ORWERR,ORWNATR) S ORWERR="" 93 Q ORWERR 94 GTORITM(Y,ORIFN) ;-- Get back the orderable item IEN 95 S ORIFN=+ORIFN 96 S Y=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE") 97 Q 98 GETPKG(Y,IFN) ;Get package for an order 99 N ORDERID,PKGID 100 Q:+IFN<1 101 S ORDERID=+IFN,Y="" 102 S PKGID=$P(^OR(100,ORDERID,0),U,14) 103 S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2) 104 Q 105 ISCPLX(ORY,ORID) ; 1: is complex order 0: is not 106 Q:'$D(^OR(100,+ORID,0)) 107 N PKG 108 S PKG=$P($G(^OR(100,+ORID,0)),U,14) 109 S PKG=$$NMSP^ORCD(PKG) 110 I PKG'="PS" Q 111 N NUMCHDS,NOWID,NOWVAL 112 S (NOWVAL,NOWID)=0 113 S NUMCHDS=$P($G(^OR(100,+ORID,2,0)),U,4) 114 I NUMCHDS>2 S ORY=1 Q 115 I NUMCHDS=2 D 116 . S ORY=1 117 . S:$D(^OR(100,+ORID,4.5,"ID","NOW")) NOWID=$O(^("NOW",0)) 118 . S:NOWID NOWVAL=$G(^OR(100,+ORID,4.5,NOWID,1)) 119 I NOWVAL=1 S ORY=0 Q 120 Q 121 ORCPLX(ORY,ORID,ORACT) ;Return children orders of the complex order 122 Q:'$D(^OR(100,+ORID,0)) 123 N PKG,LACT,OELACT,ISNOW 124 S PKG=$P($G(^OR(100,+ORID,0)),U,14) 125 S PKG=$$NMSP^ORCD(PKG) 126 I PKG'="PS" Q 127 N CHLDCNT,IDX,X3 128 S (CHLDCNT,IDX)=0 129 S:$L($G(^OR(100,+ORID,2,0))) CHLDCNT=$P(^(0),U,4) 130 I 'CHLDCNT Q 131 F S IDX=$O(^OR(100,+ORID,2,IDX)) Q:'IDX D 132 . S (LACT,OELACT,ISNOW)=0 133 . D ISNOW(.ISNOW,IDX) 134 . Q:ISNOW 135 . S X3=$G(^OR(100,IDX,3)) 136 . S LACT=$P(X3,U,7) 137 . F S OELACT=$O(^OR(100,IDX,8,OELACT),-1) Q:OELACT 138 . S:OELACT>LACT LACT=OELACT 139 . S ORY(IDX)=IDX_";"_LACT 140 Q 141 CANRN(ORY,ORID) ; Check conjunction for renew. 142 ; All conjunctioni = "And" return 1 143 ; Has a "Then" return 0 144 Q:'$G(^OR(100,+ORID,0)) 145 N PKG 146 S PKG=$P($G(^OR(100,+ORID,0)),U,14) 147 S PKG=$$NMSP^ORCD(PKG) 148 I PKG'="PS" Q 149 N INDX,INDY,CANRENEW 150 S INDX=0 151 S CANRENEW=1 152 N CHID 153 S CHID=0 F S CHID=$O(^OR(100,+ORID,2,CHID)) Q:'CHID D 154 . N ORSTS,ACTIVE S ORSTS=0 155 . S ORSTS=$P($G(^OR(100,CHID,3)),U,3) 156 . S ACTIVE=$O(^ORD(100.01,"B","ACTIVE",0)) 157 . I ACTIVE'=ORSTS S CANRENEW=0 158 I 'CANRENEW S ORY=CANRENEW Q 159 F S INDX=$O(^OR(100,+ORID,4.5,"ID","CONJ",INDX)) Q:'INDX D 160 . S INDY=0 F S INDY=$O(^OR(100,+ORID,4.5,INDX,INDY)) Q:'INDY D 161 . . I $G(^(INDY))="T" S CANRENEW=0 Q 162 . I CANRENEW=0 Q 163 S ORY=CANRENEW 164 Q 165 ISNOW(ORY,ORID) ; Is first time now order? 166 N SCH 167 Q:'$D(^OR(100,+ORID,0)) 168 S SCH="" 169 S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0)) 170 S:SCH SCH=$G(^OR(100,+ORID,4.5,SCH,1)) 171 S:SCH="NOW" ORY=1 172 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB.m
r613 r623 1 ORWDXVB ;slc/dcm - Order dialog utilities for Blood Bank ;12/7/05 17:11 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17 1997;Build 242 3 ; 4 ; DBIA 2503 RR^LR7OR1 ^TMP("LRRR",$J) 5 ; 6 GETPAT(ORX,DFN,ORL) ;Get Patient data from VBECS 7 ;Needs patient DFN and Location (ORL) 8 N ORSTN,DIV 9 S DIV=+$P($G(^SC(+$G(ORL),0)),U,15),ORSTN=$P($$SITE^VASITE(DT,DIV),U,3) 10 D OEAPI^VBECA3(.ORX,DFN,ORSTN) 11 Q 12 PTINFO(OROOT,ORX) ;Format patient BB info 13 Q:'$D(ORX) 14 D PTINFO^ORWDXVB1 15 Q 16 RESULTS(OROOT,DFN,ORX) ;Get test results 17 Q:'$O(ORX(0)) ;ORX contains a list of tests to retrieve results for 18 N ORCOM,ORT,ORTST,ORTDT,ORTMP,GCNT,CCNT,GIOSL,GIOM,I,ORZ 19 S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80 20 S OROOT=$NA(^TMP("ORVBEC",$J)) 21 K ^TMP("ORVBEC",$J) 22 D LN 23 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"RECENT LAB RESULTS:",.CCNT) 24 D LN 25 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Test Result Units Range Collected Accession Sts",.CCNT) 26 D LN 27 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---- ------ ----- ----- --------- --------- ---",.CCNT) 28 S ORT=0 F S ORT=$O(ORX(ORT)) Q:'ORT S ORTST=$P(ORX(ORT),"^",1) D 29 . K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,,,,ORTST,,1) ;DBIA 2503 30 . S ORTMP="^TMP(""LRRR"",$J,DFN)",ORTMP=$Q(@ORTMP) 31 . Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_DFN) 32 . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP 33 . D LN 34 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,$P(ORZ,"^",15),.CCNT)_$$S^ORU4(8,CCNT,$J($P(ORZ,"^",2),7),.CCNT)_$$S^ORU4(16,CCNT,$P(ORZ,"^",3),.CCNT)_$$S^ORU4(19,CCNT,$P(ORZ,"^",4),.CCNT)_$$S^ORU4(30,CCNT,$P(ORZ,"^",5),.CCNT) 35 . S ^(0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(40,CCNT,$$DATETIME^ORCHTAB(ORTDT),.CCNT)_$$S^ORU4(56,CCNT,$P(ORZ,"^",16),.CCNT)_$$S^ORU4(71,CCNT,$P(ORZ,"^",6),.CCNT) 36 . S ORCOM=$P(ORTMP,",",1,5)_",""N""" ;check for comments 37 . F S ORTMP=$Q(@ORTMP) Q:$P(ORTMP,",",1,6)'=ORCOM D 38 .. D LN 39 .. S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,@ORTMP,.CCNT) 40 K ^TMP("LRRR",$J) 41 Q 42 RAW(OROOT,DFN,ORX) ;Get RAW test results 43 Q:'$O(ORX(0)) ;ORX contains a list of tests to retrieve results for 44 N ORCOM,ORT,ORTST,ORTDT,ORTMP,GCNT,CCNT,GIOSL,GIOM,I 45 S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80 46 S OROOT=$NA(^TMP("ORVBEC",$J)) 47 K ^TMP("ORVBEC",$J) 48 S ORT=0 F S ORT=$O(ORX(ORT)) Q:'ORT S ORTST=$P(ORX(ORT),"^",1) D 49 . K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,,,,ORTST,,1) 50 . S ORTMP="^TMP(""LRRR"",$J,DFN)",ORTMP=$Q(@ORTMP) 51 . Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_DFN) 52 . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP 53 . D LN 54 . S ^TMP("ORVBEC",$J,GCNT,0)=$P(ORZ,"^",1,6)_"^"_ORTDT 55 K ^TMP("LRRR",$J) 56 Q 57 SURG(OROOT,ORX) ;Get list of surgeries 58 N I,CNT,X 59 S (I,CNT)=0 60 F S I=$O(ORX("SURGERY",I)) Q:'I S X=$G(ORX("SURGERY",I)) D 61 . S CNT=CNT+1,OROOT(CNT)=X_U_X 62 Q 63 LN ;Increment counts 64 S GCNT=GCNT+1,CCNT=1 65 Q 66 PATINFO(OROOT,DFN,LOC) ;Test ^TMP global output 67 N ORX 68 D GETPAT(.ORX,DFN,LOC) 69 I $L($G(ORX("SPECIMEN"))) S:$P(ORX("SPECIMEN"),"^") $P(ORX("SPECIMEN"),"^")=$$HL7TFM^XLFDT($P(ORX("SPECIMEN"),"^")) 70 D PTINFO(.OROOT,.ORX) 71 ;S I=0 F S I=$O(@OROOT@(I)) Q:'I W !,^(I,0) 72 ;K @OROOT 73 Q 74 GETALL(OROOT,DFN,LOC) ;Get all data in one call and let the GUI divide it up 75 N ORX,INFO,CNT,I,J,K 76 S OROOT=$NA(^TMP("ORVBECINFO",$J)),CNT=1 77 D GETPAT(.ORX,DFN,LOC) 78 ;S ^TMP("ORVBECINFO",$J,CNT)="~RAWDATA",I=0 79 ;F S I=$O(ORX(I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)=ORX(I) 80 I $L($G(ORX("SPECIMEN"))) S:$P(ORX("SPECIMEN"),"^") $P(ORX("SPECIMEN"),"^")=$$HL7TFM^XLFDT($P(ORX("SPECIMEN"),"^")) S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SPECIMEN",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORX("SPECIMEN") 81 I $L($G(ORX("ABORH"))) S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~ABORH",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORX("ABORH") 82 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TYPE AND SCREEN",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_$O(^ORD(101.43,"ID","1;99VBC",0)) 83 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~OTHER",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_$O(^ORD(101.43,"ID","6;99VBC",0)) 84 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SPECIMENS",I=0 85 F S I=$O(ORX(I)) Q:'I S J="" F S J=$O(ORX(I,J)) Q:J="" I J="SPECIMEN" S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_ORX(I,J) 86 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TESTS",I=0 87 F S I=$O(ORX(I)) Q:'I S J="" F S J=$O(ORX(I,J)) Q:J="" I J="TEST" S K=0 F S K=$O(ORX(I,J,K)) Q:'K S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_K_"^"_ORX(I,J,K) 88 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~MSBOS",I=0 89 F S I=$O(ORX(I)) Q:'I S J="" F S J=$O(ORX(I,J)) Q:J="" I J="MSBOS" S K=0 F S K=$O(ORX(I,J,K)) Q:'K S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_K_"^"_ORX(I,J,K),$P(^(CNT),"^",4)=+$P(ORX(I,J,K),"^",2) 90 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SURGERIES",I=0 91 F S I=$O(ORX("SURGERY",I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_ORX("SURGERY",I) 92 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~URGENCIES",I="" 93 F S I=$O(^ORD(101.42,"S.VBEC",I)) Q:I="" S J=0 F S J=$O(^ORD(101.42,"S.VBEC",I,J)) Q:'J S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_J_"^"_I 94 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~MODIFIERS",I="" 95 N ORMODS D GETLST^XPAR(.ORMODS,"ALL","OR VBECS MODIFIERS","I") 96 F S I=$O(ORMODS(I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORMODS(I) 97 ;F I="W^Washed","I^Irradiated","L^Leuko Reduced","V^Volume Reduced","D^Divided","E^Leuko Reduced/Irradiated" S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I 98 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~REASONS",I="" 99 N ORMODS D GETLST^XPAR(.ORMODS,"ALL","OR VBECS REASON FOR REQUEST","I") 100 F S I=$O(ORMODS(I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORMODS(I) 101 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~INFO" 102 D PTINFO(.INFO,.ORX) 103 S I=0 F S I=$O(^TMP("ORVBEC",$J,I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_^TMP("ORVBEC",$J,I,0) 104 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TNS ORDERS" 105 N ORMODS D PULL^ORWDXVB2(.ORMODS,DFN) 106 S I=0 F S I=$O(ORMODS(I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORMODS(I) 107 K ^TMP("ORVBEC",$J) 108 Q 109 STATALOW(OROOT,DFN) ;Allow stat for ORES ORELSE users 110 S OROOT=$D(^XUSEC("ORES",DUZ))!($D(^XUSEC("ORELSE",DUZ))) 111 Q 112 NURSADMN(OROOT) ;Suppress Nursing Adiminstration Order Prompt 113 S OROOT=+$$GET^XPAR("DIV^SYS^PKG","OR VBECS SUPPRESS NURS ADMIN") 114 Q 115 VBTNS(RETURN) ;RPC to get Days back to check for Type & Screen order 116 S RETURN=$$GET^XPAR("ALL","ORWDXVB VBECS TNS CHECK",1,"I") 117 Q 118 COMPORD(OROOT) ;Get sequence order of Blood Components 119 N ORLIST,I,X 120 D GETLST^XPAR(.ORLIST,"ALL","OR VBECS COMPONENT ORDER") 121 S I=0 F S I=$O(ORLIST(I)) Q:'I S X=ORLIST(I) I $D(^ORD(101.43,$P(X,"^",2),0)) S OROOT(I)=$P(X,"^",2)_"^"_$P(^(0),"^",1)_"^"_$P(^(0),"^",1) 122 Q 123 SUBCHK(OROOT,TSTNM) ;Check to see if selected test is a Blood Component or a Diagnostic Test 124 S OROOT="" 125 Q:'$L($G(TSTNM)) 126 I $O(^ORD(101.43,"S.VBT",TSTNM,0)) S OROOT="t" 127 I $O(^ORD(101.43,"S.VBC",TSTNM,0)) S OROOT="c" 128 Q 129 TESTR ;Test results call 130 N ORX 131 S ORX(3)="3" ;HGB 132 S ORX(4)="4" ;HCT 133 S ORX(1)="1" ;WBC 134 S ORX(113)="113" ;FERRITIN 135 D RESULTS(.OROOT,66,.ORX) 136 S I=0 F S I=$O(@OROOT@(I)) Q:'I W !,^(I,0) 137 K @OROOT 138 Q 1 ORWDXVB ;slc/dcm - Order dialog utilities for Blood Bank ;12/7/05 17:11 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17 1997 3 ; 4 ; DBIA 2503 RR^LR7OR1 ^TMP("LRRR",$J) 5 ; 6 GETPAT(ORX,DFN,ORL) ;Get Patient data from VBECS 7 ;Needs patient DFN and Location (ORL) 8 N ORSTN,DIV 9 S DIV=+$P($G(^SC(+$G(ORL),0)),U,15),ORSTN=$P($$SITE^VASITE(DT,DIV),U,3) 10 D OEAPI^VBECA3(.ORX,DFN,ORSTN) 11 Q 12 PTINFO(OROOT,ORX) ;Format patient BB info 13 Q:'$D(ORX) 14 D PTINFO^ORWDXVB1 15 Q 16 RESULTS(OROOT,DFN,ORX) ;Get test results 17 Q:'$O(ORX(0)) ;ORX contains a list of tests to retrieve results for 18 N ORCOM,ORT,ORTST,ORTDT,ORTMP,GCNT,CCNT,GIOSL,GIOM,I,ORZ 19 S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80 20 S OROOT=$NA(^TMP("ORVBEC",$J)) 21 K ^TMP("ORVBEC",$J) 22 D LN 23 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"RECENT LAB RESULTS:",.CCNT) 24 D LN 25 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Test Result Units Range Collected Accession Sts",.CCNT) 26 D LN 27 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---- ------ ----- ----- --------- --------- ---",.CCNT) 28 S ORT=0 F S ORT=$O(ORX(ORT)) Q:'ORT S ORTST=$P(ORX(ORT),"^",1) D 29 . K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,,,,ORTST,,1) ;DBIA 2503 30 . S ORTMP="^TMP(""LRRR"",$J,DFN)",ORTMP=$Q(@ORTMP) 31 . Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_DFN) 32 . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP 33 . D LN 34 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,$P(ORZ,"^",15),.CCNT)_$$S^ORU4(8,CCNT,$J($P(ORZ,"^",2),7),.CCNT)_$$S^ORU4(16,CCNT,$P(ORZ,"^",3),.CCNT)_$$S^ORU4(19,CCNT,$P(ORZ,"^",4),.CCNT)_$$S^ORU4(30,CCNT,$P(ORZ,"^",5),.CCNT) 35 . S ^(0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(40,CCNT,$$DATETIME^ORCHTAB(ORTDT),.CCNT)_$$S^ORU4(56,CCNT,$P(ORZ,"^",16),.CCNT)_$$S^ORU4(71,CCNT,$P(ORZ,"^",6),.CCNT) 36 . S ORCOM=$P(ORTMP,",",1,5)_",""N""" ;check for comments 37 . F S ORTMP=$Q(@ORTMP) Q:$P(ORTMP,",",1,6)'=ORCOM D 38 .. D LN 39 .. S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,@ORTMP,.CCNT) 40 K ^TMP("LRRR",$J) 41 Q 42 RAW(OROOT,DFN,ORX) ;Get RAW test results 43 Q:'$O(ORX(0)) ;ORX contains a list of tests to retrieve results for 44 N ORCOM,ORT,ORTST,ORTDT,ORTMP,GCNT,CCNT,GIOSL,GIOM,I 45 S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80 46 S OROOT=$NA(^TMP("ORVBEC",$J)) 47 K ^TMP("ORVBEC",$J) 48 S ORT=0 F S ORT=$O(ORX(ORT)) Q:'ORT S ORTST=$P(ORX(ORT),"^",1) D 49 . K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,,,,ORTST,,1) 50 . S ORTMP="^TMP(""LRRR"",$J,DFN)",ORTMP=$Q(@ORTMP) 51 . Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_DFN) 52 . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP 53 . D LN 54 . S ^TMP("ORVBEC",$J,GCNT,0)=$P(ORZ,"^",1,6)_"^"_ORTDT 55 K ^TMP("LRRR",$J) 56 Q 57 SURG(OROOT,ORX) ;Get list of surgeries 58 N I,CNT,X 59 S (I,CNT)=0 60 F S I=$O(ORX("SURGERY",I)) Q:'I S X=$G(ORX("SURGERY",I)) D 61 . S CNT=CNT+1,OROOT(CNT)=X_U_X 62 Q 63 LN ;Increment counts 64 S GCNT=GCNT+1,CCNT=1 65 Q 66 PATINFO(OROOT,DFN,LOC) ;Test ^TMP global output 67 N ORX 68 D GETPAT(.ORX,DFN,LOC) 69 I $L($G(ORX("SPECIMEN"))) S:$P(ORX("SPECIMEN"),"^") $P(ORX("SPECIMEN"),"^")=$$HL7TFM^XLFDT($P(ORX("SPECIMEN"),"^")) 70 D PTINFO(.OROOT,.ORX) 71 ;S I=0 F S I=$O(@OROOT@(I)) Q:'I W !,^(I,0) 72 ;K @OROOT 73 Q 74 GETALL(OROOT,DFN,LOC) ;Get all data in one call and let the GUI divide it up 75 N ORX,INFO,CNT,I,J,K 76 S OROOT=$NA(^TMP("ORVBECINFO",$J)),CNT=1 77 D GETPAT(.ORX,DFN,LOC) 78 ;S ^TMP("ORVBECINFO",$J,CNT)="~RAWDATA",I=0 79 ;F S I=$O(ORX(I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)=ORX(I) 80 I $L($G(ORX("SPECIMEN"))) S:$P(ORX("SPECIMEN"),"^") $P(ORX("SPECIMEN"),"^")=$$HL7TFM^XLFDT($P(ORX("SPECIMEN"),"^")) S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SPECIMEN",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORX("SPECIMEN") 81 I $L($G(ORX("ABORH"))) S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~ABORH",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORX("ABORH") 82 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TYPE AND SCREEN",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_$O(^ORD(101.43,"S.VBEC","TYPE & SCREEN",0)) 83 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SPECIMENS",I=0 84 F S I=$O(ORX(I)) Q:'I S J="" F S J=$O(ORX(I,J)) Q:J="" I J="SPECIMEN" S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_ORX(I,J) 85 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TESTS",I=0 86 F S I=$O(ORX(I)) Q:'I S J="" F S J=$O(ORX(I,J)) Q:J="" I J="TEST" S K=0 F S K=$O(ORX(I,J,K)) Q:'K S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_K_"^"_ORX(I,J,K) 87 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~MSBOS",I=0 88 F S I=$O(ORX(I)) Q:'I S J="" F S J=$O(ORX(I,J)) Q:J="" I J="MSBOS" S K=0 F S K=$O(ORX(I,J,K)) Q:'K S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_K_"^"_ORX(I,J,K),$P(^(CNT),"^",4)=+$P(ORX(I,J,K),"^",2) 89 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SURGERIES",I=0 90 F S I=$O(ORX("SURGERY",I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_ORX("SURGERY",I) 91 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~URGENCIES",I="" 92 F S I=$O(^ORD(101.42,"S.VBEC",I)) Q:I="" S J=0 F S J=$O(^ORD(101.42,"S.VBEC",I,J)) Q:'J S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_J_"^"_I 93 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~MODIFIERS",I="" 94 N ORMODS D GETLST^XPAR(.ORMODS,"ALL","OR VBECS MODIFIERS","I") 95 F S I=$O(ORMODS(I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORMODS(I) 96 ;F I="W^Washed","I^Irradiated","L^Leuko Reduced","V^Volume Reduced","D^Divided","E^Leuko Reduced/Irradiated" S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I 97 S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~INFO",I=0 98 D PTINFO(.INFO,.ORX) 99 F S I=$O(^TMP("ORVBEC",$J,I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_^TMP("ORVBEC",$J,I,0) 100 K ^TMP("ORVBEC",$J) 101 Q 102 STATALOW(OROOT,DFN) ;Allow stat for ORES ORELSE users 103 S OROOT=$D(^XUSEC("ORES",DUZ))!($D(^XUSEC("ORELSE",DUZ))) 104 Q 105 COMPORD(OROOT) ;Get sequence order of Blood Components 106 N ORLIST,I,X 107 D GETLST^XPAR(.ORLIST,"ALL","OR VBECS COMPONENT ORDER") 108 S I=0 F S I=$O(ORLIST(I)) Q:'I S X=ORLIST(I) I $D(^ORD(101.43,$P(X,"^",2),0)) S OROOT(I)=$P(X,"^",2)_"^"_$P(^(0),"^",1)_"^"_$P(^(0),"^",1) 109 Q 110 TESTR ;Test results call 111 N ORX 112 S ORX(3)="3" ;HGB 113 S ORX(4)="4" ;HCT 114 S ORX(1)="1" ;WBC 115 S ORX(113)="113" ;FERRITIN 116 D RESULTS(.OROOT,66,.ORX) 117 S I=0 F S I=$O(@OROOT@(I)) Q:'I W !,^(I,0) 118 K @OROOT 119 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB1.m
r613 r623 1 ORWDXVB1 ;slc/dcm - Order dialog utilities for Blood Bank Cont.;3/2/04 09:31 ;12/7/05 17:20 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17 1997;Build 242 3 ; 4 PTINFO ;Format patient BB info 5 N GCNT,CCNT,GIOSL,GIOM,I,TYPE,ORUA,VBERROR,ABFND,LINE1,LINE2,NOABO,NOPAT,TREQFND 6 S (GCNT,NOPAT,NOABO)=0,CCNT=1,GIOSL=999999,GIOM=80 7 S OROOT=$NA(^TMP("ORVBEC",$J)) 8 K ^TMP("ORVBEC",$J) 9 ; 10 I +$G(ORX("ERROR")) D ERROR^ORWDXVB2 Q 11 ; Patient Demographics 12 D LN 13 I '$D(ORX("PATIENT")) D Q 14 . D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 15 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(10,CCNT,"There is no previous record of this patient in VBECS.",.CCNT) Q 16 ; 17 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Name",.CCNT)_$$S^ORU4(27,CCNT,"SSN",.CCNT)_$$S^ORU4(42,CCNT,"ABO/Rh",.CCNT) 18 D LN 19 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----",.CCNT)_$$S^ORU4(27,CCNT,"---",.CCNT)_$$S^ORU4(42,CCNT,"------",.CCNT) D 20 . D LN 21 . S X=ORX("PATIENT"),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,$P(X,"^",3)_", "_$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$P(X,"^",4),.CCNT) 22 . I $P(ORX("ABORH"),"^")']"" S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(42,CCNT,"unknown",.CCNT) Q 23 . S X=ORX("ABORH"),^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(42,CCNT,$$STRIP^XLFSTR($P(X,"^")," ")_" "_$S($$STRIP^XLFSTR($P(X,"^",2)," ")="P":"Pos",$$STRIP^XLFSTR($P(X,"^",2)," ")="N":"Neg",1:"unknown"),.CCNT) Q 24 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 25 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 26 ; 27 ; Available Specimens 28 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Lab Specimen ID",.CCNT)_$$S^ORU4(27,CCNT,"Expiration Date",.CCNT) 29 D LN 30 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----------------------",.CCNT)_$$S^ORU4(27,CCNT,"---------------",.CCNT) D 31 . I '$D(ORX("SPECIMEN")) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q 32 . D LN 33 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(ORX("SPECIMEN"),"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME^ORCHTAB($P(ORX("SPECIMEN"),"^")),.CCNT) Q 34 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 35 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 36 ; 37 ; Antibodies Identified section 38 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Antibodies Identified",.CCNT) 39 D LN 40 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------------",.CCNT) D 41 . I '$O(ORX("ABHIS",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q 42 . D LN 43 . S ABFND=0 44 . S I=0 F S I=$O(ORX("ABHIS",I)) Q:I<1 D 45 . . S X=ORX("ABHIS",I) 46 . . I ABFND S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(2,CCNT,", "_$P(X,"^"),.CCNT) Q 47 . . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT),ABFND=1 48 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 49 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 50 ; 51 ; Transfusion Requirements section 52 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Transfusion Requirements",.CCNT) 53 D LN 54 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"------------------------",.CCNT) D 55 . I '$O(ORX("TRREQ",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q 56 . D LN 57 . S TREQFND=0 58 . S I=0 F S I=$O(ORX("TRREQ",I)) Q:I<1 D 59 . . S X=ORX("TRREQ",I) 60 . . I TREQFND S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(2,CCNT,", "_X,.CCNT) Q 61 . . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,X,.CCNT),TREQFND=1 62 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 63 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 64 ; 65 ; Transfusion Reactions section 66 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Transfusion Reactions",.CCNT)_$$S^ORU4(27,CCNT,"Date/Time",.CCNT) 67 D LN 68 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------------",.CCNT)_$$S^ORU4(27,CCNT,"---------",.CCNT) D 69 . I '$O(ORX("TRHX",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q 70 . S I=0 F S I=$O(ORX("TRHX",I)) Q:I<1 D 71 . . D LN 72 . . S X=ORX("TRHX",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",2)),.CCNT) 73 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 74 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 75 ; 76 ; New Units section 77 N INDEX,UNT,ORY,I,CNT,J,K,L,M,X 78 S CNT=0 79 F INDEX="A","D","C","S" I $O(ORX("UNIT",INDEX,0)) D ; A:Autologous D:Directed C:Crossmatched A:Assigned 80 . S I=0 F S I=$O(ORX("UNIT",INDEX,I)) Q:I<1 D 81 .. S X=ORX("UNIT",INDEX,I),CNT=CNT+1,ORY("~"_$P(X,"^"),"~"_$P(X,"^",2),"~"_INDEX,"~"_$P(X,"^",4),CNT)=X 82 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Units Available",.CCNT) 83 D LN 84 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------",.CCNT) 85 D LN 86 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Status",.CCNT)_$$S^ORU4(42,CCNT,"Exp Date",.CCNT)_$$S^ORU4(58,CCNT,"Division",.CCNT) 87 D LN 88 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"------",.CCNT)_$$S^ORU4(42,CCNT,"--------",.CCNT)_$$S^ORU4(58,CCNT,"--------",.CCNT) 89 S I="" F S I=$O(ORY(I)) Q:I="" S J="" F S J=$O(ORY(I,J)) Q:J="" S K="" F S K=$O(ORY(I,J,K)) Q:K="" S L="" F S L=$O(ORY(I,J,K,L)) Q:L="" S M="" F S M=$O(ORY(I,J,K,L,M)) Q:M="" D LN D 90 . S X=ORY(I,J,K,L,M),INDEX=$E(K,2),UNT=$S(INDEX="A":"Autologous",INDEX="D":"Directed",INDEX="C":"Crossmatched",INDEX="S":"Assigned",1:"Unknown") 91 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,UNT,.CCNT)_$$S^ORU4(42,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(58,CCNT,$P(X,"^",3),.CCNT) 92 Q 93 LN ;Increment counts 94 S GCNT=GCNT+1,CCNT=1 95 Q 96 DATETIME(X) ; -- Return external form of YYYYMMDDHHNNSS date 97 N Y S Y=$$HL7TFM^XLFDT(X),Y=$$DATETIME^ORCHTAB(Y) 98 Q Y 1 ORWDXVB1 ;slc/dcm - Order dialog utilities for Blood Bank Cont.;3/2/04 09:31 ;12/7/05 17:20 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17 1997 3 ; 4 PTINFO ;Format patient BB info 5 N GCNT,CCNT,GIOSL,GIOM,I,TYPE,ORUA,VBERROR,ABFND,LINE1,LINE2,NOABO,NOPAT,TREQFND 6 S (GCNT,NOPAT,NOABO)=0,CCNT=1,GIOSL=999999,GIOM=80 7 S OROOT=$NA(^TMP("ORVBEC",$J)) 8 K ^TMP("ORVBEC",$J) 9 ; 10 I +$G(ORX("ERROR")) D ERROR^ORWDXVB2 Q 11 ; Patient Demographics 12 D LN 13 I '$D(ORX("PATIENT")) D Q 14 . D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 15 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(10,CCNT,"There is no previous record of this patient in VBECS.",.CCNT) Q 16 ; 17 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Name",.CCNT)_$$S^ORU4(27,CCNT,"SSN",.CCNT)_$$S^ORU4(42,CCNT,"ABO/Rh",.CCNT) 18 D LN 19 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----",.CCNT)_$$S^ORU4(27,CCNT,"---",.CCNT)_$$S^ORU4(42,CCNT,"------",.CCNT) D 20 . D LN 21 . S X=ORX("PATIENT"),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,$P(X,"^",3)_", "_$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$P(X,"^",4),.CCNT) 22 . I $P(ORX("ABORH"),"^")']"" S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(42,CCNT,"unknown",.CCNT) Q 23 . S X=ORX("ABORH"),^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(42,CCNT,$$STRIP^XLFSTR($P(X,"^")," ")_" "_$S($$STRIP^XLFSTR($P(X,"^",2)," ")="P":"Pos",$$STRIP^XLFSTR($P(X,"^",2)," ")="N":"Neg",1:"unknown"),.CCNT) Q 24 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 25 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 26 ; 27 ; Available Specimens 28 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Available Specimen UID",.CCNT)_$$S^ORU4(27,CCNT,"Expiration Date",.CCNT) 29 D LN 30 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----------------------",.CCNT)_$$S^ORU4(27,CCNT,"---------------",.CCNT) D 31 . I '$D(ORX("SPECIMEN")) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q 32 . D LN 33 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(ORX("SPECIMEN"),"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME^ORCHTAB($P(ORX("SPECIMEN"),"^")),.CCNT) Q 34 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 35 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 36 ; 37 ; Antibodies Identified section 38 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Antibodies Identified",.CCNT) 39 D LN 40 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------------",.CCNT) D 41 . I '$O(ORX("ABHIS",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q 42 . D LN 43 . S ABFND=0 44 . S I=0 F S I=$O(ORX("ABHIS",I)) Q:I<1 D 45 . . S X=ORX("ABHIS",I) 46 . . I ABFND S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(2,CCNT,", "_$P(X,"^"),.CCNT) Q 47 . . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT),ABFND=1 48 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 49 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 50 ; 51 ; Transfusion Requirements section 52 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Transfusion Requirements",.CCNT) 53 D LN 54 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"------------------------",.CCNT) D 55 . I '$O(ORX("TRREQ",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q 56 . D LN 57 . S TREQFND=0 58 . S I=0 F S I=$O(ORX("TRREQ",I)) Q:I<1 D 59 . . S X=ORX("TRREQ",I) 60 . . I TREQFND S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(2,CCNT,", "_X,.CCNT) Q 61 . . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,X,.CCNT),TREQFND=1 62 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 63 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 64 ; 65 ; Transfusion Reactions section 66 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Transfusion Reactions",.CCNT)_$$S^ORU4(27,CCNT,"Date/Time",.CCNT) 67 D LN 68 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------------",.CCNT)_$$S^ORU4(27,CCNT,"---------",.CCNT) D 69 . I '$O(ORX("TRHX",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q 70 . S I=0 F S I=$O(ORX("TRHX",I)) Q:I<1 D 71 . . D LN 72 . . S X=ORX("TRHX",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",2)),.CCNT) 73 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 74 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 75 ; 76 ; Units section 77 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Units Available",.CCNT) 78 D LN 79 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------",.CCNT) 80 D LN 81 ; Autologous Units 82 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Autologous",.CCNT) 83 D LN 84 I $O(ORX("UNIT","A",0)) D 85 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Expiration Date Division",.CCNT) 86 . D LN 87 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"--------------- --------",.CCNT) D 88 . . S I=0 F S I=$O(ORX("UNIT","A",I)) Q:I<1 D 89 . . . D LN 90 . . . S X=ORX("UNIT","A",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(44,CCNT,$P(X,"^",3),.CCNT) 91 E S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT," none",.CCNT) 92 ; 93 ; Directed Units 94 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 95 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Directed",.CCNT) 96 D LN 97 I $O(ORX("UNIT","D",0)) D 98 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Expiration Date Division",.CCNT) 99 . D LN 100 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"--------------- --------",.CCNT) D 101 . . S I=0 F S I=$O(ORX("UNIT","D",I)) Q:I<1 D 102 . . . D LN 103 . . . S X=ORX("UNIT","D",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(44,CCNT,$P(X,"^",3),.CCNT) 104 E S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT," none",.CCNT) 105 ; 106 ; Crossmatched Units 107 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 108 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Crossmatched",.CCNT) 109 D LN 110 I $O(ORX("UNIT","C",0)) D 111 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Available Until Division",.CCNT) 112 . D LN 113 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"--------------- --------",.CCNT) D 114 . . S I=0 F S I=$O(ORX("UNIT","C",I)) Q:I<1 D 115 . . . D LN 116 . . . S X=ORX("UNIT","C",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(44,CCNT,$P(X,"^",3),.CCNT) 117 E S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT," none",.CCNT) 118 ; 119 ; Assigned Units 120 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 121 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Assigned",.CCNT) 122 D LN 123 I $O(ORX("UNIT","S",0)) D 124 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Available Until Division",.CCNT) 125 . D LN 126 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"--------------- --------",.CCNT) D 127 . . S I=0 F S I=$O(ORX("UNIT","S",I)) Q:I<1 D 128 . . . D LN 129 . . . S X=ORX("UNIT","S",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(44,CCNT,$P(X,"^",3),.CCNT) 130 E S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT," none",.CCNT) 131 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 132 ; 133 Q 134 LN ;Increment counts 135 S GCNT=GCNT+1,CCNT=1 136 Q 137 DATETIME(X) ; -- Return external form of YYYYMMDDHHNNSS date 138 N Y S Y=$$HL7TFM^XLFDT(X),Y=$$DATETIME^ORCHTAB(Y) 139 Q Y -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB2.m
r613 r623 1 ORWDXVB2 ;slc/dcm - Order dialog utilities for Blood Bank Cont.;3/2/04 09:31 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17 1997;Build 242 3 ; 4 ERROR ;Process error 5 D LN 6 S VBERROR=$P(ORX("ERROR"),"^",2) 7 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN 8 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 9 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* WARNING! *",.CCNT) D LN 10 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 11 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* An Error occurred attempting to *",.CCNT) D LN 12 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* retrieve Blood Bank order data. *",.CCNT) D LN 13 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 14 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* This order cannot be completed at this time. *",.CCNT) D LN 15 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* Revert to local downtime procedures to continue *",.CCNT) D LN 16 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* order or retry this option at a later time. *",.CCNT) D LN 17 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 18 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* Contact the Blood Bank System Administrator *",.CCNT) D LN 19 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 20 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN 21 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 22 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* Error Message *",.CCNT) D LN 23 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 24 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*",.CCNT) 25 I $L(VBERROR)<68 D 26 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(VBERROR)/2,CCNT,VBERROR,.CCNT) 27 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN 28 I $L(VBERROR)>68 D 29 . I $L(VBERROR)>136 S VBERROR=$E(VBERROR,1,136)_"..." 30 . N L1 S L1=$E(VBERROR,1,$L(VBERROR)/2) 31 . I $E(L1,$L(L1))'=" " D 32 . . S LINE1=$E(L1,1,($L(L1)-($L($P(L1," ",$L(L1," ")))))),LINE2=$E(VBERROR,$L(LINE1)+1,$L(VBERROR)) 33 . E S LINE1=$E(L1),LINE2=$E(VBERROR,$L(LINE1)+1,$L(VBERROR)) 34 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(LINE1)/2,CCNT,LINE1,.CCNT) 35 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN 36 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*",.CCNT) 37 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(LINE2)/2,CCNT,LINE2,.CCNT) 38 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN 39 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 40 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN 41 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 42 Q 43 PULL(OROOT,ORVP,ITEMID,SDATE,EDATE) ;Get list of orders matching ITEM 44 ;ITEM = Orderable Item ID e.g. "1;99VBC" for Type and Screen 45 ;SDATE = Start Date for search 46 ;EDATE = End Date for search 47 Q:'$G(ORVP) 48 N ORTNSB 49 I $P(ORVP,";",2)="" S ORVP=ORVP_";DPT(" 50 S ORTNSB=$$GET^XPAR("ALL","ORWDXVB VBECS TNS CHECK",1,"I") 51 S:'ORTNSB ORTNSB=3 ;Use Default of DT-3 or Parameter [ORWDXVB VBECS TNS CHECK] if no start date passed in 52 S ITEMID=$S($D(ITEMID):ITEMID,1:"1;99VBC") ;Default to Type and Screen if nothing passed in 53 S SDATE=$S($D(SDATE):SDATE,1:$$FMADD^XLFDT(DT-ORTNSB)) 54 S EDATE=$S($D(EDATE):EDATE,1:DT) ;Default to DT if no End date passed in 55 N ORDG,FLG,ORLIST,ORX0,ORX3,ORSTAT,ORIFN,I,X,J,CNT,ITEM,ITEMNM,ORLOC,DIV 56 S ITEM=+$O(^ORD(101.43,"ID",ITEMID,0)),ITEMNM=$P($G(^ORD(101.43,ITEM,0)),"^") 57 S CNT=0,ORDG=$O(^ORD(100.98,"B","VBEC",0)) Q:'ORDG 58 F FLG=4,23,19 D ;Get completed, active/pending, unreleased 59 . K ^TMP("ORR",$J) 60 . D EN^ORQ1(ORVP,ORDG,FLG,0,SDATE,EDATE) 61 . I '$O(^TMP("ORR",$J,ORLIST,0)) Q 62 . S I=0 63 . F S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I S X=^(I) D 64 .. S ORIFN=+X,J=0,DIV="" 65 .. Q:'$D(^OR(100,ORIFN,0)) S ORX0=^(0),ORX3=^(3) 66 .. S ORSTAT=$S($D(^ORD(100.01,+$P(ORX3,"^",3),0)):$P(^(0),"^"),1:""),ORLOC=$S($L($P($G(^SC(+$P(ORX0,"^",10),0)),"^")):$P(^(0),"^"),1:"UNKNOWN") 67 .. I +$P(ORX0,"^",10) S DIV=$P($G(^SC(+$P(ORX0,"^",10),0)),U,15),DIV=$S(DIV:$P($$SITE^VASITE(DT,DIV),"^",2),1:"") 68 .. F S J=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",J)) Q:'J I +$G(^OR(100,ORIFN,4.5,J,1))=ITEM D 69 ... S CNT=CNT+1,OROOT(CNT)="Duplicate order: "_ITEMNM_" entered "_$$FMTE^XLFDT($P(ORX0,"^",7))_" Div/Loc: "_DIV_":"_ORLOC_" ["_ORSTAT_"]" 70 Q 71 LN ;Increment counts 72 S GCNT=GCNT+1,CCNT=1 73 Q 1 ORWDXVB2 ;slc/dcm - Order dialog utilities for Blood Bank Cont.;3/2/04 09:31 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17 1997 3 ; 4 ERROR ;Process error 5 D LN 6 S VBERROR=$P(ORX("ERROR"),"^",2) 7 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN 8 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 9 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* WARNING! *",.CCNT) D LN 10 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 11 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* An Error occurred attempting to *",.CCNT) D LN 12 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* retrieve Blood Bank order data. *",.CCNT) D LN 13 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 14 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* This order cannot be completed at this time. *",.CCNT) D LN 15 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* Revert to local downtime procedures to continue *",.CCNT) D LN 16 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* order or retry this option at a later time. *",.CCNT) D LN 17 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 18 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* Contact the Blood Bank System Administrator *",.CCNT) D LN 19 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 20 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN 21 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 22 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* Error Message *",.CCNT) D LN 23 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 24 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*",.CCNT) 25 I $L(VBERROR)<68 D 26 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(VBERROR)/2,CCNT,VBERROR,.CCNT) 27 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN 28 I $L(VBERROR)>68 D 29 . I $L(VBERROR)>136 S VBERROR=$E(VBERROR,1,136)_"..." 30 . N L1 S L1=$E(VBERROR,1,$L(VBERROR)/2) 31 . I $E(L1,$L(L1))'=" " D 32 . . S LINE1=$E(L1,1,($L(L1)-($L($P(L1," ",$L(L1," ")))))),LINE2=$E(VBERROR,$L(LINE1)+1,$L(VBERROR)) 33 . E S LINE1=$E(L1),LINE2=$E(VBERROR,$L(LINE1)+1,$L(VBERROR)) 34 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(LINE1)/2,CCNT,LINE1,.CCNT) 35 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN 36 . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*",.CCNT) 37 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(LINE2)/2,CCNT,LINE2,.CCNT) 38 . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN 39 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN 40 S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN 41 D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN 42 Q 43 LN ;Increment counts 44 S GCNT=GCNT+1,CCNT=1 45 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI.m
r613 r623 1 ORWGAPI ; SLC/STAFF - Graph API ;12/21/05 08:14 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 3 ; 4 ALLITEMS(ITEMS,DFN) ; API - return all items of data on patient (procedures, tests, codes,..) 5 N CNT,SUB,TMP,TYPE 6 K ^TMP("ORWGAPI",$J) 7 S DFN=+$G(DFN) I 'DFN Q 8 D TYPES("ORWGAPI",DFN) 9 D RETURN^ORWGAPIW(.TMP,.ITEMS) 10 S CNT=0 11 S SUB="" 12 F S SUB=$O(^TMP("ORWGAPI",$J,SUB)) Q:SUB="" D 13 . S TYPE=$P(^TMP("ORWGAPI",$J,SUB),U) 14 . D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,0,,,.CNT,TMP) 15 D SETLAST^ORWGTASK(DFN) 16 K ^TMP("ORWGAPI",$J) 17 Q 18 ; 19 ALLVIEWS(DATA,VIEW,USER) ; API - get all graph views 20 D ALLVIEWS^ORWGAPIP(.DATA,+$G(VIEW),+$G(USER)) 21 Q 22 ; 23 CLASS(DATA,TYPE) ; API - get classification 24 I TYPE=50.605 D DRUGC^ORWGAPIC(.DATA) 25 I TYPE=68 D ACC^ORWGAPIC(.DATA) 26 I TYPE=8925.1 D TIUTITLE^ORWGAPIA(.DATA) 27 I TYPE=100.98 D OITEM^ORWGAPIA(.DATA) 28 Q 29 ; 30 DATEDATA(DATA,OLDEST,NEWEST,TYPEITEM,DFN) ; API - return all data for an item on patient for date range 31 N CNT,ITEM,SUB,TMP,TYPE 32 S DFN=+$G(DFN) I 'DFN Q 33 S OLDEST=+$G(OLDEST) 34 S NEWEST=+$G(NEWEST,$$NOW^ORWGAPIX) 35 S TYPEITEM=$G(TYPEITEM) I TYPEITEM'[U Q 36 I 'OLDEST D ITEMDATA(.DATA,TYPEITEM,NEWEST,DFN,OLDEST) Q 37 I OLDEST<NEWEST Q 38 S TYPEITEM=$$UP^ORWGAPIX(TYPEITEM) 39 D RETURN^ORWGAPIW(.TMP,.DATA) 40 S TYPE=$P(TYPEITEM,U) 41 S ITEM=$P(TYPEITEM,U,2) 42 S CNT=0 43 D DATA^ORWGAPIR(.DATA,ITEM,TYPE,NEWEST,DFN,.CNT,TMP,OLDEST) 44 Q 45 ; 46 DATEITEM(ITEMS,OLDEST,NEWEST,TYPE,DFN) ; API - return all file items on patient for date range 47 N CNT,SUB,TMP 48 K ^TMP("ORWGAPI",$J) 49 S DFN=+$G(DFN) I 'DFN Q 50 S OLDEST=+$G(OLDEST),NEWEST=+$G(NEWEST),TYPE=$G(TYPE) 51 I $L(TYPE) S ^TMP("ORWGAPI",$J,1)=TYPE 52 I '$L(TYPE) D TYPES("ORWGAPI",DFN) 53 D RETURN^ORWGAPIW(.TMP,.ITEMS) 54 S CNT=0 55 S SUB="" 56 F S SUB=$O(^TMP("ORWGAPI",$J,SUB)) Q:SUB="" D 57 . S TYPE=$P(^TMP("ORWGAPI",$J,SUB),U) 58 . D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,6,OLDEST,NEWEST,.CNT,TMP) 59 K ^TMP("ORWGAPI",$J) 60 Q 61 ; 62 DELVIEWS(DATA,NAME,PUBLIC) ; API - delete a graph view 63 D DELVIEWS^ORWGAPIP(.DATA,$G(NAME),$G(PUBLIC)) 64 Q 65 ; 66 DETAIL(DATA,DFN,DATE1,DATE2,VAL,COMP) ; API - get all reports for types of data from items and date range 67 D DETAIL^ORWGAPID("ORWGRPC",DFN,DATE1,DATE2,.VAL) 68 S DATA=$NA(^TMP("ORWGRPC",$J)) 69 Q 70 ; 71 DETAILS(DATA,DFN,DATE1,DATE2,TYPE,COMP) ; API - get report for type of data for a date or date range 72 D DETAILS^ORWGAPID("ORWGRPC",DFN,DATE1,DATE2,TYPE) 73 S DATA=$NA(^TMP("ORWGRPC",$J)) 74 Q 75 ; 76 FASTDATA(DATA,DFN) ; API - get all data (non-lab) on patient 77 D FASTDATA^ORWGAPIF(.DATA,DFN) 78 Q 79 ; 80 FASTITEM(ITEMS,DFN) ; API - get all items on patient 81 D FASTITEM^ORWGAPIF(.ITEMS,DFN) 82 D SETLAST^ORWGTASK(DFN) 83 Q 84 ; 85 FASTLABS(DATA,DFN) ; API - get all lab data on patient 86 D FASTLABS^ORWGAPIF(.DATA,DFN) 87 Q 88 ; 89 FASTTASK(STATUS,DFN,OLDDFN) ; API - process cache of all data and items on patient, -1 if turned off 90 ; this should be able to be turned off if needbe (D CLEAN^ORWGTASK) 91 D UPDATE^ORWGTASK(.STATUS,DFN,DUZ,+$G(OLDDFN)) 92 Q 93 ; 94 GETDATES(DATA,REPORTID) ; API - get graph date ranges 95 D GETDATES^ORWGAPID(.DATA,$G(REPORTID)) 96 Q 97 ; 98 GETPREF(DATA) ; API - get graph settings 99 D GETPREF^ORWGAPIP(.DATA) 100 Q 101 ; 102 GETSIZE(DATA) ; API - get graph positions and sizes 103 D GETSIZE^ORWGAPIP(.DATA) 104 Q 105 ; 106 GETVIEWS(DATA,ALL,PUBLIC,EXT,USER) ; API - get graph views 107 D GETVIEWS^ORWGAPIP(.DATA,$G(ALL),$G(PUBLIC),$G(EXT),+$G(USER)) 108 Q 109 ; 110 ITEMDATA(DATA,TYPEITEM,START,DFN,BACKTO) ; API - return data of an item on patient (glucose results) 111 N CNT,ITEM,TMP,TYPE 112 S DFN=+$G(DFN) I 'DFN Q 113 S TYPEITEM=$G(TYPEITEM) I TYPEITEM'[U Q 114 S TYPEITEM=$$UP^ORWGAPIX(TYPEITEM) 115 S START=$G(START,$$NOW^ORWGAPIX) 116 D RETURN^ORWGAPIW(.TMP,.DATA) 117 S TYPE=$P(TYPEITEM,U) 118 S ITEM=$P(TYPEITEM,U,2) 119 S CNT=0 120 D DATA^ORWGAPIR(.DATA,ITEM,TYPE,START,DFN,.CNT,TMP,$G(BACKTO)) 121 Q 122 ; 123 ITEMS(ITEMS,DFN,TYPE) ; API - return items of a type of data on patient (lab tests) 124 N CNT,TMP 125 S DFN=+$G(DFN) I 'DFN Q 126 S TYPE=$G(TYPE) I '$L(TYPE) Q 127 D RETURN^ORWGAPIW(.TMP,.ITEMS) 128 S CNT=0 129 D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,3,,,.CNT,TMP) 130 I TYPE=63 D SETLAST^ORWGTASK(DFN) 131 Q 132 ; 133 LOOKUP(VAL,FILE,FROM,DIR) ; API - get item names for long lookup 134 N REF,SCREEN,XREF 135 D FILE^ORWGAPIU($G(FILE),.REF,.XREF,.SCREEN) 136 I '$L(REF) Q 137 D GENERIC^ORWGAPIW(.VAL,.FROM,DIR,FILE,REF,XREF,SCREEN) 138 Q 139 ; 140 PUBLIC(USER) ; API - $$(user) -> 1 if user can edit public settings and views 141 Q $$PUBLIC^ORWGAPIP(USER) 142 ; 143 RPTPARAM(IEN) ; API - $$(ien) -> PARAM1^PARAM2 for graph report else "" 144 Q $$RPTPARAM^ORWGAPIP(IEN) 145 ; 146 SETPREF(DATA,VAL,PUBLIC) ; API - set a graph setting 147 D SETPREF^ORWGAPIP(.DATA,$G(VAL),$G(PUBLIC)) 148 Q 149 ; 150 SETSIZE(DATA,VAL) ; API - set graph positions and settings 151 D SETSIZE^ORWGAPIP(.DATA,.VAL) 152 Q 153 ; 154 SETVIEWS(DATA,NAME,PUBLIC,VAL) ; API - set a graph view 155 D SETVIEWS^ORWGAPIP(.DATA,$G(NAME),$G(PUBLIC),.VAL) 156 Q 157 ; 158 TAX(DATA,ALL,REMTAX) ; API - get reminder taxonomies 159 D TAX^ORWGAPID(.DATA,+$G(ALL),.REMTAX) 160 Q 161 ; 162 TESTING(DATA) ; API - return test data 163 D TESTING^ORWGTEST(.DATA) 164 Q 165 ; 166 TESTSPEC(DATA) ; API - return test/spec info on all lab tests 167 D TESTSPEC^ORWGAPIC(.DATA) 168 Q 169 ; 170 TYPES(TYPES,DFN,SUB) ; API - return all types of data on patient (if no dfn, return all) 171 N TMP 172 S DFN=+$G(DFN) 173 S SUB=+$G(SUB) 174 D RETURN^ORWGAPIW(.TMP,.TYPES) 175 D TYPES^ORWGAPIT(.TYPES,DFN,SUB,TMP) 176 Q 1 ORWGAPI ; SLC/STAFF - Graph API ;12/21/05 08:14 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 3 ; 4 ALLITEMS(ITEMS,DFN) ; API - return all items of data on patient (procedures, tests, codes,..) 5 N CNT,SUB,TMP,TYPE 6 K ^TMP("ORWGAPI",$J) 7 S DFN=+$G(DFN) I 'DFN Q 8 D TYPES("ORWGAPI",DFN) 9 D RETURN^ORWGAPIU(.TMP,.ITEMS) 10 S CNT=0 11 S SUB="" 12 F S SUB=$O(^TMP("ORWGAPI",$J,SUB)) Q:SUB="" D 13 . S TYPE=$P(^TMP("ORWGAPI",$J,SUB),U) 14 . D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,0,,,.CNT,TMP) 15 K ^TMP("ORWGAPI",$J) 16 Q 17 ; 18 CLASS(DATA,TYPE) ; API - get classification 19 I TYPE=50.605 D DRUGC^ORWGAPIA(.DATA) 20 I TYPE=68 D ACC^ORWGAPIA(.DATA) 21 I TYPE=8925.1 D TIUTITLE^ORWGAPIA(.DATA) 22 I TYPE=100.98 D OITEM^ORWGAPIA(.DATA) 23 Q 24 ; 25 DATEITEM(ITEMS,OLDEST,NEWEST,TYPE,DFN) ; API - return all file items on patient for date range 26 N CNT,SUB,TMP 27 K ^TMP("ORWGAPI",$J) 28 S DFN=+$G(DFN) I 'DFN Q 29 S OLDEST=+$G(OLDEST),NEWEST=+$G(NEWEST),TYPE=$G(TYPE) 30 I $L(TYPE) S ^TMP("ORWGAPI",$J,1)=TYPE 31 I '$L(TYPE) D TYPES("ORWGAPI",DFN) 32 D RETURN^ORWGAPIU(.TMP,.ITEMS) 33 S CNT=0 34 S SUB="" 35 F S SUB=$O(^TMP("ORWGAPI",$J,SUB)) Q:SUB="" D 36 . S TYPE=$P(^TMP("ORWGAPI",$J,SUB),U) 37 . D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,6,OLDEST,NEWEST,.CNT,TMP) 38 K ^TMP("ORWGAPI",$J) 39 Q 40 ; 41 DELVIEWS(DATA,NAME,PUBLIC) ; API - delete a graph view 42 D DELVIEWS^ORWGAPIP(.DATA,$G(NAME),$G(PUBLIC)) 43 Q 44 ; 45 DETAIL(DATA,DFN,DATE1,DATE2,VAL,COMP) ; API - get all reports for types of data from items and date range 46 D DETAIL^ORWGAPID("ORWGRPC",DFN,DATE1,DATE2,.VAL) 47 S DATA=$NA(^TMP("ORWGRPC",$J)) 48 Q 49 ; 50 DETAILS(DATA,DFN,DATE1,DATE2,TYPE,COMP) ; API - get report for type of data for a date or date range 51 D DETAILS^ORWGAPID("ORWGRPC",DFN,DATE1,DATE2,TYPE) 52 S DATA=$NA(^TMP("ORWGRPC",$J)) 53 Q 54 ; 55 GETDATES(DATA,REPORTID) ; API - get graph date ranges 56 N DAT,TMP K DAT 57 S REPORTID=$G(REPORTID) 58 D RETURN^ORWGAPIU(.TMP,.DATA) 59 S DAT(1)="S^Date Range..." 60 S DAT(2)="1^Today" 61 S DAT(3)="2^One Week" 62 S DAT(4)="3^Two Weeks" 63 S DAT(5)="4^One Month" 64 S DAT(6)="5^Six Months" 65 S DAT(7)="6^One Year" 66 S DAT(8)="7^Two Years" 67 S DAT(9)="8^All Results" 68 D DATES^ORWGAPIP(.DAT,REPORTID) 69 I TMP M ^TMP(DATA,$J)=DAT 70 I 'TMP M DATA=DAT 71 Q 72 ; 73 GETPREF(DATA) ; API - get graph settings 74 D GETPREF^ORWGAPIP(.DATA) 75 Q 76 ; 77 GETSIZE(DATA) ; API - get graph positions and sizes 78 D GETSIZE^ORWGAPIP(.DATA) 79 Q 80 ; 81 GETVIEWS(DATA,ALL,PUBLIC,EXT) ; API - get graph views 82 D GETVIEWS^ORWGAPIP(.DATA,$G(ALL),$G(PUBLIC),$G(EXT)) 83 Q 84 ; 85 ITEMDATA(DATA,ITEM,START,DFN) ; API - return data of an item on patient (glucose results) 86 N CNT,FILE,TMP 87 S DFN=+$G(DFN) I 'DFN Q 88 S ITEM=$G(ITEM) I ITEM'[U Q 89 S START=$G(START,$$NOW^ORWGAPIX) 90 D RETURN^ORWGAPIU(.TMP,.DATA) 91 S FILE=$P(ITEM,U) 92 S ITEM=$P(ITEM,U,2) 93 S CNT=0 94 D DATA^ORWGAPIR(.DATA,ITEM,FILE,START,DFN,.CNT,TMP) 95 Q 96 ; 97 ITEMS(ITEMS,DFN,TYPE) ; API - return items of a type of data on patient (lab tests) 98 N CNT,TMP 99 S DFN=+$G(DFN) I 'DFN Q 100 S TYPE=$G(TYPE) I '$L(TYPE) Q 101 D RETURN^ORWGAPIU(.TMP,.ITEMS) 102 S CNT=0 103 D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,3,,,.CNT,TMP) 104 Q 105 ; 106 LOOKUP(VAL,FILE,FROM,DIR) ; API - get item names for long lookup 107 N REF,SCREEN,XREF 108 D FILE^ORWGAPIU($G(FILE),.REF,.XREF,.SCREEN) 109 I '$L(REF) Q 110 D GENERIC^ORWGAPIU(.VAL,.FROM,DIR,FILE,REF,XREF,SCREEN) 111 Q 112 ; 113 PUBLIC(USER) ; API - $$(user) -> 1 if user can edit public settings and views 114 Q $$PUBLIC^ORWGAPIP(USER) 115 ; 116 RPTPARAM(IEN) ; API - $$(ien) -> PARAM1^PARAM2 for graph report else "" 117 Q $$RPTPARAM^ORWGAPIP(IEN) 118 ; 119 SETPREF(DATA,VAL,PUBLIC) ; API - set a graph setting 120 D SETPREF^ORWGAPIP(.DATA,$G(VAL),$G(PUBLIC)) 121 Q 122 ; 123 SETSIZE(DATA,VAL) ; API - set graph positions and settings 124 D SETSIZE^ORWGAPIP(.DATA,.VAL) 125 Q 126 ; 127 SETVIEWS(DATA,NAME,PUBLIC,VAL) ; API - set a graph view 128 D SETVIEWS^ORWGAPIP(.DATA,$G(NAME),$G(PUBLIC),.VAL) 129 Q 130 ; 131 TAX(DATA,ALL,REMTAX) ; API - get reminder taxonomies 132 D TAX^ORWGAPID(.DATA,+$G(ALL),.REMTAX) 133 Q 134 ; 135 TESTSPEC(DATA) ; API - return test/spec info on all lab tests 136 N CNT,LINE,TEST,TMP,SPEC 137 D RETURN^ORWGAPIU(.TMP,.DATA) 138 S CNT=0 139 S TEST=0 140 F S TEST=$O(^LAB(60,TEST)) Q:TEST<1 D 141 . S SPEC=0 142 . F S SPEC=$O(^LAB(60,TEST,1,SPEC)) Q:SPEC<1 D 143 .. S CNT=CNT+1 144 .. S LINE=TEST_U_$G(^LAB(60,TEST,1,SPEC,0)) 145 .. I $P(LINE,U,3)[$C(34) S $P(LINE,U,3)=$$TRIM^ORWGAPIX($P(LINE,U,3),"LR",$C(34)) 146 .. I $P(LINE,U,4)[$C(34) S $P(LINE,U,4)=$$TRIM^ORWGAPIX($P(LINE,U,4),"LR",$C(34)) 147 .. I TMP S ^TMP(DATA,$J,CNT)=LINE Q 148 .. S DATA(CNT)=LINE 149 Q 150 ; 151 TYPES(TYPES,DFN,SUB) ; API - return all types of data on patient (if no dfn, return all) 152 N TMP 153 S DFN=+$G(DFN) 154 S SUB=+$G(SUB) 155 D RETURN^ORWGAPIU(.TMP,.TYPES) 156 D TYPES^ORWGAPIT(.TYPES,DFN,SUB,TMP) 157 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI1.m
r613 r623 1 ORWGAPI1 ; SLC/STAFF - Graph Items ;12/21/05 08:15 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 3 ; 4 AA(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 5 ; FMT,OLDEST,NEWEST not used 6 N ITEM,FILE,NUM,REF,RESULT 7 K ^TMP("ORWGRPC DC",$J) 8 S ITEM="" 9 F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" D 10 . I $E(ITEM)="A" Q 11 . I $E(ITEM)="M" Q 12 . S RESULT=$$AALAB^ORWGAPIC(ITEM) 13 . I RESULT="" Q 14 . S RESULT="68^"_RESULT 15 . S ^TMP("ORWGRPC DC",$J,RESULT)="" 16 S RESULT="" 17 F S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT="" S CNT=CNT+1 D 18 . D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 19 K ^TMP("ORWGRPC DC",$J) 20 Q 21 ; 22 AP(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 23 N DATE,ITEM,OK,RESULT 24 S ITEM="A" 25 F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" Q:ITEM]"AZ" D 26 . S OK=0 27 . I FMT=6 D 28 .. S DATE=OLDEST 29 .. F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 30 ... S CNT=CNT+1 31 ... S OK=1 32 ... S RESULT="63AP"_U_ITEM 33 . I FMT=3 D 34 .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1) 35 .. I 'DATE Q 36 .. S OK=1 37 .. S CNT=CNT+1 38 .. S RESULT="63AP^"_ITEM_"^^"_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE 39 . I FMT=0 D 40 .. S OK=1 41 .. S CNT=CNT+1 42 .. S RESULT="63AP^"_ITEM_U_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01) 43 . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 44 Q 45 ; 46 LAB(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 47 N DATE,ITEM,OK,RESULT 48 S ITEM=0 49 F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM<1 D 50 . S OK=0 51 . I FMT=6 D 52 .. S DATE=OLDEST 53 .. F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 54 ... S CNT=CNT+1 55 ... S OK=1 56 ... S RESULT=63_U_ITEM 57 . I FMT=3 D 58 .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1) 59 .. I 'DATE Q 60 .. S CNT=CNT+1 61 .. S OK=1 62 .. S RESULT=63_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE 63 . I FMT=0 D 64 .. S CNT=CNT+1 65 .. S OK=1 66 .. S RESULT=63_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,63,.01) 67 . I OK D 68 .. S RESULT=RESULT_U_$$AALAB^ORWGAPIC(ITEM) 69 .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 70 Q 71 ; 72 MI(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 73 N DATE,ITEM,OK,RESULT 74 S ITEM="M" 75 F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" Q:ITEM]"MZ" D 76 . S OK=0 77 . I FMT=6 D 78 .. S DATE=OLDEST 79 .. F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 80 ... S CNT=CNT+1 81 ... S OK=1 82 ... S RESULT="63MI"_U_ITEM 83 . I FMT=3 D 84 .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1) 85 .. I 'DATE Q 86 .. S CNT=CNT+1 87 .. S OK=1 88 .. S RESULT="63MI^"_ITEM_"^^"_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE 89 . I FMT=0 D 90 .. S CNT=CNT+1 91 .. S OK=1 92 .. S RESULT="63MI^"_ITEM_U_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01) 93 . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 94 Q 95 ; 96 MED(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 97 D MED1^ORWGAPIE(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP) 98 Q 99 ; 100 NOTES(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 101 N DATE,DOC,DOCCLASS,DOCIEN,DOCTYPE,DUMMY,RESULT,RESULTS,TITLE K DUMMY 102 K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) 103 S CNT=$G(CNT) 104 I FMT=6 D 105 . F DOCTYPE="P","D","C" D 106 .. S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) 107 .. K ^TMP("TIUR",$J) 108 .. D TIU^ORWGAPIA(.DUMMY,DOCCLASS,5,DFN,$G(OLDEST),$G(NEWEST)) 109 .. S DOC=0 110 .. F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D 111 ... S RESULTS=^TMP("TIUR",$J,DOC) 112 ... S TITLE=$P(RESULTS,U,2) 113 ... S DATE=$P(RESULTS,U,3) 114 ... I '$L(TITLE) Q 115 ... S ^TMP("ORWGRPC TEMP",$J,TITLE,DATE)=RESULTS 116 I FMT'=6 D 117 . F DOCTYPE="P","D","C" D 118 .. S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) 119 .. K ^TMP("TIUR",$J) 120 .. D TIU^ORWGAPIA(.DUMMY,DOCCLASS,5,DFN) 121 .. S DOC=0 122 .. F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D 123 ... S RESULTS=^TMP("TIUR",$J,DOC) 124 ... S TITLE=$P(RESULTS,U,2) 125 ... S DATE=$P(RESULTS,U,3) 126 ... I '$L(TITLE) Q 127 ... S ^TMP("ORWGRPC TEMP",$J,TITLE,DATE)=RESULTS 128 S TITLE="" 129 F S TITLE=$O(^TMP("ORWGRPC TEMP",$J,TITLE)) Q:TITLE="" D 130 . S CNT=CNT+1 131 . I FMT=6 S RESULT=8925_U_TITLE 132 . I FMT=3 D 133 .. S DATE=+$O(^TMP("ORWGRPC TEMP",$J,TITLE,""),-1) 134 .. S DOCIEN=+$G(^TMP("ORWGRPC TEMP",$J,TITLE,DATE)) 135 .. S RESULT=8925_U_TITLE_"^^"_TITLE_"^^" 136 .. S RESULT=RESULT_DATE 137 .. S RESULT=RESULT_U_$$TITLE^ORWGAPIA(DOCIEN) 138 . I FMT=0 S RESULT=8925_U_TITLE_U_TITLE 139 . S RESULT=$$UP^ORWGAPIX(RESULT) 140 . D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 141 K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) 142 Q 143 ; 144 TITLE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 145 ; FMT,OLDEST,NEWEST not used 146 N ITEM,FILE,NUM,REF,RESULT 147 K ^TMP("ORWGRPC DC",$J) 148 S ITEM="" 149 F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" D 150 . I $E(ITEM)="A" Q 151 . I $E(ITEM)="M" Q 152 . S RESULT=$$AALAB^ORWGAPIC(ITEM) 153 . I RESULT="" Q 154 . S RESULT="68^"_RESULT 155 . S ^TMP("ORWGRPC DC",$J,RESULT)="" 156 S RESULT="" 157 F S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT="" S CNT=CNT+1 D 158 . D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 159 K ^TMP("ORWGRPC DC",$J) 160 Q 161 ; 1 ORWGAPI1 ; SLC/STAFF - Graph Items ;12/21/05 08:15 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 3 ; 4 AA(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 5 ; FMT,OLDEST,NEWEST not used 6 N ITEM,FILE,NUM,REF,RESULT 7 K ^TMP("ORWGRPC DC",$J) 8 S ITEM="" 9 F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" D 10 . I $E(ITEM)="A" Q 11 . I $E(ITEM)="M" Q 12 . S RESULT=$$AALAB^ORWGAPIA(ITEM) 13 . I RESULT="" Q 14 . S RESULT="68^"_RESULT 15 . S ^TMP("ORWGRPC DC",$J,RESULT)="" 16 S RESULT="" 17 F S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT="" S CNT=CNT+1 D 18 . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 19 K ^TMP("ORWGRPC DC",$J) 20 Q 21 ; 22 AP(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 23 N DATE,ITEM,OK,RESULT 24 S ITEM="A" 25 F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" Q:ITEM]"AZ" D 26 . S OK=0 27 . I FMT=6 D 28 .. S DATE=OLDEST 29 .. F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 30 ... S CNT=CNT+1 31 ... S OK=1 32 ... S RESULT="63AP"_U_ITEM 33 . I FMT=3 D 34 .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1) 35 .. I 'DATE Q 36 .. S OK=1 37 .. S CNT=CNT+1 38 .. S RESULT="63AP^"_ITEM_"^^"_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE 39 . I FMT=0 D 40 .. S OK=1 41 .. S CNT=CNT+1 42 .. S RESULT="63AP^"_ITEM_U_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01) 43 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 44 Q 45 ; 46 BCMA(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 47 N DATE,DRUG,ITEM,NUM,RESULT 48 K ^TMP("ORWGRPC TEMP",$J) 49 I FMT=6 D 50 . S DATE=OLDEST 51 . F S DATE=$O(^PSB(53.79,"AADT",DFN,DATE)) Q:DATE<1 Q:DATE>NEWEST D 52 .. S NUM=0 53 .. F S NUM=$O(^PSB(53.79,"AADT",DFN,DATE,NUM)) Q:NUM<1 D 54 ... S ITEM=$P($G(^PSB(53.79,NUM,0)),U,8) I 'ITEM Q 55 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q 56 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" 57 ... S CNT=CNT+1 58 ... S RESULT="53.79^"_ITEM 59 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 60 I FMT'=6 D 61 . S ITEM="" 62 . F S ITEM=$O(^PSB(53.79,"AOIP",DFN,ITEM)) Q:ITEM="" D 63 .. S DATE=$O(^PSB(53.79,"AOIP",DFN,ITEM,""),-1) 64 .. I 'DATE Q 65 .. S NUM=$O(^PSB(53.79,"AOIP",DFN,ITEM,DATE,""),-1) 66 .. I 'NUM Q 67 .. S CNT=CNT+1 68 .. I FMT=3 S RESULT="53.79^"_ITEM_"^^"_$$POINAME^ORWGAPIA(ITEM)_"^^"_DATE 69 .. I FMT=0 S RESULT="53.79^"_ITEM_U_$$POINAME^ORWGAPIA(ITEM) 70 .. S DRUG=$$DRUG^ORWGAPIA(NUM) 71 .. I DRUG S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIA(DRUG) 72 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 73 K ^TMP("ORWGRPC TEMP",$J) 74 Q 75 ; 76 DC(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 77 ; FMT,OLDEST,NEWEST not used 78 N DATA,DATE,DATE1,DRUG,ITEM,FILE,NUM,REF,RESULT K DATA 79 K ^TMP("ORWGRPC DC",$J) 80 F FILE=52,55 D 81 . S ITEM="" 82 . F S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM="" D 83 .. S RESULT=$$DRGCLASS^ORWGAPIA(ITEM) 84 .. I RESULT="" Q 85 .. S RESULT="50.605^"_RESULT 86 .. S ^TMP("ORWGRPC DC",$J,RESULT)="" 87 S ITEM="" 88 F S ITEM=$O(^PSB(53.79,"AOIP",DFN,ITEM)) Q:ITEM="" D 89 . S DATE=$O(^PSB(53.79,"AOIP",DFN,ITEM,""),-1) 90 . I 'DATE Q 91 . S NUM=$O(^PSB(53.79,"AOIP",DFN,ITEM,DATE,""),-1) 92 . I 'NUM Q 93 . S DRUG=$$DRUG^ORWGAPIA(NUM) 94 . I 'DRUG Q 95 . S RESULT=$$DRGCLASS^ORWGAPIA(DRUG) 96 . I 'RESULT Q 97 . S RESULT="50.605^"_RESULT 98 . S ^TMP("ORWGRPC DC",$J,RESULT)="" 99 S ITEM="" 100 F S ITEM=$O(^PXRMINDX("55NVA","PI",DFN,ITEM)) Q:ITEM="" D 101 . S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,""),-1) 102 . I 'DATE Q 103 . S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,""),-1) 104 . I '$L(DATE1) Q 105 . S REF=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE1,""),-1) 106 . I '$L(REF) Q 107 . D RXNVA^ORWGAPIA(REF,.DATA) 108 . S DRUG=+$G(DATA("DISPENSE DRUG")) 109 . I 'DRUG Q 110 . S RESULT=$$DRGCLASS^ORWGAPIA(DRUG) 111 . I 'RESULT Q 112 . S RESULT="50.605^"_RESULT 113 . S ^TMP("ORWGRPC DC",$J,RESULT)="" 114 S RESULT="" 115 F S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT="" S CNT=CNT+1 D 116 . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 117 K ^TMP("ORWGRPC DC",$J) 118 Q 119 ; 120 LAB(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 121 N DATE,ITEM,OK,RESULT 122 S ITEM=0 123 F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM<1 D 124 . S OK=0 125 . I FMT=6 D 126 .. S DATE=OLDEST 127 .. F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 128 ... S CNT=CNT+1 129 ... S OK=1 130 ... S RESULT=63_U_ITEM 131 . I FMT=3 D 132 .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1) 133 .. I 'DATE Q 134 .. S CNT=CNT+1 135 .. S OK=1 136 .. S RESULT=63_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE 137 . I FMT=0 D 138 .. S CNT=CNT+1 139 .. S OK=1 140 .. S RESULT=63_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,63,.01) 141 . I OK D 142 .. S RESULT=RESULT_U_$$AALAB^ORWGAPIA(ITEM) 143 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 144 Q 145 ; 146 MI(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 147 N DATE,ITEM,OK,RESULT 148 S ITEM="M" 149 F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" Q:ITEM]"MZ" D 150 . S OK=0 151 . I FMT=6 D 152 .. S DATE=OLDEST 153 .. F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 154 ... S CNT=CNT+1 155 ... S OK=1 156 ... S RESULT="63MI"_U_ITEM 157 . I FMT=3 D 158 .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1) 159 .. I 'DATE Q 160 .. S CNT=CNT+1 161 .. S OK=1 162 .. S RESULT="63MI^"_ITEM_"^^"_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE 163 . I FMT=0 D 164 .. S CNT=CNT+1 165 .. S OK=1 166 .. S RESULT="63MI^"_ITEM_U_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01) 167 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 168 Q 169 ; 170 MED(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 171 D MED1^ORWGAPID(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP) 172 Q 173 ; 174 NOTES(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 175 N DATE,DOC,DOCCLASS,DOCIEN,DOCTYPE,DUMMY,RESULT,RESULTS,TITLE K DUMMY 176 K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) 177 S CNT=$G(CNT) 178 I FMT=6 D 179 . F DOCTYPE="P","D","C" D 180 .. S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) 181 .. K ^TMP("TIUR",$J) 182 .. D TIU^ORWGAPIA(.DUMMY,DOCCLASS,5,DFN,$G(OLDEST),$G(NEWEST)) 183 .. S DOC=0 184 .. F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D 185 ... S RESULTS=^TMP("TIUR",$J,DOC) 186 ... S TITLE=$P(RESULTS,U,2) 187 ... S DATE=$P(RESULTS,U,3) 188 ... I '$L(TITLE) Q 189 ... S ^TMP("ORWGRPC TEMP",$J,TITLE,DATE)=RESULTS 190 I FMT'=6 D 191 . F DOCTYPE="P","D","C" D 192 .. S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) 193 .. K ^TMP("TIUR",$J) 194 .. D TIU^ORWGAPIA(.DUMMY,DOCCLASS,5,DFN) 195 .. S DOC=0 196 .. F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D 197 ... S RESULTS=^TMP("TIUR",$J,DOC) 198 ... S TITLE=$P(RESULTS,U,2) 199 ... S DATE=$P(RESULTS,U,3) 200 ... I '$L(TITLE) Q 201 ... S ^TMP("ORWGRPC TEMP",$J,TITLE,DATE)=RESULTS 202 S TITLE="" 203 F S TITLE=$O(^TMP("ORWGRPC TEMP",$J,TITLE)) Q:TITLE="" D 204 . S CNT=CNT+1 205 . I FMT=6 S RESULT=8925_U_TITLE 206 . I FMT=3 D 207 .. S DATE=+$O(^TMP("ORWGRPC TEMP",$J,TITLE,""),-1) 208 .. S DOCIEN=+$G(^TMP("ORWGRPC TEMP",$J,TITLE,DATE)) 209 .. S RESULT=8925_U_TITLE_"^^"_TITLE_"^^" 210 .. S RESULT=RESULT_DATE 211 .. S RESULT=RESULT_U_$$TITLE^ORWGAPIA(DOCIEN) 212 . I FMT=0 S RESULT=8925_U_TITLE_U_TITLE 213 . S RESULT=$$UP^ORWGAPIX(RESULT) 214 . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 215 K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) 216 Q 217 ; 218 NVAE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 219 N DATA,DATE,DATE1,DRUG,ITEM,OK,REF,RESULT K DATA 220 S ITEM="" 221 F S ITEM=$O(^PXRMINDX("55NVA","PI",DFN,ITEM)) Q:ITEM="" D 222 . S OK=0 223 . I FMT=6 D 224 .. S DATE=OLDEST 225 .. F S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 226 ... S CNT=CNT+1 227 ... S OK=1 228 ... S RESULT="55NVAE"_U_ITEM 229 . I FMT'=6 D 230 .. S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,""),-1) 231 .. I 'DATE Q 232 .. S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,""),-1) 233 .. I '$L(DATE1) Q 234 .. S REF=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE1,""),-1) 235 .. I '$L(REF) Q 236 .. D RXNVA^ORWGAPIA(REF,.DATA) 237 .. S DRUG=+$G(DATA("DISPENSE DRUG")) 238 .. S CNT=CNT+1 239 .. S OK=1 240 .. I FMT=3 S RESULT="55NVAE"_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,"55NVA",.01)_"^^"_DATE 241 .. I FMT=0 S RESULT="55NVAE"_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,"55NVA",.01) 242 .. I DRUG S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIA(DRUG) 243 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 244 Q 245 ; 246 NVA(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 247 D NVA1^ORWGAPID(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP) 248 Q 249 ; 250 TITLE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 251 ; FMT,OLDEST,NEWEST not used 252 N ITEM,FILE,NUM,REF,RESULT 253 K ^TMP("ORWGRPC DC",$J) 254 S ITEM="" 255 F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" D 256 . I $E(ITEM)="A" Q 257 . I $E(ITEM)="M" Q 258 . S RESULT=$$AALAB^ORWGAPIA(ITEM) 259 . I RESULT="" Q 260 . S RESULT="68^"_RESULT 261 . S ^TMP("ORWGRPC DC",$J,RESULT)="" 262 S RESULT="" 263 F S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT="" S CNT=CNT+1 D 264 . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 265 K ^TMP("ORWGRPC DC",$J) 266 Q 267 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI2.m
r613 r623 1 ORWGAPI2 ; SLC/STAFF - Graph API Items ;12/21/05 08:16 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 3 ; 4 ADVERSE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 5 N DATE,IEN,ITEM,RESULT 6 K ^TMP("ORWGRPC SORT",$J),^TMP("ORWGRPC TEMP",$J) 7 S IEN=0 8 F S IEN=$O(^GMR(120.8,"B",DFN,IEN)) Q:IEN<1 D 9 . I '$D(^GMR(120.8,IEN,0)) Q 10 . I $G(^GMR(120.8,IEN,"ER")) Q 11 . I '$P(^GMR(120.8,IEN,0),U,12) Q 12 . S DATE=+$P($G(^GMR(120.8,IEN,0)),U,4) I 'DATE Q 13 . S ITEM=$P(^GMR(120.8,IEN,0),U,2) I '$L(ITEM) Q 14 . S ^TMP("ORWGRPC SORT",$J,DATE,ITEM)="" ;ADVERSE 15 I FMT=6 D 16 . S DATE=OLDEST 17 . F S DATE=$O(^TMP("ORWGRPC SORT",$J,DATE)) Q:DATE<1 Q:DATE>NEWEST D 18 .. S ITEM="" 19 .. F S ITEM=$O(^TMP("ORWGRPC SORT",$J,DATE,ITEM)) Q:ITEM="" D 20 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q 21 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" 22 ... S CNT=CNT+1 23 ... S RESULT="120.8^"_ITEM 24 ... D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 25 I FMT'=6 D 26 . S DATE=0 27 . F S DATE=$O(^TMP("ORWGRPC SORT",$J,DATE)) Q:DATE<1 D 28 .. S ITEM="" 29 .. F S ITEM=$O(^TMP("ORWGRPC SORT",$J,DATE,ITEM)) Q:ITEM="" D 30 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q 31 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" 32 ... S CNT=CNT+1 33 ... I FMT=3 S RESULT="120.8^"_ITEM_"^^"_ITEM_"^^"_DATE 34 ... I FMT=0 S RESULT="120.8^"_ITEM_U_ITEM 35 ... D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 36 K ^TMP("ORWGRPC SORT",$J),^TMP("ORWGRPC TEMP",$J) 37 Q 38 ; 39 PL(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 40 N DATE,ICD9,OK,PRIORITY,RESULT,STATUS 41 K ^TMP("ORWGRPC TEMP",$J) 42 S STATUS="" 43 F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D 44 . S PRIORITY="" 45 . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D 46 .. S ICD9="" 47 .. F S ICD9=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9)) Q:ICD9="" D 48 ... S OK=0 49 ... I FMT=6 D 50 .... S DATE=OLDEST 51 .... F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 52 ..... S CNT=CNT+1 53 ..... S OK=1 54 ..... S RESULT=9000011_U_ICD9 55 ... I FMT=3 D 56 .... S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9,""),-1) 57 .... I DATE S ^TMP("ORWGRPC TEMP",$J,ICD9,DATE)="" 58 ... I FMT=0 D 59 .... S CNT=CNT+1 60 .... S OK=1 61 .... S RESULT=9000011_U_ICD9_U_$$EVALUE^ORWGAPIU(ICD9,9000011,.01) 62 ... I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 63 I FMT=3 D 64 . S ICD9="" 65 . F S ICD9=$O(^TMP("ORWGRPC TEMP",$J,ICD9)) Q:ICD9="" D 66 .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,""),-1) 67 .. I 'DATE Q 68 .. S CNT=CNT+1 69 .. S RESULT=9000011_U_ICD9_"^^"_$$EVALUE^ORWGAPIU(ICD9,9000011,.01)_"^^"_DATE 70 .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 71 K ^TMP("ORWGRPC TEMP",$J) 72 Q 73 ; 74 PLX(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 75 D PLX2^ORWGAPID(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP) 76 Q 77 ; 78 REG(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 79 N DATE,ICD,ITEM,NUM,OK,RESULT 80 K ^TMP("ORWGRPC TEMP",$J) 81 I $E(FILE,3,4)="DX" S ICD="ICD9" 82 I $E(FILE,3,4)="OP" S ICD="ICD0" 83 S NUM="" 84 F S NUM=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM)) Q:NUM="" D 85 . S ITEM="" 86 . F S ITEM=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM)) Q:ITEM="" D 87 .. S OK=0 88 .. I FMT=6 D 89 ... S DATE=OLDEST 90 ... F S DATE=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 91 .... S CNT=CNT+1 92 .... S OK=1 93 .... S RESULT=FILE_U_ITEM 94 .. I FMT=3 D 95 ... S DATE=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM,""),-1) 96 ... I DATE S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)="" 97 .. I FMT=0 D 98 ... S CNT=CNT+1 99 ... S OK=1 100 ... S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,45_";"_ICD,.01) 101 .. I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 102 I FMT=3 D 103 . S ITEM="" 104 . F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM="" D 105 .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,""),-1) 106 .. I 'DATE Q 107 .. S CNT=CNT+1 108 .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,45_";"_ICD,.01)_"^^"_DATE 109 .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 110 K ^TMP("ORWGRPC TEMP",$J) 111 Q 112 ; 1 ORWGAPI2 ; SLC/STAFF - Graph API Items ;12/21/05 08:16 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 3 ; 4 ADMITS(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 5 N DATE,DATE2,DISCH,LINE,LST,NUM,OK,RESULT K LST 6 K ^TMP("ORWGRPC TEMP",$J) 7 D ADMITLST^ORWPT(.LST,DFN) 8 S OK=0 9 S NUM=0 10 F S NUM=$O(LST(NUM)) Q:NUM<1 D Q:OK 11 . S LINE=LST(NUM) 12 . S DATE=$P(LINE,U) 13 . S DISCH=$P(LINE,U,5) 14 . S DATE2=$$DISCH^ORWGAPIA(DISCH) 15 . I DATE2="" S DATE2=DATE2\1 16 . I FMT=6 D Q 17 .. I DATE>NEWEST Q 18 .. I DATE2>0,DATE2<OLDEST Q 19 .. I $D(^TMP("ORWGRPC TEMP",$J,"ADMIT")) Q 20 .. S ^TMP("ORWGRPC TEMP",$J,"ADMIT")="" 21 .. S CNT=CNT+1 22 .. S OK=1 23 .. S RESULT="405^ADMIT" 24 . I FMT=3 D Q 25 .. I $D(^TMP("ORWGRPC TEMP",$J,"ADMIT")) Q 26 .. S ^TMP("ORWGRPC TEMP",$J,"ADMIT")="" 27 .. S CNT=CNT+1 28 .. S OK=1 29 .. S RESULT="405^ADMIT^^ADMIT^^"_DATE 30 . I FMT=0 D Q 31 .. S ^TMP("ORWGRPC TEMP",$J,"ADMIT")="" 32 .. S CNT=CNT+1 33 .. S OK=1 34 .. S RESULT="405^ADMIT^ADMIT" 35 I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 36 K ^TMP("ORWGRPC TEMP",$J) 37 Q 38 ; 39 ADVERSE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 40 N DATE,IEN,ITEM,RESULT 41 K ^TMP("ORWGRPC SORT",$J),^TMP("ORWGRPC TEMP",$J) 42 S IEN=0 43 F S IEN=$O(^GMR(120.8,"B",DFN,IEN)) Q:IEN<1 D 44 . I '$D(^GMR(120.8,IEN,0)) Q 45 . I $G(^GMR(120.8,IEN,"ER")) Q 46 . I '$P(^GMR(120.8,IEN,0),U,12) Q 47 . S DATE=+$P($G(^GMR(120.8,IEN,0)),U,4) I 'DATE Q 48 . S ITEM=$P(^GMR(120.8,IEN,0),U,2) I '$L(ITEM) Q 49 . S ^TMP("ORWGRPC SORT",$J,DATE,ITEM)="" ;ADVERSE 50 I FMT=6 D 51 . S DATE=OLDEST 52 . F S DATE=$O(^TMP("ORWGRPC SORT",$J,DATE)) Q:DATE<1 Q:DATE>NEWEST D 53 .. S ITEM="" 54 .. F S ITEM=$O(^TMP("ORWGRPC SORT",$J,DATE,ITEM)) Q:ITEM="" D 55 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q 56 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" 57 ... S CNT=CNT+1 58 ... S RESULT="120.8^"_ITEM 59 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 60 I FMT'=6 D 61 . S DATE=0 62 . F S DATE=$O(^TMP("ORWGRPC SORT",$J,DATE)) Q:DATE<1 D 63 .. S ITEM="" 64 .. F S ITEM=$O(^TMP("ORWGRPC SORT",$J,DATE,ITEM)) Q:ITEM="" D 65 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q 66 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" 67 ... S CNT=CNT+1 68 ... I FMT=3 S RESULT="120.8^"_ITEM_"^^"_ITEM_"^^"_DATE 69 ... I FMT=0 S RESULT="120.8^"_ITEM_U_ITEM 70 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 71 K ^TMP("ORWGRPC SORT",$J),^TMP("ORWGRPC TEMP",$J) 72 Q 73 ; 74 PL(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 75 N DATE,ICD9,OK,PRIORITY,RESULT,STATUS 76 K ^TMP("ORWGRPC TEMP",$J) 77 S STATUS="" 78 F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D 79 . S PRIORITY="" 80 . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D 81 .. S ICD9="" 82 .. F S ICD9=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9)) Q:ICD9="" D 83 ... S OK=0 84 ... I FMT=6 D 85 .... S DATE=OLDEST 86 .... F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 87 ..... S CNT=CNT+1 88 ..... S OK=1 89 ..... S RESULT=9000011_U_ICD9 90 ... I FMT=3 D 91 .... S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9,""),-1) 92 .... I DATE S ^TMP("ORWGRPC TEMP",$J,ICD9,DATE)="" 93 ... I FMT=0 D 94 .... S CNT=CNT+1 95 .... S OK=1 96 .... S RESULT=9000011_U_ICD9_U_$$EVALUE^ORWGAPIU(ICD9,9000011,.01) 97 ... I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 98 I FMT=3 D 99 . S ICD9="" 100 . F S ICD9=$O(^TMP("ORWGRPC TEMP",$J,ICD9)) Q:ICD9="" D 101 .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,""),-1) 102 .. I 'DATE Q 103 .. S CNT=CNT+1 104 .. S RESULT=9000011_U_ICD9_"^^"_$$EVALUE^ORWGAPIU(ICD9,9000011,.01)_"^^"_DATE 105 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 106 K ^TMP("ORWGRPC TEMP",$J) 107 Q 108 ; 109 PLX(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 110 D PLX2^ORWGAPID(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP) 111 Q 112 ; 113 REG(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 114 N DATE,ICD,ITEM,NUM,OK,RESULT 115 K ^TMP("ORWGRPC TEMP",$J) 116 I $E(FILE,3,4)="DX" S ICD="ICD9" 117 I $E(FILE,3,4)="OP" S ICD="ICD0" 118 S NUM="" 119 F S NUM=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM)) Q:NUM="" D 120 . S ITEM="" 121 . F S ITEM=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM)) Q:ITEM="" D 122 .. S OK=0 123 .. I FMT=6 D 124 ... S DATE=OLDEST 125 ... F S DATE=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 126 .... S CNT=CNT+1 127 .... S OK=1 128 .... S RESULT=FILE_U_ITEM 129 .. I FMT=3 D 130 ... S DATE=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM,""),-1) 131 ... I DATE S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)="" 132 .. I FMT=0 D 133 ... S CNT=CNT+1 134 ... S OK=1 135 ... S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,45_";"_ICD,.01) 136 .. I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 137 I FMT=3 D 138 . S ITEM="" 139 . F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM="" D 140 .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,""),-1) 141 .. I 'DATE Q 142 .. S CNT=CNT+1 143 .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,45_";"_ICD,.01)_"^^"_DATE 144 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 145 K ^TMP("ORWGRPC TEMP",$J) 146 Q 147 ; 148 SURGERY(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 149 N CASE,DATE,PROC,RESULT,RESULTS,SURG,SURGPROC K SURG,SURGPROC 150 D SURG^ORWGAPIA(.SURG,DFN) 151 K SURG(0),SURG(1) 152 I FMT=6 D 153 . S CASE=0 154 . F S CASE=$O(SURG(CASE)) Q:CASE<1 D 155 .. S RESULTS=SURG(CASE) 156 .. S PROC=$P(RESULTS,U,3) 157 .. I '$L(PROC) Q 158 .. S DATE=$P(RESULTS,U,5) 159 .. I DATE>NEWEST Q 160 .. I DATE<OLDEST Q 161 .. I $D(SURGPROC(PROC)) Q 162 .. S SURGPROC(PROC)="" 163 .. S CNT=CNT+1 164 .. S RESULT=130_U_PROC 165 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 166 I FMT'=6 D 167 . S CASE=0 168 . F S CASE=$O(SURG(CASE)) Q:CASE<1 D 169 .. S RESULTS=SURG(CASE) 170 .. S PROC=$P(RESULTS,U,3) 171 .. I '$L(PROC) Q 172 .. S SURGPROC(PROC)=RESULTS 173 . K SURG S PROC="" 174 . F S PROC=$O(SURGPROC(PROC)) Q:PROC="" D 175 .. S CNT=CNT+1 176 .. I FMT=3 S RESULT=130_U_PROC_"^^"_PROC_"^^"_$P(SURGPROC(PROC),U,5) 177 .. I FMT=0 S RESULT=130_U_PROC_U_PROC 178 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 179 Q 180 ; 181 TREAT(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR ***** change to inverse dates 182 N DATE,IEN,ITEM,OLDEST1,RESULT 183 K ^TMP("ORWGRPC TEMP",$J) 184 I FMT=6 D 185 . S OLDEST1=9999999-OLDEST 186 . S DATE=9999999-NEWEST 187 . F S DATE=$O(^AUPNVTRT("AA",DFN,DATE)) Q:DATE<1 Q:DATE>OLDEST1 D 188 .. S IEN=0 189 .. F S IEN=$O(^AUPNVTRT("AA",DFN,DATE,IEN)) Q:IEN<1 D 190 ... S ITEM=+$G(^AUPNVTRT(IEN,0)) I 'ITEM Q 191 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q 192 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" 193 ... S CNT=CNT+1 194 ... S RESULT="9000010.15^"_ITEM 195 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 196 I FMT'=6 D 197 . S OLDEST1=9999999-OLDEST 198 . S DATE=9999999-NEWEST 199 . F S DATE=$O(^AUPNVTRT("AA",DFN,DATE)) Q:DATE<1 Q:DATE>OLDEST D 200 .. S IEN=0 201 .. F S IEN=$O(^AUPNVTRT("AA",DFN,DATE,IEN)) Q:IEN<1 D 202 ... S ITEM=+$G(^AUPNVTRT(IEN,0)) I 'ITEM Q 203 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q 204 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" 205 ... S CNT=CNT+1 206 ... I FMT=3 S RESULT="9000010.15^"_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,9000010.15)_"^^"_DATE 207 ... I FMT=0 S RESULT="9000010.15^"_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,9000010.15) 208 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 209 K ^TMP("ORWGRPC TEMP",$J) 210 Q 211 ; 212 VISITS(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 213 N DATE,DATE2,ITEM,NODE,NUM,OK,RESULT 214 K ^TMP("ORWGRPC TEMP",$J) 215 I FMT=6 D 216 . S DATE=0 217 . F S DATE=$O(^AUPNVSIT("AET",DFN,DATE)) Q:DATE<1 Q:DATE>NEWEST D 218 .. S ITEM="" 219 .. F S ITEM=$O(^AUPNVSIT("AET",DFN,DATE,ITEM)) Q:ITEM="" D 220 ... S NODE="" 221 ... F S NODE=$O(^AUPNVSIT("AET",DFN,DATE,ITEM,NODE)) Q:NODE="" D 222 .... S NUM=0 223 .... F S NUM=$O(^AUPNVSIT("AET",DFN,DATE,ITEM,NODE,NUM)) Q:NUM="" D 224 ..... S DATE2=+$P($G(^AUPNVSIT(NUM,0)),U,18) 225 ..... I 'DATE2 S DATE2=DATE+.01 226 ..... I +$E($P(DATE2,".",2),1,2)>24 S DATE2=(DATE\1)+.2359 227 ..... S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)=DATE2 228 . S ITEM=0 229 . F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM<1 D 230 .. S OK=0 231 .. S DATE=0 232 .. F S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) Q:DATE<1 Q:DATE>NEWEST D Q:OK 233 ... S DATE2=$G(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) 234 ... I DATE2<OLDEST Q 235 ... S CNT=CNT+1 236 ... S OK=1 237 ... S RESULT="9000010^"_ITEM 238 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 239 I FMT'=6 D 240 . S DATE=0 241 . F S DATE=$O(^AUPNVSIT("AET",DFN,DATE)) Q:DATE<1 D 242 .. S ITEM=0 243 .. F S ITEM=$O(^AUPNVSIT("AET",DFN,DATE,ITEM)) Q:ITEM<1 D 244 ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q 245 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" 246 ... S CNT=CNT+1 247 ... I FMT=3 S RESULT="9000010^"_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,9000010,.22)_"^^"_DATE 248 ... I FMT=0 S RESULT="9000010^"_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,9000010,.22) 249 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 250 K ^TMP("ORWGRPC TEMP",$J) 251 Q 252 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI3.m
r613 r623 1 ORWGAPI3 ; SLC/STAFF - Graph Data ;12/21/05 08:17 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 3 ; 4 ; 5 ADVERSE(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 6 N ADVERSE,DATE,DATE2,NODE,RESULT,RXN,VALUE 7 S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 8 S ADVERSE="" 9 S VALUE=ITEM_U_ITEM 10 S NODE="" 11 F S NODE=$O(^GMR(120.8,"B",DFN,NODE)) Q:NODE="" D 12 . I '$D(^GMR(120.8,NODE,0)) Q 13 . I $G(^GMR(120.8,NODE,"ER")) Q ; entered in error 14 . I '$P(^GMR(120.8,NODE,0),U,12) Q ; signed 15 . S DATE=+$P($G(^GMR(120.8,NODE,0)),U,4) I 'DATE Q 16 . I DATE>START Q 17 . I DATE<BACKTO Q 18 . I ITEM'=$P(^GMR(120.8,NODE,0),U,2) Q 19 . S RXN=0 20 . F S RXN=$O(^GMR(120.8,NODE,10,"B",RXN)) Q:RXN<1 D 21 .. S ADVERSE=ADVERSE_$$EVALUE^ORWGAPIU(RXN,120.8)_", " 22 . I $L(ADVERSE)>0 S ADVERSE=$E(ADVERSE,1,$L(ADVERSE)-2) 23 . S CNT=CNT+1 24 . S RESULT=120.8_U_ITEM_U_DATE_U_DATE2_U_ADVERSE 25 . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 26 Q 27 ; 28 DX(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 29 N DATE,DATE2,NODE,NUM,RESULT,VALUE,VALUES K VALUE 30 K ^TMP("ORWGRPC TEMP",$J) 31 S DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 32 S NUM="" 33 F S NUM=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM)) Q:NUM="" D 34 . S DATE="" 35 . F S DATE=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM,ITEM,DATE)) Q:DATE="" D 36 .. I DATE>START Q 37 .. I DATE<BACKTO Q 38 .. S NODE="" 39 .. F S NODE=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM,ITEM,DATE,NODE)) Q:NODE="" D 40 ... I '$D(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)=NODE_U_NUM 41 S ITEM="" 42 F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM="" D 43 . S DATE="" 44 . F S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) Q:DATE="" D 45 .. S NODE=$G(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) I '$L(NODE) Q 46 .. S NUM=$P(NODE,U,2) 47 .. S NODE=$P(NODE,U) 48 .. I '$L($G(^DGPT(+NODE,0))) Q ; ****** remove this when PTF patch is released ********** 49 .. D PTF^ORWGAPIA(NODE,.VALUE,.VALUES) S VALUE=$$EXT^ORWGAPIX($G(VALUE("DISCHARGE STATUS")),45,6) 50 .. I NUM="DXLS" S VALUE="(DXLS) "_VALUE_U_U_VALUES ;***************************** 51 .. S RESULT=45_"DX"_U_ITEM_U_DATE_U_DATE2_U_" "_VALUE 52 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 53 K ^TMP("ORWGRPC TEMP",$J) 54 Q 55 ; 56 LAB(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 57 N COMMENT,DATE,DATE2,NODE,RESULT,TYPE,VALUE K VALUE 58 S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 59 D 60 . I $E(ITEM)="A" S TYPE="AP" Q 61 . I $E(ITEM)="M" S TYPE="MI" Q 62 . S TYPE="" Q 63 F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" D 64 . I DATE>START Q 65 . I DATE<BACKTO Q 66 . S NODE="" 67 . F S NODE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 68 .. K VALUE 69 .. D LAB^ORWGAPIC(.VALUE,NODE,ITEM) 70 .. I TYPE="AP" S RESULT="63AP^"_ITEM_U_DATE_U_DATE2 ;_U_$P(VALUE,U,2) 71 .. I TYPE="MI" S RESULT="63MI^"_ITEM_U_DATE_U_DATE2_U_$P(VALUE,U,4) 72 .. I TYPE="" D 73 ... S COMMENT="" 74 ... I $L($G(VALUE("COMMENTS",1))) S COMMENT=1 75 ... S RESULT="63^"_ITEM_U_DATE_U_DATE2_U_$P(VALUE,U,3)_U_$P(VALUE,U,4)_U_$G(VALUE("SPECIMEN"))_U_COMMENT 76 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 77 Q 78 ; 79 MED(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 80 D MED3^ORWGAPIE(.DATA,ITEM,START,DFN,.CNT,.TMP) 81 Q 82 ; 83 NOTE(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 84 N DATE,DOC,DOCCLASS,DOCTYPE,DUM,IEN,RESULT,RESULTS,TITLE,VALUE K DUM 85 K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) 86 S CNT=$G(CNT),ITEM=$$UP^ORWGAPIX(ITEM),BACKTO=+$G(BACKTO) 87 F DOCTYPE="P","D","C" D 88 . S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) 89 . K ^TMP("TIUR",$J) 90 . D TIU^ORWGAPIA(.DUM,DOCCLASS,5,DFN) 91 . S DOC=0 92 . F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D 93 .. S RESULTS=^TMP("TIUR",$J,DOC) 94 .. S IEN=+$P(RESULTS,U) 95 .. S TITLE=$$UP^ORWGAPIX($P(RESULTS,U,2)) 96 .. I TITLE'=ITEM Q 97 .. ; do not use admission date S DATE=$P($G(^AUPNVSIT(+$P($G(^TIU(8925,IEN,0)),U,3),0)),U) 98 .. S DATE=$P(RESULTS,U,3) 99 .. I DATE>START Q 100 .. I DATE<BACKTO Q 101 .. S VALUE=$P(RESULTS,U,7) 102 .. S CNT=CNT+1 103 .. S RESULT=8925_U_TITLE_U_DATE_"^^"_VALUE 104 .. I $D(^TMP("ORWGRPC TEMP",$J,RESULT)) Q 105 .. S ^TMP("ORWGRPC TEMP",$J,RESULT)="" 106 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 107 K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) 108 Q 109 ; 110 ORDER(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 111 N DATE,DATE2,NODE,ORUPCHUK,RESULT,VALUE K ORUPCHUK 112 S DATE="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 113 F S DATE=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE)) Q:DATE="" D 114 . I DATE>START Q 115 . I DATE<BACKTO Q 116 . S DATE2="" 117 . F S DATE2=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2="" D 118 .. S NODE="" 119 .. F S NODE=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE,DATE2,NODE)) Q:NODE="" D 120 ... D EN^ORX8($P(NODE,";")) S VALUE=$P($G(ORUPCHUK("ORSTS")),U,2) 121 ... S RESULT=100_U_ITEM_U_DATE_"^^"_VALUE 122 ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 123 Q 124 ; 125 RAD(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 126 N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE 127 S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 128 F S DATE=$O(^PXRMINDX(70,"PI",DFN,ITEM,DATE)) Q:DATE="" D 129 . I DATE>START Q 130 . I DATE<BACKTO Q 131 . S NODE="" 132 . F S NODE=$O(^PXRMINDX(70,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 133 .. D RAD^ORWGAPIA(NODE,.VALUE,.VALUES) S VALUE=$G(VALUE("PDX"))_"-"_$G(VALUE("EXAM STATUS"))_U_U_VALUES 134 .. S RESULT=70_U_ITEM_U_DATE_U_DATE2_U_VALUE 135 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 136 Q 137 ; 1 ORWGAPI3 ; SLC/STAFF - Graph Data ;12/21/05 08:17 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 3 ; 4 ; 5 ADVERSE(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 6 N ADVERSE,DATE,DATE2,NODE,RESULT,RXN,VALUE 7 S DATE="",DATE2="",CNT=$G(CNT) 8 S ADVERSE="" 9 S VALUE=ITEM_U_ITEM 10 S NODE="" 11 F S NODE=$O(^GMR(120.8,"B",DFN,NODE)) Q:NODE="" D 12 . I '$D(^GMR(120.8,NODE,0)) Q 13 . I $G(^GMR(120.8,NODE,"ER")) Q ; entered in error 14 . I '$P(^GMR(120.8,NODE,0),U,12) Q ; signed 15 . S DATE=+$P($G(^GMR(120.8,NODE,0)),U,4) I 'DATE Q 16 . I DATE>START Q 17 . I ITEM'=$P(^GMR(120.8,NODE,0),U,2) Q 18 . S RXN=0 19 . F S RXN=$O(^GMR(120.8,NODE,10,"B",RXN)) Q:RXN<1 D 20 .. S ADVERSE=ADVERSE_$$EVALUE^ORWGAPIU(RXN,120.8)_", " 21 . I $L(ADVERSE)>0 S ADVERSE=$E(ADVERSE,1,$L(ADVERSE)-2) 22 . S CNT=CNT+1 23 . S RESULT=120.8_U_ITEM_U_DATE_U_DATE2_U_ADVERSE 24 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 25 Q 26 ; 27 BCMA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 28 N DATE,NODE,RESULT,VALUE 29 S DATE="",CNT=$G(CNT) 30 F S DATE=$O(^PSB(53.79,"AOIP",DFN,ITEM,DATE)) Q:DATE="" D 31 . I DATE>START Q 32 . S NODE="" 33 . F S NODE=$O(^PSB(53.79,"AOIP",DFN,ITEM,DATE,NODE)) Q:NODE="" D 34 .. S VALUE=$P($G(^PSB(53.79,NODE,0)),U,9) I VALUE'="G" Q 35 .. S RESULT=53.79_U_ITEM_U_DATE_"^^" 36 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 37 Q 38 ; 39 DX(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 40 N DATE,DATE2,NODE,NUM,RESULT,VALUE K VALUE 41 K ^TMP("ORWGRPC TEMP",$J) 42 S DATE2="",CNT=$G(CNT) 43 S NUM="" 44 F S NUM=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM)) Q:NUM="" D 45 . S DATE="" 46 . F S DATE=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM,ITEM,DATE)) Q:DATE="" D 47 .. I DATE>START Q 48 .. S NODE="" 49 .. F S NODE=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM,ITEM,DATE,NODE)) Q:NODE="" D 50 ... I '$D(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)=NODE_U_NUM 51 S ITEM="" 52 F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM="" D 53 . S DATE="" 54 . F S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) Q:DATE="" D 55 .. S NODE=$G(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) I '$L(NODE) Q 56 .. S NUM=$P(NODE,U,2) 57 .. S NODE=$P(NODE,U) 58 .. D PTF^ORWGAPIA(NODE,.VALUE) S VALUE=$$EXT^ORWGAPIX($G(VALUE("DISCHARGE STATUS")),45,6) 59 .. I NUM="DXLS" S VALUE="(DXLS) "_VALUE 60 .. S RESULT=45_"DX"_U_ITEM_U_DATE_U_DATE2_U_" "_VALUE 61 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 62 K ^TMP("ORWGRPC TEMP",$J) 63 Q 64 ; 65 INRX(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 66 N DATE,DATE2,NODE,RESULT,VALUE K VALUE 67 S DATE="",CNT=$G(CNT) 68 F S DATE=$O(^PXRMINDX(55,"PI",DFN,ITEM,DATE)) Q:DATE="" D 69 . I DATE>START Q 70 . S DATE2="" 71 . F S DATE2=$O(^PXRMINDX(55,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2="" D 72 .. S NODE="" 73 .. F S NODE=$O(^PXRMINDX(55,"PI",DFN,ITEM,DATE,DATE2,NODE)) Q:NODE="" D 74 ... D RXIN^ORWGAPIA(NODE,.VALUE) S VALUE=VALUE("STAT") 75 ... S VALUE=VALUE_" "_$$INSIG^ORWGAPIA(NODE) 76 ... S RESULT=55_U_ITEM_U_DATE_U_DATE2_U_VALUE 77 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 78 Q 79 ; 80 LAB(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 81 N COMMENT,DATE,DATE2,NODE,RESULT,TYPE,VALUE K VALUE 82 S DATE="",DATE2="",CNT=$G(CNT) 83 D 84 . I $E(ITEM)="A" S TYPE="AP" Q 85 . I $E(ITEM)="M" S TYPE="MI" Q 86 . S TYPE="" Q 87 F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" D 88 . I DATE>START Q 89 . S NODE="" 90 . F S NODE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 91 .. K VALUE 92 .. D LAB^ORWGAPIA(.VALUE,NODE,ITEM) 93 .. I TYPE="AP" S RESULT="63AP^"_ITEM_U_DATE_U_DATE2 ;_U_$P(VALUE,U,2) 94 .. I TYPE="MI" S RESULT="63MI^"_ITEM_U_DATE_U_DATE2_U_$P(VALUE,U,4) 95 .. I TYPE="" D 96 ... S COMMENT="" 97 ... I $L($G(VALUE("COMMENTS",1))) S COMMENT=1 98 ... S RESULT="63^"_ITEM_U_DATE_U_DATE2_U_$P(VALUE,U,3)_U_$P(VALUE,U,4)_U_$G(VALUE("SPECIMEN"))_U_COMMENT 99 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 100 Q 101 ; 102 MED(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 103 D MED3^ORWGAPID(.DATA,ITEM,START,DFN,.CNT,.TMP) 104 Q 105 ; 106 NOTE(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 107 N DATE,DOC,DOCCLASS,DOCTYPE,DUM,IEN,RESULT,RESULTS,TITLE,VALUE K DUM 108 K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) 109 S CNT=$G(CNT),ITEM=$$UP^ORWGAPIX(ITEM) 110 F DOCTYPE="P","D","C" D 111 . S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) 112 . K ^TMP("TIUR",$J) 113 . D TIU^ORWGAPIA(.DUM,DOCCLASS,5,DFN) 114 . S DOC=0 115 . F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D 116 .. S RESULTS=^TMP("TIUR",$J,DOC) 117 .. S IEN=+$P(RESULTS,U) 118 .. S TITLE=$$UP^ORWGAPIX($P(RESULTS,U,2)) 119 .. I TITLE'=ITEM Q 120 .. ; do not use admission date S DATE=$P($G(^AUPNVSIT(+$P($G(^TIU(8925,IEN,0)),U,3),0)),U) 121 .. S DATE=$P(RESULTS,U,3) 122 .. I DATE>START Q 123 .. S VALUE=$P(RESULTS,U,7) 124 .. S CNT=CNT+1 125 .. S RESULT=8925_U_TITLE_U_DATE_"^^"_VALUE 126 .. I $D(^TMP("ORWGRPC TEMP",$J,RESULT)) Q 127 .. S ^TMP("ORWGRPC TEMP",$J,RESULT)="" 128 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 129 K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) 130 Q 131 ; 132 NVAE(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 133 N DATE,DATE2,NODE,RESULT,VALUE K VALUE 134 S DATE="",CNT=$G(CNT) 135 F S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE)) Q:DATE="" D 136 . I DATE>START Q 137 . S DATE2="" 138 . F S DATE2=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE2)) Q:DATE2="" D 139 .. S NODE="" 140 .. F S NODE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE2,NODE)) Q:NODE="" D 141 ... D RXNVA^ORWGAPIA(NODE,.VALUE) S VALUE=$G(VALUE("STATUS")) 142 ... S VALUE=VALUE_" "_$$NVASIG^ORWGAPIA(NODE) 143 ... S RESULT="55NVAE"_U_ITEM_U_DATE_"^^"_VALUE ; DATE2 is not used, NVA defined as an event 144 ... ;S RESULT="55NVAE"_U_ITEM_U_DATE_U_$S(DATE2["U":DT,1:DATE2)_U_VALUE ; DATE2 is not used, NVA defined as an event 145 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 146 Q 147 ; 148 NVA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 149 D NVA3^ORWGAPID(.DATA,ITEM,START,DFN,.CNT,.TMP) 150 Q 151 ; 152 ORDER(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 153 N DATE,DATE2,NODE,ORUPCHUK,RESULT,VALUE K ORUPCHUK 154 S DATE="",CNT=$G(CNT) 155 F S DATE=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE)) Q:DATE="" D 156 . I DATE>START Q 157 . S DATE2="" 158 . F S DATE2=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2="" D 159 .. S NODE="" 160 .. F S NODE=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE,DATE2,NODE)) Q:NODE="" D 161 ... D EN^ORX8($P(NODE,";")) S VALUE=$P($G(ORUPCHUK("ORSTS")),U,2) 162 ... S RESULT=100_U_ITEM_U_DATE_"^^"_VALUE 163 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 164 Q 165 ; 166 OUTRX(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 167 N DATE1,DATE2,LNUM,NODE,RESULT,VALUE K VALUE 168 S DATE1="",DATE2="",CNT=$G(CNT) 169 F S DATE1=$O(^PXRMINDX(52,"PI",DFN,ITEM,DATE1)) Q:DATE1="" D 170 . I DATE1>START Q 171 . S DATE2="" 172 . F S DATE2=$O(^PXRMINDX(52,"PI",DFN,ITEM,DATE1,DATE2)) Q:DATE2="" D 173 .. S NODE="" 174 .. F S NODE=$O(^PXRMINDX(52,"PI",DFN,ITEM,DATE1,DATE2,NODE)) Q:NODE="" D 175 ... D RXOUT^ORWGAPIA(NODE,.VALUE) S VALUE=$$EXTERNAL^ORWGAPIX(52,100,"",VALUE("STATUS")) 176 ... S VALUE=VALUE_" "_$$SIG^ORWGAPIA(DFN,+NODE) 177 ... S RESULT=52_U_ITEM_U_DATE1_U_DATE2_U_VALUE 178 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 179 Q 180 ; 181 RAD(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 182 N DATE,DATE2,NODE,RESULT,VALUE K VALUE 183 S DATE="",DATE2="",CNT=$G(CNT) 184 F S DATE=$O(^PXRMINDX(70,"PI",DFN,ITEM,DATE)) Q:DATE="" D 185 . I DATE>START Q 186 . S NODE="" 187 . F S NODE=$O(^PXRMINDX(70,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 188 .. D RAD^ORWGAPIA(NODE,.VALUE) S VALUE=$G(VALUE("PDX"))_"-"_$G(VALUE("EXAM STATUS")) 189 .. S RESULT=70_U_ITEM_U_DATE_U_DATE2_U_VALUE 190 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 191 Q 192 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI4.m
r613 r623 1 ORWGAPI4 ; SLC/STAFF - Graph Data, indexed ;8/21/06 07:52 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242 3 ; 4 EDU(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 5 N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE 6 S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 7 F S DATE=$O(^PXRMINDX(9000010.16,"PI",DFN,ITEM,DATE)) Q:DATE="" D 8 . I DATE>START Q 9 . I DATE<BACKTO Q 10 . S NODE="" 11 . F S NODE=$O(^PXRMINDX(9000010.16,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 12 .. D EDU^ORWGAPIA(NODE,.VALUE,.VALUES) 13 .. S VALUE=VALUE("VALUE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.16,.06)_U_VALUES ;***************************** 14 .. S RESULT=9000010.16_U_ITEM_U_DATE_"^^" ;_VALUE 15 .. S RESULT=9000010.16_U_ITEM_U_DATE_U_DATE2_U ;_VALUE 16 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 17 Q 18 ; 19 EXAM(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 20 N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE 21 S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 22 F S DATE=$O(^PXRMINDX(9000010.13,"PI",DFN,ITEM,DATE)) Q:DATE="" D 23 . I DATE>START Q 24 . I DATE<BACKTO Q 25 . S NODE="" 26 . F S NODE=$O(^PXRMINDX(9000010.13,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 27 .. D EXAM^ORWGAPIA(NODE,.VALUE,.VALUES) 28 .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.13,.04)_U_VALUES ;***************************** 29 .. S RESULT=9000010.13_U_ITEM_U_DATE_U_DATE2_U_VALUE 30 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 31 Q 32 ; 33 HF(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 34 N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE 35 S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 36 F S DATE=$O(^PXRMINDX(9000010.23,"PI",DFN,ITEM,DATE)) Q:DATE="" D 37 . I DATE>START Q 38 . I DATE<BACKTO Q 39 . S NODE="" 40 . F S NODE=$O(^PXRMINDX(9000010.23,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 41 .. D HF^ORWGAPIA(NODE,.VALUE,.VALUES) 42 .. S VALUE=VALUE("VALUE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.23,.04)_U_VALUES ;***************************** 43 .. S RESULT=9000010.23_U_ITEM_U_DATE_U_DATE2_U_VALUE 44 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 45 Q 46 ; 47 IMM(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 48 N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE 49 S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 50 F S DATE=$O(^PXRMINDX(9000010.11,"PI",DFN,ITEM,DATE)) Q:DATE="" D 51 . I DATE>START Q 52 . I DATE<BACKTO Q 53 . S NODE="" 54 . F S NODE=$O(^PXRMINDX(9000010.11,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 55 .. D IMM^ORWGAPIA(NODE,.VALUE,.VALUES) 56 .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.11,.04)_U_VALUES ;***************************** 57 .. S CNT=CNT+1 58 .. S RESULT=9000010.11_U_ITEM_U_DATE_U_DATE2_U_VALUE 59 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 60 Q 61 ; 62 MH(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 63 N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE 64 S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 65 F S DATE=$O(^PXRMINDX(601.2,"PI",DFN,ITEM,DATE)) Q:DATE="" D 66 . I DATE>START Q 67 . I DATE<BACKTO Q 68 . S NODE="" 69 . F S NODE=$O(^PXRMINDX(601.2,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 70 .. D MH^ORWGAPIA(.VALUE,NODE,.VALUES) S VALUE=$P($G(VALUE(2)),U,2,3)_U_VALUES ;***************************** 71 .. S RESULT=601.2_U_ITEM_U_DATE_U_DATE2_U ;_VALUE 72 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 73 Q 74 ; 75 OP(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 76 N DATE,DATE2,NODE,NUM,RESULT,VALUE,VALUES K VALUE 77 S DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO),VALUES="" 78 S NUM="" 79 F S NUM=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM)) Q:NUM="" D 80 . S DATE="" 81 . F S DATE=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM,ITEM,DATE)) Q:DATE="" D 82 .. I DATE>START Q 83 .. I DATE<BACKTO Q 84 .. S NODE="" 85 .. F S NODE=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM,ITEM,DATE,NODE)) Q:NODE="" D 86 ... I '$L($G(^DGPT(+NODE,0))) Q ; ****** remove this when PTF patch is released ********** 87 ... D PTF^ORWGAPIA(NODE,.VALUE,.VALUES) S VALUE=$G(VALUE("DISCHARGE STATUS"))_U_VALUES ;***************************** 88 ... S RESULT=45_"OP"_U_ITEM_U_DATE_U_DATE2_U ;_VALUE 89 ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 90 Q 91 ; 92 POV(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 93 N DATE,DATE2,NODE,RESULT,TYPE,VALUE,VALUES K VALUE 94 S DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 95 S TYPE="" 96 F S TYPE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE)) Q:TYPE="" D 97 . S DATE="" 98 . F S DATE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" D 99 .. I DATE>START Q 100 .. I DATE<BACKTO Q 101 .. S NODE="" 102 .. F S NODE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE,ITEM,DATE,NODE)) Q:NODE="" D 103 ... D POV^ORWGAPIA(NODE,.VALUE,.VALUES) 104 ... S VALUE=VALUE("CLINICAL TERM"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.07,.15)_U_VALUES ;***************************** 105 ... S CNT=CNT+1 106 ... S RESULT=9000010.07_U_ITEM_U_DATE_U_DATE2_U_VALUE 107 ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 108 Q 109 ; 110 PROB(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 111 N DATE,DATE2,DTONSET,DTRESOLV,ICD9,NODE,PRIORITY,PROB,PROBDX,PSTATUS,RESULT,STATUS,VALUE 112 K ^TMP("ORWGRPC TEMP",$J) 113 S DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 114 S STATUS="" 115 F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D 116 . S PRIORITY="" 117 . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D 118 .. S DATE="" 119 .. F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D 120 ... I DATE>START Q 121 ... I DATE<BACKTO Q 122 ... S NODE="" 123 ... F S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE="" D 124 .... S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE,NODE)="" 125 S ICD9="" 126 F S ICD9=$O(^TMP("ORWGRPC TEMP",$J,ICD9)) Q:ICD9="" D 127 . S DATE="" 128 . F S DATE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,DATE)) Q:DATE="" D 129 .. S NODE="" 130 .. F S NODE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,DATE,NODE)) Q:NODE="" D 131 ... D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE) 132 ... S RESULT=9000011_U_ITEM_U_DTONSET_U_DATE2_U_$$EXT^ORWGAPIX(PSTATUS,9000011,.12) 133 ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 134 K ^TMP("ORWGRPC TEMP",$J) 135 Q 136 ; 137 PROBX(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 138 D PROBX4^ORWGAPID(.DATA,ITEM,START,DFN,.CNT,.TMP) 139 Q 140 ; 141 PROC(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 142 N DATE,DATE2,NODE,RESULT,TYPE,VALUE,VALUES K VALUE 143 S DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 144 S TYPE="" 145 F S TYPE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE)) Q:TYPE="" D 146 . S DATE="" 147 . F S DATE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" D 148 .. I DATE>START Q 149 .. I DATE<BACKTO Q 150 .. S NODE="" 151 .. F S NODE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE,ITEM,DATE,NODE)) Q:NODE="" D 152 ... D CPT^ORWGAPIA(NODE,.VALUE,.VALUES) 153 ... S VALUE=VALUE("PRINCIPAL PROCEDURE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.18,.07)_U_VALUES ;***************************** 154 ... S RESULT=9000010.18_U_ITEM_U_DATE_U_DATE2_U_VALUE 155 ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 156 Q 157 ; 158 SKIN(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 159 N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE 160 S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 161 F S DATE=$O(^PXRMINDX(9000010.12,"PI",DFN,ITEM,DATE)) Q:DATE="" D 162 . I DATE>START Q 163 . I DATE<BACKTO Q 164 . S NODE="" 165 . F S NODE=$O(^PXRMINDX(9000010.12,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 166 .. D SKIN^ORWGAPIA(NODE,.VALUE,.VALUES) 167 .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.12,.04)_U_VALUES ;***************************** 168 .. S CNT=CNT+1 169 .. S RESULT=9000010.12_U_ITEM_U_DATE_U_DATE2_U_VALUE 170 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 171 Q 172 ; 173 VITAL(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 174 I ITEM=99999 D BMIDATA^ORWGAPIX(.DATA,ITEM,START,DFN,.CNT,TMP) Q 175 N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE 176 S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 177 F S DATE=$O(^PXRMINDX(120.5,"PI",DFN,ITEM,DATE)) Q:DATE="" D 178 . I DATE>START Q 179 . I DATE<BACKTO Q 180 . S NODE="" 181 . F S NODE=$O(^PXRMINDX(120.5,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 182 .. D VITAL^ORWGAPIA(.VALUE,NODE,.VALUES) S VALUE=$P($G(VALUE(7)),U) 183 .. I $P($G(VALUE(3)),U,2)="PAIN",VALUE=99 S VALUE="(99)" 184 .. S RESULT=120.5_U_ITEM_U_DATE_U_DATE2_U_VALUE_U_U_VALUES ;***************************** 185 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 186 Q 187 ; 1 ORWGAPI4 ; SLC/STAFF - Graph Data ;8/21/06 07:52 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26 3 ; 4 ADMIT(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 5 N DATE,DATE2,DISCH,LINE,LST,NUM,RESULT,VALUE K LST 6 S ITEM=$G(ITEM,"ADMIT") 7 D ADMITLST^ORWPT(.LST,DFN) 8 S NUM=0 9 F S NUM=$O(LST(NUM)) Q:NUM<1 D 10 . S LINE=LST(NUM) 11 . S DATE=$P(LINE,U) 12 . I DATE>START Q 13 . S DISCH=$P(LINE,U,5) 14 . S DATE2=$$DISCH^ORWGAPIA(DISCH) 15 . I DATE2="" D 16 .. S DATE2=$$FMADD^ORWGAPIX(DATE,$$LOS^ORWGAPIA(DISCH)+1) 17 .. I DATE2=-1 S DATE2=$$FMADD^ORWGAPIX(DT,1) ; just make it today + 1 18 .. S DATE2=DATE2\1 19 . S VALUE=$P(LINE,U,3)_" "_$P(LINE,U,4)_U_$P(LINE,U,5,6) 20 . S CNT=CNT+1 21 . S RESULT=405_U_ITEM_U_DATE_U_DATE2_U_VALUE 22 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 23 Q 24 ; 25 EDU(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 26 N DATE,DATE2,NODE,RESULT,VALUE K VALUE 27 S DATE="",DATE2="",CNT=$G(CNT) 28 F S DATE=$O(^PXRMINDX(9000010.16,"PI",DFN,ITEM,DATE)) Q:DATE="" D 29 . I DATE>START Q 30 . S NODE="" 31 . F S NODE=$O(^PXRMINDX(9000010.16,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 32 .. D EDU^ORWGAPIA(NODE,.VALUE) 33 .. S VALUE=VALUE("VALUE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.16,.06) 34 .. S RESULT=9000010.16_U_ITEM_U_DATE_"^^" ;_VALUE 35 .. S RESULT=9000010.16_U_ITEM_U_DATE_U_DATE2_U ;_VALUE 36 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 37 Q 38 ; 39 EXAM(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 40 N DATE,DATE2,NODE,RESULT,VALUE K VALUE 41 S DATE="",DATE2="",CNT=$G(CNT) 42 F S DATE=$O(^PXRMINDX(9000010.13,"PI",DFN,ITEM,DATE)) Q:DATE="" D 43 . I DATE>START Q 44 . S NODE="" 45 . F S NODE=$O(^PXRMINDX(9000010.13,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 46 .. D EXAM^ORWGAPIA(NODE,.VALUE) 47 .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.13,.04) 48 .. S RESULT=9000010.13_U_ITEM_U_DATE_U_DATE2_U_VALUE 49 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 50 Q 51 ; 52 HF(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 53 N DATE,DATE2,NODE,RESULT,VALUE K VALUE 54 S DATE="",DATE2="",CNT=$G(CNT) 55 F S DATE=$O(^PXRMINDX(9000010.23,"PI",DFN,ITEM,DATE)) Q:DATE="" D 56 . I DATE>START Q 57 . S NODE="" 58 . F S NODE=$O(^PXRMINDX(9000010.23,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 59 .. D HF^ORWGAPIA(NODE,.VALUE) 60 .. S VALUE=VALUE("VALUE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.23,.04) 61 .. S RESULT=9000010.23_U_ITEM_U_DATE_U_DATE2_U_VALUE 62 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 63 Q 64 ; 65 IMM(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 66 N DATE,DATE2,NODE,RESULT,VALUE K VALUE 67 S DATE="",DATE2="",CNT=$G(CNT) 68 F S DATE=$O(^PXRMINDX(9000010.11,"PI",DFN,ITEM,DATE)) Q:DATE="" D 69 . I DATE>START Q 70 . S NODE="" 71 . F S NODE=$O(^PXRMINDX(9000010.11,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 72 .. D IMM^ORWGAPIA(NODE,.VALUE) 73 .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.11,.04) 74 .. S CNT=CNT+1 75 .. S RESULT=9000010.11_U_ITEM_U_DATE_U_DATE2_U_VALUE 76 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 77 Q 78 ; 79 MH(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 80 N DATE,DATE2,NODE,RESULT,VALUE K VALUE 81 S DATE="",DATE2="",CNT=$G(CNT) 82 F S DATE=$O(^PXRMINDX(601.2,"PI",DFN,ITEM,DATE)) Q:DATE="" D 83 . I DATE>START Q 84 . S NODE="" 85 . F S NODE=$O(^PXRMINDX(601.2,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 86 .. D MH^ORWGAPIA(.VALUE,NODE) S VALUE=$P($G(VALUE(2)),U,2,3) 87 .. S RESULT=601.2_U_ITEM_U_DATE_U_DATE2_U ;_VALUE 88 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 89 Q 90 ; 91 OP(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 92 N DATE,DATE2,NODE,NUM,RESULT,VALUE K VALUE 93 S DATE2="",CNT=$G(CNT) 94 S NUM="" 95 F S NUM=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM)) Q:NUM="" D 96 . S DATE="" 97 . F S DATE=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM,ITEM,DATE)) Q:DATE="" D 98 .. I DATE>START Q 99 .. S NODE="" 100 .. F S NODE=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM,ITEM,DATE,NODE)) Q:NODE="" D 101 ... D PTF^ORWGAPIA(NODE,.VALUE) S VALUE=$G(VALUE("DISCHARGE STATUS")) 102 ... S RESULT=45_"OP"_U_ITEM_U_DATE_U_DATE2_U ;_VALUE 103 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 104 Q 105 ; 106 POV(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 107 N DATE,DATE2,NODE,RESULT,TYPE,VALUE K VALUE 108 S DATE2="",CNT=$G(CNT) 109 S TYPE="" 110 F S TYPE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE)) Q:TYPE="" D 111 . S DATE="" 112 . F S DATE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" D 113 .. I DATE>START Q 114 .. S NODE="" 115 .. F S NODE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE,ITEM,DATE,NODE)) Q:NODE="" D 116 ... D POV^ORWGAPIA(NODE,.VALUE) 117 ... S VALUE=VALUE("CLINICAL TERM"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.07,.15) 118 ... S CNT=CNT+1 119 ... S RESULT=9000010.07_U_ITEM_U_DATE_U_DATE2_U_VALUE 120 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 121 Q 122 ; 123 PROB(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 124 N DATE,DATE2,DTONSET,DTRESOLV,ICD9,NODE,PRIORITY,PROB,PROBDX,PSTATUS,RESULT,STATUS,VALUE 125 K ^TMP("ORWGRPC TEMP",$J) 126 S DATE2="",CNT=$G(CNT) 127 S STATUS="" 128 F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D 129 . S PRIORITY="" 130 . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D 131 .. S DATE="" 132 .. F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D 133 ... I DATE>START Q 134 ... S NODE="" 135 ... F S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE="" D 136 .... S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE,NODE)="" 137 S ICD9="" 138 F S ICD9=$O(^TMP("ORWGRPC TEMP",$J,ICD9)) Q:ICD9="" D 139 . S DATE="" 140 . F S DATE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,DATE)) Q:DATE="" D 141 .. S NODE="" 142 .. F S NODE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,DATE,NODE)) Q:NODE="" D 143 ... D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE) 144 ... S RESULT=9000011_U_ITEM_U_DTONSET_U_DATE2_U_$$EXT^ORWGAPIX(PSTATUS,9000011,.12) 145 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 146 K ^TMP("ORWGRPC TEMP",$J) 147 Q 148 ; 149 PROBX(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 150 D PROBX4^ORWGAPID(.DATA,ITEM,START,DFN,.CNT,.TMP) 151 Q 152 ; 153 PROC(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 154 N DATE,DATE2,NODE,RESULT,TYPE,VALUE K VALUE 155 S DATE2="",CNT=$G(CNT) 156 S TYPE="" 157 F S TYPE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE)) Q:TYPE="" D 158 . S DATE="" 159 . F S DATE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" D 160 .. I DATE>START Q 161 .. S NODE="" 162 .. F S NODE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE,ITEM,DATE,NODE)) Q:NODE="" D 163 ... D CPT^ORWGAPIA(NODE,.VALUE) 164 ... S VALUE=VALUE("PRINCIPAL PROCEDURE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.18,.07) 165 ... S RESULT=9000010.18_U_ITEM_U_DATE_U_DATE2_U_VALUE 166 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 167 Q 168 ; 169 SKIN(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 170 N DATE,DATE2,NODE,RESULT,VALUE K VALUE 171 S DATE="",DATE2="",CNT=$G(CNT) 172 F S DATE=$O(^PXRMINDX(9000010.12,"PI",DFN,ITEM,DATE)) Q:DATE="" D 173 . I DATE>START Q 174 . S NODE="" 175 . F S NODE=$O(^PXRMINDX(9000010.12,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 176 .. D SKIN^ORWGAPIA(NODE,.VALUE) 177 .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.12,.04) 178 .. S CNT=CNT+1 179 .. S RESULT=9000010.12_U_ITEM_U_DATE_U_DATE2_U_VALUE 180 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 181 Q 182 ; 183 SURG(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 184 N CASE,DATE,DATE2,NUM,PROC,RESULT,RESULTS,SURG,SURGPROC,VALUE K SURG,SURGPROC 185 S DATE2="",CNT=$G(CNT) 186 D SURG^ORWGAPIA(.SURG,DFN) 187 K SURG(0),SURG(1) 188 S ITEM=$$UP^ORWGAPIX(ITEM) 189 S NUM=0 190 S CASE=0 191 F S CASE=$O(SURG(CASE)) Q:CASE<1 D 192 . S RESULTS=SURG(CASE) 193 . S PROC=$P(RESULTS,U,3) 194 . I '$L(PROC) Q 195 . S PROC=$$UP^ORWGAPIX(PROC) 196 . I PROC'=ITEM Q 197 . S NUM=NUM+1 198 . S SURGPROC(PROC,NUM)=RESULTS 199 K SURG 200 S PROC="" 201 F S PROC=$O(SURGPROC(PROC)) Q:PROC="" D 202 . S NUM=0 203 . F S NUM=$O(SURGPROC(PROC,NUM)) Q:NUM<1 D 204 .. S RESULTS=SURGPROC(PROC,NUM) 205 .. S DATE=$P(RESULTS,U,5) 206 .. I DATE>START Q 207 .. S VALUE="" 208 .. S RESULT=130_U_PROC_U_DATE_U_DATE2_U_VALUE 209 .. S CNT=CNT+1 210 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 211 Q 212 ; 213 TREAT(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 214 N DATE,DATE2,NODE,RESULT,VALUE 215 S DATE="",DATE2="",CNT=$G(CNT) 216 S NODE="" 217 F S NODE=$O(^AUPNVTRT("C",DFN,NODE)) Q:NODE="" D 218 . I '$D(^AUPNVTRT("B",ITEM,NODE)) Q 219 . S DATE=+$G(^AUPNVSIT(+$P($G(^AUPNVTRT(NODE,0)),U,3),0)) I 'DATE Q 220 . I DATE>START Q 221 . S VALUE=+$P($G(^AUPNVTRT(NODE,0)),U,4) 222 . S CNT=CNT+1 223 . S RESULT=9000010.15_U_ITEM_U_DATE_U_DATE2_U_VALUE 224 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 225 Q 226 ; 227 VISIT(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 228 N DATE,DATE2,NODE,NUM,RESULT,VALUE 229 S DATE="",DATE2="",CNT=$G(CNT) 230 F S DATE=$O(^AUPNVSIT("AET",DFN,DATE)) Q:DATE="" D 231 . I DATE>START Q 232 . S NODE="" 233 . F S NODE=$O(^AUPNVSIT("AET",DFN,DATE,ITEM,NODE)) Q:NODE="" D 234 .. S NUM=0 235 .. F S NUM=$O(^AUPNVSIT("AET",DFN,DATE,ITEM,NODE,NUM)) Q:NUM="" D 236 ... S DATE2=+$P($G(^AUPNVSIT(NUM,0)),U,18) 237 ... I 'DATE2 S DATE2=DATE+.01 238 ... I +$E($P(DATE2,".",2),1,2)>24 S DATE2=(DATE\1)+.2359 239 ... S VALUE="" 240 ... S CNT=CNT+1 241 ... S RESULT=9000010_U_ITEM_U_DATE_U_DATE2_U_VALUE 242 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 243 Q 244 ; 245 VITAL(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 246 I ITEM=99999 D BMIDATA^ORWGAPIX(.DATA,ITEM,START,DFN,.CNT,TMP) Q 247 N DATE,DATE2,NODE,RESULT,VALUE K VALUE 248 S DATE="",DATE2="",CNT=$G(CNT) 249 F S DATE=$O(^PXRMINDX(120.5,"PI",DFN,ITEM,DATE)) Q:DATE="" D 250 . I DATE>START Q 251 . S NODE="" 252 . F S NODE=$O(^PXRMINDX(120.5,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D 253 .. D VITAL^ORWGAPIA(.VALUE,NODE) S VALUE=$P($G(VALUE(7)),U) 254 .. I $P($G(VALUE(3)),U,2)="PAIN",VALUE=99 S VALUE="(99)" 255 .. S RESULT=120.5_U_ITEM_U_DATE_U_DATE2_U_VALUE 256 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 257 Q 258 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIA.m
r613 r623 1 ORWGAPIA ; SLC/STAFF - Graph Application Calls ;2/22/07 11:16 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,251,260,243**;Dec 17, 1997;Build 242 3 ; 4 ADMITX(DFN) ; $$(dfn) -> 1 if patient has data else 0 5 Q $O(^DGPM("C",+$G(DFN),0))>0 6 ; 7 ALLERGYX(DFN) ; $$(dfn) -> 1 if patient has data else 0 8 Q $O(^GMR(120.8,"B",+$G(DFN),0))>0 9 ; 10 ALLG(IEN) ; $$(ien) -> external display of allergies 11 I IEN Q $P($G(^GMRD(120.83,IEN,0)),U) ; this is for rxn, allergy is free text 12 Q IEN 13 ; 14 CPT(NODE,ORVALUE,VALUES) ; from ORWGAPI4 15 D VCPT^PXPXRM(NODE,.ORVALUE) 16 S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** 17 Q 18 ; 19 DISCH(IEN) ; $$(pt movement ien) -> discharge date 20 Q $P($G(^DGPM(+$P($G(^DGPM(+$G(IEN),0)),U,17),0)),U) 21 ; 22 DOCCLASS(DOCTYPE) ; $$(doc type) -> ien of tiu doc class 23 N CONSULTS 24 S DOCTYPE=$E(DOCTYPE,1) 25 I DOCTYPE="P" Q 3 26 I DOCTYPE="D" Q 244 27 I DOCTYPE="C" D CNSLCLAS^TIUSRVD(.CONSULTS) Q CONSULTS 28 Q 0 29 ; 30 EDU(NODE,ORVALUE,VALUES) ; from ORWGAPI4 31 D VPEDU^PXPXRM(NODE,.ORVALUE) 32 S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** 33 Q 34 ; 35 EXAM(NODE,ORVALUE,VALUES) ; from ORWGAPI4 36 D VXAM^PXPXRM(NODE,.ORVALUE) 37 S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** 38 Q 39 ; 40 GETTIU(ORDATA,IEN) ; from ORWGAPID 41 D TGET^TIUSRVR1(.ORDATA,IEN) 42 Q 43 ; 44 HF(NODE,ORVALUE,VALUES) ; from ORWGAPI4 45 D VHF^PXPXRM(NODE,.ORVALUE) 46 S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** 47 Q 48 ; 49 ICD0(IEN) ; $$(ien) -> external display of IDC0 50 Q $P($G(^ICD0(IEN,0)),U)_" "_$P($G(^ICD0(IEN,0)),U,4) 51 ; 52 ICD9(IEN) ; $$(ien) -> external display of IDC9 53 Q $P($G(^ICD9(IEN,0)),U)_" "_$P($G(^ICD9(IEN,0)),U,3) 54 ; 55 ICPT(IEN,CSD) ; $$(ien) -> external display of CPT 56 N X S X=$$CPT^ICPTCOD($G(IEN),$G(CSD)) 57 Q $P(X,U,2)_" "_$E($P(X,U,3),1,30) 58 ; 59 IMM(NODE,ORVALUE,VALUES) ; from ORWGAPI4 60 D VIMM^PXPXRM(NODE,.ORVALUE) 61 S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** 62 Q 63 ; 64 ISA(USER,CLASS,ORERR) ; $$(user,user class,err) -> 1 if user in class, else 0 65 Q $$ISA^USRLM(USER,CLASS,.ORERR) 66 ; 67 LOS(DGPMIFN) ; $$(pt movement ien) -> length of stay 68 N X D ^DGPMLOS 69 Q +$P($G(X),U,5) 70 ; 71 MEDICINE(ARRAY,DFN) ; 72 N DATE,FILE,IEN,NAME,NUM,REF,VALUES,XREF 73 K ARRAY,^TMP("MCAR",$J),^TMP("OR",$J,"MCAR") 74 D FILE^ORWGAPIU(690,.REF,.XREF) 75 I '$L(REF) Q 76 I $E(REF,$L(REF))="," S REF=$E(REF,1,$L(REF)-1)_")" 77 I $E(REF,$L(REF))="(" S REF=$P(REF,"(") 78 D EN^MCARPS2(DFN) 79 S NUM=0 80 F S NUM=$O(^TMP("OR",$J,"MCAR","OT",NUM)) Q:NUM<1 D 81 . S VALUES=^TMP("OR",$J,"MCAR","OT",NUM) 82 . S DATE=$$DATETFM^ORWGAPIW($P(VALUES,U,6)) 83 . S NAME=$P(VALUES,U) I '$L(NAME) Q 84 . S IEN=+$O(@REF@(XREF,NAME,"")) 85 . I DATE,IEN S ARRAY(IEN,DATE)=NAME 86 K ^TMP("MCAR",$J),^TMP("OR",$J,"MCAR") 87 Q 88 ; 89 MEDVAL(VAL) ; 90 N IEN,NAME,NAMES,REF,SEQ,XREF K NAMES,VAL 91 D FILE^ORWGAPIU(690,.REF,.XREF) 92 I '$L(REF) Q 93 I $E(REF,$L(REF))="," S REF=$E(REF,1,$L(REF)-1)_")" 94 I $E(REF,$L(REF))="(" S REF=$P(REF,"(") 95 S NAME="" 96 F S NAME=$O(@REF@(XREF,NAME)) Q:NAME="" D 97 . S IEN=0 98 . F S IEN=$O(@REF@(XREF,NAME,IEN)) Q:IEN<1 D 99 .. S NAMES(IEN)=NAME 100 S SEQ=0 101 S IEN=0 102 F S IEN=$O(NAMES(IEN)) Q:IEN<1 D 103 . S SEQ=SEQ+1 104 . S VAL(SEQ)=690_U_IEN_U_NAMES(IEN) 105 Q 106 ; 107 MH(ORVALUE,NODE,VALUES) ; from ORWGAPI4 108 D ENDAS^YTAPI10(.ORVALUE,NODE) 109 S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** 110 Q 111 ; 112 NOTEX(DFN) ; $$(dfn) -> 1 if patient has data else 0 113 Q $$HASDOCMT^TIULX($G(DFN)) 114 ; 115 OITEM(DATA) ; API - get order display groups - from ORWGAPI 116 N CNT,IEN,RESULT,TMP,ZERO 117 D RETURN^ORWGAPIW(.TMP,.DATA) 118 S CNT=0 119 S IEN=0 120 F S IEN=$O(^ORD(100.98,IEN)) Q:IEN<1 D 121 . S ZERO=$G(^ORD(100.98,IEN,0)) I '$L(ZERO) Q 122 . S RESULT="100.98^"_IEN_U_$P(ZERO,U)_U_$P(ZERO,U,3) 123 . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 124 Q 125 ; 126 POV(NODE,ORVALUE,VALUES) ; from ORWGAPI4 127 D VPOV^PXPXRM(NODE,.ORVALUE) 128 S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** 129 Q 130 ; 131 PROB(GMPLLEX,GMPLSTAT,GMPLICD,GMPLODAT,GMPLXDAT,NODE) ; from ORWGAPI4 132 N GMPLPNAM,GMPLDLM,GMPLTXT,GMPLCOND,GMPLPRV,GMPLPRIO 133 D CALL2^GMPLUTL3(NODE) 134 Q 135 ; 136 PTF(NODE,ORVALUE,VALUES) ; from ORWGAPI3, ORWGAPI4 137 D PTF^DGPTPXRM(NODE,.ORVALUE) 138 S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** 139 Q 140 ; 141 RAD(NODE,ORVALUE,VALUES) ; from ORWGAPI3 142 D EN1^RAPXRM(NODE,.ORVALUE) 143 S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** 144 Q 145 ; 146 SKIN(NODE,ORVALUE,VALUES) ; from ORWGAPI4 147 D VSKIN^PXPXRM(NODE,.ORVALUE) 148 S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** 149 Q 150 ; 151 SURG(ORSURG,DFN,VALUES) ; from ORWGAPI2, ORWGAPI4 152 D GET^SROGTSR(.ORSURG,DFN) 153 S VALUES=$$DATA^ORWGAPIW(.ORSURG) ;***************************** 154 Q 155 ; 156 SURGX(DFN) ; $$(dfn) -> 1 if patient has data else 0 157 Q $O(^SRF("B",+$G(DFN),0))>0 158 ; 159 TAX(IEN) ; $$(ien) -> external display of reminder taxonomy 160 Q $P($G(^PXD(811.2,+$G(IEN),0)),U) 161 ; 162 TITLE(DOCTYPE) ; $$(document type) -> parent ien^parent^parent abbrev 163 N IEN,RESULTS K RESULTS 164 S DOCTYPE=+$G(^TIU(8925,+$G(DOCTYPE),0)) 165 S IEN=+$$DOCCLASS^TIULC1(DOCTYPE) I 'IEN Q "" 166 D GETDATA^ORWGAPIX(.RESULTS,8925.1,".01;.02",IEN) 167 I '$L($G(RESULTS(.01))) Q "" 168 Q IEN_U_"note - "_RESULTS(.01)_U_$G(RESULTS(.02)) 169 ; 170 TIU(ORVALUE,DOCIEN,ONE,DFN,OLDEST,NEWEST) ; from ORWGAPI1, ORWGAPI3 171 D CONTEXT^TIUSRVLO(.ORVALUE,DOCIEN,ONE,DFN,$G(OLDEST),$G(NEWEST)) 172 Q 173 ; 174 TIUTITLE(DATA) ; API - get tiu document titles - from ORWGAPI 175 N CNT,IEN,RESULT,RESULTS,TMP K ^TMP("TIUTLS",$J) 176 D RETURN^ORWGAPIW(.TMP,.DATA) 177 S CNT=0 178 D TITLIENS^TIULX 179 S IEN=0 180 F S IEN=$O(^TMP("TIUTLS",$J,IEN)) Q:IEN<1 D 181 . K RESULTS 182 . D GETDATA^ORWGAPIX(.RESULTS,8925.1,".01;.02",IEN) 183 . I '$L($G(RESULTS(.01))) Q 184 . S RESULT="8925.1^"_IEN_U_RESULTS(.01)_U_$G(RESULTS(.02)) 185 . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 186 K ^TMP("TIUTLS",$J) 187 Q 188 ; 189 VISITX(DFN) ; $$(dfn) -> 1 if patient has data else 0 190 Q $O(^AUPNVSIT("AET",+$G(DFN),0))>0 191 ; 192 VITAL(ORVALUE,NODE,VALUES) ; from ORWGAPI4 193 D EN^GMVPXRM(.ORVALUE,NODE) 194 S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** 195 Q 196 ; 1 ORWGAPIA ; SLC/STAFF - Graph Application Calls ;11/1/06 12:49 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,251,260**;Dec 17, 1997;Build 26 3 ; 4 AA(IEN) ; $$(ien) -> external display of accession area 5 Q $P($G(^LRO(68,IEN,0)),U) 6 AALAB(TEST) ; $$(lab test) -> accession ien^acc name^acc abbrev 7 N AA,DIV 8 S TEST=+$G(TEST) 9 S DIV=+$G(DUZ(2)) 10 S AA=+$P($G(^LAB(60,+TEST,8,DIV,0)),U,2) 11 I AA Q AA_U_$$ACCLAB(AA) 12 S AA=+$P($G(^LAB(60,+TEST,8,+$O(^LAB(60,+TEST,8,0)),0)),U,2) 13 I AA Q AA_U_$$ACCLAB(AA) 14 Q "" 15 ACC(DATA) ; API - get accession areas - from ORWGAPI 16 N CNT,IEN,TMP,RESULT,ZERO 17 D RETURN^ORWGAPIU(.TMP,.DATA) 18 S CNT=0 19 S IEN=0 20 F S IEN=$O(^LRO(68,IEN)) Q:IEN<1 D 21 . S ZERO=$G(^LRO(68,IEN,0)) I '$L(ZERO) Q 22 . S RESULT="68^"_IEN_U_$P(ZERO,U)_U_$P(ZERO,U,11) 23 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 24 Q 25 ACCLAB(AA) ; $$(accession ien) -> acc name^acc abbrev 26 N ZERO 27 S ZERO=$G(^LRO(68,AA,0)) I '$L(ZERO) Q "" 28 Q "lab - "_$P(ZERO,U)_U_$P(ZERO,U,11) 29 ADDDRUG(NUM1) ; $$(additive) -> drug in 50 else "" 30 N RESULT K ^TMP($J,"RX") 31 I '$G(IEN) Q "" 32 D ZERO^PSS52P6(IEN,,,"RX") 33 S RESULT=$P($G(^TMP($J,"RX",IEN,1)),U) 34 K ^TMP($J,"RX") 35 Q RESULT 36 ALLG(IEN) ; $$(ien) -> external display of allergies 37 I IEN Q $P($G(^GMRD(120.83,IEN,0)),U) ; this is for rxn, allergy is free text 38 Q IEN 39 CPT(NODE,ORVALUE) ; from ORWGAPI4 40 D VCPT^PXPXRM(NODE,.ORVALUE) 41 Q 42 DC(IEN) ; $$(ien) -> external display of drug class 43 N RESULT K ^TMP($J,"RX") 44 I '$G(IEN) Q "" 45 D IEN^PSN50P65(IEN,,"RX") 46 S RESULT=$G(^TMP($J,"RX",IEN,1)) 47 K ^TMP($J,"RX") 48 Q RESULT 49 DISCH(IEN) ; $$(pt movement ien) -> discharge date 50 Q $P($G(^DGPM(+$P($G(^DGPM(+$G(IEN),0)),U,17),0)),U) 51 DOCCLASS(DOCTYPE) ; $$(doc type) -> ien of tiu doc class 52 N CONSULTS 53 S DOCTYPE=$E(DOCTYPE,1) 54 I DOCTYPE="P" Q 3 55 I DOCTYPE="D" Q 244 56 I DOCTYPE="C" D CNSLCLAS^TIUSRVD(.CONSULTS) Q CONSULTS 57 Q 0 58 DRGCLASS(DRUG) ; $$(drug) -> drug class^classification 59 N RESULT K ^TMP($J,"RX") 60 I '$G(DRUG) Q "" 61 D DATA^PSS50(DRUG,,,,,"RX") 62 S RESULT=+$G(^TMP($J,"RX",DRUG,25)) 63 K ^TMP($J,"RX") 64 Q RESULT_U_"drug - "_$$DC(RESULT) 65 DRUG(NUM) ; $$(bcma entry) -> drug in 50 else "" 66 N DONE,DRUG,NUM1 67 S DONE=0,NUM=+$G(NUM) 68 S NUM1=0 69 F S NUM1=$O(^PSB(53.79,NUM,.5,"B",NUM1)) Q:NUM1<1 S DONE=1 Q 70 I DONE Q NUM1 71 S DRUG=0 72 S NUM1=0 73 F S NUM1=$O(^PSB(53.79,NUM,.6,"B",NUM1)) Q:NUM1<1 D I DONE Q 74 . S DRUG=$$ADDDRUG(NUM1) 75 . I DRUG S DONE=1 76 I DONE Q DRUG 77 S DRUG=0 78 S NUM1=0 79 F S NUM1=$O(^PSB(53.79,NUM,.7,"B",NUM1)) Q:NUM1<1 D I DONE Q 80 . S DRUG=$$SOLDRUG(NUM1) 81 . I DRUG S DONE=1 82 I DONE Q DRUG 83 Q "" 84 DRUGC(VALUES) ; API - get drug classes - from ORWGAPI 85 N CLASS,IEN,NUM,ROOT K VALUES 86 S NUM=0 87 S ROOT=$$ROOT^PSN50P65(1) 88 S CLASS="" 89 F S CLASS=$O(@ROOT@(CLASS)) Q:CLASS="" D 90 . S IEN=0 91 . F S IEN=$O(@ROOT@(CLASS,IEN)) Q:IEN="" D 92 .. S NUM=NUM+1 93 .. S VALUES(NUM)="50.605^"_IEN_U_CLASS 94 M ^TMP("ORWGRPC",$J)=VALUES K VALUES 95 Q 96 EDU(NODE,ORVALUE) ; from ORWGAPI4 97 D VPEDU^PXPXRM(NODE,.ORVALUE) 98 Q 99 EXAM(NODE,ORVALUE) ; from ORWGAPI4 100 D VXAM^PXPXRM(NODE,.ORVALUE) 101 Q 102 GETTIU(ORDATA,IEN) ; from ORWGAPID 103 D TGET^TIUSRVR1(.ORDATA,IEN) 104 Q 105 HF(NODE,ORVALUE) ; from ORWGAPI4 106 D VHF^PXPXRM(NODE,.ORVALUE) 107 Q 108 ICD0(IEN) ; $$(ien) -> external display of IDC0 109 Q $P($G(^ICD0(IEN,0)),U)_" "_$P($G(^ICD0(IEN,0)),U,4) 110 ICD9(IEN) ; $$(ien) -> external display of IDC9 111 Q $P($G(^ICD9(IEN,0)),U)_" "_$P($G(^ICD9(IEN,0)),U,3) 112 ICPT(IEN,CSD) ; $$(ien) -> external display of CPT 113 N X S X=$$CPT^ICPTCOD($G(IEN),$G(CSD)) 114 Q $P(X,U,2)_" "_$E($P(X,U,3),1,30) 115 IMM(NODE,ORVALUE) ; from ORWGAPI4 116 D VIMM^PXPXRM(NODE,.ORVALUE) 117 Q 118 INSIG(NODE) ; $$(node) -> sig 119 N DFN,DNUM,IEN,LNUM,SIG,SUB ; replace this code in v27 with INSIG^ORWGAPIX 120 S DFN=+$G(NODE) 121 S SUB=$P($G(NODE),";",2) 122 S IEN=+$P($G(NODE),";",3) 123 S SIG="" 124 I SUB=5 D 125 . S LNUM=$G(^PS(55,DFN,5,IEN,0)) 126 . S DNUM=$G(^PS(55,DFN,5,IEN,.2)) 127 . I $L(DNUM),$L(LNUM) D 128 .. S SIG=" Give: "_$$EXT^ORWGAPIX($P(LNUM,U,3),55.06,3) 129 .. S SIG=SIG_" "_$$EXT^ORWGAPIX($P(LNUM,U,7),55.06,7) 130 I SUB="IV" D 131 . S LNUM=$G(^PS(55,DFN,"IV",IEN,0)) 132 . S DNUM=$G(^PS(55,DFN,"IV",IEN,.2)) 133 . I $L(DNUM),$L(LNUM) D 134 .. S SIG=" Give: "_$P(DNUM,U,2) 135 .. S SIG=SIG_" "_$$EXT^ORWGAPIX($P(LNUM,U,2),55.01,.02)_" "_$P(LNUM,U,9) 136 Q SIG 137 ISA(USER,CLASS,ORERR) ; $$(user,user class,err) -> 1 if user in class, else 0 138 Q $$ISA^USRLM(USER,CLASS,.ORERR) 139 LAB(ORVALUE,NODE,ITEM) ; from ORWGAPI3 140 D LRPXRM^LRPXAPI(.ORVALUE,NODE,ITEM,"VSC") 141 Q 142 LABNAME(Y) ; $$(item ien) -> item name 143 I $P(Y,";")="A",$P(Y,";",2)="S" Q $P(Y,".",2,99) 144 Q $$ITEMNM^LRPXAPIU(Y) 145 LABSUM(ORDATA,DFN,DATE1,DATE2,ORSUB) ; from ORWGAPID 146 D EN^LR7OSUM(.ORDATA,DFN,DATE1,DATE2,,80,.ORSUB) 147 Q 148 LOS(DGPMIFN) ; $$(pt movement ien) -> length of stay 149 N X D ^DGPMLOS 150 Q +$P($G(X),U,5) 151 LRDFN(DFN) ; $$(dfn) -> lrdfn 152 Q $$LRDFN^LRPXAPIU(DFN) 153 LRIDT(LRDT) ; $$(date) -> inverse date 154 Q $$LRIDT^LRPXAPIU(LRDT) 155 MEDICINE(ARRAY,DFN) ; 156 N DATE,FILE,IEN,NAME,NUM,REF,VALUES,XREF 157 K ARRAY,^TMP("MCAR",$J),^TMP("OR",$J,"MCAR") 158 D FILE^ORWGAPIU(690,.REF,.XREF) 159 I '$L(REF) Q 160 I $E(REF,$L(REF))="," S REF=$E(REF,1,$L(REF)-1)_")" 161 I $E(REF,$L(REF))="(" S REF=$P(REF,"(") 162 D EN^MCARPS2(DFN) 163 S NUM=0 164 F S NUM=$O(^TMP("OR",$J,"MCAR","OT",NUM)) Q:NUM<1 D 165 . S VALUES=^TMP("OR",$J,"MCAR","OT",NUM) 166 . S DATE=$$DATETFM^ORWGAPIU($P(VALUES,U,6)) 167 . S NAME=$P(VALUES,U) I '$L(NAME) Q 168 . S IEN=+$O(@REF@(XREF,NAME,"")) 169 . I DATE,IEN S ARRAY(IEN,DATE)=NAME 170 K ^TMP("MCAR",$J),^TMP("OR",$J,"MCAR") 171 Q 172 MEDVAL(VAL) ; 173 N IEN,NAME,NAMES,REF,SEQ,XREF K NAMES,VAL 174 D FILE^ORWGAPIU(690,.REF,.XREF) 175 I '$L(REF) Q 176 I $E(REF,$L(REF))="," S REF=$E(REF,1,$L(REF)-1)_")" 177 I $E(REF,$L(REF))="(" S REF=$P(REF,"(") 178 S NAME="" 179 F S NAME=$O(@REF@(XREF,NAME)) Q:NAME="" D 180 . S IEN=0 181 . F S IEN=$O(@REF@(XREF,NAME,IEN)) Q:IEN<1 D 182 .. S NAMES(IEN)=NAME 183 S SEQ=0 184 S IEN=0 185 F S IEN=$O(NAMES(IEN)) Q:IEN<1 D 186 . S SEQ=SEQ+1 187 . S VAL(SEQ)=690_U_IEN_U_NAMES(IEN) 188 Q 189 MH(ORVALUE,NODE) ; from ORWGAPI4 190 D ENDAS^YTAPI10(.ORVALUE,NODE) 191 Q 192 NVASIG(NODE) ; $$(node) -> sig on non-va drug 193 N RESULTS,SIG K RESULTS 194 I '$L(NODE) Q "" 195 D RXNVA(NODE,.RESULTS) 196 S SIG=RESULTS("DOSAGE") 197 S SIG=SIG_" "_RESULTS("MEDICATION ROUTE") 198 S SIG=SIG_" "_RESULTS("SCHEDULE") 199 Q SIG 200 OITEM(DATA) ; API - get order display groups - from ORWGAPI 201 N CNT,IEN,RESULT,TMP,ZERO 202 D RETURN^ORWGAPIU(.TMP,.DATA) 203 S CNT=0 204 S IEN=0 205 F S IEN=$O(^ORD(100.98,IEN)) Q:IEN<1 D 206 . S ZERO=$G(^ORD(100.98,IEN,0)) I '$L(ZERO) Q 207 . S RESULT="100.98^"_IEN_U_$P(ZERO,U)_U_$P(ZERO,U,3) 208 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 209 Q 210 POINAME(IEN) ; $$(poi entry) - > name and dosage form else "" 211 N NAME,RESULT K ^TMP($J,"RX") 212 I '$G(IEN) Q "" 213 D ZERO^PSS50P7(IEN,,,"RX") 214 S NAME=$P($G(^TMP($J,"RX",IEN,.01)),U) 215 S NAME=NAME_" "_$P($G(^TMP($J,"BOB",IEN,.02)),U,2) 216 K ^TMP($J,"RX") 217 I NAME'=" " Q NAME 218 Q "" 219 POV(NODE,ORVALUE) ; from ORWGAPI4 220 D VPOV^PXPXRM(NODE,.ORVALUE) 221 Q 222 PROB(GMPLLEX,GMPLSTAT,GMPLICD,GMPLODAT,GMPLXDAT,NODE) ; from ORWGAPI4 223 N GMPLPNAM,GMPLDLM,GMPLTXT,GMPLCOND,GMPLPRV,GMPLPRIO 224 D CALL2^GMPLUTL3(NODE) 225 Q 226 PTF(NODE,ORVALUE) ; from ORWGAPI3, ORWGAPI4 227 D PTF^DGPTPXRM(NODE,.ORVALUE) 228 Q 229 RAD(NODE,ORVALUE) ; from ORWGAPI3 230 D EN1^RAPXRM(NODE,.ORVALUE) 231 Q 232 RXIN(NODE,ORVALUE) ; from ORWGAPI3 233 D OEL^PSJPXRM1(NODE,.ORVALUE) 234 Q 235 RXNVA(NODE,ORVALUE,XSTART,XSTOP) ; from ORWGAPI1, ORWGAPI3, ORWGAPID 236 S XSTART=1,XSTOP=1 237 D NVA^PSOPXRM1(NODE,.ORVALUE) 238 I '$G(ORVALUE("START DATE")) D 239 . S ORVALUE("START DATE")=$G(ORVALUE("DOCUMENTED DATE")) 240 . S XSTART=0 241 I '$G(ORVALUE("DISCONTINUED DATE")) D 242 . S XSTOP=0 243 Q 244 RXOUT(NODE,ORVALUE) ; from ORWGAPI3 245 D PSRX^PSOPXRM1(NODE,.ORVALUE) 246 Q 247 SIG(DFN,RXIEN) ; $$(dfn,prescription ien) -> sig 248 N LNUM,SIG K ^TMP($J,"RX") 249 S RXIEN=+$G(RXIEN) 250 D RX^PSO52API(DFN,"RX",RXIEN,,"M",,) 251 S SIG="" 252 S LNUM=0 253 F S LNUM=$O(^TMP($J,"RX",DFN,RXIEN,"M",LNUM)) Q:LNUM<1 D 254 . S SIG=SIG_$G(^TMP($J,"RX",DFN,RXIEN,"M",LNUM,0))_" " 255 I $L(SIG) S SIG=" Sig: "_$$LOW^ORWGAPIX(SIG) 256 K ^TMP($J,"RX") 257 Q SIG 258 SKIN(NODE,ORVALUE) ; from ORWGAPI4 259 D VSKIN^PXPXRM(NODE,.ORVALUE) 260 Q 261 SOLDRUG(NUM1) ; $$(iv solution) -> drug in 50 else "" 262 N RESULT K ^TMP($J,"RX") 263 I '$G(IEN) Q "" 264 D ZERO^PSS52P7(IEN,,,"RX") 265 S RESULT=$P($G(^TMP($J,"RX",IEN,1)),U) 266 K ^TMP($J,"RX") 267 Q RESULT 268 SURG(ORSURG,DFN) ; from ORWGAPI2, ORWGAPI4 269 D GET^SROGTSR(.ORSURG,DFN) 270 Q 271 TAX(IEN) ; $$(ien) -> external display of reminder taxonomy 272 Q $P($G(^PXD(811.2,+$G(IEN),0)),U) 273 TITLE(DOCTYPE) ; $$(document type) -> parent ien^parent^parent abbrev 274 N IEN,RESULTS K RESULTS 275 S DOCTYPE=+$G(^TIU(8925,+$G(DOCTYPE),0)) 276 S IEN=+$$DOCCLASS^TIULC1(DOCTYPE) I 'IEN Q "" 277 D GETDATA^ORWGAPIX(.RESULTS,8925.1,".01;.02",IEN) 278 I '$L($G(RESULTS(.01))) Q "" 279 Q IEN_U_"note - "_RESULTS(.01)_U_$G(RESULTS(.02)) 280 TIU(ORVALUE,DOCIEN,ONE,DFN,OLDEST,NEWEST) ; from ORWGAPI1, ORWGAPI3 281 D CONTEXT^TIUSRVLO(.ORVALUE,DOCIEN,ONE,DFN,$G(OLDEST),$G(NEWEST)) 282 Q 283 TIUTITLE(DATA) ; API - get tiu document titles - from ORWGAPI 284 N CNT,IEN,RESULT,RESULTS,TMP 285 D RETURN^ORWGAPIU(.TMP,.DATA) 286 S CNT=0 287 S IEN=0 288 F S IEN=$O(^TIU(8925.1,IEN)) Q:IEN<1 D 289 . I $P($G(^TIU(8925.1,IEN,0)),U,4)'="DOC" Q 290 . K RESULTS 291 . D GETDATA^ORWGAPIX(.RESULTS,8925.1,".01;.02",IEN) 292 . I '$L($G(RESULTS(.01))) Q 293 . S RESULT="8925.1^"_IEN_U_RESULTS(.01)_U_$G(RESULTS(.02)) 294 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 295 Q 296 VITAL(ORVALUE,NODE) ; from ORWGAPI4 297 D EN^GMVPXRM(.ORVALUE,NODE) 298 Q 299 ; $$(dfn) -> 1 if patient has data else 0 300 ADMITX(DFN) ; 301 Q $O(^DGPM("C",+$G(DFN),0))>0 302 ALLERGYX(DFN) ; 303 Q $O(^GMR(120.8,"B",+$G(DFN),0))>0 304 BCMAX(DFN) ; 305 Q $O(^PSB(53.79,"B",+$G(DFN),0))>0 306 NOTEX(DFN) ; 307 Q $O(^TIU(8925,"C",+$G(DFN),0))>0 308 NVAX(DFN) ; 309 Q $L($O(^PXRMINDX("55NVA","PI",+$G(DFN),"")))>0 310 SURGX(DFN) ; 311 Q $O(^SRF("B",+$G(DFN),0))>0 312 TREATX(DFN) ; 313 Q $L($O(^AUPNVTRT("AA",+$G(DFN),"")))>0 314 VISITX(DFN) ; 315 Q $O(^AUPNVSIT("AET",+$G(DFN),0))>0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIB.m
r613 r623 1 ORWGAPIB ; SLC/STAFF - Graph Blood Bank ;12/21/05 08:21 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 3 ; 4 BBITEM(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 5 N DATE,IDATE,INEWEST,IOLDEST,ITEM,LRDFN,OK,RESULT 6 K ^TMP("ORWGRPC TEMP",$J) 7 S INEWEST=$$LRIDT^ORWGAPIC(NEWEST),IOLDEST=$$LRIDT^ORWGAPIC(OLDEST) 8 S LRDFN=$$LRDFN^ORWGAPIC(DFN) 9 S IDATE=0 10 F S IDATE=$O(^LR(LRDFN,1.6,IDATE)) Q:IDATE<1 D 11 . S ITEM=+$P($G(^LR(LRDFN,1.6,IDATE,0)),U,2) 12 . I 'ITEM Q 13 . S OK=0 14 . I FMT=6 D 15 .. Q:IDATE<INEWEST Q:IDATE>IOLDEST 16 .. S OK=1 17 .. S CNT=CNT+1 18 .. S RESULT="63BB"_U_ITEM 19 . I FMT=3 D 20 .. I '$D(^TMP("ORWGRPC TEMP",$J,ITEM)) D 21 ... S OK=1 22 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" 23 ... S DATE=$$LRIDT^ORWGAPIC(IDATE) 24 ... S CNT=CNT+1 25 ... S RESULT="63BB^"_ITEM_"^^"_$P($G(^LAB(66,ITEM,0)),U)_"^^"_DATE 26 . I FMT=0 D 27 .. S OK=1 28 .. S CNT=CNT+1 29 .. S RESULT="63BB^"_ITEM_U_$P($G(^LAB(66,ITEM,0)),U) 30 . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 31 K ^TMP("ORWGRPC TEMP",$J) 32 Q 33 ; 34 BBDATA(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR 35 N DATE,IDATE,LRDFN,NITEM,RESULT 36 S LRDFN=$$LRDFN^ORWGAPIC(DFN) 37 S IDATE="",CNT=$G(CNT),BACKTO=+$G(BACKTO) 38 F S IDATE=$O(^LR(LRDFN,1.6,IDATE)) Q:IDATE="" D 39 . S NITEM=+$P($G(^LR(LRDFN,1.6,IDATE,0)),U,2) 40 . I NITEM'=ITEM Q 41 . S DATE=$$LRIDT^ORWGAPIC(IDATE) 42 . I DATE>START Q 43 . I DATE<BACKTO Q 44 . S RESULT="63BB^"_ITEM_U_DATE_U 45 . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 46 Q 47 ; 48 BBX(DFN) ; $$(dfn) -> 1 if patient has blood bank data ,else 0 49 Q $L($O(^LR(+$$LRDFN^ORWGAPIC($G(DFN)),1.6,"")))>0 50 ; 1 ORWGAPIB ; SLC/STAFF - Graph Blood Bank ;12/21/05 08:21 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 3 ; 4 BBITEM(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 5 N DATE,IDATE,INEWEST,IOLDEST,ITEM,LRDFN,OK,RESULT 6 K ^TMP("ORWGRPC TEMP",$J) 7 S INEWEST=$$LRIDT^ORWGAPIA(NEWEST),IOLDEST=$$LRIDT^ORWGAPIA(OLDEST) 8 S LRDFN=$$LRDFN^ORWGAPIA(DFN) 9 S IDATE=0 10 F S IDATE=$O(^LR(LRDFN,1.6,IDATE)) Q:IDATE<1 D 11 . S ITEM=+$P($G(^LR(LRDFN,1.6,IDATE,0)),U,2) 12 . I 'ITEM Q 13 . S OK=0 14 . I FMT=6 D 15 .. Q:IDATE<INEWEST Q:IDATE>IOLDEST 16 .. S OK=1 17 .. S CNT=CNT+1 18 .. S RESULT="63BB"_U_ITEM 19 . I FMT=3 D 20 .. I '$D(^TMP("ORWGRPC TEMP",$J,ITEM)) D 21 ... S OK=1 22 ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" 23 ... S DATE=$$LRIDT^ORWGAPIA(IDATE) 24 ... S CNT=CNT+1 25 ... S RESULT="63BB^"_ITEM_"^^"_$P($G(^LAB(66,ITEM,0)),U)_"^^"_DATE 26 . I FMT=0 D 27 .. S OK=1 28 .. S CNT=CNT+1 29 .. S RESULT="63BB^"_ITEM_U_$P($G(^LAB(66,ITEM,0)),U) 30 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 31 K ^TMP("ORWGRPC TEMP",$J) 32 Q 33 ; 34 BBDATA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 35 N DATE,IDATE,LRDFN,NITEM,RESULT 36 S LRDFN=$$LRDFN^ORWGAPIA(DFN) 37 S IDATE="",CNT=$G(CNT) 38 F S IDATE=$O(^LR(LRDFN,1.6,IDATE)) Q:IDATE="" D 39 . S NITEM=+$P($G(^LR(LRDFN,1.6,IDATE,0)),U,2) 40 . I NITEM'=ITEM Q 41 . S DATE=$$LRIDT^ORWGAPIA(IDATE) 42 . I DATE>START Q 43 . S RESULT="63BB^"_ITEM_U_DATE_U 44 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 45 Q 46 ; 47 BBX(DFN) ; $$(dfn) -> 1 if patient has blood bank data ,else 0 48 Q $L($O(^LR(+$$LRDFN^ORWGAPIA($G(DFN)),1.6,"")))>0 49 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPID.m
r613 r623 1 ORWGAPID ; SLC/STAFF - Graph API Details ;12/21/05 08:19 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 3 ; 4 DETAILS(DATA,DFN,DATE1,DATE2,FILEITEM) ; from ORWGAPI (series click) 5 N ITEM,FILE,SUBHEAD,TYPEITEM K SUBHEAD,TYPEITEM 6 K ^TMP("LR7OGX",$J),^TMP("LRC",$J) 7 K ^TMP("ORLRC",$J),^TMP("PSBO",$J),^TMP("TIUVIEW",$J) 8 S FILE=$P(FILEITEM,U) 9 S ITEM=$$UP^ORWGAPIX($P(FILEITEM,U,2)) 10 I '$L(ITEM) Q 11 D 12 . I FILE=63 D Q 13 .. D INTERIM^ORWLRR(.DATA,DFN,DATE1,DATE2) 14 .. M ^TMP("ORWGRPC",$J)=^TMP("LR7OGX",$J,"OUTPUT") 15 . I FILE="63MI" D Q 16 .. D MICRO^ORWLRR(.DATA,DFN,DATE1,DATE2) 17 .. M ^TMP("ORWGRPC",$J)=^TMP("LR7OGX",$J,"OUTPUT") 18 . I FILE="63AP" D Q 19 .. S SUBHEAD("CYTOPATHOLOGY")="" 20 .. S SUBHEAD("SURGICAL PATHOLOGY")="" 21 .. S SUBHEAD("EM")="" 22 .. S SUBHEAD("AUTOPSY")="" 23 .. D LABSUM^ORWGAPIC(.DATA,DFN,DATE1,DATE2,.SUBHEAD) 24 .. M ^TMP("ORWGRPC",$J)=^TMP("LRC",$J) 25 . I FILE="63BB" D Q 26 .. D BLR^ORWRP1(.DATA,DFN,"",DATE1,DATE2) 27 .. M ^TMP("ORWGRPC",$J)=^TMP("ORLRC",$J) 28 . I FILE="53.79" D Q 29 .. ;D BCMA1^ORWRP1A(.DATA,DFN,"",DATE1,DATE2) ***** BA 12/14/07 30 .. D BCMA1^ORWRP1A(.DATA,DFN,"",DATE2,DATE1) 31 .. M ^TMP("ORWGRPC",$J)=^TMP("PSBO",$J) 32 . I FILE="8925" D Q 33 .. D NOTE(.DATA,DFN,DATE1,DATE2,ITEM) 34 .. ;M ^TMP("ORWGRPC",$J)=^TMP("TIUVIEW",$J) 35 . S TYPEITEM(1)=FILE_"^0" 36 . D DETAIL(.DATA,DFN,DATE1,DATE2,.TYPEITEM) 37 K ^TMP("LR7OGX",$J),^TMP("LRC",$J) 38 K ^TMP("ORLRC",$J),^TMP("PSBO",$J),^TMP("TIUVIEW",$J) 39 Q 40 ; 41 DETAIL(DATA,DFN,DATE1,DATE2,TYPEITEM) ; from ORWGAPI (legend click) 42 N CNT,FILE,GMTSPX1,GMTSPX2,ITEM,TITEMS,TYPE 43 N COMP,NEWITEMS K COMP,NEWITEMS 44 K ^TMP("ORDATA",$J) 45 S DFN=+$G(DFN) I 'DFN Q 46 I '$L($O(TYPEITEM(0))) Q 47 S TYPE="" 48 F S TYPE=$O(TYPEITEM(TYPE)) Q:TYPE="" D 49 . S TITEMS=TYPEITEM(TYPE) 50 . S FILE=$P(TITEMS,U) I '$L(FILE) Q 51 . S ITEM=$P(TITEMS,U,2) I '$L(ITEM) Q 52 . S NEWITEMS(FILE,ITEM)="" 53 S CNT=0 54 S FILE="" 55 F S FILE=$O(NEWITEMS(FILE)) Q:FILE="" D 56 . S CNT=CNT+1 57 . S COMP(CNT)=$$COMPTYPE^ORWGAPIT(FILE) 58 S GMTSPX1=DATE1,GMTSPX2=DATE2 59 D REPORT^ORWRP2(.DATA,.COMP,DFN) 60 M ^TMP("ORWGRPC",$J)=^TMP("ORDATA",$J) 61 ;K ^TMP("ORDATA",$J) 62 ;Q 63 ; 64 S CNT=0 65 S TYPE="" 66 F S TYPE=$O(TYPEITEM(TYPE)) Q:TYPE="" D 67 . S TITEMS=TYPEITEM(TYPE) 68 . S CNT=CNT+1 69 . S ^TMP("ORWGRPC",$J,CNT/10000)="~~~^"_TITEMS 70 ; 71 K ^TMP("ORDATA",$J) 72 Q 73 ; 74 GETDATES(DATA,REPORTID) ; from ORWGAPI 75 N DAT,TMP K DAT 76 D RETURN^ORWGAPIW(.TMP,.DATA) 77 S DAT(1)="S^Date Range..." 78 S DAT(2)="1^Today" 79 S DAT(3)="2^One Week" 80 S DAT(4)="3^Two Weeks" 81 S DAT(5)="4^One Month" 82 S DAT(6)="5^Six Months" 83 S DAT(7)="6^One Year" 84 S DAT(8)="7^Two Years" 85 S DAT(9)="8^All Results" 86 D DATES^ORWGAPIP(.DAT,REPORTID) 87 I TMP M ^TMP(DATA,$J)=DAT 88 I 'TMP M DATA=DAT 89 Q 90 ; 91 NOTE(DATA,DFN,DATE1,DATE2,ITEM) ; 92 N CNT,DATE,DOC,DOCCLASS,DOCTYPE,DUM,IEN,LINE,NUM,RESULTS K DUM 93 K ^TMP("TIUR",$J),^TMP("TIUVIEW",$J) 94 S CNT=$G(CNT) 95 F DOCTYPE="P","D","C" D 96 . S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) 97 . K ^TMP("TIUR",$J) 98 . D TIU^ORWGAPIA(.DUM,DOCCLASS,5,DFN,DATE1,DATE2) 99 . S DOC=0 100 . F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D 101 .. S RESULTS=^TMP("TIUR",$J,DOC) 102 .. S IEN=+$P(RESULTS,U) 103 .. K ^TMP("TIUVIEW",$J) 104 .. D GETTIU^ORWGAPIA(.DATA,IEN) 105 .. S NUM=0 106 .. F S NUM=$O(^TMP("TIUVIEW",$J,NUM)) Q:NUM<1 D 107 ... S LINE=$G(^TMP("TIUVIEW",$J,NUM)) 108 ... S CNT=CNT+1 109 ... S ^TMP("ORWGRPC",$J,CNT)=LINE 110 .. I CNT>1 D 111 ... S CNT=CNT+1 112 ... S ^TMP("ORWGRPC",$J,CNT)=" " 113 ... S CNT=CNT+1 114 ... S ^TMP("ORWGRPC",$J,CNT)=" " 115 ... S ^TMP("ORWGRPC",$J,CNT/10000)="~~~^"_^TMP("TIUR",$J,DOC) 116 K ^TMP("TIUR",$J),^TMP("TIUVIEW",$J) 117 Q 118 ; 119 TAX(DATA,ALL,REMTAX) ; from ORWGAPI 120 N CNT,REM,CODE,NUM,TMP 121 K ^TMP("ORWG TEMP",$J) 122 D RETURN^ORWGAPIW(.TMP,.DATA) 123 S CNT=0 124 S REM=0 125 I ALL F S REM=$O(^PXD(811.2,REM)) Q:REM<1 D TEMP(REM) 126 I 'ALL D 127 . S NUM=0 128 . F S NUM=$O(REMTAX(NUM)) Q:NUM<1 D 129 .. S REM=REMTAX(NUM) 130 .. D TEMP(REM) 131 S CODE="" 132 F S CODE=$O(^TMP("ORWG TEMP",$J,CODE)) Q:CODE="" D 133 . D SETUP^ORWGAPIW(.DATA,CODE,TMP,.CNT) 134 K ^TMP("ORWG TEMP",$J) 135 Q 136 ; 137 TEMP(REM) ; 138 N NODE,NUM,SUB 139 I $P($G(^PXD(811.2,REM,0)),U,6)=1 Q 140 F SUB=80,80.1,81 D 141 . S NUM=0 142 . F S NUM=$O(^PXD(811.3,REM,SUB,NUM)) Q:NUM<1 D 143 .. S NODE=+$G(^PXD(811.3,REM,SUB,NUM,0)) 144 .. I 'NODE Q 145 .. I SUB=80 D Q 146 ... S ^TMP("ORWG TEMP",$J,"45DX;"_NODE)="" 147 ... S ^TMP("ORWG TEMP",$J,"9000010.07;"_NODE)="" 148 ... S ^TMP("ORWG TEMP",$J,"9000011;"_NODE)="" 149 .. I SUB=80.1 D Q 150 ... S ^TMP("ORWG TEMP",$J,"45OP;"_NODE)="" 151 .. I SUB=81 D Q 152 ... S ^TMP("ORWG TEMP",$J,"9000010.18;"_NODE)="" 153 Q 154 ; 155 PLX2(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 156 N DATE,DTONSET,DTPLUS1,DTRESOLV,NODE,PRIORITY,PROB,PROBDX,PSTATUS,RESULT,STATUS,VALUE 157 K ^TMP("ORWGRPC TEMP",$J) 158 S DTPLUS1=$$FMADD^ORWGAPIX(DT,1) 159 S STATUS="" 160 F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D 161 . S PRIORITY="" 162 . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D 163 .. S ITEM="" 164 .. F S ITEM=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM="" D 165 ... S DATE="" 166 ... F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D 167 .... S NODE="" 168 .... F S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE="" D 169 ..... D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE) 170 ..... I 'DTRESOLV S ^TMP("ORWGRPC TEMP",$J,PROBDX,DTONSET)=DTPLUS1 Q 171 ..... S ^TMP("ORWGRPC TEMP",$J,PROBDX,DTONSET)=DTRESOLV 172 S PROB="" 173 F S PROB=$O(^TMP("ORWGRPC TEMP",$J,PROB)) Q:PROB="" D 174 . S VALUE=$$EVALUE^ORWGAPIU(PROB,9000011,.01) 175 . I FMT=0 D 176 .. S CNT=CNT+1 177 .. S RESULT=9999911_U_PROB_U_VALUE 178 .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 179 . I FMT=6 D 180 .. S OK=0 181 .. S DATE=0 182 .. F S DATE=$O(^TMP("ORWGRPC TEMP",$J,PROB,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 183 ... S DTRESOLV=^TMP("ORWGRPC TEMP",$J,PROB,DATE) 184 ... I DTRESOLV<OLDEST Q 185 ... S CNT=CNT+1 186 ... S OK=1 187 ... S RESULT=9999911_U_PROB 188 .. I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 189 . I FMT=3 D 190 .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,PROB,""),-1) 191 .. I 'DATE Q 192 .. S CNT=CNT+1 193 .. S RESULT=9999911_U_PROB_"^^"_VALUE_"^^"_DATE 194 .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 195 K ^TMP("ORWGRPC TEMP",$J) 196 Q 197 ; 198 PROBX4(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 199 N DATE,DTONSET,DTPLUS1,DTRESOLV,NODE,PRIORITY,PROB,PROBDX,PSTATUS,RESULT,STATUS,VALUE 200 K ^TMP("ORWGRPC TEMP",$J) 201 S CNT=$G(CNT),DTPLUS1=$$FMADD^ORWGAPIX(DT,1) 202 S STATUS="" 203 F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D 204 . S PRIORITY="" 205 . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D 206 .. S DATE="" 207 .. F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D 208 ... I DATE>START Q 209 ... S NODE="" 210 ... F S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE="" D 211 .... S ^TMP("ORWGRPC TEMP",$J,NODE)="" 212 S NODE="" 213 F S NODE=$O(^TMP("ORWGRPC TEMP",$J,NODE)) Q:NODE="" D 214 . D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE) 215 . I 'DTONSET Q 216 . I 'DTRESOLV S DTRESOLV=DTPLUS1 217 . S RESULT=9999911_U_PROBDX_U_DTONSET_U_DTRESOLV_U_$$EXT^ORWGAPIX(PSTATUS,9000011,.12) 218 . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 219 K ^TMP("ORWGRPC TEMP",$J) 220 Q 221 ; 1 ORWGAPID ; SLC/STAFF - Graph API Details ;12/21/05 08:19 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 3 ; 4 DETAILS(DATA,DFN,DATE1,DATE2,FILEITEM) ; from ORWGAPI (series click) 5 N ITEM,FILE,SUBHEAD,TYPEITEM K SUBHEAD,TYPEITEM 6 K ^TMP("LR7OGX",$J),^TMP("LRC",$J) 7 K ^TMP("ORLRC",$J),^TMP("PSBO",$J),^TMP("TIUVIEW",$J) 8 S FILE=$P(FILEITEM,U) 9 S ITEM=$$UP^ORWGAPIX($P(FILEITEM,U,2)) 10 I '$L(ITEM) Q 11 D 12 . I FILE=63 D Q 13 .. D INTERIM^ORWLRR(.DATA,DFN,DATE1,DATE2) 14 .. M ^TMP("ORWGRPC",$J)=^TMP("LR7OGX",$J,"OUTPUT") 15 . I FILE="63MI" D Q 16 .. D MICRO^ORWLRR(.DATA,DFN,DATE1,DATE2) 17 .. M ^TMP("ORWGRPC",$J)=^TMP("LR7OGX",$J,"OUTPUT") 18 . I FILE="63AP" D Q 19 .. S SUBHEAD("CYTOPATHOLOGY")="" 20 .. S SUBHEAD("SURGICAL PATHOLOGY")="" 21 .. S SUBHEAD("EM")="" 22 .. S SUBHEAD("AUTOPSY")="" 23 .. D LABSUM^ORWGAPIA(.DATA,DFN,DATE1,DATE2,.SUBHEAD) 24 .. M ^TMP("ORWGRPC",$J)=^TMP("LRC",$J) 25 . I FILE="63BB" D Q 26 .. D BLR^ORWRP1(.DATA,DFN,"",DATE1,DATE2) 27 .. M ^TMP("ORWGRPC",$J)=^TMP("ORLRC",$J) 28 . I FILE="53.79" D Q 29 .. D BCMA1^ORWRP1A(.DATA,DFN,"",DATE1,DATE2) 30 .. M ^TMP("ORWGRPC",$J)=^TMP("PSBO",$J) 31 . I FILE="8925" D Q 32 .. D NOTE(.DATA,DFN,DATE1,DATE2,ITEM) 33 .. ;M ^TMP("ORWGRPC",$J)=^TMP("TIUVIEW",$J) 34 . S TYPEITEM(1)=FILE_"^0" 35 . D DETAIL(.DATA,DFN,DATE1,DATE2,.TYPEITEM) 36 K ^TMP("LR7OGX",$J),^TMP("LRC",$J) 37 K ^TMP("ORLRC",$J),^TMP("PSBO",$J),^TMP("TIUVIEW",$J) 38 Q 39 ; 40 DETAIL(DATA,DFN,DATE1,DATE2,TYPEITEM) ; from ORWGAPI (legend click) 41 N CNT,FILE,GMTSPX1,GMTSPX2,ITEM,TITEMS,TYPE 42 N COMP,NEWITEMS K COMP,NEWITEMS 43 K ^TMP("ORDATA",$J) 44 S DFN=+$G(DFN) I 'DFN Q 45 I '$L($O(TYPEITEM(0))) Q 46 S TYPE="" 47 F S TYPE=$O(TYPEITEM(TYPE)) Q:TYPE="" D 48 . S TITEMS=TYPEITEM(TYPE) 49 . S FILE=$P(TITEMS,U) I '$L(FILE) Q 50 . S ITEM=$P(TITEMS,U,2) I '$L(ITEM) Q 51 . S NEWITEMS(FILE,ITEM)="" 52 S CNT=0 53 S FILE="" 54 F S FILE=$O(NEWITEMS(FILE)) Q:FILE="" D 55 . S CNT=CNT+1 56 . S COMP(CNT)=$$COMPTYPE^ORWGAPIT(FILE) 57 S GMTSPX1=DATE1,GMTSPX2=DATE2 58 D REPORT^ORWRP2(.DATA,.COMP,DFN) 59 M ^TMP("ORWGRPC",$J)=^TMP("ORDATA",$J) 60 K ^TMP("ORDATA",$J) 61 Q 62 ; 63 NOTE(DATA,DFN,DATE1,DATE2,ITEM) ; 64 N CNT,DATE,DOC,DOCCLASS,DOCTYPE,DUM,IEN,LINE,NUM,RESULTS K DUM 65 K ^TMP("TIUR",$J),^TMP("TIUVIEW",$J) 66 S CNT=$G(CNT) 67 F DOCTYPE="P","D","C" D 68 . S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) 69 . K ^TMP("TIUR",$J) 70 . D TIU^ORWGAPIA(.DUM,DOCCLASS,5,DFN,DATE1,DATE2) 71 . S DOC=0 72 . F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D 73 .. S RESULTS=^TMP("TIUR",$J,DOC) 74 .. S IEN=+$P(RESULTS,U) 75 .. K ^TMP("TIUVIEW",$J) 76 .. D GETTIU^ORWGAPIA(.DATA,IEN) 77 .. S NUM=0 78 .. F S NUM=$O(^TMP("TIUVIEW",$J,NUM)) Q:NUM<1 D 79 ... S LINE=$G(^TMP("TIUVIEW",$J,NUM)) 80 ... S CNT=CNT+1 81 ... S ^TMP("ORWGRPC",$J,CNT)=LINE 82 .. I CNT>1 D 83 ... S CNT=CNT+1 84 ... S ^TMP("ORWGRPC",$J,CNT)=" " 85 ... S CNT=CNT+1 86 ... S ^TMP("ORWGRPC",$J,CNT)=" " 87 K ^TMP("TIUR",$J),^TMP("TIUVIEW",$J) 88 Q 89 ; 90 TAX(DATA,ALL,REMTAX) ; from ORWGAPI 91 N CNT,REM,CODE,NUM,TMP 92 K ^TMP("ORWG TEMP",$J) 93 D RETURN^ORWGAPIU(.TMP,.DATA) 94 S CNT=0 95 S REM=0 96 I ALL F S REM=$O(^PXD(811.2,REM)) Q:REM<1 D TEMP(REM) 97 I 'ALL D 98 . S NUM=0 99 . F S NUM=$O(REMTAX(NUM)) Q:NUM<1 D 100 .. S REM=REMTAX(NUM) 101 .. D TEMP(REM) 102 S CODE="" 103 F S CODE=$O(^TMP("ORWG TEMP",$J,CODE)) Q:CODE="" D 104 . D SETUP^ORWGAPIU(.DATA,CODE,TMP,.CNT) 105 K ^TMP("ORWG TEMP",$J) 106 Q 107 ; 108 TEMP(REM) ; 109 N NODE,NUM,SUB 110 I $P($G(^PXD(811.2,REM,0)),U,6)=1 Q 111 F SUB=80,80.1,81 D 112 . S NUM=0 113 . F S NUM=$O(^PXD(811.3,REM,SUB,NUM)) Q:NUM<1 D 114 .. S NODE=+$G(^PXD(811.3,REM,SUB,NUM,0)) 115 .. I 'NODE Q 116 .. I SUB=80 D Q 117 ... S ^TMP("ORWG TEMP",$J,"45DX;"_NODE)="" 118 ... S ^TMP("ORWG TEMP",$J,"9000010.07;"_NODE)="" 119 ... S ^TMP("ORWG TEMP",$J,"9000011;"_NODE)="" 120 .. I SUB=80.1 D Q 121 ... S ^TMP("ORWG TEMP",$J,"45OP;"_NODE)="" 122 .. I SUB=81 D Q 123 ... S ^TMP("ORWG TEMP",$J,"9000010.18;"_NODE)="" 124 Q 125 ; 126 MED1(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 127 N DATE,ITEM,OK,MEDARRAY,RESULT K MEDARRAY 128 D MEDICINE^ORWGAPIA(.MEDARRAY,DFN) 129 S ITEM=0 130 F S ITEM=$O(MEDARRAY(ITEM)) Q:ITEM<1 D 131 . S OK=0 132 . I FMT=6 D 133 .. S DATE=OLDEST 134 .. F S DATE=$O(MEDARRAY(ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 135 ... S CNT=CNT+1 136 ... S OK=1 137 ... S RESULT=690_U_ITEM 138 ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 139 . I FMT'=6 D 140 .. S DATE=$O(MEDARRAY(ITEM,""),-1) 141 .. I 'DATE Q 142 .. S NAME=MEDARRAY(ITEM,DATE) 143 .. I '$L(NAME) Q 144 .. S CNT=CNT+1 145 .. S OK=1 146 .. I FMT=3 S RESULT=690_U_ITEM_"^^"_NAME_"^^"_DATE 147 .. I FMT=0 S RESULT=690_U_ITEM_U_NAME 148 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 149 Q 150 ; 151 MED3(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 152 N DATE,DATE2,DATESTOP,DATESTRT,DTPLUS1,NODE,RESULT,STATUS,VALUE K VALUE 153 D MEDICINE^ORWGAPIA(.MEDARRAY,DFN) 154 S ITEM=+$G(ITEM) 155 S CNT=$G(CNT) 156 S DATE="" 157 F S DATE=$O(MEDARRAY(ITEM,DATE)) Q:DATE="" D 158 . I DATE>START Q 159 . S RESULT=690_U_ITEM_U_DATE_"^^" 160 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 161 Q 162 ; 163 NVA1(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 164 N DATA,DATE,DATE1,DATESTRT,DRUG,ITEM,OK,REF,RESULT K DATA 165 S ITEM="" 166 F S ITEM=$O(^PXRMINDX("55NVA","PI",DFN,ITEM)) Q:ITEM="" D 167 . S OK=0 168 . I FMT=6 D 169 .. S DATE=0 170 .. F S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 171 ... S DATE1="" 172 ... F S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE1)) Q:DATE1="" D Q:OK 173 .... I DATE1'["U",DATE1<OLDEST Q 174 .... S CNT=CNT+1 175 .... S OK=1 176 .... S RESULT="55NVA"_U_ITEM 177 . I FMT'=6 D 178 .. S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,""),-1) 179 .. I 'DATE Q 180 .. S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,""),-1) 181 .. I '$L(DATE1) Q 182 .. S REF=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE1,""),-1) 183 .. I '$L(REF) Q 184 .. D RXNVA^ORWGAPIA(REF,.DATA) 185 .. S DRUG=+$G(DATA("DISPENSE DRUG")) 186 .. S DATESTRT=+$G(DATA("START DATE")) 187 .. I 'DATESTRT Q 188 .. S CNT=CNT+1 189 .. S OK=1 190 .. I FMT=3 S RESULT="55NVA"_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,"55NVA",.01)_"^^"_DATESTRT 191 .. I FMT=0 S RESULT="55NVA"_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,"55NVA",.01) 192 .. I DRUG S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIA(DRUG) 193 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 194 Q 195 ; 196 NVA3(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 197 N DATE1,DATE2,DATESTOP,DATESTRT,DTPLUS1,NODE,RESULT,STATUS,VALUE K VALUE 198 S CNT=$G(CNT),DTPLUS1=$$FMADD^ORWGAPIX(DT,1) 199 S DATE1="" 200 F S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE1)) Q:DATE1="" D 201 . I DATE1>START Q 202 . S DATE2="" 203 . F S DATE2=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE1,DATE2)) Q:DATE2="" D 204 .. S NODE="" 205 .. F S NODE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE1,DATE2,NODE)) Q:NODE="" D 206 ... D RXNVA^ORWGAPIA(NODE,.VALUE) 207 ... S STATUS=$G(VALUE("STATUS")) 208 ... S DATESTRT=+$G(VALUE("START DATE")) 209 ... I 'DATESTRT Q 210 ... S DATESTOP=+$G(VALUE("DISCONTINUED DATE")) 211 ... I 'DATESTOP S DATESTOP=DTPLUS1 212 ... S STATUS=STATUS_" "_$$NVASIG^ORWGAPIA(NODE) 213 ... S RESULT="55NVA"_U_ITEM_U_DATESTRT_U_DATESTOP_U_STATUS 214 ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 215 Q 216 ; 217 PLX2(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR 218 N DATE,DTPLUS1,ICD9,OK,PRIORITY,RESULT,STATUS 219 K ^TMP("ORWGRPC TEMP",$J) 220 S DTPLUS1=$$FMADD^ORWGAPIX(DT,1) 221 S STATUS="" 222 F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D 223 . S PRIORITY="" 224 . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D 225 .. S ITEM="" 226 .. F S ITEM=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM="" D 227 ... S DATE="" 228 ... F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D 229 .... S NODE="" 230 .... F S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE="" D 231 ..... D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE) 232 ..... I 'DTRESOLV S ^TMP("ORWGRPC TEMP",$J,PROBDX,DTONSET)=DTPLUS1 Q 233 ..... S ^TMP("ORWGRPC TEMP",$J,PROBDX,DTONSET)=DTRESOLV 234 S PROB="" 235 F S PROB=$O(^TMP("ORWGRPC TEMP",$J,PROB)) Q:PROB="" D 236 . S VALUE=$$EVALUE^ORWGAPIU(PROB,9000011,.01) 237 . I FMT=0 D 238 .. S CNT=CNT+1 239 .. S RESULT=9999911_U_PROB_U_VALUE 240 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 241 . I FMT=6 D 242 .. S OK=0 243 .. S DATE=0 244 .. F S DATE=$O(^TMP("ORWGRPC TEMP",$J,PROB,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 245 ... S DTRESOLV=^TMP("ORWGRPC TEMP",$J,PROB,DATE) 246 ... I DTRESOLV<OLDEST Q 247 ... S CNT=CNT+1 248 ... S OK=1 249 ... S RESULT=9999911_U_PROB 250 .. I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 251 . I FMT=3 D 252 .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,PROB,""),-1) 253 .. I 'DATE Q 254 .. S CNT=CNT+1 255 .. S RESULT=9999911_U_PROB_"^^"_VALUE_"^^"_DATE 256 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 257 K ^TMP("ORWGRPC TEMP",$J) 258 Q 259 ; 260 PROBX4(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR 261 N DATE,DTONSET,DTPLUS1,DTRESOLV,ICD9,NODE,PRIORITY,PROB,PROBDX,PSTATUS,RESULT,STATUS,VALUE 262 K ^TMP("ORWGRPC TEMP",$J) 263 S CNT=$G(CNT),DTPLUS1=$$FMADD^ORWGAPIX(DT,1) 264 S STATUS="" 265 F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D 266 . S PRIORITY="" 267 . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D 268 .. S DATE="" 269 .. F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D 270 ... I DATE>START Q 271 ... S NODE="" 272 ... F S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE="" D 273 .... S ^TMP("ORWGRPC TEMP",$J,NODE)="" 274 S NODE="" 275 F S NODE=$O(^TMP("ORWGRPC TEMP",$J,NODE)) Q:NODE="" D 276 . D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE) 277 . I 'DTONSET Q 278 . I 'DTRESOLV S DTRESOLV=DTPLUS1 279 . S RESULT=9999911_U_PROBDX_U_DTONSET_U_DTRESOLV_U_$$EXT^ORWGAPIX(PSTATUS,9000011,.12) 280 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 281 K ^TMP("ORWGRPC TEMP",$J) 282 Q 283 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIP.m
r613 r623 1 ORWGAPIP ; SLC/STAFF - Graph Parameters ;11/20/06 08:59 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242 3 ; 4 ALLVIEWS(DATA,VTYPE,USER) ; from ORWGAPI 5 N CNT,ENT,NUM,NUM1,PARAM,PROF,RESULT,TEST,TG,TGNUM,TGNAME,TMP,VIEW,VNUM K PROF,VIEW 6 D RETURN^ORWGAPIW(.TMP,.DATA) 7 S CNT=0 8 I VTYPE=-2 D 9 . S ENT="SYS" 10 . S USER=0 11 I VTYPE=-1 D 12 . S ENT="USR" 13 . I USER S ENT="USR.`"_USER 14 I VTYPE=-3 D Q 15 . ;LAB GROUPS 16 . I 'USER S USER=DUZ 17 . D TG^ORWLRR(.PROF,USER) 18 . S NUM=0 19 . F S NUM=$O(PROF(NUM)) Q:NUM<1 D 20 .. S TG=PROF(NUM) 21 .. S TGNUM=+TG 22 .. S TGNAME=$P(TG,U,2) 23 .. ;I TGNAME[") " S TGNAME=$P(TGNAME,") ",2,99) 24 .. S VNUM=CNT+1 25 .. S RESULT="-3^V^"_VNUM_U_TGNAME_"^^^"_USER 26 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 27 .. K VIEW 28 .. D ATG^ORWLRR(.VIEW,TGNUM,USER) 29 .. S NUM1=0 30 .. F S NUM1=$O(VIEW(NUM1)) Q:NUM1<1 D 31 ... S TEST=VIEW(NUM1) 32 ... S RESULT="-3^C^"_VNUM_U_$P(TEST,U,2)_"^63^"_+TEST_U 33 ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 34 D XGETLST^ORWGAPIX(.PROF,ENT,"ORWG GRAPH VIEW") 35 S NUM=0 36 F S NUM=$O(PROF(NUM)) Q:NUM<1 D 37 . S PARAM=$P(PROF(NUM),U) 38 . S VNUM=CNT+1 39 . S RESULT=VTYPE_"^V^"_VNUM_U_PARAM_"^^^"_USER 40 . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 41 . K VIEW 42 . D XGETWP^ORWGAPIX(.VIEW,ENT,"ORWG GRAPH VIEW",PARAM) 43 . D DEFVIEWS(.DATA,.VIEW,VTYPE,VNUM,TMP,.CNT) 44 Q 45 ; 46 DATES(DAT,REPORTID) ; from ORWGAPI 47 N BEGIN,END,INFO,NEXT,PARAM1,PARAM2,RPT,START,STOP 48 S RPT=+$O(^ORD(101.24,"AC",+$G(REPORTID),0)) 49 I 'RPT Q ; RPT=1150 is exported graph report 50 S PARAM1=$P($G(^ORD(101.24,RPT,2)),U) 51 S PARAM2=$P($G(^ORD(101.24,RPT,2)),U,2) 52 S INFO=$$XGET^ORWGAPIX("ALL","ORWRP TIME/OCC LIMITS INDV",RPT,"I") 53 S BEGIN=$P(INFO,";"),START=$$DATE^ORWGAPIX(BEGIN) 54 S END=$P(INFO,";",2),STOP=$$DATE^ORWGAPIX(END) 55 I START<1 Q 56 I STOP<1 Q 57 S NEXT=1+$O(DAT(""),-1) 58 S DAT(NEXT)=U_BEGIN_" to "_END_"^^^"_INFO_U_START_U_STOP_U_PARAM1_U_PARAM2 59 Q 60 ; 61 DEFVIEWS(DATA,VIEW,VTYPE,VNUM,TMP,CNT) ; 62 N FIRST,NUM,PIECE,RESULT,RESULT1,SECOND,VALUE 63 S NUM="" 64 F S NUM=$O(VIEW(NUM)) Q:NUM="" D 65 . S RESULT=$G(VIEW(NUM,0)) 66 . S PIECE=0 67 . F S PIECE=PIECE+1 S VALUE=$P(RESULT,"|",PIECE) D:$L(VALUE) Q:'$L($P(RESULT,"|",PIECE+1,999)) 68 .. S FIRST=$P(VALUE,"~"),SECOND=$P(VALUE,"~",2) 69 .. I FIRST=0 D 70 ... I $E(SECOND,1,5)="63AP;" S RESULT1=VTYPE_"^C^"_VNUM_U_"Anatomic Path: "_$$ITEMPRFX^ORWGAPIU($E(SECOND,3,6))_" <any>"_U_SECOND_"^0^" Q 71 ... I $E(SECOND,1,5)="63MI;" S RESULT1=VTYPE_"^C^"_VNUM_U_"Microbiology: "_$$ITEMPRFX^ORWGAPIU($E(SECOND,3,6))_" <any>"_U_SECOND_"^0^" Q 72 ... S RESULT1=VTYPE_"^C^"_VNUM_U_$$FILENAME^ORWGAPIT(SECOND)_" <any>"_U_SECOND_"^0^" 73 .. I FIRST'=0 S RESULT1=VTYPE_"^C^"_VNUM_U_$$EVALUE^ORWGAPIU(SECOND,FIRST)_U_FIRST_U_SECOND_U 74 .. D SETUP^ORWGAPIW(.DATA,RESULT1,TMP,.CNT) 75 Q 76 ; 77 DELVIEWS(DATA,NAME,PUBLIC) ; from ORWGAPI 78 N ERR,TMP 79 D RETURN^ORWGAPIW(.TMP,.DATA) 80 S ERR=0 81 I '$L(NAME) S ERR=1 82 I 'ERR D 83 . S NAME=$$UP^ORWGAPIX(NAME) 84 . I PUBLIC D XDEL^ORWGAPIX("SYS","ORWG GRAPH VIEW",NAME,.ERR) 85 . I 'PUBLIC D XDEL^ORWGAPIX("USR","ORWG GRAPH VIEW",NAME,.ERR) 86 I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR 87 I 'TMP S DATA=ERR,DATA(1)=ERR 88 Q 89 ; 90 GETPREF(DATA) ; from ORWGAPI 91 N CNT,NUM,PROF,RESULT,TMP,VAL K PROF 92 I '$O(^PXRMINDX(63,"PI","")) Q ; graphing is not used if no indexes 93 S VAL=$$XGET^ORWGAPIX("PKG","ORWG GRAPH SETTING",1,"I") 94 I '$L(VAL) Q ; graphing not used if no pkg param on settings 95 D RETURN^ORWGAPIW(.TMP,.DATA) 96 S PROF(2)=1 97 I '$L($G(^XTMP("ORGRAPH",0))) S PROF(2)=-1 98 S VAL=$$XGET^ORWGAPIX("DIV^SYS^PKG","ORWG GRAPH SETTING",1,"I") 99 S PROF(1)=VAL 100 S VAL=$$XGET^ORWGAPIX("ALL","ORWG GRAPH SETTING",1,"I") 101 S PROF(0)=VAL 102 S CNT=0 103 S NUM="" 104 F S NUM=$O(PROF(NUM)) Q:NUM="" D 105 . S RESULT=$G(PROF(NUM)) 106 . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 107 Q 108 ; 109 GETSIZE(DATA) ; from ORWGAPI 110 N CNT,NUM,PROF,RESULT,TMP K PROF 111 D RETURN^ORWGAPIW(.TMP,.DATA) 112 D XGETLST^ORWGAPIX(.PROF,"USR","ORWG GRAPH SIZING") 113 S CNT=0 114 S NUM="" 115 F S NUM=$O(PROF(NUM)) Q:NUM="" D 116 . S RESULT=$G(PROF(NUM)) 117 . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 118 Q 119 ; 120 ;GETVIEWS(DATA,ALL,PUBLIC,EXT,USER) ; from ORWGAPI 121 ;N CNT,NUM,PROF,RESULT,TMP,USERPRM K PROF 122 ;D RETURN^ORWGAPIW(.TMP,.DATA) 123 ;I PUBLIC D 124 ;. I ALL=1 D XGETLST^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW") ; get list of public views 125 ;. I ALL'=1 D XGETWP^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW",ALL) ; get a public view definition 126 ;I 'PUBLIC D 127 ;. S USERPRM="USR" 128 ;. I USER S USERPRM="USR.`"_USER 129 ;. I ALL=1 D XGETLST^ORWGAPIX(.PROF,USERPRM,"ORWG GRAPH VIEW") ; get list of personal views 130 ;. I ALL'=1 D XGETWP^ORWGAPIX(.PROF,USERPRM,"ORWG GRAPH VIEW",ALL) ; get a personal view definition 131 ;S CNT=0 132 ;I 'EXT D Q 133 ;. S NUM="" 134 ;. F S NUM=$O(PROF(NUM)) Q:NUM="" D 135 ;.. I ALL=1 S RESULT=$P($G(PROF(NUM)),U) 136 ;.. I ALL'=1 S RESULT=$G(PROF(NUM,0)) 137 ;.. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 138 ;D DEFVIEWS(.DATA,.PROF,"",TMP,.CNT) 139 ;Q 140 ; 141 GETVIEWS(DATA,ALL,PUBLIC,EXT,USER) ; from ORWGAPI 142 N CNT,FIRST,NUM,PIECE,PROF,RESULT,RESULT1,SECOND,TMP,VALUE K PROF 143 D RETURN^ORWGAPIW(.TMP,.DATA) 144 I PUBLIC D 145 . I ALL=1 D XGETLST^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW") ; get list of public views 146 . I ALL'=1 D XGETWP^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW",ALL) ; get a public view definition 147 I 'PUBLIC D 148 . S USERPRM="USR" 149 . I USER S USERPRM="USR.`"_USER 150 . I ALL=1 D XGETLST^ORWGAPIX(.PROF,USERPRM,"ORWG GRAPH VIEW") ; get list of personal views 151 . I ALL'=1 D XGETWP^ORWGAPIX(.PROF,USERPRM,"ORWG GRAPH VIEW",ALL) ; get a personal view definition 152 S CNT=0 153 I 'EXT D Q 154 . S NUM="" 155 . F S NUM=$O(PROF(NUM)) Q:NUM="" D 156 .. I ALL=1 S RESULT=$P($G(PROF(NUM)),U) 157 .. I ALL'=1 S RESULT=$G(PROF(NUM,0)) 158 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 159 S NUM="" 160 F S NUM=$O(PROF(NUM)) Q:NUM="" D 161 . S RESULT=$G(PROF(NUM,0)) 162 . S PIECE=0 163 . F S PIECE=PIECE+1 S VALUE=$P(RESULT,"|",PIECE) D:$L(VALUE) Q:'$L($P(RESULT,"|",PIECE+1,999)) 164 .. S FIRST=$P(VALUE,"~"),SECOND=$P(VALUE,"~",2) 165 .. I FIRST=0 S CNT=CNT+1,RESULT1="0^"_SECOND_U_$$FILENAME^ORWGAPIT(SECOND)_" <any>" 166 .. I FIRST'=0 S CNT=CNT+1,RESULT1=FIRST_U_SECOND_U_$$EVALUE^ORWGAPIU(SECOND,FIRST) 167 .. D SETUP^ORWGAPIW(.DATA,RESULT1,TMP,.CNT) 168 Q 169 ; 170 INISET ; from ORWGAPIU initial setup of package parameters 171 N ERR,RPTNUM 172 S RPTNUM=1150 173 D SETPREF(.ERR,"63;53.79;55;55NVA;52;70;120.5|BCEFGHIKN|1|4|90|1|100||",9) ; default public settings 174 I '$D(^ORD(101.24,RPTNUM,0)) D ; make sure report has been added 175 . L +^ORD(101.24,0):20 I '$T Q 176 . S $P(^ORD(101.24,0),U,3)=RPTNUM,$P(^(0),U,4)=$P(^(0),U,4)+1 177 . S ^ORD(101.24,RPTNUM,0)="ORWG GRAPHING^OR_GRAPHS^^2^^^1^R^^^^G^^T" 178 . S ^ORD(101.24,RPTNUM,2)="^^Graphing (local only)^Graphing" 179 . L -^ORD(101.24,0) 180 . D INDEX^ORWGAPIX("^ORD(101.24,",RPTNUM) 181 D XEN^ORWGAPIX("PKG","ORWRP REPORT LIST",12,RPTNUM) 182 Q 183 ; 184 PUBLIC(USER) ; from ORWGAPI 185 N ERR,IDX,ORSRV,USRCLASS,VAL K USRCLASS 186 S VAL=0 187 I '$G(USER) Q VAL 188 S ORSRV=$$GET1^DIQ(200,DUZ,29,"I") 189 D XGETLST1^ORWGAPIX(.USRCLASS,"SYS","ORWG GRAPH PUBLIC EDITOR CLASS","Q",.ERR) 190 I ERR Q VAL 191 S IDX=0 192 F S IDX=$O(USRCLASS(IDX)) Q:'IDX D Q:VAL 193 . I $$ISA^ORWGAPIA(USER,$P(USRCLASS(IDX),U,2),.ERR) S VAL=1 194 Q VAL 195 ; 196 RPTPARAM(IEN) ; from ORWGAPI 197 N DATES,NODE,VAL 198 S IEN=+$G(IEN) 199 S VAL="" 200 S NODE=$$UP^XLFSTR($P($G(^ORD(101.24,IEN,2)),U,1,2)) 201 I $L(NODE)<2 Q VAL 202 Q NODE 203 ; 204 SETPREF(DATA,VAL,PUBLIC) ; from ORWGAPI 205 N ERR,TMP 206 D RETURN^ORWGAPIW(.TMP,.DATA) 207 S ERR=0 208 I '$L(VAL) S ERR=1 209 I 'ERR D 210 . S VAL=$$UP^ORWGAPIX(VAL) 211 . I PUBLIC=9 D XEN^ORWGAPIX("PKG","ORWG GRAPH SETTING",1,VAL,.ERR) ; only on postinit 212 . I PUBLIC D XEN^ORWGAPIX("SYS","ORWG GRAPH SETTING",1,VAL,.ERR) 213 . I 'PUBLIC D XEN^ORWGAPIX("USR","ORWG GRAPH SETTING",1,VAL,.ERR) 214 I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR 215 I 'TMP S DATA=ERR,DATA(1)=ERR 216 Q 217 ; 218 SETSIZE(DATA,VAL) ; from ORWGAPI 219 N ERR,NAME,NUM,VALUE,VALUES,TMP 220 D RETURN^ORWGAPIW(.TMP,.DATA) 221 S ERR=0 222 I '$L($O(VAL(0))) S ERR=1 223 I 'ERR D 224 . S NUM=0 225 . F S NUM=$O(VAL(NUM)) Q:NUM<1 D Q:ERR 226 .. S VALUES=VAL(NUM) 227 .. S VALUES=$$UP^ORWGAPIX(VALUES) 228 .. S NAME=$P(VALUES,U) 229 .. S VALUE=$P(VALUES,U,2) 230 .. D XEN^ORWGAPIX("USR","ORWG GRAPH SIZING",NAME,VALUE,.ERR) 231 I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR 232 I 'TMP S DATA=ERR,DATA(1)=ERR 233 Q 234 ; 235 SETVIEWS(DATA,NAME,PUBLIC,VAL) ; from ORWGAPI 236 N ERR,TMP 237 D RETURN^ORWGAPIW(.TMP,.DATA) 238 S ERR=0 239 I '$L(NAME) S ERR=1 240 I '$L($O(VAL(""))) S ERR=1 241 I 'ERR D 242 . S NAME=$$UP^ORWGAPIX(NAME) 243 . S VAL=NAME 244 . I PUBLIC D XEN^ORWGAPIX("SYS","ORWG GRAPH VIEW",NAME,.VAL,.ERR) 245 . I 'PUBLIC D XEN^ORWGAPIX("USR","ORWG GRAPH VIEW",NAME,.VAL,.ERR) 246 I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR 247 I 'TMP S DATA=ERR,DATA(1)=ERR 248 Q 249 ; 1 ORWGAPIP ; SLC/STAFF - Graph Parameters ;11/20/06 08:59 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26 3 ; 4 DATES(DAT,REPORTID) ; from ORWGAPI 5 N BEGIN,END,INFO,NEXT,PARAM1,PARAM2,RPT,START,STOP 6 S RPT=+$O(^ORD(101.24,"AC",+$G(REPORTID),0)) 7 I 'RPT Q ; RPT=1150 is exported graph report 8 S PARAM1=$P($G(^ORD(101.24,RPT,2)),U) 9 S PARAM2=$P($G(^ORD(101.24,RPT,2)),U,2) 10 S INFO=$$XGET^ORWGAPIX("ALL","ORWRP TIME/OCC LIMITS INDV",RPT,"I") 11 S BEGIN=$P(INFO,";"),START=$$DATE^ORWGAPIX(BEGIN) 12 S END=$P(INFO,";",2),STOP=$$DATE^ORWGAPIX(END) 13 I START<1 Q 14 I STOP<1 Q 15 S NEXT=1+$O(DAT(""),-1) 16 S DAT(NEXT)=U_BEGIN_" to "_END_"^^^"_INFO_U_START_U_STOP_U_PARAM1_U_PARAM2 17 Q 18 ; 19 DELVIEWS(DATA,NAME,PUBLIC) ; from ORWGAPI 20 N ERR,TMP 21 D RETURN^ORWGAPIU(.TMP,.DATA) 22 S ERR=0 23 I '$L(NAME) S ERR=1 24 I 'ERR D 25 . S NAME=$$UP^ORWGAPIX(NAME) 26 . I PUBLIC D XDEL^ORWGAPIX("SYS","ORWG GRAPH VIEW",NAME,.ERR) 27 . I 'PUBLIC D XDEL^ORWGAPIX("USR","ORWG GRAPH VIEW",NAME,.ERR) 28 I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR 29 I 'TMP S DATA=ERR,DATA(1)=ERR 30 Q 31 ; 32 GETPREF(DATA) ; from ORWGAPI 33 N CNT,NUM,PROF,RESULT,TMP,VAL K PROF 34 I '$O(^PXRMINDX(63,"PI","")) Q ; graphing is not used if no indexes 35 S VAL=$$XGET^ORWGAPIX("PKG","ORWG GRAPH SETTING",1,"I") 36 I '$L(VAL) Q ; graphing not used if no pkg param on settings 37 D RETURN^ORWGAPIU(.TMP,.DATA) 38 S VAL=$$XGET^ORWGAPIX("DIV^SYS^PKG","ORWG GRAPH SETTING",1,"I") 39 S PROF(1)=VAL 40 S VAL=$$XGET^ORWGAPIX("ALL","ORWG GRAPH SETTING",1,"I") 41 S PROF(0)=VAL 42 S CNT=0 43 S NUM="" 44 F S NUM=$O(PROF(NUM)) Q:NUM="" D 45 . S RESULT=$G(PROF(NUM)) 46 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 47 Q 48 ; 49 GETSIZE(DATA) ; from ORWGAPI 50 N CNT,NUM,PROF,RESULT,TMP K PROF 51 D RETURN^ORWGAPIU(.TMP,.DATA) 52 D XGETLST^ORWGAPIX(.PROF,"USR","ORWG GRAPH SIZING") 53 S CNT=0 54 S NUM="" 55 F S NUM=$O(PROF(NUM)) Q:NUM="" D 56 . S RESULT=$G(PROF(NUM)) 57 . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 58 Q 59 ; 60 GETVIEWS(DATA,ALL,PUBLIC,EXT) ; from ORWGAPI 61 N CNT,FIRST,NUM,PIECE,PROF,RESULT,RESULT1,SECOND,TMP,VALUE K PROF 62 D RETURN^ORWGAPIU(.TMP,.DATA) 63 I PUBLIC D 64 . I ALL=1 D XGETLST^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW") ; get list of public views 65 . I ALL'=1 D XGETWP^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW",ALL) ; get a public view definition 66 I 'PUBLIC D 67 . I ALL=1 D XGETLST^ORWGAPIX(.PROF,"USR","ORWG GRAPH VIEW") ; get list of personal views 68 . I ALL'=1 D XGETWP^ORWGAPIX(.PROF,"USR","ORWG GRAPH VIEW",ALL) ; get a personal view definition 69 S CNT=0 70 I 'EXT D Q 71 . S NUM="" 72 . F S NUM=$O(PROF(NUM)) Q:NUM="" D 73 .. I ALL=1 S RESULT=$P($G(PROF(NUM)),U) 74 .. I ALL'=1 S RESULT=$G(PROF(NUM,0)) 75 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 76 S NUM="" 77 F S NUM=$O(PROF(NUM)) Q:NUM="" D 78 . S RESULT=$G(PROF(NUM,0)) 79 . S PIECE=0 80 . F S PIECE=PIECE+1 S VALUE=$P(RESULT,"|",PIECE) D:$L(VALUE) Q:'$L($P(RESULT,"|",PIECE+1,999)) 81 .. S FIRST=$P(VALUE,"~"),SECOND=$P(VALUE,"~",2) 82 .. I FIRST=0 S CNT=CNT+1,RESULT1="0^"_SECOND_U_$$FILENAME^ORWGAPIT(SECOND)_" <any>" 83 .. I FIRST'=0 S CNT=CNT+1,RESULT1=FIRST_U_SECOND_U_$$EVALUE^ORWGAPIU(SECOND,FIRST) 84 .. D SETUP^ORWGAPIU(.DATA,RESULT1,TMP,.CNT) 85 Q 86 ; 87 INISET ; from ORWGAPIU initial setup of package parameters 88 N ERR,RPTNUM 89 S RPTNUM=1150 90 D SETPREF(.ERR,"63;53.79;55;55NVA;52;70;120.5|BCEFGHIK|1|4|90||100||",9) ; default public settings 91 I '$D(^ORD(101.24,RPTNUM,0)) D ; make sure report has been added 92 . L +^ORD(101.24,0):20 I '$T Q 93 . S $P(^ORD(101.24,0),U,3)=RPTNUM,$P(^(0),U,4)=$P(^(0),U,4)+1 94 . S ^ORD(101.24,RPTNUM,0)="ORWG GRAPHING^OR_GRAPHS^^2^^^1^R^^^^G^^T" 95 . S ^ORD(101.24,RPTNUM,2)="^^Graphing (local only)^Graphing" 96 . L -^ORD(101.24,0) 97 . D INDEX^ORWGAPIX("^ORD(101.24,",RPTNUM) 98 D XEN^ORWGAPIX("PKG","ORWRP REPORT LIST",12,RPTNUM) 99 D XVIEWS ; ***** 100 Q 101 ; 102 PUBLIC(USER) ; from ORWGAPI 103 N ERR,IDX,ORSRV,USRCLASS,VAL K USRCLASS 104 S VAL=0 105 I '$G(USER) Q VAL 106 S ORSRV=$$GET1^DIQ(200,DUZ,29,"I") 107 D XGETLST1^ORWGAPIX(.USRCLASS,"SYS","ORWG GRAPH PUBLIC EDITOR CLASS","Q",.ERR) 108 I ERR Q VAL 109 S IDX=0 110 F S IDX=$O(USRCLASS(IDX)) Q:'IDX D Q:VAL 111 . I $$ISA^ORWGAPIA(USER,$P(USRCLASS(IDX),U,2),.ERR) S VAL=1 112 Q VAL 113 ; 114 RPTPARAM(IEN) ; from ORWGAPI 115 N NODE,VAL 116 S VAL="" 117 S NODE=$$UP^XLFSTR($P($G(^ORD(101.24,+$G(IEN),2)),U,1,2)) 118 I $L(NODE)<2 Q VAL 119 Q NODE 120 ; 121 SETPREF(DATA,VAL,PUBLIC) ; from ORWGAPI 122 N ERR,TMP 123 D RETURN^ORWGAPIU(.TMP,.DATA) 124 S ERR=0 125 I '$L(VAL) S ERR=1 126 I 'ERR D 127 . S VAL=$$UP^ORWGAPIX(VAL) 128 . I PUBLIC=9 D XEN^ORWGAPIX("PKG","ORWG GRAPH SETTING",1,VAL,.ERR) ; only on postinit 129 . I PUBLIC D XEN^ORWGAPIX("SYS","ORWG GRAPH SETTING",1,VAL,.ERR) 130 . I 'PUBLIC D XEN^ORWGAPIX("USR","ORWG GRAPH SETTING",1,VAL,.ERR) 131 I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR 132 I 'TMP S DATA=ERR,DATA(1)=ERR 133 Q 134 ; 135 SETSIZE(DATA,VAL) ; from ORWGAPI 136 N ERR,NAME,NUM,VALUE,VALUES,TMP 137 D RETURN^ORWGAPIU(.TMP,.DATA) 138 S ERR=0 139 I '$L($O(VAL(0))) S ERR=1 140 I 'ERR D 141 . S NUM=0 142 . F S NUM=$O(VAL(NUM)) Q:NUM<1 D Q:ERR 143 .. S VALUES=VAL(NUM) 144 .. S VALUES=$$UP^ORWGAPIX(VALUES) 145 .. S NAME=$P(VALUES,U) 146 .. S VALUE=$P(VALUES,U,2) 147 .. D XEN^ORWGAPIX("USR","ORWG GRAPH SIZING",NAME,VALUE,.ERR) 148 I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR 149 I 'TMP S DATA=ERR,DATA(1)=ERR 150 Q 151 ; 152 SETVIEWS(DATA,NAME,PUBLIC,VAL) ; from ORWGAPI 153 N ERR,TMP 154 D RETURN^ORWGAPIU(.TMP,.DATA) 155 S ERR=0 156 I '$L(NAME) S ERR=1 157 I '$L($O(VAL(""))) S ERR=1 158 I 'ERR D 159 . S NAME=$$UP^ORWGAPIX(NAME) 160 . S VAL=NAME 161 . I PUBLIC D XEN^ORWGAPIX("SYS","ORWG GRAPH VIEW",NAME,.VAL,.ERR) 162 . I 'PUBLIC D XEN^ORWGAPIX("USR","ORWG GRAPH VIEW",NAME,.VAL,.ERR) 163 I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR 164 I 'TMP S DATA=ERR,DATA(1)=ERR 165 Q 166 ; 167 XVIEWS ; conversion on v26t41 ***** 168 N CNT,DATA,ERR,NAME,NUM,NUM1,SYSNAME,VIEWS,VIEWDEF,VIEWDIV 169 K DATA,SYSNAME,VIEWS,VIEWDEF,VIEWDIV 170 D XGETLST^ORWGAPIX(.VIEWS,"SYS","ORWG GRAPH VIEW") 171 S NUM=0 172 F S NUM=$O(VIEWS(NUM)) Q:NUM<1 D 173 . S NAME=$P(VIEWS(NUM),U) 174 . I NAME="" Q 175 . S SYSNAME(NAME)="" 176 K VIEWS 177 D XGETLST^ORWGAPIX(.VIEWS,"DIV","ORWG GRAPH VIEW") 178 S NUM=0 179 F S NUM=$O(VIEWS(NUM)) Q:NUM<1 D 180 . S NAME=$P(VIEWS(NUM),U) 181 . I NAME="" Q 182 . I '$D(SYSNAME(NAME)) D 183 .. K VIEWDEF,VIEWDIV 184 .. D XGETWP^ORWGAPIX(.VIEWDIV,"DIV","ORWG GRAPH VIEW",NAME) 185 .. S CNT=0 186 .. S NUM1="" 187 .. F S NUM1=$O(VIEWDIV(NUM1)) Q:NUM1="" D 188 ... S CNT=CNT+1 189 ... S VIEWDEF(CNT)=$G(VIEWDIV(NUM1,0)) 190 .. D SETVIEWS^ORWGAPIP(.DATA,NAME,1,.VIEWDEF) 191 . D XDEL^ORWGAPIX("DIV","ORWG GRAPH VIEW",NAME,.ERR) 192 Q 193 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIR.m
r613 r623 1 ORWGAPIR ; SLC/STAFF - Graph API Router ;8/21/06 07:52 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242 3 ; 4 DATA(DATA,ITEM,FILE,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPI 5 S DFN=+$G(DFN) I 'DFN Q 6 S FILE=$G(FILE) I '$L(FILE) Q 7 S ITEM=$G(ITEM) I '$L(ITEM) Q 8 S BACKTO=+$G(BACKTO) 9 I FILE=52 D OUTRX^ORWGAPI7(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 10 I FILE=53.79 D BCMA^ORWGAPI7(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 11 I FILE=55 D INRX^ORWGAPI7(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 12 I FILE="55NVA" D NVA^ORWGAPI7(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 13 I FILE=63 D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 14 I FILE="63AP" D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 15 ;I FILE="63BB" D BBDATA^ORWGAPIB(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 16 I FILE="63MI" D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 17 I FILE=70 D RAD^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 18 I FILE=100 D ORDER^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 19 I FILE=120.5 D VITAL^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 20 I FILE=120.8 D ADVERSE^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 21 I FILE=601.2 D MH^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 22 I FILE=9000010.07 D POV^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 23 I FILE=9000010.11 D IMM^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 24 I FILE=9000010.12 D SKIN^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 25 I FILE=9000010.13 D EXAM^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 26 I FILE=9000010.16 D EDU^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 27 I FILE=9000010.18 D PROC^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 28 I FILE=9000010.23 D HF^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 29 I FILE=9000011 D PROB^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 30 I FILE=9999911 D PROBX^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 31 I FILE="45OP" D OP^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 32 I FILE="45DX" D DX^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 33 I FILE=9000010 D VISIT^ORWGAPI8(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 34 I FILE=405 D ADMIT^ORWGAPI8(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 35 I FILE=130 D SURG^ORWGAPI8(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 36 I FILE=8925 D NOTE^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 37 I FILE=690 D MED^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q 38 Q 39 ; 40 ITEMS(ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPI 41 S FMT=$G(FMT,3),OLDEST=+$G(OLDEST),NEWEST=+$G(NEWEST),CNT=+$G(CNT) 42 I (TYPE=70)!(TYPE=100)!(TYPE=120.5)!(TYPE=601.2) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q 43 I (TYPE=9000010.11)!(TYPE=9000010.12)!(TYPE=9000010.13) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q 44 I (TYPE=9000010.16)!(TYPE=9000010.23) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q 45 I (TYPE=9000010.07)!(TYPE=9000010.18) D STD1(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q 46 I (TYPE=52)!(TYPE=55) D STD2(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q 47 I TYPE=63 D LAB^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 48 I TYPE=9000010 D VISITS^ORWGAPI6(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 49 I TYPE=9000011 D PL^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 50 I TYPE=9999911 D PLX^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 51 I TYPE=405 D ADMITS^ORWGAPI6(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 52 I TYPE=50.605 D DC^ORWGAPI5(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 53 I TYPE=68 D AA^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 54 I TYPE=8925.1 D TITLE^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 55 I TYPE=53.79 D BCMA^ORWGAPI5(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 56 I TYPE=120.8 D ADVERSE^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 57 I TYPE=130 D SURGERY^ORWGAPI6(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 58 I TYPE=8925 D NOTES^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 59 I TYPE=690 D MED^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 60 S TYPE=$$UP^ORWGAPIX(TYPE) 61 I $E(TYPE,1,2)=45 D REG^ORWGAPI2(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q 62 I TYPE="55NVA" D NVA^ORWGAPI5(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 63 I TYPE="63AP" D AP^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 64 I TYPE="63BB" D BBITEM^ORWGAPIB(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 65 I TYPE="63MI" D MI^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 66 Q 67 ; 68 STD(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; 69 N DATE,ITEM,OK,RESULT 70 S ITEM="" 71 F S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM="" D 72 . S OK=0 73 . I FMT=6 D 74 .. S DATE=OLDEST 75 .. F S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 76 ... S CNT=CNT+1 77 ... S OK=1 78 ... S RESULT=FILE_U_ITEM 79 . I FMT=3 D 80 .. S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,""),-1) 81 .. I 'DATE Q 82 .. S CNT=CNT+1 83 .. S OK=1 84 .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE 85 .. I FILE=100 S RESULT=RESULT_U_$$OGROUP^ORWGAPIW(ITEM) 86 . I FMT=0 D 87 .. S CNT=CNT+1 88 .. S OK=1 89 .. S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01) 90 . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 91 I FILE=120.5 D BMIITEMS^ORWGAPIX(.ITEMS,.CNT,TMP) Q 92 Q 93 ; 94 STD1(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; 95 N DATE,ITEM,OK,RESULT,TYPE 96 K ^TMP("ORWGRPC TEMP",$J) 97 S TYPE="" 98 F S TYPE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE)) Q:TYPE="" D 99 . S ITEM="" 100 . F S ITEM=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM)) Q:ITEM="" D 101 .. S OK=0 102 .. I FMT=6 D 103 ... S DATE=OLDEST 104 ... F S DATE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 105 .... S CNT=CNT+1 106 .... S OK=1 107 .... S RESULT=FILE_U_ITEM 108 .. I FMT=3 D 109 ... S DATE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM,""),-1) 110 ... I DATE S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)="" 111 .. I FMT=0 D 112 ... S CNT=CNT+1 113 ... S OK=1 114 ... S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01) 115 .. I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 116 I FMT=3 D 117 . S ITEM="" 118 . F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM="" D 119 .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,""),-1) 120 .. I 'DATE Q 121 .. S CNT=CNT+1 122 .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE 123 .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 124 K ^TMP("ORWGRPC TEMP",$J) 125 Q 126 ; 127 STD2(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; 128 N DATE,DATE2,ITEM,OK,RESULT 129 S ITEM="" 130 F S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM="" D 131 . S OK=0 132 . I FMT=6 D 133 .. S DATE=0 134 .. F S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 135 ... S DATE2="" 136 ... F S DATE2=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2="" D 137 .... I DATE2<OLDEST Q 138 .... S CNT=CNT+1 139 .... S OK=1 140 .... S RESULT=FILE_U_ITEM 141 . I FMT=3 D 142 .. S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,""),-1) 143 .. I 'DATE Q 144 .. S CNT=CNT+1 145 .. S OK=1 146 .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE 147 .. S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIC(ITEM) 148 . I FMT=0 D 149 .. S CNT=CNT+1 150 .. S OK=1 151 .. S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01) 152 .. S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIC(ITEM) 153 . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 154 Q 155 ; 1 ORWGAPIR ; SLC/STAFF - Graph API Router ;8/21/06 07:52 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26 3 ; 4 DATA(DATA,ITEM,FILE,START,DFN,CNT,TMP) ; from ORWGAPI 5 S DFN=+$G(DFN) I 'DFN Q 6 S FILE=$G(FILE) I '$L(FILE) Q 7 S ITEM=$G(ITEM) I '$L(ITEM) Q 8 I FILE=52 D OUTRX^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 9 I FILE=53.79 D BCMA^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 10 I FILE=55 D INRX^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 11 I FILE="55NVAE" D NVAE^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 12 I FILE="55NVA" D NVA^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 13 I FILE=63 D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 14 I FILE="63AP" D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 15 I FILE="63BB" D BBDATA^ORWGAPIB(.DATA,ITEM,START,DFN,.CNT,TMP) Q 16 I FILE="63MI" D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 17 I FILE=70 D RAD^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 18 I FILE=100 D ORDER^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 19 I FILE=120.5 D VITAL^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 20 I FILE=120.8 D ADVERSE^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 21 I FILE=601.2 D MH^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 22 I FILE=9000010.07 D POV^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 23 I FILE=9000010.11 D IMM^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 24 I FILE=9000010.12 D SKIN^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 25 I FILE=9000010.13 D EXAM^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 26 I FILE=9000010.16 D EDU^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 27 I FILE=9000010.18 D PROC^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 28 I FILE=9000010.23 D HF^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 29 I FILE=9000011 D PROB^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 30 I FILE=9999911 D PROBX^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 31 I FILE="45OP" D OP^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 32 I FILE="45DX" D DX^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 33 I FILE=9000010 D VISIT^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 34 I FILE=405 D ADMIT^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 35 I FILE=130 D SURG^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 36 I FILE=8925 D NOTE^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 37 I FILE=9000010.15 D TREAT^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP) Q 38 I FILE=690 D MED^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP) Q 39 Q 40 ; 41 ITEMS(ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPI 42 S FMT=$G(FMT,3),OLDEST=+$G(OLDEST),NEWEST=+$G(NEWEST),CNT=+$G(CNT) 43 I (TYPE=70)!(TYPE=100)!(TYPE=120.5)!(TYPE=601.2) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q 44 I (TYPE=9000010.11)!(TYPE=9000010.12)!(TYPE=9000010.13) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q 45 I (TYPE=9000010.15)!(TYPE=9000010.16)!(TYPE=9000010.23) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q 46 I (TYPE=9000010.07)!(TYPE=9000010.18) D STD1(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q 47 I (TYPE=52)!(TYPE=55) D STD2(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q 48 I TYPE=63 D LAB^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 49 I TYPE=9000010 D VISITS^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 50 I TYPE=9000010.15 D TREAT^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 51 I TYPE=9000011 D PL^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 52 I TYPE=9999911 D PLX^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 53 I TYPE=405 D ADMITS^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 54 I TYPE=50.605 D DC^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 55 I TYPE=68 D AA^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 56 I TYPE=8925.1 D TITLE^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 57 I TYPE=53.79 D BCMA^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 58 I TYPE=120.8 D ADVERSE^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 59 I TYPE=130 D SURGERY^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 60 I TYPE=8925 D NOTES^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 61 I TYPE=690 D MED^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 62 S TYPE=$$UP^ORWGAPIX(TYPE) 63 I $E(TYPE,1,2)=45 D REG^ORWGAPI2(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q 64 I TYPE="55NVAE" D NVAE^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 65 I TYPE="55NVA" D NVA^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 66 I TYPE="63AP" D AP^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 67 I TYPE="63BB" D BBITEM^ORWGAPIB(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 68 I TYPE="63MI" D MI^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q 69 Q 70 ; 71 STD(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; 72 N DATE,ITEM,OK,RESULT 73 S ITEM="" 74 F S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM="" D 75 . S OK=0 76 . I FMT=6 D 77 .. S DATE=OLDEST 78 .. F S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 79 ... S CNT=CNT+1 80 ... S OK=1 81 ... S RESULT=FILE_U_ITEM 82 . I FMT=3 D 83 .. S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,""),-1) 84 .. I 'DATE Q 85 .. S CNT=CNT+1 86 .. S OK=1 87 .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE 88 .. I FILE=100 S RESULT=RESULT_U_$$OGROUP^ORWGAPIU(ITEM) 89 . I FMT=0 D 90 .. S CNT=CNT+1 91 .. S OK=1 92 .. S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01) 93 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 94 I FILE=120.5 D BMIITEMS^ORWGAPIX(.ITEMS,.CNT,TMP) Q 95 Q 96 ; 97 STD1(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; 98 N DATE,ITEM,OK,RESULT,TYPE 99 K ^TMP("ORWGRPC TEMP",$J) 100 S TYPE="" 101 F S TYPE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE)) Q:TYPE="" D 102 . S ITEM="" 103 . F S ITEM=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM)) Q:ITEM="" D 104 .. S OK=0 105 .. I FMT=6 D 106 ... S DATE=OLDEST 107 ... F S DATE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 108 .... S CNT=CNT+1 109 .... S OK=1 110 .... S RESULT=FILE_U_ITEM 111 .. I FMT=3 D 112 ... S DATE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM,""),-1) 113 ... I DATE S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)="" 114 .. I FMT=0 D 115 ... S CNT=CNT+1 116 ... S OK=1 117 ... S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01) 118 .. I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 119 I FMT=3 D 120 . S ITEM="" 121 . F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM="" D 122 .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,""),-1) 123 .. I 'DATE Q 124 .. S CNT=CNT+1 125 .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE 126 .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 127 K ^TMP("ORWGRPC TEMP",$J) 128 Q 129 ; 130 STD2(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; 131 N DATE,DATE2,ITEM,OK,RESULT 132 S ITEM="" 133 F S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM="" D 134 . S OK=0 135 . I FMT=6 D 136 .. S DATE=0 137 .. F S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK 138 ... S DATE2="" 139 ... F S DATE2=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2="" D 140 .... I DATE2<OLDEST Q 141 .... S CNT=CNT+1 142 .... S OK=1 143 .... S RESULT=FILE_U_ITEM 144 . I FMT=3 D 145 .. S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,""),-1) 146 .. I 'DATE Q 147 .. S CNT=CNT+1 148 .. S OK=1 149 .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE 150 .. S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIA(ITEM) 151 . I FMT=0 D 152 .. S CNT=CNT+1 153 .. S OK=1 154 .. S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01) 155 .. S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIA(ITEM) 156 . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 157 Q 158 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIT.m
r613 r623 1 ORWGAPIT ; SLC/STAFF - Graph Item Types ;11/20/06 08:58 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242 3 ; 4 COMPTYPE(FILE) ; $$(file) -> hs component abbrv - from ORWGAPID 5 N COMP,COMPNAME,COMPS,NUM,OK K COMPS 6 S COMPNAME=$$COMPNAME(FILE)_"]" 7 D COMP^ORWRP2(.COMPS) 8 S COMP="" 9 S OK=0 10 S NUM=0 11 D 12 . F S NUM=$O(COMPS(NUM)) Q:NUM<1 D I OK Q 13 .. S COMP=COMPS(NUM) 14 .. I COMP[COMPNAME,COMPNAME=$P($P(COMP,U,2),"[",2) S OK=1 15 Q COMP 16 ; 17 COMPNAME(FILE) ; $$(file) -> hs component abbrv 18 I FILE=63 Q "CH" 19 I FILE=120.5 Q "VSD" 20 I FILE=120.8 Q "ADR" 21 I FILE=52 Q "RXOP" 22 I FILE=55 Q "RXUD" 23 I FILE=70 Q "II" 24 I FILE=9000010.11 Q "IM" 25 I FILE=9000010.12 Q "ST" 26 I FILE=9000010.13 Q "EXAM" 27 I FILE=9000010.18 Q "CPT" 28 I FILE=9000011 Q "PLL" 29 I FILE=9999911 Q "PLL" 30 I FILE=9000010.23 Q "HF" 31 I FILE=9000010.07 Q "OD" 32 I FILE=9000010.16 Q "ED" 33 I FILE=601.2 Q "MHPE" 34 I FILE=100 Q "ORC" 35 I FILE="45OP" Q "PRC" 36 I FILE="45DX" Q "DD" 37 I FILE="63AP" Q "SP" 38 I FILE="63BB" Q "BT" 39 I FILE="63MI" Q "MIC" 40 I FILE=9000010 Q "CVP" 41 I FILE=405 Q "ADC" 42 I FILE="55NVA" Q "RXNV" 43 I FILE=53.79 Q "BCMA" 44 I FILE=130 Q "SR" 45 I FILE=8925 Q "CNB" 46 I FILE=690 Q "MEDF" 47 Q "" 48 ; 49 FILENAME(FILE) ; $$(file) -> filename - from ORWGAPIP 50 I FILE=63 Q "LAB TESTS" 51 I FILE=120.5 Q "VITALS" 52 I FILE=120.8 Q "ALLERGIES" 53 I FILE=52 Q "MEDICATION,OUTPATIENT" 54 I FILE=55 Q "MEDICATION,INPATIENT" 55 I FILE=70 Q "RADIOLOGY EXAMS" 56 I FILE=9000010.11 Q "IMMUNIZATIONS" 57 I FILE=9000010.12 Q "SKIN TESTS" 58 I FILE=9000010.13 Q "EXAMS" 59 I FILE=9000010.18 Q "PROCEDURES" 60 I FILE=9000011 Q "PROBLEMS" 61 I FILE=9999911 Q "PROBLEMS-DURATION" ;************** 62 I FILE=9000010.23 Q "HEALTH FACTORS" 63 I FILE=9000010.07 Q "PURPOSE OF VISIT" 64 I FILE=9000010.16 Q "PATIENT EDUCATION" 65 I FILE=601.2 Q "MENTAL HEALTH" 66 I FILE=100 Q "ORDERS" 67 I FILE="45OP" Q "REGISTRATION OP/PROC" 68 I FILE="45DX" Q "REGISTRATION DX" 69 I FILE="63AP" Q "ANATOMIC PATHOLOGY" 70 I FILE="63BB" Q "BLOOD PRODUCTS" 71 I FILE="63MI" Q "MICROBIOLOGY" 72 I FILE=9000010 Q "VISITS" 73 I FILE=405 Q "ADMISSIONS" 74 I FILE="55NVA" Q "MEDICATION,NON-VA" 75 I FILE=53.79 Q "MEDICATION,BCMA" 76 I FILE=50.605 Q "DRUG CLASS" 77 I FILE=68 Q "LAB ACC AREA" 78 I FILE=8925.1 Q "NOTE TITLE" 79 I FILE=100.98 Q "ORDER DISPLAY GROUP" 80 I FILE=811.2 Q "REMINDER TAXONOMY" 81 I FILE=130 Q "SURGERY" 82 I FILE=8925 Q "NOTES" 83 I FILE=690 Q "MEDICINE" 84 Q "" 85 ; 86 FILECHK(FILES) ; 87 ; get parameter string of excluded files 88 N CHECK,NUM,ORSRV,VAL 89 S ORSRV=$$GET1^DIQ(200,DUZ,29,"I") 90 S CHECK=$$XGET^ORWGAPIX("USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORWG GRAPH EXCLUDE DATA TYPE",1,"I") 91 S CHECK=CHECK_";" 92 S NUM=0 93 F S NUM=$O(FILES(NUM)) Q:NUM<1 D 94 . S VAL=FILES(NUM) 95 . S VAL=$P(VAL,U)_";" 96 . I CHECK[VAL K FILES(NUM) 97 Q 98 ; 99 GETFILES(FILES) ; 100 ; file #^file name^graph type^lookup file^lookup global^lookup index^prefix^abbrev^hint format 101 ; commenting out a line setting FILES will inactivate that type 102 S FILES(1)="63^LAB TESTS^1^60^LAB(60,^B^^CH^~ ~units~flag~|" 103 S FILES(2)="120.5^VITALS^1^120.51^GMRD(120.51,^B^^VSD^~ ~" 104 S FILES(3)="52^MEDICATION,OUTPATIENT^3^50^PSDRUG(^B^^RXOP^~ ~" 105 S FILES(4)="55^MEDICATION,INPATIENT^3^50^PSDRUG(^B^^RXUD^~ ~" 106 S FILES(5)="70^RADIOLOGY EXAMS^2^71^RAMIS(71,^B^rad^II^~ ~" 107 S FILES(6)="9000010.11^IMMUNIZATIONS^2^9999999.14^AUTTIMM(^B^imm^IM^~ ~" 108 S FILES(7)="9000010.12^SKIN TESTS^2^9999999.28^AUTTSK(^B^skin^ST^~ ~" 109 S FILES(8)="9000010.13^EXAMS^2^9999999.15,^AUTTEXAM(^B^exam^EXAM^~ ~" 110 S FILES(9)="9000010.18^PROCEDURES^2^81^ICPT(^C^proc^CPT^~ ~" 111 S FILES(10)="9000011^PROBLEMS^2^80^ICD9(^B^prob^PLL^~ ~" ;*** 112 S FILES(11)="9000010.23^HEALTH FACTORS^2^9999999.64^AUTTHF(,^B^hf^HF^~ ~" 113 S FILES(12)="9000010.07^PURPOSE OF VISIT^2^80^ICD9(^B^pov^OD^" 114 S FILES(13)="9000010.16^PATIENT EDUCATION^2^9999999.09^AUTTEDT(^B^edu^ED^~ ~" 115 S FILES(14)="601.2^MENTAL HEALTH^2^601^YTT(601,^B^mh^MHPE^~ ~" 116 S FILES(15)="100^ORDERS^2^101.43^ORD(101.43,^B^order^ORC^~ ~" 117 S FILES(16)="45OP^REGISTRATION OP/PROC^2^*^^^op^PRC^~ ~" 118 S FILES(17)="45DX^REGISTRATION DX^2^*^^^dx^DD^~ ~" 119 S FILES(18)="63AP^ANATOMIC PATHOLOGY^2^*^^^ap^SP^~ ~" 120 S FILES(19)="63MI^MICROBIOLOGY^2^*^^^micro^MIC^~ ~" 121 S FILES(20)="9000010^VISITS^3^44^SC(^B^^CVP^~ ~" 122 S FILES(21)="405^ADMISSIONS^3^*^^^^ADC^~ ~" 123 S FILES(23)="53.79^MEDICATION,BCMA^2^50.7^PS(50.7,^B^^BCMA^~ ~" 124 S FILES(24)="130^SURGERY^2^81^ICPT(^C^surg^SR^~ ~" 125 S FILES(25)="8925^NOTES^2^*^^^note^CNB^~ ~" 126 S FILES(27)="120.8^ALLERGIES^2^*^^^allg^ADR^~ ~" 127 S FILES(28)="63BB^BLOOD BANK^2^66^LAB(66,^B^bb^BT^~ ~" 128 ;S FILES(29)="9999911^PROBLEMS-DURATION^3^80^ICD9(^B^prob^PLL^~ ~" ;*** 129 S FILES(30)="55NVA^MEDICATION,NON-VA^3^50.7^PS(50.7,^B^^RXNV^~ ~" 130 S FILES(31)="690^MEDICINE^2^*^^^med^MEDF^~ ~" 131 S FILES(2000)="811.2^Reminder Taxonomy" 132 S FILES(3000)="50.605^Drug Class" 133 Q 134 ; 135 TYPES(TYPES,DFN,SUB,TMP) ; from ORWGAPI 136 N CNT,FILES,ITEM,MEDARRAY,NUM,OK,SEQ K FILES,MEDARRAY 137 S TMP=$G(TMP) 138 D GETFILES(.FILES) 139 D FILECHK(.FILES) 140 I SUB D 141 . I $D(FILES(18)) D 142 .. S FILES(1801)="63AP;O^AP: Organ" 143 .. S FILES(1802)="63AP;T^AP: Test" 144 .. S FILES(1803)="63AP;D^AP: Disease" 145 .. S FILES(1804)="63AP;I^AP: ICD9" 146 .. S FILES(1805)="63AP;E^AP: Etiology" 147 .. S FILES(1806)="63AP;F^AP: Function" 148 .. S FILES(1807)="63AP;P^AP: Procedure" 149 .. S FILES(1808)="63AP;M^AP: Morphology" 150 .. S FILES(1809)="63AP;S^AP: Specimen" 151 . I $D(FILES(19)) D 152 .. S FILES(1901)="63MI;A^Microbiology: Antibiotic" 153 .. S FILES(1902)="63MI;T^Microbiology: Test" 154 .. S FILES(1903)="63MI;S^Microbiology: Specimen" 155 .. S FILES(1904)="63MI;O^Microbiology: Organism" 156 .. ;S FILES(1905)="63MI;M^Microbiology: TB Drug" 157 I 'SUB D 158 . K FILES(2000) 159 . K FILES(3000) 160 I DFN D 161 . I '$L($O(^PXRMINDX(63,"PI",DFN,""))) K FILES(1) 162 . I '$L($O(^PXRMINDX(120.5,"PI",DFN,""))) K FILES(2) 163 . I '$L($O(^PXRMINDX(52,"PI",DFN,""))) K FILES(3) 164 . I '$L($O(^PXRMINDX(55,"PI",DFN,""))) K FILES(4) 165 . I '$L($O(^PXRMINDX(70,"PI",DFN,""))) K FILES(5) 166 . I '$L($O(^PXRMINDX(9000010.11,"PI",DFN,""))) K FILES(6) 167 . I '$L($O(^PXRMINDX(9000010.12,"PI",DFN,""))) K FILES(7) 168 . I '$L($O(^PXRMINDX(9000010.13,"PI",DFN,""))) K FILES(8) 169 . I '$L($O(^PXRMINDX(9000010.18,"PPI",DFN,""))) K FILES(9) 170 . I '$L($O(^PXRMINDX(9000011,"PSPI",DFN,""))) K FILES(10),FILES(29) 171 . I '$L($O(^PXRMINDX(9000010.23,"PI",DFN,""))) K FILES(11) 172 . I '$L($O(^PXRMINDX(9000010.07,"PPI",DFN,""))) K FILES(12) 173 . I '$L($O(^PXRMINDX(9000010.16,"PI",DFN,""))) K FILES(13) 174 . I '$L($O(^PXRMINDX(601.2,"PI",DFN,""))) K FILES(14) 175 . I '$L($O(^PXRMINDX(100,"PI",DFN,""))) K FILES(15) 176 . I '$L($O(^PXRMINDX(45,"ICD0","PNI",DFN,0))) K FILES(16) 177 . I '$L($O(^PXRMINDX(45,"ICD9","PNI",DFN,0))) K FILES(17) 178 . I $E($O(^PXRMINDX(63,"PI",DFN,"A")))'="A" K FILES(18) D 179 .. F NUM=1:1:9 K FILES(180+NUM) 180 . I $E($O(^PXRMINDX(63,"PI",DFN,"M")))'="M" K FILES(19) D 181 .. F NUM=1:1:5 K FILES(190+NUM) 182 . I '$$VISITX^ORWGAPIA(DFN) K FILES(20) 183 . I '$$ADMITX^ORWGAPIA(DFN) K FILES(21) 184 . I '$$NVAX^ORWGAPIC(DFN) K FILES(22),FILES(30) 185 . I '$$BCMAX^ORWGAPIC(DFN) K FILES(23) 186 . I '$$SURGX^ORWGAPIA(DFN) K FILES(24) 187 . I '$$NOTEX^ORWGAPIA(DFN) K FILES(25) 188 . I '$$ALLERGYX^ORWGAPIA(DFN) K FILES(27) 189 . I '$$BBX^ORWGAPIB(DFN) K FILES(28) 190 . S OK=0 191 . D MEDICINE^ORWGAPIA(.MEDARRAY,DFN) 192 . I $O(MEDARRAY(0)) S OK=1 193 . I 'OK K FILES(31) 194 S CNT=0,SEQ=0 195 F S SEQ=$O(FILES(SEQ)) Q:SEQ<1 D 196 . S CNT=CNT+1 197 . I TMP S ^TMP(TYPES,$J,CNT)=FILES(SEQ) 198 . I 'TMP S TYPES(CNT)=FILES(SEQ) 199 Q 200 ; 1 ORWGAPIT ; SLC/STAFF - Graph Item Types ;11/20/06 08:58 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26 3 ; 4 COMPTYPE(FILE) ; $$(file) -> hs component abbrv - from ORWGAPID 5 N COMP,COMPNAME,COMPS,NUM,OK K COMPS 6 S COMPNAME=$$COMPNAME(FILE)_"]" 7 D COMP^ORWRP2(.COMPS) 8 S COMP="" 9 S OK=0 10 S NUM=0 11 D 12 . F S NUM=$O(COMPS(NUM)) Q:NUM<1 D I OK Q 13 .. S COMP=COMPS(NUM) 14 .. I COMP[COMPNAME,COMPNAME=$P($P(COMP,U,2),"[",2) S OK=1 15 Q COMP 16 ; 17 COMPNAME(FILE) ; $$(file) -> hs component abbrv 18 I FILE=63 Q "CH" 19 I FILE=120.5 Q "VSD" 20 I FILE=120.8 Q "ADR" 21 I FILE=52 Q "RXOP" 22 I FILE=55 Q "RXUD" 23 I FILE=70 Q "II" 24 I FILE=9000010.11 Q "IM" 25 I FILE=9000010.12 Q "ST" 26 I FILE=9000010.13 Q "EXAM" 27 I FILE=9000010.18 Q "CPT" 28 I FILE=9000011 Q "PLL" 29 I FILE=9999911 Q "PLL" 30 I FILE=9000010.23 Q "HF" 31 I FILE=9000010.07 Q "OD" 32 I FILE=9000010.16 Q "ED" 33 I FILE=601.2 Q "MHPE" 34 I FILE=100 Q "ORC" 35 I FILE="45OP" Q "PRC" 36 I FILE="45DX" Q "DD" 37 I FILE="63AP" Q "SP" 38 I FILE="63BB" Q "BT" 39 I FILE="63MI" Q "MIC" 40 I FILE=9000010 Q "CVP" 41 I FILE=405 Q "ADC" 42 I FILE="55NVAE" Q "RXNV" 43 I FILE="55NVA" Q "RXNV" 44 I FILE=53.79 Q "BCMA" 45 I FILE=130 Q "SR" 46 I FILE=8925 Q "CNB" 47 I FILE=9000010.15 Q "TP" 48 I FILE=690 Q "MEDF" 49 Q "" 50 ; 51 FILENAME(FILE) ; $$(file) -> filename - from ORWGAPIP 52 I FILE=63 Q "LAB TESTS" 53 I FILE=120.5 Q "VITALS" 54 I FILE=120.8 Q "ALLERGIES" 55 I FILE=52 Q "MEDICATION,OUTPATIENT" 56 I FILE=55 Q "MEDICATION,INPATIENT" 57 I FILE=70 Q "RADIOLOGY EXAMS" 58 I FILE=9000010.11 Q "IMMUNIZATIONS" 59 I FILE=9000010.12 Q "SKIN TESTS" 60 I FILE=9000010.13 Q "EXAMS" 61 I FILE=9000010.18 Q "PROCEDURES" 62 I FILE=9000011 Q "PROBLEMS" 63 I FILE=9999911 Q "PROBLEMS-DURATION" ;************** 64 I FILE=9000010.23 Q "HEALTH FACTORS" 65 I FILE=9000010.07 Q "PURPOSE OF VISIT" 66 I FILE=9000010.16 Q "PATIENT EDUCATION" 67 I FILE=601.2 Q "MENTAL HEALTH" 68 I FILE=100 Q "ORDERS" 69 I FILE="45OP" Q "REGISTRATION OP/PROC" 70 I FILE="45DX" Q "REGISTRATION DX" 71 I FILE="63AP" Q "ANATOMIC PATHOLOGY" 72 I FILE="63BB" Q "BLOOD PRODUCTS" 73 I FILE="63MI" Q "MICROBIOLOGY" 74 I FILE=9000010 Q "VISITS" 75 I FILE=405 Q "ADMISSIONS" 76 I FILE="55NVAE" Q "MEDICATION,NON-VA-EVENT" ;***** 77 I FILE="55NVA" Q "MEDICATION,NON-VA" 78 I FILE=53.79 Q "MEDICATION,BCMA" 79 I FILE=50.605 Q "DRUG CLASS" 80 I FILE=68 Q "LAB ACC AREA" 81 I FILE=8925.1 Q "NOTE TITLE" 82 I FILE=100.98 Q "ORDER DISPLAY GROUP" 83 I FILE=811.2 Q "REMINDER TAXONOMY" 84 I FILE=130 Q "SURGERY" 85 I FILE=8925 Q "NOTES" 86 I FILE=9000010.15 Q "TREATMENTS" 87 I FILE=690 Q "MEDICINE" 88 Q "" 89 ; 90 FILECHK(FILES) ; 91 ; get parameter string of excluded files 92 N CHECK,NUM,ORSRV,VAL 93 S ORSRV=$$GET1^DIQ(200,DUZ,29,"I") 94 S CHECK=$$XGET^ORWGAPIX("USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORWG GRAPH EXCLUDE DATA TYPE",1,"I") 95 S CHECK=CHECK_";" 96 S NUM=0 97 F S NUM=$O(FILES(NUM)) Q:NUM<1 D 98 . S VAL=FILES(NUM) 99 . S VAL=$P(VAL,U)_";" 100 . I CHECK[VAL K FILES(NUM) 101 Q 102 ; 103 GETFILES(FILES) ; 104 ; file #^file name^graph type^lookup file^lookup global^lookup index 105 ; commenting out a line setting FILES will inactivate that type 106 S FILES(1)="63^LAB TESTS^1^60^LAB(60,^B^^CH^" 107 S FILES(2)="120.5^VITALS^1^120.51^GMRD(120.51,^B^^VSD^" 108 S FILES(3)="52^MEDICATION,OUTPATIENT^3^50^PSDRUG(^B^^RXOP^" 109 S FILES(4)="55^MEDICATION,INPATIENT^3^50^PSDRUG(^B^^RXUD^" 110 S FILES(5)="70^RADIOLOGY EXAMS^2^71^RAMIS(71,^B^rad^II^" 111 S FILES(6)="9000010.11^IMMUNIZATIONS^2^9999999.14^AUTTIMM(^B^imm^IM^" 112 S FILES(7)="9000010.12^SKIN TESTS^2^9999999.28^AUTTSK(^B^skin^ST^" 113 S FILES(8)="9000010.13^EXAMS^2^9999999.15,^AUTTEXAM(^B^exam^EXAM^" 114 S FILES(9)="9000010.18^PROCEDURES^2^81^ICPT(^C^proc^CPT^" 115 S FILES(10)="9000011^PROBLEMS^2^80^ICD9(^B^prob^PLL^" ;*** 116 S FILES(11)="9000010.23^HEALTH FACTORS^2^9999999.64^AUTTHF(,^B^hf^HF^" 117 S FILES(12)="9000010.07^PURPOSE OF VISIT^2^80^ICD9(^B^pov^OD^" 118 S FILES(13)="9000010.16^PATIENT EDUCATION^2^9999999.09^AUTTEDT(^B^edu^ED^" 119 S FILES(14)="601.2^MENTAL HEALTH^2^601^YTT(601,^B^mh^MHPE^" 120 S FILES(15)="100^ORDERS^2^101.43^ORD(101.43,^B^order^ORC^" 121 S FILES(16)="45OP^REGISTRATION OP/PROC^2^*^^^op^PRC^" 122 S FILES(17)="45DX^REGISTRATION DX^2^*^^^dx^DD^" 123 S FILES(18)="63AP^ANATOMIC PATHOLOGY^2^*^^^ap^SP^" 124 S FILES(19)="63MI^MICROBIOLOGY^2^*^^^micro^MIC^" 125 S FILES(20)="9000010^VISITS^3^44^SC(^B^^CVP^" 126 S FILES(21)="405^ADMISSIONS^3^*^^^^ADC^" 127 ;S FILES(22)="55NVAE^MEDICATION,NON-VA-EVENT^2^50.7^PS(50.7,^B^^RXNV^" 128 S FILES(23)="53.79^MEDICATION,BCMA^2^50.7^PS(50.7,^B^^BCMA^" 129 S FILES(24)="130^SURGERY^2^81^ICPT(^C^surg^SR^" 130 S FILES(25)="8925^NOTES^2^*^^^note^CNB^" 131 ;S FILES(26)="9000010.15^TREATMENTS^2^9999999.17,^AUTTTRT(^B^treat^TP^" 132 S FILES(27)="120.8^ALLERGIES^2^*^^^allg^ADR^" 133 S FILES(28)="63BB^BLOOD BANK^2^66^LAB(66,^B^bb^BT^" 134 ;S FILES(29)="9999911^PROBLEMS-DURATION^3^80^ICD9(^B^prob^PLL^" ;*** 135 S FILES(30)="55NVA^MEDICATION,NON-VA^3^50.7^PS(50.7,^B^^RXNV^" 136 S FILES(31)="690^MEDICINE^2^*^^^med^MEDF^" 137 S FILES(2000)="811.2^Reminder Taxonomy" 138 S FILES(3000)="50.605^Drug Class" 139 Q 140 ; 141 TYPES(TYPES,DFN,SUB,TMP) ; from ORWGAPI 142 N CNT,FILES,ITEM,MEDARRAY,NUM,OK,SEQ K FILES,MEDARRAY 143 S TMP=$G(TMP) 144 D GETFILES(.FILES) 145 D FILECHK(.FILES) 146 I SUB D 147 . I $D(FILES(18)) D 148 .. S FILES(1801)="63AP;O^AP: Organ" 149 .. S FILES(1802)="63AP;T^AP: Test" 150 .. S FILES(1803)="63AP;D^AP: Disease" 151 .. S FILES(1804)="63AP;I^AP: ICD9" 152 .. S FILES(1805)="63AP;E^AP: Etiology" 153 .. S FILES(1806)="63AP;F^AP: Function" 154 .. S FILES(1807)="63AP;P^AP: Procedure" 155 .. S FILES(1808)="63AP;M^AP: Morphology" 156 .. S FILES(1809)="63AP;S^AP: Specimen" 157 . I $D(FILES(19)) D 158 .. S FILES(1901)="63MI;A^Microbiology: Antibiotic" 159 .. S FILES(1902)="63MI;T^Microbiology: Test" 160 .. S FILES(1903)="63MI;S^Microbiology: Specimen" 161 .. S FILES(1904)="63MI;O^Microbiology: Organism" 162 .. ;S FILES(1905)="63MI;M^Microbiology: TB Drug" 163 I 'SUB D 164 . K FILES(2000) 165 . K FILES(3000) 166 I DFN D 167 . I '$L($O(^PXRMINDX(63,"PI",DFN,""))) K FILES(1) 168 . I '$L($O(^PXRMINDX(120.5,"PI",DFN,""))) K FILES(2) 169 . I '$L($O(^PXRMINDX(52,"PI",DFN,""))) K FILES(3) 170 . I '$L($O(^PXRMINDX(55,"PI",DFN,""))) K FILES(4) 171 . I '$L($O(^PXRMINDX(70,"PI",DFN,""))) K FILES(5) 172 . I '$L($O(^PXRMINDX(9000010.11,"PI",DFN,""))) K FILES(6) 173 . I '$L($O(^PXRMINDX(9000010.12,"PI",DFN,""))) K FILES(7) 174 . I '$L($O(^PXRMINDX(9000010.13,"PI",DFN,""))) K FILES(8) 175 . I '$L($O(^PXRMINDX(9000010.18,"PPI",DFN,""))) K FILES(9) 176 . I '$L($O(^PXRMINDX(9000011,"PSPI",DFN,""))) K FILES(10),FILES(29) 177 . I '$L($O(^PXRMINDX(9000010.23,"PI",DFN,""))) K FILES(11) 178 . I '$L($O(^PXRMINDX(9000010.07,"PPI",DFN,""))) K FILES(12) 179 . I '$L($O(^PXRMINDX(9000010.16,"PI",DFN,""))) K FILES(13) 180 . I '$L($O(^PXRMINDX(601.2,"PI",DFN,""))) K FILES(14) 181 . I '$L($O(^PXRMINDX(100,"PI",DFN,""))) K FILES(15) 182 . I '$L($O(^PXRMINDX(45,"ICD0","PNI",DFN,0))) K FILES(16) 183 . I '$L($O(^PXRMINDX(45,"ICD9","PNI",DFN,0))) K FILES(17) 184 . I $E($O(^PXRMINDX(63,"PI",DFN,"A")))'="A" K FILES(18) D 185 .. F NUM=1:1:9 K FILES(180+NUM) 186 . I $E($O(^PXRMINDX(63,"PI",DFN,"M")))'="M" K FILES(19) D 187 .. F NUM=1:1:5 K FILES(190+NUM) 188 . I '$$VISITX^ORWGAPIA(DFN) K FILES(20) 189 . I '$$ADMITX^ORWGAPIA(DFN) K FILES(21) 190 . I '$$NVAX^ORWGAPIA(DFN) K FILES(22),FILES(30) 191 . I '$$BCMAX^ORWGAPIA(DFN) K FILES(23) 192 . I '$$SURGX^ORWGAPIA(DFN) K FILES(24) 193 . I '$$NOTEX^ORWGAPIA(DFN) K FILES(25) 194 . I '$$TREATX^ORWGAPIA(DFN) K FILES(26) 195 . I '$$ALLERGYX^ORWGAPIA(DFN) K FILES(27) 196 . I '$$BBX^ORWGAPIB(DFN) K FILES(28) 197 . S OK=0 198 . D MEDICINE^ORWGAPIA(.MEDARRAY,DFN) 199 . I $O(MEDARRAY(0)) S OK=1 200 . I 'OK K FILES(31) 201 S CNT=0,SEQ=0 202 F S SEQ=$O(FILES(SEQ)) Q:SEQ<1 D 203 . S CNT=CNT+1 204 . I TMP S ^TMP(TYPES,$J,CNT)=FILES(SEQ) 205 . I 'TMP S TYPES(CNT)=FILES(SEQ) 206 Q 207 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIU.m
r613 r623 1 ORWGAPIU ; SLC/STAFF - Graph API Utilities ;3/17/08 10:27 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242 3 ; 4 EVALUE(VAL,FILE,FIELD) ; $$(internal value,file,field) -> external value or "" 5 ; from ORWGAPI1, ORWGAPI2, ORWGAPI3, ORWGAPI4, ORWGAPIP, ORWGAPIR 6 I VAL="" Q "" 7 S FIELD=$G(FIELD,.01) 8 I $E(FILE,1,2)=63 Q $$LABNAME^ORWGAPIC(VAL) 9 I FILE="63AP;I" Q $$ICD9^ORWGAPIA(VAL) 10 I FILE="45DX" Q $$ICD9^ORWGAPIA(VAL) 11 I FILE="45OP" Q $$ICD0^ORWGAPIA(VAL) 12 I FILE="45;ICD9" Q $$ICD9^ORWGAPIA(VAL) 13 I FILE="45;ICD0" Q $$ICD0^ORWGAPIA(VAL) 14 I FIELD=.01,'$L(VAL) Q "" 15 I FILE=9000010.07 Q $$ICD9^ORWGAPIA(VAL) 16 I FILE=9000010.18 Q $$ICPT^ORWGAPIA(VAL) 17 I FILE=9000011 Q $$ICD9^ORWGAPIA(VAL) 18 I FILE=9999911 Q $$ICD9^ORWGAPIA(VAL) 19 I FILE=130 Q $$ICPT^ORWGAPIA(VAL) 20 I FILE=120.8 Q $$ALLG^ORWGAPIA(VAL) 21 I FILE=50.605 Q $$DC^ORWGAPIC(VAL) 22 I FILE=68 Q $$AA^ORWGAPIC(VAL) 23 I FILE=811.2 Q $$TAX^ORWGAPIA(VAL) 24 D 25 . I FILE=52 S FIELD=6 Q 26 . I FILE=53.79 S FIELD=.08 Q 27 . I FILE=55 S FILE=55.07 Q 28 . I FILE="55NVA" S FILE=55.05 Q 29 . I FILE=70 S FILE=70.03,FIELD=2 Q 30 . I FILE=100 S FILE=100.001 Q 31 . I FILE=120.5 S FIELD=.03 Q 32 . I FILE=601.2 S FILE=601.21 Q 33 Q $$EXT^ORWGAPIX(VAL,FILE,FIELD) 34 ; 35 FILE(FILE,REF,XREF,SCREEN) ; from ORWGAPI 36 S REF="",SCREEN="I 1",XREF="B" 37 I FILE="" Q 38 D 39 . I FILE="45DX" S REF=$$GBLREF(80),XREF="AB" Q 40 . I FILE="45OP" S REF=$$GBLREF(80.1),XREF="AB" Q 41 . I FILE=50.605 S REF=$$GBLREF(50.605),XREF="C" Q 42 . I FILE=52 S REF=$$GBLREF(50) Q 43 . I FILE=53.79 S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)'=1" Q 44 . I FILE=55 S REF=$$GBLREF(50) Q 45 . I FILE="55NVA" S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)=1" Q 46 . I FILE=63 S REF=$$GBLREF(60),SCREEN="I $L($P(ZERO,U,5)),""BO""[$P(ZERO,U,3),$P(ZERO,U,4)=""CH""" Q 47 . I FILE="63AP" S REF=$$GBLREF(60),SCREEN="I 0" Q 48 . I FILE="63AP;D" S REF=$$GBLREF(61.4) Q 49 . I FILE="63AP;E" S REF=$$GBLREF(61.2) Q 50 . I FILE="63AP;F" S REF=$$GBLREF(61.3) Q 51 . I FILE="63AP;I" S REF=$$GBLREF(80),XREF="AB" Q 52 . I FILE="63AP;M" S REF=$$GBLREF(61.1) Q 53 . I FILE="63AP;O" S REF=$$GBLREF(61) Q 54 . I FILE="63AP;P" S REF=$$GBLREF(61.5) Q 55 . I FILE="63AP;T" S REF=$$GBLREF(60),SCREEN="I ""BO""[$P(ZERO,U,3),(($P(ZERO,U,4)=""CY"")!($P(ZERO,U,4)=""SP"")!($P(ZERO,U,4)=""EM"")!($P(ZERO,U,4)=""AU""))" Q 56 . I FILE="63BB" S REF=$$GBLREF(66),SCREEN="I $P(ZERO,U,15)=1" Q 57 . I FILE="63MI" S REF=$$GBLREF(60),SCREEN="I 0" Q 58 . I FILE="63MI;A" S REF=$$GBLREF(62.06) Q 59 . I FILE="63MI;M" S REF=$$GBLREF(60) Q ; mycobacteria not currently used 60 . I FILE="63MI;O" S REF=$$GBLREF(61.2),SCREEN="I $L($P(ZERO,U,5)),""BFPMV""[$P(ZERO,U,5)" Q 61 . I FILE="63MI;S" S REF=$$GBLREF(61) Q 62 . I FILE="63MI;T" S REF=$$GBLREF(60),SCREEN="I ""BO""[$P(ZERO,U,3),$P(ZERO,U,4)=""MI""" Q 63 . I FILE=70 S REF=$$GBLREF(71) Q 64 . I FILE=100 S REF=$$GBLREF(101.43) Q 65 . I FILE=120.5 S REF=$$GBLREF(120.51),SCREEN="I ""BP^P^T^R^P^HT^WT^CVP^CG^PO2^PN""[$P(ZERO,U,2)" Q 66 . ;I FILE=120.8 S REF=$$GBLREF(120.83) Q 67 . I FILE=130 S REF=$$GBLREF(81),SCREEN="I '$P(ZERO,U,4)" Q 68 . I FILE=405 S REF=$$GBLREF(44),SCREEN="I 0" Q 69 . I FILE=601.2 S REF=$$GBLREF(601) Q 70 . I FILE=690 S REF=$$GBLREF(697.2),XREF="BA" Q 71 . I FILE=811.2 S REF=$$GBLREF(811.2),SCREEN="I $P(ZERO,U,6)'=1" Q 72 . I FILE=8925 S REF=$$GBLREF(8925.1),SCREEN="I $P(ZERO,U,4)=""DOC""" Q 73 . I FILE=9000010 S REF=$$GBLREF(44) Q 74 . I FILE=9000010.07 S REF=$$GBLREF(80),XREF="AB" Q 75 . I FILE=9000010.11 S REF=$$GBLREF(9999999.14),SCREEN="I $P(ZERO,U,7)'=1" Q 76 . I FILE=9000010.12 S REF=$$GBLREF(9999999.28),SCREEN="I $P(ZERO,U,3)'=1" Q 77 . I FILE=9000010.13 S REF=$$GBLREF(9999999.15),SCREEN="I $P(ZERO,U,4)'=1" Q 78 . I FILE=9000010.16 S REF=$$GBLREF(9999999.09),SCREEN="I $P(ZERO,U,3)'=1" Q 79 . I FILE=9000010.18 S REF=$$GBLREF(81),XREF="BA",SCREEN="I '$P(ZERO,U,4)" Q 80 . I FILE=9000010.23 S REF=$$GBLREF(9999999.64),SCREEN="I $P(ZERO,U,10)=""F"",$P(ZERO,U,11)'=1" Q 81 . I FILE=9000011 S REF=$$GBLREF(80),XREF="AB",SCREEN="I $E(ZERO)'=""E"",'$L($P(ZERO,U,9))" Q 82 . I FILE=9999911 S REF=$$GBLREF(80),XREF="AB",SCREEN="I $E(ZERO)'=""E"",'$L($P(ZERO,U,9))" Q 83 I $E(REF)'="^" S REF="" 84 S REF=REF ;_""""_XREF_""")" 85 Q 86 ; 87 GBLREF(FN) ; $$(file#) -> global reference 88 Q $$GBLREF^ORWGAPIX($G(FN)) 89 ; 90 INISET ; postinit, set initial public graph setting - from ORY215, ORY243 91 D INISET^ORWGAPIP 92 D RESOURCE^ORWGTASK 93 Q 94 ; 95 ITEMPRFX(ITEM) ; $$(item) -> item prefix - from ORWGAPI1 96 N ABBREV,PREFIX 97 S PREFIX="" 98 S ABBREV=$P(ITEM,";",2) 99 I $E(ITEM)="A" D Q PREFIX 100 . I ABBREV="T" S PREFIX="TEST" Q 101 . I ABBREV="S" S PREFIX="SPECIMEN" Q 102 . I ABBREV="O" S PREFIX="ORGAN" Q 103 . I ABBREV="M" S PREFIX="MORPHOLOGY" Q 104 . I ABBREV="E" S PREFIX="ETIOLOGY" Q 105 . I ABBREV="D" S PREFIX="DISEASE" Q 106 . I ABBREV="P" S PREFIX="PROCEDURE" Q 107 . I ABBREV="F" S PREFIX="FUNCTION" Q 108 . I ABBREV="I" S PREFIX="ICD9" Q 109 I $E(ITEM)="B" Q "BLOOD COMPONENT" 110 I $E(ITEM)="M" D Q PREFIX 111 . I ABBREV="T" S PREFIX="TEST" Q 112 . I ABBREV="S" S PREFIX="SPECIMEN" Q 113 . I ABBREV="O" S PREFIX="ORGANISM" Q 114 . I ABBREV="A" S PREFIX="ANTIBIOTIC" Q 115 . I ABBREV="M" S PREFIX="TB ANTIBIOTIC" Q 116 Q PREFIX 117 ; 1 ORWGAPIU ; SLC/STAFF - Graph API Utilities ;8/19/06 15:20 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26 3 ; 4 EVALUE(VAL,FILE,FIELD) ; $$(internal value,file,field) -> external value or "" 5 ; from ORWGAPI1, ORWGAPI2, ORWGAPI3, ORWGAPI4, ORWGAPIP, ORWGAPIR 6 I VAL="" Q "" 7 S FIELD=$G(FIELD,.01) 8 I $E(FILE,1,2)=63 Q $$LABNAME^ORWGAPIA(VAL) 9 I FILE="63AP;I" Q $$ICD9^ORWGAPIA(VAL) 10 I FILE="45DX" Q $$ICD9^ORWGAPIA(VAL) 11 I FILE="45OP" Q $$ICD0^ORWGAPIA(VAL) 12 I FILE="45;ICD9" Q $$ICD9^ORWGAPIA(VAL) 13 I FILE="45;ICD0" Q $$ICD0^ORWGAPIA(VAL) 14 I FIELD=.01,'$L(VAL) Q "" 15 I FILE=9000010.07 Q $$ICD9^ORWGAPIA(VAL) 16 I FILE=9000010.18 Q $$ICPT^ORWGAPIA(VAL) 17 I FILE=9000011 Q $$ICD9^ORWGAPIA(VAL) 18 I FILE=9999911 Q $$ICD9^ORWGAPIA(VAL) 19 I FILE=130 Q $$ICPT^ORWGAPIA(VAL) 20 I FILE=120.8 Q $$ALLG^ORWGAPIA(VAL) 21 I FILE=50.605 Q $$DC^ORWGAPIA(VAL) 22 I FILE=68 Q $$AA^ORWGAPIA(VAL) 23 I FILE=811.2 Q $$TAX^ORWGAPIA(VAL) 24 D 25 . I FILE=52 S FIELD=6 Q 26 . I FILE=53.79 S FIELD=.08 Q 27 . I FILE=55 S FILE=55.07 Q 28 . I FILE="55NVAE" S FILE=55.05 Q 29 . I FILE="55NVA" S FILE=55.05 Q 30 . I FILE=70 S FILE=70.03,FIELD=2 Q 31 . I FILE=100 S FILE=100.001 Q 32 . I FILE=120.5 S FIELD=.03 Q 33 . I FILE=601.2 S FILE=601.21 Q 34 Q $$EXT^ORWGAPIX(VAL,FILE,FIELD) 35 ; 36 FILE(FILE,REF,XREF,SCREEN) ; from ORWGAPI 37 S REF="",SCREEN="I 1",XREF="B" 38 I FILE="" Q 39 D 40 . I FILE="45DX" S REF=$$GBLREF(80),XREF="AB" Q 41 . I FILE="45OP" S REF=$$GBLREF(80.1),XREF="AB" Q 42 . I FILE=50.605 S REF=$$GBLREF(50.605),XREF="C" Q 43 . I FILE=52 S REF=$$GBLREF(50) Q 44 . I FILE=53.79 S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)'=1" Q 45 . I FILE=55 S REF=$$GBLREF(50) Q 46 . I FILE="55NVAE" S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)=1" Q 47 . I FILE="55NVA" S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)=1" Q 48 . I FILE=63 S REF=$$GBLREF(60),SCREEN="I $L($P(ZERO,U,5)),""BO""[$P(ZERO,U,3),$P(ZERO,U,4)=""CH""" Q 49 . I FILE="63AP" S REF=$$GBLREF(60),SCREEN="I 0" Q 50 . I FILE="63AP;D" S REF=$$GBLREF(61.4) Q 51 . I FILE="63AP;E" S REF=$$GBLREF(61.2) Q 52 . I FILE="63AP;F" S REF=$$GBLREF(61.3) Q 53 . I FILE="63AP;I" S REF=$$GBLREF(80),XREF="AB" Q 54 . I FILE="63AP;M" S REF=$$GBLREF(61.1) Q 55 . I FILE="63AP;O" S REF=$$GBLREF(61) Q 56 . I FILE="63AP;P" S REF=$$GBLREF(61.5) Q 57 . I FILE="63AP;T" S REF=$$GBLREF(60),SCREEN="I ""BO""[$P(ZERO,U,3),(($P(ZERO,U,4)=""CY"")!($P(ZERO,U,4)=""SP"")!($P(ZERO,U,4)=""EM"")!($P(ZERO,U,4)=""AU""))" Q 58 . I FILE="63BB" S REF=$$GBLREF(66),SCREEN="I $P(ZERO,U,15)=1" Q 59 . I FILE="63MI" S REF=$$GBLREF(60),SCREEN="I 0" Q 60 . I FILE="63MI;A" S REF=$$GBLREF(62.06) Q 61 . I FILE="63MI;M" S REF=$$GBLREF(60) Q ; mycobacteria not currently used 62 . I FILE="63MI;O" S REF=$$GBLREF(61.2),SCREEN="I $L($P(ZERO,U,5)),""BFPMV""[$P(ZERO,U,5)" Q 63 . I FILE="63MI;S" S REF=$$GBLREF(61) Q 64 . I FILE="63MI;T" S REF=$$GBLREF(60),SCREEN="I ""BO""[$P(ZERO,U,3),$P(ZERO,U,4)=""MI""" Q 65 . I FILE=70 S REF=$$GBLREF(71) Q 66 . I FILE=100 S REF=$$GBLREF(101.43) Q 67 . I FILE=120.5 S REF=$$GBLREF(120.51),SCREEN="I ""BP^P^T^R^P^HT^WT^CVP^CG^PO2^PN""[$P(ZERO,U,2)" Q 68 . ;I FILE=120.8 S REF=$$GBLREF(120.83) Q 69 . I FILE=130 S REF=$$GBLREF(81),SCREEN="I '$P(ZERO,U,4)" Q 70 . I FILE=405 S REF=$$GBLREF(44),SCREEN="I 0" Q 71 . I FILE=601.2 S REF=$$GBLREF(601) Q 72 . I FILE=690 S REF=$$GBLREF(697.2),XREF="BA" Q 73 . I FILE=811.2 S REF=$$GBLREF(811.2),SCREEN="I $P(ZERO,U,6)'=1" Q 74 . I FILE=8925 S REF=$$GBLREF(8925.1),SCREEN="I $P(ZERO,U,4)=""DOC""" Q 75 . I FILE=9000010 S REF=$$GBLREF(44) Q 76 . I FILE=9000010.07 S REF=$$GBLREF(80),XREF="AB" Q 77 . I FILE=9000010.11 S REF=$$GBLREF(9999999.14),SCREEN="I $P(ZERO,U,7)'=1" Q 78 . I FILE=9000010.12 S REF=$$GBLREF(9999999.28),SCREEN="I $P(ZERO,U,3)'=1" Q 79 . I FILE=9000010.13 S REF=$$GBLREF(9999999.15),SCREEN="I $P(ZERO,U,4)'=1" Q 80 . I FILE=9000010.15 S REF=$$GBLREF(9999999.17),SCREEN="I $P(ZERO,U,4)'=1" Q 81 . I FILE=9000010.16 S REF=$$GBLREF(9999999.09),SCREEN="I $P(ZERO,U,3)'=1" Q 82 . I FILE=9000010.18 S REF=$$GBLREF(81),SCREEN="I '$P(ZERO,U,4)" Q 83 . I FILE=9000010.23 S REF=$$GBLREF(9999999.64),SCREEN="I $P(ZERO,U,10)=""F"",$P(ZERO,U,11)'=1" Q 84 . I FILE=9000011 S REF=$$GBLREF(80),XREF="AB",SCREEN="I $E(ZERO)'=""E"",'$L($P(ZERO,U,9))" Q 85 . I FILE=9999911 S REF=$$GBLREF(80),XREF="AB",SCREEN="I $E(ZERO)'=""E"",'$L($P(ZERO,U,9))" Q 86 I $E(REF)'="^" S REF="" 87 S REF=REF ;_""""_XREF_""")" 88 Q 89 ; 90 GBLREF(FN) ; $$(file#) -> global reference 91 Q $$GBLREF^ORWGAPIX($G(FN)) 92 ; 93 GENERIC(VAL,FROM,DIR,FILE,REF,XREF,SCREEN) ; Return a set of entries from xref in REF 94 ; from ORWGAPI 95 ; .VAL=returned list, FROM=text to $O from, DIR=$O direction, 96 N CNT,IEN,NAME,NEXTNAME,NUM,OK,ROOT,ZERO S NUM=0,CNT=44 K VAL 97 I FILE=405 Q 98 S ROOT="" 99 S FROM=$$UP^ORWGAPIX(FROM) 100 I $E(REF,$L(REF))="," S ROOT=$E(REF,1,$L(REF)-1)_")" 101 I $E(REF,$L(REF))="(" S ROOT=$P(REF,"(") 102 I '$L(ROOT) Q 103 S REF=REF_""""_XREF_""")" 104 F Q:NUM'<CNT S FROM=$O(@REF@(FROM),DIR) Q:FROM="" D 105 . S IEN="" F S IEN=$O(@REF@(FROM,IEN),DIR) Q:'IEN D 106 .. I FILE=100,$O(@REF@(FROM,IEN,""))>0 Q 107 .. S ZERO=$G(@ROOT@(IEN,0)) I '$L(ZERO) Q 108 .. X SCREEN I '$T Q 109 .. S NUM=NUM+1 110 .. I FILE="45DX"!(FILE=9000010.07)!(FILE=9000011)!(FILE="63AP;I") D Q 111 ... S VAL(NUM)=FILE_U_IEN_U_$$ICD9^ORWGAPIA(IEN) Q 112 .. I FILE="45OP" S VAL(NUM)=FILE_U_IEN_U_$$ICD0^ORWGAPIA(IEN) Q 113 .. I FILE="55NVAE"!(FILE=53.79) S VAL(NUM)=FILE_U_IEN_U_$$POINAME^ORWGAPIA(IEN) Q 114 .. I FILE="55NVA" S VAL(NUM)=FILE_U_IEN_U_$$POINAME^ORWGAPIA(IEN) Q 115 .. I FILE=9000010.18 S VAL(NUM)=FILE_U_IEN_U_$$ICPT^ORWGAPIA(IEN) Q 116 .. I FILE=130 S VAL(NUM)=FILE_U_IEN_U_$$ICPT^ORWGAPIA(IEN) Q 117 .. S VAL(NUM)=FILE_U_IEN_U_FROM 118 I FILE=120.5 D 119 . S (NUM,OK)=0 120 . F S NUM=$O(VAL(NUM)) Q:NUM<1 D Q:OK 121 .. S NAME=$P(VAL(NUM),U,3) 122 .. S NEXTNAME=$P($G(VAL(NUM+1)),U,3) 123 .. I "BODY MASS INDEX"]NAME,NEXTNAME]"BODY MASS INDEX" D 124 ... S OK=1 125 ... S VAL(NUM+.5)="120.5^99999^BODY MASS INDEX" 126 Q 127 ; 128 INISET ; postinit, set initial public graph setting - from ORY215 129 D INISET^ORWGAPIP 130 Q 131 ; 132 ITEMPRFX(ITEM) ; $$(item) -> item prefix - from ORWGAPI1 133 N ABBREV,PREFIX 134 S PREFIX="" 135 S ABBREV=$P(ITEM,";",2) 136 I $E(ITEM)="A" D Q PREFIX 137 . I ABBREV="T" S PREFIX="TEST" Q 138 . I ABBREV="S" S PREFIX="SPECIMEN" Q 139 . I ABBREV="O" S PREFIX="ORGAN" Q 140 . I ABBREV="M" S PREFIX="MORPHOLOGY" Q 141 . I ABBREV="E" S PREFIX="ETIOLOGY" Q 142 . I ABBREV="D" S PREFIX="DISEASE" Q 143 . I ABBREV="P" S PREFIX="PROCEDURE" Q 144 . I ABBREV="F" S PREFIX="FUNCTION" Q 145 . I ABBREV="I" S PREFIX="ICD9" Q 146 I $E(ITEM)="B" Q "BLOOD COMPONENT" 147 I $E(ITEM)="M" D Q PREFIX 148 . I ABBREV="T" S PREFIX="TEST" Q 149 . I ABBREV="S" S PREFIX="SPECIMEN" Q 150 . I ABBREV="O" S PREFIX="ORGANISM" Q 151 . I ABBREV="A" S PREFIX="ANTIBIOTIC" Q 152 . I ABBREV="M" S PREFIX="TB ANTIBIOTIC" Q 153 Q PREFIX 154 ; 155 OGROUP(OITEM) ; $$(orderable item) -> ien display group^display group - from ORWGAPIR 156 N IEN 157 S IEN=+$P($G(^ORD(101.43,+$G(OITEM),0)),U,5) 158 Q IEN_U_"order - "_$P($G(^ORD(100.98,IEN,0)),U) 159 ; 160 RETURN(TMP,ITEMS) ; return TMP (0 use local, 1 use ^TMP(ITEMS,$J, where ITEMS is a namespaced string) 161 ; from ORWGAPI, ORWGAPIP, ORWGAPIX 162 N NMSP 163 S NMSP=$G(ITEMS) K ITEMS S ITEMS="" 164 S TMP=NMSP?1U1UN1.14UNP 165 I TMP S ITEMS=NMSP 166 Q 167 ; 168 SETUP(DATA,RESULT,TMP,CNT) ; from ORWGAPI1, ORWGAPI2, ORWGAPI3, ORWGAPI4, ORWGAPIP, ORWGAPIR, ORWGAPIX 169 S CNT=CNT+1 170 I TMP S ^TMP(DATA,$J,CNT)=RESULT 171 I 'TMP S DATA(CNT)=RESULT 172 Q 173 ; 174 DATETFM(DATETIME) ; $$(external date/time) -> fm date/time else 0 175 N DATE,DAY,FMDT,HOUR,MIN,SEC,TIME,YEAR 176 S DATE=$P(DATETIME,"@"),TIME=$P(DATETIME,"@",2) 177 S YEAR=$P(DATE,",",2) I $L(YEAR)'=4 Q 0 178 S YEAR=YEAR-1700 I YEAR<270 Q 0 179 S MONTH=$P(DATE," ") 180 S MONTH=$$MTN(MONTH) I MONTH<1 Q 0 181 I MONTH<10 S MONTH="0"_MONTH 182 S DAY=$P(DATE," ",2),DAY=$P(DAY,",") 183 I DAY<1 Q 0 184 I DAY<10 S DAY="0"_DAY 185 S HOUR=$P(TIME,":") 186 S MIN=$P(TIME,":",2) 187 S SEC=$P(TIME,":",3) 188 S TIME=HOUR_MIN_SEC 189 S FMDT=YEAR_MONTH_DAY 190 I '$L(TIME) Q FMDT 191 Q FMDT_"."_TIME 192 ; 193 MTN(MONTH) ; $$(external month) -> month number 194 N MONTHS,NUM 195 I $L(MONTH)'=3 Q 0 196 S MONTHS="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC" 197 F NUM=1:1:13 I $P(MONTHS,U,NUM)=MONTH Q 198 I NUM=13 Q 0 199 Q NUM -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIX.m
r613 r623 1 ORWGAPIX ; SLC/STAFF - Graph External Calls ;9/29/06 11:49 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242 3 ; 4 DATE(X) ; $$(date/time) -> date/time 5 N Y D ^%DT 6 Q Y 7 ENDIQ1(RESULTS,DIC,DR,DA,DIQ) ; use file # for DIC 8 N NUMDIC K RESULTS,^UTILITY("DIQ1",$J) 9 Q:'$G(DIC) Q:'$L(DR) Q:'$G(DA) 10 S NUMDIC=DIC 11 D EN^DIQ1 12 M RESULTS=^UTILITY("DIQ1",$J,NUMDIC,DA) 13 K ^UTILITY("DIQ1",$J) 14 Q 15 EXT(Y,FILE,FIELD) ; $$(value,file,field) -> external value 16 N C S C=$P($G(^DD(FILE,FIELD,0)),U,2) D Y^DIQ 17 Q Y 18 EXTERNAL(FILE,FIELD,FLAG,VAL) ; $$(file,field,flag,internal value) -> external value 19 Q $$EXTERNAL^DILFD(FILE,FIELD,FLAG,VAL) 20 EXTNAME(IEN,FN) ; $$(ien,file#) -> external form of pointer 21 N REF 22 S REF=$G(^DIC(FN,0,"GL")) 23 I $L(REF),+IEN Q $P($G(@(REF_IEN_",0)")),U) 24 Q "" 25 FILENM(FILENUM) ; $$(file#) -> file name 26 N DIC,DO,NAME K DIC,DO 27 S FILENUM=$$GBLREF(+$G(FILENUM)) 28 I '$L($G(FILENUM)) Q "" 29 S DIC=FILENUM 30 D DO^DIC1 31 S NAME=$P(DO,U) 32 Q NAME 33 GETDATA(RESULTS,DIC,DR,DA,DIQ) ; use file # for DIC 34 N NUMDIC K RESULTS,^UTILITY("DIQ1",$J) 35 Q:'$G(DIC) Q:'$L(DR) Q:'$G(DA) 36 S NUMDIC=DIC 37 D EN^DIQ1 38 M RESULTS=^UTILITY("DIQ1",$J,NUMDIC,DA) 39 K ^UTILITY("DIQ1",$J) 40 Q 41 GBLREF(FILENUM) ; $$(file#) -> global reference 42 I '$G(FILENUM) Q "" 43 Q $$ROOT^DILFD(+FILENUM) 44 INDEX(DIK,DA) ; index entry in file - from ORWGAPIP 45 D IX1^DIK 46 Q 47 XDEL(ENTITY,PARAM,NAME,ORERR) ; from ORWGAPIP 48 D DEL^XPAR(ENTITY,PARAM,NAME,.ORERR) 49 Q 50 XEN(ENTITY,PARAM,NAME,ORVAL,ORERR) ; from ORWGAPIP 51 D EN^XPAR(ENTITY,PARAM,NAME,.ORVAL,.ORERR) 52 Q 53 XENVAL(ORVALUES,PARAM) ; 54 D ENVAL^XPAR(.ORVALUES,PARAM) 55 Q 56 XGET(ENTITY,PARAM,INST,FORMAT) ; $$(...) -> parameter values 57 Q $$GET^XPAR(ENTITY,PARAM,INST,FORMAT) 58 XGETLST(ORLIST,ENTITY,PARAM) ; from ORWGAPIP 59 D GETLST^XPAR(.ORLIST,ENTITY,PARAM) 60 Q 61 XGETLST1(ORLIST,ENTITY,PARAM,FORMAT,ORERR) ; from ORWGAPIP 62 D GETLST^XPAR(.ORLIST,ENTITY,PARAM,FORMAT,.ORERR) 63 Q 64 XGETWP(ORWP,ENTITY,PARAM,ALL) ; from ORWGAPIP 65 D GETWP^XPAR(.ORWP,ENTITY,PARAM,ALL) 66 Q 67 ; kernel functions 68 FMADD(X,D,H,M,S) ; 69 Q $$FMADD^XLFDT(X,$G(D),$G(H),$G(M),$G(S)) 70 NOW() ; 71 Q $$NOW^XLFDT 72 LOW(X) ; 73 Q $$LOW^XLFSTR(X) 74 REPLACE(STRING,ORARRAY) ; 75 Q $$REPLACE^XLFSTR(STRING,.ORARRAY) 76 TRIM(X,F,V) ; 77 Q $$TRIM^XLFSTR(X,$G(F,"LR"),$G(V," ")) 78 UP(X) ; 79 Q $$UP^XLFSTR(X) 80 BMIITEMS(ITEMS,CNT,TMP) ; from ORWGAPIR 81 N BMI,NUM,REPLACE K REPLACE 82 S REPLACE("WEIGHT")="BODY MASS INDEX" 83 S BMI="" 84 S NUM=0 85 I 'TMP D 86 . F S NUM=$O(ITEMS(NUM)) Q:NUM<1 D 87 .. I $P(ITEMS(NUM),U,2)=8 S $P(BMI,U)=1 88 .. I $P(ITEMS(NUM),U,2)=9 S $P(BMI,U,2)=ITEMS(NUM) 89 I TMP D 90 . F S NUM=$O(^TMP(ITEMS,$J,NUM)) Q:NUM<1 D 91 .. I $P(^TMP(ITEMS,$J,NUM),U,2)=8 S $P(BMI,U)=1 92 .. I $P(^TMP(ITEMS,$J,NUM),U,2)=9 S $P(BMI,U,2)=^TMP(ITEMS,$J,NUM) 93 I BMI,$L(BMI)>3 D 94 . S CNT=CNT+1 95 . S RESULT=$P(BMI,U,2,99) 96 . S RESULT=$$REPLACE^ORWGAPIX(RESULT,.REPLACE) 97 . S $P(RESULT,U,2)=99999 98 . D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) 99 Q 100 ; 101 BMIDATA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPI4 102 N DATE,DATE2,NODE,RESULT,VALUE,W K VALUE 103 S DATE="",DATE2="",CNT=$G(CNT) 104 F S DATE=$O(^PXRMINDX(120.5,"PI",DFN,9,DATE)) Q:DATE="" D 105 . I DATE>START Q 106 . S NODE="" 107 . F S NODE=$O(^PXRMINDX(120.5,"PI",DFN,9,DATE,NODE)) Q:NODE="" D 108 .. D VITAL^ORWGAPIA(.VALUE,NODE) S WT=$P($G(VALUE(7)),U) I 'WT Q 109 .. S BMI=$$BMI(DFN,WT,DATE) I 'BMI Q 110 .. S RESULT=120.5_U_ITEM_U_DATE_U_DATE2_U_BMI 111 .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) 112 Q 113 ; 114 BMI(DFN,WT,DATE) ; $$(dfn,wt,date) -> bmi, else "" 115 N HDATE,HT,NEXT,NODE,PREV 116 I '$O(^PXRMINDX(120.5,"PI",DFN,8,0)) Q "" 117 S NODE=$O(^PXRMINDX(120.5,"PI",DFN,8,DATE,"")) 118 I '$L(NODE) D 119 . S NEXT=+$O(^PXRMINDX(120.5,"PI",DFN,8,DATE)) 120 . S PREV=+$O(^PXRMINDX(120.5,"PI",DFN,8,DATE),-1) 121 . S NODE=$O(^PXRMINDX(120.5,"PI",DFN,8,$$CLOSEST(DATE,NEXT,PREV),"")) 122 I '$L(NODE) Q "" 123 D VITAL^ORWGAPIA(.VALUE,NODE) S HT=$P($G(VALUE(7)),U) I 'HT Q "" 124 Q $$CALCBMI(HT,WT) 125 ; 126 CALCBMI(HT,WT) ; $$(ht,wt) -> bmi uses (inches,lbs) 127 S WT=WT/2.2 ;+$$WEIGHT^XLFMSMT(WT,"LB","KG") 128 S HT=HT*2.54/100 ;+$$LENGTH^XLFMSMT(HT,"IN","M") 129 Q $J(WT/(HT*HT),0,2) 130 ; 131 CLOSEST(DATE,NEXT,PREV) ; 132 I $$FMDIFF^XLFDT(DATE,NEXT,2)>$$FMDIFF^XLFDT(DATE,PREV,2) Q PREV 133 Q NEXT 134 ; 135 BMILAST(DFN,ARRAY,CNT) ; 136 N BMI,DATE,NUM,WT 137 S (DATE,NUM,WT)=0 138 F S NUM=$O(ARRAY(NUM)) Q:NUM<1 D Q:WT 139 . I $P(ARRAY(NUM),U,2)'="WT" Q 140 . S WT=+$P(ARRAY(NUM),U,3) 141 . S DATE=$P(ARRAY(NUM),U,4) 142 I 'WT Q 143 I 'DATE Q 144 S BMI=$$BMI(DFN,WT,DATE) 145 I 'BMI Q 146 S CNT=CNT+1 147 S ARRAY(CNT)="-1^BMI^"_BMI_U_DATE_U_BMI_"^^" 148 Q 149 ; 150 ZZ() ; test use only - this code will be removed before v27 release 151 N X,ZIP,ZZ 152 S ZZ=$C(36)_$C(90)_$C(72) 153 S ZIP="S X="_ZZ X ZIP 154 Q X 1 ORWGAPIX ; SLC/STAFF - Graph External Calls ;9/29/06 11:49 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26 3 ; 4 DATE(X) ; $$(date/time) -> date/time 5 N Y D ^%DT 6 Q Y 7 ENDIQ1(RESULTS,DIC,DR,DA,DIQ) ; use file # for DIC 8 N NUMDIC K RESULTS,^UTILITY("DIQ1",$J) 9 Q:'$G(DIC) Q:'$L(DR) Q:'$G(DA) 10 S NUMDIC=DIC 11 D EN^DIQ1 12 M RESULTS=^UTILITY("DIQ1",$J,NUMDIC,DA) 13 K ^UTILITY("DIQ1",$J) 14 Q 15 EXT(Y,FILE,FIELD) ; $$(value,file,field) -> external value 16 N C S C=$P($G(^DD(FILE,FIELD,0)),U,2) D Y^DIQ 17 Q Y 18 EXTERNAL(FILE,FIELD,FLAG,VAL) ; $$(file,field,flag,internal value) -> external value 19 Q $$EXTERNAL^DILFD(FILE,FIELD,FLAG,VAL) 20 EXTNAME(IEN,FN) ; $$(ien,file#) -> external form of pointer 21 N REF 22 S REF=$G(^DIC(FN,0,"GL")) 23 I $L(REF),+IEN Q $P($G(@(REF_IEN_",0)")),U) 24 Q "" 25 FILENM(FILENUM) ; $$(file#) -> file name 26 N DIC,DO,NAME K DIC,DO 27 S FILENUM=$$GBLREF(+$G(FILENUM)) 28 I '$L($G(FILENUM)) Q "" 29 S DIC=FILENUM 30 D DO^DIC1 31 S NAME=$P(DO,U) 32 Q NAME 33 GETDATA(RESULTS,DIC,DR,DA,DIQ) ; use file # for DIC 34 N NUMDIC K RESULTS,^UTILITY("DIQ1",$J) 35 Q:'$G(DIC) Q:'$L(DR) Q:'$G(DA) 36 S NUMDIC=DIC 37 D EN^DIQ1 38 M RESULTS=^UTILITY("DIQ1",$J,NUMDIC,DA) 39 K ^UTILITY("DIQ1",$J) 40 Q 41 GBLREF(FILENUM) ; $$(file#) -> global reference 42 I '$G(FILENUM) Q "" 43 Q $$ROOT^DILFD(+FILENUM) 44 INDEX(DIK,DA) ; index entry in file - from ORWGAPIP 45 D IX1^DIK 46 Q 47 XDEL(ENTITY,PARAM,NAME,ORERR) ; from ORWGAPIP 48 D DEL^XPAR(ENTITY,PARAM,NAME,.ORERR) 49 Q 50 XEN(ENTITY,PARAM,NAME,ORVAL,ORERR) ; from ORWGAPIP 51 D EN^XPAR(ENTITY,PARAM,NAME,.ORVAL,.ORERR) 52 Q 53 XENVAL(ORVALUES,PARAM) ; 54 D ENVAL^XPAR(.ORVALUES,PARAM) 55 Q 56 XGET(ENTITY,PARAM,INST,FORMAT) ; $$(...) -> parameter values 57 Q $$GET^XPAR(ENTITY,PARAM,INST,FORMAT) 58 XGETLST(ORLIST,ENTITY,PARAM) ; from ORWGAPIP 59 D GETLST^XPAR(.ORLIST,ENTITY,PARAM) 60 Q 61 XGETLST1(ORLIST,ENTITY,PARAM,FORMAT,ORERR) ; from ORWGAPIP 62 D GETLST^XPAR(.ORLIST,ENTITY,PARAM,FORMAT,.ORERR) 63 Q 64 XGETWP(ORWP,ENTITY,PARAM,ALL) ; from ORWGAPIP 65 D GETWP^XPAR(.ORWP,ENTITY,PARAM,ALL) 66 Q 67 ; kernel functions 68 FMADD(X,D,H,M,S) ; 69 Q $$FMADD^XLFDT(X,$G(D),$G(H),$G(M),$G(S)) 70 NOW() ; 71 Q $$NOW^XLFDT 72 LOW(X) ; 73 Q $$LOW^XLFSTR(X) 74 REPLACE(STRING,ORARRAY) ; 75 Q $$REPLACE^XLFSTR(STRING,.ORARRAY) 76 TRIM(X,F,V) ; 77 Q $$TRIM^XLFSTR(X,$G(F,"LR"),$G(V," ")) 78 UP(X) ; 79 Q $$UP^XLFSTR(X) 80 INSIG(NODE) ; $$(node) -> sig ; replace INSIG^ORWGAPIA with this code in v27 81 N SIG,SUB,VALUES K VALUES 82 S SUB=$P($G(NODE),";",2) 83 D RXIN^ORWGAPIA(NODE,.VALUES) 84 S SIG="" 85 I SUB=5 D 86 . S SIG=" Give: "_$G(VALUES("MR")) 87 . S SIG=SIG_" "_$P($G(VALUES("SCH",1,0)),U) 88 . S SIG=SIG_" "_$P($G(VALUES("SCH",1,0)),U,2) 89 I SUB="IV" D 90 . S SIG=" Give: "_$G(VALUES("DO")) 91 . S SIG=SIG_" "_$$EXT^ORWGAPIX($G(VALUES("START")),55.01,.02) 92 . S SIG=SIG_" "_$G(VALUES("SCH",1,0)) 93 Q SIG 94 ; 95 BMIITEMS(ITEMS,CNT,TMP) ; from ORWGAPIR 96 N BMI,NUM,REPLACE K REPLACE 97 S REPLACE("WEIGHT")="BODY MASS INDEX" 98 S BMI="" 99 S NUM=0 100 I 'TMP D 101 . F S NUM=$O(ITEMS(NUM)) Q:NUM<1 D 102 .. I $P(ITEMS(NUM),U,2)=8 S $P(BMI,U)=1 103 .. I $P(ITEMS(NUM),U,2)=9 S $P(BMI,U,2)=ITEMS(NUM) 104 I TMP D 105 . F S NUM=$O(^TMP(ITEMS,$J,NUM)) Q:NUM<1 D 106 .. I $P(^TMP(ITEMS,$J,NUM),U,2)=8 S $P(BMI,U)=1 107 .. I $P(^TMP(ITEMS,$J,NUM),U,2)=9 S $P(BMI,U,2)=^TMP(ITEMS,$J,NUM) 108 I BMI,$L(BMI)>3 D 109 . S CNT=CNT+1 110 . S RESULT=$P(BMI,U,2,99) 111 . S RESULT=$$REPLACE^ORWGAPIX(RESULT,.REPLACE) 112 . S $P(RESULT,U,2)=99999 113 . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) 114 Q 115 ; 116 BMIDATA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPI4 117 N DATE,DATE2,NODE,RESULT,VALUE,W K VALUE 118 S DATE="",DATE2="",CNT=$G(CNT) 119 F S DATE=$O(^PXRMINDX(120.5,"PI",DFN,9,DATE)) Q:DATE="" D 120 . I DATE>START Q 121 . S NODE="" 122 . F S NODE=$O(^PXRMINDX(120.5,"PI",DFN,9,DATE,NODE)) Q:NODE="" D 123 .. D VITAL^ORWGAPIA(.VALUE,NODE) S WT=$P($G(VALUE(7)),U) I 'WT Q 124 .. S BMI=$$BMI(DFN,WT,DATE) I 'BMI Q 125 .. S RESULT=120.5_U_ITEM_U_DATE_U_DATE2_U_BMI 126 .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) 127 Q 128 ; 129 BMI(DFN,WT,DATE) ; $$(dfn,wt,date) -> bmi, else "" 130 N HDATE,HT,NEXT,NODE,PREV 131 I '$O(^PXRMINDX(120.5,"PI",DFN,8,0)) Q "" 132 S NODE=$O(^PXRMINDX(120.5,"PI",DFN,8,DATE,"")) 133 I '$L(NODE) D 134 . S NEXT=+$O(^PXRMINDX(120.5,"PI",DFN,8,DATE)) 135 . S PREV=+$O(^PXRMINDX(120.5,"PI",DFN,8,DATE),-1) 136 . S NODE=$O(^PXRMINDX(120.5,"PI",DFN,8,$$CLOSEST(DATE,NEXT,PREV),"")) 137 I '$L(NODE) Q "" 138 D VITAL^ORWGAPIA(.VALUE,NODE) S HT=$P($G(VALUE(7)),U) I 'HT Q "" 139 Q $$CALCBMI(HT,WT) 140 ; 141 CALCBMI(HT,WT) ; $$(ht,wt) -> bmi uses (inches,lbs) 142 S WT=WT/2.2 ;+$$WEIGHT^XLFMSMT(WT,"LB","KG") 143 S HT=HT*2.54/100 ;+$$LENGTH^XLFMSMT(HT,"IN","M") 144 Q $J(WT/(HT*HT),0,2) 145 ; 146 CLOSEST(DATE,NEXT,PREV) ; 147 I $$FMDIFF^XLFDT(DATE,NEXT,2)>$$FMDIFF^XLFDT(DATE,PREV,2) Q PREV 148 Q NEXT 149 ; 150 BMILAST(DFN,ARRAY,CNT) ; 151 N BMI,DATE,NUM,WT 152 S (DATE,NUM,WT)=0 153 F S NUM=$O(ARRAY(NUM)) Q:NUM<1 D Q:WT 154 . I $P(ARRAY(NUM),U,2)'="WT" Q 155 . S WT=+$P(ARRAY(NUM),U,3) 156 . S DATE=$P(ARRAY(NUM),U,4) 157 I 'WT Q 158 I 'DATE Q 159 S BMI=$$BMI(DFN,WT,DATE) 160 I 'BMI Q 161 S CNT=CNT+1 162 S ARRAY(CNT)="-1^BMI^"_BMI_U_DATE_U_BMI_"^^" 163 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGRPC.m
r613 r623 1 ORWGRPC ; SLC/STAFF - Graph RPC ;3/9/06 13:59 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 3 ; 4 ALLITEMS(ITEMS,DFN) ; RPC - get all items of data on patient (procedures, tests, codes,..) 5 D ALLITEMS^ORWGAPI("ORWGRPC",DFN) 6 S ITEMS=$NA(^TMP("ORWGRPC",$J)) 7 Q 8 ; 9 ALLVIEWS(DATA,VIEW,USER) ; RPC - get all graph views 10 D ALLVIEWS^ORWGAPI("ORWGRPC",+$G(VIEW),+$G(USER)) 11 S DATA=$NA(^TMP("ORWGRPC",$J)) 12 Q 13 ; 14 CLASS(DATA,TYPE) ; RPC - get classifications 15 D CLASS^ORWGAPI("ORWGRPC",TYPE) 16 S DATA=$NA(^TMP("ORWGRPC",$J)) 17 Q 18 ; 19 DATEDATA(DATA,OLDEST,NEWEST,TYPEITEM,DFN) ; RPC - get data for an item on patient in date range 20 D DATEDATA^ORWGAPI("ORWGRPC",OLDEST,NEWEST,TYPEITEM,DFN) 21 S DATA=$NA(^TMP("ORWGRPC",$J)) 22 Q 23 ; 24 DATEITEM(DATA,OLDEST,NEWEST,FNUM,DFN) ; RPC - get patient items in date range for a type 25 D DATEITEM^ORWGAPI("ORWGRPC",OLDEST,NEWEST,FNUM,DFN) 26 S DATA=$NA(^TMP("ORWGRPC",$J)) 27 Q 28 ; 29 DELVIEWS(ERR,NAME,PUBLIC) ; RPC - delete a graph view 30 D DELVIEWS^ORWGAPI("ORWGRPC",NAME,+$G(PUBLIC)) 31 S ERR=$NA(^TMP("ORWGRPC",$J)) 32 Q 33 ; 34 DETAIL(ITEMS,DFN,DATE1,DATE2,VAL,COMP) ; RPC - get all reports for types of data from items and date range 35 D DETAIL^ORWGAPI("ORWGRPC",DFN,DATE1,DATE2,.VAL,$G(COMP)) 36 S ITEMS=$NA(^TMP("ORWGRPC",$J)) 37 Q 38 ; 39 DETAILS(ITEMS,DFN,DATE1,DATE2,TYPE,COMP) ; RPC - get report for type of data for a date or date range 40 D DETAILS^ORWGAPI("ORWGRPC",DFN,DATE1,DATE2,TYPE,$G(COMP)) 41 S ITEMS=$NA(^TMP("ORWGRPC",$J)) 42 Q 43 ; 44 FASTDATA(DATA,DFN) ; RPC - get all data (non-lab) set up on patient 45 D FASTDATA^ORWGAPI(.DATA,DFN) 46 Q 47 ; 48 FASTITEM(ITEMS,DFN) ; RPC - get all items set up on patient 49 D FASTITEM^ORWGAPI(.ITEMS,DFN) 50 Q 51 ; 52 FASTLABS(DATA,DFN) ; RPC - get all lab data set up on patient 53 D FASTLABS^ORWGAPI(.DATA,DFN) 54 Q 55 ; 56 FASTTASK(STATUS,DFN,OLDDFN) ; set up all data and items on patient 57 D FASTTASK^ORWGAPI(.STATUS,DFN,$G(OLDDFN)) 58 Q 59 ; 60 GETDATES(DATA,REPORTID) ; RPC - get graph date range 61 D GETDATES^ORWGAPI("ORWGRPC",$G(REPORTID)) 62 S DATA=$NA(^TMP("ORWGRPC",$J)) 63 Q 64 ; 65 GETPREF(DATA) ; RPC - get graph settings 66 D GETPREF^ORWGAPI("ORWGRPC") 67 S DATA=$NA(^TMP("ORWGRPC",$J)) 68 Q 69 ; 70 GETSIZE(DATA) ; RPC - get graph positions and sizes 71 D GETSIZE^ORWGAPI("ORWGRPC") 72 S DATA=$NA(^TMP("ORWGRPC",$J)) 73 Q 74 ; 75 GETVIEWS(DATA,ALL,PUBLIC,EXT,USER) ; RPC - get graph views 76 D GETVIEWS^ORWGAPI("ORWGRPC",ALL,+$G(PUBLIC),+$G(EXT),+$G(USER)) 77 S DATA=$NA(^TMP("ORWGRPC",$J)) 78 Q 79 ; 80 ITEMDATA(DATA,ITEM,START,DFN) ; RPC - get data of an item on patient (glucose results) 81 D ITEMDATA^ORWGAPI("ORWGRPC",ITEM,START,DFN) 82 S DATA=$NA(^TMP("ORWGRPC",$J)) 83 Q 84 ; 85 ITEMS(ITEMS,DFN,TYPE) ; RPC - get items of a type of data on patient (lab tests) 86 D ITEMS^ORWGAPI("ORWGRPC",DFN,TYPE) 87 S ITEMS=$NA(^TMP("ORWGRPC",$J)) 88 Q 89 ; 90 LOOKUP(VAL,INFO,FROM,DIR) ; RPC - get item names for long lookup 91 D LOOKUP^ORWGAPI(.VAL,INFO,.FROM,DIR) 92 Q 93 ; 94 PUBLIC(VAL) ; RPC - check if user can edit public views and settings 95 S VAL=$$PUBLIC^ORWGAPI(DUZ) 96 Q 97 ; 98 RPTPARAM(VAL,IEN) ; RPC - return PARAM1^PARAM2 for graph report 99 S VAL=$$RPTPARAM^ORWGAPI(IEN) 100 Q 101 ; 102 SETPREF(ERR,SETTING,PUBLIC) ; RPC - set a graph setting 103 D SETPREF^ORWGAPI("ORWGRPC",SETTING,+$G(PUBLIC)) 104 S ERR=$NA(^TMP("ORWGRPC",$J)) 105 Q 106 ; 107 SETSIZE(ERR,VAL) ; RPC - set graph positions and sizes 108 D SETSIZE^ORWGAPI("ORWGRPC",.VAL) 109 S ERR=$NA(^TMP("ORWGRPC",$J)) 110 Q 111 ; 112 SETVIEWS(ERR,NAME,PUBLIC,VAL) ; RPC - set a graph view 113 D SETVIEWS^ORWGAPI("ORWGRPC",NAME,+$G(PUBLIC),.VAL) 114 S ERR=$NA(^TMP("ORWGRPC",$J)) 115 Q 116 ; 117 TAX(DATA,ALL,REMTAX) ; RPC - get reminder taxonomies 118 D TAX^ORWGAPI("ORWGRPC",+$G(ALL),.REMTAX) 119 S DATA=$NA(^TMP("ORWGRPC",$J)) 120 Q 121 ; 122 TESTING(DATA) ; RPC - cache data 123 D TESTING^ORWGAPI("ORWGRPC") 124 S DATA=$NA(^TMP("ORWGRPC",$J)) 125 Q 126 ; 127 TESTSPEC(DATA) ; RPC - get test/spec info on all lab tests 128 D TESTSPEC^ORWGAPI("ORWGRPC") 129 S DATA=$NA(^TMP("ORWGRPC",$J)) 130 Q 131 ; 132 TYPES(TYPES,DFN,SUB) ; RPC - get all the types of data on a patient (SUB=1, gets subtypes, DFN=0 gets all types), 133 D TYPES^ORWGAPI("ORWGRPC",DFN,+$G(SUB)) 134 S TYPES=$NA(^TMP("ORWGRPC",$J)) 135 Q 136 ; 1 ORWGRPC ; SLC/STAFF - Graph RPC ;3/9/06 13:59 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 3 ; 4 ALLITEMS(ITEMS,DFN) ; RPC - get all items of data on patient (procedures, tests, codes,..) 5 D ALLITEMS^ORWGAPI("ORWGRPC",DFN) 6 S ITEMS=$NA(^TMP("ORWGRPC",$J)) 7 Q 8 ; 9 CLASS(DATA,TYPE) ; RPC - get classifications 10 D CLASS^ORWGAPI("ORWGRPC",TYPE) 11 S DATA=$NA(^TMP("ORWGRPC",$J)) 12 Q 13 ; 14 DATEITEM(DATA,OLDEST,NEWEST,FNUM,DFN) ; RPC - get patient items in date range for a type 15 D DATEITEM^ORWGAPI("ORWGRPC",OLDEST,NEWEST,FNUM,DFN) 16 S DATA=$NA(^TMP("ORWGRPC",$J)) 17 Q 18 ; 19 DELVIEWS(ERR,NAME,PUBLIC) ; RPC - delete a graph view 20 D DELVIEWS^ORWGAPI("ORWGRPC",NAME,+$G(PUBLIC)) 21 S ERR=$NA(^TMP("ORWGRPC",$J)) 22 Q 23 ; 24 DETAIL(ITEMS,DFN,DATE1,DATE2,VAL,COMP) ; RPC - get all reports for types of data from items and date range 25 D DETAIL^ORWGAPI("ORWGRPC",DFN,DATE1,DATE2,.VAL,$G(COMP)) 26 S ITEMS=$NA(^TMP("ORWGRPC",$J)) 27 Q 28 ; 29 DETAILS(ITEMS,DFN,DATE1,DATE2,TYPE,COMP) ; RPC - get report for type of data for a date or date range 30 D DETAILS^ORWGAPI("ORWGRPC",DFN,DATE1,DATE2,TYPE,$G(COMP)) 31 S ITEMS=$NA(^TMP("ORWGRPC",$J)) 32 Q 33 ; 34 GETDATES(DATA,REPORTID) ; RPC - get graph date range 35 D GETDATES^ORWGAPI("ORWGRPC",$G(REPORTID)) 36 S DATA=$NA(^TMP("ORWGRPC",$J)) 37 Q 38 ; 39 GETPREF(DATA) ; RPC - get graph settings 40 D GETPREF^ORWGAPI("ORWGRPC") 41 S DATA=$NA(^TMP("ORWGRPC",$J)) 42 Q 43 ; 44 GETSIZE(DATA) ; RPC - get graph positions and sizes 45 D GETSIZE^ORWGAPI("ORWGRPC") 46 S DATA=$NA(^TMP("ORWGRPC",$J)) 47 Q 48 ; 49 GETVIEWS(DATA,ALL,PUBLIC,EXT) ; RPC - get graph views 50 D GETVIEWS^ORWGAPI("ORWGRPC",ALL,+$G(PUBLIC),+$G(EXT)) 51 S DATA=$NA(^TMP("ORWGRPC",$J)) 52 Q 53 ; 54 ITEMDATA(DATA,ITEM,START,DFN) ; RPC - get data of an item on patient (glucose results) 55 S ITEM=$$UP^ORWGAPIX(ITEM) 56 D ITEMDATA^ORWGAPI("ORWGRPC",ITEM,START,DFN) 57 S DATA=$NA(^TMP("ORWGRPC",$J)) 58 Q 59 ; 60 ITEMS(ITEMS,DFN,TYPE) ; RPC - get items of a type of data on patient (lab tests) 61 D ITEMS^ORWGAPI("ORWGRPC",DFN,TYPE) 62 S ITEMS=$NA(^TMP("ORWGRPC",$J)) 63 Q 64 ; 65 LOOKUP(VAL,INFO,FROM,DIR) ; RPC - get item names for long lookup 66 D LOOKUP^ORWGAPI(.VAL,INFO,.FROM,DIR) 67 Q 68 ; 69 PUBLIC(VAL) ; RPC - check if user can edit public views and settings 70 S VAL=$$PUBLIC^ORWGAPI(DUZ) 71 Q 72 ; 73 RPTPARAM(VAL,IEN) ; RPC - return PARAM1^PARAM2 for graph report 74 S VAL=$$RPTPARAM^ORWGAPI(IEN) 75 Q 76 ; 77 SETPREF(ERR,SETTING,PUBLIC) ; RPC - set a graph setting 78 D SETPREF^ORWGAPI("ORWGRPC",SETTING,+$G(PUBLIC)) 79 S ERR=$NA(^TMP("ORWGRPC",$J)) 80 Q 81 ; 82 SETSIZE(ERR,VAL) ; RPC - set graph positions and sizes 83 D SETSIZE^ORWGAPI("ORWGRPC",.VAL) 84 S ERR=$NA(^TMP("ORWGRPC",$J)) 85 Q 86 ; 87 SETVIEWS(ERR,NAME,PUBLIC,VAL) ; RPC - set a graph view 88 D SETVIEWS^ORWGAPI("ORWGRPC",NAME,+$G(PUBLIC),.VAL) 89 S ERR=$NA(^TMP("ORWGRPC",$J)) 90 Q 91 ; 92 TAX(DATA,ALL,REMTAX) ; RPC - get reminder taxonomies 93 D TAX^ORWGAPI("ORWGRPC",+$G(ALL),.REMTAX) 94 S DATA=$NA(^TMP("ORWGRPC",$J)) 95 Q 96 ; 97 TESTSPEC(DATA) ; RPC - get test/spec info on all lab tests 98 D TESTSPEC^ORWGAPI("ORWGRPC") 99 S DATA=$NA(^TMP("ORWGRPC",$J)) 100 Q 101 ; 102 TYPES(TYPES,DFN,SUB) ; RPC - get all the types of data on a patient (SUB=1, gets subtypes, DFN=0 gets all types), 103 D TYPES^ORWGAPI("ORWGRPC",DFN,+$G(SUB)) 104 S TYPES=$NA(^TMP("ORWGRPC",$J)) 105 Q 106 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWNSS.m
r613 r623 1 ORWNSS ;JDL/SLC Non-Standard Schedule ;11/24/062 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195,243**;Dec 17, 1997;Build 242 3 NSSOK(ORY,ORX) 4 5 6 7 8 NSSMSG(ORY) 9 10 11 12 13 14 VALSCH(ORY,ORID) 15 16 17 18 19 20 21 22 23 24 25 26 27 28 . D VALSCH^ORWDPS33(.ORY,SCHVAL,"I")29 30 31 QOSCH(ORY,QOID) 32 33 34 35 36 37 38 39 40 41 42 43 44 . D VALSCH^ORWDPS33(.RST,SCHVAL,"I")45 46 47 CHKSCH(ORY,SCH) 48 49 D VALSCH^ORWDPS33(.ORY,SCH,"I")50 1 ORWNSS ;JDL/SLC Non-Standard Schedule ;12/9/04 12:02 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195**;Dec 17, 1997 3 NSSOK(ORY,ORX) ;Check availability for Non-standard schedule 4 N VAL 5 S VAL=$$PATCH^XPDUTL("PSJ*5.0*113") 6 S ORY=VAL 7 Q 8 NSSMSG(ORY) ;Retrieve site message for None-Standard Schedule 9 N ORSRV 10 S ORY="" 11 S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) 12 S ORY=$$GET^XPAR("SRV.`"_+$G(ORSRV)_"^DIV^SYS","ORWIM NSS MESSAGE",1,"I") 13 Q 14 VALSCH(ORY,ORID) ;Validate a schedule for IM order; 1: valid, 0: invalid 15 ; 16 S ORY=0 17 Q:'$D(^OR(100,+ORID,0)) 18 N IPGRP,ORGRP 19 S IPGRP=$O(^ORD(100.98,"B","UD RX",0)) 20 S ORGRP=$P($G(^OR(100,+ORID,0)),U,11) 21 I ORGRP'=IPGRP S ORY=1 Q 22 N SCH,IDX,SCHVAL S (SCH,SCHVAL)="" 23 I $D(^OR(100,+ORID,4.5,"ID","SCHEDULE")) S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0)) 24 I SCH="" S ORY=1 Q 25 S IDX=0 F S IDX=$O(^OR(100,+ORID,4.5,SCH,IDX)) Q:'IDX D 26 . S SCHVAL=$G(^OR(100,+ORID,4.5,SCH,IDX)) 27 . Q:'$L(SCHVAL) 28 . D VALSCH^ORWDPS32(.ORY,SCHVAL,"I") 29 . I ORY=0 Q 30 Q 31 QOSCH(ORY,QOID) ;Validate IM QO schedule 32 ;QOID: Inpt Pharmacy QO 33 S ORY="" 34 N QOSCH,SCHID,SCHVAL,RST 35 S SCHID=$O(^ORD(101.41,"B","OR GTX SCHEDULE",0)) 36 S (QOSCH,SCHVAL)="",RST=1 37 I '$D(^ORD(101.41,+QOID,6,"D",SCHID)) S ORY="schedule is not defined." Q 38 S QOSCH=$O(^ORD(101.41,+QOID,6,"D",SCHID,0)) 39 I 'QOSCH S ORY="schedule is not defined." Q 40 N IDX S IDX=0 41 F S IDX=$O(^ORD(101.41,+QOID,6,QOSCH,IDX)) Q:'IDX!('RST) D 42 . S SCHVAL=^ORD(101.41,+QOID,6,QOSCH,IDX) 43 . I $$UP^XLFSTR(SCHVAL)="OTHER" S ORY="OTHER" Q 44 . D VALSCH^ORWDPS32(.RST,SCHVAL,"I") 45 . I RST=0 S ORY="This quick order contains a non-standard administration schedule." Q 46 Q 47 CHKSCH(ORY,SCH) ;Validate schedule 48 Q:SCH="" 49 D VALSCH^ORWDPS32(.ORY,SCH,"I") 50 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWOR.m
r613 r623 1 ORWOR ; SLC/KCM - Orders Calls;10:54 PM 08/15/20062 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,141,163,187,190,215,243**;Dec 17, 1997;Build 242 3 4 CURRENT(LST,DFN) 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 DETAIL(LST,ORID,DFN) 22 23 24 25 26 27 28 29 RESULT(REF,DFN,ORID,ID) 30 31 32 33 34 35 36 RESHIST(REF,DFN,ORID,ID) 37 38 39 40 41 42 43 44 TSALL(LST) 45 46 47 48 DT(X) 49 50 51 VWSET(ORERR,VIEW) 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 VWGET(REC) 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 SHEETS(LST,ORVP) 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 EVENTS(LST,EVT) 109 110 111 112 113 114 115 UNSIGN(LST,ORVP,HAVE) 116 117 118 119 120 121 122 123 124 125 126 127 128 . . . S ILST=ILST+1,LST(ILST)=IFN_";"_ACT_U_$P(X8,U,3) 129 130 PKIUSE(RETURN) 131 132 133 134 PKISITE(RETURN) 135 136 137 138 139 140 ACTXT(ORY,ORIFN) 141 142 143 144 145 146 147 148 EXPIRED(ORY) 149 150 151 152 1 ORWOR ; SLC/KCM - Orders Calls;10:54 PM 02 Feb 2003 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,141,163,187,190,215**;Dec 17, 1997 3 ; 4 CURRENT(LST,DFN) ; Get Current Orders for a Patient 5 ; Returns two lists in ^TMP("ORW",$J), fields and text 6 N TM,IEN,X,X0,X3,CTR,IDX,I 7 K ^TMP("ORW",$J) 8 S IDX=0,DFN=DFN_";DPT(" 9 S TM=0 F S TM=$O(^OR(100,"AC",DFN,TM)) Q:TM<1 D 10 . S IEN=0 F S IEN=$O(^OR(100,"AC",DFN,TM,IEN)) Q:IEN<1 D 11 . . S X0=^OR(100,IEN,0),X3=^(3) 12 . . S X=IEN_U_$P(X0,U,7)_U_$P(X0,U,11)_U_$P(X3,U,6)_U_$P(X3,U,3) 13 . . S ^TMP("ORW",$J,IDX+1)=X 14 . . S (CTR,I)=0,X="" 15 . . F S I=$O(^OR(100,IEN,1,I)) Q:I<1 D Q:CTR>244 16 . . . S X=X_$E(^OR(100,IEN,1,I,0),1,(245-CTR)),CTR=$L(X) 17 . . S ^TMP("ORW",$J,IDX+2)=X,IDX=IDX+2 18 ; S LST=$NA(^TMP("ORW",$J)) 19 M LST=^TMP("ORW",$J) 20 Q 21 DETAIL(LST,ORID,DFN) ; Return details of ORID (shell to kill VIDEO subs) 22 Q:'+ORID 23 I $G(DFN) N ORVP S ORVP=DFN_";DPT(" 24 S LST="^TMP(""ORTXT"",$J)" 25 D DETAIL^ORQ2(.LST,ORID) 26 K @LST@("VIDEO") 27 S LST=$NA(^TMP("ORTXT",$J)),@LST="" 28 Q 29 RESULT(REF,DFN,ORID,ID) ; Return results of order identified by ID 30 K ^TMP("ORXPND",$J) 31 N ORESULTS,ORVP,LCNT S ORESULTS=1,LCNT=0,ORVP=DFN_";DPT(" 32 D ORDERS^ORCXPND1 33 K ^TMP("ORXPND",$J,"VIDEO") 34 S REF=$NA(^TMP("ORXPND",$J)) 35 Q 36 RESHIST(REF,DFN,ORID,ID) ; Return result history of associated tests identified by ID 37 K ^TMP("ORXPND",$J) 38 N ORESULTS,ORVP,LCNT 39 S ORESULTS=1,LCNT=0,ORVP=DFN_";DPT(" 40 D ORDHIST^ORWOR2 41 K ^TMP("ORXPND",$J,"VIDEO") 42 S REF=$NA(^TMP("ORXPND",$J)) 43 Q 44 TSALL(LST) ; Return list of treating specialties 45 N Y S Y=0 46 F S Y=$O(^DIC(45.7,Y)) Q:'Y I $$ACTIVE^DGACT(45.7,Y) S LST(Y)=Y_U_$P(^DIC(45.7,Y,0),U) 47 Q 48 DT(X) ; -- Returns FM date for X (SEE ORCHTAB1) 49 N Y,%DT S %DT="T",Y="" D:X'="" ^%DT 50 Q +Y 51 VWSET(ORERR,VIEW) ; Set the preferred view for orders 52 ; VIEW: semi-colon delimited record 53 ; 1 - Relative From Date/Time or "" 54 ; 2 - Relative Thru Date/Time or "" 55 ; 3 - Filter 56 ; 4 - Display Group Pointer 57 ; 5 - Format (preserve for list manager) 58 ; 6 - chronological display (R or F) 59 ; 7 - sort by display group 60 N FMT 61 ; use short name for display group instead of pointer 62 I $E($P(VIEW,";",2))="T" S $P(VIEW,";",2)=$P($P(VIEW,";",2),"@") ;allows all orders for Today 63 S $P(VIEW,";",4)=$P($G(^ORD(100.98,+$P(VIEW,";",4),0)),U,3) 64 ; use last saved format, since this is used only by LM 65 S FMT=$P($$GET^XPAR("ALL","ORCH CONTEXT ORDERS",1,"I"),";",5) 66 S:'$L(FMT) FMT="L" S $P(VIEW,";",5)=FMT 67 ; and save the parameter 68 D EN^XPAR(DUZ_";VA(200,","ORCH CONTEXT ORDERS",1,VIEW,.ORERR) 69 Q 70 VWGET(REC) ; Get the preferred view for orders 71 N FROM,THRU,FILTER,DGRP,FRMT,CHRN,BYGRP,S,VNAME,FL 72 S REC=$$GET^XPAR("ALL","ORCH CONTEXT ORDERS",1,"I"),S=";" 73 S FROM=$$DT($P(REC,S)),THRU=$$DT($P(REC,S,2)),FILTER=$P(REC,S,3) 74 S DGRP=$P(REC,S,4),FRMT=$P(REC,S,5),CHRN=$P(REC,S,6),BYGRP=$P(REC,S,7) 75 S:'$L(DGRP) DGRP="ALL" S DGRP=+$O(^ORD(100.98,"B",DGRP,0)) 76 I FILTER="" S FILTER=2 ; active orders 77 I CHRN="" S CHRN="R" ; reverse chronological 78 I BYGRP="" S BYGRP=1 ; sort by display group 79 ; set up view name 80 D REVSTS^ORWORDG(.FL) 81 S I=0 F S I=$O(FL(I)) Q:'I Q:+FL(I)=FILTER 82 S VNAME=$P($G(FL(+I)),U,2) 83 I '("^6^8^9^10^19^20^"[(U_FILTER_U)) S VNAME=VNAME_" Orders" 84 I FILTER=2 S VNAME="Active Orders (includes Pending & Recent Activity)" 85 I FILTER=23 S VNAME="Current Orders (Active & Pending Status Only)" 86 S VNAME=VNAME_" - "_$P($G(^ORD(100.98,DGRP,0)),U) 87 I (FROM>0)!(THRU>0) D 88 . S VNAME=VNAME_" ("_$$FMTE^XLFDT(FROM,"2D")_" thru " 89 . S VNAME=VNAME_$S(THRU>0:$$FMTE^XLFDT(THRU,"2D"),1:"")_")" 90 S REC=FROM_S_THRU_S_FILTER_S_DGRP_S_FRMT_S_CHRN_S_BYGRP_S_VNAME 91 Q 92 SHEETS(LST,ORVP) ; Return Order Sheets for a patient 93 N ELST,ETYP,ORIFN,TS,I 94 S ORVP=ORVP_";DPT(" 95 S ETYP="" F S ETYP=$O(^OR(100,"AEVNT",ORVP,ETYP)) Q:ETYP="" D 96 . S ORIFN=0 F S ORIFN=$O(^OR(100,"AEVNT",ORVP,ETYP,ORIFN)) Q:'ORIFN D 97 . . I (ETYP="A")!(ETYP="T") S ELST(ETYP,$P($G(^OR(100,+ORIFN,0)),U,13))="" 98 S LST(1)="C;O^Current View",I=1 99 S TS="" F S TS=$O(ELST("A",TS)) Q:TS="" D 100 . S I=I+1,LST(I)="A;"_TS_U_"Admit to "_$P($G(^DIC(45.7,TS,0)),U) 101 S I=I+1,LST(I)="A;-1^Admit..." 102 S TS="" F S TS=$O(ELST("T",TS)) Q:TS="" D 103 . S I=I+1,LST(I)="T;"_TS_U_"Transfer to "_$P($G(^DIC(45.7,TS,0)),U) 104 I $L($G(^DPT(+ORVP,.1))) D 105 . S I=I+1,LST(I)="T;-1^Transfer..." 106 . S I=I+1,LST(I)="D;0^Discharge" 107 Q 108 EVENTS(LST,EVT) ; Return general delayed events categories for a patient 109 N EVTI 110 S EVTI=0 111 S EVTI=EVTI+1,LST(EVTI)="A;-1^Admit..." 112 S EVTI=EVTI+1,LST(EVTI)="T;-1^Transfer..." 113 S EVTI=EVTI+1,LST(EVTI)="D;0^Discharge" 114 Q 115 UNSIGN(LST,ORVP,HAVE) ; Return Unsigned Orders that are not on client 116 N IFN,ACT,X8,ENT,LVL,TM,ILST S ILST=0 117 Q:'$D(^XUSEC("ORES",DUZ)) 118 S ORVP=ORVP_";DPT(" 119 S ENT="ALL"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+^(5),1:"") 120 S LVL=$$GET^XPAR(ENT,"OR UNSIGNED ORDERS ON EXIT") 121 Q:'LVL 122 S TM=0 F S TM=$O(^OR(100,"AS",ORVP,TM)) Q:TM<1 D 123 . S IFN=0 F S IFN=$O(^OR(100,"AS",ORVP,TM,IFN)) Q:IFN<1 D 124 . . S ACT=0 F S ACT=$O(^OR(100,"AS",ORVP,TM,IFN,ACT)) Q:ACT<1 D 125 . . . Q:$D(HAVE(IFN_";"_ACT)) ;in Changes 126 . . . S X8=$G(^OR(100,IFN,8,ACT,0)) 127 . . . I '$S(LVL=1&($P(X8,U,3)=DUZ):1,LVL=2:1,1:0) Q ;chk user 128 . . . S ILST=ILST+1,LST(ILST)=IFN_";"_ACT 129 Q 130 PKIUSE(RETURN) ; RPC determines user can use PKI Digital Signature 131 S RETURN=0 132 I $$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q") S RETURN=1 133 Q 134 PKISITE(RETURN) ; RPC determines if PKI is turned on at the site 135 S RETURN=0 136 Q:'$L($T(STORESIG^XUSSPKI)) ;Check for Kernel piece 137 Q:'$L($T(DOSE^PSSOPKI1)) ;Check for Pharmacy piece 138 I $$GET^XPAR("ALL","ORWOR PKI SITE",1,"Q") S RETURN=1 139 Q 140 ACTXT(ORY,ORIFN) ;Return detail action information 141 N ORI,CNT,OR0,OR3,OR6 142 K ^TMP("ORACTXT",$J) 143 S ORY="^TMP(""ORACTXT"",$J)",ORI=$P(ORIFN,";",2) 144 S CNT=0,ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)) 145 F S ORI=$O(^OR(100,+ORIFN,8,ORI)) Q:ORI'>0 S ACTION=$G(^(ORI,0)) D ACT^ORQ20 146 S ORY=$NA(^TMP("ORACTXT",$J)),@ORY="" 147 Q 148 EXPIRED(ORY) ;return FM date/time to begin search for expired orders 149 N HRS 150 S HRS=$$GET^XPAR("ALL","ORWOR EXPIRED ORDERS",1,"I") 151 S ORY=$$FMADD^XLFDT($$NOW^XLFDT,"","-"_HRS,"","") 152 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORB.m
r613 r623 1 ORWORB 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,148,173,190,215,243**;Dec 17, 1997;Build 242 3 4 URGENLST(ORY) 5 6 7 8 9 10 FASTUSER(ORY) 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 GETDATA(ORY,XQAID) 71 72 73 74 75 76 77 78 79 80 81 82 KILUNSNO(Y,ORVP) 83 84 85 86 87 UNFLORD( ORY,DFN,XQAID); -- auto-unflag orders?/delete alert88 89 90 91 92 93 94 95 96 97 98 . . I ORIFN,$D(^OR(100,+ORIFN,0)) S $P(^(8,ORA,3),U)=0,$P(^(3),U,6,8)=ORUNF D MSG^ORCFLAG(ORIFN); unflag99 100 101 KILEXMED(Y,ORDFN) 102 103 104 105 106 107 108 109 110 111 112 113 KILEXOI(Y,ORDFN,ORNIFN) 114 115 116 117 118 119 120 121 122 123 KILUNVOR(Y,ORDFN) 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 KILUNVMD(Y,ORDFN) 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 ESORD(ORY,XQAID) 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 TXTFUP(ROOT,DFN,NOTIF,XQADATA) 184 185 186 187 188 CHGRAD 189 190 191 192 193 194 GETSORT(ORY) 195 196 197 198 SETSORT(ORERR,SORT,DIR) 199 200 201 1 ORWORB ; slc/dee/REV/CLA - RPC functions which return user alert ;10:12 am JAN 31, 2001 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,148,173,190,215**;Dec 17, 1997 3 ; 4 URGENLST(ORY) ;return array of the urgency for the notification 5 N ORSRV,ORERROR 6 S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) 7 D GETLST^XPAR(.ORY,"USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORB URGENCY","I",.ORERROR) 8 Q 9 ; 10 FASTUSER(ORY) ;return current user's notifications across all patients 11 N STRTDATE,STOPDATE,ORTOT,I,ORURG,URG,ORN,SORT,ORN0,URGLIST,REMLIST,REM,NONORLST,NONOR 12 N ALRT,ALRTDT,ALRTPT,ALRTMSG,ALRTI,ALRTLOC,ALRTXQA,J,FWDBY,PRE,ALRTDFN 13 K ^TMP("ORBG",$J) 14 S STRTDATE="",STOPDATE="",FWDBY="Forwarded by: " 15 D GETUSER1^XQALDATA("^TMP(""ORB"",$J)",DUZ,STRTDATE,STOPDATE) 16 S ORTOT=^TMP("ORB",$J) 17 D URGLIST^ORQORB(.URGLIST) 18 D REMLIST^ORQORB(.REMLIST) 19 D REMNONOR^ORQORB(.NONORLST) 20 S J=0 21 F I=1:1:ORTOT D 22 .S ALRTDFN="" 23 .S ALRT=^TMP("ORB",$J,I) 24 .S PRE=$E(ALRT,1,1) 25 .S ALRTXQA=$P(ALRT,U,2) ;XQAID 26 .S NONOR="" F S NONOR=$O(NONORLST(NONOR)) Q:NONOR="" D 27 ..I ALRTXQA[NONOR S REM=1 ;allow this type of alert to be Removed 28 .S ALRTMSG=$P($P(ALRT,U),PRE_" ",2) 29 .I $E(ALRT,4,8)'="-----" D ;not forwarded alert info/comment 30 ..S ORURG="n/a" 31 ..S ALRTI=$P(ALRT," ") 32 ..S ALRTPT="" 33 ..S ALRTLOC="" 34 ..I $E($P(ALRTXQA,";"),1,3)="TIU" S ORURG="Moderate" 35 ..I $P(ALRTXQA,",")="OR" D 36 ...S ORN=$P($P(ALRTXQA,";"),",",3) 37 ...S URG=$G(URGLIST(ORN)) 38 ...S ORURG=$S(URG=1:"HIGH",URG=2:"Moderate",1:"low") 39 ...S REM=$G(REMLIST(ORN)) 40 ...S ORN0=^ORD(100.9,ORN,0) 41 ...S ALRTI=$S($P(ORN0,U,6)="INFODEL":"I",1:"") 42 ...S ALRTDFN=$P(ALRTXQA,",",2) 43 ...S ALRTLOC=$G(^DPT(+$G(ALRTDFN),.1)) 44 ..S ALRTI=$S(ALRTI="I":"I",1:"") 45 ..I ALRT["): " D 46 ...S ALRTPT=$P(ALRT,": ") 47 ...S ALRTPT=$E(ALRTPT,4,$L(ALRTPT)) 48 ...S ALRTMSG=$P($P(ALRT,U),"): ",2) 49 ...I $E(ALRTMSG,1,1)="[" D 50 ....S:'$L(ALRTLOC) ALRTLOC=$P($P(ALRTMSG,"]"),"[",2) 51 ....S ALRTMSG=$P(ALRTMSG,"] ",2) 52 ..I '$L($G(ALRTPT)) S ALRTPT="no patient" 53 ..S ALRTDT=$P(ALRTXQA,";",3) 54 ..S ALRTDT=$P(ALRTDT,".")_"."_$E($P(ALRTDT,".",2)_"0000",1,4) 55 ..S ALRTDT=$E(ALRTDT,4,5)_"/"_$E(ALRTDT,6,7)_"/"_($E(ALRTDT,1,3)+1700)_"@"_$E($P(ALRTDT,".",2),1,2)_":"_$E($P(ALRTDT,".",2),3,4) 56 ..;S ALRTDT=($E(ALRTDT,1,3)+1700)_"/"_$E(ALRTDT,4,5)_"/"_$E(ALRTDT,6,7)_"@"_$E($P(ALRTDT,".",2),1,2)_":"_$E($P(ALRTDT,".",2),3,4) 57 ..S J=J+1,^TMP("ORBG",$J,J)=ALRTI_U_ALRTPT_U_ALRTLOC_U_ORURG_U_ALRTDT_U 58 ..S ^TMP("ORBG",$J,J)=^TMP("ORBG",$J,J)_ALRTMSG_U_U_ALRTXQA_U_$G(REM)_U 59 .; 60 .;if alert forward info/comment: 61 .I $E(ALRTMSG,1,5)="-----" D 62 ..S ALRTMSG=$P(ALRTMSG,"-----",2) 63 ..I $E(ALRTMSG,1,14)=FWDBY D 64 ...S J=J+1,^TMP("ORBG",$J,J)=FWDBY_U_$P($P(ALRTMSG,FWDBY,2),"Generated: ")_$P($P(ALRTMSG,FWDBY,2),"Generated: ",2) 65 ..E S ^TMP("ORBG",$J,J)=^TMP("ORBG",$J,J)_U_""""_ALRTMSG_"""" 66 S ^TMP("ORBG",$J)="" 67 S ORY=$NA(^TMP("ORBG",$J)) 68 Q 69 ; 70 GETDATA(ORY,XQAID) ; return XQADATA for an alert 71 N SHOWADD 72 S ORY="" 73 Q:$G(XQAID)=""!('$D(^XTV(8992,"AXQA",XQAID))) 74 D GETACT^XQALERT(XQAID) 75 S ORY=XQADATA 76 I ($E(XQAID,1,3)="TIU"),(+ORY>0) D 77 . S SHOWADD=1 78 . S ORY=ORY_$$RESOLVE^TIUSRVLO(+ORY) 79 K XQAID,XQADATA,XQAOPT,XQAROU 80 Q 81 ; 82 KILUNSNO(Y,ORVP) ; Delete unsigned order alerts if no unsigned orders remaining 83 S ORVP=ORVP_";DPT(" 84 D UNOTIF^ORCSIGN 85 Q 86 ; 87 UNFLORD(Y,DFN,XQAID) ; -- auto-unflag orders?/delete alert 88 Q:'$L(DFN)!('$L(XQAID)) 89 N ORI,ORIFN,ORA,XQAKILL,ORN,ORBY,ORAUTO,ORUNF 90 S ORN=+$O(^ORD(100.9,"B","FLAGGED ORDERS",0)) 91 S XQAKILL=$$XQAKILL^ORB3F1(ORN) 92 D LIST^ORQOR1(.ORBY,DFN,"ALL",12,"","") 93 S ORAUTO=+$$GET^XPAR("ALL","ORPF AUTO UNFLAG") 94 S ORI=0 F S ORI=$O(ORBY(ORI)) Q:ORI'>0 D 95 . I ORAUTO D ; unflag 96 . . S ORUNF=+$E($$NOW^XLFDT,1,12)_U_DUZ_"^Auto-Unflagged" 97 . . S ORIFN=$P(ORBY(ORI),U),ORA=+$P(ORIFN,";",2) 98 . . I ORIFN,$D(^OR(100,+ORIFN,0)) S $P(^(8,ORA,3),U)=0,$P(^(3),U,6,8)=ORUNF ; unflag 99 I ORAUTO!(+$G(ORBY(1))=0) D DELETE^XQALERT 100 Q 101 KILEXMED(Y,ORDFN) ; -- Delete expiring meds notification if no expiring meds remaining 102 N ORDG,ORLST S ORDG=$$DG^ORQOR1("RX") 103 D AGET^ORWORR(.ORLST,ORDFN,5,ORDG) 104 Q:+(@ORLST@(.1)) ;more left 105 N XQAKILL,ORNIFN,ORVP,ORIO S OROI="" 106 F OROI="INPT","OUTPT" D 107 .S ORNIFN=$O(^ORD(100.9,"B","MEDICATIONS EXPIRING - "_OROI,0)),ORVP=ORDFN_";DPT(" 108 .Q:'$L($G(ORNIFN)) 109 .S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) ; expiring meds notif 110 .I $D(XQAID) D DELETE^XQALERT 111 .I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID 112 Q 113 KILEXOI(Y,ORDFN,ORNIFN) ; -- Delete expiring flagged OI notification if no flagged expiring OI remaining 114 N ORDG,ORLST S ORDG=$$DG^ORQOR1("ALL") 115 D AGET^ORWORR(.ORLST,ORDFN,5,ORDG) 116 Q:+(@ORLST@(.1)) ;more left 117 N XQAKILL,ORVP 118 S ORVP=ORDFN_";DPT(" 119 S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) ; flagged expiring OI notifications 120 I $D(XQAID) D DELETE^XQALERT 121 I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID 122 Q 123 KILUNVOR(Y,ORDFN) ; -- Delete UNVERIFIED ORDER notification if none remaining within current admission/30 days 124 N DFN,ORDG,ORLST,ORBDT,OREDT,ORDDT S ORDG=$$DG^ORQOR1("ALL") 125 S OREDT=$$NOW^XLFDT 126 S ORDDT=$$FMADD^XLFDT(OREDT,"-90") 127 ;get current admission date/time: 128 S DFN=ORDFN,VA200="" D INP^VADPT 129 S ORBDT=$P($G(VAIN(7)),U) 130 S ORBDT=$S('$L($G(ORBDT)):$$FMADD^XLFDT(OREDT,"-30"),1:ORBDT) ;<= if no admission use past 30 days 131 S ORBDT=$S(ORDDT>ORBDT:ORDDT,1:ORBDT) ;max past days to use is 90 days 132 D AGET^ORWORR(.ORLST,ORDFN,9,ORDG,ORBDT,OREDT) 133 Q:+(@ORLST@(.1)) ;more left 134 N XQAKILL,ORVP,ORNIFN 135 S ORNIFN=$O(^ORD(100.9,"B","UNVERIFIED ORDER",0)),ORVP=ORDFN_";DPT(" 136 S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) 137 I $D(XQAID) D DELETE^XQALERT 138 I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID 139 Q 140 KILUNVMD(Y,ORDFN) ; -- Delete UNVERIFIED MEDS notification if none remaining within current admission/30 days 141 N DFN,ORDG,ORLST,ORBDT,OREDT,ORDDT S ORDG=$$DG^ORQOR1("RX") 142 S OREDT=$$NOW^XLFDT 143 S ORDDT=$$FMADD^XLFDT(OREDT,"-90") 144 ;get current admission date/time: 145 S DFN=ORDFN,VA200="" D INP^VADPT 146 S ORBDT=$P($G(VAIN(7)),U) 147 S ORBDT=$S('$L($G(ORBDT)):$$FMADD^XLFDT(OREDT,"-30"),1:ORBDT) ;<= if no admission use past 30 days 148 S ORBDT=$S(ORDDT>ORBDT:ORDDT,1:ORBDT) ;max past days to use is 90 days 149 D AGET^ORWORR(.ORLST,ORDFN,9,ORDG,ORBDT,OREDT) 150 Q:+(@ORLST@(.1)) ;more left 151 N XQAKILL,ORVP,ORNIFN 152 S ORNIFN=$O(^ORD(100.9,"B","UNVERIFIED MEDICATION ORDER",0)),ORVP=ORDFN_";DPT(" 153 S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) 154 I $D(XQAID) D DELETE^XQALERT 155 I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID 156 Q 157 ESORD(ORY,XQAID) ;order(s) requiring electronic signature follow-up 158 K XQAKILL 159 N ORPT,ORDG,ORBXQAID,ORY,ORX,ORZ,ORDERS,ORDNUM,ORQUIT,ORBLMDEL 160 S ORBXQAID=XQAID,ORDERS=0,ORQUIT=0 161 S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid 162 S ORDG=$$DG^ORQOR1("ALL") 163 ;the FLG code for UNSIGNED orders in ORQ1 is '11' 164 ;get unsigned orders - if none exist, delete alert then quit: 165 D EN^ORQ1(ORPT_";DPT(",ORDG,11,"","","",0,0) 166 S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" I +$G(^TMP("ORR",$J,ORX,"TOT"))<1 D DEL^ORB3FUP1(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q 167 ; 168 ;user does not have ORES key, delete user's alert: 169 I '$D(^XUSEC("ORES",DUZ)) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q 170 ; 171 ;if prov is NOT linked to pt via attending, primary or teams: 172 I $$PPLINK^ORQPTQ1(DUZ,ORPT)=0 D 173 .S ORX="" F S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""!(ORDERS=1) D 174 ..S ORZ="" F S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:+ORZ=0!(ORDERS=1) D 175 ...S ORDNUM=^TMP("ORR",$J,ORX,ORZ) 176 ...;quit if this unsigned order's last action was made by the user 177 ...I DUZ=+$$UNSIGNOR^ORQOR2(ORDNUM) S ORDERS=1 178 .I ORDERS'=1 D ;provider has no outstanding unsigned orders for pt 179 ..S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) ;delete alert for this user 180 K ^TMP("ORR",$J) 181 Q 182 ; 183 TXTFUP(ROOT,DFN,NOTIF,XQADATA) ; Follow-up for text messages 184 ; 185 I NOTIF=67 D CHGRAD 186 Q 187 ; 188 CHGRAD ;GUI follow-up for Imaging Request Changed (#67) 189 S ROOT=$NA(^TMP($J,"RAE4")) 190 K @ROOT 191 D SET1^RAO7PC4 ;DBIA #3563 192 Q 193 ; 194 GETSORT(ORY) ;return notification sort method^direction for user/division/system/pkg 195 S ORY=$$GET^XPAR("ALL","ORB SORT METHOD",1,"I")_U_$$GET^XPAR("ALL","ORB SORT DIRECTION",1,"I") 196 Q 197 ; 198 SETSORT(ORERR,SORT,DIR) ;set notification sort method^direction for user 199 D EN^XPAR(DUZ_";VA(200,","ORB SORT METHOD",1,SORT,.ORERR) 200 I $L($G(DIR)) D EN^XPAR(DUZ_";VA(200,","ORB SORT DIRECTION",1,DIR,.ORERR) 201 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORR.m
r613 r623 1 ORWORR ; SLC/KCM/JLI - Retrieve Orders for Broker ;7/24/05 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,116,110,132,141,163,189,195,215,243**;Dec 17, 1997;Build 242 3 ; 4 GET(LST,DFN,FILTER,GROUPS) ; procedure 5 Q ; don't call until using same treating specialty logic as AGET 6 ; & until MULT, ORWARD, & ORIGVIEW implemented 7 ; & until the date ranges implemented 8 ; Get orders for patient 9 ; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 10 ; .LST=~IFN^Grp^ActTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^ActDA^Flag^DCType^ChrtRev^DEA#^^Schedule 11 ; .LST=tOrder Text (repeating as necessary) 12 ; DFN=Patient ID 13 ; FILTER=# indicates which orders to return, default=2 (current) 14 ; GROUPS=display grp of orders to show (default=ALL) 15 ; -- section uses ORQ1 to get orders list rather than XGET -- 16 N ORLIST,ORIFN,X0,X3,X8,IDX,IFN,ACT,PRV,LN,TXT,STRT,STOP,CSTS,EYE,DEA ;PKI 17 K ^TMP("ORR",$J) 18 S (IDX,LST)=0 S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2 19 D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"","","",0,1) 20 S EYE=0 F S EYE=$O(^TMP("ORR",$J,ORLIST,EYE)) Q:'EYE S IFN=^(EYE) D 21 . S ACT=$P(IFN,";",2),IFN=+IFN,X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0) 22 . D GETFLDS 23 K ^TMP("ORR",$J) 24 G EXIT 25 AGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT,ORRECIP) ;Get abbrev. event delayed order list for patient 26 ; returns ^TMP("ORR",$J,ORLIST,n)=IFN^DGrp^ActTm 27 ; see input parameters above 28 ; -- from ORWORR 29 ; -- section uses ORQ1 to get orders list rather than XGET -- 30 N ORLIST,ORIFN,IFN,I,ORWTS,TOT,MULT,ORWARD,TXTVW,ORYD,PTEVTID,EVTNAME 31 S (PTEVTID,EVTNAME)="" 32 K ^TMP("ORR",$J),^TMP("ORRJD",$J) 33 S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2 34 S ORWTS=+$P(FILTER,U,2),FILTER=+FILTER 35 S MULT=$S("^1^6^8^9^10^11^13^14^20^22^"[(U_FILTER_U):1,1:0) 36 I $L($G(^DPT(DFN,.1))) S ORWARD=1 ; normally ptr to 42 37 S:'$L($G(DTFROM)) DTFROM=0 38 S:'$L($G(DTTHRU)) DTTHRU=0 39 I $P(DTFROM,".")=$P(DTTHRU,"."),$P(DTFROM,".",2)>$P(DTTHRU,".",2),$P(DTTHRU,".",2)="" S $P(DTTHRU,".",2)=2359 40 S:'$L($G(EVENT)) EVENT=0 41 I $G(EVTDCREL)="TRUE" D 42 . D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,2,MULT,"",1,EVENT) 43 . D GET2^ORWORR1 44 E D 45 . D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,0,MULT,"",1,EVENT) 46 . D GET1^ORWORR1 47 Q 48 RGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) ;Orders of AutoDC/Release Event 49 N EVTDCREL 50 S EVTDCREL="TRUE" 51 D AGET(.REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) 52 Q 53 XGET ; retrieval algorithm before all the AC xref changes 54 N X,X0,X3,IDX,IFN,LN,TIME,DGRP,MASK,TXT,ACT,PRV,ID,DEA,PASS ;PKI 55 S DFN=DFN_";DPT(",IDX=0,LST=0 56 I '$G(FILTER) S FILTER=2 ; Default: Current/Active 57 I $D(GROUPS)=1 D 58 . S:'GROUPS GROUPS=$O(^ORD(100.98,"B",GROUPS,0)) 59 . D XPND(GROUPS) 60 I FILTER=1 D DOALL G EXIT ; All 61 I FILTER=2 D DOCUR G EXIT ; Current 62 I FILTER=3 S PASS=";1;" ; Discontinued 63 I FILTER=4 S PASS=";2;7;" ; Comp/Expired 64 I FILTER=5 S PASS=";3;4;5;6;8;9;" ; Expiring 65 I FILTER=6 S PASS=";1;2;3;4;5;6;7;8;9;11;" ; New Activity 66 I FILTER=7 S PASS=";5;" ; Pending 67 I FILTER=8 Q ; Expanded 68 I FILTER=9 S PASS=";3;4;5;6;8;9;11;" ; Unverified by Nurse 69 I FILTER=10 S PASS=";3;4;5;6;8;9;11;" ; Unverified by Clerk 70 I FILTER=11 S PASS=";3;4;5;6;7;8;11;" ; Unsigned 71 I FILTER=12 S PASS=";4;" ; Flagged 72 I FILTER=13 S PASS="" ; Verbal/Phone 73 I FILTER=14 S PASS="" ; Verbal/Phone Unsigned 74 D DOGET 75 EXIT I LST=0 D 76 . N %,X,%I D NOW^%DTC 77 . S LST(1)="~0^0^"_%_"^^^97",LST(2)="tNo Orders Found." 78 Q 79 DOGET ; Here to filter orders 80 S TIME=0 F S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME D 81 . S DGRP=0 F S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP D 82 . . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP)) ;filter by display grp 83 . . S IFN=0 F S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN D 84 . . . S X0=^OR(100,IFN,0),X3=^(3) ;get main nodes 85 . . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q ;skip veil,chld,sts=99 86 . . . I $L(PASS),(PASS'[(";"_$P(X3,U,3)_";")) Q ;filter by status 87 . . . ; any other filtering 88 . . . D GETFLDS 89 Q 90 DOALL ; Here to get all orders (no filter by status) 91 S TIME=0 F S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME D 92 . S DGRP=0 F S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP D 93 . . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP)) ;filter by display grp 94 . . S IFN=0 F S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN D 95 . . . S X0=^OR(100,IFN,0),X3=^(3) ;get main nodes 96 . . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q ;skip veil,chld,sts=99 97 . . . D GETFLDS 98 Q 99 DOCUR ; Here to get all current orders 100 N AOCTXT,STS,STOP,% 101 S X=-$$GET^XPAR("ALL","ORPF ACTIVE ORDERS CONTEXT HRS") 102 S %H=$H,X=(%H*86400+$P(%H,",",2))+(X*3600),%H=(X\86400)_","_(X#86400) 103 D YMD^%DTC S AOCTXT=X_% 104 S MASK="110000100101110" ; mask out STS=1,2,7,10,12,13,14 105 S TIME=0 F S TIME=$O(^OR(100,"AC",DFN,TIME)) Q:'TIME D 106 . S IFN=0 F S IFN=$O(^OR(100,"AC",DFN,TIME,IFN)) Q:'IFN D 107 . . ; filter out display groups here 108 . . S ACT=0 F S ACT=$O(^OR(100,"AC",DFN,TIME,IFN,ACT)) Q:'ACT D 109 . . . S X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0) 110 . . . S STS=$P(X3,U,3),STOP=$P(X0,U,9) 111 . . . I $P(X3,U,8)!$P(X3,U,9)!(STS=99) Q 112 . . . I $P(X8,U,15)=13,($P(X8,U)<AOCTXT) D ACKILL Q 113 . . . I $P(X8,U,15)=13!($P(X8,U,15)=""),("RN^XX"[$P(X8,U,2)) D ACKILL Q 114 . . . I $E(MASK,STS),STOP<AOCTXT D ACKILL Q 115 . . . D GETFLDS 116 Q 117 ACKILL ; called only from DOCUR - kill AC xref 118 ; K ^OR(100,"AC",DFN,TIME,IFN,ACT) ; let ORQ1 kill if for now 119 Q 120 GET4V11(LST,TXTVW,ORYD,IFNLST) ; get order fields TEMP 121 G GET41 122 GET4LST(LST,IFNLST) ; get order fields for list of orders 123 GET41 N ACT,ACTID,IDX,X0,X3,X8,PRV,ID,LN,TXT,STRT,STOP,CSTS,IFN,IFNIDX,ORIGVIEW,DEA ;PKI 124 N LOC ;IMO 125 S (IDX,LST,IFNIDX)=0 126 F S IFNIDX=$O(IFNLST(IFNIDX)) Q:'IFNIDX S IFN=IFNLST(IFNIDX) D 127 . S ACT=$S($P(IFN,";",2):$P(IFN,";",2),1:1),IFN=+IFN 128 . S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)),X8=$G(^(8,ACT,0)) 129 . D GETFLDS 130 Q 131 GETBYIFN(LST,IFN) ; procedure 132 ; get fields for single order 133 ; .LST(n)=described above in GET 134 ; IFN=internal entry # for order 135 I 'IFN Q 136 N ACT,IDX,X0,X3,X8,PRV,ID,LN,TXT,STRT,STOP,CSTS,ACTID,ORIGVIEW,ORYD,TXTVW,DEA ;PKI 137 S IDX=0,LST=0,ORYD=0 138 S X0=$G(^OR(100,+IFN,0)),X3=$G(^(3)) 139 S ACT=$S($P(IFN,";",2):$P(IFN,";",2),$P(X3,U,7):$P(X3,U,7),1:1) 140 S IFN=+IFN,X8=$G(^OR(100,IFN,8,ACT,0)) 141 GETFLDS ; used by entry points to place order fields into list 142 ; expects IDX=sequence #, IFN=order, X0=node 0, X3=node 3, LST=results 143 ; LST(IDX)=~IFN^Grp^OrdTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^Act^Flagged[^DCType]^ChartRev^DEA#^^DigSig^LOC 144 S PRV=$P(X8,U,5) S:'PRV PRV=$P(X8,U,3) S PRV=PRV_U 145 I PRV S PRV=PRV_$P(^VA(200,+PRV,0),U) 146 S DEA=$$DEA^XUSER(,+PRV) ; get user DEA info - PKI 147 S IDX=IDX+1,LST=LST+1,ID=IFN_";"_ACT,ACTID=$P(X8,U,2) 148 S CSTS=$S($P(X8,U,15):$P(X8,U,15),1:$P(X3,U,3)) 149 I $P(X8,U,15)=10,$P(X3,U,3)=14 S CSTS=14 ;delayed-lapsed order 150 S STRT=$S($P(X3,U,3)=11:$$RSTRT,ACTID="NW"!(ACTID="XX")!(ACTID="RL"):$P(X0,U,8),ACTID="DC":"",1:$P(X8,U)) ;110 151 S STOP=$S($P(X3,U,3)=11:$$RSTOP,ACTID="HD":$P($G(^OR(100,+IFN,8,ACT,2)),U),1:$P(X0,U,9)) 152 S LST(IDX)="~"_ID_U_$P(X0,U,11)_U_$P(X8,U)_U_STRT_U_STOP_U_CSTS_U_$P(X8,U,4)_U_$P(X8,U,8)_U_$P(X8,U,10)_U_PRV 153 S $P(LST(IDX),U,13)=+$G(^OR(100,IFN,8,ACT,3)) ; flagged 154 I +$P(X8,U,8) S $P(LST(IDX),U,8)=$$INITIALS^ORCHTAB2(+$P(X8,U,8)) ;nurse 155 I +$P(X8,U,10) S $P(LST(IDX),U,9)=$$INITIALS^ORCHTAB2(+$P(X8,U,10)) ;clerk 156 I +$P(X8,U,18) S $P(LST(IDX),U,15)=$$INITIALS^ORCHTAB2(+$P(X8,U,18)) ;chart review 157 I $L($G(DEA)) S $P(LST(IDX),U,16)=DEA ;PKI 158 I $P($G(^OR(100,IFN,8,ACT,2)),"^",5) S $P(LST(IDX),U,18)=$P(^(2),"^",4) 159 I '$P($G(^OR(100,IFN,8,ACT,2)),"^",5),$P(X0,"^",5) D ;Copy orders PKI fix 160 . N OI,ORVP,ORCAT,PKG 161 . S OI=+$O(^OR(100,IFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,IFN,4.5,OI,1)) Q:'OI 162 . S ORVP=$P(X0,"^",2),PKG=$P(X0,"^",14) 163 . S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O") 164 . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q 165 . D PKI^ORWDPS1(.ORY,OI,ORCAT,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q")) 166 . I $E($G(ORY))=2 S $P(LST(IDX),U,18)=ORY 167 ; Change to display location for Clinic Orders, Inpatients, & IV infusion orders. 168 N DGID,DGNAM 169 S LOC="" 170 S DGID=$P(X0,U,11) 171 I $L(DGID) D 172 .S DGNAM=$P($G(^ORD(100.98,DGID,0)),U) 173 .;I DGNAM="CLINIC ORDERS"!(DGNAM="INPATIENT MEDICATIONS")!(DGNAM="IV MEDICATIONS")!(DGNAM="UNIT DOSE MEDICATIONS") D 174 .S LOC=$P(X0,U,10) ;IMO 175 .S:+LOC LOC=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO 176 S $P(LST(IDX),U,19)=LOC ;IMO 177 ; 178 S ORIGVIEW=$S($G(TXTVW)=0:0,$G(TXTVW)=1:1,ORYD=-1:1,'ORYD:1,$P(X8,U)'<ORYD:0,1:1) 179 K TXT D TEXT^ORQ12(.TXT,ID,255) ; optimize later 180 I $O(^OR(100,+IFN,2,0)) S LN=$O(TXT(0)),TXT(LN)="+"_TXT(LN) 181 I $O(^OR(100,+IFN,8,"C","XX",0)) S LN=$O(TXT(0)),TXT(LN)="*"_TXT(LN) 182 S LN=0 F S LN=$O(TXT(LN)) Q:'LN S IDX=IDX+1,LST(IDX)="t"_TXT(LN) 183 I $O(^OR(100,+IFN,8,1,.2,0)) S IDX=IDX+1,LST(IDX)="|" D ;PKI XMLText 184 . S I=0 F S I=$O(^OR(100,+IFN,8,1,.2,I)) Q:'I S IDX=IDX+1,LST(IDX)="x"_^(I,0) 185 Q 186 RSTRT() ; return start date from responses 187 Q $G(^OR(100,IFN,4.5,+$O(^OR(100,IFN,4.5,"ID","START",0)),1)) 188 RSTOP() ; return stop date from responses 189 Q $G(^OR(100,IFN,4.5,+$O(^OR(100,IFN,4.5,"ID","STOP",0)),1)) 190 GETTXT(LST,IFN) ; get text of an order 191 I $L(IFN,";")=1 S IFN=IFN_";1" 192 D TEXT^ORQ12(.LST,IFN,255) 193 Q 194 XPND(AGRP) ; procedure 195 ; Expand display group (GROUPS defined outside of call) 196 N I,CHLD 197 S GROUPS(AGRP)=^ORD(100.98,AGRP,0),I=0 198 F S I=$O(^ORD(100.98,AGRP,1,I)) Q:'I S CHLD=$P(^(I,0),U) D XPND(CHLD) 199 Q 200 GETPKG(Y,IFN) ; get order pkg 201 N ORDERID,PKGID 202 Q:+IFN<1 203 S ORDERID=+IFN,Y="" 204 S PKGID=$P(OR(100,ORDERID,0),U,14) 205 S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2) 206 Q 1 ORWORR ; SLC/KCM/JLI - Retrieve Orders for Broker ;7/24/05 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,116,110,132,141,163,189,195,215**;Dec 17, 1997 3 ; 4 GET(LST,DFN,FILTER,GROUPS) ; procedure 5 Q ; don't call until using same treating specialty logic as AGET 6 ; & until MULT, ORWARD, & ORIGVIEW implemented 7 ; & until the date ranges implemented 8 ; Get orders for patient 9 ; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 10 ; .LST=~IFN^Grp^ActTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^ActDA^Flag^DCType^ChrtRev^DEA#^^Schedule 11 ; .LST=tOrder Text (repeating as necessary) 12 ; DFN=Patient ID 13 ; FILTER=# indicates which orders to return, default=2 (current) 14 ; GROUPS=display grp of orders to show (default=ALL) 15 ; -- this section uses ORQ1 to get orders list rather than XGET -- 16 N ORLIST,ORIFN,X0,X3,X8,IDX,IFN,ACT,PRV,LN,TXT,STRT,STOP,CSTS,EYE,DEA ;PKI 17 K ^TMP("ORR",$J) 18 S (IDX,LST)=0 S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2 19 D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"","","",0,1) 20 S EYE=0 F S EYE=$O(^TMP("ORR",$J,ORLIST,EYE)) Q:'EYE S IFN=^(EYE) D 21 . S ACT=$P(IFN,";",2),IFN=+IFN,X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0) 22 . D GETFLDS 23 K ^TMP("ORR",$J) 24 G EXIT 25 AGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) ;Get an abbrev. event delayed order list for patient 26 ; returns ^TMP("ORR",$J,ORLIST,n)=IFN^DGrp^ActTm 27 ; see input parameters above 28 ; -- from ORWORR 29 ; -- section uses ORQ1 to get the orders list rather than XGET -- 30 N ORLIST,ORIFN,IFN,I,ORWTS,TOT,MULT,ORWARD,TXTVW,ORYD,PTEVTID,EVTNAME 31 S (PTEVTID,EVTNAME)="" 32 K ^TMP("ORR",$J),^TMP("ORRJD",$J) 33 S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2 34 S ORWTS=+$P(FILTER,U,2),FILTER=+FILTER 35 S MULT=$S("^1^6^8^9^10^11^13^14^20^22^"[(U_FILTER_U):1,1:0) 36 I $L($G(^DPT(DFN,.1))) S ORWARD=1 ; normally ptr to 42 37 S:'$L($G(DTFROM)) DTFROM=0 38 S:'$L($G(DTTHRU)) DTTHRU=0 39 S:'$L($G(EVENT)) EVENT=0 40 I $G(EVTDCREL)="TRUE" D 41 . D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,2,MULT,"",1,EVENT) 42 . D GET2^ORWORR1 43 E D 44 . D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,0,MULT,"",1,EVENT) 45 . D GET1^ORWORR1 46 Q 47 RGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) ;Orders of AutoDC/Release Event 48 N EVTDCREL 49 S EVTDCREL="TRUE" 50 D AGET(.REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) 51 Q 52 XGET ; -- the retrieval algorithm before all the AC xref changes 53 N X,X0,X3,IDX,IFN,LN,TIME,DGRP,MASK,TXT,ACT,PRV,ID,DEA,PASS ;PKI 54 S DFN=DFN_";DPT(",IDX=0,LST=0 55 I '$G(FILTER) S FILTER=2 ; Default: Current/Active 56 I $D(GROUPS)=1 D 57 . S:'GROUPS GROUPS=$O(^ORD(100.98,"B",GROUPS,0)) 58 . D XPND(GROUPS) 59 I FILTER=1 D DOALL G EXIT ; All 60 I FILTER=2 D DOCUR G EXIT ; Current 61 I FILTER=3 S PASS=";1;" ; Discontinued 62 I FILTER=4 S PASS=";2;7;" ; Comp/Expired 63 I FILTER=5 S PASS=";3;4;5;6;8;9;" ; Expiring 64 I FILTER=6 S PASS=";1;2;3;4;5;6;7;8;9;11;" ; New Activity 65 I FILTER=7 S PASS=";5;" ; Pending 66 I FILTER=8 Q ; Expanded 67 I FILTER=9 S PASS=";3;4;5;6;8;9;11;" ; Unverified by Nurse 68 I FILTER=10 S PASS=";3;4;5;6;8;9;11;" ; Unverified by Clerk 69 I FILTER=11 S PASS=";3;4;5;6;7;8;11;" ; Unsigned 70 I FILTER=12 S PASS=";4;" ; Flagged 71 I FILTER=13 S PASS="" ; Verbal/Phone 72 I FILTER=14 S PASS="" ; Verbal/Phone Unsigned 73 D DOGET 74 EXIT I LST=0 D 75 . N %,X,%I D NOW^%DTC 76 . S LST(1)="~0^0^"_%_"^^^97",LST(2)="tNo Orders Found." 77 Q 78 DOGET ; Come here to filter orders 79 S TIME=0 F S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME D 80 . S DGRP=0 F S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP D 81 . . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP)) ;filter by display grp 82 . . S IFN=0 F S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN D 83 . . . S X0=^OR(100,IFN,0),X3=^(3) ;get main nodes 84 . . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q ;skip veil,chld,sts=99 85 . . . I $L(PASS),(PASS'[(";"_$P(X3,U,3)_";")) Q ;filter by status 86 . . . ; do any other filtering 87 . . . D GETFLDS 88 Q 89 DOALL ; Come here to get all orders (no filter by status) 90 S TIME=0 F S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME D 91 . S DGRP=0 F S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP D 92 . . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP)) ;filter by display grp 93 . . S IFN=0 F S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN D 94 . . . S X0=^OR(100,IFN,0),X3=^(3) ;get main nodes 95 . . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q ;skip veil,chld,sts=99 96 . . . D GETFLDS 97 Q 98 DOCUR ; Come here to get all current orders 99 N AOCTXT,STS,STOP,% 100 S X=-$$GET^XPAR("ALL","ORPF ACTIVE ORDERS CONTEXT HRS") 101 S %H=$H,X=(%H*86400+$P(%H,",",2))+(X*3600),%H=(X\86400)_","_(X#86400) 102 D YMD^%DTC S AOCTXT=X_% 103 S MASK="110000100101110" ; mask out STS=1,2,7,10,12,13,14 104 S TIME=0 F S TIME=$O(^OR(100,"AC",DFN,TIME)) Q:'TIME D 105 . S IFN=0 F S IFN=$O(^OR(100,"AC",DFN,TIME,IFN)) Q:'IFN D 106 . . ; filter out display groups here 107 . . S ACT=0 F S ACT=$O(^OR(100,"AC",DFN,TIME,IFN,ACT)) Q:'ACT D 108 . . . S X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0) 109 . . . S STS=$P(X3,U,3),STOP=$P(X0,U,9) 110 . . . I $P(X3,U,8)!$P(X3,U,9)!(STS=99) Q 111 . . . I $P(X8,U,15)=13,($P(X8,U)<AOCTXT) D ACKILL Q 112 . . . I $P(X8,U,15)=13!($P(X8,U,15)=""),("RN^XX"[$P(X8,U,2)) D ACKILL Q 113 . . . I $E(MASK,STS),STOP<AOCTXT D ACKILL Q 114 . . . D GETFLDS 115 Q 116 ACKILL ; called only from DOCUR - kill AC xref 117 ; K ^OR(100,"AC",DFN,TIME,IFN,ACT) ; let ORQ1 kill if for now 118 Q 119 GET4V11(LST,TXTVW,ORYD,IFNLST) ; get order fields TEMPORARY 120 G GET41 121 GET4LST(LST,IFNLST) ; get order fields for a list of orders 122 GET41 N ACT,ACTID,IDX,X0,X3,X8,PRV,ID,LN,TXT,STRT,STOP,CSTS,IFN,IFNIDX,ORIGVIEW,DEA ;PKI 123 N LOC ;IMO 124 S (IDX,LST,IFNIDX)=0 125 F S IFNIDX=$O(IFNLST(IFNIDX)) Q:'IFNIDX S IFN=IFNLST(IFNIDX) D 126 . S ACT=$S($P(IFN,";",2):$P(IFN,";",2),1:1),IFN=+IFN 127 . S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)),X8=$G(^(8,ACT,0)) 128 . D GETFLDS 129 Q 130 GETBYIFN(LST,IFN) ; procedure 131 ; get fields for single order 132 ; .LST(n)=as described above in GET 133 ; IFN=internal entry # for order 134 I 'IFN Q 135 N ACT,IDX,X0,X3,X8,PRV,ID,LN,TXT,STRT,STOP,CSTS,ACTID,ORIGVIEW,ORYD,TXTVW,DEA ;PKI 136 S IDX=0,LST=0,ORYD=0 137 S X0=$G(^OR(100,+IFN,0)),X3=$G(^(3)) 138 S ACT=$S($P(IFN,";",2):$P(IFN,";",2),$P(X3,U,7):$P(X3,U,7),1:1) 139 S IFN=+IFN,X8=$G(^OR(100,IFN,8,ACT,0)) 140 GETFLDS ; used by entry points to place order fields into list 141 ; expects IDX=sequence #, IFN=order, X0=node 0, X3=node 3, LST=results 142 ; LST(IDX)=~IFN^Grp^OrdTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^Act^Flagged[^DCType]^ChartRev^DEA#^^DigSig^LOC 143 S PRV=$P(X8,U,5) S:'PRV PRV=$P(X8,U,3) S PRV=PRV_U 144 I PRV S PRV=PRV_$P(^VA(200,+PRV,0),U) 145 S DEA=$$DEA^XUSER(,+PRV) ; get user DEA info - PKI 146 S IDX=IDX+1,LST=LST+1,ID=IFN_";"_ACT,ACTID=$P(X8,U,2) 147 S CSTS=$S($P(X8,U,15):$P(X8,U,15),1:$P(X3,U,3)) 148 I $P(X8,U,15)=10,$P(X3,U,3)=14 S CSTS=14 ;delayed-lapsed order 149 S STRT=$S($P(X3,U,3)=11:$$RSTRT,ACTID="NW"!(ACTID="XX")!(ACTID="RL"):$P(X0,U,8),ACTID="DC":"",1:$P(X8,U)) ;110 150 S STOP=$S($P(X3,U,3)=11:$$RSTOP,ACTID="HD":$P($G(^OR(100,+IFN,8,ACT,2)),U),1:$P(X0,U,9)) 151 S LST(IDX)="~"_ID_U_$P(X0,U,11)_U_$P(X8,U)_U_STRT_U_STOP_U_CSTS_U_$P(X8,U,4)_U_$P(X8,U,8)_U_$P(X8,U,10)_U_PRV 152 S $P(LST(IDX),U,13)=+$G(^OR(100,IFN,8,ACT,3)) ; flagged 153 I +$P(X8,U,8) S $P(LST(IDX),U,8)=$$INITIALS^ORCHTAB2(+$P(X8,U,8)) ;nurse 154 I +$P(X8,U,10) S $P(LST(IDX),U,9)=$$INITIALS^ORCHTAB2(+$P(X8,U,10)) ;clerk 155 I +$P(X8,U,18) S $P(LST(IDX),U,15)=$$INITIALS^ORCHTAB2(+$P(X8,U,18)) ;chart review 156 I $L($G(DEA)) S $P(LST(IDX),U,16)=DEA ;PKI 157 I $P($G(^OR(100,IFN,8,ACT,2)),"^",5) S $P(LST(IDX),U,18)=$P(^(2),"^",4) 158 I '$P($G(^OR(100,IFN,8,ACT,2)),"^",5),$P(X0,"^",5) D ;Copy orders PKI fix 159 . N OI,ORVP,ORCAT,PKG 160 . S OI=+$O(^OR(100,IFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,IFN,4.5,OI,1)) Q:'OI 161 . S ORVP=$P(X0,"^",2),PKG=$P(X0,"^",14) 162 . S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O") 163 . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q 164 . D PKI^ORWDPS1(.ORY,OI,ORCAT,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q")) 165 . I $E($G(ORY))=2 S $P(LST(IDX),U,18)=ORY 166 ; Change code to display location for Clinic Orders, Inpatients, and IV infusion orders. 167 N DGID,DGNAM 168 S LOC="" 169 S DGID=$P(X0,U,11) 170 I $L(DGID) D 171 .S DGNAM=$P($G(^ORD(100.98,DGID,0)),U) 172 .;I DGNAM="CLINIC ORDERS"!(DGNAM="INPATIENT MEDICATIONS")!(DGNAM="IV MEDICATIONS")!(DGNAM="UNIT DOSE MEDICATIONS") D 173 .S LOC=$P(X0,U,10) ;IMO 174 .S:+LOC LOC=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO 175 S $P(LST(IDX),U,19)=LOC ;IMO 176 ; 177 S ORIGVIEW=$S($G(TXTVW)=0:0,$G(TXTVW)=1:1,ORYD=-1:1,'ORYD:1,$P(X8,U)'<ORYD:0,1:1) 178 K TXT D TEXT^ORQ12(.TXT,ID,255) ; optimize this later 179 I $O(^OR(100,+IFN,2,0)) S LN=$O(TXT(0)),TXT(LN)="+"_TXT(LN) 180 I $O(^OR(100,+IFN,8,"C","XX",0)) S LN=$O(TXT(0)),TXT(LN)="*"_TXT(LN) 181 S LN=0 F S LN=$O(TXT(LN)) Q:'LN S IDX=IDX+1,LST(IDX)="t"_TXT(LN) 182 I $O(^OR(100,+IFN,8,1,.2,0)) S IDX=IDX+1,LST(IDX)="|" D ;PKI XMLText 183 . S I=0 F S I=$O(^OR(100,+IFN,8,1,.2,I)) Q:'I S IDX=IDX+1,LST(IDX)="x"_^(I,0) 184 Q 185 RSTRT() ; return start date from responses 186 Q $G(^OR(100,IFN,4.5,+$O(^OR(100,IFN,4.5,"ID","START",0)),1)) 187 RSTOP() ; return stop date from responses 188 Q $G(^OR(100,IFN,4.5,+$O(^OR(100,IFN,4.5,"ID","STOP",0)),1)) 189 GETTXT(LST,IFN) ; get the text of an order 190 I $L(IFN,";")=1 S IFN=IFN_";1" 191 D TEXT^ORQ12(.LST,IFN,255) 192 Q 193 XPND(AGRP) ; procedure 194 ; Expand a display group (GROUPS must be defined outside of call) 195 N I,CHLD 196 S GROUPS(AGRP)=^ORD(100.98,AGRP,0),I=0 197 F S I=$O(^ORD(100.98,AGRP,1,I)) Q:'I S CHLD=$P(^(I,0),U) D XPND(CHLD) 198 Q 199 GETPKG(Y,IFN) ; get pkg for order 200 N ORDERID,PKGID 201 Q:+IFN<1 202 S ORDERID=+IFN,Y="" 203 S PKGID=$P(OR(100,ORDERID,0),U,14) 204 S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2) 205 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORR1.m
r613 r623 1 ORWORR1 ; SLC/JLI - Utilities for Retrieve Orders for Broker ; 4/3/08 7:47am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,243**;Dec 17, 1997;Build 242 3 ;Called from ORWORR 4 GET1 ; 5 S TOT=^TMP("ORR",$J,ORLIST,"TOT") K ^TMP("ORR",$J,ORLIST,"TOT") 6 S I=.1 F S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I S IFN=^(I) D 7 . I $G(ORRECIP)&&($G(FILTER)=12&&($$FLAGRULE(+IFN))) K ^TMP("ORR",$J,ORLIST,I) S TOT=TOT-1 Q 8 . I ORWTS,(+$P($G(^OR(100,+IFN,0)),U,13)'=ORWTS) K ^TMP("ORR",$J,ORLIST,I) S TOT=TOT-1 Q 9 . S PTEVTID=$P($G(^OR(100,+IFN,0)),U,17) 10 . S:PTEVTID>0 EVTNAME=$$NAME^OREVNTX(PTEVTID) 11 . S ^TMP("ORR",$J,ORLIST,I)=IFN_U_$P($G(^OR(100,+IFN,0)),U,11)_U_$P($G(^(8,+$P(IFN,";",2),0)),U)_U_PTEVTID_U_EVTNAME 12 S TXTVW=$S(MULT:0,FILTER=2:2,1:1) D:FILTER=2 ORYD^ORDD100 13 S ^TMP("ORR",$J,ORLIST,.1)=TOT_U_TXTVW_U_$G(ORYD,0) 14 S REF=$NA(^TMP("ORR",$J,ORLIST)) 15 Q 16 GET2 ; For AUTO DC/Event Release Orders 17 N JDND,JDIX,JDCNT,DCSPLIT 18 S JDCNT=1,DCSPLIT=0 19 S TOT=^TMP("ORR",$J,ORLIST,"TOT") K ^TMP("ORR",$J,ORLIST,"TOT") 20 F JDND="RL","DC" D 21 . S I=.1 F S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I D 22 . . I '$D(^TMP("ORR",$J,ORLIST,I,JDND)) Q 23 . . S JDIX=0 F S JDIX=$O(^TMP("ORR",$J,ORLIST,I,JDND,JDIX)) Q:'JDIX S IFN=^(JDIX) D 24 . . . I 'DCSPLIT,(JDND="DC") D 25 . . . . S ^TMP("ORRJD",$J,JDCNT)="DC START" 26 . . . . S DCSPLIT=1,JDCNT=JDCNT+1,TOT=TOT+1 27 . . . I ORWTS,(+$P($G(^OR(100,+IFN,0)),U,13)'=ORWTS) S TOT=TOT-1 Q 28 . . . S PTEVTID=$P($G(^OR(100,+IFN,0)),U,17) 29 . . . S:PTEVTID>0 EVTNAME=$$NAME^OREVNTX(PTEVTID) 30 . . . S ^TMP("ORRJD",$J,JDCNT)=IFN_U_$P($G(^OR(100,+IFN,0)),U,11)_U_$P($G(^(8,+$P(IFN,";",2),0)),U)_U_PTEVTID_U_EVTNAME 31 . . . S JDCNT=JDCNT+1 32 S TXTVW=$S(MULT:0,FILTER=2:2,1:1) D:FILTER=2 ORYD^ORDD100 33 S ^TMP("ORRJD",$J,.1)=TOT_U_TXTVW_U_$G(ORYD,0) 34 S REF=$NA(^TMP("ORRJD",$J)) 35 Q 36 FLAGRULE(ORNUM,USR) ; 37 ;returns 0 if we should keep ORNUM in the list 38 ;returns 1 if we should remove ORNUM from the list 39 ;determines based on whether the user USR should see these flagged orders 40 ; based on presence in file 100 NODE 8 FIELD 39 and 41 ; based on whether the user should have gotten the flag due to provider recipients 42 N ORI,ORRET,ORQUIT,I,LST,ORDFN 43 I '$G(USR) S USR=DUZ 44 S ORRET=1,ORQUIT=0 45 S ORI=0 F S ORI=$O(^OR(100,ORNUM,8,ORI)) Q:'ORI D 46 .I '$P($G(^OR(100,ORNUM,8,ORI,3)),U,6)&($P($G(^OR(100,ORNUM,8,ORI,3)),U,9)) S LST($P($G(^OR(100,ORNUM,8,ORI,3)),U,9))="" 47 S ORDFN=+$P($G(^OR(100,ORNUM,0)),U,2) 48 D START^ORBPRCHK(.LST,ORNUM,6,ORDFN) 49 ;add ordering provider 50 N ORDPROV 51 S ORDPROV=$$ORDERER^ORQOR2(ORNUM) 52 I $G(ORDPROV) S LST(ORDPROV)="" 53 D ADDSURR(.LST) 54 I $D(LST(USR)) S ORRET=0 55 Q ORRET 56 ADDSURR(LST) ;TAKE LIST OF USERS AND ADD SURROGATES TO THE LIST 57 N I 58 S I=0 F S I=$O(LST(I)) Q:'I S LST($$CURRSURO^XQALSURO(I))="" 59 Q 1 ORWORR1 ; SLC/JLI - Utilities for Retrieve Orders for Broker ;9/10/02 3PM [9/16/02 2:56pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141**;Dec 17, 1997 3 ;Called from ORWORR 4 GET1 ; 5 S TOT=^TMP("ORR",$J,ORLIST,"TOT") K ^TMP("ORR",$J,ORLIST,"TOT") 6 S I=.1 F S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I S IFN=^(I) D 7 . I ORWTS,(+$P($G(^OR(100,+IFN,0)),U,13)'=ORWTS) K ^TMP("ORR",$J,ORLIST,I) S TOT=TOT-1 Q 8 . S PTEVTID=$P($G(^OR(100,+IFN,0)),U,17) 9 . S:PTEVTID>0 EVTNAME=$$NAME^OREVNTX(PTEVTID) 10 . S ^TMP("ORR",$J,ORLIST,I)=IFN_U_$P($G(^OR(100,+IFN,0)),U,11)_U_$P($G(^(8,+$P(IFN,";",2),0)),U)_U_PTEVTID_U_EVTNAME 11 S TXTVW=$S(MULT:0,FILTER=2:2,1:1) D:FILTER=2 ORYD^ORDD100 12 S ^TMP("ORR",$J,ORLIST,.1)=TOT_U_TXTVW_U_$G(ORYD,0) 13 S REF=$NA(^TMP("ORR",$J,ORLIST)) 14 Q 15 GET2 ; For AUTO DC/Event Release Orders 16 N JDND,JDIX,JDCNT,DCSPLIT 17 S JDCNT=1,DCSPLIT=0 18 S TOT=^TMP("ORR",$J,ORLIST,"TOT") K ^TMP("ORR",$J,ORLIST,"TOT") 19 F JDND="RL","DC" D 20 . S I=.1 F S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I D 21 . . I '$D(^TMP("ORR",$J,ORLIST,I,JDND)) Q 22 . . S JDIX=0 F S JDIX=$O(^TMP("ORR",$J,ORLIST,I,JDND,JDIX)) Q:'JDIX S IFN=^(JDIX) D 23 . . . I 'DCSPLIT,(JDND="DC") D 24 . . . . S ^TMP("ORRJD",$J,JDCNT)="DC START" 25 . . . . S DCSPLIT=1,JDCNT=JDCNT+1,TOT=TOT+1 26 . . . I ORWTS,(+$P($G(^OR(100,+IFN,0)),U,13)'=ORWTS) S TOT=TOT-1 Q 27 . . . S PTEVTID=$P($G(^OR(100,+IFN,0)),U,17) 28 . . . S:PTEVTID>0 EVTNAME=$$NAME^OREVNTX(PTEVTID) 29 . . . S ^TMP("ORRJD",$J,JDCNT)=IFN_U_$P($G(^OR(100,+IFN,0)),U,11)_U_$P($G(^(8,+$P(IFN,";",2),0)),U)_U_PTEVTID_U_EVTNAME 30 . . . S JDCNT=JDCNT+1 31 S TXTVW=$S(MULT:0,FILTER=2:2,1:1) D:FILTER=2 ORYD^ORDD100 32 S ^TMP("ORRJD",$J,.1)=TOT_U_TXTVW_U_$G(ORYD,0) 33 S REF=$NA(^TMP("ORRJD",$J)) 34 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE.m
r613 r623 1 ORWPCE ; SLC/JM/REV - wrap calls to PCE and AICS;04/01/2003 ;10/11/06 16:052 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,190,195,215,243**;Dec 17, 1997;Build 242 3 4 5 6 7 8 9 10 VISIT(LST,CLINIC,ORDATE) 11 12 13 14 PROC(LST,CLINIC,ORDATE) 15 16 17 18 19 20 21 22 23 24 25 26 27 28 CPTMODS(LST,ORCPTCOD,ORDATE) 29 30 31 32 33 34 35 36 37 GETMOD(MODINFO,ORMODIEN,ORDATE) 38 39 40 41 42 43 DIAG(LST,CLINIC,ORDATE) 44 45 46 47 IMM(LST,CLINIC) 48 49 50 SK(LST,CLINIC) 51 52 53 HF(LST,CLINIC) 54 55 56 PED(LST,CLINIC) 57 58 59 TRT(LST,CLINIC) 60 61 62 XAM(LST,CLINIC) 63 64 65 ACTPROB(GLST,DFN,ORDATE) 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 SCSEL(VAL,DFN,ATM,LOC,VST) 91 92 ; MSTallow^MSTdflt;HNCallow^HNCdflt;CVAllow^CVDflt;SHADAllow^SHADDflt93 94 95 S VAL=$G(ORX("SC"))_S_$G(ORX("AO"))_S_$G(ORX("IR"))_S_$G(ORX("EC"))_S_$G(ORX("MST"))_S_$G(ORX("HNC"))_S_$G(ORX("CV"))_S_$G(ORX("SHAD"))96 97 SCDIS(LST,DFN) 98 99 100 101 102 103 104 105 106 107 108 CPTREQD(VAL,IEN) 109 110 111 NOTEVSTR(VAL,IEN) 112 113 114 115 116 117 HASVISIT(ORY,IEN,DFN,ORLOC,ORDTE) 118 119 120 121 122 123 124 DELETE(VAL,VSTR,DFN) 125 126 127 128 129 130 131 132 133 134 135 136 137 SAVE(OK,PCELIST,NOTEIEN,ORLOC) 138 139 140 141 142 143 144 145 146 147 148 149 150 LEX(LST,X,APP,ORDATE) 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J)168 169 LEXCODE(VAL,IEN,APP,ORDATE) 170 171 172 173 174 175 176 ADDRES 177 178 179 180 GETSVC(NEWSVC,SVC,LOC,INP) 181 182 183 184 185 186 1 ORWPCE ; SLC/JM/REV - wrap calls to PCE and AICS;04/01/2003 ;07/05/04 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,190,195,215**;Dec 17, 1997 3 ; 4 ; DBIA 2950 LOOK^LEXA ^TMP("LEXFND",$J) 5 ; DBIA 1609 CONFIG^LEXSET ^TMP("LEXSCH",$J) 6 ; DBIA 1365 DSELECT^GMPLENFM ^TMP("IB",$J) 7 ; DBIA 3991 $$STATCHK^ICDAPIU 8 ; 9 Q 10 VISIT(LST,CLINIC,ORDATE) ; get list of visit types for clinic 11 S:'+$G(ORDATE) ORDATE=DT 12 D GETLST^IBDF18A(CLINIC,"DG SELECT VISIT TYPE CPT PROCEDURES","LST",,,,ORDATE) 13 Q 14 PROC(LST,CLINIC,ORDATE) ; get list of procedures for clinic P12 for CPTMods 15 S:'+$G(ORDATE) ORDATE=DT 16 D GETLST^IBDF18A(CLINIC,"DG SELECT CPT PROCEDURE CODES","LST",,,1,ORDATE) 17 N IDX,MOD,CODES,FIRST S IDX=0 18 F S IDX=$O(LST(IDX)) Q:'+IDX D 19 . I LST(IDX)="" K LST(IDX) Q 20 . S MOD=0,CODES="",FIRST=1 21 . F S MOD=$O(LST(IDX,"MODIFIER",MOD)) Q:(MOD="") D 22 . . I FIRST S FIRST=0 23 . . E S CODES=CODES_";" 24 . . S CODES=CODES_LST(IDX,"MODIFIER",MOD) 25 . K LST(IDX,"MODIFIER") 26 . I 'FIRST S $P(LST(IDX),U,12)=CODES 27 Q 28 CPTMODS(LST,ORCPTCOD,ORDATE) ;Return CPT Modifiers for a CPT Code 29 N ORM,ORIDX,ORI,MODNAME 30 S:'+$G(ORDATE) ORDATE=DT 31 I +($$CODM^ICPTCOD(ORCPTCOD,$NA(ORM),0,ORDATE)),+$D(ORM) D 32 . S ORIDX="",ORI=0 33 . F S ORIDX=$O(ORM(ORIDX)) Q:(ORIDX="") D 34 . . S ORI=ORI+1,MODNAME=$P(ORM(ORIDX),U,1) 35 . . S LST(MODNAME_ORI)=$P(ORM(ORIDX),U,2)_U_MODNAME_U_ORIDX 36 Q 37 GETMOD(MODINFO,ORMODIEN,ORDATE) ;Returns info for a specific CPT Modifier 38 N ORDATA 39 S:'+$G(ORDATE) ORDATE=DT 40 S ORDATA=$$MOD^ICPTMOD(ORMODIEN,"I",ORDATE,1) 41 I +ORDATA>0 S MODINFO=ORMODIEN_U_$P(ORDATA,U,3)_U_$P(ORDATA,U,2) 42 Q 43 DIAG(LST,CLINIC,ORDATE) ; get list of diagnoses for clinic 44 S:'+$G(ORDATE) ORDATE=DT 45 D GETLST^IBDF18A(CLINIC,"DG SELECT ICD-9 DIAGNOSIS CODES","LST",,,,ORDATE) 46 Q 47 IMM(LST,CLINIC) ;get list of immunizations for clinic 48 D GETLST^IBDF18A(CLINIC,"PX SELECT IMMUNIZATIONS","LST") 49 Q 50 SK(LST,CLINIC) ;get list of skin test for clinic 51 D GETLST^IBDF18A(CLINIC,"PX SELECT SKIN TESTS","LST") 52 Q 53 HF(LST,CLINIC) ;get list of health factors for clinic 54 D GETLST^IBDF18A(CLINIC,"PX SELECT HEALTH FACTORS","LST") 55 Q 56 PED(LST,CLINIC) ;get list of education topices for clinic 57 D GETLST^IBDF18A(CLINIC,"PX SELECT EDUCATION TOPICS","LST") 58 Q 59 TRT(LST,CLINIC) ;get list of treatments for clinic 60 D GETLST^IBDF18A(CLINIC,"PX SELECT TREATMENTS","LST") 61 Q 62 XAM(LST,CLINIC) ;get list of exams for clinic 63 D GETLST^IBDF18A(CLINIC,"PX SELECT EXAMS","LST") 64 Q 65 ACTPROB(GLST,DFN,ORDATE) ;get list of patient's active problems 66 K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS") 67 S:'+$G(ORDATE) ORDATE=DT 68 D DSELECT^GMPLENFM ;DBIA 1365 69 N ORPROB,ORPROBIX,ORPRCNT 70 S ORPRCNT=0 71 S ORPROBIX=0 72 F S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX D ;DBIA 1365 73 . S ORPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3) 74 . I $E(ORPROB,1)="$" S ORPROB=$E(ORPROB,2,255) 75 . I '$D(ORPROB(ORPROB)) D 76 .. S ORPROB(ORPROB)="" 77 .. S ORPRCNT=ORPRCNT+1 78 .. S $P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)=ORPROB 79 . E K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX) 80 ; DBIA 10082 NAME: ICD DIAGNOSIS FILE 81 N ORWINDEX,ORITEM 82 S ORWINDEX=0 83 F S ORWINDEX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)) Q:'ORWINDEX D:$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX),"^",1)]"" 84 . S ORITEM=^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX) 85 . I '+$$STATCHK^ICDAPIU($P(ORITEM,"^",3),ORDATE) S $P(ORITEM,"^",11)="#" ;DBIA 3991 86 . S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)=ORITEM 87 S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",0)=ORPRCNT 88 S GLST="^TMP(""IB"","_$J_",""INTERFACES"",""GMP SELECT PATIENT ACTIVE PROBLEMS"")" 89 Q 90 SCSEL(VAL,DFN,ATM,LOC,VST) ; return SC conditions that may be selected 91 ; VAL=SCallow^SCdflt;AOallow^AOdflt;IRallow^IRdflt;ECallow^ECdflt; 92 ; MSTallow^MSTdflt;HNCallow^HNCdflt;CVAllow^CVDflt 93 N ORX,S S S=";" 94 D SCCOND^PXUTLSCC(DFN,ATM,LOC,$G(VST),.ORX) 95 S VAL=$G(ORX("SC"))_S_$G(ORX("AO"))_S_$G(ORX("IR"))_S_$G(ORX("EC"))_S_$G(ORX("MST"))_S_$G(ORX("HNC"))_S_$G(ORX("CV")) 96 Q 97 SCDIS(LST,DFN) ; Return service connected % and rated disabilities 98 N VAEL,VAERR,I,ILST,DIS,SC,X 99 D ELIG^VADPT 100 S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO") 101 I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q 102 S I=0,ILST=1 F S I=$O(^DPT(DFN,.372,I)) Q:'I S X=^(I,0) D 103 . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS="" 104 . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC") 105 . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")" 106 I ILST=1 S LST(2)="Rated Disabilities: NONE STATED" 107 Q 108 CPTREQD(VAL,IEN) ; return 1 in VAL if note still needs a CPT code 109 S VAL=+$P(^TIU(8925,IEN,0),U,11) 110 Q 111 NOTEVSTR(VAL,IEN) ; return the VSTR^AUTHOR for a note 112 N X0,X12,VISIT 113 S X0=$G(^TIU(8925,+IEN,0)),X12=$G(^(12)),VISIT=$P(X12,U,7) 114 I +VISIT S VAL=$$VSTRBLD^TIUSRVP(VISIT) I 1 115 E S VAL=$P(X12,U,11)_";"_$P(X0,U,7)_";"_$P(X0,U,13) 116 Q 117 HASVISIT(ORY,IEN,DFN,ORLOC,ORDTE) ;Has visit or is stand alone 118 N ORVISIT 119 S ORY=-1 120 I +$G(IEN)>0 S ORVISIT=+$P($G(^TIU(8925,+IEN,0)),U,3) 121 I +$G(ORVISIT)'>0 S ORVISIT=$$GETENC^PXAPI(DFN,ORDTE,ORLOC) 122 I +$G(ORVISIT)>0 S ORY=$$VST2APPT^PXAPI(ORVISIT) 123 Q 124 DELETE(VAL,VSTR,DFN) ; delete PCE info when deleting a note 125 N VISIT,ORCOUNT 126 N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK 127 I '$D(^TMP("ORWPCE",$J,VSTR)) S VAL=0 Q ; no PCE data saved yet 128 I $P(VSTR,";",3)="H" S VAL=0 Q ; leave inpatient alone 129 I $L($T(DOCCNT^TIUSRVLV))=0 S VAL=0 Q ; leave if no tiu entry point 130 D DOCCNT^TIUSRVLV(.ORCOUNT,DFN,VSTR) ; Do not delete if another 131 I ORCOUNT>0 S VAL=0 Q ; title points to visit 132 S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQDEL^ORWPCE1",ZTDTH=$H 133 S (ZTSAVE("VSTR"),ZTSAVE("DFN"))="",ZTDESC="CPRS Delete Note/PCE" 134 S ZTSYNC="ORW"_VSTR 135 D ^%ZTLOAD I '$D(ZTSK) D DQDEL^ORWPCE1 136 Q 137 SAVE(OK,PCELIST,NOTEIEN,ORLOC) ; save PCE information 138 N VSTR,GMPLUSER 139 N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK 140 S VSTR=$P(PCELIST(1),U,4) K ^TMP("ORWPCE",$J,VSTR) 141 M ^TMP("ORWPCE",$J,VSTR)=PCELIST 142 S GMPLUSER=$$CLINUSER^ORQQPL1(DUZ),NOTEIEN=+$G(NOTEIEN) 143 S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQSAVE^ORWPCE1",ZTDTH=$H 144 S ZTSAVE("PCELIST(")="",ZTDESC="Data from CPRS to PCE" 145 S ZTSAVE("GMPLUSER")="",ZTSAVE("NOTEIEN")="",ZTSAVE("DUZ")="" 146 I VSTR'["E" S ZTSYNC="ORW"_VSTR 147 S ZTSAVE("ORLOC")="" 148 D ^%ZTLOAD I '$D(ZTSK) D DQSAVE^ORWPCE1 149 Q 150 LEX(LST,X,APP,ORDATE) ; return list after lexicon lookup 151 N LEX,ILST,I,IEN 152 S:APP="CPT" APP="CHP" ; LEX PATCH 10 153 S:'+$G(ORDATE) ORDATE=DT 154 D CONFIG^LEXSET(APP,APP,ORDATE) ;DBIA 1609 155 I APP="CHP" D 156 . ; Set the filter for CPT only using CS APIs - format is the same as for DIC("S") 157 . S ^TMP("LEXSCH",$J,"FIL",0)="I $L($$CPTONE^LEXU(+Y,$G(ORDATE)))!($L($$CPCONE^LEXU(+Y,$G(ORDATE))))" ;DBIA 1609 158 . ; Set Applications Default Flag (Lexicon can not overwrite filter) 159 . S ^TMP("LEXSCH",$J,"ADF",0)=1 160 D LOOK^LEXA(X,APP,1,"",ORDATE) 161 I '$D(LEX("LIST",1)) S LST(1)="-1^No matches found." Q 162 S LST(1)=LEX("LIST",1),ILST=1 163 S (I,IEN)="" 164 F S I=$O(^TMP("LEXFND",$J,I)) Q:I="" D ;DBIA 2950 165 .F S IEN=$O(^TMP("LEXFND",$J,I,IEN)) Q:IEN="" D 166 ..S ILST=ILST+1,LST(ILST)=IEN_U_^TMP("LEXFND",$J,I,IEN) 167 K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J) 168 Q 169 LEXCODE(VAL,IEN,APP,ORDATE) ; return code for a lexicon entry 170 S VAL="" 171 S:'+$G(ORDATE) ORDATE=DT 172 I APP="ICD" S VAL=$$ICDONE^LEXU(IEN,ORDATE) 173 I APP="CPT"!(APP="CHP") S VAL=$$CPTONE^LEXU(IEN,ORDATE) ; LEX PATCH 10 174 I VAL="",(APP="CHP") S VAL=$$CPCONE^LEXU(IEN,ORDATE) ; LEX PATCH 10 175 Q 176 ADDRES ; Add the ORW/PXAPI RESOURCE device 177 N X 178 S X=$$RES^XUDHSET("ORW/PXAPI RESOURCE",,5,"CPRS to PCE transactions") 179 Q 180 GETSVC(NEWSVC,SVC,LOC,INP) ; Returns the correct Service Connected Category 181 N DSS,ORWSVC 182 S DSS=$P($G(^SC(+LOC,0)),U,7) 183 Q:'+DSS 184 M ORWSVC=SVC 185 S NEWSVC=$$SVC^PXKCO(.ORWSVC,DSS,INP,LOC) ; DBIA #3225 186 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE1.m
r613 r623 1 ORWPCE1 ;SLC/KCM - PCE Calls from CPRS GUI; 10/26/04 ;4/9/08 07:44 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,187,190,215,243**;Dec 17, 1997;Build 242 3 ; 4 ; DBIA 1365 DSELECT^GMPLENFM ^TMP("IB",$J) 5 ; 6 GETVSIT(VSTR,DFN) ; lookup a visit 7 N PKG,SRC,ORPXAPI,OK,ORVISIT 8 S PKG=$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",0)) 9 S SRC="TEXT INTEGRATION UTILITIES" 10 S ORPXAPI("ENCOUNTER",1,"ENC D/T")=$P(VSTR,";",2) 11 S ORPXAPI("ENCOUNTER",1,"PATIENT")=DFN 12 S ORPXAPI("ENCOUNTER",1,"HOS LOC")=+VSTR 13 S ORPXAPI("ENCOUNTER",1,"SERVICE CATEGORY")=$P(VSTR,";",3) 14 S ORPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P" 15 S OK=$$DATA2PCE^PXAPI("ORPXAPI",PKG,SRC,.ORVISIT) 16 Q ORVISIT 17 DQDEL ; background call to DATA2PCE and DELVFILE 18 N VISIT,VAL 19 I $D(ZTQUEUED) S ZTREQ="@" 20 S VISIT=$$GETVSIT(VSTR,DFN) 21 S VAL=$$DELVFILE^PXAPI("ALL",VISIT,"","TEXT INTEGRATION UTILITIES") 22 S ZTSTAT=0 ; clear sync flag 23 Q 24 DQSAVE ; Background Call to DATA2PCE 25 N PKG,SRC,TYP,CODE,IEN,OK,I,X,ORPXAPI,ORPXDEL 26 N CAT,NARR,ROOT,ROOT2,ORAVST 27 N PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT,MOD,MODCNT,MODIDX,MODS 28 N COM,COMMENT,COMMENTS 29 N DFN,PROBLEMS,PXAPREDT,ORCPTDEL 30 I $D(ZTQUEUED) S ZTREQ="@" 31 S PKG=$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",0)) 32 S SRC="TEXT INTEGRATION UTILITIES" 33 S (PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT)=0 34 S I="" F S I=$O(PCELIST(I)) Q:'I S X=PCELIST(I) D 35 . S X=PCELIST(I),TYP=$P(X,U),CODE=$P(X,U,2),CAT=$P(X,U,3),NARR=$P(X,U,4) 36 . I $E(TYP,1,3)="PRV" D Q 37 . . Q:'$L(CODE) 38 . . S PRV=PRV+1 39 . . S ROOT="ORPXAPI(""PROVIDER"","_PRV_")" 40 . . S ROOT2="ORPXDEL(""PROVIDER"","_PRV_")" 41 . . I $E(TYP,4)'="-" D 42 . . . S @ROOT@("NAME")=CODE 43 . . . S @ROOT@("PRIMARY")=$P(X,U,6) 44 . . S @ROOT2@("NAME")=CODE 45 . . S @ROOT2@("DELETE")=1 46 . . S PXAPREDT=1 ;Allow edit of primary flag 47 . I TYP="VST" D Q 48 . . S ROOT="ORPXAPI(""ENCOUNTER"",1)" 49 . . I CODE="DT" S @ROOT@("ENC D/T")=$P(X,U,3) Q 50 . . I CODE="PT" S @ROOT@("PATIENT")=$P(X,U,3),DFN=$P(X,U,3) Q 51 . . I CODE="HL" S @ROOT@("HOS LOC")=$P(X,U,3) Q 52 . . I CODE="PR" S @ROOT@("PARENT")=$P(X,U,3) Q 53 . . ;prevents checkout! 54 . . I CODE="VC" S @ROOT@("SERVICE CATEGORY")=$P(X,U,3) Q 55 . . I CODE="SC" S @ROOT@("SC")=$P(X,U,3) Q 56 . . I CODE="AO" S @ROOT@("AO")=$P(X,U,3) Q 57 . . I CODE="IR" S @ROOT@("IR")=$P(X,U,3) Q 58 . . I CODE="EC" S @ROOT@("EC")=$P(X,U,3) Q 59 . . I CODE="MST" S @ROOT@("MST")=$P(X,U,3) Q 60 . . I CODE="HNC" S @ROOT@("HNC")=$P(X,U,3) Q 61 . . I CODE="CV" S @ROOT@("CV")=$P(X,U,3) Q 62 . . I CODE="SHD" S @ROOT@("SHAD")=$P(X,U,3) Q 63 . . I CODE="OL" D Q 64 . . . I +$P(X,U,3) S @ROOT@("INSTITUTION")=$P(X,U,3) 65 . . . E I $P(X,U,4)'="",$P(X,U,4)'="0" D 66 . . . . I $$PATCH^XPDUTL("PX*1.0*96") S @ROOT@("OUTSIDE LOCATION")=$P(X,U,4) 67 . . . . E S @ROOT@("COMMENT")="OUTSIDE LOCATION: "_$P(X,U,4) 68 . I $E(TYP,1,3)="CPT" D Q 69 . . Q:'$L(CODE) 70 . . S CPT=CPT+1,ROOT="ORPXAPI(""PROCEDURE"","_CPT_")" 71 . . S IEN=+$O(^ICPT("B",CODE,0)) 72 . . S @ROOT@("PROCEDURE")=IEN 73 . . I +$P(X,U,9) D 74 . . . S MODS=$P(X,U,9),MODCNT=+MODS 75 . . . F MODIDX=1:1:MODCNT D 76 . . . . S MOD=$P($P(MODS,";",MODIDX+1),"/") 77 . . . . S @ROOT@("MODIFIERS",MOD)="" 78 . . S:$L(CAT) @ROOT@("CATEGORY")=CAT 79 . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR 80 . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5) 81 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 82 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PROCEDURE^"_CPT 83 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0,ORCPTDEL=CPT 84 . I $E(TYP,1,3)="POV" D Q 85 . . Q:'$L(CODE) 86 . . S ICD=ICD+1,ROOT="ORPXAPI(""DX/PL"","_ICD_")" 87 . . S IEN=+$O(^ICD9("AB",CODE_" ",0)) 88 . . S @ROOT@("DIAGNOSIS")=IEN 89 . . S @ROOT@("PRIMARY")=$P(X,U,5) 90 . . S:$L(CAT) @ROOT@("CATEGORY")=CAT 91 . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR 92 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 93 . . I $L($P(X,U,7)),$P(X,U,7)=1 S @ROOT@("PL ADD")=$P(X,U,7),PROBLEMS(ICD)=NARR_U_CODE 94 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="DX/PL^"_ICD 95 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 96 . I $E(TYP,1,3)="IMM" D Q 97 . . Q:'$L(CODE) 98 . . S IMM=IMM+1,ROOT="ORPXAPI(""IMMUNIZATION"","_IMM_")" 99 . . S @ROOT@("IMMUN")=CODE 100 . . S:$L($P(X,U,5)) @ROOT@("SERIES")=$P(X,U,5) 101 . . S:$L($P(X,U,5)) @ROOT@("REACTION")=$P(X,U,7) 102 . . S:$L($P(X,U,8)) @ROOT@("CONTRAINDICATED")=$P(X,U,8) 103 . . S:$L($P(X,U,9)) @ROOT@("REFUSED")=$P(X,U,9) 104 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 105 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="IMMUNIZATION^"_IMM 106 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 107 . I $E(TYP,1,2)="SK" D Q 108 . . Q:'$L(CODE) 109 . . S SK=SK+1,ROOT="ORPXAPI(""SKIN TEST"","_SK_")" 110 . . S @ROOT@("TEST")=CODE 111 . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5) 112 . . S:$L($P(X,U,7)) @ROOT@("READING")=$P(X,U,7) 113 . . S:$L($P(X,U,8)) @ROOT@("D/T READ")=$P(X,U,8) 114 . . S:$L($P(X,U,9)) @ROOT@("EVENT D/T")=$P(X,U,9) 115 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 116 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="SKIN TEST^"_SK 117 . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1 118 . I $E(TYP,1,3)="PED" D Q 119 . . Q:'$L(CODE) 120 . . S PED=PED+1,ROOT="ORPXAPI(""PATIENT ED"","_PED_")" 121 . . S @ROOT@("TOPIC")=CODE 122 . . S:$L($P(X,U,5)) @ROOT@("UNDERSTANDING")=$P(X,U,5) 123 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 124 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PATIENT ED^"_PED 125 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 126 . I $E(TYP,1,2)="HF" D Q 127 . . Q:'$L(CODE) 128 . . S HF=HF+1,ROOT="ORPXAPI(""HEALTH FACTOR"","_HF_")" 129 . . S @ROOT@("HEALTH FACTOR")=CODE 130 . . S:$L($P(X,U,5)) @ROOT@("LEVEL/SEVERITY")=$P(X,U,5) 131 . . S:$P(X,U,6)'>0 $P(X,U,6)=$G(ORPXAPI("PROVIDER",1,"NAME")) 132 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 133 . . S:$L($P(X,U,11)) @ROOT@("EVENT D/T")=$P($P(X,U,11),";",1) 134 . . S:$L($P(X,U,11)) SRC=$P($P(X,U,11),";",2) 135 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="HEALTH FACTOR^"_HF 136 . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1 137 . I $E(TYP,1,3)="XAM" D Q 138 . . Q:'$L(CODE) 139 . . S XAM=XAM+1,ROOT="ORPXAPI(""EXAM"","_XAM_")" 140 . . S @ROOT@("EXAM")=CODE 141 . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5) 142 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 143 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="EXAM^"_XAM 144 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 145 . I $E(TYP,1,3)="TRT" D Q 146 . . Q:'$L(CODE) 147 . . S TRT=TRT+1,ROOT="ORPXAPI(""TREATMENT"","_TRT_")" 148 . . S @ROOT@("IMMUN")=CODE 149 . . S:$L(CAT) @ROOT@("CATEGORY")=CAT 150 . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR 151 . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5) 152 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 153 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="TREATMENT^"_TRT 154 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0 155 . I $E(TYP,1,3)="COM" D Q 156 . . Q:'$L(CODE) 157 . . Q:'$L(CAT) 158 . . S COMMENTS(CODE)=$P(X,U,3,999) 159 ;Store the comments 160 S COM="" 161 F S COM=$O(COMMENT(COM)) Q:COM="" S:$D(COMMENTS(COM)) ORPXAPI($P(COMMENT(COM),"^",1),$P(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM) 162 ; 163 ;Remove any problems to add that the patient already has as active problems 164 I $D(PROBLEMS),$D(DFN) D 165 . N ORWPROB,ORPROBIX 166 . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS") 167 . D DSELECT^GMPLENFM ;DBIA 1365 168 . S ORPROBIX=0 169 . F S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX D ;DBIA 1365 170 .. S ORWPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3) 171 .. S ORWPROB($S($E(ORWPROB,1)="$":$E(ORWPROB,2,255),1:ORWPROB))="" 172 . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS") 173 . Q:'$D(ORWPROB) 174 . S ORPROBIX="" 175 . F S ORPROBIX=$O(PROBLEMS(ORPROBIX)) Q:'ORPROBIX D 176 .. S:$D(ORWPROB(PROBLEMS(ORPROBIX))) ORPXAPI("DX/PL",ORPROBIX,"PL ADD")=0 177 ; 178 I $$MDS(.ORPXAPI,$G(ORLOC)) S ORPXAPI("ENCOUNTER",1,"CHECKOUT D/T")=$$NOW^XLFDT 179 S ORPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P" 180 DATA2PCE ; 181 I $G(PXAPREDT)!($G(ORCPTDEL)) D 182 . M ORPXDEL("ENCOUNTER")=ORPXAPI("ENCOUNTER") 183 . I $G(ORCPTDEL) M ORPXDEL("PROCEDURE",ORCPTDEL)=ORPXAPI("PROCEDURE",ORCPTDEL) 184 . S OK=$$DATA2PCE^PXAPI("ORPXDEL",PKG,SRC,.ORAVST) 185 S OK=$$DATA2PCE^PXAPI("ORPXAPI",PKG,SRC,.ORAVST) 186 I OK>0,+NOTEIEN,+ORAVST D ; NOTEIEN only set on inpatient encounters 187 .N OROK,ORX 188 .S ORX(1207)=ORAVST 189 .D FILE^TIUSRVP(.OROK,NOTEIEN,.ORX,1) 190 S ZTSTAT=0 ; clear sync flag 191 Q 192 ; 193 MDS(X,ORLOC) ; return TRUE if checkout is needed 194 I $$CHKOUT^ORWPCE2(ORLOC) Q 1 195 N I,ORAUTO,OROK 196 S (OROK,I)=0 197 F S I=$O(X("DX/PL",I)) Q:'I D Q:OROK 198 . I $G(X("DX/PL",I,"DIAGNOSIS")) S OROK=1 199 I 'OROK D 200 .S I=0 F S I=$O(X("PROCEDURE",I)) Q:'I D Q:OROK 201 .. I $G(X("PROCEDURE",I,"PROCEDURE")) S OROK=1 202 I $D(X("PROVIDER",1,"NAME")) S OROK=1 203 Q OROK 204 NONCOUNT(ORY,ORLOC) ; Is the location a non-count clinic? (DBIA #964) 205 Q:'ORLOC 206 S ORY=$S($P($G(^SC(ORLOC,0)),U,17)="Y":1,1:0) 207 Q 1 ORWPCE1 ;SLC/KCM - PCE Calls from CPRS GUI; 10/26/04 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,187,190,215**;Dec 17, 1997 3 ; 4 ; DBIA 1365 DSELECT^GMPLENFM ^TMP("IB",$J) 5 ; 6 GETVSIT(VSTR,DFN) ; lookup a visit 7 N PKG,SRC,ORPXAPI,OK,ORVISIT 8 S PKG=$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",0)) 9 S SRC="TEXT INTEGRATION UTILITIES" 10 S ORPXAPI("ENCOUNTER",1,"ENC D/T")=$P(VSTR,";",2) 11 S ORPXAPI("ENCOUNTER",1,"PATIENT")=DFN 12 S ORPXAPI("ENCOUNTER",1,"HOS LOC")=+VSTR 13 S ORPXAPI("ENCOUNTER",1,"SERVICE CATEGORY")=$P(VSTR,";",3) 14 S ORPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P" 15 S OK=$$DATA2PCE^PXAPI("ORPXAPI",PKG,SRC,.ORVISIT) 16 Q ORVISIT 17 DQDEL ; background call to DATA2PCE and DELVFILE 18 N VISIT,VAL 19 I $D(ZTQUEUED) S ZTREQ="@" 20 S VISIT=$$GETVSIT(VSTR,DFN) 21 S VAL=$$DELVFILE^PXAPI("ALL",VISIT,"","TEXT INTEGRATION UTILITIES") 22 S ZTSTAT=0 ; clear sync flag 23 Q 24 DQSAVE ; Background Call to DATA2PCE 25 N PKG,SRC,TYP,CODE,IEN,OK,I,X,ORPXAPI,ORPXDEL 26 N CAT,NARR,ROOT,ROOT2,ORAVST 27 N PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT,MOD,MODCNT,MODIDX,MODS 28 N COM,COMMENT,COMMENTS 29 N DFN,PROBLEMS,PXAPREDT,ORCPTDEL 30 I $D(ZTQUEUED) S ZTREQ="@" 31 S PKG=$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",0)) 32 S SRC="TEXT INTEGRATION UTILITIES" 33 S (PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT)=0 34 S I="" F S I=$O(PCELIST(I)) Q:'I S X=PCELIST(I) D 35 . S X=PCELIST(I),TYP=$P(X,U),CODE=$P(X,U,2),CAT=$P(X,U,3),NARR=$P(X,U,4) 36 . I $E(TYP,1,3)="PRV" D Q 37 . . Q:'$L(CODE) 38 . . S PRV=PRV+1 39 . . S ROOT="ORPXAPI(""PROVIDER"","_PRV_")" 40 . . S ROOT2="ORPXDEL(""PROVIDER"","_PRV_")" 41 . . I $E(TYP,4)'="-" D 42 . . . S @ROOT@("NAME")=CODE 43 . . . S @ROOT@("PRIMARY")=$P(X,U,6) 44 . . S @ROOT2@("NAME")=CODE 45 . . S @ROOT2@("DELETE")=1 46 . . S PXAPREDT=1 ;Allow edit of primary flag 47 . I TYP="VST" D Q 48 . . S ROOT="ORPXAPI(""ENCOUNTER"",1)" 49 . . I CODE="DT" S @ROOT@("ENC D/T")=$P(X,U,3) Q 50 . . I CODE="PT" S @ROOT@("PATIENT")=$P(X,U,3),DFN=$P(X,U,3) Q 51 . . I CODE="HL" S @ROOT@("HOS LOC")=$P(X,U,3) Q 52 . . I CODE="PR" S @ROOT@("PARENT")=$P(X,U,3) Q 53 . . ;prevents checkout! 54 . . I CODE="VC" S @ROOT@("SERVICE CATEGORY")=$P(X,U,3) Q 55 . . I CODE="SC" S @ROOT@("SC")=$P(X,U,3) Q 56 . . I CODE="AO" S @ROOT@("AO")=$P(X,U,3) Q 57 . . I CODE="IR" S @ROOT@("IR")=$P(X,U,3) Q 58 . . I CODE="EC" S @ROOT@("EC")=$P(X,U,3) Q 59 . . I CODE="MST" S @ROOT@("MST")=$P(X,U,3) Q 60 . . I CODE="HNC" S @ROOT@("HNC")=$P(X,U,3) Q 61 . . I CODE="CV" S @ROOT@("CV")=$P(X,U,3) Q 62 . . I CODE="OL" D Q 63 . . . I +$P(X,U,3) S @ROOT@("INSTITUTION")=$P(X,U,3) 64 . . . E I $P(X,U,4)'="",$P(X,U,4)'="0" D 65 . . . . I $$PATCH^XPDUTL("PX*1.0*96") S @ROOT@("OUTSIDE LOCATION")=$P(X,U,4) 66 . . . . E S @ROOT@("COMMENT")="OUTSIDE LOCATION: "_$P(X,U,4) 67 . I $E(TYP,1,3)="CPT" D Q 68 . . Q:'$L(CODE) 69 . . S CPT=CPT+1,ROOT="ORPXAPI(""PROCEDURE"","_CPT_")" 70 . . S IEN=+$O(^ICPT("B",CODE,0)) 71 . . S @ROOT@("PROCEDURE")=IEN 72 . . I +$P(X,U,9) D 73 . . . S MODS=$P(X,U,9),MODCNT=+MODS 74 . . . F MODIDX=1:1:MODCNT D 75 . . . . S MOD=$P($P(MODS,";",MODIDX+1),"/") 76 . . . . S @ROOT@("MODIFIERS",MOD)="" 77 . . S:$L(CAT) @ROOT@("CATEGORY")=CAT 78 . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR 79 . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5) 80 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 81 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PROCEDURE^"_CPT 82 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0,ORCPTDEL=CPT 83 . I $E(TYP,1,3)="POV" D Q 84 . . Q:'$L(CODE) 85 . . S ICD=ICD+1,ROOT="ORPXAPI(""DX/PL"","_ICD_")" 86 . . S IEN=+$O(^ICD9("AB",CODE_" ",0)) 87 . . S @ROOT@("DIAGNOSIS")=IEN 88 . . S @ROOT@("PRIMARY")=$P(X,U,5) 89 . . S:$L(CAT) @ROOT@("CATEGORY")=CAT 90 . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR 91 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 92 . . I $L($P(X,U,7)),$P(X,U,7)=1 S @ROOT@("PL ADD")=$P(X,U,7),PROBLEMS(ICD)=NARR_U_CODE 93 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="DX/PL^"_ICD 94 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 95 . I $E(TYP,1,3)="IMM" D Q 96 . . Q:'$L(CODE) 97 . . S IMM=IMM+1,ROOT="ORPXAPI(""IMMUNIZATION"","_IMM_")" 98 . . S @ROOT@("IMMUN")=CODE 99 . . S:$L($P(X,U,5)) @ROOT@("SERIES")=$P(X,U,5) 100 . . S:$L($P(X,U,5)) @ROOT@("REACTION")=$P(X,U,7) 101 . . S:$L($P(X,U,8)) @ROOT@("CONTRAINDICATED")=$P(X,U,8) 102 . . S:$L($P(X,U,9)) @ROOT@("REFUSED")=$P(X,U,9) 103 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 104 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="IMMUNIZATION^"_IMM 105 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 106 . I $E(TYP,1,2)="SK" D Q 107 . . Q:'$L(CODE) 108 . . S SK=SK+1,ROOT="ORPXAPI(""SKIN TEST"","_SK_")" 109 . . S @ROOT@("TEST")=CODE 110 . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5) 111 . . S:$L($P(X,U,7)) @ROOT@("READING")=$P(X,U,7) 112 . . S:$L($P(X,U,8)) @ROOT@("D/T READ")=$P(X,U,8) 113 . . S:$L($P(X,U,9)) @ROOT@("EVENT D/T")=$P(X,U,9) 114 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 115 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="SKIN TEST^"_SK 116 . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1 117 . I $E(TYP,1,3)="PED" D Q 118 . . Q:'$L(CODE) 119 . . S PED=PED+1,ROOT="ORPXAPI(""PATIENT ED"","_PED_")" 120 . . S @ROOT@("TOPIC")=CODE 121 . . S:$L($P(X,U,5)) @ROOT@("UNDERSTANDING")=$P(X,U,5) 122 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 123 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PATIENT ED^"_PED 124 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 125 . I $E(TYP,1,2)="HF" D Q 126 . . Q:'$L(CODE) 127 . . S HF=HF+1,ROOT="ORPXAPI(""HEALTH FACTOR"","_HF_")" 128 . . S @ROOT@("HEALTH FACTOR")=CODE 129 . . S:$L($P(X,U,5)) @ROOT@("LEVEL/SEVERITY")=$P(X,U,5) 130 . . S:$P(X,U,6)'>0 $P(X,U,6)=$G(ORPXAPI("PROVIDER",1,"NAME")) 131 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 132 . . S:$L($P(X,U,11)) @ROOT@("EVENT D/T")=$P($P(X,U,11),";",1) 133 . . S:$L($P(X,U,11)) SRC=$P($P(X,U,11),";",2) 134 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="HEALTH FACTOR^"_HF 135 . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1 136 . I $E(TYP,1,3)="XAM" D Q 137 . . Q:'$L(CODE) 138 . . S XAM=XAM+1,ROOT="ORPXAPI(""EXAM"","_XAM_")" 139 . . S @ROOT@("EXAM")=CODE 140 . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5) 141 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 142 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="EXAM^"_XAM 143 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 144 . I $E(TYP,1,3)="TRT" D Q 145 . . Q:'$L(CODE) 146 . . S TRT=TRT+1,ROOT="ORPXAPI(""TREATMENT"","_TRT_")" 147 . . S @ROOT@("IMMUN")=CODE 148 . . S:$L(CAT) @ROOT@("CATEGORY")=CAT 149 . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR 150 . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5) 151 . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) 152 . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="TREATMENT^"_TRT 153 . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0 154 . I $E(TYP,1,3)="COM" D Q 155 . . Q:'$L(CODE) 156 . . Q:'$L(CAT) 157 . . S COMMENTS(CODE)=$P(X,U,3,999) 158 ;Store the comments 159 S COM="" 160 F S COM=$O(COMMENT(COM)) Q:COM="" S:$D(COMMENTS(COM)) ORPXAPI($P(COMMENT(COM),"^",1),$P(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM) 161 ; 162 ;Remove any problems to add that the patient already has as active problems 163 I $D(PROBLEMS),$D(DFN) D 164 . N ORWPROB,ORPROBIX 165 . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS") 166 . D DSELECT^GMPLENFM ;DBIA 1365 167 . S ORPROBIX=0 168 . F S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX D ;DBIA 1365 169 .. S ORWPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3) 170 .. S ORWPROB($S($E(ORWPROB,1)="$":$E(ORWPROB,2,255),1:ORWPROB))="" 171 . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS") 172 . Q:'$D(ORWPROB) 173 . S ORPROBIX="" 174 . F S ORPROBIX=$O(PROBLEMS(ORPROBIX)) Q:'ORPROBIX D 175 .. S:$D(ORWPROB(PROBLEMS(ORPROBIX))) ORPXAPI("DX/PL",ORPROBIX,"PL ADD")=0 176 ; 177 I $$MDS(.ORPXAPI,$G(ORLOC)) S ORPXAPI("ENCOUNTER",1,"CHECKOUT D/T")=$$NOW^XLFDT 178 S ORPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P" 179 DATA2PCE ; 180 I $G(PXAPREDT)!($G(ORCPTDEL)) D 181 . M ORPXDEL("ENCOUNTER")=ORPXAPI("ENCOUNTER") 182 . I $G(ORCPTDEL) M ORPXDEL("PROCEDURE",ORCPTDEL)=ORPXAPI("PROCEDURE",ORCPTDEL) 183 . S OK=$$DATA2PCE^PXAPI("ORPXDEL",PKG,SRC,.ORAVST) 184 S OK=$$DATA2PCE^PXAPI("ORPXAPI",PKG,SRC,.ORAVST) 185 I OK>0,+NOTEIEN,+ORAVST D ; NOTEIEN only set on inpatient encounters 186 .N OROK,ORX 187 .S ORX(1207)=ORAVST 188 .D FILE^TIUSRVP(.OROK,NOTEIEN,.ORX,1) 189 S ZTSTAT=0 ; clear sync flag 190 Q 191 ; 192 MDS(X,ORLOC) ; return TRUE if checkout is needed 193 I $$CHKOUT^ORWPCE2(ORLOC) Q 1 194 N I,ORAUTO,OROK 195 S (OROK,I)=0 196 F S I=$O(X("DX/PL",I)) Q:'I D Q:OROK 197 . I $G(X("DX/PL",I,"DIAGNOSIS")) S OROK=1 198 I 'OROK D 199 .S I=0 F S I=$O(X("PROCEDURE",I)) Q:'I D Q:OROK 200 .. I $G(X("PROCEDURE",I,"PROCEDURE")) S OROK=1 201 I $D(X("PROVIDER",1,"NAME")) S OROK=1 202 Q OROK 203 NONCOUNT(ORY,ORLOC) ; Is the location a non-count clinic? (DBIA #964) 204 Q:'ORLOC 205 S ORY=$S($P($G(^SC(ORLOC,0)),U,17)="Y":1,1:0) 206 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE2.m
r613 r623 1 ORWPCE2 ; ISL/JM/RV - wrap calls to PCE ;04/06/2006 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,173,195,243**;Dec 17, 1997;Build 242 3 GETSET(ORWLST,ORWFILE,ORWFIELD,ORWNULL) ;gets set of codes 4 ; ORWLST(n)=code^text for code 5 N ORWPCE,ORWPCEL,ORWPCEC,ORWPCELO,ORWPCEHI,ORWPCECD,ORWPCET 6 S ORWPCELO="abcdefghijklmnopqrstuvwxyz" 7 S ORWPCEHI="ABCDEFGHIJKLMNOPQRSTUVWXYZ" 8 D FIELD^DID(ORWFILE,ORWFIELD,"","POINTER","ORWPCE","ORWPCE") 9 S ORWPCEL=$L(ORWPCE("POINTER"),";")-1 10 F ORWPCEC=1:1:ORWPCEL D 11 . S ORWPCECD=$P($P(ORWPCE("POINTER"),";",ORWPCEC),":",1) 12 . S ORWPCET=$P($P(ORWPCE("POINTER"),";",ORWPCEC),":",2) 13 . S ORWLST(ORWPCEC)=ORWPCECD_"^"_$E(ORWPCET)_$TR($E(ORWPCET,2,99),ORWPCEHI,ORWPCELO) 14 S:$G(ORWNULL) ORWLST(0)="@^(None selected)" 15 Q 16 ; 17 IMMTYPE(ORWLST,ORDT) ;get the list of active immunizations 18 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 19 S:'$G(ORDT) ORDT=DT 20 F S BINDEX=$O(^AUTTIMM("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN D 21 . I $D(^AUTTIMM(IEN,0))#2,+$P(^(0),"^",7)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") 22 . ;I $D(^AUTTIMM(IEN,0))#2,+$$SCREEN^XTID(9999999.14,,IEN,ORDT)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") 23 Q 24 ; 25 SKTYPE(ORWLST,ORDT) ;get the list of active skin test 26 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 27 S:'$G(ORDT) ORDT=DT 28 F S BINDEX=$O(^AUTTSK("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN D 29 . I $D(^AUTTSK(IEN,0))#2,+$P(^(0),"^",3)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") 30 . ;I $D(^AUTTSK(IEN,0))#2,+$$SCREEN^XTID(9999999.28,,IEN,ORDT)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") 31 Q 32 ; 33 EDTTYPE(ORWLST) ;get the list of active education topics 34 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 35 F S BINDEX=$O(^AUTTEDT("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTEDT(IEN,0))#2,+$P(^(0),"^",3)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") 36 Q 37 ; 38 HFTYPE(ORWLST,ADDCATS) ;get the list of active health factors 39 N IEN,CNT,BINDEX,REC 40 S (IEN,CNT,BINDEX)=0,ADDCATS=+$G(ADDCATS) 41 F S BINDEX=$O(^AUTTHF("B",BINDEX)) Q:BINDEX']"" D 42 .F S IEN=$O(^AUTTHF("B",BINDEX,IEN)) Q:'+IEN D 43 ..S REC=$G(^AUTTHF(IEN,0)) 44 ..I +$P(REC,U,11) S REC="" 45 ..I 'ADDCATS,$P(REC,U,10)="C" S REC="" 46 ..I REC'="" D 47 ...S CNT=CNT+1,ORWLST(CNT)=IEN_U_$P(REC,U) 48 ...I ADDCATS S ORWLST(CNT)=ORWLST(CNT)_U_$P(REC,U,10)_U_$P(REC,U,3) 49 Q 50 ; 51 EXAMTYPE(ORWLST) ;get the list of active exams 52 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 53 F S BINDEX=$O(^AUTTEXAM("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTEXAM(IEN,0))#2,+$P(^(0),"^",4)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") 54 Q 55 ; 56 TRTTYPE(ORWLST) ;get the list of active treatments 57 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 58 F S BINDEX=$O(^AUTTTRT("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTTRT(IEN,0))#2,+$P(^(0),"^",4)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") 59 Q 60 ; 61 ACTIVPRV(ORRETURN,ORWPROV,ORWDT) ;get if provider is active or not 62 S ORRETURN=$$ACTIVPRV^PXAPI(ORWPROV,ORWDT) 63 Q 64 GETVISIT(VISIT,IEN,DFN,VSITSTR) ;Get the visit IEN 65 I +$G(IEN)<1 D I 1 66 .S VISIT=$$GETENC^PXAPI(DFN,$P(VSITSTR,";",2),$P(VSITSTR,";")) 67 E S VISIT=$P(^TIU(8925,IEN,0),U,3) 68 Q 69 GAFOK(ORY) ; Returns true if all supporting MH GAF Code exists 70 S ORY=0 71 I $T(GAFHX^YSGAFAPI)'="",$T(ENT^YSGAFAP1)'="" S ORY=1 72 Q 73 MHCLINIC(ORY,ORIEN) ; See if this is a mental health clinic 74 I $T(MHCLIN^SDUTL2)="" S ORY=1 75 E S ORY=$$MHCLIN^SDUTL2(ORIEN) 76 Q 77 LOADGAF(ORY,ORINPUT) ; Retrieve GAF scores 78 D GAFHX^YSGAFAPI(.ORY,.ORINPUT) 79 Q 80 SAVEGAF(ORY,ORINPUT) ; Save new GAF score 81 N ORDATA 82 D ENT^YSGAFAP1(.ORDATA,.ORINPUT) 83 S ORY=($G(ORDATA(1))="[DATA]") 84 Q 85 FORCE(ORY,USER,LOC) ; Retrieve FORCE GUI PCE Entry for a given User/Location 86 N SRV,ORTMP,ORERR 87 S USER=$G(USER,DUZ) 88 S SRV=$P($G(^VA(200,USER,5)),U) 89 D GETLST^XPAR(.ORTMP,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORWPCE FORCE PCE ENTRY","Q",.ORERR) 90 S ORY=+$P($G(ORTMP(1)),U,2) 91 Q 92 HASCPT(ORY,ORLIST) ; Returns true if there are any mapped CPT Codes 93 N IEN,IDX,FOUND 94 S IDX=0 95 F S IDX=$O(ORLIST(IDX)) Q:'+IDX D 96 . S FOUND=0 97 . S IEN=$$FIND1^DIC(811.1,"","QX",ORLIST(IDX)) 98 . I +IEN S FOUND=+$$GET1^DIQ(811.1,IEN,.05,"I") 99 . S ORY(IDX)=ORLIST(IDX)_"="_FOUND 100 Q 101 ASKPCE(ORY,USER,LOC) ; Returns ORWPCE ASK ENCOUNTER UPDATE parameter value 102 N SRV,ORTMP,ORERR 103 S USER=$G(USER,DUZ) 104 S SRV=$P($G(^VA(200,USER,5)),U) 105 D GETLST^XPAR(.ORTMP,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORWPCE ASK ENCOUNTER UPDATE","Q",.ORERR) 106 S ORY=+$P($G(ORTMP(1)),U,2) 107 Q 108 GAFURL(URL) ;Returns the MH GAF Web Page URL 109 S URL="" 110 I $T(GAFURL^YTAPI5)'="" D 111 .N ORY 112 .D GAFURL^YTAPI5(.ORY) 113 .I $G(ORY(1))="[DATA]" S URL=$G(ORY(2)) 114 Q 115 MHTESTOK(ORY) ; Returns True if all supporting MH Test APIs exist 116 D GAFOK(.ORY) 117 I +ORY,+$G(DUZ),$T(SAVEIT^YTAPI1)'="",$T(PREVIEW^YTAPI4)'="",$T(SHOWALL^YTAPI3)'="",$T(LISTONE^YTAPI)'="",$T(MHS^PXRMRPCC)'="",$T(MHR^PXRMRPCC)'="",$T(MH^PXRMRPCC)'="" D 118 . N SRV 119 . S SRV=$P($G(^VA(200,DUZ,5)),U) 120 . S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM MENTAL HEALTH ACTIVE",1,"Q") 121 . I +ORY S ORY=1 122 Q 123 MHATHRZD(ORY,TEST,USER) ;Indicates that user can score test 124 N ORYS,ORANS 125 I $T(PRIVL^YTAPI5)="" S ORY=1 Q 126 S ORY=0 127 S ORYS("CODE")=TEST 128 S ORYS("STAFF")=USER 129 D PRIVL^YTAPI5(.ORANS,.ORYS) 130 I $G(ORANS(1))="[DATA]" S ORY=+$P($G(ORANS(2)),U,1) 131 Q 132 ANYTIME(ORY) ;Returns status of the ORWPCE ANYTIME ENCOUNTERS parameter 133 N SRV 134 S SRV=$P($G(^VA(200,DUZ,5)),U) 135 S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE ANYTIME ENCOUNTERS",1,"Q") 136 I +ORY S ORY=1 137 Q 138 AUTOVSIT(ORY,LOC) ; Returns TRUE if automatic selection of Visit Type 139 N SRV 140 S SRV=$P($G(^VA(200,DUZ,5)),U) 141 S ORY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE DISABLE AUTO VISIT TYPE",1,"Q") 142 I +ORY S ORY=1 143 S ORY='ORY 144 Q 145 DOCHKOUT(ORY,LOC) ; Returns TRUE if automatic selection of Visit Type 146 N SRV 147 S SRV=$P($G(^VA(200,DUZ,5)),U) 148 S ORY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE DISABLE AUTO CHECKOUT",1,"Q") 149 I +ORY S ORY=1 150 S ORY='ORY 151 Q 152 CHKOUT(LOC) ; Returns TRUE if automatic selection of Visit Type 153 N ORY 154 D DOCHKOUT(.ORY,LOC) 155 Q ORY 156 EXCLUDED(ORY,LOC,TYPE) ; Returns list of excluded PCE data elements 157 N SRV,PARAM 158 S PARAM=$S(TYPE=1:"IMMUNIZATIONS",TYPE=2:"SKIN TESTS",TYPE=3:"PATIENT ED",TYPE=4:"HEALTH FACTORS",TYPE=5:"EXAMS",1:"") 159 Q:PARAM="" 160 S SRV=$P($G(^VA(200,DUZ,5)),U) 161 S PARAM="ORWPCE EXCLUDE "_PARAM 162 D GETLST^XPAR(.ORY,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG",PARAM,"Q",.ORERR) 163 Q 164 ISCLINIC(ORY,ORLOC) ; Returns TRUE if location is a clinic 165 N ORTYP 166 S ORY=0 167 S ORTYP=$$GET1^DIQ(44,+ORLOC,2,"I") 168 I (ORTYP="C")!(ORTYP="M") S ORY=1 169 Q 170 HNCOK(ORY) ; Returns true if Head and/or Neck Cancer is enabled 171 S ORY=0 172 I $$PATCH^XPDUTL("DG*5.3*397"),$$PATCH^XPDUTL("SD*5.3*244"),$$PATCH^XPDUTL("PX*1.0*111"),$$PATCH^XPDUTL("IVM*2.0*46") S ORY=1 173 Q 174 ; 175 CODACTIV(ORY,ORCODE,ORAPP,ORDATE) ; Is code active on the given date? 176 ; Remote procedure: ORWPCE ACTIVE CODE 177 ; ORCODE = ICD or CPT code to be checked 178 ; ORAPP = "ICD" or "CHP" 179 ; ORDATE = Date to be checked (defaults to current date) 180 S:'+$G(ORDATE) ORDATE=DT 181 S ORY=1 182 I ORAPP="ICD" D 183 . S ORY=+$$STATCHK^ICDAPIU(ORCODE,ORDATE) 184 E I ORAPP="CHP" D 185 . S ORY=+$$STATCHK^ICPTAPIU(ORCODE,ORDATE) 186 Q 187 ICDACTIV(ORCODE,ORDATE) ; Check for active ICD code 188 D CODACTIV(.ORY,ORCODE,"ICD",$G(ORDATE)) 189 Q +ORY 190 CPTACTIV(ORCODE,ORDATE) ; Check for active CPT code 191 D CODACTIV(.ORY,ORCODE,"CHP",$G(ORDATE)) 192 Q +ORY 193 CXNOSHOW(ORY,ORDOCIEN) ; Should workload requirement be skipped for this note's visit? 194 ; RETURN VALUE: 0=SKIP ALL GUI WORKLOAD REQUIREMENTS 195 ; 1=CONTINUE WITH OTHER GUI WORKLOAD LOGIC 196 N ORTIU 197 D DOCPARM^TIUSRVP1(.ORTIU,ORDOCIEN) ; DBIA #4331 198 S ORY=+$$CHKWKL^TIUPXAP2(ORDOCIEN,ORTIU(0)) ; DBIA #4332 199 Q 1 ORWPCE2 ; ISL/JM - wrap calls to PCE ;9/25/2001 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,173,195**;Dec 17, 1997 3 GETSET(ORWLST,ORWFILE,ORWFIELD,ORWNULL) ;gets set of codes 4 ; ORWLST(n)=code^text for code 5 N ORWPCE,ORWPCEL,ORWPCEC,ORWPCELO,ORWPCEHI,ORWPCECD,ORWPCET 6 S ORWPCELO="abcdefghijklmnopqrstuvwxyz" 7 S ORWPCEHI="ABCDEFGHIJKLMNOPQRSTUVWXYZ" 8 D FIELD^DID(ORWFILE,ORWFIELD,"","POINTER","ORWPCE","ORWPCE") 9 S ORWPCEL=$L(ORWPCE("POINTER"),";")-1 10 F ORWPCEC=1:1:ORWPCEL D 11 . S ORWPCECD=$P($P(ORWPCE("POINTER"),";",ORWPCEC),":",1) 12 . S ORWPCET=$P($P(ORWPCE("POINTER"),";",ORWPCEC),":",2) 13 . S ORWLST(ORWPCEC)=ORWPCECD_"^"_$E(ORWPCET)_$TR($E(ORWPCET,2,99),ORWPCEHI,ORWPCELO) 14 S:$G(ORWNULL) ORWLST(0)="@^(None selected)" 15 Q 16 ; 17 IMMTYPE(ORWLST) ;get the list of active immunizations 18 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 19 F S BINDEX=$O(^AUTTIMM("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTIMM(IEN,0))#2,+$P(^(0),"^",7)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") 20 Q 21 ; 22 SKTYPE(ORWLST) ;get the list of active skin test 23 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 24 F S BINDEX=$O(^AUTTSK("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTSK(IEN,0))#2,+$P(^(0),"^",3)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") 25 Q 26 ; 27 EDTTYPE(ORWLST) ;get the list of active education topics 28 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 29 F S BINDEX=$O(^AUTTEDT("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTEDT(IEN,0))#2,+$P(^(0),"^",3)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") 30 Q 31 ; 32 HFTYPE(ORWLST,ADDCATS) ;get the list of active health factors 33 N IEN,CNT,BINDEX,REC 34 S (IEN,CNT,BINDEX)=0,ADDCATS=+$G(ADDCATS) 35 F S BINDEX=$O(^AUTTHF("B",BINDEX)) Q:BINDEX']"" D 36 .F S IEN=$O(^AUTTHF("B",BINDEX,IEN)) Q:'+IEN D 37 ..S REC=$G(^AUTTHF(IEN,0)) 38 ..I +$P(REC,U,11) S REC="" 39 ..I 'ADDCATS,$P(REC,U,10)="C" S REC="" 40 ..I REC'="" D 41 ...S CNT=CNT+1,ORWLST(CNT)=IEN_U_$P(REC,U) 42 ...I ADDCATS S ORWLST(CNT)=ORWLST(CNT)_U_$P(REC,U,10)_U_$P(REC,U,3) 43 Q 44 ; 45 EXAMTYPE(ORWLST) ;get the list of active exams 46 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 47 F S BINDEX=$O(^AUTTEXAM("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTEXAM(IEN,0))#2,+$P(^(0),"^",4)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") 48 Q 49 ; 50 TRTTYPE(ORWLST) ;get the list of active treatments 51 N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 52 F S BINDEX=$O(^AUTTTRT("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTTRT(IEN,0))#2,+$P(^(0),"^",4)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") 53 Q 54 ; 55 ACTIVPRV(ORRETURN,ORWPROV,ORWDT) ;get if provider is active or not 56 S ORRETURN=$$ACTIVPRV^PXAPI(ORWPROV,ORWDT) 57 Q 58 GETVISIT(VISIT,IEN,DFN,VSITSTR) ;Get the visit IEN 59 I +$G(IEN)<1 D I 1 60 .S VISIT=$$GETENC^PXAPI(DFN,$P(VSITSTR,";",2),$P(VSITSTR,";")) 61 E S VISIT=$P(^TIU(8925,IEN,0),U,3) 62 Q 63 GAFOK(ORY) ; Returns true if all supporting MH GAF Code exists 64 S ORY=0 65 I $T(GAFHX^YSGAFAPI)'="",$T(ENT^YSGAFAP1)'="" S ORY=1 66 Q 67 MHCLINIC(ORY,ORIEN) ; See if this is a mental health clinic 68 I $T(MHCLIN^SDUTL2)="" S ORY=1 69 E S ORY=$$MHCLIN^SDUTL2(ORIEN) 70 Q 71 LOADGAF(ORY,ORINPUT) ; Retrieve GAF scores 72 D GAFHX^YSGAFAPI(.ORY,.ORINPUT) 73 Q 74 SAVEGAF(ORY,ORINPUT) ; Save new GAF score 75 N ORDATA 76 D ENT^YSGAFAP1(.ORDATA,.ORINPUT) 77 S ORY=($G(ORDATA(1))="[DATA]") 78 Q 79 FORCE(ORY,USER,LOC) ; Retrieve FORCE GUI PCE Entry for a given User/Location 80 N SRV,ORTMP,ORERR 81 S USER=$G(USER,DUZ) 82 S SRV=$P($G(^VA(200,USER,5)),U) 83 D GETLST^XPAR(.ORTMP,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORWPCE FORCE PCE ENTRY","Q",.ORERR) 84 S ORY=+$P($G(ORTMP(1)),U,2) 85 Q 86 HASCPT(ORY,ORLIST) ; Returns true if there are any mapped CPT Codes 87 N IEN,IDX,FOUND 88 S IDX=0 89 F S IDX=$O(ORLIST(IDX)) Q:'+IDX D 90 . S FOUND=0 91 . S IEN=$$FIND1^DIC(811.1,"","QX",ORLIST(IDX)) 92 . I +IEN S FOUND=+$$GET1^DIQ(811.1,IEN,.05,"I") 93 . S ORY(IDX)=ORLIST(IDX)_"="_FOUND 94 Q 95 ASKPCE(ORY,USER,LOC) ; Returns ORWPCE ASK ENCOUNTER UPDATE parameter value 96 N SRV,ORTMP,ORERR 97 S USER=$G(USER,DUZ) 98 S SRV=$P($G(^VA(200,USER,5)),U) 99 D GETLST^XPAR(.ORTMP,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORWPCE ASK ENCOUNTER UPDATE","Q",.ORERR) 100 S ORY=+$P($G(ORTMP(1)),U,2) 101 Q 102 GAFURL(URL) ;Returns the MH GAF Web Page URL 103 S URL="" 104 I $T(GAFURL^YTAPI5)'="" D 105 .N ORY 106 .D GAFURL^YTAPI5(.ORY) 107 .I $G(ORY(1))="[DATA]" S URL=$G(ORY(2)) 108 Q 109 MHTESTOK(ORY) ; Returns True if all supporting MH Test APIs exist 110 D GAFOK(.ORY) 111 I +ORY,+$G(DUZ),$T(SAVEIT^YTAPI1)'="",$T(PREVIEW^YTAPI4)'="",$T(SHOWALL^YTAPI3)'="",$T(LISTONE^YTAPI)'="",$T(MHS^PXRMRPCC)'="",$T(MHR^PXRMRPCC)'="",$T(MH^PXRMRPCC)'="" D 112 . N SRV 113 . S SRV=$P($G(^VA(200,DUZ,5)),U) 114 . S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM MENTAL HEALTH ACTIVE",1,"Q") 115 . I +ORY S ORY=1 116 Q 117 MHATHRZD(ORY,TEST,USER) ;Indicates that user can score test 118 N ORYS,ORANS 119 I $T(PRIVL^YTAPI5)="" S ORY=1 Q 120 S ORY=0 121 S ORYS("CODE")=TEST 122 S ORYS("STAFF")=USER 123 D PRIVL^YTAPI5(.ORANS,.ORYS) 124 I $G(ORANS(1))="[DATA]" S ORY=+$P($G(ORANS(2)),U,1) 125 Q 126 ANYTIME(ORY) ;Returns status of the ORWPCE ANYTIME ENCOUNTERS parameter 127 N SRV 128 S SRV=$P($G(^VA(200,DUZ,5)),U) 129 S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE ANYTIME ENCOUNTERS",1,"Q") 130 I +ORY S ORY=1 131 Q 132 AUTOVSIT(ORY,LOC) ; Returns TRUE if automatic selection of Visit Type 133 N SRV 134 S SRV=$P($G(^VA(200,DUZ,5)),U) 135 S ORY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE DISABLE AUTO VISIT TYPE",1,"Q") 136 I +ORY S ORY=1 137 S ORY='ORY 138 Q 139 DOCHKOUT(ORY,LOC) ; Returns TRUE if automatic selection of Visit Type 140 N SRV 141 S SRV=$P($G(^VA(200,DUZ,5)),U) 142 S ORY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE DISABLE AUTO CHECKOUT",1,"Q") 143 I +ORY S ORY=1 144 S ORY='ORY 145 Q 146 CHKOUT(LOC) ; Returns TRUE if automatic selection of Visit Type 147 N ORY 148 D DOCHKOUT(.ORY,LOC) 149 Q ORY 150 EXCLUDED(ORY,LOC,TYPE) ; Returns list of excluded PCE data elements 151 N SRV,PARAM 152 S PARAM=$S(TYPE=1:"IMMUNIZATIONS",TYPE=2:"SKIN TESTS",TYPE=3:"PATIENT ED",TYPE=4:"HEALTH FACTORS",TYPE=5:"EXAMS",1:"") 153 Q:PARAM="" 154 S SRV=$P($G(^VA(200,DUZ,5)),U) 155 S PARAM="ORWPCE EXCLUDE "_PARAM 156 D GETLST^XPAR(.ORY,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG",PARAM,"Q",.ORERR) 157 Q 158 ISCLINIC(ORY,ORLOC) ; Returns TRUE if location is a clinic 159 N ORTYP 160 S ORY=0 161 S ORTYP=$$GET1^DIQ(44,+ORLOC,2,"I") 162 I (ORTYP="C")!(ORTYP="M") S ORY=1 163 Q 164 HNCOK(ORY) ; Returns true if Head and/or Neck Cancer is enabled 165 S ORY=0 166 I $$PATCH^XPDUTL("DG*5.3*397"),$$PATCH^XPDUTL("SD*5.3*244"),$$PATCH^XPDUTL("PX*1.0*111"),$$PATCH^XPDUTL("IVM*2.0*46") S ORY=1 167 Q 168 ; 169 CODACTIV(ORY,ORCODE,ORAPP,ORDATE) ; Is code active on the given date? 170 ; Remote procedure: ORWPCE ACTIVE CODE 171 ; ORCODE = ICD or CPT code to be checked 172 ; ORAPP = "ICD" or "CHP" 173 ; ORDATE = Date to be checked (defaults to current date) 174 S:'+$G(ORDATE) ORDATE=DT 175 S ORY=1 176 I ORAPP="ICD" D 177 . S ORY=+$$STATCHK^ICDAPIU(ORCODE,ORDATE) 178 E I ORAPP="CHP" D 179 . S ORY=+$$STATCHK^ICPTAPIU(ORCODE,ORDATE) 180 Q 181 ICDACTIV(ORCODE,ORDATE) ; Check for active ICD code 182 D CODACTIV(.ORY,ORCODE,"ICD",$G(ORDATE)) 183 Q +ORY 184 CPTACTIV(ORCODE,ORDATE) ; Check for active CPT code 185 D CODACTIV(.ORY,ORCODE,"CHP",$G(ORDATE)) 186 Q +ORY 187 CXNOSHOW(ORY,ORDOCIEN) ; Should workload requirement be skipped for this note's visit? 188 ; RETURN VALUE: 0=SKIP ALL GUI WORKLOAD REQUIREMENTS 189 ; 1=CONTINUE WITH OTHER GUI WORKLOAD LOGIC 190 N ORTIU 191 D DOCPARM^TIUSRVP1(.ORTIU,ORDOCIEN) ; DBIA #4331 192 S ORY=+$$CHKWKL^TIUPXAP2(ORDOCIEN,ORTIU(0)) ; DBIA #4332 193 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPS.m
r613 r623 1 ORWPS ; SLC/KCM/JLI/REV/CLA - Meds Tab; 02/11/2008 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,141,173,203,190,195,265,275,243**;Dec 17, 1997;Build 242 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 COVER(LST,DFN) ; retrieve meds for cover sheet 5 K ^TMP("PS",$J) 6 D OCL^PSOORRL(DFN,"","") 7 N ILST,ITMP,X S ILST=0 8 S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D 9 . S X=^TMP("PS",$J,ITMP,0) 10 . I '$L($P(X,U,2)) S X="??" ; show something if drug empty 11 . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C" 12 . E S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9) 13 K ^TMP("PS",$J) 14 Q 15 DT(X) ; -- Returns FM date for X 16 N Y,%DT S %DT="T",Y="" D:X'="" ^%DT 17 Q Y 18 ; 19 ACTIVE(LST,DFN,USER,VIEW,UPDATE) ; retrieve active inpatient & outpatient meds 20 K ^TMP("PS",$J) 21 K ^TMP("ORACT",$J) 22 N BEG,END,ERROR,CTX,STVIEW 23 S (BEG,END,CTX)="" 24 S VIEW=+$G(VIEW) 25 S UPDATE=+$G(UPDATE) 26 I VIEW=0,UPDATE=0 S VIEW=1 27 S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") 28 I CTX=";" D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS") 29 S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") 30 S BEG=$$DT($P(CTX,";")),END=$$DT($P(CTX,";",2)) 31 I +$G(USER)=0 S USER=DUZ 32 I UPDATE=1 D 33 .S STVIEW=$$GET^XPAR($G(USER)_";VA(200,","OR MEDS TAB SORT",1,"I") 34 .I VIEW>0,+STVIEW'=VIEW D PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,VIEW,.ERROR) S STVIEW=VIEW 35 .I VIEW=0,+STVIEW=0 D PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,"1",.ERROR) S STVIEW=1,VIEW=1 36 .I VIEW=0,+STVIEW'=VIEW S VIEW=+STVIEW 37 .S LST(0)=STVIEW 38 D OCL^PSOORRL(DFN,BEG,END,VIEW) 39 N ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J S ILST=0 40 S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D 41 . K INSTRUCT,COMMENTS,REASON 42 . K ^TMP("ORACT",$J,"COMMENTS") 43 . S COMMENTS="^TMP(""ORACT"",$J,""COMMENTS"")" 44 . S (INSTRUCT,@COMMENTS)="",FIELDS=^TMP("PS",$J,ITMP,0) 45 . I +$P(FIELDS,"^",8),$D(^OR(100,+$P(FIELDS,"^",8),8,"C","XX")) D 46 . . S $P(^TMP("PS",$J,ITMP,0),"^",2)="*"_$P(^TMP("PS",$J,ITMP,0),"^",2) ;dan testing 47 . S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD") 48 . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S TYPE="CP" 49 . N LOC,LOCEX S (LOC,LOCEX)="" 50 . I TYPE="CP" S LOC=$G(^TMP("PS",$J,ITMP,"CLINIC",0)) 51 . S:LOC LOCEX=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO NEW 52 . I TYPE="OP",$P(FIELDS,";")["N" S TYPE="NV" ;non-VA med 53 . I $O(^TMP("PS",$J,ITMP,"A",0))>0 S TYPE="IV" 54 . I $O(^TMP("PS",$J,ITMP,"B",0))>0 S TYPE="IV" 55 . I (TYPE="UD")!(TYPE="CP") D UDINST(.INSTRUCT,ITMP) 56 . I TYPE="OP" D OPINST(.INSTRUCT,ITMP) 57 . I TYPE="IV" D IVINST(.INSTRUCT,ITMP) 58 . I TYPE="NV" D NVINST(.INSTRUCT,ITMP),NVREASON(.REASON,.NVSDT,ITMP) 59 . I (TYPE="UD")!(TYPE="IV")!(TYPE="NV")!(TYPE="CP") D SETMULT(COMMENTS,ITMP,"SIO") 60 . M COMMENTS=@COMMENTS 61 . I $D(COMMENTS(1)) S COMMENTS(1)="\"_COMMENTS(1) 62 . S:TYPE="NV" $P(FIELDS,U,4)=$G(NVSDT) 63 . I LOC S LST($$NXT)="~CP:"_LOCEX_U_FIELDS 64 . E S LST($$NXT)="~"_TYPE_U_FIELDS 65 . S J=0 F S J=$O(INSTRUCT(J)) Q:'J S LST($$NXT)=INSTRUCT(J) 66 . S J=0 F S J=$O(COMMENTS(J)) Q:'J S LST($$NXT)="t"_COMMENTS(J) 67 . S J=0 F S J=$O(REASON(J)) Q:'J S LST($$NXT)="t"_REASON(J) 68 K ^TMP("PS",$J) 69 K ^TMP("ORACT",$J) 70 Q 71 NXT() ; increment ILST 72 S ILST=ILST+1 73 Q ILST 74 ; 75 UDINST(Y,INDEX) ; assembles instructions for a unit dose order 76 N I,X,RST 77 S X=^TMP("PS",$J,INDEX,0) 78 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" 79 S @RST@(1)=" "_$P(X,U,2),@RST=1 80 S X=$S($L($P(X,U,6)):$P(X,U,6),1:$P(X,U,7)) 81 I $L(X) S @RST=2,@RST@(2)=X 82 E S @RST=1 D SETMULT(.RST,INDEX,"SIG") 83 S @RST@(2)="\Give: "_$G(@RST@(2)),@RST=$G(@RST,2) 84 D SETMULT(RST,INDEX,"MDR"),SETMULT(RST,INDEX,"SCH") 85 F I=3:1:@RST S @RST@(I)=" "_@RST@(I) 86 M Y=@RST K @RST 87 Q 88 OPINST(Y,INDEX) ; assembles instructions for an outpatient prescription 89 N I,X,RST 90 S X=^TMP("PS",$J,INDEX,0) 91 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" 92 S @RST@(1)=" "_$P(X,U,2),@RST=1 93 I $L($P(X,U,12)) S @RST@(1)=@RST@(1)_" Qty: "_$P(X,U,12) 94 I $L($P(X,U,11)) S @RST@(1)=@RST@(1)_" for "_$P(X,U,11)_" days" 95 D SETMULT(RST,INDEX,"SIG") 96 I @RST=1 D 97 . D SETMULT(RST,INDEX,"SIO") 98 . D SETMULT(RST,INDEX,"MDR") 99 . D SETMULT(RST,INDEX,"SCH") 100 S @RST@(2)="\ Sig: "_$G(@RST@(2)) 101 F I=3:1:@RST S @RST@(I)=" "_@RST@(I) 102 M Y=@RST K @RST 103 Q 104 IVINST(Y,INDEX) ; assembles instructions for an IV order 105 N SOLN1,I,RST,IVDUR,CNT 106 S IVDUR="" 107 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" 108 S @RST=0 D SETMULT(RST,INDEX,"A") S SOLN1=@RST+1 109 D SETMULT(RST,INDEX,"B") 110 I $D(@RST@(SOLN1)),$L($P(FIELDS,U,2)) S @RST@(SOLN1)="in "_@RST@(SOLN1) 111 S SOLN1=@RST+1 112 S CNT=@RST 113 D SETMULT(RST,INDEX,"MDR") 114 I $D(^TMP("PS",$J,INDEX,"SCH",1,0)) S @RST@(@RST)=@RST@(@RST)_" "_^TMP("PS",$J,INDEX,"SCH",1,0) 115 F I=1:1:@RST S @RST@(I)="\"_$TR(@RST@(I),U," ") 116 I $D(@RST@(1)) S @RST@(1)=" "_$E(@RST@(1),2,999) 117 S @RST@(@RST)=@RST@(@RST)_" "_$P(^TMP("PS",$J,INDEX,0),U,3) 118 S:$D(^TMP("PS",$J,INDEX,"IVLIM",0)) IVDUR=$G(^TMP("PS",$J,INDEX,"IVLIM",0)) 119 I $L(IVDUR) D 120 . N DURU,DURV S DURU="",DURV=0 121 . I IVDUR["dose" D Q 122 . .S DURV=$P(IVDUR,"doses",2) 123 . .S IVDUR="for a total of "_+DURV_$S(+DURV=1:"dose",+DURV>1:" doses",1:" dose") 124 . .S @RST@(@RST)=@RST@(@RST)_" "_IVDUR 125 . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR)) 126 . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day") 127 . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour") 128 . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml" 129 . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L" 130 . S @RST@(@RST)=@RST@(@RST)_" "_IVDUR 131 M Y=@RST K @RST 132 Q 133 NVINST(Y,INDEX) ; assembles instructions for a non-VA med 134 N I,X,RST 135 S X=^TMP("PS",$J,INDEX,0) 136 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" 137 S @RST@(1)=" "_$P(X,U,2),@RST=1 138 D SETMULT(RST,INDEX,"SIG") 139 I @RST=1 D 140 . D SETMULT(RST,INDEX,"SIO") 141 . D SETMULT(RST,INDEX,"MDR") 142 . D SETMULT(RST,INDEX,"SCH") 143 S @RST@(2)="\ "_$G(@RST@(2)) 144 F I=3:1:@RST S @RST@(I)=" "_@RST@(I) 145 M Y=@RST K @RST 146 Q 147 NVREASON(ORR,NVSDT,INDEX) ; assembles start date and reasons for a non-VA med 148 N ORI,J,X,ORN,ORA 149 S ORI=0 K ORR 150 S X=^TMP("PS",$J,INDEX,0) 151 S ORN=+$P(X,U,8) 152 I $D(^OR(100,ORN,0)) D 153 .S NVSDT=$P(^OR(100,ORN,0),U,8) 154 .D WPVAL^ORWDXR(.ORA,ORN,"STATEMENTS") I $D(ORA) D 155 ..S J=0 F S J=$O(ORA(J)) Q:J<1 S ORI=ORI+1,ORR(ORI)=ORA(J) 156 Q 157 SETMULT(Y,INDEX,SUB) ; appends the multiple at the subscript to Y 158 N I,X,J 159 S J=$G(@Y) 160 S I=0 F S I=$O(^TMP("PS",$J,INDEX,SUB,I)) Q:'I S X=$G(^(I,0)) D 161 . I SUB="B",$L($P(X,U,3)) S X=$P(X,U)_" "_$P(X,U,3)_"^"_$P(X,U,2) 162 . S J=J+1,@Y@(J)=X 163 S @Y=J 164 Q 165 COMPRESS(Y) ; concatenate Y subscripts into smallest possible number 166 N I,J,X S J=1,X(J)="" 167 S I=0 F S I=$O(Y(I)) Q:'I D 168 . I ($L(Y(I))+$L(X(J)))>245 S J=J+1,X(J)="" 169 . S X(J)=X(J)_$S($L(X(J)):" ",1:"")_Y(I) 170 K Y M Y=X 171 Q 172 DETAIL(ROOT,DFN,ID) ; -- show details for a med order 173 K ^TMP("ORXPND",$J) 174 N LCNT,ORVP 175 S LCNT=0,ORVP=DFN_";DPT(" 176 D MEDS^ORCXPND1 177 S ROOT=$NA(^TMP("ORXPND",$J)) 178 Q 179 MEDHIST(ORROOT,DFN,ORIFN) ; -- show admin history for a med (RV) 180 N ORPSID,HPIV,ISIV,CKPKG,ORPHMID 181 N CLINDISP,IVDIAL 182 S ORPSID=+$P($$OI^ORX8(ORIFN),U,3),ISIV=0,HPIV=0 183 S ORROOT=$NA(^TMP("ORHIST",$J)) K @ORROOT 184 S ORPHMID=$G(^OR(100,+ORIFN,4)) ;Pharmacy order number 185 S ISIV=$O(^ORD(100.98,"B","IV RX",ISIV)) 186 S HPIV=$O(^ORD(100.98,"B","TPN",HPIV)) 187 S CLINDISP=$O(^ORD(100.98,"B","C RX","")) 188 S IVDIAL=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE","")) 189 S CKPKG=$$PATCH^XPDUTL("PSB*2.0*19") 190 ;if the order is pending or the order has no pharmacy # 191 ;or the order is not in the Display Group IV MEDICATION 192 ; then use the Orderable item number to get the MAH. 193 I (ORPHMID["P")!(ORPHMID="") D Q 194 . I '$L($T(HISTORY^PSBMLHS)) D Q 195 . . S @ORROOT@(0)="This report is only available using BCMA version 2.0." 196 . D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0 197 ; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MA 198 I ($P($G(^OR(100,+ORIFN,0)),U,11)=ISIV)!($P($G(^OR(100,+ORIFN,0)),U,11)=HPIV)!(($P($G(^OR(100,+ORIFN,0)),U,11)=CLINDISP)&(+$P($G(^OR(100,+ORIFN,0)),U,5)=IVDIAL)) D Q 199 . I 'CKPKG S @ORROOT@(0)="Medication Administration History is not available at this time for IV fluids." 200 . I CKPKG D 201 . . D RPC^PSBO(.ORROOT,"PM",DFN,"","","","","","","","","",ORPHMID) ;DBIA #3955 202 . . I '$D(@ORROOT) S @ORROOT@(0)="No Medication Administration History found for the IV order." 203 I '$L($T(HISTORY^PSBMLHS)) D Q 204 . S @ORROOT@(0)="This report is only available using BCMA version 2.0." 205 D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0 206 Q 207 ; 208 REASON(ORY) ; -- Return Non-VA Med Statement/Reasons 209 N ORE 210 D GETLST^XPAR(.ORY,"ALL","ORWD NONVA REASON","E") 211 Q 1 ORWPS ; SLC/KCM/JLI/REV/CLA - Meds Tab; 05/22/03 ; 5/18/07 10:18am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,141,173,203,190,195,265,275**;Dec 17, 1997;Build 7 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 COVER(LST,DFN) ; retrieve meds for cover sheet 5 K ^TMP("PS",$J) 6 D OCL^PSOORRL(DFN,"","") ;DBIA #2400 7 N ILST,ITMP,X S ILST=0 8 S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D 9 . S X=^TMP("PS",$J,ITMP,0) 10 . I '$L($P(X,U,2)) S X="??" ; show something if drug empty 11 . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C" 12 . E S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9) 13 K ^TMP("PS",$J) 14 Q 15 DT(X) ; -- Returns FM date for X 16 N Y,%DT S %DT="T",Y="" D:X'="" ^%DT 17 Q Y 18 ; 19 ACTIVE(LST,DFN) ; retrieve active inpatient & outpatient meds 20 K ^TMP("PS",$J) 21 K ^TMP("ORACT",$J) 22 N BEG,END,CTX 23 S (BEG,END,CTX)="" 24 S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") 25 I CTX=";" D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS") 26 S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") 27 S BEG=$$DT($P(CTX,";")),END=$$DT($P(CTX,";",2)) 28 D OCL^PSOORRL(DFN,BEG,END) ;DBIA #2400 29 N ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J S ILST=0 30 S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP),-1) Q:'ITMP D 31 . K INSTRUCT,COMMENTS,REASON 32 . K ^TMP("ORACT",$J,"COMMENTS") 33 . S COMMENTS="^TMP(""ORACT"",$J,""COMMENTS"")" 34 . S (INSTRUCT,@COMMENTS)="",FIELDS=^TMP("PS",$J,ITMP,0) 35 . I +$P(FIELDS,"^",8),$D(^OR(100,+$P(FIELDS,"^",8),8,"C","XX")) D 36 . . S $P(^TMP("PS",$J,ITMP,0),"^",2)="*"_$P(^TMP("PS",$J,ITMP,0),"^",2) ;dan testing 37 . S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD") 38 . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S TYPE="CP" 39 . N LOC,LOCEX S (LOC,LOCEX)="" 40 . I TYPE="CP" S LOC=$G(^TMP("PS",$J,ITMP,"CLINIC",0)) 41 . S:LOC LOCEX=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO NEW DBIA #964 42 . I TYPE="OP",$P(FIELDS,";")["N" S TYPE="NV" ;non-VA med 43 . I $O(^TMP("PS",$J,ITMP,"A",0))>0 S TYPE="IV" 44 . I $O(^TMP("PS",$J,ITMP,"B",0))>0 S TYPE="IV" 45 . I (TYPE="UD")!(TYPE="CP") D UDINST(.INSTRUCT,ITMP) 46 . I TYPE="OP" D OPINST(.INSTRUCT,ITMP) 47 . I TYPE="IV" D IVINST(.INSTRUCT,ITMP) 48 . I TYPE="NV" D NVINST(.INSTRUCT,ITMP),NVREASON(.REASON,.NVSDT,ITMP) 49 . I (TYPE="UD")!(TYPE="IV")!(TYPE="NV")!(TYPE="CP") D SETMULT(COMMENTS,ITMP,"SIO") 50 . M COMMENTS=@COMMENTS 51 . I $D(COMMENTS(1)) S COMMENTS(1)="\"_COMMENTS(1) 52 . S:TYPE="NV" $P(FIELDS,U,4)=$G(NVSDT) 53 . I LOC S LST($$NXT)="~CP:"_LOCEX_U_FIELDS 54 . E S LST($$NXT)="~"_TYPE_U_FIELDS 55 . S J=0 F S J=$O(INSTRUCT(J)) Q:'J S LST($$NXT)=INSTRUCT(J) 56 . S J=0 F S J=$O(COMMENTS(J)) Q:'J S LST($$NXT)="t"_COMMENTS(J) 57 . S J=0 F S J=$O(REASON(J)) Q:'J S LST($$NXT)="t"_REASON(J) 58 K ^TMP("PS",$J) 59 K ^TMP("ORACT",$J) 60 Q 61 NXT() ; increment ILST 62 S ILST=ILST+1 63 Q ILST 64 ; 65 UDINST(Y,INDEX) ; assembles instructions for a unit dose order 66 N I,X,RST 67 S X=^TMP("PS",$J,INDEX,0) 68 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" 69 S @RST@(1)=" "_$P(X,U,2),@RST=1 70 S X=$S($L($P(X,U,6)):$P(X,U,6),1:$P(X,U,7)) 71 I $L(X) S @RST=2,@RST@(2)=X 72 E S @RST=1 D SETMULT(.RST,INDEX,"SIG") 73 S @RST@(2)="\Give: "_$G(@RST@(2)),@RST=$G(@RST,2) 74 D SETMULT(RST,INDEX,"MDR"),SETMULT(RST,INDEX,"SCH") 75 F I=3:1:@RST S @RST@(I)=" "_@RST@(I) 76 M Y=@RST K @RST 77 Q 78 OPINST(Y,INDEX) ; assembles instructions for an outpatient prescription 79 N I,X,RST 80 S X=^TMP("PS",$J,INDEX,0) 81 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" 82 S @RST@(1)=" "_$P(X,U,2),@RST=1 83 I $L($P(X,U,12)) S @RST@(1)=@RST@(1)_" Qty: "_$P(X,U,12) 84 I $L($P(X,U,11)) S @RST@(1)=@RST@(1)_" for "_$P(X,U,11)_" days" 85 D SETMULT(RST,INDEX,"SIG") 86 I @RST=1 D 87 . D SETMULT(RST,INDEX,"SIO") 88 . D SETMULT(RST,INDEX,"MDR") 89 . D SETMULT(RST,INDEX,"SCH") 90 S @RST@(2)="\ Sig: "_$G(@RST@(2)) 91 F I=3:1:@RST S @RST@(I)=" "_@RST@(I) 92 M Y=@RST K @RST 93 Q 94 IVINST(Y,INDEX) ; assembles instructions for an IV order 95 N SOLN1,I,RST,IVDUR 96 S IVDUR="" 97 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" 98 S @RST=0 D SETMULT(RST,INDEX,"A") S SOLN1=@RST+1 99 D SETMULT(RST,INDEX,"B") 100 I $D(@RST@(SOLN1)),$L($P(FIELDS,U,2)) S @RST@(SOLN1)="in "_@RST@(SOLN1) 101 S SOLN1=@RST+1 102 D SETMULT(RST,INDEX,"SCH") S:$D(@RST@(SOLN1)) @RST@(SOLN1)=" "_@RST@(SOLN1) 103 F I=1:1:@RST S @RST@(I)="\"_$TR(@RST@(I),U," ") 104 I $D(@RST@(1)) S @RST@(1)=" "_$E(@RST@(1),2,999) 105 S @RST@(@RST)=@RST@(@RST)_" "_$P(^TMP("PS",$J,INDEX,0),U,3) 106 S:$D(^TMP("PS",$J,INDEX,"IVLIM",0)) IVDUR=$G(^TMP("PS",$J,INDEX,"IVLIM",0)) 107 I $L(IVDUR) D 108 . N DURU,DURV S DURU="",DURV=0 109 . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR)) 110 . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day") 111 . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour") 112 . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml" 113 . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L" 114 . S @RST@(@RST)=@RST@(@RST)_" "_IVDUR 115 M Y=@RST K @RST 116 Q 117 NVINST(Y,INDEX) ; assembles instructions for a non-VA med 118 N I,X,RST 119 S X=^TMP("PS",$J,INDEX,0) 120 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" 121 S @RST@(1)=" "_$P(X,U,2),@RST=1 122 D SETMULT(RST,INDEX,"SIG") 123 I @RST=1 D 124 . D SETMULT(RST,INDEX,"SIO") 125 . D SETMULT(RST,INDEX,"MDR") 126 . D SETMULT(RST,INDEX,"SCH") 127 S @RST@(2)="\ "_$G(@RST@(2)) 128 F I=3:1:@RST S @RST@(I)=" "_@RST@(I) 129 M Y=@RST K @RST 130 Q 131 NVREASON(ORR,NVSDT,INDEX) ; assembles start date and reasons for a non-VA med 132 N ORI,J,X,ORN,ORA 133 S ORI=0 K ORR 134 S X=^TMP("PS",$J,INDEX,0) 135 S ORN=+$P(X,U,8) 136 I $D(^OR(100,ORN,0)) D 137 .S NVSDT=$P(^OR(100,ORN,0),U,8) 138 .D WPVAL^ORWDXR(.ORA,ORN,"STATEMENTS") I $D(ORA) D 139 ..S J=0 F S J=$O(ORA(J)) Q:J<1 S ORI=ORI+1,ORR(ORI)=ORA(J) 140 Q 141 SETMULT(Y,INDEX,SUB) ; appends the multiple at the subscript to Y 142 N I,X,J 143 S J=$G(@Y) 144 S I=0 F S I=$O(^TMP("PS",$J,INDEX,SUB,I)) Q:'I S X=$G(^(I,0)) D 145 . I SUB="B",$L($P(X,U,3)) S X=$P(X,U)_" "_$P(X,U,3)_"^"_$P(X,U,2) 146 . S J=J+1,@Y@(J)=X 147 S @Y=J 148 Q 149 COMPRESS(Y) ; concatenate Y subscripts into smallest possible number 150 N I,J,X S J=1,X(J)="" 151 S I=0 F S I=$O(Y(I)) Q:'I D 152 . I ($L(Y(I))+$L(X(J)))>245 S J=J+1,X(J)="" 153 . S X(J)=X(J)_$S($L(X(J)):" ",1:"")_Y(I) 154 K Y M Y=X 155 Q 156 DETAIL(ROOT,DFN,ID) ; -- show details for a med order 157 K ^TMP("ORXPND",$J) 158 N LCNT,ORVP 159 S LCNT=0,ORVP=DFN_";DPT(" 160 D MEDS^ORCXPND1 161 S ROOT=$NA(^TMP("ORXPND",$J)) 162 Q 163 MEDHIST(ORROOT,DFN,ORIFN) ; -- show admin history for a med (RV) 164 N ORPSID,HPIV,ISIV,CKPKG,ORPHMID 165 S ORPSID=+$P($$OI^ORX8(ORIFN),U,3),(HPIV,ISIV)=0 166 S ORROOT=$NA(^TMP("ORHIST",$J)) K @ORROOT 167 S ORPHMID=$G(^OR(100,+ORIFN,4)) ;Pharmacy order number 168 S ISIV=$O(^ORD(100.98,"B","IV RX",ISIV)) 169 S HPIV=$O(^ORD(100.98,"B","TPN",HPIV)) 170 S CKPKG=$$PATCH^XPDUTL("PSB*2.0*19") 171 ;if the order is pending or the order has no pharmacy # 172 ;or the order is not in the Display Group IV MEDICATION 173 ; then use the Orderable item number to get the MAH. 174 I (ORPHMID["P")!(ORPHMID="") D Q 175 . I '$L($T(HISTORY^PSBMLHS)) D Q 176 . . S @ORROOT@(0)="This report is only available using BCMA version 2.0." 177 . D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0 178 ; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MAH 179 I $P($G(^OR(100,+ORIFN,0)),U,11)=ISIV!($P($G(^OR(100,+ORIFN,0)),U,11)=HPIV) D Q 180 . I 'CKPKG S @ORROOT@(0)="Medication Administration History is not available at this time for IV fluids." 181 . I CKPKG D 182 . . D RPC^PSBO(.ORROOT,"PM",DFN,"","","","","","","","","",ORPHMID) ;DBIA #3955 183 . . I '$D(@ORROOT) S @ORROOT@(0)="No Medication Administration History found for the IV order." 184 I '$L($T(HISTORY^PSBMLHS)) D Q 185 . S @ORROOT@(0)="This report is only available using BCMA version 2.0." 186 D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0 187 Q 188 ; 189 REASON(ORY) ; -- Return Non-VA Med Statement/Reasons 190 N ORE 191 D GETLST^XPAR(.ORY,"ALL","ORWD NONVA REASON","E") 192 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT.m
r613 r623 1 ORWPT ; SLC/KCM/REV - Patient Lookup Functions ;3/18/05 10:50 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215,243**;Dec 17, 1997;Build 242 3 ; 4 ; Ref. to ^UTILITY via IA 10061 5 ; 6 IDINFO(REC,DFN) ; Return identifying information for a patient 7 ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME 8 N X0,X1,X101,X3,XV ; name/dob/sex/ssn, ward, room-bed, sc%, vet 9 S X0=$G(^DPT(DFN,0)),X1=$G(^(.1)),X101=$G(^(.101)),X3=$G(^(.3)),XV=$G(^("VET")) 10 S REC=$$SSN^DPTLK1(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U) ;DG249 11 Q 12 PTINQ(REF,DFN) ; Return formatted pt inquiry report 13 K ^TMP("ORDATA",$J,1) 14 D DGINQ^ORCXPND1(DFN) 15 S REF=$NA(^TMP("ORDATA",$J,1)) 16 Q 17 SCDIS(LST,DFN) ; Return service connected % and rated disabilities 18 N VAEL,VAERR,I,ILST,DIS,SC,X 19 D ELIG^VADPT 20 S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO") 21 I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q 22 S I=0,ILST=1 F S I=$O(^DPT(DFN,.372,I)) Q:'I S X=^(I,0) D 23 . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS="" 24 . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC") 25 . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")" 26 I ILST=1 S LST(2)="Rated Disabilities: NONE STATED" 27 Q 28 SHOW ; temporary - show patient inquiry screen 29 N I,Y,DIC S DIC=2,DIC(0)="AEMQ" D ^DIC Q:'Y 30 K ^TMP("ORDATA",$J,1) 31 D DGINQ^ORCXPND1(+Y) 32 S I=0 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:'I W !,^(I) 33 K ^TMP("ORDATA",$J,1) 34 Q 35 SELCHK(REC,DFN) ; Check for sensitive pt 36 ; SENSITIVE 37 S REC=$$EN1^ORQPT2(DFN) 38 Q 39 DIEDON(VAL,DFN) ; Check for a date of death 40 S VAL=+$G(^DPT(DFN,.35)) 41 Q 42 SELECT(REC,DFN) ; Selects patient & returns key information 43 ; 1 2 3 4 5 6 7 8 9 10 11 12 44 ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^ 45 ; 13 14 15 16 46 ; SC%^ICN^AGE^TS 47 ; 48 ; for CCOW (RV - 2/27/03) name="-1", location=error message 49 I '$D(^DPT(+DFN,0)) S REC="-1^^^^^Patient is unknown to CPRS." Q 50 ; 51 N X 52 K ^TMP("ORWPCE",$J) ; delete PCE 'cache' when switching patients 53 S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101)) 54 S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44)) 55 S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN) 56 ; I $P(REC,U,9) D EN2^ORQPT2(DFN) ;update DG security log ; DG249 57 S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U) 58 S:'$D(IOST) IOST="P-OTHER" 59 S $P(REC,U,11)=0 60 D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC% 61 I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X 62 S $P(REC,U,15)=$$AGE(DFN,$P(REC,U,3)) 63 S $P(REC,U,16)=+$G(^DPT(DFN,.103)) ; treating specialty 64 K VAEL,VAERR ;VADPT call to kill? 65 S ^DISV(DUZ,"^DPT(")=DFN 66 Q 67 SHARE(VAL,IP,HWND,DFN) ; Set global to share DFN with other applications 68 K ^TMP("ORWCHART",$J),^TMP("ORECALL",$J),^TMP("ORWORD",$J) 69 K ^TMP("ORWDXMQ",$J) 70 S ^TMP("ORWCHART",$J,IP,HWND)=DFN 71 Q 72 BYWARD(LST,WARD) ; Return a list of patients in a ward 73 N ILST,DFN 74 I +$G(WARD)<1 S LST(1)="^No ward identified" Q 75 S (ILST,DFN)=0 76 S WARD=$P(^DIC(42,WARD,0),"^") ;DBIA #36 77 F S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0 D 78 . S ILST=ILST+1,LST(ILST)=+DFN_U_$P(^DPT(+DFN,0),U)_U_$G(^DPT(+DFN,.101)) 79 I ILST<1 S LST(1)="^No patients found." 80 Q 81 LAST5(LST,ID) ; Return a list of patients matching A9999 identifiers 82 N I,IEN,XREF 83 S (I,IEN)=0,XREF=$S($L(ID)=5:"BS5",1:"BS") 84 F S IEN=$O(^DPT(XREF,ID,IEN)) Q:'IEN D 85 . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN) ; DG249 86 Q 87 ; 88 LAST5RPL(LST,ID) ; ; Return list matching A9999 id's, but from RPL only. 89 N ORRPL,ORCNT,ORPT,ORPIEN 90 ; IA ____ allows read access to NEW PERSON file node 101: 91 S ORRPL=$G(^VA(200,DUZ,101)) 92 S ORRPL=$P(ORRPL,U,2) 93 I (('ORRPL)!(ORRPL="")) S LST(0)="" Q 94 ; 95 S (ORCNT,ORPT)=0 96 F S ORPT=$O(^OR(100.21,ORRPL,10,ORPT)) Q:'ORPT D 97 .S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORPT,0)) 98 .I ((ORPIEN<0)!(ORPIEN="")) Q 99 .S ORCNT=ORCNT+1 100 .S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249. 101 ; 102 Q 103 ; 104 FULLSSN(LST,ID) ; Return a list of patients matching full SSN entered 105 N I,IEN 106 S (I,IEN)=0 107 F S IEN=$O(^DPT("SSN",ID,IEN)) Q:'IEN D 108 . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN) ; DG249 109 Q 110 ; 111 FSSNRPL(LST,ID) ; Return list matching Full SSN, but from RPL only. 112 N ORRPL,ORCNT,ORPT,ORLPT,ORPIEN 113 ; IA ____ allows read access to NEW PERSON file node 101: 114 S ORRPL=$G(^VA(200,DUZ,101)) 115 S ORRPL=$P(ORRPL,U,2) 116 I (('ORRPL)!(ORRPL="")) S LST(0)="" Q 117 ; 118 S (ORCNT,ORPT)=0 119 F S ORPT=$O(^DPT("SSN",ID,ORPT)) Q:'ORPT D 120 .S ORLPT=0 121 .F S ORLPT=$O(^OR(100.21,ORRPL,10,ORLPT)) Q:'ORLPT D 122 ..S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORLPT,0)) 123 ..I ((ORPIEN<0)!(ORPIEN="")) Q 124 ..I (ORPIEN'=ORPT) Q 125 ..S ORCNT=ORCNT+1 126 ..S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249. 127 ; 128 Q 129 ; 130 TOP(LST) ; Return top for all patients list (last selected for now) 131 N IEN 132 S IEN=$G(^DISV(DUZ,"^DPT(")) 133 I IEN S LST(1)=IEN_U_$P($G(^DPT(IEN,0)),U) 134 Q 135 ENCTITL(REC,DFN,LOC,PROV) ; Return external values for encounter 136 ; LOCNAME^LOCABBR^ROOMBED^PROVNAME 137 S $P(REC,U,1)=$P($G(^SC(+LOC,0)),U,1,2) 138 S $P(REC,U,3)=$P($G(^DPT(DFN,.101)),U) 139 S $P(REC,U,4)=$P($G(^VA(200,+PROV,0)),U) 140 Q 141 LISTALL(Y,FROM,DIR) ; Return a bolus of patient names. From is either Name or IEN^Name. 142 N I,IEN,CNT,FROMIEN,ORIDNAME S CNT=44,I=0,FROMIEN=0 143 I $P(FROM,U,2)'="" S FROMIEN=$P(FROM,U,1),FROM=$O(^DPT("B",$P(FROM,U,2)),-DIR) 144 F S FROM=$O(^DPT("B",FROM),DIR) Q:FROM="" D Q:I=CNT 145 . S IEN=FROMIEN,FROMIEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT 146 . . S ORIDNAME="" 147 . . S ORIDNAME=$G(^DPT(IEN,0)) ; Get zero node name. 148 . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) 149 . . S I=I+1 S Y(I)=IEN_U_FROM_U_U_U_U_$P(ORIDNAME,U) ;_"^"_X ; _"^"_X1 ;" ("_X_")" 150 Q 151 APPTLST(LST,DFN) ; return a list of appointments 152 ; APPTTIME^LOCIEN^LOCNAME^EXTSTATUS 153 N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J) ;IA 10061 154 S VASD("F")=$$HTFM^XLFDT($H-30,1) 155 S VASD("T")=$$HTFM^XLFDT($H+1,1)_".2359" 156 S VASD("W")="123456789" 157 D SDA^ORQRY01(.ERR,.ERRMSG) 158 I ERR K ^UTILITY("VASD",$J) K LST S LST(1)=ERRMSG Q 159 S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D 160 . S LST(I)=$P(^UTILITY("VASD",$J,I,"I"),U,1,2)_U_$P(^("E"),U,2,3) 161 K ^UTILITY("VASD",$J) 162 Q 163 ADMITLST(LST,DFN) ; return a list of admissions 164 ; MOVETIME^LOCIEN^LOCNAME^TYPE 165 N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,ILST S ILST=0 166 S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D 167 . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D 168 . . N VSTR,TIUDA 169 . . S X0=$G(^DGPM(MOV,0)) I X0']"" Q 170 . . S MTIM=$P(X0,U) 171 . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1) 172 . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44)) 173 . . S VSTR=HLOC_";"_MTIM_";H",TIUDA=$$HASDS^TIULX(DFN,VSTR) 174 . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XLOC_U_XTYP_U_MOV_U_TIUDA 175 Q 176 CLINRNG(LST) ; return date ranges for clinic appointments 177 S LST(1)="T;T^Today" 178 S LST(2)="T+1;T+1^Tomorrow" 179 S LST(3)="T-1;T-1^Yesterday" 180 S LST(4)="T-7;T^Past Week" 181 S LST(5)="T-31;T^Past Month" 182 S LST(6)="S^Specify Date Range..." 183 Q 184 ; 185 N %,%H,X,SUNDAY,START 186 S LST(1)=DT_";"_DT_"^Today",X=$$HTFM^XLFDT($H+1,1) 187 S LST(2)=X_";"_X_"^Tomorrow" 188 S X=+$H F Q:X#7=3 S X=X-1 ; $H#7=3 is Sunday 189 S LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week" 190 S LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week" 191 S LST(5)=$E(DT,1,5)_"01;"_$E(DT,1,5)_"31^This Month" 192 S X=$E(DT,4,5)+1 S:X=13 X=1 S X=$E(DT,1,3)_$TR($J(X,2)," ",0) 193 S LST(6)=X_"01;"_X_"31^Next Month" 194 S LST(7)="^Specify Dates" 195 Q 196 DFLTSRC(VAL) ; return default patient list source (T, W, C, P, S) 197 N SRV S SRV=+$G(^VA(200,DUZ,5)) 198 S VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE") 199 Q 200 SAVDFLT(OK,X) ; save new default patient list settings (X=type^ien^sdt;edt) 201 G SAVDFLT^ORWPT1 202 ; 203 DISCHRG(Y,DFN,ADMITDT) ; Get discharge movement information 204 N VAIP 205 I +$G(ADMITDT)=0 S Y=DT Q 206 S VAIP("D")=ADMITDT D 52^VADPT 207 I +VAIP(17)=0 S Y=DT Q 208 S Y=+VAIP(17,1) 209 Q 210 CWAD(Y,DFN) ; returns CWAD flags for a patient 211 S Y=$$CWAD^ORQPT2(DFN) 212 Q 213 LEGACY(ORLST,DFN) ; return message if data on the legacy system 214 ; ORLST(0)=1 if data, ORLST(n)=display message if data 215 S ORLST(0)=0 216 I $L($T(HXDATA^A7RDPAGU)) D 217 . D HXDATA^A7RDPAGU(.ORLST,DFN) 218 . I $O(ORLST(0)) S ORLST(0)=1 219 Q 220 INPLOC(REC,DFN) ; Return a patient's current location 221 N X 222 S X=$G(^DPT(DFN,.102)),REC=0 223 I X S X=$P($G(^DGPM(X,0)),U,6) 224 I X S REC=+$G(^DIC(42,X,44)) 225 I X S $P(REC,U,2)=$P($G(^DIC(42,X,0)),U,1) 226 I X S X=$P($G(^DIC(42,X,0)),U,3) 227 S $P(REC,U,3)=X 228 Q 229 AGE(DFN,BEG) ; returns age based on date of birth and date of death (or DT) 230 N END,X 231 S END=+$G(^DPT(DFN,.35)),END=$S(END:END,1:DT) 232 S X=$E(END,1,3)-$E(BEG,1,3)-($E(END,4,7)<$E(BEG,4,7)) 233 Q X 234 ROK(X) ; Routine OK (in UCI) (NDBI) 235 S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0 236 ; 237 ;NDBI(X) ; National Database Integration site 1 = yes 0 = no 238 ; N R,G S X="A7RDUP" X ^%ZOSF("TEST") S R=$T,G=$S($D(^A7RCP):1,1:0),X=R+G,X=$S(X=2:1,1:0) Q X 1 ORWPT ; SLC/KCM/REV - Patient Lookup Functions ;11/23/06 10:50 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215,269**;Dec 17, 1997 LOCAL ;Build 28 3 ; Modified from FOIA VISTA, 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License 8 ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED 11/14/06 9 ; 10 Q 11 IDINFO(REC,DFN) ; Return identifying information for a patient 12 ;VWPT BELOW ADD HRN AND ALT HRN 13 ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME^HRN^ALTHRN 14 ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME 15 N X0,X1,X101,X3,XV ; name/dob/sex/ssn, ward, room-bed, sc%, vet 16 S X0=$G(^DPT(DFN,0)),X1=$G(^(.1)),X101=$G(^(.101)),X3=$G(^(.3)),XV=$G(^("VET")) 17 ;VWPT ENHANCED 18 N HRN,ID 19 S HRN=$$HRN^DGLBPID(DFN) 20 S ID=$$ID^DGLBPID(DFN) 21 I (ID=HRN)&(HRN'="") D 22 .S REC=U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U)_U_$$HRNRET(DFN)_U_$$ALTHRN^ORWPT2(DFN) ;DG249 23 E D 24 .S REC=$$ID^DGLBPID(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U)_U_$$HRNRET(DFN)_U_$$ALTHRN^ORWPT2(DFN) ;DG249 25 ;S REC=$$SSN^DPTLK1(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U) ;DG249 26 ;END VWPT 27 Q 28 ;VWPT RETURN HRN .CHECK FOR "sensitive" patients 29 HRNRET(DFN) ; 30 N IRET 31 S IRET=$$HRN^DGLBPID(DFN) ;$$HRN^VWVOEDPT(DFN) 32 ;I (IRET'="")&$$SCREEN^DPTLK1(DFN) Q "*SENSITIVE*" ;"HRN SENSITIVE" 33 I (IRET'="") Q "'"_IRET_"'" ;"HRN:"_"'"_IRET_"'" 34 Q "" 35 ; END VWPT 36 PTINQ(REF,DFN) ; Return formatted pt inquiry report 37 K ^TMP("ORDATA",$J,1) 38 D DGINQ^ORCXPND1(DFN) 39 S REF=$NA(^TMP("ORDATA",$J,1)) 40 Q 41 SCDIS(LST,DFN) ; Return service connected % and rated disabilities 42 N VAEL,VAERR,I,ILST,DIS,SC,X 43 D ELIG^VADPT 44 S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO") 45 I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q 46 S I=0,ILST=1 F S I=$O(^DPT(DFN,.372,I)) Q:'I S X=^(I,0) D 47 . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS="" 48 . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC") 49 . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")" 50 I ILST=1 S LST(2)="Rated Disabilities: NONE STATED" 51 Q 52 SHOW ; temporary - show patient inquiry screen 53 N I,Y,DIC S DIC=2,DIC(0)="AEMQ" D ^DIC Q:'Y 54 K ^TMP("ORDATA",$J,1) 55 D DGINQ^ORCXPND1(+Y) 56 S I=0 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:'I W !,^(I) 57 K ^TMP("ORDATA",$J,1) 58 Q 59 SELCHK(REC,DFN) ; Check for sensitive pt 60 ; SENSITIVE 61 S REC=$$EN1^ORQPT2(DFN) 62 Q 63 DIEDON(VAL,DFN) ; Check for a date of death 64 S VAL=+$G(^DPT(DFN,.35)) 65 Q 66 SELECT(REC,DFN) ; Selects patient & returns key information 67 ; 1 2 3 4 5 6 7 8 9 10 11 12 68 ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^ 69 ;VWPT HRN , ALTERNATE HRN 70 ; 13 14 15 16 17 18 71 ; SC%^ICN^AGE^TS^HRN^AltHRN 72 ; ; 73 ; ;end vwpt 74 ; 75 ; 76 ; for CCOW (RV - 2/27/03) name="-1", location=error message 77 I '$D(^DPT(DFN,0)) S REC="-1^^^^^Patient is unknown to CPRS." Q 78 ; 79 N X,ID,HRN 80 K ^TMP("ORWPCE",$J) ; delete PCE 'cache' when switching patients 81 D VWPT1^ORWPT2 ;moved code to ORWPT2 to save space 82 S $P(REC,U,15)=$$AGE(DFN,$P(REC,U,3)) 83 S $P(REC,U,16)=+$G(^DPT(DFN,.103)) ; treating specialty 84 D VWPT2^ORWPT2 85 Q 86 SHARE(VAL,IP,HWND,DFN) ; Set global to share DFN with other applications 87 K ^TMP("ORWCHART",$J),^TMP("ORECALL",$J),^TMP("ORWORD",$J) 88 K ^TMP("ORWDXMQ",$J) 89 S ^TMP("ORWCHART",$J,IP,HWND)=DFN 90 Q 91 BYWARD(LST,WARD) ; Return a list of patients in a ward 92 N ILST,DFN 93 I +$G(WARD)<1 S LST(1)="^No ward identified" Q 94 S (ILST,DFN)=0 95 S WARD=$P(^DIC(42,WARD,0),"^") ;DBIA #36 96 F S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0 D 97 . S ILST=ILST+1,LST(ILST)=+DFN_U_$P(^DPT(+DFN,0),U)_U_$G(^DPT(+DFN,.101)) 98 I ILST<1 S LST(1)="^No patients found." 99 Q 100 LAST5(LST,ID) ; Return a list of patients matching A9999 identifiers 101 N I,IEN,XREF 102 S (I,IEN)=0,XREF=$S($L(ID)=5:"BS5",1:"BS") 103 F S IEN=$O(^DPT(XREF,ID,IEN)) Q:'IEN D 104 . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$ID^DGLBPID(IEN) ;$$SSN^DPTLK1(IEN) ; DG249 105 Q 106 ; 107 LAST5RPL(LST,ID) ; ; Return list matching A9999 id's, but from RPL only. 108 N ORRPL,ORCNT,ORPT,ORPIEN 109 ; IA ____ allows read access to NEW PERSON file node 101: 110 S ORRPL=$G(^VA(200,DUZ,101)) 111 S ORRPL=$P(ORRPL,U,2) 112 I (('ORRPL)!(ORRPL="")) S LST(0)="" Q 113 ; 114 S (ORCNT,ORPT)=0 115 F S ORPT=$O(^OR(100.21,ORRPL,10,ORPT)) Q:'ORPT D 116 .S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORPT,0)) 117 .I ((ORPIEN<0)!(ORPIEN="")) Q 118 .S ORCNT=ORCNT+1 119 .S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$ID^DGLBPID(ORPIEN) ;$$SSN^DPTLK1(ORPIEN) ; DG249. 120 ; 121 Q 122 ; 123 FULLSSN(LST,ID) ; Return a list of patients matching full SSN entered 124 N I,IEN 125 S (I,IEN)=0 126 F S IEN=$O(^DPT("SSN",ID,IEN)) Q:'IEN D 127 . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$ID^DGLBPID(IEN) ;$$SSN^DPTLK1(IEN) ; DG249 128 Q 129 ; 130 FSSNRPL(LST,ID) ; Return list matching Full SSN, but from RPL only. 131 N ORRPL,ORCNT,ORPT,ORLPT,ORPIEN 132 ; IA ____ allows read access to NEW PERSON file node 101: 133 S ORRPL=$G(^VA(200,DUZ,101)) 134 S ORRPL=$P(ORRPL,U,2) 135 I (('ORRPL)!(ORRPL="")) S LST(0)="" Q 136 ; 137 S (ORCNT,ORPT)=0 138 F S ORPT=$O(^DPT("SSN",ID,ORPT)) Q:'ORPT D 139 .S ORLPT=0 140 .F S ORLPT=$O(^OR(100.21,ORRPL,10,ORLPT)) Q:'ORLPT D 141 ..S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORLPT,0)) 142 ..I ((ORPIEN<0)!(ORPIEN="")) Q 143 ..I (ORPIEN'=ORPT) Q 144 ..S ORCNT=ORCNT+1 145 ..S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$ID^DGLBPID(ORPIEN) ;SSN^DPTLK1(ORPIEN) ; DG249. 146 ; 147 Q 148 ; 149 TOP(LST) ; Return top for all patients list (last selected for now) 150 N IEN 151 S IEN=$G(^DISV(DUZ,"^DPT(")) 152 I IEN S LST(1)=IEN_U_$P($G(^DPT(IEN,0)),U) 153 Q 154 ENCTITL(REC,DFN,LOC,PROV) ; Return external values for encounter 155 ; LOCNAME^LOCABBR^ROOMBED^PROVNAME 156 S $P(REC,U,1)=$P($G(^SC(+LOC,0)),U,1,2) 157 S $P(REC,U,3)=$P($G(^DPT(DFN,.101)),U) 158 S $P(REC,U,4)=$P($G(^VA(200,+PROV,0)),U) 159 Q 160 LISTALL(Y,FROM,DIR) ; Return a bolus of patient names. From is either Name or IEN^Name. 161 N I,IEN,CNT,FROMIEN,ORIDNAME S CNT=44,I=0,FROMIEN=0 162 I $P(FROM,U,2)'="" S FROMIEN=$P(FROM,U,1),FROM=$O(^DPT("B",$P(FROM,U,2)),-DIR) 163 F S FROM=$O(^DPT("B",FROM),DIR) Q:FROM="" D Q:I=CNT 164 . S IEN=FROMIEN,FROMIEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT 165 . . S ORIDNAME="" 166 . . S ORIDNAME=$G(^DPT(IEN,0)) ; Get zero node name. 167 . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) 168 . . S I=I+1 S Y(I)=IEN_U_FROM_U_U_U_U_$P(ORIDNAME,U) ;_"^"_X ; _"^"_X1 ;" ("_X_")" 169 Q 170 APPTLST(LST,DFN) ; return a list of appointments 171 ; APPTTIME^LOCIEN^LOCNAME^EXTSTATUS 172 N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J) ;IA 10061 173 S VASD("F")=$$HTFM^XLFDT($H-30,1) 174 S VASD("T")=$$HTFM^XLFDT($H+1,1)_".2359" 175 S VASD("W")="123456789" 176 D SDA^ORQRY01(.ERR,.ERRMSG) 177 I ERR K ^UTILITY("VASD",$J) K LST S LST(1)=ERRMSG Q 178 S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D 179 . S LST(I)=$P(^UTILITY("VASD",$J,I,"I"),U,1,2)_U_$P(^("E"),U,2,3) 180 K ^UTILITY("VASD",$J) 181 Q 182 ADMITLST(LST,DFN) ; return a list of admissions 183 ; MOVETIME^LOCIEN^LOCNAME^TYPE 184 N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,ILST S ILST=0 185 S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D 186 . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D 187 . . N VSTR,TIUDA 188 . . S X0=$G(^DGPM(MOV,0)) I X0']"" Q 189 . . S MTIM=$P(X0,U) 190 . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1) 191 . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44)) 192 . . S VSTR=HLOC_";"_MTIM_";H",TIUDA=$$HASDS^TIULX(DFN,VSTR) 193 . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XLOC_U_XTYP_U_MOV_U_TIUDA 194 Q 195 CLINRNG(LST) ; return date ranges for clinic appointments 196 S LST(1)="T;T^Today" 197 S LST(2)="T+1;T+1^Tomorrow" 198 S LST(3)="T-1;T-1^Yesterday" 199 S LST(4)="T-7;T^Past Week" 200 S LST(5)="T-31;T^Past Month" 201 S LST(6)="S^Specify Date Range..." 202 Q 203 ; 204 N %,%H,X,SUNDAY,START 205 S LST(1)=DT_";"_DT_"^Today",X=$$HTFM^XLFDT($H+1,1) 206 S LST(2)=X_";"_X_"^Tomorrow" 207 S X=+$H F Q:X#7=3 S X=X-1 ; $H#7=3 is Sunday 208 S LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week" 209 S LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week" 210 S LST(5)=$E(DT,1,5)_"01;"_$E(DT,1,5)_"31^This Month" 211 S X=$E(DT,4,5)+1 S:X=13 X=1 S X=$E(DT,1,3)_$TR($J(X,2)," ",0) 212 S LST(6)=X_"01;"_X_"31^Next Month" 213 S LST(7)="^Specify Dates" 214 Q 215 DFLTSRC(VAL) ; return default patient list source (T, W, C, P, S) 216 N SRV S SRV=+$G(^VA(200,DUZ,5)) 217 S VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE") 218 Q 219 SAVDFLT(OK,X) ; save new default patient list settings (X=type^ien^sdt;edt) 220 G SAVDFLT^ORWPT1 221 ; 222 DISCHRG(Y,DFN,ADMITDT) ; Get discharge movement information 223 N VAIP 224 I +$G(ADMITDT)=0 S Y=DT Q 225 S VAIP("D")=ADMITDT D 52^VADPT 226 I +VAIP(17)=0 S Y=DT Q 227 S Y=+VAIP(17,1) 228 Q 229 CWAD(Y,DFN) ; returns CWAD flags for a patient 230 S Y=$$CWAD^ORQPT2(DFN) 231 Q 232 LEGACY(ORLST,DFN) ; return message if data on the legacy system 233 ; ORLST(0)=1 if data, ORLST(n)=display message if data 234 S ORLST(0)=0 235 I $L($T(HXDATA^A7RDPAGU)) D 236 . D HXDATA^A7RDPAGU(.ORLST,DFN) 237 . I $O(ORLST(0)) S ORLST(0)=1 238 Q 239 INPLOC(REC,DFN) ; Return a patient's current location 240 N X 241 S X=$G(^DPT(DFN,.102)),REC=0 242 I X S X=$P($G(^DGPM(X,0)),U,6) 243 I X S REC=+$G(^DIC(42,X,44)) 244 I X S $P(REC,U,2)=$P($G(^DIC(42,X,0)),U,1) 245 I X S X=$P($G(^DIC(42,X,0)),U,3) 246 S $P(REC,U,3)=X 247 Q 248 AGE(DFN,BEG) ; returns age based on date of birth and date of death (or DT) 249 N END,X 250 S END=+$G(^DPT(DFN,.35)),END=$S(END:END,1:DT) 251 S X=$E(END,1,3)-$E(BEG,1,3)-($E(END,4,7)<$E(BEG,4,7)) 252 Q X 253 ROK(X) ; Routine OK (in UCI) (NDBI) 254 S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0 255 ; 256 ;NDBI(X) ; National Database Integration site 1 = yes 0 = no 257 ; N R,G S X="A7RDUP" X ^%ZOSF("TEST") S R=$T,G=$S($D(^A7RCP):1,1:0),X=R+G,X=$S(X=2:1,1:0) Q X 258 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT16.m
r613 r623 1 ORWPT16 ; SLC/KCM - Patient Lookup Functions - 16bit ;7/20/96 15:43 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242 3 ; 4 IDINFO(ORY,DFN) ; Return identifying information for a patient 5 ; PID^DOB^AGE^SEX^SC%^TYPE^WARD^RM-BED^NAME 6 N OR0,OR36,OR1,OR101,VAEL,VAERR 7 S OR0=$G(^DPT(DFN,0)),OR36=$G(^(.36)),OR1=$G(^(.1)),OR101=$G(^(.101)) 8 D ELIG^VADPT 9 S ORY=$P(OR36,U,3)_U_$P(OR0,U,3)_U_U_$P(OR0,U,2) 10 S ORY=ORY_U_$P(VAEL(3),U,2)_U_$P(VAEL(6),U,2)_U_$P(OR1,U)_U_$P(OR101,U) 11 I $P(OR0,U,3) S $P(ORY,U,3)=DT-$P(OR0,U,3)\10000 12 I '$L($P(ORY,U,1)) D 13 . S X=$P(OR0,U,9),$P(ORY,U,1)=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) 14 S $P(ORY,U,9)=$P(OR0,U,1) 15 Q 16 DEMOG(VAL,DFN) ; procedure 17 ; Return common patient demographic info 18 ; NAME^SEX^DOB^SSN^WARDID^WARDNAME^RMBED^ADMITTIME^DIED ;^SC%^ELIGTYPE 19 S X=^DPT(DFN,0),VAL=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101)) 20 S X=$P(VAL,U,6) I $L(X) S $P(VAL,U,5)=$O(^SC("B",X,0)) 21 S X=$G(^DPT(DFN,.105)) I X S $P(VAL,U,8)=$P(^DGPM(X,0),U,1) 22 I $L($P($G(^DPT(DFN,.35)),U,1)) S $P(VAL,U,9)=$P(^(.35),U,1) 23 Q 24 PSCNVT(VAL,DFN) ; procedure 25 ; Call conversion routine for pharmacy (both inpatient and outpatient) 26 S VAL=0 27 Q 28 LISTALL(Y,DIR,FROM) ; Return a bolus of patient names 29 N I,IEN,CNT S CNT=44,I=0 30 ; 31 I DIR=0 D ; Forward direction 32 . F S FROM=$O(^DPT("B",FROM)) Q:FROM="" D Q:I=CNT 33 . . S IEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT 34 . . . ; S X=$P($G(^DPT(IEN,0)),"^",9) 35 . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) 36 . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) 37 . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1 ;" ("_X_")" 38 . I $G(Y(CNT))="" S I=I+1,Y(I)="" 39 ; 40 I DIR=1 D ; Reverse direction 41 . F S FROM=$O(^DPT("B",FROM),-1) Q:FROM="" D Q:I=CNT 42 . . S IEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT 43 . . . ; S X=$P($G(^DPT(IEN,0)),"^",9) 44 . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) 45 . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) 46 . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1 ;" ("_X_")" 47 Q 48 LOOKUP(Y,FROM) ; Return a set of patient names 49 N I,X 50 D FIND^DIC(2,"","","M",FROM) 51 S I=0,Y="" 52 F S I=$O(^TMP("DILIST",$J,1,I)) Q:'I D 53 . S X=^TMP("DILIST",$J,"ID",I,.09) 54 . S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) 55 . S Y(I)=^TMP("DILIST",$J,2,I)_"^"_^TMP("DILIST",$J,1,I)_"^"_X 56 K ^TMP("DILIST",$J) 57 Q 58 GETVSIT(Y,DFN,LOC,ADATE) ; procedure 59 ; Return a visit given a patient, location, and date/time 60 N VSIT,VSITPKG 61 S (VSIT,VSIT("VDT"))=ADATE,VSIT("PAT")=DFN,VSIT("LOC")=LOC 62 S VSIT("SVC")="A",VSIT("PRI")="P",VSIT(0)="NMD1",VSITPKG="OR" 63 D ^VSIT 64 S Y=VSIT("IEN") I +VSIT("IEN")'>0 S Y="" Q 65 I +VSIT("LOC") S Y=Y_U_VSIT("LOC")_U_$P(^SC(+VSIT("LOC"),0),U,1,2) 66 Q 67 APPTLST(LST,DFN) ; procedure 68 ; Return a list of appointments 69 N I,ILST S ILST=0 70 D GETAPPT^TIUVSIT(DFN) 71 S I=0 F S I=$O(^TMP("TIUVNI",$J,I)) Q:'I D 72 . S ILST=ILST+1 73 . S LST(ILST)=$P(^TMP("TIUVNI",$J,I),U,1,2)_U_$P(^TMP("TIUVN",$J,I),U,1,2) 74 K ^TMP("TIUVN",$J),^TMP("TIUVNI",$J) 75 Q 76 ADMITLST(LST,DFN) ; procedure 77 ; Return a list of admissions 78 N TIM,MOV,X0,Y,MTIM,XTIM,XTYP,XLOC,HLOC,ILST S ILST=0 79 S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D 80 . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D 81 . . S X0=^DGPM(MOV,0) 82 . . S MTIM=$P(X0,U,1),Y=MTIM D DD^%DT S XTIM=Y 83 . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1) 84 . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44)) 85 . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XTIM_U_XTYP_U_"TO: "_XLOC 86 Q 1 ORWPT16 ; SLC/KCM - Patient Lookup Functions - 16bit ;7/20/96 15:43 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 3 ; 4 IDINFO(ORY,DFN) ; Return identifying information for a patient 5 ; PID^DOB^AGE^SEX^SC%^TYPE^WARD^RM-BED^NAME 6 N OR0,OR36,OR1,OR101,VAEL,VAERR 7 S OR0=$G(^DPT(DFN,0)),OR36=$G(^(.36)),OR1=$G(^(.1)),OR101=$G(^(.101)) 8 D ELIG^VADPT 9 S ORY=$P(OR36,U,3)_U_$P(OR0,U,3)_U_U_$P(OR0,U,2) 10 S ORY=ORY_U_$P(VAEL(3),U,2)_U_$P(VAEL(6),U,2)_U_$P(OR1,U)_U_$P(OR101,U) 11 I $P(OR0,U,3) S $P(ORY,U,3)=DT-$P(OR0,U,3)\10000 12 I '$L($P(ORY,U,1)) D 13 . S X=$P(OR0,U,9),$P(ORY,U,1)=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) 14 S $P(ORY,U,9)=$P(OR0,U,1) 15 Q 16 DEMOG(VAL,DFN) ; procedure 17 ; Return common patient demographic info 18 ; NAME^SEX^DOB^SSN^WARDID^WARDNAME^RMBED^ADMITTIME^DIED ;^SC%^ELIGTYPE 19 S X=^DPT(DFN,0),VAL=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101)) 20 S X=$P(VAL,U,6) I $L(X) S $P(VAL,U,5)=$O(^SC("B",X,0)) 21 S X=$G(^DPT(DFN,.105)) I X S $P(VAL,U,8)=$P(^DGPM(X,0),U,1) 22 I $L($P($G(^DPT(DFN,.35)),U,1)) S $P(VAL,U,9)=$P(^(.35),U,1) 23 Q 24 PSCNVT(VAL,DFN) ; procedure 25 ; Call conversion routine for pharmacy (both inpatient and outpatient) 26 S VAL=0 27 S:'$D(IOST) IOST="P-OTHER" ; don't know why broker doesn't define IOST 28 S VAL=$$OTF^OR3CONV(DFN,1) 29 ; D EN1^PSOHLUP(DFN,0) 30 ; D EN^LR7OV2(DFN,0) 31 ; S VAL=1 32 Q 33 LISTALL(Y,DIR,FROM) ; Return a bolus of patient names 34 N I,IEN,CNT S CNT=44,I=0 35 ; 36 I DIR=0 D ; Forward direction 37 . F S FROM=$O(^DPT("B",FROM)) Q:FROM="" D Q:I=CNT 38 . . S IEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT 39 . . . ; S X=$P($G(^DPT(IEN,0)),"^",9) 40 . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) 41 . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) 42 . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1 ;" ("_X_")" 43 . I $G(Y(CNT))="" S I=I+1,Y(I)="" 44 ; 45 I DIR=1 D ; Reverse direction 46 . F S FROM=$O(^DPT("B",FROM),-1) Q:FROM="" D Q:I=CNT 47 . . S IEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT 48 . . . ; S X=$P($G(^DPT(IEN,0)),"^",9) 49 . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) 50 . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) 51 . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1 ;" ("_X_")" 52 Q 53 LOOKUP(Y,FROM) ; Return a set of patient names 54 N I,X 55 D FIND^DIC(2,"","","M",FROM) 56 S I=0,Y="" 57 F S I=$O(^TMP("DILIST",$J,1,I)) Q:'I D 58 . S X=^TMP("DILIST",$J,"ID",I,.09) 59 . S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) 60 . S Y(I)=^TMP("DILIST",$J,2,I)_"^"_^TMP("DILIST",$J,1,I)_"^"_X 61 K ^TMP("DILIST",$J) 62 Q 63 GETVSIT(Y,DFN,LOC,ADATE) ; procedure 64 ; Return a visit given a patient, location, and date/time 65 N VSIT,VSITPKG 66 S (VSIT,VSIT("VDT"))=ADATE,VSIT("PAT")=DFN,VSIT("LOC")=LOC 67 S VSIT("SVC")="A",VSIT("PRI")="P",VSIT(0)="NMD1",VSITPKG="OR" 68 D ^VSIT 69 S Y=VSIT("IEN") I +VSIT("IEN")'>0 S Y="" Q 70 I +VSIT("LOC") S Y=Y_U_VSIT("LOC")_U_$P(^SC(+VSIT("LOC"),0),U,1,2) 71 Q 72 APPTLST(LST,DFN) ; procedure 73 ; Return a list of appointments 74 N I,ILST S ILST=0 75 D GETAPPT^TIUVSIT(DFN) 76 S I=0 F S I=$O(^TMP("TIUVNI",$J,I)) Q:'I D 77 . S ILST=ILST+1 78 . S LST(ILST)=$P(^TMP("TIUVNI",$J,I),U,1,2)_U_$P(^TMP("TIUVN",$J,I),U,1,2) 79 K ^TMP("TIUVN",$J),^TMP("TIUVNI",$J) 80 Q 81 ADMITLST(LST,DFN) ; procedure 82 ; Return a list of admissions 83 N TIM,MOV,X0,Y,MTIM,XTIM,XTYP,XLOC,HLOC,ILST S ILST=0 84 S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D 85 . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D 86 . . S X0=^DGPM(MOV,0) 87 . . S MTIM=$P(X0,U,1),Y=MTIM D DD^%DT S XTIM=Y 88 . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1) 89 . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44)) 90 . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XTIM_U_XTYP_U_"TO: "_XLOC 91 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT2.m
r613 r623 1 ORWPT2 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 29 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 LOOKUP(LST,X1) 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 OVETT 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 TRYPH 103 104 105 106 107 108 109 CHKX(X) 110 111 112 113 114 115 116 117 118 119 120 121 122 CHKXB(X1) 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 LISTPOPB(DFN) 139 140 141 142 143 144 145 146 LISTPOP(DFN,X1) 147 148 149 150 151 152 153 154 155 LISTPOPP(DFN,X1) 156 157 158 159 160 161 162 163 164 165 LISTPOPH(DFN) 166 167 168 169 170 171 LISTPOPD(DFN) 172 173 174 175 176 177 178 179 180 VWPT1 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 VWPT2 201 202 203 204 205 206 ALTHRN(DFN) 207 1 ORWPT2 ; VOE//GT/GOW REV - Patient Lookup Functions ;8/13/07 17:45 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 28 3 ; Copyright (C) 2007 WorldVistA 4 ; 5 ; This program is free software; you can redistribute it and/or modify 6 ; it under the terms of the GNU General Public License as published by 7 ; the Free Software Foundation; either version 2 of the License, or 8 ; (at your option) any later version. 9 ; 10 ; This program is distributed in the hope that it will be useful, 11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 ; GNU General Public License for more details. 14 ; 15 ; You should have received a copy of the GNU General Public License 16 ; along with this program; if not, write to the Free Software 17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 18 ; 19 ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED 11/14/06 20 ;GFT PATIENT LOOKUP' RPC CALLS HERE FOR GENERAL PATIENT LOOKUP 21 ; Ref. to ^UTILITY via IA 10061 22 ; 23 Q 24 ;VWVOEDPT ;GFT VOE PATIENT LOOKUP;6OCT2006 25 ;;5.3;Registration;VWVF VOE LOCAL 26 ; 27 ;;Q 28 ; 29 LOOKUP(LST,X1) ;'GFT PATIENT LOOKUP' RPC CALLS HERE FOR GENERAL PATIENT LOOKUP 30 K LST 31 N GFTI,I,X,ILEN,IEN2,IENN,TAB,ILENP,X3,IEND,CR,XX 32 N IRET 33 N IDTMP,AJJTMP,AJJTMP1 34 ; 35 S X=X1 36 I X="" Q 37 S IEND=0 38 ;UPPERCASE IT 39 X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)" 40 S ILEN=$L(X) 41 ;CHECK INPUT TAB POSTION 20, 25, 30 WITH PRECEDING TRAILING BLANKS 42 ;CHECK FOR INITITAL LOOKUP BY DFN AS !DFN 43 ;CHECK FOR LOOKUP BY DFN AS 3 TAB POSITION FOR CLICKING AFTER PREVIOUS LOOKUP 44 S TAB=$C(9) 45 S X3=$P(X,TAB,3) 46 I X3'="",X3'="OPT" D 47 .S X=X3 48 .S ILENP=$L(X) 49 .S X=$E(X,2,ILENP) ;TAKEOUT ! 50 .S U="^",(GFTI,I)=0 51 .D LISTPOPD(X) 52 .S IEND=1 53 E D 54 .S X=$P(X,TAB,1) 55 I IEND=1 Q 56 I $E(X1,1,1)="'" D 57 .I ILEN'=1 S X=$E(X1,2,ILEN) 58 .;CHECK FOR ENDING "'" 59 .S CR=$C(13) 60 .I $E(X1,ILEN,ILEN)'="'" S IEND=1 61 .S X=$P(X,"'",1) 62 S U="^",(GFTI,I)=0 63 I IEND=1 Q 64 S XX=X ; NO CR FOR HRN 65 F S IRET=$$CHKX(X) Q:IRET'=1 S I=$O(^AUPNPAT("D",X,I)) Q:'I I X=$$HRN^DGLBPID(I) D LISTPOPH(I) ;I X=$P($$HRN^DGLBPID(I),"#",2 66 Q:GFTI 67 ; 68 S X=XX 69 ;NOW CHECK FOR B CROSS REFERENCE 70 D FIND^DIC(2,,,"MPC",X,,"B") ; ^SSN^BS5") 71 F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I D LISTPOPB(+^(I,0)) 72 K ^TMP("DILIST",$J) 73 Q:GFTI>0 74 OVETT ; 75 Q:ILEN<4 ;USE ADOB LOOKUP XXX- 76 ; 77 ; 78 ; 79 ; NEW EDITS/GOW 8/12/07 BELOW. CHECK TO PREVENT ASSUMED CURRENT YEAR TRIGGER 80 ; SELECTION AUTOMATICALLY WITH JUST MONTH DAY OR MM/DD INPUT. REQUIRE REMAINING YR ( 2 DIGIT MINIMUM) 81 ; WE CAN USE NUMERIC ENTRY ( IE 2-3-56, 2/3/56 OR 2.3.56, JUN 12,68, ETC OR 4 DIGIT YEAR FOR EXPLICIT YEAR ENTRY, IE JUNE 1,1903 82 S NOCONTIN=0 83 D 84 .S NOCONTIN=1 85 .S IDTMP=$E($TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),1,30) 86 .I IDTMP'=X D 87 ..S AJJTMP=$L($TR($P(X,",",2)," ")) I AJJTMP>1 S NOCONTIN=0 Q ;CASE FOR SPECIFIC DATE ENTRY BY ALPHABETIC MONTH DAY AND "," AND AT LEAST 2 YR DATE 88 ..S AJJTMP=$L($TR($P(X," ",2),",")) I AJJTMP>3 S NOCONTIN=0 Q ;CASE FOR SPECIFIC ( MONTH DAY followed by " " (space) and Year ( 2 or4 digit yr) 89 .I IDTMP'=X Q ; ALPHABETICAL DATE OF SOME KIND WHICH HAS BEEN TESTED ALREADY 90 .S AJJTMP=$L($TR($P(X,"-",3)," ")) I AJJTMP>1 S NOCONTIN=0 ;NUMERIC INPUT 91 .S AJJTMP=$L($TR($P(X,"/",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT 92 .S AJJTMP=$L($TR($P(X,".",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT 93 I NOCONTIN=1 G TRYPH ; TRY PHONE # 94 ;END EDITS/GOW 95 ; 96 ; 97 D FIND^DIC(2,,,"MPC",X,,"ADOB^B") ;^SSN^BS5") 98 F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I D LISTPOP(+^(I,0),X1) 99 K ^TMP("DILIST",$J) 100 Q:GFTI>0 101 ;TRY PHONE # WITH TRANSLATE 102 TRYPH ; 103 Q:ILEN<10 104 S X=$E($TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|"),1,30) 105 D FIND^DIC(2,,,"MPC",X,,"AZVWVOE^B") ;^SSN^BS5") 106 F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I D LISTPOPP(+^(I,0),X1) 107 K ^TMP("DILIST",$J) 108 Q 109 CHKX(X) ;CHECK TO SEE IF LEGITIMATE HRN EXISTS FOR IHS PATIENT HRN 110 N IDX,ILENM1,IFLAG 111 S IFLAG=0 112 S IDX=X 113 ;TO SEE blank char inserts 114 S ILENM1=$L(X)-1 115 I ILENM1>0 D 116 .S IDX=$E(X,1,ILENM1) 117 E D 118 .S IDX="" 119 F S IDX=$O(^AUPNPAT("D",IDX)) Q:(IDX="")!(IFLAG=1) D 120 . I IDX=X S IFLAG=1 121 Q IFLAG 122 CHKXB(X1) ;CHECK TO SEE IF PATIENT NAME ENTERED TO ALLOW LOOKUP EVEN FOR SENSITIVE PATIENT 123 N IDX,ILENM1,IFLAG,X 124 S IFLAG=0 125 S X=X1 126 ;CONVERT UPPER CASE 127 X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)" 128 S IDX=X 129 ;TO SEE blank char inserts 130 S ILENM1=$L(X)-1 131 I ILENM1>0 D 132 .S IDX=$E(X,1,ILENM1) 133 E D 134 .S IDX="" 135 F S IDX=$O(^DPT("B",IDX)) Q:(IDX="")!(IFLAG=1) D 136 . I IDX=X S IFLAG=1 137 Q IFLAG 138 LISTPOPB(DFN) ;PATIENT NAME B X-REF 139 N IEN 140 N HRN,PHONE,X 141 Q:($$SCREEN^DPTLK1(DFN)) ;SCREEN FOR VIP 142 Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX 143 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) 144 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE 145 Q 146 LISTPOP(DFN,X1) ;DOB 147 N IEN 148 N HRN,PHONE,X 149 S IEN=$$CHKXB(X1) ;ALLOW INPUT BY NAME ON CLICK 150 Q:($$SCREEN^DPTLK1(DFN))&(IEN=0) ;SCREEN FOR VIP 151 Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX 152 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) 153 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE 154 Q 155 LISTPOPP(DFN,X1) ;PHONE # 156 N IEN 157 N HRN,PHONE,X 158 S IEN=$$CHKXB(X1) ;ALLOW INPUT BY NAME ON CLICK 159 Q:($$SCREEN^DPTLK1(DFN))&(IEN=0) ;SCREEN FOR VIP 160 Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX 161 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) 162 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_PHONE_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE 163 Q 164 ; 165 LISTPOPH(DFN) ;Q:$$SCREEN^DPTLK1(DFN) ;SCREEN FOR VIP FOR HRN 166 N HRN,PHONE 167 Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX 168 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) 169 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_"'"_HRN_"'"_TAB_"!"_DFN_U_$$FMTE^XLFDT($P(^(0),U,3))_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE 170 Q 171 LISTPOPD(DFN) ; 172 N IEN 173 N HRN,PHONE,X 174 ;NO SCREEN FOR VIP 175 Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX 176 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) 177 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE 178 Q 179 ; 180 VWPT1 ;VWPT NEW LOGIC . 4TH PIECE BELOW REPLACE $P(X,U,9)=SSN WITH ID AS $$ID^DGLBPID(DFN) 181 ; THEN IF THIS VALUE = HRN AND BOTH '="" THEN PUT SINGLE QUOTES 182 ; AROUND 4TH PIECE AS THIS IS SAME AS HRN. 183 S ID=$$ID^DGLBPID(DFN) S HRN=$$HRN^DGLBPID(DFN) 184 I (ID=HRN)&(HRN'="") S ID="'"_ID_"'" 185 ; 186 ;VWPT LINE BELOW WITH ID SUBSTITUTED FOR 9TH PIECE OF X 187 S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_ID_U_U_$G(^(.1))_U_$G(^(.101)) 188 ; End VOE mod 189 ; 190 ; Following taken from ORWPT call to VWPT1 to save space 191 ; 192 S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44)) 193 S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN) 194 S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U) 195 S:'$D(IOST) IOST="P-OTHER" 196 S $P(REC,U,11)=$$OTF^OR3CONV(DFN,1) 197 D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC% 198 I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X 199 Q 200 VWPT2 ;VWPT GET HRN AND ALTERNATE HRN 201 S $P(REC,U,17)="'"_$$HRN^DGLBPID(DFN)_"'" ;$$HRN^VWVOEDPT(DFN) 202 S $P(REC,U,18)=$$ALTHRN(DFN) 203 K VAEL,VAERR ;VADPT call to kill? 204 S ^DISV(DUZ,"^DPT(")=DFN 205 Q 206 ALTHRN(DFN) ; 207 Q "" -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT3.m
r613 r623 1 ORWPT3 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 29 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 OTHER(LST,IDIN,OTHER) 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 ISNUM(XA) 158 159 1 ORWPT3 ; VOE/GOW /REV - Patient Lookup Functions ;8/13/07 17:49 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 28 3 ; Copyright (C) 2007 WorldVistA 4 ; 5 ; This program is free software; you can redistribute it and/or modify 6 ; it under the terms of the GNU General Public License as published by 7 ; the Free Software Foundation; either version 2 of the License, or 8 ; (at your option) any later version. 9 ; 10 ; This program is distributed in the hope that it will be useful, 11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 ; GNU General Public License for more details. 14 ; 15 ; You should have received a copy of the GNU General Public License 16 ; along with this program; if not, write to the Free Software 17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 18 ;'Modified' MAS Patient Look-up Check Cross-References June 1987 19 ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED WITH "OTHER" RADIOBUTTON LOOKUPS FOR DOB AND PHONE NO 11/14/06 20 ; 21 ; Ref. to ^UTILITY via IA 10061 22 ; 23 Q 24 ; 25 ;VWPT ENHANCEMENTS folow for "other" RADIO BUTTONlookup 26 OTHER(LST,IDIN,OTHER) ; RADIO BUTTON Return a list of patients matching other ID identifier 27 N I,ID,IEN,ILENX,XREF,IDM1,ILEN1,ILNM1,ILENM1,IDD1,IPAST1,IDXX,IDSS,IDD2,LEN1,IFDN,IDX,IDS,DATEF,ILEN1,IPAST,ZVW,TEMP,IVAL,IVAR1,IFIND,IFDNS,IVAR,ARRAY,ERRARRAY,IENS 28 N IEN2,IENN,TAB,IX 29 N ILENP,X3,IEND,IDXS,IENNNN 30 N IDTMP,AJJTMP,AJJTMP1 31 I IDIN="" Q 32 S (I,IEN,IEND)=0 33 S ID=IDIN 34 S X=ID 35 S ILENX=$L(X) 36 ;REMOVES TABS 37 ;CHECK INPUT TAB POSTION 20, 25, 30 WITH PRECEDING TRAILING BLANKS 38 S TAB=$C(9) 39 S IX=$P(X,TAB,3) ; WAS 2ND POS 40 I IX'="" D 41 .S ILENP=$L(IX) 42 .S X=$E(IX,2,ILENP) ; JUMP OVER ! 43 .S LST(1)=X_U_$P(^DPT(X,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_X_U_$$ID^DGLBPID(X) ; $$SSN^DPTLK1_U_IVAL ; RETURN OTHER AS 5TH PIECE 44 .; 45 .S IEND=1 46 E D 47 .;JUST UPPER CASE IT 48 .;UPPERCASE IT 49 .X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)" 50 I IEND=1 Q 51 S ID=X 52 ;OTHER IS FIELD NAME 53 ;GET THE FIELD NUMBER 54 S IFDN=0 55 S IFDN=$O(^DD(2,"B",OTHER,IFDN)) 56 I IFDN="" Q 57 ;FOR NOW JUST USE ONE OF TWO CROSS-REFERENCES , 58 ;ONE FOR DOB AS ADOB AND THE OTHER FOR PHONE # AS AZVWVOE 59 I OTHER="DATE OF BIRTH" S ICREF="ADOB" 60 I OTHER="PHONE NUMBER [RESIDENCE]" D 61 .S ICREF="AZVWVOE" 62 .S ID=$E($TR(ID,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|"),1,30) 63 I ICREF="AZVWVOE" I ILENX<7 Q 64 ; 65 ; NEW EDITS/GOW 8/12/07 BELOW. RADIO BUTTON HAS SLIGHTLY DIFFERENT FUNCTIONALITY THAN 66 ; WITH GENERIC MULTI-SOURCE LOOKUP. ALSO, CHECK TO PREVENT ASSUMED CURRENT YEAR TRIGGER 67 ; SELECTION AUTOMATICALLY WITH JUST MONTH DAY OR MM/DD INPUT. REQUIRE REMAINING YR ( 2 DIGIT MINIMUM) 68 ; THE LOGIC ALLOWED A FUZZY MONTH ONLY LOOKUP FOR DOB AS A SPECIFIC DOB MAY NOT BE KNOWN ,OR REMEMBERED. 69 ; FOR FUZZY LOGIC REQUIRE 4 DIGIT YEAR ON DATE RANGE W/O SPECIFIC DAY(DATE) ENTERED 70 ; EXAMPLE, AS MONTH/YEAR ( IE, JUN 2005). NOW, MAKE CHANGE TO ALLOW THIS ONLY BY APHABETIC MONTH AND NUMERIC YEAR (2 OR 4 DIGIT) LOOKUP 71 ; THEN FOR SPECIFIC DOB LOOKUP WITH RADIO BUTTON SELECTION, WE CAN USE NUMERIC ENTRY ( IE 2-3-56, 2/3/56 OR 2.3.56 72 ; FOR WHICH WAIT FOR SELECTION WILL OCCUR UNTIL AT A TRAILING 2 DIGIT YEAR IS INPUT WITH THE FORMER FORMATS ABOVE 73 S NOCONTIN=0 74 I ICREF="ADOB" D 75 .S NOCONTIN=1 76 .S IDTMP=$E($TR(ID,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),1,30) 77 .I IDTMP'=ID D 78 ..;ALPHABETIC FUZZY MONTH ALLOWED or a specific date for at least a 4 DIGIT year that must specified after a "," ( ie June 15,1968) 79 ..;OTHERWISE CHECK FOR TRAILING YEAR 80 ..S AJJTMP=$L($TR($P(ID,",",2)," ")) I AJJTMP>1 S NOCONTIN=0 Q ;CASE FOR SPECIFIC DATE ENTRY BY ALPHABETIC MONTH DAY AND "," AND AT LEAST 2 YR DATE 81 ..S AJJTMP=$L($TR($P(ID," ",2),",")) I AJJTMP>3 S NOCONTIN=0 Q ;CASE FOR SPECIFIC ( MONTH DAY followed by " " (space) and Year ( 2 or4 digit yr) 82 ..S AJJTMP=$L($TR($P(ID," ",2)," ")) I AJJTMP>3 S AJJTMP1=$TR(AJJTMP,",") I AJJTMP1=AJJTMP S NOCONTIN=0 Q ;CASE FOR FUZZY DATE ( MONTH followed by " " (space) and Year (4 digit yr) 83 .I IDTMP'=ID Q ; ALPHABETICAL DATE OF SOME KIND WHICH HAS BEEN TESTED ALREADY 84 .S AJJTMP=$L($TR($P(ID,"-",3)," ")) I AJJTMP>1 S NOCONTIN=0 ;NUMERIC INPUT 85 .S AJJTMP=$L($TR($P(ID,"/",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT 86 .S AJJTMP=$L($TR($P(ID,".",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT 87 I NOCONTIN=1 Q 88 ;END EDITS/GOW 89 ; 90 S IDX=ID 91 ;TO SEE blank char inserts 92 S ILENM1=$L(ID)-1 93 I ILENM1>0 D 94 .;S IDLC=$E(ID,1,ILENM1) 95 .S IDX=$E(ID,1,ILENM1) S IDXS=IDX 96 E D 97 .S IDX="" S IDXS=IDX 98 Q:ILENX<4 ;USE PHONE NUMBER LOOKUP XXX- 99 ;HOWEVER ID DATE OR DATE/TIME FIELD CONVERT ID TO 100 ;INTERNAL TIME 101 S DATEF=$P($G(^DD(2,IFDN,0)),"^",2) 102 I DATEF["D" D 103 .;NEW BELOW 104 .S X=ID D ^%DT S IDX=Y S IDS=Y 105 .I Y'=-1 D 106 . . S ILNM1=$L(IDX)-1 107 . . S IDX=$E(IDX,1,ILNM1) 108 . . ;W !,"IDX=",IDX,"IDS=",IDS 109 S IPAST=0 110 S IPAST1=0 111 S ILEN1=$L(ID) 112 F S IDX=$O(^DPT(ICREF,IDX)) Q:(IDX="")!(IPAST1=1) D 113 . S IEN=0 114 . ;EXTRA TO GET TRAILING SPACES 115 . I DATEF'["D" D 116 . . S IDD1=$E(IDX,1,ILEN1) I $L(IDD1)<ILEN1 Q 117 . F S IEN=$O(^DPT(ICREF,IDX,IEN)) Q:IEN="" D 118 . . S IPAST=0 119 . . ;W !,"IDX=",IDX," IDS=",IDS 120 . .I DATEF["D" D 121 . . .;CHECK FOR MONTH ONLY 122 . . .I $E(IDS,6,7)="00" D 123 . . . .S IDXX=$E(IDX,1,5) S IDSS=$E(IDS,1,5) 124 . . . .;W !,"IDXX=",IDXX," IDSS=",IDSS 125 . . . .I IDXX'=IDSS S IPAST=1 126 . . . .I IDXX>IDSS S IPAST1=1 Q 127 . . . .I IPAST=1 Q 128 . . .E D 129 . . . .;W !,"IDX=",IDX 130 . . . .I IDX'=IDS S IPAST=1 131 . . . .I IDX>IDS S IPAST1=1 Q 132 . . . .I IPAST=1 Q 133 . .E D 134 . . .S IDD1=$E(IDX,1,ILEN1) S IDD2=$E(ID,1,ILEN1) 135 . . .;W !,"IDD1=",IDD1 W !,"IDD2=",IDD2 136 . . .I $$ISNUM(IDD2)&$$ISNUM(IDD1) D 137 . . . .I IDD1'=IDD2 S IPAST=1 138 . . . .I IDD1>IDD2 S IPAST1=1 Q 139 . . . .I IPAST=1 Q 140 . . . .; 141 . . . .; 142 . . .E D 143 . . . .; 144 . . . .I IDD1'=IDD2 S IPAST=1 145 . . . .I IDD1]IDD2 S IPAST1=1 Q 146 . . . .I IPAST=1 Q 147 . .I IPAST=1 Q 148 . .I DATEF["D" D 149 . . .S Y=IDX S X=IDX D DD^%DT S IVAL=Y 150 . .E D 151 . . .S IVAL=IDX 152 . .S I=I+1 153 . .I $$SCREEN^DPTLK1(IEN) Q 154 . .;IVAL IS NOT HRN NOW 155 . .S LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_IVAL_TAB_"!"_IEN_U_$$FMTE^XLFDT($P(^(0),U,3))_U_$$ID^DGLBPID(IEN) ; _U_IVAL ; RETURN OTHER AS 5TH PIECE 156 Q 157 ISNUM(XA) ; 158 I XA=+XA Q 1 159 Q 0 -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP.m
r613 r623 1 ORWRP ; ALB/MJK,dcm Report Calls ; 12/05/02 11:03 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**1,10,85,109,132,160,194,227,215,262,243**;Dec 17, 1997;Build 242 3 ; 4 LABLIST(LST) ; -- report list for labs tab 5 ; RPC: ORWRP LAB REPORT LIST 6 N I,J,X,X0,X2,CNT,EOF,IFN,ROOT,RPC,ORLIST,HEAD 7 S EOF="$$END",ROOT=$NA(LST),(CNT,I)=0 8 D SETITEM(ROOT,"[LAB REPORT LIST]") 9 D GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LAB LIST") 10 F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0),X2=$G(^(2)) D 11 . Q:$P(X0,"^",12)="L" 12 . S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^") 13 . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3) 14 . S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN 15 . D SETITEM(.ROOT,X) 16 D SETITEM(.ROOT,"$$END") 17 Q 18 LIST(LST) ; -- report lists for reports tab 19 ; RPC: ORWRP REPORT LIST 20 N EOF,ROOT 21 S EOF="$$END",ROOT=$NA(LST) 22 K @ROOT 23 D GETRPTS(.ROOT,.EOF) ; -report list 24 D GETHS(.ROOT,.EOF) ; -health summary types 25 D GETDT(.ROOT,.EOF) ; -date ranges 26 Q 27 GETCOL(ROOT,IFN) ; -- get Column headers for ListView 28 N I,J,X,VAL 29 Q:'$G(IFN) 30 S I=0,ROOT=$NA(ROOT) 31 F S I=$O(^ORD(101.24,IFN,3,"C",I)) Q:'I D 32 . S VAL=$$GET^XPAR(DUZ_";VA(200,","ORWCH COLUMNS REPORTS",IFN,"I"),J=0 33 . F S J=$O(^ORD(101.24,IFN,3,"C",I,J)) Q:'J I $D(^ORD(101.24,IFN,3,J)) S X=^(J,0) D 34 .. I $L(VAL),$P(VAL,",",I) S $P(X,"^",10)=$P(VAL,",",I) 35 .. D SETITEM(.ROOT,X) 36 Q 37 GETRPTS(ROOT,EOF) ; -- get report list 38 N I,J,X,X0,X2,CNT,IFN,ORLIST,HEAD 39 D SETITEM(.ROOT,"[REPORT LIST]"),GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LIST") 40 S (CNT,I)=0 41 F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0),X2=$G(^(2)) D 42 . Q:$P(X0,"^",12)="L" 43 . S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^") 44 . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3) 45 . S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",4)_"^"_$P(X0,"^",19)_";"_$P(X0,"^",20)_"^"_$P(X0,"^",6)_"^"_$P(X0,"^",5)_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN 46 . D SETITEM(.ROOT,X) 47 D SETITEM(.ROOT,"$$END") 48 Q 49 GETHS(ROOT,EOF) ; --get health summary types 50 N C,I,IFN,ORHSPARM,ORERR,X,T 51 K ^TMP("ORHSPARM",$J) 52 S ORHSROOT="^TMP(""ORHSPARM"",$J)" 53 I $$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) S I="",C=0 D 54 . F S I=$O(^GMT(142,"B",I)) Q:I="" S IFN=$O(^(I,0)) Q:'IFN D 55 .. S X=$G(^GMT(142,IFN,0)) Q:'$L(X) 56 .. S T=$G(^GMT(142,IFN,"T")),C=C+1,@ORHSROOT@(C)=IFN_"^"_$S($L(T):T,1:$P(X,"^"))_"^^^^^1" 57 .. I I="GMTS HS ADHOC OPTION" S @ORHSROOT@(C)="0^GMTS Adhoc Report" 58 I '$$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) D 59 . D:$L($T(GETLIST^GMTSXAL)) GETLIST^GMTSXAL($NA(@ORHSROOT),$G(DUZ),1,.ORERR) 60 . Q:$G(ORERR) 61 . S I=0 F S I=$O(@ORHSROOT@(I)) Q:'I S @ORHSROOT@(I)=@ORHSROOT@(I)_"^^^^^1" I $P(@ORHSROOT@(I),"^",2)="GMTS HS ADHOC OPTION" S @ORHSROOT@(I)="0^Adhoc Report" 62 D SETITEM(.ROOT,"[HEALTH SUMMARY TYPES]") 63 S I=0 F S I=$O(@ORHSROOT@(I)) Q:'I D SETITEM(.ROOT,"h"_@ORHSROOT@(I)) 64 D SETITEM(.ROOT,EOF) 65 Q 66 GETDT(ROOT,EOF) ; -- get date range choices 67 N I,X 68 D SETITEM(.ROOT,"[DATE RANGES]") 69 F I=2:1 S X=$P($T(DTLIST+I),";",3) Q:X=EOF D SETITEM(.ROOT,"d"_X) 70 Q 71 DTLIST ; -- list of date ranges 72 ;<number of days>^ <display text> 73 ;;S^Date Range... 74 ;;0^Today 75 ;;7^One Week Back 76 ;;14^Two Weeks Back 77 ;;30^One Month Back 78 ;;180^Six Months Back 79 ;;365^One Year Back 80 ;;732^Two Years Back 81 ;;50000^All Results 82 ;;$$END 83 ; 84 SETITEM(ROOT,X) ; -- set item in list 85 S @ROOT@($O(@ROOT@(9999),-1)+1)=X 86 Q 87 RPT(ROOT,DFN,RPTID,HSTYPE,DTRANGE,EXAMID,ALPHA,OMEGA) ; -- return report text 88 ;ROOT=Output in ^TMP("ORDATA",$J) 89 ;DFN=Patient DFN ; ICN for remote sites 90 ;RPTID=Unique report ID_";"_Remote ID_"~"_HSComponent for listview (ent;rtn;0;MaxOcc) or text (ent;rtn;#component;MaxOcc) 91 ;HSTYPE=Health Sum Type 92 ;DTRANGE=# days back from today 93 ;EXAMID=Rad exam ID 94 ;ALPHA=Start date 95 ;OMEGA=End date 96 ; RPC: ORWRP REPORT TEXT 97 ; 98 N X,X0,X2,X4,I,J,ENT,RTN,ID,REMOTE,GO,OUT,MAX,SITE,ORFHIE,%ZIS,HSTAG,DIRECT,TAB 99 K ^TMP("ORDATA",$J) 100 S TAB="R" 101 I $E(RPTID,1,2)="L:" S TAB="L",RPTID=$P(RPTID,":",2,999) ;an ID beginning with "L:" forces TAB to LAB - "L:" added in GUI code 102 S HSTAG=$P($G(RPTID),"~",2),RPTID=$P($G(RPTID),"~"),ROOT=$NA(^TMP("ORDATA",$J,1)),REMOTE=+$P(RPTID,";",2),RPTID=$P($P(RPTID,";"),":") 103 I 'REMOTE S DFN=+DFN ;DFN = DFN;ICN for remote calls 104 S I=0,X0="",X2="",X4="",SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3) 105 F S I=$O(^ORD(101.24,"AC",I)) Q:I="" S J=0 F S J=$O(^ORD(101.24,"AC",I,J)) Q:'J D 106 . I $P($G(^ORD(101.24,J,0)),"^",2)=RPTID,$P(^(0),"^",8)=TAB S X0=^(0),X2=$G(^(2)),ORFHIE=$G(^(4)),DIRECT=$P(ORFHIE,"^",4),X4=$P(ORFHIE,"^",2),ORFHIE=$P(ORFHIE,"^",3) 107 I '$L(X0) D NOTYET(.ROOT) Q 108 S RTN=$P(X0,"^",5),ENT=$P(X0,"^",6) 109 I '$L(RTN)!'$L(ENT) D NOTYET(.ROOT) Q 110 I '$L($T(@(ENT_"^"_RTN))) D NOTYET(.ROOT) Q 111 ;I $G(ALPHA) S X=ALPHA-$G(OMEGA) D ;jeh 243 112 I $G(ALPHA) D 113 . N X1,X2 114 . S X=ALPHA 115 . S X1=ALPHA,X2=$G(OMEGA) D:X2 ^%DTC ;X returned, # of days diff 116 . I X<0 S X=X*(-1) 117 . I X4,X>X4 S:ALPHA>OMEGA OMEGA=$$FMADD^XLFDT(ALPHA,-X4) S:ALPHA'>OMEGA ALPHA=$$FMADD^XLFDT(OMEGA,-X4) S DTRANGE="" 118 I X4,$G(DTRANGE)>X4 S DTRANGE=X4,ALPHA="" 119 I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=DT_".235959" 120 I $G(OMEGA),$E(OMEGA,8)'="." S OMEGA=OMEGA_".235959" 121 S ID=$G(HSTAG),$P(ID,";",5,10)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9)_";"_RPTID_";"_$G(DIRECT) ;HDRHX CHANGE 122 I $L($P($G(HSTAG),";",4)) S MAX=$P(HSTAG,";",4) 123 I $L($G(HSTYPE)) M ID=HSTYPE 124 I $L($G(EXAMID)) M ID=EXAMID 125 S OUT=ENT_"^"_RTN_"(.ROOT,DFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.MAX,.ORFHIE)" 126 I REMOTE S GO=0 D Q:'GO 127 . I '$L($T(GETDFN^MPIF001)) D SETITEM(.ROOT,"MPI routines missing on remote system ("_SITE_")") S GO=0 Q 128 . S ICN=+$P(DFN,";",2),DFN=+$$GETDFN^MPIF001(ICN) 129 . I DFN<0 D SETITEM(.ROOT,"Patient not found on remote system ("_SITE_")") S GO=0 Q 130 . S GO=+$P(X0,"^",3) 131 . I 'GO D SETITEM(.ROOT,"Remote access not available for this report ("_SITE_")") 132 S %ZIS="0N" 133 D @OUT 134 Q 135 NOTYET(ROOT) ; -- not available 136 D SETITEM(.ROOT,"Report not available at this time.") 137 Q 138 START(RM,GOTO,ORIOSL) ; 139 ;RM=Right margin 140 N ZTQUEUED,ORHFS,ORSUB,ORIO,ORHANDLE,IOM,IOSL,IOST,IOF,IOT,IOS 141 S ORHFS=$$HFS(),ORSUB="ORDATA",ORHANDLE="ORWRP" 142 D HFSOPEN(ORHANDLE,ORHFS,"W") 143 I POP D Q 144 . I $D(ROOT) D SETITEM(.ROOT,"ERROR: Unable to open HFS file") 145 D IOVAR(.ORIO,.RM,.ORIOSL) 146 N $ETRAP,$ESTACK 147 S $ETRAP="D ERR^ORWRP Q" 148 U IO 149 D @GOTO 150 D HFSCLOSE(ORHANDLE,ORHFS) 151 Q 152 ERR ;Error trap 153 S $ETRAP="D UNWIND^ORWRP Q" 154 N %ZIS 155 S %ZIS="0N" 156 D @^%ZOSF("ERRTN") ;file error 157 I $D(ORHANDLE) D CLOSE^%ZISH(ORHANDLE) 158 I $D(ORHFS) D 159 . N ORARR,OROK 160 . S ORARR(ORHFS)="",OROK=$$DEL^%ZISH("",$NA(ORARR)) ;delete HFS file 161 S $ECODE=",UOR69 error during CPRS report build," 162 Q 163 UNWIND ;Unwind Error stack 164 Q:$ESTACK>1 ;pop stack 165 ; 166 Q 167 HFS() ; -- get hfs file name 168 N H 169 S H=$H 170 Q "ORU_"_$J_"_"_$P(H,",")_"_"_$P(H,",",2)_".DAT" 171 HFSOPEN(HANDLE,ORHFS,ORMODE) ; 172 D OPEN^%ZISH(HANDLE,,ORHFS,$G(ORMODE,"W")) Q:POP 173 Q 174 IOVAR(ORIO,ORRM,ORIOSL,ORIOST,ORIOF,ORIOT) ;Setup IO variables based on IO Device 175 N IFN,IFN1 176 S ORIO=$G(ORIO,"OR WORKSTATION"),ION=ORIO,IOM=$G(ORRM,80),IOSL=$G(ORIOSL,62),IOST=$G(ORIOST,"P-OTHER"),IOF=$G(ORIOF,""""""),IOT=$G(ORIOT,"HFS") 177 I $O(^%ZIS(1,"B",ORIO,0)) S IFN=$O(^(0)),IOS=IFN 178 I $D(^%ZIS(1,IFN,0)) S IOST(0)=+$G(^("SUBTYPE")),IOT=$G(ORIOT,^("TYPE")),IOST=$G(ORIOST,$P($G(^%ZIS(2,IOST(0),0),IOST),"^")) 179 I $O(^%ZIS(2,"B",IOST,0)) S IFN=$O(^(0)) I IFN S IOST(0)=IFN,IFN1=$G(^%ZIS(2,IFN,1)),IOM=$G(ORRM,$P(IFN1,"^")),IOF=$G(ORIOF,$P(IFN1,"^",2)),IOSL=$G(ORIOSL,$P(IFN1,"^",3)) 180 Q 181 HFSCLOSE(HANDLE,ORHFS) ;Close HFS and unload data 182 N ORDEL,X,%ZIS 183 S %ZIS="0N" 184 I IO[ORHFS D CLOSE^%ZISH(HANDLE) 185 S ROOT=$NA(^TMP(ORSUB,$J,1)),ORDEL(ORHFS)="" 186 K @ROOT 187 S X=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4) 188 D STRIP 189 S X=$$DEL^%ZISH(,$NA(ORDEL)) 190 Q 191 USEHFS ; -- use host file to build global array 192 N OROK,SECTION 193 S SECTION=0 194 D INIT 195 S OROK=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4) I 'OROK Q 196 D STRIP 197 N ORARR S ORARR(ORHFS)="" 198 S OROK=$$DEL^%ZISH("",$NA(ORARR)) 199 Q 200 INIT ; -- initialize counts and global section 201 S (INC,CNT)=0,SECTION=SECTION+1,ROOT=$NA(^TMP(ORSUB,$J,SECTION)) 202 K @ROOT 203 Q 204 FINAL ; -- set 'x of y' for each section CALLED FROM ^ORWLR 205 N I 206 F I=1:1:SECTION S ^TMP(ORSUB,$J,I,.1)=I_U_SECTION 207 Q 208 STRIP ; -- strip off control chars 209 N I,X 210 S I=0 F S I=$O(@ROOT@(I)) Q:'I S X=^(I) D 211 . I X[$C(8) D ;BS 212 .. I $L(X,$C(8))=$L(X,$C(95)) S (X,@ROOT@(I))=$TR(X,$C(8,95),"") Q ;BS & _ 213 .. S (X,@ROOT@(I))=$TR(X,$C(8),"") 214 . I X[$C(7)!(X[$C(12)) S @ROOT@(I)=$TR(X,$C(7,12),"") ;BEL or FF 215 Q 216 WINDFLT(ORY) ;Windows printer as default? 217 S ORY=+$$GET^XPAR("ALL","ORWDP WINPRINT DEFAULT") 218 Q 219 GETDFPRT(Y,ORUSER,ORLOC) ; Returns default printer for user 220 N IEN,X0,ENT 221 S ENT="ALL" 222 I $G(ORLOC) S ORLOC=+ORLOC_";SC(",ENT=ENT_"^"_ORLOC 223 I +$$GET^XPAR(ENT,"ORWDP WINPRINT DEFAULT") S Y="WIN;Windows Printer" Q 224 S IEN=$$GET^XPAR(ENT,"ORWDP DEFAULT PRINTER",1) Q:+IEN=0 225 Q:'$D(^%ZIS(1,IEN,0)) S X0=^(0) 226 S Y=IEN_";"_$P(X0,U) 227 Q 228 SAVDFPRT(Y,ORDEV) ; Save new default printer for user 229 N ORPAR,ORERR,ORWINDEF 230 Q:$L(ORDEV)=0 231 ; Reset Windows printer default to True/False 232 S ORPAR="ORWDP WINPRINT DEFAULT" 233 I ORDEV="WIN" S ORWINDEF="Y" 234 E S ORWINDEF="N" 235 I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR) 236 E D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR) 237 Q:ORDEV="WIN" 238 ; If not Windows printer selected, save VistA default printer 239 S ORPAR="ORWDP DEFAULT PRINTER",ORDEV="`"_ORDEV 240 I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR) 241 E D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR) 242 Q 1 ORWRP ; ALB/MJK,dcm Report Calls ; 12/05/02 11:03 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**1,10,85,109,132,160,194,227,215,262**;Dec 17, 1997;Build 3 3 ; 4 LABLIST(LST) ; -- report list for labs tab 5 ; RPC: ORWRP LAB REPORT LIST 6 N I,J,X,X0,X2,CNT,EOF,IFN,ROOT,RPC,ORLIST,HEAD 7 S EOF="$$END",ROOT=$NA(LST),(CNT,I)=0 8 D SETITEM(ROOT,"[LAB REPORT LIST]") 9 D GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LAB LIST") 10 F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0),X2=$G(^(2)) D 11 . Q:$P(X0,"^",12)="L" 12 . S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^") 13 . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3) 14 . S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN 15 . D SETITEM(.ROOT,X) 16 D SETITEM(.ROOT,"$$END") 17 Q 18 LIST(LST) ; -- report lists for reports tab 19 ; RPC: ORWRP REPORT LIST 20 N EOF,ROOT 21 S EOF="$$END",ROOT=$NA(LST) 22 K @ROOT 23 D GETRPTS(.ROOT,.EOF) ; -report list 24 D GETHS(.ROOT,.EOF) ; -health summary types 25 D GETDT(.ROOT,.EOF) ; -date ranges 26 Q 27 GETCOL(ROOT,IFN) ; -- get Column headers for ListView 28 N I,J,X,VAL 29 Q:'$G(IFN) 30 S I=0,ROOT=$NA(ROOT) 31 F S I=$O(^ORD(101.24,IFN,3,"C",I)) Q:'I D 32 . S VAL=$$GET^XPAR(DUZ_";VA(200,","ORWCH COLUMNS REPORTS",IFN,"I"),J=0 33 . F S J=$O(^ORD(101.24,IFN,3,"C",I,J)) Q:'J I $D(^ORD(101.24,IFN,3,J)) S X=^(J,0) D 34 .. I $L(VAL),$P(VAL,",",I) S $P(X,"^",10)=$P(VAL,",",I) 35 .. D SETITEM(.ROOT,X) 36 Q 37 GETRPTS(ROOT,EOF) ; -- get report list 38 N I,J,X,X0,X2,CNT,IFN,ORLIST,HEAD 39 D SETITEM(.ROOT,"[REPORT LIST]"),GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LIST") 40 S (CNT,I)=0 41 F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0),X2=$G(^(2)) D 42 . Q:$P(X0,"^",12)="L" 43 . S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^") 44 . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3) 45 . S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",4)_"^"_$P(X0,"^",19)_";"_$P(X0,"^",20)_"^"_$P(X0,"^",6)_"^"_$P(X0,"^",5)_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN 46 . D SETITEM(.ROOT,X) 47 D SETITEM(.ROOT,"$$END") 48 Q 49 GETHS(ROOT,EOF) ; --get health summary types 50 N C,I,IFN,ORHSPARM,ORERR,X,T 51 K ^TMP("ORHSPARM",$J) 52 S ORHSROOT="^TMP(""ORHSPARM"",$J)" 53 I $$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) S I="",C=0 D 54 . F S I=$O(^GMT(142,"B",I)) Q:I="" S IFN=$O(^(I,0)) Q:'IFN D 55 .. S X=$G(^GMT(142,IFN,0)) Q:'$L(X) 56 .. S T=$G(^GMT(142,IFN,"T")),C=C+1,@ORHSROOT@(C)=IFN_"^"_$S($L(T):T,1:$P(X,"^"))_"^^^^^1" 57 .. I I="GMTS HS ADHOC OPTION" S @ORHSROOT@(C)="0^GMTS Adhoc Report" 58 I '$$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) D 59 . D:$L($T(GETLIST^GMTSXAL)) GETLIST^GMTSXAL($NA(@ORHSROOT),$G(DUZ),1,.ORERR) 60 . Q:$G(ORERR) 61 . S I=0 F S I=$O(@ORHSROOT@(I)) Q:'I S @ORHSROOT@(I)=@ORHSROOT@(I)_"^^^^^1" I $P(@ORHSROOT@(I),"^",2)="GMTS HS ADHOC OPTION" S @ORHSROOT@(I)="0^Adhoc Report" 62 D SETITEM(.ROOT,"[HEALTH SUMMARY TYPES]") 63 S I=0 F S I=$O(@ORHSROOT@(I)) Q:'I D SETITEM(.ROOT,"h"_@ORHSROOT@(I)) 64 D SETITEM(.ROOT,EOF) 65 Q 66 GETDT(ROOT,EOF) ; -- get date range choices 67 N I,X 68 D SETITEM(.ROOT,"[DATE RANGES]") 69 F I=2:1 S X=$P($T(DTLIST+I),";",3) Q:X=EOF D SETITEM(.ROOT,"d"_X) 70 Q 71 DTLIST ; -- list of date ranges 72 ;<number of days>^ <display text> 73 ;;S^Date Range... 74 ;;0^Today 75 ;;7^One Week Back 76 ;;14^Two Weeks Back 77 ;;30^One Month Back 78 ;;180^Six Months Back 79 ;;365^One Year Back 80 ;;$$END 81 ; 82 SETITEM(ROOT,X) ; -- set item in list 83 S @ROOT@($O(@ROOT@(9999),-1)+1)=X 84 Q 85 RPT(ROOT,DFN,RPTID,HSTYPE,DTRANGE,EXAMID,ALPHA,OMEGA) ; -- return report text 86 ;ROOT=Output in ^TMP("ORDATA",$J) 87 ;DFN=Patient DFN ; ICN for foriegn sites 88 ;RPTID=Unique id for the report_";"_Remote Id_"~"_HSComponent for listview (ent;rtn;0;MaxOcc) or text (ent;rtn;#component;MaxOcc) 89 ;HSTYPE=Health Sum Type 90 ;DTRANGE=# days back from today 91 ;EXAMID=Rad exam ID 92 ;ALPHA=Start date (lieu of DTRANGE) 93 ;OMEGA=End date (lieu of DTRANGE) 94 ; RPC: ORWRP REPORT TEXT 95 ; 96 N X,X0,X2,X4,I,J,ENT,RTN,ID,REMOTE,GO,OUT,MAX,SITE,ORFHIE,%ZIS,HSTAG,DIRECT 97 K ^TMP("ORDATA",$J) 98 S HSTAG=$P($G(RPTID),"~",2),RPTID=$P($G(RPTID),"~"),ROOT=$NA(^TMP("ORDATA",$J,1)),REMOTE=+$P(RPTID,";",2),RPTID=$P($P(RPTID,";"),":") 99 I 'REMOTE S DFN=+DFN ;DFN = DFN;ICN for remote calls 100 S I=0,X0="",X2="",X4="",SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3) 101 F S I=$O(^ORD(101.24,"AC",I)) Q:I="" S J=0 F S J=$O(^ORD(101.24,"AC",I,J)) Q:'J D 102 . I $P($G(^ORD(101.24,J,0)),"^",2)=RPTID,$P(^(0),"^",8)="R" S X0=^(0),X2=$G(^(2)),ORFHIE=$G(^(4)),DIRECT=$P(ORFHIE,"^",4),X4=$P(ORFHIE,"^",2),ORFHIE=$P(ORFHIE,"^",3) 103 I '$L(X0) D NOTYET(.ROOT) Q 104 S RTN=$P(X0,"^",5),ENT=$P(X0,"^",6) 105 I '$L(RTN)!'$L(ENT) D NOTYET(.ROOT) Q 106 I '$L($T(@(ENT_"^"_RTN))) D NOTYET(.ROOT) Q 107 I $G(ALPHA) S X=ALPHA-$G(OMEGA) D 108 . I X<0 S X=X*(-1) 109 . I X4,X>X4 S:ALPHA>OMEGA OMEGA=$$FMADD^XLFDT(ALPHA,-X4) S:ALPHA'>OMEGA ALPHA=$$FMADD^XLFDT(OMEGA,-X4) S DTRANGE="" 110 I X4,$G(DTRANGE)>X4 S DTRANGE=X4,ALPHA="" 111 I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=DT_".235959" 112 I $G(OMEGA),$E(OMEGA,8)'="." S OMEGA=OMEGA_".235959" 113 ;S ID=$G(HSTAG),$P(ID,";",5,8)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9) 114 S ID=$G(HSTAG),$P(ID,";",5,10)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9)_";"_RPTID_";"_$G(DIRECT) ;HDRHX CHANGE 115 I $L($P($G(HSTAG),";",4)) S MAX=$P(HSTAG,";",4) 116 I $L($G(HSTYPE)) M ID=HSTYPE 117 I $L($G(EXAMID)) M ID=EXAMID 118 S OUT=ENT_"^"_RTN_"(.ROOT,DFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.MAX,.ORFHIE)" 119 I REMOTE S GO=0 D Q:'GO 120 . I '$L($T(GETDFN^MPIF001)) D SETITEM(.ROOT,"MPI routines missing on remote system ("_SITE_")") S GO=0 Q 121 . S ICN=+$P(DFN,";",2),DFN=+$$GETDFN^MPIF001(ICN) 122 . I DFN<0 D SETITEM(.ROOT,"Patient not found on remote system ("_SITE_")") S GO=0 Q 123 . S GO=+$P(X0,"^",3) 124 . I 'GO D SETITEM(.ROOT,"Remote access not available for this report ("_SITE_")") 125 S %ZIS="0N" 126 D @OUT 127 Q 128 NOTYET(ROOT) ; -- not available 129 D SETITEM(.ROOT,"Report not available at this time.") 130 Q 131 START(RM,GOTO,ORIOSL) ; 132 ;RM=Right margin 133 N ZTQUEUED,ORHFS,ORSUB,ORIO,ORHANDLE,IOM,IOSL,IOST,IOF,IOT,IOS 134 S ORHFS=$$HFS(),ORSUB="ORDATA",ORHANDLE="ORWRP" 135 D HFSOPEN(ORHANDLE,ORHFS,"W") 136 I POP D Q 137 . I $D(ROOT) D SETITEM(.ROOT,"ERROR: Unable to open HFS file") 138 D IOVAR(.ORIO,.RM,.ORIOSL) 139 N $ETRAP,$ESTACK 140 S $ETRAP="D ERR^ORWRP Q" 141 U IO 142 D @GOTO 143 D HFSCLOSE(ORHANDLE,ORHFS) 144 Q 145 ERR ;Error trap 146 S $ETRAP="D UNWIND^ORWRP Q" 147 N %ZIS 148 S %ZIS="0N" 149 D @^%ZOSF("ERRTN") ;file error 150 I $D(ORHANDLE) D CLOSE^%ZISH(ORHANDLE) 151 I $D(ORHFS) D 152 . N ORARR,OROK 153 . S ORARR(ORHFS)="",OROK=$$DEL^%ZISH("",$NA(ORARR)) ;delete HFS file 154 S $ECODE=",UOR69 error during CPRS report build," 155 Q 156 UNWIND ;Unwind Error stack 157 Q:$ESTACK>1 ;pop stack 158 ; 159 Q 160 HFS() ; -- get hfs file name 161 N H 162 S H=$H 163 Q "ORU_"_$J_"_"_$P(H,",")_"_"_$P(H,",",2)_".DAT" 164 HFSOPEN(HANDLE,ORHFS,ORMODE) ; 165 D OPEN^%ZISH(HANDLE,,ORHFS,$G(ORMODE,"W")) Q:POP 166 Q 167 IOVAR(ORIO,ORRM,ORIOSL,ORIOST,ORIOF,ORIOT) ;Setup IO variables based on IO Device 168 N IFN,IFN1 169 S ORIO=$G(ORIO,"OR WORKSTATION"),ION=ORIO,IOM=$G(ORRM,80),IOSL=$G(ORIOSL,62),IOST=$G(ORIOST,"P-OTHER"),IOF=$G(ORIOF,""""""),IOT=$G(ORIOT,"HFS") 170 I $O(^%ZIS(1,"B",ORIO,0)) S IFN=$O(^(0)),IOS=IFN 171 I $D(^%ZIS(1,IFN,0)) S IOST(0)=+$G(^("SUBTYPE")),IOT=$G(ORIOT,^("TYPE")),IOST=$G(ORIOST,$P($G(^%ZIS(2,IOST(0),0),IOST),"^")) 172 I $O(^%ZIS(2,"B",IOST,0)) S IFN=$O(^(0)) I IFN S IOST(0)=IFN,IFN1=$G(^%ZIS(2,IFN,1)),IOM=$G(ORRM,$P(IFN1,"^")),IOF=$G(ORIOF,$P(IFN1,"^",2)),IOSL=$G(ORIOSL,$P(IFN1,"^",3)) 173 Q 174 HFSCLOSE(HANDLE,ORHFS) ;Close HFS and unload data 175 N ORDEL,X,%ZIS 176 S %ZIS="0N" 177 I IO[ORHFS D CLOSE^%ZISH(HANDLE) 178 S ROOT=$NA(^TMP(ORSUB,$J,1)),ORDEL(ORHFS)="" 179 K @ROOT 180 S X=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4) 181 D STRIP 182 S X=$$DEL^%ZISH(,$NA(ORDEL)) 183 Q 184 USEHFS ; -- use host file to build global array 185 N OROK,SECTION 186 S SECTION=0 187 D INIT 188 S OROK=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4) I 'OROK Q 189 D STRIP 190 N ORARR S ORARR(ORHFS)="" 191 S OROK=$$DEL^%ZISH("",$NA(ORARR)) 192 Q 193 INIT ; -- initialize counts and global section 194 S (INC,CNT)=0,SECTION=SECTION+1,ROOT=$NA(^TMP(ORSUB,$J,SECTION)) 195 K @ROOT 196 Q 197 FINAL ; -- set 'x of y' for each section CALLED FROM ^ORWLR 198 N I 199 F I=1:1:SECTION S ^TMP(ORSUB,$J,I,.1)=I_U_SECTION 200 Q 201 STRIP ; -- strip off control chars 202 N I,X 203 S I=0 F S I=$O(@ROOT@(I)) Q:'I S X=^(I) D 204 . I X[$C(8) D ;BS 205 .. I $L(X,$C(8))=$L(X,$C(95)) S (X,@ROOT@(I))=$TR(X,$C(8,95),"") Q ;BS & _ 206 .. S (X,@ROOT@(I))=$TR(X,$C(8),"") 207 . I X[$C(7)!(X[$C(12)) S @ROOT@(I)=$TR(X,$C(7,12),"") ;BEL or FF 208 Q 209 WINDFLT(ORY) ;Windows printer as default? 210 S ORY=+$$GET^XPAR("ALL","ORWDP WINPRINT DEFAULT") 211 Q 212 GETDFPRT(Y,ORUSER,ORLOC) ; Returns default printer for user 213 N IEN,X0,ENT 214 S ENT="ALL" 215 I $G(ORLOC) S ORLOC=+ORLOC_";SC(",ENT=ENT_"^"_ORLOC 216 I +$$GET^XPAR(ENT,"ORWDP WINPRINT DEFAULT") S Y="WIN;Windows Printer" Q 217 S IEN=$$GET^XPAR(ENT,"ORWDP DEFAULT PRINTER",1) Q:+IEN=0 218 Q:'$D(^%ZIS(1,IEN,0)) S X0=^(0) 219 S Y=IEN_";"_$P(X0,U) 220 Q 221 SAVDFPRT(Y,ORDEV) ; Save new default printer for user 222 N ORPAR,ORERR,ORWINDEF 223 Q:$L(ORDEV)=0 224 ; Reset Windows printer default to True/False 225 S ORPAR="ORWDP WINPRINT DEFAULT" 226 I ORDEV="WIN" S ORWINDEF="Y" 227 E S ORWINDEF="N" 228 I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR) 229 E D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR) 230 Q:ORDEV="WIN" 231 ; If not Windows printer selected, save VistA default printer 232 S ORPAR="ORWDP DEFAULT PRINTER",ORDEV="`"_ORDEV 233 I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR) 234 E D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR) 235 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP1.m
r613 r623 1 ORWRP1 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,160,262,269**;Dec 17, 1997;Build 29 3 4 AHS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 5 6 7 AHSB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 8 9 10 11 12 HS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 13 14 15 HSB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 HSTYPE(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 31 32 33 HSTYPEB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 34 35 36 37 38 39 40 41 HSGUI(DFN,GMTSTYP) 42 43 44 BLR(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 45 46 47 48 49 50 51 52 53 54 55 56 57 58 AP(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 DIET(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 74 75 76 77 78 79 LISTNUTR(ROOT,DFN) 80 81 82 83 84 85 86 87 NUTR(ROOT,DFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) 88 89 90 91 92 93 94 VITALS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) 95 96 97 VITALSB(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) 98 99 100 101 102 103 104 105 106 STAT(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) 107 108 109 110 111 112 113 114 INTERIM(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 115 116 117 INTERIMB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 118 119 120 121 122 123 LRGEN(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 124 125 126 LRGENB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 127 128 129 130 131 132 133 GRAPH(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 134 135 136 GRAPHB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 137 138 139 140 141 142 ORS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) 143 144 145 ORSB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 146 147 148 149 150 151 152 ORD(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) 153 154 155 ORDB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 156 157 158 159 160 161 162 163 ORC(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 164 165 166 ORCB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 167 168 169 170 171 172 ORP(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) 173 174 175 ORPB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 176 177 178 179 180 181 182 183 PSO(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 184 185 186 PSOB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 187 188 189 190 191 MED(ROOT,ORDFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 192 193 194 MEDB(ROOT,DFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 195 196 197 198 199 200 201 202 203 204 PROB(ROOT,ORDFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 205 206 207 PROBB(ROOT,DFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) 208 209 210 1 ORWRP1 ; ALB/MJK,dcm Report Calls ;7/20/07 14:43 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,160,262,269**;Dec 17, 1997;Build 28 3 ; 4 AHS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - get adhoc health summary report 5 D START^ORWRP(80,"AHSB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") 6 Q 7 AHSB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -build adhoc health summary 8 N ORVP,GMTYP,Y 9 S ORVP=ORDFN_";DPT(",Y=$P($G(^GMT(142,+ORHS,0)),U),GMTSTYP=+ORHS 10 D ADHOC^ORPRS13 11 Q 12 HS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - get health summary report 13 D START^ORWRP(80,"HSB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") 14 Q 15 HSB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - build health summary report 16 N I,ICN,ORVP,GMTYP,Y,GMARXN,GMTSDLM,GMTSDTC,GMTSE,GMTSEGH,GMTSEGL,GMTSEGN,GMTSEGR,GMSEQ,GMTSHDR,GMTSLCMP,GMTSNDM,GMTSNPK,GMTSPG,GMTSPHDR,X 17 I $G(REMOTE) D Q:'ORHS 18 . S Y=$O(^GMT(142,"E",$P(ORHS,";",2),0)) 19 . I 'Y S Y=$O(^GMT(142,"E",$P($$UPPER^ORU(ORHS),";",2),0)) 20 . I 'Y S I=0 F S I=$O(^GMT(142,I)) Q:'I I $L($P($G(^GMT(142,I,"T")),"^")),$P($$UPPER^ORU(ORHS),";",2)=$$UPPER^ORU(^("T")) S Y=I Q 21 . I 'Y S Y=$O(^GMT(142,"B",$P(ORHS,";",2),0)) 22 . I 'Y S Y=$O(^GMT(142,"B",$P($$UPPER^ORU(ORHS),";",2),0)) 23 . I 'Y S I=0 F S I=$O(^GMT(142,I)) Q:'I S X=$P(^(I,0),"^") I $P($$UPPER^ORU(ORHS),";",2)=$$UPPER^ORU(X) S Y=I Q 24 . I 'Y U IO W !,ORHS_" not found on remote system",! S ORHS=Y Q 25 . S ORHS=Y 26 I +$G(ORHS)<1 W !,"Report not Available" Q 27 S ORVP=ORDFN_";DPT(",Y=$P($G(^GMT(142,+ORHS,0)),U),GMTYP(0)=1,GMTYP(1)=+ORHS_U_Y_U_Y_U_Y 28 D PQ^ORPRS13 29 Q 30 HSTYPE(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - Get HS type report 31 D START^ORWRP(80,"HSTYPEB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") 32 Q 33 HSTYPEB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - Build HS type report 34 N GMTSQIT,GMTSPRM,GMTSTITL,GMTSPX2,GMTSPX1 35 I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT 36 Q:'$G(ALPHA) Q:'$G(OMEGA) 37 I +$G(ORHS)<1 W !,"Report not Available" Q 38 S GMTSQIT=1,GMTSPRM=$P($G(^GMT(142.1,+ORHS,0)),"^",4),GMTSTITL="",GMTSPX2=ALPHA,GMTSPX1=OMEGA,DFN=ORDFN 39 D ENCWA^GMTS 40 Q 41 HSGUI(DFN,GMTSTYP) ; - Call ENX^GMTSDVR to print HS Type for Patient 42 D ENX^GMTSDVR(DFN,GMTSTYP) 43 Q 44 BLR(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -- get 'enhanced' blood bank report 45 N DFN,ORY,ORSBHEAD 46 S DFN=ORDFN 47 I $L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface 48 . K ^TMP("ORLRC",$J) 49 . D EN^ORWLR1(DFN) 50 . I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..." 51 . S ROOT=$NA(^TMP("ORLRC",$J)) 52 K ^TMP("LRC",$J) 53 S ORSBHEAD("BLOOD BANK")="" 54 D EN^LR7OSUM(.ORY,DFN,,,,,.ORSBHEAD) 55 I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="",^TMP("LRC",$J,2,0)="No Blood Bank report available..." 56 S ROOT=$NA(^TMP("LRC",$J)) 57 Q 58 AP(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -- get Anatomic path report 59 N I,C,LINES,X 60 K ^TMP("LRC",$J),^TMP("LRH",$J) 61 D AP^LR7OSUM(ORDFN) 62 I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="",^TMP("LRC",$J,2,0)="No Anatomic Pathology reports available..." 63 S I=0 64 I $L($O(^TMP("LRH",$J,0))) S I=.001,^TMP("LRC",$J,I)="[HIDDEN TEXT]^" D 65 . S X="",C=2 F S X=$O(^TMP("LRH",$J,X)) Q:X="" S LINES(^(X))=X,C=C+1 66 . S $P(^TMP("LRC",$J,.001),"^",2)=C 67 . S X="" F S X=$O(LINES(X)) Q:X="" D 68 .. S I=I+.001,^TMP("LRC",$J,I)=X_"^"_LINES(X) 69 . S I=I+.001,^TMP("LRC",$J,I)="[REPORT TEXT]" 70 S ROOT=$NA(^TMP("LRC",$J)) 71 K ^TMP("LRH",$J) 72 Q 73 DIET(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -- get dietetics profile 74 N LCNT,ORVP 75 S LCNT=0,ORVP=DFN_";DPT(" 76 D FHP^ORCXPNDR 77 S ROOT=$NA(^TMP("ORXPND",$J)) 78 Q 79 LISTNUTR(ROOT,DFN) ; -- list nutritional assessments 80 N OK,I,X 81 K ^TMP($J,"FHADT") 82 S OK=$$FHWORADT^FHWORA(DFN) 83 S I=0,SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3) 84 F S I=$O(^TMP($J,"FHADT",DFN,I)) Q:'I S X=SITE_U_I_U_^(I),^(I)=X 85 S ROOT=$NA(^TMP($J,"FHADT",DFN)) 86 Q 87 NUTR(ROOT,DFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- get nutritional assessment 88 N LCNT,ORVP 89 K ^TMP("ORXPND",$J) 90 S LCNT=0,ORVP=DFN_";DPT(",ID=DFN_";"_ID 91 D FHA^ORCXPNDR 92 S ROOT=$NA(^TMP("ORXPND",$J)) 93 Q 94 VITALS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- get vitals report 95 D START^ORWRP(132,"VITALSB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)") 96 D EN^GMRVPGC(ORDFN) Q 97 VITALSB(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- build vitals report 98 N ORVP,XQORNOD,ORSSTRT,ORSSTOP 99 Q:'$G(ORDFN) 100 I $L(ORDTRNG),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-ORDTRNG),OMEGA=$$NOW^XLFDT 101 Q:'$G(ALPHA) Q:'$G(OMEGA) 102 I '$P(OMEGA,".",2) S OMEGA=OMEGA_".2359" 103 S ORVP=ORDFN_";DPT(",XQORNOD=1,ORSSTRT(XQORNOD)=ALPHA,ORSSTOP(XQORNOD)=OMEGA 104 D VITCUM^ORPRS14 105 Q 106 STAT(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Lab Order Status 107 N ORVP 108 K ^TMP("ORDATA",$J) 109 S ORVP=ORDFN_";DPT(" 110 D EN1^LR7OSOS1(.ORY,ORVP,.ORALPHA,.OROMEGA,.ORDTRNG) 111 I '$O(^TMP("ORDATA",$J,1,0)) S ^TMP("ORDATA",$J,1,1,0)="",^TMP("ORDATA",$J,1,2,0)="No Orders found..." 112 S ROOT=ORY 113 Q 114 INTERIM(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Lab Interim 115 D START^ORWRP(80,"INTERIMB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") 116 Q 117 INTERIMB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Build Interim 118 Q:'$G(DFN) Q:'$G(ALPHA) Q:'$G(OMEGA) 119 N ORVP,XQORNOD,ORSSTRT,ORSSTOP,LRACC,LRAD,LRAN,LRRT,LRPG,LRSB,LREDT,LRIDT 120 S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=(9999999-ALPHA),(ORSSTOP(XQORNOD),LRIDT)=(9999999-OMEGA) 121 D OERR^LRRP4,CLEAN^LRRP4 122 Q 123 LRGEN(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Lab results by test 124 D START^ORWRP(80,"LRGENB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") 125 Q 126 LRGENB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Build Results 127 Q:'$G(DFN) Q:'$G(ALPHA) Q:'$G(OMEGA) 128 N ORVP,ORSSTRT,ORSSTOP,LREDT,LRSDT,XQORNOD 129 S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=(9999999-ALPHA),(ORSSTOP(XQORNOD),LRSDT)=(9999999-OMEGA) 130 D SET1^LRGEN,CLEAN^LRRP4 131 K LRPR 132 Q 133 GRAPH(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Graph labs 134 D START^ORWRP(80,"GRAPHB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") 135 Q 136 GRAPHB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Graph labs 137 Q:'$G(DFN) Q:'$G(ALPHA) Q:'$G(OMEGA) 138 N ORVP,XQORNOD,ORSSTRT,ORSSTOP,LREDT,LRSDT 139 S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=ALPHA,(ORSSTOP(XQORNOD),LRSDT)=OMEGA 140 D OERR^LRDIST4,CLEAN^LRDIST4 141 Q 142 ORS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Daily order summary 143 D START^ORWRP(80,"ORSB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)") 144 Q 145 ORSB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Daily order summary 146 N ORVP,XQORNOD,ORSSTRT,ORSSTOP 147 S ORVP=DFN_";DPT(",XQORNOD=1,X1=DT,X2=-$S(DTRANGE:DTRANGE-1,1:0) 148 D C^%DTC 149 S ORSSTRT=X-.7641,ORSSTOP=DT+.2359 150 D DAY^ORPRS02 151 Q 152 ORD(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Order Summary for Date Range 153 D START^ORWRP(80,"ORDB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)") 154 Q 155 ORDB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Order Summary for Date Range 156 Q:'$G(DFN) 157 I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT 158 Q:'$G(ALPHA) Q:'$G(OMEGA) 159 N ORVP,XQORNOD,ORSSTRT,ORSSTOP 160 S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA 161 D RANGE^ORPRS02 162 Q 163 ORC(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Custom order summary 164 D START^ORWRP(80,"ORCB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") 165 Q 166 ORCB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Custom order summary build 167 Q:'$G(DFN) Q:'$G(ALPHA) Q:'$G(OMEGA) 168 N ORVP,XQORNOD,ORSSTRT,ORSSTOP 169 S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA 170 D CUSTOM^ORPRS02 171 Q 172 ORP(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Chart copy summary 173 D START^ORWRP(80,"ORPB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.ORFHIE)") 174 Q 175 ORPB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Chart copy summary 176 Q:'$G(DFN) 177 I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT 178 Q:'$G(ALPHA) Q:'$G(OMEGA) 179 N ORVP,XQORNOD,ORSSTRT,ORSSTOP 180 S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA 181 D CHART^ORPRS02 182 Q 183 PSO(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Outpatient RX Profile 184 D START^ORWRP(80,"PSOB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORFHIE)") 185 Q 186 PSOB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Outpatient RX Action Profile 187 N ORVP,PSTYPE,PSONOPG 188 S ORVP=DFN_";DPT(",PSTYPE=1,PSONOPG=2 189 D DFN^PSOSD1 190 Q 191 MED(ROOT,ORDFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Medicine Summary of Procedures 192 D START^ORWRP(80,"MEDB^ORWRP1(.ROOT,.ORDFN,.IID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") 193 Q 194 MEDB(ROOT,DFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Medicine Summary of Procedures 195 Q:'$L($G(IID)) 196 N ORVP,XQY0,OT,MCARPPS,MCPRO,MCARGRTN,DXS,SSN,I,J,L,DA,MCARGDA 197 S ORVP=DFN_";DPT(",XQY0="",OT=$G(^TMP("OR",$J,"MCAR","OT",IID)) 198 Q:'$L(OT) 199 S (DA,MCARGDA)=$P(OT,U,2),MCARPPS=$P(OT,U,3,4),MCPRO=$P(OT,U,11) 200 D MCPPROC^MCARP 201 S MCARGRTN=$P(OT,U,5) 202 D @MCARPPS 203 Q 204 PROB(ROOT,ORDFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; Problem List (Problem Tab) 205 D START^ORWRP(80,"PROBB^ORWRP1(.ROOT,.ORDFN,.IID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") 206 Q 207 PROBB(ROOT,DFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Problem List 208 N ORSILENT S ORSILENT=1 209 D VAF^GMPLUTL2(DFN,ORSILENT) 210 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP3.m
r613 r623 1 ORWRP3 ; slc/dcm - OE/RR Report Extract RPC's ; 08 May 2001 13:32PM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,132,215,243**;Dec 17, 1997;Build 242 3 ; 4 ; DBIA 4011 Access ^XWB(8994) 5 ; 6 EX(ROOT,TST) ;Expand columns 7 ;TST=ptr to file 101.24 8 ;Y(i)=id^Name^Qualifier^IOM^Entry^Routine^Remote^Type^Category^RPC^ifn^sort_order^max_days^direct^hdr^fhie 9 Q:'$G(TST) 10 N J,X,X0,X1,X2,X4,RPC,HEAD,ORX0,ORX2,ORX4,ORX,ORTIMOCC,MAX 11 I '$L($G(C)) S C=0 12 S ORTIMOCC=$$GET^XPAR("USR.`"_DUZ_"^SYS^PKG","ORWRP TIME/OCC LIMITS INDV",+TST,"I") 13 I '$L(ORTIMOCC) S ORTIMOCC=$$GET^XPAR("USR.`"_DUZ_"^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") 14 S X0=$G(^ORD(101.24,+TST,0)),X2=$G(^(2)),X4=$G(^(4)),MAX=$P(X4,"^",2),X=$P($P(ORTIMOCC,";"),"-",2) 15 I $P(X4,"^",10) Q 16 I X,MAX,X>MAX S ORTIMOCC="T-"_MAX_";"_$P(ORTIMOCC,";",2,99) 17 I '$L(ORTIMOCC) S ORTIMOCC=";;" 18 I '$O(^ORD(101.24,+TST,10,0)) D Q 19 . Q:$P(X0,"^",12)="L" 20 . S RPC=$P($G(^XWB(8994,+$P(X0,"^",13),0)),"^") ;DBIA 4011 21 . S HEAD=$P(X0,"^") 22 . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3) 23 . S X1=$P(X0,U,2)_U_HEAD_U_ORTIMOCC_";"_$P(X0,U,4)_U_$P(X0,U,19)_";"_$P(X0,U,20)_";" 24 . S X=X1_+$P(X0,U,21)_U_$P(X0,U,6)_U_$P(X0,U,5)_U_$P(X0,U,3)_U_$P(X0,U,12)_U_$P(X0,U,7)_U_RPC_U_+TST_U_$P(X4,U)_U_$P(X4,U,2)_U_$P(X4,U,4)_U_$P(X4,U,5)_U_$P(X4,U,8)_U_$P(X4,U,9) 25 . D SETITEM(.ROOT,X) 26 I $O(^ORD(101.24,+TST,10,0)) S ORX0=^ORD(101.24,+TST,0),ORX2=$G(^(2)),ORX4=$G(^(4)) D 27 . I $P(ORX4,"^",10) Q 28 . S RPC=$P($G(^XWB(8994,+$P(X0,"^",13),0)),"^") ;DBIA 4011 29 . S X=ORX0,HEAD=$P(X,"^") 30 . I $L($P(ORX2,"^",3)) S HEAD=$P(ORX2,"^",3) 31 . S X1=$P(X,U,2)_U_HEAD_U_ORTIMOCC_";"_$P(X,U,4)_U_$P(X,U,19)_";"_$P(X,U,20)_";" 32 . S ORX=X1_+$P(X,U,21)_U_$P(X,U,6)_U_$P(X,U,5)_U_$P(X,U,3)_U_$P(X,U,12)_U_$P(X,U,7)_U_RPC_U_+TST_U_$P(ORX4,U)_U_$P(ORX4,U,2)_U_$P(ORX4,U,4)_U_$P(ORX4,U,5)_U_$P(ORX4,U,8)_U_$P(X4,U,9) 33 . D SETITEM(.ROOT,"[PARENT START]^"_ORX) 34 . S J=0 F S J=$O(^ORD(101.24,+TST,10,J)) Q:J<1 S X=^(J,0) D EX(.ROOT,+X) 35 . D SETITEM(.ROOT,"[PARENT END]^"_ORX) 36 Q 37 LIST(LST,TAB) ;Get list for Reports & Labs Tab Treeview 38 N ROOT 39 S ROOT=$NA(LST) 40 K @ROOT 41 D TRY1(.ROOT,$G(TAB)) 42 Q 43 TRY1(ROOT,TAB) ;Test expanding reports using established parameters 44 N I,ORLIST 45 D SETITEM(.ROOT,"[REPORT LIST]") 46 D GETLST^XPAR(.ORLIST,"ALL",$S($G(TAB)="LABS":"ORWRP REPORT LAB LIST",1:"ORWRP REPORT LIST")) 47 S I=0 48 F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) D EX(.ROOT,$P(ORLIST(I),"^",2)) 49 D SETITEM(.ROOT,"$$END") 50 Q 51 SETITEM(ROOT,X) ; -- set item in list 52 S @ROOT@($O(@ROOT@(9999),-1)+1)=X 53 Q 1 ORWRP3 ; slc/dcm - OE/RR Report Extract RPC's ; 08 May 2001 13:32PM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,132,215**;Dec 17, 1997 3 ; 4 ; DBIA 4011 Access ^XWB(8994) 5 ; 6 EX(ROOT,TST) ;Expand columns 7 ;TST=ptr to file 101.24 8 ;Y(i)=id^Name^Qualifier^IOM^Entry^Routine^Remote^Type^Category^RPC^ifn^sort_order^max_days^direct 9 Q:'$G(TST) 10 N J,X,X0,X2,X4,RPC,HEAD,ORX0,ORX2,ORX4,ORX,ORTIMOCC,MAX 11 I '$L($G(C)) S C=0 12 S ORTIMOCC=$$GET^XPAR("USR.`"_DUZ_"^SYS^PKG","ORWRP TIME/OCC LIMITS INDV",+TST,"I") 13 I '$L(ORTIMOCC) S ORTIMOCC=$$GET^XPAR("USR.`"_DUZ_"^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") 14 S X0=$G(^ORD(101.24,+TST,0)),X2=$G(^(2)),X4=$G(^(4)),MAX=$P(X4,"^",2),X=$P($P(ORTIMOCC,";"),"-",2) 15 I X,MAX,X>MAX S ORTIMOCC="T-"_MAX_";"_$P(ORTIMOCC,";",2,99) 16 I '$L(ORTIMOCC) S ORTIMOCC=";;" 17 I '$O(^ORD(101.24,+TST,10,0)) D Q 18 . Q:$P(X0,"^",12)="L" 19 . S RPC=$P($G(^XWB(8994,+$P(X0,"^",13),0)),"^") ;DBIA 4011 20 . S HEAD=$P(X0,"^") I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3) 21 . S X=$P(X0,U,2)_U_HEAD_U_ORTIMOCC_";"_$P(X0,U,4)_U_$P(X0,U,19)_";"_$P(X0,U,20)_";"_+$P(X0,U,21)_U_$P(X0,U,6)_U_$P(X0,U,5)_U_$P(X0,U,3)_U_$P(X0,U,12)_U_$P(X0,U,7)_U_RPC_U_+TST_U_$P(X4,U)_U_$P(X4,U,2)_U_$P(X4,U,4)_U_$P(X4,U,5) 22 . D SETITEM(.ROOT,X) 23 I $O(^ORD(101.24,+TST,10,0)) S ORX0=^ORD(101.24,+TST,0),ORX2=$G(^(2)),ORX4=$G(^(4)) D 24 . S X=ORX0,HEAD=$P(X,"^") 25 . I $L($P(ORX2,"^",3)) S HEAD=$P(ORX2,"^",3) 26 . S ORX=$P(X,U,2)_U_HEAD_U_ORTIMOCC_";"_$P(X,U,4)_U_$P(X,U,19)_";"_$P(X,U,20)_";"_+$P(X,U,21)_U_$P(X,U,6)_U_$P(X,U,5)_U_$P(X,U,3)_U_$P(X,U,12)_U_$P(X,U,7)_"^^"_+TST_U_$P(ORX4,U)_U_$P(ORX4,U,2)_U_$P(ORX4,U,4)_U_$P(ORX4,U,5) 27 . D SETITEM(.ROOT,"[PARENT START]^"_ORX) 28 . S J=0 F S J=$O(^ORD(101.24,+TST,10,J)) Q:J<1 S X=^(J,0) D EX(.ROOT,+X) 29 . D SETITEM(.ROOT,"[PARENT END]^"_ORX) 30 Q 31 LIST(LST) ;Get list for Treeview 32 N ROOT 33 S ROOT=$NA(LST) 34 K @ROOT 35 D TRY1(.ROOT) 36 Q 37 TRY1(ROOT) ;Test expanding reports using established parameters 38 N I,ORLIST 39 D SETITEM(.ROOT,"[REPORT LIST]") 40 D GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LIST") 41 S I=0 42 F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) D EX(.ROOT,$P(ORLIST(I),"^",2)) 43 D SETITEM(.ROOT,"$$END") 44 Q 45 SETITEM(ROOT,X) ; -- set item in list 46 S @ROOT@($O(@ROOT@(9999),-1)+1)=X 47 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP4P.m
r613 r623 1 ORWRP4P 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 3 PSO 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 .. D XSET^ORWRP4("13^"_$S($L($P(X,"^",15))>60:"[+]",1:"")) ; [+]33 34 35 1 ORWRP4P ; slc/dcm - OE/RR HDR Report Extract RPC's Outpatient Pharmacy ;9/21/05 13:21 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 3 PSO ;Outpatient RX for HDR 4 N IFN,IFN1,IFN2,X,X1,X2,X3,X10,X16,X17,XIFN,ORX,COL,CODE,I1,CNT,%DT,Y,FAC,FACU 5 K ^TMP("ORXS",$J) 6 S IFN="" 7 F S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN="" S XIFN=^(IFN) D 8 . S X16=$P(XIFN,"^",16),X17=$P(XIFN,"^",17),X2=$P(XIFN,"^",2),FACU=X17 9 . I X17="",X16,X16'=200 S FACU=$O(^DIC(4,"D",X16,0)) I FACU S FACU=$P(^DIC(4,FACU,0),"^") 10 . I '$L(FACU) S FACU=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown") 11 . S $P(XIFN,"^",2)=FACU,X10=$P($P(XIFN,"^",10),":",1,2),X3=$P($P(XIFN,"^",3),"~",2) 12 . I X3="" S X3=$P($P(XIFN,"^",4),"~",2) ;Get NDC name if Drug name not sent 13 . I $L(X10),$L(X3) D 14 .. S X10=9999999-$$SETDATE^ORWRP4(X10),^TMP("ORXS",$J,FACU,X10,X3,IFN)=XIFN 15 K ^TMP("ORXS1",$J) 16 S FAC="",CNT=-1 17 F S FAC=$O(^TMP("ORXS",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS",$J,FAC,IFN)) Q:IFN="" D 18 . S IFN1="" 19 . F S IFN1=$O(^TMP("ORXS",$J,FAC,IFN,IFN1)) Q:IFN1="" S IFN2="" F S IFN2=$O(^TMP("ORXS",$J,FAC,IFN,IFN1,IFN2)) Q:IFN2="" S X=^(IFN2) D 20 .. D XSET^ORWRP4("1^"_$P(X,"^",2)) ; Facility 21 .. D XSET^ORWRP4("2^"_IFN1) ; Drug Name 22 .. D XSET^ORWRP4("3^"_$P($P(X,"^",3),"~")) ; Drug IEN 23 .. D XSET^ORWRP4("4^"_$P(X,"^",5)) ; RX # 24 .. D XSET^ORWRP4("5^"_$P($P(X,"^",6),"~",2)) ; Status 25 .. D XSET^ORWRP4("6^"_$P(X,"^",7)) ; Qty 26 .. S Y=$$SETDATE^ORWRP4($P(X,"^",9)) D XSET^ORWRP4("7^"_$$DATE^ORDVU(Y)) ; Exp/Canc Date 27 .. S Y=$$SETDATE^ORWRP4($P(X,"^",10)) D XSET^ORWRP4("8^"_$$DATE^ORDVU(Y)) ; Issue Date 28 .. S Y=$$SETDATE^ORWRP4($P(X,"^",11)) D XSET^ORWRP4("9^"_$$DATE^ORDVU(Y)) ; Last Fill Date 29 .. D XSET^ORWRP4("10^"_$P(X,"^",12)) ; Refills 30 .. D XSET^ORWRP4("11^"_$P(X,"^",13)) ; Provider 31 .. D XSET^ORWRP4("12^"_$P(X,"^",14)) ; Cost/Fill 32 .. D XSET^ORWRP4("13^") ; [+] 33 .. D XSET^ORWRP4("14^"_$P(X,"^",15)) ; SIG 34 K ^XTMP(HANDLE,"D") M ^XTMP(HANDLE,"D")=^TMP("ORXS1",$J) K ^TMP("ORXS",$J),^TMP("ORXS1",$J) 35 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP4V.m
r613 r623 1 ORWRP4V ; slc/dcm - OE/RR HDR Report Extract RPC's Vitals;9/21/05 13:21 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 3 VS ;Vitals code for HDR 4 N I,IFN,IFN1,IFN2,X,X1,X2,X4,X5,XIFN,ORX,COL,CODE,I1,CNT,%DT,FAC,FACU,NODE,QUALIF,METHOD,UNIT 5 K ^TMP("ORXS",$J) 6 S IFN="" 7 F S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN="" S XIFN=^(IFN) D 8 . S X11=$P(XIFN,"^",11),X12=$P(XIFN,"^",12),X2=$P(XIFN,"^",2),FACU=X12 9 . I X12="",X11,X11'=200 S FACU=$O(^DIC(4,"D",X11,0)) I FACU S FACU=$P(^DIC(4,FACU,0),"^") 10 . I '$L(FACU) S FACU=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown") 11 . S $P(XIFN,"^",2)=FACU,X4=$P($P(XIFN,"^",4),":",1,2),X5=$P($P(XIFN,"^",5),"~",2) 12 . I $P(XIFN,"^",10)'="W",$L(X5) D 13 .. S X4=9999999-$$SETDATE^ORWRP4(X4) 14 .. I X4=9999999 F I=.01:.01 S X4=X4+I I '$D(^TMP("ORXS",$J,FACU,X4)) Q 15 .. S ^TMP("ORXS",$J,FACU,X4)=$P(XIFN,"^",2),^TMP("ORXS",$J,FACU,X4,X5,IFN)=XIFN 16 K ^TMP("ORXS1",$J),^TMP("ORXS2",$J) 17 S FAC="",CNT=-1 18 F S FAC=$O(^TMP("ORXS",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS",$J,FAC,IFN)) Q:IFN="" S NODE=^(IFN) D 19 . D XVSET("1^"_$P(NODE,"^"),1,FAC,IFN,NODE) ;Facility 20 . I $P(IFN,".")'=9999999 D XVSET("2^"_$$DATE^ORDVU(9999999-IFN),2,FAC,IFN,NODE) ; Measurement Date/Time 21 . I $P(IFN,".")=9999999 D XVSET("2^"_" ",2,FAC,IFN,NODE) ; Measurement Date/Time = "" 22 . S IFN1="" 23 . F S IFN1=$O(^TMP("ORXS",$J,FAC,IFN,IFN1)) Q:IFN1="" S IFN2="" F S IFN2=$O(^TMP("ORXS",$J,FAC,IFN,IFN1,IFN2)) Q:IFN2="" S X=^(IFN2) D 24 .. I $$UPPER^ORU(IFN1)="TEMPERATURE" D XVSET("3^"_$P(X,"^",6),3,FAC,IFN,X) D METH(X) 25 .. I $$UPPER^ORU(IFN1)="PULSE" D XVSET("4^"_$P(X,"^",6),4,FAC,IFN,X) D METH(X) 26 .. I $$UPPER^ORU(IFN1)="RESPIRATION" D XVSET("5^"_$P(X,"^",6),5,FAC,IFN,X) D METH(X) 27 .. I $$UPPER^ORU(IFN1)="BLOOD PRESSURE" D XVSET("6^"_$P(X,"^",6),6,FAC,IFN,X) D METH(X) 28 .. I $$UPPER^ORU(IFN1)="HEIGHT" D XVSET("7^"_$P(X,"^",6),7,FAC,IFN,X) D METH(X) 29 .. I $$UPPER^ORU(IFN1)="WEIGHT" D XVSET("8^"_$P(X,"^",6),8,FAC,IFN,X) D METH(X) 30 .. I $$UPPER^ORU(IFN1)="PAIN" D XVSET("9^"_$P(X,"^",6),9,FAC,IFN,X) D METH(X) 31 .. I $$UPPER^ORU(IFN1)="PULSE OXIMETRY" D 32 ... D XVSET("10^"_$P(X,"^",6),10,FAC,IFN,X) D METH(X) 33 ... F I=1:1:2 D 34 .... I $L($P(X,"^",13)),$P($P($P(X,"^",13),"|",I)," ",2)["l/min" D XVSET("13^"_$P($P($P(X,"^",13),"|",I)," "),13,FAC,IFN,X) ;Flow Rate 35 .... I $L($P(X,"^",13)),$P($P($P(X,"^",13),"|",I)," ",2)["%" D XVSET("14^"_$P($P($P(X,"^",13),"|",I)," "),14,FAC,IFN,X) ;O2 Concentration 36 .. I $$UPPER^ORU(IFN1)="CENTRAL VENOUS PRESSURE" D XVSET("11^"_$P(X,"^",6),11,FAC,IFN,X) D METH(X) 37 .. I $$UPPER^ORU(IFN1)="CIRCUMFERENCE/GIRTH" D XVSET("12^"_$P(X,"^",6),12,FAC,IFN,X) D METH(X) 38 S FAC="" 39 F S FAC=$O(^TMP("ORXS2",$J,"METH",FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS2",$J,"METH",FAC,IFN)) Q:IFN="" S METHOD=^(IFN,1),DATA=^(0) D 40 .I $L(METHOD) S X=METHOD D 41 .. D XVSET("16^"_X,16,FAC,IFN,DATA) ;Methods 42 S FAC="" 43 F S FAC=$O(^TMP("ORXS2",$J,"QUAL",FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS2",$J,"QUAL",FAC,IFN)) Q:IFN="" S QUALIF=^(IFN,1),DATA=^(0) D 44 .I $L(QUALIF) S X=QUALIF D 45 .. D XVSET("15^"_X,15,FAC,IFN,DATA) ;Qualifiers 46 S FAC="" 47 F S FAC=$O(^TMP("ORXS2",$J,"UNIT",FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS2",$J,"UNIT",FAC,IFN)) Q:IFN="" S UNIT=^(IFN,1),DATA=^(0) D 48 .I $L(UNIT) S X=UNIT D 49 .. D XVSET("17^"_X,17,FAC,IFN,DATA) ;Units 50 K ^XTMP(HANDLE,"D") 51 S FAC="",CNT=-1 52 F S FAC=$O(^TMP("ORXS1",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS1",$J,FAC,IFN)) Q:IFN="" S IFN1="" D 53 . F S IFN1=$O(^TMP("ORXS1",$J,FAC,IFN,IFN1)) Q:IFN1="" S X=^(IFN1) D 54 .. S CNT=CNT+1,^XTMP(HANDLE,"D",CNT)=X 55 K ^TMP("ORXS",$J),^TMP("ORXS1",$J),^TMP("ORXS2",$J) 56 Q 57 METH(DATA) ;Get Methods, Units & Qualifiers 58 Q:'$D(DATA) 59 N X,D,T 60 S X=$P($P(DATA,"^",3),"~",2),D=$P($G(DATA),"^",4),T=$P($P(DATA,"^",5),"~",2) 61 I $L(X),$L(T),$L(D) S METHOD=$G(^TMP("ORXS2",$J,"METH",FAC,IFN,1)),METHOD=$S($L(METHOD):METHOD_" | "_T_":",1:T_":")_X,^TMP("ORXS2",$J,"METH",FAC,IFN,1)=METHOD,^(0)=DATA 62 S X=$P($P(DATA,"^",8),"~",2) 63 I $L(X),$L(T),$L(D) S QUALIF=$G(^TMP("ORXS2",$J,"QUAL",FAC,IFN,1)),QUALIF=$S($L(QUALIF):QUALIF_" | "_T_":",1:T_":")_X,^TMP("ORXS2",$J,"QUAL",FAC,IFN,1)=QUALIF,^(0)=DATA 64 S X=$P($P(DATA,"^",7),"~",2) 65 I $L(X),$L(T),$L(D) S UNIT=$G(^TMP("ORXS2",$J,"UNIT",FAC,IFN,1)),UNIT=$S($L(UNIT):UNIT_" | "_T_":",1:T_":")_X,^TMP("ORXS2",$J,"UNIT",FAC,IFN,1)=UNIT,^(0)=DATA 66 Q 67 XVSET(X,IFN,FAC,IDT,NODE) ;Setup Vitals nodes 68 Q:'$D(X) Q:'$L($G(IDT)) 69 N SAVE,OIDT 70 S SAVE=X 71 I '$L($G(IFN)) S CNT=CNT+1,^TMP("ORXS1",$J,IDT,FAC,CNT)=$$ESCP^ORWRP4(SAVE) Q 72 I $D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D Q ;Get data where item, facility, date/time are the same 73 . S OIDT=IDT 74 . F S IDT=IDT+.0001 Q:'$D(^TMP("ORXS1",$J,IDT,IFN)) 75 . I '$D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D 76 .. S ^TMP("ORXS1",$J,IDT,FAC,1)=$$ESCP^ORWRP4("1^"_$P($G(NODE),"^",2)) ;Facility 77 .. S ^TMP("ORXS1",$J,IDT,FAC,2)=$$ESCP^ORWRP4("2^"_$$DATE^ORDVU($$SETDATE^ORWRP4($P($G(NODE),"^",4)))) ;Date/Time 78 . S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE),IDT=OIDT 79 S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE) 80 Q 1 ORWRP4V ; slc/dcm - OE/RR HDR Report Extract RPC's Vitals;9/21/05 13:21 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 3 VS ;Vitals code for HDR 4 N I,IFN,IFN1,IFN2,X,X1,X2,X4,X5,XIFN,ORX,COL,CODE,I1,CNT,%DT,FAC,FACU,NODE 5 K ^TMP("ORXS",$J) 6 S IFN="" 7 F S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN="" S XIFN=^(IFN) D 8 . S X11=$P(XIFN,"^",11),X12=$P(XIFN,"^",12),X2=$P(XIFN,"^",2),FACU=X12 9 . I X12="",X11,X11'=200 S FACU=$O(^DIC(4,"D",X11,0)) I FACU S FACU=$P(^DIC(4,FACU,0),"^") 10 . I '$L(FACU) S FACU=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown") 11 . S $P(XIFN,"^",2)=FACU,X4=$P($P(XIFN,"^",4),":",1,2),X5=$P($P(XIFN,"^",5),"~",2) 12 . I $P(XIFN,"^",10)'="W",$L(X5) D 13 .. S X4=9999999-$$SETDATE^ORWRP4(X4) 14 .. I X4=9999999 F I=.01:.01 S X4=X4+I I '$D(^TMP("ORXS",$J,FACU,X4)) Q 15 .. S ^TMP("ORXS",$J,FACU,X4)=$P(XIFN,"^",2),^TMP("ORXS",$J,FACU,X4,X5,IFN)=XIFN 16 K ^TMP("ORXS1",$J) 17 S FAC="",CNT=-1 18 F S FAC=$O(^TMP("ORXS",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS",$J,FAC,IFN)) Q:IFN="" S NODE=^(IFN) D 19 . D XVSET("1^"_$P(NODE,"^"),1,FAC,IFN,NODE) ;Facility 20 . I $P(IFN,".")'=9999999 D XVSET("2^"_$$DATE^ORDVU(9999999-IFN),2,FAC,IFN,NODE) ; Measurement Date/Time 21 . I $P(IFN,".")=9999999 D XVSET("2^"_" ",2,FAC,IFN,NODE) ; Measurement Date/Time = "" 22 . S IFN1="" 23 . F S IFN1=$O(^TMP("ORXS",$J,FAC,IFN,IFN1)) Q:IFN1="" S IFN2="" F S IFN2=$O(^TMP("ORXS",$J,FAC,IFN,IFN1,IFN2)) Q:IFN2="" S X=^(IFN2) D 24 .. I $$UPPER^ORU(IFN1)="TEMPERATURE" D XVSET("3^"_$P(X,"^",6),3,FAC,IFN,X) 25 .. I $$UPPER^ORU(IFN1)="PULSE" D XVSET("4^"_$P(X,"^",6),4,FAC,IFN,X) 26 .. I $$UPPER^ORU(IFN1)="RESPIRATION" D XVSET("5^"_$P(X,"^",6),5,FAC,IFN,X) 27 .. I $$UPPER^ORU(IFN1)="BLOOD PRESSURE" D XVSET("6^"_$P(X,"^",6),6,FAC,IFN,X) 28 .. I $$UPPER^ORU(IFN1)="HEIGHT" D XVSET("7^"_$P(X,"^",6),7,FAC,IFN,X) 29 .. I $$UPPER^ORU(IFN1)="WEIGHT" D XVSET("8^"_$P(X,"^",6),8,FAC,IFN,X) 30 .. I $$UPPER^ORU(IFN1)="PAIN" D XVSET("9^"_$P(X,"^",6),9,FAC,IFN,X) 31 .. I $$UPPER^ORU(IFN1)="PULSE OXIMETRY" D XVSET("10^"_$P(X,"^",6),10,FAC,IFN,X) 32 .. I $$UPPER^ORU(IFN1)="CENTRAL VENOUS PRESSURE" D XVSET("11^"_$P(X,"^",6),11,FAC,IFN,X) 33 .. I $$UPPER^ORU(IFN1)="CIRCUMFERENCE/GIRTH" D XVSET("12^"_$P(X,"^",6),12,FAC,IFN,X) 34 K ^XTMP(HANDLE,"D") 35 S FAC="",CNT=-1 36 F S FAC=$O(^TMP("ORXS1",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS1",$J,FAC,IFN)) Q:IFN="" S IFN1="" D 37 . F S IFN1=$O(^TMP("ORXS1",$J,FAC,IFN,IFN1)) Q:IFN1="" S X=^(IFN1) D 38 .. S CNT=CNT+1,^XTMP(HANDLE,"D",CNT)=X 39 K ^TMP("ORXS",$J),^TMP("ORXS1",$J) 40 Q 41 XVSET(X,IFN,FAC,IDT,NODE) ;Setup Vitals nodes 42 Q:'$D(X) Q:'$L($G(IDT)) 43 N SAVE,OIDT 44 S SAVE=X 45 I '$L($G(IFN)) S CNT=CNT+1,^TMP("ORXS1",$J,IDT,FAC,CNT)=$$ESCP^ORWRP4(SAVE) Q 46 I $D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D Q ;Get data where item, facility, date/time are the same 47 . S OIDT=IDT 48 . F S IDT=IDT+.0001 Q:'$D(^TMP("ORXS1",$J,IDT,IFN)) 49 . I '$D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D 50 .. S ^TMP("ORXS1",$J,IDT,FAC,1)=$$ESCP^ORWRP4("1^"_$P($G(NODE),"^",2)) ;Facility 51 .. S ^TMP("ORXS1",$J,IDT,FAC,2)=$$ESCP^ORWRP4("2^"_$$DATE^ORDVU($$SETDATE^ORWRP4($P($G(NODE),"^",4)))) ;Date/Time 52 . S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE),IDT=OIDT 53 S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE) 54 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTIU.m
r613 r623 1 ORWTIU ; slc/REV - Functions for GUI PARAMETER ACTIONS ; 08 Feb 2001 09:02AM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,195,243**;Dec 17, 1997;Build 242 3 ; 4 GTTIUCTX(Y,ORUSER) ; Returns current Notes view context for user 5 N OCCLIM,SHOWSUB 6 S Y=$$GET^XPAR("ALL","ORCH CONTEXT NOTES",1) 7 I +$P(Y,";",5)=0 D 8 . S OCCLIM=$P($$PERSPRF^TIULE(DUZ),U,10) 9 . S:+OCCLIM>0 $P(Y,";",5)=OCCLIM 10 S SHOWSUB=$P(Y,";",6) 11 S $P(Y,";",6)=$S(SHOWSUB'="":SHOWSUB,1:0) 12 Q 13 SVTIUCTX(Y,ORCTXT) ; Save new Notes view preferences for user 14 N TMP 15 S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1) 16 I TMP'="" D Q 17 . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1,ORCTXT) 18 D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1,ORCTXT) 19 Q 20 ; 21 GTDCCTX(Y,ORUSER) ; Returns current DC Summary view context for user 22 N OCCLIM,SHOWSUB 23 S Y=$$GET^XPAR("ALL","ORCH CONTEXT SUMMRIES",1) 24 I +$P(Y,";",5)=0 D 25 . S OCCLIM=$P($$PERSPRF^TIULE(DUZ),U,10) 26 . S:+OCCLIM>0 $P(Y,";",5)=OCCLIM 27 S SHOWSUB=$P(Y,";",6) 28 S $P(Y,";",6)=$S(SHOWSUB'="":SHOWSUB,1:0) 29 Q 30 SVDCCTX(Y,ORCTXT) ; Save new DC Summary view preferences for user 31 N TMP 32 S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1) 33 I TMP'="" D Q 34 . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1,ORCTXT) 35 D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1,ORCTXT) 36 Q 37 ; 38 PRINTW(ORY,ORDA,ORFLG) ;TIU print to windows printer 39 N ZTQUEUED,ORHFS,ORSUB,ORIO,ORSTATUS,ROOT,ORERR,ORWIN,ORHANDLE 40 N IOM,IOSL,IOST,IOF,IOT,IOS 41 S (ORSUB,ROOT)="ORDATA",ORIO="OR WINDOWS HFS",ORWIN=1,ORHANDLE="ORWTIU" 42 S ORY=$NA(^TMP(ORSUB,$J,1)) 43 S ORHFS=$$HFS^ORWRP() 44 D HFSOPEN^ORWRP(ORHANDLE,ORHFS,"W") 45 I POP D Q 46 . I $D(ROOT) D SETITEM^ORWRP(.ROOT,"ERROR: Unable to open HFS file for TIU print") 47 D IOVAR^ORWRP(.ORIO,,,"P-WINHFS80") 48 N $ETRAP,$ESTACK 49 S $ETRAP="D ERR^ORWRP Q" 50 U IO 51 D RPC^TIUPD(.ORERR,ORDA,ORIO,ORFLG,ORWIN) 52 D HFSCLOSE^ORWRP(ORHANDLE,ORHFS) 53 Q 54 GTLSTITM(ORY,ORTIUDA) ; Return single listbox item for document 55 Q:+$G(ORTIUDA)=0 56 S ORY=ORTIUDA_U_$$RESOLVE^TIUSRVLO(ORTIUDA) 57 Q 58 IDNOTES(ORY) ; Is ID Notes installed? 59 S ORY=$$PATCH^XPDUTL("TIU*1.0*100") 60 Q 61 CANLINK(ORY,ORTITLE) ;Can the title be an ID child? 62 ; DBIA #2322 63 S ORY=$$CANLINK^TIULP(ORTITLE) 64 Q 65 GETCP(ORY,ORTIUDA) ; Checks required CP fields before signature 66 S ORY="" 67 N ORTITLE,ORAUTH,ORCOS,ORPSUMCD,ORPROCDT,ORROOT,ORERR,ORREFDT 68 S ORERR="",ORROOT=$NA(^TMP("ORTIU",$J)) 69 D EXTRACT^TIULQ(ORTIUDA,.ORROOT,.ORERR,".01;1202;1208;70201;70202;1301",,,"I") 70 S ORTITLE=@ORROOT@(ORTIUDA,".01","I") 71 S ORAUTH=@ORROOT@(ORTIUDA,"1202","I") 72 S ORCOS=@ORROOT@(ORTIUDA,"1208","I") 73 S ORPSUMCD=@ORROOT@(ORTIUDA,"70201","I") 74 S ORPROCDT=@ORROOT@(ORTIUDA,"70202","I") 75 S ORREFDT=@ORROOT@(ORTIUDA,"1301","I") 76 S ORY=ORAUTH_U_ORCOS_U_ORPSUMCD_U_ORPROCDT_U_ORTITLE_U_ORREFDT 77 K @ORROOT 78 Q 79 CHKTXT(ORY,ORTIUDA) ; Checks for presence of text before signature 80 S ORY='$$EMPTYDOC^TIULF(ORTIUDA) ;DBIA #4426 81 Q 1 ORWTIU ; slc/REV - Functions for GUI PARAMETER ACTIONS ; 08 Feb 2001 09:02AM 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,195**;Dec 17, 1997 3 ; 4 GTTIUCTX(Y,ORUSER) ; Returns current Notes view context for user 5 N OCCLIM,SHOWSUB 6 S Y=$$GET^XPAR("ALL","ORCH CONTEXT NOTES",1) 7 I +$P(Y,";",5)=0 D 8 . S OCCLIM=$P($$PERSPRF^TIULE(DUZ),U,10) 9 . S:+OCCLIM>0 $P(Y,";",5)=OCCLIM 10 S SHOWSUB=$P(Y,";",6) 11 S $P(Y,";",6)=$S(SHOWSUB'="":SHOWSUB,1:0) 12 Q 13 SVTIUCTX(Y,ORCTXT) ; Save new Notes view preferences for user 14 N TMP 15 S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1) 16 I TMP'="" D Q 17 . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1,ORCTXT) 18 D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1,ORCTXT) 19 Q 20 ; 21 GTDCCTX(Y,ORUSER) ; Returns current DC Summary view context for user 22 N OCCLIM,SHOWSUB 23 S Y=$$GET^XPAR("ALL","ORCH CONTEXT SUMMRIES",1) 24 I +$P(Y,";",5)=0 D 25 . S OCCLIM=$P($$PERSPRF^TIULE(DUZ),U,10) 26 . S:+OCCLIM>0 $P(Y,";",5)=OCCLIM 27 S SHOWSUB=$P(Y,";",6) 28 S $P(Y,";",6)=$S(SHOWSUB'="":SHOWSUB,1:0) 29 Q 30 SVDCCTX(Y,ORCTXT) ; Save new DC Summary view preferences for user 31 N TMP 32 S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1) 33 I TMP'="" D Q 34 . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1,ORCTXT) 35 D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1,ORCTXT) 36 Q 37 ; 38 PRINTW(ORY,ORDA,ORFLG) ;TIU print to windows printer 39 N ZTQUEUED,ORHFS,ORSUB,ORIO,ORSTATUS,ROOT,ORERR,ORWIN,ORHANDLE 40 N IOM,IOSL,IOST,IOF,IOT,IOS 41 S (ORSUB,ROOT)="ORDATA",ORIO="OR WINDOWS HFS",ORWIN=1,ORHANDLE="ORWTIU" 42 S ORY=$NA(^TMP(ORSUB,$J,1)) 43 S ORHFS=$$HFS^ORWRP() 44 D HFSOPEN^ORWRP(ORHANDLE,ORHFS,"W") 45 I POP D Q 46 . I $D(ROOT) D SETITEM^ORWRP(.ROOT,"ERROR: Unable to open HFS file for TIU print") 47 D IOVAR^ORWRP(.ORIO,,,"P-WINHFS80") 48 N $ETRAP,$ESTACK 49 S $ETRAP="D ERR^ORWRP Q" 50 U IO 51 D RPC^TIUPD(.ORERR,ORDA,ORIO,ORFLG,ORWIN) 52 D HFSCLOSE^ORWRP(ORHANDLE,ORHFS) 53 Q 54 GTLSTITM(ORY,ORTIUDA) ; Return single listbox item for document 55 Q:+$G(ORTIUDA)=0 56 S ORY=ORTIUDA_U_$$RESOLVE^TIUSRVLO(ORTIUDA) 57 Q 58 IDNOTES(ORY) ; Is ID Notes installed? 59 S ORY=$$PATCH^XPDUTL("TIU*1.0*100") 60 Q 61 CANLINK(ORY,ORTITLE) ;Can the title be an ID child? 62 ; DBIA #2322 63 S ORY=$$CANLINK^TIULP(ORTITLE) 64 Q 65 GETCP(ORY,ORTIUDA) ; Checks required CP fields before signature 66 S ORY="" 67 N ORTITLE,ORAUTH,ORCOS,ORPSUMCD,ORPROCDT,ORROOT,ORERR 68 S ORERR="",ORROOT=$NA(^TMP("ORTIU",$J)) 69 D EXTRACT^TIULQ(ORTIUDA,.ORROOT,.ORERR,".01;1202;1208;70201;70202",,,"I") 70 S ORTITLE=@ORROOT@(ORTIUDA,".01","I") 71 S ORAUTH=@ORROOT@(ORTIUDA,"1202","I") 72 S ORCOS=@ORROOT@(ORTIUDA,"1208","I") 73 S ORPSUMCD=@ORROOT@(ORTIUDA,"70201","I") 74 S ORPROCDT=@ORROOT@(ORTIUDA,"70202","I") 75 S ORY=ORAUTH_U_ORCOS_U_ORPSUMCD_U_ORPROCDT_U_ORTITLE 76 K @ORROOT 77 Q 78 CHKTXT(ORY,ORTIUDA) ; Checks for presence of text before signature 79 S ORY='$$EMPTYDOC^TIULF(ORTIUDA) ;DBIA #4426 80 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPD.m
r613 r623 1 ORWTPD ; slc/jdl - Personal Reference Tool ;6/20/02 11:40am [7/22/03 11:27am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,132,148,141,173,195,243**;Dec 17,1997;Build 242 3 ;; Allow user to customize the CPRS reports date/time 4 ;; and max occurences setting 5 ; 6 SUDF(Y,VALUE) ;----Set user default for all CPRS reports 7 N ORERR S ORERR="" 8 I VALUE=$$GET^XPAR("DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") D DEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,.ORERR) K ORERR Q 9 E D EN^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,VALUE,.ORERR) 10 S Y=1 11 K ORERR,VALUES1 12 Q 13 ; 14 SUINDV(Y,RPTS,VALUE) ;----Set user individual time/occ setting 15 ; RPTS format: RPTIen^RPTIen^RPTIen such as 1^2^3 16 I $L(RPTS)=0 Q 17 N ORERR,RPTID,P1,P7 S ORERR=0 18 S (P1,P7)="" 19 F I=1:1:$L(RPTS,"^") S RPTID=$P(RPTS,U,I) D 20 . S P1=$P($G(^ORD(101.24,RPTID,0)),U),P7=$P($G(^(0)),U,7) 21 . I "02345"[P7,(P1'="ORRP IMAGING") D DEL^XPAR("USR.`"_DUZ,"ORWRP TIME/OCC LIMITS INDV",RPTID,.ORERR) Q 22 . D EN^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS INDV",RPTID,VALUE,.ORERR) 23 Q 24 ; 25 GETIMG(Y,RPT) ; ----Get Image (local only) Time/Occ 26 N IMGID,BEG,END,MAX 27 S IMGID=0,Y="" 28 S IMGID=$O(^ORD(101.24,"B","ORRP IMAGING",0)) 29 D GETINDV(.Y,IMGID) 30 I $L(Y) D 31 . S BEG=$$DT^ORCHTAB1($P(Y,";")) 32 . S END=$$DT^ORCHTAB1($P(Y,";",2)) 33 . S MAX=$P(Y,";",3) 34 . S Y=BEG_"^"_END_"^"_MAX 35 I Y="" D GETDEF^ORWRA(.Y) 36 Q 37 ; 38 GETINDV(Y,RPT) ;----Get time/occ limits for this report 39 ;RPT: Report IEN of 101.24 40 N CTX,X0,X4,X,IMGCTX 41 S X0=$G(^ORD(101.24,RPT,0)),X4=$G(^(4)) 42 I "02345"[($P(X0,U,7)),($P(X0,U)'="ORRP IMAGING") Q 43 S CTX="^DIV^SYS^PKG" 44 S Y=$$GET^XPAR("USR.`"_DUZ_CTX,"ORWRP TIME/OCC LIMITS INDV",RPT,"I") 45 S:'$L(Y) Y=$$GET^XPAR("USR.`"_DUZ_CTX,"ORWRP TIME/OCC LIMITS ALL",1,"I") 46 I $P(^ORD(101.24,RPT,0),U,7)=1 S $P(Y,";",3)="" 47 I $P(X4,"^",2) S X=$P($P(Y,";"),"-",2) I X,X>$P(X4,"^",2) S Y="T-"_$P(X4,"^",2)_";"_$P(Y,";",2,99) 48 Q 49 ; 50 GETSETS(Y) ;----Get time/occ limit set for each report 51 N I,CNT,CAT,SEC 52 S I=0,CNT=1,RST="" 53 F S I=$O(^ORD(101.24,I)) Q:'I D 54 . I $P($G(^ORD(101.24,I,0)),U,12)'="M" D 55 .. S CAT=$P(^ORD(101.24,I,0),U,7),SEC=$P(^(0),U,8) 56 .. I $S(CAT=1:1,CAT=6:1,1:0)!($P(^(0),U)="ORRP IMAGING") D 57 ... D GETINDV(.RST,I) 58 ... I $L($P(^ORD(101.24,I,2),U,4))>0 S Y(CNT)=I_U_$P(^(2),U,4)_" ["_SEC_"]"_U_RST 59 ... E S Y(CNT)=I_U_$P(^ORD(101.24,I,2),U,3)_" ["_SEC_"]"_U_RST 60 ... S CNT=CNT+1 61 K I,CNT,RST,CAT 62 Q 63 ; 64 GETDFLT(Y) ;----Get default time/occ limits for all reports 65 N VALUE 66 S Y=$$GET^XPAR("USR.`"_DUZ_"^DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") 67 K VALUE 68 Q 69 ; 70 RSDFLT(Y) ;----Retrieve sys/pkg level default time/occ setting 71 N VALUE 72 S Y=$$GET^XPAR("DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") 73 Q 74 ; 75 DELDFLT(Y) ;----Delete user's default setting 76 N ORERR S ORERR="" 77 D NDEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS INDV",.ORERR) 78 D DEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,.ORERR) 79 K ORERR 80 Q 81 ; 82 ACTDF(Y) ;----Make default setting take action for each report 83 N IND,DFLT,VALUE,X,X0,X4,MAX,DFLT1 84 S DFLT=$$GET^XPAR("USR.`"_DUZ_"^DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") 85 S IND=0,X=$P($P(DFLT,";"),"-",2) 86 F S IND=$O(^ORD(101.24,IND)) Q:'IND S X0=$G(^(IND,0)),X4=$G(^(4)) D 87 . I $P(X0,"^",8)="R",$P(X0,"^",12)'="M" D 88 .. S MAX=$P(X4,"^",2),DFLT1=DFLT 89 .. I MAX,X,X>MAX S DFLT1="T-"_MAX_";"_$P(DFLT,";",2,99) 90 .. D SUINDV(.Y,IND,DFLT1) 91 Q 92 GETOCM(ORY) ;Get value of "ORCH CONTEXT MEDS" 93 S ORY=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") 94 Q 95 ; 96 PUTOCM(ORY,ORVAL) ;Set value of "ORCH CONTEXT MEDS" 97 I '$L(ORVAL) D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS",1) Q 98 N ORERR S ORERR="" 99 D EN^XPAR(DUZ_";VA(200,","ORCH CONTEXT MEDS",1,ORVAL,.ORERR) 100 S ORY=ORERR 101 Q 102 ; 1 ORWTPD ; slc/jdl - Personal Reference Tool ;6/20/02 11:40am [7/22/03 11:27am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,132,148,141,173,195**;Dec 17,1997 3 ;; Allow user to customize the CPRS reports date/time 4 ;; and max occurences setting 5 ; 6 SUDF(Y,VALUE) ;----Set user default for all CPRS reports 7 N ORERR S ORERR="" 8 I VALUE=$$GET^XPAR("DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") D DEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,.ORERR) K ORERR Q 9 E D EN^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,VALUE,.ORERR) 10 S Y=1 11 K ORERR,VALUES1 12 Q 13 ; 14 SUINDV(Y,RPTS,VALUE) ;----Set user individual time/occ setting 15 ; RPTS format: RPTIen^RPTIen^RPTIen such as 1^2^3 16 I $L(RPTS)=0 Q 17 N ORERR,RPTID,P1,P7 S ORERR=0 18 S (P1,P7)="" 19 F I=1:1:$L(RPTS,"^") S RPTID=$P(RPTS,U,I) D 20 . S P1=$P($G(^ORD(101.24,RPTID,0)),U),P7=$P($G(^(0)),U,7) 21 . I "02345"[P7,(P1'="ORRP IMAGING") D DEL^XPAR("USR.`"_DUZ,"ORWRP TIME/OCC LIMITS INDV",RPTID,.ORERR) Q 22 . D EN^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS INDV",RPTID,VALUE,.ORERR) 23 Q 24 ; 25 GETIMG(Y,RPT) ; ----Get Image (local only) Time/Occ 26 N IMGID,BEG,END,MAX 27 S IMGID=0,Y="" 28 S IMGID=$O(^ORD(101.24,"B","ORRP IMAGING",0)) 29 D GETINDV(.Y,IMGID) 30 I $L(Y) D 31 . S BEG=$$DT^ORCHTAB1($P(Y,";")) 32 . S END=$$DT^ORCHTAB1($P(Y,";",2)) 33 . S MAX=$P(Y,";",3) 34 . S Y=BEG_"^"_END_"^"_MAX 35 I Y="" D GETDEF^ORWRA(.Y) 36 Q 37 ; 38 GETINDV(Y,RPT) ;----Get time/occ limits for this report 39 ;RPT: Report IEN of 101.24 40 N CTX,X0,X4,X,IMGCTX 41 S X0=$G(^ORD(101.24,RPT,0)),X4=$G(^(4)) 42 I "02345"[($P(X0,U,7)),($P(X0,U)'="ORRP IMAGING") Q 43 S CTX="^DIV^SYS^PKG" 44 S Y=$$GET^XPAR("USR.`"_DUZ_CTX,"ORWRP TIME/OCC LIMITS INDV",RPT,"I") 45 S:'$L(Y) Y=$$GET^XPAR("USR.`"_DUZ_CTX,"ORWRP TIME/OCC LIMITS ALL",1,"I") 46 I $P(^ORD(101.24,RPT,0),U,7)=1 S $P(Y,";",3)="" 47 I $P(X4,"^",2) S X=$P($P(Y,";"),"-",2) I X,X>$P(X4,"^",2) S Y="T-"_$P(X4,"^",2)_";"_$P(Y,";",2,99) 48 Q 49 ; 50 GETSETS(Y) ;----Get time/occ limit set for each report 51 N I,CNT,CAT S I=0,CNT=1,RST="" 52 F S I=$O(^ORD(101.24,I)) Q:'I D 53 .I $P($G(^ORD(101.24,I,0)),U,8)="R",$P($G(^ORD(101.24,I,0)),U,12)'="M" D 54 ..S CAT=$P(^ORD(101.24,I,0),U,7) I $S(CAT=1:1,CAT=6:1,1:0)!($P(^(0),U)="ORRP IMAGING") D 55 ...D GETINDV(.RST,I) 56 ...I $L($P(^ORD(101.24,I,2),U,4))>0 S Y(CNT)=I_U_$P(^ORD(101.24,I,2),U,4)_U_RST 57 ...E S Y(CNT)=I_U_$P(^ORD(101.24,I,2),U,3)_U_RST 58 ... S CNT=CNT+1 59 K I,CNT,RST,CAT 60 Q 61 ; 62 GETDFLT(Y) ;----Get default time/occ limits for all reports 63 N VALUE 64 S Y=$$GET^XPAR("USR.`"_DUZ_"^DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") 65 K VALUE 66 Q 67 ; 68 RSDFLT(Y) ;----Retrieve sys/pkg level default time/occ setting 69 N VALUE 70 S Y=$$GET^XPAR("DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") 71 Q 72 ; 73 DELDFLT(Y) ;----Delete user's default setting 74 N ORERR S ORERR="" 75 D NDEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS INDV",.ORERR) 76 D DEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,.ORERR) 77 K ORERR 78 Q 79 ; 80 ACTDF(Y) ;----Make default setting take action for each report 81 N IND,DFLT,VALUE,X,X0,X4,MAX,DFLT1 82 S DFLT=$$GET^XPAR("USR.`"_DUZ_"^DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") 83 S IND=0,X=$P($P(DFLT,";"),"-",2) 84 F S IND=$O(^ORD(101.24,IND)) Q:'IND S X0=$G(^(IND,0)),X4=$G(^(4)) D 85 . I $P(X0,"^",8)="R",$P(X0,"^",12)'="M" D 86 .. S MAX=$P(X4,"^",2),DFLT1=DFLT 87 .. I MAX,X,X>MAX S DFLT1="T-"_MAX_";"_$P(DFLT,";",2,99) 88 .. D SUINDV(.Y,IND,DFLT1) 89 Q 90 GETOCM(ORY) ;Get value of "ORCH CONTEXT MEDS" 91 S ORY=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") 92 Q 93 ; 94 PUTOCM(ORY,ORVAL) ;Set value of "ORCH CONTEXT MEDS" 95 I '$L(ORVAL) D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS",1) Q 96 N ORERR S ORERR="" 97 D EN^XPAR(DUZ_";VA(200,","ORCH CONTEXT MEDS",1,ORVAL,.ORERR) 98 S ORY=ORERR 99 Q 100 ; -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPL.m
r613 r623 1 ORWTPL ; SLC/STAFF Personal Preference - Lists ; 3/11/08 6:36am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,109,173,243**;Oct 24, 2000;Build 242 3 ; 4 NEWLIST(VAL,LISTNAME,USER,ORVIZ) ; from ORWTPP 5 ; set user's new personal list 6 S LISTNAME=$G(LISTNAME) 7 I '$L(LISTNAME) S VAL="^invalid list name" Q 8 I $O(^OR(100.21,"B",LISTNAME,0)) S VAL="^invalid list name - duplicate of another name" Q 9 ;*** check input transform, duplicate name for same user 10 N DA,DIK,NUM 11 L +^OR(100.21,0):20 I '$T S VAL="^unable to set up" Q 12 S NUM=1+$P(^OR(100.21,0),U,3) 13 F Q:'$D(^OR(100.21,NUM,0)) S NUM=NUM+1 14 S $P(^OR(100.21,0),U,3)=NUM,$P(^(0),U,4)=$P(^(0),U,4)+1 15 S ^OR(100.21,NUM,0)=LISTNAME_"^P" 16 L -^OR(100.21,0) 17 K ^OR(100.21,NUM,1),^(2),^(10) 18 S ^OR(100.21,NUM,1,0)="^100.212PA^"_USER_"^1" 19 S ^OR(100.21,NUM,1,USER,0)=USER 20 S ^OR(100.21,NUM,11)=$G(ORVIZ)_U 21 S DIK="^OR(100.21,",DA=NUM 22 D IX1^DIK 23 S VAL=NUM_U_LISTNAME_"^^^^^^^"_$G(ORVIZ) 24 Q 25 ; 26 DELLIST(OK,LISTNUM,USER) ; from ORWTPP 27 ; delete user's personal list 28 N DA,DIK 29 S LISTNUM=+$G(LISTNUM),OK=1 30 I '$O(^OR(100.21,"C",USER,LISTNUM,0)) S OK=0 Q 31 I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q 32 S DA=LISTNUM,DIK="^OR(100.21," 33 D ^DIK 34 Q 35 ; 36 SAVELIST(OK,PLIST,LISTNUM,USER,ORVIZ) ; from ORWTPP 37 ; save user's personal list changes 38 N CNT,DA,DFN,DIK,NUM K DA 39 S LISTNUM=+$G(LISTNUM),OK=1 40 I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q 41 I '$D(^OR(100.21,"C",USER,LISTNUM)) S OK=0 Q 42 I '$D(^OR(100.21,LISTNUM,10,0))#2 S ^(0)="^100.2101AV^" 43 S DA(1)=LISTNUM,DIK="^OR(100.21,"_LISTNUM_",10," 44 S DA=0 F S DA=$O(^OR(100.21,LISTNUM,10,DA)) Q:DA<1 D ^DIK 45 K DA 46 S CNT=0 47 S NUM=0 F S NUM=$O(PLIST(NUM)) Q:NUM<1 D 48 .S DFN=+PLIST(NUM) I 'DFN Q 49 .S CNT=CNT+1 50 .S ^OR(100.21,LISTNUM,10,CNT,0)=DFN_";DPT(" 51 S ^OR(100.21,LISTNUM,10,0)="^100.2101AV^"_CNT_U_CNT 52 S ^OR(100.21,LISTNUM,11)=$G(ORVIZ)_U 53 S DA=LISTNUM,DIK="^OR(100.21," 54 D IX1^DIK 55 Q 56 ; 57 LSDEF(INFO,USER) ; from ORWTPP 58 ; get user's list sources 59 N TYPE 60 S INFO="" 61 F TYPE="P","S","T","W","C" D 62 .S INFO=INFO_$P($$LISTSRC^ORQPTQ11(USER,TYPE),U)_U 63 Q 64 ; 65 SORTDEF(SORT,USER) ; from ORWTPP 66 ; get user's sort order - Modified by PKS - 8/30/2001 67 N ORSECT 68 S ORSECT=$G(^VA(200,USER,5)) 69 I +ORSECT>0 S ORSECT=$P(ORSECT,U) 70 S SORT=$$GET^XPAR("USR.`"_USER_"^SRV.`"_$G(ORSECT)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") I SORT']"" S SORT="A" 71 Q 72 ; 73 CLDAYS(DAYS,USER) ; from ORWTPP 74 ; get user's clinic defaults 75 N DAY 76 S DAYS="" 77 F DAY="MONDAY","TUESDAY","WEDNESDAY","THURSDAY","FRIDAY","SATURDAY","SUNDAY" D 78 .S DAYS=DAYS_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_DAY,1,"I")_U 79 Q 80 ; 81 CLRANGE(RANGE,USER) ; from ORWTPP 82 ; get user's default clinic start, stop dates 83 N RNG 84 S RANGE="" 85 F RNG="START","STOP" D 86 .S RANGE=RANGE_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_RNG_" DATE",1,"I")_U 87 Q 88 ; 89 SAVECD(OK,INFO,USER) ; from ORWTPP 90 ; save user's clinic defaults 91 N FRI,MON,SAT,START,STOP,SUN,THURS,TUES,WED 92 S OK=1 93 S START=+$P(INFO,U,1) S START=$S(START=0:"T",START<0:"T"_START,1:"T+"_START) 94 S STOP=+$P(INFO,U,2) S STOP=$S(STOP=0:"T",STOP<0:"T"_STOP,1:"T+"_STOP) 95 S MON=+$P(INFO,U,3),MON=$S('MON:"@",1:"`"_MON) 96 S TUES=+$P(INFO,U,4),TUES=$S('TUES:"@",1:"`"_TUES) 97 S WED=+$P(INFO,U,5),WED=$S('WED:"@",1:"`"_WED) 98 S THURS=+$P(INFO,U,6),THURS=$S('THURS:"@",1:"`"_THURS) 99 S FRI=+$P(INFO,U,7),FRI=$S('FRI:"@",1:"`"_FRI) 100 S SAT=+$P(INFO,U,8),SAT=$S('SAT:"@",1:"`"_SAT) 101 S SUN=+$P(INFO,U,9),SUN=$S('SUN:"@",1:"`"_SUN) 102 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC START DATE",1,START) 103 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC STOP DATE",1,STOP) 104 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC MONDAY",1,MON) 105 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC TUESDAY",1,TUES) 106 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC WEDNESDAY",1,WED) 107 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC THURSDAY",1,THURS) 108 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC FRIDAY",1,FRI) 109 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SATURDAY",1,SAT) 110 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SUNDAY",1,SUN) 111 Q 112 ; 113 SAVEPLD(OK,INFO,USER) ; from ORWTPP 114 ; save user's clinic defaults 115 N PROV,SORT,SOURCE,SPEC,TEAM,WARD 116 S OK=1 117 S SOURCE=$P(INFO,U,1) 118 S SORT=$P(INFO,U,2) 119 S PROV=+$P(INFO,U,3),PROV=$S('PROV:"@",1:"`"_PROV) 120 S SPEC=+$P(INFO,U,4),SPEC=$S('SPEC:"@",1:"`"_SPEC) 121 S TEAM=+$P(INFO,U,5),TEAM=$S('TEAM:"@",1:"`"_TEAM) 122 S WARD=+$P(INFO,U,6),WARD=$S('WARD:"@",1:"`"_WARD) 123 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST SOURCE",1,SOURCE) 124 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST ORDER",1,SORT) 125 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT PROVIDER",1,PROV) 126 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT SPECIALTY",1,SPEC) 127 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT TEAM",1,TEAM) 128 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT WARD",1,WARD) 129 Q 1 ORWTPL ; SLC/STAFF Personal Preference - Lists ;4/30/01 11:04 [5/19/03 3:11pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,109,173**;Oct 24, 2000 3 ; 4 NEWLIST(VAL,LISTNAME,USER) ; from ORWTPP 5 ; set user's new personal list 6 S LISTNAME=$G(LISTNAME) 7 I '$L(LISTNAME) S VAL="^invalid list name" Q 8 I $O(^OR(100.21,"B",LISTNAME,0)) S VAL="^invalid list name - duplicate of another name" Q 9 ;*** check input transform, duplicate name for same user 10 N DA,DIK,NUM 11 L +^OR(100.21,0):20 I '$T S VAL="^unable to set up" Q 12 S NUM=1+$P(^OR(100.21,0),U,3) 13 F Q:'$D(^OR(100.21,NUM,0)) S NUM=NUM+1 14 S $P(^OR(100.21,0),U,3)=NUM,$P(^(0),U,4)=$P(^(0),U,4)+1 15 S ^OR(100.21,NUM,0)=LISTNAME_"^P" 16 L -^OR(100.21,0) 17 K ^OR(100.21,NUM,1),^(2),^(10) 18 S ^OR(100.21,NUM,1,0)="^100.212PA^"_USER_"^1" 19 S ^OR(100.21,NUM,1,USER,0)=USER 20 S DIK="^OR(100.21,",DA=NUM 21 D IX1^DIK 22 S VAL=NUM_U_LISTNAME 23 Q 24 ; 25 DELLIST(OK,LISTNUM,USER) ; from ORWTPP 26 ; delete user's personal list 27 N DA,DIK 28 S LISTNUM=+$G(LISTNUM),OK=1 29 I '$O(^OR(100.21,"C",USER,LISTNUM,0)) S OK=0 Q 30 I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q 31 S DA=LISTNUM,DIK="^OR(100.21," 32 D ^DIK 33 Q 34 ; 35 SAVELIST(OK,PLIST,LISTNUM,USER) ; from ORWTPP 36 ; save user's personal list changes 37 N CNT,DA,DFN,DIK,NUM K DA 38 S LISTNUM=+$G(LISTNUM),OK=1 39 I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q 40 I '$D(^OR(100.21,"C",USER,LISTNUM)) S OK=0 Q 41 I '$D(^OR(100.21,LISTNUM,10,0))#2 S ^(0)="^100.2101AV^" 42 S DA(1)=LISTNUM,DIK="^OR(100.21,"_LISTNUM_",10," 43 S DA=0 F S DA=$O(^OR(100.21,LISTNUM,10,DA)) Q:DA<1 D ^DIK 44 K DA 45 S CNT=0 46 S NUM=0 F S NUM=$O(PLIST(NUM)) Q:NUM<1 D 47 .S DFN=+PLIST(NUM) I 'DFN Q 48 .S CNT=CNT+1 49 .S ^OR(100.21,LISTNUM,10,CNT,0)=DFN_";DPT(" 50 S ^OR(100.21,LISTNUM,10,0)="^100.2101AV^"_CNT_U_CNT 51 S DA=LISTNUM,DIK="^OR(100.21," 52 D IX1^DIK 53 Q 54 ; 55 LSDEF(INFO,USER) ; from ORWTPP 56 ; get user's list sources 57 N TYPE 58 S INFO="" 59 F TYPE="P","S","T","W","C" D 60 .S INFO=INFO_$P($$LISTSRC^ORQPTQ11(USER,TYPE),U)_U 61 Q 62 ; 63 SORTDEF(SORT,USER) ; from ORWTPP 64 ; get user's sort order - Modified by PKS - 8/30/2001 65 N ORSECT 66 S ORSECT=$G(^VA(200,USER,5)) 67 I +ORSECT>0 S ORSECT=$P(ORSECT,U) 68 S SORT=$$GET^XPAR("USR.`"_USER_"^SRV.`"_$G(ORSECT)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") I SORT']"" S SORT="A" 69 Q 70 ; 71 CLDAYS(DAYS,USER) ; from ORWTPP 72 ; get user's clinic defaults 73 N DAY 74 S DAYS="" 75 F DAY="MONDAY","TUESDAY","WEDNESDAY","THURSDAY","FRIDAY","SATURDAY","SUNDAY" D 76 .S DAYS=DAYS_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_DAY,1,"I")_U 77 Q 78 ; 79 CLRANGE(RANGE,USER) ; from ORWTPP 80 ; get user's default clinic start, stop dates 81 N RNG 82 S RANGE="" 83 F RNG="START","STOP" D 84 .S RANGE=RANGE_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_RNG_" DATE",1,"I")_U 85 Q 86 ; 87 SAVECD(OK,INFO,USER) ; from ORWTPP 88 ; save user's clinic defaults 89 N FRI,MON,SAT,START,STOP,SUN,THURS,TUES,WED 90 S OK=1 91 S START=+$P(INFO,U,1) S START=$S(START=0:"T",START<0:"T"_START,1:"T+"_START) 92 S STOP=+$P(INFO,U,2) S STOP=$S(STOP=0:"T",STOP<0:"T"_STOP,1:"T+"_STOP) 93 S MON=+$P(INFO,U,3),MON=$S('MON:"@",1:"`"_MON) 94 S TUES=+$P(INFO,U,4),TUES=$S('TUES:"@",1:"`"_TUES) 95 S WED=+$P(INFO,U,5),WED=$S('WED:"@",1:"`"_WED) 96 S THURS=+$P(INFO,U,6),THURS=$S('THURS:"@",1:"`"_THURS) 97 S FRI=+$P(INFO,U,7),FRI=$S('FRI:"@",1:"`"_FRI) 98 S SAT=+$P(INFO,U,8),SAT=$S('SAT:"@",1:"`"_SAT) 99 S SUN=+$P(INFO,U,9),SUN=$S('SUN:"@",1:"`"_SUN) 100 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC START DATE",1,START) 101 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC STOP DATE",1,STOP) 102 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC MONDAY",1,MON) 103 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC TUESDAY",1,TUES) 104 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC WEDNESDAY",1,WED) 105 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC THURSDAY",1,THURS) 106 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC FRIDAY",1,FRI) 107 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SATURDAY",1,SAT) 108 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SUNDAY",1,SUN) 109 Q 110 ; 111 SAVEPLD(OK,INFO,USER) ; from ORWTPP 112 ; save user's clinic defaults 113 N PROV,SORT,SOURCE,SPEC,TEAM,WARD 114 S OK=1 115 S SOURCE=$P(INFO,U,1) 116 S SORT=$P(INFO,U,2) 117 S PROV=+$P(INFO,U,3),PROV=$S('PROV:"@",1:"`"_PROV) 118 S SPEC=+$P(INFO,U,4),SPEC=$S('SPEC:"@",1:"`"_SPEC) 119 S TEAM=+$P(INFO,U,5),TEAM=$S('TEAM:"@",1:"`"_TEAM) 120 S WARD=+$P(INFO,U,6),WARD=$S('WARD:"@",1:"`"_WARD) 121 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST SOURCE",1,SOURCE) 122 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST ORDER",1,SORT) 123 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT PROVIDER",1,PROV) 124 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT SPECIALTY",1,SPEC) 125 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT TEAM",1,TEAM) 126 D EN^XPAR(USER_";VA(200,","ORLP DEFAULT WARD",1,WARD) 127 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPP.m
r613 r623 1 ORWTPP ; SLC/STAFF Personal Preference - Personal ; 3/11/08 6:34am2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,149,243**;Oct 24, 2000;Build 242 3 4 NEWLIST(VAL,LISTNAME ,ORVIZ); RPC5 6 D NEWLIST^ORWTPL(.VAL,LISTNAME,DUZ,$G(ORVIZ))7 8 9 DELLIST(OK,LISTNUM) 10 11 12 13 14 SAVELIST(OK,PLIST,LISTNUM ,ORVIZ); RPC15 16 D SAVELIST^ORWTPL(.OK,.PLIST,LISTNUM,DUZ,$G(ORVIZ))17 18 19 LSDEF(INFO) 20 21 22 23 24 SORTDEF(VALUE) 25 26 27 28 29 CLDAYS(INFO) 30 31 32 33 34 CLRANGE(INFO) 35 36 37 38 39 SAVECD(OK,INFO) 40 41 42 43 44 SAVEPLD(OK,INFO) 45 46 47 48 49 CSLAB(INFO) 50 51 52 53 54 CSARNG(INFO) 55 56 57 58 59 SAVECS(OK,INFO) 60 61 62 63 64 GETIMG(INFO) 65 66 67 68 69 SETIMG(OK,MAX,START,STOP) 70 71 72 73 74 GETREM(VALUES) 75 76 77 78 79 SETREM(OK,VALUES) 80 81 82 83 84 GETOC(VALUES) 85 86 87 88 89 SAVEOC(OK,VALUES) 90 91 92 93 94 GETNOT(VALUES) 95 96 97 98 99 SAVENOT(OK,VALUES) 100 101 102 103 104 CLEARNOT(OK) 105 106 107 108 109 GETNOTO(INFO) 110 111 112 113 114 CHKSURR(OK,SURR) 115 116 117 118 119 GETSURR(INFO) 120 121 122 123 124 SAVESURR(OK,INFO) 125 126 127 128 129 SAVENOTO(OK,INFO) 130 131 132 133 134 GETOTHER(INFO) 135 136 137 138 139 SETOTHER(OK,INFO) 140 141 142 143 144 GETSUB(VALUE) 145 146 147 148 149 GETCOS(VALUES,FROM,DIR,VISITORS) 150 151 152 153 154 155 GETDCOS(VALUE) 156 157 158 159 160 SETDCOS(OK,VALUE) 161 162 163 164 165 SETSUB(OK,VALUE) 166 167 168 169 170 GETTU(VALUES,CLASS) 171 172 173 174 175 GETTD(VALUE,CLASS) 176 177 178 179 180 SAVET(OK,CLASS,DEFAULT,VALUES) 181 182 183 184 185 PLISTS(VALUES) 186 187 188 189 190 PLTEAMS(VALUES) 191 192 193 194 195 TEAMS(VALUES) 196 197 198 199 200 ADDLIST(OK,VALUE) 201 202 203 204 205 REMLIST(OK,VALUE) 206 207 208 209 210 GETCOMBO(VALUES) 211 212 213 214 215 SETCOMBO(OK,VALUES) 216 217 218 1 ORWTPP ; SLC/STAFF Personal Preference - Personal ;1/19/01 15:30 [12/12/02 3:05pm] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,149**;Oct 24, 2000 3 ; 4 NEWLIST(VAL,LISTNAME) ; RPC 5 ; set current user's new personal list 6 D NEWLIST^ORWTPL(.VAL,LISTNAME,DUZ) 7 Q 8 ; 9 DELLIST(OK,LISTNUM) ; RPC 10 ; delete current user's personal list 11 D DELLIST^ORWTPL(.OK,LISTNUM,DUZ) 12 Q 13 ; 14 SAVELIST(OK,PLIST,LISTNUM) ; RPC 15 ; save current user's personal list changes 16 D SAVELIST^ORWTPL(.OK,.PLIST,LISTNUM,DUZ) 17 Q 18 ; 19 LSDEF(INFO) ; RPC 20 ; get current user's list sources 21 D LSDEF^ORWTPL(.INFO,DUZ) 22 Q 23 ; 24 SORTDEF(VALUE) ; RPC 25 ; get current user's sort order 26 D SORTDEF^ORWTPL(.VALUE,DUZ) 27 Q 28 ; 29 CLDAYS(INFO) ; RPC 30 ; get current user's clinic defaults 31 D CLDAYS^ORWTPL(.INFO,DUZ) 32 Q 33 ; 34 CLRANGE(INFO) ; RPC 35 ; get current user's default clinic start, stop dates 36 D CLRANGE^ORWTPL(.INFO,DUZ) 37 Q 38 ; 39 SAVECD(OK,INFO) ; RPC 40 ; save current user's clinic defaults 41 D SAVECD^ORWTPL(.OK,INFO,DUZ) 42 Q 43 ; 44 SAVEPLD(OK,INFO) ; RPC 45 ; save current user's list selection defaults 46 D SAVEPLD^ORWTPL(.OK,INFO,DUZ) 47 Q 48 ; 49 CSLAB(INFO) ; RPC 50 ; get lab date range defaults 51 D CSLAB^ORWTPO(.INFO,DUZ) 52 Q 53 ; 54 CSARNG(INFO) ; RPC 55 ; get current user's start, stop defaults 56 D CSARNG^ORWTPO(.INFO,DUZ) 57 Q 58 ; 59 SAVECS(OK,INFO) ; RPC 60 ; save current user's date range defaults 61 D SAVECS^ORWTPO(.OK,INFO,DUZ) 62 Q 63 ; 64 GETIMG(INFO) ; RPC 65 ; get current user's image report defaults 66 D GETIMG^ORWTPO(.INFO,DUZ) 67 Q 68 ; 69 SETIMG(OK,MAX,START,STOP) ; RPC 70 ; save current user's image report defaults 71 D SETIMG^ORWTPO(.OK,MAX,START,STOP,DUZ) 72 Q 73 ; 74 GETREM(VALUES) ; RPC 75 ; get current user's reminders 76 D GETREM^ORWTPR(.VALUES,DUZ) 77 Q 78 ; 79 SETREM(OK,VALUES) ; RPC 80 ; set current user's reminders 81 D SETREM^ORWTPR(.OK,.VALUES,DUZ) 82 Q 83 ; 84 GETOC(VALUES) ; RPC 85 ; get current user's order checks 86 D GETOC^ORWTPR(.VALUES,DUZ) 87 Q 88 ; 89 SAVEOC(OK,VALUES) ; RPC 90 ; save current user's order checks 91 D SAVEOC^ORWTPR(.OK,.VALUES,DUZ) 92 Q 93 ; 94 GETNOT(VALUES) ; RPC 95 ; get current user's notifications 96 D GETNOT^ORWTPR(.VALUES,DUZ) 97 Q 98 ; 99 SAVENOT(OK,VALUES) ; RPC 100 ; save current user's notifications 101 D SAVENOT^ORWTPR(.OK,.VALUES,DUZ) 102 Q 103 ; 104 CLEARNOT(OK) ; RPC 105 ; clear current user's notifications 106 D CLEARNOT^ORWTPR(.OK,DUZ) 107 Q 108 ; 109 GETNOTO(INFO) ; RPC 110 ; get current user's other info for notifications 111 D GETNOTO^ORWTPR(.INFO,DUZ) 112 Q 113 ; 114 CHKSURR(OK,SURR) ; RPC 115 ; check if current user's surrogate is valid 116 S OK=$$CHKSURR^ORWTPUA(DUZ,SURR) 117 Q 118 ; 119 GETSURR(INFO) ; RPC 120 ; get current user's surrogate info 121 D GETSURR^ORWTPR(.INFO,DUZ) 122 Q 123 ; 124 SAVESURR(OK,INFO) ; RPC 125 ; save current user's surrogate info 126 D SAVESURR^ORWTPR(.OK,INFO,DUZ) 127 Q 128 ; 129 SAVENOTO(OK,INFO) ; RPC 130 ; save current user's notification info 131 D SAVENOTO^ORWTPR(.OK,INFO,DUZ) 132 Q 133 ; 134 GETOTHER(INFO) ; RPC 135 ; get user's other parameter settings 136 D GETOTHER^ORWTPO(.INFO,DUZ) 137 Q 138 ; 139 SETOTHER(OK,INFO) ; RPC 140 ; set current user's other parameter settings 141 D SETOTHER^ORWTPO(.OK,INFO,DUZ) 142 Q 143 ; 144 GETSUB(VALUE) ; RPC 145 ; get Ask for Subject on notes for current user 146 D GETSUB^ORWTPN(.VALUE,DUZ) 147 Q 148 ; 149 GETCOS(VALUES,FROM,DIR,VISITORS) ; RPC 150 ; get elgible cosigners for current user 151 I '$G(VISITORS) S VISITORS="" 152 D GETCOS^ORWTPN(.VALUES,DUZ,FROM,DIR,VISITORS) 153 Q 154 ; 155 GETDCOS(VALUE) ; RPC 156 ; get default cosigner for current user 157 D GETDCOS^ORWTPN(.VALUE,DUZ) 158 Q 159 ; 160 SETDCOS(OK,VALUE) ; RPC 161 ; set default cosigner for current user 162 D SETDCOS^ORWTPN(.OK,VALUE,DUZ) 163 Q 164 ; 165 SETSUB(OK,VALUE) ; RPC 166 ; set Ask for Subject on note for current user 167 D SETSUB^ORWTPN(.OK,VALUE,DUZ) 168 Q 169 ; 170 GETTU(VALUES,CLASS) ; RPC 171 ; get titles for current user 172 D GETTU^ORWTPN(.VALUES,CLASS,DUZ) 173 Q 174 ; 175 GETTD(VALUE,CLASS) ; RPC 176 ; get default title for current user 177 D GETTD^ORWTPN(.VALUE,CLASS,DUZ) 178 Q 179 ; 180 SAVET(OK,CLASS,DEFAULT,VALUES) ; RPC 181 ; save titles for current user 182 D SAVET^ORWTPN(.OK,CLASS,DEFAULT,.VALUES,DUZ) 183 Q 184 ; 185 PLISTS(VALUES) ; RPC 186 ; get current user's personal lists 187 D PLISTS^ORWTPT(.VALUES,DUZ) 188 Q 189 ; 190 PLTEAMS(VALUES) ; RPC 191 ; get current user's teams and personal lists 192 D PLTEAMS^ORWTPT(.VALUES,DUZ) 193 Q 194 ; 195 TEAMS(VALUES) ; RPC 196 ; get teams for current user 197 D TEAMS^ORWTPT(.VALUES,DUZ) 198 Q 199 ; 200 ADDLIST(OK,VALUE) ; RPC 201 ; adds current user to a team 202 D ADDLIST^ORWTPT(.OK,VALUE,DUZ) 203 Q 204 ; 205 REMLIST(OK,VALUE) ; RPC 206 ; removes current user from a team 207 D REMLIST^ORWTPT(.OK,VALUE,DUZ) 208 Q 209 ; 210 GETCOMBO(VALUES) ; RPC 211 ; get current user's combo list definition 212 D GETCOMBO^ORWTPT(.VALUES,DUZ) 213 Q 214 ; 215 SETCOMBO(OK,VALUES) ; RPC 216 ; set current user's combo list definition 217 D SETCOMBO^ORWTPT(.OK,.VALUES,DUZ) 218 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPR.m
r613 r623 1 ORWTPR ; SLC/STAFF Personal Preference - Reminders ; 4/20/07 10:00am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,173,215,243**;Oct 24, 2000;Build 242 3 ; 4 GETREM(VALUES,USER) ; from ORWTPP 5 ; get user's reminders 6 N CLASS,CNT,ERR,IEN,NUM,OK,TMPLIST,ZERO K VALUES 7 D GETLST^XPAR(.TMPLIST,"USR.`"_USER,"ORQQPX SEARCH ITEMS","Q",.ERR) 8 S CNT=0,IEN=0 F S IEN=$O(^PXD(811.9,IEN)) Q:IEN<1 S ZERO=$G(^(IEN,0)) I $L($P(ZERO,U,3)),'$P(ZERO,U,6) D 9 .S CNT=CNT+1 10 .S VALUES(CNT)=IEN_"^0^"_$P(ZERO,U,3)_U_$P(ZERO,U) 11 .S CLASS=$P($G(^PXD(811.9,IEN,100)),U) 12 .S $P(VALUES(CNT),U,5)=$S(CLASS="N":"NATIONAL",CLASS="L":"LOCAL",1:CLASS) 13 .S OK=0,NUM=0 F S NUM=$O(TMPLIST(NUM)) Q:NUM<1 D Q:OK 14 ..I IEN=$P(TMPLIST(NUM),U,2) S OK=1 15 .I OK S $P(VALUES(CNT),U,2)=$P(TMPLIST(NUM),U) 16 Q 17 ; 18 SETREM(OK,VALUES,USER) ; from ORWTPP 19 ; save user's reminders 20 N NUM,ERR 21 S OK=1 22 D NDEL^XPAR("USR.`"_USER,"ORQQPX SEARCH ITEMS",.ERR) 23 S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D 24 .D EN^XPAR(USER_";VA(200,","ORQQPX SEARCH ITEMS",$P(VALUES(NUM),U,1),"`"_$P(VALUES(NUM),U,2),.ERR) 25 Q 26 ; 27 GETOC(VALUES,USER) ; from ORWTPP 28 ; get user's order checks 29 N CNT,IEN,LIST,NUM,VAL,VALOK K LIST,VALUES 30 S IEN=0 F S IEN=$O(^ORD(100.8,IEN)) Q:IEN<1 D 31 .S VAL=$$GET^XPAR("ALL","ORK PROCESSING FLAG",IEN,"I") 32 .I '$L(VAL) Q 33 .S VALOK=$$GET^XPAR("ALL","ORK EDITABLE BY USER",IEN,"I") 34 .S LIST(IEN)=VAL_U_VALOK 35 S NUM=0,CNT=0 F S NUM=$O(LIST(NUM)) Q:NUM<1 D 36 .S CNT=CNT+1 37 .S VALUES(CNT)=NUM_U_$P($G(^ORD(100.8,NUM,0)),U)_U_$S($P(LIST(NUM),U)="E":"ON",1:"OFF")_U_$S($P(LIST(NUM),U,2)="0":"MANDATORY",1:"") 38 Q 39 ; 40 SAVEOC(OK,VALUES,USER) ; from ORWTPP 41 ; save user's order checks 42 N NUM,ERR 43 S OK=1 44 S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D 45 .D EN^XPAR(USER_";VA(200,","ORK PROCESSING FLAG","`"_+VALUES(NUM),$S($P(VALUES(NUM),U,2)="ON":"E",1:"D"),.ERR) 46 Q 47 ; 48 ; 49 GETNOT(VALUES,USER) ; from ORWTPP 50 ; get user's notifications 51 N CNT,IEN,NAME,RESULT K VALUES 52 S CNT=0 53 S NAME="" F S NAME=$O(^ORD(100.9,"B",NAME)) Q:NAME="" D 54 .S IEN=0 F S IEN=$O(^ORD(100.9,"B",NAME,IEN)) Q:IEN<1 D 55 ..S RESULT=$$ONOFF^ORB3USER(IEN,USER,"","") I $L($G(RESULT)) D 56 ...S CNT=CNT+1 57 ...S VALUES(CNT)=IEN_U_NAME_U_$P(RESULT,U)_U_$S($$UP^XLFSTR($P(RESULT,U,3))["MANDATORY":"MANDATORY",1:"") 58 Q 59 ; 60 SAVENOT(OK,VALUES,USER) ; from ORWTPP 61 ; save user's notifications 62 N ERR,NUM 63 S OK=1 64 S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D 65 .D EN^XPAR(USER_";VA(200,","ORB PROCESSING FLAG","`"_+VALUES(NUM),$S($P(VALUES(NUM),U,2)="ON":"E",1:"D"),.ERR) 66 Q 67 ; 68 CLEARNOT(OK,USER) ; from ORWTPP 69 ; clear user's notifications 70 D RECIPURG^XQALBUTL(USER) 71 S OK=1 72 Q 73 ; 74 GETNOTO(INFO,USER) ; from ORWTPP 75 ; get user's other info for notifications 76 I $$GET^XPAR("USR.`"_USER,"ORB FLAGGED ORDERS BULLETIN",1,"Q")="Y" S $P(INFO,U,2)=1 77 I $$GET^XPAR("ALL^USR.`"_USER,"ORB ERASE ALL",1,"Q") S $P(INFO,U,3)=1 78 Q 79 ; 80 GETSURR(INFO,USER) ; from ORWTPP 81 ; get user's surrogate info 82 N SURR 83 D SUROLIST^XQALSURO(USER,.SURR) 84 S INFO=$G(SURR(1)) 85 Q 86 ; 87 SAVESURR(OK,INFO,USER) ; from ORWTPP 88 ; save user's surrogate info 89 N START,STOP,SURR,RET 90 S OK=1 91 S SURR=$P(INFO,U,1) 92 S START=$P(INFO,U,2) 93 S STOP=$P(INFO,U,3) 94 S RET=$$SAVESURR^ORWTPUA(USER,SURR,START,STOP) 95 I 'RET S OK="0^"_RET 96 Q 97 ; 98 SAVENOTO(OK,INFO,USER) ; from ORWTPP 99 ; save user's notification settings 100 N ERR,FLAG,VAL 101 S OK=1 102 S FLAG=$P(INFO,U,3) 103 S VAL=$S(FLAG>0:"Y",1:"@") 104 D EN^XPAR(USER_";VA(200,","ORB FLAGGED ORDERS BULLETIN",1,VAL,.ERR) 105 Q 106 ; 107 OCDESC(TEXT,IEN) ; from RPC 108 N CNT,LINE,NUM K TEXT 109 S IEN=+$G(IEN) I IEN<1 Q 110 S TEXT(1)=$P($G(^ORD(100.8,IEN,0)),U) 111 S TEXT(2)="" 112 S CNT=2 113 S NUM=0 F S NUM=$O(^ORD(100.8,IEN,1,NUM)) Q:NUM<1 S LINE=$G(^(NUM,0)) D 114 .S CNT=CNT+1 115 .S TEXT(CNT)=LINE 116 S TEXT(CNT+1)="" 117 Q 118 ; 119 NOTDESC(TEXT,IEN) ; from RPC 120 K TEXT 121 S IEN=+$G(IEN) I IEN<1 Q 122 S TEXT(1)=$P($G(^ORD(100.9,IEN,0)),U) 123 S TEXT(2)="" 124 S TEXT(3)=$P($G(^ORD(100.9,IEN,4)),U) 125 S TEXT(4)="" 126 Q 1 ORWTPR ; SLC/STAFF Personal Preference - Reminders ;5/3/01 15:32 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,173,215**;Oct 24, 2000 3 ; 4 GETREM(VALUES,USER) ; from ORWTPP 5 ; get user's reminders 6 N CLASS,CNT,ERR,IEN,NUM,OK,TMPLIST,ZERO K VALUES 7 D GETLST^XPAR(.TMPLIST,"USR.`"_USER,"ORQQPX SEARCH ITEMS","Q",.ERR) 8 S CNT=0,IEN=0 F S IEN=$O(^PXD(811.9,IEN)) Q:IEN<1 S ZERO=$G(^(IEN,0)) I $L($P(ZERO,U,3)),'$P(ZERO,U,6) D 9 .S CNT=CNT+1 10 .S VALUES(CNT)=IEN_"^0^"_$P(ZERO,U,3)_U_$P(ZERO,U) 11 .S CLASS=$P($G(^PXD(811.9,IEN,100)),U) 12 .S $P(VALUES(CNT),U,5)=$S(CLASS="N":"NATIONAL",CLASS="L":"LOCAL",1:CLASS) 13 .S OK=0,NUM=0 F S NUM=$O(TMPLIST(NUM)) Q:NUM<1 D Q:OK 14 ..I IEN=$P(TMPLIST(NUM),U,2) S OK=1 15 .I OK S $P(VALUES(CNT),U,2)=$P(TMPLIST(NUM),U) 16 Q 17 ; 18 SETREM(OK,VALUES,USER) ; from ORWTPP 19 ; save user's reminders 20 N NUM,ERR 21 S OK=1 22 D NDEL^XPAR("USR.`"_USER,"ORQQPX SEARCH ITEMS",.ERR) 23 S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D 24 .D EN^XPAR(USER_";VA(200,","ORQQPX SEARCH ITEMS",$P(VALUES(NUM),U,1),"`"_$P(VALUES(NUM),U,2),.ERR) 25 Q 26 ; 27 GETOC(VALUES,USER) ; from ORWTPP 28 ; get user's order checks 29 N CNT,IEN,LIST,NUM,VAL,VALOK K LIST,VALUES 30 S IEN=0 F S IEN=$O(^ORD(100.8,IEN)) Q:IEN<1 D 31 .S VAL=$$GET^XPAR("ALL","ORK PROCESSING FLAG",IEN,"I") 32 .I '$L(VAL) Q 33 .S VALOK=$$GET^XPAR("ALL","ORK EDITABLE BY USER",IEN,"I") 34 .S LIST(IEN)=VAL_U_VALOK 35 S NUM=0,CNT=0 F S NUM=$O(LIST(NUM)) Q:NUM<1 D 36 .S CNT=CNT+1 37 .S VALUES(CNT)=NUM_U_$P($G(^ORD(100.8,NUM,0)),U)_U_$S($P(LIST(NUM),U)="E":"ON",1:"OFF")_U_$S($P(LIST(NUM),U,2)="0":"MANDATORY",1:"") 38 Q 39 ; 40 SAVEOC(OK,VALUES,USER) ; from ORWTPP 41 ; save user's order checks 42 N NUM,ERR 43 S OK=1 44 S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D 45 .D EN^XPAR(USER_";VA(200,","ORK PROCESSING FLAG","`"_+VALUES(NUM),$S($P(VALUES(NUM),U,2)="ON":"E",1:"D"),.ERR) 46 Q 47 ; 48 ; 49 GETNOT(VALUES,USER) ; from ORWTPP 50 ; get user's notifications 51 N CNT,IEN,NAME,RESULT K VALUES 52 S CNT=0 53 S NAME="" F S NAME=$O(^ORD(100.9,"B",NAME)) Q:NAME="" D 54 .S IEN=0 F S IEN=$O(^ORD(100.9,"B",NAME,IEN)) Q:IEN<1 D 55 ..S RESULT=$$ONOFF^ORB3USER(IEN,USER,"","") I $L($G(RESULT)) D 56 ...S CNT=CNT+1 57 ...S VALUES(CNT)=IEN_U_NAME_U_$P(RESULT,U)_U_$S($$UP^XLFSTR($P(RESULT,U,3))["MANDATORY":"MANDATORY",1:"") 58 Q 59 ; 60 SAVENOT(OK,VALUES,USER) ; from ORWTPP 61 ; save user's notifications 62 N ERR,NUM 63 S OK=1 64 S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D 65 .D EN^XPAR(USER_";VA(200,","ORB PROCESSING FLAG","`"_+VALUES(NUM),$S($P(VALUES(NUM),U,2)="ON":"E",1:"D"),.ERR) 66 Q 67 ; 68 CLEARNOT(OK,USER) ; from ORWTPP 69 ; clear user's notifications 70 D RECIPURG^XQALBUTL(USER) 71 S OK=1 72 Q 73 ; 74 GETNOTO(INFO,USER) ; from ORWTPP 75 ; get user's other info for notifications 76 I $$GET^XPAR("USR.`"_USER,"ORB FLAGGED ORDERS BULLETIN",1,"Q")="Y" S $P(INFO,U,2)=1 77 I $$GET^XPAR("ALL^USR.`"_USER,"ORB ERASE ALL",1,"Q") S $P(INFO,U,3)=1 78 Q 79 ; 80 GETSURR(INFO,USER) ; from ORWTPP 81 ; get user's surrogate info 82 N SURR 83 D SUROLIST^XQALSURO(USER,.SURR) 84 S INFO=$G(SURR(1)) 85 Q 86 ; 87 SAVESURR(OK,INFO,USER) ; from ORWTPP 88 ; save user's surrogate info 89 N START,STOP,SURR 90 S OK=1 91 S SURR=$P(INFO,U,1) 92 S START=$P(INFO,U,2) 93 S STOP=$P(INFO,U,3) 94 D SAVESURR^ORWTPUA(USER,SURR,START,STOP) 95 Q 96 ; 97 SAVENOTO(OK,INFO,USER) ; from ORWTPP 98 ; save user's notification settings 99 N ERR,FLAG,VAL 100 S OK=1 101 S FLAG=$P(INFO,U,3) 102 S VAL=$S(FLAG>0:"Y",1:"@") 103 D EN^XPAR(USER_";VA(200,","ORB FLAGGED ORDERS BULLETIN",1,VAL,.ERR) 104 Q 105 ; 106 OCDESC(TEXT,IEN) ; from RPC 107 N CNT,LINE,NUM K TEXT 108 S IEN=+$G(IEN) I IEN<1 Q 109 S TEXT(1)=$P($G(^ORD(100.8,IEN,0)),U) 110 S TEXT(2)="" 111 S CNT=2 112 S NUM=0 F S NUM=$O(^ORD(100.8,IEN,1,NUM)) Q:NUM<1 S LINE=$G(^(NUM,0)) D 113 .S CNT=CNT+1 114 .S TEXT(CNT)=LINE 115 S TEXT(CNT+1)="" 116 Q 117 ; 118 NOTDESC(TEXT,IEN) ; from RPC 119 K TEXT 120 S IEN=+$G(IEN) I IEN<1 Q 121 S TEXT(1)=$P($G(^ORD(100.9,IEN,0)),U) 122 S TEXT(2)="" 123 S TEXT(3)=$P($G(^ORD(100.9,IEN,4)),U) 124 S TEXT(4)="" 125 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPT.m
r613 r623 1 ORWTPT ; SLC/STAFF Personal Preference - Teams ;5/4/01 15:55 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,243**;Oct 24, 2000;Build 242 3 ; 4 GETTEAM(USERS,TEAM) ; RPC 5 ; returns members of a team 6 N CNT,NAME,NUM,USER K USERS 7 S TEAM=+$G(TEAM),CNT=0 8 S NUM=0 F S NUM=$O(^OR(100.21,TEAM,1,NUM)) Q:NUM<1 S USER=+$G(^(NUM,0)) D 9 .S NAME=$P($G(^VA(200,USER,0)),U) 10 .I '$L(NAME) Q 11 .S CNT=CNT+1 12 .S USERS(CNT)=USER_U_NAME 13 Q 14 ; 15 TEAMS(TEAMS,USER) ; from ORWTPP 16 ; returns all teams a user is a member of (exculdes personal lists) 17 N CNT,NUM,ZERO K TEAMS 18 S USER=+$G(USER),CNT=0 19 S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D 20 .S ZERO=$G(^OR(100.21,NUM,0)) 21 .I $P(ZERO,U,2)="P" Q 22 .S CNT=CNT+1 23 .S TEAMS(CNT)=NUM_U_ZERO 24 Q 25 ; 26 PLISTS(TEAMS,USER) ; from ORWTPP 27 ; returns a user's personal lists 28 N CNT,NUM,ZERO K TEAMS 29 S USER=+$G(USER),CNT=0 30 S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D 31 .S ZERO=$G(^OR(100.21,NUM,0)) 32 .I $P(ZERO,U,2)'="P" Q 33 .S CNT=CNT+1 34 .N VIS S VIS=$P($G(^OR(100.21,NUM,11)),U) 35 .I '$L(VIS) S VIS=1 36 .S TEAMS(CNT)=NUM_U_ZERO_U_VIS 37 Q 38 ; 39 PLTEAMS(TEAMS,USER) ; from ORWTPP 40 ; returns all teams and personal lists for a user 41 N CNT,NUM,ZERO K TEAMS 42 S USER=+$G(USER),CNT=0 43 S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D 44 .S ZERO=$G(^OR(100.21,NUM,0)) 45 .S CNT=CNT+1 46 .S TEAMS(CNT)=NUM_U_ZERO 47 Q 48 ; 49 ATEAMS(TEAMS) ; RPC 50 ; all teams available to subscribe to 51 N CNT,NAME,NODE,NUM K TEAMS 52 S CNT=0 53 S NUM=0 F S NUM=$O(^OR(100.21,NUM)) Q:NUM<1 S NODE=$G(^(NUM,0)) D 54 .I $P(NODE,U,6)'="Y" Q 55 .I $P(NODE,U,2)="P" Q 56 .S CNT=CNT+1 57 .S TEAMS(CNT)=NUM_U_NODE ;$P(NODE,U) 58 Q 59 ; 60 ADDLIST(OK,VALUE,USER) ; from ORWTPP 61 ; adds a user to a team 62 N DA,DIC,DLAYGO,X,Y K DA,DIC,DLAYGO 63 S USER=+$G(USER) 64 S DA=USER,DA(1)=+$G(VALUE),OK=1 65 I '$D(^OR(100.21,DA(1),0)) Q 66 S DIC(0)="LM" 67 S DLAYGO=100.212 68 S X=$P($G(^VA(200,USER,0)),U) 69 S DIC="^OR(100.21,"_DA(1)_",1," 70 D 71 .L +^OR(100.21,DA(1)):5 I '$T Q 72 .D ^DIC 73 .L -^OR(100.21,DA(1)) 74 I Y=-1 S OK=0 75 K DA,DIC,DLAYGO 76 Q 77 ; 78 REMLIST(OK,VALUE,USER) ; from ORWTPP 79 ; removes a user from a team 80 N DA,DIK K DA 81 S DA=+$G(USER),DA(1)=+$G(VALUE),OK=1 82 I '$D(^OR(100.21,DA(1),0)) Q 83 S DIK="^OR(100.21,"_DA(1)_",1," 84 D 85 .L +^OR(100.21,DA(1)):5 I '$T S OK=0 Q 86 .D ^DIK 87 .L -^OR(100.21,DA(1)) 88 K DA,DIK 89 Q 90 ; 91 GETCOMBO(VALUES,USER) ; from ORWTPP 92 ; get user's combo list definition 93 N CNT,IEN,NAME,NODE,NUM,SOURCE K VALUES 94 S USER=+$G(USER) 95 I '$D(^OR(100.24,USER,0)) Q 96 S CNT=0 97 S NUM=0 F S NUM=$O(^OR(100.24,USER,.01,NUM)) Q:NUM<1 S NODE=$G(^(NUM,0)) D 98 .I '$L(NODE) Q 99 .S IEN=+NODE,SOURCE=$P(NODE,";",2),NAME="" 100 .D 101 ..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q 102 ..I SOURCE="VA(200," S SOURCE="PROVIDER",NAME=$P($G(^VA(200,IEN,0)),U) Q 103 ..I SOURCE="DIC(45.7," S SOURCE="SPECIALTY",NAME=$P($G(^DIC(45.7,IEN,0)),U) Q 104 ..I SOURCE="OR(100.21," S SOURCE="LIST",NAME=$P($G(^OR(100.21,IEN,0)),U) Q 105 ..I SOURCE="SC(" S SOURCE="CLINIC",NAME=$P($G(^SC(IEN,0)),U) Q 106 ..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q 107 .I '$L(NAME) Q 108 .S CNT=CNT+1 109 .S VALUES(CNT)=SOURCE_U_NAME_U_IEN 110 Q 111 ; 112 SETCOMBO(OK,VALUES,USER) ; from ORWTPP 113 ; set user's combo list definition 114 N CNT,DA,DIK,IEN,NUM,NVALUES,SOURCE,SOURCENM K NVALUES 115 S USER=+$G(USER),OK=1 116 I 'USER Q 117 S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D 118 .S IEN=+VALUES(NUM),SOURCENM=$$UP^XLFSTR($P(VALUES(NUM),U,2)),SOURCE="" 119 .I 'IEN Q 120 .I SOURCENM="WARD" S SOURCE=";DIC(42," 121 .I SOURCENM="PROVIDER" S SOURCE=";VA(200," 122 .I SOURCENM="SPECIALTY" S SOURCE=";DIC(45.7," 123 .I SOURCENM="LIST" S SOURCE=";OR(100.21," 124 .I SOURCENM="CLINIC" S SOURCE=";SC(" 125 .I '$L(SOURCE) Q 126 .S NVALUES(NUM)=IEN_SOURCE 127 I '$D(^OR(100.24,USER,0)) D I '$D(^OR(100.24,USER,0)) Q 128 .L +^OR(100.24,0):5 I '$T S OK=0 Q 129 .S ^OR(100.24,USER,0)=USER 130 .S $P(^OR(100.24,0),U,4)=$P(^OR(100.24,0),U,4)+1,$P(^(0),U,3)=USER 131 .L -^OR(100.24,0) 132 S CNT=0,DA=USER,DIK="^OR(100.24," 133 L +^OR(100.24,USER,0):5 I '$T Q 134 K ^OR(100.24,USER,.01) 135 S NUM=0 F S NUM=$O(NVALUES(NUM)) Q:NUM<1 D 136 .S CNT=CNT+1 137 .S ^OR(100.24,USER,.01,CNT,0)=NVALUES(NUM) 138 S ^OR(100.24,USER,.01,0)="^100.241V^"_CNT_U_CNT 139 D IX1^DIK 140 L -^OR(100.24,USER,0) 141 K NVALUES 142 Q 1 ORWTPT ; SLC/STAFF Personal Preference - Teams ;5/4/01 16:01 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85**;Oct 24, 2000 3 ; 4 GETTEAM(USERS,TEAM) ; RPC 5 ; returns members of a team 6 N CNT,NAME,NUM,USER K USERS 7 S TEAM=+$G(TEAM),CNT=0 8 S NUM=0 F S NUM=$O(^OR(100.21,TEAM,1,NUM)) Q:NUM<1 S USER=+$G(^(NUM,0)) D 9 .S NAME=$P($G(^VA(200,USER,0)),U) 10 .I '$L(NAME) Q 11 .S CNT=CNT+1 12 .S USERS(CNT)=USER_U_NAME 13 Q 14 ; 15 TEAMS(TEAMS,USER) ; from ORWTPP 16 ; returns all teams a user is a member of (exculdes personal lists) 17 N CNT,NUM,ZERO K TEAMS 18 S USER=+$G(USER),CNT=0 19 S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D 20 .S ZERO=$G(^OR(100.21,NUM,0)) 21 .I $P(ZERO,U,2)="P" Q 22 .S CNT=CNT+1 23 .S TEAMS(CNT)=NUM_U_ZERO 24 Q 25 ; 26 PLISTS(TEAMS,USER) ; from ORWTPP 27 ; returns a user's personal lists 28 N CNT,NUM,ZERO K TEAMS 29 S USER=+$G(USER),CNT=0 30 S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D 31 .S ZERO=$G(^OR(100.21,NUM,0)) 32 .I $P(ZERO,U,2)'="P" Q 33 .S CNT=CNT+1 34 .S TEAMS(CNT)=NUM_U_ZERO 35 Q 36 ; 37 PLTEAMS(TEAMS,USER) ; from ORWTPP 38 ; returns all teams and personal lists for a user 39 N CNT,NUM,ZERO K TEAMS 40 S USER=+$G(USER),CNT=0 41 S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D 42 .S ZERO=$G(^OR(100.21,NUM,0)) 43 .S CNT=CNT+1 44 .S TEAMS(CNT)=NUM_U_ZERO 45 Q 46 ; 47 ATEAMS(TEAMS) ; RPC 48 ; all teams available to subscribe to 49 N CNT,NAME,NODE,NUM K TEAMS 50 S CNT=0 51 S NUM=0 F S NUM=$O(^OR(100.21,NUM)) Q:NUM<1 S NODE=$G(^(NUM,0)) D 52 .I $P(NODE,U,6)'="Y" Q 53 .I $P(NODE,U,2)="P" Q 54 .S CNT=CNT+1 55 .S TEAMS(CNT)=NUM_U_NODE ;$P(NODE,U) 56 Q 57 ; 58 ADDLIST(OK,VALUE,USER) ; from ORWTPP 59 ; adds a user to a team 60 N DA,DIC,DLAYGO,X,Y K DA,DIC,DLAYGO 61 S USER=+$G(USER) 62 S DA=USER,DA(1)=+$G(VALUE),OK=1 63 I '$D(^OR(100.21,DA(1),0)) Q 64 S DIC(0)="LM" 65 S DLAYGO=100.212 66 S X=$P($G(^VA(200,USER,0)),U) 67 S DIC="^OR(100.21,"_DA(1)_",1," 68 D 69 .L +^OR(100.21,DA(1)):5 I '$T Q 70 .D ^DIC 71 .L -^OR(100.21,DA(1)) 72 I Y=-1 S OK=0 73 K DA,DIC,DLAYGO 74 Q 75 ; 76 REMLIST(OK,VALUE,USER) ; from ORWTPP 77 ; removes a user from a team 78 N DA,DIK K DA 79 S DA=+$G(USER),DA(1)=+$G(VALUE),OK=1 80 I '$D(^OR(100.21,DA(1),0)) Q 81 S DIK="^OR(100.21,"_DA(1)_",1," 82 D 83 .L +^OR(100.21,DA(1)):5 I '$T S OK=0 Q 84 .D ^DIK 85 .L -^OR(100.21,DA(1)) 86 K DA,DIK 87 Q 88 ; 89 GETCOMBO(VALUES,USER) ; from ORWTPP 90 ; get user's combo list definition 91 N CNT,IEN,NAME,NODE,NUM,SOURCE K VALUES 92 S USER=+$G(USER) 93 I '$D(^OR(100.24,USER,0)) Q 94 S CNT=0 95 S NUM=0 F S NUM=$O(^OR(100.24,USER,.01,NUM)) Q:NUM<1 S NODE=$G(^(NUM,0)) D 96 .I '$L(NODE) Q 97 .S IEN=+NODE,SOURCE=$P(NODE,";",2),NAME="" 98 .D 99 ..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q 100 ..I SOURCE="VA(200," S SOURCE="PROVIDER",NAME=$P($G(^VA(200,IEN,0)),U) Q 101 ..I SOURCE="DIC(45.7," S SOURCE="SPECIALTY",NAME=$P($G(^DIC(45.7,IEN,0)),U) Q 102 ..I SOURCE="OR(100.21," S SOURCE="LIST",NAME=$P($G(^OR(100.21,IEN,0)),U) Q 103 ..I SOURCE="SC(" S SOURCE="CLINIC",NAME=$P($G(^SC(IEN,0)),U) Q 104 ..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q 105 .I '$L(NAME) Q 106 .S CNT=CNT+1 107 .S VALUES(CNT)=SOURCE_U_NAME_U_IEN 108 Q 109 ; 110 SETCOMBO(OK,VALUES,USER) ; from ORWTPP 111 ; set user's combo list definition 112 N CNT,DA,DIK,IEN,NUM,NVALUES,SOURCE,SOURCENM K NVALUES 113 S USER=+$G(USER),OK=1 114 I 'USER Q 115 S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D 116 .S IEN=+VALUES(NUM),SOURCENM=$$UP^XLFSTR($P(VALUES(NUM),U,2)),SOURCE="" 117 .I 'IEN Q 118 .I SOURCENM="WARD" S SOURCE=";DIC(42," 119 .I SOURCENM="PROVIDER" S SOURCE=";VA(200," 120 .I SOURCENM="SPECIALTY" S SOURCE=";DIC(45.7," 121 .I SOURCENM="LIST" S SOURCE=";OR(100.21," 122 .I SOURCENM="CLINIC" S SOURCE=";SC(" 123 .I '$L(SOURCE) Q 124 .S NVALUES(NUM)=IEN_SOURCE 125 I '$D(^OR(100.24,USER,0)) D I '$D(^OR(100.24,USER,0)) Q 126 .L +^OR(100.24,0):5 I '$T S OK=0 Q 127 .S ^OR(100.24,USER,0)=USER 128 .S $P(^OR(100.24,0),U,4)=$P(^OR(100.24,0),U,4)+1,$P(^(0),U,3)=USER 129 .L -^OR(100.24,0) 130 S CNT=0,DA=USER,DIK="^OR(100.24," 131 L +^OR(100.24,USER,0):5 I '$T Q 132 K ^OR(100.24,USER,.01) 133 S NUM=0 F S NUM=$O(NVALUES(NUM)) Q:NUM<1 D 134 .S CNT=CNT+1 135 .S ^OR(100.24,USER,.01,CNT,0)=NVALUES(NUM) 136 S ^OR(100.24,USER,.01,0)="^100.241V^"_CNT_U_CNT 137 D IX1^DIK 138 L -^OR(100.24,USER,0) 139 K NVALUES 140 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPUA.m
r613 r623 1 ORWTPUA ; SLC/STAFF Personal Preference - Utility Alerts ; 4/20/07 10:01am 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,243**;Oct 24, 2000;Build 242 3 ; 4 START(USER) ; $$(user) -> user's surrogate start date/time 5 Q $P($G(^XTV(8992,+$G(USER),0)),U,3) 6 ; 7 STOP(USER) ; $$(user) -> user's surrogate stop date/time 8 Q $P($G(^XTV(8992,+$G(USER),0)),U,4) 9 ; 10 CHKSURR(USER,SURR) ; $$(user,surrogate) -> 1 if ok else 0^reason for reject 11 N OK,START 12 S USER=+$G(USER),SURR=+$G(SURR) 13 I USER=SURR Q "0^You cannot specify yourself as your own surrogate!" 14 S START=$$GET1^DIQ(8992,(SURR_","),.02,"I") 15 I START<.5 Q 1 16 I START=USER Q "0^You are designated as the surrogate for this user - can't do it!" 17 S OK=1 F S START=$$GET1^DIQ(8992,(START_","),.02,"I") Q:START'>0 I START=USER S OK=0 Q 18 I 'OK Q "0^This forms a circle which leads back to you - can't do it!" 19 Q 1 20 ; 21 GETSURR(USER) ; $$(user ien) -> surrogate ien 22 Q $$CURRSURO^XQALSURO(+$G(USER)) 23 ; 24 SAVESURR(USER,SURR,START,STOP) ; save user's surrogate info 25 N RET 26 D REMVSURO^XQALSURO(USER) 27 S RET=$$SETSURO1^XQALSURO(USER,SURR,START,STOP) 28 Q RET 1 ORWTPUA ; SLC/STAFF Personal Preference - Utility Alerts ;5/22/00 09:58 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85**;Oct 24, 2000 3 ; 4 START(USER) ; $$(user) -> user's surrogate start date/time 5 Q $P($G(^XTV(8992,+$G(USER),0)),U,3) 6 ; 7 STOP(USER) ; $$(user) -> user's surrogate stop date/time 8 Q $P($G(^XTV(8992,+$G(USER),0)),U,4) 9 ; 10 CHKSURR(USER,SURR) ; $$(user,surrogate) -> 1 if ok else 0^reason for reject 11 N OK,START 12 S USER=+$G(USER),SURR=+$G(SURR) 13 I USER=SURR Q "0^You cannot specify yourself as your own surrogate!" 14 S START=$$GET1^DIQ(8992,(SURR_","),.02,"I") 15 I START<.5 Q 1 16 I START=USER Q "0^You are designated as the surrogate for this user - can't do it!" 17 S OK=1 F S START=$$GET1^DIQ(8992,(START_","),.02,"I") Q:START'>0 I START=USER S OK=0 Q 18 I 'OK Q "0^This forms a circle which leads back to you - can't do it!" 19 Q 1 20 ; 21 GETSURR(USER) ; $$(user ien) -> surrogate ien 22 Q $$CURRSURO^XQALSURO(+$G(USER)) 23 ; 24 SAVESURR(USER,SURR,START,STOP) ; save user's surrogate info 25 D REMVSURO^XQALSURO(USER) 26 D SETSURO^XQALSURO(USER,SURR,START,STOP) 27 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWU.m
r613 r623 1 ORWU ; SLC/KCM - General Utilites for Windows Calls; 2/28/01 [1/15/04 11:43am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,148,149,187,195,215,243**;Dec 17, 1997;Build 242 3 ; 4 DT(Y,X,%DT) ; Internal Fileman Date/Time 5 ; change the '00:00' that could be passed so Fileman doesn't reject 6 I $L($P(X,"@",2)),("00000000"[$TR($P(X,"@",2),":","")) S $P(X,"@",2)="00:00:01" 7 S %DT=$G(%DT,"TS") D ^%DT K %DT 8 Q 9 VALDT(Y,X,%DT) ; Validate date/time 10 S:'$D(%DT) %DT="TX" D ^%DT 11 Q 12 USERINFO(REC) ; Relevant info for current user 13 ; return DUZ^NAME^USRCLS^CANSIGN^ISPROVIDER^ORDERROLE^NOORDER^DTIME^ 14 ; COUNTDOWN^ENABLEVERIFY^NOTIFYAPPS^MSGHANG^DOMAIN^SERVICE^ 15 ; AUTOSAVE^INITTAB^LASTTAB^WEBACCESS^ALLOWHOLD^ISRPL^RPLLIST^ 16 ; CORTABS^RPTTAB^STANUM^GECSTATUS^PRODACCT 17 N X,ORRPL,ORRPL1,ORRPL2,ORTAB,CORTABS,RPTTAB,ORDT,OREFF,OREXP,ORDATEOK 18 S REC=DUZ_U_$P(^VA(200,DUZ,0),U) 19 S $P(REC,U,3)=$S($D(^XUSEC("ORES",DUZ)):3,$D(^XUSEC("ORELSE",DUZ)):2,$D(^XUSEC("OREMAS",DUZ)):1,1:0) 20 S $P(REC,U,4)=$D(^XUSEC("ORES",DUZ))&$D(^XUSEC("PROVIDER",DUZ)) 21 S $P(REC,U,5)=$D(^XUSEC("PROVIDER",DUZ)) 22 S $P(REC,U,6)=$$ORDROLE 23 S $P(REC,U,7)=$$GET^XPAR("USR^SYS^PKG","ORWOR DISABLE ORDERING",1,"I") 24 S $P(REC,U,8)=$$GET^XPAR("USR^SYS","ORWOR TIMEOUT CHART",1,"I") 25 I '$P(REC,U,8),$G(DTIME) S $P(REC,U,8)=DTIME 26 S $P(REC,U,9)=$$GET^XPAR("USR^SYS^PKG","ORWOR TIMEOUT COUNTDOWN",1,"I") 27 S X=$$GET^XPAR("USR^SYS^PKG","ORWOR ENABLE VERIFY",1,"I") 28 S $P(REC,U,10)=$S(X=1:1,X=2:0,1:'$P(REC,U,7)) 29 S $P(REC,U,11)=$$GET^XPAR("USR^SYS^PKG","ORWOR BROADCAST MESSAGES",1,"I") 30 S $P(REC,U,12)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTO CLOSE PT MSG",1,"I") 31 S $P(REC,U,13)=$$KSP^XUPARAM("WHERE") ; domain 32 S $P(REC,U,14)=+$G(^VA(200,DUZ,5)) ; service/section 33 S $P(REC,U,15)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTOSAVE NOTE",1,"I") 34 S $P(REC,U,16)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH INITIAL TAB",1,"I") 35 S $P(REC,U,17)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH USE LAST TAB",1,"I") 36 S $P(REC,U,18)=$$GET^XPAR("USR^DIV^SYS^PKG","ORWOR DISABLE WEB ACCESS",1,"I") 37 S $P(REC,U,19)=$$GET^XPAR("SYS^PKG","ORWOR DISABLE HOLD ORDERS",1,"I") 38 ; 2 pieces added by PKS on 11/5/2001 for "Reports Only:" 39 ; IA# 10060 allows read access to ^VA(200 file. 40 S ORRPL=$G(^VA(200,DUZ,101)) ; RPL node. 41 S ORRPL1=$P(ORRPL,U) 42 S $P(REC,U,20)=ORRPL1 ; ISRPL piece. 43 S ORRPL2=$P(ORRPL,U,2) 44 S $P(REC,U,21)=ORRPL2 ; RPLLIST piece. 45 ; 46 ; Additional pieces for CPRS tabs access: 47 ; IA# 10060 allows read access to ^VA(200.01013 multiple. 48 S ORDT=DT ; Today. 49 S (CORTABS,RPTTAB)=0 50 S ORRPL=0 51 F S ORRPL=$O(^VA(200,DUZ,"ORD",ORRPL)) Q:ORRPL<1 D 52 .S ORTAB=$G(^VA(200,DUZ,"ORD",ORRPL,0)) 53 .I ORTAB="" Q 54 .S OREFF=$P(ORTAB,U,2) 55 .S OREXP=$P(ORTAB,U,3) 56 .S ORTAB=$P(ORTAB,U) 57 .I ORTAB="" Q 58 .S ORTAB=$G(^ORD(101.13,ORTAB,0)) 59 .I ORTAB="" Q 60 .S ORTAB=$P(ORTAB,U) 61 .I ORTAB="" Q 62 .S ORTAB=$$UP^XLFSTR(ORTAB) 63 .S ORDATEOK=1 ; Default. 64 .I ((OREFF="")!(OREFF>ORDT)) S ORDATEOK=0 ; Eff. date NG. 65 .I ORDATEOK D 66 ..I OREXP="" Q ; No exp. date. 67 ..I (OREXP<ORDT) S ORDATEOK=0 ; Exp. date NG. 68 ..I (OREXP=ORDT) S ORDATEOK=0 ; Exp. date NG. 69 .; 70 .; Set TRUE if OK: 71 .I ((ORTAB="COR")&(ORDATEOK)) S CORTABS=1 72 .I ((ORTAB="RPT")&(ORDATEOK)) S RPTTAB=1 73 ; 74 ; When done, set all valid tabs for access: 75 S $P(REC,U,22)=CORTABS ; "Core" tabs. 76 S $P(REC,U,23)=RPTTAB ; "Reports" tab. 77 ; 78 S $P(REC,U,24)=$P($$SITE^VASITE,U,3) 79 S $P(REC,U,25)=$$GET^XPAR("USR^TEA","PXRM GEC STATUS CHECK",1,"I") 80 S $P(REC,U,26)=$$PROD^XUPROD 81 Q 82 ; 83 HASKEY(VAL,KEY) ; returns TRUE if the user possesses the security key 84 S VAL=''$D(^XUSEC(KEY,DUZ)) 85 Q 86 HASOPTN(VAL,OPTION) ; returns TRUE if the user has access to a menu option 87 S VAL=+$$ACCESS^XQCHK(DUZ,OPTION) 88 I VAL'>0 S VAL=0 89 E S VAL=1 90 Q 91 NPHASKEY(VAL,NP,KEY) ; returns TRUE if the person has the security key 92 S VAL=''$D(^XUSEC(KEY,NP)) 93 Q 94 ORDROLE() ; returns the role a person takes in ordering 95 ; VAL: 0=nokey, 1=clerk, 2=nurse, 3=physician, 4=student, 5=bad keys 96 ;I '$G(ORWCLVER) Q 0 ; version of client is to old for ordering 97 I ($D(^XUSEC("OREMAS",DUZ))+$D(^XUSEC("ORELSE",DUZ))+$D(^XUSEC("ORES",DUZ)))>1 Q 5 98 I $D(^XUSEC("OREMAS",DUZ)) Q 1 ; clerk 99 I $D(^XUSEC("ORELSE",DUZ)) Q 2 ; nurse 100 I $D(^XUSEC("ORES",DUZ)),$D(^XUSEC("PROVIDER",DUZ)) Q 3 ; doctor 101 I $D(^XUSEC("PROVIDER",DUZ)) Q 4 ; student 102 Q 0 103 VALIDSIG(ESOK,X) ; returns TRUE if valid electronic signature 104 S X=$$DECRYP^XUSRB1(X),ESOK=0 ; network encrypted 105 D HASH^XUSHSHP 106 I X=$P($G(^VA(200,+DUZ,20)),U,4) S ESOK=1 107 Q 108 TOOLMENU(ORLST) ; returns a list of items for the Tools menu 109 N ANENT 110 S ANENT="ALL^"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"") 111 D GETLST^XPAR(.ORLST,ANENT,"ORWT TOOLS MENU","N") 112 Q 113 ACTLOC(LOC) ; Function: returns TRUE if active hospital location 114 ; IA# 10040. 115 N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; screen out OOS entry 116 S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; chk out of svc wards 117 S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inactivate date 118 I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0 ; chk reactivate date 119 Q 1 ; must still be active 120 ; 121 CLINLOC(Y,FROM,DIR) ; Return a set of clinics from HOSPITAL LOCATION 122 ; .Y=returned list, FROM=text to $O from, DIR=$O direction, 123 N I,IEN,CNT S I=0,CNT=44 124 F Q:I'<CNT S FROM=$O(^SC("B",FROM),DIR) Q:FROM="" D ; IA# 10040. 125 . S IEN="" F S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN D 126 . . I ($P($G(^SC(IEN,0)),U,3)'="C")!('$$ACTLOC(IEN)) Q 127 . . S I=I+1,Y(I)=IEN_"^"_FROM 128 Q 129 INPLOC(Y,FROM,DIR) ;Return a set of wards from HOSPITAL LOCATION 130 ; .Y=returned list, FROM=text to $O from, DIR=$O direction, 131 N I,IEN,CNT S I=0,CNT=44 132 F Q:I'<CNT S FROM=$O(^SC("B",FROM),DIR) Q:FROM="" D ; IA# 10040. 133 . S IEN="" F S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN D 134 . . I ($P($G(^SC(IEN,0)),U,3)'="W") Q 135 . . I '$$ACTLOC(IEN) Q 136 . . S I=I+1,Y(I)=IEN_"^"_FROM 137 Q 138 HOSPLOC(Y,FROM,DIR) ; Return a set of locations from HOSPITAL LOCATION 139 ; .Y=returned list, FROM=text to $O from, DIR=$O direction, 140 N I,IEN,CNT S I=0,CNT=44 141 F Q:I'<CNT S FROM=$O(^SC("B",FROM),DIR) Q:FROM="" D ; IA# 10040. 142 . S IEN="" F S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN D 143 . . Q:("CW"'[$P($G(^SC(IEN,0)),U,3)!('$$ACTLOC(IEN))) 144 . . S I=I+1,Y(I)=IEN_"^"_FROM 145 Q 146 NEWPERS(ORY,ORFROM,ORDIR,ORKEY,ORDATE,ORVIZ,ORALL) ; Return a set of names from the NEW PERSON file. 147 ; SLC/PKS: Code moved to ORWU1 on 12/3/2002. 148 D NP1^ORWU1 149 Q 150 GBLREF(VAL,FN) ; return global reference for file number 151 S VAL="" Q:'FN 152 S VAL=$$ROOT^DILFD(+FN) 153 ; I $E($RE(VAL))="," S VAL=$E(VAL,1,$L(VAL)-1)_")" 154 ; I $E($RE(VAL))="(" S VAL=$P(VAL,"(",1) 155 Q 156 GENERIC(Y,FROM,DIR,REF) ; Return a set of entries from xref in REF 157 ; .Y=returned list, FROM=text to $O from, DIR=$O direction, 158 N I,IEN,CNT S I=0,CNT=44 159 F Q:I'<CNT S FROM=$O(@REF@(FROM),DIR) Q:FROM="" D 160 . S IEN="" F S IEN=$O(@REF@(FROM,IEN),DIR) Q:'IEN D 161 . . S I=I+1,Y(I)=IEN_"^"_FROM 162 Q 163 EXTNAME(VAL,IEN,FN) ; return external form of pointer 164 ; IEN=internal number, FN=file number 165 N REF S REF=$G(^DIC(FN,0,"GL")),VAL="" 166 I $L(REF),+IEN S VAL=$P($G(@(REF_IEN_",0)")),U) 167 Q 168 PARAM(VAL,APARAM) ; return a parameter value for a user 169 ; call assumes current user, default entities, single instance 170 S VAL=$$GET^XPAR("ALL",APARAM,1,"I") 171 Q 172 PARAMS(ORLIST,APARAM) ; return a list of parameter values 173 ; call assumes current user, default entities, multiple instances 174 D GETLST^XPAR(.ORLIST,"ALL",APARAM,"Q") 175 Q 176 DEVICE(Y,FROM,DIR) ; Return a subset of entries from the Device file 177 ; .LST(n)=IEN;Name^DisplayName^Location^RMar^PLen 178 ; FROM=text to $O from, DIR=$O direction 179 N I,IEN,CNT,SHOW,X S I=0,CNT=20 180 I FROM["<" S FROM=$RE($P($RE(FROM),"< ",2)) 181 F Q:I'<CNT S FROM=$O(^%ZIS(1,"B",FROM),DIR) Q:FROM="" D 182 . S IEN=0 F S IEN=$O(^%ZIS(1,"B",FROM,IEN)) Q:'IEN D 183 .. N X0,X1,X90,X91,X95,XTYPE,XSTYPE,XTIME,ORA,ORPX,POP 184 .. Q:'$D(^%ZIS(1,IEN,0)) S X0=^(0),X1=$G(^(1)),X90=$G(^(90)),X91=$G(^(91)),X95=$G(^(95)),XSTYPE=$G(^("SUBTYPE")),XTIME=$G(^("TIME")),XTYPE=$G(^("TYPE")) 185 .. I $E($G(^%ZIS(2,+XSTYPE,0)))'="P" Q ;Printers only 186 .. S X=$P(XTYPE,"^") I X'="TRM",X'="HG",X'="HFS",X'="CHAN" Q ;Device Types 187 .. S X=X0 I ($P(X,U,2)="0")!($P(X,U,12)=2) Q ;Queuing allowed 188 .. S X=+X90 I X,(X'>DT) Q ;Out of Service 189 .. I XTIME]"" S ORA=$P(XTIME,"^"),ORPX=$P($H,",",2),ORPCNT=ORPX\60#60+(ORPX\3600*100),ORPX=$P(ORA,"-",2) I ORPX'<ORA&(ORPCNT'>ORPX&(ORPCNT'<ORA))!(ORPX<ORA&(ORPCNT'<ORA!(ORPCNT'>ORPX))) Q ;Prohibited Times 190 .. S POP=0 191 .. I X95]"" S ORPX=$G(DUZ(0)) I ORPX'="@" S POP=1 F ORA=1:1:$L(ORPX) I X95[$E(ORPX,ORA) S POP=0 Q 192 .. Q:POP ;Security check 193 .. S SHOW=$P(X0,U) I SHOW'=FROM S SHOW=FROM_" <"_SHOW_">" 194 .. S I=I+1,Y(I)=IEN_";"_$P(X0,U)_U_SHOW_U_$P(X1,U)_U_$P(X91,U)_U_$P(X91,U,3) 195 Q 196 URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency 197 N ORDD,I,X 198 D FIELD^DID(8925,.09,"","POINTER","ORDD") 199 F I=1:1 S X=$P(ORDD("POINTER"),";",I) Q:X="" S Y(I)=$TR(X,":","^") 200 Q 201 PATCH(VAL,X) ; Return 1 if patch X is installed 202 S VAL=$$PATCH^XPDUTL(X) 203 Q 204 VERSION(VAL,X) ;Return version of package or namespace 205 S VAL=$$VERSION^XPDUTL(X) 206 Q 207 VERSRV(VAL,X,CLVER) ; Return server version of option name 208 S ORWCLVER=$G(CLVER) ; leave in partition for session 209 N BADVAL,ORLST 210 D FIND^DIC(19,"",1,"X",X,1,,,,"ORLST") 211 I 'ORLST("DILIST",0) S VAL="0.0.0.0" Q 212 S VAL=ORLST("DILIST","ID",1,1) 213 S VAL=$P(VAL,"version ",2) 214 S BADVAL=0 215 I $P(VAL,".",1)="" S BADVAL=1 216 I $P(VAL,".",2)="" S BADVAL=1 217 I $P(VAL,".",3)="" S BADVAL=1 218 I $P(VAL,".",4)="" S BADVAL=1 219 I ((BADVAL)!('VAL)!(VAL="")) S VAL="0.0.0.0" 220 Q 1 ORWU ; SLC/KCM - General Utilites for Windows Calls; 2/28/01 [1/15/04 11:43am] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,148,149,187,195,215**;Dec 17, 1997 3 ; 4 DT(Y,X,%DT) ; Internal Fileman Date/Time 5 ; change the '00:00' that could be passed so Fileman doesn't reject 6 I $L($P(X,"@",2)),("00000000"[$TR($P(X,"@",2),":","")) S $P(X,"@",2)="00:00:01" 7 S %DT=$G(%DT,"TS") D ^%DT K %DT 8 Q 9 VALDT(Y,X,%DT) ; Validate date/time 10 S:'$D(%DT) %DT="TX" D ^%DT 11 Q 12 USERINFO(REC) ; Relevant info for current user 13 ; return DUZ^NAME^USRCLS^CANSIGN^ISPROVIDER^ORDERROLE^NOORDER^DTIME^ 14 ; COUNTDOWN^ENABLEVERIFY^NOTIFYAPPS^MSGHANG^DOMAIN^SERVICE^ 15 ; AUTOSAVE^INITTAB^LASTTAB^WEBACCESS^ALLOWHOLD^ISRPL^RPLLIST^ 16 ; CORTABS^RPTTAB^STANUM^GECSTATUS^PRODACCT 17 N X,ORRPL,ORRPL1,ORRPL2,ORTAB,CORTABS,RPTTAB,ORDT,OREFF,OREXP,ORDATEOK 18 S REC=DUZ_U_$P(^VA(200,DUZ,0),U) 19 S $P(REC,U,3)=$S($D(^XUSEC("ORES",DUZ)):3,$D(^XUSEC("ORELSE",DUZ)):2,$D(^XUSEC("OREMAS",DUZ)):1,1:0) 20 S $P(REC,U,4)=$D(^XUSEC("ORES",DUZ))&$D(^XUSEC("PROVIDER",DUZ)) 21 S $P(REC,U,5)=$D(^XUSEC("PROVIDER",DUZ)) 22 S $P(REC,U,6)=$$ORDROLE 23 S $P(REC,U,7)=$$GET^XPAR("USR^SYS^PKG","ORWOR DISABLE ORDERING",1,"I") 24 S $P(REC,U,8)=$$GET^XPAR("USR^SYS","ORWOR TIMEOUT CHART",1,"I") 25 I '$P(REC,U,8),$G(DTIME) S $P(REC,U,8)=DTIME 26 S $P(REC,U,9)=$$GET^XPAR("USR^SYS^PKG","ORWOR TIMEOUT COUNTDOWN",1,"I") 27 S X=$$GET^XPAR("USR^SYS^PKG","ORWOR ENABLE VERIFY",1,"I") 28 S $P(REC,U,10)=$S(X=1:1,X=2:0,1:'$P(REC,U,7)) 29 S $P(REC,U,11)=$$GET^XPAR("USR^SYS^PKG","ORWOR BROADCAST MESSAGES",1,"I") 30 S $P(REC,U,12)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTO CLOSE PT MSG",1,"I") 31 S $P(REC,U,13)=$$KSP^XUPARAM("WHERE") ; domain 32 S $P(REC,U,14)=+$G(^VA(200,DUZ,5)) ; service/section 33 S $P(REC,U,15)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTOSAVE NOTE",1,"I") 34 S $P(REC,U,16)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH INITIAL TAB",1,"I") 35 S $P(REC,U,17)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH USE LAST TAB",1,"I") 36 S $P(REC,U,18)=$$GET^XPAR("USR^DIV^SYS^PKG","ORWOR DISABLE WEB ACCESS",1,"I") 37 S $P(REC,U,19)=$$GET^XPAR("SYS^PKG","ORWOR DISABLE HOLD ORDERS",1,"I") 38 ; 2 pieces added by PKS on 11/5/2001 for "Reports Only:" 39 ; IA# 10060 allows read access to ^VA(200 file. 40 S ORRPL=$G(^VA(200,DUZ,101)) ; RPL node. 41 S ORRPL1=$P(ORRPL,U) 42 S $P(REC,U,20)=ORRPL1 ; ISRPL piece. 43 S ORRPL2=$P(ORRPL,U,2) 44 S $P(REC,U,21)=ORRPL2 ; RPLLIST piece. 45 ; 46 ; Additional pieces for CPRS tabs access: 47 ; IA# 10060 allows read access to ^VA(200.01013 multiple. 48 S ORDT=DT ; Today. 49 S (CORTABS,RPTTAB)=0 50 S ORRPL=0 51 F S ORRPL=$O(^VA(200,DUZ,"ORD",ORRPL)) Q:ORRPL<1 D 52 .S ORTAB=$G(^VA(200,DUZ,"ORD",ORRPL,0)) 53 .I ORTAB="" Q 54 .S OREFF=$P(ORTAB,U,2) 55 .S OREXP=$P(ORTAB,U,3) 56 .S ORTAB=$P(ORTAB,U) 57 .I ORTAB="" Q 58 .S ORTAB=$G(^ORD(101.13,ORTAB,0)) 59 .I ORTAB="" Q 60 .S ORTAB=$P(ORTAB,U) 61 .I ORTAB="" Q 62 .S ORTAB=$$UP^XLFSTR(ORTAB) 63 .S ORDATEOK=1 ; Default. 64 .I ((OREFF="")!(OREFF>ORDT)) S ORDATEOK=0 ; Eff. date NG. 65 .I ORDATEOK D 66 ..I OREXP="" Q ; No exp. date. 67 ..I (OREXP<ORDT) S ORDATEOK=0 ; Exp. date NG. 68 ..I (OREXP=ORDT) S ORDATEOK=0 ; Exp. date NG. 69 .; 70 .; Set TRUE if OK: 71 .I ((ORTAB="COR")&(ORDATEOK)) S CORTABS=1 72 .I ((ORTAB="RPT")&(ORDATEOK)) S RPTTAB=1 73 ; 74 ; When done, set all valid tabs for access: 75 S $P(REC,U,22)=CORTABS ; "Core" tabs. 76 S $P(REC,U,23)=RPTTAB ; "Reports" tab. 77 ; 78 S $P(REC,U,24)=$P($$SITE^VASITE,U,3) 79 S $P(REC,U,25)=$$GET^XPAR("USR^TEA","PXRM GEC STATUS CHECK",1,"I") 80 S $P(REC,U,26)=$$PROD^XUPROD 81 Q 82 ; 83 HASKEY(VAL,KEY) ; returns TRUE if the user possesses the security key 84 S VAL=''$D(^XUSEC(KEY,DUZ)) 85 Q 86 HASOPTN(VAL,OPTION) ; returns TRUE if the user has access to a menu option 87 S VAL=+$$ACCESS^XQCHK(DUZ,OPTION) 88 I VAL'>0 S VAL=0 89 E S VAL=1 90 Q 91 NPHASKEY(VAL,NP,KEY) ; returns TRUE if the person has the security key 92 S VAL=''$D(^XUSEC(KEY,NP)) 93 Q 94 ORDROLE() ; returns the role a person takes in ordering 95 ; VAL: 0=nokey, 1=clerk, 2=nurse, 3=physician, 4=student, 5=bad keys 96 ;I '$G(ORWCLVER) Q 0 ; version of client is to old for ordering 97 I ($D(^XUSEC("OREMAS",DUZ))+$D(^XUSEC("ORELSE",DUZ))+$D(^XUSEC("ORES",DUZ)))>1 Q 5 98 I $D(^XUSEC("OREMAS",DUZ)) Q 1 ; clerk 99 I $D(^XUSEC("ORELSE",DUZ)) Q 2 ; nurse 100 I $D(^XUSEC("ORES",DUZ)),$D(^XUSEC("PROVIDER",DUZ)) Q 3 ; doctor 101 I $D(^XUSEC("PROVIDER",DUZ)) Q 4 ; student 102 Q 0 103 VALIDSIG(ESOK,X) ; returns TRUE if valid electronic signature 104 S X=$$DECRYP^XUSRB1(X),ESOK=0 ; network encrypted 105 D HASH^XUSHSHP 106 I X=$P($G(^VA(200,+DUZ,20)),U,4) S ESOK=1 107 Q 108 TOOLMENU(ORLST) ; returns a list of items for the Tools menu 109 N ANENT 110 S ANENT="ALL^"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"") 111 D GETLST^XPAR(.ORLST,ANENT,"ORWT TOOLS MENU","N") 112 Q 113 ACTLOC(LOC) ; Function: returns TRUE if active hospital location 114 ; IA# 10040. 115 N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; screen out OOS entry 116 S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; chk out of svc wards 117 S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inactivate date 118 I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0 ; chk reactivate date 119 Q 1 ; must still be active 120 ; 121 CLINLOC(Y,FROM,DIR) ; Return a set of clinics from HOSPITAL LOCATION 122 ; .Y=returned list, FROM=text to $O from, DIR=$O direction, 123 N I,IEN,CNT S I=0,CNT=44 124 F Q:I'<CNT S FROM=$O(^SC("B",FROM),DIR) Q:FROM="" D ; IA# 10040. 125 . S IEN="" F S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN D 126 . . I ($P($G(^SC(IEN,0)),U,3)'="C")!('$$ACTLOC(IEN)) Q 127 . . S I=I+1,Y(I)=IEN_"^"_FROM 128 Q 129 INPLOC(Y,FROM,DIR) ;Return a set of wards from HOSPITAL LOCATION 130 ; .Y=returned list, FROM=text to $O from, DIR=$O direction, 131 N I,IEN,CNT S I=0,CNT=44 132 F Q:I'<CNT S FROM=$O(^SC("B",FROM),DIR) Q:FROM="" D ; IA# 10040. 133 . S IEN="" F S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN D 134 . . I ($P($G(^SC(IEN,0)),U,3)'="W") Q 135 . . I '$$ACTLOC(IEN) Q 136 . . S I=I+1,Y(I)=IEN_"^"_FROM 137 Q 138 HOSPLOC(Y,FROM,DIR) ; Return a set of locations from HOSPITAL LOCATION 139 ; .Y=returned list, FROM=text to $O from, DIR=$O direction, 140 N I,IEN,CNT S I=0,CNT=44 141 F Q:I'<CNT S FROM=$O(^SC("B",FROM),DIR) Q:FROM="" D ; IA# 10040. 142 . S IEN="" F S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN D 143 . . Q:("CW"'[$P($G(^SC(IEN,0)),U,3)!('$$ACTLOC(IEN))) 144 . . S I=I+1,Y(I)=IEN_"^"_FROM 145 Q 146 NEWPERS(ORY,ORFROM,ORDIR,ORKEY,ORDATE,ORVIZ,ORALL) ; Return a set of names from the NEW PERSON file. 147 ; SLC/PKS: Code moved to ORWU1 on 12/3/2002. 148 D NP1^ORWU1 149 Q 150 GBLREF(VAL,FN) ; return global reference for file number 151 S VAL="" Q:'FN 152 S VAL=$$ROOT^DILFD(+FN) 153 ; I $E($RE(VAL))="," S VAL=$E(VAL,1,$L(VAL)-1)_")" 154 ; I $E($RE(VAL))="(" S VAL=$P(VAL,"(",1) 155 Q 156 GENERIC(Y,FROM,DIR,REF) ; Return a set of entries from xref in REF 157 ; .Y=returned list, FROM=text to $O from, DIR=$O direction, 158 N I,IEN,CNT S I=0,CNT=44 159 F Q:I'<CNT S FROM=$O(@REF@(FROM),DIR) Q:FROM="" D 160 . S IEN="" F S IEN=$O(@REF@(FROM,IEN),DIR) Q:'IEN D 161 . . S I=I+1,Y(I)=IEN_"^"_FROM 162 Q 163 EXTNAME(VAL,IEN,FN) ; return external form of pointer 164 ; IEN=internal number, FN=file number 165 N REF S REF=$G(^DIC(FN,0,"GL")),VAL="" 166 I $L(REF),+IEN S VAL=$P($G(@(REF_IEN_",0)")),U) 167 Q 168 PARAM(VAL,APARAM) ; return a parameter value for a user 169 ; call assumes current user, default entities, single instance 170 S VAL=$$GET^XPAR("ALL",APARAM,1,"I") 171 Q 172 DEVICE(Y,FROM,DIR) ; Return a subset of entries from the Device file 173 ; .LST(n)=IEN;Name^DisplayName^Location^RMar^PLen 174 ; FROM=text to $O from, DIR=$O direction 175 N I,IEN,CNT,SHOW,X S I=0,CNT=20 176 I FROM["<" S FROM=$RE($P($RE(FROM),"< ",2)) 177 F Q:I'<CNT S FROM=$O(^%ZIS(1,"B",FROM),DIR) Q:FROM="" D 178 . S IEN=0 F S IEN=$O(^%ZIS(1,"B",FROM,IEN)) Q:'IEN D 179 .. N X0,X1,X90,X91,X95,XTYPE,XSTYPE,XTIME,ORA,ORPX,POP 180 .. Q:'$D(^%ZIS(1,IEN,0)) S X0=^(0),X1=$G(^(1)),X90=$G(^(90)),X91=$G(^(91)),X95=$G(^(95)),XSTYPE=$G(^("SUBTYPE")),XTIME=$G(^("TIME")),XTYPE=$G(^("TYPE")) 181 .. I $E($G(^%ZIS(2,+XSTYPE,0)))'="P" Q ;Printers only 182 .. S X=$P(XTYPE,"^") I X'="TRM",X'="HG",X'="HFS",X'="CHAN" Q ;Device Types 183 .. S X=X0 I ($P(X,U,2)="0")!($P(X,U,12)=2) Q ;Queuing allowed 184 .. S X=+X90 I X,(X'>DT) Q ;Out of Service 185 .. I XTIME]"" S ORA=$P(XTIME,"^"),ORPX=$P($H,",",2),ORPCNT=ORPX\60#60+(ORPX\3600*100),ORPX=$P(ORA,"-",2) I ORPX'<ORA&(ORPCNT'>ORPX&(ORPCNT'<ORA))!(ORPX<ORA&(ORPCNT'<ORA!(ORPCNT'>ORPX))) Q ;Prohibited Times 186 .. S POP=0 187 .. I X95]"" S ORPX=$G(DUZ(0)) I ORPX'="@" S POP=1 F ORA=1:1:$L(ORPX) I X95[$E(ORPX,ORA) S POP=0 Q 188 .. Q:POP ;Security check 189 .. S SHOW=$P(X0,U) I SHOW'=FROM S SHOW=FROM_" <"_SHOW_">" 190 .. S I=I+1,Y(I)=IEN_";"_$P(X0,U)_U_SHOW_U_$P(X1,U)_U_$P(X91,U)_U_$P(X91,U,3) 191 Q 192 URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency 193 N ORDD,I,X 194 D FIELD^DID(8925,.09,"","POINTER","ORDD") 195 F I=1:1 S X=$P(ORDD("POINTER"),";",I) Q:X="" S Y(I)=$TR(X,":","^") 196 Q 197 PATCH(VAL,X) ; Return 1 if patch X is installed 198 S VAL=$$PATCH^XPDUTL(X) 199 Q 200 VERSION(VAL,X) ;Return version of package or namespace 201 S VAL=$$VERSION^XPDUTL(X) 202 Q 203 VERSRV(VAL,X,CLVER) ; Return server version of option name 204 S ORWCLVER=$G(CLVER) ; leave in partition for session 205 N BADVAL,ORLST 206 D FIND^DIC(19,"",1,"X",X,1,,,,"ORLST") 207 I 'ORLST("DILIST",0) S VAL="0.0.0.0" Q 208 S VAL=ORLST("DILIST","ID",1,1) 209 S VAL=$P(VAL,"version ",2) 210 S BADVAL=0 211 I $P(VAL,".",1)="" S BADVAL=1 212 I $P(VAL,".",2)="" S BADVAL=1 213 I $P(VAL,".",3)="" S BADVAL=1 214 I $P(VAL,".",4)="" S BADVAL=1 215 I ((BADVAL)!('VAL)!(VAL="")) S VAL="0.0.0.0" 216 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORY269.m
r613 r623 1 ORY269 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997;Build 29 3 4 5 6 7 8 INSERT(OPTION,RPC) 9 10 11 12 13 14 15 16 1 ORY269 ;WV/CJS - POST INIT FOR OR*3*269 ;1/24/07 23:34 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997;Build 28 3 ; Register Lookup RPCs 4 N MENU,RPC 5 S MENU="OR CPRS GUI CHART" 6 F RPC="ORWPT ENHANCED PATLOOKUP","ORWPT OTHER-RADIOBUTTONS" D INSERT(MENU,RPC) 7 Q 8 INSERT(OPTION,RPC) ; Call FM Updater with each RPC 9 ; Input -- OPTION Option file (#19) Name field (#.01) 10 ; RPC RPC sub-file (#19.05) RPC field (#.01) 11 ; Output -- None 12 N FDA,FDAIEN,ERR,DIERR 13 S FDA(19,"?1,",.01)=OPTION 14 S FDA(19.05,"?+2,?1,",.01)=RPC 15 D UPDATE^DIE("E","FDA","FDAIEN","ERR") 16 Q -
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORYDLG.m
r613 r623 1 ORYDLG ;SLC/MKB -- Postinit bulletin for order dialogs ;7/28/04 08:18 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,216,243**;Dec 17, 1997;Build 242 3 ; 4 EN(PATCH,ORDLG,USERS) ; -- look for local copies of ORDLG(NAME) by package, 5 ; send list in bulletin to DUZ, POSTMASTER, USERS(DUZ) when done 6 ; 7 Q:$O(ORDLG(""))="" ;none 8 N ORZ,ORI,X,NM,I,OR0,PKG,DG,ORPKG,ORNATL,DLG,CNT,LR,PS 9 S ORZ(1)="The following nationally exported order dialogs have been modified by" 10 S X="this patch: ",ORI=1,NM="" F S NM=$O(ORDLG(NM)) Q:NM="" D 11 . S ORI=ORI+1,ORZ(ORI)=X_NM,X=" " 12 . S I=+$O(^ORD(101.41,"AB",NM,0)),OR0=$G(^ORD(101.41,I,0)) 13 . S PKG=+$P(OR0,U,7),DG=+$P(OR0,U,5) S:PKG ORPKG(PKG,DG)="" 14 . S:$P(NM," ")="LR" LR=1 S:"^PS^PSJ^PSO^PSH^"[(U_$P(NM," ")_U) PS=1 15 D:$G(LR) LR D:$G(PS) PS ;reset FORMAT codes in changed dialogs 16 S I=0 F I=1:1 S X=$T(NATL+I) Q:X["ZZZZZ" S ORNATL($P(X,";",3))="" 17 S ORI=ORI+1,ORZ(ORI)="Please review and compare the following locally created order dialogs" 18 S ORI=ORI+1,ORZ(ORI)="that may be copies, for any necessary changes:",CNT=0 19 S PKG=0 F S PKG=$O(ORPKG(PKG)) Q:PKG<1 S DLG=0 D 20 . F S DLG=+$O(^ORD(101.41,"APKG",PKG,DLG)) Q:DLG<1 D 21 .. S OR0=$G(^ORD(101.41,DLG,0)) Q:$P(OR0,U,4)'="D" 22 .. Q:'$D(ORPKG(PKG,+$P(OR0,U,5))) ;included DispGrp 23 .. Q:$D(ORNATL($P(OR0,U))) S CNT=CNT+1 24 .. S ORI=ORI+1,ORZ(ORI)=$J(DLG,7)_" "_$P(OR0,U) 25 EN1 I CNT>0 D ;local copies found -> send bulletin 26 . N XMDUZ,XMY,I,XMSUB,XMTEXT,DIFROM 27 . S XMDUZ="PATCH OR*3*"_$G(PATCH)_" POSTINIT",XMY(.5)="" 28 . S:$G(DUZ) XMY(DUZ)="" S I=0 F S I=$O(USERS(I)) Q:I<1 S XMY(I)="" 29 . S XMSUB=XMDUZ_" COMPLETED",XMTEXT="ORZ(" D ^XMD 30 . D BMES^XPDUTL("Some national order dialogs have been modified in this patch;") 31 . D MES^XPDUTL("a bulletin has been sent to the installer listing local copies that") 32 . D MES^XPDUTL("may need to be reviewed and updated.") 33 Q 34 ; 35 NATL ;;Nationally exported dialogs 36 ;;FHW1 37 ;;FHW2 38 ;;FHW3 39 ;;FHW7 40 ;;FHW8 41 ;;FHW OP MEAL 42 ;;FHW SPECIAL MEAL 43 ;;GMRAOR ALLERGY ENTER/EDIT 44 ;;GMRCOR CONSULT 45 ;;GMRCOR REQUEST 46 ;;GMRVOR 47 ;;LR OTHER LAB TESTS 48 ;;OR GWCOND CONDITION 49 ;;OR GWDIAG DIAGNOSIS 50 ;;OR GWINST DNR 51 ;;OR GXACTV OTHER ACTIVITY ORDER 52 ;;OR GXMISC GENERAL 53 ;;OR GXMOVE ADMIT PATIENT 54 ;;OR GXMOVE DISCHARGE 55 ;;OR GXMOVE EVENT 56 ;;OR GXMOVE TRANSFER 57 ;;OR GXMOVE TREATING SPECIALTY 58 ;;OR GXPARM CALL HO ON 59 ;;OR GXSKIN DRESSING CHANGE 60 ;;OR GXTEXT TEXT ONLY ORDER 61 ;;OR GXTEXT WORD PROCESSING ORDER 62 ;;ORWD GENERIC ACTIVITY 63 ;;ORWD GENERIC DIET 64 ;;ORWD GENERIC NURSING 65 ;;ORWD GENERIC VITALS 66 ;;PS MEDS 67 ;;PSH OERR 68 ;;PSJ OR PAT OE 69 ;;PSJI OR PAT FLUID OE 70 ;;PSO OERR 71 ;;PSO SUPPLY 72 ;;RA OERR EXAM 73 ;;ZZZZZ 74 ; 75 PS ; -- reset FORMAT values in PS dialogs 76 N DRUG,OI,STR,DLGNM,DLG,PRMT,DA 77 S DRUG=$$PTR("OR GTX DRUG NAME") 78 S OI=$$PTR("OR GTX ORDERABLE ITEM"),STR=$$PTR("OR GTX STRENGTH") 79 F DLGNM="PS MEDS","PSJ OR PAT OE","PSO OERR","PSO SUPPLY","PSH OERR" D 80 . S DLG=$$PTR(DLGNM) 81 . F PRMT=OI,STR D 82 .. S DA=+$O(^ORD(101.41,DLG,10,"D",PRMT,0)) 83 .. S:DA $P(^ORD(101.41,DLG,10,DA,2),U,2)=("@"_DRUG) 84 Q 85 ; IV dialog 86 S DLG=$$PTR("PSJI OR PAT FLUID OE"),PRMT=$$PTR("OR GTX INFUSION RATE") 87 S DA=+$O(^ORD(101.41,DLG,10,"D",PRMT,0)) 88 I DA S $P(^ORD(101.41,DLG,10,DA,2),U,2)=("@"_$$PTR("OR GTX SCHEDULE")) 89 Q 90 ; 91 LR ; -- reset FORMAT value in LR dialog 92 N DLG,PRMT,DA 93 S DLG=$$PTR("LR OTHER LAB TESTS"),PRMT=$$PTR("OR GTX SPECIMEN") 94 S DA=+$O(^ORD(101.41,DLG,10,"D",PRMT,0)) 95 I DA S $P(^ORD(101.41,DLG,10,DA,2),U,2)=("="_$$PTR("OR GTX COLLECTION SAMPLE")) 96 Q 97 ; 98 PTR(X) Q +$O(^ORD(101.41,"B",X,0)) 1 ORYDLG ;SLC/MKB -- Postinit bulletin for order dialogs ;7/28/04 08:18 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,216**;Dec 17, 1997 3 ; 4 EN(PATCH,ORDLG,USERS) ; -- look for local copies of ORDLG(NAME) by package, 5 ; send list in bulletin to DUZ, POSTMASTER, USERS(DUZ) when done 6 ; 7 Q:$O(ORDLG(""))="" ;none 8 N ORZ,ORI,X,NM,I,OR0,PKG,DG,ORPKG,ORNATL,DLG,CNT 9 S ORZ(1)="The following nationally exported order dialogs have been modified by" 10 S X="this patch: ",ORI=1,NM="" F S NM=$O(ORDLG(NM)) Q:NM="" D 11 . S ORI=ORI+1,ORZ(ORI)=X_NM,X=" " 12 . S I=+$O(^ORD(101.41,"AB",NM,0)),OR0=$G(^ORD(101.41,I,0)) 13 . S PKG=+$P(OR0,U,7),DG=+$P(OR0,U,5) S:PKG ORPKG(PKG,DG)="" 14 S I=0 F I=1:1 S X=$T(NATL+I) Q:X["ZZZZZ" S ORNATL($P(X,";",3))="" 15 S ORI=ORI+1,ORZ(ORI)="Please review and compare the following locally created order dialogs" 16 S ORI=ORI+1,ORZ(ORI)="that may be copies, for any necessary changes:",CNT=0 17 S PKG=0 F S PKG=$O(ORPKG(PKG)) Q:PKG<1 S DLG=0 D 18 . F S DLG=+$O(^ORD(101.41,"APKG",PKG,DLG)) Q:DLG<1 D 19 .. S OR0=$G(^ORD(101.41,DLG,0)) Q:$P(OR0,U,4)'="D" 20 .. Q:'$D(ORPKG(PKG,+$P(OR0,U,5))) ;included DispGrp 21 .. Q:$D(ORNATL($P(OR0,U))) S CNT=CNT+1 22 .. S ORI=ORI+1,ORZ(ORI)=$J(DLG,7)_" "_$P(OR0,U) 23 EN1 I CNT>0 D ;local copies found -> send bulletin 24 . N XMDUZ,XMY,I,XMSUB,XMTEXT,DIFROM 25 . S XMDUZ="PATCH OR*3*"_$G(PATCH)_" POSTINIT",XMY(.5)="" 26 . S:$G(DUZ) XMY(DUZ)="" S I=0 F S I=$O(USERS(I)) Q:I<1 S XMY(I)="" 27 . S XMSUB=XMDUZ_" COMPLETED",XMTEXT="ORZ(" D ^XMD 28 . D BMES^XPDUTL("Some national order dialogs have been modified in this patch;") 29 . D MES^XPDUTL("a bulletin has been sent to the installer listing local copies that") 30 . D MES^XPDUTL("may need to be reviewed and updated.") 31 Q 32 ; 33 NATL ;;Nationally exported dialogs 34 ;;FHW1 35 ;;FHW2 36 ;;FHW3 37 ;;FHW7 38 ;;FHW8 39 ;;GMRAOR ALLERGY ENTER/EDIT 40 ;;GMRCOR CONSULT 41 ;;GMRCOR REQUEST 42 ;;GMRVOR 43 ;;LR OTHER LAB TESTS 44 ;;OR GWCOND CONDITION 45 ;;OR GWDIAG DIAGNOSIS 46 ;;OR GWINST DNR 47 ;;OR GXACTV OTHER ACTIVITY ORDER 48 ;;OR GXMISC GENERAL 49 ;;OR GXMOVE ADMIT PATIENT 50 ;;OR GXMOVE DISCHARGE 51 ;;OR GXMOVE EVENT 52 ;;OR GXMOVE TRANSFER 53 ;;OR GXMOVE TREATING SPECIALTY 54 ;;OR GXPARM CALL HO ON 55 ;;OR GXSKIN DRESSING CHANGE 56 ;;OR GXTEXT TEXT ONLY ORDER 57 ;;OR GXTEXT WORD PROCESSING ORDER 58 ;;ORWD GENERIC ACTIVITY 59 ;;ORWD GENERIC DIET 60 ;;ORWD GENERIC NURSING 61 ;;ORWD GENERIC VITALS 62 ;;PS MEDS 63 ;;PSJ OR PAT OE 64 ;;PSJI OR PAT FLUID OE 65 ;;PSO OERR 66 ;;PSO SUPPLY 67 ;;RA OERR EXAM 68 ;;ZZZZZ
Note:
See TracChangeset
for help on using the changeset viewer.