source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBOUNP6.m@ 1766

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1IBOUNP6 ;ALB/CJM - INPATIENT INSURANCE REPORT ;JAN 25,1991
2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
3REPORT ;
4 N QUIT,DIV,TIME,DFN,CTG,HDR,HDR2,HDR1,PAGE,NOW,LINE1,LINE2,B,E,NAME,CRT,BOT,SUBTOT,TOTAL,FIRST,WRDN,WARD
5 S CRT=0,BOT=6,QUIT=0 I $E(IOST,1,2)="C-" S CRT=1,BOT=2
6 S FIRST=1
7 W:CRT @IOF
8 S HDR="VETERANS"
9 S LINE1="",$P(LINE1,"-",126)=""
10 S LINE2="",$P(LINE2,"=",126)=""
11 D NOW^%DTC S Y=X X ^DD("DD") S NOW=Y
12 I IBOPICK="D" S Y=IBOBEG X ^DD("DD") S B=Y,Y=IBOEND X ^DD("DD") S E=Y,HDR2="THAT WERE ADMITTED " S:E'=B HDR2=HDR2_"BETWEEN "_B_" AND "_E S:E=B HDR2=HDR2_"ON "_B
13 I IBOPICK="C" S HDR2="THAT ARE CURRENTLY ADMITTED"
14 I CRT W @IOF
15 I IBOUI S CTG="NO",HDR1=HDR_" WITH NO INSURANCE " D LOOP G:QUIT Q
16 I IBOEXP S CTG="EXPIRED",HDR1=HDR_" WHOSE INSURANCE IS EXPIRED OR WILL EXPIRE WITHIN 30 DAYS " D LOOP G:QUIT Q
17 I IBOUK S CTG="UNKNOWN",HDR1=HDR_" WHOSE INSURANCE IS UNKNOWN " D LOOP
18 I CRT,'QUIT D PAUSE
19Q D KVAR^VADPT K VA
20 Q
21LOOP ;
22 N NODE
23 S PAGE=1,(SUBTOT,TOTAL)=0 D HEADER Q:QUIT
24 S DIV="" F S DIV=$O(^TMP($J,CTG,DIV)) S TOTAL=TOTAL+SUBTOT,SUBTOT=0 Q:DIV=""!QUIT D:$Y>(IOSL-(BOT+4)) HEADER Q:QUIT W !!,?6,"Division: ",?31,DIV,!,LINE2,! D
25 .S WRDN="" F S WRDN=$O(^TMP($J,CTG,DIV,WRDN)) Q:QUIT D:WRDN=""&(SUBTOT>0) SUBTOT Q:WRDN="" D Q:QUIT
26 ..I WRDN'="ALL WARDS" D Q:QUIT
27 ...I $Y>(IOSL-(BOT+8)) D HEADER Q:QUIT
28 ...W !,?6,"Ward: ",?31,WRDN,!
29 ..S NAME="" F S NAME=$O(^TMP($J,CTG,DIV,WRDN,NAME)) Q:NAME="" D
30 ...F DFN=0:0 S DFN=$O(^TMP($J,CTG,DIV,WRDN,NAME,DFN)) Q:QUIT!(DFN'>0) S NODE=^TMP($J,CTG,DIV,WRDN,NAME,DFN),TIME=$P(NODE,"^"),WARD=$P(NODE,"^",2) D ITEM
31 ..I WRDN'="ALL WARDS" W !,LINE1
32 D:'QUIT TOTAL
33 Q
34SUBTOT ; prints subtotal for division
35 I $Y+BOT>(IOSL-3) D HEADER
36 W !?3,"_________________"
37 W !,?3,"Subtotal: ",SUBTOT
38 Q
39TOTAL ; prints total for all divisions
40 I $Y+BOT>(IOSL-3) D HEADER Q:QUIT
41 W !?3,"_________________"
42 W !?3,"Total: ",TOTAL
43 F Q:($Y>(IOSL-2)) W !
44 Q
45ITEM ; prints patient data for a single appt
46 N CNT,TM,E1,E2,PID,MS,ES,SC,AGE,INS,I,VAPA S (E1,E2,PID,MS,ES,SC,AGE)="",CNT=2,SUBTOT=SUBTOT+1
47DATA S Y=TIME X ^DD("DD") S TM=$P(Y,"@",1)_"@"_$E($P(Y,"@",2),1,5)
48 D DEM^VADPT I 'VAERR S MS=$P(VADM(10),"^",2),PID=VA("PID"),AGE=VADM(4)
49 D OPD^VADPT I 'VAERR S ES=$P(VAPD(7),"^",2)
50 D ELIG^VADPT I 'VAERR,+VAEL(3) S SC=$P(VAEL(3),"^",2)
51CKSPACE ; tries to keep vet's data on same page
52 S VAPA("P")="" D ADD^VADPT I 'VAERR D
53 . F I=2,3,4 S:VAPA(I)]"" CNT=CNT+1
54 S VAOA("A")=5 D OAD^VADPT I 'VAERR S E1=VAOA(9) I E1]"" D
55 . S CNT=CNT+1
56 . F I=1,2,3,4,5,6,8 S E1(I)=VAOA(I)
57 . F I=1,2,3 S:VAOA(I)]"" CNT=CNT+1
58 S VAOA("A")=6 D OAD^VADPT I 'VAERR S E2=VAOA(9) I E2]"" D
59 . S CNT=CNT+1
60 . F I=1,2,3,4,5,6,8 S E2(I)=VAOA(I)
61 . F I=1,2,3 S:VAOA(I)]"" CNT=CNT+1
62 S CNT=$P($G(^DPT(DFN,.312,0)),"^",4)+CNT
63 I CNT>(IOSL-($Y+BOT)) D HEADER Q:QUIT
64PRINT W !?3,$E(NAME,1,25),?31,PID,?51,TM,?74,AGE,?81,SC,?87,$E(MS,1,15),?104,$E(ES,1,20)
65 W !?5,WARD,?34,"Address:",?51,VAPA(1),?87,"Tele: ",?104,VAPA(8) W:VAPA(2)]"" !?51,VAPA(2) W:VAPA(3)]"" !?51,VAPA(3) W:VAPA(4)]"" !?51,VAPA(4)_","_$P($G(^DIC(5,+VAPA(5),0)),"^",2)_" "_VAPA(6)
66 I E1]"" W !?34,"Employer:",?51,E1,?87,"Tele: ",?104,E1(8) W:E1(1)]"" !?51,E1(1) W:E1(2)]"" !?51,E1(2) W:E1(3)]"" !?51,E1(3) W:E1(4)]"" !?51,E1(4)_","_$P($G(^DIC(5,+E1(5),0)),"^",2)_" "_E1(6)
67 I E2]"" W !?34,"Sps's Emplr:",?51,E2,?87,"Tele: ",?104,E2(8) W:E2(1)]"" !?51,E2(1) W:E2(2)]"" !?51,E2(2) W:E2(3)]"" !?51,E2(3) W:E2(4)]"" !?51,E2(4)_","_$P($G(^DIC(5,+E2(5),0)),"^",2)_" "_E2(6)
68INS ; writes insurance data
69 N I,J S J=1 F I=0:0 S I=$O(^DPT(DFN,.312,I)) Q:I'>0 S INS=$G(^(I,0)) D:$Y>(IOSL-BOT) HEADER Q:QUIT W ! W:J ?34,"Insurance:" W ?51,$P($G(^DIC(36,$P(INS,"^",1),0)),"^",1),?87 W:J "Expiration:" S Y=$P(INS,"^",4),J=0 I Y>0 X ^DD("DD") W ?104,Y
70 W !
71 Q
72HEADER ; writes the report header
73 I CRT,$Y>1,'FIRST D Q:QUIT
74 . F Q:$Y>(IOSL-1) W !
75 .D PAUSE
76 I 'FIRST W @IOF
77 I FIRST S FIRST=0
78 W ?104,NOW," PAGE ",PAGE,!?1,HDR1,HDR2,!!
79 W ?3,"PATIENT/WARD",?32,"PT ID",?51,"ADMISSION DATE",?74,"AGE",?81,"%SC",?87,"MARITAL STATUS",?104,"EMPLOYMENT STATUS",!
80 W LINE1
81 S PAGE=PAGE+1
82 Q
83PAUSE ;
84 N T R " Press RETURN to continue",T:DTIME I '$T!(T["^") S QUIT=1 Q
85 Q
Note: See TracBrowser for help on using the repository browser.