source: FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACGEN.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.2 KB
Line 
1QACGEN ;HISC/CEW,DAD - Issue Totals for All or by Gender ;5/30/95 15:32
2 ;;2.0;Patient Representative;**3,9,17**;07/25/1995
3DATE ;
4 N QACDVFLG
5 N X,Y
6 S QAQPOP=0
7 D DATE^QACUTL0 Q:QAQPOP
8 K DIR S DIR(0)="SMO^A:All;M:Male;F:Female"
9 S DIR("A")=" Selection"
10 S DIR("?")="Select A, M, or F"
11 S DIR("??")="Enter A for All Issues, M for all issues for Male patients, or F for all issues for Female patients."
12 ;Set QACGEN= to A, M, or F, and QACGENX= All, Male, or Female
13 D ^DIR K DIR G EXIT:$D(DIRUT)!($D(DIROUT)) S QACGEN=Y,QACGENX=Y(0)
14 S QACDVFLG=1
15 I $G(QACDVFLG)=1 D DIV^QACUTL0 Q:$G(QAQPOP)=1
16 K %ZIS,IOP S %ZIS="MQ" W ! D ^%ZIS G:POP EXIT
17 I $D(IO("Q")) D G EXIT
18 . S ZTDESC="Patient Rep Issue Totals"
19 . S ZTSAVE("Y")=""
20 . S (ZTSAVE("QACGEN"),ZTSAVE("QACGENX"),ZTSAVE("QACDVFLG"))=""
21 . S ZTSAVE("QACDVFLG")=""
22 . S ZTRTN="GENTSK^QACGEN"
23 . D TASK^QACUTL0
24 . Q
25GENTSK ; Gets the data to build the TMP global
26 K ^TMP("QACGEN",$J)
27 S ^TMP("QACGEN",$J)=0
28 U IO
29 N QACDT,QACD0,QACCN,QACPIEN,QACCIEN,QACCNM,QACHDNM,QACHDIEN
30 N QACHD,QACICODE,QACDIV,QACGENDR
31 ; Get each record in the date range
32 S QACDT=QAQNBEG-.0000001 F S QACDT=$O(^QA(745.1,"D",QACDT)) Q:(QACDT'>0)!(QACDT>QAQNEND)!(QACDT\1'?7N) D
33 . S QACD0=0 F S QACD0=$O(^QA(745.1,"D",QACDT,QACD0)) Q:QACD0'>0 D
34 .. ; For each record if there is a patient get the IEN and the gender
35 .. S QAC74510=^QA(745.1,QACD0,0)
36 .. S QACPIEN=+$P($G(QAC74510),U,3)
37 .. S QACDIV=$P($G(QAC74510),U,16)
38 .. I $G(QACDIV)']"" S QACDIV=0
39 .. S QACEE=0
40 .. ;I QACDIV>0 I $O(^QA(740,1,"QAC2","B",QACDIV,QACEE))']"" S QACDIV=0
41 .. I QACDIV>0,('$D(^DIC(4,QACDIV))) S QACDIV=0
42 .. I QACDIV>0,($G(^DIC(4,QACDIV,0))']"") S QACDIV=0
43 .. I $G(QAC1DIV)]"",QACDIV>0 I QAC1DIV'=QACDIV Q
44 .. I QACDIV=0 S QACDIV="Unknown"
45 .. S QACGENDR=$P($G(^DPT(QACPIEN,0)),U,2)
46 .. I $S($G(QACGEN)=QACGENDR:1,$G(QACGEN)="A":1,1:0) D
47 ... ; For each code in record, get IEN and set QACICODE=code,
48 ... ; QACHD=header for code, and QACHDIEN=header IEN.
49 ... S QACCN=0 F S QACCN=$O(^QA(745.1,QACD0,3,QACCN)) Q:QACCN'>0 D
50 .... S QACCIEN=$P($G(^QA(745.1,QACD0,3,QACCN,0)),U,1) Q:QACCIEN=""
51 .... S QACINDT=$P($G(^QA(745.2,QACCIEN,0)),U,6)
52 .... Q:(QACINDT)&(QACINDT<QAQNBEG)
53 .... S QACICODE=$P($G(^QA(745.2,QACCIEN,0)),U,1) Q:QACICODE=""
54 .... I $E(QACICODE,1,2)?2A S QACHD=$E(QACICODE,1,2)
55 .... E S QACHD=$E(QACICODE,1)
56 .... S QACHDIEN=0 F S QACHDIEN=$O(^QA(745.2,"B",QACHD,QACHDIEN)) Q:QACHDIEN'>0 D SET
57 .... Q
58 ... Q
59 .. Q
60 . Q
61INIT ;initialize ^TMP("QACGEN",$J nodes to zero if no count, yet
62 S QACCIEN=0
63 F S QACCIEN=$O(^QA(745.2,QACCIEN)) Q:QACCIEN'>0 D
64 . S QACINDT=$P($G(^QA(745.2,QACCIEN,0)),U,6)
65 . Q:(QACINDT)&(QACINDT<QAQNBEG)
66 . S QACICODE=$P($G(^QA(745.2,QACCIEN,0)),U) Q:QACICODE=""
67 . S QACHD=$S($E(QACICODE,1,2)?2A:$E(QACICODE,1,2),1:$E(QACICODE))
68 . S QACHDIEN=0
69 . F S QACHDIEN=$O(^QA(745.2,"B",QACHD,QACHDIEN)) Q:QACHDIEN'>0 D
70 .. I QACHD'=$P($G(^QA(745.2,QACHDIEN,0)),U) Q
71 .. S X=QACHD_U_QACHDIEN,Y=QACICODE_U_QACCIEN
72 .. S QACC="" F S QACC=$O(^TMP("QACGEN",$J,QACC)) Q:QACC']"" D
73 ... I $G(^TMP("QACGEN",$J,QACC,X))="" S ^TMP("QACGEN",$J,QACC,X)=0
74 ... I $G(^TMP("QACGEN",$J,QACC,X,Y))="" S ^TMP("QACGEN",$J,QACC,X,Y)=0
75 . Q
76PRINT ;
77 K QACUNDL S $P(QACUNDL,"-",81)="",QACQUIT=0,QACPG=1
78 I $O(^TMP("QACGEN",$J,""))="" S QACGENX="" D HEAD W !!,"No data found for the date range selected!" Q
79 K QACHDIEN,QACHD,QACCIEN,QACICODE
80 D HEAD S QACTOT=$P($G(^TMP("QACGEN",$J)),U,1)
81 W !!?15,"Total Issues for ",$G(QACGENX)," = ",QACTOT,! ;Write total issues
82 I $G(QACDVFLG)=1 D BYDIV G EXIT
83BYHEAD ;prints those records for each header. If by division this is called
84 ;from BYDIV. In each reference to ^TMP a $S is used to determine if
85 ;it's being sorted by division.
86 S QACHD="" F S QACHD=$S($G(QACDVFLG):$O(^TMP("QACGEN",$J,QACEE,QACHD)),1:$O(^TMP("QACGEN",$J,QACHD))) Q:(QACHD="")!($G(QACQUIT)) D
87 . S QACHDIEN=$P(QACHD,"^",2)
88 . S QACHDNM=$$EN6^QACUTIL(QACHDIEN)
89 . S QACHDTOT=$S($G(QACDVFLG):$P($G(^TMP("QACGEN",$J,QACEE,QACHD)),U,1),1:$P($G(^TMP("QACGEN",$J,QACHD)),U,1)) Q:(QACHDTOT="")!($G(QACQUIT))
90 . W !!?5,QACHDNM,?77,QACHDTOT ;Write total for header code
91 . S QACICODE="" F S QACICODE=$S($G(QACDVFLG):$O(^TMP("QACGEN",$J,QACEE,QACHD,QACICODE)),1:$O(^TMP("QACGEN",$J,QACHD,QACICODE))) Q:(QACICODE="")!($G(QACQUIT)) D
92 .. I $L($P(QACICODE,U))=2 Q
93 .. S QACCIEN=$P(QACICODE,"^",2) ;Get Issue IEN
94 .. S QACCNM=$$EN5^QACUTIL(QACCIEN) ;Get Issue name
95 .. S QACCTOT=$S($G(QACDVFLG):$P($G(^TMP("QACGEN",$J,QACEE,QACHD,QACICODE)),U,1),1:$P($G(^TMP("QACGEN",$J,QACHD,QACICODE)),U,1)) Q:(QACCTOT="")!($G(QACQUIT))
96 .. W !,QACCNM
97 .. W ?77,QACCTOT ;Write total for the issue
98 .. I '$G(QACQUIT),$Y>(IOSL-5) D:$E(IOST)="C" PAUSE Q:$G(QACQUIT) D HEAD
99 .. Q
100 . Q
101 I $G(QACDVFLG)=1 Q
102 W ! D PAUSE
103EXIT ;
104 W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
105 K IOP,POP,%ZIS,ZTDESC,ZTQUEUED,ZTREQ,ZTSAVE,ZTRTN,ZTSK
106 K QAC1DIV,QAC74510,QACC,QACCN,QACCNM,QACCIEN,QACCSS,QACCTOT
107 K QACD,QACDIV,QACDT,QACDV,QACEE,QACGEN,QACGENDR,QACGENX
108 K QACHD,QACHDIEN,QACHDNM,QACHDTOT,QACEE
109 K QACICODE,QACINDT,QACQUIT,QACPG,QACPIEN,QACTOT,QACUNDL
110 K DIR,DIRUT,DIROUT
111 K QAQ2HED,QAQNBEG,QAQNEND,QAQPOP,QAQQUIT
112 K ^TMP("QACGEN",$J),X,Y
113 D K^QAQDATE
114 Q
115HEAD ;
116 W:($E(IOST)="C")!(QACPG>1) @IOF
117 W !,"Issue Report for ",$G(QACGENX) S Y=DT D DD^%DT W ?60,"Date: ",Y,!
118 W QAQ2HED,?60,"Page: ",QACPG
119 W !,QACUNDL,! S QACPG=QACPG+1
120 Q
121PAUSE ;
122 I '$G(QACQUIT),$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S QACQUIT=$S(Y'>0:1,1:0)
123 Q
124SET ;Counts the records.
125 S ^TMP("QACGEN",$J)=$G(^TMP("QACGEN",$J))+1
126 D YESDIV
127 Q
128BYDIV ;for multi-div sites, need to loop through each div
129 N QACCOUNT
130 S QACCOUNT=1
131 S QACEE="" F S QACEE=$O(^TMP("QACGEN",$J,QACEE)) Q:(QACEE']"")!($G(QACQUIT)) D
132 . I $G(QACCOUNT)>1 D HEAD
133 . I $G(QACEE)>0 D INST^QACUTL0(QACEE,.QACDV)
134 . I $G(QACEE)=0 S QACDV="Unknown"
135 . W !!,"Total Issues by Division: ",QACDV
136 . W !,?5,"Total Issues for ",$G(QACGENX)," ",$G(^TMP("QACGEN",$J,QACEE))
137 . D BYHEAD
138 . S QACCOUNT=QACCOUNT+1
139 Q
140YESDIV ;set counts for sites that have integrated
141 S ^TMP("QACGEN",$J,QACDIV,QACHD_"^"_QACHDIEN)=$G(^TMP("QACGEN",$J,QACDIV,QACHD_"^"_QACHDIEN))+1
142 S ^TMP("QACGEN",$J,QACDIV,QACHD_"^"_QACHDIEN,QACICODE_"^"_QACCIEN)=$G(^TMP("QACGEN",$J,QACDIV,QACHD_"^"_QACHDIEN,QACICODE_"^"_QACCIEN))+1
143 S ^TMP("QACGEN",$J,QACDIV)=$G(^TMP("QACGEN",$J,QACDIV))+1
144 Q
Note: See TracBrowser for help on using the repository browser.