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 Oct 16, 2024@18:53:56 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
