FBNHDLAD.m

FBNHDLAD ;AISC/GRR - DELETE ADMISSION FOR NURSING HOME ;1/22/15  13:18

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

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

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

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

 S FB("ADDT")=$P(Y(0),"^") ; admission date/time

 S FB(161)=$P(Y(0),"^",10)

 I $O(^FBAACNH("AC",DA,DA))>0 W !!,*7,"Other movements associated with this admission are still on file.",!,"You cannot delete the admission when other movements exist!" G CKVEIW

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

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

 I $G(FB(78)) S FB(1625)=+$O(^FBAAI("E",FB(78)_";FB7078(",0))

 I $G(FB(1625)),$D(^FBAAI(FB(1625),0)) W *7,!,"Unable to delete. Payments already made against this admission!",!! G RD1

 S DIK=DIE D ^DIK K DIK W !?5,"...deleted",!

 D PTFD^FBUTL6(DFN,FB("ADDT")) ; delete associated PTF record

 D

 . N FBX

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

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

 K FB

 G RD1

Q K DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FB,FBZZ,ZZZ

 Q

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

 G RD1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBNHDLAD   1581     printed  Apr 09, 2024@21:06:31                                                                                                                                                                                                    Page 2

FBNHDLAD  ;AISC/GRR - DELETE ADMISSION FOR NURSING HOME ;1/22/15  13:18

 +1       ;;3.5;FEE BASIS;**82,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

           WRITE !

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

           SET DIC="^FBAACNH("

           SET DIE=DIC

           SET DIC(0)="AEQMZ"

           SET DLAYGO=162.3

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

           DO ^DIC

           KILL DIC,DLAYGO

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

               GOTO RD1

           if Y<0

               GOTO RD2

           SET DA=+Y

 +1       ; admission date/time

           SET FB("ADDT")=$PIECE(Y(0),"^")

 +2        SET FB(161)=$PIECE(Y(0),"^",10)

 +3        IF $ORDER(^FBAACNH("AC",DA,DA))>0

               WRITE !!,*7,"Other movements associated with this admission are still on file.",!,"You cannot delete the admission when other movements exist!"

               GOTO CKVEIW

 +4        SET DIR("A")="Are you sure you want to delete this admission"

           SET DIR(0)="Y"

           SET DIR("B")="No"

           DO ^DIR

           KILL DIR

           if $DATA(DTOUT)!$DATA(DUOUT)

               GOTO Q

           if Y=0

               GOTO RD1

 +5        IF FB(161)

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

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

 +6        IF $GET(FB(78))

               SET FB(1625)=+$ORDER(^FBAAI("E",FB(78)_";FB7078(",0))

 +7        IF $GET(FB(1625))

               IF $DATA(^FBAAI(FB(1625),0))

                   WRITE *7,!,"Unable to delete. Payments already made against this admission!",!!

                   GOTO RD1

 +8        SET DIK=DIE

           DO ^DIK

           KILL DIK

           WRITE !?5,"...deleted",!

 +9       ; delete associated PTF record

           DO PTFD^FBUTL6(DFN,FB("ADDT"))

 +10       Begin DoDot:1

 +11           NEW FBX

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

 +13           IF 'FBX

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

           End DoDot:1

 +14       KILL FB

 +15       GOTO RD1

Q          KILL DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FB,FBZZ,ZZZ

 +1        QUIT 

CKVEIW     SET DIR("A")="Want data related to this 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=DA

           DO ^FBNHDEC

 +1        GOTO RD1