Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBAHVE3

IBAHVE3.m

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