- 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 Jan 18, 2025@03:02:58 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)