FBNHAMIS ;AISC/GRR-CALCULATE AMIS 349 ;18DEC00
 ;;3.5;FEE BASIS;**12,25**;JAN 30, 1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 D DT^DICRW S %DT="AEPMX",%DT(0)=-$E(DT,1,5)_31,%DT("A")="Calculate AMIS for which Month/Year: " D ^%DT G:X=""!(X="^") END S FBPAYDT=$E(+Y,1,5)_"00",FBMM=$E(+Y,4,5),FBYY=$E(+Y,2,3),X=+Y D DAYS^FBAAUTL1
 W ! S FBDAYS=X,FBENDDT=$E(+Y,1,5)_FBDAYS+.9
 S DIR(0)="Y",DIR("A")="Do you want data validation with this output",DIR("B")="No",DIR("?")="Answering 'Yes' will print who is found for each AMIS segment." D ^DIR K DIR G:$D(DIRUT) END I Y S FBVAL=1
 S VAR="FBPAYDT^FBENDDT^FBDAYS^FBYY^FBVAL",VAL=FBPAYDT_"^"_FBENDDT_"^"_FBDAYS_"^"_FBYY_"^"_$G(FBVAL),PGM="START^FBNHAMIS",IOP="Q" D ZIS^FBAAUTL G:FBPOP END W !
START K FBOUT U IO D PRIOR
 K ^TMP($J,"FBAMIS") S FBCUR=1 ;current month flag
 F I=1:1:4 S FBG(I)=0
 F I=1:1:4 S FBL(I)=0
 F I=1,2,3 S FBR(I)=0
 S (FBASDIS,FBASDEAD,FBTRDYS,FBSC,FBFEM,TOTDAYS)=0,FBMONTH=$E(FBPAYDT,1,5)_"01^"_$E(FBENDDT,1,7)
 F FBJ=FBPAYDT:0 S FBJ=$O(^FBAACNH("B",FBJ)) Q:FBJ'>0!(FBJ>FBENDDT)  F FBIFN=0:0 S FBIFN=$O(^FBAACNH("B",FBJ,FBIFN)) Q:'FBIFN  I $D(^FBAACNH(FBIFN,0)) S Y(0)=^(0),FBTYPE=$P(Y(0),"^",3) D ADD:FBTYPE="A",TRAN:FBTYPE="T",DIS:FBTYPE="D"
 G ^FBNHAMI1
END K %DT,FB,FBSW,FBG,FBL,FBR,IFN,DFN,FBLTT,FBNAC,FBPNAC,FBZ,FBPRTR,FBDD,FBENDDT,FBPAYDT,FBDAYS,TOTDAYS,FBRIFN,FBPIFN,FBTRDYS,FBFEM,FBSC,FBASIH,Z,Y,FBJ,FBTYPE,ATYPE,DTYPE,TTYPE,VAR,VAL,PGM,FBCUR,FBCHK,FBPRIOR,FBMOV,FBPG
 K FBABD,FBASDEAD,FBASDIS,FBDEFP,FBEDT,FBERR,FBHIFN,FBIFN,FBIRAT,FBMM,FBMONTH,FBMULT,FBNHCC,FBONE,FBPREV,FBSRAT,FBSUB,FBTDT,FBTOTAL,FBTWO,FBUL,FBVCAR,FBYY,I,X,X1,Z1,Z2,FBTOT,FBCOUNT,FBPSW,FBER,FBZZ,FBVAL,FBDV,FBOUT,^TMP($J,"FBAMIS")
 D CLOSE^FBAAUTL
 Q
PRIOR ;calculate bed occupants remaining from previous month's amis
 S FBPAYHDT=FBPAYDT
 N FBR,FBPAYDT,FBENDDT,FBDAYS,FBMM,FBYY,FBYYY,FBFEM,FBTRDYS
 F I=1,2,3 S FBR(I)=0
 S (FBFEM,FBTRDYS)=0
 S FBMM=$E(FBPAYHDT,4,5),FBYYY=$E(FBPAYHDT,1,3)
 S FBMM=FBMM-1
 I FBMM<1 S FBMM=12,FBYYY=FBYYY-1
 I $L(FBMM)=1 S FBMM="0"_FBMM
 I $L(FBYYY)<3 S FBYYY=$E("000",0,3-$L(FBYYY))_FBYYY
 S FBYY=$E(FBYYY,2,3)
 S FBPAYDT=FBYYY_FBMM_"00",X=+FBPAYDT D DAYS^FBAAUTL1 S FBDAYS=X
 S FBENDDT=$E(+FBPAYDT,1,5)_FBDAYS+.9
 D NEXT^FBNHAMI1
 S FBPRIOR=FBR(1)+FBR(2) K FBPAYHDT
 Q
ADD S ATYPE=$P(Y(0),"^",6) Q:ATYPE=""
 S FBSUB=$S(ATYPE=1:1,ATYPE=2:3,1:2),FBG(FBSUB)=FBG(FBSUB)+1 D TMP^FBNHAMI1(FBSUB)
 S DFN=$P(Y(0),"^",2) I $$EXTPV^FBAAUTL5($P($G(^FBAAA(DFN,1,+$P(Y(0),"^",10),0)),"^",7))=40 S FBSC=FBSC+1 D TMP^FBNHAMI1(16)
 Q
DIS S DTYPE=$P(Y(0),"^",8) Q:DTYPE=""
 I DTYPE<4!(DTYPE=6) S FBSUB=$S(DTYPE=1:1,DTYPE=6:1,1:DTYPE),FBL(FBSUB)=FBL(FBSUB)+1 D TMP^FBNHAMI1(FBSUB+4) Q
 I DTYPE=4 S FBASDIS=FBASDIS+1 D TMP^FBNHAMI1(13) Q
 S FBASDEAD=FBASDEAD+1 D TMP^FBNHAMI1(14)
 Q
TRAN S TTYPE=$P(Y(0),"^",7) Q:TTYPE=""
 I TTYPE=6 S FBG(4)=FBG(4)+1 D TMP^FBNHAMI1(4) Q
 I TTYPE=3 S FBL(4)=FBL(4)+1 D TMP^FBNHAMI1(8) Q
 Q
DISCR ;print out pts whose authorization dates have been exceeded
 Q:'$D(FBER)
 W @IOF D HDR^FBNHPAMS
 W !?5,">>>NOTICE OF INCOMPLETE PATIENT MOVEMENTS AFFECTING AMIS TOTALS<<<",!!!,"The following patient(s) have met or exceeded their authorizations, and have",!,"not been discharged.  This will result in inaccurate AMIS 349 calculations"
 W !,"for the current month's amis, and will affect the balancing segment for",!,"subsequent months!!",!!,"To obtain an accurate AMIS, you must either discharge the patient,"
 W !,"or extend their Authorization To Date.  Once the data has been corrected,",!,"you may run the AMIS 349 again to obtain accurate figures."
 W !!?10,"PATIENT",?44,"PT. ID",?55,"AUTHORIZATION TO DATE",!
 S FBZ=0 F  S FBZ=$O(FBER(FBZ)) Q:'FBZ!($G(FBOUT))  S FBDD=0 F  S FBDD=$O(FBER(FBZ,FBDD)) Q:'FBDD!($G(FBOUT))  D PGCK^FBNHPAMS(3) Q:$G(FBOUT)  D
 .W !,$S(FBER(FBZ,FBDD)=1:"",1:"**"),?5,$$NAME^FBCHREQ2(FBZ),?40,$$SSN^FBAAUTL(FBZ),?60,$$DATX^FBAAUTL(FBDD) I FBER(FBZ,FBDD)="" S FBMOV=1
 I $G(FBMOV) D PGCK^FBNHPAMS(4) Q:$G(FBOUT)  W !!,"** indicates movement problem from the prior month that is affecting",!,"the balancing segment."
 Q