source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFFT3.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1IBDFFT3 ;ALB/MAF - ROUTINE TO QUEUE FORMS TRACKING REPORT - 13 NOV 96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**16**;APR 24, 1997
3 S IBDFDAT=$P($$HTE^XLFDT($H),":",1,2)
4 N IBDCNT,IBDCNT1,IBDFTIME,IBFLAG,IBDFPAGE
5 S (IBDCNT,IBDNKA,IBDFPAGE,IBDCNT1,VALMCNT)=0
6 S IBDFL=IBDFL_"^IBDFFT1" D @(IBDFL)
7 N IBDFDV,IBDFCL,IBDNODE,IBDFTMP,IBDFPAT,IBDFPT,IBDFT
8 S (IBDFDV,IBDFCL,IBDFPT)=0
9 I $D(VAUTG) D
10 .N IBDFGR
11 .S IBDFGR=0
12 .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
13 ..F IBDFCLI=0:0 S IBDFCL=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL)) Q:IBDFCL']"" D:'$D(IBDFCLIN(IBDFGR,IBDFCL)) HEADER1^IBDFFT4 D
14 ...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
15 ....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
16 I '$D(VAUTG) D
17 .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
18 ..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
19 ...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
20 I '$D(^TMP("FRM",$J)) D NUL^IBDFFT4 Q
21 ;Do statistics page right after printing list D EN^IBDFST1
22 D EN^IBDFST1
23 Q
24PRINT ; -- Set up Listman array
25 S DFN=$P(IBDFTMP,"^",3)
26 I '$D(^TMP("CNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFCL)) D
27 .S ^TMP("CNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFCL)="0^0^0^0^0^0"
28 .I $D(VAUTG) I '$D(^TMP("COUNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFGR,IBDFCL)) D
29 ..S ^TMP("COUNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFGR,IBDFCL)=1
30 I $D(VAUTG) K IBDFLAG I $D(^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN)) I IBDFGR=^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN) D COUNT
31 I $D(VAUTG) I '$D(^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN)) D COUNT
32 I '$D(VAUTG) S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)=$P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)+1
33 S IBDCNT1=IBDCNT1+1
34 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
35 W !
36 W $J(IBDCNT1_")",5)
37 W ?7,$E($P($G(IBDFTMP),"^",2),1,8)
38 S IBDFVAL=$P($G(IBDFTMP),"^",4) I IBDFVAL S DNKA=$$DNKA^IBDFFT1(DFN,IBDFVAL),IBDFVAL=$$FMTE^XLFDT(IBDFVAL,2)
39 W ?17,$E(IBDFVAL,1,14)
40 I $D(VAUTC)!($D(VAUTG)) S (IBDFVAL,IBDFN)=$P($G(IBDFTMP),"^",3) I IBDFVAL]"" S IBDFVAL=$P(^DPT(IBDFVAL,0),"^",1)
41 I $D(VAUTN) S (IBDFVAL,IBDFN)=$P($G(IBDFTMP),"^",1) I IBDFVAL]"" S IBDFVAL=$P(^SC(IBDFVAL,0),"^",1)
42 W ?34,$E(IBDFVAL,1,15)
43 S IBDFVAL=$P($G(IBDFTMP),"^",6)
44 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
45 W ?50,$E(IBDFVAL,1,8)
46 S VAL=$P($G(IBDFTMP),"^",12)
47 S IBDFVAL=$P($G(IBDFTMP),"^",7)
48 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
49 W ?61,$E(IBDFVAL,1,8)
50 N IBDFXX
51 S IBDFXX=$S(VAL=3:3,VAL=6:5,1:"")
52 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
53 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:"ER/NOTRN",20:"AVAIL DE",1:"NOT PRNT")
54 I DNKA S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",7)=+($P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",7))+1
55 W ?72,$E(VAL,1,8)
56 S IBDFVAL=$S(DNKA:"",1:$$SCHSTAT^IBDFFT($P(IBDFTMP,"^",3),$P(IBDFTMP,"^",4)))
57 W ?82,$E(IBDFVAL,1,12)
58 S IBDFVAL=$S($P(IBDFTMP,"^",14):" Yes",1:" No")
59 W ?96,$E(IBDFVAL,1,6)
60 ;
61 ;
62TMP ; -- Set up TMP Array
63 S ^TMP("FRM",$J,IBDCNT,0)=$$LOWER^VALM1(X),^TMP("FRM",$J,"IDX",VALMCNT,IBDCNT1)=""
64 S ^TMP("FRMIDX",$J,IBDCNT1)=VALMCNT_"^"_$P(IBDFTMP,"^",2)_"^"_$P(IBDFTMP,"^",3)_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",6)_"^"_$P(IBDFTMP,"^",7)_"^"_$P(IBDFTMP,"^",12)
65 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
66 Q
67COUNT ;
68 S ^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN)=IBDFGR,IBDFLAG=1
69 S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)=$P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)+1
70 Q
Note: See TracBrowser for help on using the repository browser.