DGEEREIM.m

DGEEREIM ;ALB/BRM;Reimbursable Primary Eligibility Code Report ; 5/23/05 11:04am

 ;;5.3;Registration;**672,706**;Aug 13,1993

 ;;

 ; This routine will identify and report any veteran who has a

 ; Reimbursable Insurance Primary Eligibility Code and who is not

 ; deceased.

 ;

QUETASK ; Queue the DMZ/Reimbursable Stats job

 N TXT,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH,POP,IO,IOBS,IOF,IOHG,IOM,ION,IOPAR

 N IOS,IOSL,IOST,IOT,IOUPAR,IOXY,%ZIS,ZTSAVE

 K ^TMP($J,"DGEEREIM")

 S %ZIS="QM" D ^%ZIS I $G(POP) W !,"Job Terminated!" Q

 I $D(IO("Q")) D  Q

 .S ZTRTN="LOOP^DGEEREIM",ZTDTH=$$NOW^XLFDT()

 .S ZTDESC="REIMBURSABLE INSURANCE PRIMARY ELIG CODE JOB"

 .D ^%ZTLOAD

 .S TXT=$S($G(ZTSK):"Task: "_ZTSK_" Queued.",1:"Error: Process not queued!")

 .D HOME^%ZIS

 .W !,TXT

 ;

LOOP ; entry point

 N QFLG,DFN,ELIG,QUIT,RCNT,RDT,ZZ

 N X,X1,X2,EC81,PRIMEC,%,CRT,DATA,DIRUT,EC8,LINE,NAME,PAGE

 ; get local codes assigned to the national Reimbursible code

 S EC8=$O(^DIC(8.1,"B","REIMBURSABLE INSURANCE",""))

 S EC81=""

 F  S EC81=$O(^DIC(8,"D",EC8,EC81)) Q:'EC81  S ELIG(EC81)=""

 ; loop through patient records

 S DFN=0

 F  S DFN=$O(^DPT(DFN)) Q:'DFN  D

 .; quit if deceased

 .Q:$P($G(^DPT(DFN,.35)),"^")

 .;check for Primary EC of Reimbursable Insurance

 .S PRIMEC=$P($G(^DPT(DFN,.36)),"^"),EC81="",QFLG=0

 .F  S EC81=$O(ELIG(EC81)) Q:(QFLG!'EC81)  D

 ..Q:PRIMEC'=EC81

 ..S ^TMP($J,"DGEEREIM","RCNT")=$G(^TMP($J,"DGEEREIM","RCNT"))+1,QFLG=1

 ..S SSN=$P($G(^DPT(DFN,0)),"^",9),NAME=$P($G(^DPT(DFN,0)),"^")

 ..S ^TMP($J,"DGEEREIM","DATA",SSN)=NAME_"^"_$$EXTERNAL^DILFD(2,.361,"",PRIMEC)

 U IO

 D PSET,REPORT

 D ^%ZISC,HOME^%ZIS

 Q

PSET ; set up printer variables

 N ZZ

 S CRT=$S($E(IOST,1,2)="C-":1,1:0)

 S (RDT,Y)=""

 F ZZ=1:1:IOM S $P(LINE,"-",ZZ)=""

 D NOW^%DTC S Y=% X ^DD("DD")

 S RDT=$P(Y,"@",1)_" @ "_$P($P(Y,"@",2),":",1,2)

 S RCNT=+$G(^TMP($J,"DGEEREIM","RCNT"))

 Q

HDR ; Report Header

 W !,?((IOM-40)\2),"Reimbursable Insurance Primary EC Report"

 W !,?((IOM-22-$L(RDT))\2),"Date/Time Report Run: ",RDT

 W !!,?((IOM-35-$L(RCNT))\2),"Total Patients with RI Primary EC: ",RCNT

 W !,LINE

 W !!,?5,"SSN",?17,"NAME",?50,"PRIMARY ELIG. CODE"

 W !,?5,"---------",?17,"------------------------------"

 W ?50,"-------------------"

 Q

REPORT ;report results

 N SSN

 I CRT,+$G(PAGE)=0 W @IOF

 S PAGE=1 D HDR

 S SSN="" F  S SSN=$O(^TMP($J,"DGEEREIM","DATA",SSN)) Q:SSN']""!($G(QUIT))  D

 .S DATA=$G(^TMP($J,"DGEEREIM","DATA",SSN))

 .I $Y>(IOSL-5) W:'$G(CRT) !,?68,"Page: "_PAGE D:$G(CRT) PAUSE Q:$G(QUIT)  W @IOF D HDR S PAGE=PAGE+1

 .W !?5,SSN,?17,$P(DATA,"^"),?50,$P(DATA,"^",2)

 Q

 ;

PAUSE ;  Screen pause.  Sets QUIT=1 if user decides to quit.        

 N DIR,X,Y

 F  Q:$Y>(IOSL-5)  W !

 W !,?68,"Page: "_PAGE,!

 S DIR(0)="E" D ^DIR I ('(+Y))!$D(DIRUT) S QUIT=1

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DGEEREIM   2818     printed  Feb 19, 2025@00:08:12                                                                                                                                                                                                    Page 2

DGEEREIM  ;ALB/BRM;Reimbursable Primary Eligibility Code Report ; 5/23/05 11:04am

 +1       ;;5.3;Registration;**672,706**;Aug 13,1993

 +2       ;;

 +3       ; This routine will identify and report any veteran who has a

 +4       ; Reimbursable Insurance Primary Eligibility Code and who is not

 +5       ; deceased.

 +6       ;

QUETASK   ; Queue the DMZ/Reimbursable Stats job

 +1        NEW TXT,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH,POP,IO,IOBS,IOF,IOHG,IOM,ION,IOPAR

 +2        NEW IOS,IOSL,IOST,IOT,IOUPAR,IOXY,%ZIS,ZTSAVE

 +3        KILL ^TMP($JOB,"DGEEREIM")

 +4        SET %ZIS="QM"

           DO ^%ZIS

           IF $GET(POP)

               WRITE !,"Job Terminated!"

               QUIT 

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

               Begin DoDot:1

 +6                SET ZTRTN="LOOP^DGEEREIM"

                   SET ZTDTH=$$NOW^XLFDT()

 +7                SET ZTDESC="REIMBURSABLE INSURANCE PRIMARY ELIG CODE JOB"

 +8                DO ^%ZTLOAD

 +9                SET TXT=$SELECT($GET(ZTSK):"Task: "_ZTSK_" Queued.",1:"Error: Process not queued!")

 +10               DO HOME^%ZIS

 +11               WRITE !,TXT

               End DoDot:1

               QUIT 

 +12      ;

LOOP      ; entry point

 +1        NEW QFLG,DFN,ELIG,QUIT,RCNT,RDT,ZZ

 +2        NEW X,X1,X2,EC81,PRIMEC,%,CRT,DATA,DIRUT,EC8,LINE,NAME,PAGE

 +3       ; get local codes assigned to the national Reimbursible code

 +4        SET EC8=$ORDER(^DIC(8.1,"B","REIMBURSABLE INSURANCE",""))

 +5        SET EC81=""

 +6        FOR 

               SET EC81=$ORDER(^DIC(8,"D",EC8,EC81))

               if 'EC81

                   QUIT 

               SET ELIG(EC81)=""

 +7       ; loop through patient records

 +8        SET DFN=0

 +9        FOR 

               SET DFN=$ORDER(^DPT(DFN))

               if 'DFN

                   QUIT 

               Begin DoDot:1

 +10      ; quit if deceased

 +11               if $PIECE($GET(^DPT(DFN,.35)),"^")

                       QUIT 

 +12      ;check for Primary EC of Reimbursable Insurance

 +13               SET PRIMEC=$PIECE($GET(^DPT(DFN,.36)),"^")

                   SET EC81=""

                   SET QFLG=0

 +14               FOR 

                       SET EC81=$ORDER(ELIG(EC81))

                       if (QFLG!'EC81)

                           QUIT 

                       Begin DoDot:2

 +15                       if PRIMEC'=EC81

                               QUIT 

 +16                       SET ^TMP($JOB,"DGEEREIM","RCNT")=$GET(^TMP($JOB,"DGEEREIM","RCNT"))+1

                           SET QFLG=1

 +17                       SET SSN=$PIECE($GET(^DPT(DFN,0)),"^",9)

                           SET NAME=$PIECE($GET(^DPT(DFN,0)),"^")

 +18                       SET ^TMP($JOB,"DGEEREIM","DATA",SSN)=NAME_"^"_$$EXTERNAL^DILFD(2,.361,"",PRIMEC)

                       End DoDot:2

               End DoDot:1

 +19       USE IO

 +20       DO PSET

           DO REPORT

 +21       DO ^%ZISC

           DO HOME^%ZIS

 +22       QUIT 

PSET      ; set up printer variables

 +1        NEW ZZ

 +2        SET CRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)

 +3        SET (RDT,Y)=""

 +4        FOR ZZ=1:1:IOM

               SET $PIECE(LINE,"-",ZZ)=""

 +5        DO NOW^%DTC

           SET Y=%

           XECUTE ^DD("DD")

 +6        SET RDT=$PIECE(Y,"@",1)_" @ "_$PIECE($PIECE(Y,"@",2),":",1,2)

 +7        SET RCNT=+$GET(^TMP($JOB,"DGEEREIM","RCNT"))

 +8        QUIT 

HDR       ; Report Header

 +1        WRITE !,?((IOM-40)\2),"Reimbursable Insurance Primary EC Report"

 +2        WRITE !,?((IOM-22-$LENGTH(RDT))\2),"Date/Time Report Run: ",RDT

 +3        WRITE !!,?((IOM-35-$LENGTH(RCNT))\2),"Total Patients with RI Primary EC: ",RCNT

 +4        WRITE !,LINE

 +5        WRITE !!,?5,"SSN",?17,"NAME",?50,"PRIMARY ELIG. CODE"

 +6        WRITE !,?5,"---------",?17,"------------------------------"

 +7        WRITE ?50,"-------------------"

 +8        QUIT 

REPORT    ;report results

 +1        NEW SSN

 +2        IF CRT

               IF +$GET(PAGE)=0

                   WRITE @IOF

 +3        SET PAGE=1

           DO HDR

 +4        SET SSN=""

           FOR 

               SET SSN=$ORDER(^TMP($JOB,"DGEEREIM","DATA",SSN))

               if SSN']""!($GET(QUIT))

                   QUIT 

               Begin DoDot:1

 +5                SET DATA=$GET(^TMP($JOB,"DGEEREIM","DATA",SSN))

 +6                IF $Y>(IOSL-5)

                       if '$GET(CRT)

                           WRITE !,?68,"Page: "_PAGE

                       if $GET(CRT)

                           DO PAUSE

                       if $GET(QUIT)

                           QUIT 

                       WRITE @IOF

                       DO HDR

                       SET PAGE=PAGE+1

 +7                WRITE !?5,SSN,?17,$PIECE(DATA,"^"),?50,$PIECE(DATA,"^",2)

               End DoDot:1

 +8        QUIT 

 +9       ;

PAUSE     ;  Screen pause.  Sets QUIT=1 if user decides to quit.        

 +1        NEW DIR,X,Y

 +2        FOR 

               if $Y>(IOSL-5)

                   QUIT 

               WRITE !

 +3        WRITE !,?68,"Page: "_PAGE,!

 +4        SET DIR(0)="E"

           DO ^DIR

           IF ('(+Y))!$DATA(DIRUT)

               SET QUIT=1

 +5        QUIT