IBOUNP3 ;ALB/CJM - OUTPATIENT INSURANCE REPORT ;JAN 25,1991
;;2.0;INTEGRATED BILLING;**249,528**;21-MAR-94;Build 163
;;Per VA Directive 6402, this routine should not be modified.
;
REPORT ;
N QUIT,IBODIV,CLNC,TIME,DFN,CTG,HDR,HDR2,HDR1,PAGE,NOW,LINE,B,E,NAME,CRT,BOT,DIVTOT,CLNTOT,TOTAL,FIRST,PATINF
S CRT=0,BOT=6,QUIT=0 I $E(IOST,1,2)="C-" S CRT=1,BOT=2
S FIRST=1
D NOW^%DTC S Y=X X ^DD("DD") S NOW=Y
I "^R^E^"'[(U_$G(IBOUT)_U) S IBOUT="R"
W:CRT @IOF
;
S HDR="OUTPATIENT VISITS FOR VETERANS",LINE="",$P(LINE,"-",126)=""
I IBOUT="E" S (HDR1,HDR2)="" D PHDL G CAT
S Y=IBOBEG X ^DD("DD") S B=Y
S Y=IBOEND X ^DD("DD") S E=Y
S HDR2="FOR APPOINTMENTS " S:E'=B HDR2=HDR2_"FROM "_B_" TO "_E
S:E=B HDR2=HDR2_"ON "_B
CAT I IBOUI S CTG="NO",HDR1=HDR_" WITH NO INSURANCE" D LOOP G:QUIT Q
I IBOEXP S CTG="EXPIRED",HDR1=HDR_" WHOSE INSURANCE IS EXPIRED OR WILL EXPIRE WITHIN 30 DAYS" D LOOP G:QUIT Q
I IBOUK S CTG="UNKNOWN",HDR1=HDR_" WHOSE INSURANCE IS UNKNOWN" D LOOP
W:IBOUT="E" !
I CRT,'QUIT D PAUSE
Q D KVAR^VADPT K VA
Q
LOOP ;
S IBODIV="",PAGE=1,(CLNTOT,DIVTOT,TOTAL)=0
I IBOUT="E" W !!,HDR1
F D:DIVTOT DIVTOT S:DIVTOT TOTAL=TOTAL+DIVTOT,DIVTOT=0 S IBODIV=$O(^TMP("IBOUNP",$J,CTG,IBODIV)) Q:IBODIV=""!QUIT S CLNC="" D
.I IBOUT="R" D HEADER Q:QUIT
.I IBOUT="R" W !!?6,"Division: ",?31,IBODIV,!
.I IBOUT="E" W !!,"Division:^",IBODIV,!
.F S CLNC=$O(^TMP("IBOUNP",$J,CTG,IBODIV,CLNC)) S DIVTOT=DIVTOT+CLNTOT,CLNTOT=0 Q:CLNC=""!QUIT D:$Y>(IOSL-BOT-4)&(IBOUT="R") HEADER Q:QUIT W:IBOUT="R" !!,?6,"Clinic: ",?31,CLNC,! W:IBOUT="E" !!,"Clinic:^",CLNC,! S NAME="" D
..F S NAME=$O(^TMP("IBOUNP",$J,CTG,IBODIV,CLNC,NAME)) Q:QUIT D:NAME=""&(CLNTOT>0) CLNTOT Q:NAME="" D
... F DFN=0:0 S DFN=$O(^TMP("IBOUNP",$J,CTG,IBODIV,CLNC,NAME,DFN)) Q:DFN'>0 S TIME=^TMP("IBOUNP",$J,CTG,IBODIV,CLNC,NAME,DFN) D ITEM Q:QUIT
D:'QUIT TOTAL
Q
CLNTOT ; prints subtotal for clinic
I IBOUT="E" W !,"________________________",!,"Clinic Subtotal : ",CLNTOT Q
I $Y+BOT>(IOSL-1) D HEADER
W !?3,"________________________"
W !,?3,"Clinic Subtotal : ",CLNTOT
Q
DIVTOT ; prints subtotal for division
I IBOUT="E" W !,"________________________",!,"Division Subtotal: ",DIVTOT Q
I $Y+BOT>(IOSL-1) D HEADER
W !?3,"________________________"
W !,?3,"Division Subtotal: ",DIVTOT
Q
TOTAL ; prints total for all clinics
I IBOUT="E" W !,"________________________",!,"Total : ",TOTAL Q
I ($Y+BOT>(IOSL-1))!($Y'>1) D HEADER Q:QUIT
W !?3,"________________________"
W !?3,"Total : ",TOTAL
;F Q:($Y>(IOSL-2)) W ! ; Eliminate scrolling problem - CJS, IB*2.0*528
Q
ITEM ; prints patient data for a single appt
N CNT,TM,E1,E2,PID,MS,ES,SC,AGE,INS,I,VAPA S (E1,E2,PID,MS,ES,SC,AGE)="",CNT=2,CLNTOT=CLNTOT+1
DATA S Y=TIME X ^DD("DD") S TM=$P(Y,"@",1)_"@"_$E($P(Y,"@",2),1,5)
D DEM^VADPT I 'VAERR S MS=$P(VADM(10),"^",2),PID=VA("PID"),AGE=VADM(4)
D OPD^VADPT I 'VAERR S ES=$P(VAPD(7),"^",2)
D ELIG^VADPT I 'VAERR,+VAEL(3) S SC=$P(VAEL(3),"^",2)
CKSPACE ; tries to keep vet's data on same page
S VAPA("P")="" D ADD^VADPT I 'VAERR D
. F I=2,3,4 S:VAPA(I)]"" CNT=CNT+1
S VAOA("A")=5 D OAD^VADPT I 'VAERR S E1=VAOA(9) I E1]"" D
. S CNT=CNT+1
. F I=1,2,3,4,5,6,8 S E1(I)=VAOA(I)
. F I=1,2,3 S:VAOA(I)]"" CNT=CNT+1
S VAOA("A")=6 D OAD^VADPT I 'VAERR S E2=VAOA(9) I E2]"" D
. S CNT=CNT+1
. F I=1,2,3,4,5,6,8 S E2(I)=VAOA(I)
. F I=1,2,3 S:VAOA(I)]"" CNT=CNT+1
S CNT=$P($G(^DPT(DFN,.312,0)),"^",4)+CNT G:IBOUT="E" XLPRINT
I CNT>(IOSL-($Y+BOT)) D HEADER Q:QUIT
PRINT W !?3,$E(NAME,1,25),?31,PID,?51,TM,?74,AGE,?81,SC,?87,$E(MS,1,15),?104,$E(ES,1,20)
W !?31,"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)
I E1]"" W !?31,"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)
I E2]"" W !?31,"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)
INS ; writes insurance data
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 ?31,"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
Q
XLPRINT ; Excel data output
W !,$E(NAME,1,25),"^",PID,"^",TM,"^",AGE,"^",SC,"^",$E(MS,1,15),"^",$E(ES,1,20)
W !,"^Address:^",VAPA(1),"^^^Tele:^",VAPA(8) W:VAPA(2)]"" !,"^^",VAPA(2) W:VAPA(3)]"" !,"^^",VAPA(3) W:VAPA(4)]"" !,"^^",VAPA(4)_","_$P($G(^DIC(5,+VAPA(5),0)),"^",2)_" "_VAPA(6)
I E1]"" W !,"^Employer:^",E1,"^^^Tele:^",E1(8) W:E1(1)]"" !,"^^",E1(1) W:E1(2)]"" !,"^^",E1(2) W:E1(3)]"" !,"^^",E1(3) W:E1(4)]"" !,"^^",E1(4)_","_$P($G(^DIC(5,+E1(5),0)),"^",2)_" "_E1(6)
I E2]"" W !,"^Sps's Emplr:^",E2,"^^^Tele:^",E2(8) W:E2(1)]"" !,"^^",E2(1) W:E2(2)]"" !,"^^",E2(2) W:E2(3)]"" !,"^^",E2(3) W:E2(4)]"" !,"^^",E2(4)_","_$P($G(^DIC(5,+E2(5),0)),"^",2)_" "_E2(6)
XLINS ; writes insurance data in Excel format
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)) W ! W:J "^Insurance:^" W:'J "^^" W $P($G(^DIC(36,$P(INS,"^",1),0)),"^",1),"^^^" W:J "Expiration:" S Y=$P(INS,"^",4),J=0 I Y>0 X ^DD("DD") W "^",Y
Q
;
I CRT,$Y>1,'FIRST D Q:QUIT
.; F Q:$Y>(IOSL-1) W ! ; Eliminate scrolling problem - CJS, IB*2.0*528
.D PAUSE
I 'FIRST W @IOF
I FIRST S FIRST=0
W !,HDR1,?104,NOW," PAGE ",PAGE,!,HDR2,!!
W ?3,"PATIENT NAME",?32,"PT ID",?51,"APPT DATE/TIME",?74,"AGE",?81,"%SC",?87,"MARITAL STATUS",?104,"EMPLOYMENT STATUS",!
W LINE
S PAGE=PAGE+1
Q
PAUSE ;
N T W:($Y<IOSL) ! R " Press RETURN to continue",T:DTIME I '$T!(T["^") S QUIT=1 Q
Q
;
PHDL ; Print header for Excel format
W "PATIENT NAME^PT ID^APPT DATE/TIME^AGE^%SC^MARITAL STATUS^EMPLOYMENT STATUS"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOUNP3 6066 printed Jan 18, 2025@03:27:29 Page 2
IBOUNP3 ;ALB/CJM - OUTPATIENT INSURANCE REPORT ;JAN 25,1991
+1 ;;2.0;INTEGRATED BILLING;**249,528**;21-MAR-94;Build 163
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
REPORT ;
+1 NEW QUIT,IBODIV,CLNC,TIME,DFN,CTG,HDR,HDR2,HDR1,PAGE,NOW,LINE,B,E,NAME,CRT,BOT,DIVTOT,CLNTOT,TOTAL,FIRST,PATINF
+2 SET CRT=0
SET BOT=6
SET QUIT=0
IF $EXTRACT(IOST,1,2)="C-"
SET CRT=1
SET BOT=2
+3 SET FIRST=1
+4 DO NOW^%DTC
SET Y=X
XECUTE ^DD("DD")
SET NOW=Y
+5 IF "^R^E^"'[(U_$GET(IBOUT)_U)
SET IBOUT="R"
+6 if CRT
WRITE @IOF
+7 ;
+8 SET HDR="OUTPATIENT VISITS FOR VETERANS"
SET LINE=""
SET $PIECE(LINE,"-",126)=""
+9 IF IBOUT="E"
SET (HDR1,HDR2)=""
DO PHDL
GOTO CAT
+10 SET Y=IBOBEG
XECUTE ^DD("DD")
SET B=Y
+11 SET Y=IBOEND
XECUTE ^DD("DD")
SET E=Y
+12 SET HDR2="FOR APPOINTMENTS "
if E'=B
SET HDR2=HDR2_"FROM "_B_" TO "_E
+13 if E=B
SET HDR2=HDR2_"ON "_B
CAT IF IBOUI
SET CTG="NO"
SET HDR1=HDR_" WITH NO INSURANCE"
DO LOOP
if QUIT
GOTO Q
+1 IF IBOEXP
SET CTG="EXPIRED"
SET HDR1=HDR_" WHOSE INSURANCE IS EXPIRED OR WILL EXPIRE WITHIN 30 DAYS"
DO LOOP
if QUIT
GOTO Q
+2 IF IBOUK
SET CTG="UNKNOWN"
SET HDR1=HDR_" WHOSE INSURANCE IS UNKNOWN"
DO LOOP
+3 if IBOUT="E"
WRITE !
+4 IF CRT
IF 'QUIT
DO PAUSE
Q DO KVAR^VADPT
KILL VA
+1 QUIT
LOOP ;
+1 SET IBODIV=""
SET PAGE=1
SET (CLNTOT,DIVTOT,TOTAL)=0
+2 IF IBOUT="E"
WRITE !!,HDR1
+3 FOR
if DIVTOT
DO DIVTOT
if DIVTOT
SET TOTAL=TOTAL+DIVTOT
SET DIVTOT=0
SET IBODIV=$ORDER(^TMP("IBOUNP",$JOB,CTG,IBODIV))
if IBODIV=""!QUIT
QUIT
SET CLNC=""
Begin DoDot:1
+4 IF IBOUT="R"
DO HEADER
if QUIT
QUIT
+5 IF IBOUT="R"
WRITE !!?6,"Division: ",?31,IBODIV,!
+6 IF IBOUT="E"
WRITE !!,"Division:^",IBODIV,!
+7 FOR
SET CLNC=$ORDER(^TMP("IBOUNP",$JOB,CTG,IBODIV,CLNC))
SET DIVTOT=DIVTOT+CLNTOT
SET CLNTOT=0
if CLNC=""!QUIT
QUIT
if $Y>(IOSL-BOT-4)&(IBOUT="R")
DO HEADER
if QUIT
QUIT
if IBOUT="R"
WRITE !!,?6,"Clinic: ",?31,CLNC,!
if IBOUT="E"
WRITE !!,"Clinic:^",CLNC,!
SET NAME=""
Begin DoDot:2
+8 FOR
SET NAME=$ORDER(^TMP("IBOUNP",$JOB,CTG,IBODIV,CLNC,NAME))
if QUIT
QUIT
if NAME=""&(CLNTOT>0)
DO CLNTOT
if NAME=""
QUIT
Begin DoDot:3
+9 FOR DFN=0:0
SET DFN=$ORDER(^TMP("IBOUNP",$JOB,CTG,IBODIV,CLNC,NAME,DFN))
if DFN'>0
QUIT
SET TIME=^TMP("IBOUNP",$JOB,CTG,IBODIV,CLNC,NAME,DFN)
DO ITEM
if QUIT
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+10 if 'QUIT
DO TOTAL
+11 QUIT
CLNTOT ; prints subtotal for clinic
+1 IF IBOUT="E"
WRITE !,"________________________",!,"Clinic Subtotal : ",CLNTOT
QUIT
+2 IF $Y+BOT>(IOSL-1)
DO HEADER
+3 WRITE !?3,"________________________"
+4 WRITE !,?3,"Clinic Subtotal : ",CLNTOT
+5 QUIT
DIVTOT ; prints subtotal for division
+1 IF IBOUT="E"
WRITE !,"________________________",!,"Division Subtotal: ",DIVTOT
QUIT
+2 IF $Y+BOT>(IOSL-1)
DO HEADER
+3 WRITE !?3,"________________________"
+4 WRITE !,?3,"Division Subtotal: ",DIVTOT
+5 QUIT
TOTAL ; prints total for all clinics
+1 IF IBOUT="E"
WRITE !,"________________________",!,"Total : ",TOTAL
QUIT
+2 IF ($Y+BOT>(IOSL-1))!($Y'>1)
DO HEADER
if QUIT
QUIT
+3 WRITE !?3,"________________________"
+4 WRITE !?3,"Total : ",TOTAL
+5 ;F Q:($Y>(IOSL-2)) W ! ; Eliminate scrolling problem - CJS, IB*2.0*528
+6 QUIT
ITEM ; prints patient data for a single appt
+1 NEW CNT,TM,E1,E2,PID,MS,ES,SC,AGE,INS,I,VAPA
SET (E1,E2,PID,MS,ES,SC,AGE)=""
SET CNT=2
SET CLNTOT=CLNTOT+1
DATA SET Y=TIME
XECUTE ^DD("DD")
SET TM=$PIECE(Y,"@",1)_"@"_$EXTRACT($PIECE(Y,"@",2),1,5)
+1 DO DEM^VADPT
IF 'VAERR
SET MS=$PIECE(VADM(10),"^",2)
SET PID=VA("PID")
SET AGE=VADM(4)
+2 DO OPD^VADPT
IF 'VAERR
SET ES=$PIECE(VAPD(7),"^",2)
+3 DO ELIG^VADPT
IF 'VAERR
IF +VAEL(3)
SET SC=$PIECE(VAEL(3),"^",2)
CKSPACE ; tries to keep vet's data on same page
+1 SET VAPA("P")=""
DO ADD^VADPT
IF 'VAERR
Begin DoDot:1
+2 FOR I=2,3,4
if VAPA(I)]""
SET CNT=CNT+1
End DoDot:1
+3 SET VAOA("A")=5
DO OAD^VADPT
IF 'VAERR
SET E1=VAOA(9)
IF E1]""
Begin DoDot:1
+4 SET CNT=CNT+1
+5 FOR I=1,2,3,4,5,6,8
SET E1(I)=VAOA(I)
+6 FOR I=1,2,3
if VAOA(I)]""
SET CNT=CNT+1
End DoDot:1
+7 SET VAOA("A")=6
DO OAD^VADPT
IF 'VAERR
SET E2=VAOA(9)
IF E2]""
Begin DoDot:1
+8 SET CNT=CNT+1
+9 FOR I=1,2,3,4,5,6,8
SET E2(I)=VAOA(I)
+10 FOR I=1,2,3
if VAOA(I)]""
SET CNT=CNT+1
End DoDot:1
+11 SET CNT=$PIECE($GET(^DPT(DFN,.312,0)),"^",4)+CNT
if IBOUT="E"
GOTO XLPRINT
+12 IF CNT>(IOSL-($Y+BOT))
DO HEADER
if QUIT
QUIT
PRINT WRITE !?3,$EXTRACT(NAME,1,25),?31,PID,?51,TM,?74,AGE,?81,SC,?87,$EXTRACT(MS,1,15),?104,$EXTRACT(ES,1,20)
+1 WRITE !?31,"Address:",?51,VAPA(1),?87,"Tele: ",?104,VAPA(8)
if VAPA(2)]""
WRITE !?51,VAPA(2)
if VAPA(3)]""
WRITE !?51,VAPA(3)
if VAPA(4)]""
WRITE !?51,VAPA(4)_","_$PIECE($GET(^DIC(5,+VAPA(5),0)),"^",2)_" "_VAPA(6)
+2 IF E1]""
WRITE !?31,"Employer:",?51,E1,?87,"Tele: ",?104,E1(8)
if E1(1)]""
WRITE !?51,E1(1)
if E1(2)]""
WRITE !?51,E1(2)
if E1(3)]""
WRITE !?51,E1(3)
if E1(4)]""
WRITE !?51,E1(4)_","_$PIECE($GET(^DIC(5,+E1(5),0)),"^",2)_" "_E1(6)
+3 IF E2]""
WRITE !?31,"Sps's Emplr:",?51,E2,?87,"Tele: ",?104,E2(8)
if E2(1)]""
WRITE !?51,E2(1)
if E2(2)]""
WRITE !?51,E2(2)
if E2(3)]""
WRITE !?51,E2(3)
if E2(4)]""
WRITE !?51,E2(4)_","_$PIECE($GET(^DIC(5,+E2(5),0)),"^",2)_" "_E2(6)
INS ; writes insurance data
+1 NEW I,J
SET J=1
FOR I=0:0
SET I=$ORDER(^DPT(DFN,.312,I))
if I'>0
QUIT
SET INS=$GET(^(I,0))
if $Y>(IOSL-BOT)
DO HEADER
if QUIT
QUIT
WRITE !
if J
WRITE ?31,"Insurance:"
WRITE ?51,$PIECE($GET(^DIC(36,$PIECE(INS,"^",1),0)),"^",1),?87
if J
WRITE "Expiration:"
SET Y=$PIECE(INS,"^",4)
SET J=0
IF Y>0
XECUTE ^DD("DD")
WRITE ?104,Y
+2 QUIT
XLPRINT ; Excel data output
+1 WRITE !,$EXTRACT(NAME,1,25),"^",PID,"^",TM,"^",AGE,"^",SC,"^",$EXTRACT(MS,1,15),"^",$EXTRACT(ES,1,20)
+2 WRITE !,"^Address:^",VAPA(1),"^^^Tele:^",VAPA(8)
if VAPA(2)]""
WRITE !,"^^",VAPA(2)
if VAPA(3)]""
WRITE !,"^^",VAPA(3)
if VAPA(4)]""
WRITE !,"^^",VAPA(4)_","_$PIECE($GET(^DIC(5,+VAPA(5),0)),"^",2)_" "_VAPA(6)
+3 IF E1]""
WRITE !,"^Employer:^",E1,"^^^Tele:^",E1(8)
if E1(1)]""
WRITE !,"^^",E1(1)
if E1(2)]""
WRITE !,"^^",E1(2)
if E1(3)]""
WRITE !,"^^",E1(3)
if E1(4)]""
WRITE !,"^^",E1(4)_","_$PIECE($GET(^DIC(5,+E1(5),0)),"^",2)_" "_E1(6)
+4 IF E2]""
WRITE !,"^Sps's Emplr:^",E2,"^^^Tele:^",E2(8)
if E2(1)]""
WRITE !,"^^",E2(1)
if E2(2)]""
WRITE !,"^^",E2(2)
if E2(3)]""
WRITE !,"^^",E2(3)
if E2(4)]""
WRITE !,"^^",E2(4)_","_$PIECE($GET(^DIC(5,+E2(5),0)),"^",2)_" "_E2(6)
XLINS ; writes insurance data in Excel format
+1 NEW I,J
SET J=1
FOR I=0:0
SET I=$ORDER(^DPT(DFN,.312,I))
if I'>0
QUIT
SET INS=$GET(^(I,0))
WRITE !
if J
WRITE "^Insurance:^"
if 'J
WRITE "^^"
WRITE $PIECE($GET(^DIC(36,$PIECE(INS,"^",1),0)),"^",1),"^^^"
if J
WRITE "Expiration:"
SET Y=$PIECE(INS,"^",4)
SET J=0
IF Y>0
XECUTE ^DD("DD")
WRITE "^",Y
+2 QUIT
+3 ;
+1 IF CRT
IF $Y>1
IF 'FIRST
Begin DoDot:1
+2 ; F Q:$Y>(IOSL-1) W ! ; Eliminate scrolling problem - CJS, IB*2.0*528
+3 DO PAUSE
End DoDot:1
if QUIT
QUIT
+4 IF 'FIRST
WRITE @IOF
+5 IF FIRST
SET FIRST=0
+6 WRITE !,HDR1,?104,NOW," PAGE ",PAGE,!,HDR2,!!
+7 WRITE ?3,"PATIENT NAME",?32,"PT ID",?51,"APPT DATE/TIME",?74,"AGE",?81,"%SC",?87,"MARITAL STATUS",?104,"EMPLOYMENT STATUS",!
+8 WRITE LINE
+9 SET PAGE=PAGE+1
+10 QUIT
PAUSE ;
+1 NEW T
if ($Y<IOSL)
WRITE !
READ " Press RETURN to continue",T:DTIME
IF '$TEST!(T["^")
SET QUIT=1
QUIT
+2 QUIT
+3 ;
PHDL ; Print header for Excel format
+1 WRITE "PATIENT NAME^PT ID^APPT DATE/TIME^AGE^%SC^MARITAL STATUS^EMPLOYMENT STATUS"
+2 QUIT
