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
 ;
HEADER ;
 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