PSJLMGUD ;BIR/MLM - INITIALIZE UNIT DOSE ORDER FIELDS FOR DISPLAY ;Nov 10, 2020@14:21:01
;;5.0;INPATIENT MEDICATIONS;**25,58,85,116,110,111,267,275,315,256,373,366,319,399**;16 DEC 97;Build 64
;
;;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^PS(51.2 is supported by DBIA 2178
; Reference to ^PSDRUG( is supported by DBIA 2192
; Reference to ^PS(55 is supported by DBIA 2191
; Reference to ES^ORX8 is supported by DBIA 3632
;
GETUD(DFN,PSGORD) ;
;
EN2 ;
N %X,%Y,ND2,ND2P1,DO,DRGI,FD,FL,FQC,NF,ND,PRI,SD,SIG,ST,STD,X,Y,ESIG ;*315
K GMRAL,P
S NF=$S(PSGORD["U":0,PSGORD["A":0,PSGORD["O":0,1:1) I NF,$D(^PS(53.1,+PSGORD,0)),$P(^(0),"^",19),$D(^PS(55,DFN,5,$P(^(0),"^",19))),(+$P(^(0),"^",19)'=+$P(^(0),"^",25)) S PSGORD=+$P(^PS(53.1,+PSGORD,0),"^",19)_"U",NF=0
S (FL,Y)="",$P(FL,"-",71)="",PSGOEEWF="^PS("_$S(NF:"53.1,",1:"55,"_DFN_",5,")_+PSGORD_","
; The naked reference on the line below refers to the full reference created by indirect reference to F, where F may refer to ^PS(53.1 or the IV or UD multiple ^PS(55
S ND=$G(@(PSGOEEWF_"0)")),ND2=$G(^(2)),ND2P1=$G(^(2.1)),PSGEB=$P($G(^(4)),"^",7),PSGOSI=$G(^(6)),SIG=$G(^(6.5)),DO=$G(^(.2)),PSGOINST=$G(^(.3)),ESIG=$P(DO,U,3),PSG14=$P($G(^(14,0)),"^",3) ;*315
I PSG14 S PSGLRN=$G(@(PSGOEEWF_"14,"_PSG14_",0)"))
S PSGOPD=+DO,PSGODO=$P(DO,U,2),PSGOPDN=$$OINAME^PSJLMUTL(+DO),X=$P(DO,U,4),PSGPRIO=$P("STAT^ASAP^ROUTINE^PREOP^TIME CRITICAL^DONE",U,$F("SARPTD",X)-1),PSJPRI=X
S PSGOPR=$P(ND,"^",2),PSGOMR=$P(ND,"^",3),PSGOSM=$P(ND,"^",5),PSGOHSM=$P(ND,"^",6),(PSGOST,ST)=$P(ND,"^",7),STT=$P(ND,"^",9),PSGOMRN=$S('PSGOMR:"",1:$P($G(^PS(51.2,PSGOMR,0)),"^")) S:PSGOMRN="" PSGOMRN=PSGOMR
S PSGLI=$P(ND,U,16),PSGOSCH=$P(ND2,"^"),(PSGOSD,SD)=$P(ND2,"^",2),(FD,PSGOFD)=$P(ND2,"^",4),(FQC,PSGS0XT)=$P(ND2,"^",6),(PSGOAT,PSGS0Y)=$P(ND2,"^",5)
S:ND2P1]"" PSGDUR=$P(ND2P1,U,1),PSGRMVT=$P(ND2P1,U,2),PSGRMV=$P(ND2P1,U,3),PSGRF=$P(ND2P1,U,4) ;*315
S PSGLIN=$$ENDD^PSGMI(PSGLI)_U_$$ENDTC^PSGMI(PSGLI)
;*366 - check provider credentials
S PRI=$S('PSGOPR:0,1:'$$ACTPRO^PSGOE1(PSGOPR)),DRGI=$S(PSGOPD'=+PSGOPD:0,1:+$G(^PSDRUG(+PSGOPD,"I"))) S:DRGI DRGI=DT'<DRGI
S PSGOPRN=$S('PSGOPR:"",1:$P($G(^VA(200,PSGOPR,0)),"^")) S:PSGOPRN="" PSGOPRN=PSGOPR I PSGOSI]"" S PSGOSI=$$ENSET^PSGSICHK(PSGOSI)
I $L($T(ES^ORX8)) N ESIG1 S ESIG1=$$ES^ORX8(+$P(ND,U,21)_";1") S:ESIG1=1 ESIG="ES"
S PSGOPRN=PSGOPRN_$S(ESIG]"":" ["_$$LOW^XLFSTR(ESIG)_"]",1:"")
S PSGEBN=$$ENNPN^PSGMI(PSGEB) S:$P(ND,U,27)="R" STT="R"
S X=STT,PSGSTAT=$S(X="":"NOT FOUND",X="DE":"DISCONTINUED (EDIT)",X="DR":"DISCONTINUED (RENEWAL)",X="RE":"REINSTATED",1:$P(X_"^ACTIVE^DISCONTINUED^EXPIRED^HOLD^INCOMPLETE^NON-VERIFIED^PENDING^RENEWED^UNRELEASED","^",$F("ADEHINPRU",X)))
S (PSGIND,PSGOIND)=$G(@(PSGOEEWF_"18)")) ;*399-IND
;*p319 clinic order
K PSJCLAPP
N CLNOR S CLNOR=$S(PSGOEEWF[53.1:$G(@(PSGOEEWF_"""DSS"")")),1:$G(@(PSGOEEWF_"8)"))) I +CLNOR D
.S PSJCMO=1,PSJCLAPP=CLNOR,(P("CLIN"),P("CLINO"))=$P(PSJCLAPP,"^")
.S (P("APPT"),P("APPTO"))=$P(PSJCLAPP,"^",2)
;
SET ;
I STT="P" S (FD,SD,ST)=""
S PSGOSTN=$$ENSTN^PSGMI(ST),(PSGOFDN,PSGOSDN)="" I SD S PSGOSDN=$$ENDD^PSGMI(SD)_"^"_$$ENDTC2^PSGMI(SD) ;#373
I FD S PSGOFDN=$$ENDD^PSGMI(FD)_"^"_$$ENDTC2^PSGMI(FD) ;#373
F X="PD","PDN","MR","MRN","ST","STN","SCH","SI","SD","SDN","FD","FDN","SM","HSM","PR","PRN","DO","AT" S @("PSG"_X)=@("PSGO"_X)
K ^PS(53.45,PSJSYSP,1),^(2),^(5),^(6) S %X=PSGOEEWF_"3,",%Y="^PS(53.45,"_PSJSYSP_",1," D %XY^%RCR S %X=PSGOEEWF_"1,",%Y="^PS(53.45,"_PSJSYSP_",2," D %XY^%RCR
S $P(^PS(53.45,PSJSYSP,2,0),"^",2)="53.4502P"
K PSJNSS I $G(PSGSCH)'="" D K PSJNSS
. N PSGS0XTO,Y,PSGOES S X=PSGSCH S PSGS0XTO=PSGS0XT N PSGOSCH S PSGOSCH=PSGSCH S PSGSCH="",PSGOES=1
. D ENOS^PSGS0 S:$G(X)="" PSGS0XT=PSGS0XTO S PSGSCH=PSGOSCH
Q
;
FINISH ;
I '$G(PSGS0XT),PSGOSCH]"" D S $P(^PS(53.1,+PSGORD,2),"^",6)=PSGS0XT
.N PSGOES,PSGS0Y S X=PSGOSCH,PSGOES=1 D ENOS^PSGS0
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:"")_" before it can be finished."
I PSGOEFF 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 PSGOEFF#2 S F1=53.1,MSG=0,Y=$T(35),@("PSGFN(35)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(35),";",3) G:'PSGOEE DONE
I PSGOEFF>9 S CHK=7 D ENDRG^PSGOEF1(PSGOPD,0) G:CHK DONE
I $G(MSG) K DIR S DIR(0)="E" W !! D ^DIR
I PSGOEFF D:PSGST="" GTST^PSGOE6(+PSGORD) N XQORM D EN^VALM("PSJ LM OE DISPLAY") G DONE
;
ACCEPT ;
D UPD^PSGOEF1 G DONE
BYPASS ;
S PSGCANFL=1 G DONE
;
EDIT ;
S PSGPDRG=PSGOPD,PSGPDRGN=PSGOPDN K PSGOEEND D ENF^PSGOEE I PSGCANFL=-1 D UPD^PSGOEF1
;
DONE ;
K CHK,DA,DIE,DR,DRG,MSG,ORETURN,ORIFN,PSGEB,PSGEFN,PSGND,PSGOEE,PSGOEEF,PSGOEEND,PSGOEEG,PSGOEF,PSGOEFF,PSGOES,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGPDRG,PSGDRGN,PSG0XT,PSGS0Y,OSGSD,Q1,Q2
K PSGDUR,PSGRMV,PSGRMVT ;*315
Q
;
;
31 ;;101^PSGOE8;PSGOPD;PSGPD;101;1
32 ;;109^PSGOE8;PSGODO;PSGDO;102;PSGODO]""
33 ;;3^PSGOE8;PSGOMR;PSGMR;3;1
34 ;;7^PSGOE8;PSGOST;PSGST;7;0
35 ;;26^PSGOE8;PSGOSCH;PSGSCH;26;1
36 ;;39^PSGOE81;PSGOAT;PSGAT;39;0
37 ;;1^PSGOE82;PSGOPR;PSGPR;1;1
38 ;;8^PSGOE81;PSGOSI;PSGSI;8;0
39 ;;2^PSGOE82;;;2;0
310 ;;40^PSGOE82;;;40;0
311 ;;66^PSGOE82;;;66;1
312 ;;10^PSGOE81;PSGOSD;PSGSD;10;0
313 ;;25^PSGOE81;PSGOFD;PSGFD;25;0
314 ;;5^PSGOE82;PSGOSM;PSGSM;5;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJLMGUD 5701 printed Dec 13, 2024@02:07:28 Page 2
PSJLMGUD ;BIR/MLM - INITIALIZE UNIT DOSE ORDER FIELDS FOR DISPLAY ;Nov 10, 2020@14:21:01
+1 ;;5.0;INPATIENT MEDICATIONS;**25,58,85,116,110,111,267,275,315,256,373,366,319,399**;16 DEC 97;Build 64
+2 ;
+3 ;;Per VHA Directive 2004-038, this routine should not be modified.
+4 ; Reference to ^PS(51.2 is supported by DBIA 2178
+5 ; Reference to ^PSDRUG( is supported by DBIA 2192
+6 ; Reference to ^PS(55 is supported by DBIA 2191
+7 ; Reference to ES^ORX8 is supported by DBIA 3632
+8 ;
GETUD(DFN,PSGORD) ;
+1 ;
EN2 ;
+1 ;*315
NEW %X,%Y,ND2,ND2P1,DO,DRGI,FD,FL,FQC,NF,ND,PRI,SD,SIG,ST,STD,X,Y,ESIG
+2 KILL GMRAL,P
+3 SET NF=$SELECT(PSGORD["U":0,PSGORD["A":0,PSGORD["O":0,1:1)
IF NF
IF $DATA(^PS(53.1,+PSGORD,0))
IF $PIECE(^(0),"^",19)
IF $DATA(^PS(55,DFN,5,$PIECE(^(0),"^",19)))
IF (+$PIECE(^(0),"^",19)'=+$PIECE(^(0),"^",25))
SET PSGORD=+$PIECE(^PS(53.1,+PSGORD,0),"^",19)_"U"
SET NF=0
+4 SET (FL,Y)=""
SET $PIECE(FL,"-",71)=""
SET PSGOEEWF="^PS("_$SELECT(NF:"53.1,",1:"55,"_DFN_",5,")_+PSGORD_","
+5 ; The naked reference on the line below refers to the full reference created by indirect reference to F, where F may refer to ^PS(53.1 or the IV or UD multiple ^PS(55
+6 ;*315
SET ND=$GET(@(PSGOEEWF_"0)"))
SET ND2=$GET(^(2))
SET ND2P1=$GET(^(2.1))
SET PSGEB=$PIECE($GET(^(4)),"^",7)
SET PSGOSI=$GET(^(6))
SET SIG=$GET(^(6.5))
SET DO=$GET(^(.2))
SET PSGOINST=$GET(^(.3))
SET ESIG=$PIECE(DO,U,3)
SET PSG14=$PIECE($GET(^(14,0)),"^",3)
+7 IF PSG14
SET PSGLRN=$GET(@(PSGOEEWF_"14,"_PSG14_",0)"))
+8 SET PSGOPD=+DO
SET PSGODO=$PIECE(DO,U,2)
SET PSGOPDN=$$OINAME^PSJLMUTL(+DO)
SET X=$PIECE(DO,U,4)
SET PSGPRIO=$PIECE("STAT^ASAP^ROUTINE^PREOP^TIME CRITICAL^DONE",U,$FIND("SARPTD",X)-1)
SET PSJPRI=X
+9 SET PSGOPR=$PIECE(ND,"^",2)
SET PSGOMR=$PIECE(ND,"^",3)
SET PSGOSM=$PIECE(ND,"^",5)
SET PSGOHSM=$PIECE(ND,"^",6)
SET (PSGOST,ST)=$PIECE(ND,"^",7)
SET STT=$PIECE(ND,"^",9)
SET PSGOMRN=$SELECT('PSGOMR:"",1:$PIECE($GET(^PS(51.2,PSGOMR,0)),"^"))
if PSGOMRN=""
SET PSGOMRN=PSGOMR
+10 SET PSGLI=$PIECE(ND,U,16)
SET PSGOSCH=$PIECE(ND2,"^")
SET (PSGOSD,SD)=$PIECE(ND2,"^",2)
SET (FD,PSGOFD)=$PIECE(ND2,"^",4)
SET (FQC,PSGS0XT)=$PIECE(ND2,"^",6)
SET (PSGOAT,PSGS0Y)=$PIECE(ND2,"^",5)
+11 ;*315
if ND2P1]""
SET PSGDUR=$PIECE(ND2P1,U,1)
SET PSGRMVT=$PIECE(ND2P1,U,2)
SET PSGRMV=$PIECE(ND2P1,U,3)
SET PSGRF=$PIECE(ND2P1,U,4)
+12 SET PSGLIN=$$ENDD^PSGMI(PSGLI)_U_$$ENDTC^PSGMI(PSGLI)
+13 ;*366 - check provider credentials
+14 SET PRI=$SELECT('PSGOPR:0,1:'$$ACTPRO^PSGOE1(PSGOPR))
SET DRGI=$SELECT(PSGOPD'=+PSGOPD:0,1:+$GET(^PSDRUG(+PSGOPD,"I")))
if DRGI
SET DRGI=DT'<DRGI
+15 SET PSGOPRN=$SELECT('PSGOPR:"",1:$PIECE($GET(^VA(200,PSGOPR,0)),"^"))
if PSGOPRN=""
SET PSGOPRN=PSGOPR
IF PSGOSI]""
SET PSGOSI=$$ENSET^PSGSICHK(PSGOSI)
+16 IF $LENGTH($TEXT(ES^ORX8))
NEW ESIG1
SET ESIG1=$$ES^ORX8(+$PIECE(ND,U,21)_";1")
if ESIG1=1
SET ESIG="ES"
+17 SET PSGOPRN=PSGOPRN_$SELECT(ESIG]"":" ["_$$LOW^XLFSTR(ESIG)_"]",1:"")
+18 SET PSGEBN=$$ENNPN^PSGMI(PSGEB)
if $PIECE(ND,U,27)="R"
SET STT="R"
+19 SET X=STT
SET PSGSTAT=$SELECT(X="":"NOT FOUND",X="DE":"DISCONTINUED (EDIT)",X="DR":"DISCONTINUED (RENEWAL)",X="RE":"REINSTATED",1:$PIECE(X_"^ACTIVE^DISCONTINUED^EXPIRED^HOLD^INCOMPLETE^NON-VERIFIED^PENDING^RENEWED^UNRELEASED","^",$FIND("ADEHINPRU",X)))
+20 ;*399-IND
SET (PSGIND,PSGOIND)=$GET(@(PSGOEEWF_"18)"))
+21 ;*p319 clinic order
+22 KILL PSJCLAPP
+23 NEW CLNOR
SET CLNOR=$SELECT(PSGOEEWF[53.1:$GET(@(PSGOEEWF_"""DSS"")")),1:$GET(@(PSGOEEWF_"8)")))
IF +CLNOR
Begin DoDot:1
+24 SET PSJCMO=1
SET PSJCLAPP=CLNOR
SET (P("CLIN"),P("CLINO"))=$PIECE(PSJCLAPP,"^")
+25 SET (P("APPT"),P("APPTO"))=$PIECE(PSJCLAPP,"^",2)
End DoDot:1
+26 ;
SET ;
+1 IF STT="P"
SET (FD,SD,ST)=""
+2 ;#373
SET PSGOSTN=$$ENSTN^PSGMI(ST)
SET (PSGOFDN,PSGOSDN)=""
IF SD
SET PSGOSDN=$$ENDD^PSGMI(SD)_"^"_$$ENDTC2^PSGMI(SD)
+3 ;#373
IF FD
SET PSGOFDN=$$ENDD^PSGMI(FD)_"^"_$$ENDTC2^PSGMI(FD)
+4 FOR X="PD","PDN","MR","MRN","ST","STN","SCH","SI","SD","SDN","FD","FDN","SM","HSM","PR","PRN","DO","AT"
SET @("PSG"_X)=@("PSGO"_X)
+5 KILL ^PS(53.45,PSJSYSP,1),^(2),^(5),^(6)
SET %X=PSGOEEWF_"3,"
SET %Y="^PS(53.45,"_PSJSYSP_",1,"
DO %XY^%RCR
SET %X=PSGOEEWF_"1,"
SET %Y="^PS(53.45,"_PSJSYSP_",2,"
DO %XY^%RCR
+6 SET $PIECE(^PS(53.45,PSJSYSP,2,0),"^",2)="53.4502P"
+7 KILL PSJNSS
IF $GET(PSGSCH)'=""
Begin DoDot:1
+8 NEW PSGS0XTO,Y,PSGOES
SET X=PSGSCH
SET PSGS0XTO=PSGS0XT
NEW PSGOSCH
SET PSGOSCH=PSGSCH
SET PSGSCH=""
SET PSGOES=1
+9 DO ENOS^PSGS0
if $GET(X)=""
SET PSGS0XT=PSGS0XTO
SET PSGSCH=PSGOSCH
End DoDot:1
KILL PSJNSS
+10 QUIT
+11 ;
FINISH ;
+1 IF '$GET(PSGS0XT)
IF PSGOSCH]""
Begin DoDot:1
+2 NEW PSGOES,PSGS0Y
SET X=PSGOSCH
SET PSGOES=1
DO ENOS^PSGS0
End DoDot:1
SET $PIECE(^PS(53.1,+PSGORD,2),"^",6)=PSGS0XT
+3 SET PSGOEFF=PSGOSCH=""+('$ORDER(^PS(53.45,PSJSYSP,2,0))*10)
IF PSGOEFF
SET X=$SELECT(PSGOEFF#2:" a SCHEDULE",1:"")_$SELECT(PSGOEFF=11:" and",1:"")_$SELECT(PSGOEFF>9:" at least one DISPENSE DRUG",1:"")_" before it can be finished."
+4 IF PSGOEFF
WRITE $CHAR(7),!!,"PLEASE NOTE: This order must have"
FOR Q=1:1:$LENGTH(X," ")
SET Y=$PIECE(X," ",Q)
if $LENGTH(Y)+$X>78
WRITE !
WRITE Y," "
+5 IF PSGOEFF#2
SET F1=53.1
SET MSG=0
SET Y=$TEXT(35)
SET @("PSGFN(35)="_$PIECE(Y,";",7))
SET PSGOEEF(+$PIECE(Y,";",3))=1
SET (PSGOEE,PSGOEEF)=1
WRITE !
DO @$PIECE($TEXT(35),";",3)
if 'PSGOEE
GOTO DONE
+6 IF PSGOEFF>9
SET CHK=7
DO ENDRG^PSGOEF1(PSGOPD,0)
if CHK
GOTO DONE
+7 IF $GET(MSG)
KILL DIR
SET DIR(0)="E"
WRITE !!
DO ^DIR
+8 IF PSGOEFF
if PSGST=""
DO GTST^PSGOE6(+PSGORD)
NEW XQORM
DO EN^VALM("PSJ LM OE DISPLAY")
GOTO DONE
+9 ;
ACCEPT ;
+1 DO UPD^PSGOEF1
GOTO DONE
BYPASS ;
+1 SET PSGCANFL=1
GOTO DONE
+2 ;
EDIT ;
+1 SET PSGPDRG=PSGOPD
SET PSGPDRGN=PSGOPDN
KILL PSGOEEND
DO ENF^PSGOEE
IF PSGCANFL=-1
DO UPD^PSGOEF1
+2 ;
DONE ;
+1 KILL CHK,DA,DIE,DR,DRG,MSG,ORETURN,ORIFN,PSGEB,PSGEFN,PSGND,PSGOEE,PSGOEEF,PSGOEEND,PSGOEEG,PSGOEF,PSGOEFF,PSGOES,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGPDRG,PSGDRGN,PSG0XT,PSGS0Y,OSGSD,Q1,Q2
+2 ;*315
KILL PSGDUR,PSGRMV,PSGRMVT
+3 QUIT
+4 ;
+5 ;
31 ;;101^PSGOE8;PSGOPD;PSGPD;101;1
32 ;;109^PSGOE8;PSGODO;PSGDO;102;PSGODO]""
33 ;;3^PSGOE8;PSGOMR;PSGMR;3;1
34 ;;7^PSGOE8;PSGOST;PSGST;7;0
35 ;;26^PSGOE8;PSGOSCH;PSGSCH;26;1
36 ;;39^PSGOE81;PSGOAT;PSGAT;39;0
37 ;;1^PSGOE82;PSGOPR;PSGPR;1;1
38 ;;8^PSGOE81;PSGOSI;PSGSI;8;0
39 ;;2^PSGOE82;;;2;0
310 ;;40^PSGOE82;;;40;0
311 ;;66^PSGOE82;;;66;1
312 ;;10^PSGOE81;PSGOSD;PSGSD;10;0
313 ;;25^PSGOE81;PSGOFD;PSGFD;25;0
314 ;;5^PSGOE82;PSGOSM;PSGSM;5;0
+1 ;
AH ;
+1 WRITE !!?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."
+2 QUIT
