IBDFFT3 ;ALB/MAF - ROUTINE TO QUEUE FORMS TRACKING REPORT - 13 NOV 96
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
S IBDFDAT=$P($$HTE^XLFDT($H),":",1,2)
N IBDCNT,IBDCNT1,IBDFTIME,IBFLAG,IBDFPAGE
S (IBDCNT,IBDNKA,IBDFPAGE,IBDCNT1,VALMCNT)=0
D @(IBDFL)^IBDFFT1
N IBDFDV,IBDFCL,IBDNODE,IBDFTMP,IBDFPAT,IBDFPT,IBDFT
S (IBDFDV,IBDFCL,IBDFPT)=0
I $D(VAUTG) D
.N IBDFGR
.S IBDFGR=0
.F IBDFDIV=0:0 S IBDFDV=$O(^TMP("FTRK",$J,IBDFDV)) Q:IBDFDV']"" D:'$D(IBDFDIV(IBDFDV)) HEADER^IBDFFT4 F IBDFGRO=0:0 S IBDFGR=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR)) Q:IBDFGR']"" D
..F IBDFCLI=0:0 S IBDFCL=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL)) Q:IBDFCL']"" D:'$D(IBDFCLIN(IBDFGR,IBDFCL)) HEADER1^IBDFFT4 D
...F IBDFT=0:0 S IBDFT=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL,IBDFT)) Q:'IBDFT F IBDFPAT=0:0 S IBDFPT=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT)) Q:IBDFPT']"" D
....F IBDFIFN=0:0 S IBDFIFN=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT,IBDFIFN)) Q:'IBDFIFN S IBDX="" F S IBDX=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT,IBDFIFN,IBDX)) Q:IBDX="" S IBDFTMP=^(IBDX) D PRINT
I '$D(VAUTG) D
.F IBDFDIV=0:0 S IBDFDV=$O(^TMP("FTRK",$J,IBDFDV)) Q:IBDFDV']"" D:'$D(IBDFDIV(IBDFDV)) HEADER^IBDFFT4 F IBDFCLI=0:0 S IBDFCL=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL)) Q:IBDFCL']"" D:'$D(IBDFCLIN(IBDFDV,IBDFCL)) HEADER1^IBDFFT4 D
..F IBDFT=0:0 S IBDFT=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL,IBDFT)) Q:'IBDFT F IBDFPAT=0:0 S IBDFPT=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL,IBDFT,IBDFPT)) Q:IBDFPT']"" D
...F IBDFIFN=0:0 S IBDFIFN=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL,IBDFT,IBDFPT,IBDFIFN)) Q:'IBDFIFN S IBDX="" F S IBDX=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL,IBDFT,IBDFPT,IBDFIFN,IBDX)) Q:IBDX="" S IBDFTMP=^(IBDX) D PRINT
I '$D(^TMP("FRM",$J)) D NUL^IBDFFT4 Q
;Do statistics page right after printing list D EN^IBDFST1
D EN^IBDFST1
Q
PRINT ; -- Set up Listman array
S DFN=$P(IBDFTMP,"^",3)
I '$D(^TMP("CNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFCL)) D
.S ^TMP("CNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFCL)="0^0^0^0^0^0"
.I $D(VAUTG) I '$D(^TMP("COUNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFGR,IBDFCL)) D
..S ^TMP("COUNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFGR,IBDFCL)=1
I $D(VAUTG) K IBDFLAG I $D(^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN)) I IBDFGR=^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN) D COUNT
I $D(VAUTG) I '$D(^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN)) D COUNT
I '$D(VAUTG) S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)=$P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)+1
S IBDCNT1=IBDCNT1+1
S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
W !
W $J(IBDCNT1_")",5)
W ?7,$E($P($G(IBDFTMP),"^",2),1,8)
S IBDFVAL=$P($G(IBDFTMP),"^",4) I IBDFVAL S DNKA=$$DNKA^IBDFFT1(DFN,IBDFVAL),IBDFVAL=$$FMTE^XLFDT(IBDFVAL,2)
W ?17,$E(IBDFVAL,1,14)
I $D(VAUTC)!($D(VAUTG)) S (IBDFVAL,IBDFN)=$P($G(IBDFTMP),"^",3) I IBDFVAL]"" S IBDFVAL=$P(^DPT(IBDFVAL,0),"^",1)
I $D(VAUTN) S (IBDFVAL,IBDFN)=$P($G(IBDFTMP),"^",1) I IBDFVAL]"" S IBDFVAL=$P(^SC(IBDFVAL,0),"^",1)
W ?34,$E(IBDFVAL,1,15)
S IBDFVAL=$P($G(IBDFTMP),"^",6)
I IBDFVAL]"" S IBDFVAL=$E(IBDFVAL,4,5)_"/"_$E(IBDFVAL,6,7)_"/"_$E(IBDFVAL,2,3) I '$D(VAUTG)!($D(VAUTG)&($D(IBDFLAG))) S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",2)=+($P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",2))+1
W ?50,$E(IBDFVAL,1,8)
S VAL=$P($G(IBDFTMP),"^",12)
S IBDFVAL=$P($G(IBDFTMP),"^",7)
I IBDFVAL]"" S IBDFVAL=$E(IBDFVAL,4,5)_"/"_$E(IBDFVAL,6,7)_"/"_$E(IBDFVAL,2,3) I '$D(VAUTG)!($D(VAUTG)&($D(IBDFLAG))) I VAL=2 S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",3)=+($P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",3))+1
W ?61,$E(IBDFVAL,1,8)
N IBDFXX
S IBDFXX=$S(VAL=3:3,VAL=6:5,1:"")
I IBDFXX]"" I '$D(VAUTG)!($D(VAUTG)&($D(IBDFLAG))) S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",IBDFXX)=$P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",IBDFXX)+1 S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",6)=$P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",6)+1
S VAL=$S(DNKA:$P(DNKA,"^",2),VAL=1:"PRINTED",VAL=2:"SCANNED",VAL=3:"SCD/PCE",VAL=4:"SCD w/ER",VAL=5:"DENTRY",VAL=6:"DE to PCE",VAL=7:"DE w/ER",VAL=11:"PEND Pgs",VAL=12:"NO TRANS",20:"AVAIL DE",1:"NOT PRNT")
I DNKA S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",7)=+($P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",7))+1
W ?72,$E(VAL,1,8)
S IBDFVAL=$S(DNKA:"",1:$$SCHSTAT^IBDFFT($P(IBDFTMP,"^",3),$P(IBDFTMP,"^",4)))
W ?82,$E(IBDFVAL,1,12)
S IBDFVAL=$S($P(IBDFTMP,"^",14):" Yes",1:" No")
W ?96,$E(IBDFVAL,1,6)
;
;
TMP ; -- Set up TMP Array
S ^TMP("FRM",$J,IBDCNT,0)=$$LOWER^VALM1(X),^TMP("FRM",$J,"IDX",VALMCNT,IBDCNT1)=""
S ^TMP("FRMIDX",$J,IBDCNT1)=VALMCNT_"^"_$P(IBDFTMP,"^",2)_"^"_$P(IBDFTMP,"^",3)_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",6)_"^"_$P(IBDFTMP,"^",7)_"^"_$P(IBDFTMP,"^",12)
D NOW^%DTC S IBDFTIME=% S X1=$S($P(IBDFTMP,"^",7):$P(IBDFTMP,"^",7),1:IBDFTIME),X2=$P(IBDFTMP,"^",4) D ^%DTC S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",4)=+($P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",4))+X
Q
COUNT ;
S ^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN)=IBDFGR,IBDFLAG=1
S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)=$P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)+1
Q
IBDFFT3 ;ALB/MAF - ROUTINE TO QUEUE FORMS TRACKING REPORT - 13 NOV 96
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 SET IBDFDAT=$PIECE($$HTE^XLFDT($HOROLOG),":",1,2)
+3 NEW IBDCNT,IBDCNT1,IBDFTIME,IBFLAG,IBDFPAGE
+4 SET (IBDCNT,IBDNKA,IBDFPAGE,IBDCNT1,VALMCNT)=0
+5 DO @(IBDFL)^IBDFFT1
+6 NEW IBDFDV,IBDFCL,IBDNODE,IBDFTMP,IBDFPAT,IBDFPT,IBDFT
+7 SET (IBDFDV,IBDFCL,IBDFPT)=0
+8 IF $DATA(VAUTG)
Begin DoDot:1
+9 NEW IBDFGR
+10 SET IBDFGR=0
+11 FOR IBDFDIV=0:0
SET IBDFDV=$ORDER(^TMP("FTRK",$JOB,IBDFDV))
IF IBDFDV']""
QUIT
IF '$DATA(IBDFDIV(IBDFDV))
DO HEADER^IBDFFT4
FOR IBDFGRO=0:0
SET IBDFGR=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR))
IF IBDFGR']""
QUIT
Begin DoDot:2
+12 FOR IBDFCLI=0:0
SET IBDFCL=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL))
IF IBDFCL']""
QUIT
IF '$DATA(IBDFCLIN(IBDFGR,IBDFCL))
DO HEADER1^IBDFFT4
Begin DoDot:3
+13 FOR IBDFT=0:0
SET IBDFT=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL,IBDFT))
IF 'IBDFT
QUIT
FOR IBDFPAT=0:0
SET IBDFPT=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT))
IF IBDFPT']""
QUIT
Begin DoDot:4
+14 FOR IBDFIFN=0:0
SET IBDFIFN=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT,IBDFIFN))
IF 'IBDFIFN
QUIT
SET IBDX=""
FOR
SET IBDX=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT,IBDFIFN,IBDX))
IF IBDX=""
QUIT
SET IBDFTMP=^(IBDX)
DO PRINT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF '$DATA(VAUTG)
Begin DoDot:1
+16 FOR IBDFDIV=0:0
SET IBDFDV=$ORDER(^TMP("FTRK",$JOB,IBDFDV))
IF IBDFDV']""
QUIT
IF '$DATA(IBDFDIV(IBDFDV))
DO HEADER^IBDFFT4
FOR IBDFCLI=0:0
SET IBDFCL=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL))
IF IBDFCL']""
QUIT
IF '$DATA(IBDFCLIN(IBDFDV,IBDFCL))
DO HEADER1^IBDFFT4
Begin DoDot:2
+17 FOR IBDFT=0:0
SET IBDFT=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL,IBDFT))
IF 'IBDFT
QUIT
FOR IBDFPAT=0:0
SET IBDFPT=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL,IBDFT,IBDFPT))
IF IBDFPT']""
QUIT
Begin DoDot:3
+18 FOR IBDFIFN=0:0
SET IBDFIFN=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL,IBDFT,IBDFPT,IBDFIFN))
IF 'IBDFIFN
QUIT
SET IBDX=""
FOR
SET IBDX=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL,IBDFT,IBDFPT,IBDFIFN,IBDX))
IF IBDX=""
QUIT
SET IBDFTMP=^(IBDX)
DO PRINT
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF '$DATA(^TMP("FRM",$JOB))
DO NUL^IBDFFT4
QUIT
+20 ;Do statistics page right after printing list D EN^IBDFST1
+21 DO EN^IBDFST1
+22 QUIT
PRINT ; -- Set up Listman array
+1 SET DFN=$PIECE(IBDFTMP,"^",3)
+2 IF '$DATA(^TMP("CNT",$JOB,$SELECT(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFCL))
Begin DoDot:1
+3 SET ^TMP("CNT",$JOB,$SELECT(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFCL)="0^0^0^0^0^0"
+4 IF $DATA(VAUTG)
IF '$DATA(^TMP("COUNT",$JOB,$SELECT(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFGR,IBDFCL))
Begin DoDot:2
+5 SET ^TMP("COUNT",$JOB,$SELECT(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFGR,IBDFCL)=1
End DoDot:2
End DoDot:1
+6 IF $DATA(VAUTG)
KILL IBDFLAG
IF $DATA(^TMP("COUNT",$JOB,IBDFCL,IBDFT,IBDFIFN))
IF IBDFGR=^TMP("COUNT",$JOB,IBDFCL,IBDFT,IBDFIFN)
DO COUNT
+7 IF $DATA(VAUTG)
IF '$DATA(^TMP("COUNT",$JOB,IBDFCL,IBDFT,IBDFIFN))
DO COUNT
+8 IF '$DATA(VAUTG)
SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",1)=$PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",1)+1
+9 SET IBDCNT1=IBDCNT1+1
+10 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+11 WRITE !
+12 WRITE $JUSTIFY(IBDCNT1_")",5)
+13 WRITE ?7,$EXTRACT($PIECE($GET(IBDFTMP),"^",2),1,8)
+14 SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",4)
IF IBDFVAL
SET DNKA=$$DNKA^IBDFFT1(DFN,IBDFVAL)
SET IBDFVAL=$$FMTE^XLFDT(IBDFVAL,2)
+15 WRITE ?17,$EXTRACT(IBDFVAL,1,14)
+16 IF $DATA(VAUTC)!($DATA(VAUTG))
SET (IBDFVAL,IBDFN)=$PIECE($GET(IBDFTMP),"^",3)
IF IBDFVAL]""
SET IBDFVAL=$PIECE(^DPT(IBDFVAL,0),"^",1)
+17 IF $DATA(VAUTN)
SET (IBDFVAL,IBDFN)=$PIECE($GET(IBDFTMP),"^",1)
IF IBDFVAL]""
SET IBDFVAL=$PIECE(^SC(IBDFVAL,0),"^",1)
+18 WRITE ?34,$EXTRACT(IBDFVAL,1,15)
+19 SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",6)
+20 IF IBDFVAL]""
SET IBDFVAL=$EXTRACT(IBDFVAL,4,5)_"/"_$EXTRACT(IBDFVAL,6,7)_"/"_$EXTRACT(IBDFVAL,2,3)
IF '$DATA(VAUTG)!($DATA(VAUTG)&($DATA(IBDFLAG)))
SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",2)=+($PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",2))+1
+21 WRITE ?50,$EXTRACT(IBDFVAL,1,8)
+22 SET VAL=$PIECE($GET(IBDFTMP),"^",12)
+23 SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",7)
+24 IF IBDFVAL]""
SET IBDFVAL=$EXTRACT(IBDFVAL,4,5)_"/"_$EXTRACT(IBDFVAL,6,7)_"/"_$EXTRACT(IBDFVAL,2,3)
IF '$DATA(VAUTG)!($DATA(VAUTG)&($DATA(IBDFLAG)))
IF VAL=2
SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",3)=+($PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",3))+1
+25 WRITE ?61,$EXTRACT(IBDFVAL,1,8)
+26 NEW IBDFXX
+27 SET IBDFXX=$SELECT(VAL=3:3,VAL=6:5,1:"")
+28 IF IBDFXX]""
IF '$DATA(VAUTG)!($DATA(VAUTG)&($DATA(IBDFLAG)))
SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",IBDFXX)=$PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",IBDFXX)+1
SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",6)=$PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",6)+1
+29 SET VAL=$SELECT(DNKA:$PIECE(DNKA,"^",2),VAL=1:"PRINTED",VAL=2:"SCANNED",VAL=3:"SCD/PCE",VAL=4:"SCD w/ER",VAL=5:"DENTRY",VAL=6:"DE to PCE",VAL=7:"DE w/ER",VAL=11:"PEND Pgs",VAL=12:"NO TRANS",20:"AVAIL DE",1:"NOT PRNT")
+30 IF DNKA
SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",7)=+($PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",7))+1
+31 WRITE ?72,$EXTRACT(VAL,1,8)
+32 SET IBDFVAL=$SELECT(DNKA:"",1:$$SCHSTAT^IBDFFT($PIECE(IBDFTMP,"^",3),$PIECE(IBDFTMP,"^",4)))
+33 WRITE ?82,$EXTRACT(IBDFVAL,1,12)
+34 SET IBDFVAL=$SELECT($PIECE(IBDFTMP,"^",14):" Yes",1:" No")
+35 WRITE ?96,$EXTRACT(IBDFVAL,1,6)
+36 ;
+37 ;
TMP ; -- Set up TMP Array
+1 SET ^TMP("FRM",$JOB,IBDCNT,0)=$$LOWER^VALM1(X)
SET ^TMP("FRM",$JOB,"IDX",VALMCNT,IBDCNT1)=""
+2 SET ^TMP("FRMIDX",$JOB,IBDCNT1)=VALMCNT_"^"_$PIECE(IBDFTMP,"^",2)_"^"_$PIECE(IBDFTMP,"^",3)_"^"_$PIECE(IBDFTMP,"^",4)_"^"_$PIECE(IBDFTMP,"^",6)_"^"_$PIECE(IBDFTMP,"^",7)_"^"_$PIECE(IBDFTMP,"^",12)
+3 DO NOW^%DTC
SET IBDFTIME=%
SET X1=$SELECT($PIECE(IBDFTMP,"^",7):$PIECE(IBDFTMP,"^",7),1:IBDFTIME)
SET X2=$PIECE(IBDFTMP,"^",4)
DO ^%DTC
SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",4)=+($PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",4))+X
+4 QUIT
COUNT ;
+1 SET ^TMP("COUNT",$JOB,IBDFCL,IBDFT,IBDFIFN)=IBDFGR
SET IBDFLAG=1
+2 SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",1)=$PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",1)+1
+3 QUIT
