PSIVOD ;BIR/JCH-CREATE NEW IV ORDER FROM OLD ONE ;25 Nov 98 / 3:34 PM
;;5.0;INPATIENT MEDICATIONS;**110,127,181,281,256**;16 DEC 97;Build 34
;
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^ORX2 is supported by DBIA 867.
;
COPY(DFN,OLDON) ;Ask to enter new order.
N PSIVOORD,OLDP,PSIVCOPY,PSGCOPY,I,% M OLDP=P
Q:'$$HIDDEN^PSJLMUTL("COPY") D ^PSJHVARS
I $P($G(^PS(55,PSGP,"IV",+PSGORD,.2)),U,4)="D",'$P($G(^(4)),"^",3) D G Q
.W !!,"Nurse verified orders with a priority of DONE may not be Copied." D PAUSE^VALM1 Q
S PSGOEAV=$P(PSJSYSP0,U,9)&PSJSYSU S PSIVOORD=PSJORD
D FULL^VALM1
F W !!,"Do you want to copy this order" S %=2 D YN^DICN Q:% D CH
G:%'=1 Q
S P("RES")="N",PSIVAC="PN",P("PON")=ON55,PSIVUP=+$$GTPCI^PSIVUTL,PSJORD=ON55,PSGORD=PSJORD
N OLDACT,PSIVCHG S OLDACT=PSGACT S PSGACT=PSGACT_"E",P(17)="N",(P("LOG"),P("LF"))="",P(21)="" K P("NAT")
S:'$G(PSGDT) PSGDT=$$DATE^PSJUTL2() S P("LOG")=PSGDT,P("PRNTON")=""
;PSJ*5*256
NEW PSJOLDNM
S PSJOLDNM("ORD_SCHD")=$G(P(9))
I $$CHKSCHD^PSJMISC2(.PSJOLDNM) W !!,"Order not copied." D PAUSE^VALM1 K PSJOLDNM G Q
S:$G(PSJOLDNM("NEW_SCHD"))]"" P(9)=PSJOLDNM("NEW_SCHD") K PSJOLDNM
D ENT^PSIVCAL,ENSTOP^PSIVCAL S ND4="^^^^" F I=5,6,8,9 S $P(ND2,"^",I)=""
S P(17)=$S($G(PSGOEAV):"A",1:"N") S P("CLRK")=DUZ_"^"_$P($G(^VA(200,+DUZ,0)),"^")
S PSIVCHG=0,PSJNEWOE=0,PSIVCOPY=1,VALMBCK="Q" K PSIVACEP
NEW PSGORQF K PSGORQF D OC^PSIVOC G:$G(PSGORQF) Q
N PSGORD,ON,ON55,PSJORD D NEW55^PSIVORFB S (PSJORD,ON)=ON55,PSIVCOPY=2
D EN^VALM("PSJ LM IV AC/EDIT")
I $G(P("NAT"))=""&($G(PSJORNAT)="") D G Q
.D FULL^VALM1 W !!,"Order not copied" D PAUSE^VALM1
W !!,"...copying..."
;RTC 178789 - not to store allergy OC until either verify or quit as non-vf order
;D SETOC^PSJNEWOC(ON55)
;
I '$G(PSGOEAV) D INMED
;
D FULL^VALM1 W !!?5,"You are finished with the new order.",!,"The following ACTION prompt is for the original order." D PAUSE^VALM1
Q ; Kill and exit.
L:'$D(PSJOE) -^PS(53.45,DUZ) S PSJNKF=1 D Q^PSIV
K FIL,I1,ND,PC,PDM,PSGDT,PSGID,PSGLMT,PSGSI,PSJNARC,PSIVAC,PSIVCHG,PSIVUP,PSIVX,PSJOPC,PSJAGYSV
S VALMBCK="R"
I '$G(PSGDT) S PSGDT=$$DATE^PSJUTL2
S PSGACT=$$ENACTION^PSGOE1(PSGP,PSIVOORD) ; resets PSGACT after copy
D RESTORE^PSJHVARS
K P M P=OLDP
Q
;
INMED ;
K PSJACEPT S VALMBCK="Q",PSIVCOPY=2,PSIVCHG=0 ;D ACEDIT^PSJLIACT
N ON55TMP,P21TMP S ON55TMP=ON55,P21TMP=$G(P(21)) S P(21)="" I $G(ON55)["P",($G(PSJORD)["V") S ON55=PSJORD
D DEL55^PSIVORE2 I $G(ON55TMP)]"" S ON55=ON55TMP,P(21)=P21TMP
;S (PSJORNAT,P("NAT"))="W"
;D OK^PSIVORE
D EN^VALM("PSJ LM IV INPT ACTIVE")
;RTC 178789 - Store allergy OC as non-vf order
D:$G(ON55)["P" SETOC^PSJNEWOC($G(ON55))
L -^PS(55,DFN,"IV",+ON55) D ULK
I $G(P("NAT"))="" D G Q
.D FULL^VALM1 W !!,"Order not copied" D PAUSE^VALM1
Q
ULK ;
Q:'$G(PSJLSORX) ;If NEW^PSIVORE did not lock, don't kill it here.
NEW X S X=DFN_";DPT(" D ULK^ORX2 K PSJLSORX
Q
HK ;Queue job to print MAR labels generated for this patient.
I PSGOP,PSGOP'=DFN D
.N PSJACPF,PSJACNWP,PSJPWD,PSJSYSL,PSJSYSW,PSJSYSW0,DFN,VAIN,VAERR S DFN=PSGOP
.D INP^VADPT S PSJPWD=+VAIN(4) I PSJPWD S PSJACPF=10 S PSJACPF=10 D WP^PSJAC D:$P(PSJSYSL,U,2)]"" ENQL^PSGLW
S PSGOP=DFN
Q
;
SPSOL S SPSOL=0 F XXX=0:0 S XXX=$O(^PS(55,DFN,"IV",+ON55,"SOL",XXX)) Q:'XXX S SPSOL=SPSOL+$P(^(XXX,0),U,2)
K XXX Q
CH ;
W !!?2,"Answer 'YES' to have a new, non-verified order created for this patient,"
W !,"using the information from this order. (The START and STOP dates will be",!,"recalculated.) Enter 'NO' (or '^') to stop now."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVOD 3619 printed Oct 16, 2024@18:05:14 Page 2
PSIVOD ;BIR/JCH-CREATE NEW IV ORDER FROM OLD ONE ;25 Nov 98 / 3:34 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**110,127,181,281,256**;16 DEC 97;Build 34
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191.
+4 ; Reference to ^ORX2 is supported by DBIA 867.
+5 ;
COPY(DFN,OLDON) ;Ask to enter new order.
+1 NEW PSIVOORD,OLDP,PSIVCOPY,PSGCOPY,I,%
MERGE OLDP=P
+2 if '$$HIDDEN^PSJLMUTL("COPY")
QUIT
DO ^PSJHVARS
+3 IF $PIECE($GET(^PS(55,PSGP,"IV",+PSGORD,.2)),U,4)="D"
IF '$PIECE($GET(^(4)),"^",3)
Begin DoDot:1
+4 WRITE !!,"Nurse verified orders with a priority of DONE may not be Copied."
DO PAUSE^VALM1
QUIT
End DoDot:1
GOTO Q
+5 SET PSGOEAV=$PIECE(PSJSYSP0,U,9)&PSJSYSU
SET PSIVOORD=PSJORD
+6 DO FULL^VALM1
+7 FOR
WRITE !!,"Do you want to copy this order"
SET %=2
DO YN^DICN
if %
QUIT
DO CH
+8 if %'=1
GOTO Q
+9 SET P("RES")="N"
SET PSIVAC="PN"
SET P("PON")=ON55
SET PSIVUP=+$$GTPCI^PSIVUTL
SET PSJORD=ON55
SET PSGORD=PSJORD
+10 NEW OLDACT,PSIVCHG
SET OLDACT=PSGACT
SET PSGACT=PSGACT_"E"
SET P(17)="N"
SET (P("LOG"),P("LF"))=""
SET P(21)=""
KILL P("NAT")
+11 if '$GET(PSGDT)
SET PSGDT=$$DATE^PSJUTL2()
SET P("LOG")=PSGDT
SET P("PRNTON")=""
+12 ;PSJ*5*256
+13 NEW PSJOLDNM
+14 SET PSJOLDNM("ORD_SCHD")=$GET(P(9))
+15 IF $$CHKSCHD^PSJMISC2(.PSJOLDNM)
WRITE !!,"Order not copied."
DO PAUSE^VALM1
KILL PSJOLDNM
GOTO Q
+16 if $GET(PSJOLDNM("NEW_SCHD"))]""
SET P(9)=PSJOLDNM("NEW_SCHD")
KILL PSJOLDNM
+17 DO ENT^PSIVCAL
DO ENSTOP^PSIVCAL
SET ND4="^^^^"
FOR I=5,6,8,9
SET $PIECE(ND2,"^",I)=""
+18 SET P(17)=$SELECT($GET(PSGOEAV):"A",1:"N")
SET P("CLRK")=DUZ_"^"_$PIECE($GET(^VA(200,+DUZ,0)),"^")
+19 SET PSIVCHG=0
SET PSJNEWOE=0
SET PSIVCOPY=1
SET VALMBCK="Q"
KILL PSIVACEP
+20 NEW PSGORQF
KILL PSGORQF
DO OC^PSIVOC
if $GET(PSGORQF)
GOTO Q
+21 NEW PSGORD,ON,ON55,PSJORD
DO NEW55^PSIVORFB
SET (PSJORD,ON)=ON55
SET PSIVCOPY=2
+22 DO EN^VALM("PSJ LM IV AC/EDIT")
+23 IF $GET(P("NAT"))=""&($GET(PSJORNAT)="")
Begin DoDot:1
+24 DO FULL^VALM1
WRITE !!,"Order not copied"
DO PAUSE^VALM1
End DoDot:1
GOTO Q
+25 WRITE !!,"...copying..."
+26 ;RTC 178789 - not to store allergy OC until either verify or quit as non-vf order
+27 ;D SETOC^PSJNEWOC(ON55)
+28 ;
+29 IF '$GET(PSGOEAV)
DO INMED
+30 ;
+31 DO FULL^VALM1
WRITE !!?5,"You are finished with the new order.",!,"The following ACTION prompt is for the original order."
DO PAUSE^VALM1
Q ; Kill and exit.
+1 if '$DATA(PSJOE)
LOCK -^PS(53.45,DUZ)
SET PSJNKF=1
DO Q^PSIV
+2 KILL FIL,I1,ND,PC,PDM,PSGDT,PSGID,PSGLMT,PSGSI,PSJNARC,PSIVAC,PSIVCHG,PSIVUP,PSIVX,PSJOPC,PSJAGYSV
+3 SET VALMBCK="R"
+4 IF '$GET(PSGDT)
SET PSGDT=$$DATE^PSJUTL2
+5 ; resets PSGACT after copy
SET PSGACT=$$ENACTION^PSGOE1(PSGP,PSIVOORD)
+6 DO RESTORE^PSJHVARS
+7 KILL P
MERGE P=OLDP
+8 QUIT
+9 ;
INMED ;
+1 ;D ACEDIT^PSJLIACT
KILL PSJACEPT
SET VALMBCK="Q"
SET PSIVCOPY=2
SET PSIVCHG=0
+2 NEW ON55TMP,P21TMP
SET ON55TMP=ON55
SET P21TMP=$GET(P(21))
SET P(21)=""
IF $GET(ON55)["P"
IF ($GET(PSJORD)["V")
SET ON55=PSJORD
+3 DO DEL55^PSIVORE2
IF $GET(ON55TMP)]""
SET ON55=ON55TMP
SET P(21)=P21TMP
+4 ;S (PSJORNAT,P("NAT"))="W"
+5 ;D OK^PSIVORE
+6 DO EN^VALM("PSJ LM IV INPT ACTIVE")
+7 ;RTC 178789 - Store allergy OC as non-vf order
+8 if $GET(ON55)["P"
DO SETOC^PSJNEWOC($GET(ON55))
+9 LOCK -^PS(55,DFN,"IV",+ON55)
DO ULK
+10 IF $GET(P("NAT"))=""
Begin DoDot:1
+11 DO FULL^VALM1
WRITE !!,"Order not copied"
DO PAUSE^VALM1
End DoDot:1
GOTO Q
+12 QUIT
ULK ;
+1 ;If NEW^PSIVORE did not lock, don't kill it here.
if '$GET(PSJLSORX)
QUIT
+2 NEW X
SET X=DFN_";DPT("
DO ULK^ORX2
KILL PSJLSORX
+3 QUIT
HK ;Queue job to print MAR labels generated for this patient.
+1 IF PSGOP
IF PSGOP'=DFN
Begin DoDot:1
+2 NEW PSJACPF,PSJACNWP,PSJPWD,PSJSYSL,PSJSYSW,PSJSYSW0,DFN,VAIN,VAERR
SET DFN=PSGOP
+3 DO INP^VADPT
SET PSJPWD=+VAIN(4)
IF PSJPWD
SET PSJACPF=10
SET PSJACPF=10
DO WP^PSJAC
if $PIECE(PSJSYSL,U,2)]""
DO ENQL^PSGLW
End DoDot:1
+4 SET PSGOP=DFN
+5 QUIT
+6 ;
SPSOL SET SPSOL=0
FOR XXX=0:0
SET XXX=$ORDER(^PS(55,DFN,"IV",+ON55,"SOL",XXX))
if 'XXX
QUIT
SET SPSOL=SPSOL+$PIECE(^(XXX,0),U,2)
+1 KILL XXX
QUIT
CH ;
+1 WRITE !!?2,"Answer 'YES' to have a new, non-verified order created for this patient,"
+2 WRITE !,"using the information from this order. (The START and STOP dates will be",!,"recalculated.) Enter 'NO' (or '^') to stop now."
+3 QUIT
