PSGOER ;BIR/CML3 - RENEW A SINGLE ORDER ;12 June 2019 09:31:53
;;5.0;INPATIENT MEDICATIONS ;**11,30,29,35,70,58,95,110,111,133,141,198,181,246,278,281,315,338,256,347,327**;16 DEC 97;Build 114
;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference to ^PS(51.1 via DBIA 2177
; Reference to ^PS(55 via DBIA 2191
; Reference to ^PSSLOCK via DBIA 2789
; Reference to ^PSBAPIPM via DBIA 3564
; Reference to ^PS(59.7 via DBIA 2181
; Reference to ^PSDRUG( via DBIA 2192
; Reference to ^TMP("PSODAOC",$J via DBIA 6071
;
; renew a single order
I $G(PSJCOM) D ^PSJCOMR Q
N PSJEXPIR S PSJEXPIR=$$EXPIRED(PSGP,PSGORD) I PSJEXPIR D Q
.W !!?3," THIS ORDER" W:PSJEXPIR'=2 " HAS BEEN INACTIVE FOR ONE OR MORE SCHEDULED",!?8," ADMINISTRATIONS AND"
.W " CANNOT BE RENEWED!" D PAUSE^VALM1
I $G(PSGSCH)]"",($G(PSGS0XT)="D"),($G(PSGAT)="") D Q
.N SWD,SDW,XABB,X,QX S X=$G(PSGSCH) D DW^PSGS0 Q:($G(X)="") I $G(PSGS0XT)="" S PSGS0XT="D"
.Q:((",P,R,")[(","_$G(PSGST)_","))
.I $G(PSGS0XT)="D",$G(PSGAT)="" S CHK=1 W !!?3,"This order contains a 'DAY OF THE WEEK' schedule without admin times"
.W !?11," and CANNOT be renewed!" D PAUSE^VALM1
I $G(PSGSCH)]"",'$$DOW^PSIVUTL(PSGSCH),'$$PRNOK^PSGS0(PSGSCH) I '$D(^PS(51.1,"AC","PSJ",PSGSCH)) D Q
.;PSJ*5*256
.NEW PSJOLDNM
.S PSJOLDNM("ORD_SCHD")=PSGSCH
.I (PSGSCH]""),$$CHKSCHD^PSJMISC2(.PSJOLDNM,"R") K PSJOLDNM Q
.K PSJOLDNM
.W !!?3,"This order contains an invalid schedule and CANNOT be renewed!" D PAUSE^VALM1
W !! K DIR S DIR(0)="Y",DIR("A")=$S($P(PSJSYSP0,"^",3):"RENEW THIS ORDER",1:"MARK THIS ORDER FOR RENEWAL"),DIR("B")="YES"
S DIR("?")="Answer 'YES' to "_$S($P(PSJSYSP0,"^",3):"renew this order",1:"mark this order for renewal")_". Answer 'NO' (or '^') to stop now." D ^DIR
I '$D(DIRUT),Y D NEW S PSGCANFL=1 D DONE Q
I '$D(DIRUT),PSJSYSU S PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4)) I $P(PSGND4,"^",15),$P(PSGND4,"^",16) D UNMARK,DONE Q
D DONE,ABORT^PSGOEE
Q
;
UNMARK ;
W !!,"THIS ORDER 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 order. Answer 'NO' (or '^') to leave the order",DIR("?")="marked. (An answer is required.)" D ^DIR
I 'Y D ABORT^PSGOEE G DONE
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,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PSGRD,PSGSD,PSGTOL,PSGTOO,PSGUOW,PSGWLL,RF Q
;
NEW ; get info, write record
EXTEND ; extend stop date on renewal order
N DUOUT,PSJABT,PSGDRG,PSJREN,PSGOREAS S PSGDRG=$P($G(^PS(55,PSGP,5,+PSGORD,1,1,0)),"^"),PSJREN=1
I $G(PSGST)="O" N ACT S ACT=$$EN^PSBAPIPM(PSGP,PSGORD) I $P(ACT,"^",2),($P(ACT,"^",3)="G") I $P(ACT,"^",2)>$P($G(^PS(55,PSGP,5,+PSGORD,2)),"^",2) D Q
. W !!?5,"THIS ONE-TIME ORDER HAS ALREADY BEEN GIVEN AND CANNOT BE RENEWED",! S (DIRUT,PSGORQF)=1 D READ
;D OC55
;Q:$D(PSGORQF) ; quit if not to continue
;; START NCC T4 MODS >> 327*RJS
N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD) I CLOZFLG D
.N PSGDRG,PSGPR S PSGDRG=$P(CLOZFLG,U,2),PSGPR=PSGOPR D CLOZ^PSJCLOZ(DFN,PSGDRG) S:$G(ANQX) PSGCANFL=1
;; END NCC T4 MODS >> 327*RJS
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 ($G(X)="^")!'$D(PSGFOK(106))!$G(DUOUT) D DONE,ABORT^PSGOEE S VALMBCK="R",COMQUIT=1 Q
;D OC55
;I $G(PSGORQF) D DONE,ABORT^PSGOEE S VALMBCK="R",COMQUIT=1 Q
SPEED ;
I +$G(PSJSYSU)=3 D EN^PSGPEN(PSGORD)
Q:$G(DUOUT)
N PSGOEAV S PSGOEAV=+PSJSYSU
W !!,"...updating order..." K DA S DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=PSJSYSU*10+18000 D ^PSGAL5 W "."
I $$LS^PSSLOCK(PSGP,PSGORD) D UPDREN(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO),UPDRENOE(PSGP,PSGORD,PSGDT) D UNL^PSSLOCK(PSGP,PSGORD)
S ^TMP("PSODAOC",$J,"IP IEN")=PSGORD ;set up which IEN will be used to store order checks
D SETOC^PSJNEWOC(PSGORD) ;PSJ*5*281 stores order checks
K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J)
;
I 'PSGOERDP,$P(PSJSYSW0,"^",4),PSGFD'<PSGWLL S $P(^PS(55,PSGP,5.1),"^")=+PSGFD
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 ^PS(53.45,PSJSYSP,Y,0)="^53.450"_Y_"P^"_Q_U_Q
;S:Q ^PS(53.45,Y,0)="^53.450"_Y_"P^"_Q_U_Q
Q
OC55 ;* Order checks for Speed finish and regular finish
;PSJ*5*181 - no longer use (OC will be triggered from OC^PSGOER0)
Q
NEWOC55 ;
N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJPDRG,PSJDD,PSJDD0,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 PSJDD0=$G(^PS(55,PSGP,5,+PSGORD,1,PSGDDI,0))
. S PSJX=$P(PSJDD0,U,3) I PSJX]"",(PSJX'>$G(PSGDT)) Q
. S PSJDD=+PSJDD0
. S PSJX=$S('$D(^PSDRUG(+PSJDD,0)):1,$P($G(^(2)),U,3)'["U":1,$G(^("I"))="":0,1:^("I")'>$G(PSGDT))
. Q:PSJX
. S PSJALLGY(PSJDD)=""
S PSJDD=$O(PSJALLGY(0))
I '+PSJDD W !!,"No active dispense drug was found" D PAUSE^PSJLMUT1 Q
K PSGORQF D ENDDC^PSGSICHK(PSGP,PSJDD)
D:'$G(PSGORQF) IN^PSJOCDS(PSGORD,"UD",PSJDD) Q:$G(PSGORQF)
Q
UPDREN(PSGORD,RNWDT,PSGOEPR,PSGOFD,PSJNOO,RDUZ) ; update renewed order
N DR,DA,DIC,DIE,DD,DO,PSGRZERO,PSGRFOUR,PSGOORD
S DR="",PSGOEENO=0,PSGOORD=PSGORD,PSGNESD=PSGSD Q:'PSGORD!'RNWDT!'PSGOEPR!'PSGOFD S PSJNOO=$S($G(PSJNOO)]"":$G(PSJNOO),1:"E")
S PSGRZERO="^PS(55,"_PSGP_",5,"_+PSGORD_",0)",PSGOEORD=$P(@PSGRZERO,"^",21)
; PSJ*5*141 - changed PSGOEPR to PSGPR for field 1 of the DR string below.
S DA(1)=PSGP,DA=+PSGORD,DIE="^PS(55,"_PSGP_",5," S DR="34////^S X=PSGFD" S:$G(PSGPR) DR=DR_";1////"_PSGPR_";110////"_PSJNOO D ^DIE
K DR,DA,DIC,DIE,DD,DO S DIC="^PS(55,"_PSGP_",5,"_+PSGORD_",14,",DIC(0)="L",DIC("P")="55.6114DA",ND14=$G(@(DIC_"0)")),DINUM=$P(ND14,"^",3)+1,DA(2)=PSGP,DA(1)=+PSGORD D
. S DIC("DR")=".01////"_$G(RNWDT)_";1////"_$S($G(RDUZ):RDUZ,1:$G(DUZ))_";2////"_$G(PSGOEPR)_";3////"_$G(PSGOFD)_";4////"_+PSGOEORD,X=$G(RNWDT) D FILE^DICN
K DR,DA,DIC,DIE,DD,DO S DA(1)=PSGP,DA=+PSGORD,DIE="^PS(55,"_PSGP_",5,",DR="28////A;105////@;107////@"
;PSJ*5*198
S PSGRFOUR="^PS(55,"_PSGP_",5,"_+PSGORD_",4)",PSGRFOUR=@PSGRFOUR I $P(PSGRFOUR,"^",2)<RNWDT S DR=DR_";16////@;17////@" I $G(PSJORD)["P",+PSJSYSU=1 S DR=DR_";18////@;19////@"
I '$G(PSJSPEED) I $G(PSGAT)]"",$G(PSGAT)'=$P($G(@(DIE_+PSGORD_",2)")),"^",5) S DR=DR_";41////"_PSGAT
D ^DIE
; PSJ*5*278 - Check to re-assign orderable item
N PSGPOI S PSGPOI=$$ACTIVE^PSJORREN(PSGP,PSGORD) Q:+PSGPOI=1 ;Quit if no change to OI
I +PSGPOI>1,$P(PSGPOI,U,2) D ;replace OI
. N DR,DA,DIE S DA(1)=PSGP,DA=+PSGORD,DIE="^PS(55,"_PSGP_",5,",DR="108///^S X=$P(PSGPOI,U,2)" D ^DIE
Q
UPDRENOE(PSGP,PSGORD,RDATE) ;
D EXPOE(PSGP,PSGORD,$G(RDATE)) ; expire original Orders File order
I PSGORD'["P" K DA,DR,DIE S DA(1)=DFN,DA=+PSGORD,DIE="^PS(55,"_DFN_$S(PSGORD="U":",5,",1:",""IV"","),DR=$S(DIE["IV":110,1:66)_"////@" D ^DIE
D ENUDTX^PSJOREN(PSGP,PSGORD,"NR")
D EN1^PSJHL2(PSGP,"SN",PSGORD,"ORDER RENEWED")
Q
READ ; hold screen
I $D(IOST) Q:$E(IOST)'="C"
W !?5,"Press return to continue " R X:$S($D(DTIME):DTIME,1:300)
Q
EXPOE(DFN,PSJORDER,EXPDT) ; expire old Orders File entry
I PSJORDER["P" S FILE="^PS(53.1,"_+PSJORDER_",0)",PSJORDER=$P(@FILE,"^",25)
I (PSJORDER'["U"),(PSJORDER'["V") Q
N CURDAT D NOW^%DTC S CURDAT=$$DATE2^PSJUTL2(%)
S PSJEXPOE=$S($G(EXPDT):EXPDT,1:CURDAT) D EN1^PSJHL2(DFN,"SC",PSJORDER) K PSJEXPOE
Q
EXPIRED(PSJX,PSJY) ;
; INPUT
; PSJX - Pharmacy Patient, pointer to ^PS(55
; PSJY - Inpatient Order Number(appended with "V" or "U")
; OUTPUT
; 0 - Order has not exceeded the Expired Time Limit
; 1 - Order has exceeded the Expired Time Limit
N STOP,STATUS,NOW,CUTOFF,FREQ,LAST,ST,X,DFN,U,PSGDT,SD,WD,PSJPSTO,PSGDW,PSGOC,ZZND,LASTAT,LSTSTR,PSBCNT S DFN=PSJX,U="^",CUTOFF=0
S STATUS=$S(PSJY["U":$P($G(^PS(55,PSJX,5,+PSJY,0)),"^",9),PSJY["V":$P($G(^PS(55,PSJX,"IV",+PSJY,0)),"^",17),1:"")
S NOW=$S($G(PSGDT):PSGDT,1:$$DATE^PSJUTL2())
S STOP=$S(PSJY["U":$P($G(^PS(55,PSJX,5,+PSJY,2)),U,4),1:$P($G(^PS(55,PSJX,"IV",+PSJY,0)),"^",3))
I NOW<STOP Q 0
;*315 ND2P1 ON NEXT LINE
I PSJY["U" N ND2,ND0 S ND0=$G(^PS(55,PSJX,5,+PSJY,0)),ND2=$G(^PS(55,PSJX,5,+PSJY,2)),ND2P1=$G(^PS(55,PSJX,5,+PSJY,2.1)),FREQ=$P(ND2,"^",6) D
.N SCHED S SCHED=$P($G(^PS(55,PSJX,5,+PSJY,2)),"^") I SCHED["PRN" S FREQ=$$PRNFREQ(SCHED)
.S LSTSTR=$P(ND2,"^",2)_"^"_$P(ND2,"^",4)_"^"_SCHED_"^"_$P(ND0,"^",7)_"^^"_$P(ND2,"^",5)
.S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I LAST,($P(ND0,"^",7)="O"),($P(LAST,"^",3)="G") I LAST>$P(ND2,"^",2) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
.I 'LAST!(LAST>$P(ND2,"^",4)) S LAST=$$LASTAT^PSJORP2(DFN,LSTSTR) S:LAST CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ) Q
.I SCHED["PRN",($P(LSTSTR,"^",6)="") S CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ) Q
.I $$DOW^PSIVUTL(SCHED) S CUTOFF=$$NXTDOW(DFN,$P(LSTSTR,"^"),$P(LSTSTR,"^",2),$P(LSTSTR,"^",3),$P(LSTSTR,"^",6)) Q
.S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I 'LAST!(LAST>$P(ND2,"^",4)) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
.S $P(LSTSTR,"^")=$$FMADD^XLFDT(LAST,,,,1),$P(LSTSTR,"^",2)=$$FMADD^XLFDT(PSGDT,,,FREQ) S CUTOFF=$$ENQ^PSJORP2(PSJX,LSTSTR)
I PSJY["V" N LIMIT S LIMIT=$P($G(^PS(59.7,1,31)),"^",4) S LIMIT=$S((LIMIT]""):+LIMIT,1:24) S CUTOFF=$$FMADD^XLFDT(STOP,,LIMIT) D
.I '($G(P(4))]"") N P,YP,XP S YP=$G(^PS(55,DFN,"IV",+PSJY,0)) F XP=1:1:23 S P(XP)=$P(YP,U,XP)
.Q:'($G(P(4))]"")
.Q:'$$SCHREQ^PSJLIVFD(.P)
.N INTERVAL,LSTSTR,ND0,SCHED,IVSTYP S ND0=$G(^PS(55,PSJX,"IV",+PSJY,0)),INTERVAL=$P(ND0,"^",15),SCHED=$P(ND0,"^",9) Q:SCHED=""
.S IVSTYP=$S($$DOW^PSIVUTL(SCHED):"D",INTERVAL="O":"O",1:"C"),LSTSTR=$P(ND0,"^",2)_"^"_$P(ND0,"^",3)_"^"_SCHED_"^"_IVSTYP_"^^"_$P(ND0,"^",11)
.S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I LAST,IVSTYP="O",LAST>$P(ND0,"^",2),($P(LAST,"^",3)="G") S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
.I 'LAST!(LAST>$P(ND0,"^",3))!(LAST&(IVSTYP="O")) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
.I IVSTYP="D" S CUTOFF=$$NXTDOW(LAST,SCHED,$G(P(2)),$P($G(P(9)),"@"),$G(P(11))) Q
.I SCHED["PRN" S FREQ=$$PRNFREQ(SCHED) S CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ) Q
.S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I 'LAST!(LAST>$P(ND0,"^",3)) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
.S $P(LSTSTR,"^")=$$FMADD^XLFDT(LAST,,,,1),$P(LSTSTR,"^",2)=$$FMADD^XLFDT(PSGDT,31) S CUTOFF=$$ENQ^PSJORP2(PSJX,LSTSTR)
K LYN,PSBDT,PSBFLAG,PSBSTR
Q $S(CUTOFF<NOW:1,1:0)
;
NXTDOW(DOWDFN,DOWSD,DOWFD,DOWSCH,DOWAT) ;
N NXTADM,DOWSTR S DOWSTR=$$FMADD^XLFDT(DOWFD,,,,1)_"^"_$$FMADD^XLFDT(DOWFD,7)_"^"_DOWSCH_"^D^^"_DOWAT S NXTADM=$$ENQ^PSJORP2(DOWDFN,DOWSTR)
Q $S(NXTADM:NXTADM,1:DOWSD)
;
PRNFREQ(SCHED) ;
N ZZND,D,DA,X,PSGAT,PSGOES,PSGST,PSJNSS,PSJPWD,TEST,VALMBCK,PSGS0XT,PSGS0Y,PSGDT
F X=$P(SCHED,"PRN"),$P(SCHED,"PRN",2),$P(SCHED," PRN"),$P(SCHED,"PRN ",2) Q:$P($G(ZZND),"^",4) D ADMIN^PSJORPOE
Q $S($G(PSGS0XT):PSGS0XT,1:1440)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOER 11487 printed Apr 09, 2024@21:05:47 Page 2
PSGOER ;BIR/CML3 - RENEW A SINGLE ORDER ;12 June 2019 09:31:53
+1 ;;5.0;INPATIENT MEDICATIONS ;**11,30,29,35,70,58,95,110,111,133,141,198,181,246,278,281,315,338,256,347,327**;16 DEC 97;Build 114
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference to ^PS(51.1 via DBIA 2177
+5 ; Reference to ^PS(55 via DBIA 2191
+6 ; Reference to ^PSSLOCK via DBIA 2789
+7 ; Reference to ^PSBAPIPM via DBIA 3564
+8 ; Reference to ^PS(59.7 via DBIA 2181
+9 ; Reference to ^PSDRUG( via DBIA 2192
+10 ; Reference to ^TMP("PSODAOC",$J via DBIA 6071
+11 ;
+12 ; renew a single order
+13 IF $GET(PSJCOM)
DO ^PSJCOMR
QUIT
+14 NEW PSJEXPIR
SET PSJEXPIR=$$EXPIRED(PSGP,PSGORD)
IF PSJEXPIR
Begin DoDot:1
+15 WRITE !!?3," THIS ORDER"
if PSJEXPIR'=2
WRITE " HAS BEEN INACTIVE FOR ONE OR MORE SCHEDULED",!?8," ADMINISTRATIONS AND"
+16 WRITE " CANNOT BE RENEWED!"
DO PAUSE^VALM1
End DoDot:1
QUIT
+17 IF $GET(PSGSCH)]""
IF ($GET(PSGS0XT)="D")
IF ($GET(PSGAT)="")
Begin DoDot:1
+18 NEW SWD,SDW,XABB,X,QX
SET X=$GET(PSGSCH)
DO DW^PSGS0
if ($GET(X)="")
QUIT
IF $GET(PSGS0XT)=""
SET PSGS0XT="D"
+19 if ((",P,R,")[(","_$GET(PSGST)_","))
QUIT
+20 IF $GET(PSGS0XT)="D"
IF $GET(PSGAT)=""
SET CHK=1
WRITE !!?3,"This order contains a 'DAY OF THE WEEK' schedule without admin times"
+21 WRITE !?11," and CANNOT be renewed!"
DO PAUSE^VALM1
End DoDot:1
QUIT
+22 IF $GET(PSGSCH)]""
IF '$$DOW^PSIVUTL(PSGSCH)
IF '$$PRNOK^PSGS0(PSGSCH)
IF '$DATA(^PS(51.1,"AC","PSJ",PSGSCH))
Begin DoDot:1
+23 ;PSJ*5*256
+24 NEW PSJOLDNM
+25 SET PSJOLDNM("ORD_SCHD")=PSGSCH
+26 IF (PSGSCH]"")
IF $$CHKSCHD^PSJMISC2(.PSJOLDNM,"R")
KILL PSJOLDNM
QUIT
+27 KILL PSJOLDNM
+28 WRITE !!?3,"This order contains an invalid schedule and CANNOT be renewed!"
DO PAUSE^VALM1
End DoDot:1
QUIT
+29 WRITE !!
KILL DIR
SET DIR(0)="Y"
SET DIR("A")=$SELECT($PIECE(PSJSYSP0,"^",3):"RENEW THIS ORDER",1:"MARK THIS ORDER FOR RENEWAL")
SET DIR("B")="YES"
+30 SET DIR("?")="Answer 'YES' to "_$SELECT($PIECE(PSJSYSP0,"^",3):"renew this order",1:"mark this order for renewal")_". Answer 'NO' (or '^') to stop now."
DO ^DIR
+31 IF '$DATA(DIRUT)
IF Y
DO NEW
SET PSGCANFL=1
DO DONE
QUIT
+32 IF '$DATA(DIRUT)
IF PSJSYSU
SET PSGND4=$GET(^PS(55,PSGP,5,+PSGORD,4))
IF $PIECE(PSGND4,"^",15)
IF $PIECE(PSGND4,"^",16)
DO UNMARK
DO DONE
QUIT
+33 DO DONE
DO ABORT^PSGOEE
+34 QUIT
+35 ;
UNMARK ;
+1 WRITE !!,"THIS ORDER 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 order. Answer 'NO' (or '^') to leave the order"
SET DIR("?")="marked. (An answer is required.)"
DO ^DIR
+3 IF 'Y
DO ABORT^PSGOEE
GOTO DONE
+4 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!"
+5 ;
DONE ;
+1 KILL %DT,DA,DIE,DIR,DR,FDSD,PSGAL,PSGALR,PSGDL,PSGDLS,PSGFD,PSGFOK,PSGND4,PSGOEE,PSGOER0,PSGOER1,PSGOER2,PSGOERDP,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PSGRD,PSGSD,PSGTOL,PSGTOO,PSGUOW,PSGWLL,RF
QUIT
+2 ;
NEW ; get info, write record
EXTEND ; extend stop date on renewal order
+1 NEW DUOUT,PSJABT,PSGDRG,PSJREN,PSGOREAS
SET PSGDRG=$PIECE($GET(^PS(55,PSGP,5,+PSGORD,1,1,0)),"^")
SET PSJREN=1
+2 IF $GET(PSGST)="O"
NEW ACT
SET ACT=$$EN^PSBAPIPM(PSGP,PSGORD)
IF $PIECE(ACT,"^",2)
IF ($PIECE(ACT,"^",3)="G")
IF $PIECE(ACT,"^",2)>$PIECE($GET(^PS(55,PSGP,5,+PSGORD,2)),"^",2)
Begin DoDot:1
+3 WRITE !!?5,"THIS ONE-TIME ORDER HAS ALREADY BEEN GIVEN AND CANNOT BE RENEWED",!
SET (DIRUT,PSGORQF)=1
DO READ
End DoDot:1
QUIT
+4 ;D OC55
+5 ;Q:$D(PSGORQF) ; quit if not to continue
+6 ;; START NCC T4 MODS >> 327*RJS
+7 NEW CLOZFLG
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD)
IF CLOZFLG
Begin DoDot:1
+8 NEW PSGDRG,PSGPR
SET PSGDRG=$PIECE(CLOZFLG,U,2)
SET PSGPR=PSGOPR
DO CLOZ^PSJCLOZ(DFN,PSGDRG)
if $GET(ANQX)
SET PSGCANFL=1
End DoDot:1
+9 ;; END NCC T4 MODS >> 327*RJS
+10 DO NOW^%DTC
SET PSGDT=%
SET PSGND4=$GET(^PS(55,PSGP,5,+PSGORD,4))
IF '$PIECE(PSJSYSP0,"^",3)
DO MARK
QUIT
+11 SET PSGWLL=$SELECT('$PIECE(PSJSYSW0,"^",4):0,1:+$GET(^PS(55,PSGP,5.1)))
SET PSGOEE="R"
KILL PSGOEOS
+12 KILL ^PS(53.45,PSJSYSP,1),^(2)
DO MOVE(3,1)
DO MOVE(1,2)
+13 DO DATE^PSGOER0(PSGP,PSGORD,PSGDT)
IF ($GET(X)="^")!'$DATA(PSGFOK(106))!$GET(DUOUT)
DO DONE
DO ABORT^PSGOEE
SET VALMBCK="R"
SET COMQUIT=1
QUIT
+14 ;D OC55
+15 ;I $G(PSGORQF) D DONE,ABORT^PSGOEE S VALMBCK="R",COMQUIT=1 Q
SPEED ;
+1 IF +$GET(PSJSYSU)=3
DO EN^PSGPEN(PSGORD)
+2 if $GET(DUOUT)
QUIT
+3 NEW PSGOEAV
SET PSGOEAV=+PSJSYSU
+4 WRITE !!,"...updating order..."
KILL DA
SET DA(1)=PSGP
SET DA=+PSGORD
SET PSGAL("C")=PSJSYSU*10+18000
DO ^PSGAL5
WRITE "."
+5 IF $$LS^PSSLOCK(PSGP,PSGORD)
DO UPDREN(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO)
DO UPDRENOE(PSGP,PSGORD,PSGDT)
DO UNL^PSSLOCK(PSGP,PSGORD)
+6 ;set up which IEN will be used to store order checks
SET ^TMP("PSODAOC",$JOB,"IP IEN")=PSGORD
+7 ;PSJ*5*281 stores order checks
DO SETOC^PSJNEWOC(PSGORD)
+8 KILL ^TMP("PSODAOC",$JOB),^TMP("PSJDAOC",$JOB)
+9 ;
+10 IF 'PSGOERDP
IF $PIECE(PSJSYSW0,"^",4)
IF PSGFD'<PSGWLL
SET $PIECE(^PS(55,PSGP,5.1),"^")=+PSGFD
+11 WRITE ".DONE!"
SET VALMBCK="Q"
QUIT
+12 ;
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))
SET ^PS(53.45,PSJSYSP,Y,0)="^53.450"_Y_"P^"_Q_U_Q
+2 ;S:Q ^PS(53.45,Y,0)="^53.450"_Y_"P^"_Q_U_Q
+3 QUIT
OC55 ;* Order checks for Speed finish and regular finish
+1 ;PSJ*5*181 - no longer use (OC will be triggered from OC^PSGOER0)
+2 QUIT
NEWOC55 ;
+1 NEW INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJPDRG,PSJDD,PSJDD0,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 PSJDD0=$GET(^PS(55,PSGP,5,+PSGORD,1,PSGDDI,0))
+5 SET PSJX=$PIECE(PSJDD0,U,3)
IF PSJX]""
IF (PSJX'>$GET(PSGDT))
QUIT
+6 SET PSJDD=+PSJDD0
+7 SET PSJX=$SELECT('$DATA(^PSDRUG(+PSJDD,0)):1,$PIECE($GET(^(2)),U,3)'["U":1,$GET(^("I"))="":0,1:^("I")'>$GET(PSGDT))
+8 if PSJX
QUIT
+9 SET PSJALLGY(PSJDD)=""
End DoDot:1
+10 SET PSJDD=$ORDER(PSJALLGY(0))
+11 IF '+PSJDD
WRITE !!,"No active dispense drug was found"
DO PAUSE^PSJLMUT1
QUIT
+12 KILL PSGORQF
DO ENDDC^PSGSICHK(PSGP,PSJDD)
+13 if '$GET(PSGORQF)
DO IN^PSJOCDS(PSGORD,"UD",PSJDD)
if $GET(PSGORQF)
QUIT
+14 QUIT
UPDREN(PSGORD,RNWDT,PSGOEPR,PSGOFD,PSJNOO,RDUZ) ; update renewed order
+1 NEW DR,DA,DIC,DIE,DD,DO,PSGRZERO,PSGRFOUR,PSGOORD
+2 SET DR=""
SET PSGOEENO=0
SET PSGOORD=PSGORD
SET PSGNESD=PSGSD
if 'PSGORD!'RNWDT!'PSGOEPR!'PSGOFD
QUIT
SET PSJNOO=$SELECT($GET(PSJNOO)]"":$GET(PSJNOO),1:"E")
+3 SET PSGRZERO="^PS(55,"_PSGP_",5,"_+PSGORD_",0)"
SET PSGOEORD=$PIECE(@PSGRZERO,"^",21)
+4 ; PSJ*5*141 - changed PSGOEPR to PSGPR for field 1 of the DR string below.
+5 SET DA(1)=PSGP
SET DA=+PSGORD
SET DIE="^PS(55,"_PSGP_",5,"
SET DR="34////^S X=PSGFD"
if $GET(PSGPR)
SET DR=DR_";1////"_PSGPR_";110////"_PSJNOO
DO ^DIE
+6 KILL DR,DA,DIC,DIE,DD,DO
SET DIC="^PS(55,"_PSGP_",5,"_+PSGORD_",14,"
SET DIC(0)="L"
SET DIC("P")="55.6114DA"
SET ND14=$GET(@(DIC_"0)"))
SET DINUM=$PIECE(ND14,"^",3)+1
SET DA(2)=PSGP
SET DA(1)=+PSGORD
Begin DoDot:1
+7 SET DIC("DR")=".01////"_$GET(RNWDT)_";1////"_$SELECT($GET(RDUZ):RDUZ,1:$GET(DUZ))_";2////"_$GET(PSGOEPR)_";3////"_$GET(PSGOFD)_";4////"_+PSGOEORD
SET X=$GET(RNWDT)
DO FILE^DICN
End DoDot:1
+8 KILL DR,DA,DIC,DIE,DD,DO
SET DA(1)=PSGP
SET DA=+PSGORD
SET DIE="^PS(55,"_PSGP_",5,"
SET DR="28////A;105////@;107////@"
+9 ;PSJ*5*198
+10 SET PSGRFOUR="^PS(55,"_PSGP_",5,"_+PSGORD_",4)"
SET PSGRFOUR=@PSGRFOUR
IF $PIECE(PSGRFOUR,"^",2)<RNWDT
SET DR=DR_";16////@;17////@"
IF $GET(PSJORD)["P"
IF +PSJSYSU=1
SET DR=DR_";18////@;19////@"
+11 IF '$GET(PSJSPEED)
IF $GET(PSGAT)]""
IF $GET(PSGAT)'=$PIECE($GET(@(DIE_+PSGORD_",2)")),"^",5)
SET DR=DR_";41////"_PSGAT
+12 DO ^DIE
+13 ; PSJ*5*278 - Check to re-assign orderable item
+14 ;Quit if no change to OI
NEW PSGPOI
SET PSGPOI=$$ACTIVE^PSJORREN(PSGP,PSGORD)
if +PSGPOI=1
QUIT
+15 ;replace OI
IF +PSGPOI>1
IF $PIECE(PSGPOI,U,2)
Begin DoDot:1
+16 NEW DR,DA,DIE
SET DA(1)=PSGP
SET DA=+PSGORD
SET DIE="^PS(55,"_PSGP_",5,"
SET DR="108///^S X=$P(PSGPOI,U,2)"
DO ^DIE
End DoDot:1
+17 QUIT
UPDRENOE(PSGP,PSGORD,RDATE) ;
+1 ; expire original Orders File order
DO EXPOE(PSGP,PSGORD,$GET(RDATE))
+2 IF PSGORD'["P"
KILL DA,DR,DIE
SET DA(1)=DFN
SET DA=+PSGORD
SET DIE="^PS(55,"_DFN_$SELECT(PSGORD="U":",5,",1:",""IV"",")
SET DR=$SELECT(DIE["IV":110,1:66)_"////@"
DO ^DIE
+3 DO ENUDTX^PSJOREN(PSGP,PSGORD,"NR")
+4 DO EN1^PSJHL2(PSGP,"SN",PSGORD,"ORDER RENEWED")
+5 QUIT
READ ; hold screen
+1 IF $DATA(IOST)
if $EXTRACT(IOST)'="C"
QUIT
+2 WRITE !?5,"Press return to continue "
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
+3 QUIT
EXPOE(DFN,PSJORDER,EXPDT) ; expire old Orders File entry
+1 IF PSJORDER["P"
SET FILE="^PS(53.1,"_+PSJORDER_",0)"
SET PSJORDER=$PIECE(@FILE,"^",25)
+2 IF (PSJORDER'["U")
IF (PSJORDER'["V")
QUIT
+3 NEW CURDAT
DO NOW^%DTC
SET CURDAT=$$DATE2^PSJUTL2(%)
+4 SET PSJEXPOE=$SELECT($GET(EXPDT):EXPDT,1:CURDAT)
DO EN1^PSJHL2(DFN,"SC",PSJORDER)
KILL PSJEXPOE
+5 QUIT
EXPIRED(PSJX,PSJY) ;
+1 ; INPUT
+2 ; PSJX - Pharmacy Patient, pointer to ^PS(55
+3 ; PSJY - Inpatient Order Number(appended with "V" or "U")
+4 ; OUTPUT
+5 ; 0 - Order has not exceeded the Expired Time Limit
+6 ; 1 - Order has exceeded the Expired Time Limit
+7 NEW STOP,STATUS,NOW,CUTOFF,FREQ,LAST,ST,X,DFN,U,PSGDT,SD,WD,PSJPSTO,PSGDW,PSGOC,ZZND,LASTAT,LSTSTR,PSBCNT
SET DFN=PSJX
SET U="^"
SET CUTOFF=0
+8 SET STATUS=$SELECT(PSJY["U":$PIECE($GET(^PS(55,PSJX,5,+PSJY,0)),"^",9),PSJY["V":$PIECE($GET(^PS(55,PSJX,"IV",+PSJY,0)),"^",17),1:"")
+9 SET NOW=$SELECT($GET(PSGDT):PSGDT,1:$$DATE^PSJUTL2())
+10 SET STOP=$SELECT(PSJY["U":$PIECE($GET(^PS(55,PSJX,5,+PSJY,2)),U,4),1:$PIECE($GET(^PS(55,PSJX,"IV",+PSJY,0)),"^",3))
+11 IF NOW<STOP
QUIT 0
+12 ;*315 ND2P1 ON NEXT LINE
+13 IF PSJY["U"
NEW ND2,ND0
SET ND0=$GET(^PS(55,PSJX,5,+PSJY,0))
SET ND2=$GET(^PS(55,PSJX,5,+PSJY,2))
SET ND2P1=$GET(^PS(55,PSJX,5,+PSJY,2.1))
SET FREQ=$PIECE(ND2,"^",6)
Begin DoDot:1
+14 NEW SCHED
SET SCHED=$PIECE($GET(^PS(55,PSJX,5,+PSJY,2)),"^")
IF SCHED["PRN"
SET FREQ=$$PRNFREQ(SCHED)
+15 SET LSTSTR=$PIECE(ND2,"^",2)_"^"_$PIECE(ND2,"^",4)_"^"_SCHED_"^"_$PIECE(ND0,"^",7)_"^^"_$PIECE(ND2,"^",5)
+16 SET LAST=$$EN^PSBAPIPM(PSJX,PSJY)
IF LAST
IF ($PIECE(ND0,"^",7)="O")
IF ($PIECE(LAST,"^",3)="G")
IF LAST>$PIECE(ND2,"^",2)
SET CUTOFF=$$FMADD^XLFDT(NOW,,-1)
QUIT
+17 IF 'LAST!(LAST>$PIECE(ND2,"^",4))
SET LAST=$$LASTAT^PSJORP2(DFN,LSTSTR)
if LAST
SET CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ)
QUIT
+18 IF SCHED["PRN"
IF ($PIECE(LSTSTR,"^",6)="")
SET CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ)
QUIT
+19 IF $$DOW^PSIVUTL(SCHED)
SET CUTOFF=$$NXTDOW(DFN,$PIECE(LSTSTR,"^"),$PIECE(LSTSTR,"^",2),$PIECE(LSTSTR,"^",3),$PIECE(LSTSTR,"^",6))
QUIT
+20 SET LAST=$$EN^PSBAPIPM(PSJX,PSJY)
IF 'LAST!(LAST>$PIECE(ND2,"^",4))
SET CUTOFF=$$FMADD^XLFDT(NOW,,-1)
QUIT
+21 SET $PIECE(LSTSTR,"^")=$$FMADD^XLFDT(LAST,,,,1)
SET $PIECE(LSTSTR,"^",2)=$$FMADD^XLFDT(PSGDT,,,FREQ)
SET CUTOFF=$$ENQ^PSJORP2(PSJX,LSTSTR)
End DoDot:1
+22 IF PSJY["V"
NEW LIMIT
SET LIMIT=$PIECE($GET(^PS(59.7,1,31)),"^",4)
SET LIMIT=$SELECT((LIMIT]""):+LIMIT,1:24)
SET CUTOFF=$$FMADD^XLFDT(STOP,,LIMIT)
Begin DoDot:1
+23 IF '($GET(P(4))]"")
NEW P,YP,XP
SET YP=$GET(^PS(55,DFN,"IV",+PSJY,0))
FOR XP=1:1:23
SET P(XP)=$PIECE(YP,U,XP)
+24 if '($GET(P(4))]"")
QUIT
+25 if '$$SCHREQ^PSJLIVFD(.P)
QUIT
+26 NEW INTERVAL,LSTSTR,ND0,SCHED,IVSTYP
SET ND0=$GET(^PS(55,PSJX,"IV",+PSJY,0))
SET INTERVAL=$PIECE(ND0,"^",15)
SET SCHED=$PIECE(ND0,"^",9)
if SCHED=""
QUIT
+27 SET IVSTYP=$SELECT($$DOW^PSIVUTL(SCHED):"D",INTERVAL="O":"O",1:"C")
SET LSTSTR=$PIECE(ND0,"^",2)_"^"_$PIECE(ND0,"^",3)_"^"_SCHED_"^"_IVSTYP_"^^"_$PIECE(ND0,"^",11)
+28 SET LAST=$$EN^PSBAPIPM(PSJX,PSJY)
IF LAST
IF IVSTYP="O"
IF LAST>$PIECE(ND0,"^",2)
IF ($PIECE(LAST,"^",3)="G")
SET CUTOFF=$$FMADD^XLFDT(NOW,,-1)
QUIT
+29 IF 'LAST!(LAST>$PIECE(ND0,"^",3))!(LAST&(IVSTYP="O"))
SET CUTOFF=$$FMADD^XLFDT(NOW,,-1)
QUIT
+30 IF IVSTYP="D"
SET CUTOFF=$$NXTDOW(LAST,SCHED,$GET(P(2)),$PIECE($GET(P(9)),"@"),$GET(P(11)))
QUIT
+31 IF SCHED["PRN"
SET FREQ=$$PRNFREQ(SCHED)
SET CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ)
QUIT
+32 SET LAST=$$EN^PSBAPIPM(PSJX,PSJY)
IF 'LAST!(LAST>$PIECE(ND0,"^",3))
SET CUTOFF=$$FMADD^XLFDT(NOW,,-1)
QUIT
+33 SET $PIECE(LSTSTR,"^")=$$FMADD^XLFDT(LAST,,,,1)
SET $PIECE(LSTSTR,"^",2)=$$FMADD^XLFDT(PSGDT,31)
SET CUTOFF=$$ENQ^PSJORP2(PSJX,LSTSTR)
End DoDot:1
+34 KILL LYN,PSBDT,PSBFLAG,PSBSTR
+35 QUIT $SELECT(CUTOFF<NOW:1,1:0)
+36 ;
NXTDOW(DOWDFN,DOWSD,DOWFD,DOWSCH,DOWAT) ;
+1 NEW NXTADM,DOWSTR
SET DOWSTR=$$FMADD^XLFDT(DOWFD,,,,1)_"^"_$$FMADD^XLFDT(DOWFD,7)_"^"_DOWSCH_"^D^^"_DOWAT
SET NXTADM=$$ENQ^PSJORP2(DOWDFN,DOWSTR)
+2 QUIT $SELECT(NXTADM:NXTADM,1:DOWSD)
+3 ;
PRNFREQ(SCHED) ;
+1 NEW ZZND,D,DA,X,PSGAT,PSGOES,PSGST,PSJNSS,PSJPWD,TEST,VALMBCK,PSGS0XT,PSGS0Y,PSGDT
+2 FOR X=$PIECE(SCHED,"PRN"),$PIECE(SCHED,"PRN",2),$PIECE(SCHED," PRN"),$PIECE(SCHED,"PRN ",2)
if $PIECE($GET(ZZND),"^",4)
QUIT
DO ADMIN^PSJORPOE
+3 QUIT $SELECT($GET(PSGS0XT):PSGS0XT,1:1440)
