PSGOEE0 ;BIR/CML3 - ORDER EDIT UTILITIES ;Oct 27, 2020@15:14:39
;;5.0;INPATIENT MEDICATIONS;**58,95,179,216,315,319,411,399**;16 DEC 97;Build 64
;;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^DICN is supported by DBIA 10009.
; Reference to ^DIR is supported by DBIA 10026.
;
ENSFE(PSGP,PSGORD) ; Determine editable fields, and fields that cause new order.
D @$S(PSGORD["P":"ENSFE3^PSGOEE0",1:"ENSFE5^PSGOEE0")
Q
ENSFE3 ; set-up fields to edit for 53.1 ;*399-IND
N PSJCMOF
S PSJCMOF=$S($G(PSJCMO):1,$G(PSJCM01):1,1:0)
I PSGSTAT="PENDING" S PSGEFN=$S(PSJCMOF:"1:16",1:"1:14") F X=1:1:$S(PSJCMOF:16,1:14) S PSGEFN(+X)=$P($T(@(3_X)),";",7),PSGOEEF(+$P($T(@(3_X)),";",3))="",PSGOEEF=PSGOEEF+1
E S PSGEFN=$S(PSJCMOF:"1:16",1:"1:14") F X=1:1:$S(PSJCMOF:16,1:14) S:X'=13 Y=$T(@(3_X)),@("PSGEFN("_+X_")="_$S($D(PSGOETOF):0,1:$P(Y,";",7))),PSGOEEF(+$P(Y,";",3))="",PSGOEEF=PSGOEEF+1
E S:$P(PSJSYSU,";",3)>1 PSGEFN(9)=0,PSGOEEF(+$P($T(39),";",3))="",PSGOEEF=PSGOEEF+1
E I PSGEB'=PSGOPR F X=10,13 S Y=$T(@(3_X)),@("PSGEFN("_X_")="_$S($D(PSGOETOF):0,1:$P(Y,";",7))),PSGOEEF(+$P(Y,";",3))="",PSGOEEF=PSGOEEF+1
;*216 highlight if DOSECHK fails
N PSJDOSE D DOSECHK^PSJDOSE I +$G(PSJDSFLG),'$G(PSGOEEF(109)) S PSGOEEF(109)=1
K PSGOEEND S PSGOEEG=3,PSGPDRG=PSGOPD,PSGPDRGN=PSGOPDN Q
;
ENSFE5 ; set-up fields to edit for 55
N PSJCMOF
S PSJCMOF=$S($G(PSJCMO):1,$G(PSJCM01):1,1:0)
S PSGEFN=$S($G(PSJCMO):"1:16",1:"1:14")
F X=1:1:$S(PSJCMOF:16,1:14) S Y=$T(@(5_X)),@("PSGEFN("_+X_")="_$S($D(PSGOETO):0,1:$P(Y,";",7))),PSGOEEF(+$P(Y,";",3))="",PSGOEEF=PSGOEEF+1
I $P(PSJSYSU,";",3)>1 S PSGEFN(9)=0,PSGOEEF(+$P($T(59),";",3))="",PSGOEEF=PSGOEEF+1
S PSGPDRG=PSGPD,PSGPDRGN=PSGPDN,PSGOEEND=1,PSGOEEG=5
;*216 highlight if DOSECHK fails
N PSJDOSE D DOSECHK^PSJDOSE I +$G(PSJDSFLG),'$G(PSGOEEF(109)) S PSGOEEF(109)=1
Q
;
ENOK ;
I $P($G(PSJSYSP0),U,2),'$O(^PS(53.45,+PSJSYSP,2,0)) D
.W !!,"No dispense drugs found for this order." D ENDRG^PSGOEF1(PSGPD,0) I '$O(^PS(53.45,+PSJSYSP,2,0)) S PSGOEENO=0,DR=""
W ! I DR="",'PSGOEENO D ABORT^PSGOEE S %=1 Q
W:PSGOEENO !,"(Accepting these changes will cause a new order to be created.)"
F W !!,"ACCEPT THESE CHANGES" S %=1 D YN^DICN Q:% D ;
.W !!?2,"Answer 'YES' (or press RETURN) if you have completed editing this order." W:PSGOEENO !,"Accepting this changes will cause a new order to be created, and this order",!,"will be discontinued."
.W:$D(PSGOEF) !,"Accepting these changes will convert this order to a non-verifed, Unit Dose",!,"order."
.W !!,"Answer 'NO' to re-edit this order. Enter an '^' to abort this edit."
S PSJNOO=$$ENNOO^PSJUTL5("E")
K F,F0,F1,F3,PSGDL,PSGDLS,PSGF2,PSGFOK,ND2,PSGOROE1,PSGRO,SDT
S:PSJNOO<0 (PSGOROE1,PSGOEENO)=0
Q
;
ENNOU ; create new order or update old order
I $G(MSG) K DIR S DIR(0)="E" W !! D ^DIR
K DR S DR="",(PSGOEENO,Q)=0
F S Q=$O(PSGEFN(Q)) Q:'Q S Y=$T(@(PSGOEEG_Q)) I $P(Y,";",4)]"",@$P(Y,";",4)'=@$P(Y,";",5) S:PSGEFN(Q) PSGOEENO=1 Q:PSGOEENO S DR=DR_$P(Y,";",6)_$S(@$P(Y,";",5)]"":"////^S X="_$P(Y,";",5),1:"////@")_";W ""."";"
I PSGSI="",PSGOSI]"" S DR=DR_"122////@;W ""."";"
I '$P(PSGSI,"^",2),$P(PSGOSI,"^",2)=1 S DR=DR_"122////@;W ""."";"
; PSJ*5*95 quick fix to prevent long string error; true fix in PSJ*5*91 (upd^psgoee)
I PSGSI]"" S DR=DR_122_"////^S X="_+$P(PSGSI,"^",2)_";" I '$G(PSJLMFIN),'$G(PSGOEENO),$L($G(PSGOSI),"^")>20 S PSGSI=$P(PSGSI,"^")
I PSGSM,PSGOHSM'=PSGHSM S DR=DR_"6////"_PSGHSM_";W ""."";"
I +$G(PSGRF)]"" D
. S DR=DR_"137////"_$G(PSGDUR)_";138////"_$G(PSGRMVT)_";139////"_$G(PSGRMV)_";140////"_$G(PSGRF) ;*315
. I $G(PSGAT) N FLD S FLD=$S(PSGORD["P":39,1:41),DR=DR_";"_FLD_"////"_$G(PSGAT) ;If DOA was edited then update the admin time.
.Q
;PSJ*5.0*179
N P I 'PSGOEENO F P="1^3^10" I $D(PSGEFN($P(P,U,3))) S (Q,QQ)=0 F S Q=$O(@("^PS(53.45,"_PSJSYSP_","_+P_","_Q_")")) Q:'Q S QQ=Q,X=$G(^(Q,0)),Y=$G(@(PSGOEEWF_$P(P,U,2)_","_Q_",0)")) I X'=Y S:+P=1 DR=DR_"*" Q
I 'PSGOEENO F P="1^3^10" I $D(PSGEFN($P(P,U,3))) S (Q,QQ)=0 F S Q=$O(@(PSGOEEWF_$P(P,U,2)_","_Q_")")) Q:'Q S QQ=Q,X=$G(^(Q,0)),Y=$G(^PS(53.45,PSJSYSP,+P,Q,0)) I X'=Y S:+P=1 DR=DR_"*" Q
Q:$S(DR]"":1,1:PSGOEENO) S (Q,QQ)=0 F S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q S QQ=Q,X=$G(^(Q,0)),Y=$G(@(PSGOEEWF_"1,"_Q_",0)")) I X'=Y S DR=DR_"*" Q
Q:$S(DR]"":1,1:PSGOEENO) S (Q,QQ)=0 F S Q=$O(@(PSGOEEWF_"1,"_Q_")")) Q:'Q S QQ=Q,X=$G(^(Q,0)),Y=$G(^PS(53.45,PSJSYSP,2,Q,0)) I X'=Y S DR=DR_"*" Q
Q
;
ENF ; finish order from edit
F S %=1 W !!,"Finish this order now" D YN^DICN Q:% D ;
.W !!,"Answer 'YES' to finish this order now. Finishing the order converts it to a",!,"non-verified Unit Dose order. Enter 'NO' (or an '^') if you do not want to",!,"finish this order now."
I %=1 S PSGOEFF=0 D UPD^PSGOEF1 K PSGOEFF,PSGND,PSGSD
Q
;*399-IND-314,514
FIELDS ;;linetag^routine for fied edit;variable used for before value;variable used for after value;associated field number in File; 1 - edit will create a new entry (field is starred) or 0 - edit will not create a new entry
31 ;;108^PSGOE8;PSGOPD;PSGPD;108;1
32 ;;109^PSGOE8;PSGODO;PSGDO;109;1
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
314 ;;132^PSGOE41;PSGOIND;PSGIND;132;0
315 ;;50^PSGOE82;P("CLINO");P("CLIN");113;0
316 ;;51^PSGOE82;P("APPTO");P("APPT");126;0
51 ;;108^PSGOE9;PSGOPD;PSGPD;108;1
52 ;;109^PSGOE9;PSGODO;PSGDO;109;1
53 ;;10^PSGOE91;PSGOSD;PSGSD;10;1
54 ;;3^PSGOE9;PSGOMR;PSGMR;3;1
55 ;;34^PSGOE91;PSGOFD;PSGFD;34;1
56 ;;7^PSGOE9;PSGOST;PSGST;7;0
57 ;;5^PSGOE82;PSGOSM;PSGSM;5;0
58 ;;26^PSGOE9;PSGOSCH;PSGSCH;26;1
59 ;;41^PSGOE91;PSGOAT;PSGAT;41;0
510 ;;1^PSGOE92;PSGOPR;PSGPR;1;1
511 ;;8^PSGOE92;PSGOSI;PSGSI;8;0
512 ;;2^PSGOE92;;;2;0
513 ;;15^PSGOE92;;;15;0
514 ;;141^PSGOE41;PSGOIND;PSGIND;141;0
515 ;;50^PSGOE82;P("CLINO");P("CLIN");130;0
516 ;;51^PSGOE82;P("APPTO");P("APPT");131;0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOEE0 6210 printed Apr 09, 2024@21:10:43 Page 2
PSGOEE0 ;BIR/CML3 - ORDER EDIT UTILITIES ;Oct 27, 2020@15:14:39
+1 ;;5.0;INPATIENT MEDICATIONS;**58,95,179,216,315,319,411,399**;16 DEC 97;Build 64
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^DICN is supported by DBIA 10009.
+4 ; Reference to ^DIR is supported by DBIA 10026.
+5 ;
ENSFE(PSGP,PSGORD) ; Determine editable fields, and fields that cause new order.
+1 DO @$SELECT(PSGORD["P":"ENSFE3^PSGOEE0",1:"ENSFE5^PSGOEE0")
+2 QUIT
ENSFE3 ; set-up fields to edit for 53.1 ;*399-IND
+1 NEW PSJCMOF
+2 SET PSJCMOF=$SELECT($GET(PSJCMO):1,$GET(PSJCM01):1,1:0)
+3 IF PSGSTAT="PENDING"
SET PSGEFN=$SELECT(PSJCMOF:"1:16",1:"1:14")
FOR X=1:1:$SELECT(PSJCMOF:16,1:14)
SET PSGEFN(+X)=$PIECE($TEXT(@(3_X)),";",7)
SET PSGOEEF(+$PIECE($TEXT(@(3_X)),";",3))=""
SET PSGOEEF=PSGOEEF+1
+4 IF '$TEST
SET PSGEFN=$SELECT(PSJCMOF:"1:16",1:"1:14")
FOR X=1:1:$SELECT(PSJCMOF:16,1:14)
if X'=13
SET Y=$TEXT(@(3_X))
SET @("PSGEFN("_+X_")="_$SELECT($DATA(PSGOETOF):0,1:$PIECE(Y,";",7)))
SET PSGOEEF(+$PIECE(Y,";",3))=""
SET PSGOEEF=PSGOEEF+1
+5 IF '$TEST
if $PIECE(PSJSYSU,";",3)>1
SET PSGEFN(9)=0
SET PSGOEEF(+$PIECE($TEXT(39),";",3))=""
SET PSGOEEF=PSGOEEF+1
+6 IF '$TEST
IF PSGEB'=PSGOPR
FOR X=10,13
SET Y=$TEXT(@(3_X))
SET @("PSGEFN("_X_")="_$SELECT($DATA(PSGOETOF):0,1:$PIECE(Y,";",7)))
SET PSGOEEF(+$PIECE(Y,";",3))=""
SET PSGOEEF=PSGOEEF+1
+7 ;*216 highlight if DOSECHK fails
+8 NEW PSJDOSE
DO DOSECHK^PSJDOSE
IF +$GET(PSJDSFLG)
IF '$GET(PSGOEEF(109))
SET PSGOEEF(109)=1
+9 KILL PSGOEEND
SET PSGOEEG=3
SET PSGPDRG=PSGOPD
SET PSGPDRGN=PSGOPDN
QUIT
+10 ;
ENSFE5 ; set-up fields to edit for 55
+1 NEW PSJCMOF
+2 SET PSJCMOF=$SELECT($GET(PSJCMO):1,$GET(PSJCM01):1,1:0)
+3 SET PSGEFN=$SELECT($GET(PSJCMO):"1:16",1:"1:14")
+4 FOR X=1:1:$SELECT(PSJCMOF:16,1:14)
SET Y=$TEXT(@(5_X))
SET @("PSGEFN("_+X_")="_$SELECT($DATA(PSGOETO):0,1:$PIECE(Y,";",7)))
SET PSGOEEF(+$PIECE(Y,";",3))=""
SET PSGOEEF=PSGOEEF+1
+5 IF $PIECE(PSJSYSU,";",3)>1
SET PSGEFN(9)=0
SET PSGOEEF(+$PIECE($TEXT(59),";",3))=""
SET PSGOEEF=PSGOEEF+1
+6 SET PSGPDRG=PSGPD
SET PSGPDRGN=PSGPDN
SET PSGOEEND=1
SET PSGOEEG=5
+7 ;*216 highlight if DOSECHK fails
+8 NEW PSJDOSE
DO DOSECHK^PSJDOSE
IF +$GET(PSJDSFLG)
IF '$GET(PSGOEEF(109))
SET PSGOEEF(109)=1
+9 QUIT
+10 ;
ENOK ;
+1 IF $PIECE($GET(PSJSYSP0),U,2)
IF '$ORDER(^PS(53.45,+PSJSYSP,2,0))
Begin DoDot:1
+2 WRITE !!,"No dispense drugs found for this order."
DO ENDRG^PSGOEF1(PSGPD,0)
IF '$ORDER(^PS(53.45,+PSJSYSP,2,0))
SET PSGOEENO=0
SET DR=""
End DoDot:1
+3 WRITE !
IF DR=""
IF 'PSGOEENO
DO ABORT^PSGOEE
SET %=1
QUIT
+4 if PSGOEENO
WRITE !,"(Accepting these changes will cause a new order to be created.)"
+5 ;
FOR
WRITE !!,"ACCEPT THESE CHANGES"
SET %=1
DO YN^DICN
if %
QUIT
Begin DoDot:1
+6 WRITE !!?2,"Answer 'YES' (or press RETURN) if you have completed editing this order."
if PSGOEENO
WRITE !,"Accepting this changes will cause a new order to be created, and this order",!,"will be discontinued."
+7 if $DATA(PSGOEF)
WRITE !,"Accepting these changes will convert this order to a non-verifed, Unit Dose",!,"order."
+8 WRITE !!,"Answer 'NO' to re-edit this order. Enter an '^' to abort this edit."
End DoDot:1
+9 SET PSJNOO=$$ENNOO^PSJUTL5("E")
+10 KILL F,F0,F1,F3,PSGDL,PSGDLS,PSGF2,PSGFOK,ND2,PSGOROE1,PSGRO,SDT
+11 if PSJNOO<0
SET (PSGOROE1,PSGOEENO)=0
+12 QUIT
+13 ;
ENNOU ; create new order or update old order
+1 IF $GET(MSG)
KILL DIR
SET DIR(0)="E"
WRITE !!
DO ^DIR
+2 KILL DR
SET DR=""
SET (PSGOEENO,Q)=0
+3 FOR
SET Q=$ORDER(PSGEFN(Q))
if 'Q
QUIT
SET Y=$TEXT(@(PSGOEEG_Q))
IF $PIECE(Y,";",4)]""
IF @$PIECE(Y,";",4)'=@$PIECE(Y,";",5)
if PSGEFN(Q)
SET PSGOEENO=1
if PSGOEENO
QUIT
SET DR=DR_$PIECE(Y,";",6)_$SELECT(@$PIECE(Y,";",5)]"":"////^S X="_$PIECE(Y,";",5),1:"////@")_";W ""."";"
+4 IF PSGSI=""
IF PSGOSI]""
SET DR=DR_"122////@;W ""."";"
+5 IF '$PIECE(PSGSI,"^",2)
IF $PIECE(PSGOSI,"^",2)=1
SET DR=DR_"122////@;W ""."";"
+6 ; PSJ*5*95 quick fix to prevent long string error; true fix in PSJ*5*91 (upd^psgoee)
+7 IF PSGSI]""
SET DR=DR_122_"////^S X="_+$PIECE(PSGSI,"^",2)_";"
IF '$GET(PSJLMFIN)
IF '$GET(PSGOEENO)
IF $LENGTH($GET(PSGOSI),"^")>20
SET PSGSI=$PIECE(PSGSI,"^")
+8 IF PSGSM
IF PSGOHSM'=PSGHSM
SET DR=DR_"6////"_PSGHSM_";W ""."";"
+9 IF +$GET(PSGRF)]""
Begin DoDot:1
+10 ;*315
SET DR=DR_"137////"_$GET(PSGDUR)_";138////"_$GET(PSGRMVT)_";139////"_$GET(PSGRMV)_";140////"_$GET(PSGRF)
+11 ;If DOA was edited then update the admin time.
IF $GET(PSGAT)
NEW FLD
SET FLD=$SELECT(PSGORD["P":39,1:41)
SET DR=DR_";"_FLD_"////"_$GET(PSGAT)
+12 QUIT
End DoDot:1
+13 ;PSJ*5.0*179
+14 NEW P
IF 'PSGOEENO
FOR P="1^3^10"
IF $DATA(PSGEFN($PIECE(P,U,3)))
SET (Q,QQ)=0
FOR
SET Q=$ORDER(@("^PS(53.45,"_PSJSYSP_","_+P_","_Q_")"))
if 'Q
QUIT
SET QQ=Q
SET X=$GET(^(Q,0))
SET Y=$GET(@(PSGOEEWF_$PIECE(P,U,2)_","_Q_",0)"))
IF X'=Y
if +P=1
SET DR=DR_"*"
QUIT
+15 IF 'PSGOEENO
FOR P="1^3^10"
IF $DATA(PSGEFN($PIECE(P,U,3)))
SET (Q,QQ)=0
FOR
SET Q=$ORDER(@(PSGOEEWF_$PIECE(P,U,2)_","_Q_")"))
if 'Q
QUIT
SET QQ=Q
SET X=$GET(^(Q,0))
SET Y=$GET(^PS(53.45,PSJSYSP,+P,Q,0))
IF X'=Y
if +P=1
SET DR=DR_"*"
QUIT
+16 if $SELECT(DR]""
QUIT
SET (Q,QQ)=0
FOR
SET Q=$ORDER(^PS(53.45,PSJSYSP,2,Q))
if 'Q
QUIT
SET QQ=Q
SET X=$GET(^(Q,0))
SET Y=$GET(@(PSGOEEWF_"1,"_Q_",0)"))
IF X'=Y
SET DR=DR_"*"
QUIT
+17 if $SELECT(DR]""
QUIT
SET (Q,QQ)=0
FOR
SET Q=$ORDER(@(PSGOEEWF_"1,"_Q_")"))
if 'Q
QUIT
SET QQ=Q
SET X=$GET(^(Q,0))
SET Y=$GET(^PS(53.45,PSJSYSP,2,Q,0))
IF X'=Y
SET DR=DR_"*"
QUIT
+18 QUIT
+19 ;
ENF ; finish order from edit
+1 ;
FOR
SET %=1
WRITE !!,"Finish this order now"
DO YN^DICN
if %
QUIT
Begin DoDot:1
+2 WRITE !!,"Answer 'YES' to finish this order now. Finishing the order converts it to a",!,"non-verified Unit Dose order. Enter 'NO' (or an '^') if you do not want to",!,"finish this order now."
End DoDot:1
+3 IF %=1
SET PSGOEFF=0
DO UPD^PSGOEF1
KILL PSGOEFF,PSGND,PSGSD
+4 QUIT
+5 ;*399-IND-314,514
FIELDS ;;linetag^routine for fied edit;variable used for before value;variable used for after value;associated field number in File; 1 - edit will create a new entry (field is starred) or 0 - edit will not create a new entry
31 ;;108^PSGOE8;PSGOPD;PSGPD;108;1
32 ;;109^PSGOE8;PSGODO;PSGDO;109;1
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
314 ;;132^PSGOE41;PSGOIND;PSGIND;132;0
315 ;;50^PSGOE82;P("CLINO");P("CLIN");113;0
316 ;;51^PSGOE82;P("APPTO");P("APPT");126;0
51 ;;108^PSGOE9;PSGOPD;PSGPD;108;1
52 ;;109^PSGOE9;PSGODO;PSGDO;109;1
53 ;;10^PSGOE91;PSGOSD;PSGSD;10;1
54 ;;3^PSGOE9;PSGOMR;PSGMR;3;1
55 ;;34^PSGOE91;PSGOFD;PSGFD;34;1
56 ;;7^PSGOE9;PSGOST;PSGST;7;0
57 ;;5^PSGOE82;PSGOSM;PSGSM;5;0
58 ;;26^PSGOE9;PSGOSCH;PSGSCH;26;1
59 ;;41^PSGOE91;PSGOAT;PSGAT;41;0
510 ;;1^PSGOE92;PSGOPR;PSGPR;1;1
511 ;;8^PSGOE92;PSGOSI;PSGSI;8;0
512 ;;2^PSGOE92;;;2;0
513 ;;15^PSGOE92;;;15;0
514 ;;141^PSGOE41;PSGOIND;PSGIND;141;0
515 ;;50^PSGOE82;P("CLINO");P("CLIN");130;0
516 ;;51^PSGOE82;P("APPTO");P("APPT");131;0
