FBCHCD ;AISC/DMK - COMPLETE DISPOSITION ;1/22/2015
;;3.5;FEE BASIS;**108,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
ASK S DIC="^FB7078(",DIC(0)="AEQMZ",D="D",DIC("A")="Select Veteran: ",DIC("S")="I $P(^(0),U,9)=""I""" D IX^DIC G END:$E(X)="^"!(X=""),ASK:Y<0 S (DA,FBAA78)=+Y,FBTYPE=6,FB(0)=Y(0),FBDXS="",FBFRDT=$P(FB(0),"^",4) K DIC("S"),D
EN S DIR(0)="162.4,4",DIR("A")="AUTHORIZATION TO DATE" D ^DIR
G END:$D(DUOUT)!$D(DTOUT),END:+Y'>0 S FBTODT=+Y K DIR,X,Y
I FBTODT]"",FBFRDT>FBTODT W !!,*7,?5,"Authorization To Date must be after Authorization From Date!",! G EN
S DIR(0)="162.4,4.5",DIR("A")="DATE OF DISCHARGE" D ^DIR K DIR
G END:$D(DUOUT)!$D(DTOUT),END:+Y'>0 S FBDOD=+Y K X,Y
I FBDOD]"",FBTODT>FBDOD W !!,*7,?5,"Date of Discharge must not be earlier than the Authorization To Date!",! G EN
S FBVEN=$P(FB(0),"^",2),FBVET=$P(FB(0),"^",3),DIE=DIC,DR="4////^S X=FBTODT;S:X="""" (Y,FBTODT)="""";S FBTODT=X;4.5////^S X=FBDOD" D ^DIE G END:FBTODT=""
D
. N FBX
. S FBX=$$ADDUA^FBUTL9(162.4,FBAA78_",","Complete 7078 authorization.")
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
ASKPT W ! S DIR(0)="SAO^00:SURGICAL;10:MEDICAL;86:PSYCHIATRY",DIR("A")="BEDSECTION/TREATING: ",DIR("?")="^D HELP^FBCH780" D ^DIR D NOUP:$D(DIRUT) G ASKPT:$D(DIRUT) S FBPT=Y K X,Y,DIRUT,DIR G AUTH^FBCH78
EDIT ;ENTRY TO EDIT A COMPLETED DISPOSITION
S FBEDAT=0
S DIC="^FB7078(",DIC(0)="AEMQZ",D="D",DIC("A")="Select Patient: ",DIC("S")="I $P(^(0),U,9)=""C""&($P(^(0),U,11)=6)" D IX^DIC G END:X="^"!(X=""),EDIT:Y<0 S FB7078=+Y,FBVET=$P(Y(0),"^",3),FBHTDT=$P(Y(0),"^",5),FBHFDT=$P(Y(0),"^",4)
G END:'$D(^FBAAA("AG",FB7078_";FB7078("))
D
. N FBX
. S FBX=$$ADDUA^FBUTL9(162.4,FB7078_",","Edit 7078 authorization.")
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
I $D(^FBAAI("E",FB7078_";FB7078(")) S FBEDAT=1 W !!,*7,"Payment already exists for this disposition, editing of dates not allowed!",!
I 'FBEDAT S DA=$O(^FBAA(162.2,"AM",+FB7078,0)) I DA]"" S DIE="^FBAA(162.2,",DR="4;S FBFRDT=(X\1)",DIE("NO^")="" D ^DIE K DIE,DR
I 'FBEDAT,(DA']"") G END
I 'FBEDAT,$G(FBFRDT) S DIE="^FB7078(",DA=+FB7078,DR=$S(FBHFDT'=FBFRDT:"3///^S X=FBFRDT;I 1;",1:"")_"4;S FBTODT=X",DIE("NO^")="" D ^DIE K DIE,DR
G END:+$G(FBTODT)'>0,END:'$G(FBFRDT)
I 'FBEDAT,(FBHTDT'=FBTODT),(FBTODT>$P(^FB7078(+FB7078,0),"^",16)) W !!,*7,"Date of Discharge must now be edited to be equal to or later than",!,"the Authorization To Date.",! S FBDR="4.5////^S X=FBTODT;I 1;"
I 'FBEDAT S FBDR=$G(FBDR)_"4.5;"
S FBTYPE=6,DIE="^FB7078(",DA=+FB7078,DR=$S($G(FBDR):FBDR,1:"")_"7///^S X=""@"";5ADMITTING AUTHORITY~",DIE("NO^")="" D ^DIE K DIC,DIE,D,DR,DA,FBDR
S DA(1)=FBVET,DIC="^FBAAA("_FBVET_",1,",DIC(0)="EQM",DA=$O(^FBAAA("AG",FB7078_";FB7078(",FBVET,0))
S DR=$S(FBEDAT'=1:".01////^S X=FBFRDT;",1:"")_$S(FBEDAT'=1:".02////^S X=FBTODT;",1:"")
; FB*3.5*108 edit contract
I $$EDCNTRA^FBUTL7(DA(1),DA) S DR=DR_"105;"
S DR=DR_".06;D DEFPTC^FBCHCD;.065///^S X=FBPT;.07;.021;.096;.097//^S X=""NO"""
S DR(1,161.01,1)="I $D(^FBAAA(FBVET,1,DA,2,0)) S ^FB7078(FB7078,1,0)=^(0) F FBI=1:1 Q:'$D(^FBAAA(FBVET,1,DA,2,FBI,0)) I $D(^(0)) S ^FB7078(FB7078,1,FBI,0)=^(0);101",DIE=DIC,DIE("NO^")="" W ! D ^DIE K DIE,DR,DIC
W !! G EDIT
END K DIC,DIE,DA,DR,FB,FBPROG,FBAAOUT,FBSW,FBVET,FB7078,FBHTDT,FBTODT,FBTYPE,FBAA78,FBFRDT,FBVEN,K,PTYPE,X,Y,Z,FBDEF,FBPT,FBI,FBHFDT,J,FBZZ,FBDA,FBDFN,FBDXS,FBNAME,FBSSN,FBZZ,ZZZ,FBDOD,FBEDAT
Q
DEFPTC S FBDEF=$P(^FBAAA(FBVET,1,DA,0),U,18),FBDEF=$S(FBDEF="00":"SURGICAL",FBDEF=10:"MEDICAL",FBDEF=86:"PSYCHIATRY",1:"")
N X,DP,Y,DQ S DIR(0)="SA^00:SURGICAL;10:MEDICAL;86:PSYCHIATRY",DIR("A")="BEDSECTION/TREATING SPECIALTY: ",DIR("?")="^D HELP^FBCH780",DIR("B")=FBDEF D ^DIR D NOUP:$D(DUOUT) G DEFPTC:$D(DIRUT) S FBPT=Y K DIR,DIRUT Q
NOUP W !!,*7,?5,"This is a mandatory response. Entering an '^' is not allowed!",! D HELP^FBCH780 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHCD 3952 printed Sep 02, 2024@18:42:55 Page 2
FBCHCD ;AISC/DMK - COMPLETE DISPOSITION ;1/22/2015
+1 ;;3.5;FEE BASIS;**108,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
ASK SET DIC="^FB7078("
SET DIC(0)="AEQMZ"
SET D="D"
SET DIC("A")="Select Veteran: "
SET DIC("S")="I $P(^(0),U,9)=""I"""
DO IX^DIC
if $EXTRACT(X)="^"!(X="")
GOTO END
if Y<0
GOTO ASK
SET (DA,FBAA78)=+Y
SET FBTYPE=6
SET FB(0)=Y(0)
SET FBDXS=""
SET FBFRDT=$PIECE(FB(0),"^",4)
KILL DIC("S"),D
EN SET DIR(0)="162.4,4"
SET DIR("A")="AUTHORIZATION TO DATE"
DO ^DIR
+1 if $DATA(DUOUT)!$DATA(DTOUT)
GOTO END
if +Y'>0
GOTO END
SET FBTODT=+Y
KILL DIR,X,Y
+2 IF FBTODT]""
IF FBFRDT>FBTODT
WRITE !!,*7,?5,"Authorization To Date must be after Authorization From Date!",!
GOTO EN
+3 SET DIR(0)="162.4,4.5"
SET DIR("A")="DATE OF DISCHARGE"
DO ^DIR
KILL DIR
+4 if $DATA(DUOUT)!$DATA(DTOUT)
GOTO END
if +Y'>0
GOTO END
SET FBDOD=+Y
KILL X,Y
+5 IF FBDOD]""
IF FBTODT>FBDOD
WRITE !!,*7,?5,"Date of Discharge must not be earlier than the Authorization To Date!",!
GOTO EN
+6 SET FBVEN=$PIECE(FB(0),"^",2)
SET FBVET=$PIECE(FB(0),"^",3)
SET DIE=DIC
SET DR="4////^S X=FBTODT;S:X="""" (Y,FBTODT)="""";S FBTODT=X;4.5////^S X=FBDOD"
DO ^DIE
if FBTODT=""
GOTO END
+7 Begin DoDot:1
+8 NEW FBX
+9 SET FBX=$$ADDUA^FBUTL9(162.4,FBAA78_",","Complete 7078 authorization.")
+10 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
ASKPT WRITE !
SET DIR(0)="SAO^00:SURGICAL;10:MEDICAL;86:PSYCHIATRY"
SET DIR("A")="BEDSECTION/TREATING: "
SET DIR("?")="^D HELP^FBCH780"
DO ^DIR
if $DATA(DIRUT)
DO NOUP
if $DATA(DIRUT)
GOTO ASKPT
SET FBPT=Y
KILL X,Y,DIRUT,DIR
GOTO AUTH^FBCH78
EDIT ;ENTRY TO EDIT A COMPLETED DISPOSITION
+1 SET FBEDAT=0
+2 SET DIC="^FB7078("
SET DIC(0)="AEMQZ"
SET D="D"
SET DIC("A")="Select Patient: "
SET DIC("S")="I $P(^(0),U,9)=""C""&($P(^(0),U,11)=6)"
DO IX^DIC
if X="^"!(X="")
GOTO END
if Y<0
GOTO EDIT
SET FB7078=+Y
SET FBVET=$PIECE(Y(0),"^",3)
SET FBHTDT=$PIECE(Y(0),"^",5)
SET FBHFDT=$PIECE(Y(0),"^",4)
+3 if '$DATA(^FBAAA("AG",FB7078_";FB7078("))
GOTO END
+4 Begin DoDot:1
+5 NEW FBX
+6 SET FBX=$$ADDUA^FBUTL9(162.4,FB7078_",","Edit 7078 authorization.")
+7 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+8 IF $DATA(^FBAAI("E",FB7078_";FB7078("))
SET FBEDAT=1
WRITE !!,*7,"Payment already exists for this disposition, editing of dates not allowed!",!
+9 IF 'FBEDAT
SET DA=$ORDER(^FBAA(162.2,"AM",+FB7078,0))
IF DA]""
SET DIE="^FBAA(162.2,"
SET DR="4;S FBFRDT=(X\1)"
SET DIE("NO^")=""
DO ^DIE
KILL DIE,DR
+10 IF 'FBEDAT
IF (DA']"")
GOTO END
+11 IF 'FBEDAT
IF $GET(FBFRDT)
SET DIE="^FB7078("
SET DA=+FB7078
SET DR=$SELECT(FBHFDT'=FBFRDT:"3///^S X=FBFRDT;I 1;",1:"")_"4;S FBTODT=X"
SET DIE("NO^")=""
DO ^DIE
KILL DIE,DR
+12 if +$GET(FBTODT)'>0
GOTO END
if '$GET(FBFRDT)
GOTO END
+13 IF 'FBEDAT
IF (FBHTDT'=FBTODT)
IF (FBTODT>$PIECE(^FB7078(+FB7078,0),"^",16))
WRITE !!,*7,"Date of Discharge must now be edited to be equal to or later than",!,"the Authorization To Date.",!
SET FBDR="4.5////^S X=FBTODT;I 1;"
+14 IF 'FBEDAT
SET FBDR=$GET(FBDR)_"4.5;"
+15 SET FBTYPE=6
SET DIE="^FB7078("
SET DA=+FB7078
SET DR=$SELECT($GET(FBDR):FBDR,1:"")_"7///^S X=""@"";5ADMITTING AUTHORITY~"
SET DIE("NO^")=""
DO ^DIE
KILL DIC,DIE,D,DR,DA,FBDR
+16 SET DA(1)=FBVET
SET DIC="^FBAAA("_FBVET_",1,"
SET DIC(0)="EQM"
SET DA=$ORDER(^FBAAA("AG",FB7078_";FB7078(",FBVET,0))
+17 SET DR=$SELECT(FBEDAT'=1:".01////^S X=FBFRDT;",1:"")_$SELECT(FBEDAT'=1:".02////^S X=FBTODT;",1:"")
+18 ; FB*3.5*108 edit contract
+19 IF $$EDCNTRA^FBUTL7(DA(1),DA)
SET DR=DR_"105;"
+20 SET DR=DR_".06;D DEFPTC^FBCHCD;.065///^S X=FBPT;.07;.021;.096;.097//^S X=""NO"""
+21 SET DR(1,161.01,1)="I $D(^FBAAA(FBVET,1,DA,2,0)) S ^FB7078(FB7078,1,0)=^(0) F FBI=1:1 Q:'$D(^FBAAA(FBVET,1,DA,2,FBI,0)) I $D(^(0)) S ^FB7078(FB7078,1,FBI,0)=^(0);101"
SET DIE=DIC
SET DIE("NO^")=""
WRITE !
DO ^DIE
KILL DIE,DR,DIC
+22 WRITE !!
GOTO EDIT
END KILL DIC,DIE,DA,DR,FB,FBPROG,FBAAOUT,FBSW,FBVET,FB7078,FBHTDT,FBTODT,FBTYPE,FBAA78,FBFRDT,FBVEN,K,PTYPE,X,Y,Z,FBDEF,FBPT,FBI,FBHFDT,J,FBZZ,FBDA,FBDFN,FBDXS,FBNAME,FBSSN,FBZZ,ZZZ,FBDOD,FBEDAT
+1 QUIT
DEFPTC SET FBDEF=$PIECE(^FBAAA(FBVET,1,DA,0),U,18)
SET FBDEF=$SELECT(FBDEF="00":"SURGICAL",FBDEF=10:"MEDICAL",FBDEF=86:"PSYCHIATRY",1:"")
+1 NEW X,DP,Y,DQ
SET DIR(0)="SA^00:SURGICAL;10:MEDICAL;86:PSYCHIATRY"
SET DIR("A")="BEDSECTION/TREATING SPECIALTY: "
SET DIR("?")="^D HELP^FBCH780"
SET DIR("B")=FBDEF
DO ^DIR
if $DATA(DUOUT)
DO NOUP
if $DATA(DIRUT)
GOTO DEFPTC
SET FBPT=Y
KILL DIR,DIRUT
QUIT
NOUP WRITE !!,*7,?5,"This is a mandatory response. Entering an '^' is not allowed!",!
DO HELP^FBCH780
QUIT
