- 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
