- IBDFQB ;ALB/MAF - MAIN QUEUE JOB FOR ENCOUNTER FORM PRINTING - FEB 2 1995
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
- ;
- EN ;
- ; -- Goes through the "SEQ" cross reference to print the
- ; highest priority jobs first (lowest sequence number).
- N IBDFQUE,IBDFQDT,IBDFQD,IBDFQT,IBDFTSTP
- S IBDFQUE=1,IBDFTSTP=1
- S (IBDFNUM,IBDFNAME,IBDFIFN,IBDFSEQ,QUIT)=0
- D NOW^%DTC S IBDFQDT=%,IBDFQD=$P(%,"."),IBDFQT=$E($P(%,".",2),1,4)
- ;
- F S IBDFSEQ=$O(^IBD(357.09,"SEQ",IBDFSEQ)) Q:IBDFSEQ']"" F S IBDFNUM=$O(^IBD(357.09,"SEQ",IBDFSEQ,IBDFNUM)) Q:IBDFNUM']"" F S IBDFIFN=$O(^IBD(357.09,"SEQ",IBDFSEQ,IBDFNUM,IBDFIFN)) Q:IBDFIFN']"" N IBDFARY D UP($$QUEUE(IBDFIFN))
- ;
- ; -- send forms pending pages to PCE automatically
- D BCKGRND^IBDFFRFT
- ;
- G EXIT
- ;
- ;
- UP(IBTASK) ; -- store results of tasking
- Q:'$G(IBTASK)
- D TASK
- Q
- ;
- ;
- QUEUE(IBDFIFN) ; -- Set up Queue variables
- N ZTSK,ZTDTH,ZTRTN,ZTDESC,ZTSAVE,ZTION,X,Y
- K ^TMP("IBDF",$J,"C"),^TMP("IBDF",$J,"D")
- D SET
- G:('$D(^TMP("IBDF",$J)))!QUIT CLEAR
- ;
- ; -- check if already tasked and running?
- ;I $P(IBDFNODE,"^",11)]"" S ZTSK=$P(IBDFNODE,"^",11) D STAT^%ZTLOAD I "^1^2^"[ZTSK(1) S QUIT=1 G CLEAR
- ;I $P(IBDFNODE,"^",11)]"" S ZTSK=$P(IBDFNODE,"^",11) W !,ZTSK,! B
- S $P(^IBD(357.09,IBDFNUM,"Q",IBDFIFN,0),"^",14)=$P(IBDFNODE,"^",11)
- ;
- F IBDT=0:0 S IBDT=$O(IBDFARY(IBDT)) Q:'IBDT D
- .S ZTDTH=$S('$D(ZTDTH):$H,$D(ZTDTH)&(ZTDTH]""):ZTDTH,1:$H)
- .S ZTRTN="DQ^IBDFQB",ZTDESC="IBD - Encounter Forms for"_IBDFNAME,ZTSAVE("^TMP(""IBDF"",$J,")="",ZTSAVE("IB*")="",ZTIO=$S($P(IBDFNODE,"^",9)]"":$P(IBDFNODE,"^",9),1:"") D ^%ZTLOAD D HOME^%ZIS
- ;
- ; -- after queing, delete start and stop times and add task
- ; -- once started add start time
- ; -- once finished add stop time, delete task no.
- ;
- S IBZTSK=ZTSK
- I '$D(ZTQUEUED) D ^%ZISC S QUIT=1
- ;
- ;
- CLEAR ; -- Clean up variables if task is not queued
- K ^TMP("IBDF",$J),^TMP("IB",$J)
- ;
- I QUIT D
- .I $D(ZTSK),$D(ZTSK(1)) I "^1^2^"[ZTSK(1) K ZTSK
- .S IBZTSK=$S($D(ZTSK):ZTSK,1:"")
- ;
- S QUIT=0
- Q $G(IBZTSK)
- ;
- DQ ; -- Generic entry points to edit
- ; -- only called by jobs tasked by this routine
- S IBDFFLD=".02" D UPDT
- D ^IBDF1B1
- S IBDFFLD=".03" D UPDT
- S IBTASK="@" D TASK
- Q
- ;
- UPDT ; -- Update start and finish times
- N DIE,DA,DR
- D NOW^%DTC S IBDFX=$E(%,1,12),DA=IBDFIFN,DA(1)=IBDFNUM,DIE="^IBD(357.09,"_DA(1)_","_"""Q"""_",",DR=IBDFFLD_"///"_"^S X=IBDFX" D ^DIE Q
- ;
- ;
- TASK ; -- Update Task number and last date printed
- N DA,DR,DIE
- S DA=IBDFIFN,DA(1)=IBDFNUM,DIE="^IBD(357.09,"_DA(1)_","_"""Q"""_",",DR=".11///"_IBTASK_";.12///"_IBDT D ^DIE
- I $D(IB1FLAG) S IB1TASK=IBTASK
- Q
- ;
- ;
- EXIT K IBADDONS,IBCLN,IBDFDAY,IBDFIFN,IBDFINST,IBDFNAME,IBDFNODE,IBDFNOW,IBDFNUM,IBDFSEQ,IBDIV,IBDT,IBREPRNT,IBSRT,IBSTRTDV,IBDFDAY1,IBDFLAST,IBDFONE,IBDFQ,IBDFXX,IBZTSK,QUIT
- I $D(ZTQUEUED) S ZTREQ="@" Q
- D ^%ZISC
- Q
- ;
- ;
- SET ; -- Set up variables needed for priniting of forms
- S IBDFNODE=$G(^IBD(357.09,IBDFNUM,"Q",IBDFIFN,0))
- I $P(IBDFNODE,"^",4)=""!($P(IBDFNODE,"^",5)="")!($P(IBDFNODE,"^",6)="")!($P(IBDFNODE,"^",7)="")!($P(IBDFNODE,"^",8)="")!($P(IBDFNODE,"^",9)="")!($P(IBDFNODE,"^",10)="") D I QUIT Q
- .I '$D(IBDFQUE) W !!,"PRINT QUEUE ABORTED.... missing required parameters!!!!" D PAUSE^VALM1
- .S QUIT=1
- .Q
- I $P(IBDFNODE,"^",8)="N" D I QUIT Q
- .I '$D(IBDFQUE) W !!,"PRINT QUEUE ABORTED.....not an active print job... check Special Instructions" D PAUSE^VALM1
- .S QUIT=1
- .Q
- S IBSRT=$P(IBDFNODE,"^",4),SELECTBY="C",IBADDONS=$P(IBDFNODE,"^",5),IBREPRNT="",IBSTRTDV=""
- D ENTRY Q:QUIT D
- .N GROUPS,IEN
- .; -- GET PRINT MANAGER GROUPS
- .S GROUPS=""
- .S GROUPS($P(IBDFNODE,"^",6))="" D
- ..S GROUPS=0 F S GROUPS=$O(GROUPS(GROUPS)) Q:'GROUPS D
- ...S IEN=0 F S IEN=$O(^IBD(357.99,GROUPS,10,IEN)) Q:'IEN S IBCLN=+$G(^IBD(357.99,GROUPS,10,IEN,0)) S:IBCLN ^TMP("IBDF",$J,"C",IBCLN)=""
- ...S IEN=0 F S IEN=$O(^IBD(357.99,GROUPS,11,IEN)) Q:'IEN S IBDIV=+$G(^IBD(357.99,GROUPS,11,IEN,0)) S:IBDIV ^TMP("IBDF",$J,"D",IBDIV)=""
- Q
- ;
- ;
- ENTRY ; -- Calc date and do checks on special instructions
- K IBDFARY
- N IBDFNOW,IBDFINST,IBDFDATE,IBDFDAYS,IBDFCTR,IBDFQTIM
- ;S IBDFNOW=$P($$NOW^XLFDT(),"."),IBDFINST=$P(IBDFNODE,"^",8),IBDFQTIM=$S($P(IBDFNODE,"^",13)]"":$P(IBDFNODE,"^",13),1:$E($P($$NOW^XLFDT(),".",2),1,4))
- S IBDFNOW=$P($$NOW^XLFDT(),"."),IBDFINST=$P(IBDFNODE,"^",8),IBDFQTIM=$S($P(IBDFNODE,"^",13)]"":$P(IBDFNODE,"^",13),1:IBDFQT)
- D:'$D(IBDFSING) ZTDTH
- ;
- ; -- if ignoring weekends and/or holidays, check current date
- I IBDFINST["W" I $$WEEKEND(IBDFNOW) S QUIT=1 Q
- I IBDFINST["H" I $$HOLIDAY(IBDFNOW) S QUIT=1 Q
- I IBDFINST["I" I $$WEEKEND(IBDFNOW)!($$HOLIDAY(IBDFNOW)) S QUIT=1 Q
- ;
- ; -- find date to return - returned in IBDFARY(date) array
- ; -- loop adds 1 day and checks if day is restricted
- ; -- if not, it adds it as a printable day and compares it
- ; -- with the number of printable days ahead the user wants to prn
- S IBDFDATE=IBDFNOW,IBDFCTR=0,IBDFDAYS=+$P(IBDFNODE,"^",7)
- F Q:IBDFCTR=IBDFDAYS D
- .S IBDFDATE=$$FMADD^XLFDT(IBDFDATE,1)
- .I IBDFINST["W" Q:$$WEEKEND(IBDFDATE)
- .I IBDFINST["H" Q:$$HOLIDAY(IBDFDATE)
- .I IBDFINST["I" Q:$$WEEKEND(IBDFDATE)!($$HOLIDAY(IBDFDATE))
- .S IBDFCTR=IBDFCTR+1
- S IBDFARY(IBDFDATE)=""
- Q
- ;
- WEEKEND(DATE) ;
- ; -- DATE (defaulted to current date if not passed)
- ; -- output = 1 if date is a weekend
- I '$G(DATE) S DATE=$P($$NOW^XLFDT(),".")
- I 60[$$DOW^XLFDT(DATE,1) Q 1
- Q 0
- ;
- HOLIDAY(DATE) ;
- ; -- DATE (defaulted to current date if not passed)
- ; -- output = 1 if date is a holiday
- I '$G(DATE) S DATE=$P($$NOW^XLFDT(),".")
- N X,Y,DIC
- S DIC="^HOLIDAY(",DIC(0)="",X=+$P(DATE,".")
- D ^DIC I +Y>0 Q 1
- Q 0
- ZTDTH ; -- Set up the variable ZTDTH to pass the queue date time of the
- ; queued job.
- N IBDFJQ
- I IBDFQT=2400!(IBDFQT=0000) D G DTIME
- .I IBDFQTIM=2400 S IBDFQTIM="0000"
- .I IBDFQTIM=IBDFQT S IBDFJQ=IBDFQDT Q
- .S IBDFJQ=IBDFQD_"."_IBDFQTIM
- I IBDFQTIM>IBDFQT S IBDFJQ=IBDFQD_"."_IBDFQTIM
- I IBDFQTIM<IBDFQT S X1=IBDFQDT,X2=1 D C^%DTC S IBDFJQ=$P(X,".")_"."_IBDFQTIM
- I IBDFQTIM=IBDFQT S IBDFJQ=IBDFQDT
- DTIME I IBDFJQ]"" S ZTDTH=$$FMTH^XLFDT(IBDFJQ)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFQB 6215 printed Jan 18, 2025@03:54:21 Page 2
- IBDFQB ;ALB/MAF - MAIN QUEUE JOB FOR ENCOUNTER FORM PRINTING - FEB 2 1995
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
- +2 ;
- EN ;
- +1 ; -- Goes through the "SEQ" cross reference to print the
- +2 ; highest priority jobs first (lowest sequence number).
- +3 NEW IBDFQUE,IBDFQDT,IBDFQD,IBDFQT,IBDFTSTP
- +4 SET IBDFQUE=1
- SET IBDFTSTP=1
- +5 SET (IBDFNUM,IBDFNAME,IBDFIFN,IBDFSEQ,QUIT)=0
- +6 DO NOW^%DTC
- SET IBDFQDT=%
- SET IBDFQD=$PIECE(%,".")
- SET IBDFQT=$EXTRACT($PIECE(%,".",2),1,4)
- +7 ;
- +8 FOR
- SET IBDFSEQ=$ORDER(^IBD(357.09,"SEQ",IBDFSEQ))
- if IBDFSEQ']""
- QUIT
- FOR
- SET IBDFNUM=$ORDER(^IBD(357.09,"SEQ",IBDFSEQ,IBDFNUM))
- if IBDFNUM']""
- QUIT
- FOR
- SET IBDFIFN=$ORDER(^IBD(357.09,"SEQ",IBDFSEQ,IBDFNUM,IBDFIFN))
- if IBDFIFN']""
- QUIT
- NEW IBDFARY
- DO UP($$QUEUE(IBDFIFN))
- +9 ;
- +10 ; -- send forms pending pages to PCE automatically
- +11 DO BCKGRND^IBDFFRFT
- +12 ;
- +13 GOTO EXIT
- +14 ;
- +15 ;
- UP(IBTASK) ; -- store results of tasking
- +1 if '$GET(IBTASK)
- QUIT
- +2 DO TASK
- +3 QUIT
- +4 ;
- +5 ;
- QUEUE(IBDFIFN) ; -- Set up Queue variables
- +1 NEW ZTSK,ZTDTH,ZTRTN,ZTDESC,ZTSAVE,ZTION,X,Y
- +2 KILL ^TMP("IBDF",$JOB,"C"),^TMP("IBDF",$JOB,"D")
- +3 DO SET
- +4 if ('$DATA(^TMP("IBDF",$JOB)))!QUIT
- GOTO CLEAR
- +5 ;
- +6 ; -- check if already tasked and running?
- +7 ;I $P(IBDFNODE,"^",11)]"" S ZTSK=$P(IBDFNODE,"^",11) D STAT^%ZTLOAD I "^1^2^"[ZTSK(1) S QUIT=1 G CLEAR
- +8 ;I $P(IBDFNODE,"^",11)]"" S ZTSK=$P(IBDFNODE,"^",11) W !,ZTSK,! B
- +9 SET $PIECE(^IBD(357.09,IBDFNUM,"Q",IBDFIFN,0),"^",14)=$PIECE(IBDFNODE,"^",11)
- +10 ;
- +11 FOR IBDT=0:0
- SET IBDT=$ORDER(IBDFARY(IBDT))
- if 'IBDT
- QUIT
- Begin DoDot:1
- +12 SET ZTDTH=$SELECT('$DATA(ZTDTH):$HOROLOG,$DATA(ZTDTH)&(ZTDTH]""):ZTDTH,1:$HOROLOG)
- +13 SET ZTRTN="DQ^IBDFQB"
- SET ZTDESC="IBD - Encounter Forms for"_IBDFNAME
- SET ZTSAVE("^TMP(""IBDF"",$J,")=""
- SET ZTSAVE("IB*")=""
- SET ZTIO=$SELECT($PIECE(IBDFNODE,"^",9)]"":$PIECE(IBDFNODE,"^",9),1:"")
- DO ^%ZTLOAD
- DO HOME^%ZIS
- End DoDot:1
- +14 ;
- +15 ; -- after queing, delete start and stop times and add task
- +16 ; -- once started add start time
- +17 ; -- once finished add stop time, delete task no.
- +18 ;
- +19 SET IBZTSK=ZTSK
- +20 IF '$DATA(ZTQUEUED)
- DO ^%ZISC
- SET QUIT=1
- +21 ;
- +22 ;
- CLEAR ; -- Clean up variables if task is not queued
- +1 KILL ^TMP("IBDF",$JOB),^TMP("IB",$JOB)
- +2 ;
- +3 IF QUIT
- Begin DoDot:1
- +4 IF $DATA(ZTSK)
- IF $DATA(ZTSK(1))
- IF "^1^2^"[ZTSK(1)
- KILL ZTSK
- +5 SET IBZTSK=$SELECT($DATA(ZTSK):ZTSK,1:"")
- End DoDot:1
- +6 ;
- +7 SET QUIT=0
- +8 QUIT $GET(IBZTSK)
- +9 ;
- DQ ; -- Generic entry points to edit
- +1 ; -- only called by jobs tasked by this routine
- +2 SET IBDFFLD=".02"
- DO UPDT
- +3 DO ^IBDF1B1
- +4 SET IBDFFLD=".03"
- DO UPDT
- +5 SET IBTASK="@"
- DO TASK
- +6 QUIT
- +7 ;
- UPDT ; -- Update start and finish times
- +1 NEW DIE,DA,DR
- +2 DO NOW^%DTC
- SET IBDFX=$EXTRACT(%,1,12)
- SET DA=IBDFIFN
- SET DA(1)=IBDFNUM
- SET DIE="^IBD(357.09,"_DA(1)_","_"""Q"""_","
- SET DR=IBDFFLD_"///"_"^S X=IBDFX"
- DO ^DIE
- QUIT
- +3 ;
- +4 ;
- TASK ; -- Update Task number and last date printed
- +1 NEW DA,DR,DIE
- +2 SET DA=IBDFIFN
- SET DA(1)=IBDFNUM
- SET DIE="^IBD(357.09,"_DA(1)_","_"""Q"""_","
- SET DR=".11///"_IBTASK_";.12///"_IBDT
- DO ^DIE
- +3 IF $DATA(IB1FLAG)
- SET IB1TASK=IBTASK
- +4 QUIT
- +5 ;
- +6 ;
- EXIT KILL IBADDONS,IBCLN,IBDFDAY,IBDFIFN,IBDFINST,IBDFNAME,IBDFNODE,IBDFNOW,IBDFNUM,IBDFSEQ,IBDIV,IBDT,IBREPRNT,IBSRT,IBSTRTDV,IBDFDAY1,IBDFLAST,IBDFONE,IBDFQ,IBDFXX,IBZTSK,QUIT
- +1 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +2 DO ^%ZISC
- +3 QUIT
- +4 ;
- +5 ;
- SET ; -- Set up variables needed for priniting of forms
- +1 SET IBDFNODE=$GET(^IBD(357.09,IBDFNUM,"Q",IBDFIFN,0))
- +2 IF $PIECE(IBDFNODE,"^",4)=""!($PIECE(IBDFNODE,"^",5)="")!($PIECE(IBDFNODE,"^",6)="")!($PIECE(IBDFNODE,"^",7)="")!($PIECE(IBDFNODE,"^",8)="")!($PIECE(IBDFNODE,"^",9)="")!($PIECE(IBDFNODE,"^",10)="")
- Begin DoDot:1
- +3 IF '$DATA(IBDFQUE)
- WRITE !!,"PRINT QUEUE ABORTED.... missing required parameters!!!!"
- DO PAUSE^VALM1
- +4 SET QUIT=1
- +5 QUIT
- End DoDot:1
- IF QUIT
- QUIT
- +6 IF $PIECE(IBDFNODE,"^",8)="N"
- Begin DoDot:1
- +7 IF '$DATA(IBDFQUE)
- WRITE !!,"PRINT QUEUE ABORTED.....not an active print job... check Special Instructions"
- DO PAUSE^VALM1
- +8 SET QUIT=1
- +9 QUIT
- End DoDot:1
- IF QUIT
- QUIT
- +10 SET IBSRT=$PIECE(IBDFNODE,"^",4)
- SET SELECTBY="C"
- SET IBADDONS=$PIECE(IBDFNODE,"^",5)
- SET IBREPRNT=""
- SET IBSTRTDV=""
- +11 DO ENTRY
- if QUIT
- QUIT
- Begin DoDot:1
- +12 NEW GROUPS,IEN
- +13 ; -- GET PRINT MANAGER GROUPS
- +14 SET GROUPS=""
- +15 SET GROUPS($PIECE(IBDFNODE,"^",6))=""
- Begin DoDot:2
- +16 SET GROUPS=0
- FOR
- SET GROUPS=$ORDER(GROUPS(GROUPS))
- if 'GROUPS
- QUIT
- Begin DoDot:3
- +17 SET IEN=0
- FOR
- SET IEN=$ORDER(^IBD(357.99,GROUPS,10,IEN))
- if 'IEN
- QUIT
- SET IBCLN=+$GET(^IBD(357.99,GROUPS,10,IEN,0))
- if IBCLN
- SET ^TMP("IBDF",$JOB,"C",IBCLN)=""
- +18 SET IEN=0
- FOR
- SET IEN=$ORDER(^IBD(357.99,GROUPS,11,IEN))
- if 'IEN
- QUIT
- SET IBDIV=+$GET(^IBD(357.99,GROUPS,11,IEN,0))
- if IBDIV
- SET ^TMP("IBDF",$JOB,"D",IBDIV)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +19 QUIT
- +20 ;
- +21 ;
- ENTRY ; -- Calc date and do checks on special instructions
- +1 KILL IBDFARY
- +2 NEW IBDFNOW,IBDFINST,IBDFDATE,IBDFDAYS,IBDFCTR,IBDFQTIM
- +3 ;S IBDFNOW=$P($$NOW^XLFDT(),"."),IBDFINST=$P(IBDFNODE,"^",8),IBDFQTIM=$S($P(IBDFNODE,"^",13)]"":$P(IBDFNODE,"^",13),1:$E($P($$NOW^XLFDT(),".",2),1,4))
- +4 SET IBDFNOW=$PIECE($$NOW^XLFDT(),".")
- SET IBDFINST=$PIECE(IBDFNODE,"^",8)
- SET IBDFQTIM=$SELECT($PIECE(IBDFNODE,"^",13)]"":$PIECE(IBDFNODE,"^",13),1:IBDFQT)
- +5 if '$DATA(IBDFSING)
- DO ZTDTH
- +6 ;
- +7 ; -- if ignoring weekends and/or holidays, check current date
- +8 IF IBDFINST["W"
- IF $$WEEKEND(IBDFNOW)
- SET QUIT=1
- QUIT
- +9 IF IBDFINST["H"
- IF $$HOLIDAY(IBDFNOW)
- SET QUIT=1
- QUIT
- +10 IF IBDFINST["I"
- IF $$WEEKEND(IBDFNOW)!($$HOLIDAY(IBDFNOW))
- SET QUIT=1
- QUIT
- +11 ;
- +12 ; -- find date to return - returned in IBDFARY(date) array
- +13 ; -- loop adds 1 day and checks if day is restricted
- +14 ; -- if not, it adds it as a printable day and compares it
- +15 ; -- with the number of printable days ahead the user wants to prn
- +16 SET IBDFDATE=IBDFNOW
- SET IBDFCTR=0
- SET IBDFDAYS=+$PIECE(IBDFNODE,"^",7)
- +17 FOR
- if IBDFCTR=IBDFDAYS
- QUIT
- Begin DoDot:1
- +18 SET IBDFDATE=$$FMADD^XLFDT(IBDFDATE,1)
- +19 IF IBDFINST["W"
- if $$WEEKEND(IBDFDATE)
- QUIT
- +20 IF IBDFINST["H"
- if $$HOLIDAY(IBDFDATE)
- QUIT
- +21 IF IBDFINST["I"
- if $$WEEKEND(IBDFDATE)!($$HOLIDAY(IBDFDATE))
- QUIT
- +22 SET IBDFCTR=IBDFCTR+1
- End DoDot:1
- +23 SET IBDFARY(IBDFDATE)=""
- +24 QUIT
- +25 ;
- WEEKEND(DATE) ;
- +1 ; -- DATE (defaulted to current date if not passed)
- +2 ; -- output = 1 if date is a weekend
- +3 IF '$GET(DATE)
- SET DATE=$PIECE($$NOW^XLFDT(),".")
- +4 IF 60[$$DOW^XLFDT(DATE,1)
- QUIT 1
- +5 QUIT 0
- +6 ;
- HOLIDAY(DATE) ;
- +1 ; -- DATE (defaulted to current date if not passed)
- +2 ; -- output = 1 if date is a holiday
- +3 IF '$GET(DATE)
- SET DATE=$PIECE($$NOW^XLFDT(),".")
- +4 NEW X,Y,DIC
- +5 SET DIC="^HOLIDAY("
- SET DIC(0)=""
- SET X=+$PIECE(DATE,".")
- +6 DO ^DIC
- IF +Y>0
- QUIT 1
- +7 QUIT 0
- ZTDTH ; -- Set up the variable ZTDTH to pass the queue date time of the
- +1 ; queued job.
- +2 NEW IBDFJQ
- +3 IF IBDFQT=2400!(IBDFQT=0000)
- Begin DoDot:1
- +4 IF IBDFQTIM=2400
- SET IBDFQTIM="0000"
- +5 IF IBDFQTIM=IBDFQT
- SET IBDFJQ=IBDFQDT
- QUIT
- +6 SET IBDFJQ=IBDFQD_"."_IBDFQTIM
- End DoDot:1
- GOTO DTIME
- +7 IF IBDFQTIM>IBDFQT
- SET IBDFJQ=IBDFQD_"."_IBDFQTIM
- +8 IF IBDFQTIM<IBDFQT
- SET X1=IBDFQDT
- SET X2=1
- DO C^%DTC
- SET IBDFJQ=$PIECE(X,".")_"."_IBDFQTIM
- +9 IF IBDFQTIM=IBDFQT
- SET IBDFJQ=IBDFQDT
- DTIME IF IBDFJQ]""
- SET ZTDTH=$$FMTH^XLFDT(IBDFJQ)
- +1 QUIT