- 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 Mar 13, 2025@21:05:50 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
