- PSIVWL ;BIR/RGY,PR - COMPILE AND PRT WARD LIST ;13 MAR 97 / 10:18 AM
- ;;5.0;INPATIENT MEDICATIONS;**41,54,74,84,93,110,111,141,305,350**;16 DEC 97;Build 3
- ;
- ; Reference to ^PS(51.1 is supported by DBIA 2177
- ; Reference to ^PS(55 is supported by DBIA 2191
- ;
- K WRD W !!,"Run ward list for DATE: TODAY//" R X:DTIME S:'$T X="^" S:X="" X="T" G Q:X["^" K %DT S %DT="XE" D ^%DT G:Y<0 PSIVWL
- S PSIVDT=Y\1 I Y<DT D ENRSET^PSIVWL1 G PSIVWL
- D ^PSIVWL1 I '$D(PSIVOD)!('$D(PSIVCD)) G Q
- I PSIVPR'=ION D QUE G Q
- DEQ ;
- N PSJOK
- D NOW^%DTC S Y=% L +^PS(55,"PSIVWL",PSIVSN):1 E W:$Y @IOF W !!,"**** WARNING --- WARD LIST NOT RUN, LABEL RUN IN PROGRESS ****" G Q
- D:$D(XRTL) T0^%ZOSV S NOFLG=0
- S PSIVT="" D ENINIT^PSIVWL1 F PSIV1=0:0 S PSIVT=$O(PSIVOD(PSIVT)) Q:PSIVT="" S PSIVDT1=PSIVOD(PSIVT)-.0001 F PSIV1=0:0 S PSIVDT1=$O(^PS(55,"AIV",PSIVDT1)) Q:'PSIVDT1 D MAN1
- I $D(XRTL) S XRTN="PSIVWL" D T1^%ZOSV
- D ENT^PSIVWL1
- Q L -^PS(55,"PSIVWL",PSIVSN) W:'$D(PSIVPR)&($Y) @IOF K MI,ON,NOFLG,PSCT,PSGCNT,PSGSA,PSIVMT,DIC,PSIVRUN,%DT,PSIVDT1,PSIVDT,PSIV,PSIVOD
- K PSIVCD,PSM,%T,D,DFN,I,P,PSIV1,VAERR,X,Y,Z,Z1,Z2,ZTSK S:$D(ZTQUEUED) ZTREQ="@"
- Q
- SETP S Y=^PS(55,DFN,"IV",ON,0) F X=1:1:23 S P(X)=$P(Y,"^",X)
- N A,PSJST
- S PSJST=$$ONE^PSJBCMA(DFN,ON,P(9))
- S PSJOK=1 I PSJST="O" S A=0 F S A=$O(^PS(55,DFN,"IV",+ON,"LAB",A)) Q:A="" I $P($G(^(A,0)),"^",3)=1 S PSJOK=0 Q
- Q
- MAN1 F DFN=0:0 S DFN=$O(^PS(55,"AIV",PSIVDT1,DFN)) Q:'DFN S PSIV("NME")=$P($G(^DPT(DFN,0)),U) D INP^VADPT F ON=0:0 S ON=$O(^PS(55,"AIV",PSIVDT1,DFN,ON)) Q:'ON Q:NOFLG=1 D SETP I PSJOK D MAN3
- Q
- MAN2 S ^PS(55,"PSIVWL",PSIVSN,$S($P(VAIN(4),U,2)]"":$P(VAIN(4),U,2),1:"Outpatient IV"),P(4)_PSIVOD(P(4)),DFN,ON)=$S($P(P(8),"@",2)'=0:PSGCNT,1:0)_"^"_PSGSA_"^"_$P(^PS(55,DFN,"IV",ON,0),"^",16)
- ;naked reference on line below refers to full global reference to right of = sign
- S $P(^(0),"^",16)=$P(^PS(55,DFN,"IV",ON,0),"^",16)+PSGCNT Q
- Q
- MAN3 ;I P(4)=""!(P(4)'=PSIVT) S NOFLG=1 D NOW^%DTC S PSIVRUN=$E(%,1,12) K %,%I,%H D HDR^PSIVWL1 W !!,"****NO DATA FOUND FOR THIS REPORT!***" Q
- Q:P(4)=""!(P(4)'=PSIVT)
- Q:'$D(PSIVOD(P(4)))!("DPN"[P(17))!($S($D(^PS(55,DFN,"IV",ON,2)):PSIVSN'=$P(^(2),"^",2),1:0))
- I "OH"[P(17) S PSGSA="",PSGCNT=0 D MAN2 Q
- S CD=$S(PSIVCD(PSIVT)<P(3):PSIVCD(PSIVT),1:P(3)),OD=$S(P(2)>PSIVOD(PSIVT):P(2),1:PSIVOD(PSIVT)) D ENP3,MAN2 Q
- QUE S ZTIO=PSIVPR,ZTDESC="IV WARD LIST",ZTRTN="DEQ^PSIVWL",PSIVT="" F I=0:0 S PSIVT=$O(PSIVMT(PSIVT)) Q:PSIVT="" S (ZTSAVE("PSIVCD("""_PSIVT_""")"),ZTSAVE("PSIVMT("""_PSIVT_""")"),ZTSAVE("PSIVOD("""_PSIVT_""")"))=""
- F X="PSIVSN","PSIVDT","PSIVSITE","PSJSYSW0","PSJSYSP0","PSJSYSU" S ZTSAVE(X)=""
- D ^%ZTLOAD W:$D(ZTSK) !,"Queued." Q
- ENP3 ;
- ;Needs DFN,ON P-array, OD and CD
- Q:'P(2)!'P(3) S PSIVMI=P(15),PSIVSD=P(2),PSGSA="",PSGCNT=0 S:PSIVMI>1440 P(11)=""
- I P(11) G:"AH"[P(4) QSP F X="STAT","ONCE","NOW","ONE-TIME","ONE TIME","ONETIME","1-TIME","1 TIME","1-TIME" I $S(X=P(9):1,1:(P(9)[X)),PSIVSD'<OD,PSIVSD'>CD S PSGSA=PSIVSD_" " G QSP
- I P(4)="P"!(P(5))!(P(23)="P"),P(11) D CHK,ENP4 G QSP
- G:P(11) QSP I PSIVMI,OD\1>(PSIVSD\1) S X1=OD,X2=PSIVSD D ^%DTC I X>1 S X=X-1,PSIVMIN=X*1440\PSIVMI*PSIVMI D ENT S PSIVSD=Y
- I PSIVSD'<OD,PSIVSD'>CD S Y=PSIVSD,PSGSA=Y_" "
- I PSIVMI F X=0:0 S PSIVMIN=PSIVMI D ENT Q:Y>CD!(Y=CD&(CD=P(3))) S PSIVSD=Y I Y'<OD,Y'>CD S:$L(PSGSA)+$L(Y)'>240 PSGSA=PSGSA_$S(PSGSA'="":"."_$P(Y,".",2),1:Y)_" "
- QSP S PSGCNT=$L(PSGSA," ")-1 K PSIVMI,OD,CD,PSIVSD S:P(7)=1!($G(P("NUMLBL"))=0) PSGCNT=0 Q ;PSJ*5*141 Add P(7) check, *305
- CHK F Y=1:1 Q:$L(P(11))>240!($P(P(11),"-",Y)="") S $P(P(11),"-",Y)=$P(P(11),"-",Y)_$E("0000",1,4-$L($P(P(11),"-",Y)))
- Q
- ENP4 Q:PSIVSD>CD S PSIVSD=OD\1 I $G(P(2)),PSIVSD<P(2) S PSIVSD=P(2)\1
- NEW ODCDWD,ADM,ADMSD,ADMTM,PSIVX,P9
- F X=OD,CD D DW^%DTC S ODCDWD=$G(ODCDWD)_$E(X,1,3)_U
- I +$O(^PS(51.1,"APPSJ",P(9),0)) S PSIVX=1 S P9=$P(P(9),"@") F X=1:1:$L(P9,"-") D Q:'$G(PSIVX)
- . I '("MON,TUE,WED,THU,FRI,SAT,SUN,"[$P(P9,"-",X)) S PSIVX=0 Q
- . I ODCDWD[$E($P(P9,"-",X),1,2) D
- .. S ADMSD=$S($P(ODCDWD,"^")[$P(P9,"-",X):OD,1:CD)\1
- .. F ADM=1:1:$L(P(11),"-") S ADMTM=$P(P(11),"-",ADM) I OD'>(ADMSD_"."_ADMTM),(CD'<(ADMSD_"."_ADMTM)) S PSGSA=PSGSA_$S(PSGSA'="":"",1:ADMSD)_"."_ADMTM_" "
- .. ;F ADM=1:1:$L(P(11),"-") S ADMTM=$P(P(11),"-",ADM) I OD'>(ADMSD_"."_ADMTM),(CD'<(ADMSD_"."_ADMTM)) S PSGSA=PSGSA_$S(PSGSA'="":"",1:PSIVSD)_"."_ADMTM_" "
- Q:+$G(PSIVX)
- I '$D(^PS(51.1,"APPSJ",P(9))) S PSIVX=1,P9=$P(P(9),"@") F X=1:1:$L(P9,"-") D Q:'$G(PSIVX)
- . I '(",MO,TU,WE,TH,FR,SA,SU,"[(","_$P(P9,"-",X)_",")) S PSIVX=0 Q
- . I ODCDWD[$E($P(P9,"-",X),1,2) D
- .. S ADMSD=$S($P(ODCDWD,"^")[$P(P9,"-",X):OD,1:CD)\1
- .. F ADM=1:1:$L(P(11),"-") S ADMTM=$P(P(11),"-",ADM) I OD'>(ADMSD_"."_ADMTM),(CD'<(ADMSD_"."_ADMTM)) S PSGSA=PSGSA_$S(PSGSA'="":"",1:ADMSD)_"."_ADMTM_" "
- .. ;F ADM=1:1:$L(P(11),"-") S ADMTM=$P(P(11),"-",ADM) I OD'>(ADMSD_"."_ADMTM),(CD'<(ADMSD_"."_ADMTM)) S PSGSA=PSGSA_$S(PSGSA'="":"",1:PSIVSD)_"."_ADMTM_" "
- Q:+$G(PSIVX)
- F Y=1:1 S (PSIVMI,MI)=$P(P(11),"-",Y),PSIVSD=+(PSIVSD\1_"."_MI) Q:PSIVSD>CD X:MI="" "S X1=PSIVSD,X2=1 D C^%DTC S PSIVSD=X,Y=0" I MI,PSIVSD'<OD,PSIVSD'>CD,PSIVSD'=P(3),'P(7) S PSGSA=PSGSA_$S(PSGSA'="":"."_$P(PSIVSD,".",2),1:PSIVSD)_" "
- ; INSTALL PRECEEDING LINE WITH VERSION 17.3 OF FILEMAN
- Q
- ENT ;PSIVMIN=# of min. to add or sub, PSIVSD=date to add or sub from in FM format -- Answer ret. in 'Y'
- S X2=PSIVMIN\1440,HOUR=(PSIVMIN-(1440*X2))\60,MIN=(PSIVMIN-(1440*X2)-(60*HOUR))#$S(PSIVMIN<0:-60,1:60),X1=PSIVSD\1,HR=$E(PSIVSD,9,10),MI=$E(PSIVSD,11,12)
- S:$L(HR)=1 HR=HR_0 S:$L(MI)=1 MI=MI_0 S MI=MI+MIN S:MI>59 MI=MI-60,HR=HR+1
- S:MI<0 MI=MI+60,HR=HR-1 S HR=HR+HOUR S:HR>23 HR=HR-24,X2=X2+1 S:HR<0 HR=HR+24,X2=X2-1 S:HR+MI=0 X2=X2-1,HR=24,MI=0 S:HR<10 HR=0_HR S:MI<10 MI=0_MI S X=X1 D:X2 C^%DTC S X=$P(X,".") S Y=+(X_"."_HR_MI)
- ; install with version 17.3 of fm
- K HR,MI,X1,X2,HOUR,MIN,PSIVMIN,O,MI Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVWL 5881 printed Feb 18, 2025@23:31:40 Page 2
- PSIVWL ;BIR/RGY,PR - COMPILE AND PRT WARD LIST ;13 MAR 97 / 10:18 AM
- +1 ;;5.0;INPATIENT MEDICATIONS;**41,54,74,84,93,110,111,141,305,350**;16 DEC 97;Build 3
- +2 ;
- +3 ; Reference to ^PS(51.1 is supported by DBIA 2177
- +4 ; Reference to ^PS(55 is supported by DBIA 2191
- +5 ;
- +6 KILL WRD
- WRITE !!,"Run ward list for DATE: TODAY//"
- READ X:DTIME
- if '$TEST
- SET X="^"
- if X=""
- SET X="T"
- if X["^"
- GOTO Q
- KILL %DT
- SET %DT="XE"
- DO ^%DT
- if Y<0
- GOTO PSIVWL
- +7 SET PSIVDT=Y\1
- IF Y<DT
- DO ENRSET^PSIVWL1
- GOTO PSIVWL
- +8 DO ^PSIVWL1
- IF '$DATA(PSIVOD)!('$DATA(PSIVCD))
- GOTO Q
- +9 IF PSIVPR'=ION
- DO QUE
- GOTO Q
- DEQ ;
- +1 NEW PSJOK
- +2 DO NOW^%DTC
- SET Y=%
- LOCK +^PS(55,"PSIVWL",PSIVSN):1
- IF '$TEST
- if $Y
- WRITE @IOF
- WRITE !!,"**** WARNING --- WARD LIST NOT RUN, LABEL RUN IN PROGRESS ****"
- GOTO Q
- +3 if $DATA(XRTL)
- DO T0^%ZOSV
- SET NOFLG=0
- +4 SET PSIVT=""
- DO ENINIT^PSIVWL1
- FOR PSIV1=0:0
- SET PSIVT=$ORDER(PSIVOD(PSIVT))
- if PSIVT=""
- QUIT
- SET PSIVDT1=PSIVOD(PSIVT)-.0001
- FOR PSIV1=0:0
- SET PSIVDT1=$ORDER(^PS(55,"AIV",PSIVDT1))
- if 'PSIVDT1
- QUIT
- DO MAN1
- +5 IF $DATA(XRTL)
- SET XRTN="PSIVWL"
- DO T1^%ZOSV
- +6 DO ENT^PSIVWL1
- Q LOCK -^PS(55,"PSIVWL",PSIVSN)
- if '$DATA(PSIVPR)&($Y)
- WRITE @IOF
- KILL MI,ON,NOFLG,PSCT,PSGCNT,PSGSA,PSIVMT,DIC,PSIVRUN,%DT,PSIVDT1,PSIVDT,PSIV,PSIVOD
- +1 KILL PSIVCD,PSM,%T,D,DFN,I,P,PSIV1,VAERR,X,Y,Z,Z1,Z2,ZTSK
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 QUIT
- SETP SET Y=^PS(55,DFN,"IV",ON,0)
- FOR X=1:1:23
- SET P(X)=$PIECE(Y,"^",X)
- +1 NEW A,PSJST
- +2 SET PSJST=$$ONE^PSJBCMA(DFN,ON,P(9))
- +3 SET PSJOK=1
- IF PSJST="O"
- SET A=0
- FOR
- SET A=$ORDER(^PS(55,DFN,"IV",+ON,"LAB",A))
- if A=""
- QUIT
- IF $PIECE($GET(^(A,0)),"^",3)=1
- SET PSJOK=0
- QUIT
- +4 QUIT
- MAN1 FOR DFN=0:0
- SET DFN=$ORDER(^PS(55,"AIV",PSIVDT1,DFN))
- if 'DFN
- QUIT
- SET PSIV("NME")=$PIECE($GET(^DPT(DFN,0)),U)
- DO INP^VADPT
- FOR ON=0:0
- SET ON=$ORDER(^PS(55,"AIV",PSIVDT1,DFN,ON))
- if 'ON
- QUIT
- if NOFLG=1
- QUIT
- DO SETP
- IF PSJOK
- DO MAN3
- +1 QUIT
- MAN2 SET ^PS(55,"PSIVWL",PSIVSN,$SELECT($PIECE(VAIN(4),U,2)]"":$PIECE(VAIN(4),U,2),1:"Outpatient IV"),P(4)_PSIVOD(P(4)),DFN,ON)=$SELECT($PIECE(P(8),"@",2)'=0:PSGCNT,1:0)_"^"_PSGSA_"^"_$PIECE(^PS(55,DFN,"IV",ON,0),"^",16)
- +1 ;naked reference on line below refers to full global reference to right of = sign
- +2 SET $PIECE(^(0),"^",16)=$PIECE(^PS(55,DFN,"IV",ON,0),"^",16)+PSGCNT
- QUIT
- +3 QUIT
- MAN3 ;I P(4)=""!(P(4)'=PSIVT) S NOFLG=1 D NOW^%DTC S PSIVRUN=$E(%,1,12) K %,%I,%H D HDR^PSIVWL1 W !!,"****NO DATA FOUND FOR THIS REPORT!***" Q
- +1 if P(4)=""!(P(4)'=PSIVT)
- QUIT
- +2 if '$DATA(PSIVOD(P(4)))!("DPN"[P(17))!($SELECT($DATA(^PS(55,DFN,"IV",ON,2))
- QUIT
- +3 IF "OH"[P(17)
- SET PSGSA=""
- SET PSGCNT=0
- DO MAN2
- QUIT
- +4 SET CD=$SELECT(PSIVCD(PSIVT)<P(3):PSIVCD(PSIVT),1:P(3))
- SET OD=$SELECT(P(2)>PSIVOD(PSIVT):P(2),1:PSIVOD(PSIVT))
- DO ENP3
- DO MAN2
- QUIT
- QUE SET ZTIO=PSIVPR
- SET ZTDESC="IV WARD LIST"
- SET ZTRTN="DEQ^PSIVWL"
- SET PSIVT=""
- FOR I=0:0
- SET PSIVT=$ORDER(PSIVMT(PSIVT))
- if PSIVT=""
- QUIT
- SET (ZTSAVE("PSIVCD("""_PSIVT_""")"),ZTSAVE("PSIVMT("""_PSIVT_""")"),ZTSAVE("PSIVOD("""_PSIVT_""")"))=""
- +1 FOR X="PSIVSN","PSIVDT","PSIVSITE","PSJSYSW0","PSJSYSP0","PSJSYSU"
- SET ZTSAVE(X)=""
- +2 DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"Queued."
- QUIT
- ENP3 ;
- +1 ;Needs DFN,ON P-array, OD and CD
- +2 if 'P(2)!'P(3)
- QUIT
- SET PSIVMI=P(15)
- SET PSIVSD=P(2)
- SET PSGSA=""
- SET PSGCNT=0
- if PSIVMI>1440
- SET P(11)=""
- +3 IF P(11)
- if "AH"[P(4)
- GOTO QSP
- FOR X="STAT","ONCE","NOW","ONE-TIME","ONE TIME","ONETIME","1-TIME","1 TIME","1-TIME"
- IF $SELECT(X=P(9):1,1:(P(9)[X))
- IF PSIVSD'<OD
- IF PSIVSD'>CD
- SET PSGSA=PSIVSD_" "
- GOTO QSP
- +4 IF P(4)="P"!(P(5))!(P(23)="P")
- IF P(11)
- DO CHK
- DO ENP4
- GOTO QSP
- +5 if P(11)
- GOTO QSP
- IF PSIVMI
- IF OD\1>(PSIVSD\1)
- SET X1=OD
- SET X2=PSIVSD
- DO ^%DTC
- IF X>1
- SET X=X-1
- SET PSIVMIN=X*1440\PSIVMI*PSIVMI
- DO ENT
- SET PSIVSD=Y
- +6 IF PSIVSD'<OD
- IF PSIVSD'>CD
- SET Y=PSIVSD
- SET PSGSA=Y_" "
- +7 IF PSIVMI
- FOR X=0:0
- SET PSIVMIN=PSIVMI
- DO ENT
- if Y>CD!(Y=CD&(CD=P(3)))
- QUIT
- SET PSIVSD=Y
- IF Y'<OD
- IF Y'>CD
- if $LENGTH(PSGSA)+$LENGTH(Y)'>240
- SET PSGSA=PSGSA_$SELECT(PSGSA'="":"."_$PIECE(Y,".",2),1:Y)_" "
- QSP ;PSJ*5*141 Add P(7) check, *305
- SET PSGCNT=$LENGTH(PSGSA," ")-1
- KILL PSIVMI,OD,CD,PSIVSD
- if P(7)=1!($GET(P("NUMLBL"))=0)
- SET PSGCNT=0
- QUIT
- CHK FOR Y=1:1
- if $LENGTH(P(11))>240!($PIECE(P(11),"-",Y)="")
- QUIT
- SET $PIECE(P(11),"-",Y)=$PIECE(P(11),"-",Y)_$EXTRACT("0000",1,4-$LENGTH($PIECE(P(11),"-",Y)))
- +1 QUIT
- ENP4 if PSIVSD>CD
- QUIT
- SET PSIVSD=OD\1
- IF $GET(P(2))
- IF PSIVSD<P(2)
- SET PSIVSD=P(2)\1
- +1 NEW ODCDWD,ADM,ADMSD,ADMTM,PSIVX,P9
- +2 FOR X=OD,CD
- DO DW^%DTC
- SET ODCDWD=$GET(ODCDWD)_$EXTRACT(X,1,3)_U
- +3 IF +$ORDER(^PS(51.1,"APPSJ",P(9),0))
- SET PSIVX=1
- SET P9=$PIECE(P(9),"@")
- FOR X=1:1:$LENGTH(P9,"-")
- Begin DoDot:1
- +4 IF '("MON,TUE,WED,THU,FRI,SAT,SUN,"[$PIECE(P9,"-",X))
- SET PSIVX=0
- QUIT
- +5 IF ODCDWD[$EXTRACT($PIECE(P9,"-",X),1,2)
- Begin DoDot:2
- +6 SET ADMSD=$SELECT($PIECE(ODCDWD,"^")[$PIECE(P9,"-",X):OD,1:CD)\1
- +7 FOR ADM=1:1:$LENGTH(P(11),"-")
- SET ADMTM=$PIECE(P(11),"-",ADM)
- IF OD'>(ADMSD_"."_ADMTM)
- IF (CD'<(ADMSD_"."_ADMTM))
- SET PSGSA=PSGSA_$SELECT(PSGSA'="":"",1:ADMSD)_"."_ADMTM_" "
- +8 ;F ADM=1:1:$L(P(11),"-") S ADMTM=$P(P(11),"-",ADM) I OD'>(ADMSD_"."_ADMTM),(CD'<(ADMSD_"."_ADMTM)) S PSGSA=PSGSA_$S(PSGSA'="":"",1:PSIVSD)_"."_ADMTM_" "
- End DoDot:2
- End DoDot:1
- if '$GET(PSIVX)
- QUIT
- +9 if +$GET(PSIVX)
- QUIT
- +10 IF '$DATA(^PS(51.1,"APPSJ",P(9)))
- SET PSIVX=1
- SET P9=$PIECE(P(9),"@")
- FOR X=1:1:$LENGTH(P9,"-")
- Begin DoDot:1
- +11 IF '(",MO,TU,WE,TH,FR,SA,SU,"[(","_$PIECE(P9,"-",X)_","))
- SET PSIVX=0
- QUIT
- +12 IF ODCDWD[$EXTRACT($PIECE(P9,"-",X),1,2)
- Begin DoDot:2
- +13 SET ADMSD=$SELECT($PIECE(ODCDWD,"^")[$PIECE(P9,"-",X):OD,1:CD)\1
- +14 FOR ADM=1:1:$LENGTH(P(11),"-")
- SET ADMTM=$PIECE(P(11),"-",ADM)
- IF OD'>(ADMSD_"."_ADMTM)
- IF (CD'<(ADMSD_"."_ADMTM))
- SET PSGSA=PSGSA_$SELECT(PSGSA'="":"",1:ADMSD)_"."_ADMTM_" "
- +15 ;F ADM=1:1:$L(P(11),"-") S ADMTM=$P(P(11),"-",ADM) I OD'>(ADMSD_"."_ADMTM),(CD'<(ADMSD_"."_ADMTM)) S PSGSA=PSGSA_$S(PSGSA'="":"",1:PSIVSD)_"."_ADMTM_" "
- End DoDot:2
- End DoDot:1
- if '$GET(PSIVX)
- QUIT
- +16 if +$GET(PSIVX)
- QUIT
- +17 FOR Y=1:1
- SET (PSIVMI,MI)=$PIECE(P(11),"-",Y)
- SET PSIVSD=+(PSIVSD\1_"."_MI)
- if PSIVSD>CD
- QUIT
- if MI=""
- XECUTE "S X1=PSIVSD,X2=1 D C^%DTC S PSIVSD=X,Y=0"
- IF MI
- IF PSIVSD'<OD
- IF PSIVSD'>CD
- IF PSIVSD'=P(3)
- IF 'P(7)
- SET PSGSA=PSGSA_$SELECT(PSGSA'="":"."_$PIECE(PSIVSD,".",2),1:PSIVSD)_" "
- +18 ; INSTALL PRECEEDING LINE WITH VERSION 17.3 OF FILEMAN
- +19 QUIT
- ENT ;PSIVMIN=# of min. to add or sub, PSIVSD=date to add or sub from in FM format -- Answer ret. in 'Y'
- +1 SET X2=PSIVMIN\1440
- SET HOUR=(PSIVMIN-(1440*X2))\60
- SET MIN=(PSIVMIN-(1440*X2)-(60*HOUR))#$SELECT(PSIVMIN<0:-60,1:60)
- SET X1=PSIVSD\1
- SET HR=$EXTRACT(PSIVSD,9,10)
- SET MI=$EXTRACT(PSIVSD,11,12)
- +2 if $LENGTH(HR)=1
- SET HR=HR_0
- if $LENGTH(MI)=1
- SET MI=MI_0
- SET MI=MI+MIN
- if MI>59
- SET MI=MI-60
- SET HR=HR+1
- +3 if MI<0
- SET MI=MI+60
- SET HR=HR-1
- SET HR=HR+HOUR
- if HR>23
- SET HR=HR-24
- SET X2=X2+1
- if HR<0
- SET HR=HR+24
- SET X2=X2-1
- if HR+MI=0
- SET X2=X2-1
- SET HR=24
- SET MI=0
- if HR<10
- SET HR=0_HR
- if MI<10
- SET MI=0_MI
- SET X=X1
- if X2
- DO C^%DTC
- SET X=$PIECE(X,".")
- SET Y=+(X_"."_HR_MI)
- +4 ; install with version 17.3 of fm
- +5 KILL HR,MI,X1,X2,HOUR,MIN,PSIVMIN,O,MI
- QUIT
