FBNHDLDI.m

FBNHDLDI ;AISC/GRR - DELETE DISCHARGE FOR NURSING HOME ;1/22/15  13:39

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

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

RD1 D GETVET^FBAAUTL1 G:DFN']"" Q

 I $D(^FBAACNH("AD",DFN)) W !!,*7,"Veteran presently has an active admission.",!,"You cannot delete a discharge when there is an active admission!",! G CKVEIW

RD2 S DIC("S")="I $P(^(0),U,3)=""D""&($P(^(0),U,2)=DFN)",DIC="^FBAACNH(",DIE=DIC,DIC(0)="AEQMZ",DLAYGO=162.3,DIC("A")="Select Discharge Date/Time: " D ^DIC K DIC,DLAYGO G RD1:X="^"!(X=""),RD2:Y<0 S DA=+Y

 S FBCKDT=+Y(0) I $O(^FBAACNH("AF",DFN,0))<(9999999.9999-FBCKDT) W !!,*7,"There is activity following this discharge date.",!,"You must delete all subsequent activity before deleting this discharge." G RD1

 S FBDA=$P(^FBAACNH(DA,0),"^",5)

 S DIR("A")="Are you sure you want to delete this discharge",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G Q:$D(DTOUT),RD1:$D(DUOUT)!(Y=0)

 S DIK="^FBAACNH(" D ^DIK S DIE="^FBAACNH(",DR="3////^S X=""Y""",DA=FBDA D ^DIE W !?5,"... deleted" D ALERT

 I DFN D

 . N FB,FBX

 . S FB(161)=$S(FBDA:$P($G(^FBAACNH(FBDA,0)),"^",10),1:"")

 . Q:'FB(161)

 . I $D(^FBAAA(DFN,1,FB(161),0)) S FB(78)=+$P(^(0),"^",9)

 . Q:'$G(FB(78))

 . S FBX=$$ADDUA^FBUTL9(162.4,FB(78)_",","Delete CNH discharge.")

 . I 'FBX W !,"Error adding record in User Audit. Please contact IRM."

 G RD1

Q K DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FBDA,FBCKDT

 Q

CKVEIW S DIR("A")="Want data related to active admission displayed",DIR("B")="No",DIR(0)="Y" D ^DIR K DIR G RD1:$D(DTOUT)!$D(DUOUT)!(Y=0) S IFN=$O(^FBAACNH("AD",DFN,0)) D ^FBNHDEC

 G RD1

ALERT W !!,*7,"It will be necessary to adjust the 'TO DATE' of this patient's authorization",!,"using the 'EDIT CNH AUTHORIZATION' option."

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBNHDLDI   1781     printed  Apr 09, 2024@21:03:27                                                                                                                                                                                                    Page 2

FBNHDLDI  ;AISC/GRR - DELETE DISCHARGE FOR NURSING HOME ;1/22/15  13:39

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

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

RD1        DO GETVET^FBAAUTL1

           if DFN']""

               GOTO Q

 +1        IF $DATA(^FBAACNH("AD",DFN))

               WRITE !!,*7,"Veteran presently has an active admission.",!,"You cannot delete a discharge when there is an active admission!",!

               GOTO CKVEIW

RD2        SET DIC("S")="I $P(^(0),U,3)=""D""&($P(^(0),U,2)=DFN)"

           SET DIC="^FBAACNH("

           SET DIE=DIC

           SET DIC(0)="AEQMZ"

           SET DLAYGO=162.3

           SET DIC("A")="Select Discharge Date/Time: "

           DO ^DIC

           KILL DIC,DLAYGO

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

               GOTO RD1

           if Y<0

               GOTO RD2

           SET DA=+Y

 +1        SET FBCKDT=+Y(0)

           IF $ORDER(^FBAACNH("AF",DFN,0))<(9999999.9999-FBCKDT)

               WRITE !!,*7,"There is activity following this discharge date.",!,"You must delete all subsequent activity before deleting this discharge."

               GOTO RD1

 +2        SET FBDA=$PIECE(^FBAACNH(DA,0),"^",5)

 +3        SET DIR("A")="Are you sure you want to delete this discharge"

           SET DIR(0)="Y"

           SET DIR("B")="No"

           DO ^DIR

           KILL DIR

           if $DATA(DTOUT)

               GOTO Q

           if $DATA(DUOUT)!(Y=0)

               GOTO RD1

 +4        SET DIK="^FBAACNH("

           DO ^DIK

           SET DIE="^FBAACNH("

           SET DR="3////^S X=""Y"""

           SET DA=FBDA

           DO ^DIE

           WRITE !?5,"... deleted"

           DO ALERT

 +5        IF DFN

               Begin DoDot:1

 +6                NEW FB,FBX

 +7                SET FB(161)=$SELECT(FBDA:$PIECE($GET(^FBAACNH(FBDA,0)),"^",10),1:"")

 +8                if 'FB(161)

                       QUIT 

 +9                IF $DATA(^FBAAA(DFN,1,FB(161),0))

                       SET FB(78)=+$PIECE(^(0),"^",9)

 +10               if '$GET(FB(78))

                       QUIT 

 +11               SET FBX=$$ADDUA^FBUTL9(162.4,FB(78)_",","Delete CNH discharge.")

 +12               IF 'FBX

                       WRITE !,"Error adding record in User Audit. Please contact IRM."

               End DoDot:1

 +13       GOTO RD1

Q          KILL DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FBDA,FBCKDT

 +1        QUIT 

CKVEIW     SET DIR("A")="Want data related to active admission displayed"

           SET DIR("B")="No"

           SET DIR(0)="Y"

           DO ^DIR

           KILL DIR

           if $DATA(DTOUT)!$DATA(DUOUT)!(Y=0)

               GOTO RD1

           SET IFN=$ORDER(^FBAACNH("AD",DFN,0))

           DO ^FBNHDEC

 +1        GOTO RD1

ALERT      WRITE !!,*7,"It will be necessary to adjust the 'TO DATE' of this patient's authorization",!,"using the 'EDIT CNH AUTHORIZATION' option."