source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFFT.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 6.3 KB
Line 
1IBDFFT ;ALB/MAF - FORMS TRACKING ; JUL 6 1995@800
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**16**;APR 24, 1997
3 ;
4 ;
5OUT S IBDF2=0
6 S DIR("B")="CLINIC",DIR(0)="SBM^C:CLINIC;P:PATIENT;G:GROUP (CLINIC)",DIR("A")="Sort by [C]linic, [P]atient, [G]roup (Clinic)" D ^DIR
7 K DIR I $D(DIRUT)&('$D(IBDF1))!(Y<0) G EXIT
8 I $D(DIRUT)&$D(IBDF1) G QUIT
9 S X=$S("Pp"[X:2,"Gg"[X:3,1:1)
10 S IBDFSR=$E(X)
11 I $D(^DG(43,1,"GL")) S IBDFMUL=$P(^DG(43,1,"GL"),"^",2)
12 S IBDFL=$S(IBDFSR=1:"CLN",IBDFSR=2:"PAT",IBDFSR=3:"GRP",1:"QUIT")
13 I $D(IBDFMUL),IBDFMUL D DIVISION^VAUTOMA G:Y=-1 QUIT
14 I 'IBDFMUL S IBDFDV=$O(^DG(40.8,0)) S VAUTD=0,VAUTD(+$O(^DG(40.8,0)))=$P($G(^DG(40.8,+$O(^DG(40.8,0)),0)),"^")
15 D @(IBDFL) G:Y=-1 QUIT ;I IBDFL="GRP" D GRP1
16 D DAT G:Y=-1 QUIT
17OKQ N IBQUEUE S %=1 W !!,"Do you want to queue this to a printer?" D YN^DICN I '% D YN G OKQ
18 I %=-1 G EXIT
19 I %=1 S IBQUEUE=1
20 I $D(IBQUEUE) G QUEUE
21 D WAIT^DICD
22 S IBDFDAT=$$HTE^XLFDT($H)
23 I '$D(IBDF1) D EN^VALM("IBDF FT REPORT")
24 I $D(IBDF1) D KILL,START^IBDFFT1 S VALMBCK="R",VALMBG=1
25 Q
26 ;
27 ;
28SAVE ; -- save variables for queue
29 S ZTSAVE("^TMP(""FTRK"",$J,")="",ZTSAVE("^TMP(""COUNT"",$J,")="",ZTSAVE("^TMP(""FRM"",$J,")="",ZTSAVE("^TMP(""CNT"",$J,")="",ZTSAVE("^TMP(""STATS"",$J,")="",ZTSAVE("VA*")="",ZTSAVE("VAUTG(")="",ZTSAVE("VAUTN(")="",ZTSAVE("VAUTC(")=""
30 Q
31QUEUE W !!,$C(7),"** Report requires 132 columns and a page length of 80 lines. **",!
32 N ZTSK,ZTDTH,ZTRTN,ZTDESC,ZTSAVE,ZTION,X,Y
33 K %IS,%ZIS,IOP S IOP="Q",%ZIS="QM0",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT
34 I $D(IO("Q")) S ZTRTN="^IBDFFT3",ZTDESC="Forms Tracking Report",ZTSAVE("^TMP(""FTRK"",$J,")="",ZTSAVE("IB*")="" D SAVE D ^%ZTLOAD K IO("Q") W !,$S($D(ZTSK):"Request Queued Task="_ZTSK,1:"Request Canceled") D HOME^%ZIS G EXIT
35 I '$D(ZTQUEUED) D ^%ZISC
36CLEAR ; -- Clean up variables if task is not queued
37 D ^IBDFFT3
38 G EXIT ;K ^TMP("IBDF",$J),^TMP("IB",$J)
39 Q
40HDR ; -- header code
41 S VALMHDR(1)="Encounter forms - printed; scanned (to PCE, w/ERrors); pending pages;"
42 S VALMHDR(2)="data entry (to PCE,w/ERrors); error detected,not transmitted; not printed."
43 Q
44 ;
45CLN S VAUTNI=2,DIC="^SC(",DIC("S")="I $P(^(0),U,3)=""C""&$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)",VAUTSTR="clinic",VAUTVB="VAUTC" D FIRST^VAUTOMA S:Y=-1 IBDF2=1 Q:IBDF2
46 Q
47 ;
48 ;
49PAT S VAUTNI=2 D PATIENT^VAUTOMA S:Y=-1 IBDF2=1 Q:IBDF2
50 Q
51 ;
52 ;
53GRP S VAUTNI=2,DIC="^IBD(357.99,",VAUTSTR="clinic group",VAUTVB="VAUTG" D FIRST^VAUTOMA S:Y=-1 IBDF2=1 Q:IBDF2
54 Q
55GRP1 N IBGROUP
56 I VAUTG=1 D
57 .S IBGROUP=0 F S IBGROUP=$O(^IBD(357.99,IBGROUP)) Q:'IBGROUP I $D(^IBD(357.99,IBGROUP,0)) S VAUTG(IBGROUP)=$P(^IBD(357.99,IBGROUP,0),"^",1)
58 .Q
59 S IBGROUP=0 F S IBGROUP=$O(VAUTG(IBGROUP)) Q:'IBGROUP D
60 .N IBCLI,IBDIV,IBCLNUM,IBDIVNUM
61 .S IBCLI=0 F S IBCLI=$O(^IBD(357.99,IBGROUP,10,IBCLI)) Q:'IBCLI I $D(^IBD(357.99,IBGROUP,10,IBCLI,0)) S IBCLNUM=+^IBD(357.99,IBGROUP,10,IBCLI,0) I $D(^SC(+IBCLNUM,0)) D
62 ..S VAUTG(IBGROUP,IBCLNUM)=$P(^SC(+IBCLNUM,0),"^",1)
63 ..Q
64 .S IBDIV=0 F S IBDIV=$O(^IBD(357.99,IBGROUP,11,IBDIV)) Q:'IBDIV I $D(^IBD(357.99,IBGROUP,11,IBDIV,0)) S IBDIVNUM=+^IBD(357.99,IBGROUP,11,IBDIV,0) I $D(^DG(40.8,IBDIVNUM,0)) D
65 ..S IBCLNUM=0 F S IBCLNUM=$O(^SC(IBCLNUM)) Q:'IBCLNUM I $D(^SC(IBCLNUM,0)) I +$P(^SC(IBCLNUM,0),"^",15)=IBDIVNUM S VAUTG(IBGROUP,IBCLNUM)=$P(^SC(IBCLNUM,0),"^",1)
66 ..Q
67 Q
68 ;
69 ;
70CHECK(CLIN) ; -- Check to see if clinic has a form and its one that is not for
71 ; future use only.
72 N IBDFNODE,IBDFCL,X
73 S QUIT=0
74 I $O(^SD(409.95,"B",+CLIN,0)) D
75 .S IBDFCL=$O(^SD(409.95,"B",+CLIN,0))
76 .S IBDFNODE=^SD(409.95,IBDFCL,0)
77 .S QUIT=0 F X=2:1:9 S:$P(IBDFNODE,"^",X)&("^1^2^3^4^5^6^8^9^"[X) QUIT=1 Q:QUIT
78 Q
79 ;
80 ;
81EXIT ; -- Code executed at action exit
82 K IBDFL,IBDFL1,IBDFBG,IBDFBG1,IBDFBEG,IBDFBEG1,IBDFEND,IBDFEND1,VAUTD,VAUTN,VAUTC,IBDFC1,IBDFN1,IBDFDV1,VAUTD1,VAUTC1,VAUTN1,IBDFN,DNKA,VAUTG,IBDFGRO,%DT,VAL,POP,IBDFG1,DIR,VAUTVB
83 K %,DIC,DIRUT,IBDF1,VALMBCK,VALMBG,VALMHDR,VAUTG1,VAUTNI,VAUTSTR,ZTQUEUED,X,X1,X2,D0,DA,DIK,%ZIS,IOP,CLIN,APPT
84 K IBDCNT,IBDCNT1,IBDFCL,IBDFDV,IBDFGR,VALMCNT,IBDFPAGE,IFN,VALMY
85EXIT1 ;
86 K DFN,IBDFCLI,IBDFDA,IBDFDAT,IBDFIFN,IBDFMUL,IBDFSA,IBDFSR,IBDFT,IBDVAL,IBDFVAL,IBDVAL1,QUIT,IBDF2,IBDNKA,IBDX
87 K ^TMP("CNT",$J),^TMP("FRM",$J),^TMP("FTRK",$J),^TMP("STATS",$J),^TMP("FRMIDX",$J),^TMP("STAIDX",$J),^TMP("COUNT",$J),IBDFDIV,IBDFCLIN,IBDFNODE,IBDFGROP
88 D ^%ZISC
89 Q
90 ;
91 ;
92DAT ; -- DATE RANGE
93BEG W ! S %DT="AEX",%DT("A")="BEGINNING DATE: " D ^%DT S IBDFBG=Y,IBDFBEG=Y-.0001 S:X="^"!(X="") Y=-1 Q:Y=-1
94END W ! S %DT("A")="ENDING DATE: " D ^%DT S:X="^"!(X="") Y=-1 Q:Y=-1 I Y<1 D HELP^%DTC G END
95 S IBDFEND=Y_.9999
96 I IBDFEND\1<IBDFBG W !!?5,"The ending date cannot be before the beginning date" G END
97 Q
98 ;
99 ;
100HELP ; -- help code
101 S X="?" D DISP^XQORM1 W !!
102 Q
103CHGLST ; -- Code to change list display
104 D FULL^VALM1
105 S IBDFL1=IBDFL,IBDFBG1=IBDFBG,IBDFBEG1=IBDFBEG,IBDFEND1=IBDFEND
106 S IBDFDV1=VAUTD S:$D(VAUTC) IBDFC1=VAUTC S:$D(VAUTN) IBDFN1=VAUTN
107 I $D(VAUTG) S IBDFG1=VAUTG
108 I VAUTD=0 F X=0:0 S X=$O(VAUTD(X)) Q:X']"" S VAUTD1(X)=VAUTD(X)
109 I $D(VAUTC),VAUTC=0 F X=0:0 S X=$O(VAUTC(X)) Q:X']"" S VAUTC1(X)=VAUTC(X)
110 I $D(VAUTN),VAUTN=0 F X=0:0 S X=$O(VAUTN(X)) Q:X']"" S VAUTN1(X)=VAUTN(X)
111 I $D(VAUTG) D
112 .N IBX
113 .S IBX=0
114 .F X=0:0 S X=$O(VAUTG(X)) Q:X']"" F Y=0:0 S Y=$O(VAUTG(X,Y)) Q:Y']"" S VAUTG1(X,Y)=VAUTG(X,Y)
115 D EXIT1,OUT
116 Q
117KILL ; -- Kill extra array variables
118 N IBDFXX
119 S IBDFXX=$S(IBDFL="CLN":"VAUTC",IBDFL="GRP":"VAUTG",1:"VAUTN")
120 I IBDFXX="VAUTN" K VAUTC,VAUTG
121 I IBDFXX="VAUTC" K VAUTN,VAUTG
122 I IBDFXX="VAUTG" K VAUTN,VAUTC
123 Q
124QUIT ; -- Kill variables and reset to last display if no change has taken place
125 I $D(IBDF1) S IBDFL=IBDFL1,IBDFBG=IBDFBG1,IBDFBEG=IBDFBEG1,IBDFEND=IBDFEND1,VAUTD=IBDFDV1 S:IBDFL="CLN" VAUTC=IBDFC1 S:IBDFL="PAT" VAUTN=IBDFN1 S:IBDFL="GRP" VAUTG=IBDFG1 D
126 .I VAUTD=0 F X=0:0 S X=$O(VAUTD1(X)) Q:X']"" S VAUTD(X)=VAUTD1(X)
127 .I $D(VAUTC),VAUTC=0 F X=0:0 S X=$O(VAUTC1(X)) Q:X']"" S VAUTC(X)=VAUTC1(X)
128 .I $D(VAUTN),VAUTN=0 F X=0:0 S X=$O(VAUTN1(X)) Q:X']"" S VAUTN(X)=VAUTN1(X)
129 .I $D(VAUTG) D
130 ..F X=0:0 S X=$O(VAUTG1(X)) Q:X']"" F Y=0:0 S Y=$O(VAUTG1(X,Y)) Q:Y']"" S VAUTG(X,Y)=VAUTG1(X,Y)
131 I '$D(IBDF1) G EXIT
132 D KILL,START^IBDFFT1 S VALMBCK="R",VALMBG=1
133 Q
134 ;
135SCHSTAT(DFN,APPT) ; -- return text of scheduling status
136 ;
137 N X
138 S X=$$REQ^IBDFDE0(DFN,APPT,+$G(^DPT(DFN,"S",APPT,0)),$$FNDSDOE^IBDFDE(DFN,APPT))
139 S X=$S(X=1:"CO Required",X=-1:"CO Complete",1:"CO Not Req.")
140 Q X
141YN W !?10,"Choose:",!?25,"Y for YES",!?25,"N for NO",! Q
Note: See TracBrowser for help on using the repository browser.