source: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACSRPT.m@ 623

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1QACSRPT ;HISC/CEW - Report of Service Contacts ;7/17/95 12:24
2 ;;2.0;Patient Representative;**3**;07/25/1995
3DATE ;
4 W !!,"Select the date range you want to print."
5 D ^QAQDATE G:QAQQUIT EXIT I QAQNBEG>DT W !,?5,"*** Beginning date must be today or earlier! ***",*7 G DATE
6 K %ZIS,IOP S %ZIS="MQ" W ! D ^%ZIS G:POP EXIT
7 I $D(IO("Q")) D G EXIT
8 . S (ZTSAVE("QAQNBEG"),ZTSAVE("QAQNEND"),ZTSAVE("QAQ2HED"))=""
9 . S ZTDESC="Patient Rep Service Report"
10 . S ZTRTN="SERTSK^QACSRPT"
11 . D ^%ZTLOAD
12 . I $G(ZTSK) W !,"Task Number: ",ZTSK
13 . Q
14SERTSK ;
15 K ^TMP($J,"QACSRPT0"),^TMP($J,"QACSRPT1"),^TMP($J,"QACSRPT2")
16 S (^TMP($J,"QACSRPT0"),^TMP($J,"QACSRPT1"),^TMP($J,"QACSRPT2"))=0
17 U IO
18 K QACDT,QACD0,QACCN,QACSIEN,QACCIEN,QACINM,QACHDNM,QACHDIEN
19 S QACDT=QAQNBEG-.0000001 F S QACDT=$O(^QA(745.1,"D",QACDT)) Q:(QACDT'>0)!(QACDT>QAQNEND)!(QACDT\1'?7N) D
20 . S QACD0=0 F S QACD0=$O(^QA(745.1,"D",QACDT,QACD0)) Q:QACD0'>0 D
21 .. S QACCN=0 F S QACCN=$O(^QA(745.1,QACD0,3,QACCN)) Q:QACCN'>0 D
22 ... S QACSN=0 F S QACSN=$O(^QA(745.1,QACD0,3,QACCN,1,QACSN)) Q:QACSN'>0 D
23 .... S QACSIEN=$P($G(^QA(745.1,QACD0,3,QACCN,1,QACSN,0)),U,1) Q:QACSIEN=""
24 .... S QACSERV=$$EN4^QACUTIL(QACSIEN)
25 .... S QACCIEN=$P($G(^QA(745.1,QACD0,3,QACCN,0)),U,1) Q:QACCIEN=""
26 .... S QACICODE=$P($G(^QA(745.2,QACCIEN,0)),U,1) Q:QACICODE=""
27 .... I $E(QACICODE,1,2)?2A S QACHD=$E(QACICODE,1,2)
28 .... E S QACHD=$E(QACICODE,1)
29 .... S QACHDIEN=0 F S QACHDIEN=$O(^QA(745.2,"B",QACHD,QACHDIEN)) Q:QACHDIEN'>0 D SET
30 .... Q
31 ... Q
32 .. Q
33 . Q
34PRINT ;
35 ;This is the header information on each page and the data by service.
36 K QACUNDL S $P(QACUNDL,"-",81)="",QACQUIT=0,QACPG=1
37 I $O(^TMP($J,"QACSRPT0",""))="" S QACSERV="" D HEAD W !!,"No data found for the date range selected!" Q
38 K QACSERV,QACHDIEN,QACHD,QACCIEN,QACICODE,QACSTOT,QACCTOT,QACHDTOT
39 S QACSERV="" F S QACSERV=$O(^TMP($J,"QACSRPT0",QACSERV)) Q:(QACSERV="")!(QACQUIT) D
40 . S QACSTOT=$P($G(^TMP($J,"QACSRPT0",QACSERV)),U,1) Q:QACSTOT=""
41 . D HEAD
42 . W !!?15,"Total Issues for ",QACSERV," = ",QACSTOT
43 . S QACHD="" F S QACHD=$O(^TMP($J,"QACSRPT1",QACSERV,QACHD)) Q:(QACHD="")!(QACQUIT) D
44 .. S QACHDIEN=$P(QACHD,"^",2)
45 .. S QACHDNM=$$EN6^QACUTIL(QACHDIEN)
46 .. S QACHDTOT=$P($G(^TMP($J,"QACSRPT1",QACSERV,QACHD)),U,1) Q:(QACHDTOT="")!(QACQUIT)
47 .. W !!?5,QACHDNM,?75,QACHDTOT
48 .. S QACICODE="" F S QACICODE=$O(^TMP($J,"QACSRPT2",QACSERV,QACHD,QACICODE)) Q:(QACICODE="")!(QACQUIT) D
49 ... S QACCIEN=$P(QACICODE,"^",2)
50 ... S QACCNM=$$EN5^QACUTIL(QACCIEN)
51 ... S QACCTOT=$P($G(^TMP($J,"QACSRPT2",QACSERV,QACHD,QACICODE)),U,1) Q:(QACCTOT="")!(QACQUIT)
52 ... W !,QACCNM,?75,QACCTOT
53 ... I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE Q:QACQUIT D HEAD
54 ... Q
55 .. Q
56 . W ! D PAUSE
57 . Q
58EXIT ;
59 W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
60 K IOP,%ZIS,ZTSAVE,ZTDESC,ZTRTN,QACDT,QACD0,QACCN,QACCIEN,QACICODE,ZTSK
61 K QACSIEN,QACSERV,QACHEAD,QACHDIEN,QACHDNM,QACINAME,QACQUIT,Y,%DT,QACPG
62 K QACDIS,QACHDTOT,QACTOT,QACHDREC,QACREC,DIR,POP,QACCNM,QACSN,QACUNDL
63 K ^TMP("J","QACSRPT0"),^TMP($J,"QACSRPT1"),^TMP($J,"QACSRPT2")
64 K DIRUT,DIROUT,QACCTOT,QACHD,QACSTOT
65 D K^QAQDATE
66 Q
67HEAD ;
68 W:($E(IOST)="C")!(QACPG>1) @IOF
69 W !,"Issue Report for ",QACSERV S Y=DT D DD^%DT W ?60,"Date: ",Y,!
70 W QAQ2HED,?60,"Page: ",QACPG
71 W !,QACUNDL,! S QACPG=QACPG+1
72 Q
73PAUSE ;
74 I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S QACQUIT=$S(Y'>0:1,1:0)
75 Q
76SET ;Counts the records.
77 S ^TMP($J,"QACSRPT0",QACSERV)=$G(^TMP($J,"QACSRPT0",QACSERV))+1
78 S ^TMP($J,"QACSRPT1",QACSERV,QACHD_"^"_QACHDIEN)=$G(^TMP($J,"QACSRPT1",QACSERV,QACHD_"^"_QACHDIEN))+1
79 S ^TMP($J,"QACSRPT2",QACSERV,QACHD_"^"_QACHDIEN,QACICODE_"^"_QACCIEN)=$G(^TMP($J,"QACSRPT2",QACSERV,QACHD_"^"_QACHDIEN,QACICODE_"^"_QACCIEN))+1
80 Q
Note: See TracBrowser for help on using the repository browser.