FBXCIPS ;WIRMFO/SAB-POST INIT ;1/7/98
;;3.5;FEE BASIS;**11**;JAN 30, 1995
;
N FBC,FBDA,FBDT,FBI,FBY
D BMES^XPDUTL(" Examining FEE BASIS ID CARD AUDIT File data...")
; init variables
S FBC("PAT","CHK")=0 ; count of patients checked
S FBC("PAT","FIX")=0 ; count of patients fixed
S FBC("AUD","CHK")=0 ; count of audit entries checked
S FBC("AUD","FIX")=0 ; count of audit entries fixed
S FBC("TOT")=$P($G(^FBAA(161.83,0)),U,4) ; number of patients to check
S XPDIDTOT=FBC("TOT") ; set total for status bar
S FBC("UPD")=5 ; initial % required to update status bar
;
; loop thru patients
S FBDA=0 F S FBDA=$O(^FBAA(161.83,FBDA)) Q:'FBDA D
. S FBC("PAT","CHK")=FBC("PAT","CHK")+1
. S FBC("%")=FBC("PAT","CHK")*100/FBC("TOT") ; calculate % complete
. ; check if status bar should be updated
. I FBC("%")>FBC("UPD") D
. . D UPDATE^XPDID(FBC("PAT","CHK")) ; update status bar
. . S FBC("UPD")=FBC("UPD")+5 ; increase update criteria by 5%
. ;
. ; check header of multiple and correct if necessary
. I +$P($G(^FBAA(161.83,FBDA,1,0)),U,2)'=161.831 D
. . S FBC("PAT","FIX")=FBC("PAT","FIX")+1
. . S $P(^FBAA(161.83,FBDA,1,0),U,2)="161.831DA"
. . ;W !,"FH ",FBDA ; uncomment for testing
. ;
. ; loop thru audit multiple and correct any invalid entries
. S FBI=0 F S FBI=$O(^FBAA(161.83,FBDA,1,FBI)) Q:'FBI D
. . S FBC("AUD","CHK")=FBC("AUD","CHK")+1
. . S FBDT=9999999.9999-FBI ; calculate date/time from FBI
. . S FBY=$G(^FBAA(161.83,FBDA,1,FBI,0))
. . ; compare #.01 field with calculated date/time
. . I +$P(FBY,U)'=+FBDT D
. . . S FBC("AUD","FIX")=FBC("AUD","FIX")+1
. . . K ^FBAA(161.83,"B",FBDT,FBI) ; delete bad "B" x-ref
. . . S ^FBAA(161.83,FBDA,1,FBI,0)=FBDT_U_$P(FBY,U)_"^Unknown^.5"
. . . S:$P(FBY,U)]"" ^FBAA(161.83,"C",$P(FBY,U),FBDA,FBI)=""
. . . ;W !," ",FBDA,?10,FBI,?25,FBY ; uncomment for testing
;
S FBX=" "_FBC("PAT","CHK")_" header node"_$S(FBC("PAT","CHK")=1:" was",1:"s were")_" examined. "
S FBX=FBX_$S(FBC("PAT","FIX")=0:"No problems were",FBC("PAT","FIX")=1:"1 problem was",1:FBC("PAT","FIX")_" problems were")_" found"_$S(FBC("PAT","FIX")>0:" and corrected",1:"")_"."
D MES^XPDUTL(FBX)
;
S FBX=" "_FBC("AUD","CHK")_" audit entr"_$S(FBC("AUD","CHK")=1:"y was",1:"ies were")_" examined. "
S FBX=FBX_$S(FBC("AUD","FIX")=0:"No problems were",FBC("AUD","FIX")=1:"1 problem was",1:FBC("AUD","FIX")_" problems were")_" found"_$S(FBC("AUD","FIX")>0:" and corrected",1:"")_"."
D MES^XPDUTL(FBX)
;
Q
;FBXCIPS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXCIPS 2532 printed Sep 23, 2025@19:37:01 Page 2
FBXCIPS ;WIRMFO/SAB-POST INIT ;1/7/98
+1 ;;3.5;FEE BASIS;**11**;JAN 30, 1995
+2 ;
+3 NEW FBC,FBDA,FBDT,FBI,FBY
+4 DO BMES^XPDUTL(" Examining FEE BASIS ID CARD AUDIT File data...")
+5 ; init variables
+6 ; count of patients checked
SET FBC("PAT","CHK")=0
+7 ; count of patients fixed
SET FBC("PAT","FIX")=0
+8 ; count of audit entries checked
SET FBC("AUD","CHK")=0
+9 ; count of audit entries fixed
SET FBC("AUD","FIX")=0
+10 ; number of patients to check
SET FBC("TOT")=$PIECE($GET(^FBAA(161.83,0)),U,4)
+11 ; set total for status bar
SET XPDIDTOT=FBC("TOT")
+12 ; initial % required to update status bar
SET FBC("UPD")=5
+13 ;
+14 ; loop thru patients
+15 SET FBDA=0
FOR
SET FBDA=$ORDER(^FBAA(161.83,FBDA))
if 'FBDA
QUIT
Begin DoDot:1
+16 SET FBC("PAT","CHK")=FBC("PAT","CHK")+1
+17 ; calculate % complete
SET FBC("%")=FBC("PAT","CHK")*100/FBC("TOT")
+18 ; check if status bar should be updated
+19 IF FBC("%")>FBC("UPD")
Begin DoDot:2
+20 ; update status bar
DO UPDATE^XPDID(FBC("PAT","CHK"))
+21 ; increase update criteria by 5%
SET FBC("UPD")=FBC("UPD")+5
End DoDot:2
+22 ;
+23 ; check header of multiple and correct if necessary
+24 IF +$PIECE($GET(^FBAA(161.83,FBDA,1,0)),U,2)'=161.831
Begin DoDot:2
+25 SET FBC("PAT","FIX")=FBC("PAT","FIX")+1
+26 SET $PIECE(^FBAA(161.83,FBDA,1,0),U,2)="161.831DA"
+27 ;W !,"FH ",FBDA ; uncomment for testing
End DoDot:2
+28 ;
+29 ; loop thru audit multiple and correct any invalid entries
+30 SET FBI=0
FOR
SET FBI=$ORDER(^FBAA(161.83,FBDA,1,FBI))
if 'FBI
QUIT
Begin DoDot:2
+31 SET FBC("AUD","CHK")=FBC("AUD","CHK")+1
+32 ; calculate date/time from FBI
SET FBDT=9999999.9999-FBI
+33 SET FBY=$GET(^FBAA(161.83,FBDA,1,FBI,0))
+34 ; compare #.01 field with calculated date/time
+35 IF +$PIECE(FBY,U)'=+FBDT
Begin DoDot:3
+36 SET FBC("AUD","FIX")=FBC("AUD","FIX")+1
+37 ; delete bad "B" x-ref
KILL ^FBAA(161.83,"B",FBDT,FBI)
+38 SET ^FBAA(161.83,FBDA,1,FBI,0)=FBDT_U_$PIECE(FBY,U)_"^Unknown^.5"
+39 if $PIECE(FBY,U)]""
SET ^FBAA(161.83,"C",$PIECE(FBY,U),FBDA,FBI)=""
+40 ;W !," ",FBDA,?10,FBI,?25,FBY ; uncomment for testing
End DoDot:3
End DoDot:2
End DoDot:1
+41 ;
+42 SET FBX=" "_FBC("PAT","CHK")_" header node"_$SELECT(FBC("PAT","CHK")=1:" was",1:"s were")_" examined. "
+43 SET FBX=FBX_$SELECT(FBC("PAT","FIX")=0:"No problems were",FBC("PAT","FIX")=1:"1 problem was",1:FBC("PAT","FIX")_" problems were")_" found"_$SELECT(FBC("PAT","FIX")>0:" and corrected",1:"")_"."
+44 DO MES^XPDUTL(FBX)
+45 ;
+46 SET FBX=" "_FBC("AUD","CHK")_" audit entr"_$SELECT(FBC("AUD","CHK")=1:"y was",1:"ies were")_" examined. "
+47 SET FBX=FBX_$SELECT(FBC("AUD","FIX")=0:"No problems were",FBC("AUD","FIX")=1:"1 problem was",1:FBC("AUD","FIX")_" problems were")_" found"_$SELECT(FBC("AUD","FIX")>0:" and corrected",1:"")_"."
+48 DO MES^XPDUTL(FBX)
+49 ;
+50 QUIT
+51 ;FBXCIPS
