IBAHVE3 ;WOIFO/SS - CV EXPIRATION REPORT ;06/16/04
;;2.0;INTEGRATED BILLING;**275**;21-MAR-94
;
START ;start report
N Y
S Y=+$$CHNGDATE(DT,-90)\1 X ^DD("DD")
S DIR(0)="DA^:NOW:EX",DIR("B")=Y,DIR("A")="From DATE: " D ^DIR K DIR I $D(DIRUT) D EXIT Q
S IBBEGDT=+Y
S DIR(0)="DA^"_+Y_":NOW:EX"
S Y=+DT\1 X ^DD("DD")
S DIR("B")=Y,DIR("A")="To DATE: " D ^DIR K DIR I $D(DIRUT) D EXIT Q
S IBENDDT=+Y
D PRNINFO(IBBEGDT,IBENDDT)
D OPEN I POP D EXIT Q
I $D(IO("Q")) D QUEUED,HOME^%ZIS D END Q
U IO
D REPORT
Q
;
REPORT ;
D PREPRPT
D PRINTRPT
D END
D EXIT
Q
;
END ;
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
D EXIT
Q
;
EXIT ; kills all vars
K IBOUT,IBPAGE,POP,IBBEGDT,IBENDDT
K IBX,IBXX,Y,DFN,IBCOL2,IBCOL3,IBCOL4,IBCOLPG,IBDONE,^TMP($J,"IBACVEXP"),DIRUT
K ZTDESC,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%ZIS,IO("Q")
D KVAR^VADPT
Q
;
OPEN ;
S %ZIS="QM" D ^%ZIS
Q
;
QUEUED ;
S ZTRTN="REPORT^IBAHVE3",ZTDESC="Current Continuous Pt Report",ZTSAVE("IBENDDT")="",ZTSAVE("IBBEGDT")=""
D ^%ZTLOAD W !!,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled")
Q
;
PREPRPT ;prepare data
; IBBEGDT - begin date ,IBENDDT - end date
S IBCOL2=23,IBCOL3=37,IBCOL4=57,IBCOLPG=70,IBDONE=0
N IBDFN,IBDT,IBDFN,IBADMDAT,IB405,IBDISCH,IBCVSTAT,IBEXPDT
;scan all admission before ENDDATE
S IBDT=0 F S IBDT=$O(^DGPM("AMV1",IBDT)) Q:+IBDT=0 Q:IBDT>IBENDDT D
. S IBDFN=0 F S IBDFN=$O(^DGPM("AMV1",IBDT,IBDFN)) Q:+IBDFN=0 D
. . S IB405=0 F S IB405=$O(^DGPM("AMV1",IBDT,IBDFN,IB405)) Q:+IB405=0 D
. . . S IBADMDAT=$G(^DGPM(IB405,0)) D:IBADMDAT>0
. . . . S IBDISCH=+$G(^DGPM(+$P(IBADMDAT,U,17),0))
. . . . ;don't include if discharge before IBBEGDT
. . . . I IBDISCH,IBDISCH<IBBEGDT Q
. . . . S IBCVSTAT=$$CVEDT^IBACV(IBDFN)
. . . . I '$P(IBCVSTAT,U,3) Q ;check if ever had CV
. . . . S IBEXPDT=+$P(IBCVSTAT,U,2)
. . . . I IBEXPDT=0 Q
. . . . I IBEXPDT<IBBEGDT Q ;if expired before IBBEGDT
. . . . I IBEXPDT>IBENDDT Q ;if expired after IBENDDT
. . . . I IBDISCH,IBEXPDT>IBDISCH Q ;if expired after discharge
. . . . I IBEXPDT<IBADMDAT Q ;if expired before admission
. . . . D SETTMP(IBDFN,+IBADMDAT,+$P(IBADMDAT,U,6),IBEXPDT)
Q
;
SETTMP(IBDFN,IBADMDT,IBWARD,IBCVDT) ;additional check and set ^TMP
;IBDFN -Pat ID,IBADMDT-admission date
;IBWARD-ward location
I '$D(^DPT(IBDFN,0)) Q
D
. N VADM,VA,VAERR,Y
. N DFN,IBPAT,IBSSN,IBADMIS,IBCVEXP
. S DFN=+IBDFN
. D DEM^VADPT
. S IBPAT=$G(VADM(1))
. S IBSSN=$P($G(VADM(2)),"^",2)
. S Y=IBADMDT\1 X ^DD("DD") S IBADMIS=Y ;date in readable form
. S Y=IBCVDT\1 X ^DD("DD") S IBCVEXP=Y ;date in readable form
. S ^TMP($J,"IBACVEXP",IBDFN,IBADMDT)=IBPAT_"^"_IBSSN_"^"_IBCVEXP_"^"_IBADMIS
Q
;
PRINTRPT ;print the report
S Y=DT X ^DD("DD")
S IBPAGE=1,IBOUT=""
D HEADER
N IBADM,IBDFN,IBTOTAL
S IBTOTAL=0
S IBDFN=0 F S IBDFN=$O(^TMP($J,"IBACVEXP",IBDFN)) Q:+IBDFN=0!(IBDONE) D
. S IBADM=0 F S IBADM=$O(^TMP($J,"IBACVEXP",IBDFN,IBADM)) Q:+IBADM=0!(IBDONE) D
. . D PRNTLINE($G(^TMP($J,"IBACVEXP",IBDFN,IBADM))) S IBTOTAL=IBTOTAL+1
I 'IBDONE D PRNTLINE("Total: "_IBTOTAL_" patient(s)")
Q
;
I IBPAGE>1,($E(IOST,1,2)="C-") S DIR(0)="E" D ^DIR K DIR I $D(DUOUT) S IBDONE=1 K DUOUT Q
I $E(IOST,1,2)["C-"!(IBPAGE>1) W @IOF
W !,?8,"***Inpatient Combat Veteran Status Expiration Report***",?IBCOLPG,"PAGE ",IBPAGE
W !,?14,"Report from " S Y=IBBEGDT\1 X ^DD("DD") W Y
W " to " S Y=IBENDDT\1 X ^DD("DD") W Y
W !,?15,"Run Date/Time: " D NOW^%DTC S Y=% X ^DD("DD") W Y
W !!,"Patient NAME",?IBCOL2,"SSN",?IBCOL3,"CV exp. date",?IBCOL4,"Date of admission"
W !!
S IBX="",$P(IBX,"=",IOM)="" W IBX,!
S IBPAGE=IBPAGE+1
Q
;
PRNTLINE(IBRECORD) ;print line of the report
;Patient NAME
W $E($P(IBRECORD,"^",1),1,21)
;SSN
W ?IBCOL2,$E($P(IBRECORD,"^",2),1,11)
;CV exp. date
W ?IBCOL3,$E($P(IBRECORD,"^",3),1,14)
;Date of admission
W ?IBCOL4,$E($P(IBRECORD,"^",4),1,14)
W !
D:$Y+4>IOSL HEADER
Q
;
CHNGDATE(DATE,CHNG) ;
N X,X1,X2
S X1=DATE,X2=CHNG D C^%DTC
Q X
;
;
PRNINFO(IBBEG,IBEND) ;
N Y
W !,"The following patients whose records indicate that they had CV status, were"
W !,"admitted for inpatient care with CV status, and their CV status has expired"
W !,"during their stays in the period of "
S Y=IBBEG X ^DD("DD")
W Y," - "
S Y=IBEND X ^DD("DD")
W Y
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAHVE3 4423 printed Sep 23, 2025@19:42:35 Page 2
IBAHVE3 ;WOIFO/SS - CV EXPIRATION REPORT ;06/16/04
+1 ;;2.0;INTEGRATED BILLING;**275**;21-MAR-94
+2 ;
START ;start report
+1 NEW Y
+2 SET Y=+$$CHNGDATE(DT,-90)\1
XECUTE ^DD("DD")
+3 SET DIR(0)="DA^:NOW:EX"
SET DIR("B")=Y
SET DIR("A")="From DATE: "
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO EXIT
QUIT
+4 SET IBBEGDT=+Y
+5 SET DIR(0)="DA^"_+Y_":NOW:EX"
+6 SET Y=+DT\1
XECUTE ^DD("DD")
+7 SET DIR("B")=Y
SET DIR("A")="To DATE: "
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO EXIT
QUIT
+8 SET IBENDDT=+Y
+9 DO PRNINFO(IBBEGDT,IBENDDT)
+10 DO OPEN
IF POP
DO EXIT
QUIT
+11 IF $DATA(IO("Q"))
DO QUEUED
DO HOME^%ZIS
DO END
QUIT
+12 USE IO
+13 DO REPORT
+14 QUIT
+15 ;
REPORT ;
+1 DO PREPRPT
+2 DO PRINTRPT
+3 DO END
+4 DO EXIT
+5 QUIT
+6 ;
END ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+2 DO ^%ZISC
+3 DO EXIT
+4 QUIT
+5 ;
EXIT ; kills all vars
+1 KILL IBOUT,IBPAGE,POP,IBBEGDT,IBENDDT
+2 KILL IBX,IBXX,Y,DFN,IBCOL2,IBCOL3,IBCOL4,IBCOLPG,IBDONE,^TMP($JOB,"IBACVEXP"),DIRUT
+3 KILL ZTDESC,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%ZIS,IO("Q")
+4 DO KVAR^VADPT
+5 QUIT
+6 ;
OPEN ;
+1 SET %ZIS="QM"
DO ^%ZIS
+2 QUIT
+3 ;
QUEUED ;
+1 SET ZTRTN="REPORT^IBAHVE3"
SET ZTDESC="Current Continuous Pt Report"
SET ZTSAVE("IBENDDT")=""
SET ZTSAVE("IBBEGDT")=""
+2 DO ^%ZTLOAD
WRITE !!,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Cancelled")
+3 QUIT
+4 ;
PREPRPT ;prepare data
+1 ; IBBEGDT - begin date ,IBENDDT - end date
+2 SET IBCOL2=23
SET IBCOL3=37
SET IBCOL4=57
SET IBCOLPG=70
SET IBDONE=0
+3 NEW IBDFN,IBDT,IBDFN,IBADMDAT,IB405,IBDISCH,IBCVSTAT,IBEXPDT
+4 ;scan all admission before ENDDATE
+5 SET IBDT=0
FOR
SET IBDT=$ORDER(^DGPM("AMV1",IBDT))
if +IBDT=0
QUIT
if IBDT>IBENDDT
QUIT
Begin DoDot:1
+6 SET IBDFN=0
FOR
SET IBDFN=$ORDER(^DGPM("AMV1",IBDT,IBDFN))
if +IBDFN=0
QUIT
Begin DoDot:2
+7 SET IB405=0
FOR
SET IB405=$ORDER(^DGPM("AMV1",IBDT,IBDFN,IB405))
if +IB405=0
QUIT
Begin DoDot:3
+8 SET IBADMDAT=$GET(^DGPM(IB405,0))
if IBADMDAT>0
Begin DoDot:4
+9 SET IBDISCH=+$GET(^DGPM(+$PIECE(IBADMDAT,U,17),0))
+10 ;don't include if discharge before IBBEGDT
+11 IF IBDISCH
IF IBDISCH<IBBEGDT
QUIT
+12 SET IBCVSTAT=$$CVEDT^IBACV(IBDFN)
+13 ;check if ever had CV
IF '$PIECE(IBCVSTAT,U,3)
QUIT
+14 SET IBEXPDT=+$PIECE(IBCVSTAT,U,2)
+15 IF IBEXPDT=0
QUIT
+16 ;if expired before IBBEGDT
IF IBEXPDT<IBBEGDT
QUIT
+17 ;if expired after IBENDDT
IF IBEXPDT>IBENDDT
QUIT
+18 ;if expired after discharge
IF IBDISCH
IF IBEXPDT>IBDISCH
QUIT
+19 ;if expired before admission
IF IBEXPDT<IBADMDAT
QUIT
+20 DO SETTMP(IBDFN,+IBADMDAT,+$PIECE(IBADMDAT,U,6),IBEXPDT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
SETTMP(IBDFN,IBADMDT,IBWARD,IBCVDT) ;additional check and set ^TMP
+1 ;IBDFN -Pat ID,IBADMDT-admission date
+2 ;IBWARD-ward location
+3 IF '$DATA(^DPT(IBDFN,0))
QUIT
+4 Begin DoDot:1
+5 NEW VADM,VA,VAERR,Y
+6 NEW DFN,IBPAT,IBSSN,IBADMIS,IBCVEXP
+7 SET DFN=+IBDFN
+8 DO DEM^VADPT
+9 SET IBPAT=$GET(VADM(1))
+10 SET IBSSN=$PIECE($GET(VADM(2)),"^",2)
+11 ;date in readable form
SET Y=IBADMDT\1
XECUTE ^DD("DD")
SET IBADMIS=Y
+12 ;date in readable form
SET Y=IBCVDT\1
XECUTE ^DD("DD")
SET IBCVEXP=Y
+13 SET ^TMP($JOB,"IBACVEXP",IBDFN,IBADMDT)=IBPAT_"^"_IBSSN_"^"_IBCVEXP_"^"_IBADMIS
End DoDot:1
+14 QUIT
+15 ;
PRINTRPT ;print the report
+1 SET Y=DT
XECUTE ^DD("DD")
+2 SET IBPAGE=1
SET IBOUT=""
+3 DO HEADER
+4 NEW IBADM,IBDFN,IBTOTAL
+5 SET IBTOTAL=0
+6 SET IBDFN=0
FOR
SET IBDFN=$ORDER(^TMP($JOB,"IBACVEXP",IBDFN))
if +IBDFN=0!(IBDONE)
QUIT
Begin DoDot:1
+7 SET IBADM=0
FOR
SET IBADM=$ORDER(^TMP($JOB,"IBACVEXP",IBDFN,IBADM))
if +IBADM=0!(IBDONE)
QUIT
Begin DoDot:2
+8 DO PRNTLINE($GET(^TMP($JOB,"IBACVEXP",IBDFN,IBADM)))
SET IBTOTAL=IBTOTAL+1
End DoDot:2
End DoDot:1
+9 IF 'IBDONE
DO PRNTLINE("Total: "_IBTOTAL_" patient(s)")
+10 QUIT
+11 ;
+1 IF IBPAGE>1
IF ($EXTRACT(IOST,1,2)="C-")
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET IBDONE=1
KILL DUOUT
QUIT
+2 IF $EXTRACT(IOST,1,2)["C-"!(IBPAGE>1)
WRITE @IOF
+3 WRITE !,?8,"***Inpatient Combat Veteran Status Expiration Report***",?IBCOLPG,"PAGE ",IBPAGE
+4 WRITE !,?14,"Report from "
SET Y=IBBEGDT\1
XECUTE ^DD("DD")
WRITE Y
+5 WRITE " to "
SET Y=IBENDDT\1
XECUTE ^DD("DD")
WRITE Y
+6 WRITE !,?15,"Run Date/Time: "
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
WRITE Y
+7 WRITE !!,"Patient NAME",?IBCOL2,"SSN",?IBCOL3,"CV exp. date",?IBCOL4,"Date of admission"
+8 WRITE !!
+9 SET IBX=""
SET $PIECE(IBX,"=",IOM)=""
WRITE IBX,!
+10 SET IBPAGE=IBPAGE+1
+11 QUIT
+12 ;
PRNTLINE(IBRECORD) ;print line of the report
+1 ;Patient NAME
+2 WRITE $EXTRACT($PIECE(IBRECORD,"^",1),1,21)
+3 ;SSN
+4 WRITE ?IBCOL2,$EXTRACT($PIECE(IBRECORD,"^",2),1,11)
+5 ;CV exp. date
+6 WRITE ?IBCOL3,$EXTRACT($PIECE(IBRECORD,"^",3),1,14)
+7 ;Date of admission
+8 WRITE ?IBCOL4,$EXTRACT($PIECE(IBRECORD,"^",4),1,14)
+9 WRITE !
+10 if $Y+4>IOSL
DO HEADER
+11 QUIT
+12 ;
CHNGDATE(DATE,CHNG) ;
+1 NEW X,X1,X2
+2 SET X1=DATE
SET X2=CHNG
DO C^%DTC
+3 QUIT X
+4 ;
+5 ;
PRNINFO(IBBEG,IBEND) ;
+1 NEW Y
+2 WRITE !,"The following patients whose records indicate that they had CV status, were"
+3 WRITE !,"admitted for inpatient care with CV status, and their CV status has expired"
+4 WRITE !,"during their stays in the period of "
+5 SET Y=IBBEG
XECUTE ^DD("DD")
+6 WRITE Y," - "
+7 SET Y=IBEND
XECUTE ^DD("DD")
+8 WRITE Y
+9 QUIT
+10 ;
