PSJSPU ;BIR/CML3-SCHEDULE PROCESSOR UTILITY ;16 DEC 97 / 1:44 PM
;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
;
EN ;
K PSJC S PSJC=0 D RUN
;
DONE ;
K AM,CD,H,HCD,I,J,M,MID,OD,PDL,ST,Q,QQ,WD,WDT,WS,WS1,X,X1,X2,XX Q
;
RUN ;
I $S(PSJSCH["PRN":1,PSJOFD<PSJSD:1,1:PSJOSD>PSJFD) Q
I $S(PSJTS="O":1,PSJSCH="STAT":1,PSJSCH="NOW":1,PSJSCH="ONCE":1,PSJSCH="ONE-TIME":1,PSJSCH="ON CALL":1,1:PSJSCH="ONE TIME") S PSJC=1,PSJC(+PSJOSD)="" Q
S ST=PSJOSD,CD=$S(PSJFD>PSJOFD:PSJOFD,1:PSJFD),OD=$S(ST>PSJSD:ST,1:PSJSD),MID=1
I PSJTS="R" D RANGE Q
I PSJTS["S" D SHFT Q
I PSJSCH["@"!(PSJTS["D") G MWF
S TS=PSJAT I PSJM>1440,TS,'(PSJM#1440) G TSFMN
I TS>0,"24"[$L($P(TS,"-")) S:PSJSD>ST ST=PSJSD G TS
I PSJM'>0 S PSJC="-1^PSJM" Q
;
MN ; minutes (MN) only
S (OD,X1)=PSJSD,X2=ST D ^%DTC I X>1 S AM=X-1*1440\PSJM*PSJM D ADD S ST=X
S (QQ,X)=ST F I=0:1 S AM=PSJM*I,ST=QQ D:AM ADD Q:X>CD!(CD=PSJOFD&(X'<CD)) I X'<OD S PSJC=PSJC+1,PSJC(+X)=""
Q
;
TSFMN ; admin times and minutes#1440=0
S X=$P(ST,"."),MID=PSJM\1440 F I=0:1 S X1=$P(ST,"."),X2=MID*I D:X2 C^%DTC Q:X'<CD I X'<(PSJSD\1) S ST=$S(PSJSD\1<X:X_.0001,1:PSJSD) G TS
Q
;
MTS ;
S CD=$S($P(HCD,".")>ST:ST_.24,1:HCD),ST=$S($P(OD,".")<ST:ST_.0001,1:OD) I PSJTS="DR" S:ST'>CD PSJC=PSJC+1,PSJC(ST)=CD Q
;
TS ; admin times
F Q=1:1 S XX=$P(TS,"-",Q) Q:XX=""!(("."_XX)'<(ST#1))
TS1 I XX="" S X1=$P(ST,"."),X2=MID D C^%DTC S ST=X,Q=1
F QQ=Q:1 S XX=$P(TS,"-",QQ) G:XX="" TS1 S ST=$P(ST,".")_"."_XX Q:ST>CD!(CD=PSJOFD&(ST'<CD)) S PSJC=PSJC+1,PSJC(+ST)=""
Q
;
MWF ;
I PSJTS'="DR" S TS=$S(PSJAT:PSJAT,$P(PSJSCH,"@",2):$P(PSJSCH,"@",2),1:$E(ST_"00011",9,12))
S HCD=CD,WS=$P(PSJSCH,"@"),X=$P(OD,"."),PDL="-" I WS'["-",WS?.E1P.E F PSJ1=1:1:$L(WS) I $E(WS,PSJ1)?1P S PDL=$E(WS,PSJ1) Q
F PSJ1=0:1 S X1=$P(OD,"."),X2=PSJ1 D:X2 C^%DTC Q:X>$P(HCD,".") S ST=X D DW^%DTC S X=X_"S" F PSJ2=1:1:$L(WS,PDL) I $P(X,$P(WS,PDL,PSJ2))="" D MTS Q
Q
;
ADD ;
S:'AM X=ST Q:'AM S T=1 S:AM<0 T=-1,AM=-AM S X2=AM\1440,AM=AM-(X2*1440),H=AM\60,M=AM#60,HRS=+$E(ST_"00",9,10),MN=+$E(ST_"0000",11,12),X=$P(ST,".")
I M S MN=MN+(M*T) S:MN>59 MN=MN-60,H=H+1 S:MN<0 MN=MN+60,H=H+1
I H S HRS=HRS+(H*T) S:HRS>24!(HRS=24&MN) HRS=HRS-24,X2=X2+1 S:HRS<0 HRS=HRS+24,X2=X2+1
I X2 S X1=$P(X,"."),X2=X2*T D C^%DTC
S X=+(X_"."_$E(0,HRS<10)_HRS_$E(0,MN<10)_MN) K AM,H,HRS,M,MN,T Q
;
SHFT ; shift schedules
K TM S TM="" F S TM=$O(PSJAT(TM)) Q:TM="" S X=$S(TM["-"&TM:TM,1:PSJAT(TM)) S:$L($P(X,"-"))=2 X=$P(X,"-")_"00-"_$P(X,"-",2)_"00" S TM(X)=""
I OD\1=(CD\1) S TM="" F S TM=$O(TM(TM)) Q:TM="" S:$P(TM,"-",2)<$P(TM,"-") $P(TM,"-",2)=24 S (X1,X2)=OD\1_".",X1=X1_$P(TM,"-"),X2=X2_$P(TM,"-",2) I X1'>CD,X2'<OD S PSJC=PSJC+1,PSJC(+$S(OD>X1:OD,1:X1))=+$S(CD>X2:X2,1:CD)
Q:OD\1=(CD\1)
K LD S LD(1)=OD F LD=2:1 S X1=OD\1,X2=LD-1 D C^%DTC S LD(LD)=X Q:CD\1=X
F LDC=1:1:LD-1 S TM="" F S TM=$O(TM(TM)) Q:TM="" S X1="."_$P(TM,"-"),X2="."_$P(TM,"-",2) D SHC
S TM="" F S TM=$O(TM(TM)) Q:TM="" S X1="."_$P(TM,"-"),X2="."_$P(TM,"-",2),X3=CD#1 I X2'<X1,X3'<X1 S PSJC=PSJC+1,PSJC(CD\1+X1)=$S(X3<X2:CD,1:CD\1+X2)
Q
;
SHC ;
I $S(LDC>1:1,X2<X1:1,1:LD(LDC)'>(LD(LDC)\1+X2)) S PSJC=PSJC+1,X=$S(LDC>1:LD(LDC)+X1,X1>(LD(LDC)#1):LD(LDC)\1+X1,1:LD(LDC)),Y=LD(X2<X1+LDC)\1+X2 S:Y>CD Y=CD S PSJC(X)=Y
Q
;
RANGE ;
I 'PSJM S PSJC=PSJC+1,PSJC(OD)=CD Q
S ST=OD F S AM=PSJM D ADD S PSJC=PSJC+1,PSJC(ST)=$S(X>CD:CD,1:X) Q:X'<CD S AM=1,ST=X D ADD S ST=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJSPU 3423 printed Apr 09, 2024@21:03:40 Page 2
PSJSPU ;BIR/CML3-SCHEDULE PROCESSOR UTILITY ;16 DEC 97 / 1:44 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
+2 ;
EN ;
+1 KILL PSJC
SET PSJC=0
DO RUN
+2 ;
DONE ;
+1 KILL AM,CD,H,HCD,I,J,M,MID,OD,PDL,ST,Q,QQ,WD,WDT,WS,WS1,X,X1,X2,XX
QUIT
+2 ;
RUN ;
+1 IF $SELECT(PSJSCH["PRN":1,PSJOFD<PSJSD:1,1:PSJOSD>PSJFD)
QUIT
+2 IF $SELECT(PSJTS="O":1,PSJSCH="STAT":1,PSJSCH="NOW":1,PSJSCH="ONCE":1,PSJSCH="ONE-TIME":1,PSJSCH="ON CALL":1,1:PSJSCH="ONE TIME")
SET PSJC=1
SET PSJC(+PSJOSD)=""
QUIT
+3 SET ST=PSJOSD
SET CD=$SELECT(PSJFD>PSJOFD:PSJOFD,1:PSJFD)
SET OD=$SELECT(ST>PSJSD:ST,1:PSJSD)
SET MID=1
+4 IF PSJTS="R"
DO RANGE
QUIT
+5 IF PSJTS["S"
DO SHFT
QUIT
+6 IF PSJSCH["@"!(PSJTS["D")
GOTO MWF
+7 SET TS=PSJAT
IF PSJM>1440
IF TS
IF '(PSJM#1440)
GOTO TSFMN
+8 IF TS>0
IF "24"[$LENGTH($PIECE(TS,"-"))
if PSJSD>ST
SET ST=PSJSD
GOTO TS
+9 IF PSJM'>0
SET PSJC="-1^PSJM"
QUIT
+10 ;
MN ; minutes (MN) only
+1 SET (OD,X1)=PSJSD
SET X2=ST
DO ^%DTC
IF X>1
SET AM=X-1*1440\PSJM*PSJM
DO ADD
SET ST=X
+2 SET (QQ,X)=ST
FOR I=0:1
SET AM=PSJM*I
SET ST=QQ
if AM
DO ADD
if X>CD!(CD=PSJOFD&(X'<CD))
QUIT
IF X'<OD
SET PSJC=PSJC+1
SET PSJC(+X)=""
+3 QUIT
+4 ;
TSFMN ; admin times and minutes#1440=0
+1 SET X=$PIECE(ST,".")
SET MID=PSJM\1440
FOR I=0:1
SET X1=$PIECE(ST,".")
SET X2=MID*I
if X2
DO C^%DTC
if X'<CD
QUIT
IF X'<(PSJSD\1)
SET ST=$SELECT(PSJSD\1<X:X_.0001,1:PSJSD)
GOTO TS
+2 QUIT
+3 ;
MTS ;
+1 SET CD=$SELECT($PIECE(HCD,".")>ST:ST_.24,1:HCD)
SET ST=$SELECT($PIECE(OD,".")<ST:ST_.0001,1:OD)
IF PSJTS="DR"
if ST'>CD
SET PSJC=PSJC+1
SET PSJC(ST)=CD
QUIT
+2 ;
TS ; admin times
+1 FOR Q=1:1
SET XX=$PIECE(TS,"-",Q)
if XX=""!(("."_XX)'<(ST#1))
QUIT
TS1 IF XX=""
SET X1=$PIECE(ST,".")
SET X2=MID
DO C^%DTC
SET ST=X
SET Q=1
+1 FOR QQ=Q:1
SET XX=$PIECE(TS,"-",QQ)
if XX=""
GOTO TS1
SET ST=$PIECE(ST,".")_"."_XX
if ST>CD!(CD=PSJOFD&(ST'<CD))
QUIT
SET PSJC=PSJC+1
SET PSJC(+ST)=""
+2 QUIT
+3 ;
MWF ;
+1 IF PSJTS'="DR"
SET TS=$SELECT(PSJAT:PSJAT,$PIECE(PSJSCH,"@",2):$PIECE(PSJSCH,"@",2),1:$EXTRACT(ST_"00011",9,12))
+2 SET HCD=CD
SET WS=$PIECE(PSJSCH,"@")
SET X=$PIECE(OD,".")
SET PDL="-"
IF WS'["-"
IF WS?.E1P.E
FOR PSJ1=1:1:$LENGTH(WS)
IF $EXTRACT(WS,PSJ1)?1P
SET PDL=$EXTRACT(WS,PSJ1)
QUIT
+3 FOR PSJ1=0:1
SET X1=$PIECE(OD,".")
SET X2=PSJ1
if X2
DO C^%DTC
if X>$PIECE(HCD,".")
QUIT
SET ST=X
DO DW^%DTC
SET X=X_"S"
FOR PSJ2=1:1:$LENGTH(WS,PDL)
IF $PIECE(X,$PIECE(WS,PDL,PSJ2))=""
DO MTS
QUIT
+4 QUIT
+5 ;
ADD ;
+1 if 'AM
SET X=ST
if 'AM
QUIT
SET T=1
if AM<0
SET T=-1
SET AM=-AM
SET X2=AM\1440
SET AM=AM-(X2*1440)
SET H=AM\60
SET M=AM#60
SET HRS=+$EXTRACT(ST_"00",9,10)
SET MN=+$EXTRACT(ST_"0000",11,12)
SET X=$PIECE(ST,".")
+2 IF M
SET MN=MN+(M*T)
if MN>59
SET MN=MN-60
SET H=H+1
if MN<0
SET MN=MN+60
SET H=H+1
+3 IF H
SET HRS=HRS+(H*T)
if HRS>24!(HRS=24&MN)
SET HRS=HRS-24
SET X2=X2+1
if HRS<0
SET HRS=HRS+24
SET X2=X2+1
+4 IF X2
SET X1=$PIECE(X,".")
SET X2=X2*T
DO C^%DTC
+5 SET X=+(X_"."_$EXTRACT(0,HRS<10)_HRS_$EXTRACT(0,MN<10)_MN)
KILL AM,H,HRS,M,MN,T
QUIT
+6 ;
SHFT ; shift schedules
+1 KILL TM
SET TM=""
FOR
SET TM=$ORDER(PSJAT(TM))
if TM=""
QUIT
SET X=$SELECT(TM["-"&TM:TM,1:PSJAT(TM))
if $LENGTH($PIECE(X,"-"))=2
SET X=$PIECE(X,"-")_"00-"_$PIECE(X,"-",2)_"00"
SET TM(X)=""
+2 IF OD\1=(CD\1)
SET TM=""
FOR
SET TM=$ORDER(TM(TM))
if TM=""
QUIT
if $PIECE(TM,"-",2)<$PIECE(TM,"-")
SET $PIECE(TM,"-",2)=24
SET (X1,X2)=OD\1_"."
SET X1=X1_$PIECE(TM,"-")
SET X2=X2_$PIECE(TM,"-",2)
IF X1'>CD
IF X2'<OD
SET PSJC=PSJC+1
SET PSJC(+$SELECT(OD>X1:OD,1:X1))=+$SELECT(CD>X2:X2,1:CD)
+3 if OD\1=(CD\1)
QUIT
+4 KILL LD
SET LD(1)=OD
FOR LD=2:1
SET X1=OD\1
SET X2=LD-1
DO C^%DTC
SET LD(LD)=X
if CD\1=X
QUIT
+5 FOR LDC=1:1:LD-1
SET TM=""
FOR
SET TM=$ORDER(TM(TM))
if TM=""
QUIT
SET X1="."_$PIECE(TM,"-")
SET X2="."_$PIECE(TM,"-",2)
DO SHC
+6 SET TM=""
FOR
SET TM=$ORDER(TM(TM))
if TM=""
QUIT
SET X1="."_$PIECE(TM,"-")
SET X2="."_$PIECE(TM,"-",2)
SET X3=CD#1
IF X2'<X1
IF X3'<X1
SET PSJC=PSJC+1
SET PSJC(CD\1+X1)=$SELECT(X3<X2:CD,1:CD\1+X2)
+7 QUIT
+8 ;
SHC ;
+1 IF $SELECT(LDC>1:1,X2<X1:1,1:LD(LDC)'>(LD(LDC)\1+X2))
SET PSJC=PSJC+1
SET X=$SELECT(LDC>1:LD(LDC)+X1,X1>(LD(LDC)#1):LD(LDC)\1+X1,1:LD(LDC))
SET Y=LD(X2<X1+LDC)\1+X2
if Y>CD
SET Y=CD
SET PSJC(X)=Y
+2 QUIT
+3 ;
RANGE ;
+1 IF 'PSJM
SET PSJC=PSJC+1
SET PSJC(OD)=CD
QUIT
+2 SET ST=OD
FOR
SET AM=PSJM
DO ADD
SET PSJC=PSJC+1
SET PSJC(ST)=$SELECT(X>CD:CD,1:X)
if X'<CD
QUIT
SET AM=1
SET ST=X
DO ADD
SET ST=X
+3 QUIT
