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 ---[H[J[2J[HDGEEREIM 2818 printed Sep 23, 2025@20:18:01 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
