Routine: FBXCIPS

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)

 ;FBXCIPS

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXCIPS   2532     printed  Apr 09, 2024@21:02:20                                                                                                                                                                                                     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

FBXCIPS.m