source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFFT1.m@ 635

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1IBDFFT1 ;ALB/MAF - FORMS TRACKING CONTINUED - JUL 6 1995
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**16**;APR 24, 1997
3 ;
4START ;
5 N IBDCNT,IBDCNT1,IBDFTIME
6 S (IBDCNT,IBDNKA,IBDCNT1,VALMCNT)=0
7 D KILL^VALM10()
8 D @(IBDFL)
9 N IBDFDV,IBDFCL,IBDNODE,IBDFTMP,IBDFPAT,IBDFPT,IBDFT
10 S (IBDFDV,IBDFCL,IBDFPT)=0
11 ;
12 I $D(VAUTG) D
13 .N IBDFGR
14 .S IBDFGR=0
15 .F IBDFDIV=0:0 S IBDFDV=$O(^TMP("FTRK",$J,IBDFDV)) Q:IBDFDV']"" D:'$D(IBDFDIV(IBDFDV)) HEADER^IBDFFT2 F IBDFGRO=0:0 S IBDFGR=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR)) Q:IBDFGR']"" D
16 ..F IBDFCLI=0:0 S IBDFCL=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL)) Q:IBDFCL']"" D:'$D(IBDFGROP(IBDFDV,IBDFGR)) HEADER2^IBDFFT2 D:'$D(IBDFCLIN(IBDFGR,IBDFCL)) HEADER1^IBDFFT2 D
17 ...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
18 ....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 SETARR
19 I '$D(VAUTG) D
20 .F IBDFDIV=0:0 S IBDFDV=$O(^TMP("FTRK",$J,IBDFDV)) Q:IBDFDV']"" D:'$D(IBDFDIV(IBDFDV)) HEADER^IBDFFT2 F IBDFCLI=0:0 S IBDFCL=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL)) Q:IBDFCL']"" D:'$D(IBDFCLIN(IBDFDV,IBDFCL)) HEADER1^IBDFFT2 D
21 ..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
22 ...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 SETARR
23 I '$D(^TMP("FRM",$J)) D NUL^IBDFFT2
24 Q
25CLN ; -- Loop clinics
26 N IBDFCLIN
27 I VAUTC=1 F IBDFCLIN=0:0 S IBDFCLIN=$O(^SC(IBDFCLIN)) Q:'IBDFCLIN D CK(IBDFCLIN) I QUIT=1 D BLD
28 I VAUTC=0 F IBDFCLIN=0:0 S IBDFCLIN=$O(VAUTC(IBDFCLIN)) Q:'IBDFCLIN D CK(IBDFCLIN) I QUIT=1 D BLD
29 D TRACKING Q
30PAT ; -- Loop patients
31 N IBDFCLIN,IBDFPAT
32 I VAUTN=1 F IBDFPAT=0:0 S IBDFPAT=$O(^DPT(IBDFPAT)) Q:'IBDFPAT F IBDFT=IBDFBEG:0 S IBDFT=$O(^DPT(IBDFPAT,"S",IBDFT)) Q:'IBDFT!($P(IBDFT,".",1)>IBDFEND) I $D(^DPT(IBDFPAT,"S",IBDFT,0)) D SET
33 I VAUTN=0 F IBDFPAT=0:0 S IBDFPAT=$O(VAUTN(IBDFPAT)) Q:'IBDFPAT F IBDFT=IBDFBEG:0 S IBDFT=$O(^DPT(IBDFPAT,"S",IBDFT)) Q:'IBDFT!($P(IBDFT,".",1)>IBDFEND) I $D(^DPT(IBDFPAT,"S",IBDFT,0)) D SET
34 D TRACKING Q
35GRP D GRP1^IBDFFT
36 N IBDFGRP,IBDFCLIN
37 F IBDFGRP=0:0 S IBDFGRP=$O(VAUTG(IBDFGRP)) Q:'IBDFGRP F IBDFCLIN=0:0 S IBDFCLIN=$O(VAUTG(IBDFGRP,IBDFCLIN)) Q:'IBDFCLIN D CK(IBDFCLIN) I QUIT=1 D BLD
38 D TRACKING Q
39 ;
40 ;
41SET S IBDFCLIN=$P(^DPT(IBDFPAT,"S",IBDFT,0),"^",1) D CK(IBDFCLIN) I QUIT=1 S DFN=IBDFPAT D CK1 Q
42 Q
43 ;
44 ;
45CK(XCL) ; -- Check clinic, division, form
46 Q:'$D(^SC(+XCL,0))
47 S QUIT=0
48 S IBDFNODE=$G(^SC(XCL,0))
49 Q:$P(IBDFNODE,"^",3)'="C"
50 I $G(VAUTD)=0 I $P(IBDFNODE,"^",15) Q:'$D(VAUTD($P(IBDFNODE,"^",15)))
51 D CHECK^IBDFFT(XCL)
52 Q:QUIT=0
53 Q
54 ;
55 ;
56BLD ; -- scan appts
57 F IBDFT=IBDFBEG:0 S IBDFT=$O(^SC(IBDFCLIN,"S",IBDFT)) Q:'IBDFT!($P(IBDFT,".",1)>IBDFEND) D
58 .F IBDFDA=0:0 S IBDFDA=$O(^SC(IBDFCLIN,"S",IBDFT,1,IBDFDA)) Q:'IBDFDA I $D(^SC(IBDFCLIN,"S",IBDFT,1,IBDFDA,0)) S IBDFSA=^(0) S DFN=+IBDFSA D CK1
59 Q
60CK1 ; --
61 N IBDFXPC,IBDFYPC
62 S IBDFXPC=$S($D(VAUTC)!($D(VAUTG)):$P(IBDFNODE,"^",1),1:$P(^DPT(IBDFPAT,0),"^",1))
63 S IBDFYPC=$S($D(VAUTC)!($D(VAUTG)):$P(^DPT(DFN,0),"^",1),1:$P(IBDFNODE,"^",1))
64 I $D(^IBD(357.96,"APTAP",DFN,IBDFT)) S IBDFIFN=0 F S IBDFIFN=$O(^IBD(357.96,"APTAP",DFN,IBDFT,IBDFIFN)) Q:'IBDFIFN I $D(^IBD(357.96,IBDFIFN,0)) D
65 .I $D(VAUTG) S ^TMP("FTRK",$J,$S($D(^DG(40.8,+$P(IBDFNODE,"^",15),0)):$P(^DG(40.8,$P(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),$P(^IBD(357.99,IBDFGRP,0),"^",1),IBDFXPC,IBDFT,IBDFYPC,DFN,+IBDFIFN)=IBDFCLIN_"^"_^IBD(357.96,IBDFIFN,0)
66 .I '$D(VAUTG) S ^TMP("FTRK",$J,$S($D(^DG(40.8,+$P(IBDFNODE,"^",15),0)):$P(^DG(40.8,$P(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),IBDFXPC,IBDFT,IBDFYPC,DFN,+IBDFIFN)=IBDFCLIN_"^"_^IBD(357.96,IBDFIFN,0)
67 .Q
68 E D
69 .I $D(VAUTG) S ^TMP("FTRK",$J,$S($D(^DG(40.8,+$P(IBDFNODE,"^",15),0)):$P(^DG(40.8,$P(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),$P(^IBD(357.99,IBDFGRP,0),"^",1),IBDFXPC,IBDFT,IBDFYPC,DFN,0)=IBDFCLIN_"^^"_DFN_"^"_IBDFT
70 .I '$D(VAUTG) S ^TMP("FTRK",$J,$S($D(^DG(40.8,+$P(IBDFNODE,"^",15),0)):$P(^DG(40.8,$P(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),IBDFXPC,IBDFT,IBDFYPC,DFN,0)=IBDFCLIN_"^^"_DFN_"^"_IBDFT
71 Q
72 ;
73SETARR ; -- Set up Listman array
74 S DFN=$P(IBDFTMP,"^",3)
75 I '$D(^TMP("CNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFCL)) D
76 .S ^TMP("CNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFCL)="0^0^0^0^0^0^0"
77 .I $D(VAUTG) I '$D(^TMP("COUNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFGR,IBDFCL)) D
78 ..S ^TMP("COUNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFGR,IBDFCL)=1
79 I $D(VAUTG) K IBDFLAG I $D(^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN)) I IBDFGR=^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN) D COUNT
80 I $D(VAUTG) I '$D(^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN)) D COUNT
81 I '$D(VAUTG) S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)=$P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)+1
82 S IBDCNT1=IBDCNT1+1
83 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
84 S X=""
85 S IBDFVAL=$J(IBDCNT1_")",5)
86 S X=$$SETSTR^VALM1(IBDFVAL,X,1,5)
87 S IBDFVAL=$P($G(IBDFTMP),"^",2)
88 S X=$$SETSTR^VALM1(IBDFVAL,X,7,8)
89 S IBDFVAL=$P($G(IBDFTMP),"^",4) I IBDFVAL S DNKA=$$DNKA(DFN,IBDFVAL),IBDFVAL=$P($$FMTE^XLFDT(IBDFVAL,2),":",1,2)
90 S X=$$SETSTR^VALM1(IBDFVAL,X,17,14)
91 I $D(VAUTC)!($D(VAUTG)) S (IBDFVAL,IBDFN)=$P($G(IBDFTMP),"^",3) I IBDFVAL]"" S IBDFVAL=$P(^DPT(IBDFVAL,0),"^",1)
92 I $D(VAUTN) S (IBDFVAL,IBDFN)=$P($G(IBDFTMP),"^",1) I IBDFVAL]"" S IBDFVAL=$P(^SC(IBDFVAL,0),"^",1)
93 S X=$$SETSTR^VALM1(IBDFVAL,X,34,15)
94 S IBDFVAL=$P($G(IBDFTMP),"^",6)
95 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
96 S X=$$SETSTR^VALM1(IBDFVAL,X,50,8)
97 S VAL=$P($G(IBDFTMP),"^",12)
98 S IBDFVAL=$P($G(IBDFTMP),"^",7)
99 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
100 S X=$$SETSTR^VALM1(IBDFVAL,X,61,8)
101 N IBDFXX
102 S IBDFXX=$S(VAL=3:3,VAL=6:5,1:"")
103 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
104 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")
105 I DNKA S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",7)=+($P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",7))+1
106 S X=$$SETSTR^VALM1(VAL,X,72,8)
107 S IBDFVAL=$S(DNKA:"",1:$$SCHSTAT^IBDFFT($P(IBDFTMP,"^",3),$P(IBDFTMP,"^",4)))
108 S X=$$SETSTR^VALM1(IBDFVAL,X,82,12)
109 S IBDFVAL=$S($P(IBDFTMP,"^",14):" Yes",1:" No")
110 S X=$$SETSTR^VALM1(IBDFVAL,X,96,6)
111 ;
112 ;
113TMP ; -- Set up TMP Array
114 S ^TMP("FRM",$J,IBDCNT,0)=$$LOWER^VALM1(X),^TMP("FRM",$J,"IDX",VALMCNT,IBDCNT1)=""
115 S ^TMP("FRMIDX",$J,IBDCNT1)=VALMCNT_"^"_$P(IBDFTMP,"^",2)_"^"_$P(IBDFTMP,"^",3)_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",6)_"^"_$P(IBDFTMP,"^",7)_"^"_$P(IBDFTMP,"^",12)
116 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
117 Q
118COUNT ;
119 S ^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN)=IBDFGR,IBDFLAG=1
120 S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)=$P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)+1
121 Q
122TRACKING ; -- loops thru forms tracking file 357.96
123 ; X-reference ^IBD(357.96,"ADATNA", Appt date/time, 1 or 0, IFN).
124 ; 1 = forms tracking file entry but no scheduled appt associated
125 ; 0 = forms tracking file entry with associated scheduled appt.
126 N IBDFCLIN,IBAPPTDT,IBDFPAT,IBDFTRK,IBDFX,IBDFT
127 S IBDFX=""
128 F IBDFT=IBDFBEG:0 S IBDFT=$O(^IBD(357.96,"ADATNA",IBDFT)) Q:'IBDFT!(IBDFT>IBDFEND) S IBDFTRK=0 F S IBDFTRK=$O(^IBD(357.96,"ADATNA",IBDFT,1,IBDFTRK)) Q:'IBDFTRK D
129 .Q:'$G(^IBD(357.96,IBDFTRK,0))
130 .S IBDFCLIN=$P(^IBD(357.96,IBDFTRK,0),"^",10)
131 .I IBDFCLIN']"" Q
132 .S IBDFPAT=$P(^IBD(357.96,IBDFTRK,0),"^",2)
133 .D CK(IBDFCLIN) I QUIT=1 D
134 ..I $D(VAUTC),VAUTC=0,'$D(VAUTC(IBDFCLIN)) Q
135 ..I $D(VAUTN),VAUTN=0,'$D(VAUTN(IBDFPAT)) Q
136 ..N IBDFXPC,IBDFYPC
137 ..S IBDFXPC=$S($D(VAUTC):$P(IBDFNODE,"^",1),$D(VAUTG):$P(IBDFNODE,"^",1),1:$P(^DPT(IBDFPAT,0),"^",1))
138 ..S IBDFYPC=$S($D(VAUTC)!($D(VAUTG)):$P(^DPT(IBDFPAT,0),"^",1),1:$P(IBDFNODE,"^",1))
139 ..I '$D(VAUTG) S ^TMP("FTRK",$J,$S($D(^DG(40.8,+$P(IBDFNODE,"^",15),0)):$P(^DG(40.8,$P(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),IBDFXPC,IBDFT,IBDFYPC,IBDFPAT,IBDFTRK)=IBDFCLIN_"^"_^IBD(357.96,IBDFTRK,0)
140 ..I $D(VAUTG) D
141 ...N IBDFGRP,IBDFCLNN,IBDFCLN,IBDFGR
142 ...S (IBDFCLN,IBDFGR)=0
143 ...F IBDFGR=0:0 S IBDFGR=$O(VAUTG(IBDFGR)) Q:IBDFGR']"" F IBDFCLN=0:0 S IBDFCLN=$O(VAUTG(IBDFGR,IBDFCLN)) Q:IBDFCLN']"" I IBDFCLN=IBDFCLIN D
144 ....N IBX,IBY
145 ....S IBX=$P($G(^IBD(357.99,IBDFGR,0)),"^"),IBY=$P($G(^SC(IBDFCLN,0)),"^")
146 ....S ^TMP("FTRK",$J,$S($D(^DG(40.8,+$P(IBDFNODE,"^",15),0)):$P(^DG(40.8,$P(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),IBX,IBY,IBDFT,IBDFYPC,IBDFPAT,IBDFTRK)=IBDFCLIN_"^"_^IBD(357.96,IBDFTRK,0)
147 Q
148 ;
149DNKA(DFN,APPT) ;
150 ; -- return did not keep appointment
151 N STATUS,DNKA
152 S DNKA=0
153 S STATUS=$P($G(^DPT(+$G(DFN),"S",+$G(APPT),0)),"^",2)
154 I STATUS]"" I "^N^C^NA^CA^PC^PCA^"[STATUS S DNKA=1_"^"_$S(STATUS["N":"NO SHOW",1:"CANCELED")
155 Q DNKA
Note: See TracBrowser for help on using the repository browser.