PSGOEE ;BIR/CML-EDIT ACTIVE OR NON VERIFIED ORDERS ;DEC 07, 2022@14:30
;;5.0;INPATIENT MEDICATIONS;**4,7,29,47,64,58,82,91,110,111,112,142,179,181,254,267,268,281,315,338,373,366,327,319,419,399,429**;16 DEC 97;Build 2
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PSSLOCK is supported by DBIA# 2789.
; Reference to ^TMP("PSODAOC",$J is supported by DBIA# 6071.
; Reference to ^YSCLTST5 is supported by DBIA# 7188.
;
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 ; Entry point
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 ; Perform Edit
NEW ANQX,PSJALGY1,PSGSDEDT
K PSGOEER
S ANQX=0
N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD)
I $G(CLOZFLG),PSJOP D
.D PROVCHK^PSJCLOZ(PSGOPR)
I +$G(ANQX) D PAUSE^VALM1 Q
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 ; Continue editing
D DONE1
S PSGOEEF=0 D GETUD^PSJLMGUD(PSGP,PSGORD),ENSFE^PSGOEE0(PSGP,PSGORD) D:PSGOEAV UNL^PSSLOCK(PSGP,PSGORD)
Q
EDIT ; Edit
I $G(Y) D ASKOVR(Y,$G(PSGORD),.PSJSTARI)
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:Q1=1 PSJALGY1=1
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 Q:PSGOEER=""
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.
K PSJNOO
D:$G(Y) EDIT I $G(PSGOROE1)=1!($G(PSGOEE)=0) S VALMBCK="R",(PSGOROE1,PSJACEPT)=0 Q
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_$$ENDTC2^PSGMI(PSGDT) ;373
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(PSGOEER)["26^PSGOE9")!($G(PSGOEER)["26^PSGOE8")!($G(PSGOEER)["109^PSGOE9")!($G(PSGOEER)["109^PSGOE8")!($G(PSGOEER)["3^PSGOE9")!($G(PSGOEER)["3^PSGOE8")!($G(PSGOEER)["101^PSGOE9")!($G(PSGOEER)["101^PSGOE8") S PSGOEENO=1
I $G(PSGOEENO)!($G(PSGOEER)["2^PSGOE92")!($G(PSGOEER)["2^PSGOE82") D OC S:($G(PSGOEER)["2^PSGOE82") PSJDSVFY=1
I $G(PSGORQF) S PSJNOO=-1
I '$G(PSJNOO),$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
OC ;Perform OC (only when OI or Dosage was edited) & dosing check
NEW PSJDD,PSJALLGY
K PSGORQF
D FULL^VALM1
N CLOZFLG,ANQX S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD)
I $G(CLOZFLG) D I $G(PSGORQF) Q
.S (ANQX,PSGORQF)=0,PSGDRG=$P(CLOZFLG,U,2) D TDD^PSJCLOZ I $G(PSGORQF) Q
.I +$G(PSGETDD) S ANQX=0 D CLOZ^PSJCLOZ(PSGP,PSGDRG) I $G(ANQX) S PSGORQF=1 Q
S PSJDD=+$$DD53P45^PSJMISC() I 'PSJDD S PSGORQF=1 Q
I $G(PSJALGY1)!$G(PSGOEENO) D
. D ENDDC^PSGSICHK(PSGP,PSJDD)
D:'$G(PSGORQF) IN^PSJOCDS($G(PSGORD),"UD",PSJDD)
Q
CHKDD ;*** Check inactive Dispense drug within the order.
D CHKDRG^PSGOE2
Q
CKDT ; Check if new start/stop dates should be calculated.
I $G(PSGSDEDT) Q ; Start/Stop Date Manually edited
S PSGS0Y=$S($D(PSGS0Y):PSGS0Y,1:$G(PSGAT))
;PSJ*5*179 Recalc start date if Before last given
I ($P($G(PSBSTR),"^")>PSGSD)!('$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 I $G(PSGOFD) S PSGNEFD=PSGFD
.S PSGSD=PSGNESD,PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC2^PSGMI(PSGNESD),PSGFD=PSGNEFD,PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC2^PSGMI(PSGNEFD),PSGNEWDT=1 ;373
.I $D(PSGOFD),PSGOFD]"",PSGFD'=PSGOFD S PSGOEEF(25)=1
.I $D(PSGOSD),PSGOSD]"",PSGSD'=PSGOSD S PSGOEEF(10)=1
;BHW;PSJ*5*179;Add EFD call here, removed from PSGOE91
D EFDACT^PSJUTL
Q
NEW3 ;
;S:PSGOEAV PSGOEAV="0^1"
NEW ;
I $D(^PS(53.45,+$G(PSJSYSP),5)) N PSJFSI S PSJFSI=1 D FILESI^PSJBCMA5(DFN,PSGORD) N SIARRAY S SIARRAY="" D
.I PSGORD["P" M SIARRAY=^PS(53.1,+PSGORD,15) D NEWNVAL^PSGAL5(PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
.I PSGORD["U" M SIARRAY=^PS(55,DFN,5,+PSGORD,15) D NEWUDAL^PSGAL5(PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
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 $G(PSJFSI) I $$GETSI^PSJBCMA5(DFN,PSGOORD) D FILESI^PSJBCMA5(DFN,PSGORD)
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 D
. S ^TMP("PSODAOC",$J,"IP IEN")=PSGORD
. D SETOC^PSJNEWOC(PSGORD) ;PSJ*5*281 stores order checks
I PSGOEAV,+PSJSYSU=3,'$D(PSGOES) D EN^PSGPEN(PSGORD),UNL^PSSLOCK(PSGP,PSGORD) Q
S PSJORD=PSGORD,PSGACT=$$ENACTION^PSGOE1(PSGP,PSGORD)
;K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J)
Q
UPD ;
;/327*MZR added next line to prevent updating if nothing changed
Q:$G(PSGOEE)=0
K DA W !!,"...updating order..."
I PSGORD["P" S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8) I PSJCOM D UPD^PSJCOM Q
I $$DIFFSI^PSJBCMA5(DFN,PSGORD) D
.N SIARRAY M:PSGORD["P" SIARRAY=^PS(53.1,+PSGORD,15) M:PSGORD["U" SIARRAY=^PS(55,DFN,5,+PSGORD,15)
.Q:'$D(SIARRAY)
.I PSGORD["P" D NEWNVAL^PSGAL5(PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
.I PSGORD["U" D NEWUDAL^PSGAL5(DFN,PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
;check for INDICATION changes and save results to use after filing data
N INDCHNG S INDCHNG=$$DIFFIND^PSGOE42($G(DFN),PSGORD,PSGIND)
; 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,^TMP("PSGSI",$J) M ^TMP("PSGSI",$J,5)=^PS(53.45,PSJSYSP,5) D
.D FILESI^PSJBCMA5(DFN,PSGORD)
.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
... I PSJCHILD=PSGORD Q
... N DR,DA,DIE,ORD
... I PSJCHILD["V" S DR="31////"_$G(P("OPI"))_";146////"_+$G(PSGSIF)
... ; Direct setting Special Instructions because it can contain ';' which throws off the DR variable for the ^DIE API (PSJ*5*409)
... I PSJCHILD'["V" D
.... N X S DR="122////"_+$G(PSGSIF)
.... S X=$G(PSGSI) I X'="" D CHKSI^PSSDDUT3 I $G(X)'="" S $P(^PS(55,DFN,5,+PSJCHILD,6),"^",1)=PSGSI
... I '$D(^PS(53.45,+$G(PSJSYSP),5)) M ^PS(53.45,+$G(PSJSYSP),5)=^TMP("PSGSI",$J,5)
... D FILESI^PSJBCMA5(DFN,PSJCHILD)
... ;PSJ*5*179 Comment edits
... S DR=$TR($G(DR),"*") I 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")
. K ^TMP("PSGSI",$J)
; PSJ*319 changes
N OLCLN
S OLCLN=$S(PSGORD["P":$G(^PS(53.1,+PSGORD,"DSS")),PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,8)),1:"")
I $P(OLCLN,"^")'="",$G(P("CLIN"))'=$P(OLCLN,"^") D
.I PSGORD["P" D NEWNVAL^PSGAL5(PSGORD,6000,"CLINIC",$P($G(^SC(+$P(OLCLN,"^"),0)),"^"))
.I PSGORD["U" D NEWUDAL^PSGAL5(DFN,PSGORD,6000,"CLINIC",$P($G(^SC(+$P(OLCLN,"^"),0)),"^"))
I $P(OLCLN,"^",2)'="",$G(P("APPT"))'=$P(OLCLN,"^",2) D
.I PSGORD["P" D NEWNVAL^PSGAL5(PSGORD,6000,"APPOINTMENT DATE/TIME",$P(OLCLN,"^",2))
.I PSGORD["U" D NEWUDAL^PSGAL5(DFN,PSGORD,6000,"APPOINTMENT DATE/TIME",$P(OLCLN,"^",2))
; when updating clinic; check if old clinic is PADE, send cancellation for old clinic to PADE
I PSGORD["U",$G(P("CLINO"))'="",$G(P("CLIN"))'=$P(OLCLN,"^") D
.N PSJPDO,I,PSJAP
.S PSJPDO=1,(PSJAP,I)=0
.F S I=$O(^PS(58.7,I)) Q:'I S J=$$PDACT^PSJPDCLA(I)
.Q:'PSJAP Q:'$$CHKPDCL^PSJPDCLA($P(OLCLN,"^"))
.N PDTYP,PSJHLDFN,RXO,OSTA
.S OSTA=$P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",9)
.S $P(^PS(55,PSGP,5,+PSGORD,0),"^",9)="D" ; temporarliy set status to DC
.S PDTYP="OD",PSJHLDFN=PSGP,RXO=PSGORD_$S(+PSGORD=PSGORD:"U",1:"")
.D PDORD^PSJPDCLU
.S $P(^PS(55,PSGP,5,+PSGORD,0),"^",9)=OSTA ; reset status
; PSJ*319 changes end
; filing edited data
S DR=$TR(DR,"*") I 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 "."
; add activity log entry for INDICATION after data was filed at the line above
I +INDCHNG=1 D
.I PSGORD["P" D Q
.. ;the next line assures that INDICATION is saved despite the issue that DR is set to "" when special instructions are used and the filing code ^DIE code above is not called.
.. I DR="",$$GET1^DIQ(53.1,+PSJORD,132,"E")'=$P(INDCHNG,U,3) S DR="132////^S X=PSGIND",DA=+PSGORD,DIE="^PS(53.1," D ^DIE W "."
.. I $$GET1^DIQ(53.1,+PSJORD,132,"E")=$P(INDCHNG,U,3) D NEWNVAL^PSGAL5(PSGORD,6000,"INDICATION",$P(INDCHNG,U,2))
.I PSGORD["U" D:$$GET1^DIQ(55.06,+PSJORD_","_+DFN_",",141)=$P(INDCHNG,U,3) NEWUDAL^PSGAL5(DFN,PSGORD,6000,"INDICATION",$P(INDCHNG,U,2))
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"
I $D(^PS(53.45,+$G(PSJSYSP),5)) D FILESI^PSJBCMA5(DFN,PSJORD)
; 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)),ND2P1=$G(^(2.1)) W !,"...updating OE/RR..." D EN1^PSJHL2(PSGP,"XX",PSGORD) ;*315
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
; **This is where the Automated Dispensing Machine hook is called. Do NOT DELETE or change this location **
D EDIT^PSJADM
; **END of Interface Hook **
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 ;
;; START NCC REMEDIATION >> 327*RJS ;/RBN & MZR changed conditions on the next line
I $G(PSGEDT),$$GET1^DIQ(55.06,+$G(PSGORD)_","_DFN,.01,"I") D
.N CLOZFLG,PSGDRG S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,DFN,+PSGORD)
.I $G(CLOZFLG) S PSGDRG=$P(CLOZFLG,U,2) D
..N DIE,DA,DR S DIE="^PS(55,"_DFN_",5,",DA=+PSGORD,DA(1)=DFN,DR="301////"
..I $D(^TMP("PSJCOM",$J,+$G(PSGORD))) D K ^TMP($J,"PSGCLOZ",DFN,+PSGORD,"SAND") I 1
...S DR=DR_$G(^TMP("PSJCOM",$J,+PSGORD,"SAND"))
..E I $G(^TMP($J,"PSGCLOZ",DFN,+$G(PSJORD),"SAND")) D K ^TMP($J,"PSGCLOZ",DFN,+PSJORD,"SAND") I 1
...S DR=DR_$G(^TMP($J,"PSGCLOZ",DFN,+PSJORD,"SAND"))
..E I $G(^TMP($J,"PSGCLOZ",DFN,+$G(PSGORD),"SAND")) D K ^TMP($J,"PSGCLOZ",DFN,+PSGORD,"SAND")
...S DR=DR_$G(^TMP($J,"PSGCLOZ",DFN,+PSGORD,"SAND"))
..D ^DIE
..N PSGDN S PSGDN=PSGDRG
..D PSJFILE^PSJCLOZ(DFN),INPSND^YSCLTST5
;; END NCC REMEDIATION >> 327*RJS
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),^(5),^(6)
I '$D(PSGOEF) K PSGSD,PSGSCH,PSGST,PSGFD
K DA,DIE,DIR,DP,DR,DRG,ND,ND0,ND1,ND2,ND2P1,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,PSGIND Q ;*399-IND
K1 ;
K BACK,F1,F2,PSGF2,MSG,PSGEFN,PSGNEWDT,PSGOEEND,PSGOPD,PSGOPDN,PSGOMR,PSGOMRN,PSGOSCH,PSGOSI,PSGOPR,PSGOSM,PSGOSD,PSGOFD,PSGOST,PSGOPRN,PSGOSTN,PSGOSDN,PSGOFDN,PSGODO,PSGPDRG,PSGPDRGN,PSGOEER,PSGOIND ;*399-IND
; P429 Removed the K PSGOHSM var above
Q
;
ABORT ; Display no change message and pause.
D FULL^VALM1
S (PSGDI,PSGDFLG)='$$DDOK^PSGOE2(PSGOEEWF_"1,",+$G(@(PSGOEEWF_".2)")))
S PSGPFLG='$$OIOK^PSGOE2(+$G(@(PSGOEEWF_".2)")))
I '$G(PSJRNFLG) W !!,$C(7),"No changes made to this order." D PAUSE^VALM1 ;if flag set in PSODGAL1, no repeat message
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
;
ASKOVR(Y,PSJOVRON,PSJSTARI) ; Check to see if any starred fields are being edited. If so, ask if they wish to view overrides/interventions if they exist
Q:'$D(Y)!$D(PSJSTARI) N II,I3,YY S YY=$S(Y:Y,1:$TR($P(Y,"^",4),"="))
Q:'YY S PSJOVRON=$S($G(PSJOVRON):PSJOVRON,1:$G(PSJORD)) Q:'$G(PSJOVRON)
N PSJORD S PSJORD=PSJOVRON
I '$G(PSJSTARI) F II=1:1:$L(YY,",") Q:$G(PSJSTARI) S I3=$P(YY,",",II) I I3 S:$G(PSGEFN(I3))!($G(PSJSTAR)[("("_I3_")")) PSJSTARI=1
I $G(PSJSTARI) I ($G(PSJORD)&$G(PSGP)) I $$ASKDISP^PSGSICH1 D FULL^VALM1 D OVRDISP^PSGSICH2(PSGP,PSJORD,3)
Q
;
;*399-IND-314,514
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
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 ;;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
514 ;;132^PSGOE41;PSGOIND;PSGIND;132;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[HPSGOEE 15778 printed Sep 23, 2025@19:38:13 Page 2
PSGOEE ;BIR/CML-EDIT ACTIVE OR NON VERIFIED ORDERS ;DEC 07, 2022@14:30
+1 ;;5.0;INPATIENT MEDICATIONS;**4,7,29,47,64,58,82,91,110,111,112,142,179,181,254,267,268,281,315,338,373,366,327,319,419,399,429**;16 DEC 97;Build 2
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference to ^PS(55 is supported by DBIA# 2191.
+5 ; Reference to ^PSSLOCK is supported by DBIA# 2789.
+6 ; Reference to ^TMP("PSODAOC",$J is supported by DBIA# 6071.
+7 ; Reference to ^YSCLTST5 is supported by DBIA# 7188.
+8 ;
+9 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 ; Entry point
+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 ; Perform Edit
+1 NEW ANQX,PSJALGY1,PSGSDEDT
+2 KILL PSGOEER
+3 SET ANQX=0
+4 NEW CLOZFLG
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD)
+5 IF $GET(CLOZFLG)
IF PSJOP
Begin DoDot:1
+6 DO PROVCHK^PSJCLOZ(PSGOPR)
End DoDot:1
+7 IF +$GET(ANQX)
DO PAUSE^VALM1
QUIT
+8 DO EN2^PSGOEEW
DO EDLOOP
if '$GET(PSJACEPT)
GOTO OUT
+9 IF $GET(PSGOEENO)
Begin DoDot:1
+10 NEW PSGOEENO
SET PSGOEENO=1
DO NEW
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 NEW PSGOEENO
SET PSGOEENO=0
DO UPD
End DoDot:1
+13 if $DATA(PSGOEF)!$GET(PSGOEENO)
SET PSGCANFL=-1
ACT1 ; Continue editing
+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 ; Edit
+1 IF $GET(Y)
DO ASKOVR(Y,$GET(PSGORD),.PSJSTARI)
+2 DO FULL^VALM1
+3 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
if Q1=1
SET PSJALGY1=1
+4 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
+5 SET PSGOEER=$EXTRACT(PSGOEER,1,$LENGTH(PSGOEER)-1)
SET (MSG,PSGOEE)=0
if PSGOEER=""
QUIT
+6 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
+7 QUIT
EDLOOP ; Continue prompting for fields to edit.
+1 KILL PSJNOO
+2 if $GET(Y)
DO EDIT
IF $GET(PSGOROE1)=1!($GET(PSGOEE)=0)
SET VALMBCK="R"
SET (PSGOROE1,PSJACEPT)=0
QUIT
+3 DO ENNOU^PSGOEE0
IF '$GET(PSGOEENO)
IF DR=""
SET VALMBCK="R"
QUIT
+4 KILL VALMSG
+5 IF '$GET(PSGOEENO)
IF $GET(PSGPDNX)
DO CKDT
+6 IF $GET(PSGOEENO)
Begin DoDot:1
+7 SET VALMSG="This change will cause a new order to be created."
DO GTSTATUS
DO CHKDD
DO CKDT
+8 ;373
SET PSGEBN=$$ENNPN^PSGMI(DUZ)
SET PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC2^PSGMI(PSGDT)
End DoDot:1
+9 DO CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGSD_"^^"_PSGFD)
+10 KILL VALMBCK,PSJACEPT,PSGPDNX
DO EN^VALM("PSJU LM ACCEPT")
if '$GET(PSJACEPT)
QUIT
+11 IF $GET(PSGS0XT)="D"
IF '$GET(PSGS0Y)
IF ((",P,R,")'[(","_$GET(PSGST)_","))
Begin DoDot:1
+12 SET PSJACEPT=0
WRITE !!,"This is a 'DAY OF THE WEEK' schedule and MUST have admin times."
DO PAUSE^VALM1
End DoDot:1
QUIT
+13 IF ($GET(PSGOEER)["26^PSGOE9")!($GET(PSGOEER)["26^PSGOE8")!($GET(PSGOEER)["109^PSGOE9")!($GET(PSGOEER)["109^PSGOE8")!($GET(PSGOEER)["3^PSGOE9")!($GET(PSGOEER)["3^PSGOE8")!($GET(PSGOEER)["101^PSGOE9")!($GET(PSGOEER)["101^PSGOE8")
SET PSGOEENO=1
+14 IF $GET(PSGOEENO)!($GET(PSGOEER)["2^PSGOE92")!($GET(PSGOEER)["2^PSGOE82")
DO OC
if ($GET(PSGOEER)["2^PSGOE82")
SET PSJDSVFY=1
+15 IF $GET(PSGORQF)
SET PSJNOO=-1
+16 IF '$GET(PSJNOO)
IF $GET(PSGOEENO)
SET PSJNOO=$$ENNOO^PSJUTL5("E")
+17 DO K1
SET PSJACEPT=$SELECT($GET(PSJNOO)<0:0,1:1)
+18 SET VALMBCK=$SELECT('PSJACEPT:"R",'PSGOEAV:"R",1:"Q")
+19 QUIT
OC ;Perform OC (only when OI or Dosage was edited) & dosing check
+1 NEW PSJDD,PSJALLGY
+2 KILL PSGORQF
+3 DO FULL^VALM1
+4 NEW CLOZFLG,ANQX
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD)
+5 IF $GET(CLOZFLG)
Begin DoDot:1
+6 SET (ANQX,PSGORQF)=0
SET PSGDRG=$PIECE(CLOZFLG,U,2)
DO TDD^PSJCLOZ
IF $GET(PSGORQF)
QUIT
+7 IF +$GET(PSGETDD)
SET ANQX=0
DO CLOZ^PSJCLOZ(PSGP,PSGDRG)
IF $GET(ANQX)
SET PSGORQF=1
QUIT
End DoDot:1
IF $GET(PSGORQF)
QUIT
+8 SET PSJDD=+$$DD53P45^PSJMISC()
IF 'PSJDD
SET PSGORQF=1
QUIT
+9 IF $GET(PSJALGY1)!$GET(PSGOEENO)
Begin DoDot:1
+10 DO ENDDC^PSGSICHK(PSGP,PSJDD)
End DoDot:1
+11 if '$GET(PSGORQF)
DO IN^PSJOCDS($GET(PSGORD),"UD",PSJDD)
+12 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 ; Start/Stop Date Manually edited
IF $GET(PSGSDEDT)
QUIT
+2 SET PSGS0Y=$SELECT($DATA(PSGS0Y):PSGS0Y,1:$GET(PSGAT))
+3 ;PSJ*5*179 Recalc start date if Before last given
+4 IF ($PIECE($GET(PSBSTR),"^")>PSGSD)!('$GET(PSGNEWDT)&(PSGSD=$GET(PSGOSD))&(PSGFD=$GET(PSGOFD)))!($GET(PSGOST)'=PSGST)!(PSGSCH'=$GET(PSGOSCH))!($GET(PSGPDNX))
Begin DoDot:1
+5 NEW PSGOES
SET PSGOES=1
SET PSGOFD=PSGFD
DO ^PSGNE3
IF $GET(PSGOFD)
SET PSGNEFD=PSGFD
+6 ;373
SET PSGSD=PSGNESD
SET PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC2^PSGMI(PSGNESD)
SET PSGFD=PSGNEFD
SET PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC2^PSGMI(PSGNEFD)
SET PSGNEWDT=1
+7 IF $DATA(PSGOFD)
IF PSGOFD]""
IF PSGFD'=PSGOFD
SET PSGOEEF(25)=1
+8 IF $DATA(PSGOSD)
IF PSGOSD]""
IF PSGSD'=PSGOSD
SET PSGOEEF(10)=1
End DoDot:1
+9 ;BHW;PSJ*5*179;Add EFD call here, removed from PSGOE91
+10 DO EFDACT^PSJUTL
+11 QUIT
NEW3 ;
+1 ;S:PSGOEAV PSGOEAV="0^1"
NEW ;
+1 IF $DATA(^PS(53.45,+$GET(PSJSYSP),5))
NEW PSJFSI
SET PSJFSI=1
DO FILESI^PSJBCMA5(DFN,PSGORD)
NEW SIARRAY
SET SIARRAY=""
Begin DoDot:1
+2 IF PSGORD["P"
MERGE SIARRAY=^PS(53.1,+PSGORD,15)
DO NEWNVAL^PSGAL5(PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
+3 IF PSGORD["U"
MERGE SIARRAY=^PS(55,DFN,5,+PSGORD,15)
DO NEWUDAL^PSGAL5(PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
End DoDot:1
+4 WRITE !,"...discontinuing original order..."
+5 IF PSGORD["P"
SET PSJCOM=+$PIECE($GET(^PS(53.1,+PSGORD,.2)),"^",8)
IF PSJCOM
DO NEW^PSJCOM1
QUIT
+6 ;DC and Unlock order.
+7 SET PSGEDIT="DE"
DO ENOR^PSGOECS
DO UNL^PSSLOCK(PSGP,PSGORD)
KILL PSGEDIT
+8 WRITE !!," ...creating new order..."
if 'PSGOEAV
WRITE "(you will now work on this new order)"
+9 SET PSGS0Y=PSGAT
SET PSGNESD=PSGSD
SET PSGNEFD=PSGFD
SET PSGOEPR=PSGPR
SET PSGPDRG=PSGPD
SET PSGPDRGN=PSGPDN
SET PSGOEE="E"
+10 SET PSGOORD=PSGORD
DO ^PSGOETO
KILL PSGOEOS
+11 IF PSGOORD["U"
SET $PIECE(^PS(55,PSGP,5,+PSGOORD,0),"^",26,27)=PSGORD_"^E"
+12 IF '$TEST
SET $PIECE(^PS(53.1,+PSGOORD,0),"^",26,27)=PSGORD_"^E"
+13 IF $GET(PSJFSI)
IF $$GETSI^PSJBCMA5(DFN,PSGOORD)
DO FILESI^PSJBCMA5(DFN,PSGORD)
+14 IF 'PSGOEAV
IF ($GET(PSGORD)["P")
IF '$GET(^PS(53.1,+PSGORD,2.5))
IF $GET(^PS(53.1,+PSGORD,0))
Begin DoDot:1
+15 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
+16 IF PSGOEAV
Begin DoDot:1
+17 SET ^TMP("PSODAOC",$JOB,"IP IEN")=PSGORD
+18 ;PSJ*5*281 stores order checks
DO SETOC^PSJNEWOC(PSGORD)
End DoDot:1
+19 IF PSGOEAV
IF +PSJSYSU=3
IF '$DATA(PSGOES)
DO EN^PSGPEN(PSGORD)
DO UNL^PSSLOCK(PSGP,PSGORD)
QUIT
+20 SET PSJORD=PSGORD
SET PSGACT=$$ENACTION^PSGOE1(PSGP,PSGORD)
+21 ;K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J)
+22 QUIT
UPD ;
+1 ;/327*MZR added next line to prevent updating if nothing changed
+2 if $GET(PSGOEE)=0
QUIT
+3 KILL DA
WRITE !!,"...updating order..."
+4 IF PSGORD["P"
SET PSJCOM=+$PIECE($GET(^PS(53.1,+PSGORD,.2)),"^",8)
IF PSJCOM
DO UPD^PSJCOM
QUIT
+5 IF $$DIFFSI^PSJBCMA5(DFN,PSGORD)
Begin DoDot:1
+6 NEW SIARRAY
if PSGORD["P"
MERGE SIARRAY=^PS(53.1,+PSGORD,15)
if PSGORD["U"
MERGE SIARRAY=^PS(55,DFN,5,+PSGORD,15)
+7 if '$DATA(SIARRAY)
QUIT
+8 IF PSGORD["P"
DO NEWNVAL^PSGAL5(PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
+9 IF PSGORD["U"
DO NEWUDAL^PSGAL5(DFN,PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
End DoDot:1
+10 ;check for INDICATION changes and save results to use after filing data
+11 NEW INDCHNG
SET INDCHNG=$$DIFFIND^PSGOE42($GET(DFN),PSGORD,PSGIND)
+12 ; Set trigger for FIELD (12) Dispense Drug to print a updated pick list.
+13 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
+14 NEW PSJX12,PSJF12
SET PSJF12=0
+15 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
+16 if PSJF12
SET ^PS(55,"AUE",PSGP,+PSGORD)=""
End DoDot:1
+17 NEW TMP,PSGSIF
SET TMP=PSGOEENO
NEW PSGOEENO
SET PSGOEENO=TMP
+18 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
+19 IF $GET(PSJCOM)
IF $GET(PSJCOMSI)
KILL PSJCOMSI,^TMP("PSGSI",$JOB)
MERGE ^TMP("PSGSI",$JOB,5)=^PS(53.45,PSJSYSP,5)
Begin DoDot:1
+20 DO FILESI^PSJBCMA5(DFN,PSGORD)
+21 NEW PSJCHILD,PSJOEORD
SET PSJOEORD=0
FOR
SET PSJOEORD=$ORDER(^PS(55,"ACX",PSJCOM,PSJOEORD))
if 'PSJOEORD
QUIT
Begin DoDot:2
+22 SET PSJCHILD=0
FOR
SET PSJCHILD=$ORDER(^PS(55,"ACX",PSJCOM,PSJOEORD,PSJCHILD))
if 'PSJCHILD
QUIT
Begin DoDot:3
+23 IF PSJCHILD=PSGORD
QUIT
+24 NEW DR,DA,DIE,ORD
+25 IF PSJCHILD["V"
SET DR="31////"_$GET(P("OPI"))_";146////"_+$GET(PSGSIF)
+26 ; Direct setting Special Instructions because it can contain ';' which throws off the DR variable for the ^DIE API (PSJ*5*409)
+27 IF PSJCHILD'["V"
Begin DoDot:4
+28 NEW X
SET DR="122////"_+$GET(PSGSIF)
+29 SET X=$GET(PSGSI)
IF X'=""
DO CHKSI^PSSDDUT3
IF $GET(X)'=""
SET $PIECE(^PS(55,DFN,5,+PSJCHILD,6),"^",1)=PSGSI
End DoDot:4
+30 IF '$DATA(^PS(53.45,+$GET(PSJSYSP),5))
MERGE ^PS(53.45,+$GET(PSJSYSP),5)=^TMP("PSGSI",$JOB,5)
+31 DO FILESI^PSJBCMA5(DFN,PSJCHILD)
+32 ;PSJ*5*179 Comment edits
+33 SET DR=$TRANSLATE($GET(DR),"*")
IF 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:3
End DoDot:2
+34 KILL ^TMP("PSGSI",$JOB)
End DoDot:1
+35 ; PSJ*319 changes
+36 NEW OLCLN
+37 SET OLCLN=$SELECT(PSGORD["P":$GET(^PS(53.1,+PSGORD,"DSS")),PSGORD["U":$GET(^PS(55,PSGP,5,+PSGORD,8)),1:"")
+38 IF $PIECE(OLCLN,"^")'=""
IF $GET(P("CLIN"))'=$PIECE(OLCLN,"^")
Begin DoDot:1
+39 IF PSGORD["P"
DO NEWNVAL^PSGAL5(PSGORD,6000,"CLINIC",$PIECE($GET(^SC(+$PIECE(OLCLN,"^"),0)),"^"))
+40 IF PSGORD["U"
DO NEWUDAL^PSGAL5(DFN,PSGORD,6000,"CLINIC",$PIECE($GET(^SC(+$PIECE(OLCLN,"^"),0)),"^"))
End DoDot:1
+41 IF $PIECE(OLCLN,"^",2)'=""
IF $GET(P("APPT"))'=$PIECE(OLCLN,"^",2)
Begin DoDot:1
+42 IF PSGORD["P"
DO NEWNVAL^PSGAL5(PSGORD,6000,"APPOINTMENT DATE/TIME",$PIECE(OLCLN,"^",2))
+43 IF PSGORD["U"
DO NEWUDAL^PSGAL5(DFN,PSGORD,6000,"APPOINTMENT DATE/TIME",$PIECE(OLCLN,"^",2))
End DoDot:1
+44 ; when updating clinic; check if old clinic is PADE, send cancellation for old clinic to PADE
+45 IF PSGORD["U"
IF $GET(P("CLINO"))'=""
IF $GET(P("CLIN"))'=$PIECE(OLCLN,"^")
Begin DoDot:1
+46 NEW PSJPDO,I,PSJAP
+47 SET PSJPDO=1
SET (PSJAP,I)=0
+48 FOR
SET I=$ORDER(^PS(58.7,I))
if 'I
QUIT
SET J=$$PDACT^PSJPDCLA(I)
+49 if 'PSJAP
QUIT
if '$$CHKPDCL^PSJPDCLA($PIECE(OLCLN,"^"))
QUIT
+50 NEW PDTYP,PSJHLDFN,RXO,OSTA
+51 SET OSTA=$PIECE($GET(^PS(55,PSGP,5,+PSGORD,0)),"^",9)
+52 ; temporarliy set status to DC
SET $PIECE(^PS(55,PSGP,5,+PSGORD,0),"^",9)="D"
+53 SET PDTYP="OD"
SET PSJHLDFN=PSGP
SET RXO=PSGORD_$SELECT(+PSGORD=PSGORD:"U",1:"")
+54 DO PDORD^PSJPDCLU
+55 ; reset status
SET $PIECE(^PS(55,PSGP,5,+PSGORD,0),"^",9)=OSTA
End DoDot:1
+56 ; PSJ*319 changes end
+57 ; filing edited data
+58 SET DR=$TRANSLATE(DR,"*")
IF 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 "."
+59 ; add activity log entry for INDICATION after data was filed at the line above
+60 IF +INDCHNG=1
Begin DoDot:1
+61 IF PSGORD["P"
Begin DoDot:2
+62 ;the next line assures that INDICATION is saved despite the issue that DR is set to "" when special instructions are used and the filing code ^DIE code above is not called.
+63 IF DR=""
IF $$GET1^DIQ(53.1,+PSJORD,132,"E")'=$PIECE(INDCHNG,U,3)
SET DR="132////^S X=PSGIND"
SET DA=+PSGORD
SET DIE="^PS(53.1,"
DO ^DIE
WRITE "."
+64 IF $$GET1^DIQ(53.1,+PSJORD,132,"E")=$PIECE(INDCHNG,U,3)
DO NEWNVAL^PSGAL5(PSGORD,6000,"INDICATION",$PIECE(INDCHNG,U,2))
End DoDot:2
QUIT
+65 IF PSGORD["U"
if $$GET1^DIQ(55.06,+PSJORD_","_+DFN_",",141)=$PIECE(INDCHNG,U,3)
DO NEWUDAL^PSGAL5(DFN,PSGORD,6000,"INDICATION",$PIECE(INDCHNG,U,2))
End DoDot:1
+66 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 "."
+67 SET $PIECE(@(PSGOEEWF_"1,0)"),"^",2)=$SELECT(PSGORD["U":55.07,1:53.11)_"P"
+68 IF $DATA(^PS(53.45,+$GET(PSJSYSP),5))
DO FILESI^PSJBCMA5(DFN,PSJORD)
+69 ; Naked reference on the line below refers to full reference using indirection to either ^PS(55 or ^PS(53.1,
+70 ;*315
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))
SET ND2P1=$GET(^(2.1))
WRITE !,"...updating OE/RR..."
DO EN1^PSJHL2(PSGP,"XX",PSGORD)
+71 IF $$ENACTION^PSGOE1(PSGP,PSGORD)["V"
SET VALMBCK="R"
+72 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
+73 ; **This is where the Automated Dispensing Machine hook is called. Do NOT DELETE or change this location **
+74 DO EDIT^PSJADM
+75 ; **END of Interface Hook **
+76 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 ;; START NCC REMEDIATION >> 327*RJS ;/RBN & MZR changed conditions on the next line
+2 IF $GET(PSGEDT)
IF $$GET1^DIQ(55.06,+$GET(PSGORD)_","_DFN,.01,"I")
Begin DoDot:1
+3 NEW CLOZFLG,PSGDRG
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,DFN,+PSGORD)
+4 IF $GET(CLOZFLG)
SET PSGDRG=$PIECE(CLOZFLG,U,2)
Begin DoDot:2
+5 NEW DIE,DA,DR
SET DIE="^PS(55,"_DFN_",5,"
SET DA=+PSGORD
SET DA(1)=DFN
SET DR="301////"
+6 IF $DATA(^TMP("PSJCOM",$JOB,+$GET(PSGORD)))
Begin DoDot:3
+7 SET DR=DR_$GET(^TMP("PSJCOM",$JOB,+PSGORD,"SAND"))
End DoDot:3
KILL ^TMP($JOB,"PSGCLOZ",DFN,+PSGORD,"SAND")
IF 1
+8 IF '$TEST
IF $GET(^TMP($JOB,"PSGCLOZ",DFN,+$GET(PSJORD),"SAND"))
Begin DoDot:3
+9 SET DR=DR_$GET(^TMP($JOB,"PSGCLOZ",DFN,+PSJORD,"SAND"))
End DoDot:3
KILL ^TMP($JOB,"PSGCLOZ",DFN,+PSJORD,"SAND")
IF 1
+10 IF '$TEST
IF $GET(^TMP($JOB,"PSGCLOZ",DFN,+$GET(PSGORD),"SAND"))
Begin DoDot:3
+11 SET DR=DR_$GET(^TMP($JOB,"PSGCLOZ",DFN,+PSGORD,"SAND"))
End DoDot:3
KILL ^TMP($JOB,"PSGCLOZ",DFN,+PSGORD,"SAND")
+12 DO ^DIE
+13 NEW PSGDN
SET PSGDN=PSGDRG
+14 DO PSJFILE^PSJCLOZ(DFN)
DO INPSND^YSCLTST5
End DoDot:2
End DoDot:1
+15 ;; END NCC REMEDIATION >> 327*RJS
+16 IF PSGORD["U"
SET X=+PSGORD
LOCK -^PS(55,PSGP,5,X)
+17 IF '$TEST
LOCK -^PS(53.1,+PSGORD)
+18 KILL ^PS(53.45,+PSJSYSP,1),^(2),^(5),^(6)
+19 IF '$DATA(PSGOEF)
KILL PSGSD,PSGSCH,PSGST,PSGFD
+20 KILL DA,DIE,DIR,DP,DR,DRG,ND,ND0,ND1,ND2,ND2P1,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
+21 ;*399-IND
KILL PSGDO,PSGOEENO,PSGIND
QUIT
K1 ;
+1 ;*399-IND
KILL BACK,F1,F2,PSGF2,MSG,PSGEFN,PSGNEWDT,PSGOEEND,PSGOPD,PSGOPDN,PSGOMR,PSGOMRN,PSGOSCH,PSGOSI,PSGOPR,PSGOSM,PSGOSD,PSGOFD,PSGOST,PSGOPRN,PSGOSTN,PSGOSDN,PSGOFDN,PSGODO,PSGPDRG,PSGPDRGN,PSGOEER,PSGOIND
+2 ; P429 Removed the K PSGOHSM var above
+3 QUIT
+4 ;
ABORT ; Display no change message and pause.
+1 DO FULL^VALM1
+2 SET (PSGDI,PSGDFLG)='$$DDOK^PSGOE2(PSGOEEWF_"1,",+$GET(@(PSGOEEWF_".2)")))
+3 SET PSGPFLG='$$OIOK^PSGOE2(+$GET(@(PSGOEEWF_".2)")))
+4 ;if flag set in PSODGAL1, no repeat message
IF '$GET(PSJRNFLG)
WRITE !!,$CHAR(7),"No changes made to this order."
DO PAUSE^VALM1
+5 KILL PSGOEEF
SET PSGOEEF=0
+6 QUIT
+7 ;
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
+4 ;
ASKOVR(Y,PSJOVRON,PSJSTARI) ; Check to see if any starred fields are being edited. If so, ask if they wish to view overrides/interventions if they exist
+1 if '$DATA(Y)!$DATA(PSJSTARI)
QUIT
NEW II,I3,YY
SET YY=$SELECT(Y:Y,1:$TRANSLATE($PIECE(Y,"^",4),"="))
+2 if 'YY
QUIT
SET PSJOVRON=$SELECT($GET(PSJOVRON):PSJOVRON,1:$GET(PSJORD))
if '$GET(PSJOVRON)
QUIT
+3 NEW PSJORD
SET PSJORD=PSJOVRON
+4 IF '$GET(PSJSTARI)
FOR II=1:1:$LENGTH(YY,",")
if $GET(PSJSTARI)
QUIT
SET I3=$PIECE(YY,",",II)
IF I3
if $GET(PSGEFN(I3))!($GET(PSJSTAR)[("("_I3_")"))
SET PSJSTARI=1
+5 IF $GET(PSJSTARI)
IF ($GET(PSJORD)&$GET(PSGP))
IF $$ASKDISP^PSGSICH1
DO FULL^VALM1
DO OVRDISP^PSGSICH2(PSGP,PSJORD,3)
+6 QUIT
+7 ;
+8 ;*399-IND-314,514
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
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 ;;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
514 ;;132^PSGOE41;PSGOIND;PSGIND;132;0
515 ;;50^PSGOE82;P("CLINO");P("CLIN");130;0
516 ;;51^PSGOE82;P("APPTO");P("APPT");131;0
