source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF1B.m@ 619

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

initial load of WorldVistAEHR

File size: 5.7 KB
Line 
1IBDF1B ;ALB/CJM - ENCOUNTER FORM (printing forms for appointments); 3/1/93
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**29**;APR 24, 1997
3 ;
4 ;IBSRT=1 for sort by clinic/patient name
5 ;IBSRT=2 for sort by terminal digits
6 ;IBSRT=3 for sort by clinic/terminal digits
7 ;
8 ;SELECTBY="P" if user wants to select appts by patient
9 ;SELECTBY="C" if user wants to select appts by division/clinic
10 ;
11 ;IBDT=date for appointments
12 ;IBREPRNT'="" if this is a reprint of a previous job - then it's either equal to clinic name or 1st 4 terminal digits
13 ;IBSTRTDV is the division to start from in the case of a reprint
14 ;IBADDONS=1 if user wants to do add-ons only, 0 otherwise
15 ;
16EN ;
17 N IBREPRNT,SELECTBY,IBDT,IBSRT,IBADDONS,IBSTRTDV,QUIT,X
18 S (IBSTRTDV,IBREPRNT)="",(QUIT,IBADDONS)=0
19 ;
20 ;set the error trap so workspace in ^TMP is erased in case of abnormal termination of the print job
21 S X="ERRORTRP^IBDF1B",@^%ZOSF("TRAP")
22 ;
23 K ^TMP("IBDF",$J),^TMP("IB",$J)
24 D HOME^%ZIS
25 D
26 .D SELECTBY Q:QUIT S:SELECTBY="P" IBSRT=1 ;if selecting by patient then sort by clinic/patient rather than by terminal digits
27 .D:SELECTBY="C" SORTBY^IBDF1BA Q:QUIT
28 .D APPTDATE Q:QUIT
29 .;now allow user to makes selections, whether by patient or clinic
30 .D @SELECTBY
31 .;
32 .;if nothing selected exit
33 .Q:'$D(^TMP("IBDF",$J))
34 .;
35 .;since selecting by entire clinics, may want to do add-ons only or restart the job
36 .I SELECTBY="C" D Q:QUIT
37 ..D ADDONS Q:QUIT
38 ..D REPRINT Q:QUIT
39 ;
40 ;
41 ;if nothing selected exit
42END G:('$D(^TMP("IBDF",$J)))!QUIT EXIT
43 W !,$C(7),"** Encounter Forms require a page size of 80 lines and 132 columns. **"
44 K %IS,%ZIS,IOP S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT
45 I $D(IO("Q")) S ZTRTN="^IBDF1B1",ZTDESC="IBDF Encounter Forms",ZTSAVE("^TMP(""IBDF"",$J,")="",ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q") W !,$S($D(ZTSK):"Request Queued Task="_ZTSK,1:"Request Canceled") D HOME^%ZIS G EXIT
46 U IO
47 D ^IBDF1B1
48EXIT ;
49 K ^TMP("IBDF",$J),^TMP("IB",$J),^TMP("RPT",$J),^TMP("DFN",$J)
50 I $D(ZTQUEUED) S ZTREQ="@" Q
51 K DTOUT,DUOUT,DIRUT,DIROUT,X,Y,D0,DA,IBTYPE
52 D ^%ZISC
53 Q
54 ;
55REPRINT ;for prior job that partially completed?
56 ;IBSTRTDV is the division to restart from
57 ;IBREPRNT is the clinic or first 4 of terminal digits to restart from
58 S DIR(0)="Y",DIR("A")="IS THIS A REPRINT OF A PREVIOUS RUN"
59 S DIR("B")="NO",DIR("?")="ANSWER YES IF SOME OF THE FORMS WERE ALREADY PRINTED BY A PREVIOUS JOB THAT DID NOT SUCCESSFULLY COMPLETE"
60 D ^DIR K DIR I $D(DIRUT)!(Y=-1) S QUIT=1 Q
61 I Y D I IBREPRNT="" S QUIT=1 Q
62 .I IBSRT=2 D ;sorting by division/terminal digit
63 ..;ask which division to restart from
64 ..S IBSTRTDV=$$STARTDIV^IBDF1BA I IBSTRTDV="" S IBREPRNT="" Q
65 ..;ask which terminal digit to restart from
66 ..D TERMSTRT^IBDF1BA Q:IBREPRNT=""
67 .I (IBSRT=1)!(IBSRT=3) D CLNCSTRT^IBDF1BA ;sorting by division/clinic, ask which clinic to restart from
68 Q
69ADDONS ;add-ons only?
70 S DIR(0)="Y",DIR("A")="WANT TO PRINT ADD-ONS ONLY"
71 S DIR("B")="NO",DIR("?")="ANSWER YES TO ONLY PRINT ADD-ONS"
72 D ^DIR K DIR I $D(DIRUT)!(Y=-1) S QUIT=1 Q
73 S IBADDONS=Y
74 Q
75SELECTBY ;select by patient or clinic?
76 W !,"Do you want to print forms for a particular patient or for entire clinics?",!
77 K DIR S DIR("B")="Clinic",DIR(0)="SO^P:Patient;C:Clinic",DIR("A")="Select Appointment by"
78 D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
79 S SELECTBY=Y
80 Q
81 ;
82P ;print by patient - get patient then appointment(s) for date
83 N IBTMP,IBNM,DFN
84 ;IBNM=patient name, IBTMP=array to store patient's appts
85 F K DIC S DIC="^DPT(",DIC(0)="AEQM" D ^DIC K DIC Q:Y<0 S DFN=+Y,IBNM=$P(Y,"^",2) D SEARCH^IBDF1BA,DISP^IBDF1BA
86 Q
87 ;
88C ;print all appointments for a clinic - find division then clinic, print all/some clinics for all/some divisions
89 ;
90 N GROUPS,IEN
91 ;
92 ;get the PRINT MANAGER CLINIC GROUPS
93 S GROUPS=""
94 K DIR
95 S DIR(0)="PAO^357.99:AEMQ",DIR("A")="Select Print Manager Clinic Group:",DIR("?")="You can choose from previously defined clinic groups."
96 F D ^DIR Q:((+Y<0)!$D(DIRUT)) S GROUPS(+Y)="",DIR("A")="Select another Print Manager Clinic Group:"
97 S GROUPS=0 F S GROUPS=$O(GROUPS(GROUPS)) Q:'GROUPS D
98 .S IEN=0 F S IEN=$O(^IBD(357.99,GROUPS,10,IEN)) Q:'IEN S IBCLN=+$G(^IBD(357.99,GROUPS,10,IEN,0)) S:IBCLN ^TMP("IBDF",$J,"C",IBCLN)=""
99 .S IEN=0 F S IEN=$O(^IBD(357.99,GROUPS,11,IEN)) Q:'IEN S IBDIV=+$G(^IBD(357.99,GROUPS,11,IEN,0)) S:IBDIV ^TMP("IBDF",$J,"D",IBDIV)=""
100 K DIR
101 G:$O(GROUPS(0)) ENDC
102 ;
103 ;now ask divisions and clinics
104 W !!,"Now you can select individual divisions and clinics."
105 ;D ASK2^IBODIV G:$D(VAUTD)<11&(VAUTD=0) ENDC
106 S VAUTD=1 I $P($G(^DG(43,1,"GL")),"^",2) D DIVISION^VAUTOMA I Y=-1 G ENDC
107 S DIC("S")="I $P(^SC(+Y,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)"
108 W !!,"If you want to print forms for all clinics in the divisions you have",!,"chosen (for those clinics with forms defined) then select ALL."
109 W !!,"Otherwise, select the particular clinics you want.",!
110 S DIC="^SC(",VAUTVB="VAUTC",VAUTNI=2,VAUTSTR="clinic" D FIRST^VAUTOMA K DIC G:$D(VAUTC)<11&(VAUTC=0) ENDC
111 I VAUTC,VAUTD S ^TMP("IBDF",$J,"D","ALL")=""
112 I VAUTC,'VAUTD S IBDIV="" F S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" S ^TMP("IBDF",$J,"D",IBDIV)=""
113 I 'VAUTC S IBCLN="" F S IBCLN=$O(VAUTC(IBCLN)) Q:IBCLN="" S ^TMP("IBDF",$J,"C",IBCLN)=""
114ENDC K VAUTNI,VAUTD,VAUTC,VAUTVB,VAUTSTR,IBDIV,IBCLN,DIC
115 Q
116 ;
117APPTDATE ;print forms for appointments on what date?
118 K DIR S DIR(0)="D^::AEX",DIR("B")="TODAY",DIR("A")="Appointment Date to Print Forms For"
119 S DIR("?",1)="Only Clinics and Patients with Appointments on this Date will be allowed."
120 S DIR("?")="Nothing will print for Appointments in Clinics/Divisions with no forms defined."
121 D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
122 S IBDT=Y
123 Q
124 ;
125ERRORTRP ;the error trap
126 K ^TMP("IBDF",$J),^TMP("IB",$J)
127 D @^%ZOSF("ERRTN")
128 Q
Note: See TracBrowser for help on using the repository browser.