FBNHEDA1 ;AISC/DMK-EDIT CNH AUTHORIZATION CONT ;4/28/93 11:05
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
I FBO'=FBAA(1) D Q:FBERR
.D CK I FBERR D
..S DA(1)=$G(DFN),DA=$G(FTP),DIE="^FBAAA("_DA(1)_",1,",DR=".01////^S X=FBO;.02////^S X=FB1" D ^DIE K DIE,DR
.D DEL
.D FILE^FBNHEAU2
;
UPDATE ;called from edit authorization and FBNHED (enter discharge)
I FBO=FBAA(1),FB1'=FBAA(2) D GET D
.I FB1>FBAA(2) S (X,HOLDX)=$O(FBZ(FBAA(2)-.9)),X=$G(FBZ(+X)) I X D
..S DA=X,DIE="^FBAA(161.23,",DR=".02////^S X="_FBAA(2) D ^DIE K DIE,DR
..N FBI F FBI=HOLDX:0 S FBI=$O(FBZ(FBI)) Q:'FBI D
...S DA=FBZ(FBI),DIK="^FBAA(161.23," D ^DIK K DIK
.I FBAA(2)>FB1 D
..S X=$O(^FBAA(161.23,"AD",FB7078,-(FB1+.9)))
..S (FBPAYDT,FBBEGDT)=$S(X>-FB1:$FN(X,"-"),1:FB1),(FBPAYDT,FBBEGDT)=$$CDTC^FBUCUTL(FBPAYDT,1),FBENDDT=FBAA(2) D Q:FBERR
...S X=+FBPAYDT D DAYS^FBAAUTL1 S FBDAYS=$S(X>(FBENDDT-FBBEGDT):(FBENDDT-FBBEGDT),1:X)
...S IFN=+$P(FBNEW,U,4) D GETRAT^FBNHEAU2 Q:$G(FBERR)
...D FILE^FBNHEAU2
;
Q
;
DEL ;if from date of authorization is changed locate and delete
;current entries in CNH authorization rate file.
;FB7078 equal to internal entry number of 7078 for authorization
I '$G(FB7078) S FBERR=1 Q
N FBI S FBI=0
F S FBI=$O(^FBAA(161.23,"AC",FB7078,FBI)) Q:'FBI I $D(^FBAA(161.23,FBI,0)) D
.S DA=FBI,DIK="^FBAA(161.23," D ^DIK K DIK
Q
;
CK ;check if vendor has sufficient contract data
N X,X1,Y
S IFN=$P(FBNEW,U,4)
S (FBBEGDT,FBPAYDT)=FBAA(1),FBENDDT=FBAA(2),X=+FBAA(1) D DAYS^FBAAUTL1 S FBDAYS=$S(X>(FBENDDT-FBBEGDT):(FBENDDT-FBBEGDT),1:X)
D GETRAT^FBNHEAU2
Q
;
GET I '$G(FB7078) S FBERR=1 Q
I '$D(^FBAA(161.23,"AC",FB7078)) S FBERR=1 Q
S FBZ=0
F S FBZ=$O(^FBAA(161.23,"AC",FB7078,FBZ)) Q:'FBZ I $D(^FBAA(161.23,FBZ,0)) S FBZ(0)=^(0) D
.S FBZ($P(FBZ(0),U,2))=FBZ
K FBZ(0) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHEDA1 1900 printed Nov 22, 2024@17:09:05 Page 2
FBNHEDA1 ;AISC/DMK-EDIT CNH AUTHORIZATION CONT ;4/28/93 11:05
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 IF FBO'=FBAA(1)
Begin DoDot:1
+4 DO CK
IF FBERR
Begin DoDot:2
+5 SET DA(1)=$GET(DFN)
SET DA=$GET(FTP)
SET DIE="^FBAAA("_DA(1)_",1,"
SET DR=".01////^S X=FBO;.02////^S X=FB1"
DO ^DIE
KILL DIE,DR
End DoDot:2
+6 DO DEL
+7 DO FILE^FBNHEAU2
End DoDot:1
if FBERR
QUIT
+8 ;
UPDATE ;called from edit authorization and FBNHED (enter discharge)
+1 IF FBO=FBAA(1)
IF FB1'=FBAA(2)
DO GET
Begin DoDot:1
+2 IF FB1>FBAA(2)
SET (X,HOLDX)=$ORDER(FBZ(FBAA(2)-.9))
SET X=$GET(FBZ(+X))
IF X
Begin DoDot:2
+3 SET DA=X
SET DIE="^FBAA(161.23,"
SET DR=".02////^S X="_FBAA(2)
DO ^DIE
KILL DIE,DR
+4 NEW FBI
FOR FBI=HOLDX:0
SET FBI=$ORDER(FBZ(FBI))
if 'FBI
QUIT
Begin DoDot:3
+5 SET DA=FBZ(FBI)
SET DIK="^FBAA(161.23,"
DO ^DIK
KILL DIK
End DoDot:3
End DoDot:2
+6 IF FBAA(2)>FB1
Begin DoDot:2
+7 SET X=$ORDER(^FBAA(161.23,"AD",FB7078,-(FB1+.9)))
+8 SET (FBPAYDT,FBBEGDT)=$SELECT(X>-FB1:$FNUMBER(X,"-"),1:FB1)
SET (FBPAYDT,FBBEGDT)=$$CDTC^FBUCUTL(FBPAYDT,1)
SET FBENDDT=FBAA(2)
Begin DoDot:3
+9 SET X=+FBPAYDT
DO DAYS^FBAAUTL1
SET FBDAYS=$SELECT(X>(FBENDDT-FBBEGDT):(FBENDDT-FBBEGDT),1:X)
+10 SET IFN=+$PIECE(FBNEW,U,4)
DO GETRAT^FBNHEAU2
if $GET(FBERR)
QUIT
+11 DO FILE^FBNHEAU2
End DoDot:3
if FBERR
QUIT
End DoDot:2
End DoDot:1
+12 ;
+13 QUIT
+14 ;
DEL ;if from date of authorization is changed locate and delete
+1 ;current entries in CNH authorization rate file.
+2 ;FB7078 equal to internal entry number of 7078 for authorization
+3 IF '$GET(FB7078)
SET FBERR=1
QUIT
+4 NEW FBI
SET FBI=0
+5 FOR
SET FBI=$ORDER(^FBAA(161.23,"AC",FB7078,FBI))
if 'FBI
QUIT
IF $DATA(^FBAA(161.23,FBI,0))
Begin DoDot:1
+6 SET DA=FBI
SET DIK="^FBAA(161.23,"
DO ^DIK
KILL DIK
End DoDot:1
+7 QUIT
+8 ;
CK ;check if vendor has sufficient contract data
+1 NEW X,X1,Y
+2 SET IFN=$PIECE(FBNEW,U,4)
+3 SET (FBBEGDT,FBPAYDT)=FBAA(1)
SET FBENDDT=FBAA(2)
SET X=+FBAA(1)
DO DAYS^FBAAUTL1
SET FBDAYS=$SELECT(X>(FBENDDT-FBBEGDT):(FBENDDT-FBBEGDT),1:X)
+4 DO GETRAT^FBNHEAU2
+5 QUIT
+6 ;
GET IF '$GET(FB7078)
SET FBERR=1
QUIT
+1 IF '$DATA(^FBAA(161.23,"AC",FB7078))
SET FBERR=1
QUIT
+2 SET FBZ=0
+3 FOR
SET FBZ=$ORDER(^FBAA(161.23,"AC",FB7078,FBZ))
if 'FBZ
QUIT
IF $DATA(^FBAA(161.23,FBZ,0))
SET FBZ(0)=^(0)
Begin DoDot:1
+4 SET FBZ($PIECE(FBZ(0),U,2))=FBZ
End DoDot:1
+5 KILL FBZ(0)
QUIT
