IBOVOP2 ;ALB/CPM-Opt/Reg Events Report Print Utilities ; 30-AUG-93
;;2.0;INTEGRATED BILLING;**52,132,153,156,167,176,234,247,339**;21-MAR-94;Build 2
;;Per VHA Directive 2004-038, this routine should not be modified.
;
PRINT ; Retrieve data for printing.
N IBCOMBAT
S IBFLD1="" I '$D(^TMP("IBOVOP",$J)) W !!,"No Outpatient activity recorded for MT/LTC copay patients on ",$$DAT1^IBOUTL(IBDATE),"."
F S IBFLD1=$O(^TMP("IBOVOP",$J,IBFLD1)) Q:(IBFLD1="")!(IBQUIT) W ! D:IBLINE>55 HDR W !,IBFLD1 D D CHRGS Q:IBQUIT
.S IBFLD2="" F S IBFLD2=$O(^TMP("IBOVOP",$J,IBFLD1,IBFLD2)) Q:(IBFLD2="")!(IBQUIT) D
..S IBFLD3="" F S IBFLD3=$O(^TMP("IBOVOP",$J,IBFLD1,IBFLD2,IBFLD3)) Q:(IBFLD3="")!(IBQUIT) D
...S IBSEQ="" F S IBSEQ=$O(^TMP("IBOVOP",$J,IBFLD1,IBFLD2,IBFLD3,IBSEQ)) Q:(IBSEQ="")!(IBQUIT) S IBDATA=$G(^(IBSEQ)) D
....S IBFLD4=$P(IBDATA,"^",1),IBFLD5=$P(IBDATA,"^",2),IBFLD6=$P(IBDATA,"^",3),DFN=$P(IBDATA,"^",4)
....S IBCOMBAT=$$CVEDT^IBACV(DFN,IBDATE) I +IBCOMBAT I $P(IBCOMBAT,"^",2)>0 W !,"Veteran has CV status until "_$$DAT1^IBOUTL($P(IBCOMBAT,"^",2))
....W !?5,IBFLD2
....W ?20,IBFLD3,?26,IBFLD4,?44,IBFLD5,?63,IBFLD6 D CLSF(+$P(IBDATA,"^",5)) D:IBFLD2="OBS ADMIS" CLSF^IBECEAU5(+$P(IBDATA,U,6)) W ! S IBLINE=IBLINE+1
....Q:$O(^TMP("IBOVOP",$J,IBFLD1))=""
....I IBLINE>55 D HDR W !,IBFLD1 I $D(^TMP("IBOVOP",$J,IBFLD1,IBFLD2,IBFLD3,IBSEQ+1)) W !?5,IBFLD2
....I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR W !,IBFLD1,!?5,IBFLD2
D:'IBQUIT PAUSE^IBOUTL
Q
;
CHRGS ; Find OP charges for day, if any. Build string for print.
Q:'$G(DFN)
N IBSTDATA
I $D(^IB("AFDT",DFN,-IBDATE))=10 D
.S IBPRNT="" F S IBPRNT=$O(^IB("AFDT",DFN,-IBDATE,IBPRNT)) Q:IBPRNT=""!(IBQUIT) D
..S IBIEN="" F S IBIEN=$O(^IB("AD",IBPRNT,IBIEN)) Q:IBIEN=""!(IBQUIT) D
...S IBDATA=$G(^IB(IBIEN,0)) Q:IBDATA=""
...I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR W !,IBFLD1
...S IBSTAT=$P($G(^IBE(350.21,+$P(IBDATA,"^",5),0)),"^",2)
...S IBACT=$S($P($G(^IBE(350.1,+$P(IBDATA,"^",3),0)),"^",8)'="":$P(^(0),"^",8),1:$P(^(0),"^",1))
...S IBAMT=$P(IBDATA,"^",7)
...S IBAMT=$S(IBAMT?1N.N1"."1N:IBAMT_"0 ",IBAMT?1N.N:IBAMT_".00 ",1:IBAMT)
...S IBAMT=$S(IBACT["CANCEL":"*($"_IBAMT_")",1:"* $"_IBAMT)
...S IBSTDATA=$G(^IBE(352.5,+$P(IBDATA,"^",20),0))
...I IBSTDATA'="" W !?26,"Stop Code: ",$P(IBSTDATA,"^",4),?58,"#",$P(IBSTDATA,"^"),?63,$$TYPE^IBEMTSCR(+$P(IBSTDATA,"^",3))
...W !?5,IBAMT,?13,IBACT,?63,IBSTAT S IBLINE=IBLINE+1
Q
;
HDR ; Print header.
S IBPAGE=IBPAGE+1,IBLINE=5,IBTITLE="Means Test/LTC Outpatient and Registration Activity for "_$$DAT1^IBOUTL(IBDATE)
I $E(IOST,1,2)["C-"!(IBPAGE>1) W @IOF,*13
W ?(80-$L(IBTITLE))\2,IBTITLE
S IBTITLE="Printed: "_$$DAT1^IBOUTL(DT)
W !?(80-$L(IBTITLE))\2,IBTITLE,?70,"Page: "_IBPAGE
W !!,"Patient/Event",?20,"Time",?26,"Clinic/Stop",?44,"Appt.Type",?63,"(Status)",!
Q
;
CLSF(IBOE) ; Display classification results.
; Input: IBOE -- Pointer to Outpatient Encounter in file #409.68
I '$G(IBOE) G CLSFQ
N I,IBCLS,IBCLSD,IBF S IBF=0,IBCLSD=$$ENCL^IBAMTS2(IBOE)
I IBCLSD]"" F I=1,2,3,4,5,6,7,8 S IBCLS=$P(IBCLSD,"^",I) I IBCLS]"" W:'IBF !?6 W:IBF " " W "Care related to ",$S(I=1:"AO",I=2:"IR",I=3:"SC",I=4:"SWA",I=5:"MST",I=6:"HNC",I=7:"CV",I=8:"SHAD",1:"??"),"? ",$S(IBCLS:"YES",1:"NO") S IBF=1
CLSFQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOVOP2 3318 printed Dec 13, 2024@02:26:24 Page 2
IBOVOP2 ;ALB/CPM-Opt/Reg Events Report Print Utilities ; 30-AUG-93
+1 ;;2.0;INTEGRATED BILLING;**52,132,153,156,167,176,234,247,339**;21-MAR-94;Build 2
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
PRINT ; Retrieve data for printing.
+1 NEW IBCOMBAT
+2 SET IBFLD1=""
IF '$DATA(^TMP("IBOVOP",$JOB))
WRITE !!,"No Outpatient activity recorded for MT/LTC copay patients on ",$$DAT1^IBOUTL(IBDATE),"."
+3 FOR
SET IBFLD1=$ORDER(^TMP("IBOVOP",$JOB,IBFLD1))
if (IBFLD1="")!(IBQUIT)
QUIT
WRITE !
if IBLINE>55
DO HDR
WRITE !,IBFLD1
Begin DoDot:1
+4 SET IBFLD2=""
FOR
SET IBFLD2=$ORDER(^TMP("IBOVOP",$JOB,IBFLD1,IBFLD2))
if (IBFLD2="")!(IBQUIT)
QUIT
Begin DoDot:2
+5 SET IBFLD3=""
FOR
SET IBFLD3=$ORDER(^TMP("IBOVOP",$JOB,IBFLD1,IBFLD2,IBFLD3))
if (IBFLD3="")!(IBQUIT)
QUIT
Begin DoDot:3
+6 SET IBSEQ=""
FOR
SET IBSEQ=$ORDER(^TMP("IBOVOP",$JOB,IBFLD1,IBFLD2,IBFLD3,IBSEQ))
if (IBSEQ="")!(IBQUIT)
QUIT
SET IBDATA=$GET(^(IBSEQ))
Begin DoDot:4
+7 SET IBFLD4=$PIECE(IBDATA,"^",1)
SET IBFLD5=$PIECE(IBDATA,"^",2)
SET IBFLD6=$PIECE(IBDATA,"^",3)
SET DFN=$PIECE(IBDATA,"^",4)
+8 SET IBCOMBAT=$$CVEDT^IBACV(DFN,IBDATE)
IF +IBCOMBAT
IF $PIECE(IBCOMBAT,"^",2)>0
WRITE !,"Veteran has CV status until "_$$DAT1^IBOUTL($PIECE(IBCOMBAT,"^",2))
+9 WRITE !?5,IBFLD2
+10 WRITE ?20,IBFLD3,?26,IBFLD4,?44,IBFLD5,?63,IBFLD6
DO CLSF(+$PIECE(IBDATA,"^",5))
if IBFLD2="OBS ADMIS"
DO CLSF^IBECEAU5(+$PIECE(IBDATA,U,6))
WRITE !
SET IBLINE=IBLINE+1
+11 if $ORDER(^TMP("IBOVOP",$JOB,IBFLD1))=""
QUIT
+12 IF IBLINE>55
DO HDR
WRITE !,IBFLD1
IF $DATA(^TMP("IBOVOP",$JOB,IBFLD1,IBFLD2,IBFLD3,IBSEQ+1))
WRITE !?5,IBFLD2
+13 IF $Y>(IOSL-5)
DO PAUSE^IBOUTL
if IBQUIT
QUIT
DO HDR
WRITE !,IBFLD1,!?5,IBFLD2
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
DO CHRGS
if IBQUIT
QUIT
+14 if 'IBQUIT
DO PAUSE^IBOUTL
+15 QUIT
+16 ;
CHRGS ; Find OP charges for day, if any. Build string for print.
+1 if '$GET(DFN)
QUIT
+2 NEW IBSTDATA
+3 IF $DATA(^IB("AFDT",DFN,-IBDATE))=10
Begin DoDot:1
+4 SET IBPRNT=""
FOR
SET IBPRNT=$ORDER(^IB("AFDT",DFN,-IBDATE,IBPRNT))
if IBPRNT=""!(IBQUIT)
QUIT
Begin DoDot:2
+5 SET IBIEN=""
FOR
SET IBIEN=$ORDER(^IB("AD",IBPRNT,IBIEN))
if IBIEN=""!(IBQUIT)
QUIT
Begin DoDot:3
+6 SET IBDATA=$GET(^IB(IBIEN,0))
if IBDATA=""
QUIT
+7 IF $Y>(IOSL-5)
DO PAUSE^IBOUTL
if IBQUIT
QUIT
DO HDR
WRITE !,IBFLD1
+8 SET IBSTAT=$PIECE($GET(^IBE(350.21,+$PIECE(IBDATA,"^",5),0)),"^",2)
+9 SET IBACT=$SELECT($PIECE($GET(^IBE(350.1,+$PIECE(IBDATA,"^",3),0)),"^",8)'="":$PIECE(^(0),"^",8),1:$PIECE(^(0),"^",1))
+10 SET IBAMT=$PIECE(IBDATA,"^",7)
+11 SET IBAMT=$SELECT(IBAMT?1N.N1"."1N:IBAMT_"0 ",IBAMT?1N.N:IBAMT_".00 ",1:IBAMT)
+12 SET IBAMT=$SELECT(IBACT["CANCEL":"*($"_IBAMT_")",1:"* $"_IBAMT)
+13 SET IBSTDATA=$GET(^IBE(352.5,+$PIECE(IBDATA,"^",20),0))
+14 IF IBSTDATA'=""
WRITE !?26,"Stop Code: ",$PIECE(IBSTDATA,"^",4),?58,"#",$PIECE(IBSTDATA,"^"),?63,$$TYPE^IBEMTSCR(+$PIECE(IBSTDATA,"^",3))
+15 WRITE !?5,IBAMT,?13,IBACT,?63,IBSTAT
SET IBLINE=IBLINE+1
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
HDR ; Print header.
+1 SET IBPAGE=IBPAGE+1
SET IBLINE=5
SET IBTITLE="Means Test/LTC Outpatient and Registration Activity for "_$$DAT1^IBOUTL(IBDATE)
+2 IF $EXTRACT(IOST,1,2)["C-"!(IBPAGE>1)
WRITE @IOF,*13
+3 WRITE ?(80-$LENGTH(IBTITLE))\2,IBTITLE
+4 SET IBTITLE="Printed: "_$$DAT1^IBOUTL(DT)
+5 WRITE !?(80-$LENGTH(IBTITLE))\2,IBTITLE,?70,"Page: "_IBPAGE
+6 WRITE !!,"Patient/Event",?20,"Time",?26,"Clinic/Stop",?44,"Appt.Type",?63,"(Status)",!
+7 QUIT
+8 ;
CLSF(IBOE) ; Display classification results.
+1 ; Input: IBOE -- Pointer to Outpatient Encounter in file #409.68
+2 IF '$GET(IBOE)
GOTO CLSFQ
+3 NEW I,IBCLS,IBCLSD,IBF
SET IBF=0
SET IBCLSD=$$ENCL^IBAMTS2(IBOE)
+4 IF IBCLSD]""
FOR I=1,2,3,4,5,6,7,8
SET IBCLS=$PIECE(IBCLSD,"^",I)
IF IBCLS]""
if 'IBF
WRITE !?6
if IBF
WRITE " "
WRITE "Care related to ",$SELECT(I=1:"AO",I=2:"IR",I=3:"SC",I=4:"SWA",I=5:"MST",I=6:"HNC",I=7:"CV",I=8:"SHAD",1:"??"),"? ",$SELECT(IBCLS:"YES",1:"NO")
SET IBF=1
CLSFQ QUIT
