- FBNHEDAD ;AISC/GRR - EDIT ADMISSION TYPE FOR NURSING HOME ;1/22/15 14:49
- ;;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
- 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 DR="5;8" D ^DIE
- D
- . N FB,FBX,DTOUT
- . S FB(161)=$S(DA:$P($G(^FBAACNH(DA,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)_",","Edit CNH admission.")
- . I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
- G RD1:'$D(DTOUT)
- Q K DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHEDAD 823 printed Feb 18, 2025@23:25:21 Page 2
- FBNHEDAD ;AISC/GRR - EDIT ADMISSION TYPE FOR NURSING HOME ;1/22/15 14:49
- +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
- 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 SET DR="5;8"
- DO ^DIE
- +2 Begin DoDot:1
- +3 NEW FB,FBX,DTOUT
- +4 SET FB(161)=$SELECT(DA:$PIECE($GET(^FBAACNH(DA,0)),"^",10),1:"")
- +5 if 'FB(161)
- QUIT
- +6 IF $DATA(^FBAAA(DFN,1,FB(161),0))
- SET FB(78)=+$PIECE(^(0),"^",9)
- +7 if '$GET(FB(78))
- QUIT
- +8 SET FBX=$$ADDUA^FBUTL9(162.4,FB(78)_",","Edit CNH admission.")
- +9 IF 'FBX
- WRITE !,"Error adding record in User Audit. Please contact IRM."
- End DoDot:1
- +10 if '$DATA(DTOUT)
- GOTO RD1
- Q KILL DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG
- +1 QUIT
