source: FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACSPRD3.m@ 1800

QACSPRD3 ;HINES/CEW - Spreadsheet report selections ;7/17/95  11:22
 ;;2.0;Patient Representative;**3,5,9,17**;07/25/1995
SEX ;
 ;Sub-routine to count total number of issues for each sex
 S QACRTN="SEXTSK^QACSPRD3",QACTITLE="Sex "
 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
 I $G(QACXFLG) G EXIT
SEXTSK ;
 ;Tasked entry point for SEX
 U IO
 S QACROU="SEXTSK1^QACSPRD3"
 S QACPCE(1)="M",QACLABEL(1)="Male"
 S QACPCE(3)="",QACCNT=2
 S QACPCE(2)="F",QACLABEL(2)="Female"
 D SET1^QACSPRD1
 D LOOP1^QACSPRD(QACROU,QAQNBEG,QAQNEND,.QACD0)
 D WRIT^QACSPRD1
 D EXIT
 Q
SEXTSK1 ;
 Q:'$D(^QA(745.1,QACD0,3))
 D ICLOOP^QACSPRD2
 S QACPN=$P(^QA(745.1,QACD0,0),U,3) Q:QACPN=""
 S QACSEX=$P($G(^DPT(QACPN,0)),U,2) Q:QACSEX=""
 S QACEE=0 F  S QACEE=$O(^QA(745.1,QACD0,3,QACEE)) Q:QACEE'>0  D
 . D TALL^QACSPRD1(QACSEX)
 Q
HEAD ;
 ;Sub-routine to count total number of issues for each Issue Code Heading
 S QACTITLE="Issue Code Heading "
 S QACRTN="HEADTSK^QACSPRD3"
 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
 I $G(QACXFLG) G EXIT
HEADTSK ;
 ;Tasked entry point for HEAD
 U IO
 S QACROU="HEADTSK1^QACSPRD3"
 S QACPCE(1)="CA",QACLABEL(1)="Patient Care"
 S QACPCE(2)="CC",QACLABEL(2)="Courtesy" ;/Communication"
 S QACPCE(3)="CM",QACLABEL(3)="Compliments"
 S QACPCE(4)="ED",QACLABEL(4)="Patient Education"
 S QACPCE(5)="EL",QACLABEL(5)="Eligibility"
 S QACPCE(6)="EN",QACLABEL(6)="Environment"
 S QACPCE(7)="IN",QACLABEL(7)="Information/Assistance"
 S QACPCE(8)="MR",QACLABEL(8)="Medical Records"
 S QACPCE(9)="PP",QACLABEL(9)="Personal Property"
 S QACPCE(10)="TI",QACLABEL(10)="Access/Timeliness" ;"Timeliness"
 S QACPCE(11)="SC",QACLABEL(11)="Courtesy" ;"Staff courtesy"
 S QACPCE(12)="AC",QACLABEL(12)="Access/Timeliness"
 S QACPCE(13)="OP",QACLABEL(13)="One Provider"
 S QACPCE(14)="PR",QACLABEL(14)="Decisions/Preferences"
 S QACPCE(15)="EM",QACLABEL(15)="Emotional Needs"
 S QACPCE(16)="PC",QACLABEL(16)="Physical Comfort"
 S QACPCE(17)="CO",QACLABEL(17)="Coordination of Care"
 S QACPCE(18)="TR",QACLABEL(18)="Transitions"
 ;S QACPCE(19)="ED",QACLABEL(19)="Patient Education"
 S QACPCE(20)="FI",QACLABEL(20)="Family Involvement"
 S QACPCE(21)="RI",QACLABEL(21)="Risk Management Complaints"
 S QACPCE(22)="RE",QACLABEL(22)="Medical Records"
 S QACPCE(23)="LL",QACLABEL(23)="Eligibility" ; Issues"
 S QACPCE(24)="EV",QACLABEL(24)="Environment" ;al Issues"
 S QACPCE(25)="RG",QACLABEL(25)="Regulation Issues"
 S QACPCE(26)="IF",QACLABEL(26)="Requests for Information"
 S QACPCE(27)="CP",QACLABEL(27)="Compliments"
 S QACPCE(28)=""
 S QACCNT=27
 D SET1^QACSPRD1
 D LOOP1^QACSPRD(QACROU,QAQNBEG,QAQNEND,.QACD0)
 D NEWHEAD
 D WRIT^QACSPRD1
 D EXIT
 Q
HEADTSK1 ;
 Q:'$D(^QA(745.1,QACD0,3,0))
 D ICLOOP^QACSPRD2
 S QACEE=0
 F  S QACEE=$O(QACODE(QACEE)) Q:QACEE']""  D
 . S QACHEAD=$E(QACODE(QACEE),1,2)
 . D TALL^QACSPRD1(QACHEAD)
 Q
NEWHEAD ;combine some of the new and old headers
 N QAC1,QAC2,QACE,QACX
 S QACE=""
 F  S QACE=$O(COUNT(QACE)) Q:QACE']""  D
 . I $G(COUNT(QACE,"SC"))>0 S QAC1="CC",QAC2="SC" D NEW2
 . I $G(COUNT(QACE,"CP"))>0 S QAC1="CM",QAC2="CP" D NEW2
 . I $G(COUNT(QACE,"LL"))>0 S QAC1="EL",QAC2="LL" D NEW2
 . I $G(COUNT(QACE,"EV"))>0 S QAC1="EN",QAC2="EV" D NEW2
 . I $G(COUNT(QACE,"RE"))>0 S QAC1="MR",QAC2="RE" D NEW2
 . I $G(COUNT(QACE,"AC"))>0 S QAC1="TI",QAC2="AC" D NEW2
 . I $G(COUNT(QACE,"IF"))>0 S QAC1="IN",QAC2="IF" D NEW2
 Q
NEW2 ;
 S COUNT(QACE,QAC1)=COUNT(QACE,QAC1)+$G(COUNT(QACE,QAC2)) ;K COUNT(QACE,QAC2)
 F QACX=11,12,22,23,24,27 K QACLABEL(QACX)
 Q
DIVC ; Sub-routine counts total number of contacts by Division
 S QACRTN="DIVCTSK^QACSPRD3",QACTITLE="Contacts "
 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
 I $G(QACXFLG) G EXIT
DIVCTSK ;
 S QACROU="DIVC1^QACSPRD3"
 D DVTSK(QACROU)
 Q
DIVC1 ;for each entry from #745.1 in the date range, check for the division
 S QACDIV=$P($G(^QA(745.1,QACD0,0)),U,16) ;Q:$G(QACDIV)']""
 I $G(QACDIV)']"" S QACDIV=0
 S QACEE=""
 ;I $O(^QA(740,1,"QAC2","B",QACDIV,QACEE))']"" S QACDIV=0
 S COUNT(QACDIV)=$G(COUNT(QACDIV))+1
 Q
WRITEDIV ;display or print the final tally
 W @IOF
 S Y=QAQNBEG D DD^%DT S QACBEG=Y
 S Y=QAQNEND D DD^%DT S QACEND=Y
 W !!?12,"Patient Rep "_QACTITLE_"by Division Spreadsheet Report"
 W !?20,"Date Range: "_QACBEG_" to "_QACEND
 S QACEE=""
 F  S QACEE=$O(COUNT(QACEE)) Q:QACEE']""  D 
 . I QACEE>0 D INST^QACUTL0(QACEE,.QACDV)
 . W !,$S(QACEE=0:"Unknown",1:QACDV),", ",COUNT(QACEE)
 . I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^QACGEN S QACPFLG=1 D WRIT^QACSPRD1
 . K QACPFLG
 Q
DIVI ;
 ; Sub-routine to count total issues by Division
 S QACRTN="DIVITSK^QACSPRD3",QACTITLE="Issues "
 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
 I $G(QACXFLG) G EXIT
DIVITSK ;
 S QACROU="DIVI1^QACSPRD3"
 D DVTSK(QACROU)
 Q
DIVI1 ;for each entry in 745.1 loop through Issue code and count by code/div
 S QACDIV=$P($G(^QA(745.1,QACD0,0)),U,16)
 I $G(QACDIV)']"" S QACDIV=0
 S QACEE=""
 ;I $O(^QA(740,1,"QAC2","B",QACDIV,QACEE))']"" S QACDIV=0
 S QACISS=0 F  S QACISS=$O(^QA(745.1,QACD0,3,QACISS)) Q:QACISS'>0  D
 . I $G(^QA(745.1,QACD0,3,QACISS,0))]"" D
 . . S COUNT(QACDIV)=$G(COUNT(QACDIV))+1
 Q
DVTSK(QACROU) ;
 U IO
 I $P($G(^QA(740,1,"QAC")),U,3)<1 W !!,"Site is not multi-divisional for Patient Representative - no report created." Q
 D LOOP1^QACSPRD(QACROU,QAQNBEG,QAQNEND,.QACD0)
 D WRITEDIV
 D EXIT
 Q
SRVDS ;Sub-routine gives total issues by Service/Discipline
 S QACIFLG=1
 S QACTITLE="Service/Discipline "
 S QACRTN="SVDSTSK^QACSPRD3"
 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
 I $G(QACXFLG) G EXIT
SVDSTSK ;  Tasked entry point for Service/Discipline
 S QACROU="SVDSTSK1^QACSPRD3"
 D TSK^QACSPRD2
 Q
SVDSTSK1 ;
 D ICLOOP^QACSPRD2
 S QACRR=0
 F  S QACRR=$O(QACODE(QACRR)) Q:QACRR'>0  D
 . S QACWW=0
 . F  S QACWW=$O(^QA(745.1,QACD0,3,QACCODE(QACRR),3,"B",QACWW)) Q:QACWW'>0  D
 . . S QACDISC=$$EN8^QACUTIL(+QACWW)
 . . S ^TMP("QACSPRD2",$J,QACDIV,QACDISC,QACODE(QACRR),QACD0)=""
 . . Q
 . Q
 Q
EXIT ;
 W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
 K ^TMP("QACSPRD2",$J),COUNT,ZTRTN,ZTSAVE,ZTDESC,%ZIS,IOP,POP
 K QAC1DIV,QACBEG,QACCIEN,QACCNT,QACCODE,QACD0,QACDISC,QACDIV,QACDT
 K QACDV,QACEE,QACEND,QACHEAD,QACICODE,QACIFLG,QACISS,QACISSUE,QACLABEL
 K QACODE,QACPCE,QACPN,QACPOP,QACRR,QACRTN,QACSEX,QACTITLE,QACWW,QACXFLG
 K QAQNBEG,QAQNEND
 Q