- 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 Jan 18, 2025@03:07: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 ;