Changeset 623 for WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW

Timestamp:

Dec 4, 2009, 12:11:15 AM (15 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

Location:

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW

Files:

• PSGOE1.m (modified) (1 diff)
• PSGOE6.m (modified) (1 diff)
• PSGOEC.m (modified) (1 diff)
• PSGOECS.m (modified) (1 diff)
• PSGOEF.m (modified) (1 diff)
• PSGOT.m (modified) (1 diff)
• PSGPLR.m (modified) (1 diff)
• PSGS0.m (modified) (1 diff)
• PSGSICHK.m (modified) (1 diff)
• PSGXR3.m (modified) (1 diff)
• PSGXR31.m (modified) (1 diff)
• PSGXR310.m (modified) (1 diff)
• PSGXR311.m (modified) (1 diff)
• PSGXR312.m (modified) (1 diff)
• PSGXR32.m (modified) (1 diff)
• PSGXR33.m (modified) (1 diff)
• PSGXR34.m (modified) (1 diff)
• PSGXR35.m (modified) (1 diff)
• PSGXR36.m (modified) (1 diff)
• PSGXR37.m (modified) (1 diff)
• PSGXR38.m (modified) (1 diff)
• PSGXR39.m (modified) (1 diff)
• PSIVCAL.m (modified) (1 diff)
• PSIVEDT.m (modified) (1 diff)
• PSIVORA.m (modified) (1 diff)
• PSIVORC.m (modified) (1 diff)
• PSIVORC1.m (modified) (1 diff)
• PSIVOREN.m (modified) (1 diff)
• PSIVORFA.m (modified) (1 diff)
• PSIVORFB.m (modified) (1 diff)
• PSIVSP.m (modified) (1 diff)
• PSIVUTL1.m (modified) (1 diff)
• PSJHL2.m (modified) (1 diff)
• PSJHL3.m (modified) (1 diff)
• PSJHL4.m (modified) (1 diff)
• PSJHL4A.m (modified) (1 diff)
• PSJHL5.m (modified) (1 diff)
• PSJHL9.m (modified) (1 diff)
• PSJHLU.m (modified) (1 diff)
• PSJLIACT.m (modified) (1 diff)
• PSJLIVFD.m (modified) (1 diff)
• PSJLIVMD.m (modified) (1 diff)
• PSJLMPRU.m (modified) (1 diff)
• PSJLMUDE.m (modified) (1 diff)
• PSJLMUT1.m (modified) (1 diff)
• PSJLMUT2.m (modified) (1 diff)
• PSJMPEND.m (modified) (1 diff)
• PSJOERI.m (modified) (1 diff)
• PSJOREN.m (modified) (1 diff)
• PSJORPOE.m (modified) (1 diff)
• PSJORRE.m (modified) (1 diff)
• PSJORRE1.m (modified) (1 diff)
• PSJORREN.m (modified) (1 diff)
• PSJORUT2.m (modified) (1 diff)
• PSJUTL.m (modified) (1 diff)

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOE1.m

@@ -1 @@
-PSGOE1  ;BIR/CML3-ACTION ON INPATIENT ORDERS ;10 Mar 99 / 10:54 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**7,19,26,39,58,85,80,110,127,133,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(55 is supported by DBIA #2191.
-        ; Reference to ^PSDRUG( is supported by DBIA #2192.
-        ; Reference to EN1^ORCFLAG is supported by DBIA #3620.
-        ; Reference to AND^ORX8 is supported by DBIA #3632.
-EN      ;       
-        K PSGDFLG,PSGPFLG S PSGOEA="^",PSGACT="",(PSGDI,PSGOENG,PSGPI,PSGRRF)=0
-        Q:'$G(DUZ)
-        D @$S(PSGORD["P":"NON",1:"ACT")
-GO      ;
-        K A,ND,PSGE,PSGR,ST,X,X1,X2,Y I $D(ORACTION) K PSGDI,PSGOENG,PSGPI Q
-        Q
-ENACTION(PSGP,PSGORD)          ;
-        ;Returns string identifying the actions allowed on this order.
-        D EN
-        Q PSGACT
-DONE    ;
-        I PSGORD["U"!(PSGORD["O") L -^PS(55,PSGP,5,+PSGORD)
-        E  L -^PS(53.1,+PSGORD)
-        K C,PSGACT,PSGDFLG,PSGPFLG,PSGDI,PSGOENG,PSGPI,PSGRRF Q
-B       ; bypass
-        S PSGCANFL=1
-        Q
-C       ; copy an order (does NOT discontinue original order)
-        D ^PSGOD Q
-D       ; discontinue (or delete) an order
-        I PSGOEAV,'$D(PSGODF) D ENDS^PSGPO Q
-        D ENO^PSGOEC(PSGP,PSGORD) Q
-E       ; edit orders
-        D ^PSGOEE Q
-F       ; finish released orders
-        D ^PSGOEF Q
-H(PSGP,PSGORD)  ; hold
-        S X=$G(^PS(55,PSGP,5,+PSGORD,4)) I $P(X,U,12),$P(X,U,13) W $C(7),!!,"WARNING!  THIS ORDER HAS BEEN MARKED FOR CANCELLATION."
-        I $P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",9)="H" D ^PSGOEH0 Q
-        D ^PSGOEH1 Q
-I       ; mark (or unmark) a non-verified order as 'incomplete'
-        D ^PSGOEI Q
-L       ; display logs
-        D ^PSGOEL Q
-N       ; mark order as 'not to be given'
-        D ^PSGOENG Q
-O       ; Outpatient (discharge) med
-        W !!,"UNDER DEVELOPMENT, NOT CURRENTLY AVAILABLE."
-        Q
-P       ; print expanded view
-        D ^PSGVWP Q
-R       ; renew an order
-        I 'PSJSYSU,$D(^PS(55,PSGP,5,+PSGORD,4)),$P(^(4),"^",15),$P(^(4),"^",16) W !!,"THIS ORDER IS ALREADY MARKED FOR RENEWAL!" Q
-        I 'PSGRRF D ^PSGOER Q
-        D ^PSGOERI Q
-S       ; show the order again
-        D EN2^PSGVW Q
-V       ; verify an order
-        D EN^PSGOEV Q
-ACT     ;
-        S X=$G(^PS(55,PSGP,5,+PSGORD,0)),ND0=X,ND=$G(^(4)),ND2=$G(^(2)),PSGOENG=$P(X,"^",22),PSGR=$E("R",'PSGOENG),PSJCOM=$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8)
-        I 'PSGOENG,PSJCOM S PSGR=$E("R",$$AND^ORX8(PSJCOM)) S:PSGR="R" PSGR=$E("R",$$RNEWOK^PSJUTL2(PSJCOM,PSGP))
-        S PSGR=$E("R",'$$EXPIRED^PSGOER(PSGP,PSGORD)) S PSGR=$E("R",$P(ND0,"^",7)'="O")
-        I $P(ND2,U,4)'>PSGDT D OLD Q
-        S PSGE="E" I '$D(PSGOETOF) S (PSGDFLG,PSGDI)='$$DDOK^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",1,",+$G(^PS(55,PSGP,5,+PSGORD,.2))),PSGPFLG='$$OIOK^PSGOE2(+$G(^PS(55,PSGP,5,+PSGORD,.2)))
-        S:$P(X,"^",26) (PSGE,PSGR)=""
-        I '$D(PSGOETOF) S PSGPI=$P(X,"^",2) I PSGPI S PSGPI=$P($G(^VA(200,PSGPI,"PS")),"^",4) S:PSGPI PSGPI=PSGPI'>DT
-        S ST=$P(X,"^",9)="H"*4 S:ST (PSGE,PSGR)=""
-        N CMPOK S CMPOK=1 I $$COMPLEX^PSJOE(PSGP,PSGORD) S CMPOK=+$P(^PS(55,PSGP,5,+PSGORD,.2),"^",8)
-        S PSGACT="D"_$S('$G(CMPOK):"",1:PSGE)_$S($P(ND,"^",18+ST)&'$P(ND,"^",19+ST)&'$P(ND,"^",PSJSYSU):"",1:"H")_"L"_$S(ST:"",1:PSGR)
-        I PSJSYSU,'$P(ND,"^",+PSJSYSU) S PSGACT=PSGACT_"V"
-        I +PSJSYSU=3,$L($T(EN1^ORCFLAG)) S PSGACT=PSGACT_"G"
-        Q
-OLD     ;
-        S A=$P(ND0,"^",9),PSGACT=$E("H",A="H")_"L" I A'["D",A'["E" Q
-        I 'PSGOENG,($D(^XUSEC("PSJU MGR",DUZ))!$D(^XUSEC("PSJ RPHARM",DUZ))) S PSGACT="LN"
-        I PSJSYSU,'$P(ND,"^",+PSJSYSU) S:(A'["D")&($G(PSGPRIO)'="DONE") PSGACT="D"_PSGACT S PSGACT=PSGACT_"V" Q
-        Q:PSGR=""!'PSJPCAF  D NOW^%DTC S (PSGDT,X1)=+$E(%,1,12),X2=-4 D C^%DTC I $S('$P(ND2,"^",4):1,1:$P(ND2,"^",4)'>X) Q
-        I A="E",$G(PSJPRI)'="D" S PSGACT=PSGACT_PSGR Q
-        I PSJSYSU,$P(ND,"^",11) S PSGACT=PSGACT_PSGR,PSGRRF=1
-        Q
-NON     ;
-        N XND,DRGPT,XND2
-        S (X,XND)=$G(^PS(53.1,+PSGORD,0)) I $P(X,"^",19),$D(^PS(55,PSGP,5,$P(X,"^",19))) L -^PS(53.1,+PSGORD) S PSGORD=$P(X,"^",19)_"U" G ACT
-        I $S($P(X,"^",26):1,$P(X,"^",9)["D":1,1:$P(X,"^",9)["E") S:$P(X,U,9)="P"&($P(X,U,26)) PSGACT="D" S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q
-        I PSGORD["U" S PSGACT="DE" S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q
-        I '$D(PSGOETOF) S (PSGDFLG,PSGDI)='$$DDOK^PSGOE2("^PS(53.1,"_+PSGORD_",1,",+$G(^PS(53.1,+PSGORD,.2))),PSGPFLG='$$OIOK^PSGOE2(+$G(^PS(53.1,+PSGORD,.2)))
-        S DRG=$$STUFFDD^PSGOE2 S:DRG ^PS(53.1,+PSGORD,1,0)="^53.11P^1^1",^PS(53.1,+PSGORD,1,1,0)=DRG,^PS(53.1,+PSGORD,1,"B",DRG,1)=""
-        F DRG=0:0 S DRG=$O(^PS(53.1,+PSGORD,1,DRG)) Q:'DRG  S DRGPT=^(DRG,0) S INACTDT=$G(^PSDRUG(+DRGPT,"I")) I INACTDT,(INACTDT'>DT) S PSGDFLG=1
-        I $P(XND,U,9)="P" S PSGACT=$S(+PSJSYSU=3:"BDEF",$G(PSJRNF):"BDEF",1:"") S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q
-        I '$D(PSGOETOF) S PSGPI=$P(XND,"^",2) I PSGPI S PSGPI=$P($G(^VA(200,PSGPI,"PS")),"^",4) S:PSGPI PSGPI=PSGPI'>DT
-        S PSGACT="DEI" I PSJSYSU,'PSGPI,$P(XND,"^",9)'="I" S PSGACT=PSGACT_"V"
-        S XND2=$G(^PS(53.1,+PSGORD,.2)) I $P(XND2,"^",8),$P(XND,"^",9)="P" S PSGACT=$TR(PSGACT,"V")
-        I +PSJSYSU=3,$L($T(EN1^ORCFLAG)) S PSGACT=PSGACT_"G"
-        I $P($G(PSGRDTX),U,2)]"",'$P($G(^PS(53.1,+PSGORD,2.5)),"^",2) S $P(^PS(53.1,+PSGORD,2.5),U,2)=$P(PSGRDTX,U,2)
-        Q
-ACTO    ;
-        S PSGACTO="" I $G(PSGACT)]"" F X=1:1:$L(PSGACT) S PSGACTO=PSGACTO_$S($E(PSGACT,X)="D":"DC",1:$E(PSGACT,X))_" "
-        S:PSGACTO]"" PSGACTO=$E(PSGACTO,1,$L(PSGACTO)-1) Q
+PSGOE1 ;BIR/CML3-ACTION ON INPATIENT ORDERS ;10 Mar 99 / 10:54 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**7,19,26,39,58,85,80,110,127,133**;16 DEC 97
+ ;
+ ; Reference to ^PS(55 is supported by DBIA #2191.
+ ; Reference to ^PSDRUG( is supported by DBIA #2192.
+ ; Reference to EN1^ORCFLAG is supported by DBIA #3620.
+ ; Reference to AND^ORX8 is supported by DBIA #3632.
+EN ;       
+ K PSGDFLG,PSGPFLG S PSGOEA="^",PSGACT="",(PSGDI,PSGOENG,PSGPI,PSGRRF)=0
+ Q:'$G(DUZ)
+ D @$S(PSGORD["P":"NON",1:"ACT")
+GO ;
+ K A,ND,PSGE,PSGR,ST,X,X1,X2,Y I $D(ORACTION) K PSGDI,PSGOENG,PSGPI Q
+ ;W:$G(PSGPFLG) !!?3,"(THE ORDERABLE ITEM IS CURRENTLY LISTED AS INACTIVE.)" W:$G(PSGDFLG) !!?3,"(ONE OR ALL DISPENSE DRUGS ARE CURRENTLY LISTED AS INACTIVE OR DO NOT MATCH",!?3,"THE ORDERABLE ITEM FOR THIS ORDER.)"
+ ;I $G(PSGPFLG)!$G(PSGDFLG) K DIR S DIR(0)="E" D ^DIR K DIR
+ ;S PSGCANFL=0 ;F  D ACTO W !!,"ACTION"_$S(PSGACTO]"":" ("_PSGACTO_")",1:"")_"? " R PSGOEA:DTIME W:'$T $C(7) S:'$T PSGOEA="^" Q:"^"[PSGOEA  D CHK D:C @PSGOEA Q:PSGCANFL
+ Q
+ENACTION(PSGP,PSGORD)        ;
+ ;Returns string identifying the actions allowed on this order.
+ D EN
+ Q PSGACT
+DONE ;
+ I PSGORD["U"!(PSGORD["O") L -^PS(55,PSGP,5,+PSGORD)
+ E  L -^PS(53.1,+PSGORD)
+ K C,PSGACT,PSGDFLG,PSGPFLG,PSGDI,PSGOENG,PSGPI,PSGRRF Q
+B ; bypass
+ S PSGCANFL=1
+ Q
+C ; copy an order (does NOT discontinue original order)
+ D ^PSGOD Q
+D ; discontinue (or delete) an order
+ I PSGOEAV,'$D(PSGODF) D ENDS^PSGPO Q
+ D ENO^PSGOEC(PSGP,PSGORD) Q
+E ; edit orders
+ D ^PSGOEE Q
+F ; finish released orders
+ D ^PSGOEF Q
+H(PSGP,PSGORD) ; hold
+ S X=$G(^PS(55,PSGP,5,+PSGORD,4)) I $P(X,U,12),$P(X,U,13) W $C(7),!!,"WARNING!  THIS ORDER HAS BEEN MARKED FOR CANCELLATION."
+ I $P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",9)="H" D ^PSGOEH0 Q
+ D ^PSGOEH1 Q
+I ; mark (or unmark) a non-verified order as 'incomplete'
+ D ^PSGOEI Q
+L ; display logs
+ D ^PSGOEL Q
+N ; mark order as 'not to be given'
+ D ^PSGOENG Q
+O ; Outpatient (discharge) med
+ W !!,"UNDER DEVELOPMENT, NOT CURRENTLY AVAILABLE."
+ Q
+P ; print expanded view
+ D ^PSGVWP Q
+R ; renew an order
+ I 'PSJSYSU,$D(^PS(55,PSGP,5,+PSGORD,4)),$P(^(4),"^",15),$P(^(4),"^",16) W !!,"THIS ORDER IS ALREADY MARKED FOR RENEWAL!" Q
+ I 'PSGRRF D ^PSGOER Q
+ D ^PSGOERI Q
+S ; show the order again
+ D EN2^PSGVW Q
+V ; verify an order
+ D EN^PSGOEV Q
+ACT ;
+ S X=$G(^PS(55,PSGP,5,+PSGORD,0)),ND0=X,ND=$G(^(4)),ND2=$G(^(2)),PSGOENG=$P(X,"^",22),PSGR=$E("R",'PSGOENG),PSJCOM=$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8)
+ I 'PSGOENG,PSJCOM S PSGR=$E("R",$$AND^ORX8(PSJCOM)) S:PSGR="R" PSGR=$E("R",$$RNEWOK^PSJUTL2(PSJCOM,PSGP))
+ S PSGR=$E("R",'$$EXPIRED^PSGOER(PSGP,PSGORD)) S PSGR=$E("R",$P(ND0,"^",7)'="O")
+ I $P(ND2,U,4)'>PSGDT D OLD Q
+ S PSGE="E" I '$D(PSGOETOF) S (PSGDFLG,PSGDI)='$$DDOK^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",1,",+$G(^PS(55,PSGP,5,+PSGORD,.2))),PSGPFLG='$$OIOK^PSGOE2(+$G(^PS(55,PSGP,5,+PSGORD,.2)))
+ S:$P(X,"^",26) (PSGE,PSGR)=""
+ I '$D(PSGOETOF) S PSGPI=$P(X,"^",2) I PSGPI S PSGPI=$P($G(^VA(200,PSGPI,"PS")),"^",4) S:PSGPI PSGPI=PSGPI'>DT
+ S ST=$P(X,"^",9)="H"*4 S:ST (PSGE,PSGR)=""
+ ;S PSGACT="D"_$S(+$P(^PS(55,PSGP,5,+PSGORD,.2),"^",8):"",1:PSGE)_$S($P(ND,"^",18+ST)&'$P(ND,"^",19+ST)&'$P(ND,"^",PSJSYSU):"",1:"H")_"L"_$S(ST:"",1:PSGR)
+ N CMPOK S CMPOK=1 I $$COMPLEX^PSJOE(PSGP,PSGORD) S CMPOK=+$P(^PS(55,PSGP,5,+PSGORD,.2),"^",8)
+ S PSGACT="D"_$S('$G(CMPOK):"",1:PSGE)_$S($P(ND,"^",18+ST)&'$P(ND,"^",19+ST)&'$P(ND,"^",PSJSYSU):"",1:"H")_"L"_$S(ST:"",1:PSGR)
+ I PSJSYSU,'$P(ND,"^",+PSJSYSU) S PSGACT=PSGACT_"V"
+ I +PSJSYSU=3,$L($T(EN1^ORCFLAG)) S PSGACT=PSGACT_"G"
+ Q
+OLD ;
+ S A=$P(ND0,"^",9),PSGACT=$E("H",A="H")_"L" I A'["D",A'["E" Q
+ I 'PSGOENG,($D(^XUSEC("PSJU MGR",DUZ))!$D(^XUSEC("PSJ RPHARM",DUZ))) S PSGACT="LN"
+ I PSJSYSU,'$P(ND,"^",+PSJSYSU) S:(A'["D")&($G(PSGPRIO)'="DONE") PSGACT="D"_PSGACT S PSGACT=PSGACT_"V" Q
+ Q:PSGR=""!'PSJPCAF  D NOW^%DTC S (PSGDT,X1)=+$E(%,1,12),X2=-4 D C^%DTC I $S('$P(ND2,"^",4):1,1:$P(ND2,"^",4)'>X) Q
+ I A="E",$G(PSJPRI)'="D" S PSGACT=PSGACT_PSGR Q
+ I PSJSYSU,$P(ND,"^",11) S PSGACT=PSGACT_PSGR,PSGRRF=1
+ Q
+NON ;
+ N XND,DRGPT,XND2
+ S (X,XND)=$G(^PS(53.1,+PSGORD,0)) I $P(X,"^",19),$D(^PS(55,PSGP,5,$P(X,"^",19))) L -^PS(53.1,+PSGORD) S PSGORD=$P(X,"^",19)_"U" G ACT
+ I $S($P(X,"^",26):1,$P(X,"^",9)["D":1,1:$P(X,"^",9)["E") S:$P(X,U,9)="P"&($P(X,U,26)) PSGACT="D" S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q
+ I PSGORD["U" S PSGACT="DE" S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q
+ I '$D(PSGOETOF) S (PSGDFLG,PSGDI)='$$DDOK^PSGOE2("^PS(53.1,"_+PSGORD_",1,",+$G(^PS(53.1,+PSGORD,.2))),PSGPFLG='$$OIOK^PSGOE2(+$G(^PS(53.1,+PSGORD,.2)))
+ S DRG=$$STUFFDD^PSGOE2 S:DRG ^PS(53.1,+PSGORD,1,0)="^53.11P^1^1",^PS(53.1,+PSGORD,1,1,0)=DRG,^PS(53.1,+PSGORD,1,"B",DRG,1)=""
+ F DRG=0:0 S DRG=$O(^PS(53.1,+PSGORD,1,DRG)) Q:'DRG  S DRGPT=^(DRG,0) S INACTDT=$G(^PSDRUG(+DRGPT,"I")) I INACTDT,(INACTDT'>DT) S PSGDFLG=1
+ I $P(XND,U,9)="P" S PSGACT=$S(+PSJSYSU=3:"BDEF",$G(PSJRNF):"BDEF",1:"") S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q
+ I '$D(PSGOETOF) S PSGPI=$P(XND,"^",2) I PSGPI S PSGPI=$P($G(^VA(200,PSGPI,"PS")),"^",4) S:PSGPI PSGPI=PSGPI'>DT
+ S PSGACT="DEI" I PSJSYSU,'PSGPI,$P(XND,"^",9)'="I" S PSGACT=PSGACT_"V"
+ ;* S PSGACT="DEI" I PSJSYSU,'PSGDI,'PSGPI,$P(X,"^",9)'="I" S PSGACT=PSGACT_"V"
+ S XND2=$G(^PS(53.1,+PSGORD,.2)) I $P(XND2,"^",8),$P(XND,"^",9)="P" S PSGACT=$TR(PSGACT,"V")
+ I +PSJSYSU=3,$L($T(EN1^ORCFLAG)) S PSGACT=PSGACT_"G"
+ I $P($G(PSGRDTX),U,2)]"",'$D(^PS(53.1,+PSGORD,2.5)) S $P(^PS(53.1,+PSGORD,2.5),U,2)=$P(PSGRDTX,U,2)
+ Q
+ACTO ;
+ S PSGACTO="" I $G(PSGACT)]"" F X=1:1:$L(PSGACT) S PSGACTO=PSGACTO_$S($E(PSGACT,X)="D":"DC",1:$E(PSGACT,X))_" "
+ S:PSGACTO]"" PSGACTO=$E(PSGACTO,1,$L(PSGACTO)-1) Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOE6.m

@@ -1 @@
-PSGOE6  ;BIR/CML3-ORDER ENTRY THROUGH OE/RR ;10 Mar 98 / 2:35 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**3,7,39,45,65,58,81,156,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(50.7 supported by DBIA #2180.
-        ; Reference to ^PS(51.1 is supported by DBIA #2177.
-        ; Reference to ^PS(51.2 is supported by DBIA #2178.
-        ; Reference to ^PS(55 is supported by DBIA #2191.
-        ; Reference to ^DD(53.1 is supported by DBIA #2256.
-        ; Reference to ^VA(200 is supported by DBIA #10060.
-        ; Reference to ^DICN is supported by DBIA #10009.
-        ;
-        K PSGFOK S F1=53.1,PSGPR=$S($D(PSGOERR):PSJORPV,1:PSGOEPR),PSGMR=$S($P(PSGNEDFD,"^",2):$P(PSGNEDFD,"^",2),1:PSGOEDMR),PSGSCH=$P(PSGNEDFD,"^",4),(PSGOROE1,PSGSI,SDT,PSGMRN,PSGSM,PSGHSM,PSGUD,PSGSD,PSGFD,PSGSI,PSGNEFD,PSGNESD)=""
-        S:PSGMR PSGMRN=$S('$P(PSGNEDFD,"^",2):"ORAL",'$D(^PS(51.2,PSGMR,0)):PSGMR,$P(^(0),"^")]"":$P(^(0),"^"),1:PSGMR) I PSGPR S PSGPRN=$P($G(^VA(200,PSGPR,0)),"^") S:PSGPRN="" PSGPRN=PSGPR
-        S PSGST=$S($P(PSGNEDFD,"^",3)]"":$P(PSGNEDFD,"^",3),1:"C")
-        ; Naked references in line below refer to ^PS(53.45,PSJSYSP
-        K ^PS(53.45,PSJSYSP,1),^(2) I PSGDRG S ^(2,0)="^53.4502P^"_PSGDRG_"^1",^(1,0)=PSGDRG,^PS(53.45,PSJSYSP,2,"B",PSGDRG,1)=""
-        ;
-109     ; dosage ordered
-        W !,"DOSAGE ORDERED: ",$S(PSGDO]"":PSGDO_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
-        I X="" S X=PSGDO I X="" W $C(7),"  (Required)" G 109
-        S PSGF2=109 I X="@" W $C(7),"  (Required)" G 109
-        I X?1."?" S F1=53.1 D ENHLP^PSGOEM(53.1,109) G 109
-        I $E(X)="^" D FF G:Y>0 @Y G 109
-        I $E(X,$L(X))=" " F  S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" "
-        I $S(X?.E1C.E:1,$L(X)>20:1,X="":1,X["^":1,X?1.P:1,1:X=+X) W $C(7),"  ",$S(X?1.P!(X=""):"(Required)",1:"??") S X="?" D ENHLP^PSGOEM(53.1,109) G 109
-        S PSGDO=X,PSGFOK(109)=""
-        ;
-3       ; med route
-        W !,"MED ROUTE: ",$S(PSGMR:PSGMRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
-        I X="",PSGMR S X=PSGMRN I PSGMR'=PSGMRN,$D(^PS(51.2,PSGMR,0)) W "  "_$P(^(0),"^",3) S PSGFOK(3)="" G 26
-        S PSGF2=3 I $S(X="@":1,X]"":0,1:'PSGMR) W $C(7),"  (Required)" S X="?" D ENHLP^PSGOEM(53.1,3) G 3
-        I X?1."?" D ENHLP^PSGOEM(53.1,3)
-        I $E(X)="^" D FF G:Y>0 @Y G 3
-        K DIC S DIC="^PS(51.2,",DIC(0)="EMQZ",DIC("S")="I $P(^(0),""^"",4)" D ^DIC K DIC I Y'>0 G 3
-        S PSGMR=+Y,PSGMRN=Y(0,0),PSGFOK(3)=""
-        ;
-26      ; schedule
-        W !,"SCHEDULE: ",$S(PSGSCH]"":PSGSCH_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
-        S:X="" X=PSGSCH S PSGF2=26 ; I "@"[X W $C(7),"  (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G 26
-        I X?1."?" D ENHLP^PSGOEM(53.1,26) G 26
-        I $E(X)="^" D FF G:Y>0 @Y G 26
-        I X="" S (PSGS0XT,PSGS0Y,PSGST)=""
-        E  D EN^PSGS0 I '$D(X) W $C(7),"  ??" S X="?" D ENHLP^PSGOEM(53.1,26) G 26
-        S PSGSCH=X,(PSGFOK(26),PSGST)="",PSGOES=1 S:PSGS0XT="O" $P(PSGNEDFD,"^",3)="O",PSGST="O" D ^PSGNE3 K PSGOES
-        ;
-66      ; provider's comments
-        ;
-        ;
-DONE    ;
-        I PSGOROE1 K Y W $C(7),"  ...order not entered..."
-        K F,F0,F1,PSGF2,F3,PSGFOK,SDT Q
-        ;
-FF      ; up-arrow to another field
-        S Y=-1 I '$D(PSGFOK) W $C(7),"  ??" Q
-        S X=$E(X,2,99) I X=+X S Y=$S($D(PSGFOK(X)):X,1:-1) W "  " W:Y>0 $$CODES2^PSIVUTL(53.1,X) W:Y'>0 $C(7),"??" Q
-        K DIC S DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I $D(PSGFOK(+Y))" D ^DIC K DIC S Y=+Y
-        Q
-        ;
-DEL     ;
-        W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W "  <NOTHING DELETED>"
-        Q
-        ;
-GTST(ON)        ; Find schedule type for pending order.
-        N PD,PDAP,ST,X,ST1 S ST=""
-        S ST=$P($G(^PS(53.1,+ON,0)),"^",7)
-        I $P($G(^PS(53.1,+ON,0)),U,24)="R" D
-        .; naked ref below is from line above, ^PS(53.1,ON,0)
-        .S X=$P(^(0),U,25) S ST=$S(X["N"!(X["P"):$P($G(^PS(53.1,+X,0)),U,7),X["V":"C",1:$P($G(^PS(55,PSGP,5,+X,0)),U,7))
-        .I ST]"" S (PSGOST,PSGST)=ST,PSGSTN=$$ENSTN^PSGMI(ST) Q
-        I ST'="" D
-        . S ST1=""
-        . S PD=+$G(^PS(53.1,+ON,.2)) S X=$G(^PS(50.7,PD,0)),ST1=$P(X,U,7)
-        . I $G(ST1)="R" S ST="R"
-        . K ST1
-        I ST="" D
-        . ;PSJ*5*156 - Don't allow backdoor to override intended schedule type from CPRS unless the default
-        . ;            schedule type (if any) is "Fill on Request".
-        . S PD=+$G(^PS(53.1,+ON,.2)) S X=$G(^PS(50.7,PD,0)),ST=$P(X,U,7)  ;see if there is a default schedule type.
-        . I ST="R" Q  ;Fill on Request default schedule type will override incoming schedule type from CPRS
-        . S ST=""  ;Reset to null in case default schedule type other than Fill on Request is defined.
-        . D OTS I ST="O" Q
-        . I PSGSCH="ON CALL"!(PSGSCH="ONCALL")!(PSGSCH="ON-CALL") S ST="OC" Q
-        . I PSGSCH["PRN" S ST="P" Q
-        . S ST="C"
-        S (PSGOST,PSGST)=ST,PSGSTN=$$ENSTN^PSGMI(ST)
-        Q
-OTS     I PSGSCH]"" S X=+$O(^PS(51.1,"B",PSGSCH,0)) I $P($G(^PS(51.1,X,0)),"^",5)="O" S ST="O" Q
-        I PSGSCH="TODAY"!(PSGSCH="NOW")!(PSGSCH="STAT")!(PSGSCH="ONCE")!(PSGSCH="ONE TIME")!(PSGSCH="ONE-TIME")!(PSGSCH="ONETIME")!(PSGSCH="1TIME")!(PSGSCH="1 TIME")!(PSGSCH="1-TIME") S ST="O"
-        Q
+PSGOE6 ;BIR/CML3-ORDER ENTRY THROUGH OE/RR ;10 Mar 98 / 2:35 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**3,7,39,45,65,58,81,156**;16 DEC 97
+ ;
+ ; Reference to ^PS(50.7 supported by DBIA #2180.
+ ; Reference to ^PS(51.1 is supported by DBIA #2177.
+ ; Reference to ^PS(51.2 is supported by DBIA #2178.
+ ; Reference to ^PS(55 is supported by DBIA #2191.
+ ; Reference to ^DD(53.1 is supported by DBIA #2256.
+ ; Reference to ^VA(200 is supported by DBIA #10060.
+ ; Reference to ^DICN is supported by DBIA #10009.
+ ;
+ K PSGFOK S F1=53.1,PSGPR=$S($D(PSGOERR):PSJORPV,1:PSGOEPR),PSGMR=$S($P(PSGNEDFD,"^",2):$P(PSGNEDFD,"^",2),1:PSGOEDMR),PSGSCH=$P(PSGNEDFD,"^",4),(PSGOROE1,PSGSI,SDT,PSGMRN,PSGSM,PSGHSM,PSGUD,PSGSD,PSGFD,PSGSI,PSGNEFD,PSGNESD)=""
+ S:PSGMR PSGMRN=$S('$P(PSGNEDFD,"^",2):"ORAL",'$D(^PS(51.2,PSGMR,0)):PSGMR,$P(^(0),"^")]"":$P(^(0),"^"),1:PSGMR) I PSGPR S PSGPRN=$P($G(^VA(200,PSGPR,0)),"^") S:PSGPRN="" PSGPRN=PSGPR
+ S PSGST=$S($P(PSGNEDFD,"^",3)]"":$P(PSGNEDFD,"^",3),1:"C")
+ K ^PS(53.45,PSJSYSP,1),^(2) I PSGDRG S ^(2,0)="^53.4502P^"_PSGDRG_"^1",^(1,0)=PSGDRG,^PS(53.45,PSJSYSP,2,"B",PSGDRG,1)=""
+ ;
+109 ; dosage ordered
+ W !,"DOSAGE ORDERED: ",$S(PSGDO]"":PSGDO_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
+ I X="" S X=PSGDO I X="" W $C(7),"  (Required)" G 109
+ S PSGF2=109 I X="@" W $C(7),"  (Required)" G 109
+ I X?1."?" S F1=53.1 D ENHLP^PSGOEM(53.1,109) G 109
+ I $E(X)="^" D FF G:Y>0 @Y G 109
+ I $E(X,$L(X))=" " F  S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" "
+ I $S(X?.E1C.E:1,$L(X)>20:1,X="":1,X["^":1,X?1.P:1,1:X=+X) W $C(7),"  ",$S(X?1.P!(X=""):"(Required)",1:"??") S X="?" D ENHLP^PSGOEM(53.1,109) G 109
+ S PSGDO=X,PSGFOK(109)=""
+ ;
+3 ; med route
+ W !,"MED ROUTE: ",$S(PSGMR:PSGMRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
+ I X="",PSGMR S X=PSGMRN I PSGMR'=PSGMRN,$D(^PS(51.2,PSGMR,0)) W "  "_$P(^(0),"^",3) S PSGFOK(3)="" G 26
+ S PSGF2=3 I $S(X="@":1,X]"":0,1:'PSGMR) W $C(7),"  (Required)" S X="?" D ENHLP^PSGOEM(53.1,3) G 3
+ I X?1."?" D ENHLP^PSGOEM(53.1,3)
+ I $E(X)="^" D FF G:Y>0 @Y G 3
+ K DIC S DIC="^PS(51.2,",DIC(0)="EMQZ",DIC("S")="I $P(^(0),""^"",4)" D ^DIC K DIC I Y'>0 G 3
+ S PSGMR=+Y,PSGMRN=Y(0,0),PSGFOK(3)=""
+ ;
+26 ; schedule
+ W !,"SCHEDULE: ",$S(PSGSCH]"":PSGSCH_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
+ S:X="" X=PSGSCH S PSGF2=26 ; I "@"[X W $C(7),"  (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G 26
+ I X?1."?" D ENHLP^PSGOEM(53.1,26) G 26
+ I $E(X)="^" D FF G:Y>0 @Y G 26
+ I X="" S (PSGS0XT,PSGS0Y,PSGST)=""
+ E  D EN^PSGS0 I '$D(X) W $C(7),"  ??" S X="?" D ENHLP^PSGOEM(53.1,26) G 26
+ S PSGSCH=X,(PSGFOK(26),PSGST)="",PSGOES=1 S:PSGS0XT="O" $P(PSGNEDFD,"^",3)="O",PSGST="O" D ^PSGNE3 K PSGOES
+ ;
+66 ; provider's comments
+ ;S DA=PSJSYSP,DIE="^PS(53.45,",DR=4 D ^DIE K DA,DIE,DR
+ ;S PSGFOK(66)="",Y=1
+ ;
+ ;
+DONE ;
+ I PSGOROE1 K Y W $C(7),"  ...order not entered..."
+ K F,F0,F1,PSGF2,F3,PSGFOK,SDT Q
+ ;
+FF ; up-arrow to another field
+ S Y=-1 I '$D(PSGFOK) W $C(7),"  ??" Q
+ S X=$E(X,2,99) I X=+X S Y=$S($D(PSGFOK(X)):X,1:-1) W "  " W:Y>0 $$CODES2^PSIVUTL(53.1,X) W:Y'>0 $C(7),"??" Q
+ K DIC S DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I $D(PSGFOK(+Y))" D ^DIC K DIC S Y=+Y
+ Q
+ ;
+DEL ;
+ W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W "  <NOTHING DELETED>"
+ Q
+ ;
+GTST(ON) ; Find schedule type for pending order.
+ N PD,PDAP,ST,X S ST="" I $P($G(^PS(53.1,+ON,0)),U,24)="R" D
+ .; naked ref below is from line above, ^PS(53.1,ON,0)
+ .S X=$P(^(0),U,25) S ST=$S(X["N"!(X["P"):$P($G(^PS(53.1,+X,0)),U,7),X["V":"C",1:$P($G(^PS(55,PSGP,5,+X,0)),U,7))
+ .I ST]"" S (PSGOST,PSGST)=ST,PSGSTN=$$ENSTN^PSGMI(ST) Q
+ I ST="" D
+ . ;PSJ*5*156 - Don't allow backdoor to override intended schedule type from CPRS unless the default
+ . ;            schedule type (if any) is "Fill on Request".
+ . S PD=+$G(^PS(53.1,+ON,.2)) S X=$G(^PS(50.7,PD,0)),ST=$P(X,U,7)  ;see if there is a default schedule type.
+ . I ST="R" Q  ;Fill on Request default schedule type will override incoming schedule type from CPRS
+ . S ST=""  ;Reset to null in case default schedule type other than Fill on Request is defined.
+ . D OTS I ST="O" Q
+ . I PSGSCH="ON CALL"!(PSGSCH="ONCALL")!(PSGSCH="ON-CALL") S ST="OC" Q
+ . I PSGSCH["PRN" S ST="P" Q
+ . S ST="C"
+ S (PSGOST,PSGST)=ST,PSGSTN=$$ENSTN^PSGMI(ST)
+ Q
+OTS I PSGSCH]"" S X=+$O(^PS(51.1,"B",PSGSCH,0)) I $P($G(^PS(51.1,X,0)),"^",5)="O" S ST="O" Q
+ I PSGSCH="TODAY"!(PSGSCH="NOW")!(PSGSCH="STAT")!(PSGSCH="ONCE")!(PSGSCH="ONE TIME")!(PSGSCH="ONE-TIME")!(PSGSCH="ONETIME")!(PSGSCH="1TIME")!(PSGSCH="1 TIME")!(PSGSCH="1-TIME") S ST="O"
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m

@@ -1 @@
-PSGOEC  ;BIR/CML3-CANCEL ORDERS ;02 Mar 99 / 9:29 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**23,58,110,175,201,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(55 is supported by DBIA# 2191.
-        ; Reference to ^PSSLOCK is supported by DBIA 2789.
-        ; 
-ENA     ; all orders
-        D ENCV^PSGSETU Q:$D(XQUIT)  S CF=$P(PSJSYSP0,U,5) N ND,ND1 S ND="$D(^PS(55,PSGP,5,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)",ND1="$D(^PS(53.1,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)"
-        F  W !!,"Do you want to ",$S(CF:"discontinue",1:"mark for discontinuation")," all of this patient's orders" S %=1 D YN^DICN Q:%  D ENCAM^PSGOEM
-        S PSGCF=0 Q:%<0  S PSGCF=1,T=$E("T",'PSJSYSU) G:%=1 ENCA F T=0:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T  F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA  I @ND Q
-        E  F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA  I @ND1 Q
-        E  G DONE
-        W !!,"SOME OR ALL OF THESE ORDERS HAVE" D ENUMK^PSGOEM Q:%'=1
-        W !!,"...a few moments, please..." S PSGAL("C")=PSJSYSU*10+21400
-        F T=PSGDT:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T  F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA  I @ND W "." D RS,^PSGAL5
-        F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA  I @ND1 W "." D RS
-        W " . . . DONE!" G DONE
-ENCA    ;
-        D NOW^%DTC S (Q1,PSGDT)=+$E(%,1,12) F  S Q1=$O(^PS(55,PSGP,5,"AUS",Q1)) Q:'Q1  F Q2=0:0 S Q2=$O(^PS(55,PSGP,5,"AUS",Q1,Q2)) Q:'Q2  I $P($G(^PS(55,PSGP,5,Q2,0)),"^",21) Q
-        E  F Q2=0:0 S Q2=$O(^PS(53.1,"AC",PSGP,Q2)) Q:'Q2  I $P($G(^PS(53.1,Q2,0)),U,21) Q
-        I  S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0!('$$REQPROV) D  G DONE
-        .W !!,$C(7),"No changes made to this order." D PAUSE^VALM1
-        S PSGALR=$S('$D(PSGALO):20,PSGALO?4N&($E(PSGALO)=1):10,1:20) I $P(PSJSYSP0,U,5) D ENHE^PSJADT0 S PSGOP=PSGP D ASET
-        F SD=PSGDT:0 S SD=$O(^PS(55,PSGP,5,"AUS",SD)) Q:'SD  F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,5,"AUS",SD,PSGORD)) Q:'PSGORD  S PSGORD=+PSGORD_"A" D AC
-        D NSET S CF=$P(PSJSYSP0,U,5) F PSGORD=0:0 S PSGORD=$O(^PS(53.1,"AC",PSGP,PSGORD)) Q:'PSGORD  S PSGORD=+PSGORD_"N" D NC
-        W " . . . DONE!" K PSGORD G DONE
-ENO(PSGP,PSGORD)        ; single order
-        I PSGSTAT="D" W !,"This order has already been DISCONTINUED." D PAUSE^VALM1 Q
-        S CF=$S($P(PSJSYSP0,U,5):1,PSGORD["U":0,1:($P($G(^PS(53.1,+PSGORD,0)),U,25)=""&($P($G(^(4)),U,7)=DUZ)))
-        S PSJCOM=+$S(PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),"^",8),1:$P($G(^PS(53.1,+PSGORD,.2)),"^",8))
-        I 'CF,PSJCOM W !!,"This order is part of a complex order and CANNOT be marked for discontinuation." Q
-        I $$PNDRNOK(PSGORD) N PSJDCTYP S PSJDCTYP=$$PNDRNA(PSGORD) D:(PSJDCTYP=1!(PSJDCTYP=2)) PNDRN($G(PSJDCTYP),PSGORD) G DONE
-        I PSJCOM W !!,"This order is part of a complex order. If you discontinue this order the",!,"following orders will be discontinued too (unless the stop date has already",!,"been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
-        F  W !!,"Do you want to ",$S(PSJCOM:"discontinue this series of complex orders",CF:"discontinue this order",1:"mark this order for discontinuation") S %=1 D YN^DICN Q:%  D ENCOM^PSGOEM
-        I %<0 S VALMBCK="" Q
-        G:%=1 SOC I $S(PSGORD["U":$D(^PS(55,PSGP,5,+PSGORD,4)),1:$D(^PS(53.1,+PSGORD,4))),$P(^(4),U,12) W !!,"THIS ORDER HAS"
-        I  D ENUMK^PSGOEM I %=1 W "..." K DA S:PSGORD["A" PSGAL("C")=PSJSYSU*10+21400,DA=+PSGORD,DA(1)=PSGP D RS,^PSGAL5:PSGORD["A" W " . . . DONE!"
-        G DONE
-SOC     ;
-        I 'CF,'$P($S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,0)),1:$G(^PS(53.1,+PSGORD,0))),U,21) W !!,"...one moment, please..."
-        E  I CF,'($G(PSJDCTYP)=2) S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0 D ABORT^PSGOEE G DONE
-        ; prompt for requesting provider
-        I '($G(PSJDCTYP)=2) I CF,'$$REQPROV D ABORT^PSGOEE G DONE
-        K DA D NOW^%DTC S PSGDT=%,T=$E("T",'PSJSYSU),PSGALR=20,DA=+PSGORD,DA(1)=PSGP
-        I 'PSJCOM D
-        .I PSGORD["U" D ASET:CF,AC
-        .I PSGORD'["U" D NSET:CF,NC
-        I PSJCOM N COMFLG S COMFLG=0 D
-        . I PSGORD["P" Q:('$$LOCK^PSJOEA(PSGP,PSJCOM))  D 
-        .. N O S O="" F  S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O=""  S (PSGORD,PSJORD)=O_"P" D NSET,NC
-        .I PSGORD["U" N O,OO S O=0,OO="" F  S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O  F  S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO=""  Q:COMFLG  D
-        .. Q:OO=PSGORD  I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q
-        I PSJCOM Q:COMFLG  N O,OO S O=0,OO="" F  S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O  F  S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO=""  D
-        . I OO["V" S ON55=OO D D1^PSIVOPT2 S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3) D
-        .. D LOG^PSIVORAL N PSJORD S PSJORD=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),P("NAT")=PSJNOO D HL^PSIVORA
-        . I OO["U" N PSGORD,PSJORD S (PSGORD,PSJORD)=OO D ASET^PSGOEC,AC^PSGOEC
-        Q
-D1      N %,DA,DIE,DIU,STP,NSTOP
-        D NOW^%DTC S NSTOP=+$E(%,1,12),STP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),NSTOP=+$S(STP>NSTOP:NSTOP,1:STP),P(17)="D"
-        S DA(1)=DFN,DA=+ON55,DIE="^PS(55,"_DFN_",""IV"",",DR="109////"_NSTOP_$S('$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7):";116////"_STP,1:"")_";100///D;.03////"_NSTOP,PSIVACT=1 D ^DIE
-        I $S($G(PSIVAC)="OD":0,$G(PSIVAC)'="AD":1,$G(PSGALO)<1060:0,1:$P($G(PSJSYSW0),U,15)) S X=$S($G(PSIVAC)="AD":1,1:2) D ENLBL^PSIVOPT(X,$S(X=1:+$G(PSGUOW),1:DUZ),DFN,3,+ON55,$E("AD",1,3-X))
-        D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF  ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN
-        Q
-OUT     ;
-        W $S(PSJCOM:"...ORDER ",1:"...ORDERS "),$S(CF:"DISCONTINUED!",1:"MARKED!") S PSGCANFL=1
-DONE    ;
-        K CF,DA,DIE,DP,DR,ORIFN,ORETURN,PSGAL,PSGALR,PSGDA,SD,ST,T,UCF,Y,PSJDCTYP Q
-ASET    ;
-        S DIE="^PS(55,"_PSGP_",5,",DR="28////"_$S($P($G(^PS(55,PSGP,5,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_";Q;34////"_PSGDT_$S(T]"":";49////1",1:"")
-        Q
-NSET    ;
-        S DIE="^PS(53.1,",DR="28////"_$S($P($G(^PS(53.1,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_$S(T]"":";42////1",1:"")_";25////"_PSGDT Q
-AC      ;
-        I 'CF K DA S $P(^PS(55,PSGP,5,+PSGORD,4),U,11,14)="^1^"_DUZ_U_PSGDT,PSGAL("C")=13040,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5
-        I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
-        Q:'CF  K DA,ORIFN S PSGAL("C")=PSJSYSU*10+4000,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5 S $P(^(2),U,3)=$P(^PS(55,PSGP,5,+PSGORD,2),U,4) D ^DIE S ^PS(55,"AUE",PSGP,+PSGORD)=""
-        I PSJSYSL K DA S $P(^PS(55,PSGP,5,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD,DA(1)=PSGP D ENL^PSGVDS
-        S ORIFN=$P($G(^PS(55,PSGP,5,+PSGORD,0)),U,21) D:ORIFN DCOR^PSGOECS
-        Q
-NC      ;
-        I 'CF S $P(^PS(53.1,+PSGORD,4),"^",11,14)="^1^"_DUZ_U_PSGDT
-        I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
-        Q:'CF  S PSGSTAT=$P($G(^PS(53.1,+PSGORD,0)),U,9),PSGORIFN=$P($G(^(0)),U,21)
-        I PSGSTAT'="U" K DA,ORIFN S DA=+PSGORD D ^DIE I PSJSYSL,PSJSYSL<3,(PSGSTAT'="P") S $P(^PS(53.1,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS
-        I PSGSTAT="U" K DA S DA=+PSGORD,DIK="^PS(53.1," D ^DIK
-        I PSGORIFN S ORIFN=PSGORIFN D DCOR^PSGOECS
-        Q
-T       ;
-        F  W !!,"Is this due to the patient being transferred" S %=2 D YN^DICN Q:%  D ENCTM^PSGOEM1
-        S T=$S(%<0:"^",1:$E("T",%=1)) Q
-RS      ;
-        ; naked ref below is from variable ND1, ^PS(53.1,PSGDA,4)
-        S $P(^(4),U,11,14)="^^^" Q
-REQPROV()                ;
-        I $G(PSJDCTYP)=2 Q 1
-        K PSJDCPRV,DIC,DUOUT,DTOUT,Y
-        N PROVIDER,PROVNAME,RESULT,RSB S RESULT=0
-        S PROVIDER=+$P($G(^PS(55,DFN,5.1)),"^",2),PROVNAME=""
-        I PROVIDER>0 D
-        .S DIC=200,DR="53.1;53.4",DIQ="RSB",DIQ(0)="I",DA=PROVIDER D EN^DIQ1
-        .K DIC,DR,DA,DIQ
-        .I $G(RSB(200,PROVIDER,53.1,"I"))="1"&(($G(RSB(200,PROVIDER,53.4,"I"))="")!($G(RSB(200,PROVIDER,53.4,"I"))>DT)) D
-        ..S DIC=200,DA=PROVIDER,DR=".01",DIQ="RSB",DIQ(0)="E" D EN^DIQ1
-        ..S PROVNAME=$G(RSB(200,PROVIDER,.01,"E")) K DA,DIQ,DR
-        K DIC S DIC=200,DIC(0)="AEMQZ"
-        S:PROVNAME]"" DIC("B")=PROVNAME
-        S DIC("A")="Requesting PROVIDER: "
-        S DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DIC
-        I +Y>0,'$D(DUOUT),'$D(DTOUT) S RESULT=1,PSJDCPRV=+Y
-        Q RESULT
-        ;
-PNDRNA(ORDER)   ; Ask Discontinue Pending Renewal only, or both Pending Renew and Renewed Order
-        ; Perform this action only for pending renewals
-        I '$G(ORDER)!'($G(ORDER)["P") Q 3
-        ; Quit if original order is no longer active
-        N ORIGORD,ORIGSTOP S ORIGORD=$P($G(^PS(53.1,+ORDER,0)),"^",25) Q:'ORIGORD  D  I ORIGSTOP<$G(PSGDT) Q 1
-        .S ORIGSTOP=$S(ORIGORD["U":$P($G(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$P($G(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"")
-        N NDP2
-        S NDP2=^PS(53.1,+ORDER,.2) S DRG=NDP2,DO=$P(DRG,"^",2) S DRG=$$ENPDN^PSGMI($P(DRG,"^"))
-        S ND2=^PS(53.1,+ORDER,2) S SCH=$P(ND2,"^"),START=$P(ND2,"^",2),START=$$FMTE^XLFDT(START,2)
-        W !!?5,DRG_" "_DO
-        W !?5,"This order has a pending status. If this pending order"
-        W !?5,"is discontinued, the original order may still be active."
-        S DIR("A")="Select order(s) to discontinue"
-        S DIR(0)="S^1:DC BOTH Orders;2:DC Pending Order;3:Cancel - No Action Taken"
-        S DIR("L",1)="1 - DC BOTH Orders"
-        S DIR("L",2)="2 - DC Pending Order"
-        S DIR("L",3)="3 - Cancel - No Action Taken" D ^DIR
-        ; Reverse order - Y=1 - Pending only  Y=2:BOTH
-        S Y=$S(Y=1:2,Y=2:1,1:3)
-        Q Y
-        ;
-PNDRN(PSJDCTYP,ORDER)   ; Perform Discontinue action for Pending order only or both Pending and Renewed
-        ; Perform this action only for pending renewals
-        N PSGORD S PSGORD=ORDER
-        Q:'$G(PSGORD)!'($G(PSGORD)["P")
-        I PSJDCTYP=1 G SOC
-        I PSJDCTYP=2 S PSJDCTYP=1 D SOC Q:'$G(PSJDCTYP)  D
-        .I ($G(PSJNOO)<0) Q
-        .N ND5310 S ND5310=$G(^PS(53.1,+PSGORD,0))
-        .N PSGORD S PSGORD=$P(ND5310,"^",25) I PSGORD S PSJDCTYP=2 D SOC K PSJDCTYP
-        Q
-PNDRNOK(ORDER)  ; Execute DC Pending Renew if 
-        ;                  1) Renewal order is pending/non-verified, and 
-        ;                  2) Original order is not DC'd or Expired
-        Q:'$G(PSGORD)!'($G(PSGORD)["P") 0
-        N ORIGORD,ORIGSTOP S ORIGORD=$P($G(^PS(53.1,+ORDER,0)),"^",25) Q:'ORIGORD 0  D  I ORIGSTOP<$G(PSGDT) Q 0
-        .S ORIGSTOP=$S(ORIGORD["U":$P($G(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$P($G(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"")
-        Q:'($P($G(^PS(53.1,+PSGORD,0)),U,24)="R") 0
-        Q 1
+PSGOEC ;BIR/CML3-CANCEL ORDERS ;02 Mar 99 / 9:29 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**23,58,110,175**;16 DEC 97;Build 18
+ ;
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^PSSLOCK is supported by DBIA 2789.
+ ; 
+ENA ; all orders
+ D ENCV^PSGSETU Q:$D(XQUIT)  S CF=$P(PSJSYSP0,U,5) N ND,ND1 S ND="$D(^PS(55,PSGP,5,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)",ND1="$D(^PS(53.1,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)"
+ F  W !!,"Do you want to ",$S(CF:"discontinue",1:"mark for discontinuation")," all of this patient's orders" S %=1 D YN^DICN Q:%  D ENCAM^PSGOEM
+ S PSGCF=0 Q:%<0  S PSGCF=1,T=$E("T",'PSJSYSU) G:%=1 ENCA F T=0:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T  F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA  I @ND Q
+ E  F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA  I @ND1 Q
+ E  G DONE
+ W !!,"SOME OR ALL OF THESE ORDERS HAVE" D ENUMK^PSGOEM Q:%'=1
+ W !!,"...a few moments, please..." S PSGAL("C")=PSJSYSU*10+21400
+ F T=PSGDT:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T  F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA  I @ND W "." D RS,^PSGAL5
+ F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA  I @ND1 W "." D RS
+ W " . . . DONE!" G DONE
+ENCA ;
+ D NOW^%DTC S (Q1,PSGDT)=+$E(%,1,12) F  S Q1=$O(^PS(55,PSGP,5,"AUS",Q1)) Q:'Q1  F Q2=0:0 S Q2=$O(^PS(55,PSGP,5,"AUS",Q1,Q2)) Q:'Q2  I $P($G(^PS(55,PSGP,5,Q2,0)),"^",21) Q
+ E  F Q2=0:0 S Q2=$O(^PS(53.1,"AC",PSGP,Q2)) Q:'Q2  I $P($G(^PS(53.1,Q2,0)),U,21) Q
+ I  S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0!('$$REQPROV) D  G DONE
+ .W !!,$C(7),"No changes made to this order." D PAUSE^VALM1
+ S PSGALR=$S('$D(PSGALO):20,PSGALO?4N&($E(PSGALO)=1):10,1:20) I $P(PSJSYSP0,U,5) D ENHE^PSJADT0 S PSGOP=PSGP D ASET
+ F SD=PSGDT:0 S SD=$O(^PS(55,PSGP,5,"AUS",SD)) Q:'SD  F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,5,"AUS",SD,PSGORD)) Q:'PSGORD  S PSGORD=+PSGORD_"A" D AC
+ D NSET S CF=$P(PSJSYSP0,U,5) F PSGORD=0:0 S PSGORD=$O(^PS(53.1,"AC",PSGP,PSGORD)) Q:'PSGORD  S PSGORD=+PSGORD_"N" D NC
+ W " . . . DONE!" K PSGORD G DONE
+ENO(PSGP,PSGORD) ; single order
+ I PSGSTAT="D" W !,"This order has already been DISCONTINUED." D PAUSE^VALM1 Q
+ S CF=$S($P(PSJSYSP0,U,5):1,PSGORD["U":0,1:($P($G(^PS(53.1,+PSGORD,0)),U,25)=""&($P($G(^(4)),U,7)=DUZ)))
+ S PSJCOM=+$S(PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),"^",8),1:$P($G(^PS(53.1,+PSGORD,.2)),"^",8))
+ I 'CF,PSJCOM W !!,"This order is part of a complex order and CANNOT be marked for discontinuation." Q
+ I PSJCOM W !!,"This order is part of a complex order. If you discontinue this order the",!,"following orders will be discontinued too (unless the stop date has already",!,"been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
+ F  W !!,"Do you want to ",$S(PSJCOM:"discontinue this series of complex orders",CF:"discontinue this order",1:"mark this order for discontinuation") S %=1 D YN^DICN Q:%  D ENCOM^PSGOEM
+ I %<0 S VALMBCK="" Q
+ G:%=1 SOC I $S(PSGORD["U":$D(^PS(55,PSGP,5,+PSGORD,4)),1:$D(^PS(53.1,+PSGORD,4))),$P(^(4),U,12) W !!,"THIS ORDER HAS"
+ I  D ENUMK^PSGOEM I %=1 W "..." K DA S:PSGORD["A" PSGAL("C")=PSJSYSU*10+21400,DA=+PSGORD,DA(1)=PSGP D RS,^PSGAL5:PSGORD["A" W " . . . DONE!"
+ G DONE
+SOC ;
+ I 'CF,'$P($S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,0)),1:$G(^PS(53.1,+PSGORD,0))),U,21) W !!,"...one moment, please..."
+ E  I CF S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0 D ABORT^PSGOEE G DONE
+ ; prompt for requesting provider
+ I CF,'$$REQPROV D ABORT^PSGOEE G DONE
+ K DA D NOW^%DTC S PSGDT=%,T=$E("T",'PSJSYSU),PSGALR=20,DA=+PSGORD,DA(1)=PSGP
+ I 'PSJCOM D
+ .I PSGORD["U" D ASET:CF,AC
+ .I PSGORD'["U" D NSET:CF,NC
+ I PSJCOM N COMFLG S COMFLG=0 D
+ . I PSGORD["P" Q:('$$LOCK^PSJOEA(PSGP,PSJCOM))  D 
+ .. N O S O="" F  S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O=""  S (PSGORD,PSJORD)=O_"P" D NSET,NC
+ .I PSGORD["U" N O,OO S O=0,OO="" F  S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O  F  S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO=""  Q:COMFLG  D
+ .. Q:OO=PSGORD  I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q
+ I PSJCOM Q:COMFLG  N O,OO S O=0,OO="" F  S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O  F  S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO=""  D
+ . I OO["V" S ON55=OO D D1^PSIVOPT2 S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3) D
+ .. D LOG^PSIVORAL N PSJORD S PSJORD=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),P("NAT")=PSJNOO D HL^PSIVORA
+ . I OO["U" N PSGORD,PSJORD S (PSGORD,PSJORD)=OO D ASET^PSGOEC,AC^PSGOEC
+ Q
+D1 N %,DA,DIE,DIU,STP,NSTOP
+ D NOW^%DTC S NSTOP=+$E(%,1,12),STP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),NSTOP=+$S(STP>NSTOP:NSTOP,1:STP),P(17)="D"
+ S DA(1)=DFN,DA=+ON55,DIE="^PS(55,"_DFN_",""IV"",",DR="109////"_NSTOP_$S('$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7):";116////"_STP,1:"")_";100///D;.03////"_NSTOP,PSIVACT=1 D ^DIE
+ I $S($G(PSIVAC)="OD":0,$G(PSIVAC)'="AD":1,$G(PSGALO)<1060:0,1:$P($G(PSJSYSW0),U,15)) S X=$S($G(PSIVAC)="AD":1,1:2) D ENLBL^PSIVOPT(X,$S(X=1:+$G(PSGUOW),1:DUZ),DFN,3,+ON55,$E("AD",1,3-X))
+ D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF  ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN
+ Q
+OUT ;
+ W $S(PSJCOM:"...ORDER ",1:"...ORDERS "),$S(CF:"DISCONTINUED!",1:"MARKED!") S PSGCANFL=1
+DONE ;
+ K CF,DA,DIE,DP,DR,ORIFN,ORETURN,PSGAL,PSGALR,PSGDA,SD,ST,T,UCF,Y Q
+ASET ;
+ S DIE="^PS(55,"_PSGP_",5,",DR="28////"_$S($P($G(^PS(55,PSGP,5,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_";Q;34////"_PSGDT_$S(T]"":";49////1",1:"")
+ Q
+NSET ;
+ S DIE="^PS(53.1,",DR="28////"_$S($P($G(^PS(53.1,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_$S(T]"":";42////1",1:"")_";25////"_PSGDT Q
+AC ;
+ I 'CF K DA S $P(^PS(55,PSGP,5,+PSGORD,4),U,11,14)="^1^"_DUZ_U_PSGDT,PSGAL("C")=13040,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5
+ I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
+ Q:'CF  K DA,ORIFN S PSGAL("C")=PSJSYSU*10+4000,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5 S $P(^(2),U,3)=$P(^PS(55,PSGP,5,+PSGORD,2),U,4) D ^DIE S ^PS(55,"AUE",PSGP,+PSGORD)=""
+ I PSJSYSL K DA S $P(^PS(55,PSGP,5,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD,DA(1)=PSGP D ENL^PSGVDS
+ S ORIFN=$P($G(^PS(55,PSGP,5,+PSGORD,0)),U,21) D:ORIFN DCOR^PSGOECS
+ Q
+NC ;
+ I 'CF S $P(^PS(53.1,+PSGORD,4),"^",11,14)="^1^"_DUZ_U_PSGDT
+ I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
+ Q:'CF  S PSGSTAT=$P($G(^PS(53.1,+PSGORD,0)),U,9),PSGORIFN=$P($G(^(0)),U,21)
+ I PSGSTAT'="U" K DA,ORIFN S DA=+PSGORD D ^DIE I PSJSYSL,PSJSYSL<3,(PSGSTAT'="P") S $P(^PS(53.1,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS
+ I PSGSTAT="U" K DA S DA=+PSGORD,DIK="^PS(53.1," D ^DIK
+ I PSGORIFN S ORIFN=PSGORIFN D DCOR^PSGOECS
+ Q
+T ;
+ F  W !!,"Is this due to the patient being transferred" S %=2 D YN^DICN Q:%  D ENCTM^PSGOEM1
+ S T=$S(%<0:"^",1:$E("T",%=1)) Q
+RS ;
+ ; naked ref below is from variable ND1, ^PS(53.1,PSGDA,4)
+ S $P(^(4),U,11,14)="^^^" Q
+ ;
+REQPROV()          ;
+ K PSJDCPRV,DIC,DUOUT,DTOUT,Y
+ N PROVIDER,PROVNAME,RESULT,RSB S RESULT=0
+ S PROVIDER=+$P($G(^PS(55,DFN,5.1)),"^",2),PROVNAME=""
+ I $G(PSJRQPND) S PROVIDER=0
+ I PROVIDER>0 D
+ .S DIC=200,DR="53.1;53.4",DIQ="RSB",DIQ(0)="I",DA=PROVIDER D EN^DIQ1
+ .K DIC,DR,DA,DIQ
+ .I $G(RSB(200,PROVIDER,53.1,"I"))="1"&(($G(RSB(200,PROVIDER,53.4,"I"))="")!($G(RSB(200,PROVIDER,53.4,"I"))>DT)) D
+ ..S DIC=200,DA=PROVIDER,DR=".01",DIQ="RSB",DIQ(0)="E" D EN^DIQ1
+ ..S PROVNAME=$G(RSB(200,PROVIDER,.01,"E")) K DA,DIQ,DR
+ K DIC S DIC=200,DIC(0)="AEMQZ"
+ S:PROVNAME]"" DIC("B")=PROVNAME
+ S DIC("A")="Requesting PROVIDER: "
+ S DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DIC
+ I +Y>0,'$D(DUOUT),'$D(DTOUT) S RESULT=1,PSJDCPRV=+Y
+ Q RESULT

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOECS.m

@@ -1 @@
-PSGOECS ;BIR/CML3-CANCEL SELECTED ORDERS ;02 Mar 99 / 9:29 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**23,29,44,58,81,110,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to FULL^VALM1 is supported by DBIA# 10116.
-        ; Reference to ^PS(55 is supported by DBIA# 2191.
-        ; Reference to ^PSSLOCK is supported by DBIA #2789.
-        ;
-AM      ;
-        W !,"...marking ",$P(X,U),"..." S $P(^PS(55,PSGP,5,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT,PSGAL("C")=13040 W "." D ^PSGAL5 W "."
-        I $D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
-        Q
-        ;
-NM      ;
-        W !,"...marking ",$P(X,U),"..." S $P(^PS(53.1,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT W "."
-        I $D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSD=PSGDT,PSGPOSA="C" D ENPOS^PSGVDS
-        Q
-        ;
-AC      ; discontinue active order
-        K DA S DA(1)=PSGP,DA=+PSGORD
-        S X=$G(^PS(55,PSGP,5,DA,.2))
-        I $P(X,U,4)="D" W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON DONE ORDER",!,$C(7) HANG 1 Q 
-        NEW XX S XX=$P(^PS(55,PSGP,5,DA,0),U,9)
-        I $S(XX="E":1,XX="D":1,XX="DE":1,1:0) W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON "_$$CODES^PSIVUTL(XX,55.06,28)_" ORDER",!,$C(7) HANG 1 Q
-        S X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD)
-        I '$P(PSJSYSP0,"^",5) D AM Q
-        W !,"...discontinuing ",$P(X,U),"...",! S PSGAL("C")=PSJSYSU*10+4000 D ^PSGAL5
-        S PSGALR=20,DIE="^PS(55,"_PSGP_",5,",DR="28////D;Q;34////"_PSGDT_$S(PSJSYSU:"",1:";49////1"),DP=55.06,$P(^(2),"^",3)=$P(^PS(55,PSGP,5,DA,2),"^",4) D ^DIE S ^PS(55,"AUE",PSGP,DA)=""
-        D EN1^PSJHL2(PSGP,"OD",PSGORD) S DA(1)=PSGP,DA=+PSGORD
-        I PSJSYSL S $P(^PS(55,PSGP,5,DA,7),"^",1,2)=PSGDT_"^D",PSGTOL=2,PSGUOW=DUZ,PSGTOO=1 D ENL^PSGVDS
-        Q
-        ;
-NC      ; discontinue non-verifed order
-        I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSJDCTYP=$$PNDRNA^PSGOEC(PSGORD) I $G(PSJDCTYP)'=1 D PNDRN($G(PSJDCTYP)) Q
-NC2     ; Called from PNDRN to discontinue both pending renewal and original order
-        K DA S DA=+PSGORD,X=$G(^PS(53.1,DA,.2)),X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD)
-        I $S($P(PSJSYSP0,"^",5):0,'$D(^PS(53.1,DA,4)):1,1:$P(^(4),"^",7)'=DUZ) D NM Q
-        W !,"...discontinuing ",$P(X,U),"...",! S DIE="^PS(53.1,",DR="28////D"_$S(PSJSYSU:"",1:";42////1") D ^DIE
-        D EN1^PSJHL2(PSGP,"OC",PSGORD)
-        S DA=+PSGORD I PSJSYSL,PSJSYSL<3 S $P(^PS(53.1,DA,7),"^",1,2)=PSGDT_"^D",PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS
-        I $G(PSJDCTYP) D UNL^PSSLOCK(DFN,PSGORD)
-        Q
-        ;
-EN      ; enter here
-        I $G(PSJIVPRF) D ^PSIVSPDC Q  ;Use for Speed DC in IV Order Profile
-        D FULL^VALM1
-EN1     ;
-        S (PSGONC,PSGLMT)=PSJOCNT,PSGONW="C" D ENWO^PSGON I "^"[X K X G RESET
-        D NOW^%DTC S PSGDT=+$E(%,1,12)
-        W ! F PSGOECS=1:1:PSGODDD F PSGOECS1=1:1 S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) Q:'PSGOECS2  D
-        .S PSGORD=^TMP("PSJON",$J,PSGOECS2) ; I $P($G(@($S((PSGORD["A")!(PSGORD["U"):"^PS(55,"_PSGP_",5,",(PSGORD["V"):"^PS(55,"_PSGP_",""IV"",",1:"^PS(53.1,")_(+PSGORD)_",0)")),"^",21) Q
-        S PSJNOO=$$ENNOO^PSJUTL5("D") G:PSJNOO<0 EN1
-        ;Prompt for requesting provider
-        W ! I '$$REQPROV^PSGOEC G EN1
-        W !
-        ;
-        ;Replaced above line with block structure below.
-        N COMFLG,PSJCOM S (EXITLOOP,PSJCOM)=0
-        F PSGOECS=1:1:PSGODDD D
-        .F PSGOECS1=1:1 D  Q:EXITLOOP=1
-        ..S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1)
-        ..I 'PSGOECS2 S EXITLOOP=1 Q
-        ..S (ON,PSGORD)=^TMP("PSJON",$J,PSGOECS2)
-        ..I PSGORD=+PSGORD D DCCOM Q
-        ..I '$$LS^PSSLOCK(DFN,PSGORD) D  Q
-        ... W:PSGORD'["V" !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q
-        ... W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D  W !,"NO ACTION WAS TAKEN",!,$C(7) HANG 1
-        ....F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X  D
-        .....W !,$G(PSJOC(ON,X))
-        ..D CHKCOM I COMFLG  D
-        ... I PSGORD'["V" W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q
-        ... W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D  W !,"NO ACTION WAS TAKEN",!,$C(7) HANG 1
-        ....F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X  D
-        .....W !,$G(PSJOC(ON,X))
-        ..Q:PSJCOM
-        ..D:(PSGORD["U") AC
-        ..D:(PSGORD["P") NC
-        ..D:(PSGORD["V") SPDCIV^PSIVSPDC
-        ..; Call the unlock procedure
-        ..D UNL^PSSLOCK(DFN,PSGORD)
-        S X=""
-RESET   ;
-        I $G(PSGORD)["V" D INIT^PSJLMHED(3) S VALMBK="R" G DONE
-        D INIT^PSJLMHED(1) S VALMBCK="R"
-        ;
-DONE    ;
-        K DA,DIE,DP,DR,PSGAL,PSGALR,PSGLMT,PSGODDD,PSGOECS,PSGOECS1,PSGOECS2,PSGONW,PSGORD,PSGPOSA,PSGPOSD,PSGTOL,PSGTOO,PSGUOW,ORIFN,ORETURN,ORNATR
-        Q
-        ;
-DCOR    ; Create DC order/update stop date in OE/RR.
-        S PSOC=$S(PSGORD["P":"OC",PSGORD["N":"OC",1:"OD")
-        D EN1^PSJHL2(PSGP,PSOC,PSGORD)
-        Q
-        ;
-ENOR    ;
-        K DA S PSGEDIT=$S($D(PSGEDIT):PSGEDIT,1:"D"),CF=1,PSGALR=20,DA=+PSGORD,T="" I PSGORD'["U",(PSGORD'["O") D:CF NSET^PSGOEC D NC^PSGOEC D ENOR2 G DONE^PSGOEC
-        S DA(1)=PSGP D:CF ASET^PSGOEC D AC^PSGOEC
-        G DONE^PSGOEC
-        ;
-ENOR2   ;Check to see if order being DC'd is a Pending Renewal and is being DC'd due to edit.
-        I PSGEDIT="DE",$P(^PS(53.1,+PSGORD,0),U,25),$P(^PS(53.1,+PSGORD,0),U,24)="R",PSGSD<$P($G(^PS(55,PSGP,5,+$P(^PS(53.1,+PSGORD,0),U,25),2)),U,4) D
-        .K DA,DR S DA(1)=PSGP,DA=+$P(^PS(53.1,+PSGORD,0),U,25),DIE="^PS(55,"_PSGP_",5,",DR="34////"_PSGSD_";25////"_$P($G(^PS(55,PSGP,5,+$P(^PS(53.1,+PSGORD,0),U,25),2)),U,4)
-        .D ^DIE,EN1^PSJHL2(PSGP,"XX",$P(^PS(53.1,+PSGORD,0),U,25))
-        Q
-        ;
-CHKCOM  ;Check to see if order is part of complex order series.
-        S PSJCOM=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,.2)),U,8),PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8),1:$P($G(^PS(53.1,+PSGORD,.2)),U,8)),COMFLG=0
-        N PSJSTAT S PSJSTAT=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,0)),"^",17),PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",9),1:$P($G(^PS(53.1,+PSGORD,0)),"^",9))
-        Q:'PSJCOM  I "DE"[PSJSTAT Q
-        W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D
-        .F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X  D
-        ..W !,$G(PSJOC(ON,X))
-        I PSGORD["U" W !,$P($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^",1) D
-        .W !!,"is part of a complex order. If you discontinue this order the following orders",!,"will be discontinued too (unless the stop date has already been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
-        F  W !!,"Do you want to discontinue this series of complex orders" S %=1 D YN^DICN Q:%
-        I %'=1 S COMFLG=1 Q
-        N O,OO S O=0,OO="" F  S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O  F  S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO=""  D  Q:COMFLG
-        .Q:OO=PSGORD  I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q
-        Q:COMFLG
-        N O,OO S O=0,OO="" F  S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O  F  S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO=""  D
-        .I (OO["U") N PSGORD S PSGORD=OO D AC
-        .I (OO["V") N PSGORD S (ON,PSGORD)=OO D SPDCIV^PSIVSPDC
-        .D UNL^PSSLOCK(DFN,PSGORD)
-        Q
-        ;
-DCCOM   ;DC pending/non-verified complex order
-        I '$$LOCK^PSJOEA(DFN,PSGORD) W !,"Order # ",PSGOECS2," could not be discontinued.",!,$C(7) HANG 1 Q
-        N PSGORD1 S PSGORD1=PSGORD
-        N PSJO S PSJO=0 F  S PSJO=$O(^PS(53.1,"ACX",PSGORD1,PSJO)) Q:'PSJO  S PSGORD=PSJO_"P" D NC
-        Q
-PNDRN(PSJDCTYP) ; Discontinue both pending renewal and original order
-        N TMPORD S TMPORD=$G(PSGORD)
-        I PSJDCTYP=2 S PSJDCTYP=1 D NC2 Q:'$G(PSJDCTYP)  D
-        .I ($G(PSJNOO)<0) Q
-        .N ND5310 S ND5310=$G(^PS(53.1,+PSGORD,0))
-        .N PSGORD S PSGORD=$P(ND5310,"^",25) I PSGORD S PSJDCTYP=2 D
-        ..I '$$LS^PSSLOCK(DFN,PSGORD) K PSJDCTYP Q
-        ..D @$S(PSGORD["U":"AC",PSGORD["V":"SPDCIV^PSIVSPDC",1:"")
-        S PSGORD=TMPORD
-        Q
+PSGOECS ;BIR/CML3-CANCEL SELECTED ORDERS ;02 Mar 99 / 9:29 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**23,29,44,58,81,110**;16 DEC 97
+ ;
+ ; Reference to FULL^VALM1 is supported by DBIA# 10116.
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^PSSLOCK is supported by DBIA #2789.
+ ;
+AM ;
+ W !,"...marking ",$P(X,U),"..." S $P(^PS(55,PSGP,5,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT,PSGAL("C")=13040 W "." D ^PSGAL5 W "."
+ I $D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
+ Q
+ ;
+NM ;
+ W !,"...marking ",$P(X,U),"..." S $P(^PS(53.1,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT W "."
+ I $D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSD=PSGDT,PSGPOSA="C" D ENPOS^PSGVDS
+ Q
+ ;
+AC ; discontinue active order
+ K DA S DA(1)=PSGP,DA=+PSGORD
+ S X=$G(^PS(55,PSGP,5,DA,.2))
+ I $P(X,U,4)="D" W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON DONE ORDER",!,$C(7) HANG 1 Q 
+ NEW XX S XX=$P(^PS(55,PSGP,5,DA,0),U,9)
+ I $S(XX="E":1,XX="D":1,XX="DE":1,1:0) W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON "_$$CODES^PSIVUTL(XX,55.06,28)_" ORDER",!,$C(7) HANG 1 Q
+ S X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD)
+ I '$P(PSJSYSP0,"^",5) D AM Q
+ W !,"...discontinuing ",$P(X,U),"...",! S PSGAL("C")=PSJSYSU*10+4000 D ^PSGAL5
+ S PSGALR=20,DIE="^PS(55,"_PSGP_",5,",DR="28////D;Q;34////"_PSGDT_$S(PSJSYSU:"",1:";49////1"),DP=55.06,$P(^(2),"^",3)=$P(^PS(55,PSGP,5,DA,2),"^",4) D ^DIE S ^PS(55,"AUE",PSGP,DA)=""
+ D EN1^PSJHL2(PSGP,"OD",PSGORD) S DA(1)=PSGP,DA=+PSGORD
+ I PSJSYSL S $P(^PS(55,PSGP,5,DA,7),"^",1,2)=PSGDT_"^D",PSGTOL=2,PSGUOW=DUZ,PSGTOO=1 D ENL^PSGVDS
+ Q
+ ;
+NC ; discontinue non-verifed order
+ K DA S DA=+PSGORD,X=$G(^PS(53.1,DA,.2)),X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD)
+ I $S($P(PSJSYSP0,"^",5):0,'$D(^PS(53.1,DA,4)):1,1:$P(^(4),"^",7)'=DUZ) D NM Q
+ W !,"...discontinuing ",$P(X,U),"...",! S DIE="^PS(53.1,",DR="28////D"_$S(PSJSYSU:"",1:";42////1") D ^DIE
+ D EN1^PSJHL2(PSGP,"OC",PSGORD)
+ S DA=+PSGORD I PSJSYSL,PSJSYSL<3 S $P(^PS(53.1,DA,7),"^",1,2)=PSGDT_"^D",PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS
+ Q
+ ;
+EN ; enter here
+ I $G(PSJIVPRF) D ^PSIVSPDC Q  ;Use for Speed DC in IV Order Profile
+ D FULL^VALM1
+EN1 ;
+ S (PSGONC,PSGLMT)=PSJOCNT,PSGONW="C" D ENWO^PSGON I "^"[X K X G RESET
+ D NOW^%DTC S PSGDT=+$E(%,1,12)
+ W ! F PSGOECS=1:1:PSGODDD F PSGOECS1=1:1 S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) Q:'PSGOECS2  D
+ .S PSGORD=^TMP("PSJON",$J,PSGOECS2) ; I $P($G(@($S((PSGORD["A")!(PSGORD["U"):"^PS(55,"_PSGP_",5,",(PSGORD["V"):"^PS(55,"_PSGP_",""IV"",",1:"^PS(53.1,")_(+PSGORD)_",0)")),"^",21) Q
+ S PSJNOO=$$ENNOO^PSJUTL5("D") G:PSJNOO<0 EN1
+ ;Prompt for requesting provider
+ W ! I '$$REQPROV^PSGOEC G EN1
+ W !
+ ;
+ ;F PSGOECS=1:1:PSGODDD F PSGOECS1=1:1 S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) Q:'PSGOECS2  S (ON,PSGORD)=^TMP("PSJON",$J,PSGOECS2) D:(PSGORD["U") AC D:(PSGORD["P") NC D:(PSGORD["V") SPDCIV^PSIVSPDC
+ ;Replaced above line with block structure below.
+ N COMFLG,PSJCOM S (EXITLOOP,PSJCOM)=0
+ F PSGOECS=1:1:PSGODDD D
+ .F PSGOECS1=1:1 D  Q:EXITLOOP=1
+ ..S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1)
+ ..I 'PSGOECS2 S EXITLOOP=1 Q
+ ..S (ON,PSGORD)=^TMP("PSJON",$J,PSGOECS2)
+ ..I PSGORD=+PSGORD D DCCOM Q
+ ..I '$$LS^PSSLOCK(DFN,PSGORD) D  Q
+ ... W:PSGORD'["V" !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q
+ ... W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D  W !,"NO ACTION WAS TAKEN",!,$C(7) HANG 1
+ ....F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X  D
+ .....W !,$G(PSJOC(ON,X))
+ ..D CHKCOM I COMFLG  D
+ ... I PSGORD'["V" W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q
+ ... W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D  W !,"NO ACTION WAS TAKEN",!,$C(7) HANG 1
+ ....F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X  D
+ .....W !,$G(PSJOC(ON,X))
+ ..Q:PSJCOM
+ ..D:(PSGORD["U") AC
+ ..D:(PSGORD["P") NC
+ ..D:(PSGORD["V") SPDCIV^PSIVSPDC
+ ..; Call the unlock procedure
+ ..D UNL^PSSLOCK(DFN,PSGORD)
+ S X=""
+RESET ;
+ I $G(PSGORD)["V" D INIT^PSJLMHED(3) S VALMBK="R" G DONE
+ D INIT^PSJLMHED(1) S VALMBCK="R"
+ ;
+DONE ;
+ K DA,DIE,DP,DR,PSGAL,PSGALR,PSGLMT,PSGODDD,PSGOECS,PSGOECS1,PSGOECS2,PSGONW,PSGORD,PSGPOSA,PSGPOSD,PSGTOL,PSGTOO,PSGUOW,ORIFN,ORETURN,ORNATR
+ Q
+ ;
+DCOR ; Create DC order/update stop date in OE/RR.
+ S PSOC=$S(PSGORD["P":"OC",PSGORD["N":"OC",1:"OD")
+ D EN1^PSJHL2(PSGP,PSOC,PSGORD)
+ Q
+ ;
+ENOR ;
+ K DA S PSGEDIT=$S($D(PSGEDIT):PSGEDIT,1:"D"),CF=1,PSGALR=20,DA=+PSGORD,T="" I PSGORD'["U",(PSGORD'["O") D:CF NSET^PSGOEC D NC^PSGOEC D ENOR2 G DONE^PSGOEC
+ S DA(1)=PSGP D:CF ASET^PSGOEC D AC^PSGOEC
+ G DONE^PSGOEC
+ ;
+ENOR2 ;Check to see if order being DC'd is a Pending Renewal and is being DC'd due to edit.
+ I PSGEDIT="DE",$P(^PS(53.1,+PSGORD,0),U,25),$P(^PS(53.1,+PSGORD,0),U,24)="R",PSGSD<$P($G(^PS(55,PSGP,5,+$P(^PS(53.1,+PSGORD,0),U,25),2)),U,4) D
+ .K DA,DR S DA(1)=PSGP,DA=+$P(^PS(53.1,+PSGORD,0),U,25),DIE="^PS(55,"_PSGP_",5,",DR="34////"_PSGSD_";25////"_$P($G(^PS(55,PSGP,5,+$P(^PS(53.1,+PSGORD,0),U,25),2)),U,4)
+ .D ^DIE,EN1^PSJHL2(PSGP,"XX",$P(^PS(53.1,+PSGORD,0),U,25))
+ Q
+ ;
+CHKCOM ;Check to see if order is part of complex order series.
+ S PSJCOM=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,.2)),U,8),PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8),1:$P($G(^PS(53.1,+PSGORD,.2)),U,8)),COMFLG=0
+ N PSJSTAT S PSJSTAT=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,0)),"^",17),PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",9),1:$P($G(^PS(53.1,+PSGORD,0)),"^",9))
+ Q:'PSJCOM  I "DE"[PSJSTAT Q
+ W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D
+ .F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X  D
+ ..W !,$G(PSJOC(ON,X))
+ I PSGORD["U" W !,$P($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^",1) D
+ .W !!,"is part of a complex order. If you discontinue this order the following orders",!,"will be discontinued too (unless the stop date has already been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
+ F  W !!,"Do you want to discontinue this series of complex orders" S %=1 D YN^DICN Q:%
+ I %'=1 S COMFLG=1 Q
+ N O,OO S O=0,OO="" F  S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O  F  S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO=""  D  Q:COMFLG
+ .Q:OO=PSGORD  I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q
+ Q:COMFLG
+ N O,OO S O=0,OO="" F  S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O  F  S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO=""  D
+ .I (OO["U") N PSGORD S PSGORD=OO D AC
+ .I (OO["V") N PSGORD S (ON,PSGORD)=OO D SPDCIV^PSIVSPDC
+ .D UNL^PSSLOCK(DFN,PSGORD)
+ Q
+ ;
+DCCOM ;DC pending/non-verified complex order
+ I '$$LOCK^PSJOEA(DFN,PSGORD) W !,"Order # ",PSGOECS2," could not be discontinued.",!,$C(7) HANG 1 Q
+ N PSGORD1 S PSGORD1=PSGORD
+ N PSJO S PSJO=0 F  S PSJO=$O(^PS(53.1,"ACX",PSGORD1,PSJO)) Q:'PSJO  S PSGORD=PSJO_"P" D NC
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEF.m

@@ -1 @@
-PSGOEF  ;BIR/CML3-FINISH ORDERS ENTERED THROUGH OE/RR ;14 May 98 / 2:17 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**7,30,29,35,39,47,50,56,80,116,110,111,133,153,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(55 is supported by DBIA 2191
-        ; Reference to ^PSDRUG( is supported by DBIA 2192
-        ; Reference to DOSE^PSSORPH is supported by DBIA 3234.
-        ;
-START   ;
-        I '$D(^PS(53.1,+PSGORD)) W $C(7),!?3,"Cannot find this pending order (#",+PSGORD,")." Q
-        D NOW^%DTC S PSGDT=+$E(%,1,12) K PSGFDX,PSGEFN,PSGOEEF,PSGOES,PSGONF,PSGRDTX S PSGOES=1,(PSGOEF,PSGOEEF)=0,PSGOEEG=3
-        I $D(PSJTUD) S PSGDO=$P($G(^PS(53.1,+PSGORD,.3)),U),(PSGPDRG,PSGPD)=PSJCOI,(PSGPDRGN,PSGPDN)=$$OINAME^PSJLMUTL(PSGPD)
-        I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S X=PSGSCH D EN^PSGORS0 D
-        . S:($D(X)&($P($G(^PS(53.1,+PSGORD,2)),"^",5)="")&($P($G(^PS(53.1,+PSGORD,0)),"^",24)="N")) PSGAT=PSGS0Y
-        . NEW PSJDOX,PSJDOSE,PSJPIECE,PSJUNIT,PSJX,X
-        . S X=$G(^PS(53.1,+PSGORD,1,1,0)) Q:'+X
-        . D DOSE^PSSORPH(.PSJDOX,+X,"U")
-        . I $S('$D(PSJDOX):1,1:+PSJDOX(1)=-1) Q
-        . S PSJPIECE=$S($P(PSJDOX(1),U)="":3,1:1)
-        . S X=^PS(53.1,+PSGORD,.2)
-        . S:PSJPIECE=3 PSJDOSE=$P(X,U,2)
-        . S:PSJPIECE=1 PSJDOSE=$P(X,U,5),PSJUNIT=$P(X,U,6)
-        . F X=0:0 S X=$O(PSJDOX(X)) Q:+$G(PSJX)!'X  D
-        .. I PSJPIECE=3,($P(PSJDOX(X),U,3)'=PSJDOSE) Q
-        .. I PSJPIECE=1,($P(PSJDOX(X),U,1)_$P(PSJDOX(X),U,2)'=(PSJDOSE_PSJUNIT)) Q
-        .. S:+$P(PSJDOX(X),U,12) $P(^PS(53.45,PSJSYSP,2,1,0),U,2)=+$P(PSJDOX(X),U,12),PSJX=1
-        I PSGEB'=PSGOPR F X=7,11 S Y=$T(@(3_X)),@("PSGEFN("_X_")="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))="",PSGOEEF=PSGOEEF+1
-        D GTST^PSGOE6(+PSGORD)
-        I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S PSGSD="" D:PSGS0Y]""
-        .N PSJX S PSJX=$P($G(^PS(53.1,+PSGORD,0)),U,25) I PSJX="" Q
-        .I PSJX["U" S PSGSD=$P($G(^PS(55,DFN,5,+PSJX,2)),U,2) Q
-        .I PSJX["V" S PSGSD=$P($G(^PS(55,DFN,"IV",+PSJX,0)),U,2) Q
-        .I PSJX["P" S PSGSD=$P($G(^PS(53.1,+PSJX,2)),U,2)
-        S:PSGSD="" PSGSD=PSGLI
-        S PSGNEDFD=$$GTNEDFD^PSGOE7("U",+PSGPD)
-        S:$P($G(PSGNEDFD),U,3)="" $P(PSGNEDFD,U,3)=PSGST  ; N PSGOEA S PSGOEA="R"
-        S (PSGNESD,PSGSD)=$$ENSD^PSGNE3(PSGSCH,PSGS0Y,PSGLI,PSGSD)
-        ;if this is a renewal order, ignore any 'requested start date' received.  Use the system calculated start date.
-        I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" D
-        . D REQDT^PSJLIVMD(PSGORD)
-        E  D
-        . S X=$$DSTART^PSJDCU(DFN,$P(^PS(53.1,+PSGORD,0),U,25)) I X]"" S (PSGNESD,PSGSD)=X K PSGRSD
-        D   ; Extend the Default Stop Date if needed for the first renewed order.
-        .N PSGOEAO,PSGWALLO
-        .I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSGOEAO=PSGOEA,PSGOEA="R",PSGWALLO=$P(^PS(55,DFN,5.1),U)
-        .D ENFD^PSGNE3(PSGLI) S PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGFD")):PSGRDTX(+PSGORD,"PSGFD"),1:PSGNEFD)
-        .I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSGOEA=PSGOEAO,$P(^PS(55,DFN,5.1),U)=PSGWALLO
-        N DUR,PSGRNSD S PSGRNSD=+$$LASTREN^PSJLMPRI(DFN,PSGORD) I PSGRNSD S DUR=$$GETDUR^PSJLIVMD(DFN,PSGORD,"P",1) I DUR]"" D
-        . N DURMIN S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN S PSGFD=$$FMADD^XLFDT(PSGRNSD,,,DURMIN)
-        S PSGOFD="",PSGSDN=$$ENDD^PSGMI(PSGSD)_U_$$ENDTC^PSGMI(PSGSD),PSGFDN=$$ENDD^PSGMI(PSGFD)_U_$$ENDTC^PSGMI(PSGFD)
-        S PSGLIN=$$ENDD^PSGMI(PSGLI)_U_$$ENDTC^PSGMI(PSGLI)
-        I '$O(^PS(53.45,PSJSYSP,2,0)) N DRG,DRGCNT S DRGCNT=0 D
-        .F X=0:0 S X=$O(^PSDRUG("ASP",+PSGPD,X)) Q:'X!(DRGCNT>1)  S:$P($G(^PSDRUG(+X,2)),U,3)["U" DRGCNT=DRGCNT+1,DRG=+X
-        .I DRGCNT=1 K ^PS(53.45,PSJSYSP,2) S ^PS(53.45,PSJSYSP,2,1,0)=DRG_U_1,^PS(53.45,PSJSYSP,2,0)="^53.4502^1^1",PS(53.45,PSJSYSP,2,"B",+DRG,1)=""
-        Q
-FINISH  ;
-        ; force display of second screen if CPRS order checks exist
-        N NSFF,PSGOEF39 S NSFF=1 K PSJNSS
-        I $G(PSGORD),$D(PSGRDTX(+PSGORD)) D  K PSGRDTX
-        . S:$G(PSGRDTX(+PSGORD,"PSGRSD")) PSGSD=PSGRDTX(+PSGORD,"PSGRSD")
-        . S:$G(PSGRDTX(+PSGORD,"PSGRFD")) PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGRFD")):PSGRDTX(+PSGORD,"PSGRFD"),1:$G(PSGNEFD))
-        N PSJCOM S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8)
-        I $O(^PS(53.1,+PSGORD,12,0))!$O(^PS(53.1,+PSGORD,10,0)) D
-        .Q:$G(PSJLMX)=1  ; there's no second screen to display
-        .S VALMBG=16 D RE^VALM4,PAUSE^VALM1
-        D FULL^VALM1
-        I $G(PSJPROT)=3,'$D(PSJTUD),'$$ENIVUD^PSGOEF1(PSGORD) Q
-        I $G(PSGOSCH)]"" D  S:$G(PSGS0XT)'="" $P(^PS(53.1,+PSGORD,2),"^",6)=PSGS0XT
-        .N PSGOES,PSGS0Y,PSGSCH S X=PSGOSCH K:$G(PSJTUD) NSFF D ENOS^PSGS0
-        .I '($G(PSGORD)["P"&($P($G(^PS(53.1,+PSGORD,0)),"^",24)="R")) I $G(X)]""&$G(PSGS0Y) S:$G(PSGAT)="" PSGAT=PSGS0Y
-        .I $G(PSJNSS) S PSGOSCH="" K PSJNSS
-        .I $G(PSGORD)["P",$G(PSGAT),$G(PSGS0Y),($G(PSGOSCH)]"") I PSGAT'=PSGS0Y D
-        ..S PSGNSTAT=1 W $C(7),!!,"PLEASE NOTE:  This order's admin times (",PSGAT,")"
-        ..W !?13," do not match the ward times (",PSGS0Y,")"
-        ..W !?13," for this administration schedule (",PSGOSCH,")",!
-        ..S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR K DIR  W !
-        I $G(PSGS0XT)="" S $P(^PS(53.1,+PSGORD,2),"^",6)=$S($P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:"")
-        S CHK=0 S:$P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" PSGSI=$$ENPC^PSJUTL("U",+PSJSYSP,180,PSGSI)
-        I '$G(PSJTUD),$G(PSJNSS),($G(PSGOSCH)]"") D NSSCONT^PSGS0(PSGOSCH,PSGS0XT) K PSJNSS S PSGOSCH=""
-        S PSGOEFF=PSGOSCH=""+('$O(^PS(53.45,PSJSYSP,2,0))*10)
-        I PSGOEFF S X=$S(PSGOEFF#2:" a SCHEDULE",1:"")_$S(PSGOEFF=11:" and",1:"")_$S(PSGOEFF>9:" at least one DISPENSE DRUG",1:"")
-        I 'PSGOEFF I (($G(PSGS0XT)="D")&($G(PSGAT)="")) S X=" Admin Times",PSGOEFF=1,PSGOEF39=1
-        I PSGOEFF,X]"" S X=X_" before it can be finished."
-        I PSGOEFF S CHK=1 W $C(7),!!,"PLEASE NOTE: This order must have" F Q=1:1:$L(X," ") S Y=$P(X," ",Q) W:$L(Y)+$X>78 ! W Y," "
-        I $G(PSGOEF39) S PSGOEE=0,PSGOEFF=0 D  I 'PSGOEE D REFRESH^VALM G DONE
-        .S F1=53.1,MSG=0,Y=$T(39),@("PSGFN(39)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEEF,PSGOEE)=1 W ! D @$P($T(39),";",3) S CHK=0
-        I PSGOEFF=1 S F1=53.1,MSG=0,Y=$T(38),@("PSGFN(38)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(38),";",3) S CHK=0 G:'PSGOEE DONE
-        I PSGOEFF=11 S F1=53.1,MSG=0,Y=$T(32),@("PSGFN(32)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(32),";",3) D  G:'PSGOEE DONE
-        .S F1=53.1,MSG=0,Y=$T(38),@("PSGFN(38)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(38),";",3) S CHK=0
-        I PSGOEFF>9 S CHK=7 D ENDRG^PSGOEF1(+PSGPD,0) I CHK D ABORTACC Q
-        I 'PSGOEFF D OC531^PSGOESF ; check every dispense drug from CPRS
-        S VALMBG=1
-        I 'PSGOEFF&($D(PSGORQF)) D RE^VALM4 Q
-        I $G(MSG) K DIR S DIR(0)="E" W !! D ^DIR
-        I PSGOEFF D:PSGST="" GTST^PSGOE6(+PSGORD)
-        S PSJLMFIN=1
-        K PSJACEPT I $O(^PS(53.1,+PSGORD,12,0)) S PSJLMP2=1
-        S PSGOEENO=0,PSGSTAT=$S($P(PSJSYSP0,U,9):"ACTIVE",1:"NON-VERIFIED")
-        NEW PSJDOSE,PSJDOX,PSJDSFLG
-        D DOSECHK^PSJDOSE
-        S:+$G(PSJDSFLG) VALMSG="Dosage Ordered & Dispense Drug are not compatible"
-        I PSGODO=PSGDO S PSGOEEF(109)=""
-        I PSGODO'=PSGDO S PSGOEENO=1,VALMSG="This change will cause a new order to be created  "
-        D EN^VALM("PSJU LM ACCEPT")
-        I $G(PSJNSS) D  S PSGOEEF(26)="" K PSJACEPT,PSJNSS
-        .K DIR S DIR(0)="FOA",DIR("A")="Invalid Schedule" D ^DIR K DIR
-        I $G(PSGS0XT)="D",'$G(PSGS0Y),'$G(PSGAT),((",P,R,")'[(","_$G(PSGST)_",")) D  S PSGOEEF(39)="" K PSJACEPT
-        .K DIR S DIR(0)="FOA",DIR("A")="   WARNING - Admin times are required for DAY OF WEEK schedules  " D ^DIR K DIR
-        I '$G(PSJACEPT) D ABORTACC Q
-        I $G(PSJRNF),$G(^PS(53.1,+PSGORD,4)) D
-        . W $C(7),!!,"ACCEPTING THIS ORDER WILL CHANGE THE STATUS TO ACTIVE."
-        . S DIR(0)="Y",DIR("A")="Do you wish to make this order Active",DIR("?",1)="Enter ""N"" if you wish to exit without Activating this order,"
-        . S DIR("?")="or ""Y"" to continue with the Activation process." D ^DIR S:'Y Y=-1 K DIR
-        I $G(PSJRNF),$G(Y)=-1 S PSJACEPT=0 D ABORTACC Q
-        I $G(PSJRNF),$G(Y)=1 S PSGOEAV=1
-        I PSGOEENO S PSJNOO=$$ENNOO^PSJUTL5("E"),PSJACEPT=$S(PSJNOO<0:0,1:1)
-ACCEPT  ;
-        S VALMBCK=$S($G(PSJACEPT):"Q",1:"R")
-        I '$G(PSJACEPT) D ABORTACC Q
-        K PSGOES,PSGRSD,PSGRSDN D:PSGOEENO NEW3^PSGOEE D:'PSGOEENO UPD^PSGOEF1 I $D(PSGOEF)!PSGOEENO S PSGCANFL=-1
-        D DONE1^PSGOEE
-        D DONE
-        Q
-BYPASS  ;
-        S PSGCANFL=1
-        ;
-DONE    ;
-        K CHK,DA,DIE,DR,DRG,MSG,Q1,Q2,PSGNSTAT ;PSGND,PSGOEE,PSGOEEF,PSGOEEND,PSGOEEG,PSGOEF,PSGOEFF,PSGOES,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGPDRG,PSGDRGN,PSG0XT,PSGS0Y,OSGSD,Q1,Q2
-        Q
-ABORTACC        ; Abort Accept process.
-        D ABORT^PSGOEE K PSGOEEF D GETUD^PSJLMGUD(PSGP,PSGORD),^PSGOEF,ENSFE^PSGOEE0(PSGP,PSGORD),INIT^PSJLMUDE(PSGP,PSGORD) S VALMBCK="R",PSGSD=PSGNESD,PSGFD=PSGNEFD Q
-        ;
-        ;
-31      ;;101^PSGOE8;PSGOPD;PSGPD;101;1
-32      ;;109^PSGOE8;PSGODO;PSGDO;109;PSGODO]""
-33      ;;10^PSGOE81;PSGOSD;PSGSD;10;0
-34      ;;3^PSGOE8;PSGOMR;PSGMR;3;1
-35      ;;25^PSGOE81;PSGOFD;PSGFD;25;0
-36      ;;7^PSGOE8;PSGOST;PSGST;7;0
-37      ;;5^PSGOE82;PSGOSM;PSGSM;5;0
-38      ;;26^PSGOE8;PSGOSCH;PSGSCH;26;1      
-39      ;;39^PSGOE81;PSGOAT;PSGAT;39;0
-310     ;;1^PSGOE82;PSGOPR;PSGPR;1;1
-311     ;;8^PSGOE81;PSGOSI;PSGSI;8;0
-312     ;;2^PSGOE82;;;2;0
-313     ;;40^PSGOE82;;;40;0
-        ;
-AH      ;
-        W !!?2,"Answer 'YES' to accept this order as a NON-VERIFIED UNIT DOSE order.  Answer",!,"'NO' to edit this order now.  Enter '^' to BYPASS this order, leaving it as",!,"a PENDING INPATIENT order."
-        Q
+PSGOEF ;BIR/CML3-FINISH ORDERS ENTERED THROUGH OE/RR ;14 May 98 / 2:17 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**7,30,29,35,39,47,50,56,80,116,110,111,133,153**;16 DEC 97
+ ;
+ ; Reference to ^PS(55 is supported by DBIA 2191
+ ; Reference to ^PSDRUG( is supported by DBIA 2192
+ ; Reference to DOSE^PSSORPH is supported by DBIA 3234.
+ ;
+START ;
+ I '$D(^PS(53.1,+PSGORD)) W $C(7),!?3,"Cannot find this pending order (#",+PSGORD,")." Q
+ D NOW^%DTC S PSGDT=+$E(%,1,12) K PSGFDX,PSGEFN,PSGOEEF,PSGOES,PSGONF,PSGRDTX S PSGOES=1,(PSGOEF,PSGOEEF)=0,PSGOEEG=3
+ I $D(PSJTUD) S PSGDO=$P($G(^PS(53.1,+PSGORD,.3)),U),(PSGPDRG,PSGPD)=PSJCOI,(PSGPDRGN,PSGPDN)=$$OINAME^PSJLMUTL(PSGPD)
+ I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S X=PSGSCH D EN^PSGORS0 S:$D(X) PSGAT=PSGS0Y D
+ . NEW PSJDOX,PSJDOSE,PSJPIECE,PSJUNIT,PSJX,X
+ . S X=$G(^PS(53.1,+PSGORD,1,1,0)) Q:'+X
+ . D DOSE^PSSORPH(.PSJDOX,+X,"U")
+ . I $S('$D(PSJDOX):1,1:+PSJDOX(1)=-1) Q
+ . S PSJPIECE=$S($P(PSJDOX(1),U)="":3,1:1)
+ . S X=^PS(53.1,+PSGORD,.2)
+ . S:PSJPIECE=3 PSJDOSE=$P(X,U,2)
+ . S:PSJPIECE=1 PSJDOSE=$P(X,U,5),PSJUNIT=$P(X,U,6)
+ . F X=0:0 S X=$O(PSJDOX(X)) Q:+$G(PSJX)!'X  D
+ .. I PSJPIECE=3,($P(PSJDOX(X),U,3)'=PSJDOSE) Q
+ .. I PSJPIECE=1,($P(PSJDOX(X),U,1)_$P(PSJDOX(X),U,2)'=(PSJDOSE_PSJUNIT)) Q
+ .. S:+$P(PSJDOX(X),U,12) $P(^PS(53.45,PSJSYSP,2,1,0),U,2)=+$P(PSJDOX(X),U,12),PSJX=1
+ I PSGEB'=PSGOPR F X=7,11 S Y=$T(@(3_X)),@("PSGEFN("_X_")="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))="",PSGOEEF=PSGOEEF+1
+ D GTST^PSGOE6(+PSGORD)
+ I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S PSGSD="" D:PSGS0Y]""
+ .N PSJX S PSJX=$P($G(^PS(53.1,+PSGORD,0)),U,25) I PSJX="" Q
+ .I PSJX["U" S PSGSD=$P($G(^PS(55,DFN,5,+PSJX,2)),U,2) Q
+ .I PSJX["V" S PSGSD=$P($G(^PS(55,DFN,"IV",+PSJX,0)),U,2) Q
+ .I PSJX["P" S PSGSD=$P($G(^PS(53.1,+PSJX,2)),U,2)
+ S:PSGSD="" PSGSD=PSGLI
+ S PSGNEDFD=$$GTNEDFD^PSGOE7("U",+PSGPD)
+ S:$P($G(PSGNEDFD),U,3)="" $P(PSGNEDFD,U,3)=PSGST  ; N PSGOEA S PSGOEA="R"
+ S (PSGNESD,PSGSD)=$$ENSD^PSGNE3(PSGSCH,PSGS0Y,PSGLI,PSGSD)
+ ;if this is a renewal order, ignore any 'requested start date' received.  Use the system calculated start date.
+ I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" D
+ . D REQDT^PSJLIVMD(PSGORD)
+ E  D
+ . S X=$$DSTART^PSJDCU(DFN,$P(^PS(53.1,+PSGORD,0),U,25)) I X]"" S (PSGNESD,PSGSD)=X K PSGRSD
+ D   ; Extend the Default Stop Date if needed for the first renewed order.
+ .N PSGOEAO,PSGWALLO
+ .I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSGOEAO=PSGOEA,PSGOEA="R",PSGWALLO=$P(^PS(55,DFN,5.1),U)
+ .D ENFD^PSGNE3(PSGLI) S PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGFD")):PSGRDTX(+PSGORD,"PSGFD"),1:PSGNEFD)
+ .I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSGOEA=PSGOEAO,$P(^PS(55,DFN,5.1),U)=PSGWALLO
+ N DUR,PSGRNSD S PSGRNSD=+$$LASTREN^PSJLMPRI(DFN,PSGORD) I PSGRNSD S DUR=$$GETDUR^PSJLIVMD(DFN,PSGORD,"P",1) I DUR]"" D
+ . N DURMIN S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN S PSGFD=$$FMADD^XLFDT(PSGRNSD,,,DURMIN)
+ S PSGOFD="",PSGSDN=$$ENDD^PSGMI(PSGSD)_U_$$ENDTC^PSGMI(PSGSD),PSGFDN=$$ENDD^PSGMI(PSGFD)_U_$$ENDTC^PSGMI(PSGFD)
+ S PSGLIN=$$ENDD^PSGMI(PSGLI)_U_$$ENDTC^PSGMI(PSGLI)
+ I '$O(^PS(53.45,PSJSYSP,2,0)) N DRG,DRGCNT S DRGCNT=0 D
+ .F X=0:0 S X=$O(^PSDRUG("ASP",+PSGPD,X)) Q:'X!(DRGCNT>1)  S:$P($G(^PSDRUG(+X,2)),U,3)["U" DRGCNT=DRGCNT+1,DRG=+X
+ .I DRGCNT=1 K ^PS(53.45,PSJSYSP,2) S ^PS(53.45,PSJSYSP,2,1,0)=DRG_U_1,^PS(53.45,PSJSYSP,2,0)="^53.4502^1^1",PS(53.45,PSJSYSP,2,"B",+DRG,1)=""
+ Q
+FINISH ;
+ ; force display of second screen if CPRS order checks exist
+ N NSFF,PSGOEF39 S NSFF=1 K PSJNSS
+ I $G(PSGORD),$D(PSGRDTX(+PSGORD)) D  K PSGRDTX
+ . S:$G(PSGRDTX(+PSGORD,"PSGRSD")) PSGSD=PSGRDTX(+PSGORD,"PSGRSD")
+ . S:$G(PSGRDTX(+PSGORD,"PSGRFD")) PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGRFD")):PSGRDTX(+PSGORD,"PSGRFD"),1:$G(PSGNEFD))
+ N PSJCOM S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8)
+ I $O(^PS(53.1,+PSGORD,12,0))!$O(^PS(53.1,+PSGORD,10,0)) D
+ .Q:$G(PSJLMX)=1  ; there's no second screen to display
+ .S VALMBG=16 D RE^VALM4,PAUSE^VALM1
+ D FULL^VALM1
+ I $G(PSJPROT)=3,'$D(PSJTUD),'$$ENIVUD^PSGOEF1(PSGORD) Q
+ S CHK=0 S:$P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" PSGSI=$$ENPC^PSJUTL("U",+PSJSYSP,180,PSGSI)
+ I $G(PSGOSCH)]"" D  S:$G(PSGS0XT)'<0 $P(^PS(53.1,+PSGORD,2),"^",6)=PSGS0XT
+ .N PSGOES,PSGS0Y,PSGSCH S X=PSGOSCH K:$G(PSJTUD) NSFF D ENOS^PSGS0 I '($G(PSGORD)["P"&($P($G(^PS(53.1,+PSGORD,0)),"^",24)="R")) I $G(X)]""&$G(PSGS0Y) S PSGAT=PSGS0Y
+ .I $G(PSJNSS) S PSGOSCH="" K PSJNSS
+ I '$G(PSJTUD),$G(PSJNSS),($G(PSGOSCH)]"") D NSSCONT^PSGS0(PSGOSCH,PSGS0XT) K PSJNSS S PSGOSCH=""
+ S PSGOEFF=PSGOSCH=""+('$O(^PS(53.45,PSJSYSP,2,0))*10)
+ I PSGOEFF S X=$S(PSGOEFF#2:" a SCHEDULE",1:"")_$S(PSGOEFF=11:" and",1:"")_$S(PSGOEFF>9:" at least one DISPENSE DRUG",1:"")
+ I 'PSGOEFF I (($G(PSGS0XT)="D")&($G(PSGAT)="")) S X=" Admin Times",PSGOEFF=1,PSGOEF39=1
+ I PSGOEFF,X]"" S X=X_" before it can be finished."
+ I PSGOEFF S CHK=1 W $C(7),!!,"PLEASE NOTE: This order must have" F Q=1:1:$L(X," ") S Y=$P(X," ",Q) W:$L(Y)+$X>78 ! W Y," "
+ I $G(PSGOEF39) S PSGOEE=0,PSGOEFF=0 D  I 'PSGOEE D REFRESH^VALM G DONE
+ .S F1=53.1,MSG=0,Y=$T(39),@("PSGFN(39)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEEF,PSGOEE)=1 W ! D @$P($T(39),";",3) S CHK=0
+ I PSGOEFF=1 S F1=53.1,MSG=0,Y=$T(38),@("PSGFN(38)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(38),";",3) S CHK=0 G:'PSGOEE DONE
+ I PSGOEFF=11 S F1=53.1,MSG=0,Y=$T(32),@("PSGFN(32)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(32),";",3) D  G:'PSGOEE DONE
+ .S F1=53.1,MSG=0,Y=$T(38),@("PSGFN(38)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(38),";",3) S CHK=0
+ I PSGOEFF>9 S CHK=7 D ENDRG^PSGOEF1(+PSGPD,0) I CHK D ABORTACC Q
+ I 'PSGOEFF D OC531^PSGOESF ; check every dispense drug from CPRS
+ S VALMBG=1
+ I 'PSGOEFF&($D(PSGORQF)) D RE^VALM4 Q
+ I $G(MSG) K DIR S DIR(0)="E" W !! D ^DIR
+ I PSGOEFF D:PSGST="" GTST^PSGOE6(+PSGORD)
+ S PSJLMFIN=1
+ K PSJACEPT I $O(^PS(53.1,+PSGORD,12,0)) S PSJLMP2=1
+ S PSGOEENO=0,PSGSTAT=$S($P(PSJSYSP0,U,9):"ACTIVE",1:"NON-VERIFIED")
+ NEW PSJDOSE,PSJDOX,PSJDSFLG
+ D DOSECHK^PSJDOSE
+ S:+$G(PSJDSFLG) VALMSG="Dosage Ordered & Dispense Drug are not compatible"
+ I PSGODO=PSGDO S PSGOEEF(109)=""
+ I PSGODO'=PSGDO S PSGOEENO=1,VALMSG="This change will cause a new order to be created  "
+ D EN^VALM("PSJU LM ACCEPT")
+ I $G(PSJNSS) D  S PSGOEEF(26)="" K PSJACEPT,PSJNSS
+ .K DIR S DIR(0)="FOA",DIR("A")="Invalid Schedule" D ^DIR K DIR
+ I $G(PSGS0XT)="D",'$G(PSGS0Y),'$G(PSGAT),((",P,R,")'[(","_$G(PSGST)_",")) D  S PSGOEEF(39)="" K PSJACEPT
+ .K DIR S DIR(0)="FOA",DIR("A")="   WARNING - Admin times are required for DAY OF WEEK schedules  " D ^DIR K DIR
+ I '$G(PSJACEPT) D ABORTACC Q
+ I $G(PSJRNF),$G(^PS(53.1,+PSGORD,4)) D
+ . W $C(7),!!,"ACCEPTING THIS ORDER WILL CHANGE THE STATUS TO ACTIVE."
+ . S DIR(0)="Y",DIR("A")="Do you wish to make this order Active",DIR("?",1)="Enter ""N"" if you wish to exit without Activating this order,"
+ . S DIR("?")="or ""Y"" to continue with the Activation process." D ^DIR S:'Y Y=-1 K DIR
+ I $G(PSJRNF),$G(Y)=-1 S PSJACEPT=0 D ABORTACC Q
+ I $G(PSJRNF),$G(Y)=1 S PSGOEAV=1
+ I PSGOEENO S PSJNOO=$$ENNOO^PSJUTL5("E"),PSJACEPT=$S(PSJNOO<0:0,1:1)
+ACCEPT ;
+ S VALMBCK=$S($G(PSJACEPT):"Q",1:"R")
+ I '$G(PSJACEPT) D ABORTACC Q
+ K PSGOES,PSGRSD,PSGRSDN D:PSGOEENO NEW3^PSGOEE D:'PSGOEENO UPD^PSGOEF1 I $D(PSGOEF)!PSGOEENO S PSGCANFL=-1
+ D DONE1^PSGOEE
+ D DONE
+ Q
+BYPASS ;
+ S PSGCANFL=1
+ ;
+DONE ;
+ K CHK,DA,DIE,DR,DRG,MSG,Q1,Q2 ;PSGND,PSGOEE,PSGOEEF,PSGOEEND,PSGOEEG,PSGOEF,PSGOEFF,PSGOES,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGPDRG,PSGDRGN,PSG0XT,PSGS0Y,OSGSD,Q1,Q2
+ Q
+ABORTACC ; Abort Accept process.
+ D ABORT^PSGOEE K PSGOEEF D GETUD^PSJLMGUD(PSGP,PSGORD),^PSGOEF,ENSFE^PSGOEE0(PSGP,PSGORD),INIT^PSJLMUDE(PSGP,PSGORD) S VALMBCK="R",PSGSD=PSGNESD,PSGFD=PSGNEFD Q
+ ;
+ ;
+31 ;;101^PSGOE8;PSGOPD;PSGPD;101;1
+32 ;;109^PSGOE8;PSGODO;PSGDO;109;PSGODO]""
+33 ;;10^PSGOE81;PSGOSD;PSGSD;10;0
+34 ;;3^PSGOE8;PSGOMR;PSGMR;3;1
+35 ;;25^PSGOE81;PSGOFD;PSGFD;25;0
+36 ;;7^PSGOE8;PSGOST;PSGST;7;0
+37 ;;5^PSGOE82;PSGOSM;PSGSM;5;0
+38 ;;26^PSGOE8;PSGOSCH;PSGSCH;26;1      
+39 ;;39^PSGOE81;PSGOAT;PSGAT;39;0
+310 ;;1^PSGOE82;PSGOPR;PSGPR;1;1
+311 ;;8^PSGOE81;PSGOSI;PSGSI;8;0
+312 ;;2^PSGOE82;;;2;0
+313 ;;40^PSGOE82;;;40;0
+ ;
+AH ;
+ W !!?2,"Answer 'YES' to accept this order as a NON-VERIFIED UNIT DOSE order.  Answer",!,"'NO' to edit this order now.  Enter '^' to BYPASS this order, leaving it as",!,"a PENDING INPATIENT order."
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOT.m

@@ -1 @@
-PSGOT   ;BIR/CML3-TRANSFERS DATA FROM 53.1 TO 55 ;24 SEP 97 / 7:54 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**13,68,90,110,173,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(55 supported by DBIA 2191.
-        ;
-START   ; get internal record number, lock record, and write
-        S ODA=+PSGORD S:$D(^PS(55,PSGP,0))[0 ^(0)=PSGP,^PS(55,"B",PSGP,PSGP)="",$P(^PS(55,0),U,3,4)=PSGP_U_($P($G(^PS(55,0)),U,4)+1) F  L +^PS(55,PSGP,5,0):1 I  Q
-        S ZND=$G(^PS(55,PSGP,5,0)) S:ZND="" ZND="^55.06IA" F DA=$P(ZND,"^",3)+1:1 I '$D(^PS(55,PSGP,5,DA)),'$D(^("B",DA)) L +^PS(55,PSGP,5,DA):1 I  S $P(ZND,"^",3)=DA,$P(ZND,"^",4)=$P(ZND,"^",4)+1,^PS(55,PSGP,5,0)=ZND Q
-        L -^PS(55,PSGP,5,0) S ND0=^PS(53.1,ODA,0),$P(ND0,"^",23)=PSJPWD,^PS(55,PSGP,5,DA,0)=ND0
-        S (ND1,^PS(55,PSGP,5,DA,.2))=$G(^PS(53.1,ODA,.2)),^PS(55,PSGP,5,DA,.3)=$G(^PS(53.1,ODA,.3)),(ND2,^PS(55,PSGP,5,DA,2))=^PS(53.1,ODA,2),^PS(55,PSGP,5,DA,4)=$G(^PS(53.1,ODA,4)),^PS(55,"AUD",+$P(ND2,"^",4),PSGP,DA)=""
-        S X=^PS(55,PSGP,0) I $P(X,"^",7)="" S $P(X,"^",7)=$P($P(ND0,"^",16),"."),$P(X,"^",8)="A",^(0)=X
-        I $P($G(^PS(55,PSGP,5,DA,2)),"^",6)="" S $P(^PS(55,PSGP,5,DA,2),"^",6)=$S($G(PSGS0XT)'="":PSGS0XT,$P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:""),$P(^PS(53.1,ODA,2),"^",6)=$P(^PS(55,PSGP,5,DA,2),"^",6)
-        F X=6,7,13 I $D(^PS(53.1,ODA,X)) S ^PS(55,PSGP,5,DA,X)=^(X)
-        I $D(^PS(53.1,ODA,"DSS")) S ^PS(55,PSGP,5,DA,8)=^("DSS")
-        I $O(^PS(53.1,ODA,1,0)) S (C,X)=0 F  S X=$O(^PS(53.1,ODA,1,X)) Q:'X  S:$D(^(X,0)) C=C+1,^PS(55,PSGP,5,DA,1,C,0)=^(0),^PS(55,PSGP,5,DA,1,"B",+$P($G(^(0)),U),C)=""
-        I $O(^PS(53.1,ODA,1,0)) S ^PS(55,PSGP,5,DA,1,0)="^55.07P^"_C_"^"_C
-        F X=3,12 D  S ^PS(55,PSGP,5,DA,X,0)="^55.0"_$S(X=3:8,1:612)_U_CNT_U_CNT
-        .S CNT=0 F C=0:0 S C=$O(^PS(53.1,ODA,X,C)) Q:'C  I $D(^(C,0)) S ^PS(55,PSGP,5,DA,X,C,0)=^(0),CNT=CNT+1
-        S $P(^PS(53.1,ODA,0),"^",19)=DA
-CR      ; set x-refs
-        N A
-        I $D(^PS(55,PSGP,5.1)),$P(^(5.1),"^",6) S X=$P(^(5.1),"^",6) I $P(ND2,"^",3),$P(ND2,"^",6)'>X S $P(^(5.1),"^",6)=$P(ND2,"^",3)
-        S ^PS(55,PSGP,5,"B",+ODA,DA)="",^PS(55,PSGP,5,"AU",$P(ND0,"^",7),+$P(ND2,"^",4),DA)=""
-        S ^PS(55,PSGP,5,"AUS",+$P(ND2,"^",4),DA)=""
-        S ^PS(55,PSGP,5,"C",+ND1,DA)="",^PS(55,"AUE",PSGP,DA)=""
-        S ^PS(55,"AUDS",+$P(ND2,"^",2),PSGP,DA)=""
-        I $D(^PS(55,PSGP,5,DA,8)) S A=^(8),^PS(55,"AUDC",+$P(ND2,"^",4),+A,PSGP,DA)=""
-        I $$PATCH^XPDUTL("PXRM*1.5*12") S X(1)=+$P(ND2,"^",2),X(2)=+$P(ND2,"^",4),DA(1)=PSGP D SPSPA^PSJXRFS(.X,.DA,"UD")
-        K DIK S DA(1)=PSGP S DIK="^PS(55,"_DA(1)_",5,",DIK(1)=125 D EN1^DIK K DIK
-        S PSGTOL=2,PSGTOO=1 F PSGUOW=0:0 S PSGUOW=$O(^PS(53.41,2,1,PSGUOW)) Q:'PSGUOW  I $D(^(PSGUOW,1,PSGP,1,2,1,ODA)) K ^(ODA) D ENL^PSGVDS
-DONE    I $D(PSGOE2),PSGOE2]"",$D(^TMP("PSJON",$J,PSGOE2)) S ^(PSGOE2)=DA_"U"
-        S PSGODA=ODA,PSGORD=DA_"U"
-        S PSGNODE=$G(^PS(55,PSGP,5,DA,0)),PSG25=$P(PSGNODE,"^",25),PSG26=$P(PSGNODE,"^",26)
-        I PSG25 S X=$S(PSG25["V":"^PS(55,"_PSGP_",""IV"",",PSG25["U"!(PSG25["A"):"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSG25_","_$E("02",PSG25["V"+1)_")" I $D(@X) S $P(@X,"^",$S(PSG25["V":6,1:26))=DA_"U"
-        I $P(PSGNODE,"^",26),$P(PSGNODE,"^",26)'["V",$D(^PS(55,PSGP,5,+$P(PSGNODE,"^",26),0)) S $P(^(0),"^",25)=DA_"U"
-        F Q=0:0 S Q=$O(^PS(53.44,Q)) Q:'Q  I $D(^(Q,1,PSGP,ODA,0)) S $P(^(0),"^",2)=DA
-        L -^PS(53.1,ODA) L -^PS(55,DFN,5,+PSGORD) K CNT,ND,ODA,XX,ZND Q
+PSGOT ;BIR/CML3-TRANSFERS DATA FROM 53.1 TO 55 ;24 SEP 97 / 7:54 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**13,68,90,110,173**;16 DEC 97;Build 4
+ ;
+ ; Reference to ^PS(55 supported by DBIA 2191.
+ ;
+START ; get internal record number, lock record, and write
+ S ODA=+PSGORD S:$D(^PS(55,PSGP,0))[0 ^(0)=PSGP,^PS(55,"B",PSGP,PSGP)="",$P(^PS(55,0),U,3,4)=PSGP_U_($P($G(^PS(55,0)),U,4)+1) F  L +^PS(55,PSGP,5,0):1 I  Q
+ S ZND=$G(^PS(55,PSGP,5,0)) S:ZND="" ZND="^55.06IA" F DA=$P(ZND,"^",3)+1:1 I '$D(^PS(55,PSGP,5,DA)),'$D(^("B",DA)) L +^PS(55,PSGP,5,DA):1 I  S $P(ZND,"^",3)=DA,$P(ZND,"^",4)=$P(ZND,"^",4)+1,^PS(55,PSGP,5,0)=ZND Q
+ L -^PS(55,PSGP,5,0) S ND0=^PS(53.1,ODA,0),$P(ND0,"^",23)=PSJPWD,^PS(55,PSGP,5,DA,0)=ND0
+ S (ND1,^PS(55,PSGP,5,DA,.2))=$G(^PS(53.1,ODA,.2)),^PS(55,PSGP,5,DA,.3)=$G(^PS(53.1,ODA,.3)),(ND2,^PS(55,PSGP,5,DA,2))=^PS(53.1,ODA,2),^PS(55,PSGP,5,DA,4)=$G(^PS(53.1,ODA,4)),^PS(55,"AUD",+$P(ND2,"^",4),PSGP,DA)=""
+ S X=^PS(55,PSGP,0) I $P(X,"^",7)="" S $P(X,"^",7)=$P($P(ND0,"^",16),"."),$P(X,"^",8)="A",^(0)=X
+ F X=6,7,13 I $D(^PS(53.1,ODA,X)) S ^PS(55,PSGP,5,DA,X)=^(X)
+ I $D(^PS(53.1,ODA,"DSS")) S ^PS(55,PSGP,5,DA,8)=^("DSS")
+ I $O(^PS(53.1,ODA,1,0)) S (C,X)=0 F  S X=$O(^PS(53.1,ODA,1,X)) Q:'X  S:$D(^(X,0)) C=C+1,^PS(55,PSGP,5,DA,1,C,0)=^(0),^PS(55,PSGP,5,DA,1,"B",+$P($G(^(0)),U),C)=""
+ ;F C=0:0 S C=$O(^PS(55,PSGP,5,DA,1,C)) Q:'C  S X=+$G(^(C,0)) S:X ^PS(55,PSGP,5,DA,1,"B",X,C)=""
+ I $O(^PS(53.1,ODA,1,0)) S ^PS(55,PSGP,5,DA,1,0)="^55.07P^"_C_"^"_C
+ F X=3,12 D  S ^PS(55,PSGP,5,DA,X,0)="^55.0"_$S(X=3:8,1:612)_U_CNT_U_CNT
+ .S CNT=0 F C=0:0 S C=$O(^PS(53.1,ODA,X,C)) Q:'C  I $D(^(C,0)) S ^PS(55,PSGP,5,DA,X,C,0)=^(0),CNT=CNT+1
+ ;F X=3,12 I $O(^PS(53.1,ODA,X,0)) S ^PS(55,PSGP,5,DA,X,0)=^(0) F C=0:0 S C=$O(^PS(53.1,ODA,X,C)) Q:'C  I $D(^(C,0)) S ^PS(55,PSGP,5,DA,X,C,0)=^(0)
+ S $P(^PS(53.1,ODA,0),"^",19)=DA
+CR ; set x-refs
+ N A
+ I $D(^PS(55,PSGP,5.1)),$P(^(5.1),"^",6) S X=$P(^(5.1),"^",6) I $P(ND2,"^",3),$P(ND2,"^",6)'>X S $P(^(5.1),"^",6)=$P(ND2,"^",3)
+ S ^PS(55,PSGP,5,"B",+ODA,DA)="",^PS(55,PSGP,5,"AU",$P(ND0,"^",7),+$P(ND2,"^",4),DA)=""
+ S ^PS(55,PSGP,5,"AUS",+$P(ND2,"^",4),DA)=""
+ S ^PS(55,PSGP,5,"C",+ND1,DA)="",^PS(55,"AUE",PSGP,DA)=""
+ S ^PS(55,"AUDS",+$P(ND2,"^",2),PSGP,DA)=""
+ I $D(^PS(55,PSGP,5,DA,8)) S A=^(8),^PS(55,"AUDC",+$P(ND2,"^",4),+A,PSGP,DA)=""
+ I $$PATCH^XPDUTL("PXRM*1.5*12") S X(1)=+$P(ND2,"^",2),X(2)=+$P(ND2,"^",4),DA(1)=PSGP D SPSPA^PSJXRFS(.X,.DA,"UD")
+ K DIK S DA(1)=PSGP S DIK="^PS(55,"_DA(1)_",5,",DIK(1)=125 D EN1^DIK K DIK
+ S PSGTOL=2,PSGTOO=1 F PSGUOW=0:0 S PSGUOW=$O(^PS(53.41,2,1,PSGUOW)) Q:'PSGUOW  I $D(^(PSGUOW,1,PSGP,1,2,1,ODA)) K ^(ODA) D ENL^PSGVDS
+DONE I $D(PSGOE2),PSGOE2]"",$D(^TMP("PSJON",$J,PSGOE2)) S ^(PSGOE2)=DA_"U"
+ S PSGODA=ODA,PSGORD=DA_"U"
+ S PSGNODE=$G(^PS(55,PSGP,5,DA,0)),PSG25=$P(PSGNODE,"^",25),PSG26=$P(PSGNODE,"^",26)
+ I PSG25 S X=$S(PSG25["V":"^PS(55,"_PSGP_",""IV"",",PSG25["U"!(PSG25["A"):"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSG25_","_$E("02",PSG25["V"+1)_")" I $D(@X) S $P(@X,"^",$S(PSG25["V":6,1:26))=DA_"U"
+ I $P(PSGNODE,"^",26),$P(PSGNODE,"^",26)'["V",$D(^PS(55,PSGP,5,+$P(PSGNODE,"^",26),0)) S $P(^(0),"^",25)=DA_"U"
+ ;I $P(PSGNODE,"^",21) S X=$O(^ORD(101,"B","PS EVSEND OR",0))_";ORD(101,",PSOC="SC",PSJORDER=$$ORDER^PSJHLU(PSGORD) D EN1^XQOR:X K X
+ F Q=0:0 S Q=$O(^PS(53.44,Q)) Q:'Q  I $D(^(Q,1,PSGP,ODA,0)) S $P(^(0),"^",2)=DA
+ L -^PS(53.1,ODA) L -^PS(55,DFN,5,+PSGORD) K CNT,ND,ODA,XX,ZND Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m

@@ -1 @@
-PSGPLR  ;BIR/CML3-PRINTS PICK LIST REPORT ; 6/15/07 1:12pm
-        ;;5.0; INPATIENT MEDICATIONS ;**10,50,67,119,129,191**;16 DEC 97;Build 9
-        ;
-        ; Reference to ^PS(55 is supported by DBIA# 2191.
-        ; Reference to ^PS(59.7 is supported by DBIA# 2181.
-        ; Reference to ^PSDRUG is supported by DBIA# 2192.
-        ; Reference to ^%DTC is supported by DBIA# 10000.
-        ; Reference to ^VADPT is supported by DBIA# 10061.
-        ;
-        N PSGY,OLDWARD,STPDT D NOW^%DTC S PSGDT=+$E(%,1,12),PPLD=$$ENDTC^PSGMI(PSGDT),$P(OLINE,"-",75)="",PSGPLXR=$S($G(PSGPLUPF)=1:"AU",1:"AC")
-        S PGN=0,(FACL,LINE)="",$P(LINE,"-",81)="",$P(FACL,"_",31)="",TND=$G(^PS(53.5,PSGPLG,0)),PSD=$P(TND,"^",3),PFD=$P(TND,"^",4),WSF=$P(TND,"^",7),WGPN=$S('$D(^PS(57.5,PSGPLWG,0)):"N/F",$P(^(0),"^")]"":$P(^(0),"^"),1:"N/F")
-        S FFF=$S($P(PSGPLWGP,"^",4):2,$P(PSGPLWGP,"^",5):1,1:0),CML=IO'=IO(0)!($E(IOST,1,2)'="C-")
-        F X="PSD","PFD" S @X=$$ENDTC^PSGMI(@X)
-        U IO
-        I '$D(^PS(53.5,$S($D(PSGPLUPF):"AU",1:"AC"),PSGPLG)) S NPLF=0 D HEADER W !!?25,"*** No orders to fill ***" W:(IO'=IO(0)!(IOST'["C-"))&($Y) @IOF G DONE
-        ;
-BEGIN   ;
-        I '$$LOCK^PSGPLUTL(PSGPLG,"PSGPLR") H 60 G BEGIN
-        S NPLF=1,TM=0 F  S TM=$O(^PS(53.5,PSGPLXR,PSGPLG,TM)) Q:TM=""!(TM["~")  S (DDRG,PDRG,PN,PST,RM,WDN)="" D HEADER:'FFF,^PSGPLR0 I CML,'FFF D PAGECK W !!?25,"FILLED BY: ",FACL,!!?25,"CHECKED BY: ",FACL
-        I CML,FFF D PAGECK W !!?25,"FILLED BY: ",FACL,!!?25,"CHECKED BY: ",FACL W:$Y @IOF
-        ;
-DONE    ;
-        D UNLOCK^PSGPLUTL(PSGPLG,"PSGPLR")
-        K AT,ATC,CML,DDRG,DIS,DND,DO,DR,DRN,DRG,FACL,FD,FFF,FQC,LINE,ND,ND0,ND1,ND2,ND6,NEED,NPLF,OLINE,PSGPLDC,PSGPLXR,PSGPLXRX
-        K PSJJORD,PSJORDN,PFD,PGN,PN,POP,PPLD,PPN,PRM,PSD,PSGID,PSGOD,PSGP,PST,PW,RM,RTE,SCH,SD,SM,PSSN,TD,TM,TND,WDN,WL,WG,WSF,WGPN,X
-        Q
-        ;
-DD      ;
-        N PSJRNW,CNT
-        I $D(PSGPLREN("B",$G(PSGP),$G(PSJJORD))),$G(PSGPLUP) D
-        .N OSTOP,DRGND S (DDRG,OLDWARD)="" S DRGND=$O(PSGPLREN("B",PSGP,PSJJORD,0)) Q:'DRGND  S OSTOP=PSGPLREN("B",PSGP,PSJJORD,DRGND) Q:'OSTOP
-        .N ST,TMPDRG S CNT=0,ST=$P(ND0,"^",7) S TMPDRG=0 S TMPDRG=$O(PSGPLREN("B",PSGP,PSJJORD,TMPDRG)) S TMPDRG=$P(DRG,"^")_"^"_TMPDRG
-        .F PSGPLXRX="AU","AC" Q:CNT  F I=0:1 S DDRG=$O(PSGPLREN(53.5,PSGPLXRX,PSGPLG,TM,WDN,RM,PN,PST,TMPDRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG")  D
-        ..S X=$G(PSGPLREN(53.5,PSGPLG,1,PSGP,1,+DRGND,1,$P(DDRG,"^",2),0)) S DR=+X,DND=$P(X,U,2,4) Q:'X
-        ..S DRN=$G(^PS(55,PSGP,5,PSJJORD,1,DR,0)),DR=$$ENDDN^PSGMI($P(DRN,"^")) I DND?7N1"DI" S DND=$E($$ENDTC^PSGMI(+DND),1,8)
-        ..S DIS=$P(DND,"^",2),NEED=$S($P(DND,"^")]"":$P(DND,"^"),1:0)
-        ..;GMZ;PSJ*5*191;Allow for Multiple Dispensed Drug units needed
-        ..S PSJRNW(I)=1_"^"_+NEED
-        ..Q
-        .K PSGPLREN("B",PSGP,PSJJORD),PSGPLREN(53.5,PSGPLG,1,PSGP,1,+DRGND) W !!
-        ;
-        S CNT=0
-        S (DDRG,OLDWARD)="" N ST S ST=$P(ND0,"^",7) F  S DDRG=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,PST,DRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG")  S X=$G(^PS(53.5,PSGPLG,1,+$P(PN,U,2),1,+$P(DRG,U,2),1,+$P(DDRG,U,2),0)),DR=+X,DND=$P(X,U,2,4) D
-        .S DRN=$G(^PS(55,PSGP,5,PSJJORD,1,DR,0)),DR=$$ENDDN^PSGMI($P(DRN,"^")) I DND?7N1"DI" S DND=$E($$ENDTC^PSGMI(+DND),1,8) W !?6,DR,?48,ST,?51,"(DI "_DND_")",?66,"Returns: ____" Q
-        .S UD=$P(DRN,"^",2),ATC=$P($G(^PSDRUG(+DRN,8.5)),"^",2)]"" S:ATC ATC=$D(^(212,"AC",PSGPLWG))
-        .S DIS=$P(DND,"^",2),NEED=$S($P(DND,"^")]"":$P(DND,"^"),1:0) I ATC S ATCFF=+$P($G(^PS(59.7,1,26)),"^",7),ATC=$S(ATCFF:NEED,UD#1:0,DIS]"":+DIS,1:NEED) I ATC,$S(ATC<1:1,ATC'?1.3N:1,1:ATC#1) S ATC=0
-        .I ATC S X=0,X=$O(^PS(59.7,X)) I $P($G(^(X,26)),U,2)=1,PST="OC" S ATC=0
-        .S UD=$S('UD:1,UD=.5:"1/2",UD=.25:"1/4",UD<1:"0"_UD,1:UD)
-        .I $D(PSJRNW) D
-        ..I 'CNT W !?35,"**** RENEWAL ****"
-        ..S NEED=NEED-$P(PSJRNW(CNT),"^",2) S:NEED<0 NEED=0 S CNT=CNT+1
-        .W !?6,DR,?48,ST W:(ATC)&(NEED>0) ?57,"ATC" W ?61,$J(UD,4),?68,$J(NEED,4),?75,$S(DIS]"":$J(DIS,4),1:"____")
-        .S:ST="DISCONTINUED" OLDWARD=1 S ST=""
-        I DDRG="NO DISPENSE DRUG" W !?6,PDRG,?48,ST,?57,"OI" S:ST="DISCONTINUED" OLDWARD=1 S ST=""
-        N GIVSTR S GIVSTR=$S(DO]"":DO_" ",1:"")_RTE_" "_SCH D
-        .N MARX,I,Y,X D TXT^PSGMUTL(GIVSTR,60)
-        .F I=1:1:MARX W:I=1 !?10,"Give: ",MARX(1) W:I>1 !?16,MARX(I)
-        D:OLDWARD WARDCHK W:AT]"" !,?65-$L(AT),AT W !?7,"Start: ",SD,?37,"Stop: ",FD
-        I Y]"" W !?10 F Q=1:1:$L(Y," ") S X=$P(Y," ",Q) W:$X+$L(X)>65 !?10 W X_" "
-        K ST
-        Q
-        ;
-EXDD    ;
-        W ! S (DDRG,OLDWARD)="" F  S DDRG=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,PST,DRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG")  S DND=^(DDRG) D
-        .S DR=$P(DDRG,"^",2),DRN=$G(^PS(55,PSGP,5,PSJJORD,1,DR,0)),ID=$P(DRN,"^",3),DR=$$ENDDN^PSGMI($P(DRN,"^")) W !?6,DR,?48,DIS,?66,"Returns: ____" S:DIS="DISCONTINUED" OLDWARD=1 S DIS=""
-        I DDRG="NO DISPENSE DRUG" S ND1=$G(^PS(55,PSGP,5,PSJJORD,.2)),PDRG=$$ENPDN^PSGMI($P(ND1,"^")) W !?6,PDRG,?48,DIS,?66,"Returns: ____" S:DIS="DISCONTINUED" OLDWARD=1 S DIS=""
-        W !?10,"Give: ",$S(DO]"":DO_" ",1:""),RTE," ",SCH D:OLDWARD WARDCHK W !?7,"Start: ",SD,?37,"Stop: ",FD
-        Q
-        ;
-FCL     ;
-        I PGN,CML,$P(PSGPLWGP,"^",6) W !!?25,"FILLED BY: ",FACL,!!?25,"CHECKED BY: "_FACL
-        ;
-HEADER  ;
-        S PGN=PGN+1 W:$Y @IOF
-        W ?1,"(",PSGPLG,")",?$S($D(PSGPLUPF):27,1:32),"PICK LIST REPORT" W:$D(PSGPLUPF) " (UPDATE)" W ?64,PPLD,!,"Ward group: ",WGPN,?73-$L(PGN),"Page: ",PGN,!?18,"For ",PSD," through ",PFD W:NPLF !,"Team: ",$S(TM'["zz":TM,1:"** N/F **")
-        W !!,$S($P(TND,"^",6)&'$P(TND,"^",8):"Bed-Room",1:"Room-Bed"),?15,"Patient",?67,"Units",?74,"Units",!?9,"Medication",?48,"ST",?62,"U/D",?66,"Needed",?74,"Disp'd",!,LINE Q
-        ;
-PAGECK  ;
-        S PSGPY=$Y,PSGPY=$Y+4 I PSGPY+4>IOSL W @IOF
-        Q
-        ;
-WARDCHK ;  if patient has discontinued orders from a different ward, print the ward and room/bed that the orders were discontinued from.
-        Q:'$G(STPDT)
-        S VAINDT=$$MINUTES(STPDT,5)
-        S DFN=PSGP D INP^VADPT I PW'=$P(VAIN(4),"^",2) W ?48,$E("(from "_$P(VAIN(4),"^",2)_" "_VAIN(5)_")",1,31)
-        S OLDWARD="" Q
-        ;
-MINUTES(STPDT,LESS)         ; pass in a FM date/time and the number of minutes (9 or less) to subtract from it
-        S VAINDT=$S($E(STPDT,9,12)<LESS:($E(STPDT,1,7)-1)_"."_(($E(STPDT,9,12)+2360)-LESS),$E(STPDT,11,12)<5:$E(STPDT,1,8)_$S($E(STPDT,9,10)="10":"09",$E(STPDT,9,10)="20":"19",1:$E(STPDT,9)_($E(STPDT,10)-1))_(60+$E(STPDT,12)-LESS),1:STPDT-(LESS*.0001))
-        Q VAINDT
+PSGPLR ;BIR/CML3-PRINTS PICK LIST REPORT ;04 May 98 / 11:23 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**10,50,67,119,129**;16 DEC 97
+ ;
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^PS(59.7 is supported by DBIA# 2181.
+ ; Reference to ^PSDRUG is supported by DBIA# 2192.
+ ; Reference to ^%DTC is supported by DBIA# 10000.
+ ; Reference to ^VADPT is supported by DBIA# 10061.
+ ;
+ N PSGY,OLDWARD,STPDT D NOW^%DTC S PSGDT=+$E(%,1,12),PPLD=$$ENDTC^PSGMI(PSGDT),$P(OLINE,"-",75)="",PSGPLXR=$S($G(PSGPLUPF)=1:"AU",1:"AC")
+ S PGN=0,(FACL,LINE)="",$P(LINE,"-",81)="",$P(FACL,"_",31)="",TND=$G(^PS(53.5,PSGPLG,0)),PSD=$P(TND,"^",3),PFD=$P(TND,"^",4),WSF=$P(TND,"^",7),WGPN=$S('$D(^PS(57.5,PSGPLWG,0)):"N/F",$P(^(0),"^")]"":$P(^(0),"^"),1:"N/F")
+ S FFF=$S($P(PSGPLWGP,"^",4):2,$P(PSGPLWGP,"^",5):1,1:0),CML=IO'=IO(0)!($E(IOST,1,2)'="C-")
+ F X="PSD","PFD" S @X=$$ENDTC^PSGMI(@X)
+ U IO
+ I '$D(^PS(53.5,$S($D(PSGPLUPF):"AU",1:"AC"),PSGPLG)) S NPLF=0 D HEADER W !!?25,"*** No orders to fill ***" W:(IO'=IO(0)!(IOST'["C-"))&($Y) @IOF G DONE
+ ;
+BEGIN ;
+ I '$$LOCK^PSGPLUTL(PSGPLG,"PSGPLR") H 60 G BEGIN
+ S NPLF=1,TM=0 F  S TM=$O(^PS(53.5,PSGPLXR,PSGPLG,TM)) Q:TM=""!(TM["~")  S (DDRG,PDRG,PN,PST,RM,WDN)="" D HEADER:'FFF,^PSGPLR0 I CML,'FFF D PAGECK W !!?25,"FILLED BY: ",FACL,!!?25,"CHECKED BY: ",FACL
+ I CML,FFF D PAGECK W !!?25,"FILLED BY: ",FACL,!!?25,"CHECKED BY: ",FACL W:$Y @IOF
+ ;
+DONE ;
+ D UNLOCK^PSGPLUTL(PSGPLG,"PSGPLR")
+ K AT,ATC,CML,DDRG,DIS,DND,DO,DR,DRN,DRG,FACL,FD,FFF,FQC,LINE,ND,ND0,ND1,ND2,ND6,NEED,NPLF,OLINE,PSGPLDC,PSGPLXR,PSGPLXRX
+ K PSJJORD,PSJORDN,PFD,PGN,PN,POP,PPLD,PPN,PRM,PSD,PSGID,PSGOD,PSGP,PST,PW,RM,RTE,SCH,SD,SM,PSSN,TD,TM,TND,WDN,WL,WG,WSF,WGPN,X
+ Q
+ ;
+DD ;
+ N PSJRNW,CNT
+ I $D(PSGPLREN("B",$G(PSGP),$G(PSJJORD))),$G(PSGPLUP) D
+ .N OSTOP,DRGND S (DDRG,OLDWARD)="" S DRGND=$O(PSGPLREN("B",PSGP,PSJJORD,0)) Q:'DRGND  S OSTOP=PSGPLREN("B",PSGP,PSJJORD,DRGND) Q:'OSTOP
+ .N ST,TMPDRG S CNT=0,ST=$P(ND0,"^",7) S TMPDRG=0 S TMPDRG=$O(PSGPLREN("B",PSGP,PSJJORD,TMPDRG)) S TMPDRG=$P(DRG,"^")_"^"_TMPDRG
+ .F PSGPLXRX="AU","AC" Q:CNT  F  S DDRG=$O(PSGPLREN(53.5,PSGPLXRX,PSGPLG,TM,WDN,RM,PN,PST,TMPDRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG")  D
+ ..S X=$G(PSGPLREN(53.5,PSGPLG,1,PSGP,1,+DRGND,1,$P(DDRG,"^",2),0)) S DR=+X,DND=$P(X,U,2,4) Q:'X
+ ..S DRN=$G(^PS(55,PSGP,5,PSJJORD,1,DR,0)),DR=$$ENDDN^PSGMI($P(DRN,"^")) I DND?7N1"DI" S DND=$E($$ENDTC^PSGMI(+DND),1,8)
+ ..S DIS=$P(DND,"^",2),NEED=$S($P(DND,"^")]"":$P(DND,"^"),1:0)
+ ..S PSJRNW=1_"^"_+NEED
+ ..Q
+ .K PSGPLREN("B",PSGP,PSJJORD),PSGPLREN(53.5,PSGPLG,1,PSGP,1,+DRGND) W !!
+ ;
+ S CNT=0
+ S (DDRG,OLDWARD)="" N ST S ST=$P(ND0,"^",7) F  S DDRG=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,PST,DRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG")  S X=$G(^PS(53.5,PSGPLG,1,+$P(PN,U,2),1,+$P(DRG,U,2),1,+$P(DDRG,U,2),0)),DR=+X,DND=$P(X,U,2,4) D
+ .S DRN=$G(^PS(55,PSGP,5,PSJJORD,1,DR,0)),DR=$$ENDDN^PSGMI($P(DRN,"^")) I DND?7N1"DI" S DND=$E($$ENDTC^PSGMI(+DND),1,8) W !?6,DR,?48,ST,?51,"(DI "_DND_")",?66,"Returns: ____" Q
+ .S UD=$P(DRN,"^",2),ATC=$P($G(^PSDRUG(+DRN,8.5)),"^",2)]"" S:ATC ATC=$D(^(212,"AC",PSGPLWG))
+ .S DIS=$P(DND,"^",2),NEED=$S($P(DND,"^")]"":$P(DND,"^"),1:0) I ATC S ATCFF=+$P($G(^PS(59.7,1,26)),"^",7),ATC=$S(ATCFF:NEED,UD#1:0,DIS]"":+DIS,1:NEED) I ATC,$S(ATC<1:1,ATC'?1.3N:1,1:ATC#1) S ATC=0
+ .I ATC S X=0,X=$O(^PS(59.7,X)) I $P($G(^(X,26)),U,2)=1,PST="OC" S ATC=0
+ .S UD=$S('UD:1,UD=.5:"1/2",UD=.25:"1/4",UD<1:"0"_UD,1:UD)
+ .I $G(PSJRNW),'CNT W !?35,"**** RENEWAL ****" S CNT=CNT+1,NEED=NEED-$P(PSJRNW,"^",2) S:NEED<0 NEED=0
+ .W !?6,DR,?48,ST W:(ATC)&(NEED>0) ?57,"ATC" W ?61,$J(UD,4),?68,$J(NEED,4),?75,$S(DIS]"":$J(DIS,4),1:"____")
+ .S:ST="DISCONTINUED" OLDWARD=1 S ST=""
+ I DDRG="NO DISPENSE DRUG" W !?6,PDRG,?48,ST,?57,"OI" S:ST="DISCONTINUED" OLDWARD=1 S ST=""
+ N GIVSTR S GIVSTR=$S(DO]"":DO_" ",1:"")_RTE_" "_SCH D
+ .N MARX,I,Y,X D TXT^PSGMUTL(GIVSTR,60)
+ .F I=1:1:MARX W:I=1 !?10,"Give: ",MARX(1) W:I>1 !?16,MARX(I)
+ D:OLDWARD WARDCHK W:AT]"" !,?65-$L(AT),AT W !?7,"Start: ",SD,?37,"Stop: ",FD
+ I Y]"" W !?10 F Q=1:1:$L(Y," ") S X=$P(Y," ",Q) W:$X+$L(X)>65 !?10 W X_" "
+ K ST
+ Q
+ ;
+EXDD ;
+ W ! S (DDRG,OLDWARD)="" F  S DDRG=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,PST,DRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG")  S DND=^(DDRG) D
+ .S DR=$P(DDRG,"^",2),DRN=$G(^PS(55,PSGP,5,PSJJORD,1,DR,0)),ID=$P(DRN,"^",3),DR=$$ENDDN^PSGMI($P(DRN,"^")) W !?6,DR,?48,DIS,?66,"Returns: ____" S:DIS="DISCONTINUED" OLDWARD=1 S DIS=""
+ I DDRG="NO DISPENSE DRUG" S ND1=$G(^PS(55,PSGP,5,PSJJORD,.2)),PDRG=$$ENPDN^PSGMI($P(ND1,"^")) W !?6,PDRG,?48,DIS,?66,"Returns: ____" S:DIS="DISCONTINUED" OLDWARD=1 S DIS=""
+ W !?10,"Give: ",$S(DO]"":DO_" ",1:""),RTE," ",SCH D:OLDWARD WARDCHK W !?7,"Start: ",SD,?37,"Stop: ",FD
+ Q
+ ;
+FCL ;
+ I PGN,CML,$P(PSGPLWGP,"^",6) W !!?25,"FILLED BY: ",FACL,!!?25,"CHECKED BY: "_FACL
+ ;
+HEADER ;
+ S PGN=PGN+1 W:$Y @IOF
+ W ?1,"(",PSGPLG,")",?$S($D(PSGPLUPF):27,1:32),"PICK LIST REPORT" W:$D(PSGPLUPF) " (UPDATE)" W ?64,PPLD,!,"Ward group: ",WGPN,?73-$L(PGN),"Page: ",PGN,!?18,"For ",PSD," through ",PFD W:NPLF !,"Team: ",$S(TM'["zz":TM,1:"** N/F **")
+ W !!,$S($P(TND,"^",6)&'$P(TND,"^",8):"Bed-Room",1:"Room-Bed"),?15,"Patient",?67,"Units",?74,"Units",!?9,"Medication",?48,"ST",?62,"U/D",?66,"Needed",?74,"Disp'd",!,LINE Q
+ ;
+PAGECK ;
+ S PSGPY=$Y,PSGPY=$Y+4 I PSGPY+4>IOSL W @IOF
+ Q
+ ;
+WARDCHK ;  if patient has discontinued orders from a different ward, print the ward and room/bed that the orders were discontinued from.
+ Q:'$G(STPDT)
+ S VAINDT=$$MINUTES(STPDT,5)
+ S DFN=PSGP D INP^VADPT I PW'=$P(VAIN(4),"^",2) W ?48,$E("(from "_$P(VAIN(4),"^",2)_" "_VAIN(5)_")",1,31)
+ S OLDWARD="" Q
+ ;
+MINUTES(STPDT,LESS)     ; pass in a FM date/time and the number of minutes (9 or less) to subtract from it
+ S VAINDT=$S($E(STPDT,9,12)<LESS:($E(STPDT,1,7)-1)_"."_(($E(STPDT,9,12)+2360)-LESS),$E(STPDT,11,12)<5:$E(STPDT,1,8)_$S($E(STPDT,9,10)="10":"09",$E(STPDT,9,10)="20":"19",1:$E(STPDT,9)_($E(STPDT,10)-1))_(60+$E(STPDT,12)-LESS),1:STPDT-(LESS*.0001))
+ Q VAINDT

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGS0.m

@@ -1 @@
-PSGS0   ;BIR/CML3-SCHEDULE PROCESSOR ;29 Jan 99 / 8:04 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**12,25,26,50,63,74,83,116,110,111,133,138,174,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(51.1 is supported by DBIA 2177
-        ; Reference to ^PS(55   is supported by DBIA 2191
-        ;
-ENA     ; entry point for train option
-        D ENCV^PSGSETU Q:$D(XQUIT)
-        F  S (PSGS0Y,PSGS0XT)="" R !!,"Select STANDARD SCHEDULE: ",X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X  D:X?1."?" ENQ^PSGSH I X'?1."?" D EN W:$D(X)[0 $C(7),"  ??" I $D(X)#2,'PSGS0Y,PSGS0XT W "  Every ",PSGS0XT," minutes"
-        K DIC,DIE,PSGS0XT,PSGS0Y,Q,X,Y,PSGDT Q
-        ;
-EN3     ;
-        S PSGST=$P($G(^PS(53.1,DA,0)),"^",7) G EN
-        ;
-EN5     ;
-        S PSGST=$P($G(^PS(55,DA(1),5,DA,0)),"^",7)
-        ;
-EN      ; validate
-        K PSGS0Y
-        I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X)>70)!($L(X)<1) K X Q
-        S X=$$TRIM^XLFSTR(X,"R"," ")
-        I X?.E1L.E S X=$$ENLU^PSGMI(X) I '$D(PSGOES) D EN^DDIOL("  ("_X_")")
-        ;
-ENOS    ; order set entry
-        N X0,Y0,PSJXI,PSJDIC2,TMPAT
-        I $G(X)="",$G(P(2)),$G(P(3)) S X=$G(P(9))
-        I $G(X)="" Q
-        S PSGXT=$G(PSGS0XT),(PSGS0XT,PSGS0Y,XT,Y,PSJNSS)=""
-        S X0=X I X?2.4N1"-".E!(X?2.4N) D ENCHK S:$D(X) Y=X G Q
-        ; * GUI 27 CHANGES * Check for admin times to be derived from 'base' schedule
-        I X["@" S TMPAT=$P(X,"@",2) I TMPAT]"" D
-        .I '$D(^PS(51.1,"AC","PSJ",TMPAT)) K TMPAT Q
-        .I '$$DOW^PSIVUTL($P(X,"@")) K TMPAT Q
-        .N LYN,ZZND,PSGS0XT,PSGS0Y,X S (PSGS0Y,PSGS0XT,X)=""
-        .S X=TMPAT D DIC I $G(Y0)>0 S TMPAT=Y0
-        I $G(TMPAT) S (PSGS0Y,$P(X,"@",2))=TMPAT,PSGS0XT="D"
-        ; * GUI 27 CHANGES *
-        I X["PRN",$$PRNOK(X),'$D(^PS(51.1,"AC","PSJ",X)) D  G Q
-        .I X["@"!$$DOW^PSIVUTL($P(X," PRN")) N DOW D  I $G(DOW) S (Y0,Y,PSGS0Y)=$P($P(X,"@",2)," ")
-        ..N TMP S TMP=X N X S X=$P(TMP," PRN") D DW I $G(X)]"" S DOW=1
-        ..I $G(DOW),$G(PSGST)]"" I ",P,R,"'[(","_PSGST_",") S (XT,PSGS0XT)="D"
-        D DIC I $G(XT)]""!$G(Y0)!($G(X)]""&$G(PSJXI)) D  I $G(X)]"" G:$D(^PS(51.1,"AC","PSJ",X)) Q3 I $P(X,"@")]"" G:$D(^PS(51.1,"AC","PSJ",$P(X,"@"))) Q3
-        .S PSGS0XT=XT S:$G(Y0) (Y,PSGS0Y)=Y0 S:'PSGS0Y&((PSGS0XT)="D")&(X["@") PSGS0Y=$P(X,"@",2)
-        .S PSGS0Y=$P(PSGS0Y," ")
-        N TMPSCHX S TMPSCHX=X I $L(X,"@")<3 S TMPX=X D DW I $G(X)]"" K PSJNSS S (PSGS0XT,XT)="D" D  G Q
-        .S Y=$S(($G(TMPSCHX)["@"):$P(TMPSCHX,"@",2),1:"")
-        .I Y,(X'["@"),(TMPSCHX["@") S X=TMPSCHX
-        S X=TMPSCHX
-        I X'="" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS G Q
-        ;
-NS      I ($G(X)="^")!($G(X)="") K X S Y="" Q
-        N NS S NS=0,PSJNSS=0
-        I $G(Y)'>0 S X=X0,Y="",NS=1,PSJNSS=1
-Q       ;
-        S PSGS0XT=$S(XT]"":XT,1:$G(PSGS0XT)),PSGS0Y=$S($G(Y):Y,$G(PSGS0Y):PSGS0Y,1:"") S:PSGS0XT<0 PSGS0XT=""
-        I ('$G(PSGS0Y)&'$G(PSJDIC2)&$G(PSGAT))&'$G(PSJNEWOE)&$G(PSGS0XT) I PSGS0XT<1441 I ($L($G(PSGAT),"-")=PSGS0XT/1440)!($G(X)]""&($G(PSGSCH)=$G(X))) S PSGS0Y=$G(PSGAT)
-Q2      K YY
-        I '$G(PSJNSS),'$G(PSGS0Y),$G(YY) S PSGS0Y=YY
-        I $G(X)]"",$$SCHREQ^PSJLIVFD(.P) D
-        .I $$DOW^PSIVUTL(X)!$$PRNOK(X)!$D(^PS(51.1,"AC","PSJ",X)) S PSJNSS=0 Q
-        .I $G(P(2))&$G(P(3)) D NSSCONT(X,PSGS0XT) S TMPX="" K X
-        I ($G(PSJNSS)&($G(VALMBCK)'="Q"))!($G(PSJNSS)&$G(PSJLIFNI))!($G(PSJNSS)&$G(PSJTUD)) D
-        .I $G(P(2))&$G(P(3)) Q
-        .I ($G(X)]"") I ($G(PSGS0XT)'="D") D NSSCONT(X,PSGS0XT) S TMPX="" K X
-Q3      I $G(X)]"" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS
-        K QX,SDW,SWD,X0,XT,Z Q
-        ;
-NSSCONT(SCH,FREQ)       ;
-        Q:SCH=""!($G(VALMBCK)]"")!$G(PSGMARSD)!$G(PSIVFN1)
-        I $G(PSGOES),'$G(NSFF) Q
-        N PSGS0XT,PSGSCH,DIR,X,Y S PSGSCH=SCH,PSGS0XT=FREQ,PSJNSS=1
-        D NSSMSG I ($L(PSJNSS)>2),'$G(PSJXI) W !!,PSJNSS,! S PSJNSS=1
-        S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR
-        K NSFF Q
-        ;
-NSSMSG  ;
-        Q:$G(PSJXI)
-        I '(",O,"[(","_$G(PSGST)_",")),$G(PSJNSS),$G(PSGSCH)]"" D
-        .S PSJNSS=" WARNING - "_PSGSCH_" is an invalid schedule."
-        S PSGSCH="",PSGS0XT=""
-        Q
-        ;
-NSO(FQ) ;
-        Q:'FQ!(FQ<0)!(",D,O,"[(","_$G(PSGST)_",")) ""
-        K FRQOUT S FRQOUT=$S(FQ<60:(FQ_"minute"),(FQ<1440)&(FQ#60):(FQ_" minute"),(FQ<1440)!(FQ#1440):(FQ/60_" hour"),1:(FQ/1440_" day")) D
-        . S:(+FRQOUT'=1) FRQOUT=FRQOUT_"s"
-        Q FRQOUT
-        ;
-ENCHK   ;
-        I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q
-        S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q
-        S X(1)=$L(X(1)) I X'["-"&((X>$E(2400,1,X(1))!($E(X,3,4)>59))) K X Q
-        F X(2)=2:1:$L(X,"-") S X(3)=$P(X,"-",X(2)) I $S($L(X(3))'=X(1):1,X(3)>$E(2400,1,X(1)):1,$E(X(3),3,4)>59:1,1:X(3)'>$P(X,"-",X(2)-1)) K X Q
-        K:$D(X) X(1),X(2),X(3) Q
-        ;
-DIC     ; Check for schedule's existence in ADMINISTRATION SCHEDULE file (#51.1)
-        ; Input:    
-        ;           X = Schedule Name
-        ;     PSJSLUP = If $G(PSJSLUP), perform interactive fileman lookup (optional).
-        ;     PSGSFLG = If $G(PSGSFLG), return schedule IEN in PSGSCIEN variable (optional)
-        ;    PSJLIFNI = Flag indicating a U/D order is being finished as an IV (optional).
-        ;      PSGOES = If PSGOES=1, IX^DIC is called silently. If PSGOES=2, IX^DIC is not called (optional).
-        ;      PSJPWD = IEN of Inpatient Ward associated with the patient/order/schedule combination (optional).
-        ; Output:
-        ;           X = Schedule Name if valid Input Schedule X, undefined if invalid Input Schedule X.
-        ;     PSGS0XT = Frequency of validated schedule.
-        ;     PSGS0Y  = Default Admin Times of validated schedule.
-        ;    PSGSCIEN = IEN of validated schedule, if PSGSLFG is passed in and is evaluated to TRUE.
-        ;     
-        ;
-        K Y0,PSJXI N Y
-        S Z=0 F PSJXI=0:1 S Z=$O(^PS(51.1,"AC","PSJ",X,Z)) Q:'Z
-        I $G(X)]"",'$G(PSJSLUP) D
-        .I $D(^PS(51.1,"AC","PSJ",X)) D  Q:$G(PSGS0Y)&($G(PSGS0XT)]"")
-        ..I $$DOW^PSIVUTL(X) S PSGS0XT="D",PSJNSS=0 S:X["@" (Y0,PSGS0Y)=$P(X,"@",2) Q
-        ..I $G(NSFF) S Y0=$S($G(PSGS0Y):PSGS0Y,$G(PSGAT)&'$G(PSJNEWOE):PSGAT,1:"") S:Y0 PSGS0Y=Y0
-        .; Check for duplicate schedules - force selection
-        .Q:PSJXI>1&('$G(PSGOES))&($G(PSGS0XT)]"")
-        .I $D(^PS(51.1,"AC","PSJ",X)) N FREQ,ADMATCH S FREQ=$G(PSGS0XT) D
-        ..N PSGS0XT,PSGS0Y,PSGST D ADMIN^PSJORPOE S:$G(PSGS0XT) XT=PSGS0XT S:$G(PSGS0Y) (Y0,Y)=PSGS0Y
-        ..;Check flag PSGSFLG to determine whether to return the schedule IEN in PSGSCIEN.
-        .S:$G(XT)]"" PSGS0XT=XT S:$G(Y) PSGS0Y=Y
-        .I $$DOW^PSIVUTL(X) S:PSGS0XT="" (XT,PSGS0XT)="D" S:PSGS0Y="" (Y0,PSGS0Y)=$S($P(X,"@",2):$P(X,"@",2),1:"")
-        I $G(PSJLIFNI)!($G(P(4))]""&($G(P(2))]"")) I '$D(^PS(51.1,"AC","PSJ",X))!($G(PSJXI)>1) S PSJSLUP=1
-        I $G(NSFF),$G(PSJXI)>1 D
-        .I $G(PSGS0XT)="",$G(NSFF),$G(PSGXT)]"" S PSGS0XT=PSGXT Q
-        .I $G(PSGS0XT)=""!($G(PSGS0Y)="") S PSJSLUP=1
-        I '$G(PSJSLUP) Q:$G(PSGS0XT)]""&($G(PSGS0Y)]"")  Q:($G(PSGS0XT)="D"&('$D(^PS(51.1,"AC","PSJ",X))))
-        Q:$G(PSGOES)=2
-        Q:$G(PSGS0XT)]""&(PSJXI=1)
-        K PSJSLUP
-        ;
-        K DIC S DIC="^PS(51.1,",DIC(0)=$E("E",'$D(PSGOES))_"ISZ",DIC("W")="W ""  "","_$S('$D(PSJPWD):"$P(^(0),""^"",2)",'PSJPWD:"$P(^(0),""^"",2)",1:"$S($D(^PS(51.1,+Y,1,+PSJPWD,0)):$P(^(0),""^"",2),1:$P(^PS(51.1,+Y,0),""^"",2))"),D="APPSJ"
-        I $D(PSGST) ;S DIC("S")="I $P(^(0),""^"",5)"_$E("'",PSGST'="O")_"=""O"""
-        S PSJDIC2=1
-        D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE I Y'>0 D  Q
-        .I '$$DOW^PSIVUTL(X),'$$PRNOK(X) S X="",PSJNSS=1,XT="",PSJXI=""
-        S XT=$S("C"[$P(Y(0),"^",5):$P(Y(0),"^",3),1:$P(Y(0),"^",5))
-        S X=+Y,Y="" I $D(PSJPWD),$D(^PS(51.1,+X,1,+PSJPWD,0)) S Y=$P(^(0),"^",2)
-        ;Check flag PSGSFLG to determine whether to return the schedule IEN in PSGSCIEN.
-        I $G(PSGSFLG) S PSGSCIEN=X
-        S (X,X0)=Y(0,0) S:$G(Y)="" Y=$P(Y(0),"^",2)
-        S (PSGS0Y,Y0)=$G(Y),Y0(0)=Y(0) I $P(Y(0),"^",3) S XT=$P(Y(0),"^",3)
-        I $G(PSGS0XT)="",$$DOW^PSIVUTL(X) S (XT,PSGS0XT)="D"
-        Q
-        ;
-DW      ;
-        N Y
-        Q:($L(X,"@")>2)
-        N AT I X["@" S AT=$P(X,"@",2)
-        S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2) N XABB S XABB=""
-        I X]"" D ENCHK Q:'$D(X)
-        S X=$P(SDW,"@"),X(1)="-" I X?.E1P.E,X'["-"  ;F QX=1:1:$L(X) I $E(X,QX)?1P S X(1)=$E(X,QX) Q
-        F Q=1:1:$L(X,X(1)) K:SWD="" X Q:SWD=""  S Z=$P(X,X(1),Q) D DWC Q:'$D(X)
-        I $D(X) F II=1:1:$L(X,X(1)) S XABB=$G(XABB)_$E($P(X,X(1),II),1,2)_"-"
-        K X(1) S:$D(X) X=SDW I $G(X)]"" I $TR(XABB,"-")]"" S X=$E($G(XABB),1,$L(XABB)-1)
-        I $G(AT) S PSGS0Y=AT
-        Q
-DWC     I $L(Z)<2 K X Q
-        F QX=1:1:$L(SWD,"^") S Y=$P(SWD,"^",QX) I $P(Y,Z)="" S SWD=$P(SWD,Y,2) S:$L(SWD) SWD=$E(SWD,2,50) Q
-        E  K X
-        Q
-        ;
-PRNOK(PSCH)     ;
-        Q:PSCH'["PRN" 0
-        I $TR(PSCH," ")="PRN" Q 1
-        N BASE,I,OK S OK=0 S I=$P(PSCH," PRN") I I]"",$D(^PS(51.1,"AC","PSJ",I)) S OK=1
-        I 'OK D
-        .I PSCH["@" I $D(^PS(51.1,"AC","PSJ",$P(PSCH,"@")))!$$DOW^PSIVUTL($P(PSCH,"@")) S OK=1 Q
-        .I $$DOW^PSIVUTL($P(PSCH," PRN")) S OK=1
-        Q OK
-ODD(PSF)        ;determine if this is an odd schedule
-        I PSF>1439,PSF#1440 Q 1
-        I PSF,PSF<1440,1440#PSF Q 1
-        Q 0
+PSGS0 ;BIR/CML3-SCHEDULE PROCESSOR ;29 Jan 99 / 8:04 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**12,25,26,50,63,74,83,116,110,111,133,138,174**;16 DEC 97
+ ;
+ ; Reference to ^PS(51.1 is supported by DBIA 2177
+ ; Reference to ^PS(55   is supported by DBIA 2191
+ ;
+ENA ; entry point for train option
+ D ENCV^PSGSETU Q:$D(XQUIT)
+ F  S (PSGS0Y,PSGS0XT)="" R !!,"Select STANDARD SCHEDULE: ",X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X  D:X?1."?" ENQ^PSGSH I X'?1."?" D EN W:$D(X)[0 $C(7),"  ??" I $D(X)#2,'PSGS0Y,PSGS0XT W "  Every ",PSGS0XT," minutes"
+ K DIC,DIE,PSGS0XT,PSGS0Y,Q,X,Y,PSGDT Q
+ ;
+EN3 ;
+ S PSGST=$P($G(^PS(53.1,DA,0)),"^",7) G EN
+ ;
+EN5 ;
+ S PSGST=$P($G(^PS(55,DA(1),5,DA,0)),"^",7)
+ ;
+EN ; validate
+ K PSGS0Y
+ I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X)>70)!($L(X)<1) K X Q
+ S X=$$TRIM^XLFSTR(X,"R"," ")
+ I X?.E1L.E S X=$$ENLU^PSGMI(X) I '$D(PSGOES) D EN^DDIOL("  ("_X_")")
+ ;
+ENOS ; order set entry
+ N X0,Y0,PSJXI,PSJDIC2
+ I $G(X)="",$G(P(2)),$G(P(3)) S X=$G(P(9))
+ I $G(X)="" Q
+ S PSGXT=$G(PSGS0XT),(PSGS0XT,PSGS0Y,XT,Y,PSJNSS)=""
+ S X0=X I X?2.4N1"-".E!(X?2.4N) D ENCHK S:$D(X) Y=X G Q
+ I X["PRN",$$PRNOK(X),'$D(^PS(51.1,"AC","PSJ",X)) D  G Q
+ .I X["@"!$$DOW^PSIVUTL($P(X," PRN")) N DOW D  I $G(DOW) S (Y0,Y,PSGS0Y)=$P($P(X,"@",2)," ")
+ ..N TMP S TMP=X N X S X=$P(TMP," PRN") D DW I $G(X)]"" S DOW=1
+ ..I $G(DOW),$G(PSGST)]"" I ",P,R,"'[(","_PSGST_",") S (XT,PSGS0XT)="D"
+ D DIC I $G(XT)]""!$G(Y0)!($G(X)]""&$G(PSJXI)) D  I $G(X)]"" G:$D(^PS(51.1,"AC","PSJ",X)) Q3 I $P(X,"@")]"" G:$D(^PS(51.1,"AC","PSJ",$P(X,"@"))) Q3
+ .S PSGS0XT=XT S:$G(Y0) (Y,PSGS0Y)=Y0 S:'PSGS0Y&((PSGS0XT)="D")&(X["@") PSGS0Y=$P(X,"@",2)
+ .S PSGS0Y=$P(PSGS0Y," ")
+ N TMPSCHX S TMPSCHX=X I $L(X,"@")<3 S TMPX=X D DW I $G(X)]"" K PSJNSS S (PSGS0XT,XT)="D" D  G Q
+ .S Y=$S(($G(TMPSCHX)["@"):$P(TMPSCHX,"@",2),1:"")
+ .I Y,(X'["@"),(TMPSCHX["@") S X=TMPSCHX
+ S X=TMPSCHX
+ I X'="" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS G Q
+ ;
+NS I ($G(X)="^")!($G(X)="") K X S Y="" Q
+ N NS S NS=0,PSJNSS=0
+ I $G(Y)'>0 S X=X0,Y="",NS=1,PSJNSS=1
+Q ;
+ S PSGS0XT=$S(XT]"":XT,1:$G(PSGS0XT)),PSGS0Y=$S($G(Y):Y,$G(PSGS0Y):PSGS0Y,1:"") S:PSGS0XT<0 PSGS0XT=""
+ I ('$G(PSGS0Y)&'$G(PSJDIC2)&$G(PSGAT))&'$G(PSJNEWOE)&$G(PSGS0XT) I PSGS0XT<1441 I ($L($G(PSGAT),"-")=PSGS0XT/1440)!($G(X)]""&($G(PSGSCH)=$G(X))) S PSGS0Y=$G(PSGAT)
+Q2 K YY
+ I '$G(PSJNSS),'$G(PSGS0Y),$G(YY) S PSGS0Y=YY
+ I $G(X)]"",$$SCHREQ^PSJLIVFD(.P) D
+ .I $$DOW^PSIVUTL(X)!$$PRNOK(X)!$D(^PS(51.1,"AC","PSJ",X)) S PSJNSS=0 Q
+ .I $G(P(2))&$G(P(3)) D NSSCONT(X,PSGS0XT) S TMPX="" K X
+ I ($G(PSJNSS)&($G(VALMBCK)'="Q"))!($G(PSJNSS)&$G(PSJLIFNI))!($G(PSJNSS)&$G(PSJTUD)) D
+ .I $G(P(2))&$G(P(3)) Q
+ .I ($G(X)]"") I ($G(PSGS0XT)'="D") D NSSCONT(X,PSGS0XT) S TMPX="" K X
+Q3 I $G(X)]"" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS
+ K QX,SDW,SWD,X0,XT,Z Q
+ ;
+NSSCONT(SCH,FREQ) ;
+ Q:SCH=""!($G(VALMBCK)]"")!$G(PSGMARSD)!$G(PSIVFN1)
+ I $G(PSGOES),'$G(NSFF) Q
+ N PSGS0XT,PSGSCH,DIR,X,Y S PSGSCH=SCH,PSGS0XT=FREQ,PSJNSS=1
+ D NSSMSG I ($L(PSJNSS)>2),'$G(PSJXI) W !!,PSJNSS,! S PSJNSS=1
+ S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR
+ K NSFF Q
+ ;
+NSSMSG ;
+ Q:$G(PSJXI)
+ I '(",O,"[(","_$G(PSGST)_",")),$G(PSJNSS),$G(PSGSCH)]"" D
+ .S PSJNSS=" WARNING - "_PSGSCH_" is an invalid schedule."
+ S PSGSCH="",PSGS0XT=""
+ Q
+ ;
+NSO(FQ) ;
+ Q:'FQ!(FQ<0)!(",D,O,"[(","_$G(PSGST)_",")) ""
+ K FRQOUT S FRQOUT=$S(FQ<60:(FQ_"minute"),(FQ<1440)&(FQ#60):(FQ_" minute"),(FQ<1440)!(FQ#1440):(FQ/60_" hour"),1:(FQ/1440_" day")) D
+ . S:(+FRQOUT'=1) FRQOUT=FRQOUT_"s"
+ Q FRQOUT
+ ;
+ENCHK ;
+ I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q
+ S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q
+ S X(1)=$L(X(1)) I X'["-"&((X>$E(2400,1,X(1))!($E(X,3,4)>59))) K X Q
+ F X(2)=2:1:$L(X,"-") S X(3)=$P(X,"-",X(2)) I $S($L(X(3))'=X(1):1,X(3)>$E(2400,1,X(1)):1,$E(X(3),3,4)>59:1,1:X(3)'>$P(X,"-",X(2)-1)) K X Q
+ K:$D(X) X(1),X(2),X(3) Q
+ ;
+DIC ;
+ K Y0,PSJXI N Y
+ S Z=0 F PSJXI=0:1 S Z=$O(^PS(51.1,"AC","PSJ",X,Z)) Q:'Z
+ I $G(X)]"",'$G(PSJSLUP) D
+ .I $D(^PS(51.1,"AC","PSJ",X)) D  Q:$G(PSGS0Y)&($G(PSGS0XT)]"")
+ ..I $$DOW^PSIVUTL(X) S PSGS0XT="D",PSJNSS=0 S:X["@" (Y0,PSGS0Y)=$P(X,"@",2) Q
+ ..I $G(NSFF) S Y0=$S($G(PSGS0Y):PSGS0Y,$G(PSGAT)&'$G(PSJNEWOE):PSGAT,1:"") S:Y0 PSGS0Y=Y0
+ .; Check for duplicate schedules - force selection
+ .Q:PSJXI>1&('$G(PSGOES))&($G(PSGS0XT)]"")
+ .I $D(^PS(51.1,"AC","PSJ",X)) N FREQ,ADMATCH S FREQ=PSGS0XT D
+ ..N PSGS0XT,PSGS0Y,PSGST D ADMIN^PSJORPOE S:$G(PSGS0XT) XT=PSGS0XT S:$G(PSGS0Y) (Y0,Y)=PSGS0Y
+ .S:$G(XT)]"" PSGS0XT=XT S:$G(Y) PSGS0Y=Y
+ .I $$DOW^PSIVUTL(X) S:PSGS0XT="" (XT,PSGS0XT)="D" S:PSGS0Y="" (Y0,PSGS0Y)=$S($P(X,"@",2):$P(X,"@",2),1:"")
+ I $G(PSJLIFNI)!($G(P(4))]""&($G(P(2))]"")) I '$D(^PS(51.1,"AC","PSJ",X))!($G(PSJXI)>1) S PSJSLUP=1
+ I $G(NSFF),$G(PSJXI)>1 D
+ .I $G(PSGS0XT)="",$G(NSFF),$G(PSGXT)]"" S PSGS0XT=PSGXT Q
+ .I $G(PSGS0XT)=""!($G(PSGS0Y)="") S PSJSLUP=1
+ I '$G(PSJSLUP) Q:$G(PSGS0XT)]""&($G(PSGS0Y)]"")  Q:($G(PSGS0XT)="D"&('$D(^PS(51.1,"AC","PSJ",X))))
+ Q:$G(PSGOES)=2
+ Q:$G(PSGS0XT)]""&(PSJXI=1)
+ K PSJSLUP
+ ;
+ K DIC S DIC="^PS(51.1,",DIC(0)=$E("E",'$D(PSGOES))_"ISZ",DIC("W")="W ""  "","_$S('$D(PSJPWD):"$P(^(0),""^"",2)",'PSJPWD:"$P(^(0),""^"",2)",1:"$S($D(^PS(51.1,+Y,1,+PSJPWD,0)):$P(^(0),""^"",2),1:$P(^PS(51.1,+Y,0),""^"",2))"),D="APPSJ"
+ I $D(PSGST) ;S DIC("S")="I $P(^(0),""^"",5)"_$E("'",PSGST'="O")_"=""O"""
+ S PSJDIC2=1
+ D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE I Y'>0 D  Q
+ .I '$$DOW^PSIVUTL(X),'$$PRNOK(X) S X="",PSJNSS=1,XT="",PSJXI=""
+ S XT=$S("C"[$P(Y(0),"^",5):$P(Y(0),"^",3),1:$P(Y(0),"^",5))
+ S X=+Y,Y="" I $D(PSJPWD),$D(^PS(51.1,+X,1,+PSJPWD,0)) S Y=$P(^(0),"^",2)
+ S (X,X0)=Y(0,0) S:$G(Y)="" Y=$P(Y(0),"^",2)
+ S (PSGS0Y,Y0)=$G(Y),Y0(0)=Y(0) I $P(Y(0),"^",3) S XT=$P(Y(0),"^",3)
+ I $G(PSGS0XT)="",$$DOW^PSIVUTL(X) S (XT,PSGS0XT)="D"
+ Q
+ ;
+DW ;
+ N Y
+ Q:($L(X,"@")>2)
+ N AT I X["@" S AT=$P(X,"@",2)
+ S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2) N XABB S XABB=""
+ I X]"" D ENCHK Q:'$D(X)
+ S X=$P(SDW,"@"),X(1)="-" I X?.E1P.E,X'["-"  ;F QX=1:1:$L(X) I $E(X,QX)?1P S X(1)=$E(X,QX) Q
+ F Q=1:1:$L(X,X(1)) K:SWD="" X Q:SWD=""  S Z=$P(X,X(1),Q) D DWC Q:'$D(X)
+ I $D(X) F II=1:1:$L(X,X(1)) S XABB=$G(XABB)_$E($P(X,X(1),II),1,2)_"-"
+ K X(1) S:$D(X) X=SDW I $G(X)]"" I $TR(XABB,"-")]"" S X=$E($G(XABB),1,$L(XABB)-1)
+ I $G(AT) S PSGS0Y=AT
+ Q
+DWC I $L(Z)<2 K X Q
+ F QX=1:1:$L(SWD,"^") S Y=$P(SWD,"^",QX) I $P(Y,Z)="" S SWD=$P(SWD,Y,2) S:$L(SWD) SWD=$E(SWD,2,50) Q
+ E  K X
+ Q
+ ;
+PRNOK(PSCH) ;
+ Q:PSCH'["PRN" 0
+ I $TR(PSCH," ")="PRN" Q 1
+ N BASE,I,OK S OK=0 S I=$P(PSCH," PRN") I I]"",$D(^PS(51.1,"AC","PSJ",I)) S OK=1
+ I 'OK D
+ .I PSCH["@" I $D(^PS(51.1,"AC","PSJ",$P(PSCH,"@")))!$$DOW^PSIVUTL($P(PSCH,"@")) S OK=1 Q
+ .I $$DOW^PSIVUTL($P(PSCH," PRN")) S OK=1
+ Q OK
+ODD(PSF) ;determine if this is an odd schedule
+ I PSF>1439,PSF#1440 Q 1
+ I PSF,PSF<1440,1440#PSF Q 1
+ Q 0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m

@@ -1 @@
-PSGSICHK        ;BIR/CML3-CHECKS SPECIAL INSTRUCTIONS ;17 Aug 98 / 8:33 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,110,139,146,160,175,201,185**;16 DEC 97;Build 6
-        ;
-        ; Reference to ^PS(50.605 is supported by DBIA 696.
-        ; Reference to EN^PSOORDRG is supported by DBIA 2190.
-        ; Reference to ^PSI(58.1 is supported by DBIA 2284.
-        ; Reference to ^PSDRUG( is supported by DBIA 2192.
-        ; Reference to ^PSD(58.8 is supported by DBIA 2283.
-        ; Reference to ^PS(55 is supported by DBIA 2191.
-        ; Reference to ^PS(51.2 is supported by DBIA 2178.
-        ; Reference to ^PS(51 is supported by DBIA 2176.
-        ; Reference to ^ORRDI1 is supported by DBIA 4659.
-        ; Reference to ^XTMP("ORRDI" is supported by DBIA 4660.
-        ; Reference to GETDATA^GMRAOR supported by DBIA 4847.
-        ; Reference to ^TMP("GMRAOC" supported by DBIA 4848.
-        ;
-START   ;
-        I $S(X'?.ANP:1,X["^":1,1:$L(X)>180) K X Q
-        S Y="" F Y(1)=1:1:$L(X," ") S Y(2)=$P(X," ",Y(1)) I Y(2)]"" D CHK Q:'$D(X)
-        I $D(X),Y]"",X'=$E(Y,1,$L(Y)-1) D EN^DDIOL("EXPANDS TO: ") W Y F Y(1)=1:1 S Y(2)=$P(Y," ",Y(1)) Q:Y(2)=""  D:$L(Y(2))+$X>78 EN^DDIOL(Y(2)_" ")
-        Q
-        ;
-CHK     ;
-        I $L(Y(2))<31,$D(^PS(51,+$O(^PS(51,"B",Y(2),0)),0)),$P(^(0),"^",2)]"",$P(^(0),"^",4) S Y(2)=$P(^(0),"^",2)
-        I $L(Y)+$L(Y(2))>180 K X Q
-        S Y=Y_Y(2)_" " Q
-        ;
-ENSET(X)        ; expands the SPECIAL INSTRUCTIONS field contained in X into Y
-        N X1,X2,Y S Y=""
-        ;BHW;PSJ*5*185;Modified Logic below to NOT strip spaces and allow existing logic to flow.
-        ;             ;Removed code I X2]"" Before Set of Y and created argumentless DO structure.
-        F X1=1:1:$L(X," ") S X2=$P(X," ",X1) D
-        . I X2']"" S Y=Y_" " Q  ;if multiple spaces in text and were $P'ing through text, X2 will="" so just add space and continue
-        . S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" "
-        . Q
-        ;BHW;Modified stripping of spaces at end of string
-        F X1=$L(Y):-1:0 Q:$E(Y,X1,X1)'=" "  S Y=$E(Y,1,X1-1)
-        Q Y
-        ;
-END     ; used by DRUG (55.06,101 & 53.1,101) x-refs to warn user if patient is receiving or about to receive the drug just ordered
-        Q:$D(PSJHLSKP)
-        N Z,ZZ,STATUSNP I $G(PSJPWD)&($P($G(PSJSYSU),";")=3)&($G(PSGDRG)) I ($D(^PSI(58.1,"D",PSGDRG,PSJPWD)))!($D(^PSD(58.8,"D",PSGDRG,PSJPWD))) D EN^DDIOL("                         *** A WARD STOCK ITEM ***")
-        D NOW^%DTC
-        N PSJDCHK F Z=%:0 S Z=$O(^PS(55,+PSGP,5,"AUS",Z)) Q:'Z!$D(DUOUT)  F ZZ=0:0 S ZZ=$O(^PS(55,+PSGP,5,"AUS",Z,ZZ)) Q:'ZZ!$D(DUOUT)  I +$G(^PS(55,+PSGP,5,ZZ,.2))=PSGX D PDWCHK(+PSGP,ZZ_"U") S PSJDCHK=1
-        F STATUSNP="N","P" F Z=0:0 S Z=$O(^PS(53.1,"AS",STATUSNP,+PSGP,Z)) Q:'Z!$D(DUOUT)  I +$G(^PS(53.1,+Z,.2))=PSGX D PDWCHK(+PSGP,Z_"P") S PSJDCHK=1
-        I $D(PSJDCHK) N DIR D
-        .S DIR(0)="Y",DIR("A")="Do you wish to continue entering this order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,"
-        .S DIR("?")="or ""Y"" to continue with the order entry process." D ^DIR S:'Y Y=-1,X="^"
-        K Z,ZZ
-        Q
-        ;
-ENDDC(PSGP,PSJDD)       ; Perform Duplicate Drug, Duplicate Class,
-        ; Drug-Drug interaction check, Drug-Allergy interaction check.
-        N PSJLINE,Z,ZZ,PSJFST
-        S (PSJLINE,PSJFST)=0
-        I $G(PSJPWD)&($P($G(PSJSYSU),";")=3)&($G(PSJDD)) I ($D(^PSI(58.1,"D",PSJDD,PSJPWD)))!($D(^PSD(58.8,"D",PSJDD,PSJPWD))) W !?25,"*** A WARD STOCK ITEM ***"
-        D EN^PSOORDRG(PSGP,PSJDD) K PSJPDRG N INTERVEN,PSJIREQ,PSJRXREQ S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)="" S DFN=PSGP
-        I $T(HAVEHDR^ORRDI1)]"",$$HAVEHDR^ORRDI1,'$D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D
-        . I $P($G(^XTMP("ORRDI","PSOO",PSGP,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSJLMUT1
-        I $D(^TMP($J,"DD")) D ORDCHK^PSJLMUT1(PSGP,"DD",4)
-        I $D(^TMP($J,"DC")) D ORDCHK^PSJLMUT1(PSGP,"DC",6)
-IVSOL   ;*** Start order check for IV solution at this point.
-        I '$D(PSJFST) N PSJFST S PSJFST=0
-        I $D(^TMP($J,"DI")) S INTERVEN=1 D ORDCHK^PSJLMUT1(PSGP,"DI",8)
-        ;*** Allergy/adverse reaction check.
-        N PTR,X
-        S PTR=$P($G(^PSDRUG(PSJDD,"ND")),U)_"."_$P($G(^PSDRUG(PSJDD,"ND")),U,3)
-        K ^TMP("PSJDAI",$J) S PSJACK=$$ORCHK^GMRAOR(DFN,"DR",PTR) D:$G(PSJACK)=1
-        .S ^TMP("PSJDAI",$J,0)=1
-        .S I=0 F  S I=$O(GMRAING(I)) Q:'I  S ^TMP("PSJDAI",$J,I,0)=GMRAING(I)
-        I $D(^TMP("PSJDAI",$J)) S PSJPDRG=1 D
-        .W $C(7),!!,"A Drug-Allergy Reaction exists for this medication!",!!
-        .W !?7,"Drug: "_$P($G(^PSDRUG(PSJDD,0)),"^") I $O(^TMP("PSJDAI",$J)) W !,"Ingredients: " D
-        ..S I=0 F  S I=$O(^TMP("PSJDAI",$J,I)) Q:'I  W:$X+$L($G(^(I,0)))+2>IOM !?19 W:I=1 $G(^TMP("PSJDAI",$J,I,0)) W:I>1 ", ",$G(^TMP("PSJDAI",$J,I,0))
-        .W !!
-        K PSJACK,GMRAING,I,^TMP($J)
-        D ALGCLASS
-CONT    ; Ask user if they wish to continue in spite of an order check.
-        Q:'$D(PSJPDRG)  N DIR S DIR(0)="Y",DIR("A")="Do you wish to continue entering this order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,"
-        S DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")="NO" D ^DIR I 'Y S PSGORQF=1,X="^",COMQUIT=1 Q
-        I 'INTERVEN!($P(PSJSYSU,";")'=3) Q
-        NEW PSJY
-        W:PSJIREQ !!,"This is a CRITICAL interaction, you must enter an intervention log to continue"
-        S DIR(0)="Y",DIR("A")="Do you wish to log an intervention",DIR("?",1)="Enter ""N"" if you do not wish to log an intervention,",DIR("?")="or ""Y"" to log an intervention." D ^DIR S PSJY=Y D:Y ^PSJRXI
-        I 'PSJY,PSJIREQ S PSGORQF=1,COMQUIT=1
-        Q
-        ;
-ENDL    ; used by PSGTRAIN DRUG LOOK-UP option
-        D ENCV^PSGSETU Q:$D(XQUIT)
-        F  S DIC="^PSDRUG(",DIC(0)="AEIMOQZ",DIC("A")="Select DRUG: " W ! D ^DIC K DIC Q:+Y'>0  D SF
-        D ENKV^PSGSETU K N5,ND,Q,Y Q
-        ;
-SF      ;
-        S Y=+Y,ND=$G(^PSDRUG(Y,0)),PSGID=+$G(^("I")) I PSGID W !!,"THIS DRUG IS INACTIVE AS OF ",$E($$ENDTC^PSGMI(PSGID),1,8)
-        W !!,$S($P(ND,"^",9):"NON-",1:""),"FORMULARY ITEM" W:$P(ND,"^",10)]"" !,$P(ND,"^",10)
-        S ND=$P($G(^PSDRUG(Y,2)),"^",3)["U" W !,$P("NOT^","^",ND+1)," A UNIT DOSE DRUG" W ! S ND=$G(^(8)),N5=$G(^(8.5)) W !?2,"DAY (nD) or DOSE (nL) LIMIT: " I ND W $P(ND,"^")
-        W !?10,"UNIT DOSE MED ROUTE: " I $P(ND,"^",2) W $S($D(^PS(51.2,$P(ND,"^",2),0)):$P(^(0),"^"),1:$P(ND,"^",2))
-        ; NAKED REF below refers to ^PS(51.2, on line above.
-        W !?6,"UNIT DOSE SCHEDULE TYPE: " I $P(ND,"^",3)]"" W $P($P(";"_$P(^(0),"^",3),";"_$P(ND,"^",3)_":",2),";")
-        W !?11,"UNIT DOSE SCHEDULE: " I $P(ND,"^",4)]"" W $P(ND,"^",4)
-        W !,"CORRESPONDING OUTPATIENT DRUG: " I $P(ND,"^",5) W $S('$D(^PSDRUG(+$P(ND,"^",5),0)):$P(ND,"^",5),$P(^(0),"^")]"":$P(^(0),"^"),1:$P(ND,"^",5))
-        W !?17,"ATC MNEMONIC: " I $P(N5,"^",2)]"" W $P(N5,"^",2)
-        W !?17,"ATC CANISTER: " F Q=0:0 S Q=$O(^PSDRUG(Y,212,Q)) Q:'Q  S ND=$G(^(Q,0)) I ND,$P(ND,"^",2) W ?31,$S('$D(^PS(57.5,+ND,0)):+ND_";PS(57.5,",$P(^(0),"^")]"":$P(^(0),"^"),1:+ND_";PS(57.5,"),?56,$P(ND,"^",2),!
-        Q
-        ;
-OCHK    ; Add drugs in current order to ^TMP("ORDERS" and call order checker.
-        ; Set PSJOCHK=1 so OP order check doesn't Kill array.
-        ;
-        K ^TMP($J,"ORDERS")
-        N PSJOCHK S PSJOCHK=1
-PDWCHK(DFN,ON)  ; Print Dup Drug order.
-        N ND,ND0,ND2,X
-        W:'$D(PSJDCHK) $C(7),$C(7),!!,"WARNING! THIS PATIENT HAS THE FOLLOWING ORDER(S) FOR THIS MEDICATION:",!!
-        S ND=$$DRUGNAME^PSJLMUTL(DFN,ON)
-        S F=$S(ON["P":"^PS(53.1,",1:"^PS(55,"_DFN_",5,"),ND0=$G(@(F_+ON_",0)")),ND2=$G(^(2)),X=$P(ND,U,2),X=$S(X=.2:$P($G(^(.2)),U,2),1:$G(^(.3)))
-        W ?10,$P(ND,U),!,?13,"Give: ",X," ",$$ENMRN^PSGMI(+$P(ND0,U,3))," ",$P(ND2,U),!!
-        Q
-ALGCLASS        ; checks any Drug allergies or reactions to see if
-        ;         the new drug is the same class
-        ; this call can be removed by commenting out the call on IVSOL+16
-        N PSJLIST,CT,CLS,CLCHK,CNT,PSJL,LIST,DCCNT,PSCLASS,LEN
-        S PSCLASS=$P($G(^PSDRUG(PSJDD,0)),"^",2),LEN=4 I $E(PSCLASS,1,4)="CN10" S LEN=5 ;look at 5 chars if ANALGESICS
-        I $T(GETDATA^GMRAOR)]"" G ALGC2
-        S GMRA="0^0^111" D EN1^GMRADPT
-        F PSJLIST=0:0 S PSJLIST=$O(GMRAL(PSJLIST)) Q:'PSJLIST  D
-        .K PSJAGL D EN1^GMRAOR2(PSJLIST,"PSJAGL")
-        .; is the allergy/reaction drug class first four digits the same as the
-        .; the class for the drug being entered?
-        .S (CT,CLS)="",DCCNT=0
-        .I $D(PSJAGL("V")) D
-        ..F  S DCCNT=$O(PSJAGL("V",DCCNT)) Q:'DCCNT  S:$E($P($G(PSJAGL("V",DCCNT)),"^"),1,LEN)=$E(PSCLASS,1,LEN) (PSJPDRG,CLCHK)=1,CNT=$S('$D(CNT):1,1:CNT+1),LIST(CNT)=$P($G(PSJAGL),"^")_"^"_$P($G(PSJAGL("V",DCCNT)),"^",2)
-        D:$G(CLCHK)
-        .W !!,$C(7),"A Drug-Allergy Reaction exists for this medication and/or class!"
-        .F PSJL=0:0 S PSJL=$O(LIST(PSJL)) Q:'PSJL  D
-        ..W !?6,"Drug: "_$P(LIST(PSJL),"^"),!,"Drug Class: "_$P(LIST(PSJL),"^",2),!
-        Q
-ALGC2   ;
-        K GMRADRCL
-        D GETDATA^GMRAOR(DFN) Q:'$D(^TMP("GMRAOC",$J,"APC"))
-        N GMRACL,RET
-        S RET=0,GMRACL="" F  S GMRACL=$O(^TMP("GMRAOC",$J,"APC",GMRACL)) Q:'$L(GMRACL)  D
-        .N GMRANM,GMRALOC
-        .S GMRALOC=^TMP("GMRAOC",$J,"APC",GMRACL)
-        .S GMRANM=$P(^PS(50.605,+$O(^PS(50.605,"B",GMRACL,0)),0),U,2)
-        .S GMRADRCL(GMRACL)=GMRACL_U_GMRANM_" ("_GMRALOC_")"
-        .S RET=RET+1
-        Q:'RET  K ^TMP("GMRAOC",$J)
-        S CLCHK="",CT="" F  S CT=$O(GMRADRCL(CT)) Q:CT=""  D
-        .I $E(PSCLASS,1,LEN)=$E(CT,1,LEN) S CLCHK=$G(CLCHK)+1,^TMP($J,"PSJDRCLS",CLCHK)=CT_" "_$P(GMRADRCL(CT),"^",2)
-CLASSDSP        ;
-        I '$D(^TMP($J,"PSJDRCLS")) Q
-        W $C(7),!,"A Drug-Allergy Reaction exists for this medication and/or class!",!
-        W !,"Drug: "_$P($G(^PSDRUG(PSJDD,0)),"^")
-        S CT="" F  S CT=$O(^TMP($J,"PSJDRCLS",CT)) Q:CT=""  W !,"Drug Class: "_^TMP($J,"PSJDRCLS",CT)
-        K ^TMP($J,"PSJDRCLS")
-        S DIR("?",1)="Answer 'YES' if you DO want to enter a reaction for this medication,"
-        S DIR("?")="       'NO' if you DON'T want to enter a reaction for this medication,"
-        S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Intervene? ",DIR("B")="Y" W ! D ^DIR
-        I Y D ^PSJRXI
-        I '$G(Y) K DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y Q
-        Q
+PSGSICHK ;BIR/CML3-CHECKS SPECIAL INSTRUCTIONS ;17 Aug 98 / 8:33 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,110,139,146,160,175**;16 DEC 97;Build 18
+ ;
+ ; Reference to EN^PSOORDRG is supported by DBIA 2190.
+ ; Reference to ^PSI(58.1 is supported by DBIA 2284.
+ ; Reference to ^PSDRUG( is supported by DBIA 2192.
+ ; Reference to ^PSD(58.8 is supported by DBIA 2283.
+ ; Reference to ^PS(55 is supported by DBIA 2191.
+ ; Reference to ^PS(51.2 is supported by DBIA 2178.
+ ; Reference to ^PS(51 is supported by DBIA 2176.
+ ; Reference to ^ORRDI1 is supported by DBIA 4659.
+ ; Reference to ^XTMP("ORRDI" is supported by DBIA 4660.
+ ;
+START ;
+ I $S(X'?.ANP:1,X["^":1,1:$L(X)>180) K X Q
+ S Y="" F Y(1)=1:1:$L(X," ") S Y(2)=$P(X," ",Y(1)) I Y(2)]"" D CHK Q:'$D(X)
+ I $D(X),Y]"",X'=$E(Y,1,$L(Y)-1) D EN^DDIOL("EXPANDS TO: ") W Y F Y(1)=1:1 S Y(2)=$P(Y," ",Y(1)) Q:Y(2)=""  D:$L(Y(2))+$X>78 EN^DDIOL(Y(2)_" ")
+ Q
+ ;
+CHK ;
+ I $L(Y(2))<31,$D(^PS(51,+$O(^PS(51,"B",Y(2),0)),0)),$P(^(0),"^",2)]"",$P(^(0),"^",4) S Y(2)=$P(^(0),"^",2)
+ I $L(Y)+$L(Y(2))>180 K X Q
+ S Y=Y_Y(2)_" " Q
+ ;
+ENSET(X) ; expands the SPECIAL INSTRUCTIONS field contained in X into Y
+ N X1,X2,Y S Y=""
+ F X1=1:1:$L(X," ") S X2=$P(X," ",X1) I X2]"" S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" "
+ S Y=$E(Y,1,$L(Y)-1) Q Y
+ ;
+END ; used by DRUG (55.06,101 & 53.1,101) x-refs to warn user if patient is receiving or about to receive the drug just ordered
+ Q:$D(PSJHLSKP)
+ N Z,ZZ,STATUSNP I $G(PSJPWD)&($P($G(PSJSYSU),";")=3)&($G(PSGDRG)) I ($D(^PSI(58.1,"D",PSGDRG,PSJPWD)))!($D(^PSD(58.8,"D",PSGDRG,PSJPWD))) D EN^DDIOL("                         *** A WARD STOCK ITEM ***")
+ D NOW^%DTC
+ N PSJDCHK F Z=%:0 S Z=$O(^PS(55,+PSGP,5,"AUS",Z)) Q:'Z!$D(DUOUT)  F ZZ=0:0 S ZZ=$O(^PS(55,+PSGP,5,"AUS",Z,ZZ)) Q:'ZZ!$D(DUOUT)  I +$G(^PS(55,+PSGP,5,ZZ,.2))=PSGX D PDWCHK(+PSGP,ZZ_"U") S PSJDCHK=1
+ F STATUSNP="N","P" F Z=0:0 S Z=$O(^PS(53.1,"AS",STATUSNP,+PSGP,Z)) Q:'Z!$D(DUOUT)  I +$G(^PS(53.1,+Z,.2))=PSGX D PDWCHK(+PSGP,Z_"P") S PSJDCHK=1
+ I $D(PSJDCHK) N DIR D
+ .S DIR(0)="Y",DIR("A")="Do you wish to continue entering this order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,"
+ .S DIR("?")="or ""Y"" to continue with the order entry process." D ^DIR S:'Y Y=-1,X="^"
+ K Z,ZZ
+ Q
+ ;
+ENDDC(PSGP,PSJDD) ; Perform Duplicate Drug, Duplicate Class,
+ ; Drug-Drug interaction check, Drug-Allergy interaction check.
+ N PSJLINE,Z,ZZ,PSJFST
+ S (PSJLINE,PSJFST)=0
+ I $G(PSJPWD)&($P($G(PSJSYSU),";")=3)&($G(PSJDD)) I ($D(^PSI(58.1,"D",PSJDD,PSJPWD)))!($D(^PSD(58.8,"D",PSJDD,PSJPWD))) W !?25,"*** A WARD STOCK ITEM ***"
+ D EN^PSOORDRG(PSGP,PSJDD) K PSJPDRG N INTERVEN,PSJIREQ,PSJRXREQ S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)="" S DFN=PSGP
+ I $T(HAVEHDR^ORRDI1)]"",$$HAVEHDR^ORRDI1,'$D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D
+ . I $P($G(^XTMP("ORRDI","PSOO",PSGP,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSJLMUT1
+ K ^TMP($J,"DUPDRG")  ;DEM - Duplicate Drug Check Ehancement.
+ I $D(^TMP($J,"DD")) D ORDCHK^PSJLMUT1(PSGP,"DD",4)
+ I $D(^TMP($J,"DC")) D ORDCHK^PSJLMUT1(PSGP,"DC",6)
+IVSOL ;*** Start order check for IV solution at this point.
+ I '$D(PSJFST) N PSJFST S PSJFST=0
+ I $D(^TMP($J,"DI")) S INTERVEN=1 D ORDCHK^PSJLMUT1(PSGP,"DI",8)
+ D DUPDRG^PSJLMUT2(PSGP) K ^TMP($J,"DUPDRG")  ;DEM - Duplicate Drug Check Ehancement.
+ ;*** Allergy/adverse reaction check.
+ N PTR,X
+ S PTR=$P($G(^PSDRUG(PSJDD,"ND")),U)_"."_$P($G(^PSDRUG(PSJDD,"ND")),U,3)
+ K ^TMP("PSJDAI",$J) S PSJACK=$$ORCHK^GMRAOR(DFN,"DR",PTR) D:$G(PSJACK)=1
+ .S ^TMP("PSJDAI",$J,0)=1
+ .S I=0 F  S I=$O(GMRAING(I)) Q:'I  S ^TMP("PSJDAI",$J,I,0)=GMRAING(I)
+ I $D(^TMP("PSJDAI",$J)) S PSJPDRG=1 D
+ .W $C(7),!!,"A Drug-Allergy Reaction exists for this medication!",!!
+ .W !?7,"Drug: "_$P($G(^PSDRUG(PSJDD,0)),"^") I $O(^TMP("PSJDAI",$J)) W !,"Ingredients: " D
+ ..S I=0 F  S I=$O(^TMP("PSJDAI",$J,I)) Q:'I  W:$X+$L($G(^(I,0)))+2>IOM !?19 W:I=1 $G(^TMP("PSJDAI",$J,I,0)) W:I>1 ", ",$G(^TMP("PSJDAI",$J,I,0))
+ .W !!
+ K PSJACK,GMRAING,I,^TMP($J)
+ D ALGCLASS^PSGSICH1
+CONT ; Ask user if they wish to continue in spite of an order check.
+ ;Variable PSJDDCON is the order continuation flag for Duplicate Drug Check Enhancement.
+ I $D(PSJDDCON("DD")),'PSJDDCON("DD") Q
+ I '$D(PSJDDCON("DD")) Q:'$D(PSJPDRG)  N DIR D  I 'Y S PSGORQF=1,X="^",COMQUIT=1 K PSJDDCON Q
+ . S DIR(0)="Y",DIR("A")=$S($G(PSJDDCON("DI")):"Do you wish to continue with the current order",1:"Do you wish to continue entering this order")
+ . S DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,",DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")=$S($G(PSJDDCON("DI")):"YES",1:"NO")
+ . D ^DIR
+ . Q
+ ;
+ K PSJDDCON  ;Order continuation flag for Duplicate Drug Check Enhancement.
+ I 'INTERVEN!($P(PSJSYSU,";")'=3) Q
+ N PSJY
+ W:PSJIREQ !!,"This is a CRITICAL interaction, you must enter an intervention log to continue"
+ S DIR(0)="Y",DIR("A")="Do you wish to log an intervention",DIR("?",1)="Enter ""N"" if you do not wish to log an intervention,",DIR("?")="or ""Y"" to log an intervention." D ^DIR S PSJY=Y D:Y ^PSJRXI
+ I 'PSJY,PSJIREQ S PSGORQF=1,COMQUIT=1
+ Q
+ ;
+ENDL ; used by PSGTRAIN DRUG LOOK-UP option
+ D ENCV^PSGSETU Q:$D(XQUIT)
+ F  S DIC="^PSDRUG(",DIC(0)="AEIMOQZ",DIC("A")="Select DRUG: " W ! D ^DIC K DIC Q:+Y'>0  D SF
+ D ENKV^PSGSETU K N5,ND,Q,Y
+ Q
+ ;
+SF ;
+ N PSGID
+ S Y=+Y,ND=$G(^PSDRUG(Y,0)),PSGID=+$G(^("I")) I PSGID W !!,"THIS DRUG IS INACTIVE AS OF ",$E($$ENDTC^PSGMI(PSGID),1,8)
+ W !!,$S($P(ND,"^",9):"NON-",1:""),"FORMULARY ITEM" W:$P(ND,"^",10)]"" !,$P(ND,"^",10)
+ S ND=$P($G(^PSDRUG(Y,2)),"^",3)["U" W !,$P("NOT^","^",ND+1)," A UNIT DOSE DRUG" W ! S ND=$G(^(8)),N5=$G(^(8.5)) W !?2,"DAY (nD) or DOSE (nL) LIMIT: " I ND W $P(ND,"^")
+ W !?10,"UNIT DOSE MED ROUTE: " I $P(ND,"^",2) W $S($D(^PS(51.2,$P(ND,"^",2),0)):$P(^(0),"^"),1:$P(ND,"^",2))
+ ; NAKED REF below refers to ^PS(51.2, on line above.
+ W !?6,"UNIT DOSE SCHEDULE TYPE: " I $P(ND,"^",3)]"" W $P($P(";"_$P(^(0),"^",3),";"_$P(ND,"^",3)_":",2),";")
+ W !?11,"UNIT DOSE SCHEDULE: " I $P(ND,"^",4)]"" W $P(ND,"^",4)
+ W !,"CORRESPONDING OUTPATIENT DRUG: " I $P(ND,"^",5) W $S('$D(^PSDRUG(+$P(ND,"^",5),0)):$P(ND,"^",5),$P(^(0),"^")]"":$P(^(0),"^"),1:$P(ND,"^",5))
+ W !?17,"ATC MNEMONIC: " I $P(N5,"^",2)]"" W $P(N5,"^",2)
+ W !?17,"ATC CANISTER: " F Q=0:0 S Q=$O(^PSDRUG(Y,212,Q)) Q:'Q  S ND=$G(^(Q,0)) I ND,$P(ND,"^",2) W ?31,$S('$D(^PS(57.5,+ND,0)):+ND_";PS(57.5,",$P(^(0),"^")]"":$P(^(0),"^"),1:+ND_";PS(57.5,"),?56,$P(ND,"^",2),!
+ Q
+ ;
+OCHK ; Add drugs in current order to ^TMP("ORDERS" and call order checker.
+ ; Set PSJOCHK=1 so OP order check doesn't Kill array.
+ ;
+ K ^TMP($J,"ORDERS")
+ N PSJOCHK S PSJOCHK=1
+PDWCHK(DFN,ON) ; Print Dup Drug order.
+ N ND,ND0,ND2,X
+ W:'$D(PSJDCHK) $C(7),$C(7),!!,"WARNING! THIS PATIENT HAS THE FOLLOWING ORDER(S) FOR THIS MEDICATION:",!!
+ S ND=$$DRUGNAME^PSJLMUTL(DFN,ON)
+ S F=$S(ON["P":"^PS(53.1,",1:"^PS(55,"_DFN_",5,"),ND0=$G(@(F_+ON_",0)")),ND2=$G(^(2)),X=$P(ND,U,2),X=$S(X=.2:$P($G(^(.2)),U,2),1:$G(^(.3)))
+ W ?10,$P(ND,U),!,?13,"Give: ",X," ",$$ENMRN^PSGMI(+$P(ND0,U,3))," ",$P(ND2,U),!!
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m

@@ -1 @@
-PSGXR3 ; DRIVER FOR COMPILED XREFS FOR FILE #53.1 ; 11/08/09
+PSGXR3 ; DRIVER FOR COMPILED XREFS FOR FILE #53.1 ; 01/17/08
  ; 
  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/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m

@@ -1 @@
-PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 11/08/09
+PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 01/17/08
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m

@@ -1 @@
-PSGXR310 ; COMPILED XREF FOR FILE #53.1114 ; 11/08/09
+PSGXR310 ; COMPILED XREF FOR FILE #53.1114 ; 01/17/08
  ; 
  S DA=0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m

@@ -1 @@
-PSGXR311 ; COMPILED XREF FOR FILE #53.157 ; 11/08/09
+PSGXR311 ; COMPILED XREF FOR FILE #53.157 ; 01/17/08
  ; 
  S DA=0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m

@@ -1 @@
-PSGXR312 ; COMPILED XREF FOR FILE #53.158 ; 11/08/09
+PSGXR312 ; COMPILED XREF FOR FILE #53.158 ; 01/17/08
  ; 
  S DA=0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m

@@ -1 @@
-PSGXR32 ; COMPILED XREF FOR FILE #53.11 ; 11/08/09
+PSGXR32 ; COMPILED XREF FOR FILE #53.11 ; 01/17/08
  ; 
  S DA(1)=DA S DA=0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m

@@ -1 @@
-PSGXR33 ; COMPILED XREF FOR FILE #53.1112 ; 11/08/09
+PSGXR33 ; COMPILED XREF FOR FILE #53.1112 ; 01/17/08
  ; 
  S DA=0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m

@@ -1 @@
-PSGXR34 ; COMPILED XREF FOR FILE #53.1114 ; 11/08/09
+PSGXR34 ; COMPILED XREF FOR FILE #53.1114 ; 01/17/08
  ; 
  S DA=0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m

@@ -1 @@
-PSGXR35 ; COMPILED XREF FOR FILE #53.157 ; 11/08/09
+PSGXR35 ; COMPILED XREF FOR FILE #53.157 ; 01/17/08
  ; 
  S DA=0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m

@@ -1 @@
-PSGXR36 ; COMPILED XREF FOR FILE #53.158 ; 11/08/09
+PSGXR36 ; COMPILED XREF FOR FILE #53.158 ; 01/17/08
  ; 
  S DA=0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m

@@ -1 @@
-PSGXR37 ; COMPILED XREF FOR FILE #53.1 ; 11/08/09
+PSGXR37 ; COMPILED XREF FOR FILE #53.1 ; 01/17/08
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m

@@ -1 @@
-PSGXR38 ; COMPILED XREF FOR FILE #53.11 ; 11/08/09
+PSGXR38 ; COMPILED XREF FOR FILE #53.11 ; 01/17/08
  ; 
  S DA(1)=DA S DA=0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m

@@ -1 @@
-PSGXR39 ; COMPILED XREF FOR FILE #53.1112 ; 11/08/09
+PSGXR39 ; COMPILED XREF FOR FILE #53.1112 ; 01/17/08
  ; 
  S DA=0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVCAL.m

@@ -1 @@
-PSIVCAL ;BIR/RGY,PR-CALCULATES START AND STOP DATES ;12 Mar 99 / 12:42 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**4,26,41,47,63,67,69,58,94,80,110,111,177,120,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(50.7 is supported by DBIA #2180.
-        ; Reference to ^PS(52.6 is supported by DBIA #1231.
-        ; Reference to ^PS(55 is supported by DBIA #2191.
-        ;
-ENT     ;NEEDS PSIVTYPE (P(4))
-        I $G(PSJREN) D  Q:P(2)
-        . I $G(P("OLDON")) N P2 S P2=$G(@("^PS(55,"_DFN_",""IV"","_+P("OLDON")_",0)")),P2=$P(P2,"^",2) I P2 S P(2)=P2
-        I $G(PSJORD)["P",$G(P("APPT"))?7N1"."1.N S START=$$DATE2^PSJUTL2(P("APPT")) G Q
-        I $G(PSJSYSW0)=""!($P(PSJSYSW0,U,5)=2) S START=+$E(P("LOG"),1,12) G Q
-        S PSIVSN=+P("IVRM"),START="",PSIVTYPE=$G(P(4)) Q:PSIVTYPE=""
-        N PSIV X $S($E(PSIVAC)="C":"S X=+$E(P(""LOG""),1,12) D H^%DTC S PSIV=%T",1:"S PSIV=$P($H,"","",2)") G T2:PSIVTYPE'["P"&('P(5))
-        I P(11)']"" X $S($E(PSIVAC)="C":"S Y=+$E(P(""LOG""),1,12)",1:"D NOW^%DTC S Y=%") S Y=Y+.007\.01/100 S:'$P(Y,".",2) Y=$$MDNGHT(Y) X ^DD("DD") S START=Y G Q
-        S X=P(11) D CHK S PX=Y,X1=PSIV\3600,X2=PSIV#3600\60,X=$E(".0",1,$L(X1)#2+1)_X1_$E("0",X2<10)_X2,START=$S($E(PSIVAC)="C":$P(P("LOG"),"."),1:"T")
-        S X1=$P(PX,"-"),X1=$E(".0",1,$L(X1)#2+1)_X1,X2=$P(PX,"-",PSGCNT),X2=$E(".0",1,$L(X2)#2+1)_X2
-        S NAT=+$P($G(^PS(59.6,+$O(^PS(59.6,"B",+VAIN(4),0)),0)),U,5)
-        I '$D(PSGDT) S PSGDT=$$DATE^PSJUTL2()
-        I X<X1,'NAT S START=$$ENSD^PSGNE3(P(9),P(11),+$E(P("LOG"),1,12),PSGDT) G Q
-        I X>X2 S START=$$ENSD^PSGNE3(P(9),P(11),+$E(P("LOG"),1,12),PSGDT) G Q
-T6      F I=2:1:PSGCNT S X1="."_$P(PX,"-",I-1),X2="."_$P(PX,"-",I) Q:+X1<X&(+X2>X)
-        S X1=X-X1,X2=$S(NAT:0,1:X2-X),START=$S(X1<X2:$P(PX,"-",I-1),1:$P(PX,"-",I)) S:START="" START=$P(PX,"-") X $S($E(PSIVAC)="C":"S Y=$P(P(""LOG""),""."") X ^DD(""DD"") S PSIV=Y",1:"S PSIV=""TODAY""") S START=PSIV_"@"_$E("0",$L(START)=3)_START G Q
-T2      S X=+("."_$E(10000+(PSIV\3600*100)+(PSIV#3600\60),2,5)),START=$O(^PS(59.5,PSIVSN,3,"AT",X)) S:'START START=$O(^(0)),PSIVTOM=1 I 'START S START=X K PSIVTOM
-        S START=$S($E(PSIVAC)="C":$P(P("LOG"),"."),1:DT)_START I $D(PSIVTOM) S X1=$S($E(PSIVAC)="C":$P(P("LOG"),"."),1:DT),X2=1 D C^%DTC S Y=$P(X,".")_START K PSIVTOM
-        S X=START,%DT="XRTX" D ^%DT
-Q       ;
-        I START["@" S X=START,%DT="RTX" D ^%DT S START=+Y
-        S P(2)=START
-        I $G(PSJORD)["P" D:'$G(PSGRDTX(+PSJORD,"PSGSD")) REQDT^PSJLIVMD(PSJORD) S START=$G(PSGRDTX(+PSJORD,"PSGSD")) S P(2)=$S(START:START,1:P(2))
-        K NAT,START,PSIVTYPE,PSIVSTRT,PSGCNT,X1,X2,PX
-        Q
-CHK     F Y=1:1 Q:$L(X)>240!($P(X,"-",Y)="")  S $P(X,"-",Y)=$P(X,"-",Y)_$E("0000",1,4-$L($P(X,"-",Y)))
-        S Y=X,PSGCNT=$L(X,"-") S:X]""&(PSGCNT<1) PSGCNT=1 Q
-        ;
-ENSTOP  ; WILL CALCULATE STOP DATE FOR ORDER
-        ;NEEDS (DFN) & ON
-        N WALL,P3,ADX,DDLX,OIX,DRGT,PSIDAY,PSIMIN,LIMDAY S (WALL,P3,PSIDAY,PSIMIN)=0
-        D:'$G(PSIVSITE) ^PSIVSET  Q:'P(2)
-        I P(23)'="" S PSIVTYPE="C"
-        S STOP="",X="",PSIVSTRT=P(2),PSIVTYPE=$G(P(4)) I $G(PSJREN) D
-        . N RDT I $G(ON)["P" S RDT=+$$LASTREN^PSJLMPRI(DFN,ON)
-        . S PSIVSTRT=$$DATE2^PSJUTL2($S($G(RDT):RDT,1:$G(PSGDT)))
-        ;BHW - PSJ*5*177 - Begin Modifications - Reset Start date to Last Renewed date for active orders that have been renewed
-        I ('$G(PSJREN))&($G(P(4))="A")&($G(ON)["V") D
-        . N RDT S RDT=+$$LASTREN^PSJLMPRI(DFN,ON)
-        . I +RDT S PSIVSTRT=RDT
-        . Q
-        ;BHW - PSJ*5*177 - End Modifications - Resetting PSIVSTRT will recalculate the stop date based on the Last renewed date.
-        ;
-        I $S("^NOW^STAT^ONCE^ONE-TIME^ONE TIME^ONETIME^1TIME^1-TIME^1 TIME^"[(U_P(9)_U):1,1:0),PSIVTYPE="P"!P(5)!(P(23)="P") S X=$$ENOSD^PSJDCU(PSJSYSW0,PSIVSTRT,DFN) I X]"" S:P(11)=""&($G(ON)["P") PSIVCAL=1 G END
-        I '$G(P("OVRIDE")),$G(ON) N DUR,DURMIN,PSJPROV,PSJDNM,A,PSJDAY I $G(ON)["V"!(($G(ON)["P")&($P($G(^PS(53.1,+ON,0)),"^",4)="F")) D
-        . S DUR=$$GETDUR^PSJLIVMD(DFN,+ON,"IV",1) I DUR]"" S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN S PSIMIN=DURMIN
-        I $P(PSIVSITE,"^",5) D
-        . N Z S Y=0
-        . F  S Y=$O(^PS(55,DFN,"IV",Y)) Q:'Y  S Z=^(Y,0) D  Q:X]""
-        .. I $P(Z,"^",17)="A",$$ONE^PSJBCMA(DFN,Y_"V",$P(Z,"^",9))'="O" S X=$P(Z,"^",3) Q
-        S:$G(X) WALL=X
-        S PSIDAY=$S(PSIVTYPE="A":$P(PSIVSITE,"^",4),PSIVTYPE="H":$P(PSIVSITE,"^",17),PSIVTYPE="P":$P(PSIVSITE,"^",18),PSIVTYPE="S":$P(PSIVSITE,"^",20),1:$P(PSIVSITE,"^",21))
-        I $G(ON)["P"!($G(ON)["V") I '$G(P("OVRIDE")) N MINS,LIM S PSIVLIM=$$GETLIM(DFN,ON) I $G(PSIVLIM)]"" S MINS=$$GETMIN(PSIVLIM,DFN,ON,.LIMDAY) D
-        .I (MINS&(MINS<PSIMIN))!'PSIMIN S PSIMIN=MINS
-        S PSJDAY="" D  I PSJDAY]"",PSJDAY<PSIDAY S PSIDAY=PSJDAY
-        . N A,B,PSJCLIN
-        . Q:'$D(PSJORD)  S A=""
-        . I PSJORD["P" S A=$G(^PS(53.1,+PSJORD,"DSS"))
-        . I PSJORD["U" S A=$G(^PS(55,PSGP,5,+PSJORD,8))
-        . I PSJORD["V" S A=$G(^PS(55,PSGP,"IV",+PSJORD,"DSS"))
-        . S (PSJCLIN,A)=$P(A,"^") Q:A=""  S PSJCLIN=$P(^SC(PSJCLIN,0),"^") I $D(^PS(53.46,"B",A)) S B=$O(^PS(53.46,"B",A,"")),PSJDAY=$P(^PS(53.46,B,0),"^",2)
-        F X=0:0 S X=$O(DRG("AD",X)) Q:'X  I $P(^PS(52.6,+$P(DRG("AD",+X),U),0),"^",4),($P(^(0),"^",4))<+PSIDAY S PSIDAY=$P(^(0),"^",4)
-        I WALL,($$FMADD^XLFDT(PSIVSTRT,PSIDAY,"D"))>WALL S PSIDAY=$$FMDIFF^XLFDT(WALL,PSIVSTRT,1) S:PSIDAY<1 PSIDAY=""
-        S DRGT=$S($D(DRG("AD")):"AD",1:"SOL") F ADX=0:0 S ADX=$O(DRG(DRGT,ADX)) Q:'ADX!($G(DRGTMP)&($G(DRGTN)["AD")&(DRGT="SOL"))  D
-        . S OIX=+$P(DRG(DRGT,ADX),"^",6),DDLX=$P(^PS(50.7,OIX,0),"^",5) Q:'DDLX  D DDLIM(.PSIDAY,.P3)
-        I '$G(DRG("AD",0)),$G(DRGTMP),($G(DRGTN)["SOL") S OIX=$P($G(DRGTMP),"^",6) I OIX S DDLX=$P(^PS(50.7,OIX,0),"^",5) I DDLX  D DDLIM(.PSIDAY,.P3)
-        I $G(PSIVLIM)["a",'$G(P("OVRIDE")) S DDLX=$P(PSIVLIM,"a",2)_"L" I $G(DDLX) D DDLIM(.PSIDAY,.P3)
-        I $G(P(2)) I P3>P(2) S X=P3
-        S:('PSIDAY&'PSIMIN) PSIDAY=1
-TIME    S X2=PSIDAY,X1=PSIVSTRT D C^%DTC S X=$P(X,"."),X=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14))
-        I PSIMIN D
-        . I $G(PSIDAY),((PSIDAY*1440)<PSIMIN) K PSIVLIM,P("LIMIT") S P("OVRIDE")=1 Q
-        . I (PSIMIN<(PSIDAY*1440)!'$G(PSIDAY)) S X=$$FMADD^XLFDT(PSIVSTRT,,,PSIMIN) D
-        .. I '(PSIMIN#1440) S X=$P(X,"."),X=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14))
-END     ;
-        S P(3)=+X
-        I $G(PSJORD)["P" D:'$G(PSGRDTX(+PSJORD,"PSGFD")) REQDT^PSJLIVMD(PSJORD) S P(3)=$S($G(PSGRDTX(+PSJORD,"PSGFD")):PSGRDTX(+PSJORD,"PSGFD"),1:P(3))
-        S P(3)=$$DATE2^PSJUTL2(P(3)),P(2)=$$DATE2^PSJUTL2(P(2))
-        Q
-        ;
-ENAD    ;Will get last admin. time for order (needs dfn and on)
-        N P4,PSIVX,PSIVY
-        I $P(PSJSYSW0,U,5)=2 S PSIVADM=$$DATE^PSJUTL2() Q
-        I $S($G(PSIVAC)["R":1,P(9)="QOD":1,1:P(9)?1"Q".N1"D") S PSIVADM=$$ENSD^PSGNE3(P(9),P(11),+$E(P("LOG"),1,12),+$P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,2)) Q:PSIVADM
-        S PSIVX=X,PSIVY=Y,P4=P(4) S:P(4)="C" P4=P(23) S:P4="S" P4=$S(P(5):"P",1:"A") D NOW^%DTC S Y=%,PSIVNOW=Y I (P4="P"&(P(11)="")&'P(15))!("HA"[P4&'P(15)) S Y=Y+.007\.01/100 G QAD
-        D P:P4="P"&('P(15)),AH:P(15)
-QAD     ;
-        S:'$D(PSGSA) PSGSA=""
-        S PSIVSD=Y I Y S OD=$L(PSGSA," ") I OD>2 S X=+PSGSA\1 F OD1=2:1:OD-1 I $P(PSGSA," ",OD1)'>$S(OD1>2:$P(PSGSA," ",OD1-1),1:PSGSA#1) S X1=X,X2=1 D C^%DTC
-        I PSIVSD,OD>2 S Y=X_PSIVSD
-        S PSIVADM=+Y,X=PSIVX,Y=PSIVY K PSGSA,PSIVSD,OD,OD1,PSIVMI,PSIVNOW S:PSIVADM<P(2) PSIVADM=P(2) Q
-        ;
-P       S CD=PSIVNOW,PSGSA="",(PSIVSD,OD)=DT_.0001,X=P(11) D CHK S P(11)=X D ENP4^PSIVWL
-        I PSGSA="" S PSIVSD=DT_.0001,PSIVMIN=-1440 D ENT^PSIVWL S $P(Y,".",2)=$P(P(11),"-",$L(P(11),"-")) Q
-        S Y=$P(PSGSA," ",$L(PSGSA," ")-1) Q
-AH      F PSIVADM=0:-1 S CD=PSIVNOW,(X,X1)=DT,X2=PSIVADM D:X2 C^%DTC S X=$P(X,".") S (OD1,PSIVSD,OD)=X_.0001,PSIVMIN=P(15) D ENP3^PSIVWL Q:PSIVADM<-4!(PSGSA]"")
-        S Y=$P(PSGSA," ",$L(PSGSA," ")-1) Q
-MDNGHT(Y)                ;Sets Start Date/Time on orders placed between midnight and 12:30
-        S Y=$$FMADD^XLFDT(Y,-1,0,0,0),Y=$P(Y,".")_".24" Q Y
-        ;
-DDLIM(PSIVDUR,STPDT)    ;  Day Dose Limit
-        N P3,NEWDAYS,NEWDUR
-        I DDLX["D" D  Q:(STPDT=0)
-        .I +DDLX'<+PSIVDUR S STPDT=0 Q
-        .S PSIVDUR=+DDLX,X2=PSIVDUR,X1=PSIVSTRT D C^%DTC S X=$P(X,"."),X=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14)) I X>P(2) S P(3)=X
-        I DDLX["L",($G(P(9))]""),("AH"'[$G(PSIVTYPE)) S LASTD=$$DOSES(DDLX,.P) I LASTD D
-        .S NEWDUR=$$FMDIFF^XLFDT(LASTD,P(2),2) I NEWDUR>0 S NEWDAYS=(NEWDUR/86400)
-        .I $G(NEWDAYS) I NEWDAYS<PSIVDUR S PSIVDUR=NEWDAYS S P(3)=$$DATE2^PSJUTL2(LASTD)
-        S P(3)=$$DATE2^PSJUTL2(P(3)),P(2)=$$DATE2^PSJUTL2(P(2)) S STPDT=P(3)
-        Q
-        ;
-GETLIM(DFN,PSJORD)      ; Convert IV Limits to minutes (only if in 'time' form).
-        N ND2P5,F
-        S F=$S(PSJORD["P":"^PS(53.1,+PSJORD,",PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD,",1:"")
-        S ND2P5=$G(@(F_"2.5)")) S LIM=$P(ND2P5,"^",4) Q:LIM="" 0
-        S ND0=$G(@(F_"0)")) I PSJORD["P",$P(ND0,"^",4)="U" Q 0
-        N MULT S MULT=$S($E(LIM)="h":60,$E(LIM)="d":1440,$E(LIM)="m":LIM,$E(LIM)="l":LIM,$E(LIM)="a":LIM,1:0) I MULT S LIM=MULT*$E(LIM,2,99)
-        Q LIM
-        ;
-GETMIN(LIM,DFN,PSJORD,DAYS)     ; Return the duration of the IV Limit in minutes (includes IV Limits in volume and doses format) 
-        S LIM=$$GETMIN^PSIVUTL1(LIM,DFN,PSJORD,.DAYS)
-        Q LIM
-DOSES(DDLX,PRAY)        ; Find stop date when 'doses' are sent as an IV Limit
-        Q:$G(DDLX)'["L" ""
-        I $P(DDLX,"L")["." S DDLX=($P(DDLX,".")+1)_"L"
-        I '$G(PRAY(15)),$G(PRAY(11)) S PRAY(15)=1440/$L(PRAY(11),"-")
-        Q:'$G(PRAY(2))!'$G(OIX) ""
-        N FIRST,DOSAR,LAST,TMP9 S LAST="",TMP9=PRAY(9)
-        S STRING=PRAY(2)_"^"_$S($G(STPDT):STPDT,1:$$FMADD^XLFDT(PSGDT,30))_"^"_PRAY(9)_"^C^"_OIX S FIRST=$$ENQ^PSJORP2(DFN,STRING)
-        S P(9)=TMP9
-        S FIRST=$S($G(FIRST):FIRST,1:PRAY(2)) Q:'FIRST  S DSTMP=FIRST,DOSAR(1)=DSTMP D
-        .I '$G(PRAY(11)) F I=2:1:DDLX+1 S DOSAR(I)=$$FMADD^XLFDT(DSTMP,,,PRAY(15)),DSTMP=DOSAR(I) Q
-        .I $G(PRAY(11)) N ADMS,NXT,LAST,DAY S LAST=$P(DSTMP,".",2),DAY=$P(DSTMP,".") D
-        ..F II=1:1:$L(PRAY(11),"-") S ADMS(+$P(PRAY(11),"-",II))=$P(PRAY(11),"-",II)
-        ..F IJ=2:1:DDLX+1 S NXT=$O(ADMS(+LAST)),LAST=NXT D
-        ...I NXT="" S NXT=$O(ADMS(NXT)),LAST=NXT,DAY=$$FMADD^XLFDT(DAY,1)
-        ...S DOSAR(IJ)=DAY_"."_ADMS(NXT),DSTMP=DOSAR(IJ)
-        ..I +DDLX=1 S NXT=$O(ADMS(LAST)),LAST=NXT D
-        ...I NXT="" S NXT=$O(ADMS(NXT)),LAST=NXT
-        I $D(DOSAR) S LAST=$O(DOSAR(""),-1) I LAST S LAST=DOSAR(LAST)
-        Q LAST
+PSIVCAL ;BIR/RGY,PR-CALCULATES START AND STOP DATES ;12 Mar 99 / 12:42 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**4,26,41,47,63,67,69,58,94,80,110,111,177,120**;16 DEC 97;Build 10
+ ;
+ ; Reference to ^PS(50.7 is supported by DBIA #2180.
+ ; Reference to ^PS(52.6 is supported by DBIA #1231.
+ ; Reference to ^PS(55 is supported by DBIA #2191.
+ ;
+ENT ;NEEDS PSIVTYPE (P(4))
+ I $G(PSJREN) D  Q:P(2)
+ . I $G(P("OLDON")) N P2 S P2=$G(@("^PS(55,"_DFN_",""IV"","_+P("OLDON")_",0)")),P2=$P(P2,"^",2) I P2 S P(2)=P2
+ I $G(PSJORD)["P",$G(P("APPT"))?7N1"."1.N S START=$$DATE2^PSJUTL2(P("APPT")) G Q
+ I $G(PSJSYSW0)=""!($P(PSJSYSW0,U,5)=2) S START=+$E(P("LOG"),1,12) G Q
+ ;I $G(P("RES"))="R" N PSIVAC S PSIVAC="PR" D ENAD I PSIVADM S P(2)=PSIVADM Q
+ S PSIVSN=+P("IVRM"),START="",PSIVTYPE=$G(P(4)) Q:PSIVTYPE=""
+ N PSIV X $S($E(PSIVAC)="C":"S X=+$E(P(""LOG""),1,12) D H^%DTC S PSIV=%T",1:"S PSIV=$P($H,"","",2)") G T2:PSIVTYPE'["P"&('P(5))
+ I P(11)']"" X $S($E(PSIVAC)="C":"S Y=+$E(P(""LOG""),1,12)",1:"D NOW^%DTC S Y=%") S Y=Y+.007\.01/100 S:'$P(Y,".",2) Y=$$MDNGHT(Y) X ^DD("DD") S START=Y G Q
+ S X=P(11) D CHK S PX=Y,X1=PSIV\3600,X2=PSIV#3600\60,X=$E(".0",1,$L(X1)#2+1)_X1_$E("0",X2<10)_X2,START=$S($E(PSIVAC)="C":$P(P("LOG"),"."),1:"T")
+ S X1=$P(PX,"-"),X1=$E(".0",1,$L(X1)#2+1)_X1,X2=$P(PX,"-",PSGCNT),X2=$E(".0",1,$L(X2)#2+1)_X2
+ S NAT=+$P($G(^PS(59.6,+$O(^PS(59.6,"B",+VAIN(4),0)),0)),U,5)
+ I '$D(PSGDT) S PSGDT=$$DATE^PSJUTL2()
+ I X<X1,'NAT S START=$$ENSD^PSGNE3(P(9),P(11),+$E(P("LOG"),1,12),PSGDT) G Q
+ I X>X2 S START=$$ENSD^PSGNE3(P(9),P(11),+$E(P("LOG"),1,12),PSGDT) G Q
+T6 F I=2:1:PSGCNT S X1="."_$P(PX,"-",I-1),X2="."_$P(PX,"-",I) Q:+X1<X&(+X2>X)
+ S X1=X-X1,X2=$S(NAT:0,1:X2-X),START=$S(X1<X2:$P(PX,"-",I-1),1:$P(PX,"-",I)) S:START="" START=$P(PX,"-") X $S($E(PSIVAC)="C":"S Y=$P(P(""LOG""),""."") X ^DD(""DD"") S PSIV=Y",1:"S PSIV=""TODAY""") S START=PSIV_"@"_$E("0",$L(START)=3)_START G Q
+T2 S X=+("."_$E(10000+(PSIV\3600*100)+(PSIV#3600\60),2,5)),START=$O(^PS(59.5,PSIVSN,3,"AT",X)) S:'START START=$O(^(0)),PSIVTOM=1 I 'START S START=X K PSIVTOM
+ S START=$S($E(PSIVAC)="C":$P(P("LOG"),"."),1:DT)_START I $D(PSIVTOM) S X1=$S($E(PSIVAC)="C":$P(P("LOG"),"."),1:DT),X2=1 D C^%DTC S Y=$P(X,".")_START K PSIVTOM
+ S X=START,%DT="XRTX" D ^%DT
+Q ;
+ I START["@" S X=START,%DT="RTX" D ^%DT S START=+Y
+ S P(2)=START
+ I $G(PSJORD)["P" D:'$G(PSGRDTX(+PSJORD,"PSGSD")) REQDT^PSJLIVMD(PSJORD) S START=$G(PSGRDTX(+PSJORD,"PSGSD")) S P(2)=$S(START:START,1:P(2))
+ K NAT,START,PSIVTYPE,PSIVSTRT,PSGCNT,X1,X2,PX
+ Q
+CHK F Y=1:1 Q:$L(X)>240!($P(X,"-",Y)="")  S $P(X,"-",Y)=$P(X,"-",Y)_$E("0000",1,4-$L($P(X,"-",Y)))
+ S Y=X,PSGCNT=$L(X,"-") S:X]""&(PSGCNT<1) PSGCNT=1 Q
+ ;
+ENSTOP ; WILL CALCULATE STOP DATE FOR ORDER
+ ;NEEDS (DFN) & ON
+ N WALL,P3,ADX,DDLX,OIX,DRGT,PSIDAY,PSIMIN S (WALL,P3,PSIDAY,PSIMIN)=0
+ D:'$G(PSIVSITE) ^PSIVSET  Q:'P(2)
+ I P(23)'="" S PSIVTYPE="C"
+ S STOP="",X="",PSIVSTRT=P(2),PSIVTYPE=$G(P(4)) I $G(PSJREN) D
+ . N RDT I $G(ON)["P" S RDT=+$$LASTREN^PSJLMPRI(DFN,ON)
+ . S PSIVSTRT=$$DATE2^PSJUTL2($S($G(RDT):RDT,1:$G(PSGDT)))
+ ;BHW - PSJ*5*177 - Begin Modifications - Reset Start date to Last Renewed date for active orders that have been renewed
+ I ('$G(PSJREN))&($G(P(4))="A")&($G(ON)["V") D
+ . N RDT S RDT=+$$LASTREN^PSJLMPRI(DFN,ON)
+ . I +RDT S PSIVSTRT=RDT
+ . Q
+ ;BHW - PSJ*5*177 - End Modifications - Resetting PSIVSTRT will recalculate the stop date based on the Last renewed date.
+ ;
+ I $S("^NOW^STAT^ONCE^ONE-TIME^ONE TIME^ONETIME^1TIME^1-TIME^1 TIME^"[(U_P(9)_U):1,1:0),PSIVTYPE="P"!P(5)!(P(23)="P") S X=$$ENOSD^PSJDCU(PSJSYSW0,PSIVSTRT,DFN) I X]"" S:P(11)=""&($G(ON)["P") PSIVCAL=1 G END
+ N DUR,DURMIN,PSJPROV,PSJDNM,A,PSJDAY I $G(PSJORD)["V" S DUR=$$GETDUR^PSJLIVMD(DFN,+PSJORD,"IV",1) I DUR]"" S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN S PSIMIN=DURMIN
+ I $G(PSJORD)["P"!($G(PSJORD)["V") N MINS,LIM S PSIVLIM=$$GETLIM(DFN,PSJORD) I PSIVLIM]"" S MINS=$$GETMIN(PSIVLIM,DFN,PSJORD) I MINS,MINS<PSIMIN!'PSIMIN S PSIMIN=MINS
+ I $P(PSIVSITE,"^",5) D
+ . N Z S Y=0
+ . F  S Y=$O(^PS(55,DFN,"IV",Y)) Q:'Y  S Z=^(Y,0) D  Q:X]""
+ .. I $P(Z,"^",17)="A",$$ONE^PSJBCMA(DFN,Y_"V",$P(Z,"^",9))'="O" S X=$P(Z,"^",3) Q
+ S:X WALL=X
+ S PSIDAY=$S(PSIVTYPE="A":$P(PSIVSITE,"^",4),PSIVTYPE="H":$P(PSIVSITE,"^",17),PSIVTYPE="P":$P(PSIVSITE,"^",18),PSIVTYPE="S":$P(PSIVSITE,"^",20),1:$P(PSIVSITE,"^",21))
+ S PSJDAY="" D  I PSJDAY]"",PSJDAY<PSIDAY S PSIDAY=PSJDAY
+ . N A,B,PSJCLIN
+ . Q:'$D(PSJORD)  S A=""
+ . I PSJORD["P" S A=$G(^PS(53.1,+PSJORD,"DSS"))
+ . I PSJORD["U" S A=$G(^PS(55,PSGP,5,+PSJORD,8))
+ . I PSJORD["V" S A=$G(^PS(55,PSGP,"IV",+PSJORD,"DSS"))
+ . S (PSJCLIN,A)=$P(A,"^") Q:A=""  S PSJCLIN=$P(^SC(PSJCLIN,0),"^") I $D(^PS(53.46,"B",A)) S B=$O(^PS(53.46,"B",A,"")),PSJDAY=$P(^PS(53.46,B,0),"^",2)
+ F X=0:0 S X=$O(DRG("AD",X)) Q:'X  I $P(^PS(52.6,+$P(DRG("AD",+X),U),0),"^",4),($P(^(0),"^",4))<+PSIDAY S PSIDAY=$P(^(0),"^",4)
+ I WALL,($$FMADD^XLFDT(PSIVSTRT,PSIDAY,"D"))>WALL S PSIDAY=$$FMDIFF^XLFDT(WALL,PSIVSTRT,1) S:PSIDAY<1 PSIDAY=""
+ S DRGT=$S($D(DRG("AD")):"AD",1:"SOL") F ADX=0:0 S ADX=$O(DRG(DRGT,ADX)) Q:'ADX!($G(DRGTMP)&($G(DRGTN)["AD")&(DRGT="SOL"))  D
+ . S OIX=+$P(DRG(DRGT,ADX),"^",6),DDLX=$P(^PS(50.7,OIX,0),"^",5) Q:'DDLX  D DDLIM(.PSIDAY,.P3)
+ I '$G(DRG("AD",0)),$G(DRGTMP),($G(DRGTN)["SOL") S OIX=$P($G(DRGTMP),"^",6) I OIX S DDLX=$P(^PS(50.7,OIX,0),"^",5) I DDLX  D DDLIM(.PSIDAY,.P3)
+ I $G(P3),$G(P(2)) I P3>P(2) S X=P3 G END
+ S:('PSIDAY&'PSIMIN) PSIDAY=1
+TIME S X2=PSIDAY,X1=PSIVSTRT D C^%DTC S X=$P(X,"."),X=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14))
+ I PSIMIN,PSIMIN<(PSIDAY*1440) S X=$$FMADD^XLFDT(PSIVSTRT,,,PSIMIN) D
+ . I '(PSIMIN#1440) S X=$P(X,"."),X=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14))
+END ;
+ S P(3)=+X
+ I $G(PSJORD)["P" D:'$G(PSGRDTX(+PSJORD,"PSGFD")) REQDT^PSJLIVMD(PSJORD) S P(3)=$S($G(PSGRDTX(+PSJORD,"PSGFD")):PSGRDTX(+PSJORD,"PSGFD"),1:P(3))
+ S P(3)=$$DATE2^PSJUTL2(P(3)),P(2)=$$DATE2^PSJUTL2(P(2))
+ Q
+ ;
+ENAD ;Will get last admin. time for order (needs dfn and on)
+ N P4,PSIVX,PSIVY
+ I $P(PSJSYSW0,U,5)=2 S PSIVADM=$$DATE^PSJUTL2() Q
+ I $S($G(PSIVAC)["R":1,P(9)="QOD":1,1:P(9)?1"Q".N1"D") S PSIVADM=$$ENSD^PSGNE3(P(9),P(11),+$E(P("LOG"),1,12),+$P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,2)) Q:PSIVADM
+ S PSIVX=X,PSIVY=Y,P4=P(4) S:P(4)="C" P4=P(23) S:P4="S" P4=$S(P(5):"P",1:"A") D NOW^%DTC S Y=%,PSIVNOW=Y I (P4="P"&(P(11)="")&'P(15))!("HA"[P4&'P(15)) S Y=Y+.007\.01/100 G QAD
+ D P:P4="P"&('P(15)),AH:P(15)
+QAD ;
+ S:'$D(PSGSA) PSGSA=""
+ S PSIVSD=Y I Y S OD=$L(PSGSA," ") I OD>2 S X=+PSGSA\1 F OD1=2:1:OD-1 I $P(PSGSA," ",OD1)'>$S(OD1>2:$P(PSGSA," ",OD1-1),1:PSGSA#1) S X1=X,X2=1 D C^%DTC
+ I PSIVSD,OD>2 S Y=X_PSIVSD
+ S PSIVADM=+Y,X=PSIVX,Y=PSIVY K PSGSA,PSIVSD,OD,OD1,PSIVMI,PSIVNOW S:PSIVADM<P(2) PSIVADM=P(2) Q
+ ;
+P S CD=PSIVNOW,PSGSA="",(PSIVSD,OD)=DT_.0001,X=P(11) D CHK S P(11)=X D ENP4^PSIVWL
+ I PSGSA="" S PSIVSD=DT_.0001,PSIVMIN=-1440 D ENT^PSIVWL S $P(Y,".",2)=$P(P(11),"-",$L(P(11),"-")) Q
+ S Y=$P(PSGSA," ",$L(PSGSA," ")-1) Q
+AH F PSIVADM=0:-1 S CD=PSIVNOW,(X,X1)=DT,X2=PSIVADM D:X2 C^%DTC S X=$P(X,".") S (OD1,PSIVSD,OD)=X_.0001,PSIVMIN=P(15) D ENP3^PSIVWL Q:PSIVADM<-4!(PSGSA]"")
+ S Y=$P(PSGSA," ",$L(PSGSA," ")-1) Q
+MDNGHT(Y)          ;Sets Start Date/Time on orders placed between midnight and 12:30
+ S Y=$$FMADD^XLFDT(Y,-1,0,0,0),Y=$P(Y,".")_".24" Q Y
+ ;
+DDLIM(PSIVDUR,STPDT) ;  
+ N P3
+ I DDLX["D" D  Q:(STPDT=0)
+ . I +DDLX'<+PSIVDUR S STPDT=0 Q
+ . S PSIVDUR=+DDLX,X2=PSIVDUR,X1=PSIVSTRT D C^%DTC S X=$P(X,"."),X=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14)) I X>P(2) S P(3)=X
+ I DDLX["L",($G(P(9))]""),$G(P(15)),("AH"'[PSIVTYPE) D
+ . Q:'$G(P(2))!'$G(OIX)  N FIRST,DOSAR,LAST,NEWDUR
+ . S STRING=P(2)_"^"_$S($G(STPDT):STPDT,1:$$FMADD^XLFDT(PSGDT,30))_"^"_P(9)_"^C^"_OIX S FIRST=$$ENQ^PSJORP2(DFN,STRING)
+ . S FIRST=$S($G(FIRST):FIRST,1:P(2)) Q:'FIRST  S DSTMP=FIRST,DOSAR(1)=DSTMP F I=2:1:DDLX+1 S DOSAR(I)=$$FMADD^XLFDT(DSTMP,,,P(15)),DSTMP=DOSAR(I)
+ . I $D(DOSAR) S LAST=$O(DOSAR(""),-1) I LAST S LAST=DOSAR(LAST) I LAST>P(2) S NEWDUR=$$FMDIFF^XLFDT(LAST,P(2)) I NEWDUR<PSIVDUR S P(3)=LAST
+ S P(3)=$$DATE2^PSJUTL2(P(3)),P(2)=$$DATE2^PSJUTL2(P(2)) S STPDT=P(3)
+ Q
+ ;
+GETLIM(DFN,PSJORD) ;
+ N ND2P5,F
+ S F=$S(PSJORD["P":"^PS(53.1,+PSJORD,",PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD,",1:"")
+ S ND2P5=$G(@(F_"2.5)")) S LIM=$P(ND2P5,"^",4) Q:LIM="" 0
+ S ND0=$G(@(F_"0)")) I PSJORD["P",$P(ND0,"^",4)="U" Q 0
+ N MULT S MULT=$S($E(LIM)="h":60,$E(LIM)="d":1440,$E(LIM)="m":LIM,$E(LIM)="l":LIM,1:0) I MULT S LIM=MULT*$E(LIM,2,99)
+ Q LIM
+ ;
+GETMIN(LIM,DFN,PSJORD) ;
+ N F
+ I LIM!(LIM=0) Q LIM
+ S F=$S(PSJORD["P":"^PS(53.1,+PSJORD,",PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD,",1:"")
+ N RATE S RATE=$S(PSJORD["P":+$P($G(@(F_"8)")),"^",5),PSJORD["V":+$P($G(@(F_"0)")),"^",8),1:0) I RATE D
+ . S LIM=$S($E(LIM)="m":$E(LIM,2,99),$E(LIM)="l":($E(LIM,2,99)*1000),1:0)/RATE S LIM=LIM*60
+ Q LIM

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVEDT.m

@@ -1 @@
-PSIVEDT ;BIR/MLM-EDIT IV ORDER ;10 Feb 98 / 3:23 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**4,110,127,133,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^DD(53.1 is supported by DBIA 2256.
-        ; Reference to ^PS(52.7 is supported by DBIA 2173.
-        ; Reference to ^PS(52.6 is supported by DBIA 1231.
-        ; Reference to ^PS(51.2 is supported by DBIA 2178.
-        ; Reference to ^PS(50.7 is supported by DBIA 2180.
-        ; Reference to ^PS(55 is supported by DBIA 2191.
-        ;
-EDIT    ;
-        I $G(DFN)&($G(PSJORD)["V") I $$COMPLEX^PSJOE(DFN,PSJORD) D
-        . N X,Y,PARENT,P2ND S P2ND=$S($G(^PS(55,PSGP,"IV",+PSJORD,.2)):$G(^PS(55,PSGP,"IV",+PSJORD,.2)),1:$G(^PS(55,PSGP,5,+PSJORD,.2)))
-        . S PARENT=$P(P2ND,"^",8)
-        . I PARENT D FULL^VALM1 W !!?5,"This order is part of a complex order. Please review the following ",!?5,"associated orders before changing this order." D CMPLX^PSJCOM1(PSGP,PARENT,PSJORD)
-        S DONE=0
-        F PSIVE=1:1 S:DONE&$E(PSIVAC)="C" OREND=1 Q:PSIVE>$L(EDIT,U)!(DONE)  Q:'$L($P(EDIT,U,PSIVE))  D @($P(EDIT,U,PSIVE)) S:$E(PSIVAC,2)="N" PSIVOK=PSIVOK_U_$P(EDIT,U,PSIVE) I $E(X)=U,$L(X)>1 S:PSIVE>1 PSIVE=PSIVE-1 F  D FF Q:Y<0  D @Y Q:$E(X)'=U
-        K EDIT,PSIVOK,PSGDI
-        Q
-        ;
-1       ; Provider.
-        I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+$G(ON),0)),"^",24)="R" D  Q
-        . W !!?5,"This is Renewal order. Provider may not be edited at this point." D PAUSE^VALM1
-        I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D  Q
-        .Q:$G(PSJBKDR)  W !!?5,"This is a Complex Order. Provider may not be edited at this point." D PAUSE^VALM1
-        S P(6)=$S('$G(^VA(200,+P(6),"PS")):"",'$P(^("PS"),U,4):P(6),$P(^("PS"),U,4)<DT:"",1:P(6))
-        W !,"PROVIDER: "_$S($P(P(6),U,2)]"":$P(P(6),U,2)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(X=""&P(6)) Q
-        I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS^PSIVEDT1 G 1
-        I X]"" K DIC S DIC=200,DIC(0)="EQMZ",DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),U,4):1,$P(^(""PS""),U,4)>DT:1,1:0)" D ^DIC K DIC I Y>0 S P(6)=+Y_U_Y(0,0) Q
-        S F1=53.1,F2=1 D ENHLP^PSIVORC1 W $C(7),!!,"A Provider must be entered.",!! G 1
-        Q
-        ;
-3       ; Med Route.
-        I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D  Q
-        . W !!?5,"Med Route may not be edited at this point." D PAUSE^VALM1
-        I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D  Q
-        .Q:$G(PSJBKDR)  W !!?5,"This is a Complex Order. Med Route may not be edited at this point." D PAUSE^VALM1
-        S P(6)=$S('$G(^VA(200,+P(6),"PS")):"",'$P(^("PS"),U,4):P(6),$P(^("PS"),U,4)<DT:"",1:P(6))
-        I P("MR")="" D
-        .N AD,SOL,OI,RT,RTCNT
-        .S AD=0 F  S AD=$O(DRG("AD",AD)) Q:'AD  S OI=$P(DRG("AD",AD),"^",6) I OI S OI(OI)=""
-        .S SOL=0 F  S SOL=$O(DRG("SOL",SOL)) Q:'SOL  S OI=$P(DRG("SOL",SOL),"^",6) I OI S OI(OI)=""
-        .S OI="" F  S OI=$O(OI(OI)) Q:'OI  S RT=$P(^PS(50.7,OI,0),"^",6) S:RT="" RT="NONE" S RT(RT)=$P($G(^PS(51.2,+RT,0)),"^",3)
-        .S RT="" F RTCNT=0:1 S RT=$O(RT(RT)) Q:RT=""
-        .Q:RTCNT>1
-        .S RT=$O(RT("")) I RT]"" S P("MR")=RT_"^"_$G(RT(RT))
-        W !,"MED ROUTE: "_$S($P(P("MR"),U,2)]"":$P(P("MR"),U,2)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I X=U!(X=""&P("MR"))!($E(X)=U) Q
-        I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS^PSIVEDT1 G 3
-        I X]"" K DIC S DIC=51.2,DIC(0)="EQMZ",DIC("S")="I $P(^(0),U,4)" D ^DIC K DIC I Y>0 S P("MR")=+Y_U_$P(Y(0),U,3) Q
-        S F1=53.1,F2=3 D ENHLP^PSIVORC1 W $C(7),!!,"A Med Route must be entered." G 3
-        Q
-        ;
-10      ; Start Date.
-        D 10^PSIVEDT1
-        Q
-        ;
-25      ; Stop Date.
-        D 25^PSIVEDT1
-        Q
-26      ; Schedule
-        D 26^PSIVEDT1
-        Q
-        ;
-39      ; Admin Times.
-        D 39^PSIVEDT1
-        Q
-        ;
-57      ; Additive.
-        I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D  Q
-        . W !!?5,"Additive may not be edited at this point." D PAUSE^VALM1
-        I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D  Q
-        .Q:$G(PSJBKDR)  W !!?5,"This is a Complex Order. Provider may not be edited at this point." D PAUSE^VALM1
-        I $E(PSIVAC)="O" W !!,"Only additives marked for use in IV Fluid Order Entry may be selected."
-        S FIL=52.6,DRGT="AD",DRGTN="ADDITIVE" D DRG^PSIVEDRG,DKILL
-        Q
-        ;
-58      ; Solution.
-        I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D  Q
-        . W !!?5,"Solution may not be edited at this point." D PAUSE^VALM1
-        S FIL=52.7,DRGT="SOL",DRGTN="SOLUTION" D DRG^PSIVEDRG
-        ;
-DKILL   ; Kill for drug edit.
-        K DRGI,DRGN,DRGT,DRGTN,FIL,PSIVSTR
-        Q
-        ;
-59      ; Infusion Rate.
-        D 59^PSIVEDT1
-        Q
-        ;
-62      ; IV Room.
-        N DIR S DIR(0)="PA^59.5",DIR("A")="IV Room: ",DIR("??")="^S F1=59.5,F2=.01 D ENHLP^PSIVORC1" S:P("IVRM") DIR("B")=$P(P("IVRM"),U,2)
-        D ^DIR Q:$D(DIRUT)  I Y>0 S P("IVRM")=Y W $P($P(Y,U,2),X,2)
-        Q
-        ;
-63      ; Remarks.
-        D 63^PSIVEDT1
-        Q
-        ;
-64      ; Other Print Info.
-        D 64^PSIVEDT1
-        Q
-        ;
-66      ; Provider's comments.
-        N DA,DIE,DIR S DA=PSIVUP,DIE="^PS(53.45,",DR=4 D ^DIE S PSGSI=X,Y=1
-        Q
-        ;
-101     ; Orderable Item.
-        I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D  Q
-        . W !!?5,"This is Renewal order. Orderable Item may not be edited at this point." D PAUSE^VALM1
-        I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D  Q
-        .Q:$G(PSJBKDR)  W !!?5,"This is a Complex Order. Orderable Item may not be edited at this point." D PAUSE^VALM1
-        W !,"Orderable Item: "_$S(P("PD"):$P(P("PD"),U,2)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(X=""&P("PD")) Q
-        I X]"" N DIC S DIC="^PS(50.7,",DIC(0)="EMQZ",DIC("B")=$S(P("PD")]"":+$P(("PD"),U),1:""),DIC("S")="S PSJSCT=1 I $$DRGSC^PSIVUTL(Y,PSJSCT) K PSJSCT" D ^DIC K DIC I Y>0 S P("PD")=Y Q
-        W $C(7),!!,"Orderable Item is required!",!! G 101
-        Q
-109     ; Dosage Ordered.
-        W !,"DOSAGE ORDERED: "_$S(P("DO")]"":P("DO")_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(P("DO")]""&(X="")) Q
-        I X="???" D ORFLDS^PSIVEDT1 G 109
-        D:X]"" CHK^DIE(53.1,109,"",X,.X) I $G(X)="^" W $C(7),!!,"Enter the dosage in which the Orderable Item entered should be dispensed.",! W "Answer must be 1-20 characters in length." G 109
-        S P("DO")=X
-        Q
-        ;
-FF      ; up-arrow to another field.
-        N DIC S X=$P(X,U,2),DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I U_PSIVOK_U[(U_+Y_U)" D ^DIC K DIC S Y=+Y
-        Q
-        ;
-NEWDRG  ; Ask if adding a new drug.
-        K DIR S DIR(0)="Y",DIR("A")="Are you adding "_$P(TDRG,U,2)_" as a new "_$S(DRGT="AD":"additive",1:"solution")_" for this order",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) Q
-        I Y S (DRGI,DRG(DRGT,0))=DRG(DRGT,0)+1,DRG=TDRG,DRG(DRGT,+DRGI)=+DRG_U_$P(DRG,U,2) I DRGT="SOL" S X=$G(^PS(52.7,+DRG,0)),$P(DRG(DRGT,DRG),U,3)=$P(X,U,3)
-        Q
+PSIVEDT ;BIR/MLM-EDIT IV ORDER ;10 Feb 98 / 3:23 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**4,110,127,133**;16 DEC 97
+ ;
+ ; Reference to ^DD(53.1 is supported by DBIA 2256.
+ ; Reference to ^PS(52.7 is supported by DBIA 2173.
+ ; Reference to ^PS(52.6 is supported by DBIA 1231.
+ ; Reference to ^PS(51.2 is supported by DBIA 2178.
+ ; Reference to ^PS(50.7 is supported by DBIA 2180.
+ ; Reference to ^PS(55 is supported by DBIA 2191.
+ ;
+EDIT ;
+ I $G(DFN)&($G(PSJORD)["V") I $$COMPLEX^PSJOE(DFN,PSJORD) D
+ . N X,Y,PARENT,P2ND S P2ND=$S($G(^PS(55,PSGP,"IV",+PSJORD,.2)):$G(^PS(55,PSGP,"IV",+PSJORD,.2)),1:$G(^PS(55,PSGP,5,+PSJORD,.2)))
+ . S PARENT=$P(P2ND,"^",8)
+ . I PARENT D FULL^VALM1 W !!?5,"This order is part of a complex order. Please review the following ",!?5,"associated orders before changing this order." D CMPLX^PSJCOM1(PSGP,PARENT,PSJORD)
+ S DONE=0
+ F PSIVE=1:1 S:DONE&$E(PSIVAC)="C" OREND=1 Q:PSIVE>$L(EDIT,U)!(DONE)  Q:'$L($P(EDIT,U,PSIVE))  D @($P(EDIT,U,PSIVE)) S:$E(PSIVAC,2)="N" PSIVOK=PSIVOK_U_$P(EDIT,U,PSIVE) I $E(X)=U,$L(X)>1 S:PSIVE>1 PSIVE=PSIVE-1 F  D FF Q:Y<0  D @Y Q:$E(X)'=U
+ K EDIT,PSIVOK,PSGDI
+ Q
+ ;
+1 ; Provider.
+ I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+$G(ON),0)),"^",24)="R" D  Q
+ . W !!?5,"This is Renewal order. Provider may not be edited at this point." D PAUSE^VALM1
+ I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D  Q
+ .Q:$G(PSJBKDR)  W !!?5,"This is a Complex Order. Provider may not be edited at this point." D PAUSE^VALM1
+ S P(6)=$S('$G(^VA(200,+P(6),"PS")):"",'$P(^("PS"),U,4):P(6),$P(^("PS"),U,4)<DT:"",1:P(6))
+ W !,"PROVIDER: "_$S($P(P(6),U,2)]"":$P(P(6),U,2)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(X=""&P(6)) Q
+ I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS^PSIVEDT1 G 1
+ I X]"" K DIC S DIC=200,DIC(0)="EQMZ",DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),U,4):1,$P(^(""PS""),U,4)>DT:1,1:0)" D ^DIC K DIC I Y>0 S P(6)=+Y_U_Y(0,0) Q
+ S F1=53.1,F2=1 D ENHLP^PSIVORC1 W $C(7),!!,"A Provider must be entered.",!! G 1
+ Q
+ ;
+3 ; Med Route.
+ I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D  Q
+ . W !!?5,"Med Route may not be edited at this point." D PAUSE^VALM1
+ I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D  Q
+ .Q:$G(PSJBKDR)  W !!?5,"This is a Complex Order. Med Route may not be edited at this point." D PAUSE^VALM1
+ S P(6)=$S('$G(^VA(200,+P(6),"PS")):"",'$P(^("PS"),U,4):P(6),$P(^("PS"),U,4)<DT:"",1:P(6))
+ I P("MR")="" S X=$O(^PS(51.2,"B","INTRAVENOUS",0)) I $P($G(^PS(51.2,+X,0)),U,4) S P("MR")=+X_U_$P(^(0),U,3)
+ W !,"MED ROUTE: "_$S($P(P("MR"),U,2)]"":$P(P("MR"),U,2)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I X=U!(X=""&P("MR"))!($E(X)=U) Q
+ I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS^PSIVEDT1 G 3
+ I X]"" K DIC S DIC=51.2,DIC(0)="EQMZ",DIC("S")="I $P(^(0),U,4)" D ^DIC K DIC I Y>0 S P("MR")=+Y_U_$P(Y(0),U,3) Q
+ S F1=53.1,F2=3 D ENHLP^PSIVORC1 W $C(7),!!,"A Med Route must be entered." G 3
+ Q
+ ;
+10 ; Start Date.
+ D 10^PSIVEDT1
+ Q
+ ;
+25 ; Stop Date.
+ D 25^PSIVEDT1
+ Q
+26 ; Schedule
+ D 26^PSIVEDT1
+ Q
+ ;
+39 ; Admin Times.
+ D 39^PSIVEDT1
+ Q
+ ;
+57 ; Additive.
+ I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D  Q
+ . W !!?5,"Additive may not be edited at this point." D PAUSE^VALM1
+ I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D  Q
+ .Q:$G(PSJBKDR)  W !!?5,"This is a Complex Order. Provider may not be edited at this point." D PAUSE^VALM1
+ I $E(PSIVAC)="O" W !!,"Only additives marked for use in IV Fluid Order Entry may be selected."
+ S FIL=52.6,DRGT="AD",DRGTN="ADDITIVE" D DRG^PSIVEDRG,DKILL
+ Q
+ ;
+58 ; Solution.
+ I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D  Q
+ . W !!?5,"Solution may not be edited at this point." D PAUSE^VALM1
+ S FIL=52.7,DRGT="SOL",DRGTN="SOLUTION" D DRG^PSIVEDRG
+ ;
+DKILL ; Kill for drug edit.
+ K DRGI,DRGN,DRGT,DRGTN,FIL,PSIVSTR
+ Q
+ ;
+59 ; Infusion Rate.
+ D 59^PSIVEDT1
+ Q
+ ;
+62 ; IV Room.
+ N DIR S DIR(0)="PA^59.5",DIR("A")="IV Room: ",DIR("??")="^S F1=59.5,F2=.01 D ENHLP^PSIVORC1" S:P("IVRM") DIR("B")=$P(P("IVRM"),U,2)
+ D ^DIR Q:$D(DIRUT)  I Y>0 S P("IVRM")=Y W $P($P(Y,U,2),X,2)
+ Q
+ ;
+63 ; Remarks.
+ D 63^PSIVEDT1
+ Q
+ ;
+64 ; Other Print Info.
+ D 64^PSIVEDT1
+ Q
+ ;
+66 ; Provider's comments.
+ N DA,DIE,DIR S DA=PSIVUP,DIE="^PS(53.45,",DR=4 D ^DIE S PSGSI=X,Y=1
+ Q
+ ;
+101 ; Orderable Item.
+ I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D  Q
+ . W !!?5,"This is Renewal order. Orderable Item may not be edited at this point." D PAUSE^VALM1
+ I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D  Q
+ .Q:$G(PSJBKDR)  W !!?5,"This is a Complex Order. Orderable Item may not be edited at this point." D PAUSE^VALM1
+ W !,"Orderable Item: "_$S(P("PD"):$P(P("PD"),U,2)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(X=""&P("PD")) Q
+ I X]"" N DIC S DIC="^PS(50.7,",DIC(0)="EMQZ",DIC("B")=$S(P("PD")]"":+$P(("PD"),U),1:""),DIC("S")="S PSJSCT=1 I $$DRGSC^PSIVUTL(Y,PSJSCT) K PSJSCT" D ^DIC K DIC I Y>0 S P("PD")=Y Q
+ W $C(7),!!,"Orderable Item is required!",!! G 101
+ Q
+109 ; Dosage Ordered.
+ W !,"DOSAGE ORDERED: "_$S(P("DO")]"":P("DO")_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(P("DO")]""&(X="")) Q
+ I X="???" D ORFLDS^PSIVEDT1 G 109
+ D:X]"" CHK^DIE(53.1,109,"",X,.X) I $G(X)="^" W $C(7),!!,"Enter the dosage in which the Orderable Item entered should be dispensed.",! W "Answer must be 1-20 characters in length." G 109
+ S P("DO")=X
+ Q
+ ;
+FF ; up-arrow to another field.
+ N DIC S X=$P(X,U,2),DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I U_PSIVOK_U[(U_+Y_U)" D ^DIC K DIC S Y=+Y
+ Q
+ ;
+NEWDRG ; Ask if adding a new drug.
+ K DIR S DIR(0)="Y",DIR("A")="Are you adding "_$P(TDRG,U,2)_" as a new "_$S(DRGT="AD":"additive",1:"solution")_" for this order",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) Q
+ I Y S (DRGI,DRG(DRGT,0))=DRG(DRGT,0)+1,DRG=TDRG,DRG(DRGT,+DRGI)=+DRG_U_$P(DRG,U,2) I DRGT="SOL" S X=$G(^PS(52.7,+DRG,0)),$P(DRG(DRGT,DRG),U,3)=$P(X,U,3)
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORA.m

@@ -1 @@
-PSIVORA ;BIR/MLM-MAIN DRIVER FOR IV FLUIDS - OE/RR INTERFACE ;08 JAN 97 / 2:47 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**29,41,110,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(55 is supported by DBIA 2191
-        ;
-EN      ; Entry point called by IV Fluid protocol.
-        S X=ORACTION,PSIVAC="O"_$S(X=0:"N",X=1:"E",X=2:"R",X=4:"H",X=6:"D",X="8":"S",1:"") S:X'=5&(X'=7) PSIVUP=+$$GTPCI^PSIVUTL
-        S (PSGP,DFN)=+ORVP,PSJACNWP=1 D ^PSJAC I "578"[ORACTION D @ORACTION,DONE^PSIVORA1 Q
-        D ENCPP^PSIVOREN Q:'PSJIVORF!('PSJORF)  D EN1,DONE^PSIVORA1
-        Q
-        ;
-EN1     ; Take action on existing order.
-        S PSJORD=$G(ORPK) I ORGY>8 D @ORGY Q
-        I 'ORACTION D ^PSIVORFE Q
-        I '$G(ORPK) W !,"INSUFFICIENT INFORMATION, CANNOT CONTINUE." S OREND=1 Q
-        I ORPK["V",($P($G(^PS(55,DFN,"IV",+ORPK,0)),U,17)="O") D ONCALL^PSIVORV1 Q
-        I ORACTION<3 S P("FRES")=$S(ORPK["V":$P($G(^PS(55,DFN,"IV",+ORPK,2)),U,9),1:$P($G(^PS(53.1,+ORPK,0)),U,27)) I P("FRES")]"" D @$S(P("FRES")="R":"ALLREN^PSIVORV1",1:"ALLED^PSIVORV1") Q
-        S PSJORSTS=ORSTS,PSJORIFN=ORIFN L +@$S(PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD)",1:"^PS(53.1,+PSJORD)"):1 E  D LOCKERR^PSIVORA1 Q
-        D @ORACTION L -@$S(PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD)",1:"^PS(53.1,+PSJORD)")
-        Q
-        ;
-1       ; Edit an existing order.
-        D EDIT^PSIVORA1
-        Q
-        ;
-2       ; Renew
-        D RENEW^PSIVORA1
-        Q
-        ;
-3       ; Flag
-        Q
-        ;
-4       ; Hold
-        I ORSTS'=3,ORSTS'=6 W !,$C(7),"Only ACTIVE orders may be placed on HOLD." S OREND=1 Q
-        S PSIVREA=$S(ORSTS=6:"H",1:"U"),ON55=PSJORD,$P(^PS(55,DFN,"IV",+ON55,0),U,10)=$S(PSIVREA="H":1,1:""),Y=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(Y,U,3),P(17)=$P(Y,U,17)
-        D NOW^%DTC I ORSTS=3,P(3)<% S P(17)="E" D UPSTAT^PSIVOPT S ORSTS=7 W $C(7),"  This order has expired." Q
-        S XED=0,PSIVALT=2,P(17)=$S(PSIVREA="H":"H",1:"A") D UPSTAT^PSIVOPT,LOG^PSIVORAL S ORSTS=$S(PSIVREA="H":3,1:6)
-        Q
-        ;
-5       ; Event
-        N DA,DIE,DR,ON,P,PSIVACT,X
-        S ON=ORPK I ON["V" S X=$G(^PS(55,+ORVP,"IV",+ON,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17)
-        I ON'["V" S P(3)=$P($G(^PS(53.1,+ON,2)),U,4),P(17)=$P($G(^PS(53.1,+ON,0)),U,9)
-        Q:"AR"'[P(17)  D NOW^%DTC Q:P(3)>%
-        I ON["V" S DR="100///E",DIE="^PS(55,"_+ORVP_",""IV"",",DA(1)=+ORVP
-        I ON'["V" S DR="28///E",DIE="^PS(53.1,"
-        S PSIVACT=1,DA=+ON D ^DIE S ORSTS=7
-        Q
-        ;
-6       ; Cancel - Delete pending or unreleased orders from Nonverified orders
-        ; (53.1) and Orders (100) files.
-        I ORSTS=1 W $C(7),!,"This order has already been DISCONTINUED." Q
-        I ORSTS=7 W $C(7),!,"Expired orders cannot be DISCONTINUED." Q
-        I PSJORD'["V",ORSTS=11 D  Q
-        .S P("OLDON")=$P($G(^PS(53.1,+PSJORD,0)),U,25) I P("OLDON")  D
-        ..I P("OLDON")["V",$D(^PS(55,DFN,"IV",+P("OLDON"),2)) S PSJRES=$P(^(2),U,9) S:PSJRES'="R" $P(^(2),U,6)="",$P(^(2),U,9)="" ;; D:PSJRES="R" ENBKOUT^PSJOREN(DFN,PSJORD)
-        ..I P("OLDON")'["V",$D(^PS(53.1,+P("OLDON"),0)) S PSJRES=$P(^(0),U,27) S:PSJRES'="R" $P(^(0),U,26,27)="^" I PSJRES="R" ;; D ENBKOUT^PSJOREN(DFN,PSJORD)
-        .K DA,DIK S DIK="^PS(53.1,",DA=+PSJORD D ^DIK S PSGP=DFN,X="P" D ENSK^PSGAXR K DA,DIK S ORIFN=PSJORIFN,ORSTS="K" Q
-        ;
-DC      ; DC order from Pharmacy complete function.
-        I PSJORD["V",'PSJCOM N PSIVREA S ON55=PSJORD,X=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17),PSIVREA="D",PSIVALT=2,PSIVALCK="STOP" D D^PSIVOPT2 D HL Q
-        I PSJORD["V",PSJCOM N PSIVREA S ON55=PSJORD,X=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17),PSIVREA="D",PSIVALT=2,PSIVALCK="STOP" D D^PSIVOPT2 Q
-        N DA,DR,DIE,PSJND S DA=+PSJORD,PSJND=$G(^PS(53.1,DA,0)),P("OLDON")=$P(PSJND,U,25),DIE="^PS(53.1,",DR="28///"_$S($P(PSJND,U,27)="E":"DE",1:"D") D ^DIE
-        D HL
-        Q
-HL      ;
-        Q:'$D(P("NAT"))
-        NEW PSJCD,PSJTX,PSJOTMP
-        I PSJORD["P" N PSJNOO S PSJCD="OC",PSJTX="ORDER CANCELED",PSJNOO=$G(P("NAT"))
-        E  S PSJCD="OD",PSJTX="ORDER DISCONTINUED"
-        S PSJOTMP=$G(P("OT")) S P("OT")="F" D EN1^PSJHL2(DFN,PSJCD,PSJORD,PSJTX)
-        Q
-        ;
-7       ; Purge
-        N ND S ND=$S(ORPK["V":$P($G(^PS(55,+ORVP,"IV",+ORPK,0)),U,17)_U_$P($G(^(0)),U,3),1:$P($G(^PS(53.1,+ORPK,0)),U,9)_U_$P($G(^(2)),U,4))
-        Q:"DE"'[$P(ND,U)  S X1=+$P(ND,U,2),X2=30 D C^%DTC S ND=X D NOW^%DTC Q:ND>%
-        I ORPK["V",$D(^PS(55,+ORVP,"IV",+ORPK,0)) S $P(^(0),U,21)=""
-        I ORPK'["V",$D(^PS(53.1,+ORPK,0)) S $P(^(0),U,21)=""
-        S ORSTS="K"
-        Q
-        ;
-8       ; Print
-        K DIR S DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!'($D(ORPK)) S OREND=1 Q
-        S:'$G(PSIVUP) PSIVUP=+$$GTPCI^PSIVUTL S:'$D(PSIVAC) PSIVAC="OS" S (ON,ON55)=ORPK,DFN=+ORVP D @$S(ON["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON_""")"),ENDT^PSIVORV1
-        Q
-        ;
-9       ; Release order (status=incomplete in 53.1, pending in 100)
-        S X=ORACTION I X=4!(X=6) D @ORACTION Q
-        Q:"36"[ORSTS  N ON,PSJORIFN S PSJORIFN=ORIFN,ON=ORPK L +^PS(53.1,+ON):1 E  D LOCKERR^PSIVORA1 Q
-        S Y=$G(^PS(53.1,+ON,0)),P("RES")=$P(Y,U,24),P("OLDON")=$P(Y,U,25)
-        N DA,DIE,DR,OREND S DR="28////P",DIE="^PS(53.1,",DA=+ON D ^DIE
-        I P("OLDON")]"" K DA,DIE,DR S DA=P("OLDON") D
-        .I DA["V" S DA(1)=+ORPV,DIE="^PS(55,"_DA(1)_",""IV"",",DR="114////"_+ON_"P"_";123////"_P("RES")
-        .E  S DIE="^PS(53.1,",DR="105////"_ON_"P"_";107////"_P("RES") I P("RES")="E",$P($G(^PS(53.1,+P("OLDON"),0)),U,9)="D" S DR=DR_";28////DE"
-        .S DA=+DA L +@(DIE_DA_")"):1 E  D LOCKERR^PSIVORA1 Q
-        .D ^DIE L -@(DIE_DA_")")
-        L -^PS(53.1,+ON) D DONE^PSIVORA1
-        Q
-        ;
-10      ; Verify
-        Q
+PSIVORA ;BIR/MLM-MAIN DRIVER FOR IV FLUIDS - OE/RR INTERFACE ;08 JAN 97 / 2:47 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**29,41,110**;16 DEC 97
+ ;
+ ; Reference to ^PS(55 is supported by DBIA 2191
+ ;
+EN ; Entry point called by IV Fluid protocol.
+ S X=ORACTION,PSIVAC="O"_$S(X=0:"N",X=1:"E",X=2:"R",X=4:"H",X=6:"D",X="8":"S",1:"") S:X'=5&(X'=7) PSIVUP=+$$GTPCI^PSIVUTL
+ S (PSGP,DFN)=+ORVP,PSJACNWP=1 D ^PSJAC I "578"[ORACTION D @ORACTION,DONE^PSIVORA1 Q
+ D ENCPP^PSIVOREN Q:'PSJIVORF!('PSJORF)  D EN1,DONE^PSIVORA1
+ Q
+ ;
+EN1 ; Take action on existing order.
+ S PSJORD=$G(ORPK) I ORGY>8 D @ORGY Q
+ I 'ORACTION D ^PSIVORFE Q
+ I '$G(ORPK) W !,"INSUFFICIENT INFORMATION, CANNOT CONTINUE." S OREND=1 Q
+ I ORPK["V",($P($G(^PS(55,DFN,"IV",+ORPK,0)),U,17)="O") D ONCALL^PSIVORV1 Q
+ I ORACTION<3 S P("FRES")=$S(ORPK["V":$P($G(^PS(55,DFN,"IV",+ORPK,2)),U,9),1:$P($G(^PS(53.1,+ORPK,0)),U,27)) I P("FRES")]"" D @$S(P("FRES")="R":"ALLREN^PSIVORV1",1:"ALLED^PSIVORV1") Q
+ S PSJORSTS=ORSTS,PSJORIFN=ORIFN L +@$S(PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD)",1:"^PS(53.1,+PSJORD)"):1 E  D LOCKERR^PSIVORA1 Q
+ D @ORACTION L -@$S(PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD)",1:"^PS(53.1,+PSJORD)")
+ Q
+ ;
+1 ; Edit an existing order.
+ D EDIT^PSIVORA1
+ Q
+ ;
+2 ; Renew
+ D RENEW^PSIVORA1
+ Q
+ ;
+3 ; Flag
+ Q
+ ;
+4 ; Hold
+ I ORSTS'=3,ORSTS'=6 W !,$C(7),"Only ACTIVE orders may be placed on HOLD." S OREND=1 Q
+ S PSIVREA=$S(ORSTS=6:"H",1:"U"),ON55=PSJORD,$P(^PS(55,DFN,"IV",+ON55,0),U,10)=$S(PSIVREA="H":1,1:""),Y=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(Y,U,3),P(17)=$P(Y,U,17)
+ D NOW^%DTC I ORSTS=3,P(3)<% S P(17)="E" D UPSTAT^PSIVOPT S ORSTS=7 W $C(7),"  This order has expired." Q
+ S XED=0,PSIVALT=2,P(17)=$S(PSIVREA="H":"H",1:"A") D UPSTAT^PSIVOPT,LOG^PSIVORAL S ORSTS=$S(PSIVREA="H":3,1:6)
+ Q
+ ;
+5 ; Event
+ N DA,DIE,DR,ON,P,PSIVACT,X
+ S ON=ORPK I ON["V" S X=$G(^PS(55,+ORVP,"IV",+ON,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17)
+ I ON'["V" S P(3)=$P($G(^PS(53.1,+ON,2)),U,4),P(17)=$P($G(^PS(53.1,+ON,0)),U,9)
+ Q:"AR"'[P(17)  D NOW^%DTC Q:P(3)>%
+ I ON["V" S DR="100///E",DIE="^PS(55,"_+ORVP_",""IV"",",DA(1)=+ORVP
+ I ON'["V" S DR="28///E",DIE="^PS(53.1,"
+ S PSIVACT=1,DA=+ON D ^DIE S ORSTS=7
+ Q
+ ;
+6 ; Cancel - Delete pending or unreleased orders from Nonverified orders
+ ; (53.1) and Orders (100) files.
+ I ORSTS=1 W $C(7),!,"This order has already been DISCONTINUED." Q
+ I ORSTS=7 W $C(7),!,"Expired orders cannot be DISCONTINUED." Q
+ I PSJORD'["V",ORSTS=11 D  Q
+ .S P("OLDON")=$P($G(^PS(53.1,+PSJORD,0)),U,25) I P("OLDON")  D
+ ..I P("OLDON")["V",$D(^PS(55,DFN,"IV",+P("OLDON"),2)) S PSJRES=$P(^(2),U,9) S:PSJRES'="R" $P(^(2),U,6)="",$P(^(2),U,9)="" ;; D:PSJRES="R" ENBKOUT^PSJOREN(DFN,PSJORD)
+ ..I P("OLDON")'["V",$D(^PS(53.1,+P("OLDON"),0)) S PSJRES=$P(^(0),U,27) S:PSJRES'="R" $P(^(0),U,26,27)="^" I PSJRES="R" ;; D ENBKOUT^PSJOREN(DFN,PSJORD)
+ .K DA,DIK S DIK="^PS(53.1,",DA=+PSJORD D ^DIK S PSGP=DFN,X="P" D ENSK^PSGAXR K DA,DIK S ORIFN=PSJORIFN,ORSTS="K" Q
+ ;
+DC ; DC order from Pharmacy complete function.
+ I PSJORD["V",'PSJCOM N PSIVREA S ON55=PSJORD,X=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17),PSIVREA="D",PSIVALT=2,PSIVALCK="STOP" D D^PSIVOPT2 D HL Q
+ I PSJORD["V",PSJCOM N PSIVREA S ON55=PSJORD,X=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17),PSIVREA="D",PSIVALT=2,PSIVALCK="STOP" D D^PSIVOPT2 Q
+ N DA,DR,DIE,PSJND S DA=+PSJORD,PSJND=$G(^PS(53.1,DA,0)),P("OLDON")=$P(PSJND,U,25),DIE="^PS(53.1,",DR="28///"_$S($P(PSJND,U,27)="E":"DE",1:"D") D ^DIE
+ D HL
+ Q
+HL ;
+ Q:'$D(P("NAT"))
+ ;D EN1^PSJHL2(DFN,"OC",PSJORD,"ORDER CANCELED")
+ NEW PSJCD,PSJTX
+ I PSJORD["P" N PSJNOO S PSJCD="OC",PSJTX="ORDER CANCELED",PSJNOO=$G(P("NAT"))
+ E  S PSJCD="OD",PSJTX="ORDER DISCONTINUED"
+ D EN1^PSJHL2(DFN,PSJCD,PSJORD,PSJTX)
+ ;D UNL^PSSLOCK(DFN,PSJORD)
+ Q
+ ;
+7 ; Purge
+ N ND S ND=$S(ORPK["V":$P($G(^PS(55,+ORVP,"IV",+ORPK,0)),U,17)_U_$P($G(^(0)),U,3),1:$P($G(^PS(53.1,+ORPK,0)),U,9)_U_$P($G(^(2)),U,4))
+ Q:"DE"'[$P(ND,U)  S X1=+$P(ND,U,2),X2=30 D C^%DTC S ND=X D NOW^%DTC Q:ND>%
+ I ORPK["V",$D(^PS(55,+ORVP,"IV",+ORPK,0)) S $P(^(0),U,21)=""
+ I ORPK'["V",$D(^PS(53.1,+ORPK,0)) S $P(^(0),U,21)=""
+ S ORSTS="K"
+ Q
+ ;
+8 ; Print
+ K DIR S DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!'($D(ORPK)) S OREND=1 Q
+ S:'$G(PSIVUP) PSIVUP=+$$GTPCI^PSIVUTL S:'$D(PSIVAC) PSIVAC="OS" S (ON,ON55)=ORPK,DFN=+ORVP D @$S(ON["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON_""")"),ENDT^PSIVORV1
+ Q
+ ;
+9 ; Release order (status=incomplete in 53.1, pending in 100)
+ S X=ORACTION I X=4!(X=6) D @ORACTION Q
+ Q:"36"[ORSTS  N ON,PSJORIFN S PSJORIFN=ORIFN,ON=ORPK L +^PS(53.1,+ON):1 E  D LOCKERR^PSIVORA1 Q
+ S Y=$G(^PS(53.1,+ON,0)),P("RES")=$P(Y,U,24),P("OLDON")=$P(Y,U,25)
+ N DA,DIE,DR,OREND S DR="28////P",DIE="^PS(53.1,",DA=+ON D ^DIE
+ I P("OLDON")]"" K DA,DIE,DR S DA=P("OLDON") D
+ .I DA["V" S DA(1)=+ORPV,DIE="^PS(55,"_DA(1)_",""IV"",",DR="114////"_+ON_"P"_";123////"_P("RES")
+ .E  S DIE="^PS(53.1,",DR="105////"_ON_"P"_";107////"_P("RES") I P("RES")="E",$P($G(^PS(53.1,+P("OLDON"),0)),U,9)="D" S DR=DR_";28////DE"
+ .S DA=+DA L +@(DIE_DA_")"):1 E  D LOCKERR^PSIVORA1 Q
+ .D ^DIE L -@(DIE_DA_")")
+ L -^PS(53.1,+ON) D DONE^PSIVORA1
+ Q
+ ;
+10 ; Verify
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC.m

@@ -1 @@
-PSIVORC ;BIR/MLM-COMPLETE IV ORDERS ENTERED THROUGH OE/RR ;02 Mar 99 / 10:16 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**23,53,80,110,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^DIC(42 is supported by DBIA 10039
-        ; Reference to ^DPT is supported by DBIA 10035
-        ; Reference to ^%DTC is supported by DBIA 10000
-        ; Reference to ^DID is supported by DBIA 2052
-        ;
-EN      ; Set IV parameters.
-        D SITE^PSIVORE Q:'$G(PSIVQ)  K PSIVQ
-        ;
-SELECT  ;
-        F  S PSGSSH="ORVC" D ^PSGSEL Q:U[PSGSS  D GTORDRS
-        D DONE^PSIVORC1
-        Q
-GTORDRS ;
-        K ^TMP("PSIV",$J) N DIC,Y D @PSGSS Q:+$G(Y)'>0  W:PSGSS'="P" !,"...a few moments, please..." D @("G"_PSGSS)
-        I $G(Y),'$D(^TMP("PSIV",$J)) W !,$C(7),"NO PENDING ORDERS FOR ",$S(PSGSS="P":"PATIENT",1:"WARD"),$S(PSGSS="G":" GROUP",1:"")," SELECTED." Q
-        D NOW^%DTC S HDT=$$ENDTC^PSGMI(%),PSIVAC="C",DONE=0,WDN=""
-        F  S WDN=$O(^TMP("PSIV",$J,WDN)) Q:WDN=""!DONE  S PNME="" F  S PNME=$O(^TMP("PSIV",$J,WDN,PNME)) Q:PNME=""!DONE  D
-        . I PSGSS'="P" S PSGDFN=$P(PNME,";",2)_"^"_$P(PNME,";") D CHK^PSJDPT(.PSGDFN,1,1) I PSGDFN=-1 Q
-        . D PROFILE D:PSIVHD ASK
-        D:$G(PSIVHD) ASK
-        Q
-        ;
-PROFILE ; Display profile of all incomplete orders.
-        ;
-        K PSGODDD S (DFN,PSGP)=$P(PNME,";",2) D ENBOTH^PSJAC
-        S RB=PSJPRB,PG=1,PSJORL=$$ENORL^PSJUTL($G(VAIN(4))),PSJIVOF=PSJORL,PSGLMT=0,LN2="" D ENHEAD^PSJO3
-        S (DONE1,TYP)="" F  S TYP=$O(^TMP("PSIV",$J,WDN,PNME,TYP)) Q:TYP=""!(DONE1)  D:$Y+5'>IOSL GTYP F ON1=0:0 S ON1=$O(^TMP("PSIV",$J,WDN,PNME,TYP,ON1)) Q:'ON1!(DONE1)  D DISPLAY
-        Q
-        ;
-DISPLAY ; Display order on profile.
-        I $Y+5>IOSL D ASK Q:DONE1  D ENHEAD^PSJO3,GTYP
-        S PSIVHD=1,PSGLMT=PSGLMT+1,PSIVCV(PSGLMT)=ON1,PSJC="" W !?3,PSGLMT D PIV^PSIVUTL(+ON1_"P")
-        Q
-        ;
-GTYP    ; Get formatted heading for type
-        N PSJD5314 D FIELD^DID(53.1,4,"","POINTER","PSJD5314")
-        ; removed ^DD ref 3-2-99, pass ^^_set of codes value
-        ; because codes^psivutl uses the 3rd piece
-        S X=$$CODES^PSIVUTL(TYP,"^^"_PSJD5314("POINTER"),"")
-        S PSIV=$S(X]"":X,1:"UNKNOWN"),X="",$P(X,"-",40-($L(PSIV)/2))="" W !,X_PSIV_X
-        Q
-        ;
-ASK     ; Ask which orders to view.
-        S PSIVHD=0,ACTION="ORDER" D RD1^PSGON I X="^" S (DONE,DONE1)=1 Q
-        Q:'$D(PSGODDD)  S DONE1=0 F PN=1:1:$L(PSGODDD(1),",")-1 S ON=+$P(PSGODDD(1),",",PN) Q:ON=""!DONE1  S ON=+$P(PSGODDD(1),",",PN) D SHOW
-        S DONE1=1,PSGOP=DFN D:$P(PSJSYSL,U,2)]"" ENQL^PSGLW
-        Q
-        ;
-SHOW    ; Display selected order and prompt for action
-        S (P("PON"),ON)=PSIVCV(ON)
-        ;
-SHOW1   ; Entry point from backdoor.
-        S PSIVUP=+$$GTPCI^PSIVUTL D GT531^PSIVORFA(DFN,ON) I $G(PSIVAC)="PRO" D ENNONUM^PSIVORV2(DFN,ON) Q
-        I $G(PSJORD)["P" D REQDT^PSJLIVMD(PSJORD)
-        S PSJORD=+ON D ^PSJLIFN
-        Q
-        ;
-        ; look-ups on ward group, ward, or patient; depending on value of SS
-G       S DIC="^PS(57.5,",DIC(0)="QEAMI",DIC("A")="Select WARD GROUP: " W ! D ^DIC S:+Y>0 WG=+Y Q
-W       S DIC="^DIC(42,",DIC(0)="QEAMI",DIC("A")="Select WARD: " W ! D ^DIC S:+Y>0 WD=+Y Q
-P       D ENGETP^PSIV Q:DFN<0  S Y=1 I $D(^PS(53.1,"AS","P",+DFN)) S PNME=$G(^DPT(+DFN,0)),PNME=$P(PNME,U)_";"_DFN,WDN=$S(VAIN(4)]"":$P(VAIN(4),U,2),1:"OUTPATIENT") D GP
-        Q
-        ;
-GG      ; put patient(s) with incomplete orders into array
-        F WD=0:0 S WD=$O(^PS(57.5,"AC",WG,WD)) Q:'WD  D GW
-        Q
-GW      S WDN=$G(^DIC(42,WD,0)),WDN=$P(WDN,U) I WDN]"" F DFN=0:0 S DFN=$O(^DPT("CN",WDN,DFN)) Q:'DFN  I $D(^PS(53.1,"AS","P",DFN)) S Y=$G(^DPT(+DFN,0)),PNME=$P(Y,U)_";"_DFN D:PNME]"" GP
-        Q
-GP      ;
-        F ON=0:0 S ON=$O(^PS(53.1,"AS","P",DFN,ON)) Q:'ON  S Y=$G(^PS(53.1,ON,0)),TYP=$S($P(Y,U,4)]"":$P(Y,U,4),1:"Z"),^TMP("PSIV",$J,WDN,PNME,TYP,ON)=""
-        Q
-DISCONT ; Cancel incomplete order
-        N PSJDCTYP I $G(ON)["P",$P($G(^PS(53.1,+$G(ON),0)),"^",24)="R" S PSJDCTYP=$$PNDRNA^PSGOEC(ON) I $G(PSJDCTYP)'=1 D PNDRN(PSJDCTYP) Q
-D2      ; Called from PNDRN for pending order
-        D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D NATURE^PSIVOREN I '$D(P("NAT")) W !,$C(7),"Order Unchanged." Q
-        ;Prompt for requesting provider
-        W ! I '$$REQPROV^PSGOEC W !,$C(7),"Order Unchanged." K PSJDCTYP Q
-        W !
-        ;
-D3      ; called from PNDRN for original order
-        I 'PSJCOM N PSJORNAT S PSJORIFN=$P($G(^PS(53.1,+ON,0)),U,21),PSJORD=ON,PSJORNAT=P("NAT") D DC^PSIVORA ;* I PSJIVORF,PSJORIFN,(ON["V") D EN1^PSJHL2(PSGP,"OD",+ON_"V","ORDER DISCONTINUED")
-        I PSJCOM,PSJORD["P" N O S O="" F  S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O=""  D
-        .S ON=O_"P",PSJORIFN=$P($G(^PS(53.1,+ON,0)),U,21),PSJORD=ON,PSJORNAT=P("NAT") D DC^PSIVORA
-        W !,"Order discontinued.",!
-        Q
-        ;
-EDIT    ; Edit incomplete order
-        S PSIVAC="CE" L +^PS(53.1,+ON):1 E  W !,$C(7),"This order LOCKED by another user." Q
-        D EDIT^PSIVORC2 L -^PS(53.1,+ON)
-        Q
-        ;
-FINISH  ; Finish incomplete order
-        S PSIVAC="CF" L +^PS(53.1,+ON):1 E  W !,$C(7),"This order LOCKED by another user." Q
-        D FINISH^PSIVORC2 L -^PS(53.1,+ON)
-        Q
-        ;
-PNDRN(PSJDCTYP) ; Discontinue pending renewal only or both pending and original orders
-        I PSJDCTYP=2 S PSJDCTYP=1 D D2 Q:'$G(PSJDCTYP)  D
-        .N ND5310 S ND5310=$G(^PS(53.1,+ON,0))
-        .N ON S ON=$P(ND5310,"^",25) I ON S PSJDCTYP=2 D D3
-        Q
+PSIVORC ;BIR/MLM-COMPLETE IV ORDERS ENTERED THROUGH OE/RR ;02 Mar 99 / 10:16 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**23,53,80,110**;16 DEC 97
+ ;
+ ; Reference to ^DIC(42 is supported by DBIA 10039
+ ; Reference to ^DPT is supported by DBIA 10035
+ ; Reference to ^%DTC is supported by DBIA 10000
+ ; Reference to ^DID is supported by DBIA 2052
+ ;
+EN ; Set IV parameters.
+ D SITE^PSIVORE Q:'$G(PSIVQ)  K PSIVQ
+ ;
+SELECT ;
+ F  S PSGSSH="ORVC" D ^PSGSEL Q:U[PSGSS  D GTORDRS
+ D DONE^PSIVORC1
+ Q
+GTORDRS ;
+ K ^TMP("PSIV",$J) N DIC,Y D @PSGSS Q:+$G(Y)'>0  W:PSGSS'="P" !,"...a few moments, please..." D @("G"_PSGSS)
+ I $G(Y),'$D(^TMP("PSIV",$J)) W !,$C(7),"NO PENDING ORDERS FOR ",$S(PSGSS="P":"PATIENT",1:"WARD"),$S(PSGSS="G":" GROUP",1:"")," SELECTED." Q
+ D NOW^%DTC S HDT=$$ENDTC^PSGMI(%),PSIVAC="C",DONE=0,WDN=""
+ F  S WDN=$O(^TMP("PSIV",$J,WDN)) Q:WDN=""!DONE  S PNME="" F  S PNME=$O(^TMP("PSIV",$J,WDN,PNME)) Q:PNME=""!DONE  D
+ . I PSGSS'="P" S PSGDFN=$P(PNME,";",2)_"^"_$P(PNME,";") D CHK^PSJDPT(.PSGDFN,1,1) I PSGDFN=-1 Q
+ . D PROFILE D:PSIVHD ASK
+ D:$G(PSIVHD) ASK
+ Q
+ ;
+PROFILE ; Display profile of all incomplete orders.
+ ;
+ K PSGODDD S (DFN,PSGP)=$P(PNME,";",2) D ENBOTH^PSJAC
+ S RB=PSJPRB,PG=1,PSJORL=$$ENORL^PSJUTL($G(VAIN(4))),PSJIVOF=PSJORL,PSGLMT=0,LN2="" D ENHEAD^PSJO3
+ S (DONE1,TYP)="" F  S TYP=$O(^TMP("PSIV",$J,WDN,PNME,TYP)) Q:TYP=""!(DONE1)  D:$Y+5'>IOSL GTYP F ON1=0:0 S ON1=$O(^TMP("PSIV",$J,WDN,PNME,TYP,ON1)) Q:'ON1!(DONE1)  D DISPLAY
+ Q
+ ;
+DISPLAY ; Display order on profile.
+ I $Y+5>IOSL D ASK Q:DONE1  D ENHEAD^PSJO3,GTYP
+ S PSIVHD=1,PSGLMT=PSGLMT+1,PSIVCV(PSGLMT)=ON1,PSJC="" W !?3,PSGLMT D PIV^PSIVUTL(+ON1_"P")
+ Q
+ ;
+GTYP ; Get formatted heading for type
+ N PSJD5314 D FIELD^DID(53.1,4,"","POINTER","PSJD5314")
+ ; removed ^DD ref 3-2-99, pass ^^_set of codes value
+ ; because codes^psivutl uses the 3rd piece
+ ;S X=$$CODES^PSIVUTL(TYP,"^^"_PSJD5314("POINTER")),PSIV=$S(X]"":X,1:"UNKNOWN"),X="",$P(X,"-",40-($L(PSIV)/2))="" W !,X_PSIV_X
+ S X=$$CODES^PSIVUTL(TYP,"^^"_PSJD5314("POINTER"),"")
+ S PSIV=$S(X]"":X,1:"UNKNOWN"),X="",$P(X,"-",40-($L(PSIV)/2))="" W !,X_PSIV_X
+ Q
+ ;
+ASK ; Ask which orders to view.
+ S PSIVHD=0,ACTION="ORDER" D RD1^PSGON I X="^" S (DONE,DONE1)=1 Q
+ Q:'$D(PSGODDD)  S DONE1=0 F PN=1:1:$L(PSGODDD(1),",")-1 S ON=+$P(PSGODDD(1),",",PN) Q:ON=""!DONE1  S ON=+$P(PSGODDD(1),",",PN) D SHOW
+ S DONE1=1,PSGOP=DFN D:$P(PSJSYSL,U,2)]"" ENQL^PSGLW
+ Q
+ ;
+SHOW ; Display selected order and prompt for action
+ S (P("PON"),ON)=PSIVCV(ON)
+ ;
+SHOW1 ; Entry point from backdoor.
+ S PSIVUP=+$$GTPCI^PSIVUTL D GT531^PSIVORFA(DFN,ON) I $G(PSIVAC)="PRO" D ENNONUM^PSIVORV2(DFN,ON) Q
+ I $G(PSJORD)["P" D REQDT^PSJLIVMD(PSJORD)
+ S PSJORD=+ON D ^PSJLIFN
+ Q
+ ;
+ ; look-ups on ward group, ward, or patient; depending on value of SS
+G S DIC="^PS(57.5,",DIC(0)="QEAMI",DIC("A")="Select WARD GROUP: " W ! D ^DIC S:+Y>0 WG=+Y Q
+W S DIC="^DIC(42,",DIC(0)="QEAMI",DIC("A")="Select WARD: " W ! D ^DIC S:+Y>0 WD=+Y Q
+P D ENGETP^PSIV Q:DFN<0  S Y=1 I $D(^PS(53.1,"AS","P",+DFN)) S PNME=$G(^DPT(+DFN,0)),PNME=$P(PNME,U)_";"_DFN,WDN=$S(VAIN(4)]"":$P(VAIN(4),U,2),1:"OUTPATIENT") D GP
+ Q
+ ;
+GG ; put patient(s) with incomplete orders into array
+ F WD=0:0 S WD=$O(^PS(57.5,"AC",WG,WD)) Q:'WD  D GW
+ Q
+GW S WDN=$G(^DIC(42,WD,0)),WDN=$P(WDN,U) I WDN]"" F DFN=0:0 S DFN=$O(^DPT("CN",WDN,DFN)) Q:'DFN  I $D(^PS(53.1,"AS","P",DFN)) S Y=$G(^DPT(+DFN,0)),PNME=$P(Y,U)_";"_DFN D:PNME]"" GP
+ Q
+GP ;
+ F ON=0:0 S ON=$O(^PS(53.1,"AS","P",DFN,ON)) Q:'ON  S Y=$G(^PS(53.1,ON,0)),TYP=$S($P(Y,U,4)]"":$P(Y,U,4),1:"Z"),^TMP("PSIV",$J,WDN,PNME,TYP,ON)=""
+ Q
+DISCONT ; Cancel incomplete order
+ D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D NATURE^PSIVOREN I '$D(P("NAT")) W !,$C(7),"Order Unchanged." Q
+ ;Prompt for requesting provider
+ W ! I '$$REQPROV^PSGOEC W !,$C(7),"Order Unchanged." Q
+ W !
+ ;
+ ;* N PSJORNAT S (PSJORIFN,ORIFN)=$P($G(^PS(53.1,+ON,0)),U,21),PSJORD=ON,PSJORNAT=P("NAT") D DC^PSIVORA ;* I PSJIVORF,PSJORIFN,(ON["V") D EN1^PSJHL2(PSGP,"OD",+ON_"V","ORDER DISCONTINUED")
+ I 'PSJCOM N PSJORNAT S PSJORIFN=$P($G(^PS(53.1,+ON,0)),U,21),PSJORD=ON,PSJORNAT=P("NAT") D DC^PSIVORA ;* I PSJIVORF,PSJORIFN,(ON["V") D EN1^PSJHL2(PSGP,"OD",+ON_"V","ORDER DISCONTINUED")
+ I PSJCOM,PSJORD["P" N O S O="" F  S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O=""  D
+ .S ON=O_"P",PSJORIFN=$P($G(^PS(53.1,+ON,0)),U,21),PSJORD=ON,PSJORNAT=P("NAT") D DC^PSIVORA
+ W !,"Order discontinued.",!
+ Q
+ ;
+EDIT ; Edit incomplete order
+ S PSIVAC="CE" L +^PS(53.1,+ON):1 E  W !,$C(7),"This order LOCKED by another user." Q
+ D EDIT^PSIVORC2 L -^PS(53.1,+ON)
+ Q
+ ;
+FINISH ; Finish incomplete order
+ S PSIVAC="CF" L +^PS(53.1,+ON):1 E  W !,$C(7),"This order LOCKED by another user." Q
+ D FINISH^PSIVORC2 L -^PS(53.1,+ON)
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC1.m

@@ -1 @@
-PSIVORC1        ;BIR/MLM-PROCESS INCOMPLETE IV ORDER - CONT ;13 Jan 98 / 11:36 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**1,37,69,110,157,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^DD("DD" is supported by DBIA 10017.
-        ; Reference to ^DD( is supported by DBIA 2255.
-        ; Reference to ^VA(200 is supported by DBIA 10060.
-        ; Reference to ^%DT is supported by DBIA 10003.
-        ; Reference to ^%DTC is supported by DBIA 10000.
-        ; Reference to ^DID is supported by DBIA 2052.
-        ; Reference to ^VALM is supported by DBIA 10118.
-        ; Reference to ^PS(55 is supported by DBIA# 2191.
-        ;
-53      ; IV Type
-        I $G(PSGORD)["P",$G(PSGAT),($G(P(9))]"") D
-        .N X,PSGS0Y,ZZ,LYN,ZZND,ZZNDW S X=P(9) S PSGS0Y="",ZZ=0 D FIND^DIC(51.1,,,,X,,"APPSJ",,,"LYN")
-        .S ZZ=$O(LYN("DILIST",2,ZZ)) I ZZ S ZZ=+LYN("DILIST",2,ZZ) I ZZ S ZZND=$G(^PS(51.1,ZZ,0)) S PSGST=$P(ZZND,U,5),PSGS0XT=$P(ZZND,U,3) I $G(PSJPWD) D
-        ..N ZZNDW S ZZNDW=$G(^PS(51.1,ZZ,1,PSJPWD,0)) I $P(ZZNDW,"^",2)]"" S PSGS0Y=$P(ZZNDW,"^",2),$P(ZZND,"^",2)=PSGS0Y
-        .S ZZ=0 F  S ZZ=$O(LYN("DILIST",1,ZZ)) Q:'ZZ  I $G(LYN("DILIST",1,ZZ))'=X K LYN("DILIST",1,ZZ),LYN("DILIST",2,ZZ),LYN("DILIST","ID",ZZ,1)
-        .I $D(PSJPWD) S ZZ=0 F  S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ  I $P($G(^PS(51.1,+LYN("DILIST",2,ZZ),1,+PSJPWD,0)),U,2)]"" S PSGS0Y=$P($G(^(0)),U,2)
-        .I '$G(PSGS0Y) S ZZ=0 F  S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ  Q:PSGS0Y]""  I $G(LYN("DILIST","ID",ZZ,1))]"" S PSGS0Y=$G(LYN("DILIST","ID",ZZ,1))
-        .Q:(PSGS0Y=PSGAT)!'$G(PSGS0Y)!($G(IVCAT)="C")
-        .S PSGNSTAT=1 W $C(7),!!,"PLEASE NOTE:  This order's admin times (",PSGAT,")"
-        .W !?13," do not match the ward times (",PSGS0Y,")"
-        .W !?13," for this administration schedule (",P(9),")",!
-        .S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR K DIR  W !
-        S DONE=0 N DIR S DIR(0)="SNA^A:ADMIXTURE;C:CHEMOTHERAPY;H:HYPERAL;P:PIGGYBACK;S:SYRINGE",DIR("A")="IV TYPE: "
-        I $G(P("RES"))'="R",$G(PSGORD)["P" N IVCAT,IVTYPTMP S IVCAT=$P($G(^PS(53.1,+PSGORD,2.5)),"^",5) S IVTYPTMP=$S((P(9)]""):"P",$G(P(5)):"P",$G(P(23))="P":"P",1:"")
-        S DIR("B")=$S($G(IVCAT)="C"!($G(IVTYPTMP)="A"):"ADMIXTURE",$G(IVCAT)="I"!($G(IVTYPTMP)="P"):"PIGGYBACK",1:"ADMIXTURE")
-        D DIRQ,^DIR S:$D(DTOUT)!(X="^") DONE=1 Q:DONE  G:$E(X)="^" 53 S P(4)=Y D:"CS"[P(4) @P(4)
-        I PSIVAC'="PN" D ENT^PSIVCAL K %DT S X=P(2),%DT="RTX" D ^%DT S P(2)=+Y D ENSTOP^PSIVCAL K %DT S X=P(3),%DT="RTX" D ^%DT S P(3)=+Y
-OTYP    ; Get order type, display type.
-        S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3) S:PSIVAC'="CF" P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I")
-        Q
-        ;
-C       ; Edit Chemo order
-        N DIR S DIR(0)="SA^A:ADMIXTURE;P:PIGGYBACK;S:SYRINGE",DIR("A")="CHEMOTHERAPY TYPE: " D DIRQ,^DIR S:$D(DTOUT)!(X=U) DONE=1 Q:$E(X)="^"!(DONE)  S P(23)=Y D:P(23)["S" S
-        Q
-        ;
-S       ; Edit Syringe order
-56      ; Intermittent Syringe
-        N DIR S DIR(0)="Y",DIR("??")="^S F1=53.1,F2=56 D ENHLP^PSIVORC1",DIR("A")="INTERMITTENT SYRINGE" D ^DIR Q:$D(DIRUT)  S P(5)=Y
-        ;
-55      ; Syringe Size
-        N DA,DIR S DIR(0)="53.1,55" D ^DIR I $D(DTOUT)!$D(DUOUT) S DONE=1 Q
-        S P("SYRS")=Y
-        Q
-        ;
-DIRQ    ; Set DIR("?") for IV Type prompt.
-        S DIR("?")="Enter a code from the list above.",DIR("??")="^S F1=55.01,F2="_$S(DIR("A")["CHEMO":106,1:.04)_" D ENHLP^PSIVORC1"
-        S DIR("?",1)="CHOOSE FROM:",Y=$P(DIR(0),U,2) F X=1:1:5 S DIR("?",X+1)="              "_$P($P(Y,";",X),":")_"    "_$P($P(Y,";",X),":",2)
-        Q
-        ;
-CKFLDS  ; Find required fields missing data.
-        NEW PSIVASX,PSIVASY,FIL,DRGTMP
-        S EDIT="" F PSIVASX="AD","SOL" D
-        .I '$D(DRG(PSIVASX)) S EDIT=EDIT_U_$S(PSIVASX="AD":57,1:58) Q
-        .S DNE=0 F PSIVASY=0:0 S PSIVASY=$O(DRG(PSIVASX,PSIVASY)) Q:'PSIVASY!DNE  D
-        .. I $P(DRG(PSIVASX,PSIVASY),U,3)="" S EDIT=EDIT_U_$S(PSIVASX="AD":57,1:58),DNE=1
-        S:'P("MR") EDIT=EDIT_U_3 F X=8,6,2,3 I P(X)="" S EDIT=EDIT_U_$S(X=8:59,X=6:1,X=2:10,X=3:25,1:"")
-        I P("DTYP")=1 S:P(9)="" EDIT=EDIT_U_26 S:P(11)="" EDIT=EDIT_U_39
-        S:$E(EDIT,1)=U EDIT=$E(EDIT,2,999)
-        Q
-        ;
-DONE    ; Kill variables and exit
-        K ACTION,AD,DFN,DNE,DONE,DONE1,DRG,DRGI,DRGN,DRGT,DRGTN,EDIT,ERR,F1,F2,FIL,HDT,J,LN,LN2,ND,ON,ON1,ON55,ORIFN,P,P16,PC,PDM,PG,PN,PNME,PNOW,PSGLMT,PSGODDD
-        K PSGSS,PSGSSH,PSIV,PSIVAC,PSIVAT,PSIVCV,PSIVE,PSIVHD,PSIVLN,PSIVOK,PSIVOLD,PSIVORUT,PSIVREA,PSIVSC1,PSIVSTR,PSIVSTRT,PSIVTYPE,PSIVUP,PSIVX,PSIVX1
-        K PSJIVORF,PSJORF,PSJORIFN,PSJORL,PSJORNP,PSJORPF,PSJORSTS,PSJIVOF,PSJNKF,PSJORD,RB,RF,SOL,STOP,TYP,UL80,WD,WDN,WG,^TMP("PSIV",$J) D ENIVKV^PSGSETU
-        Q
-ENHLP   ; order entry fields' help
-        N PSJHP,PSJX,PSJD
-        ; From within this routine, F1 and F2 will refer to file 53.1,field 56, file 55.01,field 106, or file 55.01,field .04
-        D FIELD^DID(F1,F2,"","HELP-PROMPT","PSJHP")
-        I X="?",$D(PSJHP("HELP-PROMPT")) S F=$G(PSJHP("HELP-PROMPT")) W !?5 F F0=1:1:$L(F," ") S F3=$P(F," ",F0) W:$L(F3)+$X>78 !?5 W F3_" "
-        ;
-        W:$D(^DD(F1,F2,12)) !,"("_^(12)_")" D FIELD^DID(F1,F2,"","XECUTABLE HELP","PSJX") I $D(PSJX("XECUTABLE HELP")) X PSJX("XECUTABLE HELP")
-        ;
-        ; new code
-        D FIELD^DID(F1,F2,"","DESCRIPTION","PSJD")
-        G:$S($G(X)="?":1,1:'$O(PSJD("DESCRIPTION",0))) SC F F=0:0 S F=$O(PSJD("DESCRIPTION",F)) Q:'F  I $D(PSJD("DESCRIPTION",F)) W !?2,PSJD("DESCRIPTION",F)
-SC      ;
-        I F2=5!(F2=6) W !,"CHOOSE FROM:",!?8,0,?16,"NO",!?8,1,?16,"YES" Q
-        Q
-COMPLTE ;
-        S P16=0,PSIVEXAM=1,(PSIVNOL,PSIVCT)=1 D GTOT^PSIVUTL(P(4)) D ^PSIVCHK I $D(DUOUT) W $C(7),!,"Order Unchanged.",! Q
-        G:'$D(PSIVFN1) EDIT1
-        I ERR=1 S Y=0 G EDIT1
-        D CKORD^PSIVORC2 I PSIVCHG D NOW^%DTC S P("LOG")=$E(%,1,12),P("CLRK")=DUZ_U_$P($G(^VA(200,DUZ,0)),U),P("INS")=""
-        W ! D ^PSIVORLB K PSIVEXAM S Y=P(2)
-        W !,"Start date: " X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),?30," Stop date: " S Y=P(3) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),!
-EDIT    ;
-        I ERR=1 W !,"Please re-edit this order" K DIR S DIR(0)="E" D ^DIR K DIR W:'Y $C(7),"order unchanged." Q:'Y  S Y=0 G EDIT1
-        ;PSJ*5*157 EFD FOR IV
-        D EFDIV^PSJUTL($G(ZZND))
-        W:$G(PSIVCHG) !,"*** This change will cause a new order to be created. ***"
-        K DIR S DIR(0)="Y",DIR("A")="Is this O.K.",DIR("B")=$S(ERR:"NO",1:"YES"),DIR("?",1)="Enter ""Y"" to make this an active order (only allowed if no errors were"
-        S DIR("?")="found in order), ""N"" to edit the order, or ""^"" to leave order unchanged.",DIR("??")="^S HELP=""EDIT"" D ^PSIVHLP"
-        D ^DIR K DIR I $D(DIRUT) K DIRUT W $C(7),"Order unchanged." Q
-        ;*  Kill Unit dose variables when calling from ^PSJLIFNI.
-        I +Y,$G(PSJLIFNI) D
-        . K ND,ND4,ND6,NDP2
-        . K PSGAT,PSGCANFL,PSGDI,PSGDO,PSGDT,PSGEB,PSGEBN,PSGEFN,PSGFD,PSGFDN
-        . K PSGHSM,PSGLI,PSGLIN,PSGLMT,PSGMR,PSGMRN,PSGNEDFD,PSGNEF,PSGNEFD
-        . K PSGNESD,PSGOAT,PSGODO,PSGODT,PSGEA,PSGOEAV,PSGOEEF
-        . K PSGOEEWF,PSGOEEG,PSGOEF,PSGOENG,PSGOES,PSGOFD,PSGOFDN,PSGOHSM
-        . K PSGOINST,PSGOMR,PSGOMRN,PSGONC
-        . K PSGOPD,PSOPDN,PSGOPR,PSGOPRN,PSGOSD,PSGOSDN,PSGOSI,PSGOSM
-        . K PSGOST,PSGOSTN
-        . K PSGPD,PSGPDN,PSGPDRG,PSGDRGN,PSGPFLG,PSGPI,PSGPR,PSGPRIO,PSGPRN
-        . K PSGPTMP,PSGRRF,PSG0XT,PSGS0Y,PSGSCH,PSGSD,PSGSDN,PSGSI,PSGSM
-        . K PSGST,PSGSTAT,PSGSTN,PSJACNWP,PSJACOK,PSJCOI
-EDIT1   ;
-        NEW XFLG,PSIVY S PSIVY=Y
-        NEW X S X=^TMP("PSJI",$J,0),VALMBG=$S((X<17):1,1:(X-(X#16)))
-        I PSIVY=0!'$G(PSIVFN1) S PSIVFN1=1 D EN^VALM("PSJ LM IV AC/EDIT") Q
-        S PSIVCHG=0 D EDCHK^PSIVORC2 K PSIVCHG
-        S VALMBCK="Q",PSIVACEP=1
-        Q
+PSIVORC1 ;BIR/MLM-PROCESS INCOMPLETE IV ORDER - CONT ;13 Jan 98 / 11:36 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**1,37,69,110,157**;16 DEC 97
+ ;
+ ; Reference to ^DD("DD" is supported by DBIA 10017.
+ ; Reference to ^DD( is supported by DBIA 2255.
+ ; Reference to ^VA(200 is supported by DBIA 10060.
+ ; Reference to ^%DT is supported by DBIA 10003.
+ ; Reference to ^%DTC is supported by DBIA 10000.
+ ; Reference to ^DID is supported by DBIA 2052.
+ ; Reference to ^VALM is supported by DBIA 10118.
+ ;
+53 ; IV Type
+ ;*S DONE=0 N DIR S DIR(0)="SNA^A:ADMIXTURE;C:CHEMOTHERAPY;"_$S($E(PSIVAC)'["C":"H:HYPERAL;",1:"")_"P:PIGGYBACK;S:SYRINGE",DIR("A")="IV TYPE: "
+ S DONE=0 N DIR S DIR(0)="SNA^A:ADMIXTURE;C:CHEMOTHERAPY;H:HYPERAL;P:PIGGYBACK;S:SYRINGE",DIR("A")="IV TYPE: "
+ I $G(P("RES"))'="R" S:P(4)]"" DIR("B")="ADMIXTURE",P(4)=""
+ D DIRQ,^DIR S:$D(DTOUT)!(X="^") DONE=1 Q:DONE  G:$E(X)="^" 53 S P(4)=Y D:"CS"[P(4) @P(4)
+ I PSIVAC'="PN" D ENT^PSIVCAL K %DT S X=P(2),%DT="RTX" D ^%DT S P(2)=+Y D ENSTOP^PSIVCAL K %DT S X=P(3),%DT="RTX" D ^%DT S P(3)=+Y
+OTYP ; Get order type, display type.
+ S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3) S:PSIVAC'="CF" P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I")
+ Q
+ ;
+C ; Edit Chemo order
+ N DIR S DIR(0)="SA^A:ADMIXTURE;P:PIGGYBACK;S:SYRINGE",DIR("A")="CHEMOTHERAPY TYPE: " D DIRQ,^DIR S:$D(DTOUT)!(X=U) DONE=1 Q:$E(X)="^"!(DONE)  S P(23)=Y D:P(23)["S" S
+ Q
+ ;
+S ; Edit Syringe order
+56 ; Intermittent Syringe
+ N DIR S DIR(0)="Y",DIR("??")="^S F1=53.1,F2=56 D ENHLP^PSIVORC1",DIR("A")="INTERMITTENT SYRINGE" D ^DIR Q:$D(DIRUT)  S P(5)=Y
+ ;
+55 ; Syringe Size
+ N DA,DIR S DIR(0)="53.1,55" D ^DIR I $D(DTOUT)!$D(DUOUT) S DONE=1 Q
+ S P("SYRS")=Y
+ Q
+ ;
+DIRQ ; Set DIR("?") for IV Type prompt.
+ S DIR("?")="Enter a code from the list above.",DIR("??")="^S F1=55.01,F2="_$S(DIR("A")["CHEMO":106,1:.04)_" D ENHLP^PSIVORC1"
+ S DIR("?",1)="CHOOSE FROM:",Y=$P(DIR(0),U,2) F X=1:1:5 S DIR("?",X+1)="              "_$P($P(Y,";",X),":")_"    "_$P($P(Y,";",X),":",2)
+ Q
+ ;
+CKFLDS ; Find required fields missing data.
+ NEW PSIVASX,PSIVASY,FIL,DRGTMP
+ S EDIT="" F PSIVASX="AD","SOL" D
+ .I '$D(DRG(PSIVASX)) S EDIT=EDIT_U_$S(PSIVASX="AD":57,1:58) Q
+ .S DNE=0 F PSIVASY=0:0 S PSIVASY=$O(DRG(PSIVASX,PSIVASY)) Q:'PSIVASY!DNE  D
+ .. I $P(DRG(PSIVASX,PSIVASY),U,3)="" S EDIT=EDIT_U_$S(PSIVASX="AD":57,1:58),DNE=1
+ .. ;S FIL=$S(PSIVASX="AD":"52.6",1:"52.7")
+ .. ;S DRGTMP=DRG(PSIVASX,PSIVASY) D ORDERCHK^PSIVEDRG(DFN)
+ S:'P("MR") EDIT=EDIT_U_3 F X=8,6,2,3 I P(X)="" S EDIT=EDIT_U_$S(X=8:59,X=6:1,X=2:10,X=3:25,1:"")
+ I P("DTYP")=1 S:P(9)="" EDIT=EDIT_U_26 S:P(11)="" EDIT=EDIT_U_39
+ S:$E(EDIT,1)=U EDIT=$E(EDIT,2,999)
+ Q
+ ;
+DONE ; Kill variables and exit
+ K ACTION,AD,DFN,DNE,DONE,DONE1,DRG,DRGI,DRGN,DRGT,DRGTN,EDIT,ERR,F1,F2,FIL,HDT,J,LN,LN2,ND,ON,ON1,ON55,ORIFN,P,P16,PC,PDM,PG,PN,PNME,PNOW,PSGLMT,PSGODDD
+ K PSGSS,PSGSSH,PSIV,PSIVAC,PSIVAT,PSIVCV,PSIVE,PSIVHD,PSIVLN,PSIVOK,PSIVOLD,PSIVORUT,PSIVREA,PSIVSC1,PSIVSTR,PSIVSTRT,PSIVTYPE,PSIVUP,PSIVX,PSIVX1
+ K PSJIVORF,PSJORF,PSJORIFN,PSJORL,PSJORNP,PSJORPF,PSJORSTS,PSJIVOF,PSJNKF,PSJORD,RB,RF,SOL,STOP,TYP,UL80,WD,WDN,WG,^TMP("PSIV",$J) D ENIVKV^PSGSETU
+ Q
+ENHLP ; order entry fields' help
+ N PSJHP,PSJX,PSJD
+ ;
+ D FIELD^DID(F1,F2,"","HELP-PROMPT","PSJHP")
+ I X="?",$D(PSJHP("HELP-PROMPT")) S F=$G(PSJHP("HELP-PROMPT")) W !?5 F F0=1:1:$L(F," ") S F3=$P(F," ",F0) W:$L(F3)+$X>78 !?5 W F3_" "
+ ;I X="?",$D(^DD(F1,F2,3)) S F=^(3) W !?5 F F0=1:1:$L(F," ") S F3=$P(F," ",F0) W:$L(F3)+$X>78 !?5 W F3_" "
+ ;
+ W:$D(^DD(F1,F2,12)) !,"("_^(12)_")" D FIELD^DID(F1,F2,"","XECUTABLE HELP","PSJX") I $D(PSJX("XECUTABLE HELP")) X PSJX("XECUTABLE HELP")
+ ;
+ ; new code
+ D FIELD^DID(F1,F2,"","DESCRIPTION","PSJD")
+ G:$S($G(X)="?":1,1:'$O(PSJD("DESCRIPTION",0))) SC F F=0:0 S F=$O(PSJD("DESCRIPTION",F)) Q:'F  I $D(PSJD("DESCRIPTION",F)) W !?2,PSJD("DESCRIPTION",F)
+SC ;
+ I F2=5!(F2=6) W !,"CHOOSE FROM:",!?8,0,?16,"NO",!?8,1,?16,"YES" Q
+ Q
+COMPLTE ;
+ S P16=0,PSIVEXAM=1,(PSIVNOL,PSIVCT)=1 D GTOT^PSIVUTL(P(4)) D ^PSIVCHK I $D(DUOUT) W $C(7),!,"Order Unchanged.",! Q
+ G:'$D(PSIVFN1) EDIT1
+ I ERR=1 S Y=0 G EDIT1
+ D CKORD^PSIVORC2 I PSIVCHG D NOW^%DTC S P("LOG")=$E(%,1,12),P("CLRK")=DUZ_U_$P($G(^VA(200,DUZ,0)),U),P("INS")=""
+ W ! D ^PSIVORLB K PSIVEXAM S Y=P(2)
+ W !,"Start date: " X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),?30," Stop date: " S Y=P(3) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),!
+EDIT ;
+ I ERR=1 W !,"Please re-edit this order" K DIR S DIR(0)="E" D ^DIR K DIR W:'Y $C(7),"order unchanged." Q:'Y  S Y=0 G EDIT1
+ ;PSJ*5*157 EFD FOR IV
+ D EFDIV^PSJUTL($G(ZZND))
+ W:$G(PSIVCHG) !,"*** This change will cause a new order to be created. ***"
+ K DIR S DIR(0)="Y",DIR("A")="Is this O.K.",DIR("B")=$S(ERR:"NO",1:"YES"),DIR("?",1)="Enter ""Y"" to make this an active order (only allowed if no errors were"
+ S DIR("?")="found in order), ""N"" to edit the order, or ""^"" to leave order unchanged.",DIR("??")="^S HELP=""EDIT"" D ^PSIVHLP"
+ D ^DIR K DIR I $D(DIRUT) K DIRUT W $C(7),"Order unchanged." Q
+ ;*  Kill Unit dose variables when calling from ^PSJLIFNI.
+ I +Y,$G(PSJLIFNI) D
+ . K ND,ND4,ND6,NDP2
+ . K PSGAT,PSGCANFL,PSGDI,PSGDO,PSGDT,PSGEB,PSGEBN,PSGEFN,PSGFD,PSGFDN
+ . K PSGHSM,PSGLI,PSGLIN,PSGLMT,PSGMR,PSGMRN,PSGNEDFD,PSGNEF,PSGNEFD
+ . K PSGNESD,PSGOAT,PSGODO,PSGODT,PSGEA,PSGOEAV,PSGOEEF
+ . K PSGOEEWF,PSGOEEG,PSGOEF,PSGOENG,PSGOES,PSGOFD,PSGOFDN,PSGOHSM
+ . K PSGOINST,PSGOMR,PSGOMRN,PSGONC
+ . K PSGOPD,PSOPDN,PSGOPR,PSGOPRN,PSGOSD,PSGOSDN,PSGOSI,PSGOSM
+ . K PSGOST,PSGOSTN
+ . K PSGPD,PSGPDN,PSGPDRG,PSGDRGN,PSGPFLG,PSGPI,PSGPR,PSGPRIO,PSGPRN
+ . K PSGPTMP,PSGRRF,PSG0XT,PSGS0Y,PSGSCH,PSGSD,PSGSDN,PSGSI,PSGSM
+ . K PSGST,PSGSTAT,PSGSTN,PSJACNWP,PSJACOK,PSJCOI
+EDIT1 ;
+ NEW XFLG,PSIVY S PSIVY=Y
+ NEW X S X=^TMP("PSJI",$J,0),VALMBG=$S((X<17):1,1:(X-(X#16)))
+ I PSIVY=0!'$G(PSIVFN1) S PSIVFN1=1 D EN^VALM("PSJ LM IV AC/EDIT") Q
+ S PSIVCHG=0 D EDCHK^PSIVORC2 K PSIVCHG
+ S VALMBCK="Q",PSIVACEP=1
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVOREN.m

@@ -1 @@
-PSIVOREN        ;BIR/MLM-UTILITIES FOR IV FLUIDS - OE/RR INTERFACE ; 25 Sep 98 / 2:00 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**3,18,69,110,127,133,140,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(55 is supported by DBIA 2191.
-        ; Reference to ^VA(200 is supported by DBIA 10060.
-        ; Reference to ^DIE is supported by DBIA 10018.
-        ;
-ENCPP   ; Check Package Parameter
-        D ORPARM I 'PSJORF W !!,"Inpatient Medications is not turned on for OE/RR.",!,"You will not be able to enter or edit IV or Unit Dose orders."
-        I 'PSJIVORF W !!,"IV Medications is not turned on for OE/RR.",!,"You will not be able to enter or edit IV orders."
-        I 'PSJORF!'PSJIVORF S PSJIVORF="" D DONE^PSIVORA1 Q
-        S PSJORL=$G(VAIN(4)) I 'PSJORL,$G(DFN) D INP^VADPT S PSJORL=$G(VAIN(4))
-        S PSJORPF=0,P("OT")="F^",PSJORNP=$S($G(PSJORNP):PSJORNP,1:+$G(DUZ))
-        Q
-        ;
-PS      ; Check if MD is authorized to write med. orders.
-        S PSJORPF=0 S:PSJORNP X=$G(^VA(200,+PSJORNP,"PS")) Q:$S('PSJORNP:0,'X:0,'$P(X,U,4):1,$P(X,U,4)>DT:1,1:0)  D
-        .W !?2,"(The selected PROVIDER is NOT qualified to write MEDICATION orders.  You must",!,"select a valid provider to be able to continue with Inpatient Medications.)"
-        .K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Select PHARMACY PROVIDER: ",DIC("S")="S PSIV=$G(^(""PS"")) I PSIV,$S($P(PSIV,""^"",4)="""":1,DT<$P(PSIV,""^"",4):1,1:0)" F  W ! D ^DIC Q:$D(DUOUT)!$D(DTOUT)!(Y>0)  W $C(7),"  (Required.)"
-        .K DIC S:Y'>0 PSJORPF=11 S:Y>0 PSJORNP=+Y Q
-        K DTOUT
-        Q
-        ;
-RUPDATE(DFN,ON,NSTRT)   ;
-        ; Update renewal orders (called from Pharmacy options).
-        N DA,DIE,DR,ND,NSTOP,OSTOP,NOO,ORETURN,PSIVACT,PSIVAL,PSIVALCK,PSJOSTRT,PSGOLDOE S DIE="^PS(55,"_DFN_","
-        I ON["P" S OLDON=$P($G(^PS(53.1,+ON,0)),"^",25),NOO=$P($G(^PS(53.1,+ON,.2)),"^",3)
-        I ON["V" S OLDON=ON,NOO=$P($G(^PS(55,DFN,"IV",+ON,.2)),"^",5)
-        I ON["U" S OLDON=$P($G(^PS(55,DFN,5,+ON,0)),U,25)
-        I OLDON["P" S OLDON=$P($G(^PS(53.1,+OLDON,0)),U,25)
-        I OLDON["V" S ON55=OLDON,X=$G(^PS(55,DFN,"IV",+OLDON,2)),PSJOSTRT=$P(X,U,7),OSTOP=$S(($G(PSJOSTOP)>PSJOSTRT):PSJOSTOP,1:$P($G(^(0)),U,3)),DIE=DIE_"""IV"",",DR="100////A",PSIVACT=1
-        I OLDON["U" S X=$G(^PS(55,DFN,5,+OLDON,2)),PSJOSTRT=$P(X,U,7),OSTOP=$P(X,U,4),DIE=DIE_"5,"
-        S NSTOP=+$S($G(P(3)):P(3),1:0),DA=+OLDON,DA(1)=DFN I 'NSTOP W !,"CAN'T RENEW THIS ORDER!" D PAUSE^VALM1 Q
-        ;
-        I ON["V"!(ON["P") D EXPOE^PSGOER(DFN,ON)
-        ;
-        S DR=DR_";"_$S(OLDON["V":.03,OLDON["U":34,1:25)_"////"_NSTOP_";"_$S(OLDON["V":"114////@;123////@",1:"105////@;107////@") S:+$G(P(6))?1.30N DR=DR_";.06////"_+P(6) D ^DIE
-        I ON["P" S DIE="^PS(53.1,",DR="28////A;105////@;",DA=+ON D ^DIE D
-        .I $G(OLDON)["V" S PSGOLDOE=$P($G(^PS(55,DFN,"IV",+OLDON,0)),"^",21)
-        .N NOEORD,VN,VNDT S NOEORD=$P(^PS(53.1,+ON,0),U,21) S VN=$P($G(^PS(53.1,+ON,4)),"^") I VN S VNDT=$P($G(^PS(53.1,+ON,4)),"^",2)
-        .I NOEORD K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IV"",",DA(1)=DFN,DA=+ON55,DR="110////"_+NOEORD D
-        ..S DR=DR_";16////"_$S($G(VN):VN,1:"@")_";17////"_$S($G(VNDT):VNDT,1:"@")_";" D ^DIE I NOEORD[";" S $P(^PS(53.1,+ON,0),U,21)=NOEORD
-        ..I $G(VN) D EN1^PSJHL2(DFN,"ZV",ON55)
-        I ON["V" S DIE="^PS(55,DFN,""IV"",",DR="100////A;114////@;16////@;17////@" S DA=+ON55 D ^DIE
-        N RDT S RDT=$P($G(@("^PS(53.1,"_+ON_",14,0)")),U,3) S:RDT RDT=+(^(RDT,0)) S RDT=$S(RDT:RDT,1:$$DATE^PSJUTL2) I RDT D UPDREN^PSIVOPT2(DFN,OLDON,RDT,+P(6),+$G(OSTOP),$G(NOO))
-        ;
-        I ON["V" D EN1^PSJHL2(DFN,"SN",ON,"NEW ORDER CREATED")
-        I OLDON["V" S (ON,ON55)=OLDON,PSIVAL="",PSIVALCK="STOP",(P("FRES"),PSIVREA)="R" D LOG^PSIVORAL D
-        .I $G(ON55),$G(OSTOP),$G(DFN) D STIX(OSTOP,OLDON,DFN)
-        .;Add check to If statement below. If New Stop date ='s the old Stop Don't delete AIV x-ref (NSTOP'=PSJOSTOP)
-        .I $G(PSJOSTOP),$G(NSTOP) I NSTOP=$P($G(^PS(55,DFN,"IV",+ON55,0)),"^",3),$D(^PS(55,"AIV",NSTOP,DFN,+ON55)),NSTOP'=PSJOSTOP K ^PS(55,"AIV",PSJOSTOP,DFN,+ON55)
-        D:'$D(PSJIVORF) ORPARM Q:'PSJIVORF
-        Q
-        ;
-RUPTXT(DFN,OLDON)       ;
-        ;Update ORTX( in OE/RR
-        I OLDON'["V" ;; D ENUDTX^PSJOREN(DFN,OLDON,"OR") S ORIFN=$P($G(^PS(55,DFN,"IV",+OLDON,0)),U,21)
-        I OLDON["V" S P("FRES")="R" D GTPC^PSIVORFB(OLDON),SORTX^PSIVORFE S ORIFN=$P($G(^PS(55,DFN,"IV",+OLDON,0)),U,21)
-        Q
-        ;
-ORPARM  ;Check if inpatient pkges are on.
-        S (PSJORF,PSJIVORF)=1
-        Q
-        ;
-NATURE  ; Ask nature of order.
-        Q:$G(PSJDCTYP)=2
-        I '+$G(PSJSYSU) S P("NAT")="W" Q
-        K P("NAT") NEW X
-        I $D(XQORNOD(0)) S X=$E($P(XQORNOD(0),U,3),1,1) S:X="" X="E"
-        S:'$D(X) X="N" S:"AF"[X X="E"
-        I $G(PSIVCOPY) S X="N"
-        S P("NAT")=$$ENNOO^PSJUTL5(X)
-        K:P("NAT")=-1 P("NAT")
-        Q
-CLINIC  ;Ask clinic where outpt is being seen for DSS
-        K P("CLIN") NEW X1,X2,X,PSJDT,DIC,Y
-        S X1=DT,X2=-7 D C^%DTC S PSJDT=X
-        S DIC("S")="I $P($G(^SC(Y,0)),U,3)=""C"",$S('$P($G(^(""I"")),U):1,($P($G(^(""I"")),U)>PSJDT):1,(($P($G(^(""I"")),U)<PSJDT)&($P($G(^(""I"")),U,2)]"""")&(DT>$P($G(^(""I"")),U,2))):1,1:0)"
-        S DIC=44,DIC(0)="QEAZ",DIC("A")="Select CLINIC LOCATION: " D ^DIC
-        I $S($D(DTOUT):1,$D(DUOUT):1,1:0) Q
-        S:+Y>0 P("CLIN")=+Y,$P(^PS(55,DFN,"IV",+ON55,"DSS"),"^")=+Y
-        Q
-        ;
-STIX(OST,OON,DFN)       ; Check start index, cleanup old start
-        I $G(OST),$G(OON) S OS="" F  S OS=$O(^PS(55,DFN,"IV","AIS",OS)) Q:'OS  D
-        . Q:'$D(^PS(55,DFN,"IV","AIS",OS,+OON))
-        . I $P($G(^PS(55,DFN,"IV",+OON,0)),"^",3)'=OS K ^PS(55,DFN,"IV","AIS",OS,+OON)
-        Q
+PSIVOREN ;BIR/MLM-UTILITIES FOR IV FLUIDS - OE/RR INTERFACE ; 25 Sep 98 / 2:00 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**3,18,69,110,127,133,140**;16 DEC 97
+ ;
+ ; Reference to ^PS(55 is supported by DBIA 2191.
+ ; Reference to ^VA(200 is supported by DBIA 10060.
+ ; Reference to ^DIE is supported by DBIA 10018.
+ ;
+ENCPP ; Check Package Parameter
+ D ORPARM I 'PSJORF W !!,"Inpatient Medications is not turned on for OE/RR.",!,"You will not be able to enter or edit IV or Unit Dose orders."
+ I 'PSJIVORF W !!,"IV Medications is not turned on for OE/RR.",!,"You will not be able to enter or edit IV orders."
+ I 'PSJORF!'PSJIVORF S PSJIVORF="" D DONE^PSIVORA1 Q
+ S PSJORL=$G(VAIN(4)) I 'PSJORL,$G(DFN) D INP^VADPT S PSJORL=$G(VAIN(4))
+ S PSJORPF=0,P("OT")="F^",PSJORNP=$S($G(PSJORNP):PSJORNP,1:+$G(DUZ))
+ ;; S PSJORL=ORL,PSJORPF=0,P("OT")="F^"_$O(^ORD(101,"B","PSJI OR PAT FLUID OE",0))_";ORD(101,",PSJORNP=ORNP
+ Q
+ ;
+PS ; Check if MD is authorized to write med. orders.
+ S PSJORPF=0 S:PSJORNP X=$G(^VA(200,+PSJORNP,"PS")) Q:$S('PSJORNP:0,'X:0,'$P(X,U,4):1,$P(X,U,4)>DT:1,1:0)  D
+ .W !?2,"(The selected PROVIDER is NOT qualified to write MEDICATION orders.  You must",!,"select a valid provider to be able to continue with Inpatient Medications.)"
+ .K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Select PHARMACY PROVIDER: ",DIC("S")="S PSIV=$G(^(""PS"")) I PSIV,$S($P(PSIV,""^"",4)="""":1,DT<$P(PSIV,""^"",4):1,1:0)" F  W ! D ^DIC Q:$D(DUOUT)!$D(DTOUT)!(Y>0)  W $C(7),"  (Required.)"
+ .K DIC S:Y'>0 PSJORPF=11 S:Y>0 PSJORNP=+Y Q
+ K DTOUT
+ Q
+ ;
+RUPDATE(DFN,ON,NSTRT) ;
+ ; Update renewal orders (called from Pharmacy options).
+ N DA,DIE,DR,ND,NSTOP,OSTOP,NOO,ORETURN,PSIVACT,PSIVAL,PSIVALCK,PSJOSTRT,PSGOLDOE S DIE="^PS(55,"_DFN_","
+ I ON["P" S OLDON=$P($G(^PS(53.1,+ON,0)),"^",25),NOO=$P($G(^PS(53.1,+ON,.2)),"^",3)
+ I ON["V" S OLDON=ON,NOO=$P($G(^PS(55,DFN,"IV",+ON,.2)),"^",5)
+ I ON["U" S OLDON=$P($G(^PS(55,DFN,5,+ON,0)),U,25)
+ I OLDON["P" S OLDON=$P($G(^PS(53.1,+OLDON,0)),U,25)
+ I OLDON["V" S ON55=OLDON,X=$G(^PS(55,DFN,"IV",+OLDON,2)),PSJOSTRT=$P(X,U,7),OSTOP=$S(($G(PSJOSTOP)>PSJOSTRT):PSJOSTOP,1:$P($G(^(0)),U,3)),DIE=DIE_"""IV"",",DR="100////A",PSIVACT=1
+ I OLDON["U" S X=$G(^PS(55,DFN,5,+OLDON,2)),PSJOSTRT=$P(X,U,7),OSTOP=$P(X,U,4),DIE=DIE_"5,"
+ S NSTOP=+$S($G(P(3)):P(3),1:0),DA=+OLDON,DA(1)=DFN I 'NSTOP W !,"CAN'T RENEW THIS ORDER!" D PAUSE^VALM1 Q
+ ;I OSTOP>NSTOP W !,"NEW STOP DATE IS LESS THAN PREVIOUS STOP DATE" D PAUSE^VALM1
+ ;
+ I ON["V"!(ON["P") D EXPOE^PSGOER(DFN,ON)
+ ;
+ S DR=DR_";"_$S(OLDON["V":.03,OLDON["U":34,1:25)_"////"_NSTOP_";"_$S(OLDON["V":"114////@;123////@",1:"105////@;107////@") S:+$G(P(6))?1.30N DR=DR_";.06////"_+P(6) D ^DIE
+ I ON["P" S DIE="^PS(53.1,",DR="28////A;105////@;",DA=+ON D ^DIE D
+ .I $G(OLDON)["V" S PSGOLDOE=$P($G(^PS(55,DFN,"IV",+OLDON,0)),"^",21)
+ .N NOEORD,VN,VNDT S NOEORD=$P(^PS(53.1,+ON,0),U,21) S VN=$P($G(^PS(53.1,+ON,4)),"^") I VN S VNDT=$P($G(^PS(53.1,+ON,4)),"^",2)
+ .I NOEORD K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IV"",",DA(1)=DFN,DA=+ON55,DR="110////"_+NOEORD D
+ ..S DR=DR_";16////"_$S($G(VN):VN,1:"@")_";17////"_$S($G(VNDT):VNDT,1:"@")_";" D ^DIE I NOEORD[";" S $P(^PS(53.1,+ON,0),U,21)=NOEORD
+ ..I $G(VN) D EN1^PSJHL2(DFN,"ZV",ON55)
+ I ON["V" S DIE="^PS(55,DFN,""IV"",",DR="100////A;114////@;16////@;17////@" S DA=+ON55 D ^DIE
+ N RDT S RDT=$P($G(@("^PS(53.1,"_+ON_",14,0)")),U,3) S:RDT RDT=+(^(RDT,0)) S RDT=$S(RDT:RDT,1:$$DATE^PSJUTL2) I RDT D UPDREN^PSIVOPT2(DFN,OLDON,RDT,+P(6),+$G(OSTOP),$G(NOO))
+ ;
+ I ON["V" D EN1^PSJHL2(DFN,"SN",ON,"NEW ORDER CREATED")
+ I OLDON["V" S (ON,ON55)=OLDON,PSIVAL="",PSIVALCK="STOP",(P("FRES"),PSIVREA)="R" D LOG^PSIVORAL D
+ .I $G(ON55),$G(OSTOP),$G(DFN) D STIX(OSTOP,OLDON,DFN)
+ .;Add check to If statement below. If New Stop date ='s the old Stop Don't delete AIV x-ref (NSTOP'=PSJOSTOP)
+ .I $G(PSJOSTOP),$G(NSTOP) I NSTOP=$P($G(^PS(55,DFN,"IV",+ON55,0)),"^",3),$D(^PS(55,"AIV",NSTOP,DFN,+ON55)),NSTOP'=PSJOSTOP K ^PS(55,"AIV",PSJOSTOP,DFN,+ON55)
+ D:'$D(PSJIVORF) ORPARM Q:'PSJIVORF
+ Q
+ ;
+RUPTXT(DFN,OLDON) ;
+ ;Update ORTX( in OE/RR
+ I OLDON'["V" ;; D ENUDTX^PSJOREN(DFN,OLDON,"OR") S ORIFN=$P($G(^PS(55,DFN,"IV",+OLDON,0)),U,21)
+ I OLDON["V" S P("FRES")="R" D GTPC^PSIVORFB(OLDON),SORTX^PSIVORFE S ORIFN=$P($G(^PS(55,DFN,"IV",+OLDON,0)),U,21)
+ ;; F X=0:0 S X=$O(ORTX(X)) Q:'X  S ORETURN("ORTX",X)=ORTX(X)
+ Q
+ ;
+ORPARM ;Check if inpatient pkges are on.
+ S (PSJORF,PSJIVORF)=1
+ Q
+ ;
+NATURE ; Ask nature of order.
+ I '+$G(PSJSYSU) S P("NAT")="W" Q
+ K P("NAT") NEW X
+ I $D(XQORNOD(0)) S X=$E($P(XQORNOD(0),U,3),1,1) S:X="" X="E"
+ ;* S:'$D(X) X="N" S:X="A" X="E"
+ S:'$D(X) X="N" S:"AF"[X X="E"
+ I $G(PSIVCOPY) S X="N"
+ S P("NAT")=$$ENNOO^PSJUTL5(X)
+ K:P("NAT")=-1 P("NAT")
+ Q
+CLINIC ;Ask clinic where outpt is being seen for DSS
+ K P("CLIN") NEW X1,X2,X,PSJDT,DIC,Y
+ S X1=DT,X2=-7 D C^%DTC S PSJDT=X
+ S DIC("S")="I $P($G(^SC(Y,0)),U,3)=""C"",$S('$P($G(^(""I"")),U):1,($P($G(^(""I"")),U)>PSJDT):1,(($P($G(^(""I"")),U)<PSJDT)&($P($G(^(""I"")),U,2)]"""")&(DT>$P($G(^(""I"")),U,2))):1,1:0)"
+ S DIC=44,DIC(0)="QEAZ",DIC("A")="Select CLINIC LOCATION: " D ^DIC
+ I $S($D(DTOUT):1,$D(DUOUT):1,1:0) Q
+ S:+Y>0 P("CLIN")=+Y,$P(^PS(55,DFN,"IV",+ON55,"DSS"),"^")=+Y
+ Q
+ ;
+STIX(OST,OON,DFN) ; Check start index, cleanup old start
+ I $G(OST),$G(OON) S OS="" F  S OS=$O(^PS(55,DFN,"IV","AIS",OS)) Q:'OS  D
+ . Q:'$D(^PS(55,DFN,"IV","AIS",OS,+OON))
+ . I $P($G(^PS(55,DFN,"IV",+OON,0)),"^",3)'=OS K ^PS(55,DFN,"IV","AIS",OS,+OON)
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFA.m

@@ -1 @@
-PSIVORFA        ;BIR/MLM-FILE/RETRIEVE ORDERS IN 53.1 ;26 Jun 98 / 9:16 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**4,7,18,28,50,71,58,91,80,110,111,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(51.1 supported by DBIA 2177.
-        ; Reference to ^PS(51.2 supported by DBIA 2178.
-        ; Reference to ^PS(52.7 supported by DBIA 2173.
-        ; Reference to ^PS(52.6 supported by DBIA 1231.
-        ;
-GT531(DFN,ON)   ; Retrieve order data from 53.1 and place into local array
-        ;
-        NEW PSGOES S PSGOES=1
-        F X="CUM","LF","LFA","LF","PRNTON" S P(X)=""
-        S Y=$G(^PS(53.1,+ON,0)),P(17)=$P(Y,U,9),P("LOG")=$P(Y,U,16),(P(21),P("21FLG"),PSJORIFN)=$P(Y,U,21)
-        S P("RES")=$P(Y,U,24),P("OLDON")=$P(Y,U,25),P("NEWON")=$P(Y,U,26),P("FRES")=$P(Y,U,27)
-        S P("MR")=$P(Y,U,3),P(6)=+$P(Y,U,2),Y=$G(^VA(200,+P(6),0)),$P(P(6),U,2)=$P(Y,U),Y=$G(^PS(51.2,+P("MR"),0)),$P(P("MR"),U,2)=$S($P(Y,U,3)]"":$P(Y,U,3),1:$P(Y,U))
-        S Y=$G(^PS(53.1,+ON,.2)),P("PD")=$S(+Y:$P(Y,U)_U_$$OIDF^PSJLMUT1(+Y),1:""),P("DO")=$P(Y,U,2),P("NAT")=$P(Y,U,3),P("PRY")=$P(Y,U,4),(PSJCOM,P("PRNTON"))=$P(Y,U,8)
-        S P("INS")=$G(^PS(53.1,+ON,.3))
-        I $G(^PS(53.1,+ON,4))]"" S P("NINIT")=$P(^(4),U),P("NINITDT")=$P(^(4),U,2)
-        NEW NAME S NAME=""
-        I $D(^PS(53.1,+ON,1,1)) D DD^PSJLMUT1("^PS(53.1,+ON,",.NAME)
-        S P("INS")=P("INS")_$S(P("INS")]"":" of ",1:"")_NAME
-        S P("APPT")=$G(^PS(53.1,+ON,"DSS")),P("CLIN")=$P(P("APPT"),"^"),P("APPT")=$P(P("APPT"),"^",2)
-        S Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(11)=$P(Y,U,5),P(15)=$S($P(Y,U,6)'="":$P(Y,U,6),$G(PSGS0XT)'="":PSGS0XT,$P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:""),P(2)=$P(Y,U,2),P(3)=$P(Y,U,4)
-        S Y=$G(^PS(53.1,+ON,4)),P("CLRK")=$P(Y,U,7)_U_$P($G(^VA(200,+$P(Y,U,7),0)),U),P("REN")=$P(Y,U,9),X=P(9)
-        I $P($G(^PS(53.1,+ON,0)),U,7)="P",(P(9)'["PRN") S P(9)=P(9)_" PRN"
-        K PSGST,XT
-        I P(9)]"",(P(11)="") D  S P(15)=$S($G(XT)]""&'+$G(XT):XT,+$G(XT)>0:XT,$G(PSGS0XT):PSGS0XT,1:1440),P(11)=Y
-        . I $O(^PS(51.1,"APPSJ",P(9),0)) D DIC^PSGORS0 Q
-        . I '$O(^PS(51.1,"APPSJ",P(9),0)) N NOECH,PSGSCH S NOECH=1 D EN^PSIVSP
-        S Y=$G(^PS(53.1,+ON,8)),P(4)=$P(Y,U),P(23)=$P(Y,U,2),P("SYRS")=$P(Y,U,3),P(5)=$P(Y,U,4),P(8)=$P(Y,U,5),P(7)=$P(Y,U,7),P("IVRM")=$P(Y,U,8)
-        S P(4)=$S(P(4)'="":P(4),$G(PSIVTYPE):PSIVTYPE,1:"")
-        S:'P("IVRM")&($D(PSIVSN)) P("IVRM")=+PSIVSN S Y=$G(^PS(59.5,+P("IVRM"),0)),$P(P("IVRM"),U,2)=$P(Y,U),Y=$G(^PS(53.1,+ON,9)),P("REM")=$P(Y,U),P("OPI")=$P(Y,U,2,3)
-        S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)
-        S P("PACT")=$G(^PS(53.1,+ON,"A",1,0))
-        D GTDRG,GTOT^PSIVUTL(P(4)) D:'$D(PSJLABEL) GTPC(ON)
-        N ND2P5 S ND2P5=$G(^PS(53.1,+ON,2.5)) D
-        .S P("DUR")=$P(ND2P5,"^",2)
-        .S P("LIMIT")=$P(ND2P5,"^",4)
-        .S P("IVCAT")=$P(ND2P5,"^",5)
-        Q
-GTDRG   ;
-        K DRG F X="AD","SOL" S FIL=$S(X="AD":52.6,1:52.7) F Y=0:0 S Y=$O(^PS(53.1,+ON,X,Y)) Q:'Y  D
-        .S (DRGI,DRG(X,0))=$G(DRG(X,0))+1,DRG=$G(^PS(53.1,+ON,X,Y,0)),ND=$G(^PS(FIL,+DRG,0)),DRGN=$P(ND,U),DRG(X,+DRGI)=+DRG_U_$P(ND,U)_U_$P(DRG,U,2)_U_$P(DRG,U,3)_U_$P(ND,U,13)_U_$P(ND,U,11)
-        Q
-        ;
-GTPC(ON)        ; Retrieve Provider Comments and create "scratch" fields to edit
-        Q
-        ;
-PUT531  ; Move data in local variables to 53.1
-        S:'$D(P(9)) P(9)=$G(PSGSCH)
-        S ND(0)=+ON_U_+P(6)_U_$S(+P("MR"):+P("MR"),1:"")_U_$P(P("OT"),U)_U_U_U_"C",$P(ND(0),U,9)=P(17),$P(ND(0),U,21)=$G(P(21))
-        S $P(ND(0),U,14,16)=P("LOG")_U_DFN_U_P("LOG"),$P(ND(0),U,24,26)=$G(P("RES"))_U_$G(P("OLDON"))_U_$G(P("NEWON"))
-        S ND(2)=P(9)_U_P(2)_U_U_P(3)_U_P(11)_U_$S($G(P(15))'="":P(15),$G(PSGS0XT)'="":PSGS0XT,$P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:""),$P(ND(4),U,7,9)=+P("CLRK")_U_U_P("REN")
-        S ND(8)=P(4)_U_P(23)_U_P("SYRS")_U_P(5)_U_P(8)_"^^"_P(7)_"^"_+P("IVRM"),ND(9)=$S($L(P("REM")_P("OPI")):P("REM")_U_P("OPI"),1:"") S $P(ND(4),U,1,2)=$G(P("NINIT"))_U_$G(P("NINITDT"))
-        S:+$G(P("CLIN")) $P(^PS(53.1,+ON,"DSS"),"^")=P("CLIN")
-        S:+$G(P("APPT")) $P(^PS(53.1,+ON,"DSS"),"^",2)=P("APPT")
-        S:$G(P("LIMIT"))]"" $P(^PS(53.1,+ON,2.5),"^",4)=P("LIMIT")
-        I $G(PSJORD)["V"!($G(PSJORD)["P") I $G(^PS(53.1,+ON,2.5))="" N DUR S DUR=$$GETDUR^PSJLIVMD(DFN,+PSJORD,$S((PSJORD["P"):"P",1:"IV"),1) I DUR]"" D
-        .I $G(IVLIMIT) S $P(^PS(53.1,+ON,2.5),"^",4)=DUR K IVLIMIT Q
-        .S $P(^PS(53.1,+ON,2.5),"^",2)=DUR
-        F X=0,2,4,8,9 S ^PS(53.1,+ON,X)=ND(X)
-        S PSIVCAT=$$IVCAT^PSJHLU(DFN,ON,.P) S:PSIVCAT]"" $P(^PS(53.1,+ON,2.5),"^",5)=PSIVCAT K PSIVCAT
-        S:'+$G(^PS(53.1,+ON,.2)) $P(^(.2),U,1,3)=+P("PD")_U_P("DO")_U_$G(P("NAT"))
-        F DRGT="AD","SOL" D:$D(DRG(DRGT)) PTD531
-        K DA,DIK S PSGS0Y=P(11),PSGS0XT=P(15),DA=+ON,DIK="^PS(53.1," D IX^DIK K DA,DIK,PSGS0Y,PSGS0XT,ND,^PS(53.1,"AS","P",DFN,+ON)
-        K:P(17)="A" ^PS(53.1,"AS","N",DFN,+ON)
-        S:P(15)="D" $P(^PS(53.1,+ON,2),U,6)="D"
-        Q
-        ;
-UPD100  ; Update order data in file 100
-        D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF
-        S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) D SET^PSIVORFE
-        Q
-        ;
-PTD531  ; Move drug data from local array into 53.1
-        K ^PS(53.1,+ON,DRGT) S ^PS(53.1,+ON,DRGT,0)=$S(DRGT="AD":"^53.157^0^0",1:"^53.158^0^0")
-        F X=0:0 S X=$O(DRG(DRGT,X)) Q:'X  D
-        .S X1=$P(DRG(DRGT,X),U),Y=^PS(53.1,+ON,DRGT,0),$P(Y,U,3)=$P(Y,U,3)+1,DRG=$P(Y,U,3),$P(Y,U,4)=$P(Y,U,4)+1
-        .S ^PS(53.1,+ON,DRGT,0)=Y,Y=+X1_U_$P(DRG(DRGT,X),U,3) S:DRGT="AD" $P(Y,U,3)=$P(DRG(DRGT,X),U,4) S ^PS(53.1,+ON,DRGT,+DRG,0)=Y
-        Q
+PSIVORFA ;BIR/MLM-FILE/RETRIEVE ORDERS IN 53.1 ;26 Jun 98 / 9:16 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**4,7,18,28,50,71,58,91,80,110,111**;16 DEC 97
+ ;
+ ; Reference to ^PS(51.1 supported by DBIA 2177.
+ ; Reference to ^PS(51.2 supported by DBIA 2178.
+ ; Reference to ^PS(52.7 supported by DBIA 2173.
+ ; Reference to ^PS(52.6 supported by DBIA 1231.
+ ;
+GT531(DFN,ON) ; Retrieve order data from 53.1 and place into local array
+ ;
+ NEW PSGOES S PSGOES=1
+ F X="CUM","LF","LFA","LF","PRNTON" S P(X)=""
+ S Y=$G(^PS(53.1,+ON,0)),P(17)=$P(Y,U,9),P("LOG")=$P(Y,U,16),(P(21),P("21FLG"),PSJORIFN)=$P(Y,U,21)
+ S P("RES")=$P(Y,U,24),P("OLDON")=$P(Y,U,25),P("NEWON")=$P(Y,U,26),P("FRES")=$P(Y,U,27)
+ S P("MR")=$P(Y,U,3),P(6)=+$P(Y,U,2),Y=$G(^VA(200,+P(6),0)),$P(P(6),U,2)=$P(Y,U),Y=$G(^PS(51.2,+P("MR"),0)),$P(P("MR"),U,2)=$S($P(Y,U,3)]"":$P(Y,U,3),1:$P(Y,U))
+ S Y=$G(^PS(53.1,+ON,.2)),P("PD")=$S(+Y:$P(Y,U)_U_$$OIDF^PSJLMUT1(+Y),1:""),P("DO")=$P(Y,U,2),P("NAT")=$P(Y,U,3),P("PRY")=$P(Y,U,4),(PSJCOM,P("PRNTON"))=$P(Y,U,8)
+ S P("INS")=$G(^PS(53.1,+ON,.3))
+ I $G(^PS(53.1,+ON,4))]"" S P("NINIT")=$P(^(4),U),P("NINITDT")=$P(^(4),U,2)
+ NEW NAME S NAME=""
+ I $D(^PS(53.1,+ON,1,1)) D DD^PSJLMUT1("^PS(53.1,+ON,",.NAME)
+ S P("INS")=P("INS")_$S(P("INS")]"":" of ",1:"")_NAME
+ S P("APPT")=$G(^PS(53.1,+ON,"DSS")),P("CLIN")=$P(P("APPT"),"^"),P("APPT")=$P(P("APPT"),"^",2)
+ ;;S Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(11)=$P(Y,U,5),P(15)=$P(Y,U,6),Y=$G(^PS(53.1,+ON,4)),P("CLRK")=$P(Y,U,7)_U_$P($G(^VA(200,+$P(Y,U,7),0)),U),P("REN")=$P(Y,U,9),X=P(9)
+ S Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(11)=$P(Y,U,5),P(15)=$P(Y,U,6),P(2)=$P(Y,U,2),P(3)=$P(Y,U,4)
+ S Y=$G(^PS(53.1,+ON,4)),P("CLRK")=$P(Y,U,7)_U_$P($G(^VA(200,+$P(Y,U,7),0)),U),P("REN")=$P(Y,U,9),X=P(9)
+ I $P($G(^PS(53.1,+ON,0)),U,7)="P",(P(9)'["PRN") S P(9)=P(9)_" PRN"
+ K PSGST,XT
+ I P(9)]"",(P(11)="") D  S P(15)=$S($G(XT)]""&'+$G(XT):XT,+$G(XT)>0:XT,1:1440),P(11)=Y
+ . I $O(^PS(51.1,"APPSJ",P(9),0)) D DIC^PSGORS0 Q
+ . I '$O(^PS(51.1,"APPSJ",P(9),0)) N NOECH,PSGSCH S NOECH=1 D EN^PSIVSP
+ S Y=$G(^PS(53.1,+ON,8)),P(4)=$P(Y,U),P(23)=$P(Y,U,2),P("SYRS")=$P(Y,U,3),P(5)=$P(Y,U,4),P(8)=$P(Y,U,5),P(7)=$P(Y,U,7),P("IVRM")=$P(Y,U,8)
+ S:'P("IVRM")&($D(PSIVSN)) P("IVRM")=+PSIVSN S Y=$G(^PS(59.5,+P("IVRM"),0)),$P(P("IVRM"),U,2)=$P(Y,U),Y=$G(^PS(53.1,+ON,9)),P("REM")=$P(Y,U),P("OPI")=$P(Y,U,2,3)
+ S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)
+ S P("PACT")=$G(^PS(53.1,+ON,"A",1,0))
+ ;;D GTDRG,GTOT^PSIVUTL(P(4)) D:'$D(PSJLABEL) GTPC(ON) S (P(2),P(3))="" ;L -^PS(53.1,+ON)
+ D GTDRG,GTOT^PSIVUTL(P(4)) D:'$D(PSJLABEL) GTPC(ON)
+ Q
+GTDRG ;
+ K DRG F X="AD","SOL" S FIL=$S(X="AD":52.6,1:52.7) F Y=0:0 S Y=$O(^PS(53.1,+ON,X,Y)) Q:'Y  D
+ .S (DRGI,DRG(X,0))=$G(DRG(X,0))+1,DRG=$G(^PS(53.1,+ON,X,Y,0)),ND=$G(^PS(FIL,+DRG,0)),DRGN=$P(ND,U),DRG(X,+DRGI)=+DRG_U_$P(ND,U)_U_$P(DRG,U,2)_U_$P(DRG,U,3)_U_$P(ND,U,13)_U_$P(ND,U,11)
+ Q
+ ;
+GTPC(ON) ; Retrieve Provider Comments and create "scratch" fields to edit
+ ;S:'$D(PSIVUP) PSIVUP=+$$GTPCI^PSIVUTL K ^PS(53.45,PSIVUP,4) I $O(^PS(53.1,+ON,12,0)) S %X="^PS(53.1,"_+ON_",12,",%Y="^PS(53.45,"_PSIVUP_",4," D %XY^%RCR
+ Q
+ ;
+PUT531 ; Move data in local variables to 53.1
+ S ND(0)=+ON_U_+P(6)_U_$S(+P("MR"):+P("MR"),1:"")_U_$P(P("OT"),U)_U_U_U_"C",$P(ND(0),U,9)=P(17),$P(ND(0),U,21)=$G(P(21))
+ ;;S $P(ND(0),U,14,16)=P("LOG")_U_DFN_U_P("LOG"),$P(ND(0),U,21)=$S("AD"'[P(17):PSJORIFN,1:""),$P(ND(0),U,24,26)=$G(P("RES"))_U_$G(P("OLDON"))_U_$G(P("NEWON")) S ND(2)=P(9)_U_P(2)_U_U_P(3)_U_P(11)_U_P(15),$P(ND(4),U,7,9)=+P("CLRK")_U_U_P("REN")
+ S $P(ND(0),U,14,16)=P("LOG")_U_DFN_U_P("LOG"),$P(ND(0),U,24,26)=$G(P("RES"))_U_$G(P("OLDON"))_U_$G(P("NEWON")) S ND(2)=P(9)_U_P(2)_U_U_P(3)_U_P(11)_U_P(15),$P(ND(4),U,7,9)=+P("CLRK")_U_U_P("REN")
+ S ND(8)=P(4)_U_P(23)_U_P("SYRS")_U_P(5)_U_P(8)_"^^"_P(7)_"^"_+P("IVRM"),ND(9)=$S($L(P("REM")_P("OPI")):P("REM")_U_P("OPI"),1:"")
+ S $P(ND(4),U,1,2)=$G(P("NINIT"))_U_$G(P("NINITDT"))
+ S:+$G(P("CLIN")) $P(^PS(53.1,+ON,"DSS"),"^")=P("CLIN")
+ S:+$G(P("APPT")) $P(^PS(53.1,+ON,"DSS"),"^",2)=P("APPT")
+ I $G(PSJORD)["V"!($G(PSJORD)["P") I $G(^PS(53.1,+ON,2.5))="" N DUR S DUR=$$GETDUR^PSJLIVMD(DFN,+PSJORD,$S((PSJORD["P"):"P",1:"IV"),1) I DUR]"" D
+ .I $G(IVLIMIT) S $P(^PS(53.1,+ON,2.5),"^",4)=DUR K IVLIMIT Q
+ .S $P(^PS(53.1,+ON,2.5),"^",2)=DUR
+ F X=0,2,4,8,9 S ^PS(53.1,+ON,X)=ND(X)
+ ;;S:+P("PD") ^PS(53.1,+ON,.2)=+P("PD")_U_P("DO")
+ S:'+$G(^PS(53.1,+ON,.2)) $P(^(.2),U,1,3)=+P("PD")_U_P("DO")_U_$G(P("NAT"))
+ ;;K ^PS(53.1,+ON,12) I $O(^PS(53.45,PSIVUP,4,0)) S %X="^PS(53.45,"_PSIVUP_",4,",%Y="^PS(53.1,"_+ON_",12," D %XY^%RCR
+ ;;K ^PS(53.45,+PSIVUP,4)
+ F DRGT="AD","SOL" D:$D(DRG(DRGT)) PTD531
+ K DA,DIK S PSGS0Y=P(11),PSGS0XT=P(15),DA=+ON,DIK="^PS(53.1," D IX^DIK K DA,DIK,PSGS0Y,PSGS0XT,ND,^PS(53.1,"AS","P",DFN,+ON)
+ K:P(17)="A" ^PS(53.1,"AS","N",DFN,+ON)
+ S:P(15)="D" $P(^PS(53.1,+ON,2),U,6)="D"
+ Q
+ ;
+UPD100 ; Update order data in file 100
+ D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF
+ ;* S ORIFN=PSJORIFN,PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) D SET^PSIVORFE K ORETURN ;; F X="OREVENT","ORSTS","ORSTRT","ORSTOP","ORPK","ORPCL","ORNP","ORPK" S ORETURN(X)=@X
+ S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) D SET^PSIVORFE
+ Q
+ ;
+PTD531 ; Move drug data from local array into 53.1
+ K ^PS(53.1,+ON,DRGT) S ^PS(53.1,+ON,DRGT,0)=$S(DRGT="AD":"^53.157^0^0",1:"^53.158^0^0")
+ F X=0:0 S X=$O(DRG(DRGT,X)) Q:'X  D
+ .S X1=$P(DRG(DRGT,X),U),Y=^PS(53.1,+ON,DRGT,0),$P(Y,U,3)=$P(Y,U,3)+1,DRG=$P(Y,U,3),$P(Y,U,4)=$P(Y,U,4)+1
+ .S ^PS(53.1,+ON,DRGT,0)=Y,Y=+X1_U_$P(DRG(DRGT,X),U,3) S:DRGT="AD" $P(Y,U,3)=$P(DRG(DRGT,X),U,4) S ^PS(53.1,+ON,DRGT,+DRG,0)=Y
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFB.m

@@ -1 @@
-PSIVORFB        ;BIR/MLM-FILE/RETRIEVE ORDERS IN ^PS(55 ;25 Sep 98 / 2:24 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**3,18,28,68,58,85,110,111,120,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(50.7 is supported by DBIA #2180.
-        ; Reference to ^PS(51.2 is supported by DBIA #2178.
-        ; Reference to ^PS(52.6 is supported by DBIA #1231.
-        ; Reference to ^PS(52.7 is supported by DBIA #2173.
-        ; Reference to ^PS(55 is supported by DBIA #2191.
-        ;
-NEW55   ; Get new order number in 55.
-        N DA,DD,DO,DIC,DLAYGO,X,Y,PSIVLIM,MINS,PSJDSTP1,PSJDSTP2,A,PSJCLIN,PSJDNM,PSJPROV,PSJWARD,PSJPAO,PSJALRT
-        I $D(^PS(55,+DFN)),'$D(^PS(55,+DFN,0)) D ENSET0^PSGNE3(+DFN)
-        I $G(PSJORD)["V"!($G(PSJORD)["P"),$G(P(2))]"" D LIMSTOP(.PSJDSTP1,.PSJDSTP2)
-        I ($G(PSJORD)["P"!($G(PSJORD)["V"))&$G(PSIVLIM) I $$CMPLIM(PSJORD,PSJDSTP1,PSJDSTP2) D
-        . D
-        .. S PSJPROV=DUZ I PSJORD["P" S PSJPROV=$P($G(^PS(53.1,+PSJORD,0)),"^",2)
-        .. I PSJORD["V" S PSJPROV=$P($G(^PS(55,DFN,"IV",+PSJORD,0)),"^",6)
-        .. D NOW^%DTC S XQA(PSJPROV)="",XQAID="PSJ,"_DFN_";"_PSJPROV_";"_%,XQADATA=""
-        .. D
-        ... I PSJORD["P" S A=$G(^PS(53.1,+PSJORD,"DSS"))
-        ... I PSJORD["V" S A=$G(^PS(55,PSGP,"IV",+PSJORD,"DSS"))
-        ... S PSJCLIN=$P(A,"^") I PSJCLIN]"" S PSJCLIN=$P(^SC(PSJCLIN,0),"^")
-        .. S A=$G(^DPT(DFN,0)),PSJWARD=$G(^(.1))
-        .. S XQAMSG=$P(A,"^")_" ("_$E($P(A,"^"))_$E($P(A,"^",9),6,9)_"): ["_$S(PSJWARD]"":$E(PSJWARD,1,10),$G(PSJCLIN)]"":$E(PSJCLIN,1,10),1:"UNKNOWN")_"] "
-        .. S A=$O(DRG("AD",0)) I A]"" S A=DRG("AD",A)
-        .. I A="" S A=$O(DRG("SOL",0)) I A]"" S A=DRG("SOL",A)
-        .. S PSJDNM=$P(^PS(50.7,+$P(A,"^",6),0),"^")
-        .. S XQAMSG=XQAMSG_PSJDNM_" your DURATION not used for stop date/time"
-        .. D SETUP^XQALERT
-        .. S PSJALRT=$$FMTDUR^PSJLIVMD($S(PSJORD["P":$P($G(^PS(53.1,+PSJORD,2.5)),"^",4),PSJORD["IV":$P($G(^PS(55,DFN,"IV",+PSJORD,2.5)),"^",4),1:"UNK"))
-        S DIC="^PS(55,",DIC(0)="LN",DLAYGO=55,(DINUM,X)=+DFN D ^DIC Q:Y<0
-LOCK0   F  L +^PS(55,DFN,"IV",0):0 I  Q
-        S ND=$S($D(^PS(55,DFN,"IV",0)):^(0),1:"^55.01") F DA=$P(ND,"^",3)+1:1 W "." I '$D(^PS(55,DFN,"IV",DA)) S $P(ND,"^",3)=DA,$P(ND,"^",4)=$P(ND,"^",4)+1,^PS(55,DFN,"IV",0)=ND Q
-        L +^PS(55,DFN,"IV",+DA):0 E  G LOCK0
-        S ^PS(55,DFN,"IV",+DA,0)=+DA,^PS(55,DFN,"IV","B",+DA,+DA)=""
-        L -^PS(55,DFN,"IV",0) S ON55=+DA_"V"
-        I $G(PSJALRT)]"" S PSIVAL="IV LIMIT OVERRIDDEN ("_$G(PSJALRT)_"): ALERT SENT",PSIVALT="",PSIVREA="E" D
-        .D LOG^PSIVORAL S P("LIMIT")="",P("OVRIDE")=1 K IVLIM,IVLIMIT
-        .S $P(^PS(55,DFN,"IV",+ON55,2.5),"^",4)="" S:$G(PSJORD)["P" $P(^PS(53.1,+PSJORD,2.5),"^",4)=""
-        .K PSIVAL,PSIVREA,PSIVALT
-        Q
-SET55   ; Move data from local variables to 55.
-        I '$D(ON55) W !,"*** Can't create this order at this time ***" Q
-        N DA,DIK,ND,PSIVACT,PSIVDUR
-        S:'$D(P(21)) (P(21),P("21FLG"))="" S ND(0)=+ON55,P(22)=$S(VAIN(4):+VAIN(4),1:.5) F X=2:1:23 I $D(P(X)) S $P(ND(0),U,X)=P(X)
-        S ND(.3)=$G(P("INS")),ND(2.5)="" N X S X=$S($G(PSGORD):PSGORD,1:$G(ON)) I X D
-        .N PKG S PKG=$E(X,$L(X)) S PKG=$S(PKG="V":"""IV""",PKG="U":5,PKG="P":"P",1:"") Q:PKG=""
-        .S PSIVDUR=$$GETDUR^PSJLIVMD(DFN,+X,$E(X,$L(X)),1) Q:PSIVDUR=""
-        .I $G(IVLIMIT) S ND(2.5)="^^^"_PSIVDUR K IVLIMIT Q
-        S $P(ND(0),U,17)="A",ND(1)=P("REM"),ND(3)=P("OPI"),ND(.2)=$P($G(P("PD")),U)_U_$G(P("DO"))_U_+P("MR")_U_$G(P("PRY"))_U_$G(P("NAT"))_U_U_U_$G(P("PRNTON"))
-        F X=0,1,2.5,3,.2,.3 S ^PS(55,DFN,"IV",+ON55,X)=ND(X)
-        S $P(^PS(55,DFN,"IV",+ON55,2),U,1,4)=P("LOG")_U_+P("IVRM")_U_U_P("SYRS"),$P(^(2),U,8,10)=P("RES")_U_$G(P("FRES"))_U_$S($G(VAIN(4)):+VAIN(4),1:"")
-        S X=^PS(55,DFN,0) I $P(X,"^",7)="" S $P(X,"^",7)=$P($P(P("LOG"),"^"),"."),$P(X,"^",8)="A",^(0)=X
-        S $P(^PS(55,DFN,"IV",+ON55,2),U,11)=+P("CLRK")
-        S:+$G(P("CLIN")) $P(^PS(55,DFN,"IV",+ON55,"DSS"),"^")=P("CLIN")
-        S:+$G(P("APPT")) $P(^PS(55,DFN,"IV",+ON55,"DSS"),"^",2)=P("APPT")
-        S:+$G(P("NINIT")) ^PS(55,DFN,"IV",+ON55,4)=P("NINIT")_U_P("NINITDT")
-        I '$G(PSIVCHG)!($G(PSJREN)&($G(PSIVCHG)=2)) I $G(P("PON")),P("PON")'=ON55 D
-        . N X S X=$S(P("PON")["P":"^PS(53.1,+P(""PON""),12,0)",P("PON")["V"&$G(PSJREN):"^PS(55,DFN,""IV"",+P(""PON""),5,0)",1:"") Q:X=""
-        . I $O(@X) S %X=X,%Y="^PS(55,"_DFN_",""IV"","_+ON55_",5," D %XY^%RCR
-        F DRGT="AD","SOL" D PUTD55
-        K DA,DIK S DA(1)=DFN,DA=+ON55,DIK="^PS(55,"_DA(1)_",""IV"",",PSIVACT=1 D IX^DIK
-        I $G(PSJCOM),$G(PSJCOMSI),$G(PSJORD)["V" K PSJCOMSI N PSJCHILD,PSJOEORD S PSJOEORD=0 F  S PSJOEORD=$O(^PS(55,"ACX",PSJCOM,PSJOEORD)) Q:'PSJOEORD  D
-        . N PSJCHILD S PSJCHILD=0 F  S PSJCHILD=$O(^PS(55,"ACX",PSJCOM,PSJOEORD,PSJCHILD)) Q:'PSJCHILD  S PSJCHILD(+PSJCHILD)=PSJCOM
-        . S PSJCHILD=0 F  S PSJCHILD=$O(PSJCHILD(PSJCHILD)) Q:'PSJCHILD  D
-        .. Q:PSJCHILD=PSJORD  K DR,DA,DIE,ORD S DR="31////"_$P($G(P("OPI")),"^",1,2),DA(1)=DFN
-        .. N ON,ON55 S (ON,ON55)=+PSJCHILD_"V" S:+$G(PSJPINIT)'>0 PSJPINIT=DUZ S PSIVALT=1,PSIVAL="COMPLEX ORDER" D ENTACT^PSIVAL D
-        ... I $P($G(^PS(55,DFN,"IV",+ON55,3)),"^")'=$P(P("OPI"),"^") S P("FC")="OTHER PRINT INFO^"_$P($G(^(3)),"^")_U_$P(P("OPI"),"^") D GTFC^PSIVORAL
-        ... I $D(^PS(55,DFN,"IV",+ON55,0)) S ^PS(55,DFN,"IV",+ON55,3)=P("OPI") D EN1^PSJHL2(DFN,"XX",ON55)
-        Q
-        ;
-PUTD55  ; Move drug data from local array into 55
-        K ^PS(55,DFN,"IV",+ON55,DRGT) S ^PS(55,DFN,"IV",+ON55,DRGT,0)=$S(DRGT="AD":"^55.02PA",1:"^55.11IPA")
-        F X=0:0 S X=$O(DRG(DRGT,X)) Q:'X  D
-        .S Y=^PS(55,DFN,"IV",+ON55,DRGT,0),$P(Y,U,3)=$P(Y,U,3)+1,DRG=$P(Y,U,3),$P(Y,U,4)=$P(Y,U,4)+1
-        .S ^PS(55,DFN,"IV",+ON55,DRGT,0)=Y,Y=$P(DRG(DRGT,X),U)_U_$P(DRG(DRGT,X),U,3) S:DRGT="AD" $P(Y,U,3)=$P(DRG(DRGT,X),U,4) S ^PS(55,DFN,"IV",+ON55,DRGT,+DRG,0)=Y
-        Q
-GT55    ; Retrieve data from 55 into local array
-        K DRG,DRGN,P S:'$D(ON55) ON55=ON S P("REN")="",Y=$G(^PS(55,DFN,"IV",+ON55,0)) F X=1:1:23 S P(X)=$P(Y,U,X)
-        S P("21FLG")=P(21)
-        S P("PON")=ON55,PSJORIFN=P(21),P(6)=P(6)_U_$P($G(^VA(200,+P(6),0)),U),(DRG,DRGN)="",P("REM")=$G(^PS(55,DFN,"IV",+ON55,1))
-        S Y=$G(^PS(55,DFN,"IV",+ON55,2)),P("LOG")=$P(Y,U),P("IVRM")=$P(Y,U,2)_U_$P($G(^PS(59.5,+$P(Y,U,2),0)),U)
-        S P("CLRK")=$P(Y,U,11)_U_$P($G(^VA(200,+$P(Y,U,11),0)),U),P("RES")=$P(Y,U,8),P("FRES")=$P(Y,U,9),P("SYRS")=$P(Y,U,4),P("OPI")=$G(^PS(55,DFN,"IV",+ON55,3))
-        S P("INS")=$G(^PS(55,DFN,"IV",+ON55,.3))
-        S P("CLIN")=$P($G(^PS(55,DFN,"IV",+ON55,"DSS")),"^"),P("APPT")=$P($G(^PS(55,DFN,"IV",+ON55,"DSS")),"^",2)
-        S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)
-        D:'$D(PSJLABEL) GTPC(ON55) S ND=$G(^PS(55,DFN,"IV",+ON55,.2)),P("PD")=$S($P(ND,U):$P(ND,U)_U_$$OIDF^PSJLMUT1(+ND)_U_$P($G(^PS(50.7,+ND,0)),U),1:""),P("DO")=$P(ND,U,2),P("PRY")=$P(ND,U,4),P("NAT")=$P(ND,U,5),(PSJCOM,P("PRNTON"))=$P(ND,U,8)
-        I P("PRY")="D",'+P("IVRM") S P("IVRM")=+$G(PSIVSN)_U_$P($G(^PS(59.5,+$G(PSIVSN),0)),U)
-        S P("MR")=$P(ND,U,3),ND=$G(^PS(51.2,+P("MR"),0)),P("MR")=P("MR")_U_$S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)) D GTCUM
-        D GTDRG,GTOT^PSIVUTL(P(4))
-        N ND2P5 S ND2P5=$G(^PS(55,DFN,"IV",+ON55,2.5)) D
-        .S P("DUR")=$P(ND2P5,"^",2)
-        .S P("LIMIT")=$P(ND2P5,"^",4)
-        .S P("IVCAT")=$P(ND2P5,"^",5)
-K       ; Kill and exit.
-        K FIL,ND
-        Q
-GTDRG   ; Get drug info and place in DRG(.
-        F DRGT="AD","SOL" S FIL=$S(DRGT="AD":52.6,1:52.7) F Y=0:0 S Y=$O(^PS(55,DFN,"IV",+ON55,DRGT,Y)) Q:'Y  D
-        .; naked ref below refers to line above
-        .S DRG=$G(^(Y,0)),ND=$G(^PS(FIL,+DRG,0)),(DRGI,DRG(DRGT,0))=$G(DRG(DRGT,0))+1
-        .S DRG(DRGT,+DRGI)=+DRG_U_$P(ND,U)_U_$P(DRG,U,2)_U_$P(DRG,U,3)_U_$P(ND,U,13)_U_$P(ND,U,11)
-        Q
-        ;
-GTCUM   ; Retrieve dispensing info.
-        S ND=$G(^PS(55,DFN,"IV",+ON55,9)),P("LF")=$P(ND,U),P("LFA")=$P(ND,U,2),P("CUM")=$P(ND,U,3)
-        Q
-        ;
-GTPC(ON)        ; Retrieve Provider Comments and create "scratch" fields to edit
-        Q
-        ;
-SETNEW  ; Create new order and set
-        D NEW55,SET55
-        Q
-        ;
-CMPLIM(PSJORD,PSJDSTP1,PSJDSTP2)        ; Compare stop date of order against IV Limit
-        I $P($G(^PS(53.1,+PSJORD,0)),"^",25)]"" D CHKD Q:PSJPAO 0
-        I $G(PSJDSTP1),$E(+PSJDSTP1,1,11)'=$E(+P(3),1,11),+PSJDSTP2'=+P(3) Q 1
-        Q 0
-        ;
-LIMSTOP(PSJDSTP1,PSJDSTP2)      ; Calculate default stop date using IV Limit
-        ;      Output: PSJDSTP1 - Default stop using duration only
-        ;              PSJDSTP2 - Default stop using duration and IV parameters for time
-        S PSIVLIM=$$GETLIM^PSIVCAL(DFN,PSJORD)
-        I 'PSIVLIM,PSIVLIM]"" S PSIVLIM=$$GETMIN^PSIVCAL(PSIVLIM,DFN,PSJORD)
-        I PSIVLIM]"" D
-        . S MINS=$$GETMIN^PSIVCAL(PSIVLIM,DFN,PSJORD),PSJDSTP1=$$FMADD^XLFDT(P(2),,,MINS)
-        . S X=$P(PSJDSTP1,"."),PSJDSTP2=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14))
-        Q
-        ;
-CHKD    ;Check for a previous active order and compare the duration
-        N PSJPO,A,PSJDUR
-        S PSJDUR=$$GETLIM^PSIVCAL(DFN,PSJORD)
-        S PSJPAO=0,PSJPO=PSJORD
-CHKDR   S PSJPO=$P($G(^PS(53.1,+PSJPO,0)),"^",25) Q:PSJPO=""
-        I PSJPO["P" G CHKDR
-        I PSJPO["V" S PSIVLIM=$$GETLIM^PSIVCAL(DFN,PSJPO) I PSJDUR'=PSIVLIM S PSJPAO=1 Q
-        G CHKDR
+PSIVORFB ;BIR/MLM-FILE/RETRIEVE ORDERS IN ^PS(55 ;25 Sep 98 / 2:24 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**3,18,28,68,58,85,110,111,120**;16 DEC 97;Build 10
+ ;
+ ; Reference to ^PS(50.7 is supported by DBIA #2180.
+ ; Reference to ^PS(51.2 is supported by DBIA #2178.
+ ; Reference to ^PS(52.6 is supported by DBIA #1231.
+ ; Reference to ^PS(52.7 is supported by DBIA #2173.
+ ; Reference to ^PS(55 is supported by DBIA #2191.
+ ;
+NEW55 ; Get new order number in 55.
+ N DA,DD,DO,DIC,DLAYGO,X,Y,PSIVLIM,MINS,PSJDSTP1,PSJDSTP2,A,PSJCLIN,PSJDNM,PSJPROV,PSJWARD,PSJPAO
+ I $D(^PS(55,+DFN)),'$D(^PS(55,+DFN,0)) D ENSET0^PSGNE3(+DFN)
+ I $G(PSJORD)["V"!($G(PSJORD)["P"),$G(P(2))]"" S PSIVLIM=$$GETLIM^PSIVCAL(DFN,PSJORD) I PSIVLIM D
+ . S MINS=$$GETMIN^PSIVCAL(PSIVLIM,DFN,PSJORD),PSJDSTP1=$$FMADD^XLFDT(P(2),,,MINS)
+ . S X=$P(PSJDSTP1,"."),PSJDSTP2=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14))
+ I $G(PSJORD)["P",$G(PSIVLIM) D
+ . I $P($G(^PS(53.1,+PSJORD,0)),"^",25)]"" D CHKD Q:PSJPAO
+ . I $G(PSJDSTP1),+PSJDSTP1'=+P(3),+PSJDSTP2'=+P(3) D
+ .. S PSJPROV=DUZ I PSJORD["P" S PSJPROV=$P($G(^PS(53.1,+PSJORD,0)),"^",2)
+ .. I PSJORD["V" S PSJPROV=$P($G(^PS(55,DFN,"IV",+PSJORD,0)),"^",6)
+ .. D NOW^%DTC S XQA(PSJPROV)="",XQAID="PSJ,"_DFN_";"_PSJPROV_";"_%,XQADATA=""
+ .. D
+ ... I PSJORD["P" S A=$G(^PS(53.1,+PSJORD,"DSS"))
+ ... I PSJORD["V" S A=$G(^PS(55,PSGP,"IV",+PSJORD,"DSS"))
+ ... S PSJCLIN=$P(A,"^") I PSJCLIN]"" S PSJCLIN=$P(^SC(PSJCLIN,0),"^")
+ .. S A=$G(^DPT(DFN,0)),PSJWARD=$G(^(.1))
+ .. S XQAMSG=$P(A,"^")_" ("_$E($P(A,"^"))_$E($P(A,"^",9),6,9)_"): ["_$S(PSJWARD]"":$E(PSJWARD,1,10),$G(PSJCLIN)]"":$E(PSJCLIN,1,10),1:"UNKNOWN")_"] "
+ .. S A=$O(DRG("AD",0)) I A]"" S A=DRG("AD",A)
+ .. I A="" S A=$O(DRG("SOL",0)) I A]"" S A=DRG("SOL",A)
+ .. S PSJDNM=$P(^PS(50.7,+$P(A,"^",6),0),"^")
+ .. S XQAMSG=XQAMSG_PSJDNM_" your DURATION not used for stop date/time"
+ .. D SETUP^XQALERT
+ S DIC="^PS(55,",DIC(0)="LN",DLAYGO=55,(DINUM,X)=+DFN D ^DIC Q:Y<0
+LOCK0 F  L +^PS(55,DFN,"IV",0):0 I  Q
+ S ND=$S($D(^PS(55,DFN,"IV",0)):^(0),1:"^55.01") F DA=$P(ND,"^",3)+1:1 W "." I '$D(^PS(55,DFN,"IV",DA)) S $P(ND,"^",3)=DA,$P(ND,"^",4)=$P(ND,"^",4)+1,^PS(55,DFN,"IV",0)=ND Q
+ L +^PS(55,DFN,"IV",+DA):0 E  G LOCK0
+ S ^PS(55,DFN,"IV",+DA,0)=+DA,^PS(55,DFN,"IV","B",+DA,+DA)=""
+ L -^PS(55,DFN,"IV",0) S ON55=+DA_"V"
+ Q
+ ;
+SET55 ; Move data from local variables to 55.
+ I '$D(ON55) W !,"*** Can't create this order at this time ***" Q
+ N DA,DIK,ND,PSIVACT,PSIVDUR
+ S:'$D(P(21)) (P(21),P("21FLG"))="" S ND(0)=+ON55,P(22)=$S(VAIN(4):+VAIN(4),1:.5) F X=2:1:23 I $D(P(X)) S $P(ND(0),U,X)=P(X)
+ S ND(.3)=$G(P("INS")),ND(2.5)="" N X S X=$S($G(PSGORD):PSGORD,1:$G(ON)) I X D
+ .N PKG S PKG=$E(X,$L(X)) S PKG=$S(PKG="V":"""IV""",PKG="U":5,PKG="P":"P",1:"") Q:PKG=""
+ .S PSIVDUR=$$GETDUR^PSJLIVMD(DFN,+X,$E(X,$L(X)),1) Q:PSIVDUR=""
+ .I $G(IVLIMIT) S ND(2.5)="^^^"_PSIVDUR K IVLIMIT Q
+ .S ND(2.5)="^"_PSIVDUR
+ S $P(ND(0),U,17)="A",ND(1)=P("REM"),ND(3)=P("OPI"),ND(.2)=$P($G(P("PD")),U)_U_$G(P("DO"))_U_+P("MR")_U_$G(P("PRY"))_U_$G(P("NAT"))_U_U_U_$G(P("PRNTON"))
+ F X=0,1,2.5,3,.2,.3 S ^PS(55,DFN,"IV",+ON55,X)=ND(X)
+ S $P(^PS(55,DFN,"IV",+ON55,2),U,1,4)=P("LOG")_U_+P("IVRM")_U_U_P("SYRS"),$P(^(2),U,8,10)=P("RES")_U_$G(P("FRES"))_U_$S($G(VAIN(4)):+VAIN(4),1:"")
+ S X=^PS(55,DFN,0) I $P(X,"^",7)="" S $P(X,"^",7)=$P($P(P("LOG"),"^"),"."),$P(X,"^",8)="A",^(0)=X
+ S $P(^PS(55,DFN,"IV",+ON55,2),U,11)=+P("CLRK")
+ S:+$G(P("CLIN")) $P(^PS(55,DFN,"IV",+ON55,"DSS"),"^")=P("CLIN")
+ S:+$G(P("APPT")) $P(^PS(55,DFN,"IV",+ON55,"DSS"),"^",2)=P("APPT")
+ S:+$G(P("NINIT")) ^PS(55,DFN,"IV",+ON55,4)=P("NINIT")_U_P("NINITDT")
+ ;S:'$D(PSIVUP) PSIVUP=+$$GTPCI^PSIVUTL K ^PS(55,DFN,"IV",+ON55,5) I $O(^PS(53.45,PSIVUP,4,0)) S %X="^PS(53.45,"_PSIVUP_",4,",%Y="^PS(55,"_DFN_",""IV"","_+ON55_",5," D %XY^%RCR
+ I '$G(PSIVCHG)!($G(PSJREN)&($G(PSIVCHG)=2)) I $G(P("PON")),P("PON")'=ON55 D
+ . N X S X=$S(P("PON")["P":"^PS(53.1,+P(""PON""),12,0)",P("PON")["V"&$G(PSJREN):"^PS(55,DFN,""IV"",+P(""PON""),5,0)",1:"") Q:X=""
+ . I $O(@X) S %X=X,%Y="^PS(55,"_DFN_",""IV"","_+ON55_",5," D %XY^%RCR
+ F DRGT="AD","SOL" D PUTD55
+ K DA,DIK S DA(1)=DFN,DA=+ON55,DIK="^PS(55,"_DA(1)_",""IV"",",PSIVACT=1 D IX^DIK
+ I $G(PSJCOM),$G(PSJCOMSI),$G(PSJORD)["V" K PSJCOMSI N PSJCHILD,PSJOEORD S PSJOEORD=0 F  S PSJOEORD=$O(^PS(55,"ACX",PSJCOM,PSJOEORD)) Q:'PSJOEORD  D
+ . N PSJCHILD S PSJCHILD=0 F  S PSJCHILD=$O(^PS(55,"ACX",PSJCOM,PSJOEORD,PSJCHILD)) Q:'PSJCHILD  S PSJCHILD(+PSJCHILD)=PSJCOM
+ . S PSJCHILD=0 F  S PSJCHILD=$O(PSJCHILD(PSJCHILD)) Q:'PSJCHILD  D
+ .. Q:PSJCHILD=PSJORD  K DR,DA,DIE,ORD S DR="31////"_$P($G(P("OPI")),"^",1,2),DA(1)=DFN
+ .. N ON,ON55 S (ON,ON55)=+PSJCHILD_"V" S:+$G(PSJPINIT)'>0 PSJPINIT=DUZ S PSIVALT=1,PSIVAL="COMPLEX ORDER" D ENTACT^PSIVAL D
+ ... I $P($G(^PS(55,DFN,"IV",+ON55,3)),"^")'=$P(P("OPI"),"^") S P("FC")="OTHER PRINT INFO^"_$P($G(^(3)),"^")_U_$P(P("OPI"),"^") D GTFC^PSIVORAL
+ ... I $D(^PS(55,DFN,"IV",+ON55,0)) S ^PS(55,DFN,"IV",+ON55,3)=P("OPI") D EN1^PSJHL2(DFN,"XX",ON55)
+ Q
+ ;
+PUTD55 ; Move drug data from local array into 55
+ K ^PS(55,DFN,"IV",+ON55,DRGT) S ^PS(55,DFN,"IV",+ON55,DRGT,0)=$S(DRGT="AD":"^55.02PA",1:"^55.11IPA")
+ F X=0:0 S X=$O(DRG(DRGT,X)) Q:'X  D
+ .S Y=^PS(55,DFN,"IV",+ON55,DRGT,0),$P(Y,U,3)=$P(Y,U,3)+1,DRG=$P(Y,U,3),$P(Y,U,4)=$P(Y,U,4)+1
+ .S ^PS(55,DFN,"IV",+ON55,DRGT,0)=Y,Y=$P(DRG(DRGT,X),U)_U_$P(DRG(DRGT,X),U,3) S:DRGT="AD" $P(Y,U,3)=$P(DRG(DRGT,X),U,4) S ^PS(55,DFN,"IV",+ON55,DRGT,+DRG,0)=Y
+ Q
+GT55 ; Retrieve data from 55 into local array
+ K DRG,DRGN,P S:'$D(ON55) ON55=ON S P("REN")="",Y=$G(^PS(55,DFN,"IV",+ON55,0)) F X=1:1:23 S P(X)=$P(Y,U,X)
+ S P("21FLG")=P(21)
+ S P("PON")=ON55,PSJORIFN=P(21),P(6)=P(6)_U_$P($G(^VA(200,+P(6),0)),U),(DRG,DRGN)="",P("REM")=$G(^PS(55,DFN,"IV",+ON55,1))
+ S Y=$G(^PS(55,DFN,"IV",+ON55,2)),P("LOG")=$P(Y,U),P("IVRM")=$P(Y,U,2)_U_$P($G(^PS(59.5,+$P(Y,U,2),0)),U)
+ S P("CLRK")=$P(Y,U,11)_U_$P($G(^VA(200,+$P(Y,U,11),0)),U),P("RES")=$P(Y,U,8),P("FRES")=$P(Y,U,9),P("SYRS")=$P(Y,U,4),P("OPI")=$G(^PS(55,DFN,"IV",+ON55,3))
+ S P("INS")=$G(^PS(55,DFN,"IV",+ON55,.3))
+ S P("CLIN")=$P($G(^PS(55,DFN,"IV",+ON55,"DSS")),"^"),P("APPT")=$P($G(^PS(55,DFN,"IV",+ON55,"DSS")),"^",2)
+ S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)
+ D:'$D(PSJLABEL) GTPC(ON55) S ND=$G(^PS(55,DFN,"IV",+ON55,.2)),P("PD")=$S($P(ND,U):$P(ND,U)_U_$$OIDF^PSJLMUT1(+ND)_U_$P($G(^PS(50.7,+ND,0)),U),1:""),P("DO")=$P(ND,U,2),P("PRY")=$P(ND,U,4),P("NAT")=$P(ND,U,5),(PSJCOM,P("PRNTON"))=$P(ND,U,8)
+ I P("PRY")="D",'+P("IVRM") S P("IVRM")=+$G(PSIVSN)_U_$P($G(^PS(59.5,+$G(PSIVSN),0)),U)
+ S P("MR")=$P(ND,U,3),ND=$G(^PS(51.2,+P("MR"),0)),P("MR")=P("MR")_U_$S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)) D GTCUM
+ D GTDRG,GTOT^PSIVUTL(P(4))
+K ; Kill and exit.
+ K FIL,ND
+ Q
+GTDRG ; Get drug info and place in DRG(.
+ F DRGT="AD","SOL" S FIL=$S(DRGT="AD":52.6,1:52.7) F Y=0:0 S Y=$O(^PS(55,DFN,"IV",+ON55,DRGT,Y)) Q:'Y  D
+ .; naked ref below refers to line above
+ .S DRG=$G(^(Y,0)),ND=$G(^PS(FIL,+DRG,0)),(DRGI,DRG(DRGT,0))=$G(DRG(DRGT,0))+1
+ .S DRG(DRGT,+DRGI)=+DRG_U_$P(ND,U)_U_$P(DRG,U,2)_U_$P(DRG,U,3)_U_$P(ND,U,13)_U_$P(ND,U,11)
+ Q
+ ;
+GTCUM ; Retrieve dispensing info.
+ S ND=$G(^PS(55,DFN,"IV",+ON55,9)),P("LF")=$P(ND,U),P("LFA")=$P(ND,U,2),P("CUM")=$P(ND,U,3)
+ Q
+ ;
+GTPC(ON) ; Retrieve Provider Comments and create "scratch" fields to edit
+ ;S:'$D(PSIVUP) PSIVUP=+$$GTPCI^PSIVUTL K ^PS(53.45,PSIVUP,4)
+ ;K ^PS(53.45,PSIVUP,4) I $O(^PS(55,DFN,"IV",+ON,5,0)) S %X="^PS(55,"_DFN_",""IV"","_+ON_",5,",%Y="^PS(53.45,"_PSIVUP_",4," D %XY^%RCR
+ Q
+ ;
+SETNEW ; Create new order and set
+ D NEW55,SET55
+ Q
+CHKD ;Check for a previous active order and compare the duration
+ N PSJPO,A,PSJDUR
+ S PSJDUR=$$GETLIM^PSIVCAL(DFN,PSJORD)
+ S PSJPAO=0,PSJPO=PSJORD
+CHKDR S PSJPO=$P($G(^PS(53.1,+PSJPO,0)),"^",25) Q:PSJPO=""
+ I PSJPO["P" G CHKDR
+ I PSJPO["V" S PSIVLIM=$$GETLIM^PSIVCAL(DFN,PSJPO) I PSJDUR'=PSIVLIM S PSJPAO=1 Q
+ G CHKDR

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVSP.m

@@ -1 @@
-PSIVSP  ;BIR/RGY,PR,CML3-DOSE PROCESSOR ;09 Feb 99 / 12:30 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**30,37,41,50,56,74,83,111,133,138,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(51.1 is supported by DBIA #2177
-        ;
-EN      ;
-        Q:'$D(X)
-        S ATZERO=0 I X["@",$P(X,"@",2)=0 S ATZERO=1,X=$P(X,"@")
-        D EN^PSGS0 S (P(9),PSIVSC1)=$S($G(X)]"":X,1:$G(P(9))),P(11)=$S($G(PSGS0Y):PSGS0Y,1:$G(P(11))),(XT,P(15))=$S(($G(PSGS0XT)!($G(PSGS0XT)="O")!($G(PSGS0XT)="D")):$G(PSGS0XT),1:$G(P(15)))
-        I $G(ATZERO) S P(7)=1
-        K ATZERO Q
-EN1     ;
-        S (PSIVAT,PSIVWAT,Y)="",XT=-1,X0=X,X=$S(X="ON CALL":X,X="ONCALL":X,X="ON-CALL":X,X="ONETIME":X,X="ONE-TIME":X,X="ONE TIME":X,X="1TIME":X,X="1 TIME":X,X="1-TIME":X,$L(X," ")<3:$P(X," "),1:$P(X," ",1,2))
-        S:$E(X)="^" X=$E(X,2,999) G:X="" Q S:X["@0" ATZERO=1 S X=$S(X["@0":$P(X,"@"),1:X),P(7)=$S($D(ATZERO):1,1:"") K ATZERO
-        I $S($D(^PS(51.1,"AC","PSJ",X)):1,1:$E($O(^(X)),1,$L(X))=X) D DIC I Y'<0 G SH
-NS0     S Y=""
-        I $E(X,1,2)="AD" S XT=-1 Q
-        I $E(X,1,3)="BID"!($E(X,1,3)="TID")!($E(X,1,3)="QID") S XT=1440\$F("BTQ",$E(X))
-        E  S:$E(X)="Q" X=$E(X,2,99) S:'X X=$E(X)["O"+1_X S I=+X,X=$P(X,I,2),XT=I*$S(X["'":1,(X["D"&(X'["AD"))!(X["AM")!(X["PM")!(X["HS"&(X'["THS")):1440,X["H"&(X'["TH"):60,X["AC"!(X["PC"):480,X["W":10080,X["M":40320,1:0),X=X0 D 
-        . I 'XT,X'="NOW",X'="STAT",X'="ONCE",X'="ONE-TIME",X'="ONE TIME",X'="ONETIME",X'="1-TIME",X'="1 TIME",X'="1TIME",Y="" S XT=-1
-SH      ;
-        I +Y<1,$E(X0)'="^" W:$G(ON)'["P" "  ",$S(XT=0&($S("^NOW^STAT^ONCE^ONE-TIME^ONETIME^1TIME^1-TIME^"[(U_$P(X," ")_U):1,X["1 TIME":1,1:X["ONE TIME")):"(ONCE ONLY)",XT>0:"Nonstandard schedule",XT<0:"",1:"(??)") W:XT>0 " (",XT," MINUTES)"
-Q       Q:X="ONE TIME"
-        N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X0," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 K X0 S:$G(P(7)) XT="" Q
-NEWQ    ;N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X0," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 S:P(7) X=X0 K X0 K:XT>0&('P(7)) X Q
-        Q
-        ;
-ENDL    W "   Dose limit ....  " S PSIVMIN=P(15)*X,PSIVSD=+P(2)
-        I PSIVMIN<0 W !!," --- There is something wrong with this order !!",!,"     Call inpatient supervisor ....." S Y=-1 K PSIVMIN Q
-        I P(4)="P"!(P(5))!(P(23)="P"),PSIVMIN=0,"^NOW^STAT^ONCE^ONE-TIME^ONE TIME^ON CALL^ONETIME^1TIME^1 TIME^1-TIME^"'[(U_P(9)_U) D DLP G QDL
-        D ENT^PSIVWL
-QDL     I $D(X) S X=Y X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) S Y=X
-        Q
-DLP     ;
-        S X=X+1,$P(PSIVSD,".",2)=$P(PSIVSD,".",2)_$E("0000",1,4-$L($P(PSIVSD,".",2))) D CHK S X2=0,Y=1 I X<2 S Y=+PSIVSD G QDLP
-        I $P(PSIVSD,".",2)>$P(P(11),"-",$L(P(11),"-")) S X2=1 G OV
-        G:$P(P(11),"-")>$P(PSIVSD,".",2) OV
-        F Y=1:1 S X1=$P(P(11),"-",Y) I X1=$P(PSIVSD,".",2)!($P(PSIVSD,".",2)<X1) Q
-OV      I P(11)="" W $C(7)," ???",!?15,"*** You have not defined any administration times !!" K X Q
-        F Y=Y:1 S:$P(P(11),"-",Y)="" X2=X2+1,Y=0,X=X+1 S X=X-1 Q:X<1
-        S X=PSIVSD\1 I X2>0 S X1=PSIVSD D C^%DTC S X=$P(X,".") ; install with version 17.3 of fileman
-        S Y=+(X_"."_$P(P(11),"-",Y))
-QDLP    K X1,X2 Q
-        ;
-ENI     ;
-        K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X)!'$D(P(4)) Q
-        I P(4)="P"!(P(5))!(P(23)="P") Q:'X  S X="INFUSE OVER "_X_" MINUTE"_$S(X>1:"S",1:"") W "   ",X Q
-        I X'=+X,($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)) K X Q
-        S SPSOL=$O(DRG("SOL",0)) I 'SPSOL K SPSOL,X W "  You must define at least one solution !!" Q
-        I X=+X S X=X_" ml/hr" W " ml/hr" D SPSOL S P(15)=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q
-        S SPSOL=$P(X,"@",2) S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr" W "   ",+SPSOL," Label",$S(SPSOL'=1:"s",1:"")," per day",!?15,"at an infusion rate of: ",$P(X,"@") S P(15)=$S('SPSOL:0,1:1440/SPSOL\1) K SPSOL
-        Q
-SPSOL   S SPSOL=0 F XXX=0:0 S XXX=$O(DRG("SOL",XXX)) Q:'XXX  S SPSOL=SPSOL+$P(DRG("SOL",XXX),U,3)
-        K XXX Q
-CHK     F Y=1:1 Q:$L(P(11))>240!($P(P(11),"-",Y)="")  S $P(P(11),"-",Y)=$P(P(11),"-",Y)_$E("0000",1,4-$L($P(P(11),"-",Y)))
-        Q
-        ;
-DIC     ; 51.1 look-up
-        N PSJSCH S PSJSCH=X I '$D(WSCHADM) N VAIP D IN5^VADPT S WSCHADM=VAIP(5),X=PSJSCH
-        K DIC S DIC="^PS(51.1,",DIC(0)=$E("E",'$D(NOECH))_"ISZ"
-        S DIC("W")="W ""  "","_$S('$D(WSCHADM):"$P(^(0),""^"",2)",'+WSCHADM:"$P(^(0),""^"",2)",1:"$S($D(^PS(51.1,+Y,1,+WSCHADM,0)):$P(^(0),""^"",2),1:$P(^PS(51.1,+Y,0),""^"",2))"),D="APPSJ" S:$D(PSIVSPQF) DIC(0)=DIC(0)_"O"
-        D IX^DIC K DIC
-        S:$D(DIE)#2 DIC=DIE Q:Y<0
-        S X=Y(0,0),ZZY=Y,(XT,Y)="" I $D(WSCHADM),$D(^PS(51.1,+ZZY,1,+WSCHADM,0)),$P(^(0),"^",2)]"" S (PSIVWAT,Y)=$P(^(0),"^",2)
-        K ZZY,WSCHADM S:Y="" (X,PSIVSC1)=$P(Y(0),U),(PSIVAT,Y)=$P(Y(0),"^",2) S XT=$P(Y(0),"^",3) Q
-        ;
-ORINF   ;  OERR input transform for Infusion Rate
-        ;  X=data
-        N INFUSE
-        K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q
-        I X?.E1L.E S INFUSE=$$ENLU^PSGMI(X) Q:(INFUSE="TITRATE")!(INFUSE="BOLUS")!($P(INFUSE," ")="INFUSE")!($P(INFUSE," ")="Infuse")
-        Q:(X="TITRATE")!(X="BOLUS")!($P(X," ")="INFUSE")!($P(X," ")="Infuse")
-        I X["=" D  Q   ; NOIS LOU-0501-42191
-        .N X2,X1 S X1=$P(X,"="),X2=$P(X,"=",2)
-        .I X1["ML/HR",(+X1=$P(X1,"ML/HR"))!(+X1=$P(X1," ML/HR")) D
-        ..S X1=$TR(X1,"ML/HR","ml/hr")
-        .I X2["ML/HR",(+X2=$P(X2,"ML/HR"))!(+X2=$P(X2," ML/HR")) D
-        ..S X2=$TR(X2,"ML/HR","ml/hr")
-        .I X1[" ml/hr",(+X1=$P(X1," ml/hr")) D
-        ..S X1=$P(X1," ml/hr")_$P(X1," ml/hr",2,9999)
-        .I X2[" ml/hr",(+X2=$P(X2," ml/hr")) D
-        ..S X2=$P(X2," ml/hr")_$P(X2," ml/hr",2,9999)
-        .I X1["ml/hr",(+X1=$P(X1,"ml/hr")) D
-        ..S X1=$P(X1,"ml/hr")_$P(X1,"ml/hr",2,9999)
-        .I X2["ml/hr",(+X2=$P(X2,"ml/hr")) D
-        ..S X2=$P(X2,"ml/hr")_$P(X2,"ml/hr",2,9999)
-        .I X2'=+X2 D
-        ..I X2>0&(X2<1) Q
-        ..I ($P(X2,"@",2,999)'=+$P(X2,"@",2,999)!(+$P(X2,"@",2,999)<0)) K X Q
-        .I X1>0&(X1<1) I +X1="."_$P(X1,".",2) S X1=X1_" ml/hr"
-        .I X2>0&(X2<1) I +X2="."_$P(X2,".",2) S X2=X2_" ml/hr"
-        .I X1=+X1 S X1=X1_" ml/hr"
-        .I X2=+X2 S X2=X2_" ml/hr"
-        .S:$P(X2,"@")=+X2 $P(X2,"@")=$P(X2,"@")_" ml/hr"
-        .S X=X1_"="_X2
-        I X["ML/HR",(+X=$P(X,"ML/HR"))!(+X=$P(X," ML/HR")) S X=$TR(X,"ML/HR","ml/hr")
-        I X[" ml/hr",+X=$P(X," ml/hr") S X=$P(X," ml/hr")_$P(X," ml/hr",2,9999)
-        I X["ml/hr",+X=$P(X,"ml/hr") S X=$P(X,"ml/hr")_$P(X,"ml/hr",2,9999)
-        I X>0,X<1 D  Q
-        .I X["ML/HR",(+X=$P($P(X,"ML/HR"),".",2))!(+X=$P($P(X," ML/HR"),".",2)) S X=$TR(X,"ML/HR","ml/hr")
-        .I X[" ml/hr",(+X=$P($P(X," ml/hr"),".",2)) S X=$P(X," ml/hr")_$P(X," ml/hr",2,9999)
-        .I X["ml/hr",+X=$P(X,"ml/hr") S X=$P(X,"ml/hr")_$P(X,"ml/hr",2,9999)
-        .I +X=X S X=X_" ml/hr"
-        .I $P(X,0,2)=+X S X=X_" ml/hr"
-        .S X=0_+X_$P(X,+X,2)
-        I '(X>0&X<1) I X'=+X,($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)) K X Q
-        I X=+X S X=X_" ml/hr" Q
-        S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr"
-        Q
+PSIVSP ;BIR/RGY,PR,CML3-DOSE PROCESSOR ;09 Feb 99 / 12:30 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**30,37,41,50,56,74,83,111,133,138**;16 DEC 97
+ ;
+ ; Reference to ^PS(51.1 is supported by DBIA #2177
+ ;
+EN ;
+ Q:'$D(X)
+ ;/S (PSIVAT,PSIVWAT,Y)="",XT=-1,X0=X,X=$S(X="ON CALL":X,X["ONE ":X,1:$P(X," "))
+ S ATZERO=0 I X["@",$P(X,"@",2)=0 S ATZERO=1,X=$P(X,"@")
+ D EN^PSGS0 S (P(9),PSIVSC1)=$S($G(X)]"":X,1:$G(P(9))),P(11)=$S($G(PSGS0Y):PSGS0Y,1:$G(P(11))),(XT,P(15))=$S(($G(PSGS0XT)!($G(PSGS0XT)="O")!($G(PSGS0XT)="D")):$G(PSGS0XT),1:$G(P(15)))
+ I $G(ATZERO) S P(7)=1
+ K ATZERO Q
+EN1 ;
+ S (PSIVAT,PSIVWAT,Y)="",XT=-1,X0=X,X=$S(X="ON CALL":X,X="ONCALL":X,X="ON-CALL":X,X="ONETIME":X,X="ONE-TIME":X,X="ONE TIME":X,X="1TIME":X,X="1 TIME":X,X="1-TIME":X,$L(X," ")<3:$P(X," "),1:$P(X," ",1,2))
+ S:$E(X)="^" X=$E(X,2,999) G:X="" Q S:X["@0" ATZERO=1 S X=$S(X["@0":$P(X,"@"),1:X),P(7)=$S($D(ATZERO):1,1:"") K ATZERO
+ ;;I X0["@",$P(X0,"@",2)'=0 K X Q
+ I $S($D(^PS(51.1,"AC","PSJ",X)):1,1:$E($O(^(X)),1,$L(X))=X) D DIC I Y'<0 G SH
+ ;;I $S(X="NOW":1,X="ONCE":1,X="STAT":1,X="ONE-TIME":1,X="ONE TIME":1,1:0) S XT=0,Y(0)=X G SH
+NS0 S Y=""
+ I $E(X,1,2)="AD" S XT=-1 Q
+ I $E(X,1,3)="BID"!($E(X,1,3)="TID")!($E(X,1,3)="QID") S XT=1440\$F("BTQ",$E(X))
+ E  S:$E(X)="Q" X=$E(X,2,99) S:'X X=$E(X)["O"+1_X S I=+X,X=$P(X,I,2),XT=I*$S(X["'":1,(X["D"&(X'["AD"))!(X["AM")!(X["PM")!(X["HS"&(X'["THS")):1440,X["H"&(X'["TH"):60,X["AC"!(X["PC"):480,X["W":10080,X["M":40320,1:0),X=X0 D 
+ . I 'XT,X'="NOW",X'="STAT",X'="ONCE",X'="ONE-TIME",X'="ONE TIME",X'="ONETIME",X'="1-TIME",X'="1 TIME",X'="1TIME",Y="" S XT=-1
+SH ;
+ I +Y<1,$E(X0)'="^" W:$G(ON)'["P" "  ",$S(XT=0&($S("^NOW^STAT^ONCE^ONE-TIME^ONETIME^1TIME^1-TIME^"[(U_$P(X," ")_U):1,X["1 TIME":1,1:X["ONE TIME")):"(ONCE ONLY)",XT>0:"Nonstandard schedule",XT<0:"",1:"(??)") W:XT>0 " (",XT," MINUTES)"
+Q Q:X="ONE TIME"
+ N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X0," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 K X0 S:$G(P(7)) XT="" Q
+ ;N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 K X0 S:$G(P(7)) XT="" Q
+ ;S X0=X K:XT<0!($L(X0)>22) X S:$D(X) X=X0 K X0 S:$G(P(7)) XT="" Q
+NEWQ ;N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X0," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 S:P(7) X=X0 K X0 K:XT>0&('P(7)) X Q
+ Q
+ ;
+ENDL W "   Dose limit ....  " S PSIVMIN=P(15)*X,PSIVSD=+P(2)
+ I PSIVMIN<0 W !!," --- There is something wrong with this order !!",!,"     Call inpatient supervisor ....." S Y=-1 K PSIVMIN Q
+ I P(4)="P"!(P(5))!(P(23)="P"),PSIVMIN=0,"^NOW^STAT^ONCE^ONE-TIME^ONE TIME^ON CALL^ONETIME^1TIME^1 TIME^1-TIME^"'[(U_P(9)_U) D DLP G QDL
+ D ENT^PSIVWL
+QDL I $D(X) S X=Y X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) S Y=X
+ Q
+DLP ;
+ S X=X+1,$P(PSIVSD,".",2)=$P(PSIVSD,".",2)_$E("0000",1,4-$L($P(PSIVSD,".",2))) D CHK S X2=0,Y=1 I X<2 S Y=+PSIVSD G QDLP
+ I $P(PSIVSD,".",2)>$P(P(11),"-",$L(P(11),"-")) S X2=1 G OV
+ G:$P(P(11),"-")>$P(PSIVSD,".",2) OV
+ F Y=1:1 S X1=$P(P(11),"-",Y) I X1=$P(PSIVSD,".",2)!($P(PSIVSD,".",2)<X1) Q
+OV I P(11)="" W $C(7)," ???",!?15,"*** You have not defined any administration times !!" K X Q
+ F Y=Y:1 S:$P(P(11),"-",Y)="" X2=X2+1,Y=0,X=X+1 S X=X-1 Q:X<1
+ S X=PSIVSD\1 I X2>0 S X1=PSIVSD D C^%DTC S X=$P(X,".") ; install with version 17.3 of fileman
+ S Y=+(X_"."_$P(P(11),"-",Y))
+QDLP K X1,X2 Q
+ ;
+ENI ;
+ K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X)!'$D(P(4)) Q
+ I P(4)="P"!(P(5))!(P(23)="P") Q:'X  S X="INFUSE OVER "_X_" MIN." W "   ",X Q
+ I X'=+X,($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)) K X Q
+ S SPSOL=$O(DRG("SOL",0)) I 'SPSOL K SPSOL,X W "  You must define at least one solution !!" Q
+ I X=+X S X=X_" ml/hr" W " ml/hr" D SPSOL S P(15)=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q
+ S SPSOL=$P(X,"@",2) S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr" W "   ",+SPSOL," Label",$S(SPSOL'=1:"s",1:"")," per day",!?15,"at an infusion rate of: ",$P(X,"@") S P(15)=$S('SPSOL:0,1:1440/SPSOL\1) K SPSOL
+ Q
+SPSOL S SPSOL=0 F XXX=0:0 S XXX=$O(DRG("SOL",XXX)) Q:'XXX  S SPSOL=SPSOL+$P(DRG("SOL",XXX),U,3)
+ K XXX Q
+CHK F Y=1:1 Q:$L(P(11))>240!($P(P(11),"-",Y)="")  S $P(P(11),"-",Y)=$P(P(11),"-",Y)_$E("0000",1,4-$L($P(P(11),"-",Y)))
+ Q
+ ;
+DIC ; 51.1 look-up
+ N PSJSCH S PSJSCH=X I '$D(WSCHADM) N VAIP D IN5^VADPT S WSCHADM=VAIP(5),X=PSJSCH
+ K DIC S DIC="^PS(51.1,",DIC(0)=$E("E",'$D(NOECH))_"ISZ"
+ S DIC("W")="W ""  "","_$S('$D(WSCHADM):"$P(^(0),""^"",2)",'+WSCHADM:"$P(^(0),""^"",2)",1:"$S($D(^PS(51.1,+Y,1,+WSCHADM,0)):$P(^(0),""^"",2),1:$P(^PS(51.1,+Y,0),""^"",2))"),D="APPSJ" S:$D(PSIVSPQF) DIC(0)=DIC(0)_"O"
+ D IX^DIC K DIC
+ S:$D(DIE)#2 DIC=DIE Q:Y<0
+ S X=Y(0,0),ZZY=Y,(XT,Y)="" I $D(WSCHADM),$D(^PS(51.1,+ZZY,1,+WSCHADM,0)),$P(^(0),"^",2)]"" S (PSIVWAT,Y)=$P(^(0),"^",2)
+ K ZZY,WSCHADM S:Y="" (X,PSIVSC1)=$P(Y(0),U),(PSIVAT,Y)=$P(Y(0),"^",2) S XT=$P(Y(0),"^",3) Q
+ ;
+ORINF ;  OERR input transform for Infusion Rate
+ ;  X=data
+ N INFUSE
+ K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q
+ I X?.E1L.E S INFUSE=$$ENLU^PSGMI(X) Q:(INFUSE="TITRATE")!(INFUSE="BOLUS")
+ Q:(X="TITRATE")!(X="BOLUS")
+ I X["=" D  Q   ; NOIS LOU-0501-42191
+ .N X2,X1 S X1=$P(X,"="),X2=$P(X,"=",2)
+ .I X1["ML/HR",(+X1=$P(X1,"ML/HR"))!(+X1=$P(X1," ML/HR")) D
+ ..S X1=$TR(X1,"ML/HR","ml/hr")
+ .I X2["ML/HR",(+X2=$P(X2,"ML/HR"))!(+X2=$P(X2," ML/HR")) D
+ ..S X2=$TR(X2,"ML/HR","ml/hr")
+ .I X1[" ml/hr",(+X1=$P(X1," ml/hr")) D
+ ..S X1=$P(X1," ml/hr")_$P(X1," ml/hr",2,9999)
+ .I X2[" ml/hr",(+X2=$P(X2," ml/hr")) D
+ ..S X2=$P(X2," ml/hr")_$P(X2," ml/hr",2,9999)
+ .I X1["ml/hr",(+X1=$P(X1,"ml/hr")) D
+ ..S X1=$P(X1,"ml/hr")_$P(X1,"ml/hr",2,9999)
+ .I X2["ml/hr",(+X2=$P(X2,"ml/hr")) D
+ ..S X2=$P(X2,"ml/hr")_$P(X2,"ml/hr",2,9999)
+ .I X2'=+X2 D
+ ..I ($P(X2,"@",2,999)'=+$P(X2,"@",2,999)!(+$P(X2,"@",2,999)<0)) K X Q
+ .I X1=+X1 S X1=X1_" ml/hr"
+ .I X2=+X2 S X2=X2_" ml/hr"
+ .S:$P(X2,"@")=+X2 $P(X2,"@")=$P(X2,"@")_" ml/hr"
+ .S X=X1_"="_X2
+ I X["ML/HR",(+X=$P(X,"ML/HR"))!(+X=$P(X," ML/HR")) S X=$TR(X,"ML/HR","ml/hr")
+ I X[" ml/hr",+X=$P(X," ml/hr") S X=$P(X," ml/hr")_$P(X," ml/hr",2,9999)
+ I X["ml/hr",+X=$P(X,"ml/hr") S X=$P(X,"ml/hr")_$P(X,"ml/hr",2,9999)
+ I X'=+X,($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)) K X Q
+ I X=+X S X=X_" ml/hr" Q
+ S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr"
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVUTL1.m

@@ -1 @@
-PSIVUTL1        ;BIR/MLM-IV UTILITIES ;21 MAY 96 / 10:37 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**58,81,111,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(50.7 is supported by DBIA 2180
-        ; Reference to ^PS(51.2 is supported by DBIA 2178
-        ; Reference to ^PS(52.6 is supported by DBIA 1231
-        ; Reference to ^PS(52.7 is supported by DBIA 2173.
-        ; Reference to ^PS(55 is supported by DBIA 2191
-        ;
-DRGSC(Y,PSJSCT) ; Called to set DIC("S") when selecting orderable item.
-        N OK,ND,NDU,NDI S OK=0 ;* I '$D(^PSDRUG("AP",+Y)) K PSJSCT Q 0
-        S ND=$G(^PS(50.7,+Y,0))
-        I $P(ND,U,3) S OK=$S('$P(ND,U,4):1,$P(ND,U,4)>DT:1,1:0)
-        Q OK
-        ;
-IVDRGSC(Y)      ; Set DIC("S") for IV additive/solution selection.
-        ; Naked reference below refers to full reference in Y, which is either ^PS(52.6, or ^PS(52.7
-        N Y S Y="S X(1)=$G(^(0)),X(2)=$G(^(""I"")) I $S('X(2):1,X(2)>DT:1,1:0),$D(^PSDRUG(+$P(X(1),U,2),0)) S X(2)=$G(^(""I"")) I $S('X(2):1,X(2)>DT:1,1:0)"
-        Q Y
-        ;
-ENU(Y)  ;Get IV additive strength.
-        N X S X=$P(^PS(52.6,+Y,0),U,3),Y=$$CODES^PSIVUTL(X,52.6,2)
-        Q Y
-        ;
-CODES(X,Y)      ; Get name from code.
-        S Y=$P($P(";"_$P(Y,U,3),";"_X_":",2),";")
-        Q Y
-        ;
-GTPCI(Y)        ; Set up "work" area for provider comments.
-        N DIC,DINUM,DLAYGO,X S DIC="^PS(53.45,",DIC(0)="LNZ",DLAYGO=53.45,(DINUM,X)=+DUZ D ^DIC
-        Q Y
-        ;
-WDTE(Y) ; Format and print date.
-        I 'Y S Y="******"
-        E  X ^DD("DD") S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)
-        Q Y
-GTOT(DFN,ON)    ; Get order type for display.
-        N DRGT,DRGI,Y
-        S X=$P($G(^PS(55,DFN,"IV",ON,0)),U,4)
-        S Y=$S(X="A":"F",X="H":"H",1:"I")
-        I Y="F" F DRGT="AD","SOL" F DRGI=0:0 S DRGI=$O(^PS(55,DFN,"IV",+ON,DRGT,DRGI)) Q:'DRGI  I '$P($G(^PS(55,DFN,"IV",+ON,DRGT,DRGI)),U,5) S Y="I" Q
-        Q Y
-        ;
-PIV(ON) ; Display IV orders.
-        N DRG,ON55,P,PSJORIFN,TYP,X,Y S TYP="?" I ON["V" D
-        .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X)
-        .S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"
-        .S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4))
-        I ON'["V" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4)) I $E(P("OT"))="I"  D  Q
-        .S P("PD")=$P($$DRUGNAME^PSJLMUTL(PSGP,ON),"^"),P("DO")=$S($P(DN,"^",2)=.2:$P($G(^PS(55,PSGP,5,+PSJO,.2)),"^",2),1:$G(^PS(55,PSGP,5,+PSJO,.3))),P("DO")=$P(P("DO"),"^")
-        .S Y=$G(^PS(53.1,+ON,.2)),P("MR")=$P($G(^PS(53.1,+ON,0)),U,3)_U_$P($G(^PS(51.2,+$P($G(^PS(53.1,+ON,0)),U,3),0)),U,3)
-        .W ?9,P("PD") D PIV1 W !?11,"Give: ",P("DO")," ",$P(P("MR"),U,2)," ",$S(P(9)]"":P(9),1:P(8))
-        S DRG=0 F  S DRG=$O(DRG("AD",DRG)) Q:'DRG  D PIVAD
-SOL     ;
-        NEW NAME
-        S DRG=0 F  S DRG=$O(DRG("SOL",DRG)) Q:'DRG  D
-        . D NAME(DRG("SOL",DRG),39,.NAME,0)
-        . W ! W:DRG=1 ?9,"in "
-        . F X=0:0 S X=$O(NAME(X)) Q:'X  W ?12 W NAME(X) I X=1,DRG=1,'$D(DRG("AD",1)) D PIV1
-        Q
-PIVAD   ; Print IV Additives.
-        NEW NAME
-        D NAME(DRG("AD",DRG),39,.NAME,1)
-        F X=0:0 S X=$O(NAME(X)) Q:'X  W:DRG'=1 ! W ?9,NAME(X) I X=1,DRG=1 D PIV1
-        Q
-        ;
-PIV1    ; Print Sched type, start/stop dates, and status.
-        F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5))
-        I '$D(PSJEXTP) W ?50,TYP,?53,P(2),?60,P(3),?67,P(17) Q
-        W ?50,TYP,?53,P(2),?63,P(3),?73,P(17)
-        Q
-59      ; Validate the Infusion rate entered using IV Quick order code.
-        N I F I=2,3,5,7,8,9,11,15,23 S P(I)=""
-        S P(4)="A",P(8)=$P($G(^PS(57.1,PSJQO,1)),U,5)
-        I $G(^PS(57.1,PSJQO,4,1,0)) S DRG("SOL",1)=^(0),DRG("SOL",0)=1
-        I X["?" S F1=53.1,F2=59 D ENHLP^PSIVORC1 G 59
-        I X]"" D ENI^PSIVSP S:$D(X) P(8)=X
-        Q
-WRTDRG(X,L)           ; Format and print drug name, strength and bottle no.
-        N Y S Y=" "_$P(X,U,3) S:$P(X,U,4) Y=Y_" ("_$P(X,U,4)_")"
-        Q $E($P(X,U,2),1,(L-$L(Y)))_Y
-NAME(X,L,NAME,AD)              ; Format Additive display.
-        ;INPUT : X=DRG("AD",DRG)  L=Display length   AD=for Addtive(1/0)
-        ;OUTPUT: AD(X)  if X=2 that means there is a second line to display
-        K NAME
-        NEW Y S Y=$P(X,U,3) S:(AD&$P(X,U,4)) Y=Y_" ("_$P(X,U,4)_")"
-        S:'AD Y=Y_" "_$S(P(4)="P"!($G(P(23))="P")!$G(P(5)):P(9),1:$P(P(8),"@"))
-        I ($L($P(X,U,2))+$L(Y)+1)>L S NAME(1)=$P(X,U,2),NAME(2)="   "_Y Q
-        S NAME(1)=$P(X,U,2)_" "_Y
-        Q
-        ;
-CNVTOM(RATE,TVOL)       ; Convert volume to minutes
-        ; Input:
-        ;   RATE - Infusion Rate
-        ;   TVOL - Volume being infused, EX: m100 (100 Milliliters) or l5 (5 Liters)
-        ; Output:
-        ;   MINS - Minutes required to infuse volume
-        N DAYS,ML,MLSHR
-        ; Get rate in terms of mils per hour
-        I 'RATE Q 0
-        I RATE<1 S RATE=1
-        S TVOL=$S($E(TVOL)="m":$E(TVOL,2,9),$E(TVOL)="l":$E(TVOL,2,9)*1000,1:0) Q:'TVOL 0
-        ; Find IV duration in minutes
-        S MINS=(TVOL/RATE)*60
-        Q MINS
-        ;
-GETMIN(LIM,DFN,PSJORD,DAYS)     ;
-        N F,DDLX
-        I LIM!(LIM=0) Q LIM
-        S F=$S(PSJORD["P":"^PS(53.1,+PSJORD,",PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD,",1:"")
-        N RATE S RATE=$S(PSJORD["P":+$P($G(@(F_"8)")),"^",5),PSJORD["V":+$P($G(@(F_"0)")),"^",8),1:0)
-        I (",l,m,")[(","_$E(LIM)_",") D
-        .I RATE D
-        ..I RATE<1 S RATE=1
-        ..S MIN=$$CNVTOM(RATE,LIM) I MIN S LIM=MIN
-        .I 'RATE N SOL,SOLVOL,DOSVOL,DUR,STOP,OIX,X S (SOLVOL,DOSVOL)="" D
-        ..S SOL=0 F  S SOL=$O(@(F_"""SOL"",SOL)")) Q:'SOL  D
-        ...S SOLVOL=$P(@(F_"""SOL"",SOL,0)"),"^",2) I SOLVOL S DOSVOL=DOSVOL+SOLVOL
-        ..S DDLX=$S($E(LIM)["l":(($E(LIM,2,99)*1000)/DOSVOL),1:($E(LIM,2,99)/DOSVOL))_"L"
-        I (",a,")[(","_$E(LIM)_",") S DDLX=$E(LIM,2,99)_"L"
-        I $G(DDLX)>0 D
-        .N STOP,LASTD S DAYS="",STOP=""
-        .S OIX=$P($G(@(F_".2)")),"^") S:(DDLX<1) DDLX="1L" S LASTD=$$DOSES^PSIVCAL(DDLX,.P)
-        .I LASTD,$G(P(2)) S DAYS=$$FMDIFF^XLFDT(LASTD,P(2),2) I DAYS>0 S DAYS=DAYS/86400
-        .I DAYS>0 S LIM=DAYS*1440
-        I (",h,d,")[(","_$E(LIM)_",") S LIM=$S($E(LIM)="d":(1440*$E(LIM,2,99)),1:(60*$E(LIM,2,99))) Q
-        Q LIM
+PSIVUTL1 ;BIR/MLM-IV UTILITIES ;21 MAY 96 / 10:37 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**58,81,111**;16 DEC 97
+ ;
+ ; Reference to ^PS(50.7 is supported by DBIA 2180
+ ; Reference to ^PS(51.2 is supported by DBIA 2178
+ ; Reference to ^PS(52.6 is supported by DBIA 1231
+ ; Reference to ^PS(55 is supported by DBIA 2191
+ ;
+DRGSC(Y,PSJSCT) ; Called to set DIC("S") when selecting orderable item.
+ N OK,ND,NDU,NDI S OK=0 ;* I '$D(^PSDRUG("AP",+Y)) K PSJSCT Q 0
+ S ND=$G(^PS(50.7,+Y,0))
+ I $P(ND,U,3) S OK=$S('$P(ND,U,4):1,$P(ND,U,4)>DT:1,1:0)
+ Q OK
+ ;
+IVDRGSC(Y) ; Set DIC("S") for IV additive/solution selection.
+ N Y S Y="S X(1)=$G(^(0)),X(2)=$G(^(""I"")) I $S('X(2):1,X(2)>DT:1,1:0),$D(^PSDRUG(+$P(X(1),U,2),0)) S X(2)=$G(^(""I"")) I $S('X(2):1,X(2)>DT:1,1:0)"
+ Q Y
+ ;
+ENU(Y) ;Get IV additive strength.
+ N X S X=$P(^PS(52.6,+Y,0),U,3),Y=$$CODES^PSIVUTL(X,52.6,2)
+ Q Y
+ ;
+CODES(X,Y) ; Get name from code.
+ S Y=$P($P(";"_$P(Y,U,3),";"_X_":",2),";")
+ Q Y
+ ;
+GTPCI(Y) ; Set up "work" area for provider comments.
+ N DIC,DINUM,DLAYGO,X S DIC="^PS(53.45,",DIC(0)="LNZ",DLAYGO=53.45,(DINUM,X)=+DUZ D ^DIC
+ Q Y
+ ;
+WDTE(Y) ; Format and print date.
+ I 'Y S Y="******"
+ E  X ^DD("DD") S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)
+ Q Y
+GTOT(DFN,ON) ; Get order type for display.
+ N DRGT,DRGI,Y
+ S X=$P($G(^PS(55,DFN,"IV",ON,0)),U,4)
+ S Y=$S(X="A":"F",X="H":"H",1:"I")
+ I Y="F" F DRGT="AD","SOL" F DRGI=0:0 S DRGI=$O(^PS(55,DFN,"IV",+ON,DRGT,DRGI)) Q:'DRGI  I '$P($G(^PS(55,DFN,"IV",+ON,DRGT,DRGI)),U,5) S Y="I" Q
+ Q Y
+ ;
+PIV(ON) ; Display IV orders.
+ N DRG,ON55,P,PSJORIFN,TYP,X,Y S TYP="?" I ON["V" D
+ .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X)
+ .S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"
+ .S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4))
+ I ON'["V" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4)) I $E(P("OT"))="I"  D  Q
+ .S P("PD")=$P($$DRUGNAME^PSJLMUTL(PSGP,ON),"^"),P("DO")=$S($P(DN,"^",2)=.2:$P($G(^PS(55,PSGP,5,+PSJO,.2)),"^",2),1:$G(^PS(55,PSGP,5,+PSJO,.3))),P("DO")=$P(P("DO"),"^")
+ .S Y=$G(^PS(53.1,+ON,.2)),P("MR")=$P($G(^PS(53.1,+ON,0)),U,3)_U_$P($G(^PS(51.2,+$P($G(^PS(53.1,+ON,0)),U,3),0)),U,3)
+ .W ?9,P("PD") D PIV1 W !?11,"Give: ",P("DO")," ",$P(P("MR"),U,2)," ",$S(P(9)]"":P(9),1:P(8))
+ S DRG=0 F  S DRG=$O(DRG("AD",DRG)) Q:'DRG  D PIVAD
+SOL ;
+ NEW NAME
+ S DRG=0 F  S DRG=$O(DRG("SOL",DRG)) Q:'DRG  D
+ . D NAME(DRG("SOL",DRG),39,.NAME,0)
+ . W ! W:DRG=1 ?9,"in "
+ . F X=0:0 S X=$O(NAME(X)) Q:'X  W ?12 W NAME(X) I X=1,DRG=1,'$D(DRG("AD",1)) D PIV1
+ Q
+PIVAD ; Print IV Additives.
+ NEW NAME
+ D NAME(DRG("AD",DRG),39,.NAME,1)
+ F X=0:0 S X=$O(NAME(X)) Q:'X  W:DRG'=1 ! W ?9,NAME(X) I X=1,DRG=1 D PIV1
+ Q
+ ;
+PIV1 ; Print Sched type, start/stop dates, and status.
+ F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5))
+ I '$D(PSJEXTP) W ?50,TYP,?53,P(2),?60,P(3),?67,P(17) Q
+ W ?50,TYP,?53,P(2),?63,P(3),?73,P(17)
+ Q
+59 ; Validate the Infusion rate entered using IV Quick order code.
+ N I F I=2,3,5,7,8,9,11,15,23 S P(I)=""
+ S P(4)="A",P(8)=$P($G(^PS(57.1,PSJQO,1)),U,5)
+ I $G(^PS(57.1,PSJQO,4,1,0)) S DRG("SOL",1)=^(0),DRG("SOL",0)=1
+ I X["?" S F1=53.1,F2=59 D ENHLP^PSIVORC1 G 59
+ I X]"" D ENI^PSIVSP S:$D(X) P(8)=X
+ Q
+WRTDRG(X,L)       ; Format and print drug name, strength and bottle no.
+ N Y S Y=" "_$P(X,U,3) S:$P(X,U,4) Y=Y_" ("_$P(X,U,4)_")"
+ Q $E($P(X,U,2),1,(L-$L(Y)))_Y
+ ;Q $E($$ENPDN^PSGMI($P(X,U,6)),1,(L-$L(Y)))_Y
+NAME(X,L,NAME,AD)        ; Format Additive display.
+ ;INPUT : X=DRG("AD",DRG)  L=Display length   AD=for Addtive(1/0)
+ ;OUTPUT: AD(X)  if X=2 that means there is a second line to display
+ K NAME
+ NEW Y S Y=$P(X,U,3) S:(AD&$P(X,U,4)) Y=Y_" ("_$P(X,U,4)_")"
+ S:'AD Y=Y_" "_$S(P(4)="P"!($G(P(23))="P")!$G(P(5)):P(9),1:$P(P(8),"@"))
+ I ($L($P(X,U,2))+$L(Y)+1)>L S NAME(1)=$P(X,U,2),NAME(2)="   "_Y Q
+ S NAME(1)=$P(X,U,2)_" "_Y
+ Q
+ ;
+CNVTOM(RATE,TVOL) ; Convert volume to minutes
+ N DAYS,ML,MLSHR
+ ; Get rate in terms of mils per hour
+ I 'RATE Q 0
+ S TVOL=$S($E(TVOL)="m":$E(TVOL,2,9),$E(TVOL)="l":$E(TVOL,2,9)*1000,1:0) Q:'TVOL 0
+ ; Find IV duration in minutes
+ S MINS=(TVOL/RATE)*60 S MINS=MINS+1
+ Q MINS

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL2.m

@@ -1 @@
-PSJHL2  ;BIR/RLW-PATIENT ID AND VISIT SEGMENTS ;22 Nov 1999  9:27 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**1,18,16,23,28,42,50,70,58,100,102,110,111,112,144,141,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(55 is supported by DBIA# 2191.
-        ; Reference to ^ORERR is supported by DBIA# 2187.
-        ; Reference to ^ORHLESC IS supported by DBIA# 4922.
-        ;
-EN1(PSJHLDFN,PSOC,PSJORDER,PSREASON)    ; start here
-        ; passed in are PSJHLDFN (patient ien)
-        ;               PSJORDER* (order_file (N,P,V, etc))
-        ;               PSOC* (order control code - NW for new order, OK to return filler number to OE/RR, OC for order canceled, SC for status change)
-        ;               PSREASON* (text reason)
-        ; *=optional, only required if an order segment is also to be generated
-START   ;
-        K ^TMP("PSJHLS",$J,"PS")
-        N CLERK,J,LIMIT,NAME,NEXT,NODE1,NODE2,NODE4,NOO,PSJCLEAR,PSJHINST,PSJHLSDT,PROVIDER,PSJI,ROOMBED,RXORDER,STATUS,UNDO,VERIFY,WARD,PSGST,DUR
-        S RXORDER=PSJORDER,PSJORDER=$S((PSJORDER["N")!(PSJORDER["P"):"^PS(53.1,"_+PSJORDER,PSJORDER["V":"^PS(55,"_PSJHLDFN_",""IV"","_+PSJORDER,1:"^PS(55,"_PSJHLDFN_",5,"_+PSJORDER)_","
-        I RXORDER["P",$P($G(@(PSJORDER_"0)")),U,15)'=PSJHLDFN S ORDCON="Patient does not match/PSJHL2" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON) Q
-        S UNDO=$S("OC^CR"[PSOC:1,1:0)
-        D INIT,PID,PV1,ORC
-        D @$S("SN^SC^OC^OD^DR^CR^OH^OR^XX^ZC^XR"[PSOC:"EN1^PSJHL3(PSJHLDFN,PSOC,PSJORDER)",1:"CALL^PSJHLU(PSJI)")
-        I UNDO D UNDO
-        K ^TMP("PSJHLS",$J,"PS"),FIELD
-        Q
-        ;
-INIT    ; initialize HL7 variables, set master file identification segment
-        ; PSJHLMTN = message type - ORR for messages sent as a response to an OE/RR event; ORM for "unsolicited" messages.
-        S PSJI=0,PSJHLMTN=$S($G(PSJHLMTN)]"":PSJHLMTN,1:"ORM")
-        D INIT^PSJHLU
-        S LIMIT=17 X PSJCLEAR
-        S FIELD(0)="MSH",FIELD(1)="^~\&",FIELD(2)="PHARMACY",FIELD(3)=$G(PSJHINST),FIELD(8)=PSJHLMTN
-        D SEGMENT^PSJHLU(LIMIT),DISPLAY
-        Q
-        ;
-PID     ; get patient data, format PID SEGMENT
-        S LIMIT=22 X PSJCLEAR
-        S FIELD(0)="PID"
-        S FIELD(3)=PSJHLDFN
-        N DFN S DFN=PSJHLDFN D DEM^VADPT S FIELD(5)=VADM(1)
-        I '$G(PSJBCBU) S FIELD(5)=$$ESC^ORHLESC(FIELD(5))
-        D SEGMENT^PSJHLU(LIMIT),DISPLAY
-        Q
-        ;
-PV1     ; get patient visit information, format PV1 segment
-        N PSJAPPT
-        S LIMIT=50 X PSJCLEAR
-        S FIELD(0)="PV1"
-        I PSJHLMTN="ORR" S FIELD(3)=LOC
-        I PSJHLMTN="ORM" D
-        .S LOC="",WARD=$G(^DPT(PSJHLDFN,.1)),LOC=$S($G(WARD)]"":$O(^SC("B",WARD,LOC)),1:LOC)
-        .I $G(LOC)="" D
-        .. N A
-        .. I RXORDER["P",($G(^PS(53.1,+RXORDER,"DSS"))) S A=^("DSS"),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2)
-        .. I RXORDER["V",($G(^PS(55,PSJHLDFN,"IV",+RXORDER,"DSS"))) S A=^("DSS"),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2)
-        .. I RXORDER["U",$G(^PS(55,PSJHLDFN,5,+RXORDER,8)) S A=^(8),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2)
-        .I $G(LOC)]"" S ROOMBED=$G(^DPT(PSJHLDFN,.101)) S LOC=LOC_"^"_$S($G(PSJBCBU):ROOMBED,1:$$ESC^ORHLESC(ROOMBED))
-        .S FIELD(3)=LOC I $G(PSJAPPT)]"" S FIELD(44)=$$FMTHL7^XLFDT(PSJAPPT)
-        S FIELD(2)=$S($G(CLASS)="O":CLASS,1:"I")
-        I FIELD(2)="I" N DFN S DFN=PSJHLDFN D INP^VADPT S FIELD(19)=VAIN(1)
-        D SEGMENT^PSJHLU(LIMIT),DISPLAY
-        Q
-        ;
-ORC     ; order control segment
-        S LIMIT=18 X PSJCLEAR
-        Q:'$D(PSJORDER)!'$D(PSOC)
-        S NODE1=$G(@(PSJORDER_"0)")),NODE2=$G(@(PSJORDER_"2)"))
-        S NODE4=$G(@(PSJORDER_"4)"))
-        I $G(PSGST)="" N PSGST D
-        .S PSGST=$P($G(NODE1),"^",7)
-        S FIELD(0)="ORC"
-        S FIELD(1)=PSOC
-        S FIELD(2)=$S(PSOC="SN":"",1:$P(NODE1,"^",21))_"^OR" I $P(FIELD(2),"^")=0 S $P(FIELD(2),"^")="" ; IV orders are created with a zero in the oerr order number, for some reason
-        S FIELD(3)=RXORDER_"^PS"
-        ; translate Pharmacy status code to HL7 status code, set in FIELD(5)
-        S STATUS=$S($G(PSJEXPOE):"E",(($P(NODE1,"^",17)]"")&(RXORDER["V")):($P(NODE1,"^",17)),($P(NODE1,"^",9)]""):$P(NODE1,"^",9),$G(PSIVCOPY):"DE",1:"")
-        ;BHW;Remedy HD0000000086717;If the order has a pending number, send pending status even if current status is Active.
-        I STATUS="A",RXORDER["P" S STATUS="N" D @STATUS S STATUS="A"
-        E  D @STATUS
-        I STATUS="U",RXORDER["P" S FIELD(3)="^PS"
-        S FIELD(7)="^"_$S(RXORDER["V":$P(NODE1,"^",9)_"&"_$P(NODE1,"^",11),1:$P(NODE2,"^")_"&"_$P(NODE2,"^",5))_"^^^^^"_$G(PSGST)
-        S FIELD(9)=$S(RXORDER["V":$$FMTHL7^XLFDT($P(NODE2,"^")),1:$$FMTHL7^XLFDT($P(NODE1,"^",16)))
-        S CLERK=$S(RXORDER["V":$P(NODE2,"^",11),1:$P(NODE4,"^",7))
-        S NAME=$P($G(^VA(200,+CLERK,0)),"^")
-        S FIELD(10)=CLERK_"^"_$S($G(PSJBCBU):NAME,1:$$ESC^ORHLESC(NAME))
-        I PSOC="ZV"!($G(PSJBCBU)) S VERIFY=$P($G(NODE4),"^"),FIELD(11)=VERIFY_"^"_$S($G(PSJBCBU):$P($G(^VA(200,+VERIFY,0)),"^"),1:$$ESC^ORHLESC($P($G(^VA(200,+VERIFY,0)),"^"))),FIELD(9)=$$FMTHL7^XLFDT($P(NODE4,"^",2))
-        S PROVIDER=$S($G(PSJDCPRV)]"":$G(PSJDCPRV),RXORDER["V":$P(NODE1,"^",6),1:$P(NODE1,"^",2)) K PSJDCPRV
-        S NAME=$P($G(^VA(200,+PROVIDER,0)),"^")
-        S FIELD(12)=PROVIDER_"^"_NAME
-        S FIELD(15)=$S(RXORDER["V":$$FMTHL7^XLFDT($P(NODE1,"^",2)),1:$$FMTHL7^XLFDT($P(NODE2,"^",2)))
-        I $S(RXORDER["V":$P(NODE2,"^",8)="R",1:$P(NODE1,"^",24)="R")
-        ; PSJ*5*141 - If this is a renewal order, update FIELD(10) with the person who entered the renewal order.
-        N FIELD9 S FIELD9=$$FMTHL7^XLFDT($$LASTREN^PSJLMPRI(PSJHLDFN,RXORDER)) I FIELD9>FIELD(9) S FIELD(9)=FIELD9,FIELD(15)=FIELD9,FIELD(10)=$$LASTRNBY^PSJLMPRI(PSJHLDFN,RXORDER)
-        S NOO=$S(PSJORDER["IV":$G(P("NAT")),(($G(PSJNOO)="")&($G(P("NAT"))]"")):$G(P("NAT")),1:$G(PSJNOO)),PSREASON=$S(NOO="D":"",1:$G(PSREASON))
-        S FIELD(16)=NOO_U_$S(NOO="P":"Telephoned",NOO="D":"Duplicate",NOO="X":"Rejected",NOO="A":"Auto",NOO="S":"Service Correction",NOO="W":"Written",NOO="V":"Verbal",NOO="E":"Physician Entered",NOO="I":"Policy",1:"")_U_"99ORN"_U_U_$G(PSREASON)_U
-        D SEGMENT^PSJHLU(LIMIT),DISPLAY
-        Q
-        ;
-DISPLAY ; just for testing
-        I $G(MSGTEST) W ! F NEXT=0:1:LIMIT W FIELD(NEXT)_"|"
-        Q
-UNDO    ;Undo Renew if Pending Renewal is dc'd
-        I RXORDER["P",(STATUS="D"),($G(PSJNOO)'="A"),($P(NODE1,U,24)="R") D ENBKOUT^PSJOREN(PSJHLDFN,RXORDER)
-        Q
-        ;
-A       S FIELD(5)="CM" Q  ; active
-D       S FIELD(5)="DC" Q  ; discontinued
-I       S FIELD(5)="IP" Q  ; incomplete
-N       S FIELD(5)="IP" Q  ; non-verified
-U       S FIELD(5)="ZX" Q  ; unreleased
-P       S FIELD(5)="IP" Q  ; pending
-DE      S FIELD(5)="RP" Q  ; discontinued (edit)
-E       S FIELD(5)="ZE" Q  ; expired
-H       S FIELD(5)="HD" Q  ; hold
-R       S FIELD(5)="ZZ" Q  ; renewed
-RE      S FIELD(5)="CM" Q  ; reinstated
-DR      S FIELD(5)="DC" Q  ; discontinued (renewal)
-O       S FIELD(5)="HD" Q  ; on call (is this kind of like HOLD?)
+PSJHL2 ;BIR/RLW-PATIENT ID AND VISIT SEGMENTS ;22 Nov 1999  9:27 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**1,18,16,23,28,42,50,70,58,100,102,110,111,112,144,141**;16 DEC 97
+ ;
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^ORERR is supported by DBIA# 2187.
+ ;
+EN1(PSJHLDFN,PSOC,PSJORDER,PSREASON) ; start here
+ ; passed in are PSJHLDFN (patient ien)
+ ;               PSJORDER* (order_file (N,P,V, etc))
+ ;               PSOC* (order control code - NW for new order, OK to return filler number to OE/RR, OC for order canceled, SC for status change)
+ ;               PSREASON* (text reason)
+ ; *=optional, only required if an order segment is also to be generated
+START ;
+ K ^TMP("PSJHLS",$J,"PS")
+ N CLERK,J,LIMIT,NAME,NEXT,NODE1,NODE2,NODE4,NOO,PSJCLEAR,PSJHINST,PSJHLSDT,PROVIDER,PSJI,ROOMBED,RXORDER,STATUS,UNDO,VERIFY,WARD
+ S RXORDER=PSJORDER,PSJORDER=$S((PSJORDER["N")!(PSJORDER["P"):"^PS(53.1,"_+PSJORDER,PSJORDER["V":"^PS(55,"_PSJHLDFN_",""IV"","_+PSJORDER,1:"^PS(55,"_PSJHLDFN_",5,"_+PSJORDER)_","
+ I RXORDER["P",$P($G(@(PSJORDER_"0)")),U,15)'=PSJHLDFN S ORDCON="Patient does not match/PSJHL2" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON) Q
+ S UNDO=$S("OC^CR"[PSOC:1,1:0)
+ D INIT,PID,PV1,ORC
+ D @$S("SN^SC^OC^OD^DR^CR^OH^OR^XX^ZC^XR"[PSOC:"EN1^PSJHL3(PSJHLDFN,PSOC,PSJORDER)",1:"CALL^PSJHLU(PSJI)")
+ I UNDO D UNDO
+ K ^TMP("PSJHLS",$J,"PS"),FIELD
+ Q
+ ;
+INIT ; initialize HL7 variables, set master file identification segment
+ ; PSJHLMTN = message type - ORR for messages sent as a response to an OE/RR event; ORM for "unsolicited" messages.
+ S PSJI=0,PSJHLMTN=$S($G(PSJHLMTN)]"":PSJHLMTN,1:"ORM")
+ D INIT^PSJHLU
+ S LIMIT=17 X PSJCLEAR
+ S FIELD(0)="MSH",FIELD(1)="^~\&",FIELD(2)="PHARMACY",FIELD(3)=$G(PSJHINST),FIELD(8)=PSJHLMTN
+ D SEGMENT^PSJHLU(LIMIT),DISPLAY
+ Q
+ ;
+PID ; get patient data, format PID SEGMENT
+ S LIMIT=22 X PSJCLEAR
+ S FIELD(0)="PID"
+ S FIELD(3)=PSJHLDFN
+ N DFN S DFN=PSJHLDFN D DEM^VADPT S FIELD(5)=VADM(1)
+ D SEGMENT^PSJHLU(LIMIT),DISPLAY
+ Q
+ ;
+PV1 ; get patient visit information, format PV1 segment
+ N PSJAPPT
+ S LIMIT=50 X PSJCLEAR
+ S FIELD(0)="PV1"
+ I PSJHLMTN="ORR" S FIELD(3)=LOC
+ I PSJHLMTN="ORM" D
+ .S LOC="",WARD=$G(^DPT(PSJHLDFN,.1)),LOC=$S($G(WARD)]"":$O(^SC("B",WARD,LOC)),1:LOC)
+ .I $G(LOC)="" D
+ .. N A
+ .. I RXORDER["P",($G(^PS(53.1,+RXORDER,"DSS"))) S A=^("DSS"),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2)
+ .. I RXORDER["V",($G(^PS(55,PSJHLDFN,"IV",+RXORDER,"DSS"))) S A=^("DSS"),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2)
+ .. I RXORDER["U",$G(^PS(55,PSJHLDFN,5,+RXORDER,8)) S A=^(8),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2)
+ .I $G(LOC)]"" S ROOMBED=$G(^DPT(PSJHLDFN,.101)),LOC=LOC_"^"_ROOMBED
+ .S FIELD(3)=LOC I $G(PSJAPPT)]"" S FIELD(44)=$$FMTHL7^XLFDT(PSJAPPT)
+ S FIELD(2)=$S($G(CLASS)="O":CLASS,1:"I")
+ I FIELD(2)="I" N DFN S DFN=PSJHLDFN D INP^VADPT S FIELD(19)=VAIN(1)
+ D SEGMENT^PSJHLU(LIMIT),DISPLAY
+ Q
+ ;
+ORC ; order control segment
+ S LIMIT=18 X PSJCLEAR
+ Q:'$D(PSJORDER)!'$D(PSOC)
+ S NODE1=$G(@(PSJORDER_"0)")),NODE2=$G(@(PSJORDER_"2)"))
+ S NODE4=$G(@(PSJORDER_"4)"))
+ S FIELD(0)="ORC"
+ S FIELD(1)=PSOC
+ S FIELD(2)=$S(PSOC="SN":"",1:$P(NODE1,"^",21))_"^OR" I $P(FIELD(2),"^")=0 S $P(FIELD(2),"^")="" ; IV orders are created with a zero in the oerr order number, for some reason
+ S FIELD(3)=RXORDER_"^PS"
+ ; translate Pharmacy status code to HL7 status code, set in FIELD(5)
+ S STATUS=$S($G(PSJEXPOE):"E",(($P(NODE1,"^",17)]"")&(RXORDER["V")):($P(NODE1,"^",17)),($P(NODE1,"^",9)]""):$P(NODE1,"^",9),$G(PSIVCOPY):"DE",1:"")
+ ;BHW;Remedy HD0000000086717;If the order has a pending number, send pending status even if current status is Active.
+ I STATUS="A",RXORDER["P" S STATUS="N" D @STATUS S STATUS="A"
+ E  D @STATUS
+ I STATUS="U",RXORDER["P" S FIELD(3)="^PS"
+ S FIELD(9)=$S(RXORDER["V":$$FMTHL7^XLFDT($P(NODE2,"^")),1:$$FMTHL7^XLFDT($P(NODE1,"^",16)))
+ S CLERK=$S(RXORDER["V":$P(NODE2,"^",11),1:$P(NODE4,"^",7))
+ S NAME=$P($G(^VA(200,+CLERK,0)),"^")
+ S FIELD(10)=CLERK_"^"_NAME
+ I PSOC="ZV"!($G(PSJBCBU)) S VERIFY=$P($G(NODE4),"^"),FIELD(11)=VERIFY_"^"_$P($G(^VA(200,+VERIFY,0)),"^"),FIELD(9)=$$FMTHL7^XLFDT($P(NODE4,"^",2))
+ S PROVIDER=$S($G(PSJDCPRV)]"":$G(PSJDCPRV),RXORDER["V":$P(NODE1,"^",6),1:$P(NODE1,"^",2)) K PSJDCPRV
+ S NAME=$P($G(^VA(200,+PROVIDER,0)),"^")
+ S FIELD(12)=PROVIDER_"^"_NAME
+ S FIELD(15)=$S(RXORDER["V":$$FMTHL7^XLFDT($P(NODE1,"^",2)),1:$$FMTHL7^XLFDT($P(NODE2,"^",2)))
+ I $S(RXORDER["V":$P(NODE2,"^",8)="R",1:$P(NODE1,"^",24)="R")
+ ; PSJ*5*141 - If this is a renewal order, update FIELD(10) with the person who entered the renewal order.
+ N FIELD9 S FIELD9=$$FMTHL7^XLFDT($$LASTREN^PSJLMPRI(PSJHLDFN,RXORDER)) I FIELD9>FIELD(9) S FIELD(9)=FIELD9,FIELD(15)=FIELD9,FIELD(10)=$$LASTRNBY^PSJLMPRI(PSJHLDFN,RXORDER)
+ S NOO=$S(PSJORDER["IV":$G(P("NAT")),(($G(PSJNOO)="")&($G(P("NAT"))]"")):$G(P("NAT")),1:$G(PSJNOO)),PSREASON=$S(NOO="D":"",1:$G(PSREASON))
+ S FIELD(16)=NOO_U_$S(NOO="P":"Telephoned",NOO="D":"Duplicate",NOO="X":"Rejected",NOO="A":"Auto",NOO="S":"Service Correction",NOO="W":"Written",NOO="V":"Verbal",NOO="E":"Physician Entered",NOO="I":"Policy",1:"")_U_"99ORN"_U_U_$G(PSREASON)_U
+ D SEGMENT^PSJHLU(LIMIT),DISPLAY
+ Q
+ ;
+DISPLAY ; just for testing
+ I $G(MSGTEST) W ! F NEXT=0:1:LIMIT W FIELD(NEXT)_"|"
+ Q
+UNDO ;Undo Renew if Pending Renewal is dc'd
+ I RXORDER["P",(STATUS="D"),($G(PSJNOO)'="A"),($P(NODE1,U,24)="R") D ENBKOUT^PSJOREN(PSJHLDFN,RXORDER)
+ Q
+ ;
+A S FIELD(5)="CM" Q  ; active
+D S FIELD(5)="DC" Q  ; discontinued
+I S FIELD(5)="IP" Q  ; incomplete
+N S FIELD(5)="IP" Q  ; non-verified
+U S FIELD(5)="ZX" Q  ; unreleased
+P S FIELD(5)="IP" Q  ; pending
+DE S FIELD(5)="RP" Q  ; discontinued (edit)
+E S FIELD(5)="ZE" Q  ; expired
+H S FIELD(5)="HD" Q  ; hold
+R S FIELD(5)="ZZ" Q  ; renewed
+RE S FIELD(5)="CM" Q  ; reinstated
+DR S FIELD(5)="DC" Q  ; discontinued (renewal)
+O S FIELD(5)="HD" Q  ; on call (is this kind of like HOLD?)

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL3.m

@@ -1 @@
-PSJHL3  ;BIR/RLW-PHARMACY ORDER SEGMENTS ;04 Aug 98 / 10:10 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**1,11,14,40,42,47,50,56,58,92,101,102,123,110,111,152,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(50.606 is supported by DBIA# 2174.
-        ; Reference to ^PS(50.607 is supported by DBIA# 2221.        
-        ; Reference to ^PS(50.7 is supported by DBIA# 2180.
-        ; Reference to ^PS(51.2 is supported by DBIA# 2178.
-        ; Reference to ^PS(52.6 is supported by DBIA# 1231.
-        ; Reference to ^PS(52.7 is supported by DBIA# 2173.
-        ; Reference to ^PS(55 is supported by DBIA# 2191.
-        ; Reference to ^PSDRUG( is supported by DBIA# 2192.
-        ; Reference to ^PSNDF( is supported by DBIA# 2195.
-        ; Reference to ^VA(200 is supported by DBIA# 10060.
-        ; Reference to ^PSNAPIS is supported by DBIA# 2531.
-        ; Reference to ^XLFDT is supported by DBIA# 10103.
-        ; Reference to ^PSSUTIL1 is supported by DBIA# 3179.
-        ; Reference to ^ORHLESC is supported by DBIA# 4922.
-        ;
-EN1(PSJHLDFN,PSOC,PSJORDER)     ; start here
-        ; passed in are PSJHLDFN (patient ien)
-        ;               PSJORDER (file root of order)
-        ;               OC (order control code - NW for new order, OK for finished order, OC for order canceled)
-        I $G(PSJHLDFN)']""!$G(PSOC)']""!$G(PSJORDER)']"" W !,"INSUFFICIENT DATA FOR ^PSJHL3" Q
-        N COMMENTS,DDIEA,DDNUM,DOSE,DOSEFORM,DOSEOR,NAME,DURATION,IVTYPE,NODE1,NODE2,NDNODE,OINODE,PSGPLS,PSGPLF,PRODNAME,SPDIEN,UNIT,UNITS,CNT,DDIEN,SCHEDULE,PSGST
-        D INIT
-        S IVTYPE=$S(RXORDER["U":"",1:$$IVTYPE^PSJHLU(PSJORDER))
-        D RXO,RXE,RXR D ZRX
-        D CALL^PSJHLU(PSJI)
-        Q
-INIT    ; initialize HL7 variables
-        D INIT^PSJHLU
-        Q
-RXO     ; pharmacy prescription order segment (used to send Orderable Item to OE/RR)
-        S LIMIT=17 X PSJCLEAR
-        S FIELD(0)="RXO"
-        S OINODE=$G(@(PSJORDER_".2)"))
-        S SPDIEN=+$P(OINODE,"^"),DOSEOR=$$ESC^ORHLESC($P(OINODE,"^",2)),DOSE=$P(OINODE,"^",5),UNIT=$P(OINODE,"^",6) S:'$G(PSJBCBU) UNIT=$$ESC^ORHLESC(UNIT)
-        S FIELD(1)=$S(SPDIEN=0:"^^^^",1:"^^^"_SPDIEN_"^")
-        I SPDIEN S DOSEFORM=$P($G(^PS(50.7,SPDIEN,0)),"^",2),NAME=$P($G(^PS(50.606,+DOSEFORM,0)),"^") S:'$G(PSJBCBU) NAME=$$ESC^ORHLESC(NAME) S FIELD(1)=FIELD(1)_$$ESC^ORHLESC($P($G(^PS(50.7,SPDIEN,0)),"^"))_" "_NAME
-        S FIELD(1)=FIELD(1)_"^99PSP"
-        N IVLNOD S IVLNOD=$G(@(PSJORDER_"2.5)")) D
-        .S IVLIM=$P(IVLNOD,"^",4) I IVLIM?1"a".N S IVLIM="doses"_$P(IVLIM,"a",2)
-        .S $P(FIELD(1),"^",3)=IVLIM
-        D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
-        Q
-RXE     ; pharmacy encoded order segment
-        S (UNITS,NDNODE,SPDIEN,PRODNAME,DDNUM,DDIEN,CNT)="",LIMIT=26 X PSJCLEAR
-        S FIELD(0)="RXE"
-        S NODE1=$G(@(PSJORDER_"0)")),NODE2=$G(@(PSJORDER_"2)")),NODEPT2=$G(@(PSJORDER_".2)"))
-         I $G(PSGST)="" N PSGST D
-        .I $G(RXORDER)["V" N X,ZZND,LYN,PSGS0XT,PSGS0Y,PSGOES S PSGOES=1 S X=$G(P(9)) I X]"" D EN^PSGS0 S:$G(ZZND)'="" PSGST=$P(ZZND,"^",5) Q
-        .S PSGST=$P($G(NODE1),"^",7)
-        I RXORDER["V" D IVRXE Q
-        I RXORDER["P",IVTYPE="F" D IVRXE Q
-        I RXORDER["P",$P(NODE1,"^",4)="H" D IVRXE Q
-        N RENEW S RENEW=$$LASTREN^PSJLMPRI(PSJHLDFN,RXORDER)
-        S PSGPLS=$S($G(PSJEXPOE):$P(NODE2,"^",2),RENEW>$P(NODE2,"^",2):RENEW,1:$P(NODE2,"^",2))
-        S PSGPLF=$S($G(PSJEXPOE):PSJEXPOE,1:$P(NODE2,"^",4))
-        S FIELD(1)="^"_$S($G(PSJBCBU):$P(NODE2,"^"),1:$$ESC^ORHLESC($P(NODE2,"^")))_"&"_$P(NODE2,"^",5)_"^^"_$$FMTHL7^XLFDT(PSGPLS)_"^"_$$FMTHL7^XLFDT(PSGPLF)_"^"_$P($G(NODEPT2),"^",4)_"^"_$G(PSGST)
-        S FIELD(21)="^"_$P(NODE2,"^",5)_"^99PSA^^^"
-        I ($G(DOSEOR)']"")!($O(@(PSJORDER_"1,"" "")"),-1)=1) D
-        .S (CNT,DDNUM)=0 F  S DDNUM=$O(@(PSJORDER_"1,"_DDNUM_")")) Q:'DDNUM  Q:CNT=1  S DDIEN=+$G(@(PSJORDER_"1,"_DDNUM_",0)")) D
-        ..S FIELD(1)=$S($P(@(PSJORDER_"1,"_DDNUM_",0)"),"^",2)="":"1",1:$P(@(PSJORDER_"1,"_DDNUM_",0)"),"^",2))_"&"_FIELD(1)
-        ..S FIELD(1)=DOSE_"&"_UNIT_"&"_FIELD(1),$P(FIELD(1),"^",8)=$S($G(DOSEOR)]"":$G(DOSEOR),1:DOSE_UNIT)
-        ..S:$P(FIELD(1),"^",8)="" $P(FIELD(1),"^",8)=$$ESC^ORHLESC($G(@(PSJORDER_".3)")))
-        ..S NDNODE=$G(^PSDRUG(DDIEN,"ND"))
-        ..;  CHANGE FOR NEW NDF CALL
-        ..S PRODNAME=$S($T(^PSNAPIS)]"":$$PROD0^PSNAPIS(+NDNODE,$P(NDNODE,"^",3)),$G(^PSNDF(+NDNODE,5,+$P(NDNODE,"^",3),0))]"":^(0),1:"N/A")
-        ..S:PRODNAME="" PRODNAME="N/A"
-        ..S FIELD(2)=$S(PRODNAME="N/A":"^^",1:+NDNODE_"."_+$P(NDNODE,"^",3)_"^"_$P(NDNODE,"^",2)_"^"_"99NDF")_"^"_DDIEN_"^"_$S($G(PSJBCBU):$P($G(^PSDRUG(DDIEN,0)),"^"),1:$$ESC^ORHLESC($P($G(^PSDRUG(DDIEN,0)),"^")))_"^"_"99PSD"
-        ..S UNITS=$S(PRODNAME="N/A":"N/A",1:$S($T(^PSNAPIS)]"":$P($$DFSU^PSNAPIS(+NDNODE,$P(NDNODE,"^",3)),"^",5),1:$P($G(^PSNDF(+NDNODE,2,+$P(PRODNAME,"^",2),3,+$P(PRODNAME,"^",3),4,+$P(PRODNAME,"^",4),0)),"^")))
-        ..S FIELD(5)="^^^"_$$ESC^ORHLESC(UNITS)_"^"_$$ESC^ORHLESC($P($G(^PS(50.607,UNITS,0)),"^"))_"^99PSU"
-        ..S FIELD(6)="^^^"_$$ESC^ORHLESC($G(DOSEFORM))_"^"_$$ESC^ORHLESC($P($G(^PS(50.606,+$G(DOSEFORM),0)),"^"))_"^99PSF"
-        ..S FIELD(25)=$$EN^PSSUTIL1(DDIEN),FIELD(26)=$P(FIELD(25),"|",2),FIELD(25)=$P(FIELD(25),"|")
-        ..I $P(FIELD(25),"^",5)]"" S $P(FIELD(25),"^",5)=$$ESC^ORHLESC($P(FIELD(25),"^",5))
-        ..S CNT=CNT+1
-        E  S $P(FIELD(1),"^",8)=$$ESC^ORHLESC(DOSEOR)
-        S NAME=$P($G(^VA(200,DUZ,0)),"^") S:'$G(PSJBCBU) NAME=$$ESC^ORHLESC(NAME) S FIELD(14)=DUZ_"^"_NAME_"^"_"99NP"
-        D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
-        D SEGMENT2^PSJHLU
-        Q
-IVRXE   ; RXE segment for IV orders
-        ; If an Inpatient Med IV order, send RXE w/dispense drug info.  
-        ; If an IV FLUID order, send start/stop date and duration in the RXE
-        ; and send an RXC for each additive and solution.
-        N ADSNODE
-        I RXORDER["V" S PSGPLS=$P(NODE1,"^",2),PSGPLF=$P(NODE1,"^",3)
-        E  S PSGPLS=$P(NODE2,"^",2),PSGPLF=$P(NODE2,"^",4)
-        S FIELD(1)="^"_$S(PSJORDER["IV":($P(NODE1,"^",9)_"&"_$P(NODE1,"^",11)),1:$P(NODE2,"^"))_"^^"_$$FMTHL7^XLFDT(PSGPLS)_"^"_$$FMTHL7^XLFDT(PSGPLF)_"^"_$G(P("PRY"))
-        S FIELD(21)="^"_$S(PSJORDER["IV":$P(NODE1,"^",11),1:$P(NODE2,"^",5))_"^99PSA^^^"
-        S NAME=$P($G(^VA(200,DUZ,0)),"^") S:'$G(PSJBCBU) NAME=$$ESC^ORHLESC(NAME)
-        S FIELD(14)=DUZ_"^"_NAME_"^"_"99NP"
-        N X,Y
-        I RXORDER["V" S INFUSE=$P(NODE1,"^",8)
-        E  S INFUSE=$P($G(@(PSJORDER_"8)")),"^",5)
-        I INFUSE?1N.N1" ml/hr" S FIELD(23)=+INFUSE,Y=$P(INFUSE,+INFUSE,2),Y=$$TRIM^XLFSTR(Y,"LR"," "),FIELD(24)="^^^^"_Y_"^PSU"
-        I FIELD(23)="",FIELD(24)="" S FIELD(23)=INFUSE
-        D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
-        K SEGMENT I RXORDER["V" S JJ=0 F  S JJ=$O(@(PSJORDER_"5,"_JJ_")")) Q:'JJ  S SEGMENT(JJ-1)=$S($G(PSJBCBU):$G(@(PSJORDER_"5,"_JJ_",0)")),1:$$ESC^ORHLESC($G(@(PSJORDER_"5,"_JJ_",0)"))))
-        E  S JJ=0 F  S JJ=$O(@(PSJORDER_"12,"_JJ_")")) Q:'JJ  S SEGMENT(JJ-1)=$S($G(PSJBCBU):$G(@(PSJORDER_"12,"_JJ_",0)")),1:$G(@(PSJORDER_"12,"_JJ_",0)")))
-        I $D(SEGMENT(0)) S SEGMENT(0)="NTE|6|L|"_SEGMENT(0) D
-        .D SET^PSJHLU K SEGMENT,JJ
-        I RXORDER["V",$P($G(@(PSJORDER_"3)")),"^")]"" K SEGMENT D
-        .S SEGMENT(0)="NTE|21|L|"_$S($G(PSJSBCBU):$P($G(@(PSJORDER_"3)")),"^"),1:$$ESC^ORHLESC($P($G(@(PSJORDER_"3)")),"^"))) D
-        .D SET^PSJHLU K SEGMENT
-        I RXORDER["P",$P($G(@(PSJORDER_"9)")),U,2)]"" K SEGMENT D
-        .S SEGMENT(0)="NTE|21|L|"_$S($G(PSJSBCBU):$P($G(@(PSJORDER_"9)")),U,2),1:$$ESC^ORHLESC($P($G(@(PSJORDER_"9)")),U,2))) D
-        .D SET^PSJHLU K SEGMENT
-RXC     ;component segments
-        N ADDITIVE,SOLUTION,SUB,TYPE,AD,SOL,PTR,NUM,UTMP,XTMP
-        S LIMIT=24 X PSJCLEAR
-        S FIELD(0)="RXC"
-        ; In the line below, the naked reference refers to the full global reference represented in PSJORDER_TYPE...
-        ; This could be a reference to either ^PS(53.1 or ^PS(55
-        S AD="AD",SOL="SOL" F TYPE="AD","SOL" S SUB=0 F  S SUB=$O(@(PSJORDER_TYPE_","_SUB_")")) Q:SUB=""  S NODE1=$G(^(SUB,0)) Q:NODE1=""  D
-        .S FIELD(1)=$S(TYPE="AD":"A",1:"B")
-        .S PTR=+$S(TYPE="AD":+$P($G(^PS(52.6,$P(NODE1,"^"),0)),"^",11),1:+$P($G(^PS(52.7,$P(NODE1,"^"),0)),"^",11))
-        .S FIELD(2)="^^^"_$S($G(PSJBCBU):+$P(NODE1,"^"),1:PTR)_"^"_$S($G(PSJBCBU):$S(TYPE="AD":$P($G(^PS(52.6,+$P(NODE1,"^"),0)),"^"),1:$P($G(^PS(52.7,+$P(NODE1,"^"),0)),"^")_" "_$P($G(^(0)),U,4)),1:$P($G(^PS(50.7,PTR,0)),"^"))
-        .S:(TYPE="AD"&$G(PSJBCBU)) FIELD(2)=FIELD(2)_$S($P(NODE1,"^",3)]"":" BOTTLE: "_$P(NODE1,"^",3),1:"")
-        .S FIELD(2)=FIELD(2)_"^99PSP"
-        .S FIELD(3)=$P($P(NODE1,"^",2)," ")
-        .S FIELD(4)=$P($P(NODE1,"^",2)," ",2)
-        .F XTMP=1:1:14 S UTMP($P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL","^",XTMP))="PSIV-"_XTMP
-        .S NUM="" S:FIELD(4)'="" NUM=$G(UTMP(FIELD(4)))
-        .S FIELD(4)="^^^"_NUM_"^"_FIELD(4)_"^99OTH"
-        .D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
-        Q
-RXR     ; med route segment
-        S LIMIT=4 X PSJCLEAR
-        S FIELD(0)="RXR"
-        I PSJORDER["IV" S FIELD(1)="^^^"_$P($G(@(PSJORDER_".2)")),"^",3) Q:$P(FIELD(1),U,4)=""  D
-        .N PSJUNITS S PSJUNITS=$S($G(PSJBCBU):$P($G(^PS(51.2,+$P(FIELD(1),"^",4),0)),"^"),1:$$ESC^ORHLESC($P($G(^PS(51.2,+$P(FIELD(1),"^",4),0)),"^")))
-        .S FIELD(1)=FIELD(1)_"^"_PSJUNITS_"^99PSR"
-        .S:$G(PSJBCBU) FIELD(4)="^^^"_$P($G(@(PSJORDER_"0)")),"^",4)_"^"_$$CODES^PSIVUTL($P($G(@(PSJORDER_"0)")),"^",4),55.01,.04)_"^99PSR"
-        I PSJORDER[53.1 S FIELD(1)="^^^"_$P($G(@(PSJORDER_"0)")),"^",3) Q:$P(FIELD(1),U,4)=""  D
-        .N PSJUNITS S PSJUNITS=$S($G(PSJBCBU):$P($G(^PS(51.2,+$P(FIELD(1),"^",4),0)),"^"),1:$$ESC^ORHLESC($P($G(^PS(51.2,+$P(FIELD(1),"^",4),0)),"^")))
-        .S FIELD(1)=FIELD(1)_"^"_PSJUNITS_"^99PSR"
-        .S:$G(PSJBCBU) FIELD(4)="^^^"_$P($G(@(PSJORDER_"0)")),"^",4)_"^"_$$CODES^PSIVUTL($P($G(@(PSJORDER_"0)")),"^",4),53.1,4)_"^99PSR"
-        S:FIELD(1)="" FIELD(1)="^^^"_$P(NODE1,"^",3)_"^"_$S($G(PSJBCBU):$P($G(^PS(51.2,+$P(NODE1,"^",3),0)),"^"),1:$$ESC^ORHLESC($P($G(^PS(51.2,+$P(NODE1,"^",3),0)),"^")))_"^99PSR"
-        D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
-        Q
-ZRX     ; pharmacy Z-segment
-        D ZRX^PSJHLU
-        Q
-CNT     ;Count dispense drugs for an order
-        S (CNT,DDNUM)=0 F  S DDNUM=$O(@(PSJORDER_"1,"_DDNUM_")")) Q:'DDNUM  S CNT=CNT+1
-        Q
+PSJHL3 ;BIR/RLW-PHARMACY ORDER SEGMENTS ;04 Aug 98 / 10:10 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**1,11,14,40,42,47,50,56,58,92,101,102,123,110,111,152**;16 DEC 97
+ ;
+ ; Reference to ^PS(50.606 is supported by DBIA# 2174.
+ ; Reference to ^PS(50.607 is supported by DBIA# 2221.        
+ ; Reference to ^PS(50.7 is supported by DBIA# 2180.
+ ; Reference to ^PS(51.2 is supported by DBIA# 2178.
+ ; Reference to ^PS(52.6 is supported by DBIA# 1231.
+ ; Reference to ^PS(52.7 is supported by DBIA# 2173.
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^PSDRUG( is supported by DBIA# 2192.
+ ; Reference to ^PSNDF( is supported by DBIA# 2195.
+ ; Reference to ^VA(200 is supported by DBIA# 10060.
+ ; Reference to ^PSNAPIS is supported by DBIA# 2531.
+ ; Reference to ^XLFDT is supported by DBIA# 10103.
+ ; Reference to ^PSSUTIL1 is supported by DBIA# 3179.
+ ;
+EN1(PSJHLDFN,PSOC,PSJORDER) ; start here
+ ; passed in are PSJHLDFN (patient ien)
+ ;               PSJORDER (file root of order)
+ ;               OC (order control code - NW for new order, OK for finished order, OC for order canceled)
+ I $G(PSJHLDFN)']""!$G(PSOC)']""!$G(PSJORDER)']"" W !,"INSUFFICIENT DATA FOR ^PSJHL3" Q
+ N COMMENTS,DDIEA,DDNUM,DOSE,DOSEFORM,DOSEOR,NAME,DURATION,IVTYPE,NODE1,NODE2,NDNODE,OINODE,PSGPLS,PSGPLF,PRODNAME,SPDIEN,UNIT,UNITS,CNT,DDIEN,SCHEDULE
+ D INIT
+ S IVTYPE=$S(RXORDER["U":"",1:$$IVTYPE^PSJHLU(PSJORDER))
+ D RXO,RXE D:(IVTYPE'="F")!($G(PSJBCBU)) RXR D ZRX
+ D CALL^PSJHLU(PSJI)
+ Q
+ ;
+INIT ; initialize HL7 variables
+ D INIT^PSJHLU
+ Q
+ ;
+RXO ; pharmacy prescription order segment (used to send Orderable Item to OE/RR)
+ S LIMIT=17 X PSJCLEAR
+ S FIELD(0)="RXO"
+ S OINODE=$G(@(PSJORDER_".2)"))
+ S SPDIEN=+$P(OINODE,"^"),DOSEOR=$P(OINODE,"^",2),DOSE=$P(OINODE,"^",5),UNIT=$P(OINODE,"^",6)
+ S FIELD(1)=$S(SPDIEN=0:"^^^^",1:"^^^"_SPDIEN_"^")
+ I SPDIEN S DOSEFORM=$P($G(^PS(50.7,SPDIEN,0)),"^",2),NAME=$P($G(^PS(50.606,+DOSEFORM,0)),"^"),FIELD(1)=FIELD(1)_$P($G(^PS(50.7,SPDIEN,0)),"^")_" "_NAME
+ S FIELD(1)=FIELD(1)_"^99PSP"
+ N DURNOD S DURNOD=$G(@(PSJORDER_"2.5)")) I $P(DURNOD,"^",4)]"" S $P(FIELD(1),"^",3)=$P(DURNOD,"^",4)
+ D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
+ Q
+ ;
+RXE ; pharmacy encoded order segment
+ S (UNITS,NDNODE,SPDIEN,PRODNAME,DDNUM,DDIEN,CNT)="",LIMIT=26 X PSJCLEAR
+ S FIELD(0)="RXE"
+ S NODE1=$G(@(PSJORDER_"0)")),NODE2=$G(@(PSJORDER_"2)"))
+ I RXORDER["V" D IVRXE Q
+ I RXORDER["P",IVTYPE="F" D IVRXE Q
+ I RXORDER["P",$P(NODE1,"^",4)="H" D IVRXE Q
+ ;S PSGPLS=$P(NODE2,"^",2),PSGPLF=$P(NODE2,"^",4),X1=PSGPLF,X2=PSGPLS D ^%DTC S DURATION="D"_X
+ N RENEW S RENEW=$$LASTREN^PSJLMPRI(PSJHLDFN,RXORDER)
+ S PSGPLS=$S($G(PSJEXPOE):$P(NODE2,"^",2),RENEW>$P(NODE2,"^",2):RENEW,1:$P(NODE2,"^",2))
+ S PSGPLF=$S($G(PSJEXPOE):PSJEXPOE,1:$P(NODE2,"^",4))
+ ;S FIELD(1)="^"_$P(NODE2,"^")_$S($G(PSJBCBU):"&"_$P(NODE2,"^",5),1:"")_"^^"_$$FMTHL7^XLFDT(PSGPLS)_"^"_$$FMTHL7^XLFDT(PSGPLF)
+ S FIELD(1)="^"_$P(NODE2,"^")_"^^"_$$FMTHL7^XLFDT(PSGPLS)_"^"_$$FMTHL7^XLFDT(PSGPLF)
+ S FIELD(21)="^"_$P(NODE2,"^",5)_"^99PSA^^^"
+ I ($G(DOSEOR)']"")!($O(@(PSJORDER_"1,"" "")"),-1)=1) D
+ .S (CNT,DDNUM)=0 F  S DDNUM=$O(@(PSJORDER_"1,"_DDNUM_")")) Q:'DDNUM  Q:CNT=1  S DDIEN=+$G(@(PSJORDER_"1,"_DDNUM_",0)")) D
+ ..S FIELD(1)=$S($P(@(PSJORDER_"1,"_DDNUM_",0)"),"^",2)="":"1",1:$P(@(PSJORDER_"1,"_DDNUM_",0)"),"^",2))_"&"_FIELD(1)
+ ..S FIELD(1)=DOSE_"&"_UNIT_"&"_FIELD(1),$P(FIELD(1),"^",8)=$S($G(DOSEOR)]"":$G(DOSEOR),1:DOSE_UNIT)
+ ..S:$P(FIELD(1),"^",8)="" $P(FIELD(1),"^",8)=$G(@(PSJORDER_".3)"))
+ ..S NDNODE=$G(^PSDRUG(DDIEN,"ND"))
+ ..;  CHANGE FOR NEW NDF CALL
+ ..;S PRODNAME=$S($G(^PSNDF(+NDNODE,5,+$P(NDNODE,"^",3),0))]"":^(0),1:"N/A")
+ ..S PRODNAME=$S($T(^PSNAPIS)]"":$$PROD0^PSNAPIS(+NDNODE,$P(NDNODE,"^",3)),$G(^PSNDF(+NDNODE,5,+$P(NDNODE,"^",3),0))]"":^(0),1:"N/A")
+ ..S:PRODNAME="" PRODNAME="N/A"
+ ..S FIELD(2)=$S(PRODNAME="N/A":"^^",1:+NDNODE_"."_+$P(NDNODE,"^",3)_"^"_$P(NDNODE,"^",2)_"^"_"99NDF")_"^"_DDIEN_"^"_$P($G(^PSDRUG(DDIEN,0)),"^")_"^"_"99PSD"
+ ..;S UNITS=$S(PRODNAME="N/A":"N/A",1:$P($G(^PSNDF(+NDNODE,2,+$P(PRODNAME,"^",2),3,+$P(PRODNAME,"^",3),4,+$P(PRODNAME,"^",4),0)),"^"))
+ ..S UNITS=$S(PRODNAME="N/A":"N/A",1:$S($T(^PSNAPIS)]"":$P($$DFSU^PSNAPIS(+NDNODE,$P(NDNODE,"^",3)),"^",5),1:$P($G(^PSNDF(+NDNODE,2,+$P(PRODNAME,"^",2),3,+$P(PRODNAME,"^",3),4,+$P(PRODNAME,"^",4),0)),"^")))
+ ..S FIELD(5)="^^^"_UNITS_"^"_$P($G(^PS(50.607,UNITS,0)),"^")_"^99PSU"
+ ..S FIELD(6)="^^^"_$G(DOSEFORM)_"^"_$P($G(^PS(50.606,+$G(DOSEFORM),0)),"^")_"^99PSF"
+ ..S FIELD(25)=$$EN^PSSUTIL1(DDIEN),FIELD(26)=$P(FIELD(25),"|",2),FIELD(25)=$P(FIELD(25),"|")
+ ..S CNT=CNT+1
+ E  S $P(FIELD(1),"^",8)=DOSEOR
+ S NAME=$P($G(^VA(200,DUZ,0)),"^"),FIELD(14)=DUZ_"^"_NAME_"^"_"99NP"
+ D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
+ K SEGMENT S JJ=0 F  S JJ=$O(@(PSJORDER_"12,"_JJ_")")) Q:'JJ  S SEGMENT(JJ-1)=$G(@(PSJORDER_"12,"_JJ_",0)"))
+ I $D(SEGMENT(0)) S SEGMENT(0)="NTE|6|L|"_SEGMENT(0) D SET^PSJHLU K SEGMENT,JJ
+ I $P($G(@(PSJORDER_"6)")),"^")]"" K SEGMENT S SEGMENT(0)="NTE|21|L|"_$P($G(@(PSJORDER_"6)")),"^") D SET^PSJHLU K SEGMENT
+ I PSJORDER["P",$P($G(@(PSJORDER_"9)")),"^",2)]"" K SEGMENT S SEGMENT(0)="NTE|21|L|"_$P($G(@(PSJORDER_"9)")),"^",2) D SET^PSJHLU K SEGMENT
+ Q
+ ;
+IVRXE ; RXE segment for IV orders
+ ; if it's an Inpatient Med IV order, send the RXE with dispense drug
+ ; information.  If it's an IV FLUID order, send just the start/stop
+ ; date, duration in the RXE and send an RXC for each additive and
+ ; solution.
+ N ADSNODE
+ I RXORDER["V" S PSGPLS=$P(NODE1,"^",2),PSGPLF=$P(NODE1,"^",3)
+ E  S PSGPLS=$P(NODE2,"^",2),PSGPLF=$P(NODE2,"^",4)
+ ;S X1=PSGPLF,X2=PSGPLS D ^%DTC S DURATION=$S(X]"":"D"_X,1:"")
+ S FIELD(1)="^"_$S(PSJORDER["IV":$P(NODE1,"^",9),1:$P(NODE2,"^"))_"^^"_$$FMTHL7^XLFDT(PSGPLS)_"^"_$$FMTHL7^XLFDT(PSGPLF)
+ ;S:$G(PSJBCBU) $P(FIELD(1),"^",2)=$P(FIELD(1),"^",2)_"&"_$S(PSJORDER["IV":$P(NODE1,"^",11),1:$P(NODE2,"^",5))
+ S FIELD(21)="^"_$S(PSJORDER["IV":$P(NODE1,"^",11),1:$P(NODE2,"^",5))_"^99PSA^^^"
+ S NAME=$P($G(^VA(200,DUZ,0)),"^")
+ S FIELD(14)=DUZ_"^"_NAME_"^"_"99NP"
+ N X,Y
+ I RXORDER["V" S INFUSE=$P(NODE1,"^",8)
+ E  S INFUSE=$P($G(@(PSJORDER_"8)")),"^",5)
+ I INFUSE?1N.N1" ml/hr" S FIELD(23)=+INFUSE,Y=$P(INFUSE,+INFUSE,2),Y=$$TRIM^XLFSTR(Y,"LR"," "),FIELD(24)="^^^^"_Y_"^PSU"
+ I FIELD(23)="",FIELD(24)="" S FIELD(23)=INFUSE
+ D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
+ K SEGMENT I RXORDER["V" S JJ=0 F  S JJ=$O(@(PSJORDER_"5,"_JJ_")")) Q:'JJ  S SEGMENT(JJ-1)=$G(@(PSJORDER_"5,"_JJ_",0)"))
+ E  S JJ=0 F  S JJ=$O(@(PSJORDER_"12,"_JJ_")")) Q:'JJ  S SEGMENT(JJ-1)=$G(@(PSJORDER_"12,"_JJ_",0)"))
+ I $D(SEGMENT(0)) S SEGMENT(0)="NTE|6|L|"_SEGMENT(0) D SET^PSJHLU K SEGMENT,JJ
+ I RXORDER["V",$P($G(@(PSJORDER_"3)")),"^")]"" K SEGMENT S SEGMENT(0)="NTE|21|L|"_$P($G(@(PSJORDER_"3)")),"^") D SET^PSJHLU K SEGMENT
+ I RXORDER["P",$P($G(@(PSJORDER_"9)")),U,2)]"" S SEGMENT(0)="NTE|21|L|"_$P($G(@(PSJORDER_"9)")),U,2) D SET^PSJHLU K SEGMENT
+ ;
+RXC ;component segments
+ N ADDITIVE,SOLUTION,SUB,TYPE,AD,SOL,PTR,NUM,UTMP,XTMP
+ S LIMIT=24 X PSJCLEAR
+ S FIELD(0)="RXC"
+ ; In the line below, the naked reference refers to the full global reference represented in PSJORDER_TYPE...
+ ; This could be a reference to either ^PS(53.1 or ^PS(55
+ S AD="AD",SOL="SOL" F TYPE="AD","SOL" S SUB=0 F  S SUB=$O(@(PSJORDER_TYPE_","_SUB_")")) Q:SUB=""  S NODE1=$G(^(SUB,0)) Q:NODE1=""  D
+ .S FIELD(1)=$S(TYPE="AD":"A",1:"B")
+ .S PTR=+$S(TYPE="AD":+$P($G(^PS(52.6,$P(NODE1,"^"),0)),"^",11),1:+$P($G(^PS(52.7,$P(NODE1,"^"),0)),"^",11))
+ .S FIELD(2)="^^^"_$S($G(PSJBCBU):+$P(NODE1,"^"),1:PTR)_"^"_$S($G(PSJBCBU):$S(TYPE="AD":$P($G(^PS(52.6,+$P(NODE1,"^"),0)),"^"),1:$P($G(^PS(52.7,+$P(NODE1,"^"),0)),"^")_" "_$P($G(^(0)),U,4)),1:$P($G(^PS(50.7,PTR,0)),"^"))
+ .S:(TYPE="AD"&$G(PSJBCBU)) FIELD(2)=FIELD(2)_$S($P(NODE1,"^",3)]"":" BOTTLE: "_$P(NODE1,"^",3),1:"")
+ .S FIELD(2)=FIELD(2)_"^99PSP"
+ .S FIELD(3)=$P($P(NODE1,"^",2)," ")
+ .S FIELD(4)=$P($P(NODE1,"^",2)," ",2)
+ .F XTMP=1:1:13 S UTMP($P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM","^",XTMP))="PSIV-"_XTMP
+ .S NUM="" S:FIELD(4)'="" NUM=$G(UTMP(FIELD(4)))
+ .S FIELD(4)="^^^"_NUM_"^"_FIELD(4)_"^99OTH"
+ .D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
+ Q
+ ;
+RXR ; med route segment
+ S LIMIT=4 X PSJCLEAR
+ S FIELD(0)="RXR"
+ I PSJORDER["IV" S FIELD(1)="^^^"_$P($G(@(PSJORDER_".2)")),"^",3) Q:$P(FIELD(1),U,4)=""  D
+ .S FIELD(1)=FIELD(1)_"^"_$P($G(^PS(51.2,+$P(FIELD(1),"^",4),0)),"^")_"^99PSR"
+ .S:$G(PSJBCBU) FIELD(4)="^^^"_$P($G(@(PSJORDER_"0)")),"^",4)_"^"_$$CODES^PSIVUTL($P($G(@(PSJORDER_"0)")),"^",4),55.01,.04)_"^99PSR"
+ S:FIELD(1)="" FIELD(1)="^^^"_$P(NODE1,"^",3)_"^"_$P($G(^PS(51.2,+$P(NODE1,"^",3),0)),"^")_"^99PSR"
+ D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
+ Q
+ ;
+ZRX ; pharmacy Z-segment
+ S LIMIT=6 X PSJCLEAR
+ S FIELD(0)="ZRX"
+ I '$G(PSJREN) N PREON,PSJREN I $G(PSJORD)["U"&($P(NODE1,"^",24)="R") S PSJREN=1
+ I $G(PSJORD)["V"&($P(NODE2,"^",8)="R") S PSJREN=1
+ S PREON=$S($G(PSJREN):$G(PSJORD),PSJORDER["IV":$P(NODE2,"^",5),1:$P(NODE1,"^",25))
+ S FIELD(1)=$S(PREON["P":$P($G(^PS(53.1,+PREON,0)),"^",21),PREON["V":$P($G(^PS(55,PSJHLDFN,"IV",+PREON,0)),"^",21),1:$P($G(^PS(55,PSJHLDFN,5,+PREON,0)),"^",21))
+ S FIELD(2)=$S(PSJORDER["IV":$G(P("NAT")),1:$G(PSJNOO))
+ S FIELD(3)=$S($G(PSJREN):"R",PSJORDER["IV":$P(NODE2,"^",8),1:$P(NODE1,"^",24))
+ I FIELD(3)="" I PSOC="SN" S FIELD(3)="N"
+ S NAME=$P($G(^VA(200,DUZ,0)),"^")
+ S FIELD(5)=DUZ_"^"_NAME_"^"_"99NP"
+ S FIELD(6)=$S($G(IVTYPE)="F":"IV",$P($G(@(PSJORDER_"0)")),U,4)="H":"TPN",1:"")
+ D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
+ Q
+ ;
+CNT ;Count dispense drugs for an order
+ S (CNT,DDNUM)=0 F  S DDNUM=$O(@(PSJORDER_"1,"_DDNUM_")")) Q:'DDNUM  S CNT=CNT+1
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4.m

@@ -1 @@
-PSJHL4  ;BIR/RLW-DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**1,12,27,34,40,42,55,47,50,56,58,98,85,105,107,110,111,154,134**;16 DEC 97;Build 124
-        ; Reference to $$EN^PSOHLNEW is supported by DBIA# 2188.
-        ; Reference to ^PS(50.7 is supported by DBIA 2180.
-        ; Reference to ^PS(51.2 is supported by DBIA 2178.
-        ; Reference to ^PS(55 is supported by DBIA 2191.
-        ; Reference to ^PS(59.7 supported by DBIA 2181.
-        ; Reference to ^ORHLESC is supported by DBIA 4922.
-        ; 
-EN(PSJMSG)      ; Start
-        K ^TMP("PSJNVO",$J)
-        N ADCNT,SOLCNT,OCCNT
-        N ACKDATE,ADDITIVE,ADMINSTR,APPL,COMMENT,PSJHLDFN,DISPENSE,DOSE,DURATION,II,INSTR,J,JJ,JJJ,K,LOGIN,NEWORDER,NURSEACK,OBXFL,OCNARR,OCPROV,OCRSN,ORDER,PRIORITY,PSITEM,ORDCON,PROCOM,PSJORDER,PSREASON
-        N LOC,PROVIDER,PSPR,PSOC,PTR,QQ,REQST,ROUTE,RXON,RXORDER,SCHEDULE,SEGMENT,SOLUTION,STPDT,STRENGTH,TEXT,CLERK,INFRT,IVTYP,SCHTYP,PREON,NOO,ROC,FREQ,CLASS,PSJHLMTN,UNIT,UNITS,QFLG,VOLUME,TVOLUME,PSGP
-        N PSJASTP,FLDATE,FLCMNT,PSJFLAG,PSJYN,PRNTON,APPT,IVLIMIT,IVCAT,INTRMT
-        S (ADCNT,SOLCNT,OCCNT,II,TVOLUME)="",(OBXFL,QFLG)=0,PSJHLMTN="ORR" F  S II=$O(PSJMSG(II)) Q:'II  D DECODE Q:QFLG  D @FIELD(0) Q:$G(CLASS)="O"  Q:QFLG
-        I ($G(CLASS)'="I")!(QFLG) G END
-        I ($G(PSOC)="NW")!($G(PSOC)="XO") N DIK,DA S DIK="^PS(53.1,",DA=NEWORDER D EN1^DIK L -^PS(53.1,NEWORDER)
-        I ($G(PSOC)="NW")!($G(PSOC)="XO") D EN1^PSJHL2(PSJHLDFN,$S(PSOC="NW":"OK",1:"XR"),NEWORDER_"P")
-END     ;
-        K ^TMP("PSJNVO",$J)
-        I (",S,A,")[(","_$G(PRIORITY)_",")!($G(SCHEDULE)="NOW")!($G(SCHEDULE)["STAT") D
-        . I $G(PRIORITY)="ZD",$G(PSGORD) D NOTIFY(PSGORD_$S(PSGORD["V":"V",PSGORD["U":"U",1:""),PSJHLDFN,$G(PRIORITY),$G(SCHEDULE))
-        . I $G(NEWORDER) D NOTIFY(NEWORDER_"P",PSJHLDFN,$G(PRIORITY),$G(SCHEDULE))
-        Q
-DECODE  ; Parse into fields 
-        K FIELD
-        N PSJCTR1 S PSJCTR1=""
-        S SEGMENT=$G(PSJMSG(II))
-        I $D(PSJMSG(II,1)),$P(SEGMENT,"|",1)="ORC" F  S PSJCTR1=$O(PSJMSG(II,PSJCTR1)) Q:PSJCTR1=""  D
-        . S SEGMENT=SEGMENT_PSJMSG(II,PSJCTR1)  ;Handle CPRS "overflow" ORC nodes
-        S J=0
-        F  Q:$G(SEGMENT)=""  D
-        .I SEGMENT["|" S FIELD(J)=$P(SEGMENT,"|"),SEGMENT=$E(SEGMENT,$L(FIELD(J))+2,$L(SEGMENT)),J=J+1 Q
-        .I SEGMENT'["|" S FIELD(J)=SEGMENT,SEGMENT="" Q
-        K PSJCTR1
-        Q
-NOTIFY(ORDER,PSJHLDFN,PRIO,PSJSCHED)    ; Send msg
-        N NTFYREAS,WARD,MGROUP,NTFSTAT,DRUG,DRIEN,PNAME,ORDATE,DO,PSG,XMY,VADPT,LASTFOUR,PSJSOK
-        Q:($G(PRIO)=""&($G(PSJSCHED)=""))
-        S DFN=PSJHLDFN D DEM^VADPT S LASTFOUR=$P($P(VADM(2),"^",2),"-",3)
-        S NTFYREAS=$S((",S,A,")[(","_PRIO_","):1,($G(PSJSCHED)="NOW"):2,($G(PSJSCHED)="STAT"):3,1:0) Q:'NTFYREAS
-        S PSJSOK=1
-        I ORDER["P" D PND
-        I ORDER["U" D UD
-        I ORDER["V" D IV
-        Q:PSJSOK=1
-        D XMD^PSJHL4A
-        Q
-PND     ; Pending
-        N WARD,WDPARM,MGRP
-        Q:'$D(^PS(53.1,+ORDER,0))
-        S WARD=$G(^DPT(PSJHLDFN,.1)) I WARD]"" D
-        .N DIC,X,Y S DIC="^DIC(42,",DIC(0)="BOXZ",X=WARD D ^DIC S WARD=+Y Q:WARD=0
-        .S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0
-        .Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD)
-        .S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0
-        .S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0
-        S:'$$SNDTSTP^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW PENDING ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0
-        S NTFSTAT="PENDING"
-        N NDP2,ND0 S NDP2=$G(^PS(53.1,+ORDER,.2)),ND0=$G(^PS(53.1,+ORDER,0))
-        S DRIEN=+$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(ND0,"^",3),ORDATE=$P(ND0,"^",14)
-        S SCHED=$P($G(^PS(53.1,+ORDER,2)),"^")
-        Q
-UD      ; UD
-        N WARD,WDPARM,MGRP
-        Q:'$D(^PS(55,PSJHLDFN,5,+ORDER,0))
-        S WARD=$P($G(^PS(55,PSJHLDFN,5,+ORDER,0)),"^",23) I +WARD D
-        .S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0
-        .Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD)
-        .S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0
-        .S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0
-        S:'$$SNDTSTA^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW ACTIVE ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0
-        S NTFSTAT="ACTIVE"
-        N ND2,ND0 S ND0=$G(^PS(55,PSJHLDFN,5,+ORDER,0)),ND2=$G(^PS(55,PSJHLDFN,5,+ORDER,2)),NDP2=$G(^PS(55,PSJHLDFN,5,+ORDER,.2))
-        S DRIEN=+$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(ND0,"^",3),ORDATE=$P(ND0,"^",14)
-        S SCHED=$P(ND2,"^")
-        Q
-IV      ; IV
-        N WARD,WDPARM,MGRP
-        Q:'$D(^PS(55,PSJHLDFN,"IV",+ORDER,0))
-        S WARD=$P($G(^PS(55,PSJHLDFN,"IV",+ORDER,0)),"^",22) I +WARD D
-        .S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0
-        .Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD)
-        .S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0
-        .S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0
-        S:'$$SNDTSTA^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW ACTIVE ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0
-        S NTFSTAT="ACTIVE"
-        N ND2,NDP2,ND0 S ND0=$G(^PS(55,PSJHLDFN,"IV",+ORDER,0)),ND2=$G(^PS(55,PSJHLDFN,"IV",+ORDER,2))
-        S NDP2=$G(^PS(55,PSJHLDFN,"IV",+ORDER,.2))
-        S DRIEN=$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(NDP2,"^",3)
-        S ORDATE=$P(ND2,"^"),SCHED=$P(ND0,"^",9)
-        Q
-MSH     ; Header
-        S PSOC=FIELD(8)
-        Q
-PID     ; ID
-        S PSJHLDFN=$$UNESC^ORHLESC(FIELD(3))
-        Q
-PV1     ; Visit
-        N A
-        S CLASS=FIELD(2),LOC=$P(FIELD(3),"^"),APPT="" I $G(FIELD(44))]"" S APPT=+$$HL7TFM^XLFDT(FIELD(44))
-        I "IO"'[CLASS S PSREASON="Invalid patient class" Q
-        N QQ K PSJNVA S QQ=II F  S QQ=$O(PSJMSG(QQ)) Q:'QQ  D  Q:$G(PSJNVA)
-        .S X=$G(PSJMSG(QQ))
-        .I $P(X,"|")="ZRN" S PSJNVA=1,CLASS="O" D EN^PSOHLNEW(.PSJMSG)
-        I $G(PSJNVA) K PSJNVA Q
-        I CLASS="O" N QQ S QQ=II F  S QQ=$O(PSJMSG(QQ)) Q:'QQ  I $P(PSJMSG(QQ),"|")="OBR" D  Q:$P(PSJMSG(QQ),"|")="OBR"
-        .S RXON=$P(PSJMSG(QQ),"|",4) I RXON]"" S RXON=$P(RXON,"^") I "ABNPUV"[$E(RXON,$L(RXON)) S CLASS="I"
-        I CLASS="O" N QQ S QQ=II F  S QQ=$O(PSJMSG(QQ)) Q:'QQ  I $P(PSJMSG(QQ),"|")="ORC" D  Q:$P(PSJMSG(QQ),"|")="ORC"
-        .S RXON=$P(PSJMSG(QQ),"|",4) I RXON]"" S RXON=$P(RXON,"^") I "ABNPUV"[$E(RXON,$L(RXON)) S CLASS="I"
-        I CLASS="O" N CHK,QQ S QQ=II F  S QQ=$O(PSJMSG(QQ)) Q:'QQ  I $P(PSJMSG(QQ),"|")="RXO" D  Q:$P(PSJMSG(QQ),"|")="RXO"
-        .S CHK=$P(PSJMSG(QQ),"|",2),CHK=$S($P(CHK,"^",5)="IV":"IV",1:$P(CHK,"^",4))
-        .I CHK="IV" S CLASS="I" Q
-        .I 'CHK S PSREASON="Missing or Invalid Orderable Item",CLASS="I" Q
-        .I $P($G(^PS(50.7,CHK,0)),"^",3)=1 S CLASS="I" Q
-        D:CLASS="O" EN^PSOHLNEW(.PSJMSG)
-        Q
-ORC     ; Order
-        S TMPAT=""
-        S PSOC=FIELD(1)
-        S ORDER=FIELD(2)
-        I $G(PSREASON)]"" D ERROR^PSJHL9 Q
-        S PSJORDER=$P(FIELD(2),"^"),RXON=$P(FIELD(3),"^"),RXORDER=$S((RXON["N")!(RXON["P"):"^PS(53.1,"_+RXON_",",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+RXON_",",1:"^PS(55,"_PSJHLDFN_",5,"_+RXON_",")
-        I PSOC="NA" D ASSIGN^PSJHL5 Q
-        S CLERK=+$G(FIELD(10))
-        S PROVIDER=+$G(FIELD(12)) D:PSOC="NW"
-        .I PROVIDER=0 S PSREASON="Invalid Provider" D ERROR^PSJHL9 Q 
-        .I PROVIDER>0 S PSPR=$G(^VA(200,+PROVIDER,"PS")) I '$D(PSPR)!'(PSPR)!$S($P(PSPR,"^",4)="":0,1:$P(PSPR,"^",4)'>DT) S PSREASON="Invalid Provider" D ERROR^PSJHL9 Q
-        S UNITS=$P(FIELD(7),"^"),INSTR=$$UNESC^ORHLESC($P(FIELD(7),"^",8))
-        S:UNITS["&" DOSE=$P(UNITS,"&"),UNIT=$P(UNITS,"&",2),UNITS=$P(UNITS,"&",3) S:UNITS]"" UNITS=$$UNESC^ORHLESC(UNITS) S:$G(DOSE)]"" DOSE=$$UNESC^ORHLESC(DOSE)
-        S SCHEDULE=$P(FIELD(7),"^",2),PRIORITY=$P(FIELD(7),"^",6) S:SCHEDULE["PRN" SCHTYP="P"
-        I SCHEDULE["&" S ADMINS=$P(SCHEDULE,"&",2),SCHEDULE=$P(SCHEDULE,"&") S ADMINS=$TR(ADMINS," ","") S ADMINS=$S(ADMINS:ADMINS,1:"")
-        S SCHEDULE=$$UNESC^ORHLESC(SCHEDULE)
-        I SCHEDULE["@" S TMPAT=$$TMPAT^PSJHL4A(SCHEDULE)
-        I $G(TMPAT) S $P(SCHEDULE,"@",2)=TMPAT,ADMINS=TMPAT
-        S DURATION=$P(FIELD(7),"^",3),REQST=$P(FIELD(7),"^",4) S:REQST'="" REQST=+$E(+$$HL7TFM^XLFDT(REQST),1,12) S REQST=$$DATE2^PSJUTL2(REQST)
-        S PRIORITY=$S($G(PRIORITY)]"":PRIORITY,1:"R")
-        I $E(SCHEDULE,1)=" " S:$TR(SCHEDULE," ")="PRN" SCHEDULE="PRN" I '(SCHEDULE="PRN")  S PSREASON="Invalid Schedule" D ERROR^PSJHL9 Q
-        S SCHTYP=$P(FIELD(7),"^",7)
-        I $G(SCHTYP)="D" S SCHTYP="C"  ;Makes CPRS Day of Week consistent in behavior with backdoor order of Day of Week
-        S PRNTON=$P(FIELD(8),"^")
-        S NURSEACK=$G(FIELD(11))
-        S LOGIN=$G(FIELD(15)) S:LOGIN'="" LOGIN=+$E(+$$HL7TFM^XLFDT(FIELD(15)),1,12) S LOGIN=$$DATE2^PSJUTL2(LOGIN)
-        S:$G(NURSEACK)]"" ACKDATE=LOGIN
-        S ORDCON=$P($G(FIELD(16)),U) I ORDCON="A" S PSJASTP=$G(FIELD(9)) S:$G(PSJASTP)'="" PSJASTP=+$E(+$$HL7TFM^XLFDT(PSJASTP),1,12) S PSJASTP=$$DATE2^PSJUTL2(PSJASTP)
-        I (PSOC="CA")!(PSOC="DC") D CANCEL^PSJHL6 Q
-        I PSOC="HD" D HOLD^PSJHL6 Q
-        I PSOC="RL" D UNHOLD^PSJHL6 Q
-        I PSOC="ZV" D NURSEACK^PSJHL5 Q
-        I PSOC="SS" D STATUS^PSJHL5 Q
-        I PSOC="Z@" N X S X="PSJHL8" X ^%ZOSF("TEST") I  D PURGE^PSJHL8 Q
-        I PSOC="DE" S QFLG=1 Q
-        Q
-OBR     ; Flagging from CPRS.
-        S ORDER=FIELD(2)
-        S PSJORDER=$P(FIELD(2),"^"),RXON=$P(FIELD(3),"^"),RXORDER=$S((RXON["N")!(RXON["P"):"^PS(53.1,"_+RXON_",",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+RXON_",",1:"^PS(55,"_PSJHLDFN_",5,"_+RXON_",")
-        S PSJFLAG=FIELD(4)
-        S FLDATE=$G(FIELD(7)) S:FLDATE'="" FLDATE=+$E(+$$HL7TFM^XLFDT(FIELD(7)),1,12) S FLDATE=$$DATE2^PSJUTL2(FLDATE)
-        S CLERK=+$G(FIELD(16))
-        S PSJYN=$G(FIELD(24))
-        S FLCMNT=$$UNESC^ORHLESC($G(FIELD(13)))
-        I PSOC="ORU" D FLAG^PSJHL5
-        Q
-RXC     ; IV 
-        D RXC^PSJHL4A
-        Q
-RXO     ; OP
-        D RXO^PSJHL4A
-        Q
-RXR     ; Route
-        S ROUTE=$P(FIELD(1),"^",4)
-        Q
-OBX     ; Obs.
-        D OBX^PSJHL4A
-        Q
-NTE     ; Note
-        D NTE^PSJHL4A
-        Q
-ZRX     ; Custom
-        D ZRX^PSJHL4A
-        Q
-ZSC     ;Service Connected - Not Used
-        Q
-ZRN     ;Non-VA Med (Herbal/OTC)
-        S CLASS="O" D EN^PSOHLNEW(.PSJMSG)
-        Q
-DG1     ;Billing Awareness - Not used
-        Q
+PSJHL4 ;BIR/RLW-DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**1,12,27,34,40,42,55,47,50,56,58,98,85,105,107,110,111,154**;16 DEC 97
+ ;
+ ; Reference to $$EN^PSOHLNEW is supported by DBIA# 2188.
+ ; Reference to ^PS(50.7 is supported by DBIA# 2180.
+ ; Reference to ^PS(51.2 is supported by DBIA# 2178.
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^PS(59.7 supported by DBIA #2181.
+ ;
+EN(PSJMSG) ; start here
+ K ^TMP("PSJNVO",$J)
+ N ADCNT,SOLCNT,OCCNT
+ N ACKDATE,ADDITIVE,ADMINSTR,APPL,COMMENT,PSJHLDFN,DISPENSE,DOSE,DURATION,II,INSTR,J,JJ,JJJ,K,LOGIN,NEWORDER,NURSEACK,OBXFL,OCNARR,OCPROV,OCRSN,ORDER,PRIORITY,PSITEM,ORDCON,PROCOM,PSJORDER,PSREASON
+ N LOC,PROVIDER,PSPR,PSOC,PTR,QQ,REQST,ROUTE,RXON,RXORDER,SCHEDULE,SEGMENT,SOLUTION,STPDT,STRENGTH,TEXT,CLERK,INFRT,IVTYP,SCHTYP,PREON,NOO,ROC,FREQ,CLASS,PSJHLMTN,UNIT,UNITS,QFLG,VOLUME,TVOLUME,PSGP
+ N PSJASTP,FLDATE,FLCMNT,PSJFLAG,PSJYN,PRNTON,APPT,IVLIMIT
+ S (ADCNT,SOLCNT,OCCNT,II,TVOLUME)="",(OBXFL,QFLG)=0,PSJHLMTN="ORR" F  S II=$O(PSJMSG(II)) Q:'II  D DECODE Q:QFLG  D @FIELD(0) Q:$G(CLASS)="O"  Q:QFLG
+ I ($G(CLASS)'="I")!(QFLG) G END
+ I ($G(PSOC)="NW")!($G(PSOC)="XO") N DIK,DA S DIK="^PS(53.1,",DA=NEWORDER D EN1^DIK L -^PS(53.1,NEWORDER)
+ I ($G(PSOC)="NW")!($G(PSOC)="XO") D EN1^PSJHL2(PSJHLDFN,$S(PSOC="NW":"OK",1:"XR"),NEWORDER_"P")
+END ;
+ K ^TMP("PSJNVO",$J)
+ I (",S,A,")[(","_$G(PRIORITY)_",")!($G(SCHEDULE)="NOW")!($G(SCHEDULE)["STAT") D
+ . I $G(PRIORITY)="ZD",$G(PSGORD) D NOTIFY(PSGORD_$S(PSGORD["V":"V",PSGORD["U":"U",1:""),PSJHLDFN,$G(PRIORITY),$G(SCHEDULE))
+ . I $G(NEWORDER) D NOTIFY(NEWORDER_"P",PSJHLDFN,$G(PRIORITY),$G(SCHEDULE))
+ Q
+ ;
+DECODE ;break segment down into fields 
+ K FIELD
+ S SEGMENT=$G(PSJMSG(II))
+ S J=0
+ F  Q:$G(SEGMENT)=""  D
+ .;get fields from segment
+ .I SEGMENT["|" S FIELD(J)=$P(SEGMENT,"|"),SEGMENT=$E(SEGMENT,$L(FIELD(J))+2,$L(SEGMENT)),J=J+1 Q
+ .I SEGMENT'["|" S FIELD(J)=SEGMENT,SEGMENT="" Q
+ Q
+ ;
+NOTIFY(ORDER,PSJHLDFN,PRIO,PSJSCHED) ;
+ N NTFYREAS,WARD,MGROUP,NTFSTAT,DRUG,DRIEN,PNAME,ORDATE,DO,PSG,XMY,VADPT,LASTFOUR,PSJSOK
+ Q:($G(PRIO)=""&($G(PSJSCHED)=""))
+ S DFN=PSJHLDFN D DEM^VADPT S LASTFOUR=$P($P(VADM(2),"^",2),"-",3)
+ S NTFYREAS=$S((",S,A,")[(","_PRIO_","):1,($G(PSJSCHED)="NOW"):2,($G(PSJSCHED)="STAT"):3,1:0) Q:'NTFYREAS
+ S PSJSOK=1
+ I ORDER["P" D PND
+ I ORDER["U" D UD
+ I ORDER["V" D IV
+ Q:PSJSOK=1
+ S PNAME=$P($G(^DPT(+PSJHLDFN,0)),"^") S:$G(RTE) RTE=$P(^PS(51.2,+RTE,0),"^",3)
+ S DRUG=$S(DRIEN:$P($G(^PS(50.7,+DRIEN,0)),"^"),1:""),WARD=$G(^DPT(PSJHLDFN,.1))
+ S XMDUZ="MEDICATIONS,INPATIENT",XMSUB=$G(WARD)
+ S XMSUB=XMSUB_"-"_NTFSTAT_" "_$S($G(PRIO)="A":"ASAP",$G(PRIO)="S":"STAT",$G(NTFYREAS)=2:"NOW",$G(NTFYREAS)=3:"STAT",1:"")_"-"
+ S XMSUB=XMSUB_$E(PNAME,1,65-$L(XMSUB))
+ S XMTEXT="PSG("
+ S PSG(1,0)="Inpatient Medications has received the following "_$S($G(PRIO)="A":"ASAP",$G(PRIO)="S":"STAT",$G(NTFYREAS)=2:"NOW",1:"")_" order ("_NTFSTAT_")"
+ S PSG(2,0)=""
+ S PSG(3,0)="          Patient:     "_PNAME I $G(LASTFOUR) S PSG(3,0)=PSG(3,0)_"  ("_LASTFOUR_")"
+ S PSG(4,0)="Order Information:     "_DRUG_" "_DO_" "_RTE_" "_$G(PSJSCHED)
+ S PSG(5,0)="       Order Date:     "_$$ENDTC^PSGMI(ORDATE)
+ D ^XMD
+ Q
+ ;
+PND ;
+ N WARD,WDPARM,MGRP
+ Q:'$D(^PS(53.1,+ORDER,0))
+ S WARD=$G(^DPT(PSJHLDFN,.1)) I WARD]"" D
+ .N DIC,X,Y S DIC="^DIC(42,",DIC(0)="BOXZ",X=WARD D ^DIC S WARD=+Y Q:WARD=0
+ .S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0
+ .Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD)
+ .S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0
+ .S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0
+ S:'$$SNDTSTP^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW PENDING ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0
+ S NTFSTAT="PENDING"
+ N NDP2,ND0 S NDP2=$G(^PS(53.1,+ORDER,.2)),ND0=$G(^PS(53.1,+ORDER,0))
+ S DRIEN=+$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(ND0,"^",3),ORDATE=$P(ND0,"^",14)
+ S SCHED=$P($G(^PS(53.1,+ORDER,2)),"^")
+ Q
+ ;
+UD ;
+ N WARD,WDPARM,MGRP
+ Q:'$D(^PS(55,PSJHLDFN,5,+ORDER,0))
+ S WARD=$P($G(^PS(55,PSJHLDFN,5,+ORDER,0)),"^",23) I +WARD D
+ .S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0
+ .Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD)
+ .S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0
+ .S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0
+ S:'$$SNDTSTA^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW ACTIVE ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0
+ S NTFSTAT="ACTIVE"
+ N ND2,ND0 S ND0=$G(^PS(55,PSJHLDFN,5,+ORDER,0)),ND2=$G(^PS(55,PSJHLDFN,5,+ORDER,2)),NDP2=$G(^PS(55,PSJHLDFN,5,+ORDER,.2))
+ S DRIEN=+$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(ND0,"^",3),ORDATE=$P(ND0,"^",14)
+ S SCHED=$P(ND2,"^")
+ Q
+ ;
+IV ;
+ N WARD,WDPARM,MGRP
+ Q:'$D(^PS(55,PSJHLDFN,"IV",+ORDER,0))
+ S WARD=$P($G(^PS(55,PSJHLDFN,"IV",+ORDER,0)),"^",22) I +WARD D
+ .S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0
+ .Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD)
+ .S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0
+ .S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0
+ S:'$$SNDTSTA^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW ACTIVE ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0
+ S NTFSTAT="ACTIVE"
+ N ND2,NDP2,ND0 S ND0=$G(^PS(55,PSJHLDFN,"IV",+ORDER,0)),ND2=$G(^PS(55,PSJHLDFN,"IV",+ORDER,2))
+ S NDP2=$G(^PS(55,PSJHLDFN,"IV",+ORDER,.2))
+ S DRIEN=$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(NDP2,"^",3)
+ S ORDATE=$P(ND2,"^"),SCHED=$P(ND0,"^",9)
+ Q
+ ;
+MSH ;
+ S PSOC=FIELD(8)
+ Q
+ ;
+PID ;
+ S PSJHLDFN=FIELD(3)
+ Q
+ ;
+PV1 ;
+ N A
+ S CLASS=FIELD(2),LOC=$P(FIELD(3),"^"),APPT="" I $G(FIELD(44))]"" S APPT=+$$HL7TFM^XLFDT(FIELD(44))
+ I "IO"'[CLASS S PSREASON="Invalid patient class" Q
+ ;N II K PSJNVA S II="" F  S II=$O(PSJMSG(II)) Q:'II  D  Q:CLASS="O"
+ N QQ K PSJNVA S QQ=II F  S QQ=$O(PSJMSG(QQ)) Q:'QQ  D  Q:$G(PSJNVA)
+ .S X=$G(PSJMSG(QQ))
+ .I $P(X,"|")="ZRN" S PSJNVA=1,CLASS="O" D EN^PSOHLNEW(.PSJMSG)
+ .;I $P(X,"|")="ZRN" S PSJNVA=1 D EN^PSOHLNEW(.PSJMSG)
+ ; OBR check - enable outpatient flagging from backdoor
+ I $G(PSJNVA) K PSJNVA Q
+ I CLASS="O" N QQ S QQ=II F  S QQ=$O(PSJMSG(QQ)) Q:'QQ  I $P(PSJMSG(QQ),"|")="OBR" D  Q:$P(PSJMSG(QQ),"|")="OBR"
+ .S RXON=$P(PSJMSG(QQ),"|",4) I RXON]"" S RXON=$P(RXON,"^") I "ABNPUV"[$E(RXON,$L(RXON)) S CLASS="I"
+ I CLASS="O" N QQ S QQ=II F  S QQ=$O(PSJMSG(QQ)) Q:'QQ  I $P(PSJMSG(QQ),"|")="ORC" D  Q:$P(PSJMSG(QQ),"|")="ORC"
+ .S RXON=$P(PSJMSG(QQ),"|",4) I RXON]"" S RXON=$P(RXON,"^") I "ABNPUV"[$E(RXON,$L(RXON)) S CLASS="I"
+ I CLASS="O" N CHK,QQ S QQ=II F  S QQ=$O(PSJMSG(QQ)) Q:'QQ  I $P(PSJMSG(QQ),"|")="RXO" D  Q:$P(PSJMSG(QQ),"|")="RXO"
+ .S CHK=$P(PSJMSG(QQ),"|",2),CHK=$S($P(CHK,"^",5)="IV":"IV",1:$P(CHK,"^",4))
+ .I CHK="IV" S CLASS="I" Q
+ .I 'CHK S PSREASON="Missing or Invalid Orderable Item",CLASS="I" Q
+ .I $P($G(^PS(50.7,CHK,0)),"^",3)=1 S CLASS="I" Q
+ D:CLASS="O" EN^PSOHLNEW(.PSJMSG)
+ Q
+ ;
+ORC ;
+ S PSOC=FIELD(1)
+ S ORDER=FIELD(2)
+ I $G(PSREASON)]"" D ERROR^PSJHL9 Q
+ S PSJORDER=$P(FIELD(2),"^"),RXON=$P(FIELD(3),"^"),RXORDER=$S((RXON["N")!(RXON["P"):"^PS(53.1,"_+RXON_",",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+RXON_",",1:"^PS(55,"_PSJHLDFN_",5,"_+RXON_",")
+ I PSOC="NA" D ASSIGN^PSJHL5 Q
+ S CLERK=+$G(FIELD(10))
+ S PROVIDER=+$G(FIELD(12)) D:PSOC="NW"
+ .I PROVIDER=0 S PSREASON="Invalid Provider" D ERROR^PSJHL9 Q 
+ .I PROVIDER>0 S PSPR=$G(^VA(200,+PROVIDER,"PS")) I '$D(PSPR)!'(PSPR)!$S($P(PSPR,"^",4)="":0,1:$P(PSPR,"^",4)'>DT) S PSREASON="Invalid Provider" D ERROR^PSJHL9 Q
+ S UNITS=$P(FIELD(7),"^"),INSTR=$P(FIELD(7),"^",8)
+ S:UNITS["&" DOSE=$P(UNITS,"&"),UNIT=$P(UNITS,"&",2),UNITS=$P(UNITS,"&",3)
+ S SCHEDULE=$P(FIELD(7),"^",2),PRIORITY=$P(FIELD(7),"^",6) S:SCHEDULE["PRN" SCHTYP="P"
+ S DURATION=$P(FIELD(7),"^",3),REQST=$P(FIELD(7),"^",4) S:REQST'="" REQST=+$E(+$$HL7TFM^XLFDT(REQST),1,12) S REQST=$$DATE2^PSJUTL2(REQST)
+ S PRIORITY=$S($G(PRIORITY)]"":PRIORITY,1:"R")
+ I $E(SCHEDULE,1)=" " S:$TR(SCHEDULE," ")="PRN" SCHEDULE="PRN" I '(SCHEDULE="PRN")  S PSREASON="Invalid Schedule" D ERROR^PSJHL9 Q
+ S PRNTON=$P(FIELD(8),"^")
+ S NURSEACK=$G(FIELD(11))
+ S LOGIN=$G(FIELD(15)) S:LOGIN'="" LOGIN=+$E(+$$HL7TFM^XLFDT(FIELD(15)),1,12) S LOGIN=$$DATE2^PSJUTL2(LOGIN)
+ S:$G(NURSEACK)]"" ACKDATE=LOGIN
+ S ORDCON=$P($G(FIELD(16)),U) I ORDCON="A" S PSJASTP=$G(FIELD(9)) S:$G(PSJASTP)'="" PSJASTP=+$E(+$$HL7TFM^XLFDT(PSJASTP),1,12) S PSJASTP=$$DATE2^PSJUTL2(PSJASTP)
+ I (PSOC="CA")!(PSOC="DC") D CANCEL^PSJHL6 Q
+ I PSOC="HD" D HOLD^PSJHL6 Q
+ I PSOC="RL" D UNHOLD^PSJHL6 Q
+ I PSOC="ZV" D NURSEACK^PSJHL5 Q
+ I PSOC="SS" D STATUS^PSJHL5 Q
+ I PSOC="Z@" N X S X="PSJHL8" X ^%ZOSF("TEST") I  D PURGE^PSJHL8 Q
+ I PSOC="DE" S QFLG=1 Q
+ Q
+OBR ; This segment is used to pass flagging information from CPRS.
+ S ORDER=FIELD(2)
+ S PSJORDER=$P(FIELD(2),"^"),RXON=$P(FIELD(3),"^"),RXORDER=$S((RXON["N")!(RXON["P"):"^PS(53.1,"_+RXON_",",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+RXON_",",1:"^PS(55,"_PSJHLDFN_",5,"_+RXON_",")
+ S PSJFLAG=FIELD(4)
+ S FLDATE=$G(FIELD(7)) S:FLDATE'="" FLDATE=+$E(+$$HL7TFM^XLFDT(FIELD(7)),1,12) S FLDATE=$$DATE2^PSJUTL2(FLDATE)
+ S CLERK=+$G(FIELD(16))
+ S PSJYN=$G(FIELD(24))
+ S FLCMNT=$G(FIELD(13))
+ I PSOC="ORU" D FLAG^PSJHL5
+ Q
+RXC ; IV order
+ D RXC^PSJHL4A
+ Q
+ ;
+RXO ;
+ D RXO^PSJHL4A
+ Q
+ ;
+RXR ;
+ S ROUTE=$P(FIELD(1),"^",4)
+ Q
+ ;
+OBX ;
+ D OBX^PSJHL4A
+ Q
+ ;
+NTE ;
+ D NTE^PSJHL4A
+ Q
+ ;
+ZRX ;
+ D ZRX^PSJHL4A
+ Q
+ ;
+ZSC ;Service Connected - Not Used by Inpatient
+ Q
+ ;
+ZRN ;Non-VA Med (Herbal/OTC)
+ S CLASS="O" D EN^PSOHLNEW(.PSJMSG)
+ Q
+DG1 ;Billing Awareness - Not used by Inpatient
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4A.m

@@ -1 @@
-PSJHL4A ;BIR/RLW-CONTINUE DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**105,111,154,170,159,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(52.6 is supported by DBIA# 1231.
-        ; Reference to ^PS(52.7 is supported by DBIA# 2173.
-        ; Reference to ^PS(55 is supported by DBIA# 2191.
-        ; Reference to ^PS(59.7 supported by DBIA #2181.
-        ; Reference to ^ORHLESC is supported by DBIA# 4922.
-        ; Reference to ^SC( is supported by DBIA# 10040.
-        ; Reference to ^PS(51.1 is supported by DBIA# 2177.
-        ; Reference to ^PS(50.7 is supported by DBIA #2180.
-        ; Reference to ^PS(51.2 is supported by DBIA 2178.
-        ;
-RXC     ; IV order
-        N IVFL
-        S APPL=FIELD(1)
-        I APPL["B" S SOLCNT=SOLCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR  S VOLUME=+FIELD(3)_" ML" D  I '$D(^TMP("PSJNVO",$J,"SOL",SOLCNT,0)) D SOLSRCH
-        .S SOLUTION="" F  S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) Q:'SOLUTION  S INACT=$G(^PS(52.7,SOLUTION,"I")) I 'INACT!(INACT>DT) I VOLUME=$P(^PS(52.7,SOLUTION,0),U,3) D
-        ..S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT
-        ..S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME)
-        I $G(INFRT)]"" S X=INFRT D ENI^PSJHLU S INFRT=$G(X)
-        I APPL="A" S ADCNT=ADCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR  S STRENGTH=$G(FIELD(3))_" "_$P($G(FIELD(4)),"^",5) D  I '$D(^TMP("PSJNVO",$J,"AD",ADCNT,0)) S PSREASON="Can't find matching additive" D ERROR^PSJHL9 Q
-        .S ADDITIVE="" F  S ADDITIVE=$O(^PS(52.6,"AOI",PTR,ADDITIVE)) Q:'ADDITIVE  S INACT=$G(^PS(52.6,ADDITIVE,"I")),IVFL=$P($G(^(0)),"^",13) I 'INACT!(INACT>DT),IVFL'=0 Q:$G(^PS(52.6,ADDITIVE,0))']""  D  Q:ADDITIVE
-        ..I $G(PSITEM)="" S PSITEM=PTR
-        ..S ^TMP("PSJNVO",$J,"AD",0)=ADCNT
-        ..S ^TMP("PSJNVO",$J,"AD",ADCNT,0)=ADDITIVE_"^"_STRENGTH
-        Q
-        ;
-RXO     ;
-        I $O(PSJMSG(II,0)) D
-        .K SEGMENT
-        .N KK,JJ,XX
-        .S SEGMENT(1)=$G(PSJMSG(II))
-        .S KK=1,JJ="" F  S JJ=$O(PSJMSG(II,JJ)) Q:'JJ  S KK=KK+1,SEGMENT(KK)=$G(PSJMSG(II,JJ))
-        .S KK=1,JJ=0
-        .F  Q:'$D(SEGMENT(KK))  D
-        ..I SEGMENT(KK)["|" S FIELD(JJ)=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(FIELD(JJ))+2,$L(SEGMENT(KK))),JJ=JJ+1 Q
-        ..I SEGMENT(KK)'["|" S FIELD(JJ)=SEGMENT(KK),KK=KK+1 Q:'$D(SEGMENT(KK))  D
-        ...S XX=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(X)+2,$L(SEGMENT(KK))),FIELD(JJ)=FIELD(JJ)_XX,JJ=JJ+1
-        S APPL="",PSITEM=$S($P(FIELD(1),"^",5)="IV":"",1:$P(FIELD(1),"^",4))
-        S:$P(FIELD(1),"^",6)="ORD" PSITEM=""
-        S:$P(FIELD(1),"^",5)="IV" IVTYP="A",SCHTYP="C",INFRT=$G(FIELD(2))
-        S DISPENSE=$P($G(FIELD(10)),"^",4)
-        S IVLIMIT=$P($G(PSJMSG(II)),"^",3)
-        S:IVLIMIT["doses" IVLIMIT=$TR(IVLIMIT,"doses","a")
-        Q
-        ;
-OBX     ;
-        S OBXFL=1,OCNARR=FIELD(5),OCPROV=CLERK,OCCNT=OCCNT+1
-        S ^TMP("PSJNVO",$J,10,0)=OCCNT
-        S ^TMP("PSJNVO",$J,10,OCCNT,0)=OCNARR
-        S ^TMP("PSJNVO",$J,10,OCCNT,1)=$$UNESC^ORHLESC($P($G(^VA(200,+OCPROV,0)),"^"))
-        Q
-        ;
-NTE     ;
-        S TEXT=$S((FIELD(1)=6)&('OBXFL):"PROCOM",(FIELD(1)=7)&('OBXFL):"ADMINSTR",1:"OCRSN")
-        S @TEXT@(1)=$$UNESC^ORHLESC($G(FIELD(3)))
-        S K=1,J="" F  S J=$O(PSJMSG(II,J)) Q:'J  S K=K+1,@TEXT@(K)=$G(PSJMSG(II,J))
-        D:$D(OCRSN)
-        .S QQ=0 F  S QQ=$O(OCRSN(QQ)) Q:'QQ  S ^TMP("PSJNVO",$J,10,OCCNT,2,QQ,0)=OCRSN(QQ)
-        S OBXFL=0
-        Q
-        ;
-ZRX     ;
-        N ND,ND2,CHK,FOLOR,STDT
-        S PREON=$G(FIELD(1)),ROC=$G(FIELD(3)),IVCAT=$G(FIELD(6))
-        S IVCAT=$S(",I,C,"[(","_IVCAT_","):IVCAT,1:"") I 'PREON S IVTYP=$S($G(PSGS0XT):"P",1:"A") S IVTYP=$S(IVCAT="I":"P",IVCAT="C":"A",1:$G(IVTYP))
-        S ND=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,0)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,0)),1:$G(^PS(55,PSJHLDFN,5,+PREON,0)))
-        S ND2=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,2)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,2)),1:$G(^PS(55,PSJHLDFN,5,+PREON,2)))
-        I 'ND I ROC'="N" S PSREASON="Invalid Pharmacy order number" D ERROR^PSJHL9 Q
-        I ND I ROC="R" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Duplicate Renewal Request" D ERROR^PSJHL9 Q
-        I ND I ROC="R" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "AE"'[CHK S PSREASON="Pharmacy orders with a status of "_CHK_" may not be renewed" D ERROR^PSJHL9 Q
-        I $G(CHK)="E" I PREON'["V" D NOW^%DTC S X1=+$E(%,1,12),X2=-4 D C^%DTC S STDT=$S(PREON["V":$P(ND,U,3),1:$P(ND2,U,4)) I STDT'>X S PSREASON="Pharmacy orders expired longer than 4 days may not be renewed" D ERROR^PSJHL9 Q
-        I ND I ROC="E" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Pharmacy orders may only be edited ONCE" D ERROR^PSJHL9 Q
-        I ND I ROC="E" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "DEHO"[CHK N CHKRTN S CHKRTN=CHK_"^PSJHL6" D @CHKRTN S PSREASON=PSREASON_" orders may not be edited" D ERROR^PSJHL9 Q
-        D:ROC'="R" VALID^PSJHL9 Q:QFLG
-        I $G(PSITEM)="",$D(^TMP("PSJNVO",$J,"SOL",1,0)) S PSITEM=$P($G(^PS(52.7,+^TMP("PSJNVO",$J,"SOL",1,0),0)),"^",11)
-        I PRIORITY="ZD" D VALID^PSJHL10 S QFLG=1 Q
-        I (PREON]"")&(ROC="E") D EDITCK^PSJHL5 Q:QFLG
-        D NVO^PSJHL9
-        I (PREON]"")&(ROC="R") D RENEW^PSJHL7 Q
-        I (PREON]"")&(ROC="E") D EDIT^PSJHL5
-        Q
-        ;
-SOLSRCH ;Find solution
-        N SSSS,SEG,ON,ROC,SOL,SOL2
-        F SSSS=II:0 S SSSS=$O(PSJMSG(SSSS)) Q:'SSSS  I $P(PSJMSG(SSSS),"|")="ZRX" D  Q
-        .S SEG=$G(PSJMSG(SSSS)),ON=$P(SEG,"|",2),ROC=$P(SEG,"|",4)
-        I $G(ROC)'="N" F SOL=0:0 S SOL=$O(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL)) Q:'SOL  S SOL2=$G(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL,0)) I $D(^PS(52.7,"AOI",PTR,+SOL2))&($P(SOL2,U,2)=VOLUME) S SOLUTION=+SOL2 D SET Q
-        I 'SOLUTION S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) D SET
-        Q
-SET     ;Set solution tmp nodes
-        Q:'+SOLUTION
-        S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT
-        S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME)
-        Q
-        ;
-SNDTSTW(PRIO,PSJSCHED,WARD)     ; Test to determine if mail message should be sent.
-        N SNPRIO,SNSCHD,SNOPT
-        S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
-        S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
-        S SNOPT=$P($G(^PS(59.6,WARD,0)),"^",32)
-        S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
-        Q:SNOPT="" 0
-        Q:SNOPT[SNPRIO 0
-        Q:SNOPT[SNSCHD 0
-        Q 1
-        ;
-SNDTSTP(PRIO,PSJSCHED)  ; Test to determine if mail message should be sent.
-        N SNPRIO,SNSCHD,SNOPT
-        S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
-        S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
-        S SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
-        Q:SNOPT="" 1
-        Q:SNOPT[SNPRIO 0
-        Q:SNOPT[SNSCHD 0
-        Q 1
-        ;
-SNDTSTA(PRIO,PSJSCHED)  ; Test to determine if mail message should be sent.
-        N SNPRIO,SNSCHD,SNOPT
-        S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
-        S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
-        S SNOPT=$P($G(^PS(59.7,1,27)),"^",2)
-        S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
-        Q:SNOPT="" 1
-        Q:SNOPT[SNPRIO 0
-        Q:SNOPT[SNSCHD 0
-        Q 1
-        ;
-TMPAT(SCHEDULE) ; Extract admin times from schedule in format schedule@schedule
-        S TMPAT="" I SCHEDULE'["@" Q TMPAT
-        S TMPAT=$P(SCHEDULE,"@",2) I TMPAT]"" D
-        .N WARD S WARD=$G(^DPT(PSJHLDFN,.1)) I WARD]"" D
-        ..N DIC,X,Y S DIC="^DIC(42,",DIC(0)="BOXZ",X=WARD D ^DIC S WARD=+Y Q:WARD=0
-        ..S WARD=$O(^PS(59.6,"B",WARD,0))
-        .I '$D(^PS(51.1,"AC","PSJ",TMPAT)) S TMPAT="" Q
-        .N II I '$$DOW^PSIVUTL($P(SCHEDULE,"@")) S TMPAT="" Q
-        .N TMPIEN S TMPIEN=$O(^PS(51.1,"AC","PSJ",TMPAT,0)),TMPAT=$P($G(^PS(51.1,+TMPIEN,0)),"^",2) D
-        ..I $P($G(^PS(51.1,+TMPIEN,1,+$G(WARD),0)),"^",2) S TMPAT=$P($G(^(0)),"^",2)
-        Q TMPAT
-        ;
-XMD     ; Mailman call for NOTIFY^PSJHL4
-        ; Input - PNAME  = Patient Name
-        ;         RTE    = Route
-        ;         DRUG   = Drug Name
-        ;         WARD   = Ward Name
-        ;         PRIO   = CPRS Order Priority
-        S PNAME=$P($G(^DPT(+PSJHLDFN,0)),"^") S:$G(RTE) RTE=$P(^PS(51.2,+RTE,0),"^",3)
-        S DRUG=$S(DRIEN:$P($G(^PS(50.7,+DRIEN,0)),"^"),1:""),WARD=$G(^DPT(PSJHLDFN,.1))
-        S XMDUZ="MEDICATIONS,INPATIENT",XMSUB=$G(WARD)
-        S XMSUB=XMSUB_"-"_NTFSTAT_" "_$S($G(PRIO)="A":"ASAP",$G(PRIO)="S":"STAT",$G(NTFYREAS)=2:"NOW",$G(NTFYREAS)=3:"STAT",1:"")_"-"
-        S XMSUB=XMSUB_$E(PNAME,1,65-$L(XMSUB))
-        S XMTEXT="PSG("
-        S PSG(1,0)="Inpatient Medications has received the following "_$S($G(PRIO)="A":"ASAP",$G(PRIO)="S":"STAT",$G(NTFYREAS)=2:"NOW",1:"")_" order ("_NTFSTAT_")"
-        S PSG(2,0)=""
-        S PSG(3,0)="          Patient:     "_PNAME I $G(LASTFOUR) S PSG(3,0)=PSG(3,0)_"  ("_LASTFOUR_")"
-        S PSG(4,0)="Order Information:     "_DRUG_" "_DO_" "_RTE_" "_$G(PSJSCHED)
-        S PSG(5,0)="       Order Date:     "_$$ENDTC^PSGMI(ORDATE)
-        D ^XMD
-        Q
+PSJHL4A ;BIR/RLW-CONTINUE DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**105,111,154,170,159**;16 DEC 97;Build 15
+ ;
+ ; Reference to ^PS(52.6 is supported by DBIA# 1231.
+ ; Reference to ^PS(52.7 is supported by DBIA# 2173.
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^PS(59.7 supported by DBIA #2181.
+ ;
+RXC ; IV order
+ N IVFL
+ S APPL=FIELD(1)
+ I APPL["B" S SOLCNT=SOLCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR  S VOLUME=+FIELD(3)_" ML" D  I '$D(^TMP("PSJNVO",$J,"SOL",SOLCNT,0)) D SOLSRCH
+ .S SOLUTION="" F  S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) Q:'SOLUTION  S INACT=$G(^PS(52.7,SOLUTION,"I")) I 'INACT!(INACT>DT) I VOLUME=$P(^PS(52.7,SOLUTION,0),U,3) D
+ ..S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT
+ ..S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME)
+ I $G(INFRT)]"" S X=INFRT D ENI^PSJHLU S INFRT=$G(X)
+ I APPL="A" S ADCNT=ADCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR  S STRENGTH=$G(FIELD(3))_" "_$P($G(FIELD(4)),"^",5) D  I '$D(^TMP("PSJNVO",$J,"AD",ADCNT,0)) S PSREASON="Can't find matching additive" D ERROR^PSJHL9 Q
+ .S ADDITIVE="" F  S ADDITIVE=$O(^PS(52.6,"AOI",PTR,ADDITIVE)) Q:'ADDITIVE  S INACT=$G(^PS(52.6,ADDITIVE,"I")),IVFL=$P($G(^(0)),"^",13) I 'INACT!(INACT>DT),IVFL'=0 Q:$G(^PS(52.6,ADDITIVE,0))']""  D  Q:ADDITIVE
+ ..I $G(PSITEM)="" S PSITEM=PTR
+ ..S ^TMP("PSJNVO",$J,"AD",0)=ADCNT
+ ..S ^TMP("PSJNVO",$J,"AD",ADCNT,0)=ADDITIVE_"^"_STRENGTH
+ Q
+ ;
+RXO ;
+ I $O(PSJMSG(II,0)) D
+ .K SEGMENT
+ .N KK,JJ,XX
+ .S SEGMENT(1)=$G(PSJMSG(II))
+ .S KK=1,JJ="" F  S JJ=$O(PSJMSG(II,JJ)) Q:'JJ  S KK=KK+1,SEGMENT(KK)=$G(PSJMSG(II,JJ))
+ .S KK=1,JJ=0
+ .F  Q:'$D(SEGMENT(KK))  D
+ ..I SEGMENT(KK)["|" S FIELD(JJ)=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(FIELD(JJ))+2,$L(SEGMENT(KK))),JJ=JJ+1 Q
+ ..I SEGMENT(KK)'["|" S FIELD(JJ)=SEGMENT(KK),KK=KK+1 Q:'$D(SEGMENT(KK))  D
+ ...S XX=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(X)+2,$L(SEGMENT(KK))),FIELD(JJ)=FIELD(JJ)_XX,JJ=JJ+1
+ S APPL="",PSITEM=$S($P(FIELD(1),"^",5)="IV":"",1:$P(FIELD(1),"^",4))
+ S:$P(FIELD(1),"^",6)="ORD" PSITEM=""
+ S:$P(FIELD(1),"^",5)="IV" IVTYP="A",SCHTYP="C",INFRT=$G(FIELD(2))
+ S DISPENSE=$P($G(FIELD(10)),"^",4)
+ S IVLIMIT=$P($G(PSJMSG(II)),"^",3)
+ Q
+ ;
+OBX ;
+ S OBXFL=1,OCNARR=FIELD(5),OCPROV=CLERK,OCCNT=OCCNT+1
+ S ^TMP("PSJNVO",$J,10,0)=OCCNT
+ S ^TMP("PSJNVO",$J,10,OCCNT,0)=OCNARR
+ S ^TMP("PSJNVO",$J,10,OCCNT,1)=$P($G(^VA(200,+OCPROV,0)),"^")
+ Q
+ ;
+NTE ;
+ S TEXT=$S((FIELD(1)=6)&('OBXFL):"PROCOM",(FIELD(1)=7)&('OBXFL):"ADMINSTR",1:"OCRSN")
+ S @TEXT@(1)=$G(FIELD(3))
+ S K=1,J="" F  S J=$O(PSJMSG(II,J)) Q:'J  S K=K+1,@TEXT@(K)=$G(PSJMSG(II,J))
+ D:$D(OCRSN)
+ .S QQ=0 F  S QQ=$O(OCRSN(QQ)) Q:'QQ  S ^TMP("PSJNVO",$J,10,OCCNT,2,QQ,0)=OCRSN(QQ)
+ S OBXFL=0
+ Q
+ ;
+ZRX ;
+ N ND,ND2,CHK,FOLOR,STDT
+ S PREON=$G(FIELD(1)),ROC=$G(FIELD(3))
+ S ND=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,0)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,0)),1:$G(^PS(55,PSJHLDFN,5,+PREON,0)))
+ S ND2=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,2)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,2)),1:$G(^PS(55,PSJHLDFN,5,+PREON,2)))
+ I 'ND I ROC'="N" S PSREASON="Invalid Pharmacy order number" D ERROR^PSJHL9 Q
+ I ND I ROC="R" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Duplicate Renewal Request" D ERROR^PSJHL9 Q
+ I ND I ROC="R" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "AE"'[CHK S PSREASON="Pharmacy orders with a status of "_CHK_" may not be renewed" D ERROR^PSJHL9 Q
+ I $G(CHK)="E" I PREON'["V" D NOW^%DTC S X1=+$E(%,1,12),X2=-4 D C^%DTC S STDT=$S(PREON["V":$P(ND,U,3),1:$P(ND2,U,4)) I STDT'>X S PSREASON="Pharmacy orders expired longer than 4 days may not be renewed" D ERROR^PSJHL9 Q
+ I ND I ROC="E" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Pharmacy orders may only be edited ONCE" D ERROR^PSJHL9 Q
+ I ND I ROC="E" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "DEHO"[CHK N CHKRTN S CHKRTN=CHK_"^PSJHL6" D @CHKRTN S PSREASON=PSREASON_" orders may not be edited" D ERROR^PSJHL9 Q
+ D:ROC'="R" VALID^PSJHL9 Q:QFLG
+ I $G(PSITEM)="",$D(^TMP("PSJNVO",$J,"SOL",1,0)) S PSITEM=$P($G(^PS(52.7,+^TMP("PSJNVO",$J,"SOL",1,0),0)),"^",11)
+ I PRIORITY="ZD" D VALID^PSJHL10 S QFLG=1 Q
+ I (PREON]"")&(ROC="E") D EDITCK^PSJHL5 Q:QFLG
+ D NVO^PSJHL9
+ I (PREON]"")&(ROC="R") D RENEW^PSJHL7 Q
+ I (PREON]"")&(ROC="E") D EDIT^PSJHL5
+ Q
+ ;
+SOLSRCH ;Find solution
+ N SSSS,SEG,ON,ROC,SOL,SOL2
+ F SSSS=II:0 S SSSS=$O(PSJMSG(SSSS)) Q:'SSSS  I $P(PSJMSG(SSSS),"|")="ZRX" D  Q
+ .S SEG=$G(PSJMSG(SSSS)),ON=$P(SEG,"|",2),ROC=$P(SEG,"|",4)
+ I $G(ROC)'="N" F SOL=0:0 S SOL=$O(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL)) Q:'SOL  S SOL2=$G(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL,0)) I $D(^PS(52.7,"AOI",PTR,+SOL2))&($P(SOL2,U,2)=VOLUME) S SOLUTION=+SOL2 D SET Q
+ I 'SOLUTION S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) D SET
+ Q
+SET ;Set solution tmp nodes
+ Q:'+SOLUTION
+ S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT
+ S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME)
+ Q
+ ;
+SNDTSTW(PRIO,PSJSCHED,WARD) ; Test to determine if mail message should be sent.
+ N SNPRIO,SNSCHD,SNOPT
+ S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
+ S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
+ S SNOPT=$P($G(^PS(59.6,WARD,0)),"^",32)
+ S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
+ Q:SNOPT="" 0
+ Q:SNOPT[SNPRIO 0
+ Q:SNOPT[SNSCHD 0
+ Q 1
+ ;
+SNDTSTP(PRIO,PSJSCHED) ; Test to determine if mail message should be sent.
+ N SNPRIO,SNSCHD,SNOPT
+ S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
+ S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
+ S SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
+ Q:SNOPT="" 1
+ Q:SNOPT[SNPRIO 0
+ Q:SNOPT[SNSCHD 0
+ Q 1
+ ;
+SNDTSTA(PRIO,PSJSCHED) ; Test to determine if mail message should be sent.
+ N SNPRIO,SNSCHD,SNOPT
+ S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
+ S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
+ S SNOPT=$P($G(^PS(59.7,1,27)),"^",2)
+ S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
+ Q:SNOPT="" 1
+ Q:SNOPT[SNPRIO 0
+ Q:SNOPT[SNSCHD 0
+ Q 1

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL5.m

@@ -1 @@
-PSJHL5  ;BIR/LDT-ACTIONS ON HL7 MESSAGES FROM OE/RR ;28 Jan 98 / 3:34 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**1,28,39,40,42,84,85,95,80,173,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(55 is supported by DBIA# 2191.
-        ; Reference to EN^ORERR is supported by DBIA# 2187.
-        ; Reference to NURV^ALPBCBU is supported by DBIA# 4120.
-        ; Reference to UNESC^ORHLESC is supported by DBIA# 4922
-        ;
-ASSIGN  ; number assigned, update ORDERS FILE ENTRY
-        S RXORDER=RXORDER_"0)"
-        I '$P($G(@RXORDER),U) S ORDCON="Invalid Pharmacy order number/Number Assign Msg" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON,.PSJMSG) Q
-        Q:'$P($G(@RXORDER),U)
-        I RXON["P",PSJHLDFN'=$P($G(@(RXORDER)),U,15) S ORDCON="Patient does not match/Number Assign Msg" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON,.PSJMSG) Q
-        I RXON["P",PSJHLDFN'=$P($G(@(RXORDER)),U,15) Q
-        S $P(@RXORDER,"^",21)=PSJORDER
-        Q
-        ;
-NURSEACK        ;Nurse Acknowledgement of Pending Orders
-        I '$P($G(@(RXORDER_"0)")),U) S ORDCON="Invalid Pharmacy order number/Nurse Acknowledgement Msg" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON,.PSJMSG) Q
-        Q:'$P($G(@(RXORDER_"0)")),U)
-        I RXON["P",PSJHLDFN'=$P($G(@(RXORDER_"0)")),U,15) S ORDCON="Patient does not match/Nurse Acknowledgement Msg" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON,.PSJMSG) Q
-        I RXON["P",PSJHLDFN'=$P($G(@(RXORDER_"0)")),U,15) Q
-        I RXON["P" N STATUS S STATUS=$P($G(@(RXORDER_"0)")),U,9) D:STATUS="N" EN^PSJHLV(PSJHLDFN,RXON)
-        I RXON["P" N STATUS S STATUS=$P($G(@(RXORDER_"0)")),U,9) Q:STATUS="A"
-        N DIE,DA
-        S DIE=$S(RXON["N"!(RXON["P"):"^PS(53.1,",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+RXON,DA(1)=PSJHLDFN
-        S DR="16////"_NURSEACK_";17////"_ACKDATE S:RXON["U" DR=DR_";51////1" S:RXON["V" DR=DR_";143////1",PSIVACT=""
-        I RXON["U" D NEWUDAL^PSGAL5(PSJHLDFN,RXON,22010)
-        I RXON["P" D NEWNVAL^PSGAL5(RXON,22010)
-        S PSGNVF=1 D ^DIE
-        I RXON["V" NEW ON55,DFN,PSIVAL,PSIVREA,PSIVLN K PSIVACT D
-        . S ON55=RXON,DFN=PSJHLDFN,PSIVAL="ORDER VERIFIED BY NURSE",PSIVALT="",PSIVREA="V"
-        . D LOG^PSIVORAL
-        D:RXON["P" EN^PSJLOI(PSJHLDFN,RXON) D:RXON["U" EN2^PSJLOI(PSJHLDFN,RXON)
-        K:RXON["U" ^PS(55,"ANV",PSJHLDFN,+RXON)
-        I $T(NURV^ALPBCBU)'="" D NURV^ALPBCBU(PSJHLDFN,RXON)
-        Q
-        ;
-EDIT    ;Edit orders thru OE/RR
-        N DA,DR,DIE,PREORDER,STPDT,PSIVACT,PSIVALT,ON55,PSIVREA,PSIVALCK,P
-        S PREORDER=$S((PREON["N")!(PREON["P"):"^PS(53.1,"_+PREON_",2)",PREON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+PREON_",0)",1:"^PS(55,"_PSJHLDFN_",5,"_+PREON_",2)")
-        S STPDT=$S(PREON["V":$P($G(@PREORDER),"^",3),1:$P($G(@PREORDER),"^",4))
-        D NOW^%DTC
-        S DIE=$S(PREON["N"!(PREON["P"):"^PS(53.1,",PREON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+PREON,DA(1)=+PSJHLDFN
-        S DR=$S(PREON["V":"100////D;116////^S X=STPDT;123////E;114////"_PSJORDER_";.03////"_%,((PREON["P")!(PREON["N")):"25////"_%_";28////DE;107////E;105////"_PSJORDER_";32////"_STPDT,1:"25////"_STPDT_";28////DE;107////E;105////"_PSJORDER_";34////"_%)
-        I PREON["U"!(PREON["A") S PSGAL("C")=4100 D ^PSGAL5
-        I PREON["V" S PSIVACT=1,PSIVALT=2,ON55=PREON,PSIVREA="D",PSIVALCK="STOP",P(3)=STPDT
-        D ^DIE,AUE^PSJHL6(PSJHLDFN,PREON)
-        I PREON["V" N DFN S DFN=PSJHLDFN D LOG^PSIVORAL
-        S PSJHLMTN="ORM",PSOC=$S((PREON["N")!(PREON["P"):"OC",1:"OD") D EN1^PSJHL2(PSJHLDFN,PSOC,PREON) S PSJHLMTN="ORR",PSOC="XO"
-        Q
-        ;
-EDITCK  ;Check to see if PSJHLDFN passed matches PSJHLDFN in pending order.
-        I (PREON["N")!(PREON["P"),PSJHLDFN'=$P($G(^PS(53.1,+PREON,0)),U,15) D
-        . S ORDCON="Patient does not match/Edit Msg" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON,.PSJMSG)
-        . D EN1^PSJHLERR(PSJHLDFN,"UX",$P(ORDER,"^"),ORDCON) S QFLG=1
-        Q
-        ;        
-STATUS  ;Check status of an order in response to a send order status request from CPRS.
-        N STATUS,STPDT,NODE,NODE2
-        S NODE=$G(@(RXORDER_"0)")),NODE2=$G(@(RXORDER_"2)"))
-        I 'NODE S PSREASON="Invalid Pharmacy order number" D  Q
-        .S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(PSREASON_"/Status Check",.PSJMSG)
-        .D EN1^PSJHLERR(PSJHLDFN,"DE",$P(ORDER,U),PSREASON)
-        S $P(@(RXORDER_"0)"),"^",21)=$P(ORDER,"^")
-        S STATUS=$S(RXON["V":$P(NODE,"^",17),1:$P(NODE,"^",9))
-        S STPDT=$S(RXON["V":$P(NODE,"^",3),1:$P(NODE2,"^",4))
-        D NOW^%DTC I RXON'["P" I "DEH"'[STATUS I STPDT<% D EXPIR^PSJHL6 Q
-        D EN1^PSJHL2(PSJHLDFN,"SC",RXON)
-        Q
-        ;
-FLAG    ;Flag/Unflag orders
-        I '$P($G(@(RXORDER_"0)")),U) S ORDCON="Invalid Pharmacy order number/Flag Msg" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON,.PSJMSG) Q
-        Q:'$P($G(@(RXORDER_"0)")),U)
-        S DIE=$S(RXON["N"!(RXON["P"):"^PS(53.1,",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+RXON,DA(1)=PSJHLDFN
-        S DR=$S(PSJFLAG="FL":$S(RXON["V":"148////1",1:"124////1"),1:$S(RXON["V":"148////@",1:"124////@"))
-        D ^DIE
-        I $G(FLCMNT)]"" S FLCMNT=$$UNESC^ORHLESC(FLCMNT)
-        I RXON["U" D
-        . S ^PS(55,PSJHLDFN,5,+RXON,13)=FLCMNT
-        . S FLCMNT="COMMENTS: "_FLCMNT S:$L(FLCMNT)>52 FLCMNT=$E(FLCMNT,1,49)_"..."
-        . D NEWUDAL^PSGAL5(PSJHLDFN,+RXON,$S((PSJFLAG="FL")&(PSJYN="PHR"):7000,(PSJFLAG="UF")&(PSJYN="PHR"):7010,(PSJFLAG="FL")&(PSJYN=""):7020,1:7030),FLCMNT)
-        I RXON["V" N DFN,ON55,PSIVREA,PSIVAL S DFN=PSJHLDFN S PSIVALT="",ON55=RXON,PSIVREA=$S(PSJFLAG="FL":"G",1:"UG"),PSIVAL=$S(PSJYN="PHR":"FLAGGED BY PHARMACIST ",1:"FLAGGED BY CPRS ")_FLCMNT D LOG^PSIVORAL
-        I RXON["P" D
-        . S ^PS(53.1,+RXON,13)=FLCMNT
-        . S FLCMNT="COMMENTS: "_FLCMNT S:$L(FLCMNT)>52 FLCMNT=$E(FLCMNT,1,49)_"..."
-        . D NEWNVAL^PSGAL5(+RXON,$S((PSJFLAG="FL")&(PSJYN="PHR"):7000,(PSJFLAG="UF")&(PSJYN="PHR"):7010,(PSJFLAG="FL")&(PSJYN=""):7020,1:7030),FLCMNT)
-        ;The ... on Unit Dose and Pending orders is because of the limitations in the DD of 53.1.
-        Q
+PSJHL5 ;BIR/LDT-ACTIONS ON HL7 MESSAGES FROM OE/RR ;28 Jan 98 / 3:34 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**1,28,39,40,42,84,85,95,80,173**;16 DEC 97;Build 4
+ ;
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to EN^ORERR is supported by DBIA# 2187.
+ ; Reference to NURV^ALPBCBU is supported by DBIA# 4120.
+ ;
+ASSIGN ; number assigned, update ORDERS FILE ENTRY
+ S RXORDER=RXORDER_"0)"
+ I '$P($G(@RXORDER),U) S ORDCON="Invalid Pharmacy order number/Number Assign Msg" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON,.PSJMSG) Q
+ Q:'$P($G(@RXORDER),U)
+ I RXON["P",PSJHLDFN'=$P($G(@(RXORDER)),U,15) S ORDCON="Patient does not match/Number Assign Msg" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON,.PSJMSG) Q
+ I RXON["P",PSJHLDFN'=$P($G(@(RXORDER)),U,15) Q
+ S $P(@RXORDER,"^",21)=PSJORDER
+ Q
+ ;
+NURSEACK ;Nurse Acknowledgement of Pending Orders
+ I '$P($G(@(RXORDER_"0)")),U) S ORDCON="Invalid Pharmacy order number/Nurse Acknowledgement Msg" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON,.PSJMSG) Q
+ Q:'$P($G(@(RXORDER_"0)")),U)
+ I RXON["P",PSJHLDFN'=$P($G(@(RXORDER_"0)")),U,15) S ORDCON="Patient does not match/Nurse Acknowledgement Msg" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON,.PSJMSG) Q
+ I RXON["P",PSJHLDFN'=$P($G(@(RXORDER_"0)")),U,15) Q
+ I RXON["P" N STATUS S STATUS=$P($G(@(RXORDER_"0)")),U,9) D:STATUS="N" EN^PSJHLV(PSJHLDFN,RXON)
+ I RXON["P" N STATUS S STATUS=$P($G(@(RXORDER_"0)")),U,9) Q:STATUS="A"
+ N DIE,DA
+ S DIE=$S(RXON["N"!(RXON["P"):"^PS(53.1,",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+RXON,DA(1)=PSJHLDFN
+ S DR="16////"_NURSEACK_";17////"_ACKDATE S:RXON["U" DR=DR_";51////1" S:RXON["V" DR=DR_";143////1",PSIVACT=""
+ I RXON["U" D NEWUDAL^PSGAL5(PSJHLDFN,RXON,22010)
+ I RXON["P" D NEWNVAL^PSGAL5(RXON,22010)
+ S PSGNVF=1 D ^DIE
+ I RXON["V" NEW ON55,DFN,PSIVAL,PSIVREA,PSIVLN K PSIVACT D
+ . S ON55=RXON,DFN=PSJHLDFN,PSIVAL="ORDER VERIFIED BY NURSE",PSIVALT="",PSIVREA="V"
+ . D LOG^PSIVORAL
+ D:RXON["P" EN^PSJLOI(PSJHLDFN,RXON) D:RXON["U" EN2^PSJLOI(PSJHLDFN,RXON)
+ K:RXON["U" ^PS(55,"ANV",PSJHLDFN,+RXON)
+ I $T(NURV^ALPBCBU)'="" D NURV^ALPBCBU(PSJHLDFN,RXON)
+ Q
+ ;
+EDIT ;Edit orders thru OE/RR
+ N DA,DR,DIE,PREORDER,STPDT,PSIVACT,PSIVALT,ON55,PSIVREA,PSIVALCK,P
+ S PREORDER=$S((PREON["N")!(PREON["P"):"^PS(53.1,"_+PREON_",2)",PREON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+PREON_",0)",1:"^PS(55,"_PSJHLDFN_",5,"_+PREON_",2)")
+ S STPDT=$S(PREON["V":$P($G(@PREORDER),"^",3),1:$P($G(@PREORDER),"^",4))
+ D NOW^%DTC
+ S DIE=$S(PREON["N"!(PREON["P"):"^PS(53.1,",PREON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+PREON,DA(1)=+PSJHLDFN
+ S DR=$S(PREON["V":"100////D;116////^S X=STPDT;123////E;114////"_PSJORDER_";.03////"_%,((PREON["P")!(PREON["N")):"25////"_%_";28////DE;107////E;105////"_PSJORDER_";32////"_STPDT,1:"25////"_STPDT_";28////DE;107////E;105////"_PSJORDER_";34////"_%)
+ I PREON["U"!(PREON["A") S PSGAL("C")=4100 D ^PSGAL5
+ I PREON["V" S PSIVACT=1,PSIVALT=2,ON55=PREON,PSIVREA="D",PSIVALCK="STOP",P(3)=STPDT
+ D ^DIE,AUE^PSJHL6(PSJHLDFN,PREON)
+ I PREON["V" N DFN S DFN=PSJHLDFN D LOG^PSIVORAL
+ S PSJHLMTN="ORM",PSOC=$S((PREON["N")!(PREON["P"):"OC",1:"OD") D EN1^PSJHL2(PSJHLDFN,PSOC,PREON) S PSJHLMTN="ORR",PSOC="XO"
+ Q
+ ;
+EDITCK ;Check to see if PSJHLDFN passed matches PSJHLDFN in pending order.
+ I (PREON["N")!(PREON["P"),PSJHLDFN'=$P($G(^PS(53.1,+PREON,0)),U,15) D
+ . S ORDCON="Patient does not match/Edit Msg" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON,.PSJMSG)
+ . D EN1^PSJHLERR(PSJHLDFN,"UX",$P(ORDER,"^"),ORDCON) S QFLG=1
+ Q
+ ;        
+STATUS ;Check status of an order in response to a send order status request from CPRS.
+ N STATUS,STPDT,NODE,NODE2
+ S NODE=$G(@(RXORDER_"0)")),NODE2=$G(@(RXORDER_"2)"))
+ I 'NODE S PSREASON="Invalid Pharmacy order number" D  Q
+ .S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(PSREASON_"/Status Check",.PSJMSG)
+ .D EN1^PSJHLERR(PSJHLDFN,"DE",$P(ORDER,U),PSREASON)
+ S $P(@(RXORDER_"0)"),"^",21)=$P(ORDER,"^")
+ S STATUS=$S(RXON["V":$P(NODE,"^",17),1:$P(NODE,"^",9))
+ S STPDT=$S(RXON["V":$P(NODE,"^",3),1:$P(NODE2,"^",4))
+ D NOW^%DTC I RXON'["P" I "DEH"'[STATUS I STPDT<% D EXPIR^PSJHL6 Q
+ D EN1^PSJHL2(PSJHLDFN,"SC",RXON)
+ Q
+ ;
+FLAG ;Flag/Unflag orders
+ I '$P($G(@(RXORDER_"0)")),U) S ORDCON="Invalid Pharmacy order number/Flag Msg" S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(ORDCON,.PSJMSG) Q
+ Q:'$P($G(@(RXORDER_"0)")),U)
+ S DIE=$S(RXON["N"!(RXON["P"):"^PS(53.1,",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+RXON,DA(1)=PSJHLDFN
+ S DR=$S(PSJFLAG="FL":$S(RXON["V":"148////1",1:"124////1"),1:$S(RXON["V":"148////@",1:"124////@"))
+ D ^DIE
+ I RXON["U" D
+ . S ^PS(55,PSJHLDFN,5,+RXON,13)=FLCMNT
+ . S FLCMNT="COMMENTS: "_FLCMNT S:$L(FLCMNT)>52 FLCMNT=$E(FLCMNT,1,49)_"..."
+ . D NEWUDAL^PSGAL5(PSJHLDFN,+RXON,$S((PSJFLAG="FL")&(PSJYN="PHR"):7000,(PSJFLAG="UF")&(PSJYN="PHR"):7010,(PSJFLAG="FL")&(PSJYN=""):7020,1:7030),FLCMNT)
+ I RXON["V" N DFN,ON55,PSIVREA,PSIVAL S DFN=PSJHLDFN S PSIVALT="",ON55=RXON,PSIVREA=$S(PSJFLAG="FL":"G",1:"UG"),PSIVAL=$S(PSJYN="PHR":"FLAGGED BY PHARMICIST ",1:"FLAGGED BY CPRS ")_FLCMNT D LOG^PSIVORAL
+ I RXON["P" D
+ . S ^PS(53.1,+RXON,13)=FLCMNT
+ . S FLCMNT="COMMENTS: "_FLCMNT S:$L(FLCMNT)>52 FLCMNT=$E(FLCMNT,1,49)_"..."
+ . D NEWNVAL^PSGAL5(+RXON,$S((PSJFLAG="FL")&(PSJYN="PHR"):7000,(PSJFLAG="UF")&(PSJYN="PHR"):7010,(PSJFLAG="FL")&(PSJYN=""):7020,1:7030),FLCMNT)
+ ;The ... on Unit Dose and Pending orders is because of the limitations in the DD of 53.1.
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL9.m

@@ -1 @@
-PSJHL9  ;BIR/LDT-VALIDATE INCOMING HL7 DATA/CREATE NEW ORDER ;08 Jul 99 / 10:50 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**1,18,31,42,47,50,63,72,75,58,80,110,111,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PSDRUG is supported by DBIA# 2192.
-        ; Reference to ^PS(50.7 is supported by DBIA# 2180.
-        ; Reference to ^PS(51.2 is supported by DBIA# 2178.
-        ; Reference to ^PS(55 is supported by DBIA# 2191.
-        ; Reference to ^ORERR is supported by DBIA# 2187.
-        ; Reference to ^ORHLESC is supported by DBIA# 4922.
-        ;
-VALID   ;
-        I APPL="",PSITEM="" S PSREASON="Missing or invalid Orderable Item" D ERROR Q
-        I PSITEM]"",'$D(^PS(50.7,+PSITEM,0)) S PSREASON="Missing or invalid Orderable Item" D ERROR Q
-        I $G(APPL)'["B",$G(APPL)'["A",+$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q
-        S APPL=$S($G(APPL)["B":"F",$G(APPL)["A":"F",$G(DISPENSE)]"":$$ORTYP(ROUTE,DISPENSE),1:$$TRYAGAIN(ROUTE,PSITEM))
-        S:APPL="" APPL="IP"
-        I APPL'="F" D
-        .I $G(SCHEDULE)]"" N X S X=SCHEDULE D  S SCHEDULE=X
-        ..I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>3)!($L($P(X,"@"))>70)!($L($P(X,"@",2))>119)!($L(X)<1)!(X["P RN")!(X["PR N") S X="" Q
-        ..I X?.E1L.E S X=$$ENLU^PSGMI(X)
-        ..S X=$$TRIM^XLFSTR(X,"R"," ")
-        ..I X["Q0" S X="" Q
-        .I APPL["U",$G(SCHEDULE)="" S PSREASON="Missing or invalid schedule" D ERROR Q
-        .N DFN S DFN=PSJHLDFN D IN5^VADPT I 'VAIP(5) D:APPT=""  I APPL="UN",APPT="" S PSREASON="Cannot place Unit Dose orders for an Outpatient" D ERROR Q
-        .. I APPL="UP" S APPL="IN" Q
-        .. I APPL="IP" S APPL="IN" Q
-        .I $G(ROC)'="R",$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q
-        I APPL="F" D
-        .I '$O(^TMP("PSJNVO",$J,"SOL",0))&('$O(^TMP("PSJNVO",$J,"AD",0))) S PSREASON="IV Fluid orders must have at least one additive or solution" D ERROR Q
-        .I $G(IVCAT)="I",$G(INFRT)="" Q  ;Allow intermittent IV orders to have a null infusion rate.
-        .I $G(INFRT)="" S PSREASON="Invalid Infusion Rate" D ERROR Q
-        Q
-        ;
-ERROR   ;Sends error msg to CPRS, logs error in OE/RR Errors file
-        S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(PSREASON,.PSJMSG)
-        D EN1^PSJHLERR(PSJHLDFN,$S(PSOC="XO":"UX",1:"OC"),$P(ORDER,U),PSREASON) S QFLG=1 K ^TMP("PSJNVO",$J)
-        Q
-        ;
-NVO     ; put new orders in non-verified orders file
-        I '$D(ROUTE) S ROUTE=""
-        I $G(ROUTE)="" S:APPL="F" ROUTE=$O(^PS(51.2,"B","INTRAVENOUS",0))
-        N DA,DR,DIE D ENGNN^PSGOETO S DIE="^PS(53.1,"
-        S DR="1////"_PROVIDER_";3////"_$$ESC^ORHLESC(ROUTE)_";4////"_$E(APPL)_";28////P"_";108////"_PSITEM_";27.1////"_LOGIN_";27////"_LOGIN_";.5////"_PSJHLDFN_";.24////"_PRIORITY_";125////"_$G(PRNTON)
-        I $G(LOC)]"" S:$P($G(^SC(+LOC,0)),U,3)="C" DR=DR_";113////"_LOC_";126////"_$G(APPT)
-        I $G(IVCAT)]"" S DR=DR_";128////"_IVCAT S ADMINS=""
-        S:$G(SCHTYP)]"" DR=DR_";7////"_SCHTYP
-        D ^DIE K PSJHLSKP S NEWORDER=DA,PSJORDER=DA_"P"
-        S $P(^PS(55,PSJHLDFN,5.1),"^",2)=PROVIDER
-        S:$G(ORDER)]"" $P(^PS(53.1,DA,0),"^",21)=$P(ORDER,"^")
-        S:$G(APPL)["P" $P(^PS(53.1,DA,0),"^",13)=1
-        S $P(^PS(53.1,DA,0),"^",18)=DA
-        S:$G(ROC)]"" $P(^PS(53.1,DA,0),"^",24)=ROC
-        S:$G(PREON)]"" $P(^PS(53.1,DA,0),"^",25)=PREON
-        S:$G(ADMINS) $P(^PS(53.1,DA,2),"^",5)=ADMINS
-        S:$G(REQST)]"" $P(^PS(53.1,DA,2.5),"^")=REQST
-        ; Transform duration units of doses to a for administrations
-        S:$E(DURATION,1,5)="doses" DURATION=$TR(DURATION,"doses","a")
-        S:$G(DURATION)]"" $P(^PS(53.1,DA,2.5),"^",2)=DURATION
-        S:$G(IVLIMIT)]"" $P(^PS(53.1,DA,2.5),"^",4)=IVLIMIT
-        I $G(REQST)]"",$G(DURATION)]"" S $P(^PS(53.1,DA,2.5),"^",3)=$$STOP(REQST,DURATION)
-        S:$G(INSTR)]"" $P(^PS(53.1,DA,.3),"^")=INSTR
-        I $G(INFRT)]"" D
-        .I INFRT S:(INFRT["Minutes"!(INFRT["Hours")) INFRT="INFUSE OVER "_INFRT
-        .S ^PS(53.1,DA,8)=IVTYP_"^^^^"_INFRT
-        S:$G(FREQ)]"" $P(^PS(53.1,DA,2),"^",6)=FREQ
-        S:$G(SCHTYP)]"" $P(^PS(53.1,DA,0),"^",7)=SCHTYP
-        I $G(APPL)'="I" I $G(INSTR)]"" N X S X=INSTR D STRIP I $S(X?.E1C.E:0,$L(X)>60:0,X="":0,X["^":0,X?1.P:1,1:1) S $P(^PS(53.1,DA,.2),"^",2)=X,$P(^PS(53.1,DA,.2),"^",5,6)=$G(DOSE)_"^"_$$UNESC^ORHLESC($G(UNIT))
-        S $P(^PS(53.1,DA,.2),"^",3)=ORDCON
-        I $G(SCHEDULE)]"" S $P(^PS(53.1,DA,2),"^")=$$UNESC^ORHLESC(SCHEDULE)
-        I $G(APPL)="I" I $G(UNITS)]"" S $P(^PS(53.1,DA,.3),"^")=$$UNESC^ORHLESC(UNITS)
-        S ^PS(53.1,DA,4)="^^^^^^"_CLERK
-        I $G(DISPENSE) S ^PS(53.1,DA,1,0)="^53.11P^1^1",^PS(53.1,DA,1,1,0)=DISPENSE_"^"_$$UNESC^ORHLESC(UNITS),^PS(53.1,DA,1,"B",$E(DISPENSE,1,30),1)=""
-        I $D(PROCOM) D
-        .I '$D(^PS(53.1,DA,12,0)) S ^(0)="^53.1012^0^0"
-        .S JJ=0 F  S JJ=$O(PROCOM(JJ)) Q:'JJ  S $P(^PS(53.1,DA,12,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,12,JJ,0)=$$UNESC^ORHLESC(PROCOM(JJ))
-        I $D(ADMINSTR) D
-        .I '$D(^PS(53.1,DA,3,0)) S ^(0)="^53.12^0^0"
-        .S JJ=0 F  S JJ=$O(ADMINSTR(JJ)) Q:'JJ  S $P(^PS(53.1,DA,3,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,3,JJ,0)=ADMINSTR(JJ)
-        I $D(^TMP("PSJNVO",$J,"AD")) D
-        .S ^PS(53.1,DA,"AD",0)="^53.157PA^0^0"
-        .S JJ=0 F  S JJ=$O(^TMP("PSJNVO",$J,"AD",JJ)) Q:'JJ  S $P(^PS(53.1,DA,"AD",0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,"AD",JJ,0)=^TMP("PSJNVO",$J,"AD",JJ,0),^PS(53.1,DA,"AD","B",$$UNESC^ORHLESC($P(^TMP("PSJNVO",$J,"AD",JJ,0),"^")),JJ)=""
-        I $D(^TMP("PSJNVO",$J,"SOL")) D
-        .S ^PS(53.1,DA,"SOL",0)="^53.158PA^0^0"
-        .S JJ=0 F  S JJ=$O(^TMP("PSJNVO",$J,"SOL",JJ)) Q:'JJ  S $P(^PS(53.1,DA,"SOL",0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,"SOL",JJ,0)=^TMP("PSJNVO",$J,"SOL",JJ,0),^PS(53.1,DA,"SOL","B",$P(^TMP("PSJNVO",$J,"SOL",JJ,0),"^"),JJ)=""
-        I $O(^TMP("PSJNVO",$J,10,0)) D
-        .S ^PS(53.1,DA,10,0)="^53.1112A^0^0"
-        .S JJ=0 F  S JJ=$O(^TMP("PSJNVO",$J,10,JJ)) Q:'JJ  S $P(^PS(53.1,DA,10,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,10,JJ,0)=$$UNESC^ORHLESC(^TMP("PSJNVO",$J,10,JJ,0)),^PS(53.1,DA,10,"B",$$UNESC^ORHLESC($E(^TMP("PSJNVO",$J,10,JJ,0),1,30)),JJ)="" D
-        ..S ^PS(53.1,DA,10,JJ,1)=$P($G(^VA(200,+CLERK,0)),"^")
-        ..I $O(^TMP("PSJNVO",$J,10,JJ,2,0)) S ^PS(53.1,DA,10,JJ,2,0)="^53.11122^0^0" D
-        ...S QQ=0 F  S QQ=$O(^TMP("PSJNVO",$J,10,JJ,2,QQ)) Q:'QQ  S $P(^PS(53.1,DA,10,JJ,2,0),"^",3,4)=QQ_"^"_QQ,^PS(53.1,DA,10,JJ,2,QQ,0)=$$UNESC^ORHLESC(^TMP("PSJNVO",$J,10,JJ,2,QQ,0))
-        Q
-STRIP   ;Strips spaces off the end of instructions.
-        I $E(X,$L(X))=" " F  S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" "
-        Q
-        ;
-ORTYP(MDRT,DDRG)               ;Entry point to determine order type for 53.1
-        ;MDRT=Med Route from 51.2, DDRG=Dispense Drug
-        I '$G(DDRG) S ORTYP="" Q ORTYP
-        I '$D(^PSDRUG(+DDRG,2)) S ORTYP="" Q ORTYP
-        I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PSDRUG(DDRG,2),"^",3)'["U" S ORTYP="" Q ORTYP
-        I '$G(MDRT) S ORTYP="" Q ORTYP
-        I '$D(^PS(51.2,+MDRT,0)) S ORTYP="" Q ORTYP
-        I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PSDRUG(DDRG,2),"^",3)'["U",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="IN" Q ORTYP
-        I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="UP" Q ORTYP
-        I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="IP" Q ORTYP
-        I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PSDRUG(DDRG,2),"^",3)'["U",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="IP" Q ORTYP
-        I $P(^PSDRUG(DDRG,2),"^",3)["U",$P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="UN" Q ORTYP
-        I $P(^PSDRUG(DDRG,2),"^",3)["U",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="UP" Q ORTYP
-        S ORTYP="" Q ORTYP
-        ;
-TRYAGAIN(MDRT,OI)             ;
-        ;MDRT=Med Route from 51.2, OI=Orderable Item
-        N ORTYPI,ORTYPU,ORTYPP
-        S ORTYP="",ORTYPI=0,ORTYPU=0,ORTYPP=0
-        N DDRG S DDRG=0 F  S DDRG=$O(^PSDRUG("ASP",OI,DDRG)) Q:'DDRG  D 
-        .I $G(^PSDRUG(DDRG,"I"))]"" Q:^PSDRUG(DDRG,"I")'>DT
-        .S ORTYP=$$ORTYP(MDRT,DDRG)  D
-        ..I ORTYP["I" S ORTYPI=ORTYPI+1
-        ..I ORTYP["U" S ORTYPU=ORTYPU+1
-        ..I ORTYP["P" S ORTYPP=ORTYPP+1
-        S ORTYP=$S(ORTYPU>ORTYPI:"U",1:"I") S ORTYP=ORTYP_$S(ORTYPP>0:"P",1:"N")
-        Q ORTYP
-        ;
-STOP(REQST,DURA)          ;
-        ;REQST=Requested start date, DURA=Duration from CPRS
-        I DURA["L",DURA?1A1".".N S DAYS=$$DAY($E(REQST,1,5)),DURA="H"_((DAYS*$P(DURA,"L",2))*24)
-        I DURA["L",DURA?1A.1N.N1"."1N.N D  Q STOP
-        .S NUM=$E(REQST,4,5)+$P($P(DURA,"."),"L",2),NUM=$S(NUM<10:"0"_NUM,NUM<13:NUM,1:$S((NUM-12)<10:"0"_(NUM-12),1:(NUM-12))),DATE=$E(REQST,1,3)_NUM
-        .S DAYS=$$DAY(DATE),STOP=$$SCH^XLFDT($P($P(DURA,"."),"L",2)_"M",$P(REQST,"."))_"."_$P(REQST,".",2),DEL=$P($P(DURA,"L",2),"."),STOP=$$FMADD^XLFDT(STOP,"",((DAYS*$P(DURA,DEL,2))*24))
-        I DURA["L" S STOP=$P($$SCH^XLFDT($P(DURA,"L",2)_"M",$P(REQST,".")),".")_"."_$P(REQST,".",2) Q STOP
-        I DURA["W",DURA["." S DURA="H"_(($P(DURA,"W",2)*7)*24)
-        I DURA["D",DURA["." S DURA="H"_($P(DURA,"D",2)*24)
-        I +DURA=DURA,DURA["." S DURA="H"_(DURA*24)
-        S STOP=$$FMADD^XLFDT(REQST,$S(DURA["W":$P(DURA,"W",2)*7,DURA["D":$P(DURA,"D",2),+DURA=DURA:+DURA,1:""),$S(DURA["H":$P(DURA,"H",2),1:""),$S(DURA["M":$P(DURA,"M",2),1:""),$S(DURA["S":$P(DURA,"S",2),1:""))
-        Q STOP
-ZQDATE(DATE,MONTHS)      ;BUMP DATE BY A MONTH (OR SO)
-        ;;
-        S X=$E($P(DATE,"."),1,5)+($E($P(DATE,"."),4,5)>(12-MONTHS)*88+MONTHS)_$E($P(DATE,"."),6,7) F  D ^%DT Q:Y>0  S X=X-1
-        S NEWDATE=X_"."_$P(DATE,".",2)
-        Q NEWDATE
-DAY(DATE)       ;DATE=FIRST FIVE DIGITS OF FM DATE
-        N X
-        I DATE'?5N Q -1
-        S X=$E(DATE,4,5) I X<1!(X>12) Q -1
-        S X=DATE+1+(X=12*88)_"01"
-        Q $E($$FMADD^XLFDT(X,-1),6,7)
+PSJHL9 ;BIR/LDT-VALIDATE INCOMING HL7 DATA/CREATE NEW ORDER ;08 Jul 99 / 10:50 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**1,18,31,42,47,50,63,72,75,58,80,110,111**;16 DEC 97
+ ;
+ ; Reference to ^PSDRUG is supported by DBIA# 2192.
+ ; Reference to ^PS(50.7 is supported by DBIA# 2180.
+ ; Reference to ^PS(51.2 is supported by DBIA# 2178.
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^ORERR is supported by DBIA# 2187.
+ ;
+VALID ;
+ I APPL="",PSITEM="" S PSREASON="Missing or invalid Orderable Item" D ERROR Q
+ I PSITEM]"",'$D(^PS(50.7,+PSITEM,0)) S PSREASON="Missing or invalid Orderable Item" D ERROR Q
+ I $G(APPL)'["B",$G(APPL)'["A",+$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q
+ S APPL=$S($G(APPL)["B":"F",$G(APPL)["A":"F",$G(DISPENSE)]"":$$ORTYP(ROUTE,DISPENSE),1:$$TRYAGAIN(ROUTE,PSITEM))
+ S:APPL="" APPL="IP"
+ I APPL'="F" D
+ .I $G(SCHEDULE)]"" N X S X=SCHEDULE D  S SCHEDULE=X
+ ..I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>3)!($L(X)>70)!($L(X)<1)!(X["P RN")!(X["PR N") S X="" Q
+ ..I X?.E1L.E S X=$$ENLU^PSGMI(X)
+ ..S X=$$TRIM^XLFSTR(X,"R"," ")
+ ..I X["Q0" S X="" Q
+ .I APPL["U",$G(SCHEDULE)="" S PSREASON="Missing or invalid schedule" D ERROR Q
+ .N DFN S DFN=PSJHLDFN D IN5^VADPT I 'VAIP(5) D:APPT=""  I APPL="UN",APPT="" S PSREASON="Cannot place Unit Dose orders for an Outpatient" D ERROR Q
+ .. I APPL="UP" S APPL="IN" Q
+ .. I APPL="IP" S APPL="IN" Q
+ .I $G(ROC)'="R",$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q
+ I APPL="F" D
+ .I '$O(^TMP("PSJNVO",$J,"SOL",0))&('$O(^TMP("PSJNVO",$J,"AD",0))) S PSREASON="IV Fluid orders must have at least one additive or solution" D ERROR Q
+ .I $G(INFRT)="" S PSREASON="Invalid Infusion Rate" D ERROR Q
+ Q
+ ;
+ERROR ;Sends error msg to CPRS, logs error in OE/RR Errors file
+ S X="ORERR" X ^%ZOSF("TEST") I  D EN^ORERR(PSREASON,.PSJMSG)
+ D EN1^PSJHLERR(PSJHLDFN,$S(PSOC="XO":"UX",1:"OC"),$P(ORDER,U),PSREASON) S QFLG=1 K ^TMP("PSJNVO",$J)
+ Q
+ ;
+NVO ; put new orders in non-verified orders file
+ I '$D(ROUTE) S ROUTE=""
+ S:APPL="F" ROUTE=$O(^PS(51.2,"B","INTRAVENOUS",0))
+ N DA,DR,DIE D ENGNN^PSGOETO S DIE="^PS(53.1,"
+ S DR="1////"_PROVIDER_";3////"_ROUTE_";4////"_$E(APPL)_";28////P"_";108////"_PSITEM_";27.1////"_LOGIN_";27////"_LOGIN_";.5////"_PSJHLDFN_";.24////"_PRIORITY_";125////"_$G(PRNTON)
+ I $G(LOC)]"" S:$P($G(^SC(+LOC,0)),U,3)="C" DR=DR_";113////"_LOC_";126////"_$G(APPT)
+ D ^DIE K PSJHLSKP S NEWORDER=DA,PSJORDER=DA_"P"
+ S $P(^PS(55,PSJHLDFN,5.1),"^",2)=PROVIDER
+ S:$G(ORDER)]"" $P(^PS(53.1,DA,0),"^",21)=$P(ORDER,"^")
+ S:$G(APPL)["P" $P(^PS(53.1,DA,0),"^",13)=1
+ S $P(^PS(53.1,DA,0),"^",18)=DA
+ S:$G(ROC)]"" $P(^PS(53.1,DA,0),"^",24)=ROC
+ S:$G(PREON)]"" $P(^PS(53.1,DA,0),"^",25)=PREON
+ S:$G(REQST)]"" $P(^PS(53.1,DA,2.5),"^")=REQST
+ S:$G(DURATION)]"" $P(^PS(53.1,DA,2.5),"^",2)=DURATION
+ S:$G(IVLIMIT)]"" $P(^PS(53.1,DA,2.5),"^",4)=IVLIMIT
+ I $G(REQST)]"",$G(DURATION)]"" S $P(^PS(53.1,DA,2.5),"^",3)=$$STOP(REQST,DURATION)
+ S:$G(INSTR)]"" $P(^PS(53.1,DA,.3),"^")=INSTR
+ S:$G(INFRT)]"" ^PS(53.1,DA,8)=IVTYP_"^^^^"_INFRT
+ S:$G(FREQ)]"" $P(^PS(53.1,DA,2),"^",6)=FREQ
+ S:$G(SCHTYP)]"" $P(^PS(53.1,DA,0),"^",7)=SCHTYP
+ I $G(APPL)'="I" I $G(INSTR)]"" N X S X=INSTR D STRIP I $S(X?.E1C.E:0,$L(X)>60:0,X="":0,X["^":0,X?1.P:1,1:1) S $P(^PS(53.1,DA,.2),"^",2)=X,$P(^PS(53.1,DA,.2),"^",5,6)=$G(DOSE)_"^"_$G(UNIT)
+ S $P(^PS(53.1,DA,.2),"^",3)=ORDCON
+ I $G(SCHEDULE)]"" S ^PS(53.1,DA,2)=SCHEDULE
+ I $G(APPL)="I" I $G(UNITS)]"" S $P(^PS(53.1,DA,.3),"^")=UNITS
+ S ^PS(53.1,DA,4)="^^^^^^"_CLERK
+ I $G(DISPENSE) S ^PS(53.1,DA,1,0)="^53.11P^1^1",^PS(53.1,DA,1,1,0)=DISPENSE_"^"_UNITS,^PS(53.1,DA,1,"B",$E(DISPENSE,1,30),1)=""
+ I $D(PROCOM) D
+ .I '$D(^PS(53.1,DA,12,0)) S ^(0)="^53.1012^0^0"
+ .S JJ=0 F  S JJ=$O(PROCOM(JJ)) Q:'JJ  S $P(^PS(53.1,DA,12,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,12,JJ,0)=PROCOM(JJ)
+ I $D(ADMINSTR) D
+ .I '$D(^PS(53.1,DA,3,0)) S ^(0)="^53.12^0^0"
+ .S JJ=0 F  S JJ=$O(ADMINSTR(JJ)) Q:'JJ  S $P(^PS(53.1,DA,3,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,3,JJ,0)=ADMINSTR(JJ)
+ I $D(^TMP("PSJNVO",$J,"AD")) D
+ .S ^PS(53.1,DA,"AD",0)="^53.157PA^0^0"
+ .S JJ=0 F  S JJ=$O(^TMP("PSJNVO",$J,"AD",JJ)) Q:'JJ  S $P(^PS(53.1,DA,"AD",0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,"AD",JJ,0)=^TMP("PSJNVO",$J,"AD",JJ,0),^PS(53.1,DA,"AD","B",$P(^TMP("PSJNVO",$J,"AD",JJ,0),"^"),JJ)=""
+ I $D(^TMP("PSJNVO",$J,"SOL")) D
+ .S ^PS(53.1,DA,"SOL",0)="^53.158PA^0^0"
+ .S JJ=0 F  S JJ=$O(^TMP("PSJNVO",$J,"SOL",JJ)) Q:'JJ  S $P(^PS(53.1,DA,"SOL",0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,"SOL",JJ,0)=^TMP("PSJNVO",$J,"SOL",JJ,0),^PS(53.1,DA,"SOL","B",$P(^TMP("PSJNVO",$J,"SOL",JJ,0),"^"),JJ)=""
+ I $O(^TMP("PSJNVO",$J,10,0)) D
+ .S ^PS(53.1,DA,10,0)="^53.1112A^0^0"
+ .S JJ=0 F  S JJ=$O(^TMP("PSJNVO",$J,10,JJ)) Q:'JJ  S $P(^PS(53.1,DA,10,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,10,JJ,0)=^TMP("PSJNVO",$J,10,JJ,0),^PS(53.1,DA,10,"B",$E(^TMP("PSJNVO",$J,10,JJ,0),1,30),JJ)="" D
+ ..S ^PS(53.1,DA,10,JJ,1)=$P($G(^VA(200,+CLERK,0)),"^")
+ ..I $O(^TMP("PSJNVO",$J,10,JJ,2,0)) S ^PS(53.1,DA,10,JJ,2,0)="^53.11122^0^0" D
+ ...S QQ=0 F  S QQ=$O(^TMP("PSJNVO",$J,10,JJ,2,QQ)) Q:'QQ  S $P(^PS(53.1,DA,10,JJ,2,0),"^",3,4)=QQ_"^"_QQ,^PS(53.1,DA,10,JJ,2,QQ,0)=^TMP("PSJNVO",$J,10,JJ,2,QQ,0)
+ Q
+STRIP ;Strips spaces off the end of instructions.
+ I $E(X,$L(X))=" " F  S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" "
+ Q
+ ;
+ORTYP(MDRT,DDRG)        ;Entry point to determine order type for 53.1
+ ;MDRT=Med Route from 51.2, DDRG=Dispense Drug
+ I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PSDRUG(DDRG,2),"^",3)'["U" S ORTYP="" Q ORTYP
+ I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PSDRUG(DDRG,2),"^",3)'["U",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="IN" Q ORTYP
+ I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="UP" Q ORTYP
+ I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="IP" Q ORTYP
+ I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PSDRUG(DDRG,2),"^",3)'["U",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="IP" Q ORTYP
+ I $P(^PSDRUG(DDRG,2),"^",3)["U",$P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="UN" Q ORTYP
+ I $P(^PSDRUG(DDRG,2),"^",3)["U",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="UP" Q ORTYP
+ S ORTYP="" Q ORTYP
+ ;
+TRYAGAIN(MDRT,OI)       ;
+ ;MDRT=Med Route from 51.2, OI=Orderable Item
+ N ORTYPI,ORTYPU,ORTYPP
+ S ORTYP="",ORTYPI=0,ORTYPU=0,ORTYPP=0
+ N DDRG S DDRG=0 F  S DDRG=$O(^PSDRUG("ASP",OI,DDRG)) Q:'DDRG  D 
+ .I $G(^PSDRUG(DDRG,"I"))]"" Q:^PSDRUG(DDRG,"I")'>DT
+ .S ORTYP=$$ORTYP(MDRT,DDRG)  D
+ ..I ORTYP["I" S ORTYPI=ORTYPI+1
+ ..I ORTYP["U" S ORTYPU=ORTYPU+1
+ ..I ORTYP["P" S ORTYPP=ORTYPP+1
+ S ORTYP=$S(ORTYPU>ORTYPI:"U",1:"I") S ORTYP=ORTYP_$S(ORTYPP>0:"P",1:"N")
+ Q ORTYP
+ ;
+STOP(REQST,DURA)   ;
+ ;REQST=Requested start date, DURA=Duration from CPRS
+ I DURA["L",DURA?1A1".".N S DAYS=$$DAY($E(REQST,1,5)),DURA="H"_((DAYS*$P(DURA,"L",2))*24)
+ I DURA["L",DURA?1A.1N.N1"."1N.N D  Q STOP
+ .S NUM=$E(REQST,4,5)+$P($P(DURA,"."),"L",2),NUM=$S(NUM<10:"0"_NUM,NUM<13:NUM,1:$S((NUM-12)<10:"0"_(NUM-12),1:(NUM-12))),DATE=$E(REQST,1,3)_NUM
+ .S DAYS=$$DAY(DATE),STOP=$$SCH^XLFDT($P($P(DURA,"."),"L",2)_"M",$P(REQST,"."))_"."_$P(REQST,".",2),DEL=$P($P(DURA,"L",2),"."),STOP=$$FMADD^XLFDT(STOP,"",((DAYS*$P(DURA,DEL,2))*24))
+ I DURA["L" S STOP=$P($$SCH^XLFDT($P(DURA,"L",2)_"M",$P(REQST,".")),".")_"."_$P(REQST,".",2) Q STOP
+ I DURA["W",DURA["." S DURA="H"_(($P(DURA,"W",2)*7)*24)
+ I DURA["D",DURA["." S DURA="H"_($P(DURA,"D",2)*24)
+ I +DURA=DURA,DURA["." S DURA="H"_(DURA*24)
+ S STOP=$$FMADD^XLFDT(REQST,$S(DURA["W":$P(DURA,"W",2)*7,DURA["D":$P(DURA,"D",2),+DURA=DURA:+DURA,1:""),$S(DURA["H":$P(DURA,"H",2),1:""),$S(DURA["M":$P(DURA,"M",2),1:""),$S(DURA["S":$P(DURA,"S",2),1:""))
+ Q STOP
+ZQDATE(DATE,MONTHS)  ;BUMP DATE BY A MONTH (OR SO)
+ ;;
+ S X=$E($P(DATE,"."),1,5)+($E($P(DATE,"."),4,5)>(12-MONTHS)*88+MONTHS)_$E($P(DATE,"."),6,7) F  D ^%DT Q:Y>0  S X=X-1
+ S NEWDATE=X_"."_$P(DATE,".",2)
+ Q NEWDATE
+DAY(DATE) ;DATE=FIRST FIVE DIGITS OF FM DATE
+ N X
+ I DATE'?5N Q -1
+ S X=$E(DATE,4,5) I X<1!(X>12) Q -1
+ S X=DATE+1+(X=12*88)_"01"
+ Q $E($$FMADD^XLFDT(X,-1),6,7)

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHLU.m

@@ -1 @@
-PSJHLU  ;BIR/RLW-UTILITIES USED IN BUILDING HL7 SEGMENTS ;20 Apr 98 / 9:58 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**1,56,72,102,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(52.6 is supported by DBIA# 1231.
-        ; Reference to ^PS(52.7 is supported by DBIA# 2173.
-        ; Reference to ^VA(200 is supported by DBIA 10060.
-        ; Reference to ^PS(55 is supported by DBIA# 2191.
-        ;
-INIT    ; set up HL7 application variables
-        S PSJHLSDT="PS",PSJHINST=$P($$SITE^VASITE(),"^")
-        S PSJCLEAR="K FIELD F J=0:1:LIMIT S FIELD(J)="""""
-        Q
-        ;
-SEGMENT(LIMIT)  ;
-        K SEGMENT
-        N SUBSEG,SEGLENGT S SUBSEG=0,SEGMENT="" F J=0:1:LIMIT D
-        .I SEGMENT']"" S SEGMENT=FIELD(J) Q
-        .S SEGMENT=SEGMENT_"|"_FIELD(J)
-        F  S SEGLENGT=$L(SEGMENT) D  Q:$L(SEGMENT)'>246
-        .I SEGLENGT'>246 S SEGMENT(SUBSEG)=SEGMENT
-        .I SEGLENGT>245 S SEGMENT(SUBSEG)=$E(SEGMENT,1,245),SUBSEG=SUBSEG+1 D
-        ..S SEGMENT=$E(SEGMENT,246,SEGLENGT),SEGMENT(SUBSEG)=$E(SEGMENT,1,245)
-SET     S PSJI=PSJI+1,^TMP("PSJHLS",$J,PSJHLSDT,PSJI)=SEGMENT(0)
-        F J=1:1 Q:'$D(SEGMENT(J))  S ^TMP("PSJHLS",$J,PSJHLSDT,PSJI,J)=SEGMENT(J)
-        Q
-        ;
-SEGMENT2        ; Retrieve text fields
-        K SEGMENT S JJ=0 F  S JJ=$O(@(PSJORDER_"12,"_JJ_")")) Q:'JJ  S SEGMENT(JJ-1)=$G(@(PSJORDER_"12,"_JJ_",0)"))
-        I $D(SEGMENT(0)) S SEGMENT(0)="NTE|6|L|"_$S($G(PSJBCBU):SEGMENT(0),1:$$ESC^ORHLESC(SEGMENT(0))) D
-        .D SET^PSJHLU K SEGMENT,JJ
-        I $P($G(@(PSJORDER_"6)")),"^")]"" K SEGMENT S SEGMENT(0)="NTE|21|L|"_$S($G(PSJBCBU):$P($G(@(PSJORDER_"6)")),"^"),1:$$ESC^ORHLESC($P($G(@(PSJORDER_"6)")),"^"))) D
-        .D SET^PSJHLU K SEGMENT
-        I PSJORDER["P",$P($G(@(PSJORDER_"9)")),"^",2)]"" K SEGMENT S SEGMENT(0)="NTE|21|L|"_$S($G(PSJBCBU):$P($G(@(PSJORDER_"9)")),"^",2),1:$$ESC^ORHLESC($P($G(@(PSJORDER_"9)")),"^",2))) D
-        .D SET^PSJHLU K SEGMENT
-        Q
-        ;
-CALL(HLEVN)     ; call DHCP HL7 package -or- protocol, to pass Orders
-        ; HLEVN = number of segments in message
-        K CLERK,DDIEN,DDNUM,DOSEFORM,DOSEOR,FIELD,IVTYPE,LIMIT,NAME,NDNODE,NODE1,NODE2,PRODNAME,PROVIDER,PSGS0Y,PSJHINST,PSJHLSDT,PSJI,PSJORDER,PSOC,PSREASON,ROOMBED,SPDIEN,SEGMENT
-        I $G(PSJBCBU)=1 M PSJNAME=^TMP("PSJHLS",$J,"PS") Q
-        S PSJMSG="^TMP(""PSJHLS"",$J,""PS"")"
-        D MSG^XQOR("PS EVSEND OR",.PSJMSG)
-        Q
-        ;
-IVTYPE(PSJORDER)        ; check whether a back-door order is Inpatient IV or IV fluid
-        I RXORDER["V",$P($G(@(PSJORDER_"0)")),"^",4)'="A" Q "I"
-        I RXORDER["P" I $P($G(@(PSJORDER_"0)")),"^",4)'="F" S IVTYPE="" Q IVTYPE
-        N SUB,AD,SOL,IVTYPE,NODE1 S SUB=0,IVTYPE="F"
-        ;naked reference on line below refers to the full indirect reference of PSJORDER_ which is from ^PS(55,DFN,"IV",PSJORD
-        F TYPE="AD","SOL" S SUB=0 F  S SUB=$O(@(PSJORDER_""""_TYPE_""""_","_SUB_")")) Q:(SUB="")!(IVTYPE="I")  S NODE1=$G(^(SUB,0)) Q:NODE1=""  D  Q:IVTYPE="I"
-        .I TYPE="AD" D
-        ..I '$P($G(^PS(52.6,$P(NODE1,"^"),0)),"^",13) S IVTYPE="I"
-        .D:TYPE="SOL"
-        ..S:'$P($G(^PS(52.7,$P(NODE1,"^"),0)),"^",13) IVTYPE="I"
-        Q IVTYPE
-ENI     ;Calculate Frequency for IV orders
-        N INFUSE
-        I X?.E1L.E S INFUSE=$$ENLU^PSGMI(X) Q:(INFUSE="TITRATE")!(INFUSE="BOLUS")!($P(INFUSE," ")="INFUSE")!($P(INFUSE," ")="Infuse")
-        Q:(X="TITRATE")!(X="BOLUS")!($P(X," ")="INFUSE")!($P(X," ")="Infuse")
-        Q:$$INTRMT(X)
-        K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q
-        I X["=" D  Q   ; NOIS LOU-0501-42191
-        .N X2,X1 S X1=$P(X,"="),X2=$P(X,"=",2)
-        .I X1["ML/HR",(+X1=$P(X1,"ML/HR"))!(+X1=$P(X1," ML/HR")) D
-        ..S X1=$TR(X1,"ML/HR","ml/hr")
-        .I X2["ML/HR",(+X2=$P(X2,"ML/HR"))!(+X2=$P(X2," ML/HR")) D
-        ..S X2=$TR(X2,"ML/HR","ml/hr")
-        .I X1[" ml/hr",(+X1=$P(X1," ml/hr")) D
-        ..S X1=$P(X1," ml/hr")_$P(X1," ml/hr",2,9999)
-        .I X2[" ml/hr",(+X2=$P(X2," ml/hr")) D
-        ..S X2=$P(X2," ml/hr")_$P(X2," ml/hr",2,9999)
-        .I X1["ml/hr",(+X1=$P(X1,"ml/hr")) D
-        ..S X1=$P(X1,"ml/hr")_$P(X1,"ml/hr",2,9999)
-        .I X2["ml/hr",(+X2=$P(X2,"ml/hr")) D
-        ..S X2=$P(X2,"ml/hr")_$P(X2,"ml/hr",2,9999)
-        .I X2'=+X2 D
-        ..I ($P(X2,"@",2,999)'=+$P(X2,"@",2,999)!(+$P(X2,"@",2,999)<0)) K X Q
-        .I X1=+X1 S X1=X1_" ml/hr"
-        .I X2=+X2 S X2=X2_" ml/hr"
-        .S:$P(X2,"@")=+X2 $P(X2,"@")=$P(X2,"@")_" ml/hr"
-        .S X=X1_"="_X2
-        I X'=+X,($P($TR(X," ml/hr",""),"@",2,999)'=+$P($TR(X," ml/hr",""),"@",2,999)!(+$P(X,"@",2,999)<0)),($P(X," ml/hr")'=+$P(X," ml/hr")!(+$P(X," ml/hr")<0)) Q:(X>0&($E(X)=0))  K X Q
-        I X=+X!(X>0&($E(X)=0)) S X=X_" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q
-        I X[" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q
-        S SPSOL=$P(X,"@",2) S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr" S FREQ=$S('SPSOL:0,1:1440/SPSOL\1) K SPSOL
-        Q
-SPSOL   S SPSOL=+TVOLUME Q
-INTRMT(X)       ;
-        Q:'$P(X," ") 0
-        Q:$P(X," ",2)="Minutes" 1
-        Q:$P(X," ",2)="Hours" 1
-        Q 0
-IVCAT(DFN,PSJORD,PARRAY)        ; This returns the IV CATEGORY based on the IV TYPE and CHEMO TYPE (not what is already in the IV CATEGORY field)
-        ;  Passed in:  PSJORDER (file root of order)
-        N NODE,TYP,CHEMTYP,INTSYR,ND2P5
-        S (CHEMTYP,INTSYR)=""
-        S TYP=$G(P(4)),INTSYR=$G(P(5)),CHEMTYP=$G(P(23))
-        I TYP="",$G(PSJORD)["V" S NODE=$G(^PS(55,DFN,"IV",+PSJORD,0)) S TYP=$P(NODE,"^",4),INTSYR=$P(NODE,"^",5),CHEMTYP=$P(NODE,"^",23)
-        I TYP="",$G(PSJORD)["P" S NODE=$G(^PS(53.1,+PSJORD,8)) S TYP=$P(NODE,"^"),INTSYR=$P(NODE,"^",4),CHEMTYP=$P(NODE,"^",2)
-        I TYP="" S TYP=$G(PARRAY(4)),INTSYR=$G(PARRAY(5)),CHEMTYP=$G(PARRAY(23))
-        Q:$G(TYP)="" ""
-        S CAT=$S(",A,H,"[(","_TYP_","):"C",TYP="C"&(",A,H,S,"[(","_CHEMTYP_",")&'INTSYR):"C",TYP="C"&(CHEMTYP="P"):"I",TYP="S"&'INTSYR:"C",TYP="P":"I",$G(INTSYR):"I",1:"")
-        Q CAT
-ZRX     ; Perform outbound processing
-        S LIMIT=6 X PSJCLEAR
-        S FIELD(0)="ZRX"
-        I '$G(PSJREN) N PREON,PSJREN I $G(PSJORD)["U"&($P(NODE1,"^",24)="R") S PSJREN=1
-        I $G(PSJORD)["V"&($P(NODE2,"^",8)="R") S PSJREN=1
-        S PREON=$S($G(PSJREN):$G(PSJORD),PSJORDER["IV":$P(NODE2,"^",5),1:$P(NODE1,"^",25))
-        S FIELD(1)=$S(PREON["P":$P($G(^PS(53.1,+PREON,0)),"^",21),PREON["V":$P($G(^PS(55,PSJHLDFN,"IV",+PREON,0)),"^",21),1:$P($G(^PS(55,PSJHLDFN,5,+PREON,0)),"^",21))
-        S FIELD(2)=$S(PSJORDER["IV":$G(P("NAT")),1:$G(PSJNOO))
-        S FIELD(3)=$S($G(PSJREN):"R",PSJORDER["IV":$P(NODE2,"^",8),1:$P(NODE1,"^",24))
-        I FIELD(3)="" I PSOC="SN" S FIELD(3)="N"
-        I $D(P)>1 S FIELD(6)=$$IVCAT^PSJHLU(PSJHLDFN,RXORDER,.P)
-        S NAME=$P($G(^VA(200,DUZ,0)),"^")
-        S FIELD(5)=DUZ_"^"_$S($G(PSJBCBU):NAME,1:$$ESC^ORHLESC(NAME))_"^"_"99NP"
-        D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
-        Q
+PSJHLU ;BIR/RLW-UTILITIES USED IN BUILDING HL7 SEGMENTS ;20 Apr 98 / 9:58 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**1,56,72,102**;16 DEC 97
+ ;
+ ; Reference to ^PS(52.6 is supported by DBIA# 1231.
+ ; Reference to ^PS(52.7 is supported by DBIA# 2173.
+ ;
+INIT ; set up HL7 application variables
+ S PSJHLSDT="PS",PSJHINST=$P($$SITE^VASITE(),"^")
+ S PSJCLEAR="K FIELD F J=0:1:LIMIT S FIELD(J)="""""
+ Q
+ ;
+SEGMENT(LIMIT) ;
+ K SEGMENT
+ N SUBSEG,SEGLENGT S SUBSEG=0,SEGMENT="" F J=0:1:LIMIT D
+ .I SEGMENT']"" S SEGMENT=FIELD(J) Q
+ .S SEGMENT=SEGMENT_"|"_FIELD(J)
+ F  S SEGLENGT=$L(SEGMENT) D  Q:$L(SEGMENT)'>246
+ .I SEGLENGT'>246 S SEGMENT(SUBSEG)=SEGMENT
+ .I SEGLENGT>245 S SEGMENT(SUBSEG)=$E(SEGMENT,1,245),SUBSEG=SUBSEG+1 D
+ ..S SEGMENT=$E(SEGMENT,246,SEGLENGT),SEGMENT(SUBSEG)=$E(SEGMENT,1,245)
+SET S PSJI=PSJI+1,^TMP("PSJHLS",$J,PSJHLSDT,PSJI)=SEGMENT(0)
+ F J=1:1 Q:'$D(SEGMENT(J))  S ^TMP("PSJHLS",$J,PSJHLSDT,PSJI,J)=SEGMENT(J)
+ Q
+ ;
+CALL(HLEVN) ; call DHCP HL7 package -or- protocol, to pass Orders
+ ; HLEVN = number of segments in message
+ K CLERK,DDIEN,DDNUM,DOSEFORM,DOSEOR,FIELD,IVTYPE,LIMIT,NAME,NDNODE,NODE1,NODE2,PRODNAME,PROVIDER,PSGS0Y,PSJHINST,PSJHLSDT,PSJI,PSJORDER,PSOC,PSREASON,ROOMBED,SPDIEN,SEGMENT
+ I $G(PSJBCBU)=1 M PSJNAME=^TMP("PSJHLS",$J,"PS") Q
+ S PSJMSG="^TMP(""PSJHLS"",$J,""PS"")"
+ D MSG^XQOR("PS EVSEND OR",.PSJMSG)
+ Q
+ ;
+IVTYPE(PSJORDER) ; check whether a back-door order is Inpatient IV or IV fluid
+ I RXORDER["V",$P($G(@(PSJORDER_"0)")),"^",4)'="A" Q "I"
+ I RXORDER["P" I $P($G(@(PSJORDER_"0)")),"^",4)'="F" S IVTYPE="" Q IVTYPE
+ N SUB,AD,SOL,IVTYPE,NODE1 S SUB=0,IVTYPE="F"
+ ;naked reference on line below refers to the full indirect reference of PSJORDER_...
+ F TYPE="AD","SOL" S SUB=0 F  S SUB=$O(@(PSJORDER_""""_TYPE_""""_","_SUB_")")) Q:(SUB="")!(IVTYPE="I")  S NODE1=$G(^(SUB,0)) Q:NODE1=""  D  Q:IVTYPE="I"
+ .I TYPE="AD" D
+ ..I '$P($G(^PS(52.6,$P(NODE1,"^"),0)),"^",13) S IVTYPE="I"
+ .D:TYPE="SOL"
+ ..S:'$P($G(^PS(52.7,$P(NODE1,"^"),0)),"^",13) IVTYPE="I"
+ Q IVTYPE
+ENI ;Calculate Frequency for IV orders
+ N INFUSE
+ K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q
+ I X?.E1L.E S INFUSE=$$ENLU^PSGMI(X) Q:(INFUSE="TITRATE")!(INFUSE="BOLUS")
+ Q:(X="TITRATE")!(X="BOLUS")
+ I X["=" D  Q   ; NOIS LOU-0501-42191
+ .N X2,X1 S X1=$P(X,"="),X2=$P(X,"=",2)
+ .I X1["ML/HR",(+X1=$P(X1,"ML/HR"))!(+X1=$P(X1," ML/HR")) D
+ ..S X1=$TR(X1,"ML/HR","ml/hr")
+ .I X2["ML/HR",(+X2=$P(X2,"ML/HR"))!(+X2=$P(X2," ML/HR")) D
+ ..S X2=$TR(X2,"ML/HR","ml/hr")
+ .I X1[" ml/hr",(+X1=$P(X1," ml/hr")) D
+ ..S X1=$P(X1," ml/hr")_$P(X1," ml/hr",2,9999)
+ .I X2[" ml/hr",(+X2=$P(X2," ml/hr")) D
+ ..S X2=$P(X2," ml/hr")_$P(X2," ml/hr",2,9999)
+ .I X1["ml/hr",(+X1=$P(X1,"ml/hr")) D
+ ..S X1=$P(X1,"ml/hr")_$P(X1,"ml/hr",2,9999)
+ .I X2["ml/hr",(+X2=$P(X2,"ml/hr")) D
+ ..S X2=$P(X2,"ml/hr")_$P(X2,"ml/hr",2,9999)
+ .I X2'=+X2 D
+ ..I ($P(X2,"@",2,999)'=+$P(X2,"@",2,999)!(+$P(X2,"@",2,999)<0)) K X Q
+ .I X1=+X1 S X1=X1_" ml/hr"
+ .I X2=+X2 S X2=X2_" ml/hr"
+ .S:$P(X2,"@")=+X2 $P(X2,"@")=$P(X2,"@")_" ml/hr"
+ .S X=X1_"="_X2
+ I X'=+X,($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)),($P(X," ml/hr")'=+$P(X," ml/hr")!(+$P(X," ml/hr")<0)) K X Q
+ I X=+X S X=X_" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q
+ I X[" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q
+ S SPSOL=$P(X,"@",2) S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr" S FREQ=$S('SPSOL:0,1:1440/SPSOL\1) K SPSOL
+ Q
+SPSOL S SPSOL=+TVOLUME Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIACT.m

@@ -1 @@
-PSJLIACT        ;BIR/MV-IV ACTION ;28 Jul 98 / 8:50 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**15,47,62,58,82,97,80,110,111,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(55 is supported by DBIA 2191.
-        ; Reference to MAIN^TIUEDIT is supported by DBIA 2410.
-        ;
-DC      ; Discontinue order
-        D HOLDHDR^PSJOE
-        S PSJCOM=+$S(PSJORD["V":$P($G(^PS(55,DFN,"IV",+PSJORD,.2)),"^",8),1:$P($G(^PS(53.1,+PSJORD,.2)),"^",8))
-        I PSJCOM W !!,"This order is part of a complex order. If you discontinue this order the",!,"following orders will be discontinued too (unless the stop date has already",!,"been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSJORD)
-        I PSJCOM F  W !!,"Do you want to discontinue this order" S %=1 D YN^DICN Q:%  D ENCOM^PSGOEM
-        I PSJCOM,%'=1 S VALMBK="" Q
-        I PSJORD["V" D DC^PSIVORA,EN^PSJLIORD(DFN,ON) Q
-        D:PSJORD["P" DISCONT^PSIVORC
-        S VALMBCK="Q"
-        Q
-ACEDIT  ; Display LM screen and AC and EDit actions
-        D EN^PSJLIVMD
-        S VALMBCK=$S($G(PSIVACEP):"Q",1:"R")
-        Q
-AEEXIT  ; Call for EXIT CODE in PSJ LM IV AC/EDIT
-        D:ON["V" GT55^PSIVORFB
-        I ON["P" D GT531^PSIVORFA(DFN,ON) D:P("OT")'="I" GTDATA^PSJLIFN
-        D EN^PSJLIVMD
-        K PSIVENO
-        Q
-EDIT    ; Edit order
-        K PSIVFN1 NEW PSIVNBD
-        I $D(PSGACT),PSGACT'["E" W !,"This order may not be edited." D PAUSE^VALM1 Q
-        D EDIT1
-        Q:$D(PSIVNBD)!($G(PSIVCOPY)&'$G(PSIVENO))
-        D EN^PSJLIVMD
-        S VALMBCK=$S($G(PSIVFN1):"Q",1:"R")
-        Q
-EDIT1   ;
-        ;Ensure P() is defined
-        I $D(P)<10 S XQORQUIT=1,P("PON")="",PSIVNBD=1 D  Q
-        .W !,"WARNING: An error has occurred. Changes will not be saved"
-        .D PAUSE^VALM1
-        .S VALMBCK="Q"
-        I "ANP"'[P(17) W !,"You cannot edit an inactive order" D PAUSE^VALM1 Q
-        S:$G(ON55)="" ON55=$G(PSJORD)
-        D HOLDHDR^PSJOE
-        ;* Edit a new back door order
-        I ($G(ON55)["V"&($G(P("21FLG"))="")) D  Q
-        . D GSTRING^PSIVORE1,GTFLDS^PSIVORFE
-        . I $G(ON55)["V",'$G(DONE) D OK^PSIVORE
-        . S VALMBCK="Q",PSIVNBD=1
-        ;* Edit an active order
-        I $G(ON55)["V" NEW PSJEDIT1 D E^PSIVOPT1 D  Q
-        . I $G(PSJIVBD) K PSJIVBD D EN^PSJLIORD(DFN,ON)
-        I $G(ON55)["P" D EDIT^PSIVORC ;Edit incomplete order.
-        K P("OVRIDE")
-        Q
-ACCEPT  ; Accept order
-        D HOLDHDR^PSJOE
-        ;Accept IV from back door.
-        I $G(PSJIVBD) K PSJIVBD D OK^PSIVORE S VALMBCK="Q" Q
-        I ON["V" D ACCEPT^PSIVOPT1 Q
-        S PSIVFN1=1
-        D COMPLTE^PSIVORC1
-        S VALMBCK="Q"
-        Q
-R       ; Renewal
-        S PSJREN=1
-        D HOLDHDR^PSJOE
-        NEW PSIVAC S PSIVAC="PR" K PSGFDX
-        D R^PSIVOPT
-        D EN^PSJLIORD(DFN,ON)
-        K PSJREN
-        Q
-H       ; Hold
-        NEW TEX S TEX="Active order ***"
-        D HOLDHDR^PSJOE
-        D H^PSIVOPT(DFN,ON,P(17),P(3))
-        D:P(17)="A" PAUSE^VALM1
-        D EN^PSJLIORD(DFN,ON)
-        Q
-L       ; Activity Log
-        NEW PSIVLAB,PSIVLOG,PSJHIS S (PSIVLAB,PSIVLOG)=1
-        D EN^PSIVVW1
-        D EN^PSJLIVMD
-        S VALMBCK="R"
-        Q
-O       ; On Call
-        NEW TEX S TEX="Active order ***"
-        D HOLDHDR^PSJOE
-        D O^PSIVOPT(DFN,ON,P(17),P(3))
-        D:P(17)="A" PAUSE^VALM1
-        D EN^PSJLIORD(DFN,ON)
-        Q
-VF      ; Make the order active
-        NEW PSIVCHG S PSIVCHG=0
-        I ON["V" S ON55=ON D VF1("V","ORDER VERIFIED BY ",1) Q
-        D ACTIVE^PSIVORC2
-        Q
-VF1(PSIVREA,PSIVAL,PSIVLOG)     ;
-        ;Update 4 node and set activity log.
-        ;PSIVREA: the reason use by LOG^PSIVORAL
-        ;PSIVAL : the description reason
-        ;PSIVLOG: Log an activity if = 1
-        I '+$G(OD)!($L($G(OD))>16) K OD
-        D:+PSJSYSU=3 ^PSIVORE1
-        NEW DIE,DA,DR,PSJX,XX,PSIVACT,PSJRQND
-        S PSIVACT=1
-        S PSJX=$G(^PS(55,DFN,"IV",+ON55,4)),XX=""
-        I $P(PSJX,U)="" S XX=";143////0"
-        I $P(PSJX,U,4)="" S XX=XX_U_";142////0"
-        D NOW^%DTC
-        S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON55,DA(1)=DFN
-        I +PSJSYSU=3 S DR="140////"_DUZ_";141////"_$E(%,1,12)_";142////1"_$P(XX,U)
-        I +PSJSYSU=1 S DR="16////"_DUZ_";17////"_$E(%,1,12)_";143////1"_$P(XX,U,2)
-        I $G(P("PRY"))="D" S DR=DR_";.22////"_+P("IVRM")
-        D ^DIE
-        ; If pending IV renew is edited during finish, go back and DE the original active order left in RENEWED status
-        S PREREN=$S(ON55["V":$G(@(DIE_"+ON55,2)")),1:""),PREREN=$P(PREREN,"^",5) I PREREN D  K PREREN
-        . I PREREN["P" S PREREN=$G(@("^PS(53.1,+PREREN,0)")),PREREN=$P(PREREN,"^",25)
-        . I PREREN["V" N PRERENOD S PRERENOD=$G(@("^PS(55,DFN,""IV"",+PREREN,0)")) I $P(PRERENOD,"^",17)="R",($G(P("RES"))="E") D
-        ..  S DIE="^PS(55,"_DFN_",""IV"",",DA=+PREREN,DA(1)=DFN
-        ..  S DR="100////D;.03////"_PSGDT S ORIGSTOP=$P($G(@("^PS(55,DFN,""IV"",+PREREN,2)")),"^",3) I ORIGSTOP S DR=DR_";116////"_ORIGSTOP
-        ..  D ^DIE D EN1^PSJHL2(DFN,"SC",PREREN)
-        K DR,DIE,DA
-        I (+PSJSYSU=3)&($G(P("PRY"))="D") D
-        .N DIR W ! S DIR(0)="S^Y:Yes;N:No",DIR("A")="Do you want to enter a Progress Note",DIR("B")="No" D ^DIR
-        .Q:Y="N"
-        .D MAIN^TIUEDIT(3,.TIUDA,DFN,"","","","",1)
-        Q:'$G(PSIVLOG)
-        I $G(P("PACT"))]"",+$P(P("PACT"),U,2),+$P(P("PACT"),U,3) D
-        . NEW DIC,DA,X,Y,XX,DO D NAME^PSJBCMA1($P(P("PACT"),U,2),.XX)
-        . S DIC(0)="L",DA(1)=DFN,DA(2)=+ON55,X=1
-        . S DIC="^PS(55,"_DA(1)_",""IV"","_DA(2)_",""A"","
-        . S DIC("DR")=".02////F;.03////"_XX_";.04////"_$P($G(^PS(53.3,+$P(P("PACT"),U,3),0)),U)_";.05////"_$P(P("PACT"),U)_";.06////"_$P(P("PACT"),U,2)
-        . D FILE^DICN
-        NEW PSIVALCK
-        S PSIVREA="V",PSIVALT=""
-        S PSIVAL=PSIVAL_$S(+PSJSYSU=3:"PHARMACIST",1:"NURSE")
-        D LOG^PSIVORAL K PSIVAL,PSIVREA,PSIVLN
-        I $G(PSJORD)["P" S PSIVREA="V",PSIVALT="",PSGRDTX=$G(^PS(53.1,+PSJORD,2.5)) D
-        . I $G(PSGRDTX) S PSIVAL="Requested Start Date: "_$$ENDTC^PSGMI($$DATE2^PSJUTL2($P(PSGRDTX,U))) D LOG^PSIVORAL
-        . I $P(PSGRDTX,U,3) S PSIVREA="V",PSIVALT="" S PSIVAL="Requested Stop Date: "_$$ENDTC^PSGMI($$DATE2^PSJUTL2($P(PSGRDTX,U,3))) D LOG^PSIVORAL
-        N DUR I $G(PSJORD) S DUR=$$GETDUR^PSJLIVMD(DFN,+PSJORD,$S(PSJORD["P":"P",1:"IV"),1) I DUR]""  D
-        . K DR S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON55,DA(1)=DFN
-        . S DR=$S($G(IVLIMIT):"152////"_DUR,1:"151////"_DUR) K IVLIMIT
-        . D ^DIE
-        D EN1^PSJHL2(DFN,"SC",ON55)
-        D:+PSJSYSU=1 EN1^PSJHL2(DFN,"ZV",ON55)
-        D GT55^PSIVORFB S OLDON=$P($G(^PS(55,DFN,"IV",+ON55,2)),"^",5),P("OLDON")=OLDON
-        N PSJPRIO,PSJSCH,NODE0,NODEP2 S NODE0=$G(^PS(55,DFN,"IV",+ON55,0)),NODEP2=$G(^PS(55,DFN,"IV",+ON55,.2))
-        S PSJPRIO=$P(NODEP2,"^",4),PSJSCH=$P(NODE0,"^",9)
-        I (",S,A,")[(","_$G(PSJPRIO)_",")!($G(PSJSCH)="NOW")!($G(PSJSCH)["STAT") D NOTIFY^PSJHL4(ON55,DFN,$G(PSJPRIO),$G(PSJSCH))
-        Q
+PSJLIACT ;BIR/MV-IV ACTION ;28 Jul 98 / 8:50 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**15,47,62,58,82,97,80,110,111**;16 DEC 97
+ ;
+ ; Reference to ^PS(55 is supported by DBIA 2191.
+ ; Reference to MAIN^TIUEDIT is supported by DBIA 2410.
+ ;
+DC ; Discontinue order
+ D HOLDHDR^PSJOE
+ S PSJCOM=+$S(PSJORD["V":$P($G(^PS(55,DFN,"IV",+PSJORD,.2)),"^",8),1:$P($G(^PS(53.1,+PSJORD,.2)),"^",8))
+ I PSJCOM W !!,"This order is part of a complex order. If you discontinue this order the",!,"following orders will be discontinued too (unless the stop date has already",!,"been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSJORD)
+ I PSJCOM F  W !!,"Do you want to discontinue this order" S %=1 D YN^DICN Q:%  D ENCOM^PSGOEM
+ I PSJCOM,%'=1 S VALMBK="" Q
+ I PSJORD["V" D DC^PSIVORA,EN^PSJLIORD(DFN,ON) Q
+ D:PSJORD["P" DISCONT^PSIVORC
+ S VALMBCK="Q"
+ Q
+ACEDIT ; Display LM screen and AC and EDit actions
+ ;K PSIVFN1 ; if not set display the second screen when finish.
+ D EN^PSJLIVMD
+ S VALMBCK=$S($G(PSIVACEP):"Q",1:"R")
+ Q
+AEEXIT ; Call for EXIT CODE in PSJ LM IV AC/EDIT
+ D:ON["V" GT55^PSIVORFB
+ I ON["P" D GT531^PSIVORFA(DFN,ON) D:P("OT")'="I" GTDATA^PSJLIFN
+ D EN^PSJLIVMD
+ K PSIVENO
+ Q
+EDIT ; Edit order
+ K PSIVFN1 NEW PSIVNBD
+ I $D(PSGACT),PSGACT'["E" W !,"This order may not be edited." D PAUSE^VALM1 Q
+ D EDIT1
+ ;Q:$D(PSIVNBD)
+ Q:$D(PSIVNBD)!($G(PSIVCOPY)&'$G(PSIVENO))
+ D EN^PSJLIVMD
+ S VALMBCK=$S($G(PSIVFN1):"Q",1:"R")
+ Q
+EDIT1 ;
+ ;Ensure P() is defined
+ I $D(P)<10 S XQORQUIT=1,P("PON")="",PSIVNBD=1 D  Q
+ .W !,"WARNING: An error has occurred. Changes will not be saved"
+ .D PAUSE^VALM1
+ .S VALMBCK="Q"
+ I "ANP"'[P(17) W !,"You cannot edit an inactive order" D PAUSE^VALM1 Q
+ S:$G(ON55)="" ON55=$G(PSJORD)
+ D HOLDHDR^PSJOE
+ ;* Edit a new back door order
+ ;;I ($G(ON55)["V"&($G(P(21))="")) D  Q
+ I ($G(ON55)["V"&($G(P("21FLG"))="")) D  Q
+ . D GSTRING^PSIVORE1,GTFLDS^PSIVORFE
+ . I $G(ON55)["V",'$G(DONE) D OK^PSIVORE
+ . S VALMBCK="Q",PSIVNBD=1
+ ;* Edit an active order
+ I $G(ON55)["V" NEW PSJEDIT1 D E^PSIVOPT1 D  Q
+ . I $G(PSJIVBD) K PSJIVBD D EN^PSJLIORD(DFN,ON)
+ I $G(ON55)["P" D EDIT^PSIVORC ;Edit incomplete order.
+ Q
+ACCEPT ; Accept order
+ D HOLDHDR^PSJOE
+ ;Accept IV from back door.
+ I $G(PSJIVBD) K PSJIVBD D OK^PSIVORE S VALMBCK="Q" Q
+ I ON["V" D ACCEPT^PSIVOPT1 Q
+ S PSIVFN1=1
+ D COMPLTE^PSIVORC1
+ S VALMBCK="Q"
+ Q
+R ; Renewal
+ S PSJREN=1
+ D HOLDHDR^PSJOE
+ NEW PSIVAC S PSIVAC="PR" K PSGFDX
+ D R^PSIVOPT
+ D EN^PSJLIORD(DFN,ON)
+ K PSJREN
+ Q
+H ; Hold
+ NEW TEX S TEX="Active order ***"
+ D HOLDHDR^PSJOE
+ D H^PSIVOPT(DFN,ON,P(17),P(3))
+ D:P(17)="A" PAUSE^VALM1
+ D EN^PSJLIORD(DFN,ON)
+ Q
+L ; Activity Log
+ NEW PSIVLAB,PSIVLOG,PSJHIS S (PSIVLAB,PSIVLOG)=1
+ D EN^PSIVVW1
+ D EN^PSJLIVMD
+ S VALMBCK="R"
+ Q
+O ; On Call
+ NEW TEX S TEX="Active order ***"
+ D HOLDHDR^PSJOE
+ D O^PSIVOPT(DFN,ON,P(17),P(3))
+ D:P(17)="A" PAUSE^VALM1
+ D EN^PSJLIORD(DFN,ON)
+ Q
+VF ; Make the order active
+ NEW PSIVCHG S PSIVCHG=0
+ I ON["V" S ON55=ON D VF1("V","ORDER VERIFIED BY ",1) Q
+ D ACTIVE^PSIVORC2
+ Q
+VF1(PSIVREA,PSIVAL,PSIVLOG) ;
+ ;Update 4 node and set activity log.
+ ;PSIVREA: the reason use by LOG^PSIVORAL
+ ;PSIVAL : the description reason
+ ;PSIVLOG: Log an activity if = 1
+ I '+$G(OD)!($L($G(OD))>16) K OD
+ D:+PSJSYSU=3 ^PSIVORE1
+ NEW DIE,DA,DR,PSJX,XX,PSIVACT,PSJRQND
+ S PSIVACT=1
+ S PSJX=$G(^PS(55,DFN,"IV",+ON55,4)),XX=""
+ I $P(PSJX,U)="" S XX=";143////0"
+ I $P(PSJX,U,4)="" S XX=XX_U_";142////0"
+ D NOW^%DTC
+ S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON55,DA(1)=DFN
+ I +PSJSYSU=3 S DR="140////"_DUZ_";141////"_$E(%,1,12)_";142////1"_$P(XX,U)
+ I +PSJSYSU=1 S DR="16////"_DUZ_";17////"_$E(%,1,12)_";143////1"_$P(XX,U,2)
+ I $G(P("PRY"))="D" S DR=DR_";.22////"_+P("IVRM")
+ D ^DIE
+ ; If pending IV renew is edited during finish, go back and DE the original active order left in RENEWED status
+ S PREREN=$S(ON55["V":$G(@(DIE_"+ON55,2)")),1:""),PREREN=$P(PREREN,"^",5) I PREREN D  K PREREN
+ . I PREREN["P" S PREREN=$G(@("^PS(53.1,+PREREN,0)")),PREREN=$P(PREREN,"^",25)
+ . I PREREN["V" N PRERENOD S PRERENOD=$G(@("^PS(55,DFN,""IV"",+PREREN,0)")) I $P(PRERENOD,"^",17)="R",($G(P("RES"))="E") D
+ ..  S DIE="^PS(55,"_DFN_",""IV"",",DA=+PREREN,DA(1)=DFN
+ ..  S DR="100////D;.03////"_PSGDT S ORIGSTOP=$P($G(@("^PS(55,DFN,""IV"",+PREREN,2)")),"^",3) I ORIGSTOP S DR=DR_";116////"_ORIGSTOP
+ ..  D ^DIE D EN1^PSJHL2(DFN,"SC",PREREN)
+ K DR,DIE,DA
+ ;I ((+PSJSYSU=3)&($G(PSJPRI)="D"))!((+PSJSYSU=3)&($G(P("PRY"))="D")) D
+ I (+PSJSYSU=3)&($G(P("PRY"))="D") D
+ .N DIR W ! S DIR(0)="S^Y:Yes;N:No",DIR("A")="Do you want to enter a Progress Note",DIR("B")="No" D ^DIR
+ .Q:Y="N"
+ .D MAIN^TIUEDIT(3,.TIUDA,DFN,"","","","",1)
+ Q:'$G(PSIVLOG)
+ I $G(P("PACT"))]"",+$P(P("PACT"),U,2),+$P(P("PACT"),U,3) D
+ . NEW DIC,DA,X,Y,XX,DO D NAME^PSJBCMA1($P(P("PACT"),U,2),.XX)
+ . S DIC(0)="L",DA(1)=DFN,DA(2)=+ON55,X=1
+ . S DIC="^PS(55,"_DA(1)_",""IV"","_DA(2)_",""A"","
+ . S DIC("DR")=".02////F;.03////"_XX_";.04////"_$P($G(^PS(53.3,+$P(P("PACT"),U,3),0)),U)_";.05////"_$P(P("PACT"),U)_";.06////"_$P(P("PACT"),U,2)
+ . D FILE^DICN
+ NEW PSIVALCK
+ S PSIVREA="V",PSIVALT=""
+ S PSIVAL=PSIVAL_$S(+PSJSYSU=3:"PHARMACIST",1:"NURSE")
+ D LOG^PSIVORAL K PSIVAL,PSIVREA,PSIVLN
+ I $G(PSJORD)["P" S PSIVREA="V",PSIVALT="",PSGRDTX=$G(^PS(53.1,+PSJORD,2.5)) D
+ . I $G(PSGRDTX) S PSIVAL="Requested Start Date: "_$$ENDTC^PSGMI($$DATE2^PSJUTL2($P(PSGRDTX,U))) D LOG^PSIVORAL
+ . I $P(PSGRDTX,U,3) S PSIVREA="V",PSIVALT="" S PSIVAL="Requested Stop Date: "_$$ENDTC^PSGMI($$DATE2^PSJUTL2($P(PSGRDTX,U,3))) D LOG^PSIVORAL
+ N DUR I $G(PSJORD) S DUR=$$GETDUR^PSJLIVMD(DFN,+PSJORD,$S(PSJORD["P":"P",1:"IV"),1) I DUR]""  D
+ . K DR S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON55,DA(1)=DFN
+ . S DR=$S($G(IVLIMIT):"152////"_DUR,1:"151////"_DUR) K IVLIMIT
+ . D ^DIE
+ D EN1^PSJHL2(DFN,"SC",ON55)
+ D:+PSJSYSU=1 EN1^PSJHL2(DFN,"ZV",ON55)
+ D GT55^PSIVORFB S OLDON=$P($G(^PS(55,DFN,"IV",+ON55,2)),"^",5),P("OLDON")=OLDON
+ N PSJPRIO,PSJSCH,NODE0,NODEP2 S NODE0=$G(^PS(55,DFN,"IV",+ON55,0)),NODEP2=$G(^PS(55,DFN,"IV",+ON55,.2))
+ S PSJPRIO=$P(NODEP2,"^",4),PSJSCH=$P(NODE0,"^",9)
+ I (",S,A,")[(","_$G(PSJPRIO)_",")!($G(PSJSCH)="NOW")!($G(PSJSCH)["STAT") D NOTIFY^PSJHL4(ON55,DFN,$G(PSJPRIO),$G(PSJSCH))
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVFD.m

@@ -1 @@
-PSJLIVFD        ;BIR/MV-SETUP LM TEMPLATE FOR IV FLUID ;4 Aug 00 / 2:37 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**7,50,63,64,58,81,91,80,116,110,111,180,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^VALM0 is supported by DBIA # 2615.
-        ;
-        ;NFI changes for FR# 3@AD+4
-        ;
-EN      ; Build LM template to display IV order.
-        K ^TMP("PSJI",$J)
-        S UL80="",$P(UL80,"=",80)=""
-        S PSJLN=1
-AD      ;
-        NEW VALMEVL S VALMEVL=1
-        S PSJL="" D FLDNO^PSJLIUTL("(1)",1)
-        S PSJL=PSJL_"Additives:"
-        S:$G(P("PON"))["V"&(P(17)'="N") PSJL=$$SETSTR^VALM1("Order number:",PSJL,30,14)_+P("PON")
-        S PSJL=$$SETSTR^VALM1("Type:",PSJL,57,6)_$$TYPE^PSJLIUTL
-        NEW PSJVD S PSJVD=$$DINFLIV^PSJDIN(.DRG)
-        S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,6)
-        I '$D(IORVON),$D(IOST(0)) D ENS^%ZISS,TERM^VALM0
-        I $D(IORVON),(PSJVD]"") D CNTRL^VALM10(1,76,5,IORVON,IORVOFF,0) K PSJVD
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-        D:+$G(PSJLMX) CLRDSPL^PSJLIVMD
-        ;PSJLMX count number of lines needed to display the add/sol
-        S PSJLMX=0 D WRTDRG^PSJLIUTL("AD")
-SOL     ;
-        S PSJL="" D FLDNO^PSJLIUTL("(2)",1)
-        S PSJL=PSJL_"Solutions:"
-        I P("SYRS")]"" D
-        . S PSJL=$$SETSTR^VALM1("Syr. Size:",PSJL,52,10)_$E(P("SYRS"),1,13)
-        . S:$L(P("SYRS"))>13 PSJL=PSJL_"..."
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-        D WRTDRG^PSJLIUTL("SOL")
-DUR     ;
-        S PSJL=""
-        N DUROUT,IVLIMIT S DUROUT=$$GETDUR^PSJLIVMD(PSGP,+PSJORD,$S(PSJORD["P":"P",1:"IV"))
-        I $G(PSJORD)["P" N ND25 S ND25=$G(^PS(53.1,+PSJORD,2.5)),IVLIMIT=$P(ND25,"^",4) D
-        .S IVLIMIT=$S(IVLIMIT]"":$$FMTDUR^PSJLIVMD(IVLIMIT),1:"") S:IVLIMIT]"" DUROUT=IVLIMIT
-        S LABEL=$S($G(IVLIMIT):"IV Limit: ",1:"Duration: ") K IVLIMIT
-        S PSJL=$$SETSTR^VALM1(LABEL,PSJL,12,10)
-        S PSJL=PSJL_DUROUT
-START   ;
-        D FLDNO^PSJLIUTL("(4)",47)
-        S PSJL=$$SETSTR^VALM1("Start:",PSJL,56,7)_$$STARTDT^PSJLIUTL
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-        NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN
-        S PSJL="" I $G(PSJORD)["P",$G(PSGRDTX) D
-        . N RSDLABL,PSJRQB,PSJRQL,PSGRSD,PSGSRSDN
-        . S RSDLABL="     REQUESTED START: ",PSJRQB=41,PSJRQL=39,PSGRSD="",PSGRSDN=""
-        . I $G(PSGRDTX(+$G(PSJORD),"PSGRSD")),$G(P(2)) S PSJRQB=51,PSJRQL=29 D
-        .. S PSGRSD=PSGRDTX(+$G(PSJORD),"PSGRSD"),PSGRSDN=$$ENDTC^PSGMI(+PSGRSD),RSDLABL="Calc Start: "
-        . I '$G(P(2)),'$P(PSGRDTX,U,3) S PSGRSD=+PSGRDTX,PSGRSDN=$$ENDTC^PSGMI(PSGRSD)
-        . I $G(PSGRSD),($G(PSGRSDN)]"") D DSPLYDT^PSJLIVMD(PSJLMX+5,.PSGRSD,.PSGRSDN,RSDLABL,1,PSJRQB,PSJRQL),SETTMP^PSJLMPRU("PSJI",PSJL)
-INFRATE ;
-        S PSJL="" D FLDNO^PSJLIUTL("(3)",1)
-        S PSJL=$$SETSTR^VALM1("Infusion Rate:",PSJL,7,15)
-        D LONG^PSJLIUTL(P(8),22,24)
-LASTREN ;
-        N PSGRNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,$S($G(PSJORD):PSJORD,1:$G(ON))) I PSGRNDT D
-        . S PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,54,32)
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-MR      ;
-        S PSJL="" D FLDNO^PSJLIUTL("(5)",1)
-        S PSJL=$$SETSTR^VALM1("Med Route:",PSJL,11,11)
-        S PSJL=PSJL_$P(P("MR"),U,2)
-STOP    ;
-        D FLDNO^PSJLIUTL("(6)",47)
-        ;PSJ*5*180 - If Invalid Duration/Limit - Cannot Calculate Stop Date
-        S PSJL=$$SETSTR^VALM1("Stop:",PSJL,57,6)_$S($G(PSJBADD)=1:"CANNOT CALCULATE",1:$$STOPDT^PSJLIUTL)
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-        S PSJL=""
-        N PSJBCMA S PSJBCMA=$$BCMALG^PSJUTL2(DFN,PSJORD)
-        I $G(PSJBCMA)]"" S PSJL=$$SETSTR^VALM1(PSJBCMA,PSJL,1,52)
-        I $G(PSGRDTX(+PSJORD,"PSGRFD")) S PSGRFD=PSGRDTX(+PSJORD,"PSGRFD"),PSGRFDN=$$ENDTC^PSGMI(PSGRFD) D
-        . D DSPLYDT^PSJLIVMD(PSJLMX+7,.PSGRFD,.PSGRFDN," Calc Stop: ",0,51,29)
-        D:($G(PSJBCMA)]"")!($G(PSGRFD)]"") SETTMP^PSJLMPRU("PSJI",PSJL)
-SCH     ;
-        S PSJL="" D FLDNO^PSJLIUTL("(7)",1)
-        S PSJL=$$SETSTR^VALM1("Schedule:",PSJL,12,11)
-        D LONG^PSJLIUTL(P(9),22,32) S PSJL=PSJL_$S(P(7):"@0 labels a day",1:"")
-LASTFL  ;
-        S PSJL=$$SETSTR^VALM1("Last Fill:",PSJL,52,11)
-        S PSJL=PSJL_$$ENDTC^PSGMI(P("LF"))
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-ADM     ;
-        S PSJL="" D FLDNO^PSJLIUTL("(8)",1)
-        S PSJL=$$SETSTR^VALM1("Admin Times:",PSJL,9,14)
-        D LONG^PSJLIUTL(P(11),22,30)
-QTY     ;
-        S PSJL=$$SETSTR^VALM1("Quantity:",PSJL,53,10)_+P("LFA")
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-PROVIDER        ;
-        S PSJL="" D FLDNO^PSJLIUTL("(9)",1)
-        S PSJL=$$SETSTR^VALM1("Provider:",PSJL,12,10)_$$PROVIDER^PSJLIUTL
-CUMDOSES        ;
-        S PSJL=$$SETSTR^VALM1("Cum. Doses:",PSJL,51,12)_P("CUM")
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-OPI     ;
-        S PSJL="" D FLDNO^PSJLIUTL("(10)",1)
-        S PSJL=$$SETSTR^VALM1("Other Print"_$S($P(P("OPI"),"^",2)=1:"!: ",1:": "),PSJL,9,13)_$P(P("OPI"),"^")
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-PC      ;
-        S PSJL=""
-        S PSJL=$$SETSTR^VALM1("Provider Comments:",PSJL,3,18) D WTPC^PSJLIUTL
-REMARK  ;
-        D SETTMP^PSJLMPRU("PSJI","")
-        S PSJL="" D FLDNO^PSJLIUTL("(11)",1)
-        S PSJL=$$SETSTR^VALM1("Remarks :",PSJL,8,10)
-        D LONG^PSJLIUTL(P("REM"),18,62)
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-IVROOM  ;
-        S PSJL=""
-        S PSJL=$$SETSTR^VALM1("IV Room:",PSJL,9,9)_$P(P("IVRM"),U,2)
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-ENTRY   ;
-        S PSJL="",PSJL=$$SETSTR^VALM1("Entry By:",PSJL,8,10)
-        S PSJL=PSJL_$S($P(P("CLRK"),U,2)]"":$E($P(P("CLRK"),U,2),1,18),1:"*** Undefined")
-        S PSJL=$$SETSTR^VALM1("Entry Date:",PSJL,51,12)_$$ENDTC^PSGMI(P("LOG"))
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-        S PSJL="" S PSGLRN=$$LASTRNBY^PSJLMPRI(DFN,$S($G(PSJORD):PSJORD,1:$G(ON))) I PSGLRN D
-        . S PSJL=$$SETSTR^VALM1("Renewed By: ",PSJL,6,12)_$$ENNPN^PSGMI(PSGLRN) D SETTMP^PSJLMPRU("PSJI",PSJL) K PSGLRN
-        S VALM("TITLE")=$$CODES^PSIVUTL(P(17),$S($G(ON)["P":53.1,1:55.01),$S(ON["P":28,1:100))_" IV "
-        I $G(P("PRY"))="D"!($G(P("PON"))["P") S VALM("TITLE")=VALM("TITLE")_$S($G(P("PRY"))="":"",1:"("_$$CODES^PSIVUTL(P("PRY"),53.1,.24)_")")
-        I $G(P("PON"))["P" D ORDCHK
-        S VALMCNT=PSJLN-1,^TMP("PSJI",$J,0)=VALMCNT
-        Q
-        ;
-ORDCHK  ;Display order check for pending order
-        Q:'$O(^PS(53.1,+ON,10,0))
-        NEW PSJIVX,PSJIVXX
-        F PSJIVX=0:0 S PSJIVX=$O(^PS(53.1,+ON,10,PSJIVX)) Q:'PSJIVX  D
-        . D SETTMP^PSJLMPRU("PSJI","")
-        . S PSJL="Order Checks       :" D LONG^PSJLIUTL($G(^PS(53.1,+ON,10,PSJIVX,0)),22,60)
-        . D SETTMP^PSJLMPRU("PSJI",PSJL)
-        . S PSJL="Overriding Provider: "_$P($G(^PS(53.1,+ON,10,PSJIVX,1)),U)
-        . D SETTMP^PSJLMPRU("PSJI",PSJL)
-        . S PSJL="Overriding Reason  : "
-        . F PSJIVXX=0:0 S PSJIVXX=$O(^PS(53.1,+ON,10,PSJIVX,2,PSJIVXX)) Q:'PSJIVXX  D
-        .. D LONG^PSJLIUTL($G(^PS(53.1,+ON,10,PSJIVX,2,PSJIVXX,0)),22,60)
-        .. D SETTMP^PSJLMPRU("PSJI",PSJL) S PSJL=""
-        Q
-        ;
-SCHREQ(IVAR)    ;
-        I $G(IVAR(4))="P"!($G(IVAR(23))="P")!($G(IVAR(5))) Q 1
-        Q 0
+PSJLIVFD ;BIR/MV-SETUP LM TEMPLATE FOR IV FLUID ;4 Aug 00 / 2:37 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**7,50,63,64,58,81,91,80,116,110,111,180**;16 DEC 97;Build 5
+ ;
+ ; Reference to ^VALM0 is supported by DBIA # 2615.
+ ;
+ ;NFI changes for FR# 3@AD+4
+ ;
+EN ; Build LM template to display IV order.
+ K ^TMP("PSJI",$J)
+ S UL80="",$P(UL80,"=",80)=""
+ S PSJLN=1
+AD ;
+ NEW VALMEVL S VALMEVL=1
+ S PSJL="" D FLDNO^PSJLIUTL("(1)",1)
+ S PSJL=PSJL_"Additives:"
+ S:$G(P("PON"))["V"&(P(17)'="N") PSJL=$$SETSTR^VALM1("Order number:",PSJL,30,14)_+P("PON")
+ S PSJL=$$SETSTR^VALM1("Type:",PSJL,57,6)_$$TYPE^PSJLIUTL
+ NEW PSJVD S PSJVD=$$DINFLIV^PSJDIN(.DRG)
+ S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,6)
+ I '$D(IORVON),$D(IOST(0)) D ENS^%ZISS,TERM^VALM0
+ I $D(IORVON),(PSJVD]"") D CNTRL^VALM10(1,76,5,IORVON,IORVOFF,0) K PSJVD
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ D:+$G(PSJLMX) CLRDSPL^PSJLIVMD
+ ;PSJLMX count number of lines needed to display the add/sol
+ S PSJLMX=0 D WRTDRG^PSJLIUTL("AD")
+SOL ;
+ S PSJL="" D FLDNO^PSJLIUTL("(2)",1)
+ S PSJL=PSJL_"Solutions:"
+ I P("SYRS")]"" D
+ . S PSJL=$$SETSTR^VALM1("Syr. Size:",PSJL,52,10)_$E(P("SYRS"),1,13)
+ . S:$L(P("SYRS"))>13 PSJL=PSJL_"..."
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ D WRTDRG^PSJLIUTL("SOL")
+DUR ;
+ S PSJL=""
+ N DUROUT,IVLIMIT S DUROUT=$$GETDUR^PSJLIVMD(PSGP,+PSJORD,$S(PSJORD["P":"P",1:"IV"))
+ S LABEL=$S($G(IVLIMIT):"IV Limit: ",1:"Duration: ") K IVLIMIT
+ S PSJL=$$SETSTR^VALM1(LABEL,PSJL,12,10)
+ S PSJL=PSJL_DUROUT
+START ;
+ D FLDNO^PSJLIUTL("(4)",47)
+ S PSJL=$$SETSTR^VALM1("Start:",PSJL,56,7)_$$STARTDT^PSJLIUTL
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN
+ S PSJL="" I $G(PSJORD)["P",$G(PSGRDTX) D
+ . N RSDLABL,PSJRQB,PSJRQL,PSGRSD,PSGSRSDN
+ . S RSDLABL="     REQUESTED START: ",PSJRQB=41,PSJRQL=39,PSGRSD="",PSGRSDN=""
+ . I $G(PSGRDTX(+$G(PSJORD),"PSGRSD")),$G(P(2)) S PSJRQB=51,PSJRQL=29 D
+ .. S PSGRSD=PSGRDTX(+$G(PSJORD),"PSGRSD"),PSGRSDN=$$ENDTC^PSGMI(+PSGRSD),RSDLABL="Calc Start: "
+ . I '$G(P(2)),'$P(PSGRDTX,U,3) S PSGRSD=+PSGRDTX,PSGRSDN=$$ENDTC^PSGMI(PSGRSD)
+ . I $G(PSGRSD),($G(PSGRSDN)]"") D DSPLYDT^PSJLIVMD(PSJLMX+5,.PSGRSD,.PSGRSDN,RSDLABL,1,PSJRQB,PSJRQL),SETTMP^PSJLMPRU("PSJI",PSJL)
+INFRATE ;
+ S PSJL="" D FLDNO^PSJLIUTL("(3)",1)
+ S PSJL=$$SETSTR^VALM1("Infusion Rate:",PSJL,7,15)
+ D LONG^PSJLIUTL(P(8),22,24)
+LASTREN ;
+ N PSGRNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,$S($G(PSJORD):PSJORD,1:$G(ON))) I PSGRNDT D
+ . S PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,54,32)
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+MR ;
+ S PSJL="" D FLDNO^PSJLIUTL("(5)",1)
+ S PSJL=$$SETSTR^VALM1("Med Route:",PSJL,11,11)
+ S PSJL=PSJL_$P(P("MR"),U,2)
+STOP ;
+ D FLDNO^PSJLIUTL("(6)",47)
+ ;PSJ*5*180 - If Invalid Duration/Limit - Cannot Calculate Stop Date
+ S PSJL=$$SETSTR^VALM1("Stop:",PSJL,57,6)_$S($G(PSJBADD)=1:"CANNOT CALCULATE",1:$$STOPDT^PSJLIUTL)
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ S PSJL=""
+ N PSJBCMA S PSJBCMA=$$BCMALG^PSJUTL2(DFN,PSJORD)
+ I $G(PSJBCMA)]"" S PSJL=$$SETSTR^VALM1(PSJBCMA,PSJL,1,52)
+ ;D:$G(PSGRFD) DSPLYDT^PSJLIVMD(PSJLMX+7,.PSGRFD,.PSGRFDN," REQUESTED STOP: ",P(3)'=PSGRFD)
+ I $G(PSGRDTX(+PSJORD,"PSGRFD")) S PSGRFD=PSGRDTX(+PSJORD,"PSGRFD"),PSGRFDN=$$ENDTC^PSGMI(PSGRFD) D
+ . D DSPLYDT^PSJLIVMD(PSJLMX+7,.PSGRFD,.PSGRFDN," Calc Stop: ",0,51,29)
+ D:($G(PSJBCMA)]"")!($G(PSGRFD)]"") SETTMP^PSJLMPRU("PSJI",PSJL)
+SCH ;
+ S PSJL="" D FLDNO^PSJLIUTL("(7)",1)
+ S PSJL=$$SETSTR^VALM1("Schedule:",PSJL,12,11)
+ D LONG^PSJLIUTL(P(9),22,32) S PSJL=PSJL_$S(P(7):"@0 labels a day",1:"")
+LASTFL ;
+ S PSJL=$$SETSTR^VALM1("Last Fill:",PSJL,52,11)
+ S PSJL=PSJL_$$ENDTC^PSGMI(P("LF"))
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ADM ;
+ S PSJL="" D FLDNO^PSJLIUTL("(8)",1)
+ S PSJL=$$SETSTR^VALM1("Admin Times:",PSJL,9,14)
+ D LONG^PSJLIUTL(P(11),22,30)
+QTY ;
+ S PSJL=$$SETSTR^VALM1("Quantity:",PSJL,53,10)_+P("LFA")
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+PROVIDER ;
+ S PSJL="" D FLDNO^PSJLIUTL("(9)",1)
+ S PSJL=$$SETSTR^VALM1("Provider:",PSJL,12,10)_$$PROVIDER^PSJLIUTL
+CUMDOSES ;
+ ;S PSJL=$$SETSTR^VALM1("Cumulative Doses:",PSJL,45,17)_P("CUM")
+ S PSJL=$$SETSTR^VALM1("Cum. Doses:",PSJL,51,12)_P("CUM")
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+OPI ;
+ S PSJL="" D FLDNO^PSJLIUTL("(10)",1)
+ S PSJL=$$SETSTR^VALM1("Other Print"_$S($P(P("OPI"),"^",2)=1:"!: ",1:": "),PSJL,9,13)_$P(P("OPI"),"^")
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+PC ;
+ S PSJL=""
+ ;S PSJL=$$SETSTR^VALM1("Provider Comments:",PSJL,3,18) D SETTMP^PSJLMPRU("PSJI",PSJL) D WTPC^PSJLIUTL
+ S PSJL=$$SETSTR^VALM1("Provider Comments:",PSJL,3,18) D WTPC^PSJLIUTL
+REMARK ;
+ D SETTMP^PSJLMPRU("PSJI","")
+ S PSJL="" D FLDNO^PSJLIUTL("(11)",1)
+ S PSJL=$$SETSTR^VALM1("Remarks :",PSJL,8,10)
+ D LONG^PSJLIUTL(P("REM"),18,62)
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+IVROOM ;
+ S PSJL=""
+ S PSJL=$$SETSTR^VALM1("IV Room:",PSJL,9,9)_$P(P("IVRM"),U,2)
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ENTRY ;
+ S PSJL="",PSJL=$$SETSTR^VALM1("Entry By:",PSJL,8,10)
+ S PSJL=PSJL_$S($P(P("CLRK"),U,2)]"":$E($P(P("CLRK"),U,2),1,18),1:"*** Undefined")
+ S PSJL=$$SETSTR^VALM1("Entry Date:",PSJL,51,12)_$$ENDTC^PSGMI(P("LOG"))
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ S PSJL="" S PSGLRN=$$LASTRNBY^PSJLMPRI(DFN,$S($G(PSJORD):PSJORD,1:$G(ON))) I PSGLRN D
+ . S PSJL=$$SETSTR^VALM1("Renewed By: ",PSJL,6,12)_$$ENNPN^PSGMI(PSGLRN) D SETTMP^PSJLMPRU("PSJI",PSJL) K PSGLRN
+ S VALM("TITLE")=$$CODES^PSIVUTL(P(17),$S($G(ON)["P":53.1,1:55.01),$S(ON["P":28,1:100))_" IV "
+ I $G(P("PRY"))="D"!($G(P("PON"))["P") S VALM("TITLE")=VALM("TITLE")_$S($G(P("PRY"))="":"",1:"("_$$CODES^PSIVUTL(P("PRY"),53.1,.24)_")")
+ I $G(P("PON"))["P" D ORDCHK
+ S VALMCNT=PSJLN-1,^TMP("PSJI",$J,0)=VALMCNT
+ Q
+ ;
+ORDCHK ;Display order check for pending order
+ Q:'$O(^PS(53.1,+ON,10,0))
+ NEW PSJIVX,PSJIVXX
+ F PSJIVX=0:0 S PSJIVX=$O(^PS(53.1,+ON,10,PSJIVX)) Q:'PSJIVX  D
+ . D SETTMP^PSJLMPRU("PSJI","")
+ . S PSJL="Order Checks       :" D LONG^PSJLIUTL($G(^PS(53.1,+ON,10,PSJIVX,0)),22,60)
+ . D SETTMP^PSJLMPRU("PSJI",PSJL)
+ . S PSJL="Overriding Provider: "_$P($G(^PS(53.1,+ON,10,PSJIVX,1)),U)
+ . D SETTMP^PSJLMPRU("PSJI",PSJL)
+ . S PSJL="Overriding Reason  : "
+ . F PSJIVXX=0:0 S PSJIVXX=$O(^PS(53.1,+ON,10,PSJIVX,2,PSJIVXX)) Q:'PSJIVXX  D
+ .. D LONG^PSJLIUTL($G(^PS(53.1,+ON,10,PSJIVX,2,PSJIVXX,0)),22,60)
+ .. D SETTMP^PSJLMPRU("PSJI",PSJL) S PSJL=""
+ Q
+ ;
+SCHREQ(IVAR) ;
+ I $G(IVAR(4))="P"!($G(IVAR(23))="P")!($G(IVAR(5))) Q 1
+ Q 0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVMD.m

@@ -1 @@
-PSJLIVMD        ;BIR/MV-SETUP LM TEMPLATE FOR INPT MED. IV ;4 Aug 00 / 4:29 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**37,50,63,58,81,91,80,116,110,111,180,134**;16 DEC 97;Build 124
-        ;
-        ;Reference to ^PS(55 is supported by DBIA #2191.
-        ;
-EN      ; Build LM template to display IV order.
-        D GTOT^PSIVUTL(P(4))
-        S:'$D(PSJSTAR) PSJSTAR="" S:'$D(PSGP) PSGP=DFN
-        I $E(P("OT"))'="I" D EN^PSJLIVFD Q
-        K ^TMP("PSJI",$J)
-        S UL80="",$P(UL80,"=",80)=""
-        S PSJLN=1
-        I $G(PSIV531),P("PON")["P" S (P(2),P(3),P(4))=""
-AD      ;
-        NEW VALMEVL S VALMEVL=1
-        S PSJL="" D FLDNO^PSJLIUTL("(1)",1)
-        S PSJL=PSJL_" Additives:"
-        S:$G(P("PON"))["V"&(P(17)'="N") PSJL=$$SETSTR^VALM1("Order number:",PSJL,28,14)_+P("PON")
-        S PSJL=$$SETSTR^VALM1("Type:",PSJL,57,6)_$$TYPE^PSJLIUTL
-        NEW PSJVD S PSJVD=$$DINFLIV^PSJDIN(.DRG)
-        S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,6)
-        I $D(IORVON),(PSJVD]"") D CNTRL^VALM10(1,76,5,IORVON,IORVOFF,0) K PSJVD
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-        D:+$G(PSJLMX) CLRDSPL
-        ;PSJLMX count number of lines needed to display the add/sol
-        S PSJLMX=0 D WRTDRG^PSJLIUTL("AD")
-SOL     ;
-        S PSJL="" D FLDNO^PSJLIUTL("(2)",1)
-        S PSJL=PSJL_" Solutions:"
-        I P("SYRS")]"" D
-        . S PSJL=$$SETSTR^VALM1("Syr. Size:",PSJL,52,11)_$E(P("SYRS"),1,13)
-        . S:$L(P("SYRS"))>13 PSJL=PSJL_"..."
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-        D WRTDRG^PSJLIUTL("SOL")
-        D DUR
-START   ;
-        NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN
-        I $G(P("OT"))="I",$G(P(4))]"" D
-        .Q:$G(ON)["V"  I $G(PSIVAC)="" N PSIVAC S PSIVAC="CF"
-        .Q:$G(P(3))
-        .D ENT^PSIVCAL,ENSTOP^PSIVCAL
-        D REQDT(ON)
-        D FLDNO^PSJLIUTL("(4)",47)
-        S PSJL=$$SETSTR^VALM1("Start:",PSJL,56,7)_$$STARTDT^PSJLIUTL
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-INFRATE ;
-        S PSJL="" D FLDNO^PSJLIUTL("(3)",1)
-        S PSJL=$$SETSTR^VALM1("Infusion Rate:",PSJL,7,15)
-        D LONG^PSJLIUTL(P(8),22,23)
-RSTART  ;
-        I $G(ON)["P" N PSGNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,ON) D
-        . I PSGRNDT S PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,54,32) Q
-        . Q:'$G(PSGRDTX)  N PSJRQB,PSJRQL,RSDLABL,PSGRSD,PSGRSDN
-        . S RSDLABL="     REQUESTED START: ",PSJRQB=41,PSJRQL=39,PSGRSD="",PSGRSDN=""
-        . I $G(PSGRDTX(+$G(PSJORD),"PSGRSD")),$G(P(2)) S PSJRQB=51,PSJRQL=29 D
-        .. S PSGRSD=PSGRDTX(+$G(PSJORD),"PSGRSD"),PSGRSDN=$$ENDTC^PSGMI(+PSGRSD),RSDLABL="Calc Start: "
-        . I '$G(P(2)),'$P(PSGRDTX,U,3) S PSGRSD=+PSGRDTX,PSGRSDN=$$ENDTC^PSGMI(PSGRSD)
-        . I $G(PSGRSD),($G(PSGRSDN)]"") D DSPLYDT(PSJLMX+5,.PSGRSD,.PSGRSDN,RSDLABL,1,PSJRQB,PSJRQL)  ;,SETTMP^PSJLMPRU("PSJI",PSJL)
-        I $G(ON)["V" N PSGRNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,ON) I PSGRNDT S PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,54,32)
-        I PSJL]"" D SETTMP^PSJLMPRU("PSJI",PSJL)
-        ;
-MR      ;
-        S PSJL="" D FLDNO^PSJLIUTL("(5)",1)
-        S PSJL=$$SETSTR^VALM1("Med Route:",PSJL,11,11)
-        S PSJL=PSJL_$P(P("MR"),U,2)
-STOP    ;
-        S:'$D(PSGP) PSGP=DFN
-        D FLDNO^PSJLIUTL("(6)",47)
-        ;PSJ*5*180 - If CPRS sends invalid duration/limit - Cannot Calculate Stop Date.
-        S PSJL=$$SETSTR^VALM1("Stop:",PSJL,57,6)_$S($G(PSJBADD)=1:"CANNOT CALCULATE",1:$$STOPDT^PSJLIUTL)
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-        S PSJL=""
-        N PSJBCMA S PSJBCMA=$$BCMALG^PSJUTL2(PSGP,PSJORD)
-        I $G(PSJBCMA)]"",$G(DFN) S PSJL=$$SETSTR^VALM1(PSJBCMA,PSJL,1,52)
-        I $G(PSJORD)["P",$G(PSGRDTX(+$G(PSJORD),"PSGRFD")),$G(P(3)) S PSGRFDN=$$ENDTC^PSGMI(PSGRDTX(+PSJORD,"PSGRFD")) D
-        . D DSPLYDT(PSJLMX+7,.PSGRFD,.PSGRFDN," Calc Stop: ",1,51,29)
-        I ($G(PSJBCMA)]"")!($G(PSGRDTX(+$G(PSJORD),"PSGRFD"))&$G(P(3))) D SETTMP^PSJLMPRU("PSJI",PSJL)
-SCH     ;
-        S PSJL="" D FLDNO^PSJLIUTL("(7)",1)
-        S PSJL=$$SETSTR^VALM1("Schedule:",PSJL,12,11)
-        D LONG^PSJLIUTL(P(9)_$S(P(7):"@0 labels a day",1:"")_$G(SCHMSG),22,31)
-LASTFL  ;
-        S PSJL=$$SETSTR^VALM1("Last Fill:",PSJL,52,11)
-        S PSJL=PSJL_$$ENDTC^PSGMI(P("LF"))
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-ADM     ;
-        S PSJL="" D FLDNO^PSJLIUTL("(8)",1)
-        S PSJL=$$SETSTR^VALM1("Admin Times:",PSJL,9,14)
-        NEW NOECH
-        D LONG^PSJLIUTL(P(11),22,29)
-QTY     ;
-        S PSJL=$$SETSTR^VALM1("Quantity:",PSJL,53,10)_+P("LFA")
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-PROVIDER        ;
-        S PSJL="" D FLDNO^PSJLIUTL("(9)",1)
-        S PSJL=$$SETSTR^VALM1("Provider:",PSJL,12,10)_$$PROVIDER^PSJLIUTL
-CUMDOSES        ;
-        S PSJL=$$SETSTR^VALM1("Cum. Doses:",PSJL,51,12)_P("CUM")
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-OI      ;
-        S PSJL="" D FLDNO^PSJLIUTL("(10)",1)
-        S PSJL=$$SETSTR^VALM1("Orderable Item:",PSJL,6,16)_$P(P("PD"),U,2)_$$OINF^PSJDIN(+P("PD"))
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-INS     ;
-        S PSJL=""
-        S PSJL=$$SETSTR^VALM1("Instructions:",PSJL,8,14)
-        D LONG^PSJLIUTL(P("INS"),22,58)
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-OPI     ;
-        S PSJL="" D FLDNO^PSJLIUTL("(11)",1)
-        S PSJL=$$SETSTR^VALM1("Other Print"_$S($P(P("OPI"),"^",2)=1:"!: ",1:": "),PSJL,9,13)_$P(P("OPI"),"^")
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-PC      ;
-        S PSJL=""
-        S PSJL=$$SETSTR^VALM1("Provider Comments:",PSJL,3,18) D WTPC^PSJLIUTL
-REMARK  ;
-        D SETTMP^PSJLMPRU("PSJI","")
-        S PSJL="" D FLDNO^PSJLIUTL("(12)",1)
-        S PSJL=$$SETSTR^VALM1("Remarks :",PSJL,8,10)
-        D LONG^PSJLIUTL(P("REM"),18,62)
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-IVROOM  ;
-        S PSJL=""
-        S PSJL=$$SETSTR^VALM1("IV Room:",PSJL,9,9)_$P(P("IVRM"),U,2)
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-ENTRY   ;
-        S PSJL="",PSJL=$$SETSTR^VALM1("Entry By:",PSJL,8,10)
-        S PSJL=PSJL_$S($P(P("CLRK"),U,2)]"":$E($P(P("CLRK"),U,2),1,24),1:"*** Undefined")
-        S PSJL=$$SETSTR^VALM1("Entry Date:",PSJL,51,12)_$$ENDTC^PSGMI(P("LOG"))
-        D SETTMP^PSJLMPRU("PSJI",PSJL)
-        S PSJL="" S PSGLRN=$$LASTRNBY^PSJLMPRI(DFN,$S($G(PSJORD):PSJORD,1:$G(ON))) I PSGLRN D
-        . S PSJL=$$SETSTR^VALM1("Renewed By: ",PSJL,6,12)_$$ENNPN^PSGMI(PSGLRN) D SETTMP^PSJLMPRU("PSJI",PSJL) K PSGLRN
-        S VALM("TITLE")=$$CODES^PSIVUTL(P(17),$S($G(ON)["P":53.1,1:55.01),$S($G(ON)["P":28,1:100))_" IV "
-        I $G(P("PRY"))="D"!($G(P("PON"))["P") S VALM("TITLE")=VALM("TITLE")_$S($G(P("PRY"))="":"",1:"("_$$CODES^PSIVUTL(P("PRY"),53.1,.24)_")")
-        I $G(P("PON"))["P" D ORDCHK^PSJLIVFD
-        S VALMCNT=PSJLN-1,^TMP("PSJI",$J,0)=VALMCNT
-        Q
-DSPLYDT(PSJLN,PSGRDT,PSGRDTN,TXT,PSJFSH,PSJRDBEG,PSJRDLEN)       ;
-        ;LINE   : Line number the Requested Start and Stop dates are display in
-        ;PSGRDT : Either it is the requested start or stop date in FM format
-        ;PSGRDTN: Either it is the requested start or stop date in IPM format
-        ;TXT    : The display text
-        ;PSJFSH     : if it is 1 then flash
-        ;
-        S:'$G(PSJRDBEG) PSJRDBEG=41,PSJRDLEN=39
-        S PSJL=$$SETSTR^VALM1(TXT_PSGRDTN,PSJL,PSJRDBEG,PSJRDLEN)
-        Q
-CLRDSPL ;
-        ;Clear the blinking after edit the pending order.
-        ;Without it more than the requested start and stop dates are blinking at the ac/edit screen
-        ;PSJLMX: # ad/sol counted in WRTDRG^PSJLIUTL
-        Q:'$D(IOBOFF)
-        NEW PSJX
-        F PSJX=5:1:PSJLMX+7 D CNTRL^VALM10(PSJX,36,80,IOBOFF,IOINORM)
-        Q
-REQDT(ORDER)          ;Get requested date if it is a pending order
-        ;ORDER  : Pending Order Number (PSJORD or PSGORD)
-        Q:ORDER'["P"  D REQDT^PSJLIUTL(ORDER)
-        Q
-        ;
-GETDUR(PAT,ORD,PKG,RAW) ;
-        ; PAT= Patient DFN
-        ; ORD= Order #
-        ; PKG= 5(UD), "IV"(IV), "P"(Pending)
-        N ACT,DUR,ND,ND25,F25,ND0,ND2,OLDORD S DUR="",ORD=+ORD K IVLIMIT
-        S:PKG="V" PKG="IV"
-        I PKG="P" S ND=$G(^PS(53.1,+ORD,0)) D  I '$G(OLDORD) Q DUR
-        . I $G(P("OVRIDE")) S DUR="" Q
-        . D PENDING(ORD) Q:DUR]""
-        . S ND0=$G(^PS(53.1,ORD,0)) I $P(ND0,U,24)="E" S OLDORD=$P(ND0,U,25) I OLDORD S PKG=$S(OLDORD["V":"IV",OLDORD["U":5,OLDORD["P":"P",1:"")
-        . Q:($G(OLDORD)'["P")
-        . D PENDING(OLDORD) S OLDORD=""
-        I PKG="IV" S ND2=$G(^PS(55,PAT,PKG,ORD,2)) I $P(ND2,U,8)="E" S OLDORD=$P(ND2,U,5) S:OLDORD'["V" OLDORD="" I OLDORD D
-        .N ACTND S ACTND=0 F  S ACTND=$O(^PS(55,PAT,"IV",ORD,"A",ACTND)) Q:'ACTND  D
-        ..I $G(^PS(55,PAT,"IV",ORD,"A",ACTND,0))["IV LIMIT OVERRIDDEN" S OLDORD=""
-        I $G(P("LIMIT"))]"" S DUR=P("LIMIT"),IVLIMIT=1 I '$G(RAW) S DUR=$$FMTDUR(DUR) Q DUR
-        I PKG=5 S ND0=$G(^PS(55,PAT,PKG,ORD,0)) I $P(ND0,U,24)="E" S OLDORD=$P(ND0,U,25) S:OLDORD'["U" OLDORD=""
-        S F25="^PS(55,PAT,PKG,ORD,2.5)" I '$G(OLDORD) Q:'$D(@(F25)) DUR
-        S ND25=$G(@(F25)) S DUR=$P(ND25,U,2) I DUR="" S DUR=$P(ND25,U,4) I DUR]"" S IVLIMIT=1
-        I DUR="",$G(OLDORD) S ORD=+OLDORD Q:'$D(@(F25)) DUR  D
-        . S ND25=$G(@(F25)) S DUR=$P(ND25,U,2) I DUR="" S DUR=$P(ND25,U,4) I DUR]"" S IVLIMIT=1
-        I '$G(RAW),DUR]"" S DUR=$$FMTDUR(DUR)
-        Q DUR
-        ;
-PENDING(PNDON)  ;
-        S ND=$G(^PS(53.1,+ORD,0))
-        I ND S ND25=$S(($P(ND,U,15)=PAT):$G(^PS(53.1,+ORD,2.5)),1:"")
-        S DUR=$P(ND25,U,4) I DUR]"" D  Q
-        .S:($E(DUR)="s")!($E(DUR)="m")!($E(DUR)="l")!($E(DUR)="d")!($E(DUR)="h")!($E(DUR)="a") IVLIMIT=1 S DUR=$S($G(RAW):DUR,1:$$FMTDUR(DUR))
-        S DUR=$P(ND25,U,2) I DUR]"" S DUR=$S($G(RAW):DUR,1:$$FMTDUR(DUR))
-        Q
-        ;
-FMTDUR(DURCODE) ;
-        N DUNIT,DNUM,BAD S BAD=0
-        ;PSJ*5*180 - Add PSJBADD variable
-        K PSJBADD S PSJBADD=0
-        S DUNIT=$E(DURCODE),DNUM=$P(DURCODE,DUNIT,2) I 'DNUM S BAD=1
-        I DUNIT'="",DUNIT'?1(1U,1L) S PSJBADD=1
-        S DUNIT=$S(DUNIT="D"!(DUNIT="d"):" day",DUNIT="H"!(DUNIT="h"):" hour",DUNIT="W":" week",DUNIT="L":" month",DUNIT="M":" minute",DUNIT="S":" second",DUNIT="m":" ml",DUNIT="l":" liter",DUNIT="a":" dose",1:"")
-        S:DUNIT="" BAD=1 I (DNUM'=1),(DUNIT'["ml") S DUNIT=DUNIT_"s"
-        I PSJBADD=1 S PSGACT=$TR($G(PSGACT),"F")
-        Q $S(PSJBADD=1:"*INVALID DURATION/LIMIT*",BAD:"",1:DNUM_DUNIT)
-        ;
-DURMIN(DCOD)    ;
-        N DUR,DMIN,CHR S DUR="" F I=1:1:$L(DCOD) S CHR=$E(DCOD,I) I CHR?1N S DUR=DUR_CHR
-        S DMIN=DUR*$S(DCOD["L":43200,DCOD["W":10080,DCOD["M":1,DCOD["S":(1/60),DCOD["D":1440,1:0) S DMIN=+$FN(DMIN,"",1)
-        Q DMIN
-        ;
-DUR     ;
-        N DUROUT,LABEL,IVLIMIT
-        Q:'$G(PSJORD)  S PSJL=""
-        S DUROUT=$$GETDUR^PSJLIVMD(PSGP,+PSJORD,$S(PSJORD["P":"P",1:"IV"))
-        S LABEL=$S($G(IVLIMIT):"IV Limit: ",1:"Duration: ") K IVLIMIT
-        S PSJL=$$SETSTR^VALM1(LABEL,PSJL,12,10)
-        S PSJL=PSJL_DUROUT
-        Q
+PSJLIVMD ;BIR/MV-SETUP LM TEMPLATE FOR INPT MED. IV ;4 Aug 00 / 4:29 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**37,50,63,58,81,91,80,116,110,111,180**;16 DEC 97;Build 5
+ ;
+ ;Reference to ^PS(55 is supported by DBIA #2191.
+ ;
+EN ; Build LM template to display IV order.
+ D GTOT^PSIVUTL(P(4))
+ S:'$D(PSJSTAR) PSJSTAR="" S:'$D(PSGP) PSGP=DFN
+ I $E(P("OT"))'="I" D EN^PSJLIVFD Q
+ K ^TMP("PSJI",$J)
+ S UL80="",$P(UL80,"=",80)=""
+ S PSJLN=1
+ I $G(PSIV531),P("PON")["P" S (P(2),P(3),P(4))=""
+AD ;
+ NEW VALMEVL S VALMEVL=1
+ S PSJL="" D FLDNO^PSJLIUTL("(1)",1)
+ S PSJL=PSJL_" Additives:"
+ S:$G(P("PON"))["V"&(P(17)'="N") PSJL=$$SETSTR^VALM1("Order number:",PSJL,28,14)_+P("PON")
+ S PSJL=$$SETSTR^VALM1("Type:",PSJL,57,6)_$$TYPE^PSJLIUTL
+ NEW PSJVD S PSJVD=$$DINFLIV^PSJDIN(.DRG)
+ S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,6)
+ I $D(IORVON),(PSJVD]"") D CNTRL^VALM10(1,76,5,IORVON,IORVOFF,0) K PSJVD
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ D:+$G(PSJLMX) CLRDSPL
+ ;PSJLMX count number of lines needed to display the add/sol
+ S PSJLMX=0 D WRTDRG^PSJLIUTL("AD")
+SOL ;
+ S PSJL="" D FLDNO^PSJLIUTL("(2)",1)
+ S PSJL=PSJL_" Solutions:"
+ I P("SYRS")]"" D
+ . S PSJL=$$SETSTR^VALM1("Syr. Size:",PSJL,52,11)_$E(P("SYRS"),1,13)
+ . S:$L(P("SYRS"))>13 PSJL=PSJL_"..."
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ D WRTDRG^PSJLIUTL("SOL")
+ D DUR
+START ;
+ NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN
+ D REQDT(ON)
+ D FLDNO^PSJLIUTL("(4)",47)
+ S PSJL=$$SETSTR^VALM1("Start:",PSJL,56,7)_$$STARTDT^PSJLIUTL
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+INFRATE ;
+ S PSJL="" D FLDNO^PSJLIUTL("(3)",1)
+ S PSJL=$$SETSTR^VALM1("Infusion Rate:",PSJL,7,15)
+ D LONG^PSJLIUTL(P(8),22,23)
+RSTART ;
+ I $G(ON)["P" N PSGNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,ON) D
+ . I PSGRNDT S PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,54,32) Q
+ . Q:'$G(PSGRDTX)  N PSJRQB,PSJRQL,RSDLABL,PSGRSD,PSGRSDN
+ . S RSDLABL="     REQUESTED START: ",PSJRQB=41,PSJRQL=39,PSGRSD="",PSGRSDN=""
+ . I $G(PSGRDTX(+$G(PSJORD),"PSGRSD")),$G(P(2)) S PSJRQB=51,PSJRQL=29 D
+ .. S PSGRSD=PSGRDTX(+$G(PSJORD),"PSGRSD"),PSGRSDN=$$ENDTC^PSGMI(+PSGRSD),RSDLABL="Calc Start: "
+ . I '$G(P(2)),'$P(PSGRDTX,U,3) S PSGRSD=+PSGRDTX,PSGRSDN=$$ENDTC^PSGMI(PSGRSD)
+ . I $G(PSGRSD),($G(PSGRSDN)]"") D DSPLYDT(PSJLMX+5,.PSGRSD,.PSGRSDN,RSDLABL,1,PSJRQB,PSJRQL)  ;,SETTMP^PSJLMPRU("PSJI",PSJL)
+ I $G(ON)["V" N PSGRNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,ON) I PSGRNDT S PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,54,32)
+ I PSJL]"" D SETTMP^PSJLMPRU("PSJI",PSJL)
+ ;
+MR ;
+ S PSJL="" D FLDNO^PSJLIUTL("(5)",1)
+ S PSJL=$$SETSTR^VALM1("Med Route:",PSJL,11,11)
+ S PSJL=PSJL_$P(P("MR"),U,2)
+STOP ;
+ S:'$D(PSGP) PSGP=DFN
+ D FLDNO^PSJLIUTL("(6)",47)
+ ;PSJ*5*180 - If CPRS sends invalid duration/limit - Cannot Calculate Stop Date.
+ S PSJL=$$SETSTR^VALM1("Stop:",PSJL,57,6)_$S($G(PSJBADD)=1:"CANNOT CALCULATE",1:$$STOPDT^PSJLIUTL)
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ S PSJL=""
+ N PSJBCMA S PSJBCMA=$$BCMALG^PSJUTL2(PSGP,PSJORD)
+ I $G(PSJBCMA)]"",$G(DFN) S PSJL=$$SETSTR^VALM1(PSJBCMA,PSJL,1,52)
+ I $G(PSJORD)["P",$G(PSGRDTX(+$G(PSJORD),"PSGRFD")),$G(P(3)) S PSGRFDN=$$ENDTC^PSGMI(PSGRDTX(+PSJORD,"PSGRFD")) D
+ . D DSPLYDT(PSJLMX+7,.PSGRFD,.PSGRFDN," Calc Stop: ",1,51,29)
+ I ($G(PSJBCMA)]"")!($G(PSGRDTX(+$G(PSJORD),"PSGRFD"))&$G(P(3))) D SETTMP^PSJLMPRU("PSJI",PSJL)
+SCH ;
+ S PSJL="" D FLDNO^PSJLIUTL("(7)",1)
+ S PSJL=$$SETSTR^VALM1("Schedule:",PSJL,12,11)
+ D LONG^PSJLIUTL(P(9)_$S(P(7):"@0 labels a day",1:"")_$G(SCHMSG),22,31)
+LASTFL ;
+ S PSJL=$$SETSTR^VALM1("Last Fill:",PSJL,52,11)
+ S PSJL=PSJL_$$ENDTC^PSGMI(P("LF"))
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ADM ;
+ S PSJL="" D FLDNO^PSJLIUTL("(8)",1)
+ S PSJL=$$SETSTR^VALM1("Admin Times:",PSJL,9,14)
+ NEW NOECH
+ D LONG^PSJLIUTL(P(11),22,29)
+QTY ;
+ S PSJL=$$SETSTR^VALM1("Quantity:",PSJL,53,10)_+P("LFA")
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+PROVIDER ;
+ S PSJL="" D FLDNO^PSJLIUTL("(9)",1)
+ S PSJL=$$SETSTR^VALM1("Provider:",PSJL,12,10)_$$PROVIDER^PSJLIUTL
+CUMDOSES ;
+ S PSJL=$$SETSTR^VALM1("Cum. Doses:",PSJL,51,12)_P("CUM")
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+OI ;
+ S PSJL="" D FLDNO^PSJLIUTL("(10)",1)
+ S PSJL=$$SETSTR^VALM1("Orderable Item:",PSJL,6,16)_$P(P("PD"),U,2)_$$OINF^PSJDIN(+P("PD"))
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+INS ;
+ S PSJL=""
+ S PSJL=$$SETSTR^VALM1("Instructions:",PSJL,8,14)
+ D LONG^PSJLIUTL(P("INS"),22,58)
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+OPI ;
+ S PSJL="" D FLDNO^PSJLIUTL("(11)",1)
+ S PSJL=$$SETSTR^VALM1("Other Print"_$S($P(P("OPI"),"^",2)=1:"!: ",1:": "),PSJL,9,13)_$P(P("OPI"),"^")
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+PC ;
+ S PSJL=""
+ S PSJL=$$SETSTR^VALM1("Provider Comments:",PSJL,3,18) D WTPC^PSJLIUTL
+REMARK ;
+ D SETTMP^PSJLMPRU("PSJI","")
+ S PSJL="" D FLDNO^PSJLIUTL("(12)",1)
+ S PSJL=$$SETSTR^VALM1("Remarks :",PSJL,8,10)
+ D LONG^PSJLIUTL(P("REM"),18,62)
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+IVROOM ;
+ S PSJL=""
+ S PSJL=$$SETSTR^VALM1("IV Room:",PSJL,9,9)_$P(P("IVRM"),U,2)
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ENTRY ;
+ S PSJL="",PSJL=$$SETSTR^VALM1("Entry By:",PSJL,8,10)
+ S PSJL=PSJL_$S($P(P("CLRK"),U,2)]"":$E($P(P("CLRK"),U,2),1,24),1:"*** Undefined")
+ S PSJL=$$SETSTR^VALM1("Entry Date:",PSJL,51,12)_$$ENDTC^PSGMI(P("LOG"))
+ D SETTMP^PSJLMPRU("PSJI",PSJL)
+ S PSJL="" S PSGLRN=$$LASTRNBY^PSJLMPRI(DFN,$S($G(PSJORD):PSJORD,1:$G(ON))) I PSGLRN D
+ . S PSJL=$$SETSTR^VALM1("Renewed By: ",PSJL,6,12)_$$ENNPN^PSGMI(PSGLRN) D SETTMP^PSJLMPRU("PSJI",PSJL) K PSGLRN
+ S VALM("TITLE")=$$CODES^PSIVUTL(P(17),$S($G(ON)["P":53.1,1:55.01),$S($G(ON)["P":28,1:100))_" IV "
+ I $G(P("PRY"))="D"!($G(P("PON"))["P") S VALM("TITLE")=VALM("TITLE")_$S($G(P("PRY"))="":"",1:"("_$$CODES^PSIVUTL(P("PRY"),53.1,.24)_")")
+ I $G(P("PON"))["P" D ORDCHK^PSJLIVFD
+ S VALMCNT=PSJLN-1,^TMP("PSJI",$J,0)=VALMCNT
+ Q
+DSPLYDT(PSJLN,PSGRDT,PSGRDTN,TXT,PSJFSH,PSJRDBEG,PSJRDLEN)  ;
+ ;LINE   : Line number the Requested Start and Stop dates are display in
+ ;PSGRDT : Either it is the requested start or stop date in FM format
+ ;PSGRDTN: Either it is the requested start or stop date in IPM format
+ ;TXT    : The display text
+ ;PSJFSH     : if it is 1 then flash
+ ;
+ S:'$G(PSJRDBEG) PSJRDBEG=41,PSJRDLEN=39
+ S PSJL=$$SETSTR^VALM1(TXT_PSGRDTN,PSJL,PSJRDBEG,PSJRDLEN)
+ Q
+CLRDSPL ;
+ ;Clear the blinking after edit the pending order.
+ ;Without it more than the requested start and stop dates are blinking at the ac/edit screen
+ ;PSJLMX: # ad/sol counted in WRTDRG^PSJLIUTL
+ Q:'$D(IOBOFF)
+ NEW PSJX
+ F PSJX=5:1:PSJLMX+7 D CNTRL^VALM10(PSJX,36,80,IOBOFF,IOINORM)
+ Q
+REQDT(ORDER)       ;Get requested date if it is a pending order
+ ;ORDER  : Pending Order Number (PSJORD or PSGORD)
+ Q:ORDER'["P"  D REQDT^PSJLIUTL(ORDER)
+ Q
+ ;
+GETDUR(PAT,ORD,PKG,RAW) ;
+ ; PAT= Patient DFN
+ ; ORD= Order #
+ ; PKG= 5(UD), "IV"(IV), "P"(Pending)
+ N ACT,DUR,ND,ND25,F25,ND0,ND2,OLDORD S DUR="",ORD=+ORD K IVLIMIT
+ S:PKG="V" PKG="IV"
+ I PKG="P" S ND=$G(^PS(53.1,+ORD,0)) D  I '$G(OLDORD) Q DUR
+ . D PENDING(ORD) Q:DUR]""
+ . S ND0=$G(^PS(53.1,ORD,0)) I $P(ND0,U,24)="E" S OLDORD=$P(ND0,U,25) I OLDORD S PKG=$S(OLDORD["V":"IV",OLDORD["U":5,OLDORD["P":"P",1:"")
+ . Q:($G(OLDORD)'["P")
+ . D PENDING(OLDORD) S OLDORD=""
+ I PKG="IV" S ND2=$G(^PS(55,PAT,PKG,ORD,2)) I $P(ND2,U,8)="E" S OLDORD=$P(ND2,U,5) S:OLDORD'["V" OLDORD=""
+ I PKG=5 S ND0=$G(^PS(55,PAT,PKG,ORD,0)) I $P(ND0,U,24)="E" S OLDORD=$P(ND0,U,25) S:OLDORD'["U" OLDORD=""
+ S F25="^PS(55,PAT,PKG,ORD,2.5)" I '$G(OLDORD) Q:'$D(@(F25)) DUR
+ S ND25=$G(@(F25)) S DUR=$P(ND25,U,2) I DUR="" S DUR=$P(ND25,U,4) I DUR]"" S IVLIMIT=1
+ I DUR="",$G(OLDORD) S ORD=+OLDORD Q:'$D(@(F25)) DUR  D
+ . S ND25=$G(@(F25)) S DUR=$P(ND25,U,2) I DUR="" S DUR=$P(ND25,U,4) I DUR]"" S IVLIMIT=1
+ I '$G(RAW),DUR]"" S DUR=$$FMTDUR(DUR)
+ Q DUR
+ ;
+PENDING(PNDON) ;
+ S ND=$G(^PS(53.1,+ORD,0))
+ I ND S ND25=$S(($P(ND,U,15)=PAT):$G(^PS(53.1,+ORD,2.5)),1:"")
+ S DUR=$P(ND25,U,4) I DUR]"" S:$E(DUR)="m"!($E(DUR)="l")!($E(DUR)="d")!($E(DUR)="h") IVLIMIT=1 S DUR=$S($G(RAW):DUR,1:$$FMTDUR(DUR)) Q
+ S DUR=$P(ND25,U,2) I DUR]"" S DUR=$S($G(RAW):DUR,1:$$FMTDUR(DUR))
+ Q
+ ;
+FMTDUR(DURCODE) ;
+ N DUNIT,DNUM,BAD S BAD=0
+ ;PSJ*5*180 - Add PSJBADD variable
+ K PSJBADD S PSJBADD=0
+ S DUNIT=$E(DURCODE),DNUM=$P(DURCODE,DUNIT,2) I 'DNUM S BAD=1
+ I DUNIT'="",DUNIT'?1(1U,1L) S PSJBADD=1
+ S DUNIT=$S(DUNIT="D"!(DUNIT="d"):" day",DUNIT="H"!(DUNIT="h"):" hour",DUNIT="W":" week",DUNIT="L":" month",DUNIT="M":" minute",DUNIT="S":" second",DUNIT="m":" ml",DUNIT="l":" liter",1:"")
+ S:DUNIT="" BAD=1 I (DNUM'=1),(DUNIT'["ml") S DUNIT=DUNIT_"s"
+ I PSJBADD=1 S PSGACT=$TR($G(PSGACT),"F")
+ Q $S(PSJBADD=1:"*INVALID DURATION/LIMIT*",BAD:"",1:DNUM_DUNIT)
+ ;
+DURMIN(DCOD) ;
+ N DUR,DMIN,CHR S DUR="" F I=1:1:$L(DCOD) S CHR=$E(DCOD,I) I CHR?1N S DUR=DUR_CHR
+ S DMIN=DUR*$S(DCOD["L":43200,DCOD["W":10080,DCOD["M":1,DCOD["S":(1/60),DCOD["D":1440,1:0) S DMIN=+$FN(DMIN,"",1)
+ Q DMIN
+ ;
+DUR ;
+ N DUROUT,LABEL,IVLIMIT
+ Q:'$G(PSJORD)  S PSJL=""
+ S DUROUT=$$GETDUR^PSJLIVMD(PSGP,+PSJORD,$S(PSJORD["P":"P",1:"IV"))
+ S LABEL=$S($G(IVLIMIT):"IV Limit: ",1:"Duration: ") K IVLIMIT
+ S PSJL=$$SETSTR^VALM1(LABEL,PSJL,12,10)
+ S PSJL=PSJL_DUROUT
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m

@@ -1 @@
-PSJLMPRU        ;BIR/MLM-INPATIENT LISTMAN UD PROFILE UTILITIES ;27 Aug 98 / 8:45 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**16,58,85,110,185**;16 DEC 97;Build 6
-        ;
-        ; Reference to ^PSDRUG is supported by DBIA 2192.
-        ; Reference to ^PS(55 is supported by DBIA 2191.
-        ;
-PUD(DFN,ON,PSJF,DN)     ; Setup LM profile view for UD
-        N PSJFLAG,PSJV
-        ; Naked references on the two lines below refer to full reference ^PS(55,DFN,5,+ON in PSJF using indirection.
-        S ND=$G(@(PSJF_+ON_",0)")),SCH=$G(^(2)),ND4=$G(^(4)),ND6=$G(^(6)),NDP2=$G(^(.2)),PSJFLAG=$P(NDP2,U,7),X=$P(DN,U,2),DO=$S('X:"",1:$G(^(+X))) S:X=.2 DO=$P(DO,U,2)
-        S ND14=$G(@(PSJF_+ON_",14,0)")),RNDT="" I $P(ND14,"^",3) S ND14=$G(^($P(ND14,"^",3),0)),RNDT=$P(ND14,"^")
-        I "AO"[PSJC D
-        .;S V='$P(ND4,"^",UDU),PSJL=$$SETSTR^VALM1($S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",18)&($P(ND4,"^",19)!V):"H",$P(ND4,"^",22)&($P(ND4,"^",23)!V):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" "),PSJL,5,1)
-        .S V='$P(ND4,"^",UDU),PSJL=$$SETSTR^VALM1($S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",19)&$P(ND4,"^",18):"H",$P(ND4,"^",23)&$P(ND4,"^",22):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" "),PSJL,5,1)
-        .;S X=$S(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0)
-        .S PSJV=$S($P(NDP2,U,4)="D":"d",1:" ")_$S(+PSJSYSU=1&V:"->",+PSJSYSU=3&V:"->",1:"   ") I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
-        .S PSJL=$$SETSTR^VALM1(PSJV,PSJL,6,3)
-        ;I $S(PSJC["C":0,1:PSJC["B") S PSJL=$$SETSTR^VALM1($S($P(ND4,"^",12):"D",1:" ")_$S($P(ND,U,4)="I":"",PSJSYSU:"->",1:""),PSJL,6,3)
-        ;I $S(PSJC["C":0,1:PSJC["B") S PSJL=$$SETSTR^VALM1($S($P(ND4,"^",12):"D",1:" ")
-        S RTE=$P(ND,"^",3),SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2),STAT=$S($P(ND,"^",9)]"":$P(ND,"^",9),1:"NF"),PF=$E("*",$P(ND,"^",20)>0),PSGID=$P(SCH,"^",2),SD=$P(SCH,"^",4),SCH=$P(SCH,"^")
-        I STAT="A",$P(ND,U,27)="R" S STAT="R"
-        ;S NF=$P(DN,"^",3),WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0)
-        S NF="",WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0)
-        N PSJDISP F PSJDISP=0:0 S PSJDISP=$O(@(PSJF_+ON_",1,"_PSJDISP_")")) Q:'PSJDISP  D
-        .I $P($G(^PSDRUG(+$P($G(@(PSJF_+ON_",1,"_PSJDISP_",0)")),"^"),0)),"^",9)=1 S NF=1
-        NEW DRUGNAME,PSGID1,SD1,LEN,PSGID1,SD1 S LEN=$S($D(PSJEXPT):8,1:5)
-        F X="PSGID","SD" S @(X_1)=$S(PSJC["C":"*****",1:$E($$ENDTC^PSGMI(@X),1,LEN))
-        D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0)
-        F PSJX=0:0 S PSJX=$O(DRUGNAME(PSJX)) Q:'PSJX  D
-        . I PSJX=1 D
-        ..I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
-        ..S PSJL=$$SETSTR^VALM1($S($E(PSJS)="*":$P(PSJS,"^"),1:DRUGNAME(PSJX)),PSJL,9,39)
-        ..S PSJL=$$SETSTR^VALM1($S(PSJC["C":"?",PSJSCHT'="z":PSJSCHT,1:"?"),PSJL,50,3)
-        ..S PSJL=PSJL_PSGID1_"  "_SD1_"  "_$E(STAT,1)_"    "_$S($G(RNDT):$E($$ENDTC^PSGMI(RNDT),1,LEN),1:"")
-        ..I NF!WS!SM!PF S PSJL=$$SETSTR^VALM1($S(NF:"NF ",WS:"WS ",SM:$E("HSM",SM,3),1:""),PSJL,69,3) S:PF PSJL=$$SETSTR^VALM1("*",PSJL,79,1)
-        . I PSJX>1 S PSJL="",PSJL=$$SETSTR^VALM1(DRUGNAME(PSJX),PSJL,11,66)
-        . D SETTMP("PSJPRO",PSJL) I ($P(NDP2,U,4)="S"),STAT="P" D CNTRL^VALM10((PSJLN-1),9,9+$L(PSJL),IOINHI_IOBON,IOINORM,0)
-        D:$P(ND6,"^")]"" PTXT($P(ND6,"^"),"PSJPRO",10,66)
-        Q
-        ;
-PTXT(TXT,SUB,LM,RM)     ; Display Instructions/dosage ordered.
-        ;* Input:       TXT = Text to display.
-        ;                       SUB = First subscript for ^TMP node, ** MUST be PSJ namespace **
-        ;                       LM  = Begin display of text after LM spaces.
-        ;                       RM  = Length of display text.
-        ;
-        ;BHW;PSJ*5*185;Extra spaces causes display to "skip" part of the field.                      
-        ;S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD=""  D
-        S PSJL="",$P(PSJL," ",LM)=""
-        F X=1:1:$L(TXT," ") S WRD=$P(TXT," ",X) D
-        .;BHW;PSJ*5*185;check if end of string or just extra space.
-        .I WRD="" S PSJL=PSJL_" " Q
-        .I $L(PSJL_" "_WRD)'<RM D SETTMP(SUB,PSJL) S PSJL="",$P(PSJL," ",10)=""
-        .I $L(PSJL_" "_WRD)'<RM S PSJL=PSJL_" "_$E(WRD,1,(RM-10)) D SETTMP(SUB,PSJL) S PSJL="",$P(PSJL," ",10)="",WRD=$E(WRD,(RM-9),$L(WRD))
-        .S PSJL=PSJL_" "_WRD
-        D SETTMP(SUB,PSJL)
-        Q
-SETTMP(SUB,PSJL)        ;
-        S ^TMP(SUB,$J,PSJLN,0)=PSJL,PSJLN=PSJLN+1
-        Q
+PSJLMPRU ;BIR/MLM-INPATIENT LISTMAN UD PROFILE UTILITIES ;27 Aug 98 / 8:45 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**16,58,85,110**;16 DEC 97
+ ;
+ ; Reference to ^PSDRUG is supported by DBIA 2192.
+ ; Reference to ^PS(55 is supported by DBIA 2191.
+ ;
+PUD(DFN,ON,PSJF,DN) ; Setup LM profile view for UD
+ N PSJFLAG,PSJV
+ ; Naked references on the two lines below refer to full reference ^PS(55,DFN,5,+ON in PSJF using indirection.
+ S ND=$G(@(PSJF_+ON_",0)")),SCH=$G(^(2)),ND4=$G(^(4)),ND6=$G(^(6)),NDP2=$G(^(.2)),PSJFLAG=$P(NDP2,U,7),X=$P(DN,U,2),DO=$S('X:"",1:$G(^(+X))) S:X=.2 DO=$P(DO,U,2)
+ S ND14=$G(@(PSJF_+ON_",14,0)")),RNDT="" I $P(ND14,"^",3) S ND14=$G(^($P(ND14,"^",3),0)),RNDT=$P(ND14,"^")
+ I "AO"[PSJC D
+ .;S V='$P(ND4,"^",UDU),PSJL=$$SETSTR^VALM1($S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",18)&($P(ND4,"^",19)!V):"H",$P(ND4,"^",22)&($P(ND4,"^",23)!V):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" "),PSJL,5,1)
+ .S V='$P(ND4,"^",UDU),PSJL=$$SETSTR^VALM1($S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",19)&$P(ND4,"^",18):"H",$P(ND4,"^",23)&$P(ND4,"^",22):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" "),PSJL,5,1)
+ .;S X=$S(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0)
+ .S PSJV=$S($P(NDP2,U,4)="D":"d",1:" ")_$S(+PSJSYSU=1&V:"->",+PSJSYSU=3&V:"->",1:"   ") I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
+ .S PSJL=$$SETSTR^VALM1(PSJV,PSJL,6,3)
+ ;I $S(PSJC["C":0,1:PSJC["B") S PSJL=$$SETSTR^VALM1($S($P(ND4,"^",12):"D",1:" ")_$S($P(ND,U,4)="I":"",PSJSYSU:"->",1:""),PSJL,6,3)
+ ;I $S(PSJC["C":0,1:PSJC["B") S PSJL=$$SETSTR^VALM1($S($P(ND4,"^",12):"D",1:" ")
+ S RTE=$P(ND,"^",3),SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2),STAT=$S($P(ND,"^",9)]"":$P(ND,"^",9),1:"NF"),PF=$E("*",$P(ND,"^",20)>0),PSGID=$P(SCH,"^",2),SD=$P(SCH,"^",4),SCH=$P(SCH,"^")
+ I STAT="A",$P(ND,U,27)="R" S STAT="R"
+ ;S NF=$P(DN,"^",3),WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0)
+ S NF="",WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0)
+ N PSJDISP F PSJDISP=0:0 S PSJDISP=$O(@(PSJF_+ON_",1,"_PSJDISP_")")) Q:'PSJDISP  D
+ .I $P($G(^PSDRUG(+$P($G(@(PSJF_+ON_",1,"_PSJDISP_",0)")),"^"),0)),"^",9)=1 S NF=1
+ NEW DRUGNAME,PSGID1,SD1,LEN,PSGID1,SD1 S LEN=$S($D(PSJEXPT):8,1:5)
+ F X="PSGID","SD" S @(X_1)=$S(PSJC["C":"*****",1:$E($$ENDTC^PSGMI(@X),1,LEN))
+ D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0)
+ F PSJX=0:0 S PSJX=$O(DRUGNAME(PSJX)) Q:'PSJX  D
+ . I PSJX=1 D
+ ..I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
+ ..S PSJL=$$SETSTR^VALM1($S($E(PSJS)="*":$P(PSJS,"^"),1:DRUGNAME(PSJX)),PSJL,9,39)
+ ..S PSJL=$$SETSTR^VALM1($S(PSJC["C":"?",PSJSCHT'="z":PSJSCHT,1:"?"),PSJL,50,3)
+ ..S PSJL=PSJL_PSGID1_"  "_SD1_"  "_$E(STAT,1)_"    "_$S($G(RNDT):$E($$ENDTC^PSGMI(RNDT),1,LEN),1:"")
+ ..I NF!WS!SM!PF S PSJL=$$SETSTR^VALM1($S(NF:"NF ",WS:"WS ",SM:$E("HSM",SM,3),1:""),PSJL,69,3) S:PF PSJL=$$SETSTR^VALM1("*",PSJL,79,1)
+ . I PSJX>1 S PSJL="",PSJL=$$SETSTR^VALM1(DRUGNAME(PSJX),PSJL,11,66)
+ . D SETTMP("PSJPRO",PSJL) I ($P(NDP2,U,4)="S"),STAT="P" D CNTRL^VALM10((PSJLN-1),9,9+$L(PSJL),IOINHI_IOBON,IOINORM,0)
+ D:$P(ND6,"^")]"" PTXT($P(ND6,"^"),"PSJPRO",10,66)
+ Q
+ ;
+PTXT(TXT,SUB,LM,RM) ; Display Instructions/dosage ordered.
+ ;* Input:       TXT = Text to display.
+ ;                       SUB = First subscript for ^TMP node, ** MUST be PSJ namespace **
+ ;                       LM  = Begin display of text after LM spaces.
+ ;                       RM  = Length of display text.
+ ;                       
+ S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD=""  D
+ .I $L(PSJL_" "_WRD)'<RM D SETTMP(SUB,PSJL) S PSJL="",$P(PSJL," ",10)=""
+ .I $L(PSJL_" "_WRD)'<RM S PSJL=PSJL_" "_$E(WRD,1,(RM-10)) D SETTMP(SUB,PSJL) S PSJL="",$P(PSJL," ",10)="",WRD=$E(WRD,(RM-9),$L(WRD))
+ .S PSJL=PSJL_" "_WRD
+ D SETTMP(SUB,PSJL)
+ Q
+SETTMP(SUB,PSJL) ;
+ S ^TMP(SUB,$J,PSJLN,0)=PSJL,PSJLN=PSJLN+1
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUDE.m

@@ -1 @@
-PSJLMUDE        ;BIR/MLM-SHOW FIELDS FOR EDIT (LISTMAN STYLE) ;01 JUNE 00 / 2:40 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**7,47,50,63,64,58,80,116,110,111,164,175,201**;16 DEC 97;Build 2
-         ;NFI-UD Fr#:2 chgs@init+4 to display non-formulary (N/F)
-         ;also chgs @init+23
-        ;
-        ; Reference to ^PS(55 is supported by DBIA# 2191
-        ; Reference to ^PSDRUG is supported by DBIA 2192
-        ;
-INIT(PSGP,PSGORD)       ;
-        N D,ND,PSJBCMA,PSJL,PSJLM,PSJLN,Q,QQ,PSJDUR K ^TMP("PSJUDE",$J)
-        K:$G(PSJNORD) PSGOEEF S PSJLN=1
-        D CLEAN^VALM10
-        S PSJL=$S($D(PSGEFN(1)):$E(" *",PSGEFN(1)+1)_"(1)",1:"   "),PSJL=$$SETSTR^VALM1("Orderable Item: "_PSGPDN_$$OINF^PSJDIN(PSGPD),PSJL,5,74) D  D SETTMP D:$G(PSGOEEF(108))!($G(PSGOEEF(101))) HILITE(1)
-        . NEW Q,PSJDDA,PSJVD F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q  S PSJDDA(+$G(^(Q,0)))=""
-        . S PSJVD=$$DINFLUD^PSJDIN(PSGPD,.PSJDDA)
-        . S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,80)
-        . D:PSJVD]"" CNTRL^VALM10(1,75,5,IORVON,IORVOFF,0)
-        I $G(PSJORD)["P" D REQDT^PSJLIVMD(PSJORD)
-        S PSJL="Instructions: "_PSGOINST D PTXT^PSJLMPRU(PSJL,"PSJUDE",6,80)
-        S PSJL=$S($D(PSGEFN(2)):$E(" *",PSGEFN(2)+1)_"(2)",1:"    "),PSJL=$$SETSTR^VALM1("Dosage Ordered: "_PSGDO,PSJL,5,76) D SETTMP D:$G(PSGOEEF(109)) HILITE(2)
-        I $G(PSGRDTX) S PSJDUR=$$FMTDUR^PSJLIVMD($P($G(PSGRDTX),U,2))
-        I $G(PSJORD),($G(PSJDUR)="") S P=$S(PSJORD["U":5,PSJORD["V":"IV",PSJORD["P":"P",1:-1) S PSJDUR=$$GETDUR^PSJLIVMD(PSGP,+PSJORD,P)
-        S PSJL=$$SETSTR^VALM1("Duration: "_$G(PSJDUR),PSJL,11,25)
-        S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(3)):$E(" *",PSGEFN(3)+1)_"(3)",1:"    ")_"Start: "_$P(PSGSDN,U,2),PSJL,54,26) D:$G(PSGOEEF(10)) HILITE(3)
-        I $G(PSGORD)["P" N ND0,OLDO S ND0=@(PSGOEEWF_"0)") I $P(ND0,"^",24)="R" S OLDO=$P(ND0,"^",25) I OLDO,(OLDO["U") D
-        . N OSTRT,OSTRTN S OSTRT=$G(@("^PS(55,"_PSGP_",5,"_+OLDO_",2)")),OSTRT=$P(OSTRT,"^",2) Q:'OSTRT  S OSTRTN=$$ENDTC^PSGMI(+OSTRT)
-        . S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(3)):$E(" *",PSGEFN(3)+1)_"(3)",1:"    ")_"Start: "_OSTRTN,PSJL,54,26)
-        D SETTMP
-        S PSJL=$S($D(PSGEFN(4)):$E(" *",PSGEFN(4)+1)_"(4)",1:"    "),PSJL=$$SETSTR^VALM1("Med Route: "_PSGMRN,PSJL,10,35) D:$G(PSGOEEF(3)) HILITE(4)
-        I $G(PSJORD)["P" N PSGRNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,PSGORD) S:PSGRNDT PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,56,32)
-        I '$G(PSGRNDT),$G(PSGRDTX) D
-        . I $D(PSGRDTX)<10 S PSGRSDN=$$ENDTC^PSGMI(+PSGRDTX),PSJL=$$SETSTR^VALM1("REQUESTED START: "_PSGRSDN,PSJL,48,32) Q
-        . I $G(PSGRDTX(+$G(PSJORD),"PSGRSD")),$P($G(PSGSDN),U,2) S PSGRSDN=$$ENDTC^PSGMI(PSGRDTX(+PSJORD,"PSGRSD")),PSJL=$$SETSTR^VALM1("Calc Start: "_PSGRSDN,PSJL,53,32) D
-        .. I PSGSD'=PSGRDTX(+PSJORD,"PSGRSD") D CNTRL^VALM10(5,53,80,IORVON,IORVOFF)
-        ; Indirect reference in PSGOEEWF below refers to either ^PS(53.1 or ^PS(55,DFN,5,. Naked reference refers to full indirect reference
-        I $G(PSJORD)["U" N ND14 S ND14=$G(@(PSGOEEWF_"14,0)")) I ND14]"" S ND14=$G(^($P(ND14,"^",3),0)),RNDT=$P(ND14,"^") I RNDT D
-        . N PSGRNDT S PSGRNDT=$$ENDTC^PSGMI(+RNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,56,32)
-        D SETTMP
-        I PSGORD]"" S PSJBCMA=$$BCMALG^PSJUTL2(PSGP,PSGORD)
-        I $G(PSJBCMA)]"" S PSJL=$$SETSTR^VALM1(PSJBCMA,PSJL,1,52)
-        S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(5)):$E(" *",PSGEFN(5)+1)_"(5)",1:"     ")_" Stop: "_$P(PSGFDN,U,2),PSJL,54,26) D SETTMP D:$G(PSGOEEF(25))!($G(PSGOEEF(34))) HILITE(5)
-        S PSJL=$S($D(PSGEFN(6)):$E(" *",PSGEFN(6)+1)_"(6)",1:"   "),PSJL=$$SETSTR^VALM1("Schedule Type: "_PSGSTN,PSJL,6,45) D:$G(PSGOEEF(7)) HILITE(6)
-        I $G(PSJORD)["P",$G(PSGRDTX(+$G(PSJORD),"PSGRFD")),$P($G(PSGFDN),U,2) S PSGRFDN=$$ENDTC^PSGMI(PSGRDTX(+PSJORD,"PSGRFD")),PSJL=$$SETSTR^VALM1("Calc Stop: "_PSGRFDN,PSJL,54,26) D
-        . I PSGFD'=PSGRDTX(+PSJORD,"PSGRFD") D CNTRL^VALM10(7,54,80,IORVON,IORVOFF)
-        D SETTMP
-        S PSGSMN=$P("NO^YES",U,PSGSM+1)
-        S PSJL=$S($D(PSGEFN(8)):$E(" *",PSGEFN(8)+1)_"(8)",1:"   "),PSJL=$$SETSTR^VALM1("Schedule: "_PSGSCH_$G(SCHMSG),PSJL,11,68) D SETTMP D:$G(PSGOEEF(26)) HILITE(8)
-        S PSJL=$S($D(PSGEFN(9)):$E(" *",PSGEFN(9)+1)_"(9)",1:"   "),PSJL=$$SETSTR^VALM1("Admin Times: "_PSGAT,PSJL,8,71) D SETTMP D:$G(PSGOEEF(39))!($G(PSGOEEF(41))) HILITE(9)
-        S PSJL=$S($D(PSGEFN(10)):$E(" *",PSGEFN(10)+1)_"(10)",1:"   "),PSJL=$$SETSTR^VALM1("Provider: "_PSGPRN,PSJL,11,68) D:$G(PSGOEEF(1)) HILITE(10) D SETTMP
-        ;S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(7)):$E(" *",PSGEFN(7)+1)_"(7)",1:"   ")_"Self Med: "_PSGSMN,PSJL,56,24) S:PSGSM&PSGHSM PSJL=$$SETSTR^VALM1("  (HS)",PSJL,71,7) D SETTMP D:$G(PSGOEEF(5)) HILITE(7)
-        S PSJL=$S($D(PSGEFN(11)):$E(" *",PSGEFN(11))_"(11)",1:"   ")_" Special Instructions"_$S($P(PSGSI,"^",2)=1:"!: ",1:": ")_$P(PSGSI,"^") D PTXT^PSJLMPRU(PSJL,"PSJUDE",1,80)
-        S PSJL="" D SETTMP D:$G(PSGOEEF(8)) HILITE(11)
-        ; E3R 16130
-        I $O(^PS(53.45,PSJSYSP,2,1)) F  S PSJL="" D SETTMP Q:PSJLN>15
-        S PSJL=$S($D(PSGEFN(12)):$E(" *",PSGEFN(12))_" (12)",1:"   ")_" Dispense Drug",PSJL=$$SETSTR^VALM1("U/D",PSJL,54,60),PSJL=$$SETSTR^VALM1("Inactive Date",PSJL,65,16) D SETTMP,CNTRL^VALM10(13,1,80,IOUON,IOUOFF,0)
-        ;S $P(PSJL,"-",80)="" D SETTMP
-        NEW PSJX
-        F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q  S ND=$G(^(Q,0)) D
-        .S D=$P(ND,"^"),PSGID=$P(ND,"^",3) I PSGID S PSGID=$$ENDTC^PSGMI(PSGID)
-        .S D=$S(D="":"NOT FOUND",'$D(^PSDRUG(D,0)):D,$P(^(0),"^")]"":$P(^(0),"^"),1:D_";PSDRUG(")
-        .S PSJL="      "_D_$$DDNF^PSJDIN(+ND),PSJL=$$SETSTR^VALM1($S($P(ND,"^",2):$S($P(ND,"^",2)=.5:"1/2",$P(ND,"^",2)=.25:"1/4",1:$P(ND,"^",2)),$P(ND,"^",2)=0:0,1:1),PSJL,54,63) S:PSGID PSJL=$$SETSTR^VALM1(PSGID,PSJL,65,16) D  D SETTMP
-        ..S PSJX=$G(PSJX)+1
-        ..I $G(PSGOEEF(109)) D CNTRL^VALM10(13+PSJX,7,73,IORVON_IOBON,IORVOFF_IOBOFF,0)
-        I $S(PSGORD["P":$O(^PS(53.1,+$G(PSGORD),12,0)),1:$O(^PS(55,PSGP,5,+PSGORD,12,0))) S PSJL="Provider Comments:" D SETTMP S PSJL="" D
-        .F Q=0:0 S Q=$S(PSGORD["P":$O(^PS(53.1,+$G(PSGORD),12,Q)),1:$O(^PS(55,PSGP,5,+PSGORD,12,Q))) Q:'Q  S PSJL=$G(^(Q,0)) D SETTMP
-        D SETTMP S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(7)):$E(" *",PSGEFN(7)+1)_"(7)",1:"   ")_"Self Med: "_PSGSMN,PSJL,1,24)
-        S:PSGSM&PSGHSM PSJL=$$SETSTR^VALM1("  (HS)",PSJL,16,7) D SETTMP D:$G(PSGOEEF(5)) HILITE(7)
-        D SETTMP S PSJL="Entry By: "_PSGEBN,PSJL=$$SETSTR^VALM1("Entry Date: "_$P(PSGLIN,U,2),PSJL,51,39) D SETTMP
-        I $G(PSGLRN) D SETTMP S PSJL="Renewed By: "_$$ENNPN^PSGMI($P(PSGLRN,"^",2)) D SETTMP
-        D SETTMP S PSJL="(13)"_" Comments:"
-        D:'$O(^PS(53.45,PSJSYSP,1,0)) SETTMP
-        D SETTMP F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,1,Q)) Q:'Q  S PSJWPL=PSJL_$S($E(PSJL)=" ":"",1:" ")_$G(^(Q,0)),PSJL="" D DISPLAY
-        D SETTMP
-        I PSGORD["P",($P($G(^PS(53.1,+PSGORD,0)),U,9)="P"),$O(^PS(53.1,+PSGORD,10,0)) D
-        .D SETTMP S PSJL="Order Checks:" D SETTMP
-        .F Q=0:0 S Q=$O(^PS(53.1,+PSGORD,10,Q)) Q:'Q  D
-        ..S PSJL="" D SETTMP S PSJL=$G(^PS(53.1,+PSGORD,10,Q,0)) D SETTMP
-        ..S PSJL="Overriding Provider: "_$P($G(^PS(53.1,+PSGORD,10,Q,1)),U) D SETTMP
-        ..S PSJL="Overriding Reason: " F X=0:0 S X=$O(^PS(53.1,+PSGORD,10,Q,2,X)) Q:'X   D
-        ...S PSJL=PSJL_$G(^PS(53.1,+PSGORD,10,Q,2,X,0)) D SETTMP S PSJL="                   "
-ACTFLG  ;
-        S ND4=$S(PSGORD["P":$G(^PS(53.1,+PSGORD,4)),1:$G(^PS(55,PSGP,5,+PSGORD,4)))
-        S AT="",Y="12,13,D,18,19,H1,22,23,H0,15,16,R" F X=1:3:12 I $P(ND4,"^",$P(Y,",",X)),$P(ND4,"^",$P(Y,",",X+1)) S AT=$P(Y,",",X+2) Q
-        I AT="",'$P(ND4,"^",$S($P(PSJSYSU,";",3)>1:3,1:1)) S AT="V"_$S($P(ND4,"^",18):"H1",$P(ND4,"^",22):"H0",$P(ND4,"^",15):"R",1:"")
-        I AT]"" D
-        .S PSJL="" D SETTMP
-        .S PSJL="ORDER "_$S(AT["V":"NOT VERIFIED"_$S($P(AT,"V",2)="":"",1:" ("_$S(AT["H1":"ON HOLD",AT["H0":"OFF HOLD",1:"RENEWAL")_")"),1:"MARKED TO BE "_$S(AT["D":"CANCELLED",AT["H1":"PLACED ON HOLD",AT["H0":"TAKEN OFF OF HOLD",1:"RENEWED"))
-        I AT'["V",AT["H1",$D(^PS(55,PSGP,5.1)) S AT=^(5.1) I $P(AT,"^",7),$P(AT,"^",10)]"" S PSJL=PSJL_"  ("_$P(AT,"^",10)_")"
-        D SETTMP
-        S VALMCNT=PSJLN-1
-        K PSGSMN,Q,Y,Y1,Y2,PSGLRN
-        S VALM("TITLE")=PSGSTAT_" UNIT DOSE "_$S((PSGSTAT="PENDING")&($G(PSGPRIO)]""):"("_PSGPRIO_")",$G(PSGPRIO)="DONE":"("_PSGPRIO_")",1:"") I $D(PSJLMP2) S VALMBG=16 K PSJLMP2
-TEST    ;
-        I $G(PSGPFLG) S VALMSG="INVALID ORDERABLE ITEM"
-        I $G(PSGDI) S VALMSG=$S($G(VALMSG)="":"INVALID",1:VALMSG_",")_" DISPENSE DRUG"
-        I $G(PSGPI) S VALMSG=$S($G(VALMSG)="":"INVALID",1:VALMSG_",")_" PROVIDER"
-        Q
-DISPLAY ;
-        S PSJL=PSJWPL D SETTMP
-        ;F X=1:1 S WRD=$P(PSJWPL," ",X) Q:WRD=""  D
-        ;.I $L(PSJL_" "_WRD)'<80 D SETTMP S PSJL=$P(PSJWPL,PSJL,2) S:$E(PSJL,1)=" " PSJL=$E(PSJL,2,999),PSJWPL="" Q
-        ;.S PSJL=PSJL_$S(PSJL="":"",1:" ")_WRD
-        Q
-        ;
-SETTMP  ;
-        S ^TMP("PSJUDE",$J,PSJLN,0)=PSJL,PSJLN=PSJLN+1,PSJL=""
-        Q
-        ;
-HILITE(FLD)     ; 
-        N COL,LIN,WID,X
-        ;Q:'$G(PSGOEENO)
-        S X="$T("_FLD_"^PSJLMUDE)",@("X="_X),X=$P(X,";;",2),LIN=+X,COL=$P(X,",",2),LAB=$P(X,",",3),X=$P(X,",",4),WID=(LAB+$L(@X))
-        ;D CNTRL^VALM10(LIN,COL,WID,IORVON_IOBON,IOINORM,0)
-        I FLD=7 S LIN=+$G(PSJLN)-1 Q:LIN<13
-        D CNTRL^VALM10(LIN,COL,WID,IORVON_IOBON,IORVOFF_IOBOFF,0)
-        Q
-        ;
-1       ;;1,5,16,PSGPDN
-2       ;;3,5,16,PSGDO
-3       ;;4,58,7,PSGSDN
-4       ;;5,10,11,PSGMRN
-5       ;;6,59,6,PSGFDN
-6       ;;7,6,15,PSGSTN
-7       ;;18,5,14,PSGSMN
-8       ;;8,11,12,PSGSCH
-9       ;;9,8,13,PSGAT
-10      ;;10,11,10,PSGPRN
-11      ;;11,7,22,PSGSI
-ENKILL  ;
-        K PSGAT,PSGEB,PSGEFN,PSGFD,PSGHSM,PSGNEFD,PSGNESD,PSGOEEF,PSGOEER,PSGOFD,PSGOHSM,PSGOMR,PSGOMRN,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGOSD,PSGOSM,PSGOST,PSGPD,PSGPDN,PSGPR,PSGSD,PSGSM Q
+PSJLMUDE ;BIR/MLM-SHOW FIELDS FOR EDIT (LISTMAN STYLE) ;01 JUNE 00 / 2:40 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**7,47,50,63,64,58,80,116,110,111,164,175**;16 DEC 97;Build 18
+ ;NFI-UD Fr#:2 chgs@init+4 to display non-formulary (N/F)
+ ;also chgs @init+23
+ ;
+ ; Reference to ^PS(55 is supported by DBIA# 2191
+ ; Reference to ^PSDRUG is supported by DBIA 2192
+ ;
+INIT(PSGP,PSGORD) ;
+ N D,ND,PSJBCMA,PSJL,PSJLM,PSJLN,Q,QQ,PSJDUR K ^TMP("PSJUDE",$J)
+ K:$G(PSJNORD) PSGOEEF S PSJLN=1
+ D CLEAN^VALM10
+ S PSJL=$S($D(PSGEFN(1)):$E(" *",PSGEFN(1)+1)_"(1)",1:"   "),PSJL=$$SETSTR^VALM1("Orderable Item: "_PSGPDN_$$OINF^PSJDIN(PSGPD),PSJL,5,74) D  D SETTMP D:$G(PSGOEEF(108))!($G(PSGOEEF(101))) HILITE(1)
+ . N Q,PSJDDA,PSJVD F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q  S PSJDDA(+$G(^(Q,0)))=""
+ . S PSJVD=$$DINFLUD^PSJDIN(PSGPD,.PSJDDA)
+ . S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,80)
+ . D:PSJVD]"" CNTRL^VALM10(1,75,5,IORVON,IORVOFF,0)
+ I $G(PSJORD)["P" D REQDT^PSJLIVMD(PSJORD)
+ S PSJL="Instructions: "_PSGOINST D PTXT^PSJLMPRU(PSJL,"PSJUDE",6,120)
+ S PSJL=$S($D(PSGEFN(2)):$E(" *",PSGEFN(2)+1)_"(2)",1:"    "),PSJL=$$SETSTR^VALM1("Dosage Ordered: "_PSGDO,PSJL,5,76) D SETTMP D:$G(PSGOEEF(109)) HILITE(2)
+ I $G(PSGRDTX) S PSJDUR=$$FMTDUR^PSJLIVMD($P($G(PSGRDTX),U,2))
+ I $G(PSJORD),($G(PSJDUR)="") S P=$S(PSJORD["U":5,PSJORD["V":"IV",PSJORD["P":"P",1:-1) S PSJDUR=$$GETDUR^PSJLIVMD(PSGP,+PSJORD,P)
+ S PSJL=$$SETSTR^VALM1("Duration: "_$G(PSJDUR),PSJL,11,25)
+ S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(3)):$E(" *",PSGEFN(3)+1)_"(3)",1:"    ")_"Start: "_$P(PSGSDN,U,2),PSJL,54,26) D:$G(PSGOEEF(10)) HILITE(3)
+ I $G(PSGORD)["P" N ND0,OLDO S ND0=@(PSGOEEWF_"0)") I $P(ND0,"^",24)="R" S OLDO=$P(ND0,"^",25) I OLDO,(OLDO["U") D
+ . N OSTRT,OSTRTN S OSTRT=$G(@("^PS(55,"_PSGP_",5,"_+OLDO_",2)")),OSTRT=$P(OSTRT,"^",2) Q:'OSTRT  S OSTRTN=$$ENDTC^PSGMI(+OSTRT)
+ . S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(3)):$E(" *",PSGEFN(3)+1)_"(3)",1:"    ")_"Start: "_OSTRTN,PSJL,54,26)
+ D SETTMP
+ S PSJL=$S($D(PSGEFN(4)):$E(" *",PSGEFN(4)+1)_"(4)",1:"    "),PSJL=$$SETSTR^VALM1("Med Route: "_PSGMRN,PSJL,10,35) D:$G(PSGOEEF(3)) HILITE(4)
+ I $G(PSJORD)["P" N PSGRNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,PSGORD) S:PSGRNDT PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,56,32)
+ I '$G(PSGRNDT),$G(PSGRDTX) D
+ . I $D(PSGRDTX)<10 S PSGRSDN=$$ENDTC^PSGMI(+PSGRDTX),PSJL=$$SETSTR^VALM1("REQUESTED START: "_PSGRSDN,PSJL,48,32) Q
+ . I $G(PSGRDTX(+$G(PSJORD),"PSGRSD")),$P($G(PSGSDN),U,2) S PSGRSDN=$$ENDTC^PSGMI(PSGRDTX(+PSJORD,"PSGRSD")),PSJL=$$SETSTR^VALM1("Calc Start: "_PSGRSDN,PSJL,53,32) D
+ .. I PSGSD'=PSGRDTX(+PSJORD,"PSGRSD") D CNTRL^VALM10(5,53,80,IORVON,IORVOFF)
+ ; Indirect reference in PSGOEEWF below refers to either ^PS(53.1 or ^PS(55,DFN,5,. Naked reference refers to full indirect reference
+ I $G(PSJORD)["U" N ND14 S ND14=$G(@(PSGOEEWF_"14,0)")) I ND14]"" S ND14=$G(^($P(ND14,"^",3),0)),RNDT=$P(ND14,"^") I RNDT D
+ . N PSGRNDT S PSGRNDT=$$ENDTC^PSGMI(+RNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,56,32)
+ D SETTMP
+ I PSGORD]"" S PSJBCMA=$$BCMALG^PSJUTL2(PSGP,PSGORD)
+ I $G(PSJBCMA)]"" S PSJL=$$SETSTR^VALM1(PSJBCMA,PSJL,1,52)
+ S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(5)):$E(" *",PSGEFN(5)+1)_"(5)",1:"     ")_" Stop: "_$P(PSGFDN,U,2),PSJL,54,26) D SETTMP D:$G(PSGOEEF(25))!($G(PSGOEEF(34))) HILITE(5)
+ S PSJL=$S($D(PSGEFN(6)):$E(" *",PSGEFN(6)+1)_"(6)",1:"   "),PSJL=$$SETSTR^VALM1("Schedule Type: "_PSGSTN,PSJL,6,45) D:$G(PSGOEEF(7)) HILITE(6)
+ I $G(PSJORD)["P",$G(PSGRDTX(+$G(PSJORD),"PSGRFD")),$P($G(PSGFDN),U,2) S PSGRFDN=$$ENDTC^PSGMI(PSGRDTX(+PSJORD,"PSGRFD")),PSJL=$$SETSTR^VALM1("Calc Stop: "_PSGRFDN,PSJL,54,26) D
+ . I PSGFD'=PSGRDTX(+PSJORD,"PSGRFD") D CNTRL^VALM10(7,54,80,IORVON,IORVOFF)
+ D SETTMP
+ S PSGSMN=$P("NO^YES",U,PSGSM+1)
+ S PSJL=$S($D(PSGEFN(8)):$E(" *",PSGEFN(8)+1)_"(8)",1:"   "),PSJL=$$SETSTR^VALM1("Schedule: "_PSGSCH_$G(SCHMSG),PSJL,11,68) D SETTMP D:$G(PSGOEEF(26)) HILITE(8)
+ S PSJL=$S($D(PSGEFN(9)):$E(" *",PSGEFN(9)+1)_"(9)",1:"   "),PSJL=$$SETSTR^VALM1("Admin Times: "_PSGAT,PSJL,8,71) D SETTMP D:$G(PSGOEEF(39))!($G(PSGOEEF(41))) HILITE(9)
+ S PSJL=$S($D(PSGEFN(10)):$E(" *",PSGEFN(10)+1)_"(10)",1:"   "),PSJL=$$SETSTR^VALM1("Provider: "_PSGPRN,PSJL,11,68) D:$G(PSGOEEF(1)) HILITE(10) D SETTMP
+ S PSJL=$S($D(PSGEFN(11)):$E(" *",PSGEFN(11))_"(11)",1:"   ")_" Special Instructions"_$S($P(PSGSI,"^",2)=1:"!: ",1:": ")_$P(PSGSI,"^") D PTXT^PSJLMPRU(PSJL,"PSJUDE",1,80)
+ S PSJL="" D SETTMP D:$G(PSGOEEF(8)) HILITE(11)
+ ; E3R 16130
+ I $O(^PS(53.45,PSJSYSP,2,1)) F  S PSJL="" D SETTMP Q:PSJLN>15
+ S PSJL=$S($D(PSGEFN(12)):$E(" *",PSGEFN(12))_" (12)",1:"   ")_" Dispense Drug",PSJL=$$SETSTR^VALM1("U/D",PSJL,54,60),PSJL=$$SETSTR^VALM1("Inactive Date",PSJL,65,16) D SETTMP,CNTRL^VALM10(13,1,80,IOUON,IOUOFF,0)
+ N PSJX,PSGID
+ F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q  S ND=$G(^(Q,0)) D
+ .S D=$P(ND,"^"),PSGID=$P(ND,"^",3) I PSGID S PSGID=$$ENDTC^PSGMI(PSGID)
+ .S D=$S(D="":"NOT FOUND",'$D(^PSDRUG(D,0)):D,$P(^(0),"^")]"":$P(^(0),"^"),1:D_";PSDRUG(")
+ .S PSJL="      "_D_$$DDNF^PSJDIN(+ND),PSJL=$$SETSTR^VALM1($S($P(ND,"^",2):$S($P(ND,"^",2)=.5:"1/2",$P(ND,"^",2)=.25:"1/4",1:$P(ND,"^",2)),$P(ND,"^",2)=0:0,1:1),PSJL,54,63) S:PSGID PSJL=$$SETSTR^VALM1(PSGID,PSJL,65,16) D  D SETTMP
+ ..S PSJX=$G(PSJX)+1
+ ..I $G(PSGOEEF(109)) D CNTRL^VALM10(13+PSJX,7,73,IORVON_IOBON,IORVOFF_IOBOFF,0)
+ I $S(PSGORD["P":$O(^PS(53.1,+$G(PSGORD),12,0)),1:$O(^PS(55,PSGP,5,+PSGORD,12,0))) S PSJL="Provider Comments:" D SETTMP S PSJL="" D
+ .F Q=0:0 S Q=$S(PSGORD["P":$O(^PS(53.1,+$G(PSGORD),12,Q)),1:$O(^PS(55,PSGP,5,+PSGORD,12,Q))) Q:'Q  S PSJL=$G(^(Q,0)) D SETTMP
+ D SETTMP S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(7)):$E(" *",PSGEFN(7)+1)_"(7)",1:"   ")_"Self Med: "_PSGSMN,PSJL,1,24)
+ S:PSGSM&PSGHSM PSJL=$$SETSTR^VALM1("  (HS)",PSJL,16,7) D SETTMP D:$G(PSGOEEF(5)) HILITE(7)
+ D SETTMP S PSJL="Entry By: "_PSGEBN,PSJL=$$SETSTR^VALM1("Entry Date: "_$P(PSGLIN,U,2),PSJL,51,39) D SETTMP
+ I $G(PSGLRN) D SETTMP S PSJL="Renewed By: "_$$ENNPN^PSGMI($P(PSGLRN,"^",2)) D SETTMP
+ D SETTMP S PSJL="(13)"_" Comments:"
+ D:'$O(^PS(53.45,PSJSYSP,1,0)) SETTMP
+ D SETTMP F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,1,Q)) Q:'Q  S PSJWPL=PSJL_$S($E(PSJL)=" ":"",1:" ")_$G(^(Q,0)),PSJL="" D DISPLAY
+ D SETTMP
+ I PSGORD["P",($P($G(^PS(53.1,+PSGORD,0)),U,9)="P"),$O(^PS(53.1,+PSGORD,10,0)) D
+ .D SETTMP S PSJL="Order Checks:" D SETTMP
+ .F Q=0:0 S Q=$O(^PS(53.1,+PSGORD,10,Q)) Q:'Q  D
+ ..S PSJL="" D SETTMP S PSJL=$G(^PS(53.1,+PSGORD,10,Q,0)) S PSJWPL=PSJL D DISPLAY
+ ..S PSJL="Overriding Provider: "_$P($G(^PS(53.1,+PSGORD,10,Q,1)),U) D SETTMP
+ ..S PSJL="Overriding Reason: " F X=0:0 S X=$O(^PS(53.1,+PSGORD,10,Q,2,X)) Q:'X   D
+ ...S PSJL=PSJL_$G(^PS(53.1,+PSGORD,10,Q,2,X,0)) D SETTMP S PSJL="                   "
+ACTFLG ;
+ N ND4,AT,Y,X
+ S ND4=$S(PSGORD["P":$G(^PS(53.1,+PSGORD,4)),1:$G(^PS(55,PSGP,5,+PSGORD,4)))
+ S AT="",Y="12,13,D,18,19,H1,22,23,H0,15,16,R" F X=1:3:12 I $P(ND4,"^",$P(Y,",",X)),$P(ND4,"^",$P(Y,",",X+1)) S AT=$P(Y,",",X+2) Q
+ I AT="",'$P(ND4,"^",$S($P(PSJSYSU,";",3)>1:3,1:1)) S AT="V"_$S($P(ND4,"^",18):"H1",$P(ND4,"^",22):"H0",$P(ND4,"^",15):"R",1:"")
+ I AT]"" D
+ .S PSJL="" D SETTMP
+ .S PSJL="ORDER "_$S(AT["V":"NOT VERIFIED"_$S($P(AT,"V",2)="":"",1:" ("_$S(AT["H1":"ON HOLD",AT["H0":"OFF HOLD",1:"RENEWAL")_")"),1:"MARKED TO BE "_$S(AT["D":"CANCELLED",AT["H1":"PLACED ON HOLD",AT["H0":"TAKEN OFF OF HOLD",1:"RENEWED"))
+ I AT'["V",AT["H1",$D(^PS(55,PSGP,5.1)) S AT=^(5.1) I $P(AT,"^",7),$P(AT,"^",10)]"" S PSJL=PSJL_"  ("_$P(AT,"^",10)_")"
+ D SETTMP
+ S VALMCNT=PSJLN-1
+ K PSGSMN,Q,Y,Y1,Y2,PSGLRN
+ S VALM("TITLE")=PSGSTAT_" UNIT DOSE "_$S((PSGSTAT="PENDING")&($G(PSGPRIO)]""):"("_PSGPRIO_")",$G(PSGPRIO)="DONE":"("_PSGPRIO_")",1:"") I $D(PSJLMP2) S VALMBG=16 K PSJLMP2
+TEST ;
+ I $G(PSGPFLG) S VALMSG="INVALID ORDERABLE ITEM"
+ I $G(PSGDI) S VALMSG=$S($G(VALMSG)="":"INVALID",1:VALMSG_",")_" DISPENSE DRUG"
+ I $G(PSGPI) S VALMSG=$S($G(VALMSG)="":"INVALID",1:VALMSG_",")_" PROVIDER"
+ Q
+ ;
+DISPLAY ;
+ N X,LEN,LIM,PCS
+ S LIM=$L(PSJWPL," "),PCS=1
+ F X=1:1:LIM S LEN=$L($P(PSJWPL," ",PCS,X)) D
+ . I LEN'<72!(X=LIM) D
+ .. S PSJL=$P(PSJWPL," ",PCS,X)
+ .. I PCS>1 S PSJL="   "_PSJL
+ .. S PCS=X+1
+ .. D SETTMP
+ Q 
+ ;
+SETTMP ;
+ S ^TMP("PSJUDE",$J,PSJLN,0)=PSJL,PSJLN=PSJLN+1,PSJL=""
+ Q
+ ;
+HILITE(FLD) ; 
+ N COL,LAB,LIN,WID,X
+ S X="$T("_FLD_"^PSJLMUDE)",@("X="_X),X=$P(X,";;",2),LIN=+X,COL=$P(X,",",2),LAB=$P(X,",",3),X=$P(X,",",4),WID=(LAB+$L(@X))
+ I FLD=7 S LIN=+$G(PSJLN)-1 Q:LIN<13
+ D CNTRL^VALM10(LIN,COL,WID,IORVON_IOBON,IORVOFF_IOBOFF,0)
+ Q
+ ;
+1 ;;1,5,16,PSGPDN
+2 ;;3,5,16,PSGDO
+3 ;;4,58,7,PSGSDN
+4 ;;5,10,11,PSGMRN
+5 ;;6,59,6,PSGFDN
+6 ;;7,6,15,PSGSTN
+7 ;;18,5,14,PSGSMN
+8 ;;8,11,12,PSGSCH
+9 ;;9,8,13,PSGAT
+10 ;;10,11,10,PSGPRN
+11 ;;11,7,22,PSGSI
+ENKILL ;
+ K PSGAT,PSGDO,PSGEB,PSGEFN,PSGFD,PSGFDN,PSGHSM,PSGNEFD,PSGNESD,PSGOEEF,PSGOEER,PSGOFD,PSGOHSM,PSGOMR,PSGMRN,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGOSD
+ K PSGOSM,PSGOST,PSGPD,PSGPDN,PSGPR,PSGSD,PSGSM,PSGOINST,PSGPRN,PSGRFDN,PSGRSDN,PSGSCH,PSGSDN,PSGSI,PSGSTN,PSJWPL,RNDT
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m

@@ -1 @@
-PSJLMUT1        ;BIR/MLM-DRUG NAME DISPLAY ;05 Feb 98 / 1:39 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**4,27,29,49,58,107,110,146,175,201**;16 DEC 97;Build 2
-        ;
-        ; Reference to ^PS(55 is supported by DBIA# 2191.
-        ; Reference to ^PS(50.7 is supported by DBIA# 2180.
-        ; Reference to ^PS(50.606 is supported by DBIA# 2174.
-        ; Reference to EN^PSODRDU2 is supported by DBIA# 2189.
-        ; Reference to ^PSDRUG( is supported by DBIA 2192.
-        ;
-DRGDISP(DFN,ON,NL,GL,NAME,DRUGONLY)           ;
-        ;; DRUGONLY = 1/0 - Only the drug name will be returned.
-        ;; NL       = The drug name display length
-        ;; GL       = The give line display length, total length-6 ("Give: ")
-        ;; NAME(X)  = Drug name and give line in displayable format.
-        ;; ON       = IEN#_U/P (U=Unit Dose; P=Pending)
-        ;
-        NEW F,OIND,MARX,MR,NOTGV,SCH,PSGUPDDO,PSGGV,X,PSGX,PSGINS,DRUGNAME
-        K NAME S PSGINS=""
-        S:ON["U" F="^PS(55,DFN,5,+ON,"
-        I ON["P" S F="^PS(53.1,+ON,",X=$G(@(F_".3)")),PSGINS=$S(X]"":X,1:"")
-        I $G(@(F_"0)"))="" S NAME(1)="NOT FOUND" Q
-        S OIND=$G(@(F_".2)")),PSGUPDDO=$P(OIND,U,2),X=@(F_"0)"),NOTGV=$P(X,U,22),MR=$$ENMRN^PSGMI(+$P(X,U,3))
-        I '+OIND,($P(X,U,4)'="U") NEW DRG D GTDRG^PSIVORFA F X="AD","SOL" Q:+OIND  F PSGX=0:0 S PSGX=$O(DRG(X,PSGX)) Q:'PSGX  S OIND=$P(DRG(X,PSGX),U,6) Q:+OIND
-        S SCH=$P($G(@(F_"2)")),U)
-        I +$O(@(F_"1,0)")),'+$O(@(F_"1,1)")),PSGUPDDO="" D DD(F,.DRUGNAME)
-        S:($G(DRUGNAME)=""!($G(DRUGNAME)["NOT FOUND")) DRUGNAME=$$OIDF(OIND)
-        ;S PSGGV=$S(NOTGV:"*** NOT TO BE GIVEN *** ",1:"")_PSGINS_PSGUPDDO_" "_MR_" "_SCH
-        S PSGGV=$S(NOTGV:"*** NOT TO BE GIVEN *** ",1:"")_$S(('$D(PSJPDDDP)&('$L(PSGUPDDO))):PSGINS,1:PSGUPDDO)_" "_MR_" "_SCH
-        S PSGX=0 K PSJPDDDP
-        D TXT^PSGMUTL(DRUGNAME,NL) F X=0:0 S X=$O(MARX(X)) Q:'X  S NAME(X)=$S(X>1:"  ",1:"")_MARX(X),PSGX=X
-        Q:+DRUGONLY
-        D TXT^PSGMUTL(PSGGV,GL) F X=0:0 S X=$O(MARX(X)) Q:'X  D
-        . I X=1 S NAME(PSGX+X)="Give: "_MARX(X) Q
-        . S NAME(PSGX+X)=$S(X>1:"      ",1:"")_MARX(X)
-        Q
-OIDF(OIND)         ; Return Orderable Item name and Dosage form.
-        ;; +OIND = orderable item IEN
-        NEW X,NAME
-        S X=$G(^PS(50.7,+OIND,0))
-        S:$P(X,U)]"" NAME=$P(X,U)_" "_$P($G(^PS(50.606,+$P(X,U,2),0)),U)
-        Q $S($G(NAME)]"":NAME,1:"NOT FOUND "_+OIND_";PS(50.7")
-        ;
-DD(F,NAME)             ; Return Dispense drug name.
-        ;; F = "^PS(55,DFN,5,+ON," or "^PS(53.1,+ON,"
-        NEW X K NAME
-        S X=$O(@(F_"1,0)")),X=$G(@(F_"1,"_+X_",0)"))
-        I $P(X,U)]"" S NAME=$P($G(^PSDRUG(+X,0)),U)
-        E  S NAME="NOT FOUND "_+X_";PSDRUG"
-        I '$O(@(F_"1,1)")),+$P(X,U,2)>1 S PSGUPDDO=+$P(X,U,2)
-        S PSJPDDDP=1
-        Q
-DSPLORDU(PSGP,ON)         ; Display UD order for order check as in the Inpat Profile.
-        NEW DRUGNAME,F,NODE0,NODE2,PSJID,PSJX,SCH,SD,STAT,X,Y
-        S F=$S(ON["U":"^PS(55,PSGP,5,"_+ON_",",1:"^PS(53.1,"_+ON_",")
-        S NODE0=$G(@(F_"0)")),NODE2=$G(@(F_"2)"))
-        D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0)
-        I ON["P",$P(NODE0,U,4)="F" D DSPLORDV(PSGP,ON) Q
-        S SCH=$P(NODE0,U,7)
-        S STAT=$P(NODE0,U,9) I STAT="A",$P(NODE0,U,27)="R" S STAT="R"
-        I STAT'="P" S PSJID=$E($$ENDTC^PSGMI($P(NODE2,U,2)),1,5),SD=$E($$ENDTC^PSGMI($P(NODE2,U,4)),1,5)
-        I STAT="P" S (PSJID,SD)="*****",SCH="?"
-        F PSJX=0:0 S PSJX=$O(DRUGNAME(PSJX)) Q:'PSJX  D
-        . S:PSJX=1 X=SCH_"  "_PSJID_"  "_SD_"  "_$E(STAT,1)
-        . S:PSJX=1 DRUGNAME(1)=$$SETSTR^VALM1(X,$E(DRUGNAME(1),1,40),42,20)
-        . S PSJOC(ON,PSJLINE)="        "_DRUGNAME(PSJX)
-        . S PSJLINE=PSJLINE+1
-        Q
-DSPLORDV(DFN,ON)          ; Display IV order for order check as in the Inpat Profile.
-        N DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJIVFLG,PSJORIFN,TYP,X,Y
-        S TYP="?" I ON["V" D
-        .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X)
-        .S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"
-        .S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4))
-        S PSJCT=0,PSJL=""
-        I ON'["V" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4))
-        S PSJIVFLG=1 D PIVAD,SOL
-        Q
-SOL     ;
-        S PSJL=$S($G(PSJIVFLG):PSJL,1:"")_"        in"
-        S DRG=0 F  S DRG=+$O(DRG("SOL",DRG)) Q:'DRG  D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F  S DRGX=$O(NAME(DRGX)) Q:'DRGX  S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:$G(PSJIVFLG) PIV1 D SETTMP S PSJL="      "
-        Q
-PIVAD   ; Print IV Additives.
-        F DRG=0:0 S DRG=$O(DRG("AD",DRG)) Q:'DRG  D NAME^PSIVUTL(DRG("AD",DRG),39,.NAME,1) F DRGX=0:0 S DRGX=$O(NAME(DRGX)) Q:'DRGX  S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,9,60) D:$G(PSJIVFLG) PIV1 D SETTMP
-        Q
-        ;
-PIV1    ; Print Sched type, start/stop dates, and status.
-        K PSJIVFLG
-        F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5))
-        I '$D(PSJEXTP) S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),PSJL,53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,60,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,67,1)
-        E  S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,63,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,73,1)
-        Q
-SETTMP  ;
-        S PSJOC(ON,PSJLINE)=PSJL,PSJLINE=PSJLINE+1
-        Q
-ORDCHK(DFN,TYPE,PIECE)    ;
-        ;TYPE ="DD" - Duplicate drug
-        ;     ="DC" - Duplicate class
-        ;     -"DI" - Drug Interaction
-        ;PIECE = The piece order number is return from ^TMP($J,"DD"...
-        ;PSJOC(ON,x) = Array of inpatient orders to be displayed
-        ;
-        NEW ON,PSJL,PSIVX,PSJOC,PSJORIEN,PSJPACK,PSJLINE
-        S PSJOC=0,PSJLINE=1
-        F PSIVX=0:0 S PSIVX=$O(^TMP($J,TYPE,PSIVX)) Q:'PSIVX  D
-        . S PSJPACK=$P(^TMP($J,TYPE,PSIVX,0),U,PIECE)
-        . I $G(PSGORD) S PSJORD=PSGORD ; Set PSJORD if PSGORD exists and is not Null
-        . I $G(PSJORD)]"" I $S($D(PSJORD):$G(PSJORD),1:$G(PSGORD))'["V",$P(PSJPACK,";")=$S($D(PSJORD):$G(PSJORD),1:$G(PSGORD)) Q  ; don't flag order that is being renewed as duplicate, only checks Unit Dose orders
-        . I $G(PSJCOM),($G(PSJORD)["P") Q:$D(^PS(53.1,"ACX",PSJCOM,+PSJPACK))
-        . ; Don't flag if pending renewal from CPRS
-        . I $G(PSJORD)]"",(PSJORD["P"),($P($G(^PS(53.1,+PSJORD,0)),"^",24)="R"),($P(PSJPACK,";")["U"),($P($G(^PS(55,DFN,5,+$P(PSJPACK,";"),0)),"^",27)="R"),($P($G(^PS(55,DFN,5,+$P(PSJPACK,";"),0)),"^",26)=PSJORD) Q
-        . I $G(PSIVRNFG),$G(ON55)["V",$P(PSJPACK,";")=$G(ON55) Q  ;PSIVRNFG set and kill in R+2^PSIVOPT2. Needed to do dupl. check on new order but not renew.
-        . S PSJORIEN=$P(^TMP($J,TYPE,PSIVX,0),U,PIECE-1)
-        . I TYPE="DI",($P(^TMP($J,TYPE,PSIVX,0),U,4)="CRITICAL") S PSJIREQ=1
-        . ; Adding Drug Interactions check for use in Intervention defaults in PSJRXI.
-        . I TYPE="DI" S PSJRXREQ=$S($P(^TMP($J,TYPE,PSIVX,0),U,4)="CRITICAL":1,1:2)
-        . ;I $P(PSJPACK,";",2)["O" D  Q
-        . N X S X=$P(PSJPACK,";",2) I X["O" D  Q
-        ..  D:PSJFST=1 PAUSE
-        ..  W !!,"The patient has this "_$S($P(PSJPACK,";")["N":"Non-VA Meds",$P(PSJPACK,";",2)["O":"Outpatient",1:"")_" order:",!
-        ..  I $D(^TMP($J,TYPE,PSIVX,1)) D SHOR^PSJLMUT2(TYPE,PSIVX),PAUSE S PSJFST=$S(PSJFST=0:PSJFST+2,1:PSJFST+1) Q
-        ..  D EN^PSODRDU2(DFN,PSJPACK),PAUSE S PSJPDRG=1,PSJFST=$S(PSJFST=0:PSJFST+2,1:PSJFST+1)
-        . S ON=$P(PSJPACK,";") Q:$D(PSJOC(ON))
-        . I ON=$G(PSIVOCON),+PSJORIEN Q
-        . I ON=$G(PSIVOCON),'+PSJORIEN D SETPSJOC Q
-        . ;S PSJOC=PSJOC+1,PSJPDRG=1 D:PSJOC=1 WRITE(TYPE)
-        . I ON["V" D
-        .. I '$O(^PS(55,DFN,"IV",+ON,0)) D SETPSJOC Q
-        .. D DSPLORDV(DFN,ON) S PSJOC=PSJOC+1
-        . I ON'["V" D DSPLORDU(DFN,ON) S PSJOC=PSJOC+1
-        . S PSJOC(ON,PSJLINE)="",PSJLINE=PSJLINE+1
-        D:PSJOC WRITE(TYPE)
-        S ON="" F  S ON=$O(PSJOC(ON)) Q:ON=""  W ! S PSJLINE=PSJLINE+1,PSJFST=PSJFST+1 D
-        . F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX  W !,PSJOC(ON,PSIVX) S PSJLINE=PSJLINE+1 D:'(PSIVX#6) PAUSE
-        W !
-        Q
-SETPSJOC        ;Set PSJOC array to be displayed later
-        NEW PIECE S PIECE=$S(TYPE="DC":4,1:2)
-        S X=$$SETSTR^VALM1($P(^TMP($J,TYPE,PSIVX,0),U,PIECE),"",9,40)
-        S X=$$SETSTR^VALM1("* EXISTS IN CURRENT ORDER *",X,50,27)
-        S PSJOC(ON,PSJLINE)=X,PSJLINE=PSJLINE+1,PSJOC=PSJOC+1
-        Q
-WRITE(TYPE)            ;Display order check description
-        S PSJPDRG=1
-        I TYPE="DD" W !!,"This patient is already receiving the following order",$S(PSJOC>1:"s",1:"")," for ",$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"this drug"),":",!
-        I TYPE="DC" W !!,"This patient is already receiving ",$S(PSJOC>1:"orders",1:"an order")," for the following drug",$S(PSJOC>1:"s",1:"")," in the same",!,"class as ",$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"the drug selected"),":",!
-        I TYPE="DI" W !!,"This patient is receiving the following medication",$S(PSJOC>1:"s",1:"")," that ha",$S(PSJOC>1:"ve",1:"s")," an interaction",!,"with ",$P($G(^PSDRUG(PSJDD,0)),U),":",!
-        Q
-PAUSE   ;
-        K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W !
-        Q
+PSJLMUT1 ;BIR/MLM-DRUG NAME DISPLAY ;05 Feb 98 / 1:39 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**4,27,29,49,58,107,110,146,175**;16 DEC 97;Build 18
+ ;
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^PS(50.7 is supported by DBIA# 2180.
+ ; Reference to ^PS(50.606 is supported by DBIA# 2174.
+ ; Reference to EN^PSODRDU2 is supported by DBIA# 2189.
+ ; Reference to ^PSDRUG( is supported by DBIA 2192.
+ ;
+DRGDISP(DFN,ON,NL,GL,NAME,DRUGONLY)       ;
+ ;; DRUGONLY = 1/0 - Only the drug name will be returned.
+ ;; NL       = The drug name display length
+ ;; GL       = The give line display length, total length-6 ("Give: ")
+ ;; NAME(X)  = Drug name and give line in displayable format.
+ ;; ON       = IEN#_U/P (U=Unit Dose; P=Pending)
+ ;
+ NEW F,OIND,MARX,MR,NOTGV,SCH,PSGUPDDO,PSGGV,X,PSGX,PSGINS,DRUGNAME
+ K NAME S PSGINS=""
+ S:ON["U" F="^PS(55,DFN,5,+ON,"
+ I ON["P" S F="^PS(53.1,+ON,",X=$G(@(F_".3)")),PSGINS=$S(X]"":X,1:"")
+ I $G(@(F_"0)"))="" S NAME(1)="NOT FOUND" Q
+ S OIND=$G(@(F_".2)")),PSGUPDDO=$P(OIND,U,2),X=@(F_"0)"),NOTGV=$P(X,U,22),MR=$$ENMRN^PSGMI(+$P(X,U,3))
+ I '+OIND,($P(X,U,4)'="U") NEW DRG D GTDRG^PSIVORFA F X="AD","SOL" Q:+OIND  F PSGX=0:0 S PSGX=$O(DRG(X,PSGX)) Q:'PSGX  S OIND=$P(DRG(X,PSGX),U,6) Q:+OIND
+ S SCH=$P($G(@(F_"2)")),U)
+ I +$O(@(F_"1,0)")),'+$O(@(F_"1,1)")),PSGUPDDO="" D DD(F,.DRUGNAME)
+ S:($G(DRUGNAME)=""!($G(DRUGNAME)["NOT FOUND")) DRUGNAME=$$OIDF(OIND)
+ S PSGGV=$S(NOTGV:"*** NOT TO BE GIVEN *** ",1:"")_$S(('$D(PSJPDDDP)&('$L(PSGUPDDO))):PSGINS,1:PSGUPDDO)_" "_MR_" "_SCH
+ S PSGX=0 K PSJPDDDP
+ D TXT^PSGMUTL(DRUGNAME,NL) F X=0:0 S X=$O(MARX(X)) Q:'X  S NAME(X)=$S(X>1:"  ",1:"")_MARX(X),PSGX=X
+ Q:+DRUGONLY
+ D TXT^PSGMUTL(PSGGV,GL) F X=0:0 S X=$O(MARX(X)) Q:'X  D
+ . I X=1 S NAME(PSGX+X)="Give: "_MARX(X) Q
+ . S NAME(PSGX+X)=$S(X>1:"      ",1:"")_MARX(X)
+ Q
+ ;
+OIDF(OIND)    ; Return Orderable Item name and Dosage form.
+ ;; +OIND = orderable item IEN
+ NEW X,NAME
+ S X=$G(^PS(50.7,+OIND,0))
+ S:$P(X,U)]"" NAME=$P(X,U)_" "_$P($G(^PS(50.606,+$P(X,U,2),0)),U)
+ Q $S($G(NAME)]"":NAME,1:"NOT FOUND "_+OIND_";PS(50.7")
+ ;
+DD(F,NAME)        ; Return Dispense drug name.
+ ;; F = "^PS(55,DFN,5,+ON," or "^PS(53.1,+ON,"
+ NEW X K NAME
+ S X=$O(@(F_"1,0)")),X=$G(@(F_"1,"_+X_",0)"))
+ I $P(X,U)]"" S NAME=$P($G(^PSDRUG(+X,0)),U)
+ E  S NAME="NOT FOUND "_+X_";PSDRUG"
+ I '$O(@(F_"1,1)")),+$P(X,U,2)>1 S PSGUPDDO=+$P(X,U,2)
+ S PSJPDDDP=1
+ Q
+ ;
+DSPLORDU(PSGP,ON)   ; Display UD order for order check as in the Inpat Profile.
+ NEW DRUGNAME,F,NODE0,NODE2,PSJID,PSJX,SCH,SD,STAT,X,Y
+ S F=$S(ON["U":"^PS(55,PSGP,5,"_+ON_",",1:"^PS(53.1,"_+ON_",")
+ S NODE0=$G(@(F_"0)")),NODE2=$G(@(F_"2)"))
+ D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0)
+ I ON["P",$P(NODE0,U,4)="F" D DSPLORDV(PSGP,ON) Q
+ S SCH=$P(NODE0,U,7)
+ S STAT=$P(NODE0,U,9) I STAT="A",$P(NODE0,U,27)="R" S STAT="R"
+ I STAT'="P" S PSJID=$E($$ENDTC^PSGMI($P(NODE2,U,2)),1,5),SD=$E($$ENDTC^PSGMI($P(NODE2,U,4)),1,5)
+ I STAT="P" S (PSJID,SD)="*****",SCH="?"
+ F PSJX=0:0 S PSJX=$O(DRUGNAME(PSJX)) Q:'PSJX  D
+ . S:PSJX=1 X=SCH_"  "_PSJID_"  "_SD_"  "_$E(STAT,1)
+ . S:PSJX=1 DRUGNAME(1)=$$SETSTR^VALM1(X,$E(DRUGNAME(1),1,40),42,20)
+ . S PSJOC(ON,PSJLINE)="        "_DRUGNAME(PSJX)
+ . S PSJLINE=PSJLINE+1
+ Q
+ ;
+DSPLORDV(DFN,ON)   ; Display IV order for order check as in the Inpat Profile.
+ N DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJCT,PSJIVFLG,PSJORIFN,TYP,X,Y
+ S TYP="?" I ON["V" D
+ .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X)
+ .S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"
+ .S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4))
+ S PSJCT=0,PSJL=""
+ I ON'["V" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4))
+ S PSJIVFLG=1 D PIVAD,SOL
+ Q
+ ;
+SOL ;
+ S PSJL=$S($G(PSJIVFLG):PSJL,1:"")_"        in"
+ S DRG=0 F  S DRG=+$O(DRG("SOL",DRG)) Q:'DRG  D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F  S DRGX=$O(NAME(DRGX)) Q:'DRGX  S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:$G(PSJIVFLG) PIV1 D SETTMP S PSJL="      "
+ Q
+ ;
+PIVAD ; Print IV Additives.
+ F DRG=0:0 S DRG=$O(DRG("AD",DRG)) Q:'DRG  D NAME^PSIVUTL(DRG("AD",DRG),39,.NAME,1) F DRGX=0:0 S DRGX=$O(NAME(DRGX)) Q:'DRGX  S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,9,60) D:$G(PSJIVFLG) PIV1 D SETTMP
+ Q
+ ;
+PIV1 ; Print Sched type, start/stop dates, and status.
+ K PSJIVFLG
+ F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5))
+ I '$D(PSJEXTP) S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),PSJL,53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,60,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,67,1)
+ E  S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,63,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,73,1)
+ Q
+ ;
+SETTMP ;
+ S PSJOC(ON,PSJLINE)=PSJL,PSJLINE=PSJLINE+1
+ Q
+ ;
+ORDCHK(DFN,TYPE,PIECE)   ;
+ ;TYPE ="DD" - Duplicate drug
+ ;     ="DC" - Duplicate class
+ ;     -"DI" - Drug Interaction
+ ;PIECE = The piece order number is return from ^TMP($J,"DD"...
+ ;PSJOC(ON,x) = Array of inpatient orders to be displayed
+ ;
+ NEW ON,PSJL,PSIVX,PSJOC,PSJORIEN,PSJPACK,PSJLINE
+ S PSJOC=0,PSJLINE=1
+ F PSIVX=0:0 S PSIVX=$O(^TMP($J,TYPE,PSIVX)) Q:'PSIVX  D
+ . S PSJPACK=$P(^TMP($J,TYPE,PSIVX,0),U,PIECE)
+ . I $G(PSGORD) S PSJORD=PSGORD ; Set PSJORD if PSGORD exists and is not Null
+ . I $G(PSJORD)]"" I $S($D(PSJORD):$G(PSJORD),1:$G(PSGORD))'["V",$P(PSJPACK,";")=$S($D(PSJORD):$G(PSJORD),1:$G(PSGORD)) Q  ; don't flag order that is being renewed as duplicate, only checks Unit Dose orders
+ . I $G(PSJCOM),($G(PSJORD)["P") Q:$D(^PS(53.1,"ACX",PSJCOM,+PSJPACK))
+ . ; Don't flag if pending renewal from CPRS
+ . I $G(PSJORD)]"",(PSJORD["P"),($P($G(^PS(53.1,+PSJORD,0)),"^",24)="R"),($P(PSJPACK,";")["U"),($P($G(^PS(55,DFN,5,+$P(PSJPACK,";"),0)),"^",27)="R"),($P($G(^PS(55,DFN,5,+$P(PSJPACK,";"),0)),"^",26)=PSJORD) Q
+ . I $G(PSIVRNFG),$G(ON55)["V",$P(PSJPACK,";")=$G(ON55) Q  ;PSIVRNFG set and kill in R+2^PSIVOPT2. Needed to do dupl. check on new order but not renew.
+ . S PSJORIEN=$P(^TMP($J,TYPE,PSIVX,0),U,PIECE-1)
+ . I TYPE="DI",($P(^TMP($J,TYPE,PSIVX,0),U,4)="CRITICAL") S PSJIREQ=1
+ . ; Adding Drug Interactions check for use in Intervention defaults in PSJRXI.
+ . I TYPE="DI" S PSJRXREQ=$S($P(^TMP($J,TYPE,PSIVX,0),U,4)="CRITICAL":1,1:2)
+ . N X S X=$P(PSJPACK,";",2) I X["O" D  Q
+ ..  D:PSJFST=1 PAUSE
+ ..  W !!,"The patient has this "_$S($P(PSJPACK,";")["N":"Non-VA Meds",$P(PSJPACK,";",2)["O":"Outpatient",1:"")_" order:",!
+ ..  I $D(^TMP($J,TYPE,PSIVX,1)) D SHOR^PSJLMUT2(TYPE,PSIVX),PAUSE S PSJFST=$S(PSJFST=0:PSJFST+2,1:PSJFST+1) Q
+ ..  D EN^PSODRDU2(DFN,PSJPACK),PAUSE S PSJPDRG=1,PSJFST=$S(PSJFST=0:PSJFST+2,1:PSJFST+1)
+ . S ON=$P(PSJPACK,";") Q:$D(PSJOC(ON))
+ . I ON=$G(PSIVOCON),+PSJORIEN Q
+ . I ON=$G(PSIVOCON),'+PSJORIEN D SETPSJOC Q
+ . I ON["V" D
+ .. I '$O(^PS(55,DFN,"IV",+ON,0)) D SETPSJOC Q
+ .. D DSPLORDV(DFN,ON) S PSJOC=PSJOC+1
+ . I ON'["V" D DSPLORDU(DFN,ON) S PSJOC=PSJOC+1
+ . S PSJOC(ON,PSJLINE)="",PSJLINE=PSJLINE+1
+ ;  DEM - If TYPE="DI", and there are "DI" orders,
+ ;        then display "DI" orders.
+ I TYPE="DI",PSJOC D WRITE(TYPE) D  ;DEM
+ . S ON="" F  S ON=$O(PSJOC(ON)) Q:ON=""  S PSJLINE=PSJLINE+1,PSJFST=PSJFST+1 D  ;DEM
+ .. F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX  W !,PSJOC(ON,PSIVX) S PSJLINE=PSJLINE+1  ;DEM
+ Q:(TYPE="DI")  ;DEM - Don't continue if TYPE="DI". Code that follows is for TYPEs "DD" and "DC" only.
+ Q:'PSJOC  ;DEM - No need to continue if no "DD", or "DC" orders.
+ ;  DEM - If we are here, then there are "DD", or "DC" orders in
+ ;        PSJOC array. Loop on PSJOC array and set orders into
+ ;        ^TMP($J,"DUPDRG",TYPE) global. The ^TMP($J,"DUPDRG",TYPE)
+ ;        global will be used for display of "DD" and "DC" orders
+ ;        for possible discontinuation of the "DD", or "DC" orders.
+ ;        See subroutine DUPDRG and calling routine ENDDC^PSGSICHK
+ ;        for details.
+ S ON="" F  S ON=$O(PSJOC(ON)) Q:ON=""  D  ;DEM
+ . F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX  S ^TMP($J,"DUPDRG",TYPE,ON,PSIVX)=PSJOC(ON,PSIVX)  ;DEM
+ Q
+ ;
+SETPSJOC ;Set PSJOC array to be displayed later
+ NEW PIECE S PIECE=$S(TYPE="DC":4,1:2)
+ S X=$$SETSTR^VALM1($P(^TMP($J,TYPE,PSIVX,0),U,PIECE),"",9,40)
+ S X=$$SETSTR^VALM1("* EXISTS IN CURRENT ORDER *",X,50,27)
+ S PSJOC(ON,PSJLINE)=X,PSJLINE=PSJLINE+1,PSJOC=PSJOC+1
+ Q
+ ;
+WRITE(TYPE)        ;Display order check description
+ S PSJPDRG=1
+ I TYPE="DD" W !!,"This patient is already receiving the following order",$S(PSJOC>1:"s",1:"")," for ",$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"this drug"),":",!
+ I TYPE="DC" W !!,"This patient is already receiving ",$S(PSJOC>1:"orders",1:"an order")," for the following drug",$S(PSJOC>1:"s",1:"")," in the same",!,"class as ",$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"the drug selected"),":",!
+ I TYPE="DI" W !!,"This patient is receiving the following medication",$S(PSJOC>1:"s",1:"")," that ha",$S(PSJOC>1:"ve",1:"s")," an interaction",!,"with ",$P($G(^PSDRUG(PSJDD,0)),U),":",!
+ Q
+ ;
+PAUSE ;
+ K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W !
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m

@@ -1 @@
-PSJLMUT2        ;BIR/JLC-DISPLAY UTILITIES ;22 Jun 05
-        ;;5.0; INPATIENT MEDICATIONS ;**146,175,201**;16 DEC 97;Build 2
-        ;
-SHOR(PSJT,PSJI)       ;Display outpatient remote order checks.
-        ;; PSJT = Type of order check in ^TMP
-        ;; PSJI = Index to ^TMP to find order check detail
-        ;
-        N PSJD0,PSJD1,PSJRX,PSJRS,FSIG,PSJULN,PSJLF,PSJDN
-        S PSJD0=^TMP($J,PSJT,PSJI,0),PSJD1=^(1)
-        I PSJT="DD" S PSJRX=$P($P(PSJD0,"^",4),";"),PSJRS=$P(PSJD0,"^",5),PSJDN=$P(PSJD0,"^",2)
-        I PSJT="DC" S PSJRX=$P($P(PSJD0,"^",6),";"),PSJRS=$P(PSJD0,"^",7),PSJDN=$P(PSJD0,"^",4)
-        I PSJT="DI" S PSJRX=$P($P(PSJD0,"^",8),";"),PSJRS=$P(PSJD0,"^",9),PSJDN=$P(PSJD0,"^",2)
-        S PSJLF=$P(PSJD1,"^",3),$P(PSJULN,"-",79)=""
-        W !,PSJULN,!
-        W PSJRS I $L(PSJRS)>13 W !
-        W ?14,"Rx #: ",$E(PSJRX,1,$L(PSJRX)-1) I $A($L(PSJRX))<54 W $E(PSJRX,$L(PSJRX))
-        W ?39,PSJDN,! I PSJT="DI" W ?39,$P(PSJD0,"^",4)," INTERACTION",!
-        W $J("Status: ",20),$P(PSJD1,"^",2),?40,$J("Issued: ",20),$P(PSJD1,"^",9)
-        D FSIG(.FSIG)
-        W !,$J("SIG: ",20) F I=1:1 Q:'$D(FSIG(I))  W ?20,FSIG(I),!
-        W $J("QTY: ",20)_$P(PSJD1,"^",5)
-        W !,$J("Provider: ",20),$P(PSJD1,"^",8),?40,$J("Refills remaining: ",20),$P(PSJD1,"^",6)
-        W !?40,$J("Last filled on: ",20),PSJLF
-        W !?40,$J("Days Supply: ",20)_$P(PSJD1,"^",4)
-        W !,PSJULN
-        Q
-FSIG(FSIG)      ;Format sig from remote site
-        ;returned in the FSIG array
-        N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II,I
-        F I=0:1 Q:'$D(^TMP($J,PSJT,PSJI,1,I))  S HSIG(I+1)=^(I)
-FSTART  S (FVAR,FVAR1)="",II=1
-        F FFF=0:0 S FFF=$O(HSIG(FFF)) Q:'FFF  S CNT=0 F NNN=1:1:$L(HSIG(FFF)) I $E(HSIG(FFF),NNN)=" "!($L(HSIG(FFF))=NNN) S CNT=CNT+1 D  I $L(FVAR)>52 S FSIG(II)=FLIM_" ",II=II+1,FVAR=FVAR1
-        .S FVAR1=$P(HSIG(FFF)," ",(CNT))
-        .S FLIM=FVAR
-        .S FVAR=$S(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
-        I $G(FVAR)'="" S FSIG(II)=FVAR
-        I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2)
-FQUIT   Q
-PAUSE   ;
-        K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W !
-        Q
+PSJLMUT2 ;BIR/JLC-DISPLAY UTILITIES ;22 Jun 05
+ ;;5.0; INPATIENT MEDICATIONS ;**146,175**;16 DEC 97;Build 18
+ ;
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^PSDRUG is supported by DBIA# 2192.
+ ; Reference to ^PSSLOCK is supported by DBIA# 2789.
+ ; Reference to ^VA(200 is supported by DBIA# 10060.
+ ; 
+SHOR(PSJT,PSJI)       ;Display outpatient remote order checks.
+ ;; PSJT = Type of order check in ^TMP
+ ;; PSJI = Index to ^TMP to find order check detail
+ ;
+ N PSJD0,PSJD1,PSJRX,PSJRS,FSIG,PSJULN,PSJLF,PSJDN
+ S PSJD0=^TMP($J,PSJT,PSJI,0),PSJD1=^(1)
+ I PSJT="DD" S PSJRX=$P($P(PSJD0,"^",4),";"),PSJRS=$P(PSJD0,"^",5),PSJDN=$P(PSJD0,"^",2)
+ I PSJT="DC" S PSJRX=$P($P(PSJD0,"^",6),";"),PSJRS=$P(PSJD0,"^",7),PSJDN=$P(PSJD0,"^",4)
+ I PSJT="DI" S PSJRX=$P($P(PSJD0,"^",8),";"),PSJRS=$P(PSJD0,"^",9),PSJDN=$P(PSJD0,"^",2)
+ S PSJLF=$P(PSJD1,"^",3),$P(PSJULN,"-",79)=""
+ W !,PSJULN,!
+ W PSJRS I $L(PSJRS)>13 W !
+ W ?14,"Rx #: ",$E(PSJRX,1,$L(PSJRX)-1) I $A($L(PSJRX))<54 W $E(PSJRX,$L(PSJRX))
+ W ?39,PSJDN,! I PSJT="DI" W ?39,$P(PSJD0,"^",4)," INTERACTION",!
+ W $J("Status: ",20),$P(PSJD1,"^",2),?40,$J("Issued: ",20),$P(PSJD1,"^",9)
+ D FSIG(.FSIG)
+ W !,$J("SIG: ",20) F I=1:1 Q:'$D(FSIG(I))  W ?20,FSIG(I),!
+ W $J("QTY: ",20)_$P(PSJD1,"^",5)
+ W !,$J("Provider: ",20),$P(PSJD1,"^",8),?40,$J("Refills remaining: ",20),$P(PSJD1,"^",6)
+ W !?40,$J("Last filled on: ",20),PSJLF
+ W !?40,$J("Days Supply: ",20)_$P(PSJD1,"^",4)
+ W !,PSJULN
+ Q
+ ;
+FSIG(FSIG) ;Format sig from remote site
+ ;returned in the FSIG array
+ N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II,I
+ F I=0:1 Q:'$D(^TMP($J,PSJT,PSJI,1,I))  S HSIG(I+1)=^(I)
+FSTART S (FVAR,FVAR1)="",II=1
+ F FFF=0:0 S FFF=$O(HSIG(FFF)) Q:'FFF  S CNT=0 F NNN=1:1:$L(HSIG(FFF)) I $E(HSIG(FFF),NNN)=" "!($L(HSIG(FFF))=NNN) S CNT=CNT+1 D  I $L(FVAR)>52 S FSIG(II)=FLIM_" ",II=II+1,FVAR=FVAR1
+ .S FVAR1=$P(HSIG(FFF)," ",(CNT))
+ .S FLIM=FVAR
+ .S FVAR=$S(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
+ I $G(FVAR)'="" S FSIG(II)=FVAR
+ I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2)
+FQUIT Q
+ ;
+DUPDRG(DFN) ;DEM - Duplicate Drug Check Ehancement
+ ;
+ ;  Note: Display of Drug Interaction, Non-VA Meds, and Outpatient
+ ;        orders is done by ORDCHK^PSJLMUT1. ORDCHK is called by
+ ;        routine ENDDC^PSGSICHK before routine ENDDC^PSGSICHK calls
+ ;        DUPDRG^PSJLMUT2. If ORDCHK finds "DD", or "DC" orders,
+ ;        then ORDCHK will set "DD", or "DC" orders into
+ ;        ^TMP($J,"DUPDRG",TYPE) global.
+ ;
+ K PSJDDCON  ;Order continuation flag used by routine PSGSICHK.
+ S:$D(^TMP($J,"DI")) PSJDDCON("DI")=1  ;Order continuation flag used by routine PSGSICHK.
+ ;  Quit if no duplicate drug orders(s), or duplicate drug class
+ ;  order(s) found.
+ Q:'$D(^TMP($J,"DUPDRG","DD"))&'$D(^TMP($J,"DUPDRG","DC"))
+ S PSJDDCON("DD")=0  ;Order continuation flag used by routine PSGSICHK.
+ ;
+ ;  Display orders in ^TMP($J,"DUPDRG",DUPLICATE_TYPE,ON,LINE_#)
+ ;  (DUPLICATE TYPEs: "DD" - "Duplicate Drug"
+ ;                    "DC" - "Duplicate Drug Class"
+ ;
+ S PSJPDRG=1  ;If we are here, then set PSJPDRG=1. ORDCHK^PSJLMUT1 addresses this variable for Outpatient orders and "DI" orders.
+ N X,Y,DIR,TYPE,ON,PSJOC,PSJOCPOP,PSJSYSL
+ W !!,"This patient is already receiving the following INPATIENT order(s) for the same drug or in the same drug class as "_$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"the drug selected"),":",!!
+ D DSPLDD  ;Display patients orders for the same drug or same drug class as drug selected.
+ ;  Ask user if they wish to continue in spite of an order check.
+ S DIR(0)="Y",DIR("A")="Do you wish to continue with the current order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,"
+ S DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")="YES" D ^DIR I 'Y S PSGORQF=1,COMQUIT=1 K X,Y,DIR W ! Q
+ K X,Y,DIR
+ S PSJDDCON("DD")=1,PSJSYSL=0  ;Order continuation flag used by routine PSGSICHK. 
+ W !
+ F  D  Q:('PSJOC)!(PSJOCPOP)  ;Order discontinuation loop.
+ . N TYPE,ON,PSJOCSEQ
+ . S PSJOCPOP=0
+ . ;  Ask user if they wish to discontinue any of the listed orders.
+ . S DIR(0)="Y",DIR("A")="Do you wish to DISCONTINUE any of the listed orders",DIR("?",1)="Enter ""N"" if you wish to exit without discontinuing any of the listed orders,"
+ . S DIR("?")="or ""Y"" to discontinue any of the listed orders.",DIR("B")="NO" D ^DIR I 'Y K X,Y,DIR S PSJOCPOP=1 W ! Q
+ . K X,Y,DIR
+ . W !
+ . ;  Choose for DISCONTINUE 1-PSJOC (PSJOC is the total number of duplicate and duplicate class orders).
+ . S DIR(0)="N^1:"_PSJOC,DIR("A")="Choose for DISCONTINUE",DIR("?")="Choose an order 1-"_PSJOC D ^DIR I 'Y K X,Y,DIR S PSJOCPOP=1 W ! Q
+ . S PSJOCSEQ=+Y
+ . K X,Y,DIR
+ . ;
+ . ;  *** Discontinue order ***
+ . S ON=$P(PSJOC(PSJOCSEQ),"^",2)
+ . I '$$LS^PSSLOCK(DFN,ON) S PSJOCPOP=1 Q
+ . S PSGSTAT=$$GTSTATUS^PSJOE(DFN,ON)
+ . D  ;Set PSGOEEWF for order being discontinued - DRF
+ .. I ON["P" S PSGOEEWF="^PS(53.1,"_+ON_"," Q
+ .. I ON["U" S PSGOEEWF="^PS(55,"_DFN_",5,"_+ON_"," Q
+ .. S PSGOEEWF="^PS(55,"_DFN_",""IV"","_+ON_","
+ . D  ;The following variables must be newed or they are stomped on by the discontinue code
+ .. N %DT,CF,D,D0,DA,DI,DIC,DIE,DISYS,DQ,DR,DRG,DRGT,DRGTMP,DRGX
+ .. N DTIME,FIL,I,JJ,LOC,OCXDT,OCXI,OCXSEG,ORIFN,ORO,POP,PSGALR
+ .. N PSGDT,PSGOEAV,PSJNOO,PSGOEDMR,PSGOEPR,PSGPDRG,PSGTOO,PSGTOL
+ .. N PSGUOW,PSIVOI,PSIVX,PSJCOM,PSJDD,PSJHLMTN,PSJMSG,PSJQO,PSOC
+ .. N Q,QQ,T,VA,VADM,VAERR,VAIN,XPARSYS,XQXFLG,Y,PSJRQPND
+ .. D
+ ... S PSJRQPND=1
+ ... I ON["V" D  Q  ;IV order
+ .... N PSJORD
+ .... S PSJORD=ON
+ .... D DC^PSJLIACT
+ ... D DC^PSJOE(DFN,ON)  ;UD order
+ .. I $$GTSTATUS^PSJOE(DFN,ON)="D" D  ;  Clean up PSJOC and ^TMP($J,"DUPDRG") arrays, and reset PSJOC counter IF and after selected order has been discontinued.
+ ... S TYPE=$P(PSJOC(PSJOCSEQ),"^",1),ON=$P(PSJOC(PSJOCSEQ),"^",2),PSJOC=PSJOC-1
+ ... K PSJOC(PSJOCSEQ),^TMP($J,"DUPDRG",TYPE,ON),PSJOCSEQ
+ . D UNL^PSSLOCK(DFN,ON)
+ . Q:'PSJOC
+ . W !!,"Now, this patient is already receiving the following INPATIENT order(s) for the same drug or in the same drug class as "_$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"the drug selected"),":",!!
+ . D DSPLDD
+ . Q
+ W !
+ K PSJOCPOP,PSGSTAT
+ Q
+ ;
+DSPLDD ;
+ ;  Display patients orders for the same drug or same drug class as drug selected.
+ N X,REQPROV,PSJLINE,PSJFLN
+ K PSJOC
+ ;  Requesting Provider
+ S PSJOC=0
+ F TYPE="DD","DC" S ON="" F  S ON=$O(^TMP($J,"DUPDRG",TYPE,ON)) Q:ON=""  S PSJFLN=1 D
+ . I ON["U" S REQPROV=$P(^PS(55,DFN,5,+ON,0),"^",2)
+ . I ON["V" S REQPROV=$P(^PS(55,DFN,"IV",+ON,0),"^",6)
+ . I ON["P" S REQPROV=$P(^PS(53.1,+ON,0),"^",2)
+ . S REQPROV=$S(REQPROV>0:$P($G(^VA(200,REQPROV,0)),"^",1),1:"") S:REQPROV="" REQPROV="Requesting Provider Unknown"
+ . F PSJLINE=0:0 S PSJLINE=$O(^TMP($J,"DUPDRG",TYPE,ON,PSJLINE)) Q:'PSJLINE  D
+ .. I PSJFLN=1 S PSJOC=PSJOC+1,PSJOC(PSJOC)=TYPE_"^"_ON W PSJOC_".",^TMP($J,"DUPDRG",TYPE,ON,PSJLINE),! S PSJFLN=PSJFLN+1 Q
+ .. S X=^TMP($J,"DUPDRG",TYPE,ON,PSJLINE) S:PSJFLN=2 X=$$SETSTR^VALM1(REQPROV,X,(48+$L(PSJOC_".")),25) W ?($L(PSJOC_".")),X,! S PSJFLN=PSJFLN+1 Q
+ .. Q
+ . Q
+ Q
+ ;
+PAUSE ;
+ K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W !
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m

@@ -1 @@
-PSJMPEND        ;BIR/CML3-MD MARS - GATHER ACK ORDERS INFO (MDWS) ; 6/18/07 12:11pm
-        ;;5.0; INPATIENT MEDICATIONS ;**191**;16 DEC 97;Build 9
-        ;
-PEND    ;*** Only select orders that were acknowledged by nurses and are
-        ;*** still having pending status.
-        NEW X S X=$O(^PS(59.6,"B",+PSJPWD,0)) Q:'+$P($G(^PS(59.6,+X,0)),U,6)
-        NEW ND,ON,TYPE,QST
-        F ON=0:0 S ON=$O(^PS(53.1,"AV",PSGP,ON)) Q:'ON  D
-        . S ND=$G(^PS(53.1,ON,0)),TYPE=$P(ND,U,4)
-        . S ND2=$G(^PS(53.1,ON,2)),PSGLSD=$P(ND2,U,2),PSGLFD=$P(ND2,U,4)
-        . I $P(ND,U,7)="P"!($P($G(^PS(53.1,ON,2)),U)["PRN") S QST="PZ"_$S($P(ND,U,4)="F":"V",1:"A")
-        . E  S QST="CZ"_$S($P(ND,U,4)="F":"V",1:"A")
-        . I PSGMTYPE[1 D:TYPE'="F" SETTMP D:TYPE="F" IV
-        . I PSGMTYPE'[1 D
-        .. I PSGMTYPE[2,(TYPE="U") D SETTMP Q
-        .. I PSGMTYPE'[2,(TYPE="I") D SETTMP Q
-        .. I PSGMTYPE[4,(TYPE="F") D IV
-        Q
-        ;
-SETTMP  ;*** Setup ^tmp for pending U/D and Inpatient med IVs.
-        ;*** PZ_(V/A) = PRN/One time orders (V=IV).
-        ;*** CZ_(V/A) = Continuous orders (A=U/D).
-        I 'PSJMPRN,(QST["PZ") Q
-        NEW MARX
-        D DRGDISP^PSJLMUT1(PSGP,+ON_"P",20,0,.MARX,1) S DRG=MARX(1)_U_ON
-        ;*** Set up ^TMP for sort by patients
-        S PSJDOS=$P(^PS(53.1,ON,.2),U,2),PSJMR=$E($S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)),1,5),PSJSCHE=$P($G(^PS(53.1,ON,2)),U)
-        S PSJHOLD=$S($P(ND,U,9)["H":1,1:0),PSGLOD=$P(ND,U,14),PSJATME=9999,PSJADT=$S(QST["C":"8999999",1:"9999999")
-        D SI
-        I PSGSS="P" D  Q
-        . S ^TMP($J,PSJADT,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB
-        . S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD
-        . S ^TMP($J,QST,PSGP,ON,1)=PSJSI
-        ;*** Set up ^TMP when listing by ward
-        S:PSGRBADM="A" ^TMP($J,PSJADT,TM,PSJATME,PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
-        S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
-        S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
-        S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD_U_PSGLSD_U_PSGLFD
-        S ^TMP($J,QST,PSGP,ON,1)=PSJSI
-        Q
-SI      ;*** Find the Special instructions.
-        S X=0,PSJSI="" F  S X=$O(^PS(53.1,ON,12,X)) Q:'X  S Z=$G(^(X,0)),Y=$L(PSJSI) S:Y+$L(Z)'>179 PSJSI=PSJSI_Z_" " I Y+$L(Z)>179 S PSJSI="SEE PROVIDER COMMENTS" Q
-        Q
-        ;
-IV      ;*** Sort IV pending orders for 24 Hrs, 7/14 Day MAR.
-        K DRG,P NEW X,ON55,P,PSJLABEL
-        S DFN=PSGP,PSJLABEL=1 D GT531^PSIVORFA(DFN,ON)
-        S X=$P(P("MR"),U,2)
-        S QST=QST_4
-        S PSJADT=$S(QST["C":"8999999",1:"9999999")
-        I DRG S X=$S($G(DRG("AD",1)):DRG("AD",1),1:$G(DRG("SOL",1))),X=$E($P(X,U,2),1,20)_U_ON D
-        . I PSGSS="P" S ^TMP($J,PSJADT,PPN_U_PSGP,"9999",QST,X)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB Q
-        . S:PSGRBADM="A" ^TMP($J,PSJADT,TM,"9999",PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
-        . S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,"9999",QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
-        . S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,"9999",QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
-        Q
+PSJMPEND ;BIR/CML3-MD MARS - GATHER ACK ORDERS INFO (MDWS) ;20 DEC 96 / 3:15 PM
+ ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
+ ;
+PEND ;*** Only select orders that were acknowledged by nurses and are
+ ;*** still having pending status.
+ NEW X S X=$O(^PS(59.6,"B",+PSJPWD,0)) Q:'+$P($G(^PS(59.6,+X,0)),U,6)
+ NEW ND,ON,TYPE,QST
+ F ON=0:0 S ON=$O(^PS(53.1,"AV",PSGP,ON)) Q:'ON  D
+ . S ND=$G(^PS(53.1,ON,0)),TYPE=$P(ND,U,4)
+ . I $P(ND,U,7)="P"!($P($G(^PS(53.1,ON,2)),U)["PRN") S QST="PZ"_$S($P(ND,U,4)="F":"V",1:"A")
+ . E  S QST="CZ"_$S($P(ND,U,4)="F":"V",1:"A")
+ . I PSGMTYPE[1 D:TYPE'="F" SETTMP D:TYPE="F" IV
+ . I PSGMTYPE'[1 D
+ .. I PSGMTYPE[2,(TYPE="U") D SETTMP Q
+ .. I PSGMTYPE'[2,(TYPE="I") D SETTMP Q
+ .. I PSGMTYPE[4,(TYPE="F") D IV
+ Q
+ ;
+SETTMP ;*** Setup ^tmp for pending U/D and Inpatient med IVs.
+ ;*** PZ_(V/A) = PRN/One time orders (V=IV).
+ ;*** CZ_(V/A) = Continuous orders (A=U/D).
+ I 'PSJMPRN,(QST["PZ") Q
+ NEW MARX
+ D DRGDISP^PSJLMUT1(PSGP,+ON_"P",20,0,.MARX,1) S DRG=MARX(1)_U_ON
+ ;*** Set up ^TMP for sort by patients
+ S PSJDOS=$P(^PS(53.1,ON,.2),U,2),PSJMR=$E($S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)),1,5),PSJSCH=$P($G(^PS(53.1,ON,2)),U)
+ S PSJHOLD=$S($P(ND,U,9)["H":1,1:0),PSGLOD=$P(ND,U,14),PSJATME=9999,PSJADT=$S(QST["C":"8999999",1:"9999999")
+ D SI
+ I PSGSS="P" D  Q
+ . S ^TMP($J,PSJADT,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB
+ . S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD
+ . S ^TMP($J,QST,PSGP,ON,1)=PSJSI
+ ;*** Set up ^TMP when listing by ward
+ S:PSGRBADM="A" ^TMP($J,PSJADT,TM,PSJATME,PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
+ S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
+ S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
+ S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD_U_PSGLSD_U_PSGLFD
+ S ^TMP($J,QST,PSGP,ON,1)=PSJSI
+ Q
+SI ;*** Find the Special instructions.
+ S X=0,PSJSI="" F  S X=$O(^PS(53.1,ON,12,X)) Q:'X  S Z=$G(^(X,0)),Y=$L(PSJSI) S:Y+$L(Z)'>179 PSJSI=PSJSI_Z_" " I Y+$L(Z)>179 S PSJSI="SEE PROVIDER COMMENTS" Q
+ Q
+ ;
+IV ;*** Sort IV pending orders for 24 Hrs, 7/14 Day MAR.
+ K DRG,P NEW X,ON55,P,PSJLABEL
+ S DFN=PSGP,PSJLABEL=1 D GT531^PSIVORFA(DFN,ON)
+ S X=$P(P("MR"),U,2)
+ S QST=QST_4
+ S PSJADT=$S(QST["C":"8999999",1:"9999999")
+ I DRG S X=$S($G(DRG("AD",1)):DRG("AD",1),1:$G(DRG("SOL",1))),X=$E($P(X,U,2),1,20)_U_ON D
+ . I PSGSS="P" S ^TMP($J,PSJADT,PPN_U_PSGP,"9999",QST,X)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB Q
+ . S:PSGRBADM="A" ^TMP($J,PSJADT,TM,"9999",PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
+ . S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,"9999",QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
+ . S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,"9999",QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOERI.m

@@ -1 @@
-PSJOERI ;BIR/LDT-CPRS ORDER UPDATE FOR INPATIENT MEDS ; 7/30/08 7:51am
-        ;;5.0; INPATIENT MEDICATIONS ;**86,108,204**;16 DEC 97;Build 3
-        ;
-        ; Reference to ^PS(55 is supported by DBIA 2191
-        ; Reference to ^%DTC is supported by DBIA 10000
-        ; Reference to ^DIE is supported by DBIA 10018
-        ;
-ENR(DFN,ON,PSJWARD)     ;
-        I $G(DFN)=""!($G(ON)="")!(+$G(PSJWARD)'>0) Q
-        I PSJWARD'=+PSJWARD Q
-        D NOW^%DTC S PSJNOW=%
-        I ON["V" D  Q
-        . I '$D(^PS(55,DFN,"IV",+ON)) Q
-        . I $P(^PS(55,DFN,"IV",+ON,0),"^",17)'="D" Q
-        . I $P(^PS(55,DFN,"IV",+ON,0),"^",12)="" Q
-        . N DA,DR,DIE,DIK,PSIVREA,PSIVALCK,PSIVOPT,PSIVAL,PSIVALT,X,Y
-        . S P(3)=$P($G(^PS(55,DFN,"IV",+ON,0)),"^",3)
-        . S X=$G(^PS(55,DFN,"IV",+ON,"ADC")) I X K ^PS(55,"ADC",X,DFN,+ON),^PS(55,DFN,"IV",+ON,"ADC")
-        . S PSIVACT=1,DR="100///A;.03////"_+$P($G(^PS(55,DFN,"IV",+ON,2)),U,7)_";9////^S X=PSJWARD;109///@;116///@;121///@",DIE="^PS(55,"_DFN_",""IV"",",DA=+ON,DA(1)=DFN
-        .;PSJ*5.0*204
-        . I $P($G(^PS(55,DFN,"IV",+ON,4)),"^",18)=1 S DR="100////H;.03////"_+$P($G(^PS(55,DFN,"IV",+ON,2)),U,7)_";9////^S X=PSJWARD;109///@;116///@;121///@"
-        . N CHKIT S CHKIT=$G(^PS(55,DFN,"IV",+ON,2)) I $P(CHKIT,U,6)["P",($P(CHKIT,U,9)="R") S DR=DR_";114///@;123///@"
-        . D ^DIE
-        . D IRA(1),EN1^PSJHL2(DFN,"SC",ON,"AUTO REINSTATED (CPRS)")
-        I ON["U" D  Q
-        . I '$D(^PS(55,DFN,5,+ON)) Q
-        . I $P(^PS(55,DFN,5,+ON,0),"^",9)'="D" Q
-        . I $P(^PS(55,DFN,5,+ON,4),"^",11)="" Q
-        . N DA,DR,DIE,PSGFD,X,Z
-        . S PSGFD=$P($G(^PS(55,DFN,5,+ON,2)),"^",3)
-        . S DR="28////A;34////^S X=PSGFD;68////^S X=PSJWARD",Z=$G(^PS(55,DFN,5,+ON,4)),$P(Z,U,11)="",$P(Z,"^",15,17)="^^" S ^(4)=Z
-        .;PSJ*5.0*204
-        . I $P($G(^PS(55,DFN,5,+ON,4)),"^",18)=1 S DR="28////H;34////^S X=PSGFD;68////^S X=PSJWARD"
-        . N CHKIT S CHKIT=$G(^PS(55,DFN,5,+ON,0)) I $P(CHKIT,U,26)["P",($P(CHKIT,U,27)="R") S DR=DR_";105///@;107///@"
-        . S DIE="^PS(55,"_DFN_",5,",DA(1)=DFN,DA=+ON D ^DIE
-        . S X=$P(^PS(55,DFN,5,+ON,0),"^",20),$P(^(0),"^",20)="" K:X ^PS(55,"AUDDD",X,DFN,+ON) ;Removed cross reference after reinstate order.
-        . D URA(1),EN1^PSJHL2(DFN,"SC",ON,"AUTO REINSTATED (CPRS)")
-        Q
-IRA(STAT)       ;
-        S ON55=ON,P(17)="A",PSIVREA="AI",PSIVALCK="STOP",(PSIVOPT,PSIVALT)=1,PSJUNDC=1,PSIVAL="AUTO REINSTATED (CPRS)"
-        D LOG^PSIVORAL
-        Q
-URA(STAT)       ;
-        S PSGAL("C")=18560 D ^PSGAL5
-        Q
+PSJOERI ;BIR/LDT-CPRS ORDER UPDATE FOR INPATIENT MEDS ;18 JUN 01
+ ;;5.0; INPATIENT MEDICATIONS ;**86,108**;16 DEC 97
+ ;
+ ; Reference to ^PS(55 is supported by DBIA 2191
+ ; Reference to ^%DTC is supported by DBIA 10000
+ ; Reference to ^DIE is supported by DBIA 10018
+ ;
+ENR(DFN,ON,PSJWARD) ;
+ I $G(DFN)=""!($G(ON)="")!(+$G(PSJWARD)'>0) Q
+ I PSJWARD'=+PSJWARD Q
+ D NOW^%DTC S PSJNOW=%
+ I ON["V" D  Q
+ . I '$D(^PS(55,DFN,"IV",+ON)) Q
+ . I $P(^PS(55,DFN,"IV",+ON,0),"^",17)'="D" Q
+ . I $P(^PS(55,DFN,"IV",+ON,0),"^",12)="" Q
+ . N DA,DR,DIE,DIK,PSIVREA,PSIVALCK,PSIVOPT,PSIVAL,PSIVALT,X,Y
+ . S P(3)=$P($G(^PS(55,DFN,"IV",+ON,0)),"^",3)
+ . S X=$G(^PS(55,DFN,"IV",+ON,"ADC")) I X K ^PS(55,"ADC",X,DFN,+ON),^PS(55,DFN,"IV",+ON,"ADC")
+ . S PSIVACT=1,DR="100///A;.03////"_+$P($G(^PS(55,DFN,"IV",+ON,2)),U,7)_";9////^S X=PSJWARD;109///@;116///@;121///@",DIE="^PS(55,"_DFN_",""IV"",",DA=+ON,DA(1)=DFN
+ . N CHKIT S CHKIT=$G(^PS(55,DFN,"IV",+ON,2)) I $P(CHKIT,U,6)["P",($P(CHKIT,U,9)="R") S DR=DR_";114///@;123///@"
+ . D ^DIE
+ . D IRA(1),EN1^PSJHL2(DFN,"SC",ON,"AUTO REINSTATED (CPRS)")
+ I ON["U" D  Q
+ . I '$D(^PS(55,DFN,5,+ON)) Q
+ . I $P(^PS(55,DFN,5,+ON,0),"^",9)'="D" Q
+ . I $P(^PS(55,DFN,5,+ON,4),"^",11)="" Q
+ . N DA,DR,DIE,PSGFD,X,Z
+ . S PSGFD=$P($G(^PS(55,DFN,5,+ON,2)),"^",3)
+ . S DR="28////A;34////^S X=PSGFD;68////^S X=PSJWARD",Z=$G(^PS(55,DFN,5,+ON,4)),$P(Z,U,11)="",$P(Z,"^",15,17)="^^" S ^(4)=Z
+ . N CHKIT S CHKIT=$G(^PS(55,DFN,5,+ON,0)) I $P(CHKIT,U,26)["P",($P(CHKIT,U,27)="R") S DR=DR_";105///@;107///@"
+ . S DIE="^PS(55,"_DFN_",5,",DA(1)=DFN,DA=+ON D ^DIE
+ . S X=$P(^PS(55,DFN,5,+ON,0),"^",20),$P(^(0),"^",20)="" K:X ^PS(55,"AUDDD",X,DFN,+ON) ;Removed cross reference after reinstate order.
+ . D URA(1),EN1^PSJHL2(DFN,"SC",ON,"AUTO REINSTATED (CPRS)")
+ Q
+IRA(STAT) ;
+ S ON55=ON,P(17)="A",PSIVREA="AI",PSIVALCK="STOP",(PSIVOPT,PSIVALT)=1,PSJUNDC=1,PSIVAL="AUTO REINSTATED (CPRS)"
+ D LOG^PSIVORAL
+ Q
+URA(STAT) ;
+ S PSGAL("C")=18560 D ^PSGAL5
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOREN.m

@@ -1 @@
-PSJOREN ;BIR/CML3-INTERFACE FOR INPATIENT PHARMACY AND OE/RR ;07 AUG 97 / 3:21 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**109,127,134**;16 DEC 97;Build 124
-        ;
-        ;Reference to ^ORD(100.98 supported by DBIA 873
-        ;Reference to ^PS(51.2 supported by DBIA 2178
-        ;Reference to ^PS(55 supported by DBIA 2191
-        ;
-ENTRY   ;
-        K PSGOEE,PSGOES
-        I '$D(^DPT(+ORVP,.1)) W !!,"THIS PATIENT HAS NOT BEEN ADMITTED.",!,"(Any non-IV orders entered will be discontinued by the pharmacist...)"
-        ;
-GO      ; get orders
-        S PSGOEORF=1,PSGOEAV=0,PSJORTOU=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",0)),PSGOEDMR=$O(^PS(51.2,"B","ORAL",0)),PSGOEPR=PSJORPV
-        F  S PSGOEOS="U" D ^PSGOE7 Q:Y<0  D:X?1"S."1.E ^PSGOES I X'?1."S."1.E D ^PSGOE6 K PSGOEE D:$D(Y) ^PSGOETO
-        ;
-DONE    ;
-        ;
-OUT     ;
-        Q  ;
-PS      ;
-        W $C(7),!!,"The selected PROVIDER is NOT qualified to write MEDICATION orders.  You must",!,"select a valid provider to be able to continue with Inpatient Medications."
-        K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Select PHARMACY PROVIDER: ",DIC("S")="S PSG=$G(^(""PS"")) I PSG,$S('$P(PSG,""^"",4):1,1:DT<$P(PSG,""^"",4))" F  W ! D ^DIC Q:$D(DUOUT)!$D(DTOUT)!(Y>0)  W $C(7),"  (Required.)"
-        K DIC S:Y'>0 PSJORPF=11 S:Y>0 PSJORPV=+Y,PSJORPVN=Y(0,0) Q
-        Q
-ENBKOUT(DFN,ON) ; Undo Renew.
-        Q:'$G(ON)
-        N PSJOLD,PSJRES,PSJOC,PSJOC2,PSIVACT,PSIVALT,PSIVREA,ON55,PSGAL,DA,PSIVAL,PSJUNDC
-        S PSJOC=PSOC,PSJOC2=PSJHLMTN,PSIVAL=24000
-        S X=$G(^PS(53.1,+ON,0)) Q:'X
-        S PSJRES=$P(X,U,24),(X,PSJOLD)=$P(X,U,25)
-        I PSJOLD["V" D
-        .I $D(^PS(55,DFN,"IV",+PSJOLD,2)) D
-        ..N PSJOSTOP,PSJNOW,PSJSTAT S PSJNOW=$$DATE^PSJUTL2(),PSJOSTOP=$P($G(^PS(55,DFN,"IV",+PSJOLD,0)),"^",3),PSJSTAT=$P(^(0),"^",17)
-        ..S $P(^PS(55,DFN,"IV",+PSJOLD,2),U,6)="",$P(^(2),U,9)="",$P(^(0),U,17)=$S(PSJNOW>PSJOSTOP:"E",PSJSTAT="R":"A",1:PSJSTAT)
-        ..S PSIVACT=1,PSIVALT=$S(PSOC="CR":2,1:1),PSJUNDC=1,PSIVAL=$P($G(^PS(53.3,+PSIVAL,0)),U),PSIVREA="PNRD",ON55=PSJOLD
-        .D LOG^PSIVORAL
-        I PSJOLD["U" D
-        .I $D(^PS(55,DFN,5,+PSJOLD,0)) N PSJSTAT S PSJSTAT=$P(^(0),"^",9) D
-        ..N PSJOSTOP,PSJNOW S PSJNOW=$$DATE^PSJUTL2(),PSJOSTOP=$P($G(^PS(55,DFN,5,+PSJOLD,2)),"^",4)
-        ..S $P(^PS(55,DFN,5,+PSJOLD,0),U,26,27)=U,PSGAL("C")=24000,DA=+PSJOLD,DA(1)=DFN S $P(^(0),U,9)=$S(PSJNOW>PSJOSTOP:"E",PSJSTAT="R":"A",1:PSJSTAT)
-        .D ^PSGAL5
-        S PSOC="SC",PSJHLMTN="ORM" D EN1^PSJHL2(DFN,PSOC,PSJOLD) S PSOC=PSJOC,PSJHLMTN=PSJOC2
-        Q
-        ;
-ENUDTX(DFN,ON,RES)      ; Set up ORTX( Array for UD orders.
-        K ORTX N DO,MRN,ND0,NDP1,ND2,PD,ST,SCH
-        S Y=2 I ON["A"!(ON["O") S ND0=$G(^PS(55,DFN,5,+ON,0)),NDP1=$G(^(.1)),ND2=$G(^(2)),Y=2 F X=0:0 S X=$O(^PS(55,DFN,5,+ON,12,X)) Q:'X  S Y=Y+1,ORTX(Y)=$G(^(X,0))
-        E  S ND0=$G(^PS(53.1,+ON,0)),NDP1=$G(^(.1)),ND2=$G(^(2)),Y=2 F X=0:0 S X=$O(^PS(53.1,+ON,12,X)) Q:'X  S Y=Y+1,ORTX(Y)=$G(^(X,0))
-        S ORTX(1)=$S($G(RES)="NR":"RENEWAL -",$G(RES)="OR":"RENEWED -",1:"")_$P($G(^PS(50.3,+NDP1,0)),U)
-        S ORTX(2)=" Give: "_$S($P(NDP1,U,2)]"":$P(NDP1,U,2)_" ",1:"")_$P($G(^PS(51.2,+$P(ND0,U,3),0)),U,3)_" "_$P(ND2,U)_$S($P(ND2,U)["PRN":"",$P(ND0,U,7)="P":" PRN",1:"")
-        I $G(DFN),$G(ON) S:ON["U" ^PS(55,"AUE",DFN,+ON)=""
-        Q
+PSJOREN ;BIR/CML3-INTERFACE FOR INPATIENT PHARMACY AND OE/RR ;07 AUG 97 / 3:21 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**109,127**;16 DEC 97
+ ;
+ ;Reference to ^ORD(100.98 supported by DBIA 873
+ ;Reference to ^PS(51.2 supported by DBIA 2178
+ ;Reference to ^PS(55 supported by DBIA 2191
+ ;
+ENTRY ;
+ K PSGOEE,PSGOES
+ ;S PSJORPF=0 S:ORNP PSJORPV=ORNP,PSJORPVN=$P(^VA(200,+ORNP,0),"^"),X=$G(^("PS")) I $S('ORNP:1,'X:1,'$P(X,"^",4):0,1:$P(X,"^",4)'>DT) D PS I PSJORPF G OUT
+ I '$D(^DPT(+ORVP,.1)) W !!,"THIS PATIENT HAS NOT BEEN ADMITTED.",!,"(Any non-IV orders entered will be discontinued by the pharmacist...)"
+ ;
+GO ; get orders
+ ; S PSJORPCL=XQORNOD,PSJORNS=+XQORNOD,PSJORL=ORL,PSJORTS=ORTS,PSJORVP=ORVP
+ S PSGOEORF=1,PSGOEAV=0,PSJORTOU=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",0)),PSGOEDMR=$O(^PS(51.2,"B","ORAL",0)),PSGOEPR=PSJORPV
+ F  S PSGOEOS="U" D ^PSGOE7 Q:Y<0  D:X?1"S."1.E ^PSGOES I X'?1."S."1.E D ^PSGOE6 K PSGOEE D:$D(Y) ^PSGOETO
+ ;
+DONE ;
+ ; I $P(PSJSYSL,"^",2)]"" S PSGOP=PSGP D ENQL^PSGLW
+ ;
+OUT ;
+ ; S PSJNKF=1 D ENIVKV^PSGSETU K PSJORPCL,PSJORTOI,PSJORTOU,PSJORPV,PSJORPVN,PSJORNS,PSJORVP,PSJORL,PSJORTS,PSGOEORF,PSGOEAV,PSJORPF,PSJORQF,PSJPV,PSGOEOS Q
+ Q  ;
+PS ;
+ W $C(7),!!,"The selected PROVIDER is NOT qualified to write MEDICATION orders.  You must",!,"select a valid provider to be able to continue with Inpatient Medications."
+ K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Select PHARMACY PROVIDER: ",DIC("S")="S PSG=$G(^(""PS"")) I PSG,$S('$P(PSG,""^"",4):1,1:DT<$P(PSG,""^"",4))" F  W ! D ^DIC Q:$D(DUOUT)!$D(DTOUT)!(Y>0)  W $C(7),"  (Required.)"
+ K DIC S:Y'>0 PSJORPF=11 S:Y>0 PSJORPV=+Y,PSJORPVN=Y(0,0) Q
+ Q
+ENBKOUT(DFN,ON) ; Undo Renew.
+ Q:'$G(ON)
+ N PSJOLD,PSJRES,PSJOC,PSJOC2,PSIVACT,PSIVALT,PSIVREA,ON55,PSGAL,DA,PSIVAL,PSJUNDC
+ S PSJOC=PSOC,PSJOC2=PSJHLMTN,PSIVAL=24000
+ S X=$G(^PS(53.1,+ON,0)) Q:'X
+ S PSJRES=$P(X,U,24),(X,PSJOLD)=$P(X,U,25)
+ I PSJOLD["V" S:$D(^PS(55,DFN,"IV",+PSJOLD,2)) $P(^(2),U,6)="",$P(^(2),U,9)="",$P(^(0),U,17)="A",PSIVACT=1,PSIVALT=$S(PSOC="CR":2,1:1),PSJUNDC=1,PSIVAL=$P($G(^PS(53.3,+PSIVAL,0)),U),PSIVREA="PNRD",ON55=PSJOLD D LOG^PSIVORAL
+ I PSJOLD["U" S:$D(^PS(55,DFN,5,+PSJOLD,0)) $P(^(0),U,26,27)=U,$P(^(0),U,9)="A",PSGAL("C")=24000,DA=+PSJOLD,DA(1)=DFN D ^PSGAL5
+ S PSOC="SC",PSJHLMTN="ORM" D EN1^PSJHL2(DFN,PSOC,PSJOLD) S PSOC=PSJOC,PSJHLMTN=PSJOC2
+ Q
+ ;
+ENUDTX(DFN,ON,RES) ; Set up ORTX( Array for UD orders.
+ K ORTX N DO,MRN,ND0,NDP1,ND2,PD,ST,SCH
+ S Y=2 I ON["A"!(ON["O") S ND0=$G(^PS(55,DFN,5,+ON,0)),NDP1=$G(^(.1)),ND2=$G(^(2)),Y=2 F X=0:0 S X=$O(^PS(55,DFN,5,+ON,12,X)) Q:'X  S Y=Y+1,ORTX(Y)=$G(^(X,0))
+ E  S ND0=$G(^PS(53.1,+ON,0)),NDP1=$G(^(.1)),ND2=$G(^(2)),Y=2 F X=0:0 S X=$O(^PS(53.1,+ON,12,X)) Q:'X  S Y=Y+1,ORTX(Y)=$G(^(X,0))
+ S ORTX(1)=$S($G(RES)="NR":"RENEWAL -",$G(RES)="OR":"RENEWED -",1:"")_$P($G(^PS(50.3,+NDP1,0)),U)
+ S ORTX(2)=" Give: "_$S($P(NDP1,U,2)]"":$P(NDP1,U,2)_" ",1:"")_$P($G(^PS(51.2,+$P(ND0,U,3),0)),U,3)_" "_$P(ND2,U)_$S($P(ND2,U)["PRN":"",$P(ND0,U,7)="P":" PRN",1:"")
+ I $G(DFN),$G(ON) S:ON["U" ^PS(55,"AUE",DFN,+ON)=""
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORPOE.m

@@ -1 @@
-PSJORPOE        ;BIR/MLM,LDT-MISC. PROCEDURE CALLS FOR OE/RR 3.0 ;24 Feb 99 / 10:43 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**50,56,92,80,110,127,133,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(50.7 is supported by DBIA# 2180.
-        ; Reference to ^PS(51.2 is supported by DBIA# 2178.
-        ; Reference to ^PS(55 is supported by DBIA# 2191.
-        ; Reference to ^PS(51.1 is supported by DBIA# 2177.
-        ; Reference to ^PS(52.6 is supported by DBIA# 1231.
-        ; Reference to ^PS(52.7 is supported by DBIA# 2173.
-        ; Reference to ^PSDRUG is supported by DBIA# 2192.
-        ;
-STARTSTP(PSGP,SCH,OI,PSJPWD,PSGORD,PSJADM)      ;
-        ; PSGP=Patient IEN
-        ; SCH=Schedule
-        ; OI=Orderable Item        
-        ; PSJPWD=Ward Location (Optional)
-        ; PSGORD=Pharmacy Order Number if the order being placed is a Renewal (Optional)
-        ;
-        Q:+PSGP'>0 ""
-        Q:SCH']"" ""
-        Q:+OI'>0 ""
-        I SCH?.E1L.E S SCH=$$ENLU^PSGMI(SCH)
-        K DFN,PSGNEFDO,PSGNEFD,PSGST,PSGSCH,PSGNEDFD,PSGNESD,PSJSYSW,PSJSYSW0 N RESULT
-        S:'$D(PSGS0XT) PSGS0XT="" S:'$D(PSGS0Y) PSGSOY=""
-        I $G(PSJPWD)']"" S DFN=PSGP D IN5^VADPT S:VAIP(5)]"" PSJPWD=+VAIP(5)
-        S PSJSYSW0="",PSJSYSW=0 I $G(PSJPWD)]"" S PSJSYSW=+$O(^PS(59.6,"B",PSJPWD,0)) I PSJSYSW S PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
-        S RESULT=$S($P(PSJSYSW0,"^",5)=0:"CLOSEST",$P(PSJSYSW0,"^",5)=1:"NEXT",1:"NOW")
-        I OI]"" S PSGST=$S($P($G(^PS(50.7,OI,0)),"^",7)]"":$P($G(^PS(50.7,OI,0)),"^",7),1:"C")
-        N %,PSGXSCH D NOW^%DTC S PSGDT=%,DFN=PSGP,(PSGSCH,PSGXSCH)=SCH
-        S X=PSGSCH,PSGS0Y="" D ADMIN
-        I $G(PSGORD)]"" D
-        .S PSGNESD=$$DSTART^PSJDCU(PSGP,PSGORD) I PSGNESD]"" S $P(RESULT,"^",2)=PSGNESD Q
-        .S ND=$S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,2)),1:$G(^PS(55,PSGP,"IV",+PSGORD,0)))
-        .N PSJADM,PSJSTRT S PSJADM=$S(PSGORD["U":$P(ND,"^",5),1:$P(ND,"^",11)),PSJSTRT=$P(ND,"^",2),PSJREN=1
-        S SCH=PSGXSCH
-        N PSJTMPW0 S PSJTMPW0=PSJSYSW0 S $P(PSJSYSW0,"^",5)=1
-        I $G(PSGNESD)="" S RESULT=RESULT_"^"_$$ENSD^PSGNE3(PSGSCH,$S($G(PSJADM)]"":$G(PSJADM),1:PSGS0Y),PSGDT,$S($G(PSJSTRT)]"":$G(PSJSTRT),1:PSGDT))
-        S PSJSYSW0=PSJTMPW0
-        S PSGNESD=$P(RESULT,"^",2)
-        S PSGNEDFD=$$GTNEDFD^PSGOE7("U",OI)
-        K PSGODF,PSGOES,PSJREN
-        S SCH=PSGXSCH
-        D ENFD^PSGNE3(PSGDT) S RESULT=RESULT_"^"_$G(PSGNEFD) ;_"^"_$G(PSGNEFDO)
-        N DATE S DATE=$$FMDIFF^XLFDT($P(RESULT,"^",3),$P(RESULT,"^",2),3)
-        S $P(RESULT,"^",3)=$S($G(PSGST)="O":0,+DATE>0:+DATE_"D",$P($P(DATE," ",2),":")>0:$P($P(DATE," ",2),":")_"H",1:0)
-        N STRING S STRING=PSGNESD_U_PSGNEFD_U_$G(PSGSCH)_U_$G(PSGST)_U_$G(OI) I ($P($G(ZZND),U,2)]"")&($P($G(ZZND),"^")=$G(PSGSCH)) S STRING=STRING_U_$P(ZZND,U,2)
-        I $G(PSGSCH)]"" I $$DOW^PSIVUTL(PSGSCH) S:$G(PSGS0Y) $P(STRING,"^",6)=PSGS0Y
-        I $G(PSJADM) S $P(STRING,"^",6)=PSJADM
-        S RESULT=RESULT_"^"_$$ENQ^PSJORP2(PSGP,STRING) I ($G(PSGSCH)]"") I $$DOW^PSIVUTL(PSGSCH),(PSGSCH'["@"),'$G(PSGS0Y) S $P(RESULT,"^",4)=$P(RESULT,"^",2)
-        I ($G(PSGSCH)]"") I $$PRNOK^PSGS0(PSGSCH) S $P(RESULT,"^",4)=$P(RESULT,"^",2)
-        D KVAR^VADPT K LYN,ND,PSGDT,PSGNEDFD,PSGNEFD,PSGNEFDO,PSGNESD,PSGS0Y,PSGSCH,PSGST,PSJSYSW,PSJSYSW0,ZZ
-        ;RESULT=WARD PARAMETER^DEFAULT START DATE/TIME^#_D(NUMBER OF DAYS ORDER LASTS) OR #_H(NUMBER OF HOURS ORDER LASTS)^EXPECTED FIRST DOSE
-        Q RESULT
-        ;
-RESOLVE(PSGP,SCH,OI,PCH,PSJPWD,PSJADM)  ;
-        ; PSGP=Patient IEN
-        ; SCH=Schedule
-        ; OI=Orderable Item
-        ; PCH=Providers Choice
-        ; PSJPWD=Ward Location (Optional)
-        ; PSJADM=Admin Times (Optional)
-        ;
-        N PSJSYSW0,PSJSYSW,PSGSCH,PSGOES,PSGS0Y,DFN,RESULT1
-        I $G(PSJPWD)']"" S DFN=PSGP D IN5^VADPT S:VAIP(5)]"" PSJPWD=+VAIP(5)
-        S PSJSYSW0="",PSJSYSW=0 I $G(PSJPWD)]"" S PSJSYSW=+$O(^PS(59.6,"B",PSJPWD,0)) I PSJSYSW S PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
-        S $P(PSJSYSW0,"^",5)=$S($$ONE(SCH):2,PCH="NEXT":1,1:0)
-        S RESULT1=$S($P(PSJSYSW0,"^",5)=0:"CLOSEST",$P(PSJSYSW0,"^",5)=1:"NEXT",1:"NOW")
-        I OI]"" S PSGST=$S($P($G(^PS(50.7,OI,0)),"^",7)]"":$P($G(^PS(50.7,OI,0)),"^",7),1:"C")
-        N % D NOW^%DTC S PSGDT=%,DFN=PSGP,PSGSCH=SCH
-        S X=PSGSCH,PSGS0Y="" I $D(^PS(51.1,"AC","PSJ",X)) D ADMIN
-        S:$G(PSJADM) PSGS0Y=PSJADM
-        S RESULT1=RESULT1_"^"_$$ENSD^PSGNE3(SCH,PSGS0Y,PSGDT,PSGDT)
-        I $G(PSGSCH)]"" I $$DOW^PSIVUTL(PSGSCH),(PSGSCH'["@"),'$G(PSGS0Y) S $P(RESULT,"^",4)=$P(RESULT,"^",2)
-        I $G(PSGSCH)]"" I $$PRNOK^PSGS0(PSGSCH) S $P(RESULT1,"^",4)=$P(RESULT,"^",2)
-        D KVAR^VADPT K LYN,PSGDT,PSGNEDFD,PSGNEFD,PSGNEFDO,PSGNESD,PSGS0Y,PSGSCH,PSGST,PSJSYSW,PSJSYSW0,ZZ,PSGS0XT,PSGS0Y
-        Q RESULT1
-        ;
-SCHREQ(MR,OI,DD)         ;
-        ; MR=Medication Route from 51.2 (Required)
-        ; OI=Orderable Item from 50.7 (Optional)
-        ; DD=Dispense Drug from 50 (Optional)
-        N ADDITIVE,SOLUTION,REQ S REQ=0,(SOLUTION,ADDITIVE)=""
-        I '+$G(MR) S REQ=1 Q REQ
-        I '+$G(OI),'+$G(DD) S REQ=1 Q REQ
-        I +$G(DD) S:$P($G(^PSDRUG(+DD,2)),U,3)["U" REQ=1 Q REQ
-        I '$D(PS(51.2,+MR,0)) S REQ=1 Q REQ
-        I $P($G(^PS(51.2,+MR,0)),"^",6)=1 D
-        .I +$G(OI) D
-        ..I '$D(^PS(50.7,+OI,0)) S REQ=1 Q
-        ..F  S SOLUTION=$O(^PS(52.7,"AOI",+OI,SOLUTION)) Q:'SOLUTION  Q:REQ=1  S:$P(^PSDRUG(+$P(^PS(52.7,SOLUTION,0),U,2),2),U,3)["U" REQ=1
-        ..F  S ADDITIVE=$O(^PS(52.6,"AOI",+OI,ADDITIVE)) Q:'ADDITIVE  Q:REQ=1  S:$P(^PSDRUG(+$P(^PS(52.6,ADDITIVE,0),U,2),2),U,3)["U" REQ=1
-        Q REQ
-        ;
-ADMIN   ; Get admin times associated with schedule
-        S PSGS0Y="",ZZ=0
-        I $$DOW^PSIVUTL($P(X,"@")),'$D(^PS(51.1,"AC","PSJ",X)) S PSGST="D" D  Q:$G(PSGS0Y)
-        .I $P(X,"@",2) N PSJADBAD D  Q
-        ..S PSGS0Y=$S($G(PSJADBAD):"",1:$P(X,"@",2))
-        ..N ADMIN,TIME,II S ADMIN=$P(X,"@",2) F II=1:1:$L(ADMIN,"-") S TIME=$P(ADMIN,"-",II) I TIME'?2N&(TIME'?4N) S PSJADBAD=1
-        .I $P(X,"@",2)]"",$D(^PS(51.1,"APPSJ",$P(X,"@",2))) S X=$P(X,"@",2)
-        D FIND^DIC(51.1,,,,X,,"APPSJ",,,"LYN")
-        S ZZ=$O(LYN("DILIST",2,ZZ)) I ZZ S ZZ=+LYN("DILIST",2,ZZ) I ZZ S ZZND=$G(^PS(51.1,ZZ,0)) S PSGST=$P(ZZND,U,5),PSGS0XT=$P(ZZND,U,3) S:$G(PSGSFLG) PSGSCIEN=$G(LYN("DILIST",2,ZZ)) I $G(PSJPWD) D
-        . N ZZNDW S ZZNDW=$G(^PS(51.1,ZZ,1,PSJPWD,0)) I $P(ZZNDW,"^",2)]"" S PSGS0Y=$P(ZZNDW,"^",2),$P(ZZND,"^",2)=PSGS0Y I $G(PSGSFLG) S PSGSCIEN=$G(LYN("DILIST",2,ZZ))
-        S ZZ=0 F  S ZZ=$O(LYN("DILIST",1,ZZ)) Q:'ZZ  I $G(LYN("DILIST",1,ZZ))'=X K LYN("DILIST",1,ZZ),LYN("DILIST",2,ZZ),LYN("DILIST","ID",ZZ,1)
-        I $D(PSJPWD) S ZZ=0 F  S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ!$G(PSGS0Y)  I $P($G(^PS(51.1,+LYN("DILIST",2,ZZ),1,+PSJPWD,0)),U,2)]"" S PSGS0Y=$P($G(^(0)),U,2) I $G(PSGSFLG) S PSGSCIEN=$G(LYN("DILIST",2,ZZ))
-        Q:PSGS0Y]""  S ZZ=0 F  S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ!$G(PSGS0Y)  I $G(LYN("DILIST","ID",ZZ,1))]"" S PSGS0Y=$G(LYN("DILIST","ID",ZZ,1))
-        Q
-        ;
-ONE(SCH)        ;
-        ; SCH=Admin Schedule
-        ; Returns 0 = (zero) Not a one time schedule.
-        ;         1 =  One time schedule. 
-        Q:$G(SCH)="" 0
-        N X,SCHLST
-        S SCHLST=",TODAY,ONCE,NOW,ONE TIME,ONETIME,ONE-TIME,1TIME,1 TIME,1-TIME,STAT,"
-        I SCHLST[(","_SCH_",") Q 1
-        I $D(^PS(51.1,"AC","PSJ",SCH)) S X=$O(^(SCH,"")) S X=$P(^PS(51.1,X,0),"^",5) Q $S(X="O":1,1:0)
-        Q 0
+PSJORPOE ;BIR/MLM,LDT-MISC. PROCEDURE CALLS FOR OE/RR 3.0 ;24 Feb 99 / 10:43 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**50,56,92,80,110,127,133**;16 DEC 97
+ ;
+ ; Reference to ^PS(50.7 is supported by DBIA# 2180.
+ ; Reference to ^PS(51.2 is supported by DBIA# 2178.
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^PS(51.1 is supported by DBIA# 2177.
+ ; Reference to ^PS(52.6 is supported by DBIA# 1231.
+ ; Reference to ^PS(52.7 is supported by DBIA# 2173.
+ ; Reference to ^PSDRUG is supported by DBIA# 2192.
+ ;
+STARTSTP(PSGP,SCH,OI,PSJPWD,PSGORD) ;
+ ; PSGP=Patient IEN
+ ; SCH=Schedule
+ ; OI=Orderable Item        
+ ; PSJPWD=Ward Location (Optional)
+ ; PSGORD=Pharmacy Order Number if the order being placed is a Renewal (Optional)
+ ;
+ Q:+PSGP'>0 ""
+ Q:SCH']"" ""
+ Q:+OI'>0 ""
+ I SCH?.E1L.E S SCH=$$ENLU^PSGMI(SCH)
+ K DFN,PSGNEFDO,PSGNEFD,PSGST,PSGSCH,PSGNEDFD,PSGNESD,PSJSYSW,PSJSYSW0 N RESULT
+ S:'$D(PSGS0XT) PSGS0XT="" S:'$D(PSGS0Y) PSGSOY=""
+ I $G(PSJPWD)']"" S DFN=PSGP D IN5^VADPT S:VAIP(5)]"" PSJPWD=+VAIP(5)
+ S PSJSYSW0="",PSJSYSW=0 I $G(PSJPWD)]"" S PSJSYSW=+$O(^PS(59.6,"B",PSJPWD,0)) I PSJSYSW S PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
+ S RESULT=$S($P(PSJSYSW0,"^",5)=0:"CLOSEST",$P(PSJSYSW0,"^",5)=1:"NEXT",1:"NOW")
+ I OI]"" S PSGST=$S($P($G(^PS(50.7,OI,0)),"^",7)]"":$P($G(^PS(50.7,OI,0)),"^",7),1:"C")
+ N %,PSGXSCH D NOW^%DTC S PSGDT=%,DFN=PSGP,(PSGSCH,PSGXSCH)=SCH
+ S X=PSGSCH,PSGS0Y="" D ADMIN
+ I $G(PSGORD)]"" D
+ .S PSGNESD=$$DSTART^PSJDCU(PSGP,PSGORD) I PSGNESD]"" S RESULT=RESULT_"^"_PSGNESD Q
+ .S ND=$S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,2)),1:$G(^PS(55,PSGP,"IV",+PSGORD,0)))
+ .N PSJADM,PSJSTRT S PSJADM=$S(PSGORD["U":$P(ND,"^",5),1:$P(ND,"^",11)),PSJSTRT=$P(ND,"^",2),PSJREN=1
+ S SCH=PSGXSCH
+ I $G(PSGNESD)="" S RESULT=RESULT_"^"_$$ENSD^PSGNE3(PSGSCH,$S($G(PSJADM)]"":$G(PSJADM),1:PSGS0Y),PSGDT,$S($G(PSJSTRT)]"":$G(PSJSTRT),1:PSGDT))
+ ;S Y=$P(RESULT,"^",2) X ^DD("DD") S RESULT=RESULT_"^"_Y
+ S PSGNESD=$P(RESULT,"^",2)
+ S PSGNEDFD=$$GTNEDFD^PSGOE7("U",OI)
+ K PSGODF,PSGOES,PSJREN
+ S SCH=PSGXSCH
+ D ENFD^PSGNE3(PSGDT) S RESULT=RESULT_"^"_$G(PSGNEFD) ;_"^"_$G(PSGNEFDO)
+ N DATE S DATE=$$FMDIFF^XLFDT($P(RESULT,"^",3),$P(RESULT,"^",2),3)
+ S $P(RESULT,"^",3)=$S($G(PSGST)="O":0,+DATE>0:+DATE_"D",$P($P(DATE," ",2),":")>0:$P($P(DATE," ",2),":")_"H",1:0)
+ ;S RESULT=RESULT_"^"_$P($$RESOLVE(PSGP,SCH,OI,"NEXT"),"^",2)
+ N STRING S STRING=PSGNESD_U_PSGNEFD_U_$G(PSGSCH)_U_$G(PSGST)_U_$G(OI) I ($P($G(ZZND),U,2)]"")&($P($G(ZZND),"^")=$G(PSGSCH)) S STRING=STRING_U_$P(ZZND,U,2)
+ I $G(PSGSCH)]"" I $$DOW^PSIVUTL(PSGSCH) S:$G(PSGS0Y) $P(STRING,"^",6)=PSGS0Y
+ S RESULT=RESULT_"^"_$$ENQ^PSJORP2(PSGP,STRING) I ($G(PSGSCH)]"") I $$DOW^PSIVUTL(PSGSCH),(PSGSCH'["@"),'$G(PSGS0Y) S $P(RESULT,"^",4)=$P(RESULT,"^",2)
+ I ($G(PSGSCH)]"") I $$PRNOK^PSGS0(PSGSCH) S $P(RESULT,"^",4)=$P(RESULT,"^",2)
+ D KVAR^VADPT K LYN,ND,PSGDT,PSGNEDFD,PSGNEFD,PSGNEFDO,PSGNESD,PSGS0Y,PSGSCH,PSGST,PSJSYSW,PSJSYSW0,ZZ
+ ;RESULT=WARD PARAMETER^DEFAULT START DATE/TIME^#_D(NUMBER OF DAYS ORDER LASTS) OR #_H(NUMBER OF HOURS ORDER LASTS)^EXPECTED FIRST DOSE
+ Q RESULT
+ ;
+RESOLVE(PSGP,SCH,OI,PCH,PSJPWD) ;
+ ; PSGP=Patient IEN
+ ; SCH=Schedule
+ ; OI=Orderable Item
+ ; PCH=Providers Choice
+ ; PSJPWD=Ward Location (Optional)
+ ;
+ N PSJSYSW0,PSJSYSW,PSGSCH,PSGOES,PSGS0Y,DFN,RESULT1
+ I $G(PSJPWD)']"" S DFN=PSGP D IN5^VADPT S:VAIP(5)]"" PSJPWD=+VAIP(5)
+ S PSJSYSW0="",PSJSYSW=0 I $G(PSJPWD)]"" S PSJSYSW=+$O(^PS(59.6,"B",PSJPWD,0)) I PSJSYSW S PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
+ S $P(PSJSYSW0,"^",5)=$S($$ONE(SCH):2,PCH="NEXT":1,1:0)
+ S RESULT1=$S($P(PSJSYSW0,"^",5)=0:"CLOSEST",$P(PSJSYSW0,"^",5)=1:"NEXT",1:"NOW")
+ I OI]"" S PSGST=$S($P($G(^PS(50.7,OI,0)),"^",7)]"":$P($G(^PS(50.7,OI,0)),"^",7),1:"C")
+ N % D NOW^%DTC S PSGDT=%,DFN=PSGP,PSGSCH=SCH
+ S X=PSGSCH,PSGS0Y="" I $D(^PS(51.1,"AC","PSJ",X)) D ADMIN
+ S RESULT1=RESULT1_"^"_$$ENSD^PSGNE3(SCH,PSGS0Y,PSGDT,PSGDT)
+ I $G(PSGSCH)]"" I $$DOW^PSIVUTL(PSGSCH),(PSGSCH'["@"),'$G(PSGS0Y) S $P(RESULT,"^",4)=$P(RESULT,"^",2)
+ I $G(PSGSCH)]"" I $$PRNOK^PSGS0(PSGSCH) S $P(RESULT1,"^",4)=$P(RESULT,"^",2)
+ D KVAR^VADPT K LYN,PSGDT,PSGNEDFD,PSGNEFD,PSGNEFDO,PSGNESD,PSGS0Y,PSGSCH,PSGST,PSJSYSW,PSJSYSW0,ZZ,PSGS0XT,PSGS0Y
+ Q RESULT1
+ ;
+SCHREQ(MR,OI,DD)  ;
+ ; MR=Medication Route from 51.2 (Required)
+ ; OI=Orderable Item from 50.7 (Optional)
+ ; DD=Dispense Drug from 50 (Optional)
+ N ADDITIVE,SOLUTION,REQ S REQ=0,(SOLUTION,ADDITIVE)=""
+ I '+$G(MR) S REQ=1 Q REQ
+ I '+$G(OI),'+$G(DD) S REQ=1 Q REQ
+ I +$G(DD) S:$P($G(^PSDRUG(+DD,2)),U,3)["U" REQ=1 Q REQ
+ I '$D(PS(51.2,+MR,0)) S REQ=1 Q REQ
+ I $P($G(^PS(51.2,+MR,0)),"^",6)=1 D
+ .I +$G(OI) D
+ ..I '$D(^PS(50.7,+OI,0)) S REQ=1 Q
+ ..F  S SOLUTION=$O(^PS(52.7,"AOI",+OI,SOLUTION)) Q:'SOLUTION  Q:REQ=1  S:$P(^PSDRUG(+$P(^PS(52.7,SOLUTION,0),U,2),2),U,3)["U" REQ=1
+ ..F  S ADDITIVE=$O(^PS(52.6,"AOI",+OI,ADDITIVE)) Q:'ADDITIVE  Q:REQ=1  S:$P(^PSDRUG(+$P(^PS(52.6,ADDITIVE,0),U,2),2),U,3)["U" REQ=1
+ Q REQ
+ ;
+ADMIN ; Get admin times associated with schedule
+ S PSGS0Y="",ZZ=0
+ I $$DOW^PSIVUTL(X),'$D(^PS(51.1,"AC","PSJ",X)) S PSGST="D" D  Q
+ .I $P(X,"@",2) N PSJADBAD D  I '$G(PSJADBAD) S PSGS0Y=$P(X,"@",2)
+ ..N ADMIN,TIME,II S ADMIN=$P(X,"@",2) F II=1:1:$L(ADMIN,"-") S TIME=$P(ADMIN,"-",II) I TIME'?2N&(TIME'?4N) S PSJADBAD=1
+ .I '$G(PSGS0Y) S PSGS0Y=""
+ D FIND^DIC(51.1,,,,X,,"APPSJ",,,"LYN")
+ S ZZ=$O(LYN("DILIST",2,ZZ)) I ZZ S ZZ=+LYN("DILIST",2,ZZ) I ZZ S ZZND=$G(^PS(51.1,ZZ,0)) S PSGST=$P(ZZND,U,5),PSGS0XT=$P(ZZND,U,3) I $G(PSJPWD) D
+ . N ZZNDW S ZZNDW=$G(^PS(51.1,ZZ,1,PSJPWD,0)) I $P(ZZNDW,"^",2)]"" S PSGS0Y=$P(ZZNDW,"^",2),$P(ZZND,"^",2)=PSGS0Y
+ S ZZ=0 F  S ZZ=$O(LYN("DILIST",1,ZZ)) Q:'ZZ  I $G(LYN("DILIST",1,ZZ))'=X K LYN("DILIST",1,ZZ),LYN("DILIST",2,ZZ),LYN("DILIST","ID",ZZ,1)
+ I $D(PSJPWD) S ZZ=0 F  S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ  I $P($G(^PS(51.1,+LYN("DILIST",2,ZZ),1,+PSJPWD,0)),U,2)]"" S PSGS0Y=$P($G(^(0)),U,2)
+ Q:PSGS0Y]""  S ZZ=0 F  S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ  Q:PSGS0Y]""  I $G(LYN("DILIST","ID",ZZ,1))]"" S PSGS0Y=$G(LYN("DILIST","ID",ZZ,1))
+ Q
+ ;
+ONE(SCH) ;
+ ; SCH=Admin Schedule
+ ; Returns 0 = (zero) Not a one time schedule.
+ ;         1 =  One time schedule. 
+ Q:$G(SCH)="" 0
+ N X,SCHLST
+ S SCHLST=",TODAY,ONCE,NOW,ONE TIME,ONETIME,ONE-TIME,1TIME,1 TIME,1-TIME,STAT,"
+ I SCHLST[(","_SCH_",") Q 1
+ I $D(^PS(51.1,"AC","PSJ",SCH)) S X=$O(^(SCH,"")) S X=$P(^PS(51.1,X,0),"^",5) Q $S(X="O":1,1:0)
+ Q 0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE.m

@@ -1 @@
-PSJORRE ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (CONDENSED) ;28 Jan 99 / 12:56 PM
-        ;;5.0; INPATIENT MEDICATIONS ;**22,51,50,58,81,110,111,112,134**;16 DEC 97;Build 124
-        ;
-        ;Reference to ^PS(52.6 is supported by DBIA 1231.
-        ;Reference to ^PS(52.7 is supported by DBIA 2173.
-        ;Reference to ^PS(55 is supported by DBIA 2191.
-        ;Reference to ^TMP("PS" is documented in DBIA #2383.
-        ;
-OCL(DFN,BDT,EDT,TFN,MVIEW)              ; return condensed list of inpat meds
-        ; MVIEW=0   -  This returns the 'unsorted' list as it was returned prior to GUI 27 
-        ; MVIEW=1   -  This returns the old sort view of the list, pre-sorted for GUI 27
-        ; MVIEW=2   -  This returns new sort view #1 of the order profile for GUI 27 
-        ; MVIEW=3   -  This returns new sort view #2 of the order profile for GUI 27
-        D @$S($G(MVIEW)=3:"OCL^PSJORRN1(DFN,BDT,EDT,.TFN)",$G(MVIEW)=2:"OCL^PSJORRN(DFN,BDT,EDT,.TFN)",$G(MVIEW)=1:"OCL^PSJORRO(DFN,BDT,EDT,.TFN)",1:"OCL1(DFN,BDT,EDT,TFN)")
-        Q
-OCL1(DFN,BDT,EDT,TFN,MVIEW)     ; Execute this section if MVIEW=0
-        N ADM,CNT,DN,DO,F,FON,INFUS,INST,MR,ND,ND0,ND2,ND6,ON,PON,PST,SCH,SIO,STAT,TYPE,UNITS,WBDT,X,Y,PSJCLIN,A
-        ; PON=placer order number (oerr), FON=filler order number
-        S:BDT="" BDT=DT S WBDT=BDT_".000001"
-        S:EDT="" EDT=9999999
-        S:EDT'["." EDT=EDT_".999999"
-        S F="^PS(55,DFN,5," F  S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT  F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON  D UDTMP
-        S F="^PS(53.1," F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON  S X=$P($G(^PS(53.1,+ON,0)),U,4) D @$S(X="U":"UDTMP",1:"IVTMP")
-        S F="^PS(55,"_DFN_",""IV"",",WBDT=BDT F  S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT  F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON  D IVTMP
-        Q
-        ;
-UDTMP   ;*** Set ^TMP for Unit dose orders.
-        N PROVIDER,RNWDT,EDTCMPLX,NDP2 S (MR,SCH,INST,PON)="",FON=+ON_$S(F["53.1":"P",1:"U")
-        D TYPE
-        S RNWDT=$$LASTREN^PSJLMPRI(DFN,FON) I RNWDT S RNWDT=+RNWDT
-        S NDP2=$G(@(F_ON_",.2)")) S EDTCMPLX=$P(NDP2,"^",8)
-        S ND2=$G(@(F_ON_",2)")) I 'EDTCMPLX I F'["53.1",($P(ND2,U,2)>EDT) Q
-        S ND0=$G(@(F_ON_",0)")) I 'EDTCMPLX I F["53.1",($P(ND0,U,16)>EDT) Q
-        S STAT=$$CODES^PSIVUTL($P(ND0,U,9),$S(FON["P":53.1,1:55.06),28)
-        S ND6=$P($G(@(F_ON_",6)")),"^"),INST=$G(@(F_+ON_",.3)"))
-        S FON=+ON_$S(F["53.1":"P",1:"U"),DO=$P($G(@(F_ON_",.2)")),"^",2)
-        D DRGDISP^PSJLMUT1(DFN,FON,40,0,.DN,1)
-        S UNITS="" I '$O(@(F_+ON_",1,1)")) S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2) S:(FON["U")&(UNITS="") UNITS=1
-        S:+$P(ND0,U,3) MR=$$MR^PSJORRE1(+$P(ND0,U,3))
-        N NOTGIVEN S NOTGIVEN=$S(FON["U":$P($G(^PS(55,DFN,5,+ON,0)),"^",22),1:"")
-        S TFN=TFN+1
-        S ^TMP("PS",$J,TFN,0)=FON_";I"_U_DN(1)_"^^"_$P(ND2,U,4)_"^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_STAT_U_U_U_U_NOTGIVEN_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_$P(ND2,U,2)_U_$G(RNWDT)
-        K ^TMP("PS",$J,TFN,"CLINIC",0) I PSJCLIN]"" S ^TMP("PS",$J,TFN,"CLINIC",0)=PSJCLIN
-        S PROVIDER=$P($G(@(F_+ON_",0)")),"^",2)
-        I PROVIDER S ^TMP("PS",$J,TFN,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^")
-        S ^TMP("PS",$J,TFN,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,TFN,"MDR",1,0)=MR
-        S ^TMP("PS",$J,TFN,"SCH",0)=$P(ND2,U)]"" S:$P(ND2,U)]"" ^TMP("PS",$J,TFN,"SCH",1,0)=$P(ND2,U)
-        S ^TMP("PS",$J,TFN,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,TFN,"SIG",1,0)=INST
-        S ^TMP("PS",$J,TFN,"ADM",0)=$P(ND2,U,5)]"" S:$P(ND2,U,5)]"" ^TMP("PS",$J,TFN,"ADM",1,0)=$P(ND2,U,5)
-        S ^TMP("PS",$J,TFN,"SIO",0)=ND6]"" S:ND6]"" ^TMP("PS",$J,TFN,"SIO",1,0)=ND6
-        Q
-        ;
-IVTMP   ;*** Set ^TMP for IV orders.
-        N PROVIDER,START,STOP,EDTCMPLX,NDP2,IVLIM
-        S NDP2=$G(@(F_ON_",.2)")) S EDTCMPLX=$P(NDP2,"^",8)
-        S ND0=$G(@(F_ON_",0)")) I 'EDTCMPLX I F'["53.1",($P(ND0,U,2)>EDT) Q
-        D TYPE
-        S FON=+ON_$S(F["53.1":"P",1:"V"),TFN=TFN+1,CNT=0
-        S RNWDT=$$LASTREN^PSJLMPRI(DFN,FON) I RNWDT S RNWDT=+RNWDT
-        F X=0:0 S X=$O(@(F_ON_",""AD"","_X_")")) Q:'X  S ND=$G(@(F_ON_",""AD"","_X_",0)")),DN=$P($G(^PS(52.6,+ND,0)),U),Y=DN_U_$P(ND,U,2) S:$P(ND,U,3) Y=Y_U_$P(ND,U,3) S CNT=CNT+1,^TMP("PS",$J,TFN,"A",CNT,0)=Y
-        S ^TMP("PS",$J,TFN,"A",0)=CNT,CNT=0
-        F X=0:0 S X=$O(@(F_ON_",""SOL"","_X_")")) Q:'X  S ND=$G(@(F_ON_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0)),CNT=CNT+1,^TMP("PS",$J,TFN,"B",CNT,0)=$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4)
-        S ^TMP("PS",$J,TFN,"B",0)=CNT
-        S TYPE=$P(ND0,U,4),(MR,SCH,INST,INFUS)=""
-        I FON["P" S ND2=$G(^PS(53.1,+ON,2)),SCH=$P(ND2,U),START=$P(ND2,U,2),STOP=$P(ND2,U,4),MR=$P(ND0,U,3),INFUS=$P($G(^PS(53.1,+ON,8)),U,5),STAT=$$CODES^PSIVUTL($P(ND0,U,9),53.1,28),ADM=$P(ND2,U,5),SIO=$P($G(@(F_+ON_",6)")),"^")
-        I FON'["P" S START=$P(ND0,U,2),STOP=$P(ND0,U,3),SCH=$P(ND0,U,9),INFUS=$P(ND0,U,8),MR=$P($G(^PS(55,DFN,"IV",+ON,.2)),U,3),STAT=$$CODES^PSIVUTL($P(ND0,U,17),55.01,100),ADM=$P(ND0,U,11),SIO=$P($G(@(F_+ON_",3)")),"^")
-        S DN=$G(@(F_+ON_",.2)")),DO=$P(DN,U,2)
-        S DN=$S(+$P(DN,U):$$OIDF^PSJLMUT1($P(DN,U)),1:"")
-        S:MR MR=$$MR^PSJORRE1(+MR),INST=$G(@(F_+ON_",.3)"))
-        S ^TMP("PS",$J,TFN,0)=FON_";I"_U_DN_U_INFUS_U_STOP_"^^"_DO_"^^"_$P(ND0,"^",21)_U_STAT_U_U_U_U_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_START_U_$G(RNWDT)
-        K ^TMP("PS",$J,TFN,"CLINIC",0) I PSJCLIN]"" S ^TMP("PS",$J,TFN,"CLINIC",0)=PSJCLIN
-        S PROVIDER=$P($G(@(F_+ON_",0)")),"^",6)
-        I PROVIDER S ^TMP("PS",$J,TFN,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^")
-        S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4) I $E(IVLIM)="a" S IVLIM="doses"_$P(IVLIM,"a",2)
-        I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM=""
-        S ^TMP("PS",$J,TFN,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,TFN,"MDR",1,0)=MR
-        S ^TMP("PS",$J,TFN,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,TFN,"SIG",1,0)=INST
-        S ^TMP("PS",$J,TFN,"SCH",0)=SCH]"" S:SCH]"" ^TMP("PS",$J,TFN,"SCH",1,0)=SCH
-        S ^TMP("PS",$J,TFN,"ADM",0)=ADM]"" S:ADM]"" ^TMP("PS",$J,TFN,"ADM",1,0)=ADM
-        S ^TMP("PS",$J,TFN,"SIO",0)=SIO]"" S:SIO]"" ^TMP("PS",$J,TFN,"SIO",1,0)=SIO
-        I $G(IVLIM)]"" S ^TMP("PS",$J,TFN,"IVLIM",0)=IVLIM
-        Q
-STAT(Y,X)       ;* Return the full status instead of just the code for U/D.
-        S X=$P($P(";"_$P(Y,U,3),";"_X_":",2),";")
-        Q X
-TYPE    ;determine if this is an IMO order or not
-        S (A,PSJCLIN)="" I F["PS(53.1" S A=$G(^PS(53.1,ON,"DSS"))
-        I F["PS(55" S A=$S(F["IV":$G(^PS(55,DFN,"IV",ON,"DSS")),1:$G(^PS(55,DFN,5,ON,8)))
-        I $P(A,"^",2)'="" S PSJCLIN=+A
-        Q
+PSJORRE ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (CONDENSED) ;28 Jan 99 / 12:56 PM
+ ;;5.0; INPATIENT MEDICATIONS ;**22,51,50,58,81,110,111,112**;16 DEC 97
+ ;
+ ;Reference to ^PS(52.6 is supported by DBIA 1231.
+ ;Reference to ^PS(52.7 is supported by DBIA 2173.
+ ;Reference to ^PS(55 is supported by DBIA 2191.
+ ;Reference to OTF^OR3CONV is supported by DBIA 2412.
+ ;Reference to ^TMP("PS" is documented in DBIA #2383.
+ ;
+OCL(DFN,BDT,EDT,TFN)         ; return condensed list of inpat meds
+ N ADM,CNT,DN,DO,F,FON,INFUS,INST,MR,ND,ND0,ND2,ND6,ON,PON,PST,SCH,SIO,STAT,TYPE,UNITS,WBDT,X,Y,PSJCLIN,A
+ ;Check if 5.0 order conversion should be run for the selected patient.
+ F  S X=$$OTF^OR3CONV(DFN,$S($E($G(IOST),1)="C":0,1:1)) Q:+X'<0  D
+ .I +X=-1 H 3
+ ; PON=placer order number (oerr), FON=filler order number
+ S:BDT="" BDT=DT S WBDT=BDT_".000001"
+ S:EDT="" EDT=9999999
+ S:EDT'["." EDT=EDT_".999999"
+ S F="^PS(55,DFN,5," F  S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT  F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON  D UDTMP
+ S F="^PS(53.1," F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON  S X=$P($G(^PS(53.1,+ON,0)),U,4) D @$S(X="U":"UDTMP",1:"IVTMP")
+ S F="^PS(55,"_DFN_",""IV"",",WBDT=BDT-1 F  S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT  F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON  D IVTMP
+ Q
+ ;
+UDTMP ;*** Set ^TMP for Unit dose orders.
+ N PROVIDER,RNWDT,EDTCMPLX,NDP2 S (MR,SCH,INST,PON)="",FON=+ON_$S(F["53.1":"P",1:"U")
+ D TYPE
+ S RNWDT=$$LASTREN^PSJLMPRI(DFN,FON) I RNWDT S RNWDT=+RNWDT
+ S NDP2=$G(@(F_ON_",.2)")) S EDTCMPLX=$P(NDP2,"^",8)
+ S ND2=$G(@(F_ON_",2)")) I 'EDTCMPLX I F'["53.1",($P(ND2,U,2)>EDT) Q
+ S ND0=$G(@(F_ON_",0)")) I 'EDTCMPLX I F["53.1",($P(ND0,U,16)>EDT) Q
+ S STAT=$$CODES^PSIVUTL($P(ND0,U,9),$S(FON["P":53.1,1:55.06),28)
+ S ND6=$P($G(@(F_ON_",6)")),"^"),INST=$G(@(F_+ON_",.3)"))
+ S FON=+ON_$S(F["53.1":"P",1:"U"),DO=$P($G(@(F_ON_",.2)")),"^",2)
+ D DRGDISP^PSJLMUT1(DFN,FON,40,0,.DN,1)
+ ;S UNITS="" I '$O(@(F_+ON_",1,1)")),DO="" S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2)
+ S UNITS="" I '$O(@(F_+ON_",1,1)")) S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2) S:(FON["U")&(UNITS="") UNITS=1
+ S:+$P(ND0,U,3) MR=$$MR^PSJORRE1(+$P(ND0,U,3))
+ N NOTGIVEN S NOTGIVEN=$S(FON["U":$P($G(^PS(55,DFN,5,+ON,0)),"^",22),1:"")
+ S TFN=TFN+1
+ S ^TMP("PS",$J,TFN,0)=FON_";I"_U_DN(1)_"^^"_$P(ND2,U,4)_"^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_STAT_U_U_U_U_NOTGIVEN_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_$P(ND2,U,2)_U_$G(RNWDT)
+ K ^TMP("PS",$J,TFN,"CLINIC",0) I PSJCLIN]"" S ^TMP("PS",$J,TFN,"CLINIC",0)=PSJCLIN
+ ;*S ^TMP("PS",$J,TFN,0)=FON_";I"_U_DN(1)_"^^"_$P(ND2,U,4)_"^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_STAT_U_U_U_U_$P($G(^PS(55,DFN,5,+ON,0)),"^",22)_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))
+ S PROVIDER=$P($G(@(F_+ON_",0)")),"^",2)
+ I PROVIDER S ^TMP("PS",$J,TFN,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^")
+ S ^TMP("PS",$J,TFN,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,TFN,"MDR",1,0)=MR
+ S ^TMP("PS",$J,TFN,"SCH",0)=$P(ND2,U)]"" S:$P(ND2,U)]"" ^TMP("PS",$J,TFN,"SCH",1,0)=$P(ND2,U)
+ ;S:$P(ND0,U,7)]"" ^TMP("PS",$J,TFN,"SCH",0)=1,$P(^TMP("PS",$J,TFN,"SCH",1,0),U,2)=$P(ND0,U,7)
+ S ^TMP("PS",$J,TFN,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,TFN,"SIG",1,0)=INST
+ S ^TMP("PS",$J,TFN,"ADM",0)=$P(ND2,U,5)]"" S:$P(ND2,U,5)]"" ^TMP("PS",$J,TFN,"ADM",1,0)=$P(ND2,U,5)
+ S ^TMP("PS",$J,TFN,"SIO",0)=ND6]"" S:ND6]"" ^TMP("PS",$J,TFN,"SIO",1,0)=ND6
+ Q
+ ;
+IVTMP ;*** Set ^TMP for IV orders.
+ N PROVIDER,START,STOP,EDTCMPLX,NDP2,IVLIM
+ S NDP2=$G(@(F_ON_",.2)")) S EDTCMPLX=$P(NDP2,"^",8)
+ S ND0=$G(@(F_ON_",0)")) I 'EDTCMPLX I F'["53.1",($P(ND0,U,2)>EDT) Q
+ D TYPE
+ S FON=+ON_$S(F["53.1":"P",1:"V"),TFN=TFN+1,CNT=0
+ S RNWDT=$$LASTREN^PSJLMPRI(DFN,FON) I RNWDT S RNWDT=+RNWDT
+ F X=0:0 S X=$O(@(F_ON_",""AD"","_X_")")) Q:'X  S ND=$G(@(F_ON_",""AD"","_X_",0)")),DN=$P($G(^PS(52.6,+ND,0)),U),Y=DN_U_$P(ND,U,2) S:$P(ND,U,3) Y=Y_U_$P(ND,U,3) S CNT=CNT+1,^TMP("PS",$J,TFN,"A",CNT,0)=Y
+ S ^TMP("PS",$J,TFN,"A",0)=CNT,CNT=0
+ F X=0:0 S X=$O(@(F_ON_",""SOL"","_X_")")) Q:'X  S ND=$G(@(F_ON_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0)),CNT=CNT+1,^TMP("PS",$J,TFN,"B",CNT,0)=$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4)
+ S ^TMP("PS",$J,TFN,"B",0)=CNT
+ S TYPE=$P(ND0,U,4),(MR,SCH,INST,INFUS)=""
+ I FON["P" S ND2=$G(^PS(53.1,+ON,2)),SCH=$P(ND2,U),START=$P(ND2,U,2),STOP=$P(ND2,U,4),MR=$P(ND0,U,3),INFUS=$P($G(^PS(53.1,+ON,8)),U,5),STAT=$$CODES^PSIVUTL($P(ND0,U,9),53.1,28),ADM=$P(ND2,U,5),SIO=$P($G(@(F_+ON_",6)")),"^")
+ I FON'["P" S START=$P(ND0,U,2),STOP=$P(ND0,U,3),SCH=$P(ND0,U,9),INFUS=$P(ND0,U,8),MR=$P($G(^PS(55,DFN,"IV",+ON,.2)),U,3),STAT=$$CODES^PSIVUTL($P(ND0,U,17),55.01,100),ADM=$P(ND0,U,11),SIO=$P($G(@(F_+ON_",3)")),"^")
+ S DN=$G(@(F_+ON_",.2)")),DO=$P(DN,U,2)
+ S DN=$S(+$P(DN,U):$$OIDF^PSJLMUT1($P(DN,U)),1:"")
+ S:MR MR=$$MR^PSJORRE1(+MR),INST=$G(@(F_+ON_",.3)"))
+ ;S ^TMP("PS",$J,TFN,0)=FON_";I"_U_DN_U_INFUS_U_$P(ND0,U,3)_"^^"_DO_"^^"_$P(ND0,"^",21)_U_STAT
+ S ^TMP("PS",$J,TFN,0)=FON_";I"_U_DN_U_INFUS_U_STOP_"^^"_DO_"^^"_$P(ND0,"^",21)_U_STAT_U_U_U_U_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_START_U_$G(RNWDT)
+ K ^TMP("PS",$J,TFN,"CLINIC",0) I PSJCLIN]"" S ^TMP("PS",$J,TFN,"CLINIC",0)=PSJCLIN
+ S PROVIDER=$P($G(@(F_+ON_",0)")),"^",6)
+ I PROVIDER S ^TMP("PS",$J,TFN,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^")
+ S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4)
+ I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM=""
+ S ^TMP("PS",$J,TFN,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,TFN,"MDR",1,0)=MR
+ S ^TMP("PS",$J,TFN,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,TFN,"SIG",1,0)=INST
+ S ^TMP("PS",$J,TFN,"SCH",0)=SCH]"" S:SCH]"" ^TMP("PS",$J,TFN,"SCH",1,0)=SCH
+ ;I FON["P" S:$P(ND0,U,7)]"" ^TMP("PS",$J,TFN,"SCH",0)=1,$P(^TMP("PS",$J,TFN,"SCH",1,0),U,2)=$P(ND0,U,7)
+ S ^TMP("PS",$J,TFN,"ADM",0)=ADM]"" S:ADM]"" ^TMP("PS",$J,TFN,"ADM",1,0)=ADM
+ S ^TMP("PS",$J,TFN,"SIO",0)=SIO]"" S:SIO]"" ^TMP("PS",$J,TFN,"SIO",1,0)=SIO
+ I $G(IVLIM)]"" S ^TMP("PS",$J,TFN,"IVLIM",0)=IVLIM
+ Q
+STAT(Y,X) ;* Return the full status instead of just the code for U/D.
+ S X=$P($P(";"_$P(Y,U,3),";"_X_":",2),";")
+ Q X
+TYPE ;determine if this is an IMO order or not
+ S (A,PSJCLIN)="" I F["PS(53.1" S A=$G(^PS(53.1,ON,"DSS"))
+ I F["PS(55" S A=$S(F["IV":$G(^PS(55,DFN,"IV",ON,"DSS")),1:$G(^PS(55,DFN,5,ON,8)))
+ I $P(A,"^",2)'="" S PSJCLIN=+A
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE1.m

@@ -1 @@
-PSJORRE1        ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (EXPANDED) ;29 Jan 99 / 8:49 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**22,51,50,58,81,91,110,111,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(51.2 is supported by DBIA 2178.
-        ; Reference to ^PS(52.6 is supported by DBIA 1231.
-        ; Reference to ^PS(52.7 is supported by DBIA 2173.
-        ; Reference to ^PS(55 is supported by DBIA 2191.
-        ; Reference to ^PSDRUG is supported by DBIA 2192.
-        ; Reference to ^TMP("PS" is documented in DBIA #2384.
-        ;
-OEL(DFN,ON)             ; return list of expanded inpat meds
-        K ^TMP("PS",$J)
-        N ADM,CNT,DN,DO,F,INFUS,INST,MR,ND,ND0,ND2,ND2P5,ND6,NDOI,SCH,SIO,START,STAT,STOP,TYP,UNITS,X,Y
-        S F=$S(ON["P":"^PS(53.1,",ON["U":"^PS(55,DFN,5,",1:"^PS(55,"_DFN_",""IV"",")
-        I ON'["P",'$D(@(F_+ON_")")) Q
-        I ON["P" S X=$G(^PS(53.1,+ON,0)) Q:$P(X,U,15)'=DFN  S TYP=$P(X,U,4) D @$S(TYP="U":"UDTMP",1:"IVTMP")
-        D:ON'["P" @$S(ON["U":"UDTMP",1:"IVTMP")
-        S Y=$S(ON["V":5,1:12),CNT=0
-        I $O(@(F_+ON_","_Y_",0)")) D
-        . F X=0:0 S X=$O(@(F_+ON_","_Y_","_X_")")) Q:'X  D
-        ..S CNT=CNT+1,ND=$G(@(F_+ON_","_Y_","_X_",0)")),^TMP("PS",$J,"PC",CNT,0)=ND
-        S ^TMP("PS",$J,"PC",0)=CNT
-        Q
-        ;
-UDTMP   ;*** Set ^TMP for Unit dose orders.
-        N DO,DN,INST,X,Y,PROVIDER,NOTGIVEN,RNWDT
-        S (MR,SCH,INST)=""
-        S ND2=$G(@(F_+ON_",2)")),ND0=$G(@(F_+ON_",0)"))
-        S ND6=$P($G(@(F_+ON_",6)")),"^")
-        S RNWDT=$$LASTREN^PSJLMPRI(DFN,ON) I RNWDT S RNWDT=+RNWDT
-        S STAT=$$CODES^PSIVUTL($P(ND0,U,9),$S(ON["P":53.1,1:55.06),28)
-        S NDOI=$G(@(F_+ON_",.2)")),DO=$P(NDOI,U,2)
-        S DN(1)=$$OIDF^PSJLMUT1(NDOI) I DN(1)=""  K DN D DRGDISP^PSJLMUT1(DFN,ON,40,0,.DN,1)
-        S UNITS="" I '$O(@(F_+ON_",1,1)")) S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2) S:(ON["U")&(UNITS="") UNITS=1
-        S MR=$$MR(+$P(ND0,U,3)),INST=$G(@(F_+ON_",.3)"))
-        S NOTGIVEN=$S(ON["U":$P($G(^PS(55,DFN,5,+ON,0)),"^",22),1:"")
-        S ^TMP("PS",$J,0)=DN(1)_"^^"_$P(ND2,U,4)_"^^"_$P(ND2,U,2)_U_STAT_"^^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_U_NOTGIVEN_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_U_$G(RNWDT)
-        S PROVIDER=$P($G(@(F_+ON_",0)")),"^",2)
-        I PROVIDER S ^TMP("PS",$J,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^")
-        S ^TMP("PS",$J,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,"MDR",1,0)=MR
-        S ^TMP("PS",$J,"SCH",0)=$P(ND2,U)]"" S:$P(ND2,U)]"" ^TMP("PS",$J,"SCH",1,0)=$P(ND2,U)
-        S:$P(ND0,U,7)]"" ^TMP("PS",$J,"SCH",0)=1,$P(^TMP("PS",$J,"SCH",1,0),U,2)=$$GTSCHT($P(ND0,U,7))_"^"_$P(ND0,U,7)
-        S ^TMP("PS",$J,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,"SIG",1,0)=INST
-        S ^TMP("PS",$J,"ADM",0)=$P(ND2,U,5)]"" S:$P(ND2,U,5)]"" ^TMP("PS",$J,"ADM",1,0)=$P(ND2,U,5)
-        S ^TMP("PS",$J,"SIO",0)=ND6]"" S:ND6]"" ^TMP("PS",$J,"SIO",1,0)=ND6
-        NEW VERPHARM S:ON["U" VERPHARM=$P($G(@(F_+ON_",4)")),U,3)
-        S:+$G(VERPHARM) $P(^TMP("PS",$J,"RXN",0),U,5)=VERPHARM
-        NEW PSJDD,INACTDT,NDDD,OUTOI,PSJOUT S CNT=0
-        F PSJDD=0:0 S PSJDD=$O(@(F_+ON_",1,PSJDD)")) Q:'PSJDD  D
-        . S NDDD=@(F_+ON_",1,PSJDD,0)")
-        . I $P(NDDD,U,3)]"",($P(NDDD,U,3)'>DT) Q
-        . S PSJOUT=$P($G(^PSDRUG(+NDDD,8)),U,5)
-        . I +PSJOUT D
-        .. S INACTDT=$G(^PSDRUG(+PSJOUT,"I")),OUTOI=+$G(^PSDRUG(+PSJOUT,2))
-        .. I INACTDT]"",(INACTDT'>DT) S (PSJOUT,OUTOI)=""
-        . I '+PSJOUT,($P($G(^PSDRUG(+NDDD,2)),U,3)["O") D
-        .. S PSJOUT=+NDDD,OUTOI=+NDOI
-        .. S INACTDT=$G(^PSDRUG(+NDDD,"I"))
-        .. I INACTDT]"",(INACTDT'>DT) S (PSJOUT,OUTOI)=""
-        . S UNITS=$P(NDDD,U,2) S:(ON["U")&(UNITS="") UNITS=1
-        . S CNT=CNT+1,^TMP("PS",$J,"DD",CNT,0)=+NDDD_U_UNITS_U_PSJOUT_U_$G(OUTOI)
-        S ^TMP("PS",$J,"DD",0)=CNT
-        Q
-        ;
-IVTMP   ;*** Set ^TMP for IV orders.
-        N PROVIDER,RNWDT,IVLIM S ND0=$G(@(F_+ON_",0)")),CNT=0
-        F X=0:0 S X=$O(@(F_+ON_",""AD"","_X_")")) Q:'X  S ND=$G(@(F_+ON_",""AD"","_X_",0)")),DN=$P($G(^PS(52.6,+ND,0)),U),Y=DN_U_$P(ND,U,2) S:$P(ND,U,3) Y=Y_U_$P(ND,U,3) S CNT=CNT+1,^TMP("PS",$J,"A",CNT,0)=Y
-        S RNWDT=$$LASTREN^PSJLMPRI(DFN,ON) I RNWDT S RNWDT=+RNWDT
-        S ^TMP("PS",$J,"A",0)=CNT,CNT=0
-        F X=0:0 S X=$O(@(F_+ON_",""SOL"","_X_")")) Q:'X  S ND=$G(@(F_+ON_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0)),CNT=CNT+1,^TMP("PS",$J,"B",CNT,0)=$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4)
-        S ^TMP("PS",$J,"B",0)=CNT
-        S INST=$G(@(F_+ON_",.3)"))
-        I ON["P" D
-        . S SCH=$P($G(^PS(53.1,+ON,2)),U)
-        . S PROVIDER=$P(ND0,U,2)
-        . S MR=$$MR(+$P(ND0,U,3)),STAT=$$CODES^PSIVUTL($P(ND0,U,9),53.1,28)
-        . S INFUS=$P($G(^PS(53.1,+ON,8)),U,5)
-        . S ND2=$G(@(F_+ON_",2)")),START=$P(ND2,U,2),STOP=$P(ND2,U,4)
-        . S ADM=$P(ND2,U,5),SIO=$P($G(@(F_+ON_",6)")),"^")
-        . S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4) I $E(IVLIM)="a" S IVLIM="doses"_$P(IVLIM,"a",2)
-        . I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM=""
-        I ON'["P"  D
-        . S PROVIDER=$P(ND0,U,6)
-        . S SCH=$P(ND0,U,9),INFUS=$P(ND0,U,8),STAT=$$CODES^PSIVUTL($P(ND0,U,17),55.01,100)
-        . S MR=$$MR(+$P($G(^PS(55,DFN,"IV",+ON,.2)),U,3))
-        . S START=$P(ND0,U,2),STOP=$P(ND0,U,3)
-        . S ADM=$P(ND0,U,11),SIO=$P($G(@(F_+ON_",3)")),"^")
-        . NEW VERPHARM S VERPHARM=$P($G(^PS(55,DFN,"IV",+ON,4)),U,4)
-        . S:+VERPHARM $P(^TMP("PS",$J,"RXN",0),U,5)=VERPHARM
-        . S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4) I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM=""
-        S DN=$G(@(F_+ON_",.2)")),DO=$P(DN,U,2)
-        S DN=$S(+$P(DN,U):$$OIDF^PSJLMUT1($P(DN,U)),1:"")
-        S ^TMP("PS",$J,0)=DN_U_INFUS_U_STOP_"^^"_START_U_STAT_"^^^"_DO_"^^"_$P(ND0,U,21)_U_U_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_U_$G(RNWDT)
-        I PROVIDER S ^TMP("PS",$J,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^")
-        S ^TMP("PS",$J,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,"MDR",1,0)=MR
-        S ^TMP("PS",$J,"SCH",0)=SCH]"" S:SCH]"" ^TMP("PS",$J,"SCH",1,0)=SCH
-        I ON["P" S:$P(ND0,U,7)]"" ^TMP("PS",$J,"SCH",0)=1,$P(^TMP("PS",$J,"SCH",1,0),U,2)=$$GTSCHT($P(ND0,U,7))_"^"_$P(ND0,U,7)
-        S ^TMP("PS",$J,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,"SIG",1,0)=INST
-        S ^TMP("PS",$J,"ADM",0)=ADM]"" S:ADM]"" ^TMP("PS",$J,"ADM",1,0)=ADM
-        S ^TMP("PS",$J,"SIO",0)=SIO]"" S:SIO]"" ^TMP("PS",$J,"SIO",1,0)=SIO
-        I $G(IVLIM)]"" S ^TMP("PS",$J,"IVLIM",0)=$G(IVLIM)
-        Q
-        ;
-MR(X)   ;RETURN MED ROUTE ABBR. IF THE ABBR="" RETURN MED ROUTE'S NAME.
-        S X=$G(^PS(51.2,X,0))
-        Q $S($P(X,U,3)]"":$P(X,U,3),1:$P(X,U))
-        ;
-GTSTAT(X)       ;
-        Q $S(X="A":"ACTIVE",X="D":"DISCONTINUED",X="I":"INCOMPLETE",X="N":"NON-VERFIED",X="U":"UNRELEASED",X="P":"PENDING",X="DE":"DISCONTINUED (EDIT)",X="O":"ON CALL",1:"NOT FOUND")
-        ;
-VA200(X)        ;Return the IEN for the user.
-        ; X = User name
-        NEW DIC,Y S DIC="^VA(200,",DIC(0)="NZ" D ^DIC
-        I +Y=-1 Q ""
-        Q $P(Y,U)
-GTSCHT(X)             ;
-        Q $S(X="C":"CONTINUOUS",X="O":"ONE TIME",X="P":"PRN",X="R":"FILL ON REQUEST",X="OC":"ON CALL",1:"NOT FOUND")
+PSJORRE1 ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (EXPANDED) ;29 Jan 99 / 8:49 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**22,51,50,58,81,91,110,111**;16 DEC 97
+ ;
+ ; Reference to ^PS(51.2 is supported by DBIA 2178.
+ ; Reference to ^PS(52.6 is supported by DBIA 1231.
+ ; Reference to ^PS(52.7 is supported by DBIA 2173.
+ ; Reference to ^PS(55 is supported by DBIA 2191.
+ ; Reference to ^PSDRUG is supported by DBIA 2192.
+ ; Reference to OTF^OR3CONV is supported by DBIA 2412.
+ ; Reference to ^TMP("PS" is documented in DBIA #2384.
+ ;
+OEL(DFN,ON)         ; return list of expanded inpat meds
+ K ^TMP("PS",$J)
+ N ADM,CNT,DN,DO,F,INFUS,INST,MR,ND,ND0,ND2,ND2P5,ND6,NDOI,SCH,SIO,START,STAT,STOP,TYP,UNITS,X,Y
+ ;Check if 5.0 order conversion should be run for the selected patient.
+ ;I '$P($G(^PS(55,DFN,5.1)),U,11) D CONVERT^PSJUTL1(DFN,0)
+ F  S X=$$OTF^OR3CONV(DFN,$S($E(IOST,1)="C":0,1:1)) Q:+X'<0  D
+ .I +X=-1 H 3
+ S F=$S(ON["P":"^PS(53.1,",ON["U":"^PS(55,DFN,5,",1:"^PS(55,"_DFN_",""IV"",")
+ I ON'["P",'$D(@(F_+ON_")")) Q
+ I ON["P" S X=$G(^PS(53.1,+ON,0)) Q:$P(X,U,15)'=DFN  S TYP=$P(X,U,4) D @$S(TYP="U":"UDTMP",1:"IVTMP")
+ D:ON'["P" @$S(ON["U":"UDTMP",1:"IVTMP")
+ S Y=$S(ON["V":5,1:12),CNT=0
+ I $O(@(F_+ON_","_Y_",0)")) D
+ . F X=0:0 S X=$O(@(F_+ON_","_Y_","_X_")")) Q:'X  D
+ ..S CNT=CNT+1,ND=$G(@(F_+ON_","_Y_","_X_",0)")),^TMP("PS",$J,"PC",CNT,0)=ND
+ S ^TMP("PS",$J,"PC",0)=CNT
+ Q
+ ;
+UDTMP ;*** Set ^TMP for Unit dose orders.
+ N DO,DN,INST,X,Y,PROVIDER,NOTGIVEN,RNWDT
+ S (MR,SCH,INST)=""
+ S ND2=$G(@(F_+ON_",2)")),ND0=$G(@(F_+ON_",0)"))
+ S ND6=$P($G(@(F_+ON_",6)")),"^")
+ S RNWDT=$$LASTREN^PSJLMPRI(DFN,ON) I RNWDT S RNWDT=+RNWDT
+ S STAT=$$CODES^PSIVUTL($P(ND0,U,9),$S(ON["P":53.1,1:55.06),28)
+ D DRGDISP^PSJLMUT1(DFN,ON,40,0,.DN,1)
+ S NDOI=$G(@(F_+ON_",.2)")),DO=$P(NDOI,U,2)
+ ;S UNITS="" I '$O(@(F_+ON_",1,1)")),DO="" S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2)
+ S UNITS="" I '$O(@(F_+ON_",1,1)")) S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2) S:(ON["U")&(UNITS="") UNITS=1
+ S MR=$$MR(+$P(ND0,U,3)),INST=$G(@(F_+ON_",.3)"))
+ S NOTGIVEN=$S(ON["U":$P($G(^PS(55,DFN,5,+ON,0)),"^",22),1:"")
+ S ^TMP("PS",$J,0)=DN(1)_"^^"_$P(ND2,U,4)_"^^"_$P(ND2,U,2)_U_STAT_"^^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_U_NOTGIVEN_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_U_$G(RNWDT)
+ ;S ^TMP("PS",$J,0)=DN(1)_"^^"_$P(ND2,U,4)_"^^"_$P(ND2,U,2)_U_STAT_"^^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_U_$P($G(^PS(55,DFN,5,+ON,0)),"^",22)_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))
+ S PROVIDER=$P($G(@(F_+ON_",0)")),"^",2)
+ I PROVIDER S ^TMP("PS",$J,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^")
+ S ^TMP("PS",$J,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,"MDR",1,0)=MR
+ S ^TMP("PS",$J,"SCH",0)=$P(ND2,U)]"" S:$P(ND2,U)]"" ^TMP("PS",$J,"SCH",1,0)=$P(ND2,U)
+ S:$P(ND0,U,7)]"" ^TMP("PS",$J,"SCH",0)=1,$P(^TMP("PS",$J,"SCH",1,0),U,2)=$$GTSCHT($P(ND0,U,7))_"^"_$P(ND0,U,7)
+ S ^TMP("PS",$J,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,"SIG",1,0)=INST
+ S ^TMP("PS",$J,"ADM",0)=$P(ND2,U,5)]"" S:$P(ND2,U,5)]"" ^TMP("PS",$J,"ADM",1,0)=$P(ND2,U,5)
+ S ^TMP("PS",$J,"SIO",0)=ND6]"" S:ND6]"" ^TMP("PS",$J,"SIO",1,0)=ND6
+ NEW VERPHARM S:ON["U" VERPHARM=$P($G(@(F_+ON_",4)")),U,3)
+ S:+$G(VERPHARM) $P(^TMP("PS",$J,"RXN",0),U,5)=VERPHARM
+ NEW PSJDD,INACTDT,NDDD,OUTOI,PSJOUT S CNT=0
+ F PSJDD=0:0 S PSJDD=$O(@(F_+ON_",1,PSJDD)")) Q:'PSJDD  D
+ . S NDDD=@(F_+ON_",1,PSJDD,0)")
+ . I $P(NDDD,U,3)]"",($P(NDDD,U,3)'>DT) Q
+ . S PSJOUT=$P($G(^PSDRUG(+NDDD,8)),U,5)
+ . I +PSJOUT D
+ .. S INACTDT=$G(^PSDRUG(+PSJOUT,"I")),OUTOI=+$G(^PSDRUG(+PSJOUT,2))
+ .. I INACTDT]"",(INACTDT'>DT) S (PSJOUT,OUTOI)=""
+ . I '+PSJOUT,($P($G(^PSDRUG(+NDDD,2)),U,3)["O") D
+ .. S PSJOUT=+NDDD,OUTOI=+NDOI
+ .. S INACTDT=$G(^PSDRUG(+NDDD,"I"))
+ .. I INACTDT]"",(INACTDT'>DT) S (PSJOUT,OUTOI)=""
+ . ;* S UNITS=$S('+$P(NDDD,U,2):1,1:$P(NDDD,U,2))
+ . S UNITS=$P(NDDD,U,2) S:(ON["U")&(UNITS="") UNITS=1
+ . S CNT=CNT+1,^TMP("PS",$J,"DD",CNT,0)=+NDDD_U_UNITS_U_PSJOUT_U_$G(OUTOI)
+ S ^TMP("PS",$J,"DD",0)=CNT
+ Q
+ ;
+IVTMP ;*** Set ^TMP for IV orders.
+ N PROVIDER,RNWDT,IVLIM S ND0=$G(@(F_+ON_",0)")),CNT=0
+ F X=0:0 S X=$O(@(F_+ON_",""AD"","_X_")")) Q:'X  S ND=$G(@(F_+ON_",""AD"","_X_",0)")),DN=$P($G(^PS(52.6,+ND,0)),U),Y=DN_U_$P(ND,U,2) S:$P(ND,U,3) Y=Y_U_$P(ND,U,3) S CNT=CNT+1,^TMP("PS",$J,"A",CNT,0)=Y
+ S RNWDT=$$LASTREN^PSJLMPRI(DFN,ON) I RNWDT S RNWDT=+RNWDT
+ S ^TMP("PS",$J,"A",0)=CNT,CNT=0
+ F X=0:0 S X=$O(@(F_+ON_",""SOL"","_X_")")) Q:'X  S ND=$G(@(F_+ON_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0)),CNT=CNT+1,^TMP("PS",$J,"B",CNT,0)=$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4)
+ S ^TMP("PS",$J,"B",0)=CNT
+ S INST=$G(@(F_+ON_",.3)"))
+ I ON["P" D
+ . S SCH=$P($G(^PS(53.1,+ON,2)),U)
+ . S PROVIDER=$P(ND0,U,2)
+ . S MR=$$MR(+$P(ND0,U,3)),STAT=$$CODES^PSIVUTL($P(ND0,U,9),53.1,28)
+ . S INFUS=$P($G(^PS(53.1,+ON,8)),U,5)
+ . S ND2=$G(@(F_+ON_",2)")),START=$P(ND2,U,2),STOP=$P(ND2,U,4)
+ . S ADM=$P(ND2,U,5),SIO=$P($G(@(F_+ON_",6)")),"^")
+ . S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4) I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM=""
+ I ON'["P"  D
+ . S PROVIDER=$P(ND0,U,6)
+ . S SCH=$P(ND0,U,9),INFUS=$P(ND0,U,8),STAT=$$CODES^PSIVUTL($P(ND0,U,17),55.01,100)
+ . S MR=$$MR(+$P($G(^PS(55,DFN,"IV",+ON,.2)),U,3))
+ . S START=$P(ND0,U,2),STOP=$P(ND0,U,3)
+ . S ADM=$P(ND0,U,11),SIO=$P($G(@(F_+ON_",3)")),"^")
+ . NEW VERPHARM S VERPHARM=$P($G(^PS(55,DFN,"IV",+ON,4)),U,4)
+ . S:+VERPHARM $P(^TMP("PS",$J,"RXN",0),U,5)=VERPHARM
+ . S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4) I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM=""
+ S DN=$G(@(F_+ON_",.2)")),DO=$P(DN,U,2)
+ S DN=$S(+$P(DN,U):$$OIDF^PSJLMUT1($P(DN,U)),1:"")
+ S ^TMP("PS",$J,0)=DN_U_INFUS_U_STOP_"^^"_START_U_STAT_"^^^"_DO_"^^"_$P(ND0,U,21)_U_U_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_U_$G(RNWDT)
+ ;*S PROVIDER=$P($G(@(F_+ON_",0)")),"^",6)
+ I PROVIDER S ^TMP("PS",$J,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^")
+ S ^TMP("PS",$J,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,"MDR",1,0)=MR
+ S ^TMP("PS",$J,"SCH",0)=SCH]"" S:SCH]"" ^TMP("PS",$J,"SCH",1,0)=SCH
+ I ON["P" S:$P(ND0,U,7)]"" ^TMP("PS",$J,"SCH",0)=1,$P(^TMP("PS",$J,"SCH",1,0),U,2)=$$GTSCHT($P(ND0,U,7))_"^"_$P(ND0,U,7)
+ S ^TMP("PS",$J,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,"SIG",1,0)=INST
+ S ^TMP("PS",$J,"ADM",0)=ADM]"" S:ADM]"" ^TMP("PS",$J,"ADM",1,0)=ADM
+ S ^TMP("PS",$J,"SIO",0)=SIO]"" S:SIO]"" ^TMP("PS",$J,"SIO",1,0)=SIO
+ I $G(IVLIM)]"" S ^TMP("PS",$J,"IVLIM",0)=$G(IVLIM)
+ Q
+ ;
+MR(X) ;RETURN MED ROUTE ABBR. IF THE ABBR="" RETURN MED ROUTE'S NAME.
+ S X=$G(^PS(51.2,X,0))
+ Q $S($P(X,U,3)]"":$P(X,U,3),1:$P(X,U))
+ ;
+GTSTAT(X) ;
+ Q $S(X="A":"ACTIVE",X="D":"DISCONTINUED",X="I":"INCOMPLETE",X="N":"NON-VERFIED",X="U":"UNRELEASED",X="P":"PENDING",X="DE":"DISCONTINUED (EDIT)",X="O":"ON CALL",1:"NOT FOUND")
+ ;
+VA200(X) ;Return the IEN for the user.
+ ; X = User name
+ NEW DIC,Y S DIC="^VA(200,",DIC(0)="NZ" D ^DIC
+ I +Y=-1 Q ""
+ Q $P(Y,U)
+GTSCHT(X)       ;
+ Q $S(X="C":"CONTINUOUS",X="O":"ONE TIME",X="P":"PRN",X="R":"FILL ON REQUEST",X="OC":"ON CALL",1:"NOT FOUND")

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORREN.m

@@ -1 @@
-PSJORREN        ;BIR/MV-RENEWAL FLAG ;6 DEC 00 / 3:11 PM 
-        ;;5.0; INPATIENT MEDICATIONS ;**50,70,58,89,91,110,127,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(50.7 supported by DBIA #2180
-        ; References to ^PS(52.6 supported by DBIA #1231
-        ; References to ^PS(52.7 supported by DBIA #2173
-        ; References to ^PS(55 supported by DBIA #2191
-        ; Reference to ^PSDRUG( is supported by DBIA 2192
-        ;
-ACTIVE(DFN,ON)  ;
-        ;DFN: Patient IEN
-        ;ON : Order number_"U/V/P"
-        ;Output: 0^reason not renewable (Can't renew)
-        ;        2^New OI (Need to create a new order as in edit)
-        ;          note: with PSJ*5*70 - instead of 2, IV order will return 0
-        ;        1 (OK to renew)
-        NEW PSJRT,PSJEXP
-        I '$D(^PS(53.1,+ON))&'$D(^PS(55,+DFN,5,+ON,0))&'$D(^PS(55,+DFN,"IV",+ON,0)) S PSJRT="0^Invalid Package Reference" Q $G(PSJRT)
-        D:ON["U" UD
-        D:ON["V" IV
-        I (+$G(PSJRT)=1) S PSJEXP=$$EXPIRED^PSGOER(DFN,ON) I PSJEXP S PSJRT="0^Expired Time Limit Exceeded"
-        Q $G(PSJRT)
-UD      ;
-        ;If both PSJRT(2) & (3) existed it meant order has multiple DDs and one
-        ;is tied to a different OI. It's best to not allow renewal of the order.
-        ;
-        NEW PSJDD,PSJDDOI,PSJDDX,PSJACT,PSJOI,PSJOIACT,PSJUSE,PSJPRI,X,ND2
-        K PSJRT
-        S PSJOI=+^PS(55,DFN,5,+ON,.2)
-        S PSJPRI=$P(^PS(55,DFN,5,+ON,.2),"^",4)
-        I PSJPRI="D" S PSJRT="0^Orders with a Done priority may not be renewed" Q
-        S ND0=$G(^PS(55,DFN,5,+ON,0)) I $P(ND0,"^",7)="O" S PSJRT="0^One Time orders may not be renewed" Q
-        N PSJCANT,PSJDAD,NDP2,PSJORKID,PSJKID S NDP2=$G(^PS(55,DFN,5,+ON,.2)),PSJDAD=$P(NDP2,"^",8) I PSJDAD D
-        .S PSJORKID="" F  S PSJORKID=$O(^PS(55,"ACX",PSJDAD,PSJORKID)) Q:'PSJORKID!$G(PSJCANT)  S PSJKID="" F  S PSJKID=$O(^PS(55,"ACX",PSJDAD,PSJORKID,PSJKID)) Q:'PSJKID!$G(PSJCANT)  D
-        ..S ND0=$G(^PS(55,DFN,5,+PSJKID,2)) I $P(ND0,"^",7)="O" S PSJRT="0^Complex Orders with One-Time doses may not be renewed",PSJCANT=1
-        Q:$G(PSJCANT)
-        F PSJDD=0:0 S PSJDD=$O(^PS(55,DFN,5,+ON,1,PSJDD)) Q:('PSJDD!$D(PSJRT(1)))  D
-        . S (PSJACT,PSJOIACT)=0 S PSJDDX=^PS(55,DFN,5,+ON,1,PSJDD,0)
-        . S X=$P(PSJDDX,U,3) I X]"",(X'>DT) S PSJACT=1
-        . S X=$G(^PSDRUG(+PSJDDX,"I")) I X]"",(X'>DT) S PSJACT=1
-        . S X=$G(^PSDRUG(+PSJDDX,2)),PSJUSE=$P(X,U,3)["U",PSJDDOI=+X I '+PSJDDOI S PSJRT(3)="0^Dispense drug is not matched to an Orderable Item" Q
-        . S X=$P($G(^PS(50.7,+PSJDDOI,0)),U,4) I X]"",(X'>DT) S PSJOIACT=1
-        . I 'PSJACT,PSJUSE D  Q
-        .. I PSJOI=PSJDDOI D  Q
-        ... I 'PSJOIACT S PSJRT(1)=1 Q
-        ... S:PSJOIACT PSJRT(3)="0^Inactive Orderable Item"
-        .. I +PSJDDOI,(PSJOI'=PSJDDOI) D
-        ... S:'PSJOIACT PSJRT(2)="2"_U_PSJDDOI
-        ... S:PSJOIACT PSJRT(3)="0^Dispense drug ties to an inactive Orderable Item"
-        . I PSJACT S PSJRT(3)="0^This drug has been Inactivated"
-        . I 'PSJUSE S PSJRT(3)="0^Drug is No longer used in Inpatient Meds"
-        I $D(PSJRT(1)) S PSJRT=1 Q
-        I $D(PSJRT(2)),$D(PSJRT(3)) S PSJRT=PSJRT(3) Q
-        I '$D(PSJRT) S PSJRT="0^Order has no Dispense drug" Q
-        S X=$O(PSJRT(0)),PSJRT=$G(PSJRT(X))
-        Q
-IV      ;
-        NEW FIL,PSJACT,PSJAS,PSJASNO,PSJASOI,PSJCNT,PSJIEN,PSJOI,PSJOIACT,PSJPRI,X
-        K PSJRT
-        S PSJCNT=0
-        S PSJOI=+$G(^PS(55,DFN,"IV",+ON,.2))
-        S PSJPRI=$P(^PS(55,DFN,"IV",+ON,.2),"^",4)
-        I PSJPRI="D" S PSJRT="0^Orders with a Done priority may not be renewed" Q
-        N ND2,PSBACT,IVSCHED
-        S ND0=$G(^PS(55,DFN,"IV",+ON,0)) I ($P(ND0,"^",4)="P")!($P(ND0,"^",23)="P")!$P(ND0,"^",5) D  Q:$G(PSJRT)]""
-        .N X,PSGOES,ZZND S PSGOES=2,X=$P(ND0,"^",9) D ENOS^PSGS0 Q:($G(X)="")!($P($G(ZZND),"^",5)'="O")
-        .S PSJRT="0^This One-Time order may not be renewed"
-        F FIL="AD","SOL"  F PSJAS=0:0 S PSJAS=$O(^PS(55,DFN,"IV",+ON,FIL,PSJAS)) Q:'PSJAS  D
-        . S (PSJACT,PSJOIACT)=0
-        . S PSJASNO=$S(FIL="AD":52.6,1:52.7)
-        . S PSJIEN=+^PS(55,DFN,"IV",+ON,FIL,PSJAS,0)
-        . S X=$G(^PS(PSJASNO,+PSJIEN,"I")) I X]"",(X'>DT) S PSJACT=1
-        . S PSJASOI=$P(^PS(PSJASNO,PSJIEN,0),U,11)
-        . S X=$P($G(^PS(50.7,+PSJASOI,0)),U,4) I X]"",(X'>DT) S PSJOIACT=1
-        . I PSJACT S PSJCNT=PSJCNT+1,PSJRT(3)="0^Inactive "_$S(FIL="AD":"Additive",1:"Solution") Q
-        . I PSJOI=PSJASOI D  Q
-        .. I 'PSJOIACT S PSJRT(1)="" Q
-        .. I PSJOIACT S PSJRT(3)="0^Inactive Orderable Item"
-        . I PSJOI'=PSJASOI D
-        .. I 'PSJOIACT S PSJCNT=PSJCNT+1,PSJRT(2)=2_U_PSJASOI
-        .. I PSJOIACT S PSJRT(3)="0^Inactive Orderable Item"
-        I $D(PSJRT(1)) S PSJRT=1 Q
-        I $D(PSJRT(3)) S PSJRT=PSJRT(3) Q
-        I $D(PSJRT(2)),PSJCNT=1 S PSJRT="0^New Orderable Item" Q
-        S PSJRT="0^Inactive drug"
-        Q
+PSJORREN ;BIR/MV-RENEWAL FLAG ;6 DEC 00 / 3:11 PM 
+ ;;5.0; INPATIENT MEDICATIONS ;**50,70,58,89,91,110,127**;16 DEC 97
+ ;
+ ; Reference to ^PS(50.7 supported by DBIA #2180
+ ; References to ^PS(52.6 supported by DBIA #1231
+ ; References to ^PS(52.7 supported by DBIA #2173
+ ; References to ^PS(55 supported by DBIA #2191
+ ; Reference to ^PSDRUG( is supported by DBIA 2192
+ ;
+ACTIVE(DFN,ON) ;
+ ;DFN: Patient IEN
+ ;ON : Order number_"U/V/P"
+ ;Output: 0^reason not renewable (Can't renew)
+ ;        2^New OI (Need to create a new order as in edit)
+ ;          note: with PSJ*5*70 - instead of 2, IV order will return 0
+ ;        1 (OK to renew)
+ NEW PSJRT,PSJEXP
+ D:ON["U" UD
+ D:ON["V" IV
+ I (+$G(PSJRT)=1) S PSJEXP=$$EXPIRED^PSGOER(DFN,ON) I PSJEXP S PSJRT="0^Expired Time Limit Exceeded"
+ Q $G(PSJRT)
+UD ;
+ ;If both PSJRT(2) & (3) existed it meant order has multiple DDs and one
+ ;is tied to a different OI. It's best to not allow renewal of the order.
+ ;
+ NEW PSJDD,PSJDDOI,PSJDDX,PSJACT,PSJOI,PSJOIACT,PSJUSE,PSJPRI,X,ND2
+ K PSJRT
+ S PSJOI=+^PS(55,DFN,5,+ON,.2)
+ S PSJPRI=$P(^PS(55,DFN,5,+ON,.2),"^",4)
+ I PSJPRI="D" S PSJRT="0^Orders with a Done priority may not be renewed" Q
+ S ND0=$G(^PS(55,DFN,5,+ON,0)) I $P(ND0,"^",7)="O" S PSJRT="0^One Time orders may not be renewed" Q
+ N PSJCANT,PSJDAD,NDP2,PSJORKID,PSJKID S NDP2=$G(^PS(55,DFN,5,+ON,.2)),PSJDAD=$P(NDP2,"^",8) I PSJDAD D
+ .S PSJORKID="" F  S PSJORKID=$O(^PS(55,"ACX",PSJDAD,PSJORKID)) Q:'PSJORKID!$G(PSJCANT)  S PSJKID="" F  S PSJKID=$O(^PS(55,"ACX",PSJDAD,PSJORKID,PSJKID)) Q:'PSJKID!$G(PSJCANT)  D
+ ..S ND0=$G(^PS(55,DFN,5,+PSJKID,2)) I $P(ND0,"^",7)="O" S PSJRT="0^Complex Orders with One-Time doses may not be renewed",PSJCANT=1
+ Q:$G(PSJCANT)
+ F PSJDD=0:0 S PSJDD=$O(^PS(55,DFN,5,+ON,1,PSJDD)) Q:('PSJDD!$D(PSJRT(1)))  D
+ . S (PSJACT,PSJOIACT)=0 S PSJDDX=^PS(55,DFN,5,+ON,1,PSJDD,0)
+ . S X=$P(PSJDDX,U,3) I X]"",(X'>DT) S PSJACT=1
+ . S X=$G(^PSDRUG(+PSJDDX,"I")) I X]"",(X'>DT) S PSJACT=1
+ . S X=$G(^PSDRUG(+PSJDDX,2)),PSJUSE=$P(X,U,3)["U",PSJDDOI=+X I '+PSJDDOI S PSJRT(3)="0^Dispense drug is not matched to an Orderable Item" Q
+ . S X=$P($G(^PS(50.7,+PSJDDOI,0)),U,4) I X]"",(X'>DT) S PSJOIACT=1
+ . I 'PSJACT,PSJUSE D  Q
+ .. I PSJOI=PSJDDOI D  Q
+ ... I 'PSJOIACT S PSJRT(1)=1 Q
+ ... S:PSJOIACT PSJRT(3)="0^Inactive Orderable Item"
+ .. I +PSJDDOI,(PSJOI'=PSJDDOI) D
+ ... S:'PSJOIACT PSJRT(2)="2"_U_PSJDDOI
+ ... S:PSJOIACT PSJRT(3)="0^Dispense drug ties to an inactive Orderable Item"
+ . I PSJACT S PSJRT(3)="0^This drug has been Inactivated"
+ . I 'PSJUSE S PSJRT(3)="0^Drug is No longer used in Inpatient Meds"
+ I $D(PSJRT(1)) S PSJRT=1 Q
+ I $D(PSJRT(2)),$D(PSJRT(3)) S PSJRT=PSJRT(3) Q
+ I '$D(PSJRT) S PSJRT="0^Order has no Dispense drug" Q
+ S X=$O(PSJRT(0)),PSJRT=$G(PSJRT(X))
+ Q
+IV ;
+ NEW FIL,PSJACT,PSJAS,PSJASNO,PSJASOI,PSJCNT,PSJIEN,PSJOI,PSJOIACT,PSJPRI,X
+ K PSJRT
+ S PSJCNT=0
+ S PSJOI=+$G(^PS(55,DFN,"IV",+ON,.2))
+ S PSJPRI=$P(^PS(55,DFN,"IV",+ON,.2),"^",4)
+ I PSJPRI="D" S PSJRT="0^Orders with a Done priority may not be renewed" Q
+ N ND2,PSBACT,IVSCHED
+ S ND0=$G(^PS(55,DFN,"IV",+ON,0)) I ($P(ND0,"^",4)="P")!($P(ND0,"^",23)="P")!$P(ND0,"^",5) D  Q:$G(PSJRT)]""
+ .N X,PSGOES,ZZND S PSGOES=2,X=$P(ND0,"^",9) D ENOS^PSGS0 Q:($G(X)="")!($P($G(ZZND),"^",5)'="O")
+ .S PSJRT="0^This One-Time order may not be renewed"
+ F FIL="AD","SOL"  F PSJAS=0:0 S PSJAS=$O(^PS(55,DFN,"IV",+ON,FIL,PSJAS)) Q:'PSJAS  D
+ . S (PSJACT,PSJOIACT)=0
+ . S PSJASNO=$S(FIL="AD":52.6,1:52.7)
+ . S PSJIEN=+^PS(55,DFN,"IV",+ON,FIL,PSJAS,0)
+ . S X=$G(^PS(PSJASNO,+PSJIEN,"I")) I X]"",(X'>DT) S PSJACT=1
+ . S PSJASOI=$P(^PS(PSJASNO,PSJIEN,0),U,11)
+ . S X=$P($G(^PS(50.7,+PSJASOI,0)),U,4) I X]"",(X'>DT) S PSJOIACT=1
+ . I PSJACT S PSJCNT=PSJCNT+1,PSJRT(3)="0^Inactive "_$S(FIL="AD":"Additive",1:"Solution") Q
+ . I PSJOI=PSJASOI D  Q
+ .. I 'PSJOIACT S PSJRT(1)="" Q
+ .. I PSJOIACT S PSJRT(3)="0^Inactive Orderable Item"
+ . I PSJOI'=PSJASOI D
+ .. I 'PSJOIACT S PSJCNT=PSJCNT+1,PSJRT(2)=2_U_PSJASOI
+ .. I PSJOIACT S PSJRT(3)="0^Inactive Orderable Item"
+ I $D(PSJRT(1)) S PSJRT=1 Q
+ I $D(PSJRT(3)) S PSJRT=PSJRT(3) Q
+ ;I $D(PSJRT(2)),PSJCNT=1 S PSJRT=PSJRT(2) Q
+ I $D(PSJRT(2)),PSJCNT=1 S PSJRT="0^New Orderable Item" Q
+ S PSJRT="0^Inactive drug"
+ Q

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORUT2.m

@@ -1 @@
-PSJORUT2        ;BIR/MLM-MISC. PROCEDURE CALLS FOR OE/RR 3.0 (CONT.) ;03 Aug 98 / 8:42 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**14,29,50,56,58,107,152,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^PS(55 is supported by DBIA 2191
-        ; Reference to ^PS(50.605 is supported by DBIA 2138,696.
-        ; References to ^PS(52.6 supported by DBIA 1231
-        ; Reference to ^PS(52.7 supported by DBIA 2173.
-        ; Reference to ^PSDRUG( is supported by DBIA 2192
-        ; Reference to ^PSNDF( is supported by DBIA 2195
-        ; Reference to ^PSRX( is supported by DBIA 824
-        ; Reference to ^PSNAPIS is supported by DBIA 2531
-        ;
-ENVAC(PN)       ; Find VA CLASS of VA Product Name
-        ;Input: PN - See above
-        ;Output: VA Drug Class^Classification
-        ;
-        ; NEW NDF CALL 
-        N X S X="PSNAPIS" X ^%ZOSF("TEST") I  N PSJC,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),PSJC=$$DCLASS^PSNAPIS(X1,X2) Q PSJC
-        ;
-        N GDP,PNP S GDP=$P(PN,"."),PNP=$P(PN,".",2)
-        S X=+$P($G(^PSNDF(+GDP,5,+PNP,0)),U,2),X=+$P($G(^PSNDF(GDP,2,X,0)),U,3),PSJC=$P($G(^PS(50.605,X,0)),U,2)
-        Q $S('X:0,PSJC="":0,1:X_U_PSJC)
-        ;
-ENVAGN(PN)      ; Return VA Generic Name for specified VA Product Name.
-        ;Input:  PN - VA Product Name IEN
-        ;Output: VA Generic Name IEN^VA Generic Name
-        ;
-        ; NEW NDF CALL 
-        N X S X="PSNAPIS" X ^%ZOSF("TEST") I  N GDP,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),GDP=$$VAGN^PSNAPIS(X1) Q $S(GDP=0:0,1:X1_U_GDP)
-        ;
-        N GDP,PNP S GDP=+$P(PN,"."),PNP=+$P(PN,".",2)
-        S X=$P($G(^PSNDF(GDP,0)),U)
-        Q $S('GDP:0,X="":0,1:GDP_U_X)
-ENVOL(PN,ARRAY) ;
-        I (PN'["A")&(PN'["B") S ARRAY="0" Q
-        N X,XX,F,INACT,IVFL
-        S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM",X(14)="MMOL"
-        I PN["A" N ADD S (ADD,X,XX)=0 F  S ADD=$O(^PS(52.6,"AOI",+PN,ADD))  Q:ADD=""  D
-        .S INACT=$G(^PS(52.6,ADD,"I")) I INACT']""!(INACT>DT) S IVFL=$P($G(^(0)),"^",13) Q:'IVFL  S XX=XX+1,ARRAY(ADD)="^"_X($P($G(^PS(52.6,ADD,0)),U,3)) Q
-        I PN["B" N SOL S SOL=0,XX=0 F  S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL=""  D
-        .S INACT=$G(^PS(52.7,SOL,"I")) I INACT']""!(INACT>DT) S IVFL=$P($G(^(0)),"^",13) Q:'IVFL  S XX=XX+1,ARRAY(SOL)=$P($G(^PS(52.7,SOL,0)),"^",3)
-        S ARRAY=XX>0
-        Q
-        ;
-ENVOL2(PN,ARRAY)        ;Only for Med Button IV orders.
-        I (PN'["A")&(PN'["B") S ARRAY="0" Q
-        N X,XX,F,INACT
-        S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM",X(14)="MMOL"
-        I PN["A" N ADD S (ADD,X,XX)=0 F  S ADD=$O(^PS(52.6,"AOI",+PN,ADD))  Q:ADD=""  D
-        .S INACT=$G(^PS(52.6,ADD,"I")) I INACT']""!(INACT>DT) S XX=XX+1,ARRAY(ADD)="^"_X($P($G(^PS(52.6,ADD,0)),U,3)) Q
-        I PN["B" N SOL S SOL=0,XX=0 F  S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL=""  D
-        .S INACT=$G(^PS(52.7,SOL,"I")) I INACT']""!(INACT>DT) S XX=XX+1,ARRAY(SOL)=$P($G(^PS(52.7,SOL,0)),"^",3)
-        S ARRAY=XX>0
-        Q
-        ;
-        ;
-SENVOL(PN,PSJ)  ;Return array listing volume (base only) and volume units for the specified additive or solution.
-        ;Input:  PN - IEN_B (Base) or A (Additive)
-        ;Output: ARRAY(IEN,A:additive or B:Base)=volume^volume units
-        ;        If no volume or units found PSJ=0; If found PSJ=1.
-        ;
-        N X S PSJ=1
-        S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM",X(14)="MMOL"
-        I PN'["A",PN'["B" S PSJ=0 Q
-        S PSJ=PSJ+1
-        I PN["A" S PSJ(+PN,"A")=U_X(+$P($G(^PS(52.6,+PN,0)),U,3)) Q
-        I PN["B" S PSJ(+PN,"B")=+$P($G(^PS(52.7,+PN,0)),U,3)_U_X(1) Q
-        Q
-        ;
-ENREF(PRX)      ; Return number of refills remaining.
-        ;Input: PRX - Internal prescription number from File #52.
-        ;Output: Number of refills remaining.
-        ;
-        N X,COUNT,CNT S PRX=$P(PRX,"^"),COUNT=0,X=$P(^PSRX(PRX,0),"^",9)
-        D:$O(^PSRX(PRX,1,0))
-        .F CNT=0:0 S CNT=$O(^PSRX(PRX,1,CNT)) Q:'CNT  S COUNT=COUNT+1
-        S:$G(COUNT) X=X-COUNT
-        Q X
-        ;
-ENCHK(DFN,PSJINX)           ; Return dispense drug check array.
-        ;Input: DFN      - Patient internal entry number
-        ;       PSJINX   - Index number so duplicate drugs will be returned.
-        ;       PSGOCHK  - Check should include dispense drugs in 53.45
-        ;       PSIVOCHK - Check should include entries in DRG array
-        ;Output: ^TMP($J,"ORDERS",PSJINX)=DRUG CLASS^NATIONAL DRUG FILE ENTRY
-        ;        _"A"_PSNDFA PRODUCT NAME ENTRY_DISPENSE DRUG NAME^OE/RR #
-        ;        _ORDER NUMBER(P/I/V)_";I"
-        ;
-        NEW BDT,DDRUG,DDRUG0,DDRUGND,EDT,F,ON,ON1,PST,WBDT,X,PSJORIEN
-        D NOW^%DTC S (BDT,WBDT)=%,EDT=9999999
-        S F="^PS(55,DFN,5," F  S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT  F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON  D UD
-        S F="^PS(53.1," F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON  D
-        . I $O(^PS(53.1,+ON,"AD",0))!$O(^PS(53.1,+ON,"SOL",0)) D PIV Q
-        . D UD
-        S WBDT=BDT F  S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT  F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON  D IV
-        I '$G(PSIVOCON) D NEWIV ; Don't do this when Finishing orders (FN)
-        Q
-UD      ;*** Get the dispense drugs for the Unit Dose orders.
-        S PSJORIEN=$P(@(F_ON_",0)"),U,21),DDRUG=0
-        I F="^PS(53.1,",($P(@(F_ON_",0)"),U,4)="I") D  Q
-        . NEW PSJPD S COD=ON_"P"
-        . S PSJPD=+$G(^PS(53.1,ON,.2)) D:$D(^PS(52.6,"AOI",PSJPD)) ENDDIV^PSJORUTL(PSJPD,"A","",.DDRUG) S DDRUG=+DDRUG D:DDRUG DDRUG
-        S ON1=0 F  S ON1=$O(@(F_ON_",1,"_ON1_")")) Q:'ON1  S DDRUG=@(F_ON_",1,"_ON1_",0)") I $P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG
-        I $D(PSGOCHK) F ON1=0:0 S ON1=$O(^PS(53.45,+PSJSYSP,1,ON1)) Q:'ON1  S DDRUG=$G(^PS(53.45,+PSJSYSP,1,ON1,0)) I $P(DDRUG,U,3)=""!@($P(DDRUG,U,3)>BDT) S (COD,PSJORIEN)="" D DDRUG
-        I '$O(@(F_ON_",1,"_0_")")) N OI S OI=+$G(@(F_ON_",.2)")) I OI D
-        .S DDRUG="" F  S DDRUG=$O(^PSDRUG("ASP",OI,DDRUG)) Q:'DDRUG  D
-        ..I ($P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT)) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG
-        Q
-PIV     ;*** Get the dispense drugs for the Pending IV orders.
-        S X=^PS(53.1,+ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,27)="R"
-        S ON1=0 F  S ON1=$O(^PS(53.1,+ON,"AD",ON1)) Q:'ON1  S X=+^PS(53.1,+ON,"AD",ON1,0),DDRUG=$P($G(^PS(52.6,X,0)),U,2) S COD=+ON_"P" D DDRUG
-        S ON1=0 F  S ON1=$O(^PS(53.1,+ON,"SOL",ON1)) Q:'ON1  S X=+^PS(53.1,+ON,"SOL",ON1,0),DDRUG=$P($G(^PS(52.7,X,0)),U,2) S COD=+ON_"P" D DDRUG
-        Q
-IV      ;*** Get the dispense drugs for the IV orders.
-        NEW X S X=^PS(55,DFN,"IV",ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,17)="R"
-        S ON1=0 F  S ON1=$O(^PS(55,DFN,"IV",ON,"AD",ON1)) Q:'ON1  S X=+^PS(55,DFN,"IV",ON,"AD",ON1,0),DDRUG=$P($G(^PS(52.6,X,0)),U,2) S COD=ON_"V" D DDRUG
-        S ON1=0 F  S ON1=$O(^PS(55,DFN,"IV",ON,"SOL",ON1)) Q:'ON1  S X=+^PS(55,DFN,"IV",ON,"SOL",ON1,0),DDRUG=$P($G(^PS(52.7,X,0)),U,2) S COD=ON_"V" D DDRUG
-        Q
-NEWIV   ;*** Get the dispense drugs for the newly entered IV order.
-        NEW PSIVX,ON
-        S ON=$O(DRGOC(0)),PSJORIEN="" Q:'+ON
-        F PSIVX=0:0 S PSIVX=$O(DRGOC(ON,"AD",PSIVX)) Q:'PSIVX  S DDRUG=$P(^PS(52.6,+DRGOC(ON,"AD",PSIVX),0),U,2),COD=ON55 D DDRUG
-        F PSIVX=0:0 S PSIVX=$O(DRGOC(ON,"SOL",PSIVX)) Q:'PSIVX  S DDRUG=$P(^PS(52.7,+DRGOC(ON,"SOL",PSIVX),0),U,2),COD=ON D DDRUG
-        Q
-DDRUG   ;*** Set PSJ(DDRUG NAME) arrays.
-        Q:'DDRUG  S DDRUG0=$G(^PSDRUG(+DDRUG,0)),DDRUGND=$G(^PSDRUG(+DDRUG,"ND"))
-        S PSJINX=+$G(PSJINX)+1 ;* ^PSOORDRG calls this entry point.
-        I $D(DDRUG)=11,DDRUG[";" D  Q   ; if called from ^PSOORDRG
-        .N IPOROP S IPOROP=$P(DDRUG,";",2)
-        .S IPOROP=$S(IPOROP="PSO":";O",IPOROP="PSH":"N;O",1:";I")
-        .S ^TMP($J,"ORDERS",PSJINX)=$P(DDRUG0,U,2)_U_$P(DDRUGND,U)_"A"_$P(DDRUGND,U,3)_U_$P(DDRUG0,U)_U_$S($G(DDRUG(DDRUG)):DDRUG(DDRUG),1:$G(PSJORIEN))_U_$G(COD)_IPOROP
-        S ^TMP($J,"ORDERS",PSJINX)=$P(DDRUG0,U,2)_U_$P(DDRUGND,U)_"A"_$P(DDRUGND,U,3)_U_$P(DDRUG0,U)_U_$G(PSJORIEN)_U_$G(COD)_";I"
-        Q
-        ;
-PRCHK(PSJ)      ; Check if authorized to write med orders.
-        N %,X
-        D NOW^%DTC S X=$G(^VA(200,PSJ,"PS")) I $S('X:1,'$P(%,"^",4):0,1:$P(X,"^",4)'>%) Q 0
-        Q PSJ
-        ;
-ENNG(PSJDPT,PSJNUM)              ; returns 1 if order marked "Not To Be Given"
-        ;                                  0 if not marked
-        I '$D(^PS(55,PSJDPT,5,+PSJNUM,0)) Q 0
-        I $P($G(^PS(55,PSJDPT,5,+PSJNUM,0)),"^",22)=1 Q 1
-        Q 0
+PSJORUT2 ;BIR/MLM-MISC. PROCEDURE CALLS FOR OE/RR 3.0 (CONT.) ;03 Aug 98 / 8:42 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**14,29,50,56,58,107,152**;16 DEC 97
+ ;
+ ; Reference to ^PS(55 is supported by DBIA 2191
+ ; Reference to ^PS(50.605 is supported by DBIA 2138
+ ; References to ^PS(52.6 supported by DBIA 1231
+ ; Reference to ^PS(52.7 supported by DBIA 2173.
+ ; Reference to ^PSDRUG( is supported by DBIA 2192
+ ; Reference to ^PSNDF( is supported by DBIA 2195
+ ; Reference to ^PSRX( is supported by DBIA 824
+ ; Reference to ^PSNAPIS is supported by DBIA 2531
+ ;
+ENVAC(PN) ; Find VA CLASS of VA Product Name
+ ;Input: PN - See above
+ ;Output: VA Drug Class^Classification
+ ;
+ ; NEW NDF CALL 
+ N X S X="PSNAPIS" X ^%ZOSF("TEST") I  N PSJC,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),PSJC=$$DCLASS^PSNAPIS(X1,X2) Q PSJC
+ ;
+ N GDP,PNP S GDP=$P(PN,"."),PNP=$P(PN,".",2)
+ S X=+$P($G(^PSNDF(+GDP,5,+PNP,0)),U,2),X=+$P($G(^PSNDF(GDP,2,X,0)),U,3),PSJC=$P($G(^PS(50.605,X,0)),U,2)
+ Q $S('X:0,PSJC="":0,1:X_U_PSJC)
+ ;
+ENVAGN(PN) ; Return VA Generic Name for specified VA Product Name.
+ ;Input:  PN - VA Product Name IEN
+ ;Output: VA Generic Name IEN^VA Generic Name
+ ;
+ ; NEW NDF CALL 
+ N X S X="PSNAPIS" X ^%ZOSF("TEST") I  N GDP,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),GDP=$$VAGN^PSNAPIS(X1) Q $S(GDP=0:0,1:X1_U_GDP)
+ ;
+ N GDP,PNP S GDP=+$P(PN,"."),PNP=+$P(PN,".",2)
+ S X=$P($G(^PSNDF(GDP,0)),U)
+ Q $S('GDP:0,X="":0,1:GDP_U_X)
+ENVOL(PN,ARRAY) ;
+ I (PN'["A")&(PN'["B") S ARRAY="0" Q
+ N X,XX,F,INACT,IVFL S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM"
+ I PN["A" N ADD S (ADD,X,XX)=0 F  S ADD=$O(^PS(52.6,"AOI",+PN,ADD))  Q:ADD=""  D
+ .S INACT=$G(^PS(52.6,ADD,"I")) I INACT']""!(INACT>DT) S IVFL=$P($G(^(0)),"^",13) Q:'IVFL  S XX=XX+1,ARRAY(ADD)="^"_X($P($G(^PS(52.6,ADD,0)),U,3)) Q
+ I PN["B" N SOL S SOL=0,XX=0 F  S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL=""  D
+ .S INACT=$G(^PS(52.7,SOL,"I")) I INACT']""!(INACT>DT) S IVFL=$P($G(^(0)),"^",13) Q:'IVFL  S XX=XX+1,ARRAY(SOL)=$P($G(^PS(52.7,SOL,0)),"^",3)
+ S ARRAY=XX>0
+ Q
+ ;
+ENVOL2(PN,ARRAY) ;Only for Med Button IV orders.
+ I (PN'["A")&(PN'["B") S ARRAY="0" Q
+ N X,XX,F,INACT S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM"
+ I PN["A" N ADD S (ADD,X,XX)=0 F  S ADD=$O(^PS(52.6,"AOI",+PN,ADD))  Q:ADD=""  D
+ .S INACT=$G(^PS(52.6,ADD,"I")) I INACT']""!(INACT>DT) S XX=XX+1,ARRAY(ADD)="^"_X($P($G(^PS(52.6,ADD,0)),U,3)) Q
+ I PN["B" N SOL S SOL=0,XX=0 F  S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL=""  D
+ .S INACT=$G(^PS(52.7,SOL,"I")) I INACT']""!(INACT>DT) S XX=XX+1,ARRAY(SOL)=$P($G(^PS(52.7,SOL,0)),"^",3)
+ S ARRAY=XX>0
+ Q
+ ;
+ ;
+SENVOL(PN,PSJ) ;Return array listing volume (base only) and volume units for the specified additive or solution.
+ ;Input:  PN - IEN_B (Base) or A (Additive)
+ ;Output: ARRAY(IEN,A:additive or B:Base)=volume^volume units
+ ;        If no volume or units found PSJ=0; If found PSJ=1.
+ ;
+ N X S PSJ=1,X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM"
+ I PN'["A",PN'["B" S PSJ=0 Q
+ S PSJ=PSJ+1
+ I PN["A" S PSJ(+PN,"A")=U_X(+$P($G(^PS(52.6,+PN,0)),U,3)) Q
+ I PN["B" S PSJ(+PN,"B")=+$P($G(^PS(52.7,+PN,0)),U,3)_U_X(1) Q
+ Q
+ ;
+ENREF(PRX) ; Return number of refills remaining.
+ ;Input: PRX - Internal prescription number from File #52.
+ ;Output: Number of refills remaining.
+ ;
+ N X,COUNT,CNT S PRX=$P(PRX,"^"),COUNT=0,X=$P(^PSRX(PRX,0),"^",9)
+ D:$O(^PSRX(PRX,1,0))
+ .F CNT=0:0 S CNT=$O(^PSRX(PRX,1,CNT)) Q:'CNT  S COUNT=COUNT+1
+ S:$G(COUNT) X=X-COUNT
+ Q X
+ ;
+ENCHK(DFN,PSJINX)     ; Return dispense drug check array.
+ ;Input: DFN      - Patient internal entry number
+ ;       PSJINX   - Index number so duplicate drugs will be returned.
+ ;       PSGOCHK  - Check should include dispense drugs in 53.45
+ ;       PSIVOCHK - Check should include entries in DRG array
+ ;Output: ^TMP($J,"ORDERS",PSJINX)=DRUG CLASS^NATIONAL DRUG FILE ENTRY
+ ;        _"A"_PSNDFA PRODUCT NAME ENTRY_DISPENSE DRUG NAME^OE/RR #
+ ;        _ORDER NUMBER(P/I/V)_";I"
+ ;
+ NEW BDT,DDRUG,DDRUG0,DDRUGND,EDT,F,ON,ON1,PST,WBDT,X,PSJORIEN
+ ;* S BDT=DT,WBDT=BDT_".000001",EDT=9999999
+ D NOW^%DTC S (BDT,WBDT)=%,EDT=9999999
+ S F="^PS(55,DFN,5," F  S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT  F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON  D UD
+ S F="^PS(53.1," F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON  D
+ . I $O(^PS(53.1,+ON,"AD",0))!$O(^PS(53.1,+ON,"SOL",0)) D PIV Q
+ . D UD
+ S WBDT=BDT F  S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT  F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON  D IV
+ I '$G(PSIVOCON) D NEWIV ; Don't do this when Finishing orders (FN)
+ Q
+UD ;*** Get the dispense drugs for the Unit Dose orders.
+ S PSJORIEN=$P(@(F_ON_",0)"),U,21),DDRUG=0
+ I F="^PS(53.1,",($P(@(F_ON_",0)"),U,4)="I") D  Q
+ . NEW PSJPD S COD=ON_"P"
+ . S PSJPD=+$G(^PS(53.1,ON,.2)) D:$D(^PS(52.6,"AOI",PSJPD)) ENDDIV^PSJORUTL(PSJPD,"A","",.DDRUG) S DDRUG=+DDRUG D:DDRUG DDRUG
+ S ON1=0 F  S ON1=$O(@(F_ON_",1,"_ON1_")")) Q:'ON1  S DDRUG=@(F_ON_",1,"_ON1_",0)") I $P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG
+ I $D(PSGOCHK) F ON1=0:0 S ON1=$O(^PS(53.45,+PSJSYSP,1,ON1)) Q:'ON1  S DDRUG=$G(^PS(53.45,+PSJSYSP,1,ON1,0)) I $P(DDRUG,U,3)=""!@($P(DDRUG,U,3)>BDT) S (COD,PSJORIEN)="" D DDRUG
+ I '$O(@(F_ON_",1,"_0_")")) N OI S OI=+$G(@(F_ON_",.2)")) I OI D
+ .S DDRUG="" F  S DDRUG=$O(^PSDRUG("ASP",OI,DDRUG)) Q:'DDRUG  D
+ ..I ($P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT)) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG
+ Q
+PIV ;*** Get the dispense drugs for the Pending IV orders.
+ S X=^PS(53.1,+ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,27)="R"
+ S ON1=0 F  S ON1=$O(^PS(53.1,+ON,"AD",ON1)) Q:'ON1  S X=+^PS(53.1,+ON,"AD",ON1,0),DDRUG=$P($G(^PS(52.6,X,0)),U,2) S COD=+ON_"P" D DDRUG
+ S ON1=0 F  S ON1=$O(^PS(53.1,+ON,"SOL",ON1)) Q:'ON1  S X=+^PS(53.1,+ON,"SOL",ON1,0),DDRUG=$P($G(^PS(52.7,X,0)),U,2) S COD=+ON_"P" D DDRUG
+ Q
+IV ;*** Get the dispense drugs for the IV orders.
+ NEW X S X=^PS(55,DFN,"IV",ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,17)="R"
+ S ON1=0 F  S ON1=$O(^PS(55,DFN,"IV",ON,"AD",ON1)) Q:'ON1  S X=+^PS(55,DFN,"IV",ON,"AD",ON1,0),DDRUG=$P($G(^PS(52.6,X,0)),U,2) S COD=ON_"V" D DDRUG
+ S ON1=0 F  S ON1=$O(^PS(55,DFN,"IV",ON,"SOL",ON1)) Q:'ON1  S X=+^PS(55,DFN,"IV",ON,"SOL",ON1,0),DDRUG=$P($G(^PS(52.7,X,0)),U,2) S COD=ON_"V" D DDRUG
+ ;*D:$G(PSIVNEW) NEWIV
+ Q
+NEWIV ;*** Get the dispense drugs for the newly entered IV order.
+ NEW PSIVX,ON
+ S ON=$O(DRGOC(0)),PSJORIEN="" Q:'+ON
+ F PSIVX=0:0 S PSIVX=$O(DRGOC(ON,"AD",PSIVX)) Q:'PSIVX  S DDRUG=$P(^PS(52.6,+DRGOC(ON,"AD",PSIVX),0),U,2),COD=ON55 D DDRUG
+ F PSIVX=0:0 S PSIVX=$O(DRGOC(ON,"SOL",PSIVX)) Q:'PSIVX  S DDRUG=$P(^PS(52.7,+DRGOC(ON,"SOL",PSIVX),0),U,2),COD=ON D DDRUG
+ Q
+DDRUG ;*** Set PSJ(DDRUG NAME) arrays.
+ Q:'DDRUG  S DDRUG0=$G(^PSDRUG(+DDRUG,0)),DDRUGND=$G(^PSDRUG(+DDRUG,"ND"))
+ S PSJINX=+$G(PSJINX)+1 ;* ^PSOORDRG calls this entry point.
+ I $D(DDRUG)=11,DDRUG[";" D  Q   ; if called from ^PSOORDRG
+ .N IPOROP S IPOROP=$P(DDRUG,";",2)
+ .S IPOROP=$S(IPOROP="PSO":";O",IPOROP="PSH":"N;O",1:";I")
+ .S ^TMP($J,"ORDERS",PSJINX)=$P(DDRUG0,U,2)_U_$P(DDRUGND,U)_"A"_$P(DDRUGND,U,3)_U_$P(DDRUG0,U)_U_$S($G(DDRUG(DDRUG)):DDRUG(DDRUG),1:$G(PSJORIEN))_U_$G(COD)_IPOROP
+ S ^TMP($J,"ORDERS",PSJINX)=$P(DDRUG0,U,2)_U_$P(DDRUGND,U)_"A"_$P(DDRUGND,U,3)_U_$P(DDRUG0,U)_U_$G(PSJORIEN)_U_$G(COD)_";I"
+ Q
+ ;
+PRCHK(PSJ) ; Check if authorized to write med orders.
+ N %,X
+ D NOW^%DTC S X=$G(^VA(200,PSJ,"PS")) I $S('X:1,'$P(%,"^",4):0,1:$P(X,"^",4)'>%) Q 0
+ Q PSJ
+ ;
+ENNG(PSJDPT,PSJNUM)          ; returns 1 if order marked "Not To Be Given"
+ ;                                  0 if not marked
+ I '$D(^PS(55,PSJDPT,5,+PSJNUM,0)) Q 0
+ I $P($G(^PS(55,PSJDPT,5,+PSJNUM,0)),"^",22)=1 Q 1
+ Q 0

WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJUTL.m

@@ -1 @@
-PSJUTL  ;BIR/MLM-MISC. INPATIENT UTILITIES ;17 Mar 98 / 11:05 AM
-        ;;5.0; INPATIENT MEDICATIONS ;**9,47,58,80,110,136,157,177,134**;16 DEC 97;Build 124
-        ;
-        ; Reference to ^DIC(42 is supported by DBIA 10039.
-        ; Reference to ^PS(50.7 is supported by DBIA 2180.
-        ; Reference to ^PSDRUG( is supported by DBIA 2192.
-        ; Reference to ^DIC is supported by DBIA 10006.
-        ; Reference to ^DIC1 is supported by DBIA 10007.
-        ; Reference to ^DIR is supported by DBIA 10026.
-        ; Reference to ^VALM1 is supported by DBIA 10116.
-        ;
-ENDL    ; device look-up
-        N DA,DIC,DIE,DIX,DO,DR
-        S DIC="^%ZIS(1,",DIC(0)="EIMZ" D DO^DIC1,^DIC I Y'>0 K X Q
-        S X=Y(0,0)
-        Q
-        ;
-ENDH(X) ; device help
-        N D,XQH,DA,DIC,DIE,DO,DR,DZ
-        S DIC="^%ZIS(1,",DIC(0)="EIM" D DO^DIC1,^DIC
-        Q
-        ;
-READ    ; hold screen
-        I $D(IOST) Q:$E(IOST)'="C"
-        W ! I $D(IOSL),$Y<(IOSL-4) G READ
-        W !?5,"Press return to continue  " R X:$S($D(DTIME):DTIME,1:300)
-        Q
-        ;
-ENOISC(PSJOI,USAGE)              ;Set DIC("S") so that only Orderable Items with at 
-        ;least 1 active dispense drug for the specified usage.
-        ;Input:  PSJOI IEN of Orderable Item selected
-        ;        USAGE - Type of drugs (UD,IV,etc) to be selected
-        ;Output: 1-At least one dispense drug found
-        ;        0-None found
-        N FOUND,PSJ
-        S PSJ=$P($G(^PS(50.7,+PSJOI,0)),U,4),FOUND=$S('PSJ:1,PSJ>DT:1,1:0)
-        I FOUND S FOUND=0 F PSJ=0:0 S PSJ=$O(^PSDRUG("ASP",PSJOI,PSJ)) Q:FOUND!'PSJ  I $P($G(^PSDRUG(PSJ,2)),U,3)[USAGE,'$G(^("I"))!($G(^("I"))'<DT) S FOUND=1
-        Q FOUND
-        ;
-AADR    ; display allergies and adverse reactions
-        D ATS^PSJMUTL(60,50,1) N A,B
-        I (PSGALG=0)&(PSGADR=0) W !!,"No allergies or ADRs on file."
-        I PSGALG'=0 W !!,"Allergies: " S B="PSGALG" F  S A=$Q(@B) Q:A=""  W ?12,$G(@A),! S B=A
-        I PSGADR'=0 W !,"      ADR: " S B="PSGADR" F  S A=$Q(@B) Q:A=""  W ?12,$G(@A),! S B=A
-        D READ K PSGALG,PSGADR Q
-        ;
-ENALU   ; application look-up
-        N PSJ S PSJ=DA(1) N DA,DIC,DIE,DIX,DO,DR S DIC="^PS(50.35,",DIC(0)="EIMZ" D DO^DIC1,^DIC I Y'>0 K X Q
-        S X=$P(Y(0),"^",2) K:$S(X="":1,1:$D(^PS(50.3,PSJ,1,"B",X))) X
-        Q
-        ;
-ENAQ    ; application query
-        S X=DZ N D,DA,DIC,DIE,DO,DR,DZ,XQH S DIC="^PS(50.35,",DIC(0)="EIMQ" D DO^DIC1,^DIC
-        Q
-        ;
-ENPC(PSJTYP,PSJSYSP,LEN,TEXT)   ; Copy Provider Comments -> Special Instructions.
-        Q:'$D(^PS(53.1,+$G(PSJORD),12,1,0)) ""
-        N DIR,PSGSI,PSGOEE,X,Y
-        S Y="" F X=0:0 S X=$O(^PS(53.1,+$G(PSJORD),12,X)) Q:'X  S Y=Y_^(X,0)_" " Q:$L(Y)>LEN
-        S:$G(PSJTYP)'="V" Y=$$ENSET^PSGSICHK(Y) S:$G(PSJTYP)="V" Y=$E(Y,1,$L(Y)-1)
-        I $L(Y)'<LEN S PSGOEE=0 D REDISP Q PSGSI
-        ;Display Provider Comments Prior to Asking the Copy Provider Comments Question;BHW;PSJ*5*136
-        N PSJTMP S PSJTMP=0
-        W !,"PROVIDER COMMENTS:"
-        F  S PSJTMP=$O(^PS(53.1,+$G(PSJORD),12,PSJTMP)) Q:'PSJTMP  W !,^PS(53.1,+$G(PSJORD),12,PSJTMP,0)
-        S PSGSI=Y W ! S DIR(0)="S^Y:Yes;N:No;!:Copy and flag for display in a BCMA Message Box",DIR("A")="Copy the Provider Comments into "_$$ENFIELD(PSJTYP)_" (Yes/No/!)",DIR("??")="^D ENPCHLP1^PSJUTL(PSJTYP)" D ^DIR
-        Q:Y="Y" PSGSI
-        Q:Y="!" PSGSI_"^1"
-        Q ""
-        ;
-REDISP  ; Redisplay Provider Comments and allow entry of Spec. Instructions.
-        D CLEAR^VALM1 F X=0:0 S X=$O(^PS(53.1,+$G(PSJORD),12,X)) Q:'X  W ^(X,0),!
-        W !! S PSGSI=""
-        D:PSJTYP'="V" 8^PSGOE81
-        I PSJTYP="V" D 64^PSIVEDT1 S PSGSI=P("OPI")
-        Q
-        ;
-ENPCHLP1(Y)     ; Display help messages for Provider Comment copy.
-        W !,"Enter ""YES"" to copy Provider Comments into the ",$$ENFIELD(Y)," field",!,"or ""NO"" to bypass",!,"or ""!"" to copy the Provider Comments into the ",$$ENFIELD(PSJTYP)," field",!,"and flag them for display in a BCMA Message Box",!!
-        Q
-ENPCHLP2(Y,X)   ;
-        W !,"The Provider Comments entered for this order are longer than the space available",!,"in the ",$$ENFIELD(Y)," field.",!!,"Enter ""YES"" to copy the first ",X-3," characters into the ",$$ENFIELD(Y),!,"field, or ""NO"" to continue.",!!
-        Q
-ENBCMA(PSJTYP)   ;
-        N DIR,X,Y
-        W !!,"Would you like to flag the ",$$ENFIELD(PSJTYP)," field for display in a BCMA",!,"Message box?"
-        W ! S DIR(0)="S^Y:Yes;N:No",DIR("A")="Flag the "_$$ENFIELD(PSJTYP)_" (Yes/No)" D ^DIR
-        K PSJCOMSI I $G(PSJCOM),$G(PSJORD)'["P" N TEXT S TEXT=$S(PSJTYP="U":$G(PSGSI),1:$G(P("OPI"))) S PSJCOMSI=$$COMSI(PSJCOM,TEXT)
-        Q:Y="Y" $S($G(PSJTYP)="U":$P(PSGSI,"^")_"^1",1:$P(P("OPI"),"^")_"^1")
-        Q $S(PSJTYP="U":$P(PSGSI,"^"),1:$P($G(P("OPI")),"^"))
-ENFIELD(Y)      ;
-        Q $S(Y="V":"Other Print Info",1:"Special Instructions")
-        ;
-COMSI(PARENT,INSTR)     ;
-        N DIR,X,Y
-        W !!!!?15,"** WARNING **",!?5,"This order is part of a complex order."
-        W !!,"Would you like to copy the ",$$ENFIELD(PSJTYP)
-        W !,"to the other orders in the complex order?"
-        S DIR(0)="S^Y:Yes;N:No",DIR("A")="     Copy the "_$$ENFIELD(PSJTYP)_" (Yes/No)" D ^DIR
-        Q:Y="Y" 1
-        Q 0
-        ;
-ENORL(X)        ; Return patient's location as variable ptr.
-        Q $S(+$G(^DIC(42,+X,44)):+$G(^(44))_";SC(",$D(^DIC(42,+X,0)):+X_";DIC(42,",1:"")
-        ;
-ENMARD()        ; validate MAR SELECTION DEFAULT string in WARD PARMS file.
-        N PSJANS,PSJX1,PSJX2,RANGE,Q
-        S RANGE="1:6" F PSJX1=1:1:6 S RANGE(PSJX1)=""
-        S:$E(X)="-" X=+RANGE_X S:$E($L(X))="-" X=X_$P(RANGE,":",2)
-        S PSJANS="" F Q=1:1:$L(X,",") S PSJX1=$P(X,",",Q) D FS Q:'$D(PSJANS)
-        Q:'$G(PSJANS) 0
-        S PSJANS=$E(PSJANS,1,$L(PSJANS)-1) F Q=1:1:$L(PSJANS,",") D  Q:'$D(PSJANS)
-        .I $P(PSJANS,",",Q)=1,$L(PSJANS,",")>1 W !!,"All Medications (1) may not be selected in combination with other types." K PSJANS Q
-        .W ?47,$P(PSJANS,",",Q)," - ",$P($T(@$P(PSJANS,",",Q)),";;",2),!
-        S:$G(PSJANS) X=PSJANS Q $G(PSJANS)
-        ;
-FS      ;
-        I $S(PSJX1?1.N1"-"1.N:0,PSJX1'?1.N:1,'$D(RANGE(PSJX1)):1,1:","_PSJANS[PSJX1) K PSJANS Q
-        I PSJX1'["-" S PSJANS=PSJANS_PSJX1_"," Q
-        S PSJX2=+PSJX1,PSJANS=PSJANS_PSJX2_","
-        F  S PSJX2=$O(RANGE(PSJX2)) K:$S(X="":1,","_PSJANS[PSJX2:1,1:PSJX2>$P(PSJX1,"-",2)) PSJANS Q:'$D(PSJANS)  S PSJANS=PSJANS_PSJX2_"," Q:PSJX2=$P(PSJX1,"-",2)
-        Q
-        ;
-ENMARDH ;Help text for MAR default answer.
-        W !!?2,"Enter the number corresponding to the type of orders to be included on MARs",!,"printed for this ward. Multiple types (except 1) may be selected using ""-""",!,"or "","" as delimiters.",!!,"Choose from: ",!
-        N X F X=1:1:6 W !?13,X," - ",$P($T(@X),";;",2)
-        W !
-        Q
-1       ;;All Medications
-2       ;;Non-IV Medications only
-3       ;;IV Piggybacks
-4       ;;LVPs
-5       ;;TPNs
-6       ;;Chemotherapy Medications (IV)
-        ;
-EFD     ;The following EFD Tags are used to Calculate the Expected First Dose for backdoor
-        ;orders.  The call to $$ENQ^PSJORP2 is used to actually perform the calculation.
-        ;The program $$ENQ^PSJORP2 requires the variable INFO to equal the following:
-        ;BHW;PSJ*5*136
-        ; INFO (piece 1) = START DATE/TIME      ;PSGNESD (NEW ORDER)
-        ; INFO (piece 2) = STOP DATE/TIME       ;PSGNEFD (NEW ORDER)
-        ; INFO (piece 3) = SCHEDULE             ;PSGSCH  (NEW ORDER)
-        ; INFO (piece 4) = SCHEDULE TYPE        ;PSGST   (NEW ORDER)
-        ; INFO (piece 5) = ORDERABLE ITEM       ;PSGDRG  (NEW ORDER)
-        ; INFO (piece 6) = ADMIN TIMES          ;PSGS0Y  (NEW ORDER)
-        ; 
-EFDNEW  ;Call Here if NEW or RENEWED Order
-        N INFO
-        S INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGDRG))_U_($G(PSGS0Y))
-        D EFDDISP
-        QUIT
-EFDACT  ;Call here if Editing Fields for an ACTIVE order
-        ; Field 10 = Start Date
-        ; Field 34 = Stop Date
-        ; Field 41 = Admin Times
-        N INFO,KEY,ORDER,LAST
-        ;Loop Fields to be edited, in order, and determine when to Display expected first dose message
-        F KEY=1:1 S ORDER=$P(PSGOEER,";",KEY) Q:'$L(ORDER)  I "10^34^41"[$P(ORDER,U,1) S ORDER(KEY)=$P(ORDER,U,1)
-        ;If there are no entries in ORDER, then were Not Editing Start/Stop or Admin Times
-        S LAST=$O(ORDER(99),-1) Q:'LAST
-        ;Only display EFD once, so Quit if this call is not for the Last field in the Edit
-        S LAST=ORDER(LAST)
-        I LAST'=PSGF2 Q
-        S INFO=($G(PSGSD))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y))
-        D EFDDISP
-        QUIT
-EFDNV   ;Call here if Editing Fields for a NON-VERIFIED order
-        ; Field 10 = Start Date
-        ; Field 25 = Stop Date
-        ; Field 39 = Admin Times
-        N INFO,KEY,ORDER,LAST
-        ;Check if called during finish process
-        I '$D(PSGOEER) D  D EFDDISP Q
-        . S INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y))
-        . Q
-        ;Loop Fields to be edited, in order, and determine when to Display expected first dose message
-        F KEY=1:1 S ORDER=$P(PSGOEER,";",KEY) Q:'$L(ORDER)  I "10^25^39"[$P(ORDER,U,1) S ORDER(KEY)=$P(ORDER,U,1)
-        ;If there are no entries in ORDER, then were Not Editing Start/Stop or Admin Times
-        S LAST=$O(ORDER(99),-1) Q:'LAST
-        ;Only display EFD once, so Quit if this call is not for the Last field in the Edit
-        S LAST=ORDER(LAST)
-        I LAST'=PSGF2 Q
-        S INFO=($G(PSGSD))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y))
-        D EFDDISP
-        QUIT
-EFDIV(PSGZZND)  ;Set variables for EFD on IV orders.
-        I $G(PSGZZND)="" D
-        .N X,ZZND,LYN,PSGS0XT,PSGS0Y,PSGOES S PSGOES=1 S X=P(9) D EN^PSGS0 S:$G(ZZND)'="" PSGZZND=ZZND
-        S PSGNESD=P(2),PSGNEFD=P(3),PSGSCH=P(9),PSGST=$P($G(PSGZZND),"^",5),PSGDRG=$P($G(P("PD")),"^"),PSGS0Y=P(11)
-        ;BHW - PSJ*5*177 Add call to check stop date.  If it's in the past, Display Message
-        D CHKSTOP
-        D EFDNEW
-        W !
-        Q
-EFDDISP ;Display Expected First Dose
-        N Y,Z
-        Q:$G(PSGST)="OC"!($G(PSGST)="P")!($G(PSGST)="O")
-        Q:$G(PSGSCH)["ON CALL"!($G(PSGSCH)["ON-CALL")!($G(PSGSCH)["ONCALL")
-        Q:$G(PSGSCH)["PRN"
-        I '$L($G(PSGP)) N PSGP S PSGP=""
-        S Y=$$ENQ^PSJORP2(PSGP,INFO)
-        I 'Y S Y="Unable to Calculate"
-        X ^DD("DD")
-        W !,"Expected First Dose: ",Y H 2
-        Q
-CHKSTOP ;BHW - PSJ*5*177 Warn user if the Stop Date is < now.
-        I '+$G(P(3)) Q
-        N PSNOW,%,%H,%I,X D NOW^%DTC S PSNOW=%
-        I +P(3)<PSNOW D  Q
-        . W !,$C(7),"The Stop Date/Time is in the Past!!!  This order will",!,"automatically EXPIRE upon Verification!!",!
-        . Q
-        Q
+PSJUTL ;BIR/MLM-MISC. INPATIENT UTILITIES ;17 Mar 98 / 11:05 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**9,47,58,80,110,136,157,177**;16 DEC 97
+ ;
+ ; Reference to ^DIC(42 is supported by DBIA 10039.
+ ; Reference to ^PS(50.7 is supported by DBIA 2180.
+ ; Reference to ^PSDRUG( is supported by DBIA 2192.
+ ; Reference to ^DIC is supported by DBIA 10006.
+ ; Reference to ^DIC1 is supported by DBIA 10007.
+ ; Reference to ^DIR is supported by DBIA 10026.
+ ; Reference to ^VALM1 is supported by DBIA 10116.
+ ;
+ENDL ; device look-up
+ N DA,DIC,DIE,DIX,DO,DR
+ S DIC="^%ZIS(1,",DIC(0)="EIMZ" D DO^DIC1,^DIC I Y'>0 K X Q
+ S X=Y(0,0)
+ Q
+ ;
+ENDH(X) ; device help
+ N D,XQH,DA,DIC,DIE,DO,DR,DZ
+ S DIC="^%ZIS(1,",DIC(0)="EIM" D DO^DIC1,^DIC
+ Q
+ ;
+READ ; hold screen
+ I $D(IOST) Q:$E(IOST)'="C"
+ W ! I $D(IOSL),$Y<(IOSL-4) G READ
+ W !?5,"Press return to continue  " R X:$S($D(DTIME):DTIME,1:300)
+ Q
+ ;
+ENOISC(PSJOI,USAGE)          ;Set DIC("S") so that only Orderable Items with at 
+ ;least 1 active dispense drug for the specified usage.
+ ;Input:  PSJOI IEN of Orderable Item selected
+ ;        USAGE - Type of drugs (UD,IV,etc) to be selected
+ ;Output: 1-At least one dispense drug found
+ ;        0-None found
+ N FOUND,PSJ
+ S PSJ=$P($G(^PS(50.7,+PSJOI,0)),U,4),FOUND=$S('PSJ:1,PSJ>DT:1,1:0)
+ I FOUND S FOUND=0 F PSJ=0:0 S PSJ=$O(^PSDRUG("ASP",PSJOI,PSJ)) Q:FOUND!'PSJ  I $P($G(^PSDRUG(PSJ,2)),U,3)[USAGE,'$G(^("I"))!($G(^("I"))'<DT) S FOUND=1
+ Q FOUND
+ ;
+AADR ; display allergies and adverse reactions
+ D ATS^PSJMUTL(60,50,1) N A,B
+ I (PSGALG=0)&(PSGADR=0) W !!,"No allergies or ADRs on file."
+ I PSGALG'=0 W !!,"Allergies: " S B="PSGALG" F  S A=$Q(@B) Q:A=""  W ?12,$G(@A),! S B=A
+ I PSGADR'=0 W !,"      ADR: " S B="PSGADR" F  S A=$Q(@B) Q:A=""  W ?12,$G(@A),! S B=A
+ D READ K PSGALG,PSGADR Q
+ ;
+ENALU ; application look-up
+ N PSJ S PSJ=DA(1) N DA,DIC,DIE,DIX,DO,DR S DIC="^PS(50.35,",DIC(0)="EIMZ" D DO^DIC1,^DIC I Y'>0 K X Q
+ S X=$P(Y(0),"^",2) K:$S(X="":1,1:$D(^PS(50.3,PSJ,1,"B",X))) X
+ Q
+ ;
+ENAQ ; application query
+ S X=DZ N D,DA,DIC,DIE,DO,DR,DZ,XQH S DIC="^PS(50.35,",DIC(0)="EIMQ" D DO^DIC1,^DIC
+ Q
+ ;
+ENPC(PSJTYP,PSJSYSP,LEN,TEXT) ; Copy Provider Comments -> Special Instructions.
+ Q:'$D(^PS(53.1,+$G(PSJORD),12,1,0)) ""
+ N DIR,PSGSI,PSGOEE,X,Y
+ S Y="" F X=0:0 S X=$O(^PS(53.1,+$G(PSJORD),12,X)) Q:'X  S Y=Y_^(X,0)_" " Q:$L(Y)>LEN
+ S:$G(PSJTYP)'="V" Y=$$ENSET^PSGSICHK(Y) S:$G(PSJTYP)="V" Y=$E(Y,1,$L(Y)-1)
+ I $L(Y)'<LEN S PSGOEE=0 D REDISP Q PSGSI
+ ;Display Provider Comments Prior to Asking the Copy Provider Comments Question;BHW;PSJ*5*136
+ N PSJTMP S PSJTMP=0
+ W !,"PROVIDER COMMENTS:"
+ F  S PSJTMP=$O(^PS(53.1,+$G(PSJORD),12,PSJTMP)) Q:'PSJTMP  W !,^PS(53.1,+$G(PSJORD),12,PSJTMP,0)
+ S PSGSI=Y W ! S DIR(0)="S^Y:Yes;N:No;!:Copy and flag for display in a BCMA Message Box",DIR("A")="Copy the Provider Comments into "_$$ENFIELD(PSJTYP)_" (Yes/No/!)",DIR("??")="^D ENPCHLP1^PSJUTL(PSJTYP)" D ^DIR
+ Q:Y="Y" PSGSI
+ Q:Y="!" PSGSI_"^1"
+ Q ""
+ ;
+REDISP ; Redisplay Provider Comments and allow entry of Spec. Instructions.
+ D CLEAR^VALM1 F X=0:0 S X=$O(^PS(53.1,+$G(PSJORD),12,X)) Q:'X  W ^(X,0),!
+ W !! S PSGSI=""
+ D:PSJTYP'="V" 8^PSGOE81
+ I PSJTYP="V" D 64^PSIVEDT1 S PSGSI=P("OPI")
+ Q
+ ;
+ENPCHLP1(Y) ; Display help messages for Provider Comment copy.
+ W !,"Enter ""YES"" to copy Provider Comments into the ",$$ENFIELD(Y)," field",!,"or ""NO"" to bypass",!,"or ""!"" to copy the Provider Comments into the ",$$ENFIELD(PSJTYP)," field",!,"and flag them for display in a BCMA Message Box",!!
+ Q
+ENPCHLP2(Y,X) ;
+ W !,"The Provider Comments entered for this order are longer than the space available",!,"in the ",$$ENFIELD(Y)," field.",!!,"Enter ""YES"" to copy the first ",X-3," characters into the ",$$ENFIELD(Y),!,"field, or ""NO"" to continue.",!!
+ Q
+ENBCMA(PSJTYP)  ;
+ N DIR,X,Y
+ W !!,"Would you like to flag the ",$$ENFIELD(PSJTYP)," field for display in a BCMA",!,"Message box?"
+ W ! S DIR(0)="S^Y:Yes;N:No",DIR("A")="Flag the "_$$ENFIELD(PSJTYP)_" (Yes/No)" D ^DIR
+ K PSJCOMSI I $G(PSJCOM),$G(PSJORD)'["P" N TEXT S TEXT=$S(PSJTYP="U":$G(PSGSI),1:$G(P("OPI"))) S PSJCOMSI=$$COMSI(PSJCOM,TEXT)
+ Q:Y="Y" $S($G(PSJTYP)="U":$P(PSGSI,"^")_"^1",1:$P(P("OPI"),"^")_"^1")
+ Q $S(PSJTYP="U":$P(PSGSI,"^"),1:$P($G(P("OPI")),"^"))
+ENFIELD(Y) ;
+ Q $S(Y="V":"Other Print Info",1:"Special Instructions")
+ ;
+COMSI(PARENT,INSTR) ;
+ N DIR,X,Y
+ W !!!!?15,"** WARNING **",!?5,"This order is part of a complex order."
+ W !!,"Would you like to copy the ",$$ENFIELD(PSJTYP)
+ W !,"to the other orders in the complex order?"
+ S DIR(0)="S^Y:Yes;N:No",DIR("A")="     Copy the "_$$ENFIELD(PSJTYP)_" (Yes/No)" D ^DIR
+ Q:Y="Y" 1
+ Q 0
+ ;
+ENORL(X) ; Return patient's location as variable ptr.
+ Q $S(+$G(^DIC(42,+X,44)):+$G(^(44))_";SC(",$D(^DIC(42,+X,0)):+X_";DIC(42,",1:"")
+ ;
+ENMARD() ; validate MAR SELECTION DEFAULT string in WARD PARMS file.
+ N PSJANS,PSJX1,PSJX2,RANGE,Q
+ S RANGE="1:6" F PSJX1=1:1:6 S RANGE(PSJX1)=""
+ S:$E(X)="-" X=+RANGE_X S:$E($L(X))="-" X=X_$P(RANGE,":",2)
+ S PSJANS="" F Q=1:1:$L(X,",") S PSJX1=$P(X,",",Q) D FS Q:'$D(PSJANS)
+ Q:'$G(PSJANS) 0
+ S PSJANS=$E(PSJANS,1,$L(PSJANS)-1) F Q=1:1:$L(PSJANS,",") D  Q:'$D(PSJANS)
+ .I $P(PSJANS,",",Q)=1,$L(PSJANS,",")>1 W !!,"All Medications (1) may not be selected in combination with other types." K PSJANS Q
+ .W ?47,$P(PSJANS,",",Q)," - ",$P($T(@$P(PSJANS,",",Q)),";;",2),!
+ S:$G(PSJANS) X=PSJANS Q $G(PSJANS)
+ ;
+FS ;
+ I $S(PSJX1?1.N1"-"1.N:0,PSJX1'?1.N:1,'$D(RANGE(PSJX1)):1,1:","_PSJANS[PSJX1) K PSJANS Q
+ I PSJX1'["-" S PSJANS=PSJANS_PSJX1_"," Q
+ S PSJX2=+PSJX1,PSJANS=PSJANS_PSJX2_","
+ F  S PSJX2=$O(RANGE(PSJX2)) K:$S(X="":1,","_PSJANS[PSJX2:1,1:PSJX2>$P(PSJX1,"-",2)) PSJANS Q:'$D(PSJANS)  S PSJANS=PSJANS_PSJX2_"," Q:PSJX2=$P(PSJX1,"-",2)
+ Q
+ ;
+ENMARDH ;Help text for MAR default answer.
+ W !!?2,"Enter the number corresponding to the type of orders to be included on MARs",!,"printed for this ward. Multiple types (except 1) may be selected using ""-""",!,"or "","" as delimiters.",!!,"Choose from: ",!
+ N X F X=1:1:6 W !?13,X," - ",$P($T(@X),";;",2)
+ W !
+ Q
+1 ;;All Medications
+2 ;;Non-IV Medications only
+3 ;;IV Piggybacks
+4 ;;LVPs
+5 ;;TPNs
+6 ;;Chemotherapy Medications (IV)
+ ;
+EFD ;The following EFD Tags are used to Calculate the Expected First Dose for backdoor
+ ;orders.  The call to $$ENQ^PSJORP2 is used to actually perform the calculation.
+ ;The program $$ENQ^PSJORP2 requires the variable INFO to equal the following:
+ ;BHW;PSJ*5*136
+ ; INFO (piece 1) = START DATE/TIME      ;PSGNESD (NEW ORDER)
+ ; INFO (piece 2) = STOP DATE/TIME       ;PSGNEFD (NEW ORDER)
+ ; INFO (piece 3) = SCHEDULE             ;PSGSCH  (NEW ORDER)
+ ; INFO (piece 4) = SCHEDULE TYPE        ;PSGST   (NEW ORDER)
+ ; INFO (piece 5) = ORDERABLE ITEM       ;PSGDRG  (NEW ORDER)
+ ; INFO (piece 6) = ADMIN TIMES          ;PSGS0Y  (NEW ORDER)
+ ; 
+EFDNEW ;Call Here if NEW or RENEWED Order
+ N INFO
+ S INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGDRG))_U_($G(PSGS0Y))
+ D EFDDISP
+ QUIT
+EFDACT ;Call here if Editing Fields for an ACTIVE order
+ ; Field 10 = Start Date
+ ; Field 34 = Stop Date
+ ; Field 41 = Admin Times
+ N INFO,KEY,ORDER,LAST
+ ;Loop Fields to be edited, in order, and determine when to Display expected first dose message
+ F KEY=1:1 S ORDER=$P(PSGOEER,";",KEY) Q:'$L(ORDER)  I "10^34^41"[$P(ORDER,U,1) S ORDER(KEY)=$P(ORDER,U,1)
+ ;If there are no entries in ORDER, then were Not Editing Start/Stop or Admin Times
+ S LAST=$O(ORDER(99),-1) Q:'LAST
+ ;Only display EFD once, so Quit if this call is not for the Last field in the Edit
+ S LAST=ORDER(LAST)
+ I LAST'=PSGF2 Q
+ S INFO=($G(PSGSD))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y))
+ D EFDDISP
+ QUIT
+EFDNV ;Call here if Editing Fields for a NON-VERIFIED order
+ ; Field 10 = Start Date
+ ; Field 25 = Stop Date
+ ; Field 39 = Admin Times
+ N INFO,KEY,ORDER,LAST
+ ;Check if called during finish process
+ I '$D(PSGOEER) D  D EFDDISP Q
+ . S INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y))
+ . Q
+ ;Loop Fields to be edited, in order, and determine when to Display expected first dose message
+ F KEY=1:1 S ORDER=$P(PSGOEER,";",KEY) Q:'$L(ORDER)  I "10^25^39"[$P(ORDER,U,1) S ORDER(KEY)=$P(ORDER,U,1)
+ ;If there are no entries in ORDER, then were Not Editing Start/Stop or Admin Times
+ S LAST=$O(ORDER(99),-1) Q:'LAST
+ ;Only display EFD once, so Quit if this call is not for the Last field in the Edit
+ S LAST=ORDER(LAST)
+ I LAST'=PSGF2 Q
+ S INFO=($G(PSGSD))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y))
+ D EFDDISP
+ QUIT
+EFDIV(PSGZZND) ;Set variables for EFD on IV orders.
+ S PSGNESD=P(2),PSGNEFD=P(3),PSGSCH=P(9),PSGST=$P($G(PSGZZND),"^",5),PSGDRG=$P($G(P("PD")),"^"),PSGS0Y=P(11)
+ ;BHW - PSJ*5*177 Add call to check stop date.  If it's in the past, Display Message
+ D CHKSTOP
+ D EFDNEW
+ W !
+ Q
+EFDDISP ;Display Expected First Dose
+ N Y
+ Q:$G(PSGST)="OC"!($G(PSGST)="P")
+ Q:$G(PSGSCH)["ON CALL"!($G(PSGSCH)["ON-CALL")!($G(PSGSCH)["ONCALL")
+ Q:$G(PSGSCH)["PRN"
+ I '$L($G(PSGP)) N PSGP S PSGP=""
+ ;
+ S Y=$$ENQ^PSJORP2(PSGP,INFO)
+ I 'Y S Y="Unable to Calculate"
+ X ^DD("DD")
+ W !,"Expected First Dose: ",Y H 2
+ Q
+CHKSTOP ;BHW - PSJ*5*177 Warn user if the Stop Date is < now.
+ I '+$G(P(3)) Q
+ N PSNOW,%,%H,%I,X D NOW^%DTC S PSNOW=%
+ I +P(3)<PSNOW D  Q
+ . W !,$C(7),"The Stop Date/Time is in the Past!!!  This order will",!,"automatically EXPIRE upon Verification!!",!
+ . Q
+ Q