FBXIP154 ;WOIFO/SAB - PATCH INSTALL ROUTINE ;12/2/2014
;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
;
; ICRs
; #2050 MSG^DIALOG
; #2052 $$GET1^DID
; #2053 FILE^DIE, UPDATE^DIE
; #2056 $$GET1^DIQ
; #2343 $$ACTIVE^XUSER()
; #10103 $$FMADD^XLFDT
; #10141 BMES^XPDUTL, MES^XPDUTL, $$NEWCP^XPDUTL
;
PS ; post-install entry point
; create KIDS checkpoints with call backs
N FBX,Y
F FBX="USRAUD","AUTHP" D
. S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP154")
. I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
Q
;
USRAUD ; populate user audit
N DA,DIERR,FBC,FBCE,FBDT,FBFILE,FBIENS,FBTXT,FBUSR,FBY
D BMES^XPDUTL(" Creating User Audit entries. This may take some time.")
;
; populate user audit in file 162.2
D MES^XPDUTL(" processing file 162.2...")
S (FBC,FBCE)=0
S FBFILE=162.292
S FBTXT(1)="Added by FB*3.5*154 based on legal determination."
S FBTXT(2)="Added by FB*3.5*154 based on medical determination."
S FBTXT(3)="Added by FB*3.5*154 based on user entering & install date."
; loop thru file 162.2
S DA=0 F S DA=$O(^FBAA(162.2,DA)) Q:'DA D
. ; skip if user audit already populated
. Q:$O(^FBAA(162.2,DA,"LOG1",0))
. ;
. S FBIENS=DA_","
. S FBY=$G(^FBAA(162.2,DA,0))
. ;
. S FBDT=$P(FBY,U,10) ; DATE OF LEGAL DETERMINATION
. S FBUSR=$P(FBY,U,11) ; USER ENTERING LEGAL DETERM.
. I FBDT,FBUSR D ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT(1))
. ;
. S FBDT=$P(FBY,U,13) ; DATE OF MEDICAL DETERMINATION
. S FBUSR=$P(FBY,U,14) ; USER ENTERING MEDICAL DETERM.
. I FBDT,FBUSR D ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT(2))
. ;
. S FBDT=DT ; current (install) date
. S FBUSR=$P(FBY,U,8) ; USER ENTERING NOTIFICATION
. I FBDT,FBUSR D ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT(3))
D SHOWCNT
;
; populate user audit in file 162.4
D MES^XPDUTL(" processing file 162.4...")
S (FBC,FBCE)=0
S FBFILE=162.492
S FBTXT="Added by FB*3.5*154 based on user entering & date of issue."
; loop thru file 162.4
S DA=0 F S DA=$O(^FB7078(DA)) Q:'DA D
. ; skip if user audit already populated
. Q:$O(^FB7078(DA,"LOG1",0))
. ;
. S FBIENS=DA_","
. S FBY=$G(^FB7078(DA,0))
. ;
. S FBDT=$P(FBY,U,10) ; DATE OF ISSUE
. S FBUSR=$P(FBY,U,8) ; USER ENTERING
. I FBDT,FBUSR D ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT)
D SHOWCNT
;
; populate user audit in file 162.7
D MES^XPDUTL(" processing file 162.7...")
S (FBC,FBCE)=0
S FBFILE=162.792
S FBTXT="Added by FB*3.5*154 based on entered/last edited."
; loop thru file 162.7
S DA=0 F S DA=$O(^FB583(DA)) Q:'DA D
. ; skip if user audit already populated
. Q:$O(^FB583(DA,"LOG1",0))
. ;
. S FBIENS=DA_","
. S FBY=$G(^FB583(DA,0))
. ;
. S FBDT=$P(FBY,U,18) ; DATE ENTERED/LAST EDITED
. S FBUSR=$P(FBY,U,17) ; ENTERED/LAST EDITED BY
. I FBDT,FBUSR D ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT)
D SHOWCNT
;
; populate user audit in sub-file 161.01
D MES^XPDUTL(" processing sub-file 161.01...")
S (FBC,FBCE)=0
S FBFILE=161.192
S FBTXT="Added by FB*3.5*154 based on clerk & install date."
; loop thru file 161
S DA(1)=0 F S DA(1)=$O(^FBAAA(DA(1))) Q:'DA(1) D
. ; loop thru sub-file 161.01
. S DA=0 F S DA=$O(^FBAAA(DA(1),1,DA)) Q:'DA D
. . N FBX
. . ; skip if user audit already populated
. . Q:$O(^FBAAA(DA(1),1,DA,"LOG1",0))
. . ;
. . S FBIENS=DA_","_DA(1)_","
. . ;
. . S FBDT=DT ; current (install) date
. . S FBUSR=$P($G(^FBAAA(DA(1),1,DA,100)),U) ; CLERK
. . S FBX=$P($G(^FBAAA(DA(1),1,DA,0)),U,9) ; ASSOCIATED 7078/583
. . ;
. . ; skip if 7078 and clerk already in file 162.4 user audit
. . I FBUSR,FBX[";FB7078(",$O(^FB7078(+FBX,"LOG1","AU",FBUSR,0)) Q
. . ;
. . ; skip if U/C and clerk already in file 162.7 user audit
. . I FBUSR,FBX[";FB583(",$O(^FB583(+FBX,"LOG1","AU",FBUSR,0)) Q
. . ;
. . I FBDT,FBUSR D ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT)
D SHOWCNT
;
D MES^XPDUTL(" Done creating user audit entries.")
Q
;
ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT) ; add user audit record
Q:FBDT'?7N ; invalid date
Q:$$ACTIVE^XUSER(FBUSR)="" ; no user record found
N FBFDA
S FBIENS="+1,"_FBIENS
S FBFDA(FBFILE,FBIENS,.01)=FBDT ; DATE/TIME EDITED
S FBFDA(FBFILE,FBIENS,1)=FBUSR ; EDITED BY
S FBFDA(FBFILE,FBIENS,2)=FBTXT ; COMMENTS
D UPDATE^DIE("","FBFDA")
I $G(DIERR)="" S FBC=FBC+1
E D
. S FBCE=FBCE+1
. D MES^XPDUTL(" "_"Error creating record with IENS "_FBIENS)
Q
;
SHOWCNT ; show counts for file
D MES^XPDUTL(" "_FBC_" user audit entries were created.")
D:FBCE MES^XPDUTL(" "_FBCE_" user audit entries not created due to error.")
Q
;
AUTHP ; populate authorization pointer data
N DA,DIERR,FBA,FBAUTHP,FBFE,FBIENS,FBP,FBT,FBX,FBYA,FBYD,FBYP
D MES^XPDUTL("Populating new AUTHORIZATION POINTER field. This may take some time...")
;
; init counters
S FBT("TLN")=0 ; total line items
S FBT("TLN","SKIP")=0 ; lines skipped because new field was populated
S FBT("TLN","PROC")=0 ; lines processed
S FBT("NOP")=0 ; processed lines without old authorization pointer
S FBT("NOP","7078C")=0 ; populated based on 7078/583 match
S FBT("NOP","7078U")=0 ; not populated, no 7078/583 match found
S FBT("NOP","POVC")=0 ; populated based on POV match
S FBT("NOP","POVU")=0 ; not populated, no POV match found
S FBT("PTR")=0 ; processed lines with old authorization pointer
S FBT("PTR","7078M")=0 ; populated with same value based on 7078/583
S FBT("PTR","7078C")=0 ; populated with diff value based on 7078/583
S FBT("PTR","7078U")=0 ; populated with same value, no 7078/583 match
S FBT("PTR","POVM")=0 ; populated with same value based on POV
S FBT("PTR","POVC")=0 ; populated with diff value based on POV
S FBT("PTR","POVU")=0 ; populated with same value, no POV match
;
; set header for XTMP with purge date in 120 days
S ^XTMP("FB*3.5*154",0)=$$FMADD^XLFDT(DT,120)_"^"_DT_"^From patch FB*3.5*154 post init."
;
; determine if old field still exists
S FBFE=$S($$GET1^DID(162.02,3,"","LABEL")="*AUTHORIZATION POINTER":1,1:0)
;
; loop thru outpatient and ancillary line items in FEE BASIS PAYMENT
; loop thru patients
S DA(3)=0
F S DA(3)=$O(^FBAAC(DA(3))) Q:'DA(3) D
. ; loop thru vendors
. S DA(2)=0
. F S DA(2)=$O(^FBAAC(DA(3),1,DA(2))) Q:'DA(2) D
. . ; loop thru dates of service
. . S DA(1)=0
. . F S DA(1)=$O(^FBAAC(DA(3),1,DA(2),1,DA(1))) Q:'DA(1) D
. . . S FBYD=$G(^FBAAC(DA(3),1,DA(2),1,DA(1),0))
. . . S FBP("DOS")=$P(FBYD,U,1) ; date of service
. . . S FBP("FTP")=$S(FBFE:$P(FBYD,U,4),1:"") ; old value
. . . ; don't use old value if authorization does not exist in file 161
. . . I FBP("FTP"),'$D(^FBAAA(DA(3),1,FBP("FTP"),0)) S FBP("FTP")=""
. . . S FBYA=$S(FBP("FTP"):$G(^FBAAA(DA(3),1,FBP("FTP"),0)),1:"")
. . . S FBA("POV")=$P(FBYA,U,7) ; PURPOSE OF VISIT
. . . S FBA("7078")=$P(FBYA,U,9) ; ASSOCIATED 7078/583
. . . ; loop thru service provided
. . . S DA=0
. . . F S DA=$O(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA)) Q:'DA D
. . . . S FBT("TLN")=FBT("TLN")+1
. . . . S FBIENS=DA_","_DA(1)_","_DA(2)_","_DA(3)_","
. . . . ;
. . . . ; skip if already converted (i.e. new field populated)
. . . . I $P($G(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,3)),U,9) D Q
. . . . . S FBT("TLN","SKIP")=FBT("TLN","SKIP")+1
. . . . S FBT("TLN","PROC")=FBT("TLN","PROC")+1
. . . . ;
. . . . S FBYP=$G(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,0))
. . . . S FBP("7078")=$P(FBYP,U,13) ; ASSOCIATED 7078/583
. . . . S FBP("POV")=$P(FBYP,U,18) ; PURPOSE OF VISIT
. . . . ;
. . . . I 'FBP("FTP") S FBT("NOP")=FBT("NOP")+1 ; no old pointer
. . . . E S FBT("PTR")=FBT("PTR")+1 ; old pointer exists
. . . . ;
. . . . ; determine correct authorization pointer for line item
. . . . S FBAUTHP="" ; init new auth pointer value
. . . . ; if payment associated 7078/583 exists then match with that
. . . . I FBP("7078")]"" D
. . . . . ; if pointer exists and 7078/583 matches then copy old value
. . . . . I FBP("FTP"),FBP("7078")=FBA("7078") D Q:FBAUTHP
. . . . . . S FBAUTHP=FBP("FTP")
. . . . . . S FBT("PTR","7078M")=FBT("PTR","7078M")+1
. . . . . ; if 7078/583 does not match then look for an better auth.
. . . . . I FBP("7078")'=FBA("7078") D Q:FBAUTHP
. . . . . . S FBX=$$ASSOC(DA(3),FBP("DOS"),FBP("7078"))
. . . . . . Q:'FBX
. . . . . . S FBAUTHP=FBX
. . . . . . I FBP("FTP") S FBT("PTR","7078C")=FBT("PTR","7078C")+1
. . . . . . I 'FBP("FTP") S FBT("NOP","7078C")=FBT("NOP","7078C")+1
. . . . . . S ^XTMP("FB*3.5*154","7078C",FBIENS)=FBP("FTP")_"^"_FBAUTHP
. . . . . I 'FBAUTHP D
. . . . . . ; if better auth. not found use old value when available
. . . . . . I FBP("FTP") S FBAUTHP=FBP("FTP")
. . . . . . I FBP("FTP") S FBT("PTR","7078U")=FBT("PTR","7078U")+1
. . . . . . I 'FBP("FTP") S FBT("NOP","7078U")=FBT("NOP","7078U")+1
. . . . . . S ^XTMP("FB*3.5*154","7078U",FBIENS)=FBP("FTP")_"^"_FBAUTHP
. . . . ;
. . . . ; if payment associated 7078/583 blank then match with POV
. . . . I FBP("7078")="" D
. . . . . ; if pointer exists and POV matches then copy old value
. . . . . I FBP("FTP"),FBP("POV")=FBA("POV") D Q:FBAUTHP
. . . . . . S FBAUTHP=FBP("FTP")
. . . . . . S FBT("PTR","POVM")=FBT("PTR","POVM")+1
. . . . . ; if POV does not match then look for an better auth.
. . . . . I FBP("POV")'=FBA("POV") D Q:FBAUTHP
. . . . . . S FBX=$$POV(DA(3),FBP("DOS"),FBP("POV"))
. . . . . . Q:'FBX
. . . . . . S FBAUTHP=FBX
. . . . . . I FBP("FTP") S FBT("PTR","POVC")=FBT("PTR","POVC")+1
. . . . . . I 'FBP("FTP") S FBT("NOP","POVC")=FBT("NOP","POVC")+1
. . . . . . S ^XTMP("FB*3.5*154","POVC",FBIENS)=FBP("FTP")_"^"_FBAUTHP
. . . . . ; if better auth. not found use old value when available
. . . . . I 'FBAUTHP D
. . . . . . I FBP("FTP") S FBAUTHP=FBP("FTP")
. . . . . . I FBP("FTP") S FBT("PTR","POVU")=FBT("PTR","POVU")+1
. . . . . . I 'FBP("FTP") S FBT("NOP","POVU")=FBT("NOP","POVU")+1
. . . . . . S ^XTMP("FB*3.5*154","POVU",FBIENS)=FBP("FTP")_"^"_FBAUTHP
. . . . ;
. . . . ; save authorization pointer value in new field
. . . . I FBAUTHP D
. . . . . N FBFDA
. . . . . S FBFDA(162.03,FBIENS,15.5)=FBAUTHP
. . . . . D FILE^DIE("","FBFDA")
. . . . . I $G(DIERR)'="" D MES^XPDUTL(" Error updating record with IENS "_FBIENS)
;
; report results
S FBX=$J($FN(FBT("TLN"),","),10)_" payment line items in FEE BASIS PAYMENT file"
D MES^XPDUTL(FBX)
D MES^XPDUTL("----------")
S FBX=$J($FN(FBT("TLN","SKIP"),","),10)_" lines skipped because new field already populated"
D MES^XPDUTL(FBX)
S FBX=$J($FN(FBT("TLN","PROC"),","),10)_" lines processed"
D MES^XPDUTL(FBX)
;
S FBX=$J($FN(FBT("NOP"),","),10)_" processed lines without an existing authorization pointer value"
D BMES^XPDUTL(FBX)
D MES^XPDUTL("----------")
S FBX=$J($FN(FBT("NOP","7078C"),","),10)_" lines populated based on 7078/583 match"
D MES^XPDUTL(FBX)
S FBX=$J($FN(FBT("NOP","7078U"),","),10)_" lines not populated because 7078/583 match not found"
D MES^XPDUTL(FBX)
S FBX=$J($FN(FBT("NOP","POVC"),","),10)_" lines populated based on POV match"
D MES^XPDUTL(FBX)
S FBX=$J($FN(FBT("NOP","POVU"),","),10)_" lines not populated because POV match not found"
D MES^XPDUTL(FBX)
;
S FBX=$J($FN(FBT("PTR"),","),10)_" processed lines with an existing authorization pointer value"
D BMES^XPDUTL(FBX)
D MES^XPDUTL("----------")
S FBX=$J($FN(FBT("PTR","7078M"),","),10)_" lines populated with same value based on 7078/583 match"
D MES^XPDUTL(FBX)
S FBX=$J($FN(FBT("PTR","7078C"),","),10)_" lines populated with different value based on 7078/583 match"
D MES^XPDUTL(FBX)
S FBX=$J($FN(FBT("PTR","7078U"),","),10)_" lines populated with same value since 7078/583 match not found"
D MES^XPDUTL(FBX)
S FBX=$J($FN(FBT("PTR","POVM"),","),10)_" lines populated with same value based on POV match"
D MES^XPDUTL(FBX)
S FBX=$J($FN(FBT("PTR","POVC"),","),10)_" lines populated with different value based on POV match"
D MES^XPDUTL(FBX)
S FBX=$J($FN(FBT("PTR","POVU"),","),10)_" lines populated with same value since POV match not found"
D MES^XPDUTL(FBX)
;
Q
;
ASSOC(FBDFN,FBDOS,FB7078) ; find authorization for ASSOCIATED 7078/583
; input
; FBDFN - patient (internal, pointer to file 2 and file 161)
; FBDOS - date of service (internal, FM date)
; FB7078 - associated 7078/583 (internal)
; returns null value or authorization IEN in file 161 for patient
N FBFTP
S FBFTP=""
I $G(FB7078)]"",$G(FBDFN)]"",$G(FBDOS)]"" D
. N FBDA,FBY
. ; loop thru authorizations for ASSOCIATED 7078/583 and PATIENT
. S FBDA=0
. F S FBDA=$O(^FBAAA("AG",FB7078,FBDFN,FBDA)) Q:'FBDA D Q:FBFTP
. . S FBY=$G(^FBAAA(FBDFN,1,FBDA,0))
. . Q:$P(FBY,U,1)="" ; invalid data
. . Q:$P(FBY,U,1)>FBDOS ; auth from date is after date of service
. . Q:$P(FBY,U,2)<FBDOS ; auth to date is before date of service
. . ; passed all criterion, found matching authorization
. . S FBFTP=FBDA
;
Q FBFTP
;
POV(FBDFN,FBDOS,FBPOV) ; find authorization for POV
; input
; FBDFN - patient (internal, pointer to file 2 and file 161)
; FBDOS - date of service (internal, FM date)
; FBPOV - purpose of visit (internal, pointer to 161.82)
; returns null value or authorization IEN in file 161 for patient
N FBFTP
S FBFTP=""
I $G(FBPOV)]"",$G(FBDFN)]"",$G(FBDOS)]"" D
. N FBDA,FBY
. ; loop thru authorizations for patient
. S FBDA=0
. F S FBDA=$O(^FBAAA(FBDFN,1,FBDA)) Q:'FBDA D Q:FBFTP
. . S FBY=$G(^FBAAA(FBDFN,1,FBDA,0))
. . Q:$P(FBY,U,1)="" ; invalid data
. . Q:$P(FBY,U,7)'=FBPOV ; POV does not match input value
. . Q:$P(FBY,U,1)>FBDOS ; auth from date is after date of service
. . Q:$P(FBY,U,2)<FBDOS ; auth to date is before date of service
. . ; passed all criterion, found matching authorization
. . S FBFTP=FBDA
;
Q FBFTP
;
;
RPT ; report of ^XTMP
W !,"Report of XTMP(""FB*3.5*154"") data"
;
D LIST("7078C")
D LIST("7078U")
D LIST("POVC")
D LIST("POVU")
Q
;
;
LIST(FBSUB) ; list lines in subscript
N FBIENS,FBFLD,FBFLDN,FBY
;
W:FBSUB["C" !,"Lines with pointer changed based on "
W:FBSUB["U" !,"Lines with no matching authorization found using "
W:FBSUB["7078" "associated 7078/583"
W:FBSUB["POV" "POV"
I FBSUB["7078" S FBFLD=27,FBFLDN=" 7078/583: "
I FBSUB["POV" S FBFLD=16,FBFLDN=" POV: "
;
S FBIENS=""
F S FBIENS=$O(^XTMP("FB*3.5*154",FBSUB,FBIENS)) Q:FBIENS="" D
. S FBY=$G(^XTMP("FB*3.5*154",FBSUB,FBIENS))
. W !,FBIENS," From: ",$P(FBY,U,1)," To: ",$P(FBY,U,2),FBFLDN,$$GET1^DIQ(162.03,FBIENS,FBFLD,"I")
Q
;FBXIP154
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXIP154 14753 printed Apr 09, 2024@21:00:54 Page 2
FBXIP154 ;WOIFO/SAB - PATCH INSTALL ROUTINE ;12/2/2014
+1 ;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; ICRs
+5 ; #2050 MSG^DIALOG
+6 ; #2052 $$GET1^DID
+7 ; #2053 FILE^DIE, UPDATE^DIE
+8 ; #2056 $$GET1^DIQ
+9 ; #2343 $$ACTIVE^XUSER()
+10 ; #10103 $$FMADD^XLFDT
+11 ; #10141 BMES^XPDUTL, MES^XPDUTL, $$NEWCP^XPDUTL
+12 ;
PS ; post-install entry point
+1 ; create KIDS checkpoints with call backs
+2 NEW FBX,Y
+3 FOR FBX="USRAUD","AUTHP"
Begin DoDot:1
+4 SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP154")
+5 IF 'Y
DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
End DoDot:1
+6 QUIT
+7 ;
USRAUD ; populate user audit
+1 NEW DA,DIERR,FBC,FBCE,FBDT,FBFILE,FBIENS,FBTXT,FBUSR,FBY
+2 DO BMES^XPDUTL(" Creating User Audit entries. This may take some time.")
+3 ;
+4 ; populate user audit in file 162.2
+5 DO MES^XPDUTL(" processing file 162.2...")
+6 SET (FBC,FBCE)=0
+7 SET FBFILE=162.292
+8 SET FBTXT(1)="Added by FB*3.5*154 based on legal determination."
+9 SET FBTXT(2)="Added by FB*3.5*154 based on medical determination."
+10 SET FBTXT(3)="Added by FB*3.5*154 based on user entering & install date."
+11 ; loop thru file 162.2
+12 SET DA=0
FOR
SET DA=$ORDER(^FBAA(162.2,DA))
if 'DA
QUIT
Begin DoDot:1
+13 ; skip if user audit already populated
+14 if $ORDER(^FBAA(162.2,DA,"LOG1",0))
QUIT
+15 ;
+16 SET FBIENS=DA_","
+17 SET FBY=$GET(^FBAA(162.2,DA,0))
+18 ;
+19 ; DATE OF LEGAL DETERMINATION
SET FBDT=$PIECE(FBY,U,10)
+20 ; USER ENTERING LEGAL DETERM.
SET FBUSR=$PIECE(FBY,U,11)
+21 IF FBDT
IF FBUSR
DO ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT(1))
+22 ;
+23 ; DATE OF MEDICAL DETERMINATION
SET FBDT=$PIECE(FBY,U,13)
+24 ; USER ENTERING MEDICAL DETERM.
SET FBUSR=$PIECE(FBY,U,14)
+25 IF FBDT
IF FBUSR
DO ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT(2))
+26 ;
+27 ; current (install) date
SET FBDT=DT
+28 ; USER ENTERING NOTIFICATION
SET FBUSR=$PIECE(FBY,U,8)
+29 IF FBDT
IF FBUSR
DO ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT(3))
End DoDot:1
+30 DO SHOWCNT
+31 ;
+32 ; populate user audit in file 162.4
+33 DO MES^XPDUTL(" processing file 162.4...")
+34 SET (FBC,FBCE)=0
+35 SET FBFILE=162.492
+36 SET FBTXT="Added by FB*3.5*154 based on user entering & date of issue."
+37 ; loop thru file 162.4
+38 SET DA=0
FOR
SET DA=$ORDER(^FB7078(DA))
if 'DA
QUIT
Begin DoDot:1
+39 ; skip if user audit already populated
+40 if $ORDER(^FB7078(DA,"LOG1",0))
QUIT
+41 ;
+42 SET FBIENS=DA_","
+43 SET FBY=$GET(^FB7078(DA,0))
+44 ;
+45 ; DATE OF ISSUE
SET FBDT=$PIECE(FBY,U,10)
+46 ; USER ENTERING
SET FBUSR=$PIECE(FBY,U,8)
+47 IF FBDT
IF FBUSR
DO ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT)
End DoDot:1
+48 DO SHOWCNT
+49 ;
+50 ; populate user audit in file 162.7
+51 DO MES^XPDUTL(" processing file 162.7...")
+52 SET (FBC,FBCE)=0
+53 SET FBFILE=162.792
+54 SET FBTXT="Added by FB*3.5*154 based on entered/last edited."
+55 ; loop thru file 162.7
+56 SET DA=0
FOR
SET DA=$ORDER(^FB583(DA))
if 'DA
QUIT
Begin DoDot:1
+57 ; skip if user audit already populated
+58 if $ORDER(^FB583(DA,"LOG1",0))
QUIT
+59 ;
+60 SET FBIENS=DA_","
+61 SET FBY=$GET(^FB583(DA,0))
+62 ;
+63 ; DATE ENTERED/LAST EDITED
SET FBDT=$PIECE(FBY,U,18)
+64 ; ENTERED/LAST EDITED BY
SET FBUSR=$PIECE(FBY,U,17)
+65 IF FBDT
IF FBUSR
DO ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT)
End DoDot:1
+66 DO SHOWCNT
+67 ;
+68 ; populate user audit in sub-file 161.01
+69 DO MES^XPDUTL(" processing sub-file 161.01...")
+70 SET (FBC,FBCE)=0
+71 SET FBFILE=161.192
+72 SET FBTXT="Added by FB*3.5*154 based on clerk & install date."
+73 ; loop thru file 161
+74 SET DA(1)=0
FOR
SET DA(1)=$ORDER(^FBAAA(DA(1)))
if 'DA(1)
QUIT
Begin DoDot:1
+75 ; loop thru sub-file 161.01
+76 SET DA=0
FOR
SET DA=$ORDER(^FBAAA(DA(1),1,DA))
if 'DA
QUIT
Begin DoDot:2
+77 NEW FBX
+78 ; skip if user audit already populated
+79 if $ORDER(^FBAAA(DA(1),1,DA,"LOG1",0))
QUIT
+80 ;
+81 SET FBIENS=DA_","_DA(1)_","
+82 ;
+83 ; current (install) date
SET FBDT=DT
+84 ; CLERK
SET FBUSR=$PIECE($GET(^FBAAA(DA(1),1,DA,100)),U)
+85 ; ASSOCIATED 7078/583
SET FBX=$PIECE($GET(^FBAAA(DA(1),1,DA,0)),U,9)
+86 ;
+87 ; skip if 7078 and clerk already in file 162.4 user audit
+88 IF FBUSR
IF FBX[";FB7078("
IF $ORDER(^FB7078(+FBX,"LOG1","AU",FBUSR,0))
QUIT
+89 ;
+90 ; skip if U/C and clerk already in file 162.7 user audit
+91 IF FBUSR
IF FBX[";FB583("
IF $ORDER(^FB583(+FBX,"LOG1","AU",FBUSR,0))
QUIT
+92 ;
+93 IF FBDT
IF FBUSR
DO ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT)
End DoDot:2
End DoDot:1
+94 DO SHOWCNT
+95 ;
+96 DO MES^XPDUTL(" Done creating user audit entries.")
+97 QUIT
+98 ;
ADDUA(FBFILE,FBIENS,FBDT,FBUSR,FBTXT) ; add user audit record
+1 ; invalid date
if FBDT'?7N
QUIT
+2 ; no user record found
if $$ACTIVE^XUSER(FBUSR)=""
QUIT
+3 NEW FBFDA
+4 SET FBIENS="+1,"_FBIENS
+5 ; DATE/TIME EDITED
SET FBFDA(FBFILE,FBIENS,.01)=FBDT
+6 ; EDITED BY
SET FBFDA(FBFILE,FBIENS,1)=FBUSR
+7 ; COMMENTS
SET FBFDA(FBFILE,FBIENS,2)=FBTXT
+8 DO UPDATE^DIE("","FBFDA")
+9 IF $GET(DIERR)=""
SET FBC=FBC+1
+10 IF '$TEST
Begin DoDot:1
+11 SET FBCE=FBCE+1
+12 DO MES^XPDUTL(" "_"Error creating record with IENS "_FBIENS)
End DoDot:1
+13 QUIT
+14 ;
SHOWCNT ; show counts for file
+1 DO MES^XPDUTL(" "_FBC_" user audit entries were created.")
+2 if FBCE
DO MES^XPDUTL(" "_FBCE_" user audit entries not created due to error.")
+3 QUIT
+4 ;
AUTHP ; populate authorization pointer data
+1 NEW DA,DIERR,FBA,FBAUTHP,FBFE,FBIENS,FBP,FBT,FBX,FBYA,FBYD,FBYP
+2 DO MES^XPDUTL("Populating new AUTHORIZATION POINTER field. This may take some time...")
+3 ;
+4 ; init counters
+5 ; total line items
SET FBT("TLN")=0
+6 ; lines skipped because new field was populated
SET FBT("TLN","SKIP")=0
+7 ; lines processed
SET FBT("TLN","PROC")=0
+8 ; processed lines without old authorization pointer
SET FBT("NOP")=0
+9 ; populated based on 7078/583 match
SET FBT("NOP","7078C")=0
+10 ; not populated, no 7078/583 match found
SET FBT("NOP","7078U")=0
+11 ; populated based on POV match
SET FBT("NOP","POVC")=0
+12 ; not populated, no POV match found
SET FBT("NOP","POVU")=0
+13 ; processed lines with old authorization pointer
SET FBT("PTR")=0
+14 ; populated with same value based on 7078/583
SET FBT("PTR","7078M")=0
+15 ; populated with diff value based on 7078/583
SET FBT("PTR","7078C")=0
+16 ; populated with same value, no 7078/583 match
SET FBT("PTR","7078U")=0
+17 ; populated with same value based on POV
SET FBT("PTR","POVM")=0
+18 ; populated with diff value based on POV
SET FBT("PTR","POVC")=0
+19 ; populated with same value, no POV match
SET FBT("PTR","POVU")=0
+20 ;
+21 ; set header for XTMP with purge date in 120 days
+22 SET ^XTMP("FB*3.5*154",0)=$$FMADD^XLFDT(DT,120)_"^"_DT_"^From patch FB*3.5*154 post init."
+23 ;
+24 ; determine if old field still exists
+25 SET FBFE=$SELECT($$GET1^DID(162.02,3,"","LABEL")="*AUTHORIZATION POINTER":1,1:0)
+26 ;
+27 ; loop thru outpatient and ancillary line items in FEE BASIS PAYMENT
+28 ; loop thru patients
+29 SET DA(3)=0
+30 FOR
SET DA(3)=$ORDER(^FBAAC(DA(3)))
if 'DA(3)
QUIT
Begin DoDot:1
+31 ; loop thru vendors
+32 SET DA(2)=0
+33 FOR
SET DA(2)=$ORDER(^FBAAC(DA(3),1,DA(2)))
if 'DA(2)
QUIT
Begin DoDot:2
+34 ; loop thru dates of service
+35 SET DA(1)=0
+36 FOR
SET DA(1)=$ORDER(^FBAAC(DA(3),1,DA(2),1,DA(1)))
if 'DA(1)
QUIT
Begin DoDot:3
+37 SET FBYD=$GET(^FBAAC(DA(3),1,DA(2),1,DA(1),0))
+38 ; date of service
SET FBP("DOS")=$PIECE(FBYD,U,1)
+39 ; old value
SET FBP("FTP")=$SELECT(FBFE:$PIECE(FBYD,U,4),1:"")
+40 ; don't use old value if authorization does not exist in file 161
+41 IF FBP("FTP")
IF '$DATA(^FBAAA(DA(3),1,FBP("FTP"),0))
SET FBP("FTP")=""
+42 SET FBYA=$SELECT(FBP("FTP"):$GET(^FBAAA(DA(3),1,FBP("FTP"),0)),1:"")
+43 ; PURPOSE OF VISIT
SET FBA("POV")=$PIECE(FBYA,U,7)
+44 ; ASSOCIATED 7078/583
SET FBA("7078")=$PIECE(FBYA,U,9)
+45 ; loop thru service provided
+46 SET DA=0
+47 FOR
SET DA=$ORDER(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA))
if 'DA
QUIT
Begin DoDot:4
+48 SET FBT("TLN")=FBT("TLN")+1
+49 SET FBIENS=DA_","_DA(1)_","_DA(2)_","_DA(3)_","
+50 ;
+51 ; skip if already converted (i.e. new field populated)
+52 IF $PIECE($GET(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,3)),U,9)
Begin DoDot:5
+53 SET FBT("TLN","SKIP")=FBT("TLN","SKIP")+1
End DoDot:5
QUIT
+54 SET FBT("TLN","PROC")=FBT("TLN","PROC")+1
+55 ;
+56 SET FBYP=$GET(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,0))
+57 ; ASSOCIATED 7078/583
SET FBP("7078")=$PIECE(FBYP,U,13)
+58 ; PURPOSE OF VISIT
SET FBP("POV")=$PIECE(FBYP,U,18)
+59 ;
+60 ; no old pointer
IF 'FBP("FTP")
SET FBT("NOP")=FBT("NOP")+1
+61 ; old pointer exists
IF '$TEST
SET FBT("PTR")=FBT("PTR")+1
+62 ;
+63 ; determine correct authorization pointer for line item
+64 ; init new auth pointer value
SET FBAUTHP=""
+65 ; if payment associated 7078/583 exists then match with that
+66 IF FBP("7078")]""
Begin DoDot:5
+67 ; if pointer exists and 7078/583 matches then copy old value
+68 IF FBP("FTP")
IF FBP("7078")=FBA("7078")
Begin DoDot:6
+69 SET FBAUTHP=FBP("FTP")
+70 SET FBT("PTR","7078M")=FBT("PTR","7078M")+1
End DoDot:6
if FBAUTHP
QUIT
+71 ; if 7078/583 does not match then look for an better auth.
+72 IF FBP("7078")'=FBA("7078")
Begin DoDot:6
+73 SET FBX=$$ASSOC(DA(3),FBP("DOS"),FBP("7078"))
+74 if 'FBX
QUIT
+75 SET FBAUTHP=FBX
+76 IF FBP("FTP")
SET FBT("PTR","7078C")=FBT("PTR","7078C")+1
+77 IF 'FBP("FTP")
SET FBT("NOP","7078C")=FBT("NOP","7078C")+1
+78 SET ^XTMP("FB*3.5*154","7078C",FBIENS)=FBP("FTP")_"^"_FBAUTHP
End DoDot:6
if FBAUTHP
QUIT
+79 IF 'FBAUTHP
Begin DoDot:6
+80 ; if better auth. not found use old value when available
+81 IF FBP("FTP")
SET FBAUTHP=FBP("FTP")
+82 IF FBP("FTP")
SET FBT("PTR","7078U")=FBT("PTR","7078U")+1
+83 IF 'FBP("FTP")
SET FBT("NOP","7078U")=FBT("NOP","7078U")+1
+84 SET ^XTMP("FB*3.5*154","7078U",FBIENS)=FBP("FTP")_"^"_FBAUTHP
End DoDot:6
End DoDot:5
+85 ;
+86 ; if payment associated 7078/583 blank then match with POV
+87 IF FBP("7078")=""
Begin DoDot:5
+88 ; if pointer exists and POV matches then copy old value
+89 IF FBP("FTP")
IF FBP("POV")=FBA("POV")
Begin DoDot:6
+90 SET FBAUTHP=FBP("FTP")
+91 SET FBT("PTR","POVM")=FBT("PTR","POVM")+1
End DoDot:6
if FBAUTHP
QUIT
+92 ; if POV does not match then look for an better auth.
+93 IF FBP("POV")'=FBA("POV")
Begin DoDot:6
+94 SET FBX=$$POV(DA(3),FBP("DOS"),FBP("POV"))
+95 if 'FBX
QUIT
+96 SET FBAUTHP=FBX
+97 IF FBP("FTP")
SET FBT("PTR","POVC")=FBT("PTR","POVC")+1
+98 IF 'FBP("FTP")
SET FBT("NOP","POVC")=FBT("NOP","POVC")+1
+99 SET ^XTMP("FB*3.5*154","POVC",FBIENS)=FBP("FTP")_"^"_FBAUTHP
End DoDot:6
if FBAUTHP
QUIT
+100 ; if better auth. not found use old value when available
+101 IF 'FBAUTHP
Begin DoDot:6
+102 IF FBP("FTP")
SET FBAUTHP=FBP("FTP")
+103 IF FBP("FTP")
SET FBT("PTR","POVU")=FBT("PTR","POVU")+1
+104 IF 'FBP("FTP")
SET FBT("NOP","POVU")=FBT("NOP","POVU")+1
+105 SET ^XTMP("FB*3.5*154","POVU",FBIENS)=FBP("FTP")_"^"_FBAUTHP
End DoDot:6
End DoDot:5
+106 ;
+107 ; save authorization pointer value in new field
+108 IF FBAUTHP
Begin DoDot:5
+109 NEW FBFDA
+110 SET FBFDA(162.03,FBIENS,15.5)=FBAUTHP
+111 DO FILE^DIE("","FBFDA")
+112 IF $GET(DIERR)'=""
DO MES^XPDUTL(" Error updating record with IENS "_FBIENS)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+113 ;
+114 ; report results
+115 SET FBX=$JUSTIFY($FNUMBER(FBT("TLN"),","),10)_" payment line items in FEE BASIS PAYMENT file"
+116 DO MES^XPDUTL(FBX)
+117 DO MES^XPDUTL("----------")
+118 SET FBX=$JUSTIFY($FNUMBER(FBT("TLN","SKIP"),","),10)_" lines skipped because new field already populated"
+119 DO MES^XPDUTL(FBX)
+120 SET FBX=$JUSTIFY($FNUMBER(FBT("TLN","PROC"),","),10)_" lines processed"
+121 DO MES^XPDUTL(FBX)
+122 ;
+123 SET FBX=$JUSTIFY($FNUMBER(FBT("NOP"),","),10)_" processed lines without an existing authorization pointer value"
+124 DO BMES^XPDUTL(FBX)
+125 DO MES^XPDUTL("----------")
+126 SET FBX=$JUSTIFY($FNUMBER(FBT("NOP","7078C"),","),10)_" lines populated based on 7078/583 match"
+127 DO MES^XPDUTL(FBX)
+128 SET FBX=$JUSTIFY($FNUMBER(FBT("NOP","7078U"),","),10)_" lines not populated because 7078/583 match not found"
+129 DO MES^XPDUTL(FBX)
+130 SET FBX=$JUSTIFY($FNUMBER(FBT("NOP","POVC"),","),10)_" lines populated based on POV match"
+131 DO MES^XPDUTL(FBX)
+132 SET FBX=$JUSTIFY($FNUMBER(FBT("NOP","POVU"),","),10)_" lines not populated because POV match not found"
+133 DO MES^XPDUTL(FBX)
+134 ;
+135 SET FBX=$JUSTIFY($FNUMBER(FBT("PTR"),","),10)_" processed lines with an existing authorization pointer value"
+136 DO BMES^XPDUTL(FBX)
+137 DO MES^XPDUTL("----------")
+138 SET FBX=$JUSTIFY($FNUMBER(FBT("PTR","7078M"),","),10)_" lines populated with same value based on 7078/583 match"
+139 DO MES^XPDUTL(FBX)
+140 SET FBX=$JUSTIFY($FNUMBER(FBT("PTR","7078C"),","),10)_" lines populated with different value based on 7078/583 match"
+141 DO MES^XPDUTL(FBX)
+142 SET FBX=$JUSTIFY($FNUMBER(FBT("PTR","7078U"),","),10)_" lines populated with same value since 7078/583 match not found"
+143 DO MES^XPDUTL(FBX)
+144 SET FBX=$JUSTIFY($FNUMBER(FBT("PTR","POVM"),","),10)_" lines populated with same value based on POV match"
+145 DO MES^XPDUTL(FBX)
+146 SET FBX=$JUSTIFY($FNUMBER(FBT("PTR","POVC"),","),10)_" lines populated with different value based on POV match"
+147 DO MES^XPDUTL(FBX)
+148 SET FBX=$JUSTIFY($FNUMBER(FBT("PTR","POVU"),","),10)_" lines populated with same value since POV match not found"
+149 DO MES^XPDUTL(FBX)
+150 ;
+151 QUIT
+152 ;
ASSOC(FBDFN,FBDOS,FB7078) ; find authorization for ASSOCIATED 7078/583
+1 ; input
+2 ; FBDFN - patient (internal, pointer to file 2 and file 161)
+3 ; FBDOS - date of service (internal, FM date)
+4 ; FB7078 - associated 7078/583 (internal)
+5 ; returns null value or authorization IEN in file 161 for patient
+6 NEW FBFTP
+7 SET FBFTP=""
+8 IF $GET(FB7078)]""
IF $GET(FBDFN)]""
IF $GET(FBDOS)]""
Begin DoDot:1
+9 NEW FBDA,FBY
+10 ; loop thru authorizations for ASSOCIATED 7078/583 and PATIENT
+11 SET FBDA=0
+12 FOR
SET FBDA=$ORDER(^FBAAA("AG",FB7078,FBDFN,FBDA))
if 'FBDA
QUIT
Begin DoDot:2
+13 SET FBY=$GET(^FBAAA(FBDFN,1,FBDA,0))
+14 ; invalid data
if $PIECE(FBY,U,1)=""
QUIT
+15 ; auth from date is after date of service
if $PIECE(FBY,U,1)>FBDOS
QUIT
+16 ; auth to date is before date of service
if $PIECE(FBY,U,2)<FBDOS
QUIT
+17 ; passed all criterion, found matching authorization
+18 SET FBFTP=FBDA
End DoDot:2
if FBFTP
QUIT
End DoDot:1
+19 ;
+20 QUIT FBFTP
+21 ;
POV(FBDFN,FBDOS,FBPOV) ; find authorization for POV
+1 ; input
+2 ; FBDFN - patient (internal, pointer to file 2 and file 161)
+3 ; FBDOS - date of service (internal, FM date)
+4 ; FBPOV - purpose of visit (internal, pointer to 161.82)
+5 ; returns null value or authorization IEN in file 161 for patient
+6 NEW FBFTP
+7 SET FBFTP=""
+8 IF $GET(FBPOV)]""
IF $GET(FBDFN)]""
IF $GET(FBDOS)]""
Begin DoDot:1
+9 NEW FBDA,FBY
+10 ; loop thru authorizations for patient
+11 SET FBDA=0
+12 FOR
SET FBDA=$ORDER(^FBAAA(FBDFN,1,FBDA))
if 'FBDA
QUIT
Begin DoDot:2
+13 SET FBY=$GET(^FBAAA(FBDFN,1,FBDA,0))
+14 ; invalid data
if $PIECE(FBY,U,1)=""
QUIT
+15 ; POV does not match input value
if $PIECE(FBY,U,7)'=FBPOV
QUIT
+16 ; auth from date is after date of service
if $PIECE(FBY,U,1)>FBDOS
QUIT
+17 ; auth to date is before date of service
if $PIECE(FBY,U,2)<FBDOS
QUIT
+18 ; passed all criterion, found matching authorization
+19 SET FBFTP=FBDA
End DoDot:2
if FBFTP
QUIT
End DoDot:1
+20 ;
+21 QUIT FBFTP
+22 ;
+23 ;
RPT ; report of ^XTMP
+1 WRITE !,"Report of XTMP(""FB*3.5*154"") data"
+2 ;
+3 DO LIST("7078C")
+4 DO LIST("7078U")
+5 DO LIST("POVC")
+6 DO LIST("POVU")
+7 QUIT
+8 ;
+9 ;
LIST(FBSUB) ; list lines in subscript
+1 NEW FBIENS,FBFLD,FBFLDN,FBY
+2 ;
+3 if FBSUB["C"
WRITE !,"Lines with pointer changed based on "
+4 if FBSUB["U"
WRITE !,"Lines with no matching authorization found using "
+5 if FBSUB["7078"
WRITE "associated 7078/583"
+6 if FBSUB["POV"
WRITE "POV"
+7 IF FBSUB["7078"
SET FBFLD=27
SET FBFLDN=" 7078/583: "
+8 IF FBSUB["POV"
SET FBFLD=16
SET FBFLDN=" POV: "
+9 ;
+10 SET FBIENS=""
+11 FOR
SET FBIENS=$ORDER(^XTMP("FB*3.5*154",FBSUB,FBIENS))
if FBIENS=""
QUIT
Begin DoDot:1
+12 SET FBY=$GET(^XTMP("FB*3.5*154",FBSUB,FBIENS))
+13 WRITE !,FBIENS," From: ",$PIECE(FBY,U,1)," To: ",$PIECE(FBY,U,2),FBFLDN,$$GET1^DIQ(162.03,FBIENS,FBFLD,"I")
End DoDot:1
+14 QUIT
+15 ;FBXIP154
