source: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACSPRD.m@ 1593

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

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1QACSPRD ;HISC/CEW - Spreadsheet reports ;7/17/95 11:04
2 ;;2.0;Patient Representative;**3,9,12,17**;07/25/1995
3DATE ;
4 N QACIFLG,QACXFLG
5 S QAQPOP=0
6 D DATDIV^QACUTL0 G:QAQPOP EXIT
7BEGIN ;
8 K DIR
9 S DIR(0)="NA^1:13"
10 W !!?5,"1 Contact made by (#C)",!?5,"2 Issue Headers (#I)",!?5,"3 Issues"
11 W !?5,"4 Location (#I)"
12 W !?5,"5 Service (Old field - Service field de-activated 10/97 - #I)"
13 W !?5,"6 Service/Discipline (#I)",!?5,"7 Sex (#I)"
14 W !?5,"8 Contact Source (#C)",!?5,"9 Treatment Status (#C)"
15 W !?5,"10 Treatment Status (#I)",!?5,"11 Discipline (#I)"
16 W !?5,"12 Division (#C)",!?5,"13 Division (#I)",!!
17 S DIR("A")="Print Spreadsheet Totals for: "
18 S DIR("?")=" Select the number or item you want totalled."
19 S DIR("?",1)=" #I means total is by Issues. #C means total is by Contacts."
20 S DIR("?",2)=" Enter ""^"" or <RET> to exit."
21 D ^DIR K DIR G:$D(DIRUT)!$D(DIROUT) EXIT S QACITEM=Y
22 K COUNT,QACPCE,QACLABEL,QACDIV
23 N QACRTN
24 I QACITEM=1 D CONTACT^QACSPRD1
25 I QACITEM=2 D HEAD^QACSPRD3
26 I QACITEM=3 D CODE^QACSPRD2
27 I QACITEM=4 D LOC^QACSPRD2
28 I QACITEM=5 D SERVICE^QACSPRD2
29 I QACITEM=6 D SRVDS^QACSPRD3
30 I QACITEM=7 D SEX^QACSPRD3
31 I QACITEM=8 D SOURCE^QACSPRD1
32 I QACITEM=9 D TREATC^QACSPRD1
33 I QACITEM=10 D TREATI^QACSPRD1
34 I QACITEM=11 D DISC^QACSPRD2
35 I QACITEM=12 D DIVC^QACSPRD3
36 I QACITEM=13 D DIVI^QACSPRD3
37 K DIR S DIR(0)="E" D ^DIR G EXIT:$D(DIRUT),DATE
38EXIT ;
39 K DIR,DIROUT,DIRUT,POP,Y
40 K QAC1DIV,QACDT,QACITEM,QACNUM,QACPOP,QAQPOP,QACWW
41 K ZTDESC,ZTRTN,ZTSAVE
42 D K^QAQDATE
43 Q
44LOOP1(ROU,NBEG,NEND,QACD0) ;loop through #745.1 within the date range
45 S QACDT=NBEG-.0000001 F S QACDT=$O(^QA(745.1,"D",QACDT)) Q:(QACDT'>0)!(QACDT>NEND)!(QACDT\1'?7N) D
46 . S QACD0=0 F S QACD0=$O(^QA(745.1,"D",QACDT,QACD0)) Q:QACD0'>0 D
47 . . S QACDIV=$P(^QA(745.1,QACD0,0),U,16)
48 . . ;S QACWW=""
49 . . ;I $G(QACDIV)]"" I $O(^QA(740,1,"QAC2","B",QACDIV,QACWW))']"" S QACDIV=0
50 . . I $G(QACDIV)']"" S QACDIV=0
51 . . I $O(QACDIV(0))>0 D CHKDIV
52 . . I $G(QAC1DIV)]"" I $G(QACDIV)=$G(QAC1DIV) D @ROU
53 . . I $G(QAC1DIV)']"" D @ROU
54 Q
55ZIS1(ZTRTN,DESC,XFLG) ;subroutine sets up and calls ^%ZIS and ^%ZTLOAD
56 K QACXFLG
57 K %ZIS,IOP S %ZIS="MQ" W ! D ^%ZIS I POP S QACPOP=1 Q
58 I $D(IO("Q")) D
59 . S (ZTSAVE("QAQNBEG"),ZTSAVE("QAQNEND"))=""
60 . S (ZTSAVE("QAC1DIV"),ZTSAVE("QACDIV"),ZTSAVE("QAQPOP"))=""
61 . S (ZTSAVE("QACTITLE"),ZTSAVE("QACIFLG"))=""
62 . I $G(QACIFLG)=1 K ^TMP("QACSPRD2",$J)
63 . I $G(QACIFLG)=1 S (ZTSAVE("^TMP(""QACSPRD2"",$J,"),ZTSAVE("QACODE"))=""
64 . S ZTDESC="Patient Rep "_DESC_"Spreadsheet Report"
65 . D ^%ZTLOAD S QACXFLG=1
66 Q
67CHKDIV ;
68 N QACD,QACQ
69 S QACD=""
70 F S QACD=$O(QACDIV(QACD)) Q:QACD']"" D
71 . I QACD=QACDIV S QACQ=1
72 I $G(QAC1DIV)']"" I $G(QACQ)'=1 S QACDIV=0
73 Q
Note: See TracBrowser for help on using the repository browser.