PSGOERS ;BIR/CML3 - RENEW SELECTED ORDERS ; 10/23/14 9:30pm
;;5.0;INPATIENT MEDICATIONS;**11,29,35,47,58,110,281,327**;16 DEC 97;Build 114
;
; Reference to ^PS(50.7 is supported by DBIA 2180
; Reference to ^PS(55 is supported by DBIA 2191
; Reference to ^PSDRUG( is supported by DBIA 2192
; Reference to ^PSSLOCK is supported by DBIA 2789
; Reference to NOW^%DTC is supported by DBIA 10000
;
MARK ; only mark order, not actually renew
W !,"...marking ",PSGPDRGN," ",PSGDO,"..." S $P(^PS(55,PSGP,5,+PSGORD,4),"^",15,17)="1^"_DUZ_"^"_PSGDT,PSGAL("C")=13180 D ^PSGAL5 W "."
I $D(PSJSYSO) S PSGPOSA="R",PSGPOSD=PSGDT,PSGORD=+PSGORD_"A" D ENPOS^PSGVDS
Q
RENEW ; mark or renew order
D NOW^%DTC K DA S DA(1)=PSGP,DA=+PSGORD,PSGDT=+$E(%,1,12)
I $G(PSGFD)="" S X=$P(PSGFDN,":",1,2) D ^%DT S:Y>0 PSGFD=Y
; do order checking
N PSJABT,PSGDRG,PSGOER1,PSGDO,PSGPDRG,PSGPDRGN,PSGOER0,PSGST,PSGOER2,PSGSI,PSGOSD,PSGOFD,PSGNEDFD,PSGNESD,PSGMR,PSGSM,PSGHSM,PSGSCH,PSGS0Y,PSGS0XT,PSGNEFD
;* S PSGDRG=$P($G(^PS(55,PSGP,5,+PSGORD,1,1,0)),"^")
;* K PSGORQF D ENDDC^PSGSICHK(PSGP,+PSGDRG)
;D OC55^PSGOER
;I $D(PSGORQF) W !!," ",PSGOERS2,". ",$P($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^")," ",$P(^PS(55,PSGP,5,+PSGORD,.2),"^",2),!,"...No action taken on this order...",! Q
;* Q:$D(PSGORQF) ; quit if not to continue
;
S PSGOER1=$G(^PS(55,PSGP,5,+PSGORD,.2)),PSGDO=$P(PSGOER1,"^",2),PSGPDRG=$P(PSGOER1,"^"),PSGPDRGN=$$ENPDN^PSGMI(PSGPDRG) I '$P(PSJSYSP0,"^",3) G MARK
S PSGOER0=$G(^PS(55,PSGP,5,+PSGORD,0)),PSGST=$P(PSGOER0,"^",7),PSGOER2=$G(^(2)),PSGND4=$G(^(4)),PSGSI=$G(^(6)),PSGOSD=$P(PSGOER2,"^",2),PSGOFD=$P(PSGOER2,"^",4),PSGNEDFD=$P($$GTNEDFD^PSGOE7("U",PSGPDRG),U)_"^^"_PSGST
N PSGOEAV S PSGOEAV=1,PSGOORD=PSGORD W "." K ^PS(53.45,PSJSYSP,1),^(2)
I $$CHKDD() W !!,"...",PSGPDRGN," ",PSGDO," order NOT renewed..." Q
; p327
I $$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD) D Q
.W !,"Clozapine orders cannot be renewed."
.W !,"...order NOT renewed..."
;W !!,"...renewing ",PSGOERS2,". ",PSGPDRGN," ",PSGDO,"..."
S PSGMR=$P(PSGOER0,"^",3),PSGMRN=$$ENMRN^PSGMI(PSGMR),PSGSM=$P(PSGOER0,"^",5),PSGHSM=$P(PSGOER0,"^",6),PSGPDRG=$P(PSGOER1,"^"),PSGDO=$P(PSGOER1,"^",2)
S PSGSCH=$P(PSGOER2,"^"),PSGS0Y=$P(PSGOER2,"^",5),PSGS0XT=$P(PSGOER2,"^",6),PSGNESD=PSGSD,PSGNEFD=$S(PSGST="O":PSGSD,1:PSGFD)
S:PSJPWD'=$P(PSGOER2,U,10) PSGS0Y=$$ENRNAT^PSGOU($P(PSGOER2,U,10),+PSJPWD,PSGSCH,PSGS0Y)
;K ^PS(53.45,PSJSYSP,4) S Q=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,12,Q)) Q:'Q S ^PS(53.45,PSJSYSP,4,Q,0)=$G(^(Q,0))
I $O(^PS(55,PSGP,5,+PSGORD,3,0)) S ^PS(53.45,PSJSYSP,1,0)=^(0),Q=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,3,Q)) Q:'Q S ^PS(53.45,PSJSYSP,1,Q,0)=$G(^(Q,0))
I '$O(^PS(53.45,PSJSYSP,2,0)) D
.S X=$O(^PS(55,PSGP,5,+PSGORD,1,0)) I X S (Q,Q1)=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,1,Q)) Q:'Q S ND=$G(^(Q,0)) I ND,$S('$P(ND,"^",3):1,1:$P(ND,"^",3)>DT) S Q1=Q1+1,^PS(53.45,PSJSYSP,2,Q1,0)=$P(ND,"^",1,3)
D NEWOC55^PSGOER I $G(PSGORQF) W !!,"...order NOT renewed..." Q
W !!,"...renewing ",PSGOERS2,". ",PSGPDRGN," ",PSGDO,"..."
D SPEED^PSGOER
; PSGP,PSGORD) D UPDREN(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO),UPDRENOE(PSGP,PSGORD,PSGDT
;S:$S(X:Q1,1:0) ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_Q1_"^"_Q1 D ^PSGOETO I +PSJSYSU=3,PSGOORD["O" D EN^PSGPEN(+PSGORD)
;W !,"...updating original order...",! K DA S DA(1)=PSGP,DA=+PSGOORD,PSGAL("C")=PSJSYSU*10+18000 D ^PSGAL5
;I PSGORD'["O",PSGSD<PSGOFD S PSGALR=70,DIE="^PS(55,"_PSGP_",5,",DR="34////"_+PSGSD S:PSGSD'>PSGDT DR=DR_";28////E"
;I D ^DIE I $P($G(^PS(55,PSGP,5,+PSGOORD,0)),"^",21) D EN1^PSJHL2(PSGP,"SC",PSGOORD,"ORDER EXPIRED")
;S $P(PSGND4,"^",12,14)="^^",$P(PSGND4,"^",15,20)="^^^^^",$P(PSGND4,"^",22,24)="^^",^PS(55,PSGP,5,+PSGOORD,4)=PSGND4,$P(^(0),"^",26,27)=PSGORD_"^R"
Q
CHKDD() ;
I '$$CHKDD^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",") Q 0
I $P(PSJSYSU,";")'=3,'$P(PSJSYSP0,U,2) W !!,"This order's dispense drug is invalid, a pharmacist must renew this order." Q 1
W !!,"THE DISPENSE DRUG IS MISSING FROM THIS ORDER."
D ENDRG^PSGOEF1(+^PS(55,PSGP,5,+PSGORD,.2),0)
I $G(DUOUT) W !,"ORDER NOT RENEW."
Q $G(DUOUT)!'$G(DRG)
EN ;
NEW PSGORQF,PSJOCFG S PSJOCFG="SPEED RENEW"
Q:'$$HIDDEN^PSJLMUTL("SPEED") S PSJSPEED=1
N PSGONR,CODE,ST,DRG,ON S PSGOEORF=1 D FULL^VALM1
S CODE="",PSGONR=0 F S CODE=$O(^TMP("PSJ",$J,CODE)) Q:CODE'="A" D
.S ST="" F S ST=$O(^TMP("PSJ",$J,CODE,ST)) Q:ST="" D
..S DRG="" F S DRG=$O(^TMP("PSJ",$J,CODE,ST,DRG)) Q:DRG="" S ON="" F S ON=$O(^TMP("PSJ",$J,CODE,ST,DRG,ON)) Q:ON="" S PSGONR=PSGONR+1
S PSGONW="R",PSGLMT=PSGONR D ENWO^PSGON I "^"[X K X G DONE
S PSGOSD=0 F PSGOERS=1:1:PSGODDD F PSGOERS1=1:1 S PSGOERS2=$P(PSGODDD(PSGOERS),",",PSGOERS1) Q:'PSGOERS2 S Y=+^TMP("PSJON",$J,PSGOERS2),F=$G(^PS(55,PSGP,5,Y,0)),D=$G(^(.2)) D HMSG I F G EN
I $P(PSJSYSP0,"^",3) D I '$D(PSGFOK) S X="" G DONE
.NEW PSGRENEW S PSGRENEW=1
.S PSGORD=^TMP("PSJON",$J,+PSGODDD(1)),DA=+PSGORD,DA(1)=PSGP,PSGWLL=$S($P(PSJSYSW0,"^",4):+$G(^PS(55,PSGP,5.1)),1:0),PSGOEE="R" W ! D DATE^PSGOER0(PSGP,PSGORD,PSGDT)
.I '$D(PSGFOK(106)) W $C(7),!,"...order",$E("s",$L(PSGODDD(1),",")>2)," NOT renewed..." K PSGFOK Q
.I 'PSGNEDFD,$P(PSJSYSW0,"^",4),PSGFD'<PSGWLL S $P(^PS(55,PSGP,5.1),"^")=+PSGFD
;W ! F PSGOERS=1:1:PSGODDD F PSGOERS1=1:1 S PSGOERS2=$P(PSGODDD(PSGOERS),",",PSGOERS1) Q:'PSGOERS2 S PSGORD=^TMP("PSJON",$J,PSGOERS2) D RENEW
W !
N EXITLOOP S EXITLOOP=0
F PSGOERS=1:1:PSGODDD D
.F PSGOERS1=1:1 D Q:EXITLOOP=1
..S PSGOERS2=$P(PSGODDD(PSGOERS),",",PSGOERS1)
..I 'PSGOERS2 S EXITLOOP=1 Q
..S PSGORD=^TMP("PSJON",$J,PSGOERS2)
..I $$CHKCOM Q
..I '$$LS^PSSLOCK(DFN,PSGORD) W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q
..D RENEW
..; Call the unlock procedure
..D UNL^PSSLOCK(DFN,PSGORD)
..I $G(PSGOORD) D UNL^PSSLOCK(DFN,PSGOORD)
S X=""
DONE ;
D INIT^PSJLMHED(1)
K DA,DIE,DR,FDSD,PSGAL,PSGALR,PSGFD,PSGFOK,PSGLMT,PSGND4,PSGODDD,PSGOERS,PSGOERS1,PSGOERS2,PSGONW,PSGOPR,PSGORD,PSGOSD,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PSGSD
K PSGST,PSGTOL,PSGTOO,PSGUOW,PSGWLL,PSJSPEED,PSGDT,ND,Q,Q1,PSGDO,PSGOER1,PSGPDRG,PSGPDRGN,PSGOER0,PSGOER2,PSGND4,PSGSI,PSGOSD,PSGOFD,PSGNEDFD,%,Y,F,D
Q
GRI ; get renewal info
HMSG ; hold/'not to be given' message
S X=$P($G(^PS(50.7,+D,0)),"^") S:X]"" X=X_" "_$P(D,"^",2)
I $P(F,"^",22) S H="has been marked as 'NOT TO BE GIVEN'" D WO Q
I $P(F,"^",9)="H" S H="is ON HOLD" D WO Q
I $P(F,"^",27)]"",$P(F,"^",26) S H="has been "_$S($P(F,"^",24)="E":"EDITED",1:"RENEWED") D WO Q
I ($P($G(^PS(50.7,+D,0)),"^",4)]"")&($P($G(^(0)),"^",4)'>DT) S H="is no longer an active Orderable Item" D WO Q
N PSGDFLG,DRG,DRGPT
S PSGDFLG=1 F DRG=0:0 S DRG=$O(^PSDRUG("ASP",+D,DRG)) Q:'DRG I $P(^PSDRUG(DRG,2),U,3)["U",($G(^PSDRUG(DRG,"I"))=""!($G(^("I"))>DT)) S PSGDFLG=0 Q
I PSGDFLG S H="is no longer an active Dispense drug" D WO Q
S F=0,X=$P($G(^PS(55,PSGP,5,Y,2)),"^",2) S:X>PSGOSD PSGOSD=X Q
WO ;
W $C(7)," ??",! W:X]"" !,X S H1="Order number "_$G(PSGOERS2)_" "_H_", and cannot be renewed." W ! F H2=1:1:$L(H1," ") S H3=$P(H1," ",H2) W:$L(H3)+$X>78 ! W H3," "
S F=1 K H,H1,H2,H3 Q
CHKCOM() ; Check if this order is a complex order
S PSJCOM=0
I PSGORD=+PSGORD S PSJCOM=PSGORD W !," Order ",PSGOERS2," is part of a complex order series, and cannot be renewed.",! H 2 Q PSJCOM
S PSJCOM=$S(PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8),1:$P($G(^PS(53.1,+PSGORD,.2)),U,8))
I PSJCOM W !," Order ",PSGOERS2," is part of a complex order series, and cannot be renewed.",! H 2
Q PSJCOM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOERS 7539 printed Oct 16, 2024@18:03:11 Page 2
PSGOERS ;BIR/CML3 - RENEW SELECTED ORDERS ; 10/23/14 9:30pm
+1 ;;5.0;INPATIENT MEDICATIONS;**11,29,35,47,58,110,281,327**;16 DEC 97;Build 114
+2 ;
+3 ; Reference to ^PS(50.7 is supported by DBIA 2180
+4 ; Reference to ^PS(55 is supported by DBIA 2191
+5 ; Reference to ^PSDRUG( is supported by DBIA 2192
+6 ; Reference to ^PSSLOCK is supported by DBIA 2789
+7 ; Reference to NOW^%DTC is supported by DBIA 10000
+8 ;
MARK ; only mark order, not actually renew
+1 WRITE !,"...marking ",PSGPDRGN," ",PSGDO,"..."
SET $PIECE(^PS(55,PSGP,5,+PSGORD,4),"^",15,17)="1^"_DUZ_"^"_PSGDT
SET PSGAL("C")=13180
DO ^PSGAL5
WRITE "."
+2 IF $DATA(PSJSYSO)
SET PSGPOSA="R"
SET PSGPOSD=PSGDT
SET PSGORD=+PSGORD_"A"
DO ENPOS^PSGVDS
+3 QUIT
RENEW ; mark or renew order
+1 DO NOW^%DTC
KILL DA
SET DA(1)=PSGP
SET DA=+PSGORD
SET PSGDT=+$EXTRACT(%,1,12)
+2 IF $GET(PSGFD)=""
SET X=$PIECE(PSGFDN,":",1,2)
DO ^%DT
if Y>0
SET PSGFD=Y
+3 ; do order checking
+4 NEW PSJABT,PSGDRG,PSGOER1,PSGDO,PSGPDRG,PSGPDRGN,PSGOER0,PSGST,PSGOER2,PSGSI,PSGOSD,PSGOFD,PSGNEDFD,PSGNESD,PSGMR,PSGSM,PSGHSM,PSGSCH,PSGS0Y,PSGS0XT,PSGNEFD
+5 ;* S PSGDRG=$P($G(^PS(55,PSGP,5,+PSGORD,1,1,0)),"^")
+6 ;* K PSGORQF D ENDDC^PSGSICHK(PSGP,+PSGDRG)
+7 ;D OC55^PSGOER
+8 ;I $D(PSGORQF) W !!," ",PSGOERS2,". ",$P($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^")," ",$P(^PS(55,PSGP,5,+PSGORD,.2),"^",2),!,"...No action taken on this order...",! Q
+9 ;* Q:$D(PSGORQF) ; quit if not to continue
+10 ;
+11 SET PSGOER1=$GET(^PS(55,PSGP,5,+PSGORD,.2))
SET PSGDO=$PIECE(PSGOER1,"^",2)
SET PSGPDRG=$PIECE(PSGOER1,"^")
SET PSGPDRGN=$$ENPDN^PSGMI(PSGPDRG)
IF '$PIECE(PSJSYSP0,"^",3)
GOTO MARK
+12 SET PSGOER0=$GET(^PS(55,PSGP,5,+PSGORD,0))
SET PSGST=$PIECE(PSGOER0,"^",7)
SET PSGOER2=$GET(^(2))
SET PSGND4=$GET(^(4))
SET PSGSI=$GET(^(6))
SET PSGOSD=$PIECE(PSGOER2,"^",2)
SET PSGOFD=$PIECE(PSGOER2,"^",4)
SET PSGNEDFD=$PIECE($$GTNEDFD^PSGOE7("U",PSGPDRG),U)_"^^"_PSGST
+13 NEW PSGOEAV
SET PSGOEAV=1
SET PSGOORD=PSGORD
WRITE "."
KILL ^PS(53.45,PSJSYSP,1),^(2)
+14 IF $$CHKDD()
WRITE !!,"...",PSGPDRGN," ",PSGDO," order NOT renewed..."
QUIT
+15 ; p327
+16 IF $$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD)
Begin DoDot:1
+17 WRITE !,"Clozapine orders cannot be renewed."
+18 WRITE !,"...order NOT renewed..."
End DoDot:1
QUIT
+19 ;W !!,"...renewing ",PSGOERS2,". ",PSGPDRGN," ",PSGDO,"..."
+20 SET PSGMR=$PIECE(PSGOER0,"^",3)
SET PSGMRN=$$ENMRN^PSGMI(PSGMR)
SET PSGSM=$PIECE(PSGOER0,"^",5)
SET PSGHSM=$PIECE(PSGOER0,"^",6)
SET PSGPDRG=$PIECE(PSGOER1,"^")
SET PSGDO=$PIECE(PSGOER1,"^",2)
+21 SET PSGSCH=$PIECE(PSGOER2,"^")
SET PSGS0Y=$PIECE(PSGOER2,"^",5)
SET PSGS0XT=$PIECE(PSGOER2,"^",6)
SET PSGNESD=PSGSD
SET PSGNEFD=$SELECT(PSGST="O":PSGSD,1:PSGFD)
+22 if PSJPWD'=$PIECE(PSGOER2,U,10)
SET PSGS0Y=$$ENRNAT^PSGOU($PIECE(PSGOER2,U,10),+PSJPWD,PSGSCH,PSGS0Y)
+23 ;K ^PS(53.45,PSJSYSP,4) S Q=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,12,Q)) Q:'Q S ^PS(53.45,PSJSYSP,4,Q,0)=$G(^(Q,0))
+24 IF $ORDER(^PS(55,PSGP,5,+PSGORD,3,0))
SET ^PS(53.45,PSJSYSP,1,0)=^(0)
SET Q=0
FOR
SET Q=$ORDER(^PS(55,PSGP,5,+PSGORD,3,Q))
if 'Q
QUIT
SET ^PS(53.45,PSJSYSP,1,Q,0)=$GET(^(Q,0))
+25 IF '$ORDER(^PS(53.45,PSJSYSP,2,0))
Begin DoDot:1
+26 SET X=$ORDER(^PS(55,PSGP,5,+PSGORD,1,0))
IF X
SET (Q,Q1)=0
FOR
SET Q=$ORDER(^PS(55,PSGP,5,+PSGORD,1,Q))
if 'Q
QUIT
SET ND=$GET(^(Q,0))
IF ND
IF $SELECT('$PIECE(ND,"^",3):1,1:$PIECE(ND,"^",3)>DT)
SET Q1=Q1+1
SET ^PS(53.45,PSJSYSP,2,Q1,0)=$PIECE(ND,"^",1,3)
End DoDot:1
+27 DO NEWOC55^PSGOER
IF $GET(PSGORQF)
WRITE !!,"...order NOT renewed..."
QUIT
+28 WRITE !!,"...renewing ",PSGOERS2,". ",PSGPDRGN," ",PSGDO,"..."
+29 DO SPEED^PSGOER
+30 ; PSGP,PSGORD) D UPDREN(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO),UPDRENOE(PSGP,PSGORD,PSGDT
+31 ;S:$S(X:Q1,1:0) ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_Q1_"^"_Q1 D ^PSGOETO I +PSJSYSU=3,PSGOORD["O" D EN^PSGPEN(+PSGORD)
+32 ;W !,"...updating original order...",! K DA S DA(1)=PSGP,DA=+PSGOORD,PSGAL("C")=PSJSYSU*10+18000 D ^PSGAL5
+33 ;I PSGORD'["O",PSGSD<PSGOFD S PSGALR=70,DIE="^PS(55,"_PSGP_",5,",DR="34////"_+PSGSD S:PSGSD'>PSGDT DR=DR_";28////E"
+34 ;I D ^DIE I $P($G(^PS(55,PSGP,5,+PSGOORD,0)),"^",21) D EN1^PSJHL2(PSGP,"SC",PSGOORD,"ORDER EXPIRED")
+35 ;S $P(PSGND4,"^",12,14)="^^",$P(PSGND4,"^",15,20)="^^^^^",$P(PSGND4,"^",22,24)="^^",^PS(55,PSGP,5,+PSGOORD,4)=PSGND4,$P(^(0),"^",26,27)=PSGORD_"^R"
+36 QUIT
CHKDD() ;
+1 IF '$$CHKDD^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",")
QUIT 0
+2 IF $PIECE(PSJSYSU,";")'=3
IF '$PIECE(PSJSYSP0,U,2)
WRITE !!,"This order's dispense drug is invalid, a pharmacist must renew this order."
QUIT 1
+3 WRITE !!,"THE DISPENSE DRUG IS MISSING FROM THIS ORDER."
+4 DO ENDRG^PSGOEF1(+^PS(55,PSGP,5,+PSGORD,.2),0)
+5 IF $GET(DUOUT)
WRITE !,"ORDER NOT RENEW."
+6 QUIT $GET(DUOUT)!'$GET(DRG)
EN ;
+1 NEW PSGORQF,PSJOCFG
SET PSJOCFG="SPEED RENEW"
+2 if '$$HIDDEN^PSJLMUTL("SPEED")
QUIT
SET PSJSPEED=1
+3 NEW PSGONR,CODE,ST,DRG,ON
SET PSGOEORF=1
DO FULL^VALM1
+4 SET CODE=""
SET PSGONR=0
FOR
SET CODE=$ORDER(^TMP("PSJ",$JOB,CODE))
if CODE'="A"
QUIT
Begin DoDot:1
+5 SET ST=""
FOR
SET ST=$ORDER(^TMP("PSJ",$JOB,CODE,ST))
if ST=""
QUIT
Begin DoDot:2
+6 SET DRG=""
FOR
SET DRG=$ORDER(^TMP("PSJ",$JOB,CODE,ST,DRG))
if DRG=""
QUIT
SET ON=""
FOR
SET ON=$ORDER(^TMP("PSJ",$JOB,CODE,ST,DRG,ON))
if ON=""
QUIT
SET PSGONR=PSGONR+1
End DoDot:2
End DoDot:1
+7 SET PSGONW="R"
SET PSGLMT=PSGONR
DO ENWO^PSGON
IF "^"[X
KILL X
GOTO DONE
+8 SET PSGOSD=0
FOR PSGOERS=1:1:PSGODDD
FOR PSGOERS1=1:1
SET PSGOERS2=$PIECE(PSGODDD(PSGOERS),",",PSGOERS1)
if 'PSGOERS2
QUIT
SET Y=+^TMP("PSJON",$JOB,PSGOERS2)
SET F=$GET(^PS(55,PSGP,5,Y,0))
SET D=$GET(^(.2))
DO HMSG
IF F
GOTO EN
+9 IF $PIECE(PSJSYSP0,"^",3)
Begin DoDot:1
+10 NEW PSGRENEW
SET PSGRENEW=1
+11 SET PSGORD=^TMP("PSJON",$JOB,+PSGODDD(1))
SET DA=+PSGORD
SET DA(1)=PSGP
SET PSGWLL=$SELECT($PIECE(PSJSYSW0,"^",4):+$GET(^PS(55,PSGP,5.1)),1:0)
SET PSGOEE="R"
WRITE !
DO DATE^PSGOER0(PSGP,PSGORD,PSGDT)
+12 IF '$DATA(PSGFOK(106))
WRITE $CHAR(7),!,"...order",$EXTRACT("s",$LENGTH(PSGODDD(1),",")>2)," NOT renewed..."
KILL PSGFOK
QUIT
+13 IF 'PSGNEDFD
IF $PIECE(PSJSYSW0,"^",4)
IF PSGFD'<PSGWLL
SET $PIECE(^PS(55,PSGP,5.1),"^")=+PSGFD
End DoDot:1
IF '$DATA(PSGFOK)
SET X=""
GOTO DONE
+14 ;W ! F PSGOERS=1:1:PSGODDD F PSGOERS1=1:1 S PSGOERS2=$P(PSGODDD(PSGOERS),",",PSGOERS1) Q:'PSGOERS2 S PSGORD=^TMP("PSJON",$J,PSGOERS2) D RENEW
+15 WRITE !
+16 NEW EXITLOOP
SET EXITLOOP=0
+17 FOR PSGOERS=1:1:PSGODDD
Begin DoDot:1
+18 FOR PSGOERS1=1:1
Begin DoDot:2
+19 SET PSGOERS2=$PIECE(PSGODDD(PSGOERS),",",PSGOERS1)
+20 IF 'PSGOERS2
SET EXITLOOP=1
QUIT
+21 SET PSGORD=^TMP("PSJON",$JOB,PSGOERS2)
+22 IF $$CHKCOM
QUIT
+23 IF '$$LS^PSSLOCK(DFN,PSGORD)
WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$CHAR(7)
HANG 1
QUIT
+24 DO RENEW
+25 ; Call the unlock procedure
+26 DO UNL^PSSLOCK(DFN,PSGORD)
+27 IF $GET(PSGOORD)
DO UNL^PSSLOCK(DFN,PSGOORD)
End DoDot:2
if EXITLOOP=1
QUIT
End DoDot:1
+28 SET X=""
DONE ;
+1 DO INIT^PSJLMHED(1)
+2 KILL DA,DIE,DR,FDSD,PSGAL,PSGALR,PSGFD,PSGFOK,PSGLMT,PSGND4,PSGODDD,PSGOERS,PSGOERS1,PSGOERS2,PSGONW,PSGOPR,PSGORD,PSGOSD,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PSGSD
+3 KILL PSGST,PSGTOL,PSGTOO,PSGUOW,PSGWLL,PSJSPEED,PSGDT,ND,Q,Q1,PSGDO,PSGOER1,PSGPDRG,PSGPDRGN,PSGOER0,PSGOER2,PSGND4,PSGSI,PSGOSD,PSGOFD,PSGNEDFD,%,Y,F,D
+4 QUIT
GRI ; get renewal info
HMSG ; hold/'not to be given' message
+1 SET X=$PIECE($GET(^PS(50.7,+D,0)),"^")
if X]""
SET X=X_" "_$PIECE(D,"^",2)
+2 IF $PIECE(F,"^",22)
SET H="has been marked as 'NOT TO BE GIVEN'"
DO WO
QUIT
+3 IF $PIECE(F,"^",9)="H"
SET H="is ON HOLD"
DO WO
QUIT
+4 IF $PIECE(F,"^",27)]""
IF $PIECE(F,"^",26)
SET H="has been "_$SELECT($PIECE(F,"^",24)="E":"EDITED",1:"RENEWED")
DO WO
QUIT
+5 IF ($PIECE($GET(^PS(50.7,+D,0)),"^",4)]"")&($PIECE($GET(^(0)),"^",4)'>DT)
SET H="is no longer an active Orderable Item"
DO WO
QUIT
+6 NEW PSGDFLG,DRG,DRGPT
+7 SET PSGDFLG=1
FOR DRG=0:0
SET DRG=$ORDER(^PSDRUG("ASP",+D,DRG))
if 'DRG
QUIT
IF $PIECE(^PSDRUG(DRG,2),U,3)["U"
IF ($GET(^PSDRUG(DRG,"I"))=""!($GET(^("I"))>DT))
SET PSGDFLG=0
QUIT
+8 IF PSGDFLG
SET H="is no longer an active Dispense drug"
DO WO
QUIT
+9 SET F=0
SET X=$PIECE($GET(^PS(55,PSGP,5,Y,2)),"^",2)
if X>PSGOSD
SET PSGOSD=X
QUIT
WO ;
+1 WRITE $CHAR(7)," ??",!
if X]""
WRITE !,X
SET H1="Order number "_$GET(PSGOERS2)_" "_H_", and cannot be renewed."
WRITE !
FOR H2=1:1:$LENGTH(H1," ")
SET H3=$PIECE(H1," ",H2)
if $LENGTH(H3)+$X>78
WRITE !
WRITE H3," "
+2 SET F=1
KILL H,H1,H2,H3
QUIT
CHKCOM() ; Check if this order is a complex order
+1 SET PSJCOM=0
+2 IF PSGORD=+PSGORD
SET PSJCOM=PSGORD
WRITE !," Order ",PSGOERS2," is part of a complex order series, and cannot be renewed.",!
HANG 2
QUIT PSJCOM
+3 SET PSJCOM=$SELECT(PSGORD["U":$PIECE($GET(^PS(55,PSGP,5,+PSGORD,.2)),U,8),1:$PIECE($GET(^PS(53.1,+PSGORD,.2)),U,8))
+4 IF PSJCOM
WRITE !," Order ",PSGOERS2," is part of a complex order series, and cannot be renewed.",!
HANG 2
+5 QUIT PSJCOM
