Routine: FBNHEDTR

FBNHEDTR ;AISC/GRR - EDIT TRANSFER TYPE FOR NURSING HOME ;9/19/2014

 ;;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)=""T""&($P(^(0),U,2)=DFN)",DIC="^FBAACNH(",DIE=DIC,DIC(0)="AEQMZ",DLAYGO=162.3,DIC("A")="Select Transfer Date/Time: " D ^DIC K DIC,DLAYGO G RD1:X="^"!(X=""),RD2:Y<0 S (DA,IFN)=+Y,FBAADT=$P(Y,U,2)

 S FBDA=$P(Y(0),U,5) D  I $G(FBERR) D Q G RD1

 .  I $O(^FBAACNH("AC",FBDA,DA)) W !,*7,"There are movements following this transfer that must be deleted first.",!! S FBERR=1

 S FBTR=$P(Y(0),U,7),FBLTTYP=""

 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

 . S FBLTTYP=$P(^FBAACNH(FBK,0),U,7)

 S DR="@1;6;S FBNTR=X;D CHKTR^FBNHEDTR;6////^S X=FBTR;S Y=""@1"""

 D ^DIE K DIE G Q:$D(DTOUT)

 . N FB,FBX

 . 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 transfer.")

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

 D Q G RD1

Q K DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FBTR,FBNTR,IFN,FBAADT,FBJ,FBK,FBASIH,FBDA,FBERR,FBLTTYP

CHKTR ;called from dr string to make sure that the transfer type is

 ;consistant, that is if the old transfer type (FBTR) is a loss

 ;then the new transfer type (FBNTR) is also a loss.

 I '$G(FBLTTYP),(FBTR>3&(FBNTR'>3)) D ERROR1 Q

 I '$G(FBLTTYP),(FBTR<4&(FBNTR'<4)) D ERROR Q

 S Y=""

ERROR ;write inconsistant movement type which will reset the movement type

 ;to original and allow user to re-edit.

 W !?5,*7,"Movement Type must be consistant. A transfer that is a loss",!?5,"may only be editted to another 'loss' type.",!

ERROR1 ;write inconsistant movement type 'gain', reset transfer type and re-edit

 W !?5,*7,"Movement Type must be consistant.  A transfer that is a gain",!?5,"may only be editted to another 'gain' type.",!

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHEDTR   2161     printed  Apr 23, 2025@18:13:29                                                                                                                                                                                                    Page 2

FBNHEDTR  ;AISC/GRR - EDIT TRANSFER TYPE FOR NURSING HOME ;9/19/2014

 +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

 +1       ;

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

           SET DIC="^FBAACNH("

           SET DIE=DIC

           SET DIC(0)="AEQMZ"

           SET DLAYGO=162.3

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

           DO ^DIC

           KILL DIC,DLAYGO

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

               GOTO RD1

           if Y<0

               GOTO RD2

           SET (DA,IFN)=+Y

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

 +1        SET FBDA=$PIECE(Y(0),U,5)

           Begin DoDot:1

 +2            IF $ORDER(^FBAACNH("AC",FBDA,DA))

                   WRITE !,*7,"There are movements following this transfer that must be deleted first.",!!

                   SET FBERR=1

           End DoDot:1

           IF $GET(FBERR)

               DO Q

               GOTO RD1

 +3       ;

 +4        SET FBTR=$PIECE(Y(0),U,7)

           SET FBLTTYP=""

 +5        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

 +6                    SET FBLTTYP=$PIECE(^FBAACNH(FBK,0),U,7)

                   End DoDot:1

                   QUIT

 +7        SET DR="@1;6;S FBNTR=X;D CHKTR^FBNHEDTR;6////^S X=FBTR;S Y=""@1"""

 +8        DO ^DIE

           KILL DIE

           if $DATA(DTOUT)

               GOTO Q

 +9        Begin DoDot:1

 +10           NEW FB,FBX

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

 +12           if 'FB(161)

                   QUIT

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

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

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

                   QUIT

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

 +16           IF 'FBX

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

           End DoDot:1

 +17       DO Q

           GOTO RD1

 +18      ;

Q          KILL DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FBTR,FBNTR,IFN,FBAADT,FBJ,FBK,FBASIH,FBDA,FBERR,FBLTTYP

 +1        QUIT

CHKTR     ;called from dr string to make sure that the transfer type is

 +1       ;consistant, that is if the old transfer type (FBTR) is a loss

 +2       ;then the new transfer type (FBNTR) is also a loss.

 +3       ;

 +4        IF '$GET(FBLTTYP)

               IF (FBTR>3&(FBNTR'>3))

                   DO ERROR1

                   QUIT

 +5        IF '$GET(FBLTTYP)

               IF (FBTR<4&(FBNTR'<4))

                   DO ERROR

                   QUIT

 +6        SET Y=""

 +7        QUIT

 +8       ;

ERROR     ;write inconsistant movement type which will reset the movement type

 +1       ;to original and allow user to re-edit.

 +2       ;

 +3        WRITE !?5,*7,"Movement Type must be consistant. A transfer that is a loss",!?5,"may only be editted to another 'loss' type.",!

 +4        QUIT

ERROR1    ;write inconsistant movement type 'gain', reset transfer type and re-edit

 +1       ;

 +2        WRITE !?5,*7,"Movement Type must be consistant.  A transfer that is a gain",!?5,"may only be editted to another 'gain' type.",!

 +3        QUIT

FBNHEDTR.m