PSIVOPT1 ;BIR/MLM - EDIT/DC ORDER (BACKDOOR) ;May 01, 2019@12:56:55
;;5.0;INPATIENT MEDICATIONS ;**29,58,101,110,127,181,258,279,281,319**;16 DEC 97;Build 31
;
; Reference to ^PS(55 is supported by DBIA 2191
; Reference to ^PSSLOCK is supported by DBIA #2789
; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
;
E ; Edit order through Pharmacy.
N PSIEDITO S PSIEDITO=1
D GSTRING^PSIVORE1,GTFLDS^PSIVORFE
I '$G(PSIVENO) S PSIVENO=1 D EN^VALM("PSJ LM IV AC/EDIT") S VALMBCK="Q"
Q
ACCEPT ; To be called by ACCEPT^PSJLIACT
NEW PSIVDSFG
D CKNEW
D:'$G(PSGORQF) DOSING
Q:$G(PSGORQF)
;Don't create new order if Inf rate changed not supposed too set PSIVCHG=1
I PSIVCHG,'$G(PSJEDIT1) D
.S P("OLDON")=ON55,Y=$G(^PS(55,DFN,"IV",+ON55,0)) D NOW^%DTC S P("LOG")=$E(%,1,12) K %
.S P("CLRK")=DUZ_U_$P($G(^VA(200,DUZ,0)),U)
.I $G(PSGSDX)!$G(PSGFDX) Q
.I $P(Y,U,2)=P(2),$P(Y,U,3)=P(3) D ENT^PSIVCAL S X=P(2),%DT="T" D ^%DT S P(2)=$E(Y,1,12),PSJEDIT1=1 D ENSTOP^PSIVCAL
I $G(PSGORQF) S VALMBCK="Q" W !,"Order unchanged." D PAUSE^PSJMISC(1,) Q
D OK^PSIVOPT2
I X["N" S VALMBCK="R" Q
I X["^" D GT55^PSIVORFB W !,"Order unchanged." Q
I $G(P("21FLG"))]"" D CKNEW,@$S(PSIVCHG:"NEWORD",1:"UPDATE") Q:$D(X)
S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) S ON=ON55,OD=P(2)
D:ON["V" EN^PSIVORE
I $G(PSJIVORF),PSIVCHG D EN1^PSJHL2(DFN,"SN",ON55,"NEW ORDER") NEW PSIVXX S PSIVXX=$$LS^PSSLOCK(DFN,ON55)
S ^TMP("PSODAOC",$J,"IP NEW IEN")=ON55
D SETOC^PSJNEWOC(ON55)
S PSIVACEP=1
Q
;
DOSING ;
NEW TMPDRG
;PSIVDSFG is set when changes to fields (except Schedule for continuous IV type) that caused a new order to create.
D TMPDRG^PSJMISC(DFN,$G(ON55),.TMPDRG)
I $S($G(PSIVDSFG):0,$G(PSIVCHG):1,1:0)!$$COMPARE^PSJMISC(.DRG,.TMPDRG,$S(P("DTYP")=1:0,1:1))!$$INFRATE^PSJMISC(DFN,ON55,P(8),P("DTYP")) D
. D IN^PSJOCDS($G(ON),"IV","")
I $G(PSGORQF) S VALMBCK="Q"
Q
CKNEW ; Check if new order is to be created.
N DNE,ND,TDRG,PSJCHG,TMPDRG S (DNE,PSIVCHG,PSIVDSFG)=0
Q:PSIVCHG
D TMPDRG^PSJMISC(DFN,$G(ON55),.TMPDRG)
I $$COMPARE^PSJMISC(.DRG,.TMPDRG,$S(P("DTYP")=1:0,1:1)) S PSIVCHG=1
K TMPDRG
Q:PSIVCHG
F DRGT="AD","SOL" F DRGI=0:0 S DRGI=$O(DRG(DRGT,DRGI)) Q:'DRGI I $P(P("OT"),U)="F",'$P(DRG(DRGT,DRGI),U,5) S P("OT")="I"
;I $G(DRG("AD",0))+$S(P("DTYP")=1:0,1:+$G(DRG("SOL",0)))'=DRG("DRGC") S PSIVCHG=1 Q
S ND(0)=$G(^PS(55,DFN,"IV",+ON55,0)),ND("PD")=$G(^PS(55,DFN,"IV",+ON55,.2))
N X S X=$S($P(ND(0),U,8)["@":$P($P(ND(0),U,8),"@"),1:$P(ND(0),U,8))
S ND=$S($E(P("OT"))="I":$P(ND("PD"),U,1,2)_U,1:"")_$P(ND("PD"),U,3)_U_$S($E(P("OT"))'="I":X_U,1:"")_+$P(ND(0),U,6)_U_$P(ND(0),U,2)_U_$P(ND(0),U,3)
S:ND'=($S($E(P("OT"))="I":+P("PD")_U_$G(P("DO"))_U,1:"")_+P("MR")_U_$S($E(P("OT"))'="I":$S(P(8)["@":$P(P(8),"@"),1:P(8))_U,1:"")_+P(6)_U_P(2)_U_P(3)) PSIVCHG=1
I 'PSIVCHG I $P(ND(0),U,9)'=P(9) S:(P("DTYP")'=1) PSIVDSFG=1 S PSIVCHG=1
;S ND=$S($E(P("OT"))="I":$P(ND("PD"),U,1,2)_U,1:"")_$P(ND("PD"),U,3)_U_$S($E(P("OT"))'="I":X_U,1:"")_+$P(ND(0),U,6)_U_$P(ND(0),U,2)_U_$P(ND(0),U,3)_U_$P(ND(0),U,9)
;S:ND'=($S($E(P("OT"))="I":+P("PD")_U_$G(P("DO"))_U,1:"")_+P("MR")_U_$S($E(P("OT"))'="I":$S(P(8)["@":$P(P(8),"@"),1:P(8))_U,1:"")_+P(6)_U_P(2)_U_P(3)_U_P(9)) PSIVCHG=1
;* S ND=$S($E(P("OT"))="I":$P(ND("PD"),U,1,2)_U,1:"")_$P(ND("PD"),U,3)_U_$S($E(P("OT"))'="I":$P(ND(0),U,8)_U,1:"")_+$P(ND(0),U,6)_U_$P(ND(0),U,2)_U_$P(ND(0),U,3)_U_$P(ND(0),U,9)
;* S:ND'=($S($E(P("OT"))="I":+P("PD")_U_$G(P("DO"))_U,1:"")_+P("MR")_U_$S($E(P("OT"))'="I":P(8)_U,1:"")_+P(6)_U_P(2)_U_P(3)_U_P(9)) PSIVCHG=1
Q
;
UPDATE ; Update original order.
I '$G(PSJSYSP) N PSJSYSP S PSJSYSP=$S($G(DUZ):DUZ,1:$J)
N PSJIBDT,PSJINIV S PSJINIV=0
S PSIVALT=1,PSIVALCK="EN",PSIVREA="E",ON=ON55 K P("OLDON") D LOG^PSIVORAL
; PSJ*319 when updating clinic; check if old clinic is PADE, send cancellation for old clinic to PADE
N OLCLN
S OLCLN=$G(^PS(55,DFN,"IV",+ON55,"DSS")),OLCLN=$P(OLCLN,"^")
I $P(OLCLN,"^")'="",$G(P("CLIN"))'=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
.I '$$CHKPDCL^PSJPDCLA(OLCLN) Q
.N PDTYP,PSJHLDFN,RXO,OSTA
.S OSTA=$P($G(^PS(55,DFN,"IV",+ON55,0)),"^",17)
.S $P(^PS(55,DFN,"IV",+ON55,0),"^",17)="D" ; temporarliy set status to DC
.S PDTYP="OD",PSJHLDFN=PSGP,RXO=ON55
.D PDORD^PSJPDCLU
.S $P(^PS(55,DFN,"IV",+ON55,0),"^",17)=OSTA ; reset status
; PSJ*319 changes end
D SET55^PSIVORFB I $G(P("NUMLBL")) S $P(^PS(55,DFN,"IV",+ON55,11),"^")=$G(P("NUMLBL")) K P("NUMLBL")
D PSBPOIV^PSJIBAG(DFN,ON55,,.PSJINIV)
D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"E")
D:'$D(PSJIVORF) ORPARM^PSIVOREN K X Q:'PSJIVORF
S PSJORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'PSJORIFN
S P("NAT")=""
D EN1^PSJHL2(DFN,"XX",+ON55_"V","UPDATED ORDER")
I $G(PSJINIV),'$G(PSIVCHG) W ! D
.N DIR,X,Y,PSJIRPLB S DIR(0)="Y",DIR("B")="NO",DIR("A")="Print new replacement labels",DIR("?")="Enter YES to print new IV labels to replace inactivated IV labels" D ^DIR
.I ($G(Y)>0) K DIR S PSJIRPLB=1 D ^PSIVORE1
K X
Q
;
NEWORD ; DC orig. order, get new order no.
N PSJIBDT,PSIEDFIR S PSJIBDT=1
D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D NATURE^PSIVOREN I '$D(P("NAT")) S X=1 W !,"Order unchanged." Q
S P("RES")="E",P("OLDON")=$S($G(PSIVCOPY)=2:"",1:ON55),P(16)="" ; INC000000801240 / MWA (VMP)
S PSJAGYSV=1
Q:$$NONVF()
I '($G(PSIVCOPY)=2) K ON55 D NEW55^PSIVORFB
S (P("PON"),P("NEWON"),ON)=ON55,ON55=P("OLDON") S:($G(PSIVCOPY)=2) P("OLDON")=""
I $P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)="A" D D1^PSIVOPT2 D
. I PSJIVORF,$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) S PSIEDFIR=1 D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED") K PSIEDFIR
. S P("21FLG")="" W !!,"Original order discontinued...",!!
. D UNL^PSSLOCK(DFN,+ON55_"V")
F ON55=P("NEWON"),P("OLDON") K DA,DIE,DR D
.S DA(1)=DFN,DA=+ON55,DIE="^PS(55,"_DFN_",""IV"",",DR=$S((ON55=P("NEWON")&(+ON55'=+P("OLDON"))):"113////"_P("OLDON")_";122////E",1:"114////"_P("NEWON")_";123////E") D ^DIE
.I ON55=P("NEWON") N CLINAPPT S CLINAPPT=$G(^PS(55,DFN,"IV",+P("OLDON"),"DSS")) D
..S:CLINAPPT DR=DR_";136////"_+CLINAPPT S:$P(CLINAPPT,"^",2) DR=DR_";139////"_$P(CLINAPPT,"^",2)
.D ^DIE
.Q:ON55=P("OLDON")&($P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)'="D")
.D:ON55=P("NEWON") SET55^PSIVORFB
.D:ON55=P("NEWON") VF1^PSJLIACT("","",0)
.D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$S(ON55=P("NEWON"):"N",1:"DE"))
.S PSIVREA="E",PSIVAL="Order "_$S(ON55=P("OLDON"):"discontinued",1:"created")_" due to edit" S:ON55=P("OLDON") PSIVALCK="STOP" D LOG^PSIVORAL
L -^PS(55,DFN,"IV",+P("OLDON")) ;D NEWENT^PSIVORFE
K X S ON55=P("NEWON"),P(17)="A" Q:'PSJIVORF D SET^PSIVORFE
Q
;
NEWSTOP ; Set stop date for DC and renewals.
S ND=$G(^PS(55,DFN,"IV",+ON55,0)),Y=+$P(ND,U,3),$P(^PS(55,DFN,"IV",+P("OLDON"),2),U,7)=Y,NSTOP=$S(NSTOP>Y:Y,1:NSTOP),$P(^PS(55,DFN,"IV",+ON55,0),U,3)=NSTOP
K DA,DIK S DIK="^PS(55,"_DFN_",""IV"",",DA(1)=DFN,DA=+P("OLDON") D IX^DIK K DA,DIK
Q
NONVF() ;
NEW PSGOEAV S PSGOEAV=+$P(PSJSYSP0,U,9)
I +PSJSYSU=3,PSGOEAV Q 0
I +PSJSYSU=1,PSGOEAV Q 0
K DA D ENGNN^PSGOETO S (ON,P("NEWON"))=DA_"P",P(17)="N"
S (P("DO"),P("PD"))=""
D GTPD^PSIVORE2,PUT531^PSIVORFA
I $P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)="A" D D1^PSIVOPT2 D
. I PSJIVORF,$P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,21) D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED")
. S P("21FLG")="" W !!,"Original order discontinued...",!!
. D UNL^PSSLOCK(DFN,+P("OLDON")_"V")
F ON55=P("NEWON"),P("OLDON") K DA,DIE,DR D
. S DA=+ON55
. S:ON55=P("NEWON") DIE="^PS(53.1,",DR="104////"_P("OLDON")_";103////E"
. S:ON55=P("OLDON") DA(1)=DFN,DIE="^PS(55,"_DFN_",""IV"",",DR="114////"_P("NEWON")_";123////E"
. D ^DIE
. Q:ON55=P("OLDON")&($P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)'="D")
. I ON55=P("OLDON") D
.. D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$S(ON55=P("NEWON"):"N",1:"DE"))
.. S PSIVALT="",PSIVREA="E",PSIVAL="Order discontinued due to edit" S PSIVALCK="STOP" D LOG^PSIVORAL
. I ON55=P("NEWON") D NEWNVAL^PSGAL5(ON55,4100,"","") I $G(PSJIBDT)?7N1"."1.N D NEWNVAL^PSGAL5(ON55,6000,"LABEL INVALID DATE",PSJIBDT)
L -^PS(55,DFN,"IV",+P("OLDON"))
K X S (ON,ON55)=P("NEWON")
D EN1^PSJHL2(DFN,"SN",ON,"ORDER CREATED")
S ^TMP("PSODAOC",$J,"IP NEW IEN")=ON
;RTC 178789 - not to store allergy OC until either verify or quit as non-vf order
;D SETOC^PSJNEWOC(ON)
S X=$$LS^PSSLOCK(DFN,ON)
D GT531^PSIVORFA(DFN,ON)
I ON["P" N CLINAPPT S CLINAPPT=$G(^PS(55,DFN,"IV",+ON,"DSS")) I CLINAPPT D K DIE,DA,DR
. S:CLINAPPT DR="136////"_+CLINAPPT_";" S:$P(CLINAPPT,"^",2) DR=DR_"139////"_$P(CLINAPPT,"^",2)_";" D ^DIE
S VALMBCK="Q"
S PSGACT="EL"
I P(17)="N",(P("OLDON")=""),(P("CLRK")=DUZ) S PSGACT="ELD"
I +PSJSYSU=3!(+PSJSYSU=1) S PSGACT="DELV"
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVOPT1 8798 printed Sep 23, 2025@19:40:37 Page 2
PSIVOPT1 ;BIR/MLM - EDIT/DC ORDER (BACKDOOR) ;May 01, 2019@12:56:55
+1 ;;5.0;INPATIENT MEDICATIONS ;**29,58,101,110,127,181,258,279,281,319**;16 DEC 97;Build 31
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191
+4 ; Reference to ^PSSLOCK is supported by DBIA #2789
+5 ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
+6 ;
E ; Edit order through Pharmacy.
+1 NEW PSIEDITO
SET PSIEDITO=1
+2 DO GSTRING^PSIVORE1
DO GTFLDS^PSIVORFE
+3 IF '$GET(PSIVENO)
SET PSIVENO=1
DO EN^VALM("PSJ LM IV AC/EDIT")
SET VALMBCK="Q"
+4 QUIT
ACCEPT ; To be called by ACCEPT^PSJLIACT
+1 NEW PSIVDSFG
+2 DO CKNEW
+3 if '$GET(PSGORQF)
DO DOSING
+4 if $GET(PSGORQF)
QUIT
+5 ;Don't create new order if Inf rate changed not supposed too set PSIVCHG=1
+6 IF PSIVCHG
IF '$GET(PSJEDIT1)
Begin DoDot:1
+7 SET P("OLDON")=ON55
SET Y=$GET(^PS(55,DFN,"IV",+ON55,0))
DO NOW^%DTC
SET P("LOG")=$EXTRACT(%,1,12)
KILL %
+8 SET P("CLRK")=DUZ_U_$PIECE($GET(^VA(200,DUZ,0)),U)
+9 IF $GET(PSGSDX)!$GET(PSGFDX)
QUIT
+10 IF $PIECE(Y,U,2)=P(2)
IF $PIECE(Y,U,3)=P(3)
DO ENT^PSIVCAL
SET X=P(2)
SET %DT="T"
DO ^%DT
SET P(2)=$EXTRACT(Y,1,12)
SET PSJEDIT1=1
DO ENSTOP^PSIVCAL
End DoDot:1
+11 IF $GET(PSGORQF)
SET VALMBCK="Q"
WRITE !,"Order unchanged."
DO PAUSE^PSJMISC(1,)
QUIT
+12 DO OK^PSIVOPT2
+13 IF X["N"
SET VALMBCK="R"
QUIT
+14 IF X["^"
DO GT55^PSIVORFB
WRITE !,"Order unchanged."
QUIT
+15 IF $GET(P("21FLG"))]""
DO CKNEW
DO @$SELECT(PSIVCHG:"NEWORD",1:"UPDATE")
if $DATA(X)
QUIT
+16 SET PSJORL=$$ENORL^PSJUTL($GET(VAIN(4)))
SET ON=ON55
SET OD=P(2)
+17 if ON["V"
DO EN^PSIVORE
+18 IF $GET(PSJIVORF)
IF PSIVCHG
DO EN1^PSJHL2(DFN,"SN",ON55,"NEW ORDER")
NEW PSIVXX
SET PSIVXX=$$LS^PSSLOCK(DFN,ON55)
+19 SET ^TMP("PSODAOC",$JOB,"IP NEW IEN")=ON55
+20 DO SETOC^PSJNEWOC(ON55)
+21 SET PSIVACEP=1
+22 QUIT
+23 ;
DOSING ;
+1 NEW TMPDRG
+2 ;PSIVDSFG is set when changes to fields (except Schedule for continuous IV type) that caused a new order to create.
+3 DO TMPDRG^PSJMISC(DFN,$GET(ON55),.TMPDRG)
+4 IF $SELECT($GET(PSIVDSFG):0,$GET(PSIVCHG):1,1:0)!$$COMPARE^PSJMISC(.DRG,.TMPDRG,$SELECT(P("DTYP")=1:0,1:1))!$$INFRATE^PSJMISC(DFN,ON55,P(8),P("DTYP"))
Begin DoDot:1
+5 DO IN^PSJOCDS($GET(ON),"IV","")
End DoDot:1
+6 IF $GET(PSGORQF)
SET VALMBCK="Q"
+7 QUIT
CKNEW ; Check if new order is to be created.
+1 NEW DNE,ND,TDRG,PSJCHG,TMPDRG
SET (DNE,PSIVCHG,PSIVDSFG)=0
+2 if PSIVCHG
QUIT
+3 DO TMPDRG^PSJMISC(DFN,$GET(ON55),.TMPDRG)
+4 IF $$COMPARE^PSJMISC(.DRG,.TMPDRG,$SELECT(P("DTYP")=1:0,1:1))
SET PSIVCHG=1
+5 KILL TMPDRG
+6 if PSIVCHG
QUIT
+7 FOR DRGT="AD","SOL"
FOR DRGI=0:0
SET DRGI=$ORDER(DRG(DRGT,DRGI))
if 'DRGI
QUIT
IF $PIECE(P("OT"),U)="F"
IF '$PIECE(DRG(DRGT,DRGI),U,5)
SET P("OT")="I"
+8 ;I $G(DRG("AD",0))+$S(P("DTYP")=1:0,1:+$G(DRG("SOL",0)))'=DRG("DRGC") S PSIVCHG=1 Q
+9 SET ND(0)=$GET(^PS(55,DFN,"IV",+ON55,0))
SET ND("PD")=$GET(^PS(55,DFN,"IV",+ON55,.2))
+10 NEW X
SET X=$SELECT($PIECE(ND(0),U,8)["@":$PIECE($PIECE(ND(0),U,8),"@"),1:$PIECE(ND(0),U,8))
+11 SET ND=$SELECT($EXTRACT(P("OT"))="I":$PIECE(ND("PD"),U,1,2)_U,1:"")_$PIECE(ND("PD"),U,3)_U_$SELECT($EXTRACT(P("OT"))'="I":X_U,1:"")_+$PIECE(ND(0),U,6)_U_$PIECE(ND(0),U,2)_U_$PIECE(ND(0),U,3)
+12 if ND'=($SELECT($EXTRACT(P("OT"))="I"
SET PSIVCHG=1
+13 IF 'PSIVCHG
IF $PIECE(ND(0),U,9)'=P(9)
if (P("DTYP")'=1)
SET PSIVDSFG=1
SET PSIVCHG=1
+14 ;S ND=$S($E(P("OT"))="I":$P(ND("PD"),U,1,2)_U,1:"")_$P(ND("PD"),U,3)_U_$S($E(P("OT"))'="I":X_U,1:"")_+$P(ND(0),U,6)_U_$P(ND(0),U,2)_U_$P(ND(0),U,3)_U_$P(ND(0),U,9)
+15 ;S:ND'=($S($E(P("OT"))="I":+P("PD")_U_$G(P("DO"))_U,1:"")_+P("MR")_U_$S($E(P("OT"))'="I":$S(P(8)["@":$P(P(8),"@"),1:P(8))_U,1:"")_+P(6)_U_P(2)_U_P(3)_U_P(9)) PSIVCHG=1
+16 ;* S ND=$S($E(P("OT"))="I":$P(ND("PD"),U,1,2)_U,1:"")_$P(ND("PD"),U,3)_U_$S($E(P("OT"))'="I":$P(ND(0),U,8)_U,1:"")_+$P(ND(0),U,6)_U_$P(ND(0),U,2)_U_$P(ND(0),U,3)_U_$P(ND(0),U,9)
+17 ;* S:ND'=($S($E(P("OT"))="I":+P("PD")_U_$G(P("DO"))_U,1:"")_+P("MR")_U_$S($E(P("OT"))'="I":P(8)_U,1:"")_+P(6)_U_P(2)_U_P(3)_U_P(9)) PSIVCHG=1
+18 QUIT
+19 ;
UPDATE ; Update original order.
+1 IF '$GET(PSJSYSP)
NEW PSJSYSP
SET PSJSYSP=$SELECT($GET(DUZ):DUZ,1:$JOB)
+2 NEW PSJIBDT,PSJINIV
SET PSJINIV=0
+3 SET PSIVALT=1
SET PSIVALCK="EN"
SET PSIVREA="E"
SET ON=ON55
KILL P("OLDON")
DO LOG^PSIVORAL
+4 ; PSJ*319 when updating clinic; check if old clinic is PADE, send cancellation for old clinic to PADE
+5 NEW OLCLN
+6 SET OLCLN=$GET(^PS(55,DFN,"IV",+ON55,"DSS"))
SET OLCLN=$PIECE(OLCLN,"^")
+7 IF $PIECE(OLCLN,"^")'=""
IF $GET(P("CLIN"))'=OLCLN
Begin DoDot:1
+8 NEW PSJPDO,I,PSJAP
+9 SET PSJPDO=1
SET (PSJAP,I)=0
+10 FOR
SET I=$ORDER(^PS(58.7,I))
if 'I
QUIT
SET J=$$PDACT^PSJPDCLA(I)
+11 if 'PSJAP
QUIT
+12 IF '$$CHKPDCL^PSJPDCLA(OLCLN)
QUIT
+13 NEW PDTYP,PSJHLDFN,RXO,OSTA
+14 SET OSTA=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),"^",17)
+15 ; temporarliy set status to DC
SET $PIECE(^PS(55,DFN,"IV",+ON55,0),"^",17)="D"
+16 SET PDTYP="OD"
SET PSJHLDFN=PSGP
SET RXO=ON55
+17 DO PDORD^PSJPDCLU
+18 ; reset status
SET $PIECE(^PS(55,DFN,"IV",+ON55,0),"^",17)=OSTA
End DoDot:1
+19 ; PSJ*319 changes end
+20 DO SET55^PSIVORFB
IF $GET(P("NUMLBL"))
SET $PIECE(^PS(55,DFN,"IV",+ON55,11),"^")=$GET(P("NUMLBL"))
KILL P("NUMLBL")
+21 DO PSBPOIV^PSJIBAG(DFN,ON55,,.PSJINIV)
+22 DO ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"E")
+23 if '$DATA(PSJIVORF)
DO ORPARM^PSIVOREN
KILL X
if 'PSJIVORF
QUIT
+24 SET PSJORIFN=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,21)
if 'PSJORIFN
QUIT
+25 SET P("NAT")=""
+26 DO EN1^PSJHL2(DFN,"XX",+ON55_"V","UPDATED ORDER")
+27 IF $GET(PSJINIV)
IF '$GET(PSIVCHG)
WRITE !
Begin DoDot:1
+28 NEW DIR,X,Y,PSJIRPLB
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Print new replacement labels"
SET DIR("?")="Enter YES to print new IV labels to replace inactivated IV labels"
DO ^DIR
+29 IF ($GET(Y)>0)
KILL DIR
SET PSJIRPLB=1
DO ^PSIVORE1
End DoDot:1
+30 KILL X
+31 QUIT
+32 ;
NEWORD ; DC orig. order, get new order no.
+1 NEW PSJIBDT,PSIEDFIR
SET PSJIBDT=1
+2 if '$DATA(PSJIVORF)
DO ORPARM^PSIVOREN
IF PSJIVORF
DO NATURE^PSIVOREN
IF '$DATA(P("NAT"))
SET X=1
WRITE !,"Order unchanged."
QUIT
+3 ; INC000000801240 / MWA (VMP)
SET P("RES")="E"
SET P("OLDON")=$SELECT($GET(PSIVCOPY)=2:"",1:ON55)
SET P(16)=""
+4 SET PSJAGYSV=1
+5 if $$NONVF()
QUIT
+6 IF '($GET(PSIVCOPY)=2)
KILL ON55
DO NEW55^PSIVORFB
+7 SET (P("PON"),P("NEWON"),ON)=ON55
SET ON55=P("OLDON")
if ($GET(PSIVCOPY)=2)
SET P("OLDON")=""
+8 IF $PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)="A"
DO D1^PSIVOPT2
Begin DoDot:1
+9 IF PSJIVORF
IF $PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,21)
SET PSIEDFIR=1
DO EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED")
KILL PSIEDFIR
+10 SET P("21FLG")=""
WRITE !!,"Original order discontinued...",!!
+11 DO UNL^PSSLOCK(DFN,+ON55_"V")
End DoDot:1
+12 FOR ON55=P("NEWON"),P("OLDON")
KILL DA,DIE,DR
Begin DoDot:1
+13 SET DA(1)=DFN
SET DA=+ON55
SET DIE="^PS(55,"_DFN_",""IV"","
SET DR=$SELECT((ON55=P("NEWON")&(+ON55'=+P("OLDON"))):"113////"_P("OLDON")_";122////E",1:"114////"_P("NEWON")_";123////E")
DO ^DIE
+14 IF ON55=P("NEWON")
NEW CLINAPPT
SET CLINAPPT=$GET(^PS(55,DFN,"IV",+P("OLDON"),"DSS"))
Begin DoDot:2
+15 if CLINAPPT
SET DR=DR_";136////"_+CLINAPPT
if $PIECE(CLINAPPT,"^",2)
SET DR=DR_";139////"_$PIECE(CLINAPPT,"^",2)
End DoDot:2
+16 DO ^DIE
+17 if ON55=P("OLDON")&($PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)'="D")
QUIT
+18 if ON55=P("NEWON")
DO SET55^PSIVORFB
+19 if ON55=P("NEWON")
DO VF1^PSJLIACT("","",0)
+20 DO ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$SELECT(ON55=P("NEWON"):"N",1:"DE"))
+21 SET PSIVREA="E"
SET PSIVAL="Order "_$SELECT(ON55=P("OLDON"):"discontinued",1:"created")_" due to edit"
if ON55=P("OLDON")
SET PSIVALCK="STOP"
DO LOG^PSIVORAL
End DoDot:1
+22 ;D NEWENT^PSIVORFE
LOCK -^PS(55,DFN,"IV",+P("OLDON"))
+23 KILL X
SET ON55=P("NEWON")
SET P(17)="A"
if 'PSJIVORF
QUIT
DO SET^PSIVORFE
+24 QUIT
+25 ;
NEWSTOP ; Set stop date for DC and renewals.
+1 SET ND=$GET(^PS(55,DFN,"IV",+ON55,0))
SET Y=+$PIECE(ND,U,3)
SET $PIECE(^PS(55,DFN,"IV",+P("OLDON"),2),U,7)=Y
SET NSTOP=$SELECT(NSTOP>Y:Y,1:NSTOP)
SET $PIECE(^PS(55,DFN,"IV",+ON55,0),U,3)=NSTOP
+2 KILL DA,DIK
SET DIK="^PS(55,"_DFN_",""IV"","
SET DA(1)=DFN
SET DA=+P("OLDON")
DO IX^DIK
KILL DA,DIK
+3 QUIT
NONVF() ;
+1 NEW PSGOEAV
SET PSGOEAV=+$PIECE(PSJSYSP0,U,9)
+2 IF +PSJSYSU=3
IF PSGOEAV
QUIT 0
+3 IF +PSJSYSU=1
IF PSGOEAV
QUIT 0
+4 KILL DA
DO ENGNN^PSGOETO
SET (ON,P("NEWON"))=DA_"P"
SET P(17)="N"
+5 SET (P("DO"),P("PD"))=""
+6 DO GTPD^PSIVORE2
DO PUT531^PSIVORFA
+7 IF $PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)="A"
DO D1^PSIVOPT2
Begin DoDot:1
+8 IF PSJIVORF
IF $PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),0)),U,21)
DO EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED")
+9 SET P("21FLG")=""
WRITE !!,"Original order discontinued...",!!
+10 DO UNL^PSSLOCK(DFN,+P("OLDON")_"V")
End DoDot:1
+11 FOR ON55=P("NEWON"),P("OLDON")
KILL DA,DIE,DR
Begin DoDot:1
+12 SET DA=+ON55
+13 if ON55=P("NEWON")
SET DIE="^PS(53.1,"
SET DR="104////"_P("OLDON")_";103////E"
+14 if ON55=P("OLDON")
SET DA(1)=DFN
SET DIE="^PS(55,"_DFN_",""IV"","
SET DR="114////"_P("NEWON")_";123////E"
+15 DO ^DIE
+16 if ON55=P("OLDON")&($PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)'="D")
QUIT
+17 IF ON55=P("OLDON")
Begin DoDot:2
+18 DO ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$SELECT(ON55=P("NEWON"):"N",1:"DE"))
+19 SET PSIVALT=""
SET PSIVREA="E"
SET PSIVAL="Order discontinued due to edit"
SET PSIVALCK="STOP"
DO LOG^PSIVORAL
End DoDot:2
+20 IF ON55=P("NEWON")
DO NEWNVAL^PSGAL5(ON55,4100,"","")
IF $GET(PSJIBDT)?7N1"."1.N
DO NEWNVAL^PSGAL5(ON55,6000,"LABEL INVALID DATE",PSJIBDT)
End DoDot:1
+21 LOCK -^PS(55,DFN,"IV",+P("OLDON"))
+22 KILL X
SET (ON,ON55)=P("NEWON")
+23 DO EN1^PSJHL2(DFN,"SN",ON,"ORDER CREATED")
+24 SET ^TMP("PSODAOC",$JOB,"IP NEW IEN")=ON
+25 ;RTC 178789 - not to store allergy OC until either verify or quit as non-vf order
+26 ;D SETOC^PSJNEWOC(ON)
+27 SET X=$$LS^PSSLOCK(DFN,ON)
+28 DO GT531^PSIVORFA(DFN,ON)
+29 IF ON["P"
NEW CLINAPPT
SET CLINAPPT=$GET(^PS(55,DFN,"IV",+ON,"DSS"))
IF CLINAPPT
Begin DoDot:1
+30 if CLINAPPT
SET DR="136////"_+CLINAPPT_";"
if $PIECE(CLINAPPT,"^",2)
SET DR=DR_"139////"_$PIECE(CLINAPPT,"^",2)_";"
DO ^DIE
End DoDot:1
KILL DIE,DA,DR
+31 SET VALMBCK="Q"
+32 SET PSGACT="EL"
+33 IF P(17)="N"
IF (P("OLDON")="")
IF (P("CLRK")=DUZ)
SET PSGACT="ELD"
+34 IF +PSJSYSU=3!(+PSJSYSU=1)
SET PSGACT="DELV"
+35 QUIT 1
