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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHAMIS 4126 printed Nov 22, 2024@17:08:55 Page 2
FBNHAMIS ;AISC/GRR-CALCULATE AMIS 349 ;18DEC00
+1 ;;3.5;FEE BASIS;**12,25**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO DT^DICRW
SET %DT="AEPMX"
SET %DT(0)=-$EXTRACT(DT,1,5)_31
SET %DT("A")="Calculate AMIS for which Month/Year: "
DO ^%DT
if X=""!(X="^")
GOTO END
SET FBPAYDT=$EXTRACT(+Y,1,5)_"00"
SET FBMM=$EXTRACT(+Y,4,5)
SET FBYY=$EXTRACT(+Y,2,3)
SET X=+Y
DO DAYS^FBAAUTL1
+4 WRITE !
SET FBDAYS=X
SET FBENDDT=$EXTRACT(+Y,1,5)_FBDAYS+.9
+5 SET DIR(0)="Y"
SET DIR("A")="Do you want data validation with this output"
SET DIR("B")="No"
SET DIR("?")="Answering 'Yes' will print who is found for each AMIS segment."
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
IF Y
SET FBVAL=1
+6 SET VAR="FBPAYDT^FBENDDT^FBDAYS^FBYY^FBVAL"
SET VAL=FBPAYDT_"^"_FBENDDT_"^"_FBDAYS_"^"_FBYY_"^"_$GET(FBVAL)
SET PGM="START^FBNHAMIS"
SET IOP="Q"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
WRITE !
START KILL FBOUT
USE IO
DO PRIOR
+1 ;current month flag
KILL ^TMP($JOB,"FBAMIS")
SET FBCUR=1
+2 FOR I=1:1:4
SET FBG(I)=0
+3 FOR I=1:1:4
SET FBL(I)=0
+4 FOR I=1,2,3
SET FBR(I)=0
+5 SET (FBASDIS,FBASDEAD,FBTRDYS,FBSC,FBFEM,TOTDAYS)=0
SET FBMONTH=$EXTRACT(FBPAYDT,1,5)_"01^"_$EXTRACT(FBENDDT,1,7)
+6 FOR FBJ=FBPAYDT:0
SET FBJ=$ORDER(^FBAACNH("B",FBJ))
if FBJ'>0!(FBJ>FBENDDT)
QUIT
FOR FBIFN=0:0
SET FBIFN=$ORDER(^FBAACNH("B",FBJ,FBIFN))
if 'FBIFN
QUIT
IF $DATA(^FBAACNH(FBIFN,0))
SET Y(0)=^(0)
SET FBTYPE=$PIECE(Y(0),"^",3)
if FBTYPE="A"
DO ADD
if FBTYPE="T"
DO TRAN
if FBTYPE="D"
DO DIS
+7 GOTO ^FBNHAMI1
END KILL %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
+1 KILL 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($JOB,"FBAMIS")
+2 DO CLOSE^FBAAUTL
+3 QUIT
PRIOR ;calculate bed occupants remaining from previous month's amis
+1 SET FBPAYHDT=FBPAYDT
+2 NEW FBR,FBPAYDT,FBENDDT,FBDAYS,FBMM,FBYY,FBYYY,FBFEM,FBTRDYS
+3 FOR I=1,2,3
SET FBR(I)=0
+4 SET (FBFEM,FBTRDYS)=0
+5 SET FBMM=$EXTRACT(FBPAYHDT,4,5)
SET FBYYY=$EXTRACT(FBPAYHDT,1,3)
+6 SET FBMM=FBMM-1
+7 IF FBMM<1
SET FBMM=12
SET FBYYY=FBYYY-1
+8 IF $LENGTH(FBMM)=1
SET FBMM="0"_FBMM
+9 IF $LENGTH(FBYYY)<3
SET FBYYY=$EXTRACT("000",0,3-$LENGTH(FBYYY))_FBYYY
+10 SET FBYY=$EXTRACT(FBYYY,2,3)
+11 SET FBPAYDT=FBYYY_FBMM_"00"
SET X=+FBPAYDT
DO DAYS^FBAAUTL1
SET FBDAYS=X
+12 SET FBENDDT=$EXTRACT(+FBPAYDT,1,5)_FBDAYS+.9
+13 DO NEXT^FBNHAMI1
+14 SET FBPRIOR=FBR(1)+FBR(2)
KILL FBPAYHDT
+15 QUIT
ADD SET ATYPE=$PIECE(Y(0),"^",6)
if ATYPE=""
QUIT
+1 SET FBSUB=$SELECT(ATYPE=1:1,ATYPE=2:3,1:2)
SET FBG(FBSUB)=FBG(FBSUB)+1
DO TMP^FBNHAMI1(FBSUB)
+2 SET DFN=$PIECE(Y(0),"^",2)
IF $$EXTPV^FBAAUTL5($PIECE($GET(^FBAAA(DFN,1,+$PIECE(Y(0),"^",10),0)),"^",7))=40
SET FBSC=FBSC+1
DO TMP^FBNHAMI1(16)
+3 QUIT
DIS SET DTYPE=$PIECE(Y(0),"^",8)
if DTYPE=""
QUIT
+1 IF DTYPE<4!(DTYPE=6)
SET FBSUB=$SELECT(DTYPE=1:1,DTYPE=6:1,1:DTYPE)
SET FBL(FBSUB)=FBL(FBSUB)+1
DO TMP^FBNHAMI1(FBSUB+4)
QUIT
+2 IF DTYPE=4
SET FBASDIS=FBASDIS+1
DO TMP^FBNHAMI1(13)
QUIT
+3 SET FBASDEAD=FBASDEAD+1
DO TMP^FBNHAMI1(14)
+4 QUIT
TRAN SET TTYPE=$PIECE(Y(0),"^",7)
if TTYPE=""
QUIT
+1 IF TTYPE=6
SET FBG(4)=FBG(4)+1
DO TMP^FBNHAMI1(4)
QUIT
+2 IF TTYPE=3
SET FBL(4)=FBL(4)+1
DO TMP^FBNHAMI1(8)
QUIT
+3 QUIT
DISCR ;print out pts whose authorization dates have been exceeded
+1 if '$DATA(FBER)
QUIT
+2 WRITE @IOF
DO HDR^FBNHPAMS
+3 WRITE !?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"
+4 WRITE !,"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,"
+5 WRITE !,"or extend their Authorization To Date. Once the data has been corrected,",!,"you may run the AMIS 349 again to obtain accurate figures."
+6 WRITE !!?10,"PATIENT",?44,"PT. ID",?55,"AUTHORIZATION TO DATE",!
+7 SET FBZ=0
FOR
SET FBZ=$ORDER(FBER(FBZ))
if 'FBZ!($GET(FBOUT))
QUIT
SET FBDD=0
FOR
SET FBDD=$ORDER(FBER(FBZ,FBDD))
if 'FBDD!($GET(FBOUT))
QUIT
DO PGCK^FBNHPAMS(3)
if $GET(FBOUT)
QUIT
Begin DoDot:1
+8 WRITE !,$SELECT(FBER(FBZ,FBDD)=1:"",1:"**"),?5,$$NAME^FBCHREQ2(FBZ),?40,$$SSN^FBAAUTL(FBZ),?60,$$DATX^FBAAUTL(FBDD)
IF FBER(FBZ,FBDD)=""
SET FBMOV=1
End DoDot:1
+9 IF $GET(FBMOV)
DO PGCK^FBNHPAMS(4)
if $GET(FBOUT)
QUIT
WRITE !!,"** indicates movement problem from the prior month that is affecting",!,"the balancing segment."
+10 QUIT
