Routine: FBCHC78

FBCHC78 ;AISC/DMK - CANCEL A 7078 ;8/25/14  15:22

 ;;3.5;FEE BASIS;**82,154**;JAN 30, 1995;Build 12

 ;;Per VA Directive 6402, this routine should not be modified.

 Q:'$G(DUZ)

 ;get station number from site parameter file

 D SITEP^FBAAUTL G END:FBPOP

 S FBPSA=$E($P($G(^DIC(4,+$P($G(FBSITE(1)),"^",3),99)),"^"),1,3)

ASK ;get 7078 entry to cancel

 W ! S DIC(0)="AEQMZ",DIC="^FB7078(",D="D",DIC("A")="Select Patient: ",DIC("S")="I $P(^(0),U,9)'=""DC""&($P(^(0),U,11)=$S($D(FBNH):7,1:6))" D IX^DIC K DIC,D G END:X=""!(X="^"),ASK:Y<0

 S FB7078=+Y_";FB7078(",FBAAOB=FBPSA_"-"_$P(Y(0,0),".")_"-"_$P(Y(0,0),".",2),DFN=+$P(Y(0),"^",3),FB(161)=+$O(^FBAAA("AG",FB7078,DFN,0)),FBMM=$E($P(Y(0),U,4),4,5)

 S FBADDT=$P(Y(0),U,4),FBVEN=$P(Y(0),U,2)

 I $D(FBNH) S DIC="^FBAACNH(",DIC(0)="MZ",DIC("S")="I $P(^(0),U,2)=DFN&($P(^(0),U,10)=FB(161))",X=$P(Y(0),U,4) D ^DIC K DIC I +Y>0 W !,*7,"Must delete all movements associated with this authorization before canceling.",! G END

 ;check if payments made against the 7078

 ;if so do not allow a user to cancel

 I $D(^FBAAI("E",FB7078)) W !!,*7,"There is already an invoice entered for this hospitalization.  Cannot delete!",!! G END

 I $D(^FBAAC("AM",FB7078)) W !!,*7,"There already are ancillary services entered against this authorization.  Cannot delete!",!! G END

 ;display 7078 and ask if ok to cancel

 S DA=+FB7078,DIC="^FB7078(",DR="0;1" D EN^DIQ

 W ! S DIR(0)="Y",DIR("A")="Are you sure you want to cancel",DIR("B")="No" D ^DIR K DIR G FBCHC78:'Y,END:$D(DIRUT)

 ;cancelling 7078 and associated athorization in file 161

 ;deleting associated 7078 from the notification file in civil hospital

 ;remove entries assoiciated with CNH in 161.23

 ;removing estimated amount from 1358

 I '$D(FBNH) S DA=$O(^FBAA(162.2,"AM",+FB7078,0)) I DA S DIE="^FBAA(162.2,",DR="16///@" D ^DIE K DIC,DIE W " ."

 S DA(1)=DFN,DA=$O(^FBAAA("AG",FB7078,DFN,0)) I DA S DIK="^FBAAA("_DFN_",1," D ^DIK K DIK,DA W "."

 S DA=+FB7078,DIE="^FB7078(",DR=".013////^S X=DUZ;.014////^S X=DT;9////^S X=""DC""" D ^DIE K DIE,DIC W "."

 I $D(FBNH) S FBI=0 F  S FBI=$O(^FBAA(161.23,"AC",+FB7078,FBI)) Q:'FBI  I $D(^FBAA(161.23,FBI,0)) D

 . S DA=FBI,DIK="^FBAA(161.23," D ^DIK K DIK W "."

 ; if cancelled civil hospital 7078 then delete associated PTF record

 I '$G(FBNH) D PTFD^FBUTL6(DFN,FBADDT)

 W !!,"Authorization cancelled.  Now updating 1358.",!

 D 1358 I $D(FBERR) W !,"Unable to affect 1358 adjustment.  Use appropriate IFCAP options.",!

 W "...  Finished",!

END K DA,DR,DIE,DIC,DFN,FB,FBI,FB7078,FBAAOB,FBERR,PRC,PRCS,PRCSX,FBPSA,FBZZ,FBSITE,X,Y,FBPOP,FBNH,FBMM,FBADDT,FBVEN

1358 ;subtract estimated dollar amount from 1358

 ;FBAAOB=FULL OBLIGATION NUMBER (STATION #-OBLIGATION #-REF #)

 ;FBERR returned if IFCAP call fails

 ;internal entry # in 424 = $O(^PRC(424,"B",FBAAOB,0))

 ;check if 1358 available for posting

 I '$$INTER() W !,*7,"Unable to locate reference number on 1358.",! S FBERR=1 Q

 S PRCS("X")=$P(FBAAOB,"-",1,2),PRCS("TYPE")="FB" D EN3^PRCS58 I Y=-1 W !,*7,"1358 Not available for posting.",! S FBERR=1 Q

 D NOW^%DTC

 S PRCSX=$$INTER()_"^"_%_"^"_0_"^"_"Authorization has been cancelled"_"^"_1_"^"

 S PRCS("TYPE")="FB" D ^PRCS58CC I Y'=1 W !,*7,$P(Y,"^",2),! S FBERR=1 Q

INTER() ;get internal entry number from file 424

 ;first check interface id x-ref

 ;second check is to "B" x-ref to stay backward compatible with IFCAP3.6

 I '$G(FBNH),$D(^PRC(424,"E",DFN_";"_+FB7078_";"_$P(FBAAOB,"-",2))) Q $O(^(DFN_";"_+FB7078_";"_$P(FBAAOB,"-",2),0))

 I $G(FBNH),$D(^PRC(424,"E",DFN_";"_+FB7078_";"_$P(FBAAOB,"-",2)_";"_FBMM)) Q $O(^(DFN_";"_+FB7078_";"_$P(FBAAOB,"-",2)_";"_FBMM,0))

 I $D(^PRC(424,"B",FBAAOB)) Q $O(^(FBAAOB,0))

Q 0

CNH ;entry point to cancel an authorization associated with the

 ;community nursing home program.

 S FBNH=1 G FBCHC78

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHC78   3871     printed  Mar 13, 2025@21:02:14                                                                                                                                                                                                     Page 2

FBCHC78   ;AISC/DMK - CANCEL A 7078 ;8/25/14  15:22

 +1       ;;3.5;FEE BASIS;**82,154**;JAN 30, 1995;Build 12

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3        if '$GET(DUZ)

               QUIT

 +4       ;

 +5       ;get station number from site parameter file

 +6        DO SITEP^FBAAUTL

           if FBPOP

               GOTO END

 +7        SET FBPSA=$EXTRACT($PIECE($GET(^DIC(4,+$PIECE($GET(FBSITE(1)),"^",3),99)),"^"),1,3)

 +8       ;

ASK       ;get 7078 entry to cancel

 +1        WRITE !

           SET DIC(0)="AEQMZ"

           SET DIC="^FB7078("

           SET D="D"

           SET DIC("A")="Select Patient: "

           SET DIC("S")="I $P(^(0),U,9)'=""DC""&($P(^(0),U,11)=$S($D(FBNH):7,1:6))"

           DO IX^DIC

           KILL DIC,D

           if X=""!(X="^")

               GOTO END

           if Y<0

               GOTO ASK

 +2        SET FB7078=+Y_";FB7078("

           SET FBAAOB=FBPSA_"-"_$PIECE(Y(0,0),".")_"-"_$PIECE(Y(0,0),".",2)

           SET DFN=+$PIECE(Y(0),"^",3)

           SET FB(161)=+$ORDER(^FBAAA("AG",FB7078,DFN,0))

           SET FBMM=$EXTRACT($PIECE(Y(0),U,4),4,5)

 +3        SET FBADDT=$PIECE(Y(0),U,4)

           SET FBVEN=$PIECE(Y(0),U,2)

 +4        IF $DATA(FBNH)

               SET DIC="^FBAACNH("

               SET DIC(0)="MZ"

               SET DIC("S")="I $P(^(0),U,2)=DFN&($P(^(0),U,10)=FB(161))"

               SET X=$PIECE(Y(0),U,4)

               DO ^DIC

               KILL DIC

               IF +Y>0

                   WRITE !,*7,"Must delete all movements associated with this authorization before canceling.",!

                   GOTO END

 +5       ;

 +6       ;check if payments made against the 7078

 +7       ;if so do not allow a user to cancel

 +8        IF $DATA(^FBAAI("E",FB7078))

               WRITE !!,*7,"There is already an invoice entered for this hospitalization.  Cannot delete!",!!

               GOTO END

 +9        IF $DATA(^FBAAC("AM",FB7078))

               WRITE !!,*7,"There already are ancillary services entered against this authorization.  Cannot delete!",!!

               GOTO END

 +10      ;

 +11      ;display 7078 and ask if ok to cancel

 +12       SET DA=+FB7078

           SET DIC="^FB7078("

           SET DR="0;1"

           DO EN^DIQ

 +13       WRITE !

           SET DIR(0)="Y"

           SET DIR("A")="Are you sure you want to cancel"

           SET DIR("B")="No"

           DO ^DIR

           KILL DIR

           if 'Y

               GOTO FBCHC78

           if $DATA(DIRUT)

               GOTO END

 +14      ;

 +15      ;cancelling 7078 and associated athorization in file 161

 +16      ;deleting associated 7078 from the notification file in civil hospital

 +17      ;remove entries assoiciated with CNH in 161.23

 +18      ;removing estimated amount from 1358

 +19       IF '$DATA(FBNH)

               SET DA=$ORDER(^FBAA(162.2,"AM",+FB7078,0))

               IF DA

                   SET DIE="^FBAA(162.2,"

                   SET DR="16///@"

                   DO ^DIE

                   KILL DIC,DIE

                   WRITE " ."

 +20       SET DA(1)=DFN

           SET DA=$ORDER(^FBAAA("AG",FB7078,DFN,0))

           IF DA

               SET DIK="^FBAAA("_DFN_",1,"

               DO ^DIK

               KILL DIK,DA

               WRITE "."

 +21       SET DA=+FB7078

           SET DIE="^FB7078("

           SET DR=".013////^S X=DUZ;.014////^S X=DT;9////^S X=""DC"""

           DO ^DIE

           KILL DIE,DIC

           WRITE "."

 +22       IF $DATA(FBNH)

               SET FBI=0

FOR

                   SET FBI=$ORDER(^FBAA(161.23,"AC",+FB7078,FBI))

                   if 'FBI

                       QUIT

                   IF $DATA(^FBAA(161.23,FBI,0))

                       Begin DoDot:1

 +23                       SET DA=FBI

                           SET DIK="^FBAA(161.23,"

                           DO ^DIK

                           KILL DIK

                           WRITE "."

                       End DoDot:1

 +24      ; if cancelled civil hospital 7078 then delete associated PTF record

 +25       IF '$GET(FBNH)

               DO PTFD^FBUTL6(DFN,FBADDT)

 +26       WRITE !!,"Authorization cancelled.  Now updating 1358.",!

 +27       DO 1358

           IF $DATA(FBERR)

               WRITE !,"Unable to affect 1358 adjustment.  Use appropriate IFCAP options.",!

 +28       WRITE "...  Finished",!

 +29      ;

END        KILL DA,DR,DIE,DIC,DFN,FB,FBI,FB7078,FBAAOB,FBERR,PRC,PRCS,PRCSX,FBPSA,FBZZ,FBSITE,X,Y,FBPOP,FBNH,FBMM,FBADDT,FBVEN

 +1        QUIT

1358      ;subtract estimated dollar amount from 1358

 +1       ;FBAAOB=FULL OBLIGATION NUMBER (STATION #-OBLIGATION #-REF #)

 +2       ;FBERR returned if IFCAP call fails

 +3       ;internal entry # in 424 = $O(^PRC(424,"B",FBAAOB,0))

 +4       ;

 +5       ;check if 1358 available for posting

 +6        IF '$$INTER()

               WRITE !,*7,"Unable to locate reference number on 1358.",!

               SET FBERR=1

               QUIT

 +7        SET PRCS("X")=$PIECE(FBAAOB,"-",1,2)

           SET PRCS("TYPE")="FB"

           DO EN3^PRCS58

           IF Y=-1

               WRITE !,*7,"1358 Not available for posting.",!

               SET FBERR=1

               QUIT

 +8        DO NOW^%DTC

 +9        SET PRCSX=$$INTER()_"^"_%_"^"_0_"^"_"Authorization has been cancelled"_"^"_1_"^"

 +10       SET PRCS("TYPE")="FB"

           DO ^PRCS58CC

           IF Y'=1

               WRITE !,*7,$PIECE(Y,"^",2),!

               SET FBERR=1

               QUIT

 +11       QUIT

 +12      ;

INTER()   ;get internal entry number from file 424

 +1       ;first check interface id x-ref

 +2       ;second check is to "B" x-ref to stay backward compatible with IFCAP3.6

 +3       ;

 +4        IF '$GET(FBNH)

               IF $DATA(^PRC(424,"E",DFN_";"_+FB7078_";"_$PIECE(FBAAOB,"-",2)))

                   QUIT $ORDER(^(DFN_";"_+FB7078_";"_$PIECE(FBAAOB,"-",2),0))

 +5        IF $GET(FBNH)

               IF $DATA(^PRC(424,"E",DFN_";"_+FB7078_";"_$PIECE(FBAAOB,"-",2)_";"_FBMM))

                   QUIT $ORDER(^(DFN_";"_+FB7078_";"_$PIECE(FBAAOB,"-",2)_";"_FBMM,0))

 +6        IF $DATA(^PRC(424,"B",FBAAOB))

               QUIT $ORDER(^(FBAAOB,0))

 +7        QUIT 0

 +8       ;

CNH       ;entry point to cancel an authorization associated with the

 +1       ;community nursing home program.

 +2        SET FBNH=1

           GOTO FBCHC78

 +3        QUIT

FBCHC78.m