source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGEEREIM.m@ 1379

Last change on this file since 1379 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.7 KB
RevLine 
[613]1DGEEREIM ;ALB/BRM;Reimbursable Primary Eligibility Code Report ; 5/23/05 11:04am
2 ;;5.3;Registration;**672,706**;Aug 13,1993
3 ;;
4 ; This routine will identify and report any veteran who has a
5 ; Reimbursable Insurance Primary Eligibility Code and who is not
6 ; deceased.
7 ;
8QUETASK ; Queue the DMZ/Reimbursable Stats job
9 N TXT,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH,POP,IO,IOBS,IOF,IOHG,IOM,ION,IOPAR
10 N IOS,IOSL,IOST,IOT,IOUPAR,IOXY,%ZIS,ZTSAVE
11 K ^TMP($J,"DGEEREIM")
12 S %ZIS="QM" D ^%ZIS I $G(POP) W !,"Job Terminated!" Q
13 I $D(IO("Q")) D Q
14 .S ZTRTN="LOOP^DGEEREIM",ZTDTH=$$NOW^XLFDT()
15 .S ZTDESC="REIMBURSABLE INSURANCE PRIMARY ELIG CODE JOB"
16 .D ^%ZTLOAD
17 .S TXT=$S($G(ZTSK):"Task: "_ZTSK_" Queued.",1:"Error: Process not queued!")
18 .D HOME^%ZIS
19 .W !,TXT
20 ;
21LOOP ; entry point
22 N QFLG,DFN,ELIG,QUIT,RCNT,RDT,ZZ
23 N X,X1,X2,EC81,PRIMEC,%,CRT,DATA,DIRUT,EC8,LINE,NAME,PAGE
24 ; get local codes assigned to the national Reimbursible code
25 S EC8=$O(^DIC(8.1,"B","REIMBURSABLE INSURANCE",""))
26 S EC81=""
27 F S EC81=$O(^DIC(8,"D",EC8,EC81)) Q:'EC81 S ELIG(EC81)=""
28 ; loop through patient records
29 S DFN=0
30 F S DFN=$O(^DPT(DFN)) Q:'DFN D
31 .; quit if deceased
32 .Q:$P($G(^DPT(DFN,.35)),"^")
33 .;check for Primary EC of Reimbursable Insurance
34 .S PRIMEC=$P($G(^DPT(DFN,.36)),"^"),EC81="",QFLG=0
35 .F S EC81=$O(ELIG(EC81)) Q:(QFLG!'EC81) D
36 ..Q:PRIMEC'=EC81
37 ..S ^TMP($J,"DGEEREIM","RCNT")=$G(^TMP($J,"DGEEREIM","RCNT"))+1,QFLG=1
38 ..S SSN=$P($G(^DPT(DFN,0)),"^",9),NAME=$P($G(^DPT(DFN,0)),"^")
39 ..S ^TMP($J,"DGEEREIM","DATA",SSN)=NAME_"^"_$$EXTERNAL^DILFD(2,.361,"",PRIMEC)
40 U IO
41 D PSET,REPORT
42 D ^%ZISC,HOME^%ZIS
43 Q
44PSET ; set up printer variables
45 N ZZ
46 S CRT=$S($E(IOST,1,2)="C-":1,1:0)
47 S (RDT,Y)=""
48 F ZZ=1:1:IOM S $P(LINE,"-",ZZ)=""
49 D NOW^%DTC S Y=% X ^DD("DD")
50 S RDT=$P(Y,"@",1)_" @ "_$P($P(Y,"@",2),":",1,2)
51 S RCNT=+$G(^TMP($J,"DGEEREIM","RCNT"))
52 Q
53HDR ; Report Header
54 W !,?((IOM-40)\2),"Reimbursable Insurance Primary EC Report"
55 W !,?((IOM-22-$L(RDT))\2),"Date/Time Report Run: ",RDT
56 W !!,?((IOM-35-$L(RCNT))\2),"Total Patients with RI Primary EC: ",RCNT
57 W !,LINE
58 W !!,?5,"SSN",?17,"NAME",?50,"PRIMARY ELIG. CODE"
59 W !,?5,"---------",?17,"------------------------------"
60 W ?50,"-------------------"
61 Q
62REPORT ;report results
63 N SSN
64 I CRT,+$G(PAGE)=0 W @IOF
65 S PAGE=1 D HDR
66 S SSN="" F S SSN=$O(^TMP($J,"DGEEREIM","DATA",SSN)) Q:SSN']""!($G(QUIT)) D
67 .S DATA=$G(^TMP($J,"DGEEREIM","DATA",SSN))
68 .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
69 .W !?5,SSN,?17,$P(DATA,"^"),?50,$P(DATA,"^",2)
70 Q
71 ;
72PAUSE ; Screen pause. Sets QUIT=1 if user decides to quit.
73 N DIR,X,Y
74 F Q:$Y>(IOSL-5) W !
75 W !,?68,"Page: "_PAGE,!
76 S DIR(0)="E" D ^DIR I ('(+Y))!$D(DIRUT) S QUIT=1
77 Q
Note: See TracBrowser for help on using the repository browser.