- 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 Jan 18, 2025@02:58:45 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