Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBNHDLAD

FBNHDLAD.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. RD1 D GETVET^FBAAUTL1 G:DFN']"" Q W !
  1. 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
  1. S FB("ADDT")=$P(Y(0),"^") ; admission date/time
  1. S FB(161)=$P(Y(0),"^",10)
  1. 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
  1. 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
  1. I FB(161),$D(^FBAAA(DFN,1,FB(161),0)) S FB(78)=$P($P(^(0),"^",9),";")
  1. I $G(FB(78)) S FB(1625)=+$O(^FBAAI("E",FB(78)_";FB7078(",0))
  1. I $G(FB(1625)),$D(^FBAAI(FB(1625),0)) W *7,!,"Unable to delete. Payments already made against this admission!",!! G RD1
  1. S DIK=DIE D ^DIK K DIK W !?5,"...deleted",!
  1. D PTFD^FBUTL6(DFN,FB("ADDT")) ; delete associated PTF record
  1. D
  1. . N FBX
  1. . S FBX=$$ADDUA^FBUTL9(162.4,FB(78)_",","Delete CNH admission.")
  1. . I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
  1. K FB
  1. G RD1
  1. Q K DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FB,FBZZ,ZZZ
  1. Q
  1. 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
  1. G RD1