source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF1B1A.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: 5.0 KB
Line 
1IBDF1B1A ;ALB/CJM - ENCOUNTER FORM PRINT (IBDF1B continued - user options for printing- continuation of IBDF1B1); 3/1/93
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997
3 ;
4ENCL ;for every clinic choosen find patient appointments on DATE
5 N DFN,CLNCNAME,IBCLINIC,PNAME,TDIGIT,IBAPPT,IBAPTYP,IBX,Y,IBDIV,FIRST4
6 S IBCLINIC="" F S IBCLINIC=$O(^TMP("IBDF",$J,"C",IBCLINIC)) Q:'IBCLINIC D
7 .;
8 .;
9 .;get the clinic's division
10 .S IBDIV=$$DIVISION^IBDF1B5(IBCLINIC) S:IBDIV="" IBDIV="^ "
11 .
12 .;setup defined for clinic or division? - otherwise there is nothing to print
13 .Q:'($D(^SD(409.95,"B",IBCLINIC))!$D(^SD(409.96,"B",+IBDIV)))
14 .S IBDIV=$P(IBDIV,"^",2)
15 .;
16 .;if restart, sorting is by division/clinic, and clinic is in the starting division, make sure the clinic does not precede the starting clinic
17 .I IBDIV=IBSTRTDV,((IBSRT=1)!(IBSRT=3)) S CLNCNAME=$P($G(^SC(IBCLINIC,0)),"^") I CLNCNAME'=IBREPRNT,CLNCNAME']IBREPRNT Q
18 .;
19 .;find the appts
20 .S IBAPPT=IBDT F S IBAPPT=$O(^SC(IBCLINIC,"S",IBAPPT)) Q:$E(IBAPPT,1,7)'=IBDT D
21 ..S IBX=0 F S IBX=$O(^SC(IBCLINIC,"S",IBAPPT,1,IBX)) Q:IBX="" D
22 ...Q:$P($G(^SC(IBCLINIC,"S",IBAPPT,1,IBX,0)),"^",9)="C"
23 ...S DFN=+$G(^SC(IBCLINIC,"S",IBAPPT,1,IBX,0)) Q:$E($P($G(^DPT(DFN,0)),"^",9),1,5)="00000"&($D(IBDFTSTP)) S PNAME=$P($G(^DPT(DFN,0)),"^") Q:PNAME=""
24 ...;check the appt status - may be cancelled
25 ...S IBAPTYP=$G(^DPT(DFN,"S",IBAPPT,0)) Q:"NT,I,"'[($P(IBAPTYP,"^",2)_",")
26 ...; -- check parameter if inpatient and don't print inpatients then quit
27 ...I $P(IBAPTYP,"^",2)="I",$P($G(^IBD(357.09,1,0)),"^",5)=0 Q
28 ...;
29 ...;if only printing add-ons don't print if already printed
30 ...I IBADDONS,IBREPRNT="" Q:$$PRINTED(DFN,IBAPPT)
31 ...I IBADDONS,IBREPRNT'="" Q:'$$ADDON(DFN,IBAPPT)
32 ...;
33 ...;case of sort by clinic,patient
34 ...;
35 ...;**** when the new SAC standards go into effect, increasing the allowable global subscript length, this line should be substituted for the line following it ****
36 ...I IBSRT=1 S CLNCNAME=$P($G(^SC(IBCLINIC,0)),"^") Q:CLNCNAME="" S ^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,$E(PNAME,1,15),DFN,+IBAPPT)=""
37 ...; old way ;I IBSRT=1 S CLNCNAME=$P($G(^SC(IBCLINIC,0)),"^") Q:CLNCNAME="" S ^TMP("IBDF",$J,"P",$E(IBDIV,1,20),$E(CLNCNAME,1,10),IBCLINIC,$E(PNAME,1,10),DFN,+IBAPPT)=""
38 ...;
39 ...;case of sort by terminal digit
40 ...I IBSRT=2 D
41 ....S TDIGIT=$$TDG(DFN),FIRST4=$E(TDIGIT,1,$L(TDIGIT)-5)
42 ....;
43 ....;if this is a restart and clinic is in the starting division, make sure the terminal digits (1st 4) do not precede the restart position
44 ....I IBDIV=IBSTRTDV,FIRST4'=IBREPRNT,FIRST4<IBREPRNT Q
45 ....;
46 ....S ^TMP("IBDF",$J,"P",IBDIV,TDIGIT,DFN,+IBAPPT)=IBCLINIC
47 ...;
48 ...;case of sort by clinic/terminal digits
49 ...;
50 ...;**** when the new SAC standards go into effect, increasing the allowable global subscript length, this line should be substituted for the line following it ****
51 ...I IBSRT=3 S TDIGIT=$$TDG(DFN),CLNCNAME=$P($G(^SC(IBCLINIC,0)),"^") Q:CLNCNAME="" S ^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,TDIGIT,DFN,+IBAPPT)=""
52 ...; this is the old way ;I IBSRT=3 S TDIGIT=$$TDG(DFN),CLNCNAME=$P($G(^SC(IBCLINIC,0)),"^") Q:CLNCNAME="" S ^TMP("IBDF",$J,"P",$E(IBDIV,1,20),$E(CLNCNAME,1,10),IBCLINIC,TDIGIT,DFN,+IBAPPT)=""
53 ;
54 ;don't need the list of clinics anymore
55 K ^TMP("IBDF",$J,"C")
56 Q
57 ;
58TDG(DFN) ;reformat patient's SSN into terminal digit order, then turns it into a cannonic number
59 ; returns either 0 or ssn in terminal digit order
60 N X,Y,I,SSN
61 S SSN=$P($G(^DPT(DFN,0)),"^",9)
62 S Y="" F I=1:1 S X=$E(SSN,I) Q:X="" I X?1N S Y=Y_X
63 S Y=$S(Y'?9N:0,1:$E(Y,8,9)_$E(Y,6,7)_$E(Y,4,5)_$E(Y,1,3))
64 Q +Y
65 ;
66PRINTED(DFN,IBAPPT) ;returns 1 if the print manager already printed forms for this appt, 0 otherwise
67 Q +$P($G(^DPT(DFN,"S",IBAPPT,0)),"^",21)
68ADDON(DFN,IBAPPT) ;returns 1 if the print manager already printed forms for this appt as an add-on, 0 otherwise
69 Q +$P($G(^DPT(DFN,"S",IBAPPT,0)),"^",22)
70 ;
71GETLIST(DFN,IBDT,DIVISION) ;creates a list of the patient's appts on IBDT
72 Q:'DFN!'IBDT
73 N APPT,NODE,TO
74 S TO=IBDT+.999999
75 S ^TMP("IBDF",$J,"APPT LIST",DIVISION,DFN)=""
76 S APPT=IBDT-.0001 F S APPT=$O(^DPT(DFN,"S",APPT)) Q:'APPT!(APPT>TO) D
77 .S NODE=$G(^DPT(DFN,"S",APPT,0))
78 .Q:"NT,I,"'[($P(NODE,"^",2)_",")
79 .Q:$P($G(^SC(+NODE,0)),"^",15)'=DIVISION
80 .; -- check parameter
81 .;I $P(NODE,"^",2)="I",$P($G(^IBD(357.09,1,0)),"^",5)=0 Q
82 .S ^TMP("IBDF",$J,"APPT LIST",DIVISION,DFN,APPT)=+NODE
83 Q
84MULTIPLE(DFN,APPT) ;determines if patient=DFN has multiple appts on the list and APPT is the earliest
85 N APT
86 D GETLIST(DFN,APPT,DIVISION)
87 S APT=$O(^TMP("IBDF",$J,"APPT LIST",DIVISION,DFN,""))
88 ;Q:APT'=APPT 0
89 I $O(^TMP("IBDF",$J,"APPT LIST",DIVISION,DFN,APT))
90 Q $T
91 ;
92DIVHAS(IBDIV) ;returns >0 if the division has anything to print, 0 otherwise
93 Q:'$G(IBDIV) 0
94 Q $L($O(^SD(409.96,"A",IBDIV,"")))
95 ;
96CLNCHAS(CLINIC) ;returns>0 if the clinic has something to print
97 N NODE,SETUP,I,FOUND
98 S SETUP=$O(^SD(409.95,"B",CLINIC,0)) Q:'SETUP 0
99 S NODE=$G(^SD(409.95,SETUP,0))
100 S FOUND=0 F I=2,3,4,6,8,9 I $P(NODE,"^",I) S FOUND=1 Q
101 Q:FOUND 1
102 Q $L($O(^SD(409.95,"A",CLINIC,"")))
Note: See TracBrowser for help on using the repository browser.