Routine: AGBENPRD

AGBENPRD ;IHS/ASDS/TPF - PRINT BENEFIT PRODUCTIVITY REPORT; MAR 19, 2010

 ;;7.1;PATIENT REGISTRATION;**2,4,7,11**;AUG 25, 2005;Build 1

 ;IHS/OIT/NKD AG*7.1*11 ADDITIONAL OVERALL STATUS ENTRIES

START ;

 D INIT

ASKBEG ;

W !

 S %DT("A")="Enter the BEGINNING DATE for this report: "

 S %DT="APE"

 D ^%DT

 Q:X=""!(X[U)

 S AGBEG=Y

ASKEND ;

W !

 S %DT("A")="Enter the ENDING DATE for this report: "

 S %DT="APE"

 D ^%DT

 G:X=""!(X[U)!(Y<0) ASKBEG

 S AGEND=Y

 I AGBEG>AGEND W !!,*7,"INVALID ENTRY - The END is before the BEGINNING." G ASKBEG

 S AGBEGX=$$FMTE^XLFDT(AGBEG,5)

 S AGENDX=$$FMTE^XLFDT(AGEND,5)

ASKTYPE ;

 K DIR

 S DIR(0)="SO^1:RECEIVER;2:APPTYPE"

 S DIR("L",1)="Which Type of report do you wish?"

 S DIR("L",2)="1... PERSON RECEIVING APPLICATION"

 S DIR("L")="2... APPLICATION TYPE"

 D ^DIR

 G:'Y!($D(DTOUT))!($D(DIROUT))!($D(DUOUT)) ASKEND

 S AGRPTTYP=Y(0)

 D DEV Q:POP

 I $D(ZTSK) W !,"Report queued with task # ",$G(ZTSK) K DIR S DIR(0)="E" D ^DIR Q

 U IO

 D QUEUED

 D HOME^%ZIS

 D ^%ZISC

QUEUED ;

 D PROCESS

 D PRINT

PROCESS ;

 N IEN,REC

 K ^XTMP("AGBENPRD",$J)

 S AGBEG=AGBEG-.01

 F  S AGBEG=$O(^AUPNAPPS("D",AGBEG)) Q:AGBEG=""!(AGBEG>AGEND)  D

 .S IEN=""

 .F  S IEN=$O(^AUPNAPPS("D",AGBEG,IEN)) Q:IEN=""  D

 ..S REC=""

 ..F  S REC=$O(^AUPNAPPS("D",AGBEG,IEN,REC)) Q:REC=""  D

 ...S AGTYPE=$P($G(^AUPNAPPS(IEN,11,REC,0)),U,2)

 ...I AGTYPE="" S AGTYPE="UNPOPULATED"

 ...E  S AGTYPE=$P($G(^AUPNAPPT(AGTYPE,0)),U)

 ...S PERSREC=$P($G(^AUPNAPPS(IEN,11,REC,0)),U,3)

 ...I PERSREC="" S PERSREC="UNPOPULATED"

 ...E  S PERSREC=$P($G(^VA(200,PERSREC,0)),U)

 ...S OVERSTAT=$P($G(^AUPNAPPS(IEN,11,REC,0)),U,4)

 ...S IENS=REC_","_IEN_","

 ...Q:OVERSTAT=""

 ...I OVERSTAT="" S OVERSTAT="UNPOPULATED"

 ...E  S OVERSTAT=$$GET1^DIQ(9000045.11,IENS,.04,"I","AGDATA","AGERR")

 ...;IHS/OIT/NKD AG*7.1*11 CHANGED SETTING OF TMP GLOBAL TO INCLUDE OFFSET AND ADDED 2 NEW ENTRIES

 ...;S OVERSTAT=$S(OVERSTAT="A":1_U_OVERSTAT,OVERSTAT="D":2_U_OVERSTAT,OVERSTAT="R":3_U_OVERSTAT,OVERSTAT="RE":4_U_OVERSTAT,OVERSTAT="F":5_U_OVERSTAT,OVERSTAT="E":6_U_OVERSTAT,OVERSTAT="P":7_U_OVERSTAT,1:"UNDEFINED")

 ...S OVERSTAT=$S(OVERSTAT="A":17_U_OVERSTAT,OVERSTAT="D":25_U_OVERSTAT,OVERSTAT="R":32_U_OVERSTAT,OVERSTAT="RE":39_U_OVERSTAT,OVERSTAT="F":47_U_OVERSTAT,OVERSTAT="E":54_U_OVERSTAT,OVERSTAT="P":60_U_OVERSTAT,1:OVERSTAT)

 ...S:OVERSTAT'[U OVERSTAT=$S(OVERSTAT="O":68_U_OVERSTAT,OVERSTAT="S":75_U_OVERSTAT,1:"UNDEFINED")

 ...S SUB3=$S(AGRPTTYP="APPTYPE":AGTYPE,1:PERSREC)

 ...S:SUB3="" SUB3="UNPOPULATED"

 ...S ^XTMP("AGBENPRD",$J,SUB3,OVERSTAT)=$G(^XTMP("AGBENPRD",$J,SUB3,OVERSTAT))+1

 ...S ^XTMP("AGBENPRD",$J,"~",OVERSTAT)=$G(^XTMP("AGBENPRD",$J,"~",OVERSTAT))+1

PRINT ;

 D HDR

 D SUBHDR

 S APPTYPE=""

 N ESC

 ;F  S APPTYPE=$O(^XTMP("AGBENPRD",$J,APPTYPE)) Q:APPTYPE=""!(APPTYPE="~")  D

 ;AG*7.1*7/IHS/SD/AR 02/23/2010

 F  S APPTYPE=$O(^XTMP("AGBENPRD",$J,APPTYPE)) Q:APPTYPE=""!(APPTYPE="~")!$G(ESC)  D

 .W !,$E(APPTYPE,1,15)

 .S OVERSTAT=""

 .F  S OVERSTAT=$O(^XTMP("AGBENPRD",$J,APPTYPE,OVERSTAT)) Q:OVERSTAT=""  D

 ..S STATUS=$P(OVERSTAT,U,2)

 ..;IHS/OIT/NKD AG*7.1*11 CHANGED $S FOR OFFSET TO USE 1ST PIECE IN TMP GLOBAL

 ..;S OFFSET=$S(STATUS="A":18,STATUS="D":28,STATUS="R":37,STATUS="RE":47,STATUS="F":58,STATUS="E":66,STATUS="P":75,1:0)

 ..S OFFSET=+$P(OVERSTAT,U,1)

 ..;I '$D(ZTQUEUED) I ($Y>(IOSL-4)!($Y=(IOSL-4))),(IOST[("C-")) W !! K DIR S DIR(0)="E" D ^DIR D HDR,SUBHDR Q

 ..;AG*7.1*7/IHS/SD/AR 02/23/2010

 ..I '$D(ZTQUEUED) I ($Y>(IOSL-4)!($Y=(IOSL-4))),(IOST[("C-")) W !! K DIR S DIR(0)="E" D ^DIR S ESC=X=U D HDR,SUBHDR Q

 ..I ($Y>(IOSL-4)!($Y=(IOSL-4))),(IOST'[("C-")) D HDR,SUBHDR

 ..W ?OFFSET,$G(^XTMP("AGBENPRD",$J,APPTYPE,OVERSTAT))

 I $G(ESC) K ^XTMP("AGBENPRD",$J) Q

 W !!,AGDASH

 W !,"TOTALS"

 S OVERSTAT=""

 F  S OVERSTAT=$O(^XTMP("AGBENPRD",$J,"~",OVERSTAT)) Q:OVERSTAT=""  D

 .Q:OVERSTAT=0

 .Q:STATUS="UNDEFINED"

 .S STATUS=$P(OVERSTAT,U,2)

 .;IHS/OIT/NKD AG*7.1*11 CHANGED $S FOR OFFSET TO USE 1ST PIECE IN TMP GLOBAL

 .;S OFFSET=$S(STATUS="A":18,STATUS="D":28,STATUS="R":37,STATUS="RE":47,STATUS="F":58,STATUS="E":66,STATUS="P":75,1:0)

 .S OFFSET=+$P(OVERSTAT,U,1)

 .W ?OFFSET,$G(^XTMP("AGBENPRD",$J,"~",OVERSTAT))

 D ^%ZISC

 I '$D(ZTQUEUED) I $Y>IOSL-4,(IOST[("C-")) W !! K DIR S DIR(0)="E" D ^DIR

 K ^XTMP("AGBENPRD",$J)

INIT ;

 S AGUSER=$P($G(^VA(200,DUZ,0)),U)

 ;S AGLOC=$P($G(^AUTTLOC(DUZ(2),0)),U,2)

 S AGLOC=$P($G(^AUTTLOC(DUZ(2),0)),U)  ;AG*7.1*4 DIDN'T WANT SHORT NAME

 S AGRPTNAM="BENEFIT COORDINATOR PRODUCTIVITY REPORT"

 X ^%ZOSF("UCI") S AGUCI=Y

 D NOW^%DTC

 S Y=% X ^DD("DD")

 S AGRPTDT=Y

 S AGPAGE=0

 S $P(AGDASH,"-",81)=""

HDR ;

 S AGPAGE=AGPAGE+1

 W @IOF

 W AGUSER,?70,"Page ",AGPAGE

 W !,$$C^XBFUNC(AGLOC)

 W !,$$C^XBFUNC(AGRPTNAM)

 W !,$$C^XBFUNC("UCI: "_AGUCI)

 W !,$$C^XBFUNC("Report Date: "_AGRPTDT)

 S STR="Date range From "_AGBEGX_" to "_AGENDX

 ;W !,$$C^XBFUNC("Date range From "_AGBEGX) W " to ",AGENDX

 W !,$$C^XBFUNC(STR)

SUBHDR ;

 W !!

 W $S(AGRPTTYP="RECEIVER":"PERSON",1:"APPLICATION")

 ;IHS/OIT/NKD AG*7.1*11 ABBREVIATED COLUMN HEADERS TO FIT ADDITIONAL ENTRIES

 ;W ?36,"RE-",?53,"FOLLOWUP",?63,"ENTERED"

W !

 W $S(AGRPTTYP="RECEIVER":"RECEIVING",1:"TYPE")

 ;IHS/OIT/NKD AG*7.1*11  ABBREVIATED COLUMN HEADERS TO FIT ADDITIONAL ENTRIES

 ;W ?14,"APPROVED",?24,"DENIED",?33,"SUBMITTED",?43,"REFUSED",?54,"NEEDED",?62,"IN ERROR",?72,"PENDING"

 W ?14,"APPROVED",?23,"DENIED",?30,"RESUB",?36,"REFUSED",?44,"FOLLOWUP",?53,"ERR",?57,"PENDING",?65,"OVERINC",?73,"SCREEN"

 W !,AGDASH

W !

DEV ;

 K %ZIS,ZTSK

 S %ZIS="OPQ"

 D ^%ZIS

 Q:POP

 Q:'$D(IO("Q"))

 S ZTRTN="QUEUED^AGBENPRD",ZTDESC=AGRPTNAM

 S ZTSAVE("AG*")=""

 D ^%ZTLOAD

AGBENPRD  ;IHS/ASDS/TPF - PRINT BENEFIT PRODUCTIVITY REPORT; MAR 19, 2010

 +1       ;;7.1;PATIENT REGISTRATION;**2,4,7,11**;AUG 25, 2005;Build 1

 +2       ;IHS/OIT/NKD AG*7.1*11 ADDITIONAL OVERALL STATUS ENTRIES

 +3       ;

START     ;

 +1        DO INIT

ASKBEG    ;

 +1        WRITE !

 +2        SET %DT("A")="Enter the BEGINNING DATE for this report: "

 +3        SET %DT="APE"

 +4        DO ^%DT

 +5        IF X=""!(X[U)

               QUIT

 +6        SET AGBEG=Y

ASKEND    ;

 +1        WRITE !

 +2        SET %DT("A")="Enter the ENDING DATE for this report: "

 +3        SET %DT="APE"

 +4        DO ^%DT

 +5        IF X=""!(X[U)!(Y<0)

               GOTO ASKBEG

 +6        SET AGEND=Y

 +7        IF AGBEG>AGEND

               WRITE !!,*7,"INVALID ENTRY - The END is before the BEGINNING."

               GOTO ASKBEG

 +8        SET AGBEGX=$$FMTE^XLFDT(AGBEG,5)

 +9        SET AGENDX=$$FMTE^XLFDT(AGEND,5)

 +10      ;

ASKTYPE   ;

 +1        KILL DIR

 +2        SET DIR(0)="SO^1:RECEIVER;2:APPTYPE"

 +3        SET DIR("L",1)="Which Type of report do you wish?"

 +4        SET DIR("L",2)="1... PERSON RECEIVING APPLICATION"

 +5        SET DIR("L")="2... APPLICATION TYPE"

 +6        DO ^DIR

 +7        IF 'Y!($DATA(DTOUT))!($DATA(DIROUT))!($DATA(DUOUT))

               GOTO ASKEND

 +8        SET AGRPTTYP=Y(0)

 +9       ;

 +10       DO DEV

           IF POP

               QUIT

 +11       IF $DATA(ZTSK)

               WRITE !,"Report queued with task # ",$GET(ZTSK)

               KILL DIR

               SET DIR(0)="E"

               DO ^DIR

               QUIT

 +12       USE IO

 +13       DO QUEUED

 +14       DO HOME^%ZIS

 +15       DO ^%ZISC

 +16       QUIT

QUEUED    ;

 +1        DO PROCESS

 +2        DO PRINT

 +3        QUIT

PROCESS   ;

 +1        NEW IEN,REC

 +2        KILL ^XTMP("AGBENPRD",$JOB)

 +3        SET AGBEG=AGBEG-.01

 +4        FOR

               SET AGBEG=$ORDER(^AUPNAPPS("D",AGBEG))

               IF AGBEG=""!(AGBEG>AGEND)

                   QUIT

               Begin DoDot:1

 +5                SET IEN=""

 +6                FOR

                       SET IEN=$ORDER(^AUPNAPPS("D",AGBEG,IEN))

                       IF IEN=""

                           QUIT

                       Begin DoDot:2

 +7                        SET REC=""

 +8                        FOR

                               SET REC=$ORDER(^AUPNAPPS("D",AGBEG,IEN,REC))

                               IF REC=""

                                   QUIT

                               Begin DoDot:3

 +9                                SET AGTYPE=$PIECE($GET(^AUPNAPPS(IEN,11,REC,0)),U,2)

 +10                               IF AGTYPE=""

                                       SET AGTYPE="UNPOPULATED"

 +11                              IF '$TEST

                                       SET AGTYPE=$PIECE($GET(^AUPNAPPT(AGTYPE,0)),U)

 +12                               SET PERSREC=$PIECE($GET(^AUPNAPPS(IEN,11,REC,0)),U,3)

 +13                               IF PERSREC=""

                                       SET PERSREC="UNPOPULATED"

 +14                              IF '$TEST

                                       SET PERSREC=$PIECE($GET(^VA(200,PERSREC,0)),U)

 +15                               SET OVERSTAT=$PIECE($GET(^AUPNAPPS(IEN,11,REC,0)),U,4)

 +16                               SET IENS=REC_","_IEN_","

 +17                               IF OVERSTAT=""

                                       QUIT

 +18                               IF OVERSTAT=""

                                       SET OVERSTAT="UNPOPULATED"

 +19                              IF '$TEST

                                       SET OVERSTAT=$$GET1^DIQ(9000045.11,IENS,.04,"I","AGDATA","AGERR")

 +20      ;IHS/OIT/NKD AG*7.1*11 CHANGED SETTING OF TMP GLOBAL TO INCLUDE OFFSET AND ADDED 2 NEW ENTRIES

 +21      ;S OVERSTAT=$S(OVERSTAT="A":1_U_OVERSTAT,OVERSTAT="D":2_U_OVERSTAT,OVERSTAT="R":3_U_OVERSTAT,OVERSTAT="RE":4_U_OVERSTAT,OVERSTAT="F":5_U_OVERSTAT,OVERSTAT="E":6_U_OVERSTAT,OVERSTAT="P":7_U_OVERSTAT,1:"UNDEFINED")

 +22                               SET OVERSTAT=$SELECT(OVERSTAT="A":17_U_OVERSTAT,OVERSTAT="D":25_U_OVERSTAT,OVERSTAT="R":32_U_OVERSTAT,OVERSTAT="RE":39_U_OVERSTAT,OVERSTAT="F":47_U_OVERSTAT,OVERSTAT="E":54_U_OVERSTAT,OVERSTAT="P":60_U_OVERSTAT,1:OVERSTA

T)

 +23                               IF OVERSTAT'[U

                                       SET OVERSTAT=$SELECT(OVERSTAT="O":68_U_OVERSTAT,OVERSTAT="S":75_U_OVERSTAT,1:"UNDEFINED")

 +24                               SET SUB3=$SELECT(AGRPTTYP="APPTYPE":AGTYPE,1:PERSREC)

 +25                               IF SUB3=""

                                       SET SUB3="UNPOPULATED"

 +26                               SET ^XTMP("AGBENPRD",$JOB,SUB3,OVERSTAT)=$GET(^XTMP("AGBENPRD",$JOB,SUB3,OVERSTAT))+1

 +27                               SET ^XTMP("AGBENPRD",$JOB,"~",OVERSTAT)=$GET(^XTMP("AGBENPRD",$JOB,"~",OVERSTAT))+1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +28       QUIT

PRINT     ;

 +1        DO HDR

 +2        DO SUBHDR

 +3        SET APPTYPE=""

 +4        NEW ESC

 +5       ;F  S APPTYPE=$O(^XTMP("AGBENPRD",$J,APPTYPE)) Q:APPTYPE=""!(APPTYPE="~")  D

 +6       ;AG*7.1*7/IHS/SD/AR 02/23/2010

 +7        FOR

               SET APPTYPE=$ORDER(^XTMP("AGBENPRD",$JOB,APPTYPE))

               IF APPTYPE=""!(APPTYPE="~")!$GET(ESC)

                   QUIT

               Begin DoDot:1

 +8                WRITE !,$EXTRACT(APPTYPE,1,15)

 +9                SET OVERSTAT=""

 +10               FOR

                       SET OVERSTAT=$ORDER(^XTMP("AGBENPRD",$JOB,APPTYPE,OVERSTAT))

                       IF OVERSTAT=""

                           QUIT

                       Begin DoDot:2

 +11                       SET STATUS=$PIECE(OVERSTAT,U,2)

 +12      ;IHS/OIT/NKD AG*7.1*11 CHANGED $S FOR OFFSET TO USE 1ST PIECE IN TMP GLOBAL

 +13      ;S OFFSET=$S(STATUS="A":18,STATUS="D":28,STATUS="R":37,STATUS="RE":47,STATUS="F":58,STATUS="E":66,STATUS="P":75,1:0)

 +14                       SET OFFSET=+$PIECE(OVERSTAT,U,1)

 +15      ;I '$D(ZTQUEUED) I ($Y>(IOSL-4)!($Y=(IOSL-4))),(IOST[("C-")) W !! K DIR S DIR(0)="E" D ^DIR D HDR,SUBHDR Q

 +16      ;AG*7.1*7/IHS/SD/AR 02/23/2010

 +17                       IF '$DATA(ZTQUEUED)

                               IF ($Y>(IOSL-4)!($Y=(IOSL-4)))

                                   IF (IOST[("C-"))

                                       WRITE !!

                                       KILL DIR

                                       SET DIR(0)="E"

                                       DO ^DIR

                                       SET ESC=X=U

                                       DO HDR

                                       DO SUBHDR

                                       QUIT

 +18                       IF ($Y>(IOSL-4)!($Y=(IOSL-4)))

                               IF (IOST'[("C-"))

                                   DO HDR

                                   DO SUBHDR

 +19                       WRITE ?OFFSET,$GET(^XTMP("AGBENPRD",$JOB,APPTYPE,OVERSTAT))

                       End DoDot:2

               End DoDot:1

 +20       IF $GET(ESC)

               KILL ^XTMP("AGBENPRD",$JOB)

               QUIT

 +21       WRITE !!,AGDASH

 +22       WRITE !,"TOTALS"

 +23       SET OVERSTAT=""

 +24       FOR

               SET OVERSTAT=$ORDER(^XTMP("AGBENPRD",$JOB,"~",OVERSTAT))

               IF OVERSTAT=""

                   QUIT

               Begin DoDot:1

 +25               IF OVERSTAT=0

                       QUIT

 +26               IF STATUS="UNDEFINED"

                       QUIT

 +27               SET STATUS=$PIECE(OVERSTAT,U,2)

 +28      ;IHS/OIT/NKD AG*7.1*11 CHANGED $S FOR OFFSET TO USE 1ST PIECE IN TMP GLOBAL

 +29      ;S OFFSET=$S(STATUS="A":18,STATUS="D":28,STATUS="R":37,STATUS="RE":47,STATUS="F":58,STATUS="E":66,STATUS="P":75,1:0)

 +30               SET OFFSET=+$PIECE(OVERSTAT,U,1)

 +31               WRITE ?OFFSET,$GET(^XTMP("AGBENPRD",$JOB,"~",OVERSTAT))

               End DoDot:1

 +32       DO ^%ZISC

 +33       IF '$DATA(ZTQUEUED)

               IF $Y>IOSL-4

                   IF (IOST[("C-"))

                       WRITE !!

                       KILL DIR

                       SET DIR(0)="E"

                       DO ^DIR

 +34       KILL ^XTMP("AGBENPRD",$JOB)

 +35       QUIT

INIT      ;

 +1        SET AGUSER=$PIECE($GET(^VA(200,DUZ,0)),U)

 +2       ;S AGLOC=$P($G(^AUTTLOC(DUZ(2),0)),U,2)

 +3       ;AG*7.1*4 DIDN'T WANT SHORT NAME

           SET AGLOC=$PIECE($GET(^AUTTLOC(DUZ(2),0)),U)

 +4        SET AGRPTNAM="BENEFIT COORDINATOR PRODUCTIVITY REPORT"

 +5        XECUTE ^%ZOSF("UCI")

           SET AGUCI=Y

 +6        DO NOW^%DTC

 +7        SET Y=%

           XECUTE ^DD("DD")

 +8        SET AGRPTDT=Y

 +9        SET AGPAGE=0

 +10       SET $PIECE(AGDASH,"-",81)=""

 +11       QUIT

HDR       ;

 +1        SET AGPAGE=AGPAGE+1

 +2        WRITE @IOF

 +3        WRITE AGUSER,?70,"Page ",AGPAGE

 +4        WRITE !,$$C^XBFUNC(AGLOC)

 +5        WRITE !,$$C^XBFUNC(AGRPTNAM)

 +6        WRITE !,$$C^XBFUNC("UCI: "_AGUCI)

 +7        WRITE !,$$C^XBFUNC("Report Date: "_AGRPTDT)

 +8        SET STR="Date range From "_AGBEGX_" to "_AGENDX

 +9       ;W !,$$C^XBFUNC("Date range From "_AGBEGX) W " to ",AGENDX

 +10       WRITE !,$$C^XBFUNC(STR)

 +11       QUIT

SUBHDR    ;

 +1        WRITE !!

 +2        WRITE $SELECT(AGRPTTYP="RECEIVER":"PERSON",1:"APPLICATION")

 +3       ;IHS/OIT/NKD AG*7.1*11 ABBREVIATED COLUMN HEADERS TO FIT ADDITIONAL ENTRIES

 +4       ;W ?36,"RE-",?53,"FOLLOWUP",?63,"ENTERED"

 +5        WRITE !

 +6        WRITE $SELECT(AGRPTTYP="RECEIVER":"RECEIVING",1:"TYPE")

 +7       ;IHS/OIT/NKD AG*7.1*11  ABBREVIATED COLUMN HEADERS TO FIT ADDITIONAL ENTRIES

 +8       ;W ?14,"APPROVED",?24,"DENIED",?33,"SUBMITTED",?43,"REFUSED",?54,"NEEDED",?62,"IN ERROR",?72,"PENDING"

 +9        WRITE ?14,"APPROVED",?23,"DENIED",?30,"RESUB",?36,"REFUSED",?44,"FOLLOWUP",?53,"ERR",?57,"PENDING",?65,"OVERINC",?73,"SCREEN"

 +10       WRITE !,AGDASH

 +11       WRITE !

 +12       QUIT

DEV       ;

 +1        KILL %ZIS,ZTSK

 +2        SET %ZIS="OPQ"

 +3        DO ^%ZIS

 +4        IF POP

               QUIT

 +5        IF '$DATA(IO("Q"))

               QUIT

 +6        SET ZTRTN="QUEUED^AGBENPRD"

           SET ZTDESC=AGRPTNAM

 +7        SET ZTSAVE("AG*")=""

 +8        DO ^%ZTLOAD

 +9        QUIT

AGBENPRD.m