source: FOIAVistA/tag/r/PATIENT_REPRESENTATIVE-QAC/QACSPRD2.m@ 628

QACSPRD2 ;HINES/CEW - Spreadsheet report selections ;7/17/95  11:17
 ;;2.0;Patient Representative;**3,9,12,17**;07/25/1995
CODE ;
 ;Sub-routine to count total number of issues for each issue code
 S QACTITLE="Issue Code "
 S QACRTN="CODETSK^QACSPRD2"
 S QACIFLG=1
 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACD0) G:$G(QACPOP) EXIT
 I $G(QACXFLG) G EXIT
CODETSK ;
 ;Tasked entry point for CODE
 S QACROU="CODETSK1^QACSPRD2"
 D TSK
 Q
CODETSK1 ;
 D ICLOOP
 S QACRR=0
 F  S QACRR=$O(QACODE(QACRR)) Q:QACRR']""  D
 . S ^TMP("QACSPRD2",$J,QACDIV,QACODE(QACRR),QACD0)=""
 . ;D TALL^QACSPRD1(QACD0) ;Q
 Q
LOC ;
 ;Sub-routine to count total number of issues for Location of Event
 S QACTITLE="Location "
 S QACRTN="LOCTSK^QACSPRD2"
 S QACIFLG=1
 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACD0) G:$G(QACPOP) EXIT
 I $G(QACXFLG) G EXIT
LOCTSK ;
 ;Tasked entry point for LOC
 S QACROU="LOCTSK1^QACSPRD2"
 D TSK
 Q
LOCTSK1 ;
 D ICLOOP
 S QACLNUM=$P(^QA(745.1,QACD0,0),U,12) Q:QACLNUM=""  D
 . S QACLOC=$P($G(^SC(+QACLNUM,0)),U,1)
 Q:$G(QACLOC)']""
 S QACRR=0
 F  S QACRR=$O(QACODE(QACRR)) Q:QACRR']""  D
 . S ^TMP("QACSPRD2",$J,QACDIV,QACLOC,QACODE(QACRR),QACD0)=""
 . Q
 Q
SERVICE ;
 ;Sub-routine to count total number of issues for Service
 ;This field is the old service/section involved field, no longer used
 ;after 10/01/97.  Report is kept for records entered prior to that date.
 K %ZIS,IOP S %ZIS="MQ" W ! D ^%ZIS G:POP EXIT
 I $D(IO("Q")) D  G EXIT
 . S (ZTSAVE("QAQNBEG"),ZTSAVE("QAQNEND"))=""
 . S ZTSAVE("^TMP(""QACSPRD2"",$J,")=""
 . S ZTDESC="Patient Rep Service Spreadsheet"
 . S ZTRTN="SERVTSK^QACSPRD2" D ^%ZTLOAD
 . Q
SERVTSK ;
 ;Tasked entry point for SERVICE
 U IO
 S QACDT=QAQNBEG-.0000001 F  S QACDT=$O(^QA(745.1,"D",QACDT)) Q:(QACDT'>0)!(QACDT>QAQNEND)!(QACDT\1'?7N)  D
 . S QACD0=0 F  S QACD0=$O(^QA(745.1,"D",QACDT,QACD0)) Q:QACD0'>0  D
 .. Q:'$D(^QA(745.1,QACD0,3,0))
 .. S QACCN=0 F  S QACCN=$O(^QA(745.1,QACD0,3,QACCN)) Q:QACCN'>0  D
 ... S QACCIEN=$P($G(^QA(745.1,QACD0,3,QACCN,0)),U,1) Q:QACCIEN=""
 ... S QACICODE=$P($G(^QA(745.2,QACCIEN,0)),U,1) Q:QACICODE=""  D
 .... Q:'$D(^QA(745.1,QACD0,3,QACCN,1,0))
 .... S QACSIEN=0 F  S QACSIEN=$O(^QA(745.1,QACD0,3,QACCN,1,"B",QACSIEN)) Q:QACSIEN'>0  D
 ..... S QACSERV=$$EN4^QACUTIL(+QACSIEN)
 ..... S ^TMP("QACSPRD2",$J,QACSERV,QACICODE,QACD0)=""
 ..... Q
 .... Q
 ... Q
 .. Q
 . Q
 S QACSERV="" F  S QACSERV=$O(^TMP("QACSPRD2",$J,QACSERV)) Q:QACSERV=""  D
 . S QACICODE="",QACTOT=0 F  S QACICODE=$O(^TMP("QACSPRD2",$J,QACSERV,QACICODE)) Q:QACICODE=""  D
 .. S QACREC=0 F  S QACREC=$O(^TMP("QACSPRD2",$J,QACSERV,QACICODE,QACREC)) Q:QACREC'>0  D
 ... S QACTOT=QACTOT+1
 ... Q
 .. Q
 . W !,QACSERV_","_QACTOT
 . Q
 D EXIT
 Q
DISC ; Sub-routine to count total issue per discipline
 S QACTITLE="Discipline "
 S QACRTN="DISCTSK^QACSPRD2"
 S QACIFLG=1
 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACD0) G:$G(QACPOP) EXIT
 I $G(QACXFLG) G EXIT
DISCTSK ; Tasked entry point for DISCIPLINE
 S QACROU="DISCTSK1^QACSPRD2"
 D TSK
 Q
DISCTSK1 ;
 D ICLOOP
 S QACRR=0
 F  S QACRR=$O(QACODE(QACRR)) Q:QACRR'>0  D
 . ;Q:'$D(^QA(745.1,QACD0,3,QACODE(QACRR),3,0))
 . S QACWW=0
 . F  S QACWW=$O(^QA(745.1,QACD0,3,QACCODE(QACRR),3,"B",QACWW)) Q:QACWW'>0  D
 . . S QACDIEN=$P(^QA(745.55,QACWW,0),U,3) Q:$G(QACDIEN)']""
 . . S QACDISC=$$EN7^QACUTIL(+QACDIEN)
 . . S ^TMP("QACSPRD2",$J,QACDIV,QACDISC,QACODE(QACRR),QACD0)=""
 . . Q
 . Q
 Q
EXIT ;
 W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
 K ^TMP("QACSPRD2",$J),IOP,POP,ZTRTN,ZTSAVE,ZTDESC,%ZIS
 K COUNT,QAC1,QAC1DIV,QAC2,QAC3,QAC4,QACCIEN,QACCODE,QACCN,QACD0
 K QACDD,QACDIV,QACDIEN,QACDISC,QACDV,QACDNUM,QACDT,QACEE,QACICODE
 K QACIFLG,QACISSUE,QACLOC,QACLNUM,QACMM,QACNUM,QACPN,QACPOP,QACREC
 K QACROU,QACRR,QACRTN,QACSERV,QACSIEN,QACTITLE,QACTOT,QACWW,QACXFLG
 K QAQNBEG,QAQNEND
 Q
ICLOOP ;
 U IO
 K QACODE
 Q:'$D(^QA(745.1,QACD0,3,0))
 S QACEE=0 F  S QACEE=$O(^QA(745.1,QACD0,3,"B",QACEE)) Q:QACEE'>0  D
 . S QACODE(QACEE)=$P($G(^QA(745.2,QACEE,0)),U,1) I QACODE(QACEE)="" K QACODE(QACEE) Q
 . ;get the issue code IEN so that in DISCTSK1 can get the discpline
 . S QACMM=0 S QACMM=$O(^QA(745.1,QACD0,3,"B",QACEE,QACMM)) I $G(QACMM)>0 S QACCODE(QACEE)=QACMM
 Q
COUNT ;
 N QACCNT,QACCNT2,QACCNT3,QACCNT4,QACTOT
 S QAC1=""
 S (QACCNT2,QACCNT3,QACCNT4)=0
 F  S QAC1=$O(^TMP("QACSPRD2",$J,QAC1)) Q:QAC1']""  D
 . I $D(QAC1DIV) D
 . . I $G(QAC1)]"" S QACDV=QAC1
 . . I $G(QAC1)=+$G(QAC1) D INST^QACUTL0(QAC1,.QACDV)
 . . W !!?5,"Division: "_$S(QAC1=0:"Unknown",1:QACDV)
 . S QAC2=""
 . F  S QAC2=$O(^TMP("QACSPRD2",$J,QAC1,QAC2)) Q:QAC2']""  D
 . . S QACCNT2=$G(QACCNT2)+1
 . . S QAC3=""
 . . F  S QAC3=$O(^TMP("QACSPRD2",$J,QAC1,QAC2,QAC3)) Q:QAC3']""  D
 . . . S QACCNT3=$G(QACCNT3)+1
 . . . S QAC4=""
 . . . F  S QAC4=$O(^TMP("QACSPRD2",$J,QAC1,QAC2,QAC3,QAC4)) Q:QAC4']""  D
 . . . . S QACCNT4=$G(QACCNT4)+1
 . . W !,QAC2_", "_$S($G(QACCNT4)>0:QACCNT4,1:QACCNT3) S (QACCNT3,QACCNT4)=0
 . ;W !?5,QAC1_", "_$S($G(QACCNT3)>0:QACCNT3,1:QACCNT2) S (QACCNT3,QACCNT2)=0
 ;. . S (QACCNT3,QACCNT4)=0
 Q
TSK ;
 D LOOP1^QACSPRD(QACROU,QAQNBEG,QAQNEND,.QACD0)
 ;D SET1^QACSPRD1
 D WRIT^QACSPRD1
 D COUNT
 D EXIT
 Q
LOOP2 ;
 S (QACDD,QACTOT)=0
 F  S QACDD=$O(^TMP("QACSPRD2",$J,QAC1,QAC2,QACDD)) Q:QACDD']""  D
 . S QACTOT=QACTOT+1
 W !,QAC2_", "_QACTOT
 I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^QACGEN S QACPFLG=1 D WRIT^QACSPRD1
 S QACTOT=0
 K QACPFLG
 Q