Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSGOER

PSGOER.m

Go to the documentation of this file. 
  1. PSGOER ;BIR/CML3-RENEW A SINGLE ORDER ;29-May-2012 14:30;PLS
  1.  ;;5.0; INPATIENT MEDICATIONS ;**11,30,29,35,70,58,95,1004,110,111,133,141,198,1015**;16 DEC 97;Build 62
  1.  ;
  1.  ; Reference to ^PS(51.1 supported by DBIA 2177.
  1.  ; Reference to ^PS(55 supported by DBIA 2191.
  1.  ; Reference to ^PSSLOCK is supported by DBIA 2789.
  1.  ; Reference to ^PSBAPIPM is supported by DBIA 3564.
  1.  ; Reference to ^PS(59.7 is supported by DBIA 2181.
  1.  ; Reference to ^PSDRUG( is supported by DBIA 2192.
  1.  ;
  1.  ; Modified - IHS/CIA/PLS - 10/14/05 - Line NEW+20
  1.  ;
  1.  ; renew a single order
  1.  I $G(PSJCOM) D ^PSJCOMR Q
  1.  N PSJEXPIR S PSJEXPIR=$$EXPIRED(PSGP,PSGORD) I PSJEXPIR D  Q
  1.  .W !!?3,"  THIS ORDER" W:PSJEXPIR'=2 " HAS BEEN INACTIVE FOR ONE OR MORE SCHEDULED",!?8," ADMINISTRATIONS AND"
  1.  .W " CANNOT BE RENEWED!" D PAUSE^VALM1
  1.  I $G(PSGSCH)]"",($G(PSGS0XT)="D"),($G(PSGAT)="") D  Q
  1.  .N SWD,SDW,XABB,X,QX S X=$G(PSGSCH) D DW^PSGS0 Q:($G(X)="")  I $G(PSGS0XT)="" S PSGS0XT="D"
  1.  .Q:((",P,R,")[(","_$G(PSGST)_","))
  1.  .I $G(PSGS0XT)="D",$G(PSGAT)="" S CHK=1 W !!?3,"This order contains a 'DAY OF THE WEEK' schedule without admin times"
  1.  .W !?11," and CANNOT be renewed!" D PAUSE^VALM1
  1.  I $G(PSGSCH)]"",'$$DOW^PSIVUTL(PSGSCH),'$$PRNOK^PSGS0(PSGSCH) I '$D(^PS(51.1,"AC","PSJ",PSGSCH)) D  Q
  1.  .W !!?3,"This order contains an invalid schedule and CANNOT be renewed!" D PAUSE^VALM1
  1.  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"
  1.  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
  1.  I '$D(DIRUT),Y D NEW S PSGCANFL=1 D DONE Q
  1.  I '$D(DIRUT),PSJSYSU S PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4)) I $P(PSGND4,"^",15),$P(PSGND4,"^",16) D UNMARK,DONE Q
  1.  D DONE,ABORT^PSGOEE
  1.  Q
  1.  ;
  1. UNMARK ;
  1.  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"
  1.  S DIR("?",1)="  Answer 'YES' to unmark this order.  Answer 'NO' (or '^') to leave the order",DIR("?")="marked.  (An answer is required.)" D ^DIR
  1.  I 'Y D ABORT^PSGOEE G DONE
  1.  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!"
  1.  ;
  1. DONE ;
  1.  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
  1.  ;
  1. NEW ; get info, write record
  1. EXTEND ; extend stop date on renewal order
  1.  N DUOUT,PSJABT,PSGDRG,PSJREN,PSGOREAS S PSGDRG=$P($G(^PS(55,PSGP,5,+PSGORD,1,1,0)),"^"),PSJREN=1
  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
  1.  . W !!?5,"THIS ONE-TIME ORDER HAS ALREADY BEEN GIVEN AND CANNOT BE RENEWED",! S (DIRUT,PSGORQF)=1 D READ
  1.  D OC55
  1.  Q:$D(PSGORQF)  ; quit if not to continue
  1.  D NOW^%DTC S PSGDT=%,PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4)) I '$P(PSJSYSP0,"^",3) D MARK Q
  1.  S PSGWLL=$S('$P(PSJSYSW0,"^",4):0,1:+$G(^PS(55,PSGP,5.1))),PSGOEE="R" K PSGOEOS
  1.  K ^PS(53.45,PSJSYSP,1),^(2) D MOVE(3,1),MOVE(1,2)
  1.  D DATE^PSGOER0(PSGP,PSGORD,PSGDT) I ($G(X)="^")!'$D(PSGFOK(106))!$G(DUOUT) D DONE,ABORT^PSGOEE S VALMBCK="R",COMQUIT=1 Q
  1. SPEED ;
  1.  I +$G(PSJSYSU)=3 D EN^PSGPEN(PSGORD)
  1.  Q:$G(DUOUT)
  1.  N PSGOEAV S PSGOEAV=+PSJSYSU
  1.  D CALLBOP  ;IHS/CIA/PLS - 10/14/05 - Call to Automated Dispensing System
  1.  W !!,"...updating order..." K DA S DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=PSJSYSU*10+18000 D ^PSGAL5 W "."
  1.  I $$LS^PSSLOCK(PSGP,PSGORD) D UPDREN(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO),UPDRENOE(PSGP,PSGORD,PSGDT) D UNL^PSSLOCK(PSGP,PSGORD)
  1.  ;
  1.  I 'PSGOERDP,$P(PSJSYSW0,"^",4),PSGFD'<PSGWLL S $P(^PS(55,PSGP,5.1),"^")=+PSGFD
  1.  W ".DONE!" S VALMBCK="Q" Q
  1.  ;
  1. MARK ;
  1.  I $P(PSGND4,"^",15),$P(PSGND4,"^",16) W $C(7),!!?3,"...THIS ORDER IS ALREADY MARKED FOR RENEWAL!..." Q
  1.  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
  1.  I $D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="R",PSGPOSD=PSGDT D ENPOS^PSGVDS
  1.  Q
  1. MOVE(X,Y) ; Move comments/dispense drugs from 55 to 53.45.
  1.  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))
  1.  S:Q ^PS(53.45,Y,0)="^53.450"_Y_"P^"_Q_U_Q
  1.  Q
  1. OC55 ;* Order checks for Speed finish and regular finish
  1.  N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJPDRG
  1.  S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)=""
  1.  K PSGORQF D ENDDC^PSGSICHK(PSGP,+$G(^PS(55,PSGP,5,+PSGORD,1,1,0)))
  1.  I '$D(PSGORQF) K PSGORQF,^TMP($J,"DI") D
  1.  . 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
  1.  Q
  1.  ; Call Automated Dispensing System if present
  1. CALLBOP ;
  1.  D:$$PATCH^XPDUTL("BOP*1.0*1") RENEW^BOPCAP
  1.  Q
  1. UPDREN(PSGORD,RNWDT,PSGOEPR,PSGOFD,PSJNOO,RDUZ) ; update renewed order
  1.  N DR,DA,DIC,DIE,DD,DO,PSGRZERO,PSGRFOUR,PSGOORD
  1.  S DR="",PSGOEENO=0,PSGOORD=PSGORD,PSGNESD=PSGSD Q:'PSGORD!'RNWDT!'PSGOEPR!'PSGOFD  S PSJNOO=$S($G(PSJNOO)]"":$G(PSJNOO),1:"E")
  1.  S PSGRZERO="^PS(55,"_PSGP_",5,"_+PSGORD_",0)",PSGOEORD=$P(@PSGRZERO,"^",21)
  1.  ; PSJ*5*141 - changed PSGOEPR to PSGPR for field 1 of the DR string below.
  1.  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
  1.  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
  1.  . 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
  1.  K DR,DA,DIC,DIE,DD,DO S DA(1)=PSGP,DA=+PSGORD,DIE="^PS(55,"_PSGP_",5,",DR="28////A;105////@;107////@"
  1.  ;PSJ*5*198
  1.  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////@"
  1.  I '$G(PSJSPEED) I $G(PSGAT)]"",$G(PSGAT)'=$P($G(@(DIE_+PSGORD_",2)")),"^",5) S DR=DR_";41////"_PSGAT
  1.  D ^DIE
  1.  Q
  1. UPDRENOE(PSGP,PSGORD,RDATE) ;
  1.  D EXPOE(PSGP,PSGORD,$G(RDATE)) ; expire original Orders File order
  1.  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
  1.  D ENUDTX^PSJOREN(PSGP,PSGORD,"NR")
  1.  D EN1^PSJHL2(PSGP,"SN",PSGORD,"ORDER RENEWED")
  1.  Q
  1. READ ; hold screen
  1.  I $D(IOST) Q:$E(IOST)'="C"
  1.  W !?5,"Press return to continue  " R X:$S($D(DTIME):DTIME,1:300)
  1.  Q
  1. EXPOE(DFN,PSJORDER,EXPDT) ; expire old Orders File entry
  1.  I PSJORDER["P" S FILE="^PS(53.1,"_+PSJORDER_",0)",PSJORDER=$P(@FILE,"^",25)
  1.  I (PSJORDER'["U"),(PSJORDER'["V") Q
  1.  N CURDAT D NOW^%DTC S CURDAT=$$DATE2^PSJUTL2(%)
  1.  S PSJEXPOE=$S($G(EXPDT):EXPDT,1:CURDAT) D EN1^PSJHL2(DFN,"SC",PSJORDER) K PSJEXPOE
  1.  Q
  1. EXPIRED(PSJX,PSJY) ;
  1.  ; INPUT
  1.  ;       PSJX - Pharmacy Patient, pointer to ^PS(55
  1.  ;       PSJY - Inpatient Order Number (appended with "V" or "U")
  1.  ; OUTPUT
  1.  ;   0  -  Order has not exceeded the Expired Time Limit
  1.  ;   1  -  Order has exceeded the Expired Time Limit
  1.  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
  1.  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:"")
  1.  S NOW=$S($G(PSGDT):PSGDT,1:$$DATE^PSJUTL2())
  1.  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))
  1.  I NOW<STOP Q 0
  1.  I PSJY["U" N ND2,ND0 S ND0=$G(^PS(55,PSJX,5,+PSJY,0)),ND2=$G(^PS(55,PSJX,5,+PSJY,2)),FREQ=$P(ND2,"^",6) D
  1.  .N SCHED S SCHED=$P($G(^PS(55,PSJX,5,+PSJY,2)),"^") I SCHED["PRN" S FREQ=$$PRNFREQ(SCHED)
  1.  .S LSTSTR=$P(ND2,"^",2)_"^"_$P(ND2,"^",4)_"^"_SCHED_"^"_$P(ND0,"^",7)_"^^"_$P(ND2,"^",5)
  1.  .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
  1.  .I 'LAST!(LAST>$P(ND2,"^",4)) S LAST=$$LASTAT^PSJORP2(DFN,LSTSTR) S:LAST CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ) Q
  1.  .I SCHED["PRN",($P(LSTSTR,"^",6)="") S CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ) Q
  1.  .I $$DOW^PSIVUTL(SCHED) S CUTOFF=$$NXTDOW(DFN,$P(LSTSTR,"^"),$P(LSTSTR,"^",2),$P(LSTSTR,"^",3),$P(LSTSTR,"^",6)) Q
  1.  .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I 'LAST!(LAST>$P(ND2,"^",4)) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
  1.  .S $P(LSTSTR,"^")=$$FMADD^XLFDT(LAST,,,,1),$P(LSTSTR,"^",2)=$$FMADD^XLFDT(PSGDT,,,FREQ) S CUTOFF=$$ENQ^PSJORP2(PSJX,LSTSTR)
  1.  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
  1.  .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)
  1.  .Q:'($G(P(4))]"")
  1.  .Q:'$$SCHREQ^PSJLIVFD(.P)
  1.  .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=""
  1.  .S IVSTYP=$S($$DOW^PSIVUTL(SCHED):"D",INTERVAL="O":"O",1:"C"),LSTSTR=$P(ND0,"^",2)_"^"_$P(ND0,"^",3)_"^"_SCHED_"^"_IVSTYP_"^^"_$P(ND0,"^",11)
  1.  .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
  1.  .I 'LAST!(LAST>$P(ND0,"^",3))!(LAST&(IVSTYP="O")) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
  1.  .I IVSTYP="D" S CUTOFF=$$NXTDOW(LAST,SCHED,$G(P(2)),$P($G(P(9)),"@"),$G(P(11))) Q
  1.  .I SCHED["PRN" S FREQ=$$PRNFREQ(SCHED) S CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ) Q
  1.  .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I 'LAST!(LAST>$P(ND0,"^",3)) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
  1.  .S $P(LSTSTR,"^")=$$FMADD^XLFDT(LAST,,,,1),$P(LSTSTR,"^",2)=$$FMADD^XLFDT(PSGDT,31) S CUTOFF=$$ENQ^PSJORP2(PSJX,LSTSTR)
  1.  K LYN,PSBDT,PSBFLAG,PSBSTR
  1.  Q $S(CUTOFF<NOW:1,1:0)
  1.  ;
  1. NXTDOW(DOWDFN,DOWSD,DOWFD,DOWSCH,DOWAT) ;
  1.  N NXTADM,DOWSTR S DOWSTR=$$FMADD^XLFDT(DOWFD,,,,1)_"^"_$$FMADD^XLFDT(DOWFD,7)_"^"_DOWSCH_"^D^^"_DOWAT S NXTADM=$$ENQ^PSJORP2(DOWDFN,DOWSTR)
  1.  Q $S(NXTADM:NXTADM,1:DOWSD)
  1.  ;
  1. PRNFREQ(SCHED) ;
  1.  N ZZND,D,DA,X,PSGAT,PSGOES,PSGST,PSJNSS,PSJPWD,TEST,VALMBCK,PSGS0XT,PSGS0Y,PSGDT
  1.  F X=$P(SCHED,"PRN"),$P(SCHED,"PRN",2),$P(SCHED," PRN"),$P(SCHED,"PRN ",2) Q:$P($G(ZZND),"^",4)  D ADMIN^PSJORPOE
  1.  Q $S($G(PSGS0XT):PSGS0XT,1:1440)