- 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 ---[H[J[2J[HFBNHDLAD 1581 printed Feb 18, 2025@23:25:13 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