source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF1B1.m@ 1806

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1IBDF1B1 ;ALB/CJM - ENCOUNTER FORM PRINT (IBDF1B continued - print encounter forms for selected appts); 3/1/93
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**3**;APR 24, 1997
3 ;
4 N IBDEVICE,IBQUIT
5 ;
6 K DA,D0,X,Y,I
7 ;
8 ;set the error trap so workspace in ^TMP is erased in case of abnormal termination of the print job
9 S X="ERRORTRP^IBDF1B",@^%ZOSF("TRAP")
10 ;
11 S IBQUIT=0
12 D DEVICE^IBDFUA(0,.IBDEVICE)
13 D:$D(^TMP("IBDF",$J,"D")) ENDV^IBDF1B1B D:$D(^TMP("IBDF",$J,"C")) ENCL^IBDF1B1A
14 K ^TMP("EARL",$J),^TMP("MULT",$J)
15 D ENPT
16 D KPRNTVAR^IBDFUA
17 K ^TMP("IBDF",$J),^TMP("IB",$J),^TMP("EARL",$J),^TMP("MULT",$J),DA,D0,X,Y,I,IBI
18 I $D(ZTQUEUED) S ZTREQ="@"
19 Q
20ENPT ;print encounter forms for each appt
21 ;input ^TMP( - contains appointment data:
22 ;if IBSRT=1 format is ^TMP("IBDF",$J,"P",division name,clinic name,clinic ien,patient name,dfn,appt)=""
23 ;if IBSRT=2 format is^TMP("IBDF",$J,"P",division name,terminal digits,dfn,appt)=clinic ien
24 ;if IBSRT=3 format is ^TMP("IBDF",$J,"P",division name,clinic name,clinic ien,terminal digits,dfn,appt)=""
25 N DFN,CLNCNAME,IBCLINIC,PNAME,TDIGIT,IBAPPT,IBDIV
26 ;IBCLINIC=ien of clinic
27 ;IBSTRTDV is the division to start from in the case of a reprint
28 ;IBREPRNT is the clinic or terminal digits (1st 4) to start from in case of a reprint
29 ;
30 S IBDIV="" F S IBDIV=$O(^TMP("IBDF",$J,"P",IBDIV)) Q:IBQUIT!(IBDIV="") D:(IBDIV=" ")!(IBSTRTDV']IBDIV)
31 .I IBSRT=2,IBDIV]" " W !,"DIVISION: ",IBDIV,@IOF
32 .D:IBSRT=1 SORT1
33 .D:IBSRT=2 SORT2
34 .D:IBSRT=3 SORT3
35 D:'IBQUIT TRLR
36 Q
37 ;
38SORT1 ;case of sort by div/clinic/patient
39 S CLNCNAME=""
40 ;check if report was restarted, start is after this clinic
41 I IBREPRNT]"" I ((IBDIV=" ")!(IBDIV=IBSTRTDV)) S CLNCNAME=$E(IBREPRNT,1,$L(IBREPRNT)-1)
42 F S CLNCNAME=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME)) Q:CLNCNAME=""!IBQUIT S IBCLINIC="" F S IBCLINIC=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC)) Q:'IBCLINIC!IBQUIT D
43 .D HDRPG($P($G(^SC(IBCLINIC,0)),"^"),IBDIV)
44 .S PNAME="" F S PNAME=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,PNAME)) Q:PNAME=""!IBQUIT S DFN="" F S DFN=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,PNAME,DFN)) Q:'DFN!IBQUIT D
45 ..S IBAPPT="" F S IBAPPT=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,PNAME,DFN,IBAPPT)) Q:'(+IBAPPT)!IBQUIT D APPT($G(IBDIV),$G(CLNCNAME),$G(IBCLINIC),$G(PNAME),$G(DFN),$G(IBAPPT))
46 Q
47SORT2 ;case of sort by div/terminal digit
48 S TDIGIT=""
49 ;check if report was restarted, start is after this terminal digit
50 I IBREPRNT]"" I ((IBDIV=" ")!(IBDIV=IBSTRTDV)) S TDIGIT=IBREPRNT
51 F S TDIGIT=$O(^TMP("IBDF",$J,"P",IBDIV,TDIGIT)) Q:TDIGIT=""!IBQUIT D
52 .S DFN="" F S DFN=$O(^TMP("IBDF",$J,"P",IBDIV,TDIGIT,DFN)) Q:'DFN!IBQUIT D
53 ..S IBAPPT="" F S IBAPPT=$O(^TMP("IBDF",$J,"P",IBDIV,TDIGIT,DFN,IBAPPT)) Q:'+IBAPPT!IBQUIT D
54 ...S IBCLINIC=$G(^TMP("IBDF",$J,"P",IBDIV,TDIGIT,DFN,IBAPPT)) Q:'IBCLINIC!IBQUIT D APPT($G(IBDIV),$G(CLNCNAME),$G(IBCLINIC),$G(PNAME),$G(DFN),$G(IBAPPT),$G(TDIGIT))
55 Q
56SORT3 ;case of sort by div/clinic/terminal digits
57 S CLNCNAME=""
58 ;check if report was restarted, start is after this CLINIC
59 I IBREPRNT]"" I ((IBDIV=" ")!(IBDIV=IBSTRTDV)) S CLNCNAME=$E(IBREPRNT,1,$L(IBREPRNT)-1)
60 F S CLNCNAME=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME)) Q:CLNCNAME=""!IBQUIT S IBCLINIC="" F S IBCLINIC=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC)) Q:'IBCLINIC!IBQUIT D
61 .D HDRPG($P($G(^SC(IBCLINIC,0)),"^"),IBDIV)
62 .S TDIGIT="" F S TDIGIT=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,TDIGIT)) Q:TDIGIT=""!IBQUIT S DFN="" F S DFN=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,TDIGIT,DFN)) Q:'DFN!IBQUIT D
63 ..S IBAPPT="" F S IBAPPT=$O(^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,TDIGIT,DFN,IBAPPT)) Q:'(+IBAPPT)!IBQUIT D APPT($G(IBDIV),$G(CLNCNAME),$G(IBCLINIC),$G(PNAME),$G(DFN),$G(IBAPPT),$G(TDIGIT))
64 Q
65 ;
66APPT(IBDIV,CLNCNAME,IBCLINIC,PNAME,DFN,IBAPPT,TDIGIT) ;print everything for single appt
67 ;input - DFN,IBAPPT,IBCLINIC
68 I $$S^%ZTLOAD S (ZTSTOP,IBQUIT)=1 W !,"TASK STOPPED AT USER'S REQUEST" Q
69 D PRNTFRMS^IBDF1B2
70 D PRNTOTHR^IBDF1B5(IBCLINIC,IBAPPT,DFN)
71 I $D(^DPT(DFN,"S",IBAPPT,0)) S $P(^DPT(DFN,"S",IBAPPT,0),"^",21)=1 S:IBADDONS $P(^DPT(DFN,"S",IBAPPT,0),"^",22)=1
72 Q
73 ;
74HDRPG(CLINIC,IBDIV) ;print a header page for clinic
75 N LN
76 S LN="BEGINNING TO PRINT ENCOUNTER FORMS FOR "_CLINIC_$S(IBDIV'=" ":" IN "_IBDIV,1:"")_" on "_$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
77 I $Y W @IOF
78 W !!!!!,?((IOM-$L(LN))\2),LN
79 W @IOF
80 W !!
81 Q
82TRLR ;prints a trailer page
83 N LN
84 S LN="PRINTING OF ENCOUNTER FORMS IS COMPLETE"_" for "_$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
85 W !!!!!,?((IOM-$L(LN))\2),LN
86 W @IOF
87 Q
88EARLIEST(DFN,APPT) ;determines if APPT is the earliest appt on the list for DFN
89 D GETLIST^IBDF1B1A(DFN,IBDT,DIVISION)
90 I APPT=$O(^TMP("IBDF",$J,"APPT LIST",DFN,""))
91 Q $T
Note: See TracBrowser for help on using the repository browser.