- 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 Jan 18, 2025@03:03:39 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