162 lines
5.2 KiB
Mathematica
162 lines
5.2 KiB
Mathematica
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
|