FBXIP38 ;WOIFO/SAB-PATCH INSTALL ROUTINE ;11/26/2001
;;3.5;FEE BASIS;**38**;JAN 30, 1995
Q
;
PS ; post-install entry point
; create KIDS checkpoints with call backs
N FBX,Y
F FBX="SUSCOD","STATEXP","EXPDT" D
. S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP38")
. I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
Q
;
SUSCOD ; Add new Suspend Code to the FEE BASIS SUSPENSION (#161.27) file.
D BMES^XPDUTL(" Adding new suspend code to file #161.27...")
N FBDA
; check for J suspension code
S FBDA=$$FIND1^DIC(161.27,"","X","J","B")
; if not found then add it
I 'FBDA D
. N DA,DD,DIC,DINUM,DLAYGO,DO,X,Y
. S DIC="^FBAA(161.27,",DIC(0)="L",DLAYGO=161.27
. S X="J"
. S DIC("DR")="2///^S X=""Mill Bill Authority, 38 U.S.C. 1725"""
. D FILE^DICN
. I Y<0 D MES^XPDUTL("ERROR ADDING J SUSPEND CODE") Q
. ; update Description wp field of entry (replaces current text)
. K ^TMP($J,"FB1")
. S ^TMP($J,"FB1",1,0)="Payment in Accordance with pricing for claims approved under 38 USC 1725"
. S ^TMP($J,"FB1",2,0)="payer of last resort."
. ; replace existing text with content of array
. D WP^DIE(161.27,+Y_",",1,"","^TMP($J,""FB1"")") D MSG^DIALOG()
. K ^TMP($J,"FB1")
Q
;
STATEXP ; Populate field .07 in file 162.92 for appropriate status
D BMES^XPDUTL(" Populating new field in file #162.92...")
N FBDA,FBFDA,FBORDER
; loop thru status orders that need to be populated
F FBORDER=10,40,55,70 D
. S FBDA=$$STATUS^FBUCUTL(FBORDER) ; get ien
. Q:'FBDA
. Q:$P($G(^FB(162.92,FBDA,0)),U,7)]"" ; field already populated
. I FBORDER=10 S FBFDA(162.92,FBDA_",",.07)="31"
. I FBORDER=40 S FBFDA(162.92,FBDA_",",.07)="366"
. I FBORDER=55 S FBFDA(162.92,FBDA_",",.07)="366"
. I FBORDER=70 S FBFDA(162.92,FBDA_",",.07)="121"
; update entries
I $D(FBFDA) D FILE^DIE("E","FBFDA") D MSG^DIALOG()
Q
;
EXPDT ; Recompute expiration dates of incomplete Mill Bill claims
D BMES^XPDUTL(" Recalculating expiration date of incomplete claims...")
N FBDA,FBEXP,FBEXPN,FBLETDT,FBORDER,FBSTATUS,FBUCA
;
; get ien for status 'incomplete unauthorized claim'
S FBORDER=10
S FBSTATUS=$$STATUS^FBUCUTL(FBORDER)
;
; loop thru incomplete claims
S FBDA=0 F S FBDA=$O(^FB583("AS",FBSTATUS,FBDA)) Q:'FBDA D
. S FBUCA=$G(^FB583(FBDA,0))
. S FBEXP=$P(FBUCA,U,26) ; expiration date
. S FBLETDT=$P(FBUCA,U,19) ; date letter sent
. Q:$P(FBUCA,U,28)'=1 ; skip if not mill bill claim
. Q:FBEXP'>0 ; skip if no expiration date on file
. Q:FBLETDT'>0 ; skip if letter date is not on file
. ;
. ; calculate new expiration date and update claim
. S FBEXPN=$$EXPIRE^FBUCUTL8(FBDA,FBLETDT,FBUCA,FBORDER)
. ;W !,FBDA,?10,FBLETDT,?20,FBEXP,?30,FBEXPN
. D EDITL^FBUCED(FBDA,FBEXPN,0)
Q
;FBXIP38
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXIP38 2776 printed Nov 22, 2024@17:11:57 Page 2
FBXIP38 ;WOIFO/SAB-PATCH INSTALL ROUTINE ;11/26/2001
+1 ;;3.5;FEE BASIS;**38**;JAN 30, 1995
+2 QUIT
+3 ;
PS ; post-install entry point
+1 ; create KIDS checkpoints with call backs
+2 NEW FBX,Y
+3 FOR FBX="SUSCOD","STATEXP","EXPDT"
Begin DoDot:1
+4 SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP38")
+5 IF 'Y
DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
End DoDot:1
+6 QUIT
+7 ;
SUSCOD ; Add new Suspend Code to the FEE BASIS SUSPENSION (#161.27) file.
+1 DO BMES^XPDUTL(" Adding new suspend code to file #161.27...")
+2 NEW FBDA
+3 ; check for J suspension code
+4 SET FBDA=$$FIND1^DIC(161.27,"","X","J","B")
+5 ; if not found then add it
+6 IF 'FBDA
Begin DoDot:1
+7 NEW DA,DD,DIC,DINUM,DLAYGO,DO,X,Y
+8 SET DIC="^FBAA(161.27,"
SET DIC(0)="L"
SET DLAYGO=161.27
+9 SET X="J"
+10 SET DIC("DR")="2///^S X=""Mill Bill Authority, 38 U.S.C. 1725"""
+11 DO FILE^DICN
+12 IF Y<0
DO MES^XPDUTL("ERROR ADDING J SUSPEND CODE")
QUIT
+13 ; update Description wp field of entry (replaces current text)
+14 KILL ^TMP($JOB,"FB1")
+15 SET ^TMP($JOB,"FB1",1,0)="Payment in Accordance with pricing for claims approved under 38 USC 1725"
+16 SET ^TMP($JOB,"FB1",2,0)="payer of last resort."
+17 ; replace existing text with content of array
+18 DO WP^DIE(161.27,+Y_",",1,"","^TMP($J,""FB1"")")
DO MSG^DIALOG()
+19 KILL ^TMP($JOB,"FB1")
End DoDot:1
+20 QUIT
+21 ;
STATEXP ; Populate field .07 in file 162.92 for appropriate status
+1 DO BMES^XPDUTL(" Populating new field in file #162.92...")
+2 NEW FBDA,FBFDA,FBORDER
+3 ; loop thru status orders that need to be populated
+4 FOR FBORDER=10,40,55,70
Begin DoDot:1
+5 ; get ien
SET FBDA=$$STATUS^FBUCUTL(FBORDER)
+6 if 'FBDA
QUIT
+7 ; field already populated
if $PIECE($GET(^FB(162.92,FBDA,0)),U,7)]""
QUIT
+8 IF FBORDER=10
SET FBFDA(162.92,FBDA_",",.07)="31"
+9 IF FBORDER=40
SET FBFDA(162.92,FBDA_",",.07)="366"
+10 IF FBORDER=55
SET FBFDA(162.92,FBDA_",",.07)="366"
+11 IF FBORDER=70
SET FBFDA(162.92,FBDA_",",.07)="121"
End DoDot:1
+12 ; update entries
+13 IF $DATA(FBFDA)
DO FILE^DIE("E","FBFDA")
DO MSG^DIALOG()
+14 QUIT
+15 ;
EXPDT ; Recompute expiration dates of incomplete Mill Bill claims
+1 DO BMES^XPDUTL(" Recalculating expiration date of incomplete claims...")
+2 NEW FBDA,FBEXP,FBEXPN,FBLETDT,FBORDER,FBSTATUS,FBUCA
+3 ;
+4 ; get ien for status 'incomplete unauthorized claim'
+5 SET FBORDER=10
+6 SET FBSTATUS=$$STATUS^FBUCUTL(FBORDER)
+7 ;
+8 ; loop thru incomplete claims
+9 SET FBDA=0
FOR
SET FBDA=$ORDER(^FB583("AS",FBSTATUS,FBDA))
if 'FBDA
QUIT
Begin DoDot:1
+10 SET FBUCA=$GET(^FB583(FBDA,0))
+11 ; expiration date
SET FBEXP=$PIECE(FBUCA,U,26)
+12 ; date letter sent
SET FBLETDT=$PIECE(FBUCA,U,19)
+13 ; skip if not mill bill claim
if $PIECE(FBUCA,U,28)'=1
QUIT
+14 ; skip if no expiration date on file
if FBEXP'>0
QUIT
+15 ; skip if letter date is not on file
if FBLETDT'>0
QUIT
+16 ;
+17 ; calculate new expiration date and update claim
+18 SET FBEXPN=$$EXPIRE^FBUCUTL8(FBDA,FBLETDT,FBUCA,FBORDER)
+19 ;W !,FBDA,?10,FBLETDT,?20,FBEXP,?30,FBEXPN
+20 DO EDITL^FBUCED(FBDA,FBEXPN,0)
End DoDot:1
+21 QUIT
+22 ;FBXIP38
