- 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 Mar 13, 2025@21:03:49 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
