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

PSGNE3.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to ^PS(51.1 is supported by DBIA 2177
  1. ; Reference to ^PS(55 is supported by DBIA 2191
  1. ; Reference to PSBAPIPM is supported by DBIA 3564
  1. ;
  1. N X1,X2,Y
  1. NOW ;
  1. S:'$D(PSGST) PSGST=""
  1. S PSGDT=$$DATE^PSJUTL2(),PSGNESD=$$ENSD($S(PSGST["P":"PRN",1:PSGSCH),PSGS0Y,PSGDT,PSGDT)
  1. ;
  1. STOP ; exit when start date found
  1. K ET,F,FT,LT,NT,PSGNE3,TT G:$D(PSGOES)!$D(PSGODF) SF S PSGNESDO=$$ENDD^PSGMI(PSGNESD)
  1. Q
  1. ;
  1. ENFD(PSGDT) ; find default stop date
  1. N X1,X2,X3DMIN,Y
  1. 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)=""
  1. S PSJSYSW0=$G(PSJSYSW0) ; Initialize/restore PSJSYSW0 ward parameters; clinic orders may not have them. Killed at exit in ENKV^PSGSETU
  1. I $G(PSGOEA)="R",$P(PSJSYSW0,"^",4) D ENWALL(%,0,PSGP)
  1. 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
  1. I PSGNEW,($G(PSGOEA)="R") S X1=$P(%,"."),X2=3 D C^%DTC S PSGNEW=$S($P(X,".")_(PSGNESD#1)'>PSGNEW:PSGNEW,1:0)
  1. I PSGST="O" S PSGNEFD=$$ENOSD^PSJDCU(PSJSYSW0,PSGNESD,PSGP) I PSGNEFD]"" G OUT
  1. ;PSJ*179;x-ref to "APPSJ"
  1. 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
  1. S X1=$P(PSGNESD,"."),X2=$S($P(PSJSYSW0,"^",3):+$P(PSJSYSW0,"^",3),1:14)
  1. D
  1. . ; *** psi 06 082 - RDC 08/2006;ADDED VAR AA TO CHK FOR APPT and CLINIC ***
  1. . N A,AA,B
  1. . Q:'$D(PSGORD) S A=""
  1. . I PSGORD["P" S A=$G(^PS(53.1,+PSGORD,"DSS"))
  1. . I PSGORD["U" S A=$G(^PS(55,PSGP,5,+PSGORD,8))
  1. . I PSGORD["I" S A=$G(^PS(55,PSGP,"IV",+PSGORD,"DSS"))
  1. . ;PSJ*5*179;Clin Def Stop
  1. . 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
  1. D
  1. .N CLOZFLG I $G(PSGORD)["P",$$GET1^DIQ(53.1,+PSGORD,.01) S CLOZFLG=$$ISCLOZ^PSJCLOZ(+PSGORD) I 1
  1. .E I $G(PSGORD),$$GET1^DIQ(55.06,+PSGORD_","_PSGP,.01) S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD) I 1
  1. .E S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,,,$G(PSGDRG))
  1. .Q:'CLOZFLG
  1. .N DFN,X1 S DFN=PSGP
  1. .I '$D(CLOZPAT) D CLOZPAT^PSJCLOZ
  1. .N PSGANC,PSGCFLG,PSGOVRD
  1. .S PSGANC=$$CL^YSCLTST2(DFN),PSGCFLG=1
  1. .S PSGOVRD=$$OVERRIDE^YSCLTST2(DFN)
  1. .S X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90)
  1. .I $$GET1^DIQ(55,DFN,53)?1U6N S X2=4
  1. .I 'PSGOVRD,'+$P(PSGANC,"^",4) S X2=4
  1. D C^%DTC
  1. I $G(PSGNEDFD) I $S($P(PSGNEDFD,"^")["L":PSGS0XT!PSGS0Y,1:1) D DFD
  1. 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
  1. . S X3DMIN=$$DURMIN^PSJLIVMD(X3DMIN) I $G(X3DMIN) S PSGNEFD=$$FMADD^XLFDT(PSGNESD,,,X3DMIN)
  1. S X=+(X_$S($P(PSJSYSW0,"^",7):"."_$P(PSJSYSW0,"^",7),1:(PSGNESD#1)))
  1. S PSGNEFD=$S('PSGNEFD:X,X<PSGNEFD:X,1:PSGNEFD) I PSGNEW,(PSGNEW<PSGNEFD),$P(PSJSYSW0,U,4) D
  1. . I $G(PSGORD),$G(PSGRDTX) I PSGORD=$P(PSGRDTX,U,4),PSGNEW<PSGRDTX Q ; Requested Start is after Stop
  1. . S PSGNEFD=PSGNEW
  1. ;; END NCC REMEDIATION >> 327*RJS
  1. ;
  1. OUT ;
  1. ;*179 Account for drug changing
  1. I $G(PSGPDNX)&('$G(PSBSTR)) S:$G(PSGSDX) PSGNESD=PSGSDX S:$G(PSGFDX) PSGNEFD=PSGFDX
  1. I '$D(PSGODF),'$D(PSGOES) S PSGNEFDO=$$ENDD^PSGMI(PSGNEFD)
  1. K PSGDL,PSGNEW Q
  1. ;
  1. DFD ;
  1. 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)))
  1. I $P(PSGNEDFD,"^")["L" S PSGDL=+PSGNEDFD D EN1^PSGDL
  1. S PSGNEFD=$S(PSGNEW<X&PSGNEW:PSGNEW,1:X) Q:$P(PSGNEDFD,"^")'["D"!'$P(PSJSYSW0,"^",4)!PSGNEW
  1. Q
  1. ;
  1. ENOR ;
  1. K PSGOES,PSGODF S X=$P($G(^PS(53.1,DA,2)),"^")
  1. 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
  1. Q
  1. ;
  1. ENSET0(DFN) ; Set "0" node and build xrefs for entries found without one.
  1. N DA,DIK S ^PS(55,DFN,0)=DFN,DIK="^PS(55,",DIK(1)=.01,DA=DFN D EN^DIK
  1. S $P(^PS(55,DFN,5.1),"^",11)=2 ; Mark as converted for POE
  1. Q
  1. ;
  1. ENWALL(SD,FD,DFN) ; Update default stop date if appropriate.
  1. N WALL,NWALL,X1,X2,X3
  1. D NOW^%DTC S X3=%
  1. S WALL=+$G(^PS(55,DFN,5.1)),X1=$P(SD,"."),X2=3 D C^%DTC I +(X_"."_$P(SD,".",2))'>+WALL Q
  1. S X1=$P(X3,"."),X2=$S($P(PSJSYSW0,U,3):+$P(PSJSYSW0,U,3),1:14) D C^%DTC
  1. S NWALL=X_$S($P(PSJSYSW0,U,7):"."_$P(PSJSYSW0,U,7),1:SD#1)
  1. S $P(^PS(55,DFN,5.1),U)=+$S(FD>NWALL:FD,1:NWALL)
  1. Q
  1. ;
  1. ENSD(SCH,AT,LI,OSD) ;Find start dt/tm
  1. ;SCH=schedule,AT=admin times,LI=login date/time,OSD=Renewed orders start
  1. I $G(APPT),$G(PSGORD)["P" S XD=$$DATE2^PSJUTL2($S(($$FMDIFF^XLFDT(APPT,PSGDT,2)<0):PSGDT,1:APPT)) Q XD
  1. N X,OSDLI D
  1. .I $L(LI)<13 S X=LI Q
  1. .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
  1. .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
  1. I $G(LI) S:(LI=$G(OSD)) OSDLI=1
  1. S LI=+$FN(X,"",4) I '$P(LI,".",2) S LI=$$FMADD^XLFDT(LI,-1,0,0,0)_.24
  1. I $G(OSDLI) S OSD=LI K OSDLI
  1. ;BHW;PSJ*5*179;Re-calc Start date
  1. N PSGBCADM,PSGBCLDT,PSGBCLA,PSGBCFR,PSGBTT,PSGBST,PSGBCSHH,PSGBCLHH,PSGBSAT,PSGBSATN,PSGBNAT,PSGBCLIT,PSGBCTDY
  1. N PSGBCTDD,PSGBCTDA,PSGDAYC,PSGBDNXT,PSGBCSCD,PSGBCLID
  1. S (PSGBST,PSGBCFR,PSGBCADM)=""
  1. S PSGBCORD=$S($G(PSGORD):PSGORD,$G(PSJORD):PSJORD,1:$G(PSGORD))
  1. I PSGBCORD S:'$P($G(^PS(55,DFN,$S($G(PSGBCORD)["V":"IV",1:5),+PSGBCORD,0)),"^",2) PSGBCORD=""
  1. I PSGBCORD["U" S PSGBCOT=5,PSGBCND=0,PSGBCPO=25
  1. I PSGBCORD["V" S PSGBCOT="IV",PSGBCND=2,PSGBCPO=5
  1. I (PSGBCORD'["U")&(PSGBCORD'["V") S PSGBCORD=""
  1. I +$G(DFN)&(+PSGBCORD) S PSGBCPRV=PSGBCORD D
  1. .F S PSGBCADM=$$EN^PSBAPIPM(DFN,PSGBCPRV) Q:PSGBCADM'="" S PSGBCPRV=$P(^PS(55,DFN,PSGBCOT,+PSGBCPRV,PSGBCND),U,PSGBCPO) Q:(PSGBCPRV="")!(PSGBCPRV["P")
  1. .Q
  1. I $L(PSGBCADM) D I PSGBST Q +PSGBST
  1. .S PSGBCLID=$P(LI,".",1),PSGBCLIT=$E($P(LI,".",2),1,2) I $L(PSGBCLIT)=1 S PSGBCLIT=PSGBCLIT*10
  1. .S PSGBCSCH=$P(PSGBCADM,U,1),PSGBCSCD=$P(PSGBCSCH,".",1),PSGBCLDT=$P(PSGBCADM,U,2),PSGBCLA=$P(PSGBCADM,U,3)
  1. .I "GR"'[PSGBCLA Q
  1. .S PSGBCFR=""
  1. .I PSGBCORD["U" S PSGBCFR=$P(^PS(55,DFN,5,+PSGBCORD,2),U,6)
  1. .I PSGBCORD["V" S PSGBCFR=$P(^PS(55,DFN,"IV",+PSGBCORD,0),U,15)
  1. .;Convert
  1. .S PSGBCFR=$S(PSGBCFR="D":1440,PSGBCFR="O":0,1:PSGBCFR)*60
  1. .I 'PSGBCFR,'AT Q
  1. .S X=PSGBCSCH D H^%DTC S PSGBCSCH=%H*86400+%T,PSGBCSHH=%H_","_%T
  1. .S X=PSGBCLDT D H^%DTC S PSGBCLDT=%H*86400+%T,PSGBCLHH=%H_","_%T
  1. .;Sched Admin Time
  1. .I PSGBCSCH D
  1. ..;Check admin times/freq
  1. ..I AT D Q:PSGBST
  1. ...S PSGBSAT=$P($P(PSGBCADM,"^",1),".",2) Q:'PSGBSAT
  1. ...I $L(PSGBSAT)=1 S PSGBSAT=PSGBSAT*10
  1. ...I ((PSGBSAT<PSGBCLIT)!(PSGBCSCD<PSGBCLID))&(PSGBCSCD'>PSGBCLID) S PSGBSAT=PSGBCLIT ;&(PSGBCFR<86400)
  1. ...S PSGBNAT=""
  1. ...I ($L($P(AT,"-",1))=4)&($L(PSGBSAT)'=4) S PSGBSAT=PSGBSAT_$E("00",1,4-$L(PSGBSAT))
  1. ...F PSGBSATN=1:1 S PSGBNAT=$P(AT,"-",PSGBSATN) Q:PSGBNAT="" I PSGBNAT>PSGBSAT Q
  1. ...;If DOW
  1. ...I ("SU-MO-TU-WE-TH-FR-SA"[$P(SCH,"-",1)) D Q:PSGBST
  1. ....;Get TODAY
  1. ....D NOW^%DTC I '$L(PSGBNAT),PSGBCSCD'<X S X1=X,X2=1 D C^%DTC
  1. ....S PSGBCTDD=X D DW^%DTC S PSGBCTDY=$E(X,1,2)
  1. ....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)
  1. ....;DAY of Last Admin
  1. ....S X=PSGBCSCD D DW^%DTC S PSGBCTDA=$E(X,1,2) I PSGBCSCD<PSGBCTDD S PSGBCTDA=PSGBCTDY
  1. ....;Get Next Day in Sched
  1. ....S PSGDAYC=PSGBCTMP(PSGBCTDA),(PSGBDNXT,X)=""
  1. ....F X=PSGDAYC:1:7 I SCH[$G(PSGBCTMP(X)) S PSGBDNXT=PSGBCTMP(X) Q
  1. ....I '$L(PSGBDNXT) S PSGBDNXT=$P(SCH,"-",1)
  1. ....;Set new Start Day
  1. ....S PSGBCTDY=PSGBCTMP(PSGBCTDY)
  1. ....S PSGBDNXT=PSGBCTMP(PSGBDNXT)
  1. ....S X2=PSGBDNXT-PSGBCTDY I X2<0 S X2=(7-PSGBCTDY)+PSGBDNXT
  1. ....S X1=PSGBCTDD D C^%DTC ;Add # of days
  1. ....I +X S PSGBST=X_"."_($S('$L(PSGBNAT)!(PSGBCLID'=X):$P(AT,"-",1),1:PSGBNAT))
  1. ....Q
  1. ...;IF no Next Admin
  1. ...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
  1. ...S PSGBST=PSGBCSCD_"."_PSGBNAT
  1. ...Q
  1. ..I 'PSGBCFR Q
  1. ..;Add Freq
  1. ..S PSGBST=PSGBCSCH+PSGBCFR,PSGBST=(PSGBST\86400)_","_(PSGBST#86400)
  1. ..I $P(PSGBST,",",2)<3600 S $P(PSGBST,",",2)=3600
  1. ..;If next day
  1. ..I $P(PSGBST,",",2)<3600 S %H=$S(+PSGBST=+PSGBCSHH:+PSGBST,1:PSGBST-1)_",86400"
  1. ..S %H=PSGBST D YMD^%DTC S PSGBST=X_(+$E(%,1,5))
  1. ..I PSGBST<LI S PSGBST="" Q
  1. ..;If the date/time is > than the First admin
  1. ..I AT,($P(PSGBST,".",1)>PSGBCLID) D
  1. ...S PSGBSAT=$P(PSGBST,".",2) I $L(PSGBSAT)=1 S PSGBSAT=PSGBSAT*10
  1. ...S PSGBSATN=$P(AT,"-",1) ;First admin TIME
  1. ...I PSGBSAT>PSGBSATN S PSGBST=$P(PSGBST,".",1)_"."_PSGBSATN
  1. ...Q
  1. ..Q
  1. .;Future Date?
  1. .I (PSGBST)&((PSGBST<LI)!(($P(PSGBCADM,"^",1)+.0001)>PSGBST)) D
  1. ..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))
  1. ..S PSGBST=$$ENQ^PSJORP2(PSGP,INFO)
  1. ..I PSGBST<LI S PSGBST="" Q
  1. ..Q
  1. .;No Sched time
  1. .I PSGBCLDT,PSGBCFR,'PSGBCSCH D Q
  1. ..;Add Freq
  1. ..S PSGBST=PSGBCLDT+PSGBCFR,PSGBST=(PSGBST\86400)_","_(PSGBST#86400)
  1. ..I $P(PSGBST,",",2)<3600 S $P(PSGBST,",",2)=3600
  1. ..I $P(PSGBST,",",2)#3600 S PSGBTT=$P(($P(PSGBST,",",2)/3600)+1,".",1)*3600,$P(PSGBST,",",2)=PSGBTT
  1. ..;If next day
  1. ..I $P(PSGBST,",",2)<3600 S %H=$S(+PSGBST=+PSGBCLHH:+PSGBST,1:PSGBST-1)_",86400"
  1. ..S %H=PSGBST D YMD^%DTC S PSGBST=X_(+$E(%,1,3))
  1. ..I PSGBST<LI S PSGBST="" Q
  1. ..Q
  1. ;BHW;PSJ*5*179;END
  1. I ($P($G(PSJSYSW0),U,5)="")!($P($G(PSJSYSW0),U,5)=2) Q LI
  1. S:SCH["PRN" AT=""
  1. 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)
  1. 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)
  1. S:INT=24 OSD=$$FMADD^XLFDT(LI,0,-INT,0,0)
  1. 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)
  1. 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
  1. Q:INT=24&'$L(AT,"-") $E(LI,1,8)_AT
  1. I '$O(PSG(LI)) S X=$S(OSD>1:OSD,LI>1:LI,1:$$DATE^PSJUTL2) D
  1. .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)
  1. ..F Y=1:1 S AT1=$P(AT,"-",Y) Q:'AT1 S ND=ND\1_"."_AT1,PSG(+ND)=""
  1. Q:$P(PSJSYSW0,U,5) $O(PSG(LI))
  1. 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
  1. Q $S($G(OND):OND,1:LI) ;Use login time if OND is null PSJ*5*193