QACEMPE ;WCIOFO/VAD-Report By Employee ;02/10/1999
;;2.0;Patient Representative;**9**;07/25/1995
;
MAIN ;
D INIT
D DATDIV^QACUTL0 G:QAQPOP EXIT
I +$G(QAC1DIV) D INST^QACUTL0(QAC1DIV,.QACDVNAM) ; If reporting for one division get the division name to be reported.
;
D GTEMP G:QAQPOP EXIT
;
K %ZIS,IOP S %ZIS="MQ" W ! D ^%ZIS I POP D EXIT Q
;
I $D(IO("Q")) D Q
. S ZTDESC=QACDESC
. S ZTRTN="PROCESS^QACEMPE"
. S ZTSAVE("QACALL")="",ZTSAVE("QACDESC")=""
. S ZTSAVE("QAC1DIV")="",ZTSAVE("QACDVNAM")=""
. S ZTSAVE("QACESEL")="",ZTSAVE("QACINFO")="",ZTSAVE("QACRTN")=""
. S ZTSAVE("QAQRANG")=""
. D TASK^QACUTL0
;
D PROCESS
Q
;
INIT ;
S (QACINFO,QAQPOP)=0,QACDVNAM=""
S QACRTN="QACEMPE"
S QACDESC="Report by Employee"
Q
;
GTEMP ; Get the Employee Selection.
S QACESEL="",QACALL=0
W !!,"Enter an Employee Name or <CR> for ALL: " R QACESEL:DTIME
I QACESEL="^" S QAQPOP=1 Q
I QACESEL="" S QACALL=1 Q
I QACESEL'?.AP W !,$C(7),"INVALID NAME...RE-ENTER NAME!" G GTEMP
S QACESEL=$$TRANS(QACESEL)
;
; Select one Employee.
S QACFIL=200,QACFLDS=.01,QACFLGS="O",QACDATA="^TMP(QACRTN,$J,""DATA"")",QACERR="^TMP(QACRTN,$J,""ERR"")"
D FIND^DIC(QACFIL,,.QACFLDS,QACFLGS,QACESEL,,,,,QACDATA,QACERR)
S QACFOUND=+$G(^TMP(QACRTN,$J,"DATA","DILIST",0))
I 'QACFOUND D G GTEMP
. W !!,$C(7),"EMPLOYEE SELECTION NOT FOUND...<CR> to Continue" R R:DTIME
;
S QACOK=0
I QACFOUND=1 D GTEMP1 Q:QACOK G GTEMP
D GTEMP2 Q:QACOK G GTEMP
Q
;
GTEMP1 ;
S QACREC=^TMP(QACRTN,$J,"DATA","DILIST",1,1)
W !!?5,QACREC
W !!?5,"Is the above Employee the correct one? <Y> " R R:DTIME
S R=$$TRANS(R)
I R="" S R="Y"
I R="Y" S QACESEL=QACREC,QACOK=1 Q
I R'="N" D G GTEMP1
. W !!,"PLEASE ENTER 'Y' or 'N'...<CR> to Continue" R R:DTIME
Q
;
GTEMP2 ;
F I=1:1:QACFOUND D
. S QACREC=^TMP(QACRTN,$J,"DATA","DILIST",1,I)
. W !?5,I,".) ",QACREC
;
W !!?5,"Select one of the above: " R QACNUM:DTIME
I '$L(QACNUM) Q
I QACNUM>QACFOUND D G GTEMP2
. W !!,"MUST SELECT A NUMBER FROM 1-",QACFOUND,"...<CR> to Continue" R R:DTIME
S QACESEL=^TMP(QACRTN,$J,"DATA","DILIST",1,QACNUM)
S QACOK=1
Q
;
PROCESS ;
D SETUP,SORT,RPT
I 'QACINFO D HEADER W !!?26,"* * * NO DATA TO PRINT * * *",!!
D EXIT
Q
;
SETUP ;
K ^TMP(QACRTN,$J)
K QACEMPNM
S (QACQUIT,QACPAGE)=0
S QACHDR2="Date "_QAQRANG
S $P(QACUNDL,"-",78)="-"
S QACDTIM=$$HTE^XLFDT($H,1)
S QACTIME=$P(QACDTIM,"@",2)
S QACTODAY=$P(QACDTIM,"@")_" "_$E(QACTIME,1,5)
Q
;
SORT ; Sort thru the data to accumulate results based upon selection criteria
S QACDATE1=QAQNBEG-1 ; Initialize the starting point for the Date of Contacts.
I '$D(QAC1DIV) S QACDVNAM="NON-DIVISIONAL"
;
; Loop thru ROCs by "Date of Contact"
F S QACDATE1=$O(^QA(745.1,"D",QACDATE1)) Q:(QACDATE1>QAQNEND)!('$L(QACDATE1)) D
. S QACD0=""
. F S QACD0=$O(^QA(745.1,"D",QACDATE1,QACD0)) Q:'$L(QACD0) D
. . K QACOUT
. . D GETS^DIQ(745.1,QACD0,".01;1;2;37","NIE","QACOUT")
. . S QACD0X=QACD0_","
. . S QACROCNO=$G(QACOUT(745.1,QACD0X,.01,"E")) ; Contact Number
. . S QACROCDT=$G(QACOUT(745.1,QACD0X,1,"E")) ; Date of Contact - External
. . S QACPTNO=$G(QACOUT(745.1,QACD0X,2,"I")) ; Patient #
. . S QACPTNAM=$G(QACOUT(745.1,QACD0X,2,"E")) ; Patient Name
. . S QACDOK=1
. . ;
. . ; If site is Multi-divisional set up for the division name.
. . I $D(QAC1DIV) D Q:'QACDOK
. . . S QACDVNO=$G(QACOUT(745.1,QACD0X,37,"I")) ; Division #
. . . I +QAC1DIV,+QAC1DIV'=+QACDVNO S QACDOK=0 Q ; Not the selected Division
. . . S QACDVNAM=$G(QACOUT(745.1,QACD0X,37,"E")) ; Division Name
. . . I '$L(QACDVNAM) S QACDVNAM=" EMPTY"
. . ;
. . ; Get array of Service/Disciplines for an ROC.
. . K QAC3ARAY
. . S QACD1=0
. . F S QACD1=$O(^QA(745.1,QACD0,3,QACD1)) Q:'$L(QACD1) D
. . . I '$D(^QA(745.1,QACD0,3,QACD1,3,"B")) Q
. . . S QACD2=""
. . . F S QACD2=$O(^QA(745.1,QACD0,3,QACD1,3,"B",QACD2)) Q:'$L(QACD2) D
. . . . S QACSVDP=$P($G(^QA(745.55,QACD2,0)),U,1) ; Serv/Disp Name
. . . . S QACD3=""
. . . . F S QACD3=$O(^QA(745.1,QACD0,3,QACD1,3,"B",QACD2,QACD3)) Q:'$L(QACD3) D
. . . . . S QACSEQ=0 F QACSEQ=QACSEQ:1 I '$D(QAC3ARAY(QACSVDP,QACSEQ)) Q
. . . . . S QAC3ARAY(QACSVDP,QACSEQ)=""
. . ;
. . ; Get each Employee for an ROC.
. . S QACD1=0
. . F S QACD1=$O(^QA(745.1,QACD0,8,QACD1)) Q:'$L(QACD1)!(QACD1'?.N) D
. . . S QACENO=$G(^QA(745.1,QACD0,8,QACD1,0)) ; Employee Internal #
. . . S QACENOX=QACENO_","
. . . I '$D(QACEMPNM(200,QACENOX)) D ; If Employee Name not previously accessed get the name.
. . . . D GETS^DIQ(200,QACENO,".01","NE","QACEMPNM")
. . . . I $G(QACEMPNM(200,QACENOX,.01,"E"))="" S ^("E")="Unknown Employee"
. . . S QACENAM=QACEMPNM(200,QACENOX,.01,"E") ; Employee Name
. . . D STORIT
Q
;
STORIT ; Store sorted ROC data in the ^TMP global for reporting purposes.
I 'QACALL,(QACENAM'=QACESEL) Q ; Not selected Employee.
I '$D(^TMP(QACRTN,$J,"ROC",QACROCNO)) D
. S ^TMP(QACRTN,$J,"ROC",QACROCNO)=QACD0_U_QACROCDT_U_QACPTNAM
; Store record for reporting purposes
S (QACSVDP,QACSEQ)=""
F S QACSVDP=$O(QAC3ARAY(QACSVDP)) Q:'$L(QACSVDP) D
. F S QACSEQ=$O(QAC3ARAY(QACSVDP,QACSEQ)) Q:'$L(QACSEQ) D
. . S ^TMP(QACRTN,$J,"RPT",QACDVNAM,QACENAM,QACSVDP,QACROCNO,QACSEQ)=""
Q
;
RPT ; Print the report
U IO
;
; Loop through the Sorted data.
S (QACDVNAM,QACEMPNM,QACSVDP,QACROCNO,QACSEQ)=""
F S QACDVNAM=$O(^TMP(QACRTN,$J,"RPT",QACDVNAM)) Q:QACDVNAM="" D Q:QACQUIT
. F S QACEMPNM=$O(^TMP(QACRTN,$J,"RPT",QACDVNAM,QACEMPNM)) Q:QACEMPNM="" D Q:QACQUIT
. . ;
. . ; New Employee
. . D HEADER Q:QACQUIT
. . F S QACSVDP=$O(^TMP(QACRTN,$J,"RPT",QACDVNAM,QACEMPNM,QACSVDP)) Q:QACSVDP="" D Q:QACQUIT
. . . F S QACROCNO=$O(^TMP(QACRTN,$J,"RPT",QACDVNAM,QACEMPNM,QACSVDP,QACROCNO)) Q:QACROCNO="" D Q:QACQUIT
. . . . ;
. . . . ; Get an array of Issue Text for an ROC.
. . . . K QACITXT
. . . . S QACREC=^TMP(QACRTN,$J,"ROC",QACROCNO)
. . . . S QACD0=$P(QACREC,U),QACROCDT=$P(QACREC,U,2),QACPTNAM=$P(QACREC,U,3)
. . . . I $D(^QA(745.1,QACD0,4,0)) D
. . . . . S DIC=745.1,DA=QACD0,DR=22,DIQ="QACITXT"
. . . . . D EN^DIQ1
. . . . ;
. . . . ; Print the Contact #, Date of Contact and Patient Name
. . . . I $Y>(IOSL-6) D HEADER Q:QACQUIT
. . . . W !!,QACROCNO,?25,QACROCDT,?45,QACPTNAM
. . . . ;
. . . . ; Print the Issue Text if there is any.
. . . . I $D(QACITXT) D Q:QACQUIT
. . . . . S QACD1=""
. . . . . F S QACD1=$O(QACITXT(745.1,QACD0,DR,QACD1)) Q:'$L(QACD1) D Q:QACQUIT
. . . . . . I $Y>(IOSL-6) D HEADER Q:QACQUIT
. . . . . . W !?3,QACITXT(745.1,QACD0,DR,QACD1)
. . . . ;
. . . . F S QACSEQ=$O(^TMP(QACRTN,$J,"RPT",QACDVNAM,QACEMPNM,QACSVDP,QACROCNO,QACSEQ)) Q:QACSEQ="" D Q:QACQUIT
. . . . . ;
. . . . . ; Print a Serv/Sect or Discipline line.
. . . . . I $Y>(IOSL-6) D HEADER Q:QACQUIT
. . . . . W !?6,QACSVDP
Q
;
S QACPAGE=QACPAGE+1
I QACPAGE>1 D Q:QACQUIT
. W $C(7)
. I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S QACQUIT=$S(Y'>0:1,1:0)
;
W:$E(IOST)="C"!(QACPAGE>1) @IOF
W !,QACDESC,?48,QACTODAY,?70,"PAGE ",QACPAGE
W !?(80-$L(QACHDR2))/2,QACHDR2
W !,"Contact #",?25,"Date of Contact",?45,"Patient Name"
W !?3,"Issue Text",!?6,"Serv/Sect or Discipline"
W !,QACUNDL
;
I $D(QAC1DIV) D ; Print the division if site is Multi-divisional.
. S QACDVTXT="Division: "_$S(QACDVNAM=" EMPTY":"EMPTY",1:QACDVNAM)
. I $L(QACDVNAM) W !?(80-$L(QACDVTXT))/2,QACDVTXT S QACINFO=1
;
S QACEMTXT="Employee: "_QACEMPNM
I $L(QACEMPNM) W !?(80-$L(QACEMTXT))/2,QACEMTXT,! S QACINFO=1
Q
;
TRANS(X) ; Module to transform lower-case into uppercase.
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q X
;
EXIT ;
W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
D K^QAQDATE
K ^TMP(QACRTN,$J)
K DA,DIC,DIQ,DIR,DR
K QAC1DIV,QAC3ARAY,QAC4ARAY,QACALL,QACCONT,QACCREC0,QACD0,QACD0X
K QACD1,QACD2,QACD3,QACDATA,QACDATE1,QACDESC,QACDOK,QACDTIM,QACDV
K QACDVNAM,QACDVNO,QACDVTXT,QACEMPNM,QACEMTXT,QACENAM,QACENO,QACENOX
K QACERR,QACESEL,QACFIL,QACFLDS,QACFLGS,QACFOUND,QACHDR2,QACINFO,QACITXT
K QACNUM,QACOK,QACOUT,QACPAGE,QACPTNAM,QACPTNO,QACQUIT,QACREC
K QACROCNO,QACROCDT,QACRTN,QACSEQ,QACSNO,QACSVDP,QACTIME,QACTODAY
K QACUNDL,QAQDTOUT,QAQNBEG,QAQNEND,QAQPOP,QAQRANG
K I,POP,R,X,Y,ZTDESC,ZTRTN,ZTSAVE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQACEMPE 8413 printed Jan 14, 2021@17:15:25 Page 2
QACEMPE ;WCIOFO/VAD-Report By Employee ;02/10/1999
+1 ;;2.0;Patient Representative;**9**;07/25/1995
+2 ;
MAIN ;
+1 DO INIT
+2 DO DATDIV^QACUTL0
if QAQPOP
GOTO EXIT
+3 ; If reporting for one division get the division name to be reported.
IF +$GET(QAC1DIV)
DO INST^QACUTL0(QAC1DIV,.QACDVNAM)
+4 ;
+5 DO GTEMP
if QAQPOP
GOTO EXIT
+6 ;
+7 KILL %ZIS,IOP
SET %ZIS="MQ"
WRITE !
DO ^%ZIS
IF POP
DO EXIT
QUIT
+8 ;
+9 IF $DATA(IO("Q"))
Begin DoDot:1
+10 SET ZTDESC=QACDESC
+11 SET ZTRTN="PROCESS^QACEMPE"
+12 SET ZTSAVE("QACALL")=""
SET ZTSAVE("QACDESC")=""
+13 SET ZTSAVE("QAC1DIV")=""
SET ZTSAVE("QACDVNAM")=""
+14 SET ZTSAVE("QACESEL")=""
SET ZTSAVE("QACINFO")=""
SET ZTSAVE("QACRTN")=""
+15 SET ZTSAVE("QAQRANG")=""
+16 DO TASK^QACUTL0
End DoDot:1
QUIT
+17 ;
+18 DO PROCESS
+19 QUIT
+20 ;
INIT ;
+1 SET (QACINFO,QAQPOP)=0
SET QACDVNAM=""
+2 SET QACRTN="QACEMPE"
+3 SET QACDESC="Report by Employee"
+4 QUIT
+5 ;
GTEMP ; Get the Employee Selection.
+1 SET QACESEL=""
SET QACALL=0
+2 WRITE !!,"Enter an Employee Name or <CR> for ALL: "
READ QACESEL:DTIME
+3 IF QACESEL="^"
SET QAQPOP=1
QUIT
+4 IF QACESEL=""
SET QACALL=1
QUIT
+5 IF QACESEL'?.AP
WRITE !,$CHAR(7),"INVALID NAME...RE-ENTER NAME!"
GOTO GTEMP
+6 SET QACESEL=$$TRANS(QACESEL)
+7 ;
+8 ; Select one Employee.
+9 SET QACFIL=200
SET QACFLDS=.01
SET QACFLGS="O"
SET QACDATA="^TMP(QACRTN,$J,""DATA"")"
SET QACERR="^TMP(QACRTN,$J,""ERR"")"
+10 DO FIND^DIC(QACFIL,,.QACFLDS,QACFLGS,QACESEL,,,,,QACDATA,QACERR)
+11 SET QACFOUND=+$GET(^TMP(QACRTN,$JOB,"DATA","DILIST",0))
+12 IF 'QACFOUND
Begin DoDot:1
+13 WRITE !!,$CHAR(7),"EMPLOYEE SELECTION NOT FOUND...<CR> to Continue"
READ R:DTIME
End DoDot:1
GOTO GTEMP
+14 ;
+15 SET QACOK=0
+16 IF QACFOUND=1
DO GTEMP1
if QACOK
QUIT
GOTO GTEMP
+17 DO GTEMP2
if QACOK
QUIT
GOTO GTEMP
+18 QUIT
+19 ;
GTEMP1 ;
+1 SET QACREC=^TMP(QACRTN,$JOB,"DATA","DILIST",1,1)
+2 WRITE !!?5,QACREC
+3 WRITE !!?5,"Is the above Employee the correct one? <Y> "
READ R:DTIME
+4 SET R=$$TRANS(R)
+5 IF R=""
SET R="Y"
+6 IF R="Y"
SET QACESEL=QACREC
SET QACOK=1
QUIT
+7 IF R'="N"
Begin DoDot:1
+8 WRITE !!,"PLEASE ENTER 'Y' or 'N'...<CR> to Continue"
READ R:DTIME
End DoDot:1
GOTO GTEMP1
+9 QUIT
+10 ;
GTEMP2 ;
+1 FOR I=1:1:QACFOUND
Begin DoDot:1
+2 SET QACREC=^TMP(QACRTN,$JOB,"DATA","DILIST",1,I)
+3 WRITE !?5,I,".) ",QACREC
End DoDot:1
+4 ;
+5 WRITE !!?5,"Select one of the above: "
READ QACNUM:DTIME
+6 IF '$LENGTH(QACNUM)
QUIT
+7 IF QACNUM>QACFOUND
Begin DoDot:1
+8 WRITE !!,"MUST SELECT A NUMBER FROM 1-",QACFOUND,"...<CR> to Continue"
READ R:DTIME
End DoDot:1
GOTO GTEMP2
+9 SET QACESEL=^TMP(QACRTN,$JOB,"DATA","DILIST",1,QACNUM)
+10 SET QACOK=1
+11 QUIT
+12 ;
PROCESS ;
+1 DO SETUP
DO SORT
DO RPT
+2 IF 'QACINFO
DO HEADER
WRITE !!?26,"* * * NO DATA TO PRINT * * *",!!
+3 DO EXIT
+4 QUIT
+5 ;
SETUP ;
+1 KILL ^TMP(QACRTN,$JOB)
+2 KILL QACEMPNM
+3 SET (QACQUIT,QACPAGE)=0
+4 SET QACHDR2="Date "_QAQRANG
+5 SET $PIECE(QACUNDL,"-",78)="-"
+6 SET QACDTIM=$$HTE^XLFDT($HOROLOG,1)
+7 SET QACTIME=$PIECE(QACDTIM,"@",2)
+8 SET QACTODAY=$PIECE(QACDTIM,"@")_" "_$EXTRACT(QACTIME,1,5)
+9 QUIT
+10 ;
SORT ; Sort thru the data to accumulate results based upon selection criteria
+1 ; Initialize the starting point for the Date of Contacts.
SET QACDATE1=QAQNBEG-1
+2 IF '$DATA(QAC1DIV)
SET QACDVNAM="NON-DIVISIONAL"
+3 ;
+4 ; Loop thru ROCs by "Date of Contact"
+5 FOR
SET QACDATE1=$ORDER(^QA(745.1,"D",QACDATE1))
if (QACDATE1>QAQNEND)!('$LENGTH(QACDATE1))
QUIT
Begin DoDot:1
+6 SET QACD0=""
+7 FOR
SET QACD0=$ORDER(^QA(745.1,"D",QACDATE1,QACD0))
if '$LENGTH(QACD0)
QUIT
Begin DoDot:2
+8 KILL QACOUT
+9 DO GETS^DIQ(745.1,QACD0,".01;1;2;37","NIE","QACOUT")
+10 SET QACD0X=QACD0_","
+11 ; Contact Number
SET QACROCNO=$GET(QACOUT(745.1,QACD0X,.01,"E"))
+12 ; Date of Contact - External
SET QACROCDT=$GET(QACOUT(745.1,QACD0X,1,"E"))
+13 ; Patient #
SET QACPTNO=$GET(QACOUT(745.1,QACD0X,2,"I"))
+14 ; Patient Name
SET QACPTNAM=$GET(QACOUT(745.1,QACD0X,2,"E"))
+15 SET QACDOK=1
+16 ;
+17 ; If site is Multi-divisional set up for the division name.
+18 IF $DATA(QAC1DIV)
Begin DoDot:3
+19 ; Division #
SET QACDVNO=$GET(QACOUT(745.1,QACD0X,37,"I"))
+20 ; Not the selected Division
IF +QAC1DIV
IF +QAC1DIV'=+QACDVNO
SET QACDOK=0
QUIT
+21 ; Division Name
SET QACDVNAM=$GET(QACOUT(745.1,QACD0X,37,"E"))
+22 IF '$LENGTH(QACDVNAM)
SET QACDVNAM=" EMPTY"
End DoDot:3
if 'QACDOK
QUIT
+23 ;
+24 ; Get array of Service/Disciplines for an ROC.
+25 KILL QAC3ARAY
+26 SET QACD1=0
+27 FOR
SET QACD1=$ORDER(^QA(745.1,QACD0,3,QACD1))
if '$LENGTH(QACD1)
QUIT
Begin DoDot:3
+28 IF '$DATA(^QA(745.1,QACD0,3,QACD1,3,"B"))
QUIT
+29 SET QACD2=""
+30 FOR
SET QACD2=$ORDER(^QA(745.1,QACD0,3,QACD1,3,"B",QACD2))
if '$LENGTH(QACD2)
QUIT
Begin DoDot:4
+31 ; Serv/Disp Name
SET QACSVDP=$PIECE($GET(^QA(745.55,QACD2,0)),U,1)
+32 SET QACD3=""
+33 FOR
SET QACD3=$ORDER(^QA(745.1,QACD0,3,QACD1,3,"B",QACD2,QACD3))
if '$LENGTH(QACD3)
QUIT
Begin DoDot:5
+34 SET QACSEQ=0
FOR QACSEQ=QACSEQ:1
IF '$DATA(QAC3ARAY(QACSVDP,QACSEQ))
QUIT
+35 SET QAC3ARAY(QACSVDP,QACSEQ)=""
End DoDot:5
End DoDot:4
End DoDot:3
+36 ;
+37 ; Get each Employee for an ROC.
+38 SET QACD1=0
+39 FOR
SET QACD1=$ORDER(^QA(745.1,QACD0,8,QACD1))
if '$LENGTH(QACD1)!(QACD1'?.N)
QUIT
Begin DoDot:3
+40 ; Employee Internal #
SET QACENO=$GET(^QA(745.1,QACD0,8,QACD1,0))
+41 SET QACENOX=QACENO_","
+42 ; If Employee Name not previously accessed get the name.
IF '$DATA(QACEMPNM(200,QACENOX))
Begin DoDot:4
+43 DO GETS^DIQ(200,QACENO,".01","NE","QACEMPNM")
+44 IF $GET(QACEMPNM(200,QACENOX,.01,"E"))=""
SET ^("E")="Unknown Employee"
End DoDot:4
+45 ; Employee Name
SET QACENAM=QACEMPNM(200,QACENOX,.01,"E")
+46 DO STORIT
End DoDot:3
End DoDot:2
End DoDot:1
+47 QUIT
+48 ;
STORIT ; Store sorted ROC data in the ^TMP global for reporting purposes.
+1 ; Not selected Employee.
IF 'QACALL
IF (QACENAM'=QACESEL)
QUIT
+2 IF '$DATA(^TMP(QACRTN,$JOB,"ROC",QACROCNO))
Begin DoDot:1
+3 SET ^TMP(QACRTN,$JOB,"ROC",QACROCNO)=QACD0_U_QACROCDT_U_QACPTNAM
End DoDot:1
+4 ; Store record for reporting purposes
+5 SET (QACSVDP,QACSEQ)=""
+6 FOR
SET QACSVDP=$ORDER(QAC3ARAY(QACSVDP))
if '$LENGTH(QACSVDP)
QUIT
Begin DoDot:1
+7 FOR
SET QACSEQ=$ORDER(QAC3ARAY(QACSVDP,QACSEQ))
if '$LENGTH(QACSEQ)
QUIT
Begin DoDot:2
+8 SET ^TMP(QACRTN,$JOB,"RPT",QACDVNAM,QACENAM,QACSVDP,QACROCNO,QACSEQ)=""
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
RPT ; Print the report
+1 USE IO
+2 ;
+3 ; Loop through the Sorted data.
+4 SET (QACDVNAM,QACEMPNM,QACSVDP,QACROCNO,QACSEQ)=""
+5 FOR
SET QACDVNAM=$ORDER(^TMP(QACRTN,$JOB,"RPT",QACDVNAM))
if QACDVNAM=""
QUIT
Begin DoDot:1
+6 FOR
SET QACEMPNM=$ORDER(^TMP(QACRTN,$JOB,"RPT",QACDVNAM,QACEMPNM))
if QACEMPNM=""
QUIT
Begin DoDot:2
+7 ;
+8 ; New Employee
+9 DO HEADER
if QACQUIT
QUIT
+10 FOR
SET QACSVDP=$ORDER(^TMP(QACRTN,$JOB,"RPT",QACDVNAM,QACEMPNM,QACSVDP))
if QACSVDP=""
QUIT
Begin DoDot:3
+11 FOR
SET QACROCNO=$ORDER(^TMP(QACRTN,$JOB,"RPT",QACDVNAM,QACEMPNM,QACSVDP,QACROCNO))
if QACROCNO=""
QUIT
Begin DoDot:4
+12 ;
+13 ; Get an array of Issue Text for an ROC.
+14 KILL QACITXT
+15 SET QACREC=^TMP(QACRTN,$JOB,"ROC",QACROCNO)
+16 SET QACD0=$PIECE(QACREC,U)
SET QACROCDT=$PIECE(QACREC,U,2)
SET QACPTNAM=$PIECE(QACREC,U,3)
+17 IF $DATA(^QA(745.1,QACD0,4,0))
Begin DoDot:5
+18 SET DIC=745.1
SET DA=QACD0
SET DR=22
SET DIQ="QACITXT"
+19 DO EN^DIQ1
End DoDot:5
+20 ;
+21 ; Print the Contact #, Date of Contact and Patient Name
+22 IF $Y>(IOSL-6)
DO HEADER
if QACQUIT
QUIT
+23 WRITE !!,QACROCNO,?25,QACROCDT,?45,QACPTNAM
+24 ;
+25 ; Print the Issue Text if there is any.
+26 IF $DATA(QACITXT)
Begin DoDot:5
+27 SET QACD1=""
+28 FOR
SET QACD1=$ORDER(QACITXT(745.1,QACD0,DR,QACD1))
if '$LENGTH(QACD1)
QUIT
Begin DoDot:6
+29 IF $Y>(IOSL-6)
DO HEADER
if QACQUIT
QUIT
+30 WRITE !?3,QACITXT(745.1,QACD0,DR,QACD1)
End DoDot:6
if QACQUIT
QUIT
End DoDot:5
if QACQUIT
QUIT
+31 ;
+32 FOR
SET QACSEQ=$ORDER(^TMP(QACRTN,$JOB,"RPT",QACDVNAM,QACEMPNM,QACSVDP,QACROCNO,QACSEQ))
if QACSEQ=""
QUIT
Begin DoDot:5
+33 ;
+34 ; Print a Serv/Sect or Discipline line.
+35 IF $Y>(IOSL-6)
DO HEADER
if QACQUIT
QUIT
+36 WRITE !?6,QACSVDP
End DoDot:5
if QACQUIT
QUIT
End DoDot:4
if QACQUIT
QUIT
End DoDot:3
if QACQUIT
QUIT
End DoDot:2
if QACQUIT
QUIT
End DoDot:1
if QACQUIT
QUIT
+37 QUIT
+38 ;
+1 SET QACPAGE=QACPAGE+1
+2 IF QACPAGE>1
Begin DoDot:1
+3 WRITE $CHAR(7)
+4 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET QACQUIT=$SELECT(Y'>0:1,1:0)
End DoDot:1
if QACQUIT
QUIT
+5 ;
+6 if $EXTRACT(IOST)="C"!(QACPAGE>1)
WRITE @IOF
+7 WRITE !,QACDESC,?48,QACTODAY,?70,"PAGE ",QACPAGE
+8 WRITE !?(80-$LENGTH(QACHDR2))/2,QACHDR2
+9 WRITE !,"Contact #",?25,"Date of Contact",?45,"Patient Name"
+10 WRITE !?3,"Issue Text",!?6,"Serv/Sect or Discipline"
+11 WRITE !,QACUNDL
+12 ;
+13 ; Print the division if site is Multi-divisional.
IF $DATA(QAC1DIV)
Begin DoDot:1
+14 SET QACDVTXT="Division: "_$SELECT(QACDVNAM=" EMPTY":"EMPTY",1:QACDVNAM)
+15 IF $LENGTH(QACDVNAM)
WRITE !?(80-$LENGTH(QACDVTXT))/2,QACDVTXT
SET QACINFO=1
End DoDot:1
+16 ;
+17 SET QACEMTXT="Employee: "_QACEMPNM
+18 IF $LENGTH(QACEMPNM)
WRITE !?(80-$LENGTH(QACEMTXT))/2,QACEMTXT,!
SET QACINFO=1
+19 QUIT
+20 ;
TRANS(X) ; Module to transform lower-case into uppercase.
+1 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 QUIT X
+3 ;
EXIT ;
+1 WRITE !
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 DO K^QAQDATE
+3 KILL ^TMP(QACRTN,$JOB)
+4 KILL DA,DIC,DIQ,DIR,DR
+5 KILL QAC1DIV,QAC3ARAY,QAC4ARAY,QACALL,QACCONT,QACCREC0,QACD0,QACD0X
+6 KILL QACD1,QACD2,QACD3,QACDATA,QACDATE1,QACDESC,QACDOK,QACDTIM,QACDV
+7 KILL QACDVNAM,QACDVNO,QACDVTXT,QACEMPNM,QACEMTXT,QACENAM,QACENO,QACENOX
+8 KILL QACERR,QACESEL,QACFIL,QACFLDS,QACFLGS,QACFOUND,QACHDR2,QACINFO,QACITXT
+9 KILL QACNUM,QACOK,QACOUT,QACPAGE,QACPTNAM,QACPTNO,QACQUIT,QACREC
+10 KILL QACROCNO,QACROCDT,QACRTN,QACSEQ,QACSNO,QACSVDP,QACTIME,QACTODAY
+11 KILL QACUNDL,QAQDTOUT,QAQNBEG,QAQNEND,QAQPOP,QAQRANG
+12 KILL I,POP,R,X,Y,ZTDESC,ZTRTN,ZTSAVE
+13 QUIT
