Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOE1.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOE1.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOE1.m (revision 623) @@ -1,97 +1,102 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOE6.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOE6.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOE6.m (revision 623) @@ -1,89 +1,83 @@ -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 " " - 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 " " + 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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m (revision 623) @@ -1,150 +1,110 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOECS.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOECS.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOECS.m (revision 623) @@ -1,139 +1,127 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEF.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEF.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEF.m (revision 623) @@ -1,149 +1,141 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOT.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOT.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOT.m (revision 623) @@ -1,37 +1,39 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m (revision 623) @@ -1,90 +1,87 @@ -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)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)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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m (revision 623) @@ -1,161 +1,118 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m (revision 623) @@ -1,3 +1,3 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m (revision 623) @@ -1,3 +1,3 @@ -PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 11/08/09 +PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 01/17/08 ; S DIKZK=2 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m (revision 623) @@ -1,3 +1,3 @@ -PSGXR310 ; COMPILED XREF FOR FILE #53.1114 ; 11/08/09 +PSGXR310 ; COMPILED XREF FOR FILE #53.1114 ; 01/17/08 ; S DA=0 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m (revision 623) @@ -1,3 +1,3 @@ -PSGXR311 ; COMPILED XREF FOR FILE #53.157 ; 11/08/09 +PSGXR311 ; COMPILED XREF FOR FILE #53.157 ; 01/17/08 ; S DA=0 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m (revision 623) @@ -1,3 +1,3 @@ -PSGXR312 ; COMPILED XREF FOR FILE #53.158 ; 11/08/09 +PSGXR312 ; COMPILED XREF FOR FILE #53.158 ; 01/17/08 ; S DA=0 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m (revision 623) @@ -1,3 +1,3 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m (revision 623) @@ -1,3 +1,3 @@ -PSGXR33 ; COMPILED XREF FOR FILE #53.1112 ; 11/08/09 +PSGXR33 ; COMPILED XREF FOR FILE #53.1112 ; 01/17/08 ; S DA=0 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m (revision 623) @@ -1,3 +1,3 @@ -PSGXR34 ; COMPILED XREF FOR FILE #53.1114 ; 11/08/09 +PSGXR34 ; COMPILED XREF FOR FILE #53.1114 ; 01/17/08 ; S DA=0 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m (revision 623) @@ -1,3 +1,3 @@ -PSGXR35 ; COMPILED XREF FOR FILE #53.157 ; 11/08/09 +PSGXR35 ; COMPILED XREF FOR FILE #53.157 ; 01/17/08 ; S DA=0 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m (revision 623) @@ -1,3 +1,3 @@ -PSGXR36 ; COMPILED XREF FOR FILE #53.158 ; 11/08/09 +PSGXR36 ; COMPILED XREF FOR FILE #53.158 ; 01/17/08 ; S DA=0 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m (revision 623) @@ -1,3 +1,3 @@ -PSGXR37 ; COMPILED XREF FOR FILE #53.1 ; 11/08/09 +PSGXR37 ; COMPILED XREF FOR FILE #53.1 ; 01/17/08 ; S DIKZK=1 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m (revision 623) @@ -1,3 +1,3 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m (revision 623) @@ -1,3 +1,3 @@ -PSGXR39 ; COMPILED XREF FOR FILE #53.1112 ; 11/08/09 +PSGXR39 ; COMPILED XREF FOR FILE #53.1112 ; 01/17/08 ; S DA=0 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVCAL.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVCAL.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVCAL.m (revision 623) @@ -1,148 +1,131 @@ -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 XX2 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:+X1X) - S X1=X-X1,X2=$S(NAT:0,1:X2-X),START=$S(X1240!($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&(MINSWALL 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)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:PSIVADMP(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 NEWDAYSX2 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:+X1X) + S X1=X-X1,X2=$S(NAT:0,1:X2-X),START=$S(X1240!($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,MINSWALL 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:PSIVADMP(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$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,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)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,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)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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORA.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORA.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORA.m (revision 623) @@ -1,101 +1,103 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC.m (revision 623) @@ -1,104 +1,97 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC1.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC1.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC1.m (revision 623) @@ -1,117 +1,107 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVOREN.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVOREN.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVOREN.m (revision 623) @@ -1,88 +1,91 @@ -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)$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)$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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFA.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFA.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFA.m (revision 623) @@ -1,80 +1,80 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFB.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFB.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFB.m (revision 623) @@ -1,138 +1,121 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVSP.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVSP.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVSP.m (revision 623) @@ -1,109 +1,104 @@ -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)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)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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVUTL1.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVUTL1.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVUTL1.m (revision 623) @@ -1,127 +1,98 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL2.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL2.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL2.m (revision 623) @@ -1,117 +1,112 @@ -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?) Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL3.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL3.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL3.m (revision 623) @@ -1,147 +1,160 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4.m (revision 623) @@ -1,189 +1,209 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4A.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4A.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4A.m (revision 623) @@ -1,160 +1,121 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL5.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL5.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL5.m (revision 623) @@ -1,89 +1,87 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL9.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL9.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL9.m (revision 623) @@ -1,146 +1,133 @@ -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) Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHLU.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHLU.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHLU.m (revision 623) @@ -1,118 +1,74 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIACT.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIACT.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIACT.m (revision 623) @@ -1,151 +1,154 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVFD.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVFD.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVFD.m (revision 623) @@ -1,145 +1,146 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVMD.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVMD.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVMD.m (revision 623) @@ -1,216 +1,207 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m (revision 623) @@ -1,60 +1,55 @@ -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)'",+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)'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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m (revision 623) @@ -1,150 +1,169 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m (revision 623) @@ -1,41 +1,142 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m (revision 623) @@ -1,56 +1,55 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOERI.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOERI.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOERI.m (revision 623) @@ -1,45 +1,41 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOREN.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOREN.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOREN.m (revision 623) @@ -1,52 +1,47 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORPOE.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORPOE.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORPOE.m (revision 623) @@ -1,118 +1,114 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE.m (revision 623) @@ -1,90 +1,92 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE1.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE1.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE1.m (revision 623) @@ -1,117 +1,125 @@ -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") Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORREN.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORREN.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORREN.m (revision 623) @@ -1,86 +1,86 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORUT2.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORUT2.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORUT2.m (revision 623) @@ -1,144 +1,143 @@ -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 Index: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJUTL.m =================================================================== --- WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJUTL.m (revision 613) +++ WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJUTL.m (revision 623) @@ -1,212 +1,211 @@ -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"))'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)'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)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"))'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)'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)