source: FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACSPRD1.m@ 1729

QACSPRD1 ;HINES/CEW - Spreadsheet report selections ;1/12/99
 ;;2.0;Patient Representative;**3,9,17**;07/25/1995
CONTACT ;
 ;Sub-routine to count total number of contacts for Contact Made By
 S QACRTN="CONTSK^QACSPRD1",QACTITLE="Contact Made by "
 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
 I $G(QACXFLG) G EXIT
CONTSK ;
 S QACROU="CONTSK1^QACSPRD1"
 S QACFLD=12
 D TSK
 Q
CONTSK1 ;
 K QACENTRY
 S QACENTRY=$P(^QA(745.1,QACD0,0),U,10) Q:$G(QACENTRY)']""
 D TALL(QACENTRY)
 Q
SOURCE ;
 ;Sub-routine to count total number of contacts for Source
 S QACRTN="SOURTSK^QACSPRD1",QACTITLE="Source of Contact "
 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
 I $G(QACXFLG) G EXIT
SOURTSK ;
 S QACROU="SOURTSK1^QACSPRD1"
 S QACFLD=13 D QACSET(QACFLD)
 D TSK
 Q
SOURTSK1 ;
 K QACENTRY
 S QACENTRY=$P(^QA(745.1,QACD0,0),U,11)
 I $G(QACENTRY)]"" D TALL(QACENTRY)
 I $G(QACENTRY)']"" D
 . S QACEE=0
 . F  S QACEE=$O(^QA(745.1,QACD0,12,QACEE)) Q:QACEE'>0  D
 . . S QACENTRY=$G(^QA(745.1,QACD0,12,QACEE,0))
 . . I $G(QACENTRY)]"" D TALL(QACENTRY)
 Q
TREATC ;
 ;Sub-routine to count total number of contacts for Treatment Status
 S QACRTN="TRTCTSK^QACSPRD1",QACTITLE="Contact Numbers by Treatment Status "
 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACXFLG) G:$G(QACPOP) EXIT
 I $G(QACXFLG) G EXIT
TRTCTSK ;
 S QACROU="TRTCTSK1^QACSPRD1"
 S QACFLD=16.5
 D TSK
 Q
TRTCTSK1 ;
 K QACENTRY
 I $G(^QA(745.1,QACD0,2))]"" S QACENTRY=$P(^QA(745.1,QACD0,2),U,2) Q:$G(QACENTRY)']""
 I $G(QACENTRY)]"" D TALL(QACENTRY)
 Q
TREATI ;
 ;Sub-routine to count total number of issues for Treatment Status
 S QACRTN="TRTITSK^QACSPRD1",QACTITLE="Issue Code by Treatment Status "
 S ZTSAVE("QACENTRY")=""
 D ZIS1^QACSPRD(QACRTN,QACTITLE,.QACD0) G:$G(QACPOP) EXIT
 I $G(QACXFLG) G EXIT
TRTITSK ;
 S QACROU="TRTITSK1^QACSPRD1"
 S QACFLD=16.5
 D TSK
 Q
TRTITSK1 ;
 K QACENTRY
 I $G(^QA(745.1,QACD0,2))]"" S QACENTRY=$P(^QA(745.1,QACD0,2),U,2) Q:$G(QACENTRY)']""
 S QACEE=0
 F  S QACEE=$O(^QA(745.1,QACD0,3,QACEE)) Q:QACEE'>0  D
 . I $G(QACENTRY)]"" D TALL(QACENTRY)
 Q
EXIT ;
 W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
 K %ZIS,IOP,POP,ZTSAVE,ZTDESC,ZTRTN,ZTSK,QACSOUR
 K BB,COUNT,DDD,EE,MM,RR
 K QAC1DIV,QAC,QACAA,QACBEG,QACCMB,QACCNT,QACD0,QACDT,QACDIV,QACDV
 K QACEE,QACEND,QACIFLG,QACISSUE,QACLABEL,QACNODE,QACPCE,QACPOP,QACROU
 K QACRTN,QACTR,QACXFLG,QACY7E,QACYES
 K QAQNBEG,QAQNEND
 Q
QACSET(QACFLD,QACENTRY,QACTITLE) ;subroutines to set up counters for 
 ; fields that are sets of codes
 S QACCNT=0
 S QACNODE=$P(^DD(745.1,QACFLD,0),U,3)
 F QACEE=1:1  S QACPCE(QACEE)=$P(QACNODE,";",QACEE) Q:$G(QACPCE(QACEE))']""  S QACCNT=QACCNT+1
 F QACEE=1:1:QACCNT  D
 . S QACLABEL(QACEE)=$P(QACPCE(QACEE),":",2)
 . S QACPCE(QACEE)=$P(QACPCE(QACEE),":",1)
 ;I '$D(QAC1DIV) D SET2 Q
SET1 ;multidivisional
 N RR,RRR
 I $G(QAC1DIV)']"" D
 . ;S RR=0 F  S RR=$O(^QA(740,1,"QAC2",RR)) Q:RR'>0  D
 . ;. S QACDIV(RR)=^QA(740,1,"QAC2",RR,0)
 . ;. D SET2
 . S (RRR,QACDIV(0))=0 D SET2
 . S RRR=0,RR=1
 . F  S RRR=$O(^DG(40.8,"AD",RRR)) Q:RRR'>0  D
 . . Q:'$D(^DIC(4,RRR,0))
 . . S QACDIV(RRR)=RRR
 . . S RR=RR+1
 . . D SET2
 I $G(QAC1DIV)]"" D
 . ;S RR=1,QACDIV(RR)=QAC1DIV
 . S QACDIV(1)=QAC1DIV
 . S RRR=1
 . D SET2
 Q
SET2 ;for each division or not multi-divisional, initialize counts
 S EE=0 F  S EE=$O(QACPCE(EE)) Q:$G(QACPCE(EE))']""  D
 . S QAC=QACPCE(EE)
 . ;I S COUNT(QAC)=0
 . S COUNT(QACDIV(RRR),QACPCE(EE))=0
 Q
SET3 ;multi-divisional, but entry has no division, initialize counts
 S MM="" I $O(QACDIV(MM))>0 D
 . S QACDIV(0)=0
 . S BB=0 F  S BB=$O(QACPCE(BB)) Q:BB>QACCNT  D
 . . S COUNT(0,QACPCE(BB))=0
 S EE=0 F  S EE=$O(QACPCE(EE)) Q:$G(QACPCE(EE))']""  I QACENTRY=QACPCE(EE) D
 . ;S COUNT(QACDIV,QACPCE(EE))=$G(COUNT(QACDIV,QACPCE(EE)))+1
 . S EE=QACCNT
 Q
TALL(QACENTRY) ;tally the entry
 S (QACAA,QACYES)=0
 F  S QACAA=$O(QACDIV(QACAA)) Q:QACAA'>0  D
 . I QACDIV=QACDIV(QACAA) S QACYES=1
 ;I $G(QACYES)'=1 S QACDIV=0
 I $G(QAC1DIV)']"" S RR=0 D SET3
 S EE=0 F  S EE=$O(QACPCE(EE)) Q:EE>QACCNT  I QACENTRY=QACPCE(EE) D
 . ;I '$D(QAC1DIV) S COUNT(QACPCE(EE))=COUNT(QACPCE(EE))+1
 . S COUNT(QACDIV,QACPCE(EE))=$G(COUNT(QACDIV,QACPCE(EE)))+1
 . S EE=QACCNT
 Q
WRIT ;output
 W:($E(IOST)="C")!($G(QACPFLG)=1) @IOF
 W !!?15,$G(QACTITLE)_"Spreadsheet Report"
 S Y=QAQNBEG D DD^%DT S QACBEG=Y
 S Y=QAQNEND D DD^%DT S QACEND=Y
 W !?20,"Date Range: "_QACBEG_" to "_QACEND
 W !
 I $G(QACIFLG)=1!($G(QACPFLG)=1) Q
 ;I '$D(QAC1DIV) D WRIT2 Q
 S DDD=""
 F  S DDD=$O(QACDIV(DDD)) Q:DDD']""  D
 . I $G(DDD)>0 D INST^QACUTL0(QACDIV(DDD),.QACDV)
 . W !!,"Division: "_$S(DDD=0:"Unknown",1:QACDV)
 . D WRIT2
 Q
WRIT2 ;
 N EE
 S EE=0
 F  S EE=$O(QACLABEL(EE)) Q:EE'>0  D
 . W !,QACLABEL(EE)_", "_COUNT(QACDIV(DDD),QACPCE(EE))
 . I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^QACGEN S QACPFLG=1 D WRIT
 . K QACPFLG
 W !!
 Q
TSK ;
 U IO
 D QACSET(QACFLD)
 D LOOP1^QACSPRD(QACROU,QAQNBEG,QAQNEND,.QACD0)
 D WRIT
 D EXIT
 Q