| 1 | QACSPRD ;HISC/CEW - Spreadsheet reports ;7/17/95 11:04
|
|---|
| 2 | ;;2.0;Patient Representative;**3,9,12,17**;07/25/1995
|
|---|
| 3 | DATE ;
|
|---|
| 4 | N QACIFLG,QACXFLG
|
|---|
| 5 | S QAQPOP=0
|
|---|
| 6 | D DATDIV^QACUTL0 G:QAQPOP EXIT
|
|---|
| 7 | BEGIN ;
|
|---|
| 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
|
|---|
| 38 | EXIT ;
|
|---|
| 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
|
|---|
| 44 | LOOP1(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
|
|---|
| 55 | ZIS1(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
|
|---|
| 67 | CHKDIV ;
|
|---|
| 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
|
|---|
