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)
D
. 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
Q
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=""
Q
;
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.",!
Q
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.",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHEDTR 2161 printed Dec 13, 2024@01:58:59 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
