- PSGOEE ;BIR/CML3-EDIT ACTIVE OR NON-VERIFIED ORDERS ;29-May-2012 14:30;PLS
- ;;5.0; INPATIENT MEDICATIONS ;**4,7,29,47,64,58,82,91,1004,110,111,112,142,1015**;16 DEC 97;Build 62
- ;
- ; Reference to ^PS(55 is supported by DBIA# 2191.
- ; Reference to ^PSSLOCK is supported by DBIA# 2789.
- ;
- ; Modified - IHS/CIA/PLS - 10/14/05 - Line UPD+10
- ;
- D NOW^%DTC S PSGDT=% K PSGEFN,PSGOEEF S PSGOEEF=0 I PSGORD["A"!(PSGORD["O") G ACT
- 531 ; edit orders in 53.1
- ENF ;
- D EN2^PSGOEEW
- K PSJACEPT D EDLOOP G:'$G(PSJACEPT) OUT
- I $G(PSGOEENO) D
- . N PSGOEENO S PSGOEENO=1 D NEW
- E D
- . N PSGOEENO S PSGOEENO=0 D UPD
- I $G(PSGOEAV) D ACT1 Q
- D DONE1
- S PSGOEEF=0,PSJORD=PSGORD D GETUD^PSJLMGUD(PSGP,PSGORD),ENSFE^PSGOEE0(PSGP,PSGORD)
- Q
- ACT ;
- D EN2^PSGOEEW,EDLOOP G:'$G(PSJACEPT) OUT
- I $G(PSGOEENO) D
- . N PSGOEENO S PSGOEENO=1 D NEW
- E D
- . N PSGOEENO S PSGOEENO=0 D UPD
- S:$D(PSGOEF)!$G(PSGOEENO) PSGCANFL=-1
- ACT1 ;I 'PSGOEAV,PSJSYSL>1 S $P(@($S(PSGORD["U":"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSGORD_",7)"),"^",1,2)=PSGDT_"^"_$E("D",PSGOEENO)_"E",PSGTOL=2,PSGUOW=DUZ,PSGTOO=PSGORD'["U"+1,DA=+PSGORD D ENL^PSGVDS
- D DONE1
- S PSGOEEF=0 D GETUD^PSJLMGUD(PSGP,PSGORD),ENSFE^PSGOEE0(PSGP,PSGORD) D:PSGOEAV UNL^PSSLOCK(PSGP,PSGORD)
- Q
- EDIT ;
- D FULL^VALM1
- W ! S PSGOEER="" F Q=1:1 S Q1=$P(Y,",",Q) Q:'Q1 S X=$P($T(@(PSGOEEG_Q1)),";",3),PSGOEER=PSGOEER_X_";",PSGOEEF(+X)=Q
- S LIMIT=$L(PSGOEER,";")-1,(PSGDEF,PSGOEE)=0 F S PSGOEE=PSGOEE+1 Q:PSGOEE>LIMIT I +$P(PSGOEER,";",PSGOEE)=101 S PSGDEF=1
- S PSGOEER=$E(PSGOEER,1,$L(PSGOEER)-1),(MSG,PSGOEE)=0 F S PSGOEE=PSGOEE+1 Q:PSGOEE>$L(PSGOEER,";") S F1=$S(PSGOEEG=3:53.1,1:55.06) I 'PSGDEF!((PSGDEF)&(+$P(PSGOEER,";",PSGOEE)'=2)) D @$P(PSGOEER,";",PSGOEE) Q:'PSGOEE
- Q
- EDLOOP ; Continue prompting for fields to edit.
- D:$G(Y) EDIT
- D ENNOU^PSGOEE0 I '$G(PSGOEENO),DR="" S VALMBCK="R" Q
- K VALMSG
- I '$G(PSGOEENO),$G(PSGPDNX) D CKDT
- I $G(PSGOEENO) D
- .S VALMSG="This change will cause a new order to be created." D GTSTATUS,CHKDD,CKDT
- .S PSGEBN=$$ENNPN^PSGMI(DUZ),PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PSGDT)
- D CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGSD_"^^"_PSGFD)
- K VALMBCK,PSJACEPT,PSGPDNX D EN^VALM("PSJU LM ACCEPT") Q:'$G(PSJACEPT)
- I $G(PSGS0XT)="D",'$G(PSGS0Y) I ((",P,R,")'[(","_$G(PSGST)_",")) D Q
- .S PSJACEPT=0 W !!,"This is a 'DAY OF THE WEEK' schedule and MUST have admin times." D PAUSE^VALM1
- I $G(PSGOEENO) S PSJNOO=$$ENNOO^PSJUTL5("E")
- D K1 S PSJACEPT=$S($G(PSJNOO)<0:0,1:1)
- S VALMBCK=$S('PSJACEPT:"R",'PSGOEAV:"R",1:"Q")
- Q
- CHKDD ;*** Check inactive Dispense drug within the order.
- D CHKDRG^PSGOE2
- Q
- CKDT ; Check if new start/stop dates should be calculated.
- S PSGS0Y=$S($D(PSGS0Y):PSGS0Y,1:$G(PSGAT))
- I ('$G(PSGNEWDT)&(PSGSD=$G(PSGOSD))&(PSGFD=$G(PSGOFD)))!($G(PSGOST)'=PSGST)!(PSGSCH'=$G(PSGOSCH))!($G(PSGPDNX)) D
- .N PSGOES S PSGOES=1,PSGOFD=PSGFD D ^PSGNE3 S PSGSD=PSGNESD,PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC^PSGMI(PSGNESD),PSGFD=PSGNEFD,PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^PSGMI(PSGNEFD),PSGNEWDT=1
- .I $D(PSGOFD),PSGOFD]"",PSGFD'=PSGOFD S PSGOEEF(25)=1
- .I $D(PSGOSD),PSGOSD]"",PSGSD'=PSGOSD S PSGOEEF(10)=1
- Q
- NEW3 ;
- ;S:PSGOEAV PSGOEAV="0^1"
- NEW ;
- W !,"...discontinuing original order..."
- I PSGORD["P" S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8) I PSJCOM D NEW^PSJCOM1 Q
- ;DC and Unlock order.
- S PSGEDIT="DE" D ENOR^PSGOECS,UNL^PSSLOCK(PSGP,PSGORD) K PSGEDIT
- W !!," ...creating new order..." W:'PSGOEAV "(you will now work on this new order)"
- S PSGS0Y=PSGAT,PSGNESD=PSGSD,PSGNEFD=PSGFD,PSGOEPR=PSGPR,PSGPDRG=PSGPD,PSGPDRGN=PSGPDN,PSGOEE="E"
- S PSGOORD=PSGORD D ^PSGOETO K PSGOEOS
- I PSGOORD["U" S $P(^PS(55,PSGP,5,+PSGOORD,0),"^",26,27)=PSGORD_"^E"
- E S $P(^PS(53.1,+PSGOORD,0),"^",26,27)=PSGORD_"^E"
- I 'PSGOEAV,($G(PSGORD)["P"),'$G(^PS(53.1,+PSGORD,2.5)),$G(^PS(53.1,+PSGORD,0)) D
- . N DUR S DUR=$$GETDUR^PSJLIVMD(PSGP,PSGORD,$S(PSGORD["P":"P",1:5),1) I DUR]"" K DA,DR,DIE S DIE="^PS(53.1,",DA=+PSGORD,DR="116////"_DUR D ^DIE
- I PSGOEAV,+PSJSYSU=3,'$D(PSGOES) D EN^PSGPEN(PSGORD),UNL^PSSLOCK(PSGP,PSGORD) Q
- S PSJORD=PSGORD,PSGACT=$$ENACTION^PSGOE1(PSGP,PSGORD)
- Q
- UPD ;
- K DA W !!,"...updating order..."
- I PSGORD["P" S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8) I PSJCOM D UPD^PSJCOM Q
- ; Set trigger for FIELD (12) Dispense Drug to print a updated pick list.
- I PSGORD["U",$D(^PS(53.45,PSJSYSP,2,1,0)),$D(^PS(55,PSGP,5,+PSGORD,1,1,0)) D
- .N PSJX12,PSJF12 S PSJF12=0
- .F PSJX12=0:1 S PSJX12=$O(^PS(53.45,PSJSYSP,2,PSJX12)) Q:+PSJX12=0 S:$G(^PS(53.45,PSJSYSP,2,PSJX12,0))'=$G(^PS(55,PSGP,5,+PSGORD,1,PSJX12,0)) PSJF12=1
- .S:PSJF12 ^PS(55,"AUE",PSGP,+PSGORD)=""
- N TMP,PSGSIF S TMP=PSGOEENO N PSGOEENO S PSGOEENO=TMP
- N II F II=1:1:$L($G(DR),";") I $E($P($G(DR),";",II),1,7)="122////" S PSGSIF=$P(PSGSI,"^",2),PSGSI=$P(PSGSI,"^") Q
- I $G(PSJCOM),$G(PSJCOMSI) K PSJCOMSI N PSJCHILD,PSJOEORD S PSJOEORD=0 F S PSJOEORD=$O(^PS(55,"ACX",PSJCOM,PSJOEORD)) Q:'PSJOEORD D
- . S PSJCHILD=0 F S PSJCHILD=$O(^PS(55,"ACX",PSJCOM,PSJOEORD,PSJCHILD)) Q:'PSJCHILD D
- .. Q:PSJCHILD=PSGORD N DR,DA,DIE,ORD S DR=$S(PSJCHILD["V":"31////"_$G(P("OPI")),1:"8////"_$G(PSGSI)) S DR=DR_";"_$S(PSJCHILD["V":146,1:122)_"////"_+$G(PSGSIF)
- .. I $E(DR)'="*" S DA=+PSJCHILD,DIE=$S(PSJCHILD["U":"^PS(55,"_PSGP_",5,",1:"^PS(53.1,") S:DIE["^PS(55," DA(1)=PSGP D ^DIE W "." D EN1^PSJHL2(PSGP,"XX",+PSJCHILD_"U")
- I $E(DR)'="*" S DA=+PSGORD,DIE=$S(PSGORD["U":"^PS(55,"_PSGP_",5,",1:"^PS(53.1,") S:DIE["^PS(55," DA(1)=PSGP D ^DIE W "."
- F Q=1,3 K @(PSGOEEWF_Q_")") S %X="^PS(53.45,"_PSJSYSP_","_$S(Q=1:2,1:1)_",",%Y=PSGOEEWF_Q_"," K @(PSGOEEWF_Q_")") D %XY^%RCR W "."
- S $P(@(PSGOEEWF_"1,0)"),"^",2)=$S(PSGORD["U":55.07,1:53.11)_"P"
- ; Naked reference on the line below refers to full reference using indirection to either ^PS(55 or ^PS(53.1,
- S ND=$G(@($S(PSGORD["U":"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSGORD_",0)")) I $P(ND,"^",21) S ORIFN=$P(ND,"^",21),ND1=$G(^(.2)),ND2=$G(^(2)) W !,"...updating OE/RR..." D EN1^PSJHL2(PSGP,"XX",PSGORD)
- I $$ENACTION^PSGOE1(PSGP,PSGORD)["V" S VALMBCK="R"
- I PSJSYSL,PSJSYSL<3 S $P(@($S(PSGORD["U":"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSGORD_",7)"),"^",1,2)=PSGDT_"^"_$E("D",PSGOEENO)_"E",PSGTOL=2,PSGUOW=DUZ,PSGTOO=PSGORD'["U"+1,DA=+PSGORD D ENL^PSGVDS
- D CALLBOP ;IHS/CIA/PLS - 10/14/05 - Call to Automated Dispensing System
- Q
- ; Call Automated Dispensing System if present
- CALLBOP ;
- I $$PATCH^XPDUTL("BOP*1.0*1") D
- .D EDIT^BOPCP2
- .D ^BOPSD
- Q
- OUT ;
- D ABORT K PSGNEWDT S PSGCANFL=1 D GETUD^PSJLMGUD(PSGP,PSGORD),ENSFE^PSGOEE0(PSGP,PSGORD),INIT^PSJLMUDE(PSGP,PSGORD)
- Q
- DONE ;
- I PSGORD["P",'$D(PSGOEF),PSGSCH]"",$O(^PS(53.1,+PSGORD,1,0)) D ENF^PSGOEE0
- DONE1 ;
- I PSGORD["U" S X=+PSGORD L -^PS(55,PSGP,5,X)
- E L -^PS(53.1,+PSGORD)
- K ^PS(53.45,+PSJSYSP,1),^(2)
- I '$D(PSGOEF) K PSGSD,PSGSCH,PSGST,PSGFD
- K DA,DIE,DIR,DP,DR,DRG,ND,ND0,ND1,ND2,ORIFN,PSGAL,PSGALEF,PSGAT,PSGOEE,PSGOEEF,PSGOEEG,PSGOEEWF,PSGEFN,PSGTOL,PSGTOO,PSGUOW,XREF,PSGEFN,PSGMR,PSGMRN,PSGOROE1,PSGPD,PSGPDN,PSGSI,PSGPR,PSGSM,PSGHSM,PSGSTN,PSGSDN,PSGFDN,PSGPRN
- K PSGDO,PSGOEENO Q
- K1 ;
- K BACK,F1,F2,PSGF2,MSG,PSGEFN,PSGNEWDT,PSGOEEF,PSGOEEND,PSGOPD,PSGOPDN,PSGOMR,PSGOMRN,PSGOSCH,PSGOSI,PSGOPR,PSGOSM,PSGOHSM,PSGOSD,PSGOFD,PSGOST,PSGOPRN,PSGOSTN,PSGOSDN,PSGOFDN,PSGODO,PSGPDRG,PSGPDRGN,PSGOEER
- Q
- ;
- ABORT ; Display no change message and pause.
- S (PSGDI,PSGDFLG)='$$DDOK^PSGOE2(PSGOEEWF_"1,",+$G(@(PSGOEEWF_".2)")))
- S PSGPFLG='$$OIOK^PSGOE2(+$G(@(PSGOEEWF_".2)")))
- W !!,$C(7),"No changes made to this order." D PAUSE^VALM1 K PSGOEEF S PSGOEEF=0
- Q
- ;
- GTSTATUS ; Determine status of new order and set LM title.
- S PSGSTAT=$S($P($G(PSJSYSP0),U,9):"ACTIVE",1:"NON-VERIFIED")
- S VALM("TITLE")=PSGSTAT_" UNIT DOSE "_$S(PSGSTAT="PENDING":"("_PSGPRIO_")",1:"")
- Q
- FIELDS ;
- 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
- 51 ;;101^PSGOE9;PSGOPD;PSGPD;101;1
- 52 ;;109^PSGOE9;PSGODO;PSGDO;109;PSGODO]""
- 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^PSGOE92;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^PSGOE91;PSGOSI;PSGSI;8;0
- 512 ;;2^PSGOE92;;;2;0
- 513 ;;15^PSGOE92;;;15;0
- PSGOEE ;BIR/CML3-EDIT ACTIVE OR NON-VERIFIED ORDERS ;29-May-2012 14:30;PLS
- +1 ;;5.0; INPATIENT MEDICATIONS ;**4,7,29,47,64,58,82,91,1004,110,111,112,142,1015**;16 DEC 97;Build 62
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA# 2191.
- +4 ; Reference to ^PSSLOCK is supported by DBIA# 2789.
- +5 ;
- +6 ; Modified - IHS/CIA/PLS - 10/14/05 - Line UPD+10
- +7 ;
- +8 DO NOW^%DTC
- SET PSGDT=%
- KILL PSGEFN,PSGOEEF
- SET PSGOEEF=0
- IF PSGORD["A"!(PSGORD["O")
- GOTO ACT
- 531 ; edit orders in 53.1
- ENF ;
- +1 DO EN2^PSGOEEW
- +2 KILL PSJACEPT
- DO EDLOOP
- IF '$GET(PSJACEPT)
- GOTO OUT
- +3 IF $GET(PSGOEENO)
- Begin DoDot:1
- +4 NEW PSGOEENO
- SET PSGOEENO=1
- DO NEW
- End DoDot:1
- +5 IF '$TEST
- Begin DoDot:1
- +6 NEW PSGOEENO
- SET PSGOEENO=0
- DO UPD
- End DoDot:1
- +7 IF $GET(PSGOEAV)
- DO ACT1
- QUIT
- +8 DO DONE1
- +9 SET PSGOEEF=0
- SET PSJORD=PSGORD
- DO GETUD^PSJLMGUD(PSGP,PSGORD)
- DO ENSFE^PSGOEE0(PSGP,PSGORD)
- +10 QUIT
- ACT ;
- +1 DO EN2^PSGOEEW
- DO EDLOOP
- IF '$GET(PSJACEPT)
- GOTO OUT
- +2 IF $GET(PSGOEENO)
- Begin DoDot:1
- +3 NEW PSGOEENO
- SET PSGOEENO=1
- DO NEW
- End DoDot:1
- +4 IF '$TEST
- Begin DoDot:1
- +5 NEW PSGOEENO
- SET PSGOEENO=0
- DO UPD
- End DoDot:1
- +6 IF $DATA(PSGOEF)!$GET(PSGOEENO)
- SET PSGCANFL=-1
- ACT1 ;I 'PSGOEAV,PSJSYSL>1 S $P(@($S(PSGORD["U":"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSGORD_",7)"),"^",1,2)=PSGDT_"^"_$E("D",PSGOEENO)_"E",PSGTOL=2,PSGUOW=DUZ,PSGTOO=PSGORD'["U"+1,DA=+PSGORD D ENL^PSGVDS
- +1 DO DONE1
- +2 SET PSGOEEF=0
- DO GETUD^PSJLMGUD(PSGP,PSGORD)
- DO ENSFE^PSGOEE0(PSGP,PSGORD)
- IF PSGOEAV
- DO UNL^PSSLOCK(PSGP,PSGORD)
- +3 QUIT
- EDIT ;
- +1 DO FULL^VALM1
- +2 WRITE !
- SET PSGOEER=""
- FOR Q=1:1
- SET Q1=$PIECE(Y,",",Q)
- IF 'Q1
- QUIT
- SET X=$PIECE($TEXT(@(PSGOEEG_Q1)),";",3)
- SET PSGOEER=PSGOEER_X_";"
- SET PSGOEEF(+X)=Q
- +3 SET LIMIT=$LENGTH(PSGOEER,";")-1
- SET (PSGDEF,PSGOEE)=0
- FOR
- SET PSGOEE=PSGOEE+1
- IF PSGOEE>LIMIT
- QUIT
- IF +$PIECE(PSGOEER,";",PSGOEE)=101
- SET PSGDEF=1
- +4 SET PSGOEER=$EXTRACT(PSGOEER,1,$LENGTH(PSGOEER)-1)
- SET (MSG,PSGOEE)=0
- FOR
- SET PSGOEE=PSGOEE+1
- IF PSGOEE>$LENGTH(PSGOEER,";")
- QUIT
- SET F1=$SELECT(PSGOEEG=3:53.1,1:55.06)
- IF 'PSGDEF!((PSGDEF)&(+$PIECE(PSGOEER,";",PSGOEE)'=2))
- DO @$PIECE(PSGOEER,";",PSGOEE)
- IF 'PSGOEE
- QUIT
- +5 QUIT
- EDLOOP ; Continue prompting for fields to edit.
- +1 IF $GET(Y)
- DO EDIT
- +2 DO ENNOU^PSGOEE0
- IF '$GET(PSGOEENO)
- IF DR=""
- SET VALMBCK="R"
- QUIT
- +3 KILL VALMSG
- +4 IF '$GET(PSGOEENO)
- IF $GET(PSGPDNX)
- DO CKDT
- +5 IF $GET(PSGOEENO)
- Begin DoDot:1
- +6 SET VALMSG="This change will cause a new order to be created."
- DO GTSTATUS
- DO CHKDD
- DO CKDT
- +7 SET PSGEBN=$$ENNPN^PSGMI(DUZ)
- SET PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PSGDT)
- End DoDot:1
- +8 DO CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGSD_"^^"_PSGFD)
- +9 KILL VALMBCK,PSJACEPT,PSGPDNX
- DO EN^VALM("PSJU LM ACCEPT")
- IF '$GET(PSJACEPT)
- QUIT
- +10 IF $GET(PSGS0XT)="D"
- IF '$GET(PSGS0Y)
- IF ((",P,R,")'[(","_$GET(PSGST)_","))
- Begin DoDot:1
- +11 SET PSJACEPT=0
- WRITE !!,"This is a 'DAY OF THE WEEK' schedule and MUST have admin times."
- DO PAUSE^VALM1
- End DoDot:1
- QUIT
- +12 IF $GET(PSGOEENO)
- SET PSJNOO=$$ENNOO^PSJUTL5("E")
- +13 DO K1
- SET PSJACEPT=$SELECT($GET(PSJNOO)<0:0,1:1)
- +14 SET VALMBCK=$SELECT('PSJACEPT:"R",'PSGOEAV:"R",1:"Q")
- +15 QUIT
- CHKDD ;*** Check inactive Dispense drug within the order.
- +1 DO CHKDRG^PSGOE2
- +2 QUIT
- CKDT ; Check if new start/stop dates should be calculated.
- +1 SET PSGS0Y=$SELECT($DATA(PSGS0Y):PSGS0Y,1:$GET(PSGAT))
- +2 IF ('$GET(PSGNEWDT)&(PSGSD=$GET(PSGOSD))&(PSGFD=$GET(PSGOFD)))!($GET(PSGOST)'=PSGST)!(PSGSCH'=$GET(PSGOSCH))!($GET(PSGPDNX))
- Begin DoDot:1
- +3 NEW PSGOES
- SET PSGOES=1
- SET PSGOFD=PSGFD
- DO ^PSGNE3
- SET PSGSD=PSGNESD
- SET PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC^PSGMI(PSGNESD)
- SET PSGFD=PSGNEFD
- SET PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^PSGMI(PSGNEFD)
- SET PSGNEWDT=1
- +4 IF $DATA(PSGOFD)
- IF PSGOFD]""
- IF PSGFD'=PSGOFD
- SET PSGOEEF(25)=1
- +5 IF $DATA(PSGOSD)
- IF PSGOSD]""
- IF PSGSD'=PSGOSD
- SET PSGOEEF(10)=1
- End DoDot:1
- +6 QUIT
- NEW3 ;
- +1 ;S:PSGOEAV PSGOEAV="0^1"
- NEW ;
- +1 WRITE !,"...discontinuing original order..."
- +2 IF PSGORD["P"
- SET PSJCOM=+$PIECE($GET(^PS(53.1,+PSGORD,.2)),"^",8)
- IF PSJCOM
- DO NEW^PSJCOM1
- QUIT
- +3 ;DC and Unlock order.
- +4 SET PSGEDIT="DE"
- DO ENOR^PSGOECS
- DO UNL^PSSLOCK(PSGP,PSGORD)
- KILL PSGEDIT
- +5 WRITE !!," ...creating new order..."
- IF 'PSGOEAV
- WRITE "(you will now work on this new order)"
- +6 SET PSGS0Y=PSGAT
- SET PSGNESD=PSGSD
- SET PSGNEFD=PSGFD
- SET PSGOEPR=PSGPR
- SET PSGPDRG=PSGPD
- SET PSGPDRGN=PSGPDN
- SET PSGOEE="E"
- +7 SET PSGOORD=PSGORD
- DO ^PSGOETO
- KILL PSGOEOS
- +8 IF PSGOORD["U"
- SET $PIECE(^PS(55,PSGP,5,+PSGOORD,0),"^",26,27)=PSGORD_"^E"
- +9 IF '$TEST
- SET $PIECE(^PS(53.1,+PSGOORD,0),"^",26,27)=PSGORD_"^E"
- +10 IF 'PSGOEAV
- IF ($GET(PSGORD)["P")
- IF '$GET(^PS(53.1,+PSGORD,2.5))
- IF $GET(^PS(53.1,+PSGORD,0))
- Begin DoDot:1
- +11 NEW DUR
- SET DUR=$$GETDUR^PSJLIVMD(PSGP,PSGORD,$SELECT(PSGORD["P":"P",1:5),1)
- IF DUR]""
- KILL DA,DR,DIE
- SET DIE="^PS(53.1,"
- SET DA=+PSGORD
- SET DR="116////"_DUR
- DO ^DIE
- End DoDot:1
- +12 IF PSGOEAV
- IF +PSJSYSU=3
- IF '$DATA(PSGOES)
- DO EN^PSGPEN(PSGORD)
- DO UNL^PSSLOCK(PSGP,PSGORD)
- QUIT
- +13 SET PSJORD=PSGORD
- SET PSGACT=$$ENACTION^PSGOE1(PSGP,PSGORD)
- +14 QUIT
- UPD ;
- +1 KILL DA
- WRITE !!,"...updating order..."
- +2 IF PSGORD["P"
- SET PSJCOM=+$PIECE($GET(^PS(53.1,+PSGORD,.2)),"^",8)
- IF PSJCOM
- DO UPD^PSJCOM
- QUIT
- +3 ; Set trigger for FIELD (12) Dispense Drug to print a updated pick list.
- +4 IF PSGORD["U"
- IF $DATA(^PS(53.45,PSJSYSP,2,1,0))
- IF $DATA(^PS(55,PSGP,5,+PSGORD,1,1,0))
- Begin DoDot:1
- +5 NEW PSJX12,PSJF12
- SET PSJF12=0
- +6 FOR PSJX12=0:1
- SET PSJX12=$ORDER(^PS(53.45,PSJSYSP,2,PSJX12))
- IF +PSJX12=0
- QUIT
- IF $GET(^PS(53.45,PSJSYSP,2,PSJX12,0))'=$GET(^PS(55,PSGP,5,+PSGORD,1,PSJX12,0))
- SET PSJF12=1
- +7 IF PSJF12
- SET ^PS(55,"AUE",PSGP,+PSGORD)=""
- End DoDot:1
- +8 NEW TMP,PSGSIF
- SET TMP=PSGOEENO
- NEW PSGOEENO
- SET PSGOEENO=TMP
- +9 NEW II
- FOR II=1:1:$LENGTH($GET(DR),";")
- IF $EXTRACT($PIECE($GET(DR),";",II),1,7)="122////"
- SET PSGSIF=$PIECE(PSGSI,"^",2)
- SET PSGSI=$PIECE(PSGSI,"^")
- QUIT
- +10 IF $GET(PSJCOM)
- IF $GET(PSJCOMSI)
- KILL PSJCOMSI
- NEW PSJCHILD,PSJOEORD
- SET PSJOEORD=0
- FOR
- SET PSJOEORD=$ORDER(^PS(55,"ACX",PSJCOM,PSJOEORD))
- IF 'PSJOEORD
- QUIT
- Begin DoDot:1
- +11 SET PSJCHILD=0
- FOR
- SET PSJCHILD=$ORDER(^PS(55,"ACX",PSJCOM,PSJOEORD,PSJCHILD))
- IF 'PSJCHILD
- QUIT
- Begin DoDot:2
- +12 IF PSJCHILD=PSGORD
- QUIT
- NEW DR,DA,DIE,ORD
- SET DR=$SELECT(PSJCHILD["V":"31////"_$GET(P("OPI")),1:"8////"_$GET(PSGSI))
- SET DR=DR_";"_$SELECT(PSJCHILD["V":146,1:122)_"////"_+$GET(PSGSIF)
- +13 IF $EXTRACT(DR)'="*"
- SET DA=+PSJCHILD
- SET DIE=$SELECT(PSJCHILD["U":"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")
- IF DIE["^PS(55,"
- SET DA(1)=PSGP
- DO ^DIE
- WRITE "."
- DO EN1^PSJHL2(PSGP,"XX",+PSJCHILD_"U")
- End DoDot:2
- End DoDot:1
- +14 IF $EXTRACT(DR)'="*"
- SET DA=+PSGORD
- SET DIE=$SELECT(PSGORD["U":"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")
- IF DIE["^PS(55,"
- SET DA(1)=PSGP
- DO ^DIE
- WRITE "."
- +15 FOR Q=1,3
- KILL @(PSGOEEWF_Q_")")
- SET %X="^PS(53.45,"_PSJSYSP_","_$SELECT(Q=1:2,1:1)_","
- SET %Y=PSGOEEWF_Q_","
- KILL @(PSGOEEWF_Q_")")
- DO %XY^%RCR
- WRITE "."
- +16 SET $PIECE(@(PSGOEEWF_"1,0)"),"^",2)=$SELECT(PSGORD["U":55.07,1:53.11)_"P"
- +17 ; Naked reference on the line below refers to full reference using indirection to either ^PS(55 or ^PS(53.1,
- +18 SET ND=$GET(@($SELECT(PSGORD["U":"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSGORD_",0)"))
- IF $PIECE(ND,"^",21)
- SET ORIFN=$PIECE(ND,"^",21)
- SET ND1=$GET(^(.2))
- SET ND2=$GET(^(2))
- WRITE !,"...updating OE/RR..."
- DO EN1^PSJHL2(PSGP,"XX",PSGORD)
- +19 IF $$ENACTION^PSGOE1(PSGP,PSGORD)["V"
- SET VALMBCK="R"
- +20 IF PSJSYSL
- IF PSJSYSL<3
- SET $PIECE(@($SELECT(PSGORD["U":"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSGORD_",7)"),"^",1,2)=PSGDT_"^"_$EXTRACT("D",PSGOEENO)_"E"
- SET PSGTOL=2
- SET PSGUOW=DUZ
- SET PSGTOO=PSGORD'["U"+1
- SET DA=+PSGORD
- DO ENL^PSGVDS
- +21 ;IHS/CIA/PLS - 10/14/05 - Call to Automated Dispensing System
- DO CALLBOP
- +22 QUIT
- +23 ; Call Automated Dispensing System if present
- CALLBOP ;
- +1 IF $$PATCH^XPDUTL("BOP*1.0*1")
- Begin DoDot:1
- +2 DO EDIT^BOPCP2
- +3 DO ^BOPSD
- End DoDot:1
- +4 QUIT
- OUT ;
- +1 DO ABORT
- KILL PSGNEWDT
- SET PSGCANFL=1
- DO GETUD^PSJLMGUD(PSGP,PSGORD)
- DO ENSFE^PSGOEE0(PSGP,PSGORD)
- DO INIT^PSJLMUDE(PSGP,PSGORD)
- +2 QUIT
- DONE ;
- +1 IF PSGORD["P"
- IF '$DATA(PSGOEF)
- IF PSGSCH]""
- IF $ORDER(^PS(53.1,+PSGORD,1,0))
- DO ENF^PSGOEE0
- DONE1 ;
- +1 IF PSGORD["U"
- SET X=+PSGORD
- LOCK -^PS(55,PSGP,5,X)
- +2 IF '$TEST
- LOCK -^PS(53.1,+PSGORD)
- +3 KILL ^PS(53.45,+PSJSYSP,1),^(2)
- +4 IF '$DATA(PSGOEF)
- KILL PSGSD,PSGSCH,PSGST,PSGFD
- +5 KILL DA,DIE,DIR,DP,DR,DRG,ND,ND0,ND1,ND2,ORIFN,PSGAL,PSGALEF,PSGAT,PSGOEE,PSGOEEF,PSGOEEG,PSGOEEWF,PSGEFN,PSGTOL,PSGTOO,PSGUOW,XREF,PSGEFN,PSGMR,PSGMRN,PSGOROE1,PSGPD,PSGPDN,PSGSI,PSGPR,PSGSM,PSGHSM,PSGSTN,PSGSDN,PSGFDN,PSGPRN
- +6 KILL PSGDO,PSGOEENO
- QUIT
- K1 ;
- +1 KILL BACK,F1,F2,PSGF2,MSG,PSGEFN,PSGNEWDT,PSGOEEF,PSGOEEND,PSGOPD,PSGOPDN,PSGOMR,PSGOMRN,PSGOSCH,PSGOSI,PSGOPR,PSGOSM,PSGOHSM,PSGOSD,PSGOFD,PSGOST,PSGOPRN,PSGOSTN,PSGOSDN,PSGOFDN,PSGODO,PSGPDRG,PSGPDRGN,PSGOEER
- +2 QUIT
- +3 ;
- ABORT ; Display no change message and pause.
- +1 SET (PSGDI,PSGDFLG)='$$DDOK^PSGOE2(PSGOEEWF_"1,",+$GET(@(PSGOEEWF_".2)")))
- +2 SET PSGPFLG='$$OIOK^PSGOE2(+$GET(@(PSGOEEWF_".2)")))
- +3 WRITE !!,$CHAR(7),"No changes made to this order."
- DO PAUSE^VALM1
- KILL PSGOEEF
- SET PSGOEEF=0
- +4 QUIT
- +5 ;
- GTSTATUS ; Determine status of new order and set LM title.
- +1 SET PSGSTAT=$SELECT($PIECE($GET(PSJSYSP0),U,9):"ACTIVE",1:"NON-VERIFIED")
- +2 SET VALM("TITLE")=PSGSTAT_" UNIT DOSE "_$SELECT(PSGSTAT="PENDING":"("_PSGPRIO_")",1:"")
- +3 QUIT
- FIELDS ;
- 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
- 51 ;;101^PSGOE9;PSGOPD;PSGPD;101;1
- 52 ;;109^PSGOE9;PSGODO;PSGDO;109;PSGODO]""
- 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^PSGOE92;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^PSGOE91;PSGOSI;PSGSI;8;0
- 512 ;;2^PSGOE92;;;2;0
- 513 ;;15^PSGOE92;;;15;0
