PSGNE3 ;BIR/CML3,MLM-DETERMINE DEFAULT FOR START & STOP TIMES ; 12/13/10 2:46pm
;;5.0;INPATIENT MEDICATIONS ;**4,26,47,50,63,69,105,80,111,183,193,179,275,378,327**;16 DEC 97;Build 114
;
; Reference to ^PS(51.1 is supported by DBIA 2177
; Reference to ^PS(55 is supported by DBIA 2191
; Reference to PSBAPIPM is supported by DBIA 3564
;
N X1,X2,Y
NOW ;
S:'$D(PSGST) PSGST=""
S PSGDT=$$DATE^PSJUTL2(),PSGNESD=$$ENSD($S(PSGST["P":"PRN",1:PSGSCH),PSGS0Y,PSGDT,PSGDT)
;
STOP ; exit when start date found
K ET,F,FT,LT,NT,PSGNE3,TT G:$D(PSGOES)!$D(PSGODF) SF S PSGNESDO=$$ENDD^PSGMI(PSGNESD)
Q
;
ENFD(PSGDT) ; find default stop date
N X1,X2,X3DMIN,Y
SF I '$O(^PS(55,PSGP,5,"AUS",PSGDT)),'$D(^PS(53.1,"AC",PSGP)),+$G(^PS(55,PSGP,5.1)) S $P(^PS(55,PSGP,5.1),U)=""
S PSJSYSW0=$G(PSJSYSW0) ; Initialize/restore PSJSYSW0 ward parameters; clinic orders may not have them. Killed at exit in ENKV^PSGSETU
I $G(PSGOEA)="R",$P(PSJSYSW0,"^",4) D ENWALL(%,0,PSGP)
S PSGNEFD="",PSGNEW=$S('$P(PSJSYSW0,U,4):0,+$G(^PS(55,PSGP,5.1))'>PSGDT:0,1:+$G(^PS(55,PSGP,5.1))) S:PSGNEW<PSGNESD PSGNEW=0
I PSGNEW,($G(PSGOEA)="R") S X1=$P(%,"."),X2=3 D C^%DTC S PSGNEW=$S($P(X,".")_(PSGNESD#1)'>PSGNEW:PSGNEW,1:0)
I PSGST="O" S PSGNEFD=$$ENOSD^PSJDCU(PSJSYSW0,PSGNESD,PSGP) I PSGNEFD]"" G OUT
;PSJ*179;x-ref to "APPSJ"
I PSGST'="O",PSGSCH]"",$S(PSGSCH="ONCE":1,PSGSCH="STAT":1,PSGSCH="ONE TIME":1,1:0)!($P($G(^PS(51.1,+$O(^PS(51.1,"AC","PSJ",PSGSCH,0)),0)),"^",5)="O") S PSGNEFD=$$ENOSD^PSJDCU(PSJSYSW0,PSGNESD,PSGP) I PSGNEFD]"" G OUT
S X1=$P(PSGNESD,"."),X2=$S($P(PSJSYSW0,"^",3):+$P(PSJSYSW0,"^",3),1:14)
D
. ; *** psi 06 082 - RDC 08/2006;ADDED VAR AA TO CHK FOR APPT and CLINIC ***
. N A,AA,B
. Q:'$D(PSGORD) S A=""
. I PSGORD["P" S A=$G(^PS(53.1,+PSGORD,"DSS"))
. I PSGORD["U" S A=$G(^PS(55,PSGP,5,+PSGORD,8))
. I PSGORD["I" S A=$G(^PS(55,PSGP,"IV",+PSGORD,"DSS"))
. ;PSJ*5*179;Clin Def Stop
. S AA=$P(A,"^",2),A=$P(A,"^") I A,AA S X2=14 I $D(^PS(53.46,"B",A)) S B=$O(^PS(53.46,"B",A,"")),X2=$P(^PS(53.46,B,0),"^",2) I X2="" S X2=14
D
.N CLOZFLG I $G(PSGORD)["P",$$GET1^DIQ(53.1,+PSGORD,.01) S CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD) I 1
.E I $G(PSGORD),$$GET1^DIQ(55.06,+PSGORD_","_PSGP,.01) S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD) I 1
.E S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,,$G(PSGDRG))
.Q:'CLOZFLG
.N DFN,X1 S DFN=PSGP
.I '$D(CLOZPAT) D CLOZPAT^PSJCLOZ
.N PSGANC,PSGCFLG,PSGOVRD
.S PSGANC=$$CL^YSCLTST2(DFN),PSGCFLG=1
.S PSGOVRD=$$OVERRIDE^YSCLTST2(DFN)
.S X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
.I $$GET1^DIQ(55,DFN,53)?1U6N S X2=4
.I 'PSGOVRD,'+$P(PSGANC,"^",4) S X2=4
D C^%DTC
I $G(PSGNEDFD) I $S($P(PSGNEDFD,"^")["L":PSGS0XT!PSGS0Y,1:1) D DFD
I $G(PSGORD),$G(PSGFD) S X3DMIN=$$GETDUR^PSJLIVMD(PSGP,+$G(PSGORD),$S($G(PSGORD)["P":"P",$G(PSGORD)["V":"IV",1:5),1) I X3DMIN]"" D I PSGNEFD]"" G OUT
. S X3DMIN=$$DURMIN^PSJLIVMD(X3DMIN) I $G(X3DMIN) S PSGNEFD=$$FMADD^XLFDT(PSGNESD,,,X3DMIN)
S X=+(X_$S($P(PSJSYSW0,"^",7):"."_$P(PSJSYSW0,"^",7),1:(PSGNESD#1)))
S PSGNEFD=$S('PSGNEFD:X,X<PSGNEFD:X,1:PSGNEFD) I PSGNEW,(PSGNEW<PSGNEFD),$P(PSJSYSW0,U,4) D
. I $G(PSGORD),$G(PSGRDTX) I PSGORD=$P(PSGRDTX,U,4),PSGNEW<PSGRDTX Q ; Requested Start is after Stop
. S PSGNEFD=PSGNEW
;; END NCC REMEDIATION >> 327*RJS
;
OUT ;
;*179 Account for drug changing
I $G(PSGPDNX)&('$G(PSBSTR)) S:$G(PSGSDX) PSGNESD=PSGSDX S:$G(PSGFDX) PSGNEFD=PSGFDX
I '$D(PSGODF),'$D(PSGOES) S PSGNEFDO=$$ENDD^PSGMI(PSGNEFD)
K PSGDL,PSGNEW Q
;
DFD ;
I $P(PSGNEDFD,"^")["D" S X1=$P(PSGNESD,"."),X2=+PSGNEDFD D C^%DTC S X=+(X_"."_$S($P(PSJSYSW0,"^",7):$P(PSJSYSW0,"^",7),1:$P(PSGNESD,".",2)))
I $P(PSGNEDFD,"^")["L" S PSGDL=+PSGNEDFD D EN1^PSGDL
S PSGNEFD=$S(PSGNEW<X&PSGNEW:PSGNEW,1:X) Q:$P(PSGNEDFD,"^")'["D"!'$P(PSJSYSW0,"^",4)!PSGNEW
Q
;
ENOR ;
K PSGOES,PSGODF S X=$P($G(^PS(53.1,DA,2)),"^")
S $P(^PS(53.1,DA,0),"^",7)=$S(X="PRN":"P",X="ONCE":"O",X="STAT":"O",X="ONE TIME":"O",X="ON CALL":"OC",$P(PSGNEDFD,"^",3)]"":$P(PSGNEDFD,"^",3),1:"C") D PSGNE3 S X=PSGNESD
Q
;
ENSET0(DFN) ; Set "0" node and build xrefs for entries found without one.
N DA,DIK S ^PS(55,DFN,0)=DFN,DIK="^PS(55,",DIK(1)=.01,DA=DFN D EN^DIK
S $P(^PS(55,DFN,5.1),"^",11)=2 ; Mark as converted for POE
Q
;
ENWALL(SD,FD,DFN) ; Update default stop date if appropriate.
N WALL,NWALL,X1,X2,X3
D NOW^%DTC S X3=%
S WALL=+$G(^PS(55,DFN,5.1)),X1=$P(SD,"."),X2=3 D C^%DTC I +(X_"."_$P(SD,".",2))'>+WALL Q
S X1=$P(X3,"."),X2=$S($P(PSJSYSW0,U,3):+$P(PSJSYSW0,U,3),1:14) D C^%DTC
S NWALL=X_$S($P(PSJSYSW0,U,7):"."_$P(PSJSYSW0,U,7),1:SD#1)
S $P(^PS(55,DFN,5.1),U)=+$S(FD>NWALL:FD,1:NWALL)
Q
;
ENSD(SCH,AT,LI,OSD) ;Find start dt/tm
;SCH=schedule,AT=admin times,LI=login date/time,OSD=Renewed orders start
I $G(APPT),$G(PSGORD)["P" S XD=$$DATE2^PSJUTL2($S(($$FMDIFF^XLFDT(APPT,PSGDT,2)<0):PSGDT,1:APPT)) Q XD
N X,OSDLI D
.I $L(LI)<13 S X=LI Q
.I $L(LI)=14 S X=$E(LI,13,14) S:X>29 X=$E(LI,1,12)_5 S:X'>29 X=$E(LI,1,12)_1 Q
.I $L(LI)=13 S X=$E(LI,13)_0 S:X>29 X=$E(LI,1,12)_5 S:X'>29 X=$E(LI,1,12)_1 Q
I $G(LI) S:(LI=$G(OSD)) OSDLI=1
S LI=+$FN(X,"",4) I '$P(LI,".",2) S LI=$$FMADD^XLFDT(LI,-1,0,0,0)_.24
I $G(OSDLI) S OSD=LI K OSDLI
;BHW;PSJ*5*179;Re-calc Start date
N PSGBCADM,PSGBCLDT,PSGBCLA,PSGBCFR,PSGBTT,PSGBST,PSGBCSHH,PSGBCLHH,PSGBSAT,PSGBSATN,PSGBNAT,PSGBCLIT,PSGBCTDY
N PSGBCTDD,PSGBCTDA,PSGDAYC,PSGBDNXT,PSGBCSCD,PSGBCLID
S (PSGBST,PSGBCFR,PSGBCADM)=""
S PSGBCORD=$S($G(PSGORD):PSGORD,$G(PSJORD):PSJORD,1:$G(PSGORD))
I PSGBCORD S:'$P($G(^PS(55,DFN,$S($G(PSGBCORD)["V":"IV",1:5),+PSGBCORD,0)),"^",2) PSGBCORD=""
I PSGBCORD["U" S PSGBCOT=5,PSGBCND=0,PSGBCPO=25
I PSGBCORD["V" S PSGBCOT="IV",PSGBCND=2,PSGBCPO=5
I (PSGBCORD'["U")&(PSGBCORD'["V") S PSGBCORD=""
I +$G(DFN)&(+PSGBCORD) S PSGBCPRV=PSGBCORD D
.F S PSGBCADM=$$EN^PSBAPIPM(DFN,PSGBCPRV) Q:PSGBCADM'="" S PSGBCPRV=$P(^PS(55,DFN,PSGBCOT,+PSGBCPRV,PSGBCND),U,PSGBCPO) Q:(PSGBCPRV="")!(PSGBCPRV["P")
.Q
I $L(PSGBCADM) D I PSGBST Q +PSGBST
.S PSGBCLID=$P(LI,".",1),PSGBCLIT=$E($P(LI,".",2),1,2) I $L(PSGBCLIT)=1 S PSGBCLIT=PSGBCLIT*10
.S PSGBCSCH=$P(PSGBCADM,U,1),PSGBCSCD=$P(PSGBCSCH,".",1),PSGBCLDT=$P(PSGBCADM,U,2),PSGBCLA=$P(PSGBCADM,U,3)
.I "GR"'[PSGBCLA Q
.S PSGBCFR=""
.I PSGBCORD["U" S PSGBCFR=$P(^PS(55,DFN,5,+PSGBCORD,2),U,6)
.I PSGBCORD["V" S PSGBCFR=$P(^PS(55,DFN,"IV",+PSGBCORD,0),U,15)
.;Convert
.S PSGBCFR=$S(PSGBCFR="D":1440,PSGBCFR="O":0,1:PSGBCFR)*60
.I 'PSGBCFR,'AT Q
.S X=PSGBCSCH D H^%DTC S PSGBCSCH=%H*86400+%T,PSGBCSHH=%H_","_%T
.S X=PSGBCLDT D H^%DTC S PSGBCLDT=%H*86400+%T,PSGBCLHH=%H_","_%T
.;Sched Admin Time
.I PSGBCSCH D
..;Check admin times/freq
..I AT D Q:PSGBST
...S PSGBSAT=$P($P(PSGBCADM,"^",1),".",2) Q:'PSGBSAT
...I $L(PSGBSAT)=1 S PSGBSAT=PSGBSAT*10
...I ((PSGBSAT<PSGBCLIT)!(PSGBCSCD<PSGBCLID))&(PSGBCSCD'>PSGBCLID) S PSGBSAT=PSGBCLIT ;&(PSGBCFR<86400)
...S PSGBNAT=""
...I ($L($P(AT,"-",1))=4)&($L(PSGBSAT)'=4) S PSGBSAT=PSGBSAT_$E("00",1,4-$L(PSGBSAT))
...F PSGBSATN=1:1 S PSGBNAT=$P(AT,"-",PSGBSATN) Q:PSGBNAT="" I PSGBNAT>PSGBSAT Q
...;If DOW
...I ("SU-MO-TU-WE-TH-FR-SA"[$P(SCH,"-",1)) D Q:PSGBST
....;Get TODAY
....D NOW^%DTC I '$L(PSGBNAT),PSGBCSCD'<X S X1=X,X2=1 D C^%DTC
....S PSGBCTDD=X D DW^%DTC S PSGBCTDY=$E(X,1,2)
....K PSGBCTMP F PSGBCTMP="SU:1","MO:2","TU:3","WE:4","TH:5","FR:6","SA:7" S PSGBCTMP($P(PSGBCTMP,":",1))=$P(PSGBCTMP,":",2),PSGBCTMP($P(PSGBCTMP,":",2))=$P(PSGBCTMP,":",1)
....;DAY of Last Admin
....S X=PSGBCSCD D DW^%DTC S PSGBCTDA=$E(X,1,2) I PSGBCSCD<PSGBCTDD S PSGBCTDA=PSGBCTDY
....;Get Next Day in Sched
....S PSGDAYC=PSGBCTMP(PSGBCTDA),(PSGBDNXT,X)=""
....F X=PSGDAYC:1:7 I SCH[$G(PSGBCTMP(X)) S PSGBDNXT=PSGBCTMP(X) Q
....I '$L(PSGBDNXT) S PSGBDNXT=$P(SCH,"-",1)
....;Set new Start Day
....S PSGBCTDY=PSGBCTMP(PSGBCTDY)
....S PSGBDNXT=PSGBCTMP(PSGBDNXT)
....S X2=PSGBDNXT-PSGBCTDY I X2<0 S X2=(7-PSGBCTDY)+PSGBDNXT
....S X1=PSGBCTDD D C^%DTC ;Add # of days
....I +X S PSGBST=X_"."_($S('$L(PSGBNAT)!(PSGBCLID'=X):$P(AT,"-",1),1:PSGBNAT))
....Q
...;IF no Next Admin
...I (('PSGBNAT)&(PSGBCFR))!((PSGBCFR>86399)&(PSGBCSCD<PSGBCLID)) S X1=$S(PSGBCFR<86400:PSGBCLID,1:PSGBCSCD),X2=$S(PSGBCFR<86400:1,1:PSGBCFR/60/60/24) D C^%DTC S PSGBST=+X_"."_($S(PSGBNAT:PSGBNAT,1:$P(AT,"-",1))) Q
...S PSGBST=PSGBCSCD_"."_PSGBNAT
...Q
..I 'PSGBCFR Q
..;Add Freq
..S PSGBST=PSGBCSCH+PSGBCFR,PSGBST=(PSGBST\86400)_","_(PSGBST#86400)
..I $P(PSGBST,",",2)<3600 S $P(PSGBST,",",2)=3600
..;If next day
..I $P(PSGBST,",",2)<3600 S %H=$S(+PSGBST=+PSGBCSHH:+PSGBST,1:PSGBST-1)_",86400"
..S %H=PSGBST D YMD^%DTC S PSGBST=X_(+$E(%,1,5))
..I PSGBST<LI S PSGBST="" Q
..;If the date/time is > than the First admin
..I AT,($P(PSGBST,".",1)>PSGBCLID) D
...S PSGBSAT=$P(PSGBST,".",2) I $L(PSGBSAT)=1 S PSGBSAT=PSGBSAT*10
...S PSGBSATN=$P(AT,"-",1) ;First admin TIME
...I PSGBSAT>PSGBSATN S PSGBST=$P(PSGBST,".",1)_"."_PSGBSATN
...Q
..Q
.;Future Date?
.I (PSGBST)&((PSGBST<LI)!(($P(PSGBCADM,"^",1)+.0001)>PSGBST)) D
..S INFO=($S(($P(PSGBCADM,"^",1)+.0001>PSGBST):$P(PSGBCADM,"^",1)+.0001,1:$G(LI)))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y))
..S PSGBST=$$ENQ^PSJORP2(PSGP,INFO)
..I PSGBST<LI S PSGBST="" Q
..Q
.;No Sched time
.I PSGBCLDT,PSGBCFR,'PSGBCSCH D Q
..;Add Freq
..S PSGBST=PSGBCLDT+PSGBCFR,PSGBST=(PSGBST\86400)_","_(PSGBST#86400)
..I $P(PSGBST,",",2)<3600 S $P(PSGBST,",",2)=3600
..I $P(PSGBST,",",2)#3600 S PSGBTT=$P(($P(PSGBST,",",2)/3600)+1,".",1)*3600,$P(PSGBST,",",2)=PSGBTT
..;If next day
..I $P(PSGBST,",",2)<3600 S %H=$S(+PSGBST=+PSGBCLHH:+PSGBST,1:PSGBST-1)_",86400"
..S %H=PSGBST D YMD^%DTC S PSGBST=X_(+$E(%,1,3))
..I PSGBST<LI S PSGBST="" Q
..Q
;BHW;PSJ*5*179;END
I ($P($G(PSJSYSW0),U,5)="")!($P($G(PSJSYSW0),U,5)=2) Q LI
S:SCH["PRN" AT=""
N INT,PSG S:(SCH'["PRN"&(SCH'?1"Q".N1"H")&(LI'=OSD)&('AT)&($G(PSGST)'="O")) AT=$E(OSD,9,10) S OSD=$E(OSD,1,10)
S INT=$S(SCH="QD":24,SCH="QOD":48,SCH="QH":1,SCH?1"Q".N1"D":(+$P(SCH,"Q",2)*24),SCH?1"Q".N1"H":+$P(SCH,"Q",2),LI=OSD:24,1:24)
S:INT=24 OSD=$$FMADD^XLFDT(LI,0,-INT,0,0)
I 'AT,INT>23 S:$P(PSJSYSW0,U,5)!($E(LI,11,12)>30) AT=$E($$FMADD^XLFDT(LI,0,1,0,0),9,10) S:AT="00" AT=24 S:'AT AT=$E(LI,9,10)
I SCH?1"Q".N1"H",'AT S ND=OSD,PSG(+ND)="" S:(INT>24)&('$G(PSJREN)) INT=24 S DAYS=INT\24,HRS=(-INT\24*24+INT) F S ND=$$FMADD^XLFDT(ND,DAYS,HRS),PSG(+ND)="" Q:ND>LI
Q:INT=24&'$L(AT,"-") $E(LI,1,8)_AT
I '$O(PSG(LI)) S X=$S(OSD>1:OSD,LI>1:LI,1:$$DATE^PSJUTL2) D
.F S ND=X D Q:ND>LI S:(INT>24)&('$G(PSJREN)) INT=24 S DAYS=INT\24,HRS=(-INT\24*24+INT) S X=$$FMADD^XLFDT($S($P(ND,".",2)=24:$P(ND,".")_".23",1:ND),DAYS,HRS) S:$P(X,".")'>$P(ND,".") X=$$FMADD^XLFDT(X,1,0,0,0)
..F Y=1:1 S AT1=$P(AT,"-",Y) Q:'AT1 S ND=ND\1_"."_AT1,PSG(+ND)=""
Q:$P(PSJSYSW0,U,5) $O(PSG(LI))
S INT="" F ND=0:0 S ND=$O(PSG(ND)) S X=$$FMDIFF^XLFDT(LI,ND,2) S:X<0 X=-X Q:INT&(X'<INT) S INT=+X,OND=ND Q:INT=0
Q $S($G(OND):OND,1:LI) ;Use login time if OND is null PSJ*5*193
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGNE3 11061 printed Apr 09, 2024@21:08:24 Page 2
PSGNE3 ;BIR/CML3,MLM-DETERMINE DEFAULT FOR START & STOP TIMES ; 12/13/10 2:46pm
+1 ;;5.0;INPATIENT MEDICATIONS ;**4,26,47,50,63,69,105,80,111,183,193,179,275,378,327**;16 DEC 97;Build 114
+2 ;
+3 ; Reference to ^PS(51.1 is supported by DBIA 2177
+4 ; Reference to ^PS(55 is supported by DBIA 2191
+5 ; Reference to PSBAPIPM is supported by DBIA 3564
+6 ;
+7 NEW X1,X2,Y
NOW ;
+1 if '$DATA(PSGST)
SET PSGST=""
+2 SET PSGDT=$$DATE^PSJUTL2()
SET PSGNESD=$$ENSD($SELECT(PSGST["P":"PRN",1:PSGSCH),PSGS0Y,PSGDT,PSGDT)
+3 ;
STOP ; exit when start date found
+1 KILL ET,F,FT,LT,NT,PSGNE3,TT
if $DATA(PSGOES)!$DATA(PSGODF)
GOTO SF
SET PSGNESDO=$$ENDD^PSGMI(PSGNESD)
+2 QUIT
+3 ;
ENFD(PSGDT) ; find default stop date
+1 NEW X1,X2,X3DMIN,Y
SF IF '$ORDER(^PS(55,PSGP,5,"AUS",PSGDT))
IF '$DATA(^PS(53.1,"AC",PSGP))
IF +$GET(^PS(55,PSGP,5.1))
SET $PIECE(^PS(55,PSGP,5.1),U)=""
+1 ; Initialize/restore PSJSYSW0 ward parameters; clinic orders may not have them. Killed at exit in ENKV^PSGSETU
SET PSJSYSW0=$GET(PSJSYSW0)
+2 IF $GET(PSGOEA)="R"
IF $PIECE(PSJSYSW0,"^",4)
DO ENWALL(%,0,PSGP)
+3 SET PSGNEFD=""
SET PSGNEW=$SELECT('$PIECE(PSJSYSW0,U,4):0,+$GET(^PS(55,PSGP,5.1))'>PSGDT:0,1:+$GET(^PS(55,PSGP,5.1)))
if PSGNEW<PSGNESD
SET PSGNEW=0
+4 IF PSGNEW
IF ($GET(PSGOEA)="R")
SET X1=$PIECE(%,".")
SET X2=3
DO C^%DTC
SET PSGNEW=$SELECT($PIECE(X,".")_(PSGNESD#1)'>PSGNEW:PSGNEW,1:0)
+5 IF PSGST="O"
SET PSGNEFD=$$ENOSD^PSJDCU(PSJSYSW0,PSGNESD,PSGP)
IF PSGNEFD]""
GOTO OUT
+6 ;PSJ*179;x-ref to "APPSJ"
+7 IF PSGST'="O"
IF PSGSCH]""
IF $SELECT(PSGSCH="ONCE":1,PSGSCH="STAT":1,PSGSCH="ONE TIME":1,1:0)!($PIECE($GET(^PS(51.1,+$ORDER(^PS(51.1,"AC","PSJ",PSGSCH,0)),0)),"^",5)="O")
SET PSGNEFD=$$ENOSD^PSJDCU(PSJSYSW0,PSGNESD,PSGP)
IF PSGNEFD]""
GOTO OUT
+8 SET X1=$PIECE(PSGNESD,".")
SET X2=$SELECT($PIECE(PSJSYSW0,"^",3):+$PIECE(PSJSYSW0,"^",3),1:14)
+9 Begin DoDot:1
+10 ; *** psi 06 082 - RDC 08/2006;ADDED VAR AA TO CHK FOR APPT and CLINIC ***
+11 NEW A,AA,B
+12 if '$DATA(PSGORD)
QUIT
SET A=""
+13 IF PSGORD["P"
SET A=$GET(^PS(53.1,+PSGORD,"DSS"))
+14 IF PSGORD["U"
SET A=$GET(^PS(55,PSGP,5,+PSGORD,8))
+15 IF PSGORD["I"
SET A=$GET(^PS(55,PSGP,"IV",+PSGORD,"DSS"))
+16 ;PSJ*5*179;Clin Def Stop
+17 SET AA=$PIECE(A,"^",2)
SET A=$PIECE(A,"^")
IF A
IF AA
SET X2=14
IF $DATA(^PS(53.46,"B",A))
SET B=$ORDER(^PS(53.46,"B",A,""))
SET X2=$PIECE(^PS(53.46,B,0),"^",2)
IF X2=""
SET X2=14
End DoDot:1
+18 Begin DoDot:1
+19 NEW CLOZFLG
IF $GET(PSGORD)["P"
IF $$GET1^DIQ(53.1,+PSGORD,.01)
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD)
IF 1
+20 IF '$TEST
IF $GET(PSGORD)
IF $$GET1^DIQ(55.06,+PSGORD_","_PSGP,.01)
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD)
IF 1
+21 IF '$TEST
SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,,$GET(PSGDRG))
+22 if 'CLOZFLG
QUIT
+23 NEW DFN,X1
SET DFN=PSGP
+24 IF '$DATA(CLOZPAT)
DO CLOZPAT^PSJCLOZ
+25 NEW PSGANC,PSGCFLG,PSGOVRD
+26 SET PSGANC=$$CL^YSCLTST2(DFN)
SET PSGCFLG=1
+27 SET PSGOVRD=$$OVERRIDE^YSCLTST2(DFN)
+28 SET X2=$SELECT($GET(CLOZPAT)=2:28,$GET(CLOZPAT)=1:14,$GET(CLOZPAT)=0:7,1:90)
+29 IF $$GET1^DIQ(55,DFN,53)?1U6N
SET X2=4
+30 IF 'PSGOVRD
IF '+$PIECE(PSGANC,"^",4)
SET X2=4
End DoDot:1
+31 DO C^%DTC
+32 IF $GET(PSGNEDFD)
IF $SELECT($PIECE(PSGNEDFD,"^")["L":PSGS0XT!PSGS0Y,1:1)
DO DFD
+33 IF $GET(PSGORD)
IF $GET(PSGFD)
SET X3DMIN=$$GETDUR^PSJLIVMD(PSGP,+$GET(PSGORD),$SELECT($GET(PSGORD)["P":"P",$GET(PSGORD)["V":"IV",1:5),1)
IF X3DMIN]""
Begin DoDot:1
+34 SET X3DMIN=$$DURMIN^PSJLIVMD(X3DMIN)
IF $GET(X3DMIN)
SET PSGNEFD=$$FMADD^XLFDT(PSGNESD,,,X3DMIN)
End DoDot:1
IF PSGNEFD]""
GOTO OUT
+35 SET X=+(X_$SELECT($PIECE(PSJSYSW0,"^",7):"."_$PIECE(PSJSYSW0,"^",7),1:(PSGNESD#1)))
+36 SET PSGNEFD=$SELECT('PSGNEFD:X,X<PSGNEFD:X,1:PSGNEFD)
IF PSGNEW
IF (PSGNEW<PSGNEFD)
IF $PIECE(PSJSYSW0,U,4)
Begin DoDot:1
+37 ; Requested Start is after Stop
IF $GET(PSGORD)
IF $GET(PSGRDTX)
IF PSGORD=$PIECE(PSGRDTX,U,4)
IF PSGNEW<PSGRDTX
QUIT
+38 SET PSGNEFD=PSGNEW
End DoDot:1
+39 ;; END NCC REMEDIATION >> 327*RJS
+40 ;
OUT ;
+1 ;*179 Account for drug changing
+2 IF $GET(PSGPDNX)&('$GET(PSBSTR))
if $GET(PSGSDX)
SET PSGNESD=PSGSDX
if $GET(PSGFDX)
SET PSGNEFD=PSGFDX
+3 IF '$DATA(PSGODF)
IF '$DATA(PSGOES)
SET PSGNEFDO=$$ENDD^PSGMI(PSGNEFD)
+4 KILL PSGDL,PSGNEW
QUIT
+5 ;
DFD ;
+1 IF $PIECE(PSGNEDFD,"^")["D"
SET X1=$PIECE(PSGNESD,".")
SET X2=+PSGNEDFD
DO C^%DTC
SET X=+(X_"."_$SELECT($PIECE(PSJSYSW0,"^",7):$PIECE(PSJSYSW0,"^",7),1:$PIECE(PSGNESD,".",2)))
+2 IF $PIECE(PSGNEDFD,"^")["L"
SET PSGDL=+PSGNEDFD
DO EN1^PSGDL
+3 SET PSGNEFD=$SELECT(PSGNEW<X&PSGNEW:PSGNEW,1:X)
if $PIECE(PSGNEDFD,"^")'["D"!'$PIECE(PSJSYSW0,"^",4)!PSGNEW
QUIT
+4 QUIT
+5 ;
ENOR ;
+1 KILL PSGOES,PSGODF
SET X=$PIECE($GET(^PS(53.1,DA,2)),"^")
+2 SET $PIECE(^PS(53.1,DA,0),"^",7)=$SELECT(X="PRN":"P",X="ONCE":"O",X="STAT":"O",X="ONE TIME":"O",X="ON CALL":"OC",$PIECE(PSGNEDFD,"^",3)]"":$PIECE(PSGNEDFD,"^",3),1:"C")
DO PSGNE3
SET X=PSGNESD
+3 QUIT
+4 ;
ENSET0(DFN) ; Set "0" node and build xrefs for entries found without one.
+1 NEW DA,DIK
SET ^PS(55,DFN,0)=DFN
SET DIK="^PS(55,"
SET DIK(1)=.01
SET DA=DFN
DO EN^DIK
+2 ; Mark as converted for POE
SET $PIECE(^PS(55,DFN,5.1),"^",11)=2
+3 QUIT
+4 ;
ENWALL(SD,FD,DFN) ; Update default stop date if appropriate.
+1 NEW WALL,NWALL,X1,X2,X3
+2 DO NOW^%DTC
SET X3=%
+3 SET WALL=+$GET(^PS(55,DFN,5.1))
SET X1=$PIECE(SD,".")
SET X2=3
DO C^%DTC
IF +(X_"."_$PIECE(SD,".",2))'>+WALL
QUIT
+4 SET X1=$PIECE(X3,".")
SET X2=$SELECT($PIECE(PSJSYSW0,U,3):+$PIECE(PSJSYSW0,U,3),1:14)
DO C^%DTC
+5 SET NWALL=X_$SELECT($PIECE(PSJSYSW0,U,7):"."_$PIECE(PSJSYSW0,U,7),1:SD#1)
+6 SET $PIECE(^PS(55,DFN,5.1),U)=+$SELECT(FD>NWALL:FD,1:NWALL)
+7 QUIT
+8 ;
ENSD(SCH,AT,LI,OSD) ;Find start dt/tm
+1 ;SCH=schedule,AT=admin times,LI=login date/time,OSD=Renewed orders start
+2 IF $GET(APPT)
IF $GET(PSGORD)["P"
SET XD=$$DATE2^PSJUTL2($SELECT(($$FMDIFF^XLFDT(APPT,PSGDT,2)<0):PSGDT,1:APPT))
QUIT XD
+3 NEW X,OSDLI
Begin DoDot:1
+4 IF $LENGTH(LI)<13
SET X=LI
QUIT
+5 IF $LENGTH(LI)=14
SET X=$EXTRACT(LI,13,14)
if X>29
SET X=$EXTRACT(LI,1,12)_5
if X'>29
SET X=$EXTRACT(LI,1,12)_1
QUIT
+6 IF $LENGTH(LI)=13
SET X=$EXTRACT(LI,13)_0
if X>29
SET X=$EXTRACT(LI,1,12)_5
if X'>29
SET X=$EXTRACT(LI,1,12)_1
QUIT
End DoDot:1
+7 IF $GET(LI)
if (LI=$GET(OSD))
SET OSDLI=1
+8 SET LI=+$FNUMBER(X,"",4)
IF '$PIECE(LI,".",2)
SET LI=$$FMADD^XLFDT(LI,-1,0,0,0)_.24
+9 IF $GET(OSDLI)
SET OSD=LI
KILL OSDLI
+10 ;BHW;PSJ*5*179;Re-calc Start date
+11 NEW PSGBCADM,PSGBCLDT,PSGBCLA,PSGBCFR,PSGBTT,PSGBST,PSGBCSHH,PSGBCLHH,PSGBSAT,PSGBSATN,PSGBNAT,PSGBCLIT,PSGBCTDY
+12 NEW PSGBCTDD,PSGBCTDA,PSGDAYC,PSGBDNXT,PSGBCSCD,PSGBCLID
+13 SET (PSGBST,PSGBCFR,PSGBCADM)=""
+14 SET PSGBCORD=$SELECT($GET(PSGORD):PSGORD,$GET(PSJORD):PSJORD,1:$GET(PSGORD))
+15 IF PSGBCORD
if '$PIECE($GET(^PS(55,DFN,$SELECT($GET(PSGBCORD)["V"
SET PSGBCORD=""
+16 IF PSGBCORD["U"
SET PSGBCOT=5
SET PSGBCND=0
SET PSGBCPO=25
+17 IF PSGBCORD["V"
SET PSGBCOT="IV"
SET PSGBCND=2
SET PSGBCPO=5
+18 IF (PSGBCORD'["U")&(PSGBCORD'["V")
SET PSGBCORD=""
+19 IF +$GET(DFN)&(+PSGBCORD)
SET PSGBCPRV=PSGBCORD
Begin DoDot:1
+20 FOR
SET PSGBCADM=$$EN^PSBAPIPM(DFN,PSGBCPRV)
if PSGBCADM'=""
QUIT
SET PSGBCPRV=$PIECE(^PS(55,DFN,PSGBCOT,+PSGBCPRV,PSGBCND),U,PSGBCPO)
if (PSGBCPRV="")!(PSGBCPRV["P")
QUIT
+21 QUIT
End DoDot:1
+22 IF $LENGTH(PSGBCADM)
Begin DoDot:1
+23 SET PSGBCLID=$PIECE(LI,".",1)
SET PSGBCLIT=$EXTRACT($PIECE(LI,".",2),1,2)
IF $LENGTH(PSGBCLIT)=1
SET PSGBCLIT=PSGBCLIT*10
+24 SET PSGBCSCH=$PIECE(PSGBCADM,U,1)
SET PSGBCSCD=$PIECE(PSGBCSCH,".",1)
SET PSGBCLDT=$PIECE(PSGBCADM,U,2)
SET PSGBCLA=$PIECE(PSGBCADM,U,3)
+25 IF "GR"'[PSGBCLA
QUIT
+26 SET PSGBCFR=""
+27 IF PSGBCORD["U"
SET PSGBCFR=$PIECE(^PS(55,DFN,5,+PSGBCORD,2),U,6)
+28 IF PSGBCORD["V"
SET PSGBCFR=$PIECE(^PS(55,DFN,"IV",+PSGBCORD,0),U,15)
+29 ;Convert
+30 SET PSGBCFR=$SELECT(PSGBCFR="D":1440,PSGBCFR="O":0,1:PSGBCFR)*60
+31 IF 'PSGBCFR
IF 'AT
QUIT
+32 SET X=PSGBCSCH
DO H^%DTC
SET PSGBCSCH=%H*86400+%T
SET PSGBCSHH=%H_","_%T
+33 SET X=PSGBCLDT
DO H^%DTC
SET PSGBCLDT=%H*86400+%T
SET PSGBCLHH=%H_","_%T
+34 ;Sched Admin Time
+35 IF PSGBCSCH
Begin DoDot:2
+36 ;Check admin times/freq
+37 IF AT
Begin DoDot:3
+38 SET PSGBSAT=$PIECE($PIECE(PSGBCADM,"^",1),".",2)
if 'PSGBSAT
QUIT
+39 IF $LENGTH(PSGBSAT)=1
SET PSGBSAT=PSGBSAT*10
+40 ;&(PSGBCFR<86400)
IF ((PSGBSAT<PSGBCLIT)!(PSGBCSCD<PSGBCLID))&(PSGBCSCD'>PSGBCLID)
SET PSGBSAT=PSGBCLIT
+41 SET PSGBNAT=""
+42 IF ($LENGTH($PIECE(AT,"-",1))=4)&($LENGTH(PSGBSAT)'=4)
SET PSGBSAT=PSGBSAT_$EXTRACT("00",1,4-$LENGTH(PSGBSAT))
+43 FOR PSGBSATN=1:1
SET PSGBNAT=$PIECE(AT,"-",PSGBSATN)
if PSGBNAT=""
QUIT
IF PSGBNAT>PSGBSAT
QUIT
+44 ;If DOW
+45 IF ("SU-MO-TU-WE-TH-FR-SA"[$PIECE(SCH,"-",1))
Begin DoDot:4
+46 ;Get TODAY
+47 DO NOW^%DTC
IF '$LENGTH(PSGBNAT)
IF PSGBCSCD'<X
SET X1=X
SET X2=1
DO C^%DTC
+48 SET PSGBCTDD=X
DO DW^%DTC
SET PSGBCTDY=$EXTRACT(X,1,2)
+49 KILL PSGBCTMP
FOR PSGBCTMP="SU:1","MO:2","TU:3","WE:4","TH:5","FR:6","SA:7"
SET PSGBCTMP($PIECE(PSGBCTMP,":",1))=$PIECE(PSGBCTMP,":",2)
SET PSGBCTMP($PIECE(PSGBCTMP,":",2))=$PIECE(PSGBCTMP,":",1)
+50 ;DAY of Last Admin
+51 SET X=PSGBCSCD
DO DW^%DTC
SET PSGBCTDA=$EXTRACT(X,1,2)
IF PSGBCSCD<PSGBCTDD
SET PSGBCTDA=PSGBCTDY
+52 ;Get Next Day in Sched
+53 SET PSGDAYC=PSGBCTMP(PSGBCTDA)
SET (PSGBDNXT,X)=""
+54 FOR X=PSGDAYC:1:7
IF SCH[$GET(PSGBCTMP(X))
SET PSGBDNXT=PSGBCTMP(X)
QUIT
+55 IF '$LENGTH(PSGBDNXT)
SET PSGBDNXT=$PIECE(SCH,"-",1)
+56 ;Set new Start Day
+57 SET PSGBCTDY=PSGBCTMP(PSGBCTDY)
+58 SET PSGBDNXT=PSGBCTMP(PSGBDNXT)
+59 SET X2=PSGBDNXT-PSGBCTDY
IF X2<0
SET X2=(7-PSGBCTDY)+PSGBDNXT
+60 ;Add # of days
SET X1=PSGBCTDD
DO C^%DTC
+61 IF +X
SET PSGBST=X_"."_($SELECT('$LENGTH(PSGBNAT)!(PSGBCLID'=X):$PIECE(AT,"-",1),1:PSGBNAT))
+62 QUIT
End DoDot:4
if PSGBST
QUIT
+63 ;IF no Next Admin
+64 IF (('PSGBNAT)&(PSGBCFR))!((PSGBCFR>86399)&(PSGBCSCD<PSGBCLID))
SET X1=$SELECT(PSGBCFR<86400:PSGBCLID,1:PSGBCSCD)
SET X2=$SELECT(PSGBCFR<86400:1,1:PSGBCFR/60/60/24)
DO C^%DTC
SET PSGBST=+X_"."_($SELECT(PSGBNAT:PSGBNAT,1:$PIECE(AT,"-",1)))
QUIT
+65 SET PSGBST=PSGBCSCD_"."_PSGBNAT
+66 QUIT
End DoDot:3
if PSGBST
QUIT
+67 IF 'PSGBCFR
QUIT
+68 ;Add Freq
+69 SET PSGBST=PSGBCSCH+PSGBCFR
SET PSGBST=(PSGBST\86400)_","_(PSGBST#86400)
+70 IF $PIECE(PSGBST,",",2)<3600
SET $PIECE(PSGBST,",",2)=3600
+71 ;If next day
+72 IF $PIECE(PSGBST,",",2)<3600
SET %H=$SELECT(+PSGBST=+PSGBCSHH:+PSGBST,1:PSGBST-1)_",86400"
+73 SET %H=PSGBST
DO YMD^%DTC
SET PSGBST=X_(+$EXTRACT(%,1,5))
+74 IF PSGBST<LI
SET PSGBST=""
QUIT
+75 ;If the date/time is > than the First admin
+76 IF AT
IF ($PIECE(PSGBST,".",1)>PSGBCLID)
Begin DoDot:3
+77 SET PSGBSAT=$PIECE(PSGBST,".",2)
IF $LENGTH(PSGBSAT)=1
SET PSGBSAT=PSGBSAT*10
+78 ;First admin TIME
SET PSGBSATN=$PIECE(AT,"-",1)
+79 IF PSGBSAT>PSGBSATN
SET PSGBST=$PIECE(PSGBST,".",1)_"."_PSGBSATN
+80 QUIT
End DoDot:3
+81 QUIT
End DoDot:2
+82 ;Future Date?
+83 IF (PSGBST)&((PSGBST<LI)!(($PIECE(PSGBCADM,"^",1)+.0001)>PSGBST))
Begin DoDot:2
+84 SET INFO=($SELECT(($PIECE(PSGBCADM,"^",1)+.0001>PSGBST):$PIECE(PSGBCADM,"^",1)+.0001,1:$GET(LI)))_U_($GET(PSGFD))_U_($GET(PSGSCH))_U_($GET(PSGST))_U_($GET(PSGPDRG))_U_($GET(PSGS0Y))
+85 SET PSGBST=$$ENQ^PSJORP2(PSGP,INFO)
+86 IF PSGBST<LI
SET PSGBST=""
QUIT
+87 QUIT
End DoDot:2
+88 ;No Sched time
+89 IF PSGBCLDT
IF PSGBCFR
IF 'PSGBCSCH
Begin DoDot:2
+90 ;Add Freq
+91 SET PSGBST=PSGBCLDT+PSGBCFR
SET PSGBST=(PSGBST\86400)_","_(PSGBST#86400)
+92 IF $PIECE(PSGBST,",",2)<3600
SET $PIECE(PSGBST,",",2)=3600
+93 IF $PIECE(PSGBST,",",2)#3600
SET PSGBTT=$PIECE(($PIECE(PSGBST,",",2)/3600)+1,".",1)*3600
SET $PIECE(PSGBST,",",2)=PSGBTT
+94 ;If next day
+95 IF $PIECE(PSGBST,",",2)<3600
SET %H=$SELECT(+PSGBST=+PSGBCLHH:+PSGBST,1:PSGBST-1)_",86400"
+96 SET %H=PSGBST
DO YMD^%DTC
SET PSGBST=X_(+$EXTRACT(%,1,3))
+97 IF PSGBST<LI
SET PSGBST=""
QUIT
+98 QUIT
End DoDot:2
QUIT
End DoDot:1
IF PSGBST
QUIT +PSGBST
+99 ;BHW;PSJ*5*179;END
+100 IF ($PIECE($GET(PSJSYSW0),U,5)="")!($PIECE($GET(PSJSYSW0),U,5)=2)
QUIT LI
+101 if SCH["PRN"
SET AT=""
+102 NEW INT,PSG
if (SCH'["PRN"&(SCH'?1"Q".N1"H")&(LI'=OSD)&('AT)&($GET(PSGST)'="O"))
SET AT=$EXTRACT(OSD,9,10)
SET OSD=$EXTRACT(OSD,1,10)
+103 SET INT=$SELECT(SCH="QD":24,SCH="QOD":48,SCH="QH":1,SCH?1"Q".N1"D":(+$PIECE(SCH,"Q",2)*24),SCH?1"Q".N1"H":+$PIECE(SCH,"Q",2),LI=OSD:24,1:24)
+104 if INT=24
SET OSD=$$FMADD^XLFDT(LI,0,-INT,0,0)
+105 IF 'AT
IF INT>23
if $PIECE(PSJSYSW0,U,5)!($EXTRACT(LI,11,12)>30)
SET AT=$EXTRACT($$FMADD^XLFDT(LI,0,1,0,0),9,10)
if AT="00"
SET AT=24
if 'AT
SET AT=$EXTRACT(LI,9,10)
+106 IF SCH?1"Q".N1"H"
IF 'AT
SET ND=OSD
SET PSG(+ND)=""
if (INT>24)&('$GET(PSJREN))
SET INT=24
SET DAYS=INT\24
SET HRS=(-INT\24*24+INT)
FOR
SET ND=$$FMADD^XLFDT(ND,DAYS,HRS)
SET PSG(+ND)=""
if ND>LI
QUIT
+107 if INT=24&'$LENGTH(AT,"-")
QUIT $EXTRACT(LI,1,8)_AT
+108 IF '$ORDER(PSG(LI))
SET X=$SELECT(OSD>1:OSD,LI>1:LI,1:$$DATE^PSJUTL2)
Begin DoDot:1
+109 FOR
SET ND=X
Begin DoDot:2
+110 FOR Y=1:1
SET AT1=$PIECE(AT,"-",Y)
if 'AT1
QUIT
SET ND=ND\1_"."_AT1
SET PSG(+ND)=""
End DoDot:2
if ND>LI
QUIT
if (INT>24)&('$GET(PSJREN))
SET INT=24
SET DAYS=INT\24
SET HRS=(-INT\24*24+INT)
SET X=$$FMADD^XLFDT($SELECT($PIECE(ND,".",2)=24:$PIECE(ND,".")_".23",1:ND),DAYS,HRS)
if $PIECE(X,".")'>$PIECE(ND,".")
SET X=$$FMADD^XLFDT(X,1,0,0,0)
End DoDot:1
+111 if $PIECE(PSJSYSW0,U,5)
QUIT $ORDER(PSG(LI))
+112 SET INT=""
FOR ND=0:0
SET ND=$ORDER(PSG(ND))
SET X=$$FMDIFF^XLFDT(LI,ND,2)
if X<0
SET X=-X
if INT&(X'<INT)
QUIT
SET INT=+X
SET OND=ND
if INT=0
QUIT
+113 ;Use login time if OND is null PSJ*5*193
QUIT $SELECT($GET(OND):OND,1:LI)
