FBNHEDDI.m

FBNHEDDI ;AISC/GRR,JPN - EDIT DISCHARGE FOR NURSING HOME ;JUL 22,2019@08:43

 ;;3.5;FEE BASIS;**154,182**;JAN 30, 1995;Build 2

 ;;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)=""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,FBAADT=$P(Y,U,2)

 S FBDIST=$P(^FBAACNH(DA,0),U,8)

 S FBJ=9999999.999999-FBAADT F  S FBJ=$O(^FBAACNH("AF",DFN,FBJ)) Q:'FBJ  S FBK=$O(^FBAACNH("AF",DFN,FBJ,0)) I $P($G(^FBAACNH(FBK,0)),"^",5)=$P(^FBAACNH(DA,0),"^",5) D  Q

 .I $P(^FBAACNH(FBK,0),"^",7)=3 S FBASIH=1

 S DIR(0)=$S($G(FBASIH):"S^4:ASIH;5:DEATH WHILE ASIH",1:"S^1:REGULAR;2:DEATH;3:TRANSFER TO OTHER CNH;6:REGULAR - PRIVATE PAY"),DIR("A")="Discharge Type: ",DIR("B")=FBDIST D ^DIR K DIR Q:$D(DIRUT)  S FBZ=+Y

 ; S DR="7////^S X=FBZ" D ^DIE

 ;FB*3.5*182 changed from 4 slashes to 3

 S DR="7///^S X=FBZ" D ^DIE

 D

 . N FB,FBDA,FBX

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

 . Q:'FBDA

 . 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)_",","Edit 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,FBASIH,FBK,FBJ,FBAADT,FBDIST,FBZ

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBNHEDDI   1461     printed  Apr 09, 2024@21:01:38                                                                                                                                                                                                    Page 2

FBNHEDDI  ;AISC/GRR,JPN - EDIT DISCHARGE FOR NURSING HOME ;JUL 22,2019@08:43

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

 +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)=""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

           SET FBAADT=$PIECE(Y,U,2)

 +1        SET FBDIST=$PIECE(^FBAACNH(DA,0),U,8)

 +2        SET FBJ=9999999.999999-FBAADT

           FOR 

               SET FBJ=$ORDER(^FBAACNH("AF",DFN,FBJ))

               if 'FBJ

                   QUIT 

               SET FBK=$ORDER(^FBAACNH("AF",DFN,FBJ,0))

               IF $PIECE($GET(^FBAACNH(FBK,0)),"^",5)=$PIECE(^FBAACNH(DA,0),"^",5)

                   Begin DoDot:1

 +3                    IF $PIECE(^FBAACNH(FBK,0),"^",7)=3

                           SET FBASIH=1

                   End DoDot:1

                   QUIT 

 +4        SET DIR(0)=$SELECT($GET(FBASIH):"S^4:ASIH;5:DEATH WHILE ASIH",1:"S^1:REGULAR;2:DEATH;3:TRANSFER TO OTHER CNH;6:REGULAR - PRIVATE PAY")

           SET DIR("A")="Discharge Type: "

           SET DIR("B")=FBDIST

           DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               QUIT 

           SET FBZ=+Y

 +5       ; S DR="7////^S X=FBZ" D ^DIE

 +6       ;FB*3.5*182 changed from 4 slashes to 3

 +7        SET DR="7///^S X=FBZ"

           DO ^DIE

 +8        Begin DoDot:1

 +9            NEW FB,FBDA,FBX

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

 +11           if 'FBDA

                   QUIT 

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

 +13           if 'FB(161)

                   QUIT 

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

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

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

                   QUIT 

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

 +17           IF 'FBX

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

           End DoDot:1

 +18       GOTO RD1

Q          KILL DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FBASIH,FBK,FBJ,FBAADT,FBDIST,FBZ

 +1        QUIT