Routine: PSJCOMR

PSJCOMR ;BIR/CML3-RENEW A COMPLEX ORDER SERIES ;07 MAR 96 / 1:23 PM

 ;;5.0; INPATIENT MEDICATIONS ;**110,127,136,157**;16 DEC 97

 ; Reference to ^PS(55 supported by DBIA 2191.

 ; Reference to ^PSSLOCK is supported by DBIA 2789.

 ; Reference to NOW^%DTC is supported by DBIA 10000.

 ; Reference to ^DIR is supported by DBIA 10026.

 ; renew a complex order series

 Q:'PSJCOM  K COMQUIT

 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

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,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

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)

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

 D UNL^PSSLOCK(PSGP,PSGORD)

 W ".DONE!" S VALMBCK="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

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

OC55 ;* Order checks for Speed finish and regular finish

 N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJPDRG

 S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)=""

 K PSGORQF D ENDDC^PSGSICHK(PSGP,+$G(^PS(55,PSGP,5,+PSGORD,1,1,0)))

 I '$D(PSGORQF) K PSGORQF,^TMP($J,"DI") D

 . F PSGDDI=1:0 S PSGDDI=$O(^PS(55,PSGP,5,+PSGORD,1,PSGDDI)) Q:'PSGDDI  S PSJDD=+$G(^PS(55,PSGP,5,+PSGORD,1,PSGDDI,0)) K PSJPDRG D IVSOL^PSGSICHK

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

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

 NEW 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)

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")

TEMP(VARS) ;

 Q:'PSJCOM  S ^TMP("PSJCOMR",$J,PSJCOM,PSGORD)=VARS

RD ; Delete for renew.

 D DEL55^PSIVORE2 S (ON55,P("PON"))=P("OLDON") D GT55^PSIVORFB

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

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)

ABORT ; No changes

 W !!,$C(7),"No changes made to this order." D PAUSE^VALM1 K PSGOEEF S PSGOEEF=0

PSJCOMR   ;BIR/CML3-RENEW A COMPLEX ORDER SERIES ;07 MAR 96 / 1:23 PM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**110,127,136,157**;16 DEC 97

 +2       ;

 +3       ; Reference to ^PS(55 supported by DBIA 2191.

 +4       ; Reference to ^PSSLOCK is supported by DBIA 2789.

 +5       ; Reference to NOW^%DTC is supported by DBIA 10000.

 +6       ; Reference to ^DIR is supported by DBIA 10026.

 +7       ;

 +8       ; renew a complex order series

 +9        IF 'PSJCOM

               QUIT

           KILL COMQUIT

 +10       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)

 +11       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"

 +12       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

 +13       IF 'Y

               NEW DIR

               DO ABORT

               GOTO DONE

 +14       IF '$DATA(DIRUT)

               IF Y

                   DO NEW

                   SET PSGCANFL=1

                   DO DONE

                   QUIT

 +15       IF '$DATA(DIRUT)

               IF PSJSYSU

                   IF $PIECE(PSGND4,"^",15)

                       IF $PIECE(PSGND4,"^",16)

                           DO UNMARK

                           DO DONE

                           QUIT

 +16       DO DONE

           DO ABORT^PSGOEE

 +17       QUIT

 +18      ;

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,PSGOERDP,PSGOPR,PSGOSD,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PSGRD,PSGSD,PSGTOL,PSGTOO,PSGUOW,PSGWLL,RF

           QUIT

 +2       ;

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        DO 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       DO UNL^PSSLOCK(PSGP,PSGORD)

 +11       WRITE ".DONE!"

           SET VALMBCK="Q"

 +12       QUIT

 +13      ;

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

 +2        SET Y=1

           SET (PSJIREQ,PSJRXREQ,INTERVEN,X)=""

 +3        KILL PSGORQF

           DO ENDDC^PSGSICHK(PSGP,+$GET(^PS(55,PSGP,5,+PSGORD,1,1,0)))

 +4        IF '$DATA(PSGORQF)

               KILL PSGORQF,^TMP($JOB,"DI")

               Begin DoDot:1

 +5                FOR PSGDDI=1:0

                       SET PSGDDI=$ORDER(^PS(55,PSGP,5,+PSGORD,1,PSGDDI))

                       IF 'PSGDDI

                           QUIT

                       SET PSJDD=+$GET(^PS(55,PSGP,5,+PSGORD,1,PSGDDI,0))

                       KILL PSJPDRG

                       DO IVSOL^PSGSICHK

               End DoDot:1

 +6        QUIT

 +7       ;

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        NEW 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

PSJCOMR.m