PSJCOMR ;BIR/CML3-RENEW A COMPLEX ORDER SERIES ;07 MAR 96 / 1:23 PM
;;5.0;INPATIENT MEDICATIONS;**110,127,136,157,181,268,281**;16 DEC 97;Build 113
;
; Reference to ^PS(55 supported by DBIA 2191
; Reference to ^PSSLOCK supported by DBIA 2789
; Reference to NOW^%DTC supported by DBIA 10000
; Reference to ^DIR supported by DBIA 10026
; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
; Reference to ^DD("DD" supported by DBIA 999
;
; renew a complex order series
Q:'PSJCOM K COMQUIT,PSGORQF
W !!,"This order is part of a complex order. If you "_$S($P(PSJSYSP0,"^",3):"RENEW",1:"MARK")_" this order the",!,"following orders will be "_$S($P(PSJSYSP0,"^",3):"RENEWED",1:"MARKED")_" too." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
W !! K DIR S DIR(0)="Y",DIR("A")=$S($P(PSJSYSP0,"^",3):"RENEW THIS COMPLEX ORDER SERIES",1:"MARK THIS COMPLEX ORDER SERIES FOR RENEWAL"),DIR("B")="YES"
S DIR("?")="Answer 'YES' to "_$S($P(PSJSYSP0,"^",3):"renew this complex order series",1:"mark this complex order series for renewal")_". Answer 'NO' (or '^') to stop now." D ^DIR K DIR
I 'Y N DIR D ABORT G DONE
I '$D(DIRUT),Y D NEW S PSGCANFL=1 D DONE Q
I '$D(DIRUT),PSJSYSU I $P(PSGND4,"^",15),$P(PSGND4,"^",16) D UNMARK,DONE Q
D DONE,ABORT^PSGOEE
Q
;
UNMARK ;
W !!,"THIS COMPLEX ORDER SERIES HAS BEEN 'MARKED FOR RENEWAL'.",! K DIR S DIR(0)="Y",DIR("A")="DO YOU WANT TO 'UNMARK IT'",DIR("B")="NO"
S DIR("?",1)=" Answer 'YES' to unmark this complex order series. Answer 'NO' (or '^') to leave the complex",DIR("?")="order series marked. (An answer is required.)" D ^DIR
I 'Y N DIR D ABORT^PSGOEE G DONE
N PSGORD,XX,X S XX=0,X="" F S XX=$O(^PS(55,"ACX",PSJCOM,XX)) Q:'XX F S X=$O(^PS(55,"ACX",PSJCOM,XX,X)) Q:X="" S PSGORD=X D
.S PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4))
.S DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=21180+PSJSYSU D ^PSGAL5 S $P(PSGND4,"^",15,17)="^^",^PS(55,PSGP,5,DA,4)=PSGND4 W "...DONE!"
;
DONE ;
K %DT,DA,DIE,DIR,DR,FDSD,PSGAL,PSGALR,PSGDL,PSGDLS,PSGFD,PSGFOK,PSGND4,PSGOEE,PSGOER0,PSGOER1,PSGOER2
K PSGOERDP,PSGOPR,PSGOSD,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PSGRD,PSGSD,PSGTOL,PSGTOO,PSGUOW,PSGWLL,RF,%
Q
;
NEW ; get info, write record
K ^TMP("PSJCOMR",$J)
N DUOUT,PSGORD,TMPP,TMPO,PS55ACX,TMPDUZ,TMPOE,COMQUIT S TMPP=0 K PS55ACX M PS55ACX(55,"ACX",PSJCOM)=^PS(55,"ACX",PSJCOM)
F S TMPP=$O(PS55ACX(55,"ACX",PSJCOM,TMPP)) Q:'TMPP!$G(COMQUIT) D
. S TMPO=0 F S TMPO=$O(PS55ACX(55,"ACX",PSJCOM,TMPP,TMPO)) Q:TMPO=""!$G(COMQUIT) S PSGORD=TMPO D:PSGORD["U" NEWUD I PSGORD["V" D NEWIV
I $G(COMQUIT)!$G(DUOUT) W !!,"By not verifying all the orders, none of the orders will be verified." D PAUSE^VALM1 Q
I '$G(COMQUIT)&'$G(DUOUT) S TMPOE=0 F S TMPOE=$O(^PS(55,"ACX",PSJCOM,TMPOE)) Q:TMPOE="" S TMPO=0 F S TMPO=$O(^PS(55,"ACX",PSJCOM,TMPOE,TMPO)) Q:'TMPO!$G(COMQUIT) S PSGORD=TMPO D
. K VSTRING S VSTRING=$G(^TMP("PSJCOMR",$J,PSJCOM,TMPO)) I PSGORD'=$P(VSTRING,"^",2) S COMQUIT=1 Q
. S PSGP=$P(VSTRING,"^"),PSGDT=$P(VSTRING,"^",3),PSGOEPR=$P(VSTRING,"^",4),PSGOFD=$P(VSTRING,"^",5),PSGFD=$P(VSTRING,"^",6),PSJNOO=$P(VSTRING,"^",7),TMPDUZ=$P(VSTRING,"^",8)
. D:PSGORD["U" FILEUD D:PSGORD["V" FILEIV
K ^TMP("PSJCOMR",$J),VSTRING
Q
NEWUD N PSJABT,PSGDRG,PSJREN,X,XX,PSGORDP,UDSTRING S PSGDRG=$P($G(^PS(55,PSGP,5,+PSGORD,1,1,0)),"^"),PSJREN=1
;D OC55
Q:$D(PSGORQF) ; quit if not to continue
D NOW^%DTC S PSGDT=%,PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4)) I '$P(PSJSYSP0,"^",3) D MARK Q
S PSGWLL=$S('$P(PSJSYSW0,"^",4):0,1:+$G(^PS(55,PSGP,5.1))),PSGOEE="R" K PSGOEOS
K ^PS(53.45,PSJSYSP,1),^(2) D MOVE(3,1),MOVE(1,2)
D DATE^PSGOER0(PSGP,PSGORD,PSGDT) I '$D(PSGFOK(106)) D DONE,ABORT^PSGOEE S VALMBCK="R" Q
W !!,"...updating order..." N PSGOEAV S PSGOEAV=+PSJSYSU,PSGOORD=PSGORD,PSGOER1=$G(^PS(55,PSGP,5,+PSGORD,.2)),PSGSI=$G(^(6)) W "."
S PSGMR=$P(PSGOER0,"^",3),PSGSM=$P(PSGOER0,"^",5),PSGHSM=$P(PSGOER0,"^",6)
S PSGMRN=$$ENMRN^PSGMI(PSGMR),PSGPDRGN=$$ENPDN^PSGMI(PSGPDRG),PSGDO=$P(PSGOER1,"^",2),PSGSCH=$P(PSGOER2,"^")
S PSGS0Y=$P(PSGOER2,"^",5),PSGS0XT=$P(PSGOER2,"^",6),PSGNESD=PSGSD,PSGNEFD=PSGFD
S:PSJPWD'=$P(PSGOER2,U,10) PSGS0Y=$$ENRNAT^PSGOU($P(PSGOER2,U,10),+PSJPWD,PSGSCH,PSGS0Y)
S UDSTRING=PSGP_"^"_PSGORD_"^"_PSGDT_"^"_PSGOEPR_"^"_PSGOFD_"^"_PSGFD_"^"_PSJNOO F II=1:1:$L(UDSTRING,"^") I $P(UDSTRING,"^",II)="" K UDSTRING
I '$D(UDSTRING) S COMQUIT=1 Q
S:$G(DUZ) UDSTRING=UDSTRING_"^"_DUZ D TEMP(UDSTRING)
Q
;
FILEUD ;
;Changed the reference to the type "O" for order numbers previously in v4.5
N X,PSJORD,PSGOERDP,PSGOREAS,PSGRZERO S PSJORD=PSGORD K PSJPREX
;Make sure Admin times for parent don't carry to children;BHW;PSJ*5*136
S X=$$LS^PSSLOCK(PSGP,PSGORD) S PSGRTWO=^PS(55,+$G(PSGP),5,+PSGORD,2) S PSGRZERO="^PS(55,"_PSGP_",5,"_+PSGORD_",0)",PSGOREAS=$P(@(PSGRZERO),"^",24) D
. S (PSGAT,PSGS0Y)=$P(PSGRTWO,"^",5)
. S $P(@PSGRZERO,"^",24)="R" D UPDREN^PSGOER(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO,$G(TMPDUZ)),UPDRENOE^PSGOER(PSGP,PSGORD) S $P(@PSGRZERO,"^",24)=PSGOREAS
I +$G(PSJSYSU)=3,$G(PSJCOM) D CMPLX2^PSJCOM1(PSGP,PSJCOM,PSGORD) I $G(PSGPXN) S PSJPREX=1
W !!,"...updating order..." K DA S DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=PSJSYSU*10+18000 D ^PSGAL5 W "."
I '$G(PSGOERDP),$P(PSJSYSW0,"^",4) I $G(PSGFD),$G(PSGWLL),(PSGFD'<PSGWLL) S $P(^PS(55,PSGP,5.1),"^")=+PSGFD
S ^TMP("PSODAOC",$J,"IP IEN")=PSGORD
D SETOC^PSJNEWOC(PSGORD)
; ** This is where the Automated Dispensing Machine hook is called. Do NOT DELETE or change location **
D RENEW^PSJADM
; ** END of INTERFACE Hook **
D UNL^PSSLOCK(PSGP,PSGORD)
W ".DONE!" S VALMBCK="Q"
Q
;
MARK ;
I $P(PSGND4,"^",15),$P(PSGND4,"^",16) W $C(7),!!?3,"...THIS ORDER IS ALREADY MARKED FOR RENEWAL!..." Q
K DA S $P(PSGND4,"^",15,17)="1^"_DUZ_"^"_PSGDT,^PS(55,PSGP,5,+PSGORD,4)=PSGND4,PSGAL("C")=13180,DA(1)=PSGP,DA=+PSGORD W "." D ^PSGAL5
I $D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="R",PSGPOSD=PSGDT D ENPOS^PSGVDS
Q
MOVE(X,Y) ; Move comments/dispense drugs from 55 to 53.45.
S Q=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,X,Q)) Q:'Q S ^PS(53.45,PSJSYSP,Y,Q,0)=$G(^(Q,0))
S:Q ^PS(53.45,Y,0)="^53.450"_Y_"P^"_Q_U_Q
Q
OC55 ;* Order checks for Speed finish and regular finish
N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJPDRG,PSJDD,PSJALLGY
S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)=""
F PSGDDI=0:0 S PSGDDI=$O(^PS(55,PSGP,5,+PSGORD,1,PSGDDI)) Q:'PSGDDI D
. S PSJDD=+$G(^PS(55,PSGP,5,+PSGORD,1,PSGDDI,0))
. S PSJALLGY(PSJDD)=""
K PSGORQF D ENDDC^PSGSICHK(PSGP,PSJDD)
Q
;
RIV ; Renew order.
Q:'PSJCOM N PSGORD,TMPP,TMPO S (TMPP,TMPO)=0 K PS55ACX M PS55ACX(55,"ACX",PSJCOM)=^PS(55,"ACX",PSJCOM)
F S TMPP=$O(PS55ACX(55,"ACX",PSJCOM,TMPP)) Q:'TMPP S TMPO=0 F S TMPO=$O(PS55ACX(55,"ACX",PSJCOM,TMPP,TMPO)) Q:TMPO="" D
. S PSGORD=TMPO D:PSGORD["U" NEWUD D:PSGORD["V" NEWIV
Q
NEWIV ;Renew complex IV orders
N X,XX
I P(17)="D",P(12) N ERR D RI W:$G(ERR)=1 $C(7)," Order unchanged." Q:$G(ERR)<2
K PSGORQF S PSIVRNFG=1 D ORDCHK^PSJLIFN K PSIVRNFG Q:$G(PSGORQF) W !
I $G(PSGORD)["V" S ON55=PSGORD S P("OLDON")=$P(^PS(55,DFN,"IV",+PSGORD,2),"^",5) S:'P("OLDON") P("OLDON")=ON55
;
R1 N PSIVND0,PSIVND2,PSIVREAS,PSIVOFD,IVSTRING,P2,PSJBKDR S PSJBKDR=1
S P("NEWON")=ON55,(PSIVOK,EDIT)="25^1",P2=P(2) S P(2)=$$DATE^PSJUTL2 D EDIT^PSIVEDT S P(2)=P2 I X="^" D RD Q
S:+VAIN(4)'=$P($G(^PS(55,DFN,"IV",+P("OLDON"),2)),U,10) P(11)=$$ENRNAT^PSGOU($P($G(^PS(55,DFN,"IV",+P("OLDON"),2)),U,10),+VAIN(4),P(9),P(11))
S PSIVCHG=2
D OK G:X["N" R1 I X=U D RD Q
S P(17)="A",P("RES")="R",P("FRES")="" D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D Q:'$D(P("NAT"))
.D NATURE^PSIVOREN I '$D(P("NAT")) D RD S COMQUIT=1 Q
.S ON=ON55 ;D SET^PSIVORFE
S P(16)="",PSJORIFN="",PSIVACT=1,P("21FLG")="",PSIVOFD=$P($G(^PS(55,DFN,"IV",+PSGORD,0)),"^",3)
S IVSTRING=DFN_"^"_ON55_"^"_$$DATE^PSJUTL2()_"^"_+$G(P(6))_"^"_PSIVOFD_"^"_P(3)_"^"_P("NAT") F II=1:1:$L(IVSTRING,"^") I $P(IVSTRING,"^",II)="" K IVSTRING
I '$D(IVSTRING) S COMQUIT=1 Q
S:$G(DUZ) IVSTRING=IVSTRING_"^"_DUZ D TEMP(IVSTRING)
Q
;
FILEIV ;
N X,ON,ON55,PSJORD,P,PSIVTMP,PSIVZERO,OREAS
S X=$$LS^PSSLOCK(DFN,+PSGORD_"V") S PSIVZERO="^PS(55,"_DFN_",""IV"","_+PSGORD_",0)" S PSIVTMP0=$G(@PSIVZERO) Q:'PSIVTMP0
S PSIVTMP2="^PS(55,"_DFN_",""IV"","_+PSGORD_",2)",OREAS=$P(PSIVTMP2,"^",8),$P(@PSIVTMP2,"^",8)="R"
F I=1:1:$L(PSIVTMP0,"^") S P(I)=$P(PSIVTMP0,"^",I)
S (ON,ON55,PSJORD)=PSGORD,P(3)=PSGFD,P(6)=PSGOEPR,P("NAT")=PSJNOO,PSIVOFD=PSGOFD D RUPDATE^PSIVOREN(DFN,ON55,P(2))
Q:'PSJIVORF
D EN1^PSJHL2(DFN,"SN",+ON55_"V","ORDER RENEWED")
S OD=P(2) D EN^PSIVORE
D VF1^PSJLIACT("","",0),UNL^PSSLOCK(DFN,+ON55_"V") S $P(@PSIVTMP2,"^",8)=OREAS
D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"R")
Q
;
TEMP(VARS) ;
Q:'PSJCOM S ^TMP("PSJCOMR",$J,PSJCOM,PSGORD)=VARS
Q
;
RD ; Delete for renew.
D DEL55^PSIVORE2 S (ON55,P("PON"))=P("OLDON") D GT55^PSIVORFB
Q
;
OK ;Print example label, run order through checker, ask if it is ok.
S P16=0,PSIVEXAM=1,(PSIVNOL,PSIVCT)=1 D GTOT^PSIVUTL(P(4)) I ($G(P("PD"))="") D GTPD^PSIVORE2
D ^PSIVCHK I $D(DUOUT) S X="^" Q
I ERR=1 S X="N" Q
W ! D ^PSIVORLB K PSIVEXAM S Y=P(2) W !,"Start date: " X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),?30," Stop date: " S Y=P(3) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),!
D EFDIV^PSJUTL($G(ZZND))
S X="Is this O.K.: ^"_$S(ERR:"N",1:"Y")_"^^NO"_$S(ERR'=1:",YES",1:"") D ENQ^PSIV I X["?" S HELP="OK" D ^PSIVHLP G OK
Q
;
RI ; Reinstate Auto-DC'ed order.
N DA,DIE,DIR,DIU,DR,PSIVACT,PSIVALT,PSIVALCK,PSIVREA W !!,$C(7),"This order has been Auto-DC'ed."
S DIR(0)="Y",DIR("A")="Reinstate this order" D ^DIR K DIR I 'Y S ERR=1 Q
D NOW^%DTC I %>$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7) D
.K DIR S ERR=1,DIR(0)="Y",DIR("A",1)="The original stop date of this order has past.",DIR("A")="Do you wish to renew this order" D ^DIR K DIR S ERR=$S(Y:2,1:1)
Q:$G(ERR) S X=$G(^VA(200,+P(6),"PS")) I $S('X:1,'$P(X,U,4):0,DT<$P(X,U,4):0,1:1) S ERR=1
I $G(ERR) W !!,$C(7),"This order's provider is no longer valid. Please enter a valid provider." S (EDIT,PSIVOK)=1 D EDIT^PSIVEDT I $G(DONE) W $C(7),"Order unchanged." S ERR=1 Q
N PSGALO S PSGALO=18530 D ENARI^PSIVOPT(DFN,ON,DUZ,PSGALO)
Q
;
ABORT ; No changes
W !!,$C(7),"No changes made to this order." D PAUSE^VALM1 K PSGOEEF S PSGOEEF=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJCOMR 10261 printed Nov 22, 2024@17:16:37 Page 2
PSJCOMR ;BIR/CML3-RENEW A COMPLEX ORDER SERIES ;07 MAR 96 / 1:23 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**110,127,136,157,181,268,281**;16 DEC 97;Build 113
+2 ;
+3 ; Reference to ^PS(55 supported by DBIA 2191
+4 ; Reference to ^PSSLOCK supported by DBIA 2789
+5 ; Reference to NOW^%DTC supported by DBIA 10000
+6 ; Reference to ^DIR supported by DBIA 10026
+7 ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
+8 ; Reference to ^DD("DD" supported by DBIA 999
+9 ;
+10 ; renew a complex order series
+11 if 'PSJCOM
QUIT
KILL COMQUIT,PSGORQF
+12 WRITE !!,"This order is part of a complex order. If you "_$SELECT($PIECE(PSJSYSP0,"^",3):"RENEW",1:"MARK")_" this order the",!,"following orders will be "_$SELECT($PIECE(PSJSYSP0,"^",3):"RENEWED",1:"MARKED")_" too."
DO CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
+13 WRITE !!
KILL DIR
SET DIR(0)="Y"
SET DIR("A")=$SELECT($PIECE(PSJSYSP0,"^",3):"RENEW THIS COMPLEX ORDER SERIES",1:"MARK THIS COMPLEX ORDER SERIES FOR RENEWAL")
SET DIR("B")="YES"
+14 SET DIR("?")="Answer 'YES' to "_$SELECT($PIECE(PSJSYSP0,"^",3):"renew this complex order series",1:"mark this complex order series for renewal")_". Answer 'NO' (or '^') to stop now."
DO ^DIR
KILL DIR
+15 IF 'Y
NEW DIR
DO ABORT
GOTO DONE
+16 IF '$DATA(DIRUT)
IF Y
DO NEW
SET PSGCANFL=1
DO DONE
QUIT
+17 IF '$DATA(DIRUT)
IF PSJSYSU
IF $PIECE(PSGND4,"^",15)
IF $PIECE(PSGND4,"^",16)
DO UNMARK
DO DONE
QUIT
+18 DO DONE
DO ABORT^PSGOEE
+19 QUIT
+20 ;
UNMARK ;
+1 WRITE !!,"THIS COMPLEX ORDER SERIES HAS BEEN 'MARKED FOR RENEWAL'.",!
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="DO YOU WANT TO 'UNMARK IT'"
SET DIR("B")="NO"
+2 SET DIR("?",1)=" Answer 'YES' to unmark this complex order series. Answer 'NO' (or '^') to leave the complex"
SET DIR("?")="order series marked. (An answer is required.)"
DO ^DIR
+3 IF 'Y
NEW DIR
DO ABORT^PSGOEE
GOTO DONE
+4 NEW PSGORD,XX,X
SET XX=0
SET X=""
FOR
SET XX=$ORDER(^PS(55,"ACX",PSJCOM,XX))
if 'XX
QUIT
FOR
SET X=$ORDER(^PS(55,"ACX",PSJCOM,XX,X))
if X=""
QUIT
SET PSGORD=X
Begin DoDot:1
+5 SET PSGND4=$GET(^PS(55,PSGP,5,+PSGORD,4))
+6 SET DA(1)=PSGP
SET DA=+PSGORD
SET PSGAL("C")=21180+PSJSYSU
DO ^PSGAL5
SET $PIECE(PSGND4,"^",15,17)="^^"
SET ^PS(55,PSGP,5,DA,4)=PSGND4
WRITE "...DONE!"
End DoDot:1
+7 ;
DONE ;
+1 KILL %DT,DA,DIE,DIR,DR,FDSD,PSGAL,PSGALR,PSGDL,PSGDLS,PSGFD,PSGFOK,PSGND4,PSGOEE,PSGOER0,PSGOER1,PSGOER2
+2 KILL PSGOERDP,PSGOPR,PSGOSD,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PSGRD,PSGSD,PSGTOL,PSGTOO,PSGUOW,PSGWLL,RF,%
+3 QUIT
+4 ;
NEW ; get info, write record
+1 KILL ^TMP("PSJCOMR",$JOB)
+2 NEW DUOUT,PSGORD,TMPP,TMPO,PS55ACX,TMPDUZ,TMPOE,COMQUIT
SET TMPP=0
KILL PS55ACX
MERGE PS55ACX(55,"ACX",PSJCOM)=^PS(55,"ACX",PSJCOM)
+3 FOR
SET TMPP=$ORDER(PS55ACX(55,"ACX",PSJCOM,TMPP))
if 'TMPP!$GET(COMQUIT)
QUIT
Begin DoDot:1
+4 SET TMPO=0
FOR
SET TMPO=$ORDER(PS55ACX(55,"ACX",PSJCOM,TMPP,TMPO))
if TMPO=""!$GET(COMQUIT)
QUIT
SET PSGORD=TMPO
if PSGORD["U"
DO NEWUD
IF PSGORD["V"
DO NEWIV
End DoDot:1
+5 IF $GET(COMQUIT)!$GET(DUOUT)
WRITE !!,"By not verifying all the orders, none of the orders will be verified."
DO PAUSE^VALM1
QUIT
+6 IF '$GET(COMQUIT)&'$GET(DUOUT)
SET TMPOE=0
FOR
SET TMPOE=$ORDER(^PS(55,"ACX",PSJCOM,TMPOE))
if TMPOE=""
QUIT
SET TMPO=0
FOR
SET TMPO=$ORDER(^PS(55,"ACX",PSJCOM,TMPOE,TMPO))
if 'TMPO!$GET(COMQUIT)
QUIT
SET PSGORD=TMPO
Begin DoDot:1
+7 KILL VSTRING
SET VSTRING=$GET(^TMP("PSJCOMR",$JOB,PSJCOM,TMPO))
IF PSGORD'=$PIECE(VSTRING,"^",2)
SET COMQUIT=1
QUIT
+8 SET PSGP=$PIECE(VSTRING,"^")
SET PSGDT=$PIECE(VSTRING,"^",3)
SET PSGOEPR=$PIECE(VSTRING,"^",4)
SET PSGOFD=$PIECE(VSTRING,"^",5)
SET PSGFD=$PIECE(VSTRING,"^",6)
SET PSJNOO=$PIECE(VSTRING,"^",7)
SET TMPDUZ=$PIECE(VSTRING,"^",8)
+9 if PSGORD["U"
DO FILEUD
if PSGORD["V"
DO FILEIV
End DoDot:1
+10 KILL ^TMP("PSJCOMR",$JOB),VSTRING
+11 QUIT
NEWUD NEW PSJABT,PSGDRG,PSJREN,X,XX,PSGORDP,UDSTRING
SET PSGDRG=$PIECE($GET(^PS(55,PSGP,5,+PSGORD,1,1,0)),"^")
SET PSJREN=1
+1 ;D OC55
+2 ; quit if not to continue
if $DATA(PSGORQF)
QUIT
+3 DO NOW^%DTC
SET PSGDT=%
SET PSGND4=$GET(^PS(55,PSGP,5,+PSGORD,4))
IF '$PIECE(PSJSYSP0,"^",3)
DO MARK
QUIT
+4 SET PSGWLL=$SELECT('$PIECE(PSJSYSW0,"^",4):0,1:+$GET(^PS(55,PSGP,5.1)))
SET PSGOEE="R"
KILL PSGOEOS
+5 KILL ^PS(53.45,PSJSYSP,1),^(2)
DO MOVE(3,1)
DO MOVE(1,2)
+6 DO DATE^PSGOER0(PSGP,PSGORD,PSGDT)
IF '$DATA(PSGFOK(106))
DO DONE
DO ABORT^PSGOEE
SET VALMBCK="R"
QUIT
+7 WRITE !!,"...updating order..."
NEW PSGOEAV
SET PSGOEAV=+PSJSYSU
SET PSGOORD=PSGORD
SET PSGOER1=$GET(^PS(55,PSGP,5,+PSGORD,.2))
SET PSGSI=$GET(^(6))
WRITE "."
+8 SET PSGMR=$PIECE(PSGOER0,"^",3)
SET PSGSM=$PIECE(PSGOER0,"^",5)
SET PSGHSM=$PIECE(PSGOER0,"^",6)
+9 SET PSGMRN=$$ENMRN^PSGMI(PSGMR)
SET PSGPDRGN=$$ENPDN^PSGMI(PSGPDRG)
SET PSGDO=$PIECE(PSGOER1,"^",2)
SET PSGSCH=$PIECE(PSGOER2,"^")
+10 SET PSGS0Y=$PIECE(PSGOER2,"^",5)
SET PSGS0XT=$PIECE(PSGOER2,"^",6)
SET PSGNESD=PSGSD
SET PSGNEFD=PSGFD
+11 if PSJPWD'=$PIECE(PSGOER2,U,10)
SET PSGS0Y=$$ENRNAT^PSGOU($PIECE(PSGOER2,U,10),+PSJPWD,PSGSCH,PSGS0Y)
+12 SET UDSTRING=PSGP_"^"_PSGORD_"^"_PSGDT_"^"_PSGOEPR_"^"_PSGOFD_"^"_PSGFD_"^"_PSJNOO
FOR II=1:1:$LENGTH(UDSTRING,"^")
IF $PIECE(UDSTRING,"^",II)=""
KILL UDSTRING
+13 IF '$DATA(UDSTRING)
SET COMQUIT=1
QUIT
+14 if $GET(DUZ)
SET UDSTRING=UDSTRING_"^"_DUZ
DO TEMP(UDSTRING)
+15 QUIT
+16 ;
FILEUD ;
+1 ;Changed the reference to the type "O" for order numbers previously in v4.5
+2 NEW X,PSJORD,PSGOERDP,PSGOREAS,PSGRZERO
SET PSJORD=PSGORD
KILL PSJPREX
+3 ;Make sure Admin times for parent don't carry to children;BHW;PSJ*5*136
+4 SET X=$$LS^PSSLOCK(PSGP,PSGORD)
SET PSGRTWO=^PS(55,+$GET(PSGP),5,+PSGORD,2)
SET PSGRZERO="^PS(55,"_PSGP_",5,"_+PSGORD_",0)"
SET PSGOREAS=$PIECE(@(PSGRZERO),"^",24)
Begin DoDot:1
+5 SET (PSGAT,PSGS0Y)=$PIECE(PSGRTWO,"^",5)
+6 SET $PIECE(@PSGRZERO,"^",24)="R"
DO UPDREN^PSGOER(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO,$GET(TMPDUZ))
DO UPDRENOE^PSGOER(PSGP,PSGORD)
SET $PIECE(@PSGRZERO,"^",24)=PSGOREAS
End DoDot:1
+7 IF +$GET(PSJSYSU)=3
IF $GET(PSJCOM)
DO CMPLX2^PSJCOM1(PSGP,PSJCOM,PSGORD)
IF $GET(PSGPXN)
SET PSJPREX=1
+8 WRITE !!,"...updating order..."
KILL DA
SET DA(1)=PSGP
SET DA=+PSGORD
SET PSGAL("C")=PSJSYSU*10+18000
DO ^PSGAL5
WRITE "."
+9 IF '$GET(PSGOERDP)
IF $PIECE(PSJSYSW0,"^",4)
IF $GET(PSGFD)
IF $GET(PSGWLL)
IF (PSGFD'<PSGWLL)
SET $PIECE(^PS(55,PSGP,5.1),"^")=+PSGFD
+10 SET ^TMP("PSODAOC",$JOB,"IP IEN")=PSGORD
+11 DO SETOC^PSJNEWOC(PSGORD)
+12 ; ** This is where the Automated Dispensing Machine hook is called. Do NOT DELETE or change location **
+13 DO RENEW^PSJADM
+14 ; ** END of INTERFACE Hook **
+15 DO UNL^PSSLOCK(PSGP,PSGORD)
+16 WRITE ".DONE!"
SET VALMBCK="Q"
+17 QUIT
+18 ;
MARK ;
+1 IF $PIECE(PSGND4,"^",15)
IF $PIECE(PSGND4,"^",16)
WRITE $CHAR(7),!!?3,"...THIS ORDER IS ALREADY MARKED FOR RENEWAL!..."
QUIT
+2 KILL DA
SET $PIECE(PSGND4,"^",15,17)="1^"_DUZ_"^"_PSGDT
SET ^PS(55,PSGP,5,+PSGORD,4)=PSGND4
SET PSGAL("C")=13180
SET DA(1)=PSGP
SET DA=+PSGORD
WRITE "."
DO ^PSGAL5
+3 IF $DATA(PSJSYSO)
SET PSGORD=+PSGORD_"A"
SET PSGPOSA="R"
SET PSGPOSD=PSGDT
DO ENPOS^PSGVDS
+4 QUIT
MOVE(X,Y) ; Move comments/dispense drugs from 55 to 53.45.
+1 SET Q=0
FOR
SET Q=$ORDER(^PS(55,PSGP,5,+PSGORD,X,Q))
if 'Q
QUIT
SET ^PS(53.45,PSJSYSP,Y,Q,0)=$GET(^(Q,0))
+2 if Q
SET ^PS(53.45,Y,0)="^53.450"_Y_"P^"_Q_U_Q
+3 QUIT
OC55 ;* Order checks for Speed finish and regular finish
+1 NEW INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJPDRG,PSJDD,PSJALLGY
+2 SET Y=1
SET (PSJIREQ,PSJRXREQ,INTERVEN,X)=""
+3 FOR PSGDDI=0:0
SET PSGDDI=$ORDER(^PS(55,PSGP,5,+PSGORD,1,PSGDDI))
if 'PSGDDI
QUIT
Begin DoDot:1
+4 SET PSJDD=+$GET(^PS(55,PSGP,5,+PSGORD,1,PSGDDI,0))
+5 SET PSJALLGY(PSJDD)=""
End DoDot:1
+6 KILL PSGORQF
DO ENDDC^PSGSICHK(PSGP,PSJDD)
+7 QUIT
+8 ;
RIV ; Renew order.
+1 if 'PSJCOM
QUIT
NEW PSGORD,TMPP,TMPO
SET (TMPP,TMPO)=0
KILL PS55ACX
MERGE PS55ACX(55,"ACX",PSJCOM)=^PS(55,"ACX",PSJCOM)
+2 FOR
SET TMPP=$ORDER(PS55ACX(55,"ACX",PSJCOM,TMPP))
if 'TMPP
QUIT
SET TMPO=0
FOR
SET TMPO=$ORDER(PS55ACX(55,"ACX",PSJCOM,TMPP,TMPO))
if TMPO=""
QUIT
Begin DoDot:1
+3 SET PSGORD=TMPO
if PSGORD["U"
DO NEWUD
if PSGORD["V"
DO NEWIV
End DoDot:1
+4 QUIT
NEWIV ;Renew complex IV orders
+1 NEW X,XX
+2 IF P(17)="D"
IF P(12)
NEW ERR
DO RI
if $GET(ERR)=1
WRITE $CHAR(7)," Order unchanged."
if $GET(ERR)<2
QUIT
+3 KILL PSGORQF
SET PSIVRNFG=1
DO ORDCHK^PSJLIFN
KILL PSIVRNFG
if $GET(PSGORQF)
QUIT
WRITE !
+4 IF $GET(PSGORD)["V"
SET ON55=PSGORD
SET P("OLDON")=$PIECE(^PS(55,DFN,"IV",+PSGORD,2),"^",5)
if 'P("OLDON")
SET P("OLDON")=ON55
+5 ;
R1 NEW PSIVND0,PSIVND2,PSIVREAS,PSIVOFD,IVSTRING,P2,PSJBKDR
SET PSJBKDR=1
+1 SET P("NEWON")=ON55
SET (PSIVOK,EDIT)="25^1"
SET P2=P(2)
SET P(2)=$$DATE^PSJUTL2
DO EDIT^PSIVEDT
SET P(2)=P2
IF X="^"
DO RD
QUIT
+2 if +VAIN(4)'=$PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),2)),U,10)
SET P(11)=$$ENRNAT^PSGOU($PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),2)),U,10),+VAIN(4),P(9),P(11))
+3 SET PSIVCHG=2
+4 DO OK
if X["N"
GOTO R1
IF X=U
DO RD
QUIT
+5 SET P(17)="A"
SET P("RES")="R"
SET P("FRES")=""
if '$DATA(PSJIVORF)
DO ORPARM^PSIVOREN
IF PSJIVORF
Begin DoDot:1
+6 DO NATURE^PSIVOREN
IF '$DATA(P("NAT"))
DO RD
SET COMQUIT=1
QUIT
+7 ;D SET^PSIVORFE
SET ON=ON55
End DoDot:1
if '$DATA(P("NAT"))
QUIT
+8 SET P(16)=""
SET PSJORIFN=""
SET PSIVACT=1
SET P("21FLG")=""
SET PSIVOFD=$PIECE($GET(^PS(55,DFN,"IV",+PSGORD,0)),"^",3)
+9 SET IVSTRING=DFN_"^"_ON55_"^"_$$DATE^PSJUTL2()_"^"_+$GET(P(6))_"^"_PSIVOFD_"^"_P(3)_"^"_P("NAT")
FOR II=1:1:$LENGTH(IVSTRING,"^")
IF $PIECE(IVSTRING,"^",II)=""
KILL IVSTRING
+10 IF '$DATA(IVSTRING)
SET COMQUIT=1
QUIT
+11 if $GET(DUZ)
SET IVSTRING=IVSTRING_"^"_DUZ
DO TEMP(IVSTRING)
+12 QUIT
+13 ;
FILEIV ;
+1 NEW X,ON,ON55,PSJORD,P,PSIVTMP,PSIVZERO,OREAS
+2 SET X=$$LS^PSSLOCK(DFN,+PSGORD_"V")
SET PSIVZERO="^PS(55,"_DFN_",""IV"","_+PSGORD_",0)"
SET PSIVTMP0=$GET(@PSIVZERO)
if 'PSIVTMP0
QUIT
+3 SET PSIVTMP2="^PS(55,"_DFN_",""IV"","_+PSGORD_",2)"
SET OREAS=$PIECE(PSIVTMP2,"^",8)
SET $PIECE(@PSIVTMP2,"^",8)="R"
+4 FOR I=1:1:$LENGTH(PSIVTMP0,"^")
SET P(I)=$PIECE(PSIVTMP0,"^",I)
+5 SET (ON,ON55,PSJORD)=PSGORD
SET P(3)=PSGFD
SET P(6)=PSGOEPR
SET P("NAT")=PSJNOO
SET PSIVOFD=PSGOFD
DO RUPDATE^PSIVOREN(DFN,ON55,P(2))
+6 if 'PSJIVORF
QUIT
+7 DO EN1^PSJHL2(DFN,"SN",+ON55_"V","ORDER RENEWED")
+8 SET OD=P(2)
DO EN^PSIVORE
+9 DO VF1^PSJLIACT("","",0)
DO UNL^PSSLOCK(DFN,+ON55_"V")
SET $PIECE(@PSIVTMP2,"^",8)=OREAS
+10 DO ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"R")
+11 QUIT
+12 ;
TEMP(VARS) ;
+1 if 'PSJCOM
QUIT
SET ^TMP("PSJCOMR",$JOB,PSJCOM,PSGORD)=VARS
+2 QUIT
+3 ;
RD ; Delete for renew.
+1 DO DEL55^PSIVORE2
SET (ON55,P("PON"))=P("OLDON")
DO GT55^PSIVORFB
+2 QUIT
+3 ;
OK ;Print example label, run order through checker, ask if it is ok.
+1 SET P16=0
SET PSIVEXAM=1
SET (PSIVNOL,PSIVCT)=1
DO GTOT^PSIVUTL(P(4))
IF ($GET(P("PD"))="")
DO GTPD^PSIVORE2
+2 DO ^PSIVCHK
IF $DATA(DUOUT)
SET X="^"
QUIT
+3 IF ERR=1
SET X="N"
QUIT
+4 WRITE !
DO ^PSIVORLB
KILL PSIVEXAM
SET Y=P(2)
WRITE !,"Start date: "
XECUTE ^DD("DD")
WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2),?30," Stop date: "
SET Y=P(3)
XECUTE ^DD("DD")
WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2),!
+5 DO EFDIV^PSJUTL($GET(ZZND))
+6 SET X="Is this O.K.: ^"_$SELECT(ERR:"N",1:"Y")_"^^NO"_$SELECT(ERR'=1:",YES",1:"")
DO ENQ^PSIV
IF X["?"
SET HELP="OK"
DO ^PSIVHLP
GOTO OK
+7 QUIT
+8 ;
RI ; Reinstate Auto-DC'ed order.
+1 NEW DA,DIE,DIR,DIU,DR,PSIVACT,PSIVALT,PSIVALCK,PSIVREA
WRITE !!,$CHAR(7),"This order has been Auto-DC'ed."
+2 SET DIR(0)="Y"
SET DIR("A")="Reinstate this order"
DO ^DIR
KILL DIR
IF 'Y
SET ERR=1
QUIT
+3 DO NOW^%DTC
IF %>$PIECE($GET(^PS(55,DFN,"IV",+ON55,2)),U,7)
Begin DoDot:1
+4 KILL DIR
SET ERR=1
SET DIR(0)="Y"
SET DIR("A",1)="The original stop date of this order has past."
SET DIR("A")="Do you wish to renew this order"
DO ^DIR
KILL DIR
SET ERR=$SELECT(Y:2,1:1)
End DoDot:1
+5 if $GET(ERR)
QUIT
SET X=$GET(^VA(200,+P(6),"PS"))
IF $SELECT('X:1,'$PIECE(X,U,4):0,DT<$PIECE(X,U,4):0,1:1)
SET ERR=1
+6 IF $GET(ERR)
WRITE !!,$CHAR(7),"This order's provider is no longer valid. Please enter a valid provider."
SET (EDIT,PSIVOK)=1
DO EDIT^PSIVEDT
IF $GET(DONE)
WRITE $CHAR(7),"Order unchanged."
SET ERR=1
QUIT
+7 NEW PSGALO
SET PSGALO=18530
DO ENARI^PSIVOPT(DFN,ON,DUZ,PSGALO)
+8 QUIT
+9 ;
ABORT ; No changes
+1 WRITE !!,$CHAR(7),"No changes made to this order."
DO PAUSE^VALM1
KILL PSGOEEF
SET PSGOEEF=0
+2 QUIT
