source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF14A.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: 4.0 KB
Line 
1IBDF14A ;ALB/CJM - AICS LIST CLINIC SETUP ; JUL 20,1993
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997
3 ;
4% ; -- entry point from ibdf14
5 I '$D(VAUTD) G ^IBDF14
6 D CLINICS,PRINT
7 Q
8 ;
9CLINICS ; -- get a list of clinics with setups defined
10 S CNT=0
11 S CLINIC="" F S CLINIC=$O(^SD(409.95,"B",CLINIC)) Q:'CLINIC D
12 .S SETUP=$O(^SD(409.95,"B",CLINIC,""))
13 .S NAME=$P($G(^SC(CLINIC,0)),"^")
14 .S DIVIS=$P($G(^SC(CLINIC,0)),"^",15)
15 .I DIVIS="" S DIVIS=$S(MULTI=0:$$PRIM^VASITE,MULTI=1:"Unknown",1:1)
16 .I 'VAUTD,'$D(VAUTD(DIVIS)) Q ;if not all divisions or select div.
17 .S:+DIVIS DIVIS=$P($G(^DG(40.8,+DIVIS,0)),"^")
18 .I DIVIS="" S DIVIS="Unknown"
19 .S:NAME]"" ^TMP($J,"IBCS",DIVIS,NAME)=CLINIC_"^"_SETUP,CNT(DIVIS)=$G(CNT(DIVIS))+1
20 Q
21 ;
22PRINT ; -- Main print driver for output
23 W:$E(IOST,1,2)="C-" @IOF
24 S NEWDIV=0
25 S DIVIS="" F S DIVIS=$O(^TMP($J,"IBCS",DIVIS)) Q:DIVIS=""!IBQUIT S NEWDIV=1 D
26 .S NAME="" F S NAME=$O(^TMP($J,"IBCS",DIVIS,NAME)) Q:NAME=""!IBQUIT S CLINIC=+^(NAME),SETUP=$P(^(NAME),"^",2) D Q:IBQUIT
27 ..Q:'SETUP
28 ..I $G(NEWDIV) D HEADER Q:IBQUIT W !?9,"Division: ",DIVIS,! S NEWDIV=0
29 ..I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
30 ..W !,"Clinic: ",NAME I '$$ACLN^IBDFCNOF(CLINIC) W " (Clinic Currently Inactive)"
31 ..D FORMS Q:IBQUIT
32 ..D REPORTS Q:IBQUIT
33 ..D EXCLUDE Q:IBQUIT
34 ..W !
35 .I 'VAUTD,$G(CNT(DIVIS))<1 D HEADER W !,"No clinics found for division '",DIVIS,"'",!
36 I $E(IOST,1,2)="C-",'IBQUIT D PAUSE
37 Q
38 ;
39FORMS ; -- prints the clinic's encounter forms to the report
40 S NODE=$G(^SD(409.95,SETUP,0))
41 I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
42 S FORM=$P(NODE,"^",2) I FORM W !,?5,"BASIC DEFAULT FORM: ..........................",$P($G(^IBE(357,FORM,0)),"^")
43 S FORM=$P(NODE,"^",5) I FORM W !,?5,"FORM WITH NO PRE-PRINTED PATIENT DATA: .......",$P($G(^IBE(357,FORM,0)),"^")
44 I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
45 S FORM=$P(NODE,"^",3) I FORM W !,?5,"SUPPLEMENTAL FORM - PATIENT WITH PRIOR VISITS: ",$P($G(^IBE(357,FORM,0)),"^")
46 I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
47 S FORM=$P(NODE,"^",4) I FORM W !,?5,"SUPPLEMENTAL FORM - FIRST TIME PATIENT: ......",$P($G(^IBE(357,FORM,0)),"^")
48 I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
49 S FORM=$P(NODE,"^",6) I FORM W !,?5,"SUPPLEMENTAL FORM - ALL PATIENTS: ............",$P($G(^IBE(357,FORM,0)),"^")
50 I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
51 S FORM=$P(NODE,"^",8) I FORM W !,?5,"SUPPLEMENTAL FORM - ALL PATIENTS: ............",$P($G(^IBE(357,FORM,0)),"^")
52 I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
53 S FORM=$P(NODE,"^",9) I FORM W !,?5,"SUPPLEMENTAL FORM - ALL PATIENTS: ............",$P($G(^IBE(357,FORM,0)),"^")
54 I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
55 S FORM=$P(NODE,"^",7) I FORM W !,?5,"RESERVED FOR FUTURE USE: .....................",$P($G(^IBE(357,FORM,0)),"^")
56 Q
57 ;
58REPORTS ; -- prints the clinic's reports
59 Q:'$O(^SD(409.95,SETUP,1,0))
60 I ($Y>(IOSL-5)) D HEADER Q:IBQUIT
61 W !!,?5,"REPORTS",?50,"PRINT CONDITION",!,?5,"=======",?50,"==============="
62 S REPORT=0 F S REPORT=$O(^SD(409.95,SETUP,1,REPORT)) Q:'REPORT D Q:IBQUIT
63 .I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
64 .S NODE=$G(^SD(409.95,SETUP,1,REPORT,0))
65 .S INTRFACE=$P(NODE,"^"),COND=$P(NODE,"^",2)
66 .I INTRFACE,COND S INTRFACE=$P($G(^IBE(357.6,INTRFACE,0)),"^"),COND=$P($G(^IBE(357.92,COND,0)),"^") W:INTRFACE]"" !,?5,INTRFACE,?50,COND
67 Q
68 ;
69EXCLUDE ; -- prints the division reports excluded from clinic
70 Q:'$O(^SD(409.95,SETUP,2,0))
71 I ($Y>(IOSL-5)) D HEADER Q:IBQUIT
72 W !!,?5,"EXCLUDED REPORTS",!,?5,"================"
73 S REPORT=0 F S REPORT=$O(^SD(409.95,SETUP,2,REPORT)) Q:'REPORT D Q:IBQUIT
74 .I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
75 .S NODE=$G(^SD(409.95,SETUP,2,REPORT,0))
76 .S INTRFACE=$P(NODE,"^")
77 .I INTRFACE S INTRFACE=$P($G(^IBE(357.6,INTRFACE,0)),"^") W:INTRFACE]"" !,?5,INTRFACE
78 Q
79 ;
80HEADER ; -- writes the report header
81 I $E(IOST,1,2)="C-",$Y>1,PAGE>1 D PAUSE Q:IBQUIT
82 I PAGE>1 W @IOF
83 W !,"AICS Print Manager Clinic Setup Report",?IOM-32,IBHDT," PAGE ",PAGE
84 W !,"For Division: ",DIVIS
85 W !,$TR($J(" ",IOM)," ","-")
86 S PAGE=PAGE+1
87 Q
88 ;
89PAUSE ; -- hold screen
90 N DIR,X,Y
91 F Q:$Y>(IOSL-2) W !
92 S DIR(0)="E" D ^DIR S IBQUIT=$S(+Y:0,1:1)
93 Q
Note: See TracBrowser for help on using the repository browser.