FBUCLNK1 ;ALBISC/TET - LINK CLAIM DISPLAY
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
LINK(FBDA,FBIX,FBSET) ;determine if link claims exist
;INPUT: FBDA = ien of unauthoriezed claim
; FBIX = xref indicating how user is looking up (APMS,AVMS,AOMS)
; FBSET = (optional) 1 to set global array, 0 to not set
;OUTPUT: 1 if claim is linked to others, 0 if not
; TMP("FBAR" global array (if 1 and flagged to set)
I '+$G(FBDA) Q 0 S:$G(FBSET)']"" FBSET=0
N FBCT,FBDCT,FBI,FBMC,FBZ S FBMC=+$P($$FBZ^FBUCUTL(FBDA),U,20) I 'FBMC Q 0
S (FBDCT,FBCT,FBI)=0 F S FBI=$O(^FB583("AMC",FBMC,FBI)) Q:'FBI!(FBCT&('FBSET)) I FBI'=FBDA S FBCT=FBCT+1 I FBSET S FBZ=$G(^FB583(FBI,0)) I FBZ]"" D
.;set array
.D DA^FBUCUTL5(FBI,"APMS",.FBDCT,+$P(FBZ,U,20),FBZ)
I FBCT,FBSET D FBAR^FBUCUTL5(FBCT)
Q $S(FBCT:1,1:0)
;
ENTER(FBDA,FBUCA,DISP,FBIX) ;link claim on entry
;called from fbucen - enter new unauth claim
;INPUT: FBDA = ien of unauthorized claim
; FBUCA = after node of unauthorized claim
; DISP = 0 to display only, 1 to update
; FBIX = cross-ref (optional)
;VAR: FBTFROM-treatment from date/FBTTO-treatment to date/FBVET-veteran
;OUTPUT: link new claim to existing claim, if user so designates
; data stored in tmp(fbar/tmp(fbary global arrays
N FBAR,FBARY,FBCNT,FBDCT,FBI,FBLINK,FBMC,FBOUT,FBTFROM,FBTTO,FBVET,FBX,FBZ S FBDCT=0
S:$G(FBIX)']"" FBIX="APMS" S FBTFROM=$P(FBUCA,U,5),FBTTO=$P(FBUCA,U,6),FBVET=$P(FBUCA,U,4),FBMC=+$P(FBUCA,U,20),FBX=+$O(^FB583("APF",FBVET,FBTFROM,0))
I FBX'=FBDA S FBLINK=1,FBI=0 F S FBI=$O(^FB583("APF",FBVET,FBTFROM,FBI)) Q:'FBI S FBZ=$$FBZ^FBUCUTL(FBI) I $P(FBZ,U,6)=FBTTO,$$LINKTO^FBUCUTL4(FBI,FBZ,FBDA),FBI'=FBDA D DA^FBUCUTL5(FBI,FBIX,.FBDCT,FBMC,FBZ)
D FBAR^FBUCUTL5(FBDCT)
I DISP,+$G(FBLINK),+$G(FBAR) D ASK^FBUCLINK Q:+$G(FBOUT) I FBLINK D SELECT^FBUCLINK(+FBAR) Q:+$G(FBOUT) D:FBLINK UPD^FBUCLINK(FBDA,FBLINK)
I 'DISP,+$G(FBLINK),+$G(FBAR) S FBX="< ASSOCIATED CLAIMS >" W !!?(IOM-$L(FBX)/2),FBX,! D DISPX^FBUCUTL1(0)
K ^TMP("FBAR",$J),^TMP("FBARY",$J) Q
;
UNLINK(FBGROUP,FBDA,FBZ,FBRELINK) ;unlink claim from group/determine new primary claim
;INPUT: FBGROUP = # in group^# of programs^1 if auth^# of u/c w/same status^# of diff dispositions
; FBGROUP(ien of 162.7) = prog^auth ien^status ien^dispositon ien
; FBDA = ien of unauth claim working with
; FBZ = zero node of unauth claim (fbda)
; FBRELINK = <optional> flag to auto relink: 1 for auto-relink
;OUTPUT: fbda claim is unlinked; if group and fbda primary, new primary
; if another claim exists with same vet and episode of care,
; the unlinked claim may be relinked to it.
I $S('+$G(FBGROUP):1,'+$G(FBDA):1,$G(FBZ)']"":1,1:0) Q
S FBRELINK=+$G(FBRELINK) N FBALL,FBD,FBDIRA,FBI,FBMATCH,FBO,FBOUT,FBPRIME,FBTFR,FBTTO,FBVET ;other variables
S (FBALL,FBMATCH,FBOUT)=0
S FBPRIME=$$PRIME^FBUCUTL4(FBDA,FBZ) D:FBPRIME PRIME(.FBGROUP,FBDA,FBZ) I 'FBPRIME D DIE^FBUCUTL2("^FB583(",FBDA,"20////^S X="_FBDA)
S FBVET=$P(FBZ,U,4),FBTFR=$P(FBZ,U,5),FBTTO=$P(FBZ,U,6),FBD=FBTFR-.1
F S FBD=$O(^FB583("APF",FBVET,FBD)) Q:'FBD!(FBD>FBTFR) S FBI=0 F S FBI=$O(^FB583("APF",FBVET,FBD,FBI)) Q:'FBI!(FBMATCH) I FBI'=FBDA S FBO=$G(^FB583(FBI,0)) I $P(FBO,U,6)=FBTTO,'$D(FBGROUP(FBI)) S FBMATCH=+$P(FBO,U,20)
Q:'FBMATCH ;nothing else to which this claim can be grouped
I 'FBRELINK S FBDIRA="Do you want to automatically link this claim with another group" D READ^FBUCUTL7(FBDIRA,.FBOUT) Q:FBOUT!('FBALL)
I FBALL D DIE^FBUCUTL2("^FB583(",FBDA,"20////^S X="_FBMATCH)
Q
PRIME(FBGROUP,FBDA,FBZ) ;determine primary claim
;INPUT: FBGROUP = # in group^# of programs^1 if auth^# of u/c w/same status^# of diff dispositions
; FBGROUP(ien of 162.7) = prog^auth ien^status ien^dispositon ien
; FBDA = ien of unauth claim
; FBZ = zero node of unauth claim (fbda)
;OUTPUT: if primary, find new primary for other claims in group and update
N FBPRIME,FBI,FBO
;determine new primary claim; reset rest in group to new primary
S (FBI,FBPRIME)=0 F S FBI=$O(FBGROUP(FBI)) Q:'FBI I FBI'=FBDA S FBPRIME=FBI Q:FBPRIME
I FBPRIME S FBI=0 F S FBI=$O(FBGROUP(FBI)) Q:'FBI I FBI'=FBDA S FBO=$G(^FB583(FBI,0)) D DIE^FBUCUTL2("^FB583(",FBI,"20////^S X="_FBPRIME)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCLNK1 4401 printed Dec 13, 2024@02:00:20 Page 2
FBUCLNK1 ;ALBISC/TET - LINK CLAIM DISPLAY
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
LINK(FBDA,FBIX,FBSET) ;determine if link claims exist
+1 ;INPUT: FBDA = ien of unauthoriezed claim
+2 ; FBIX = xref indicating how user is looking up (APMS,AVMS,AOMS)
+3 ; FBSET = (optional) 1 to set global array, 0 to not set
+4 ;OUTPUT: 1 if claim is linked to others, 0 if not
+5 ; TMP("FBAR" global array (if 1 and flagged to set)
+6 IF '+$GET(FBDA)
QUIT 0
if $GET(FBSET)']""
SET FBSET=0
+7 NEW FBCT,FBDCT,FBI,FBMC,FBZ
SET FBMC=+$PIECE($$FBZ^FBUCUTL(FBDA),U,20)
IF 'FBMC
QUIT 0
+8 SET (FBDCT,FBCT,FBI)=0
FOR
SET FBI=$ORDER(^FB583("AMC",FBMC,FBI))
if 'FBI!(FBCT&('FBSET))
QUIT
IF FBI'=FBDA
SET FBCT=FBCT+1
IF FBSET
SET FBZ=$GET(^FB583(FBI,0))
IF FBZ]""
Begin DoDot:1
+9 ;set array
+10 DO DA^FBUCUTL5(FBI,"APMS",.FBDCT,+$PIECE(FBZ,U,20),FBZ)
End DoDot:1
+11 IF FBCT
IF FBSET
DO FBAR^FBUCUTL5(FBCT)
+12 QUIT $SELECT(FBCT:1,1:0)
+13 ;
ENTER(FBDA,FBUCA,DISP,FBIX) ;link claim on entry
+1 ;called from fbucen - enter new unauth claim
+2 ;INPUT: FBDA = ien of unauthorized claim
+3 ; FBUCA = after node of unauthorized claim
+4 ; DISP = 0 to display only, 1 to update
+5 ; FBIX = cross-ref (optional)
+6 ;VAR: FBTFROM-treatment from date/FBTTO-treatment to date/FBVET-veteran
+7 ;OUTPUT: link new claim to existing claim, if user so designates
+8 ; data stored in tmp(fbar/tmp(fbary global arrays
+9 NEW FBAR,FBARY,FBCNT,FBDCT,FBI,FBLINK,FBMC,FBOUT,FBTFROM,FBTTO,FBVET,FBX,FBZ
SET FBDCT=0
+10 if $GET(FBIX)']""
SET FBIX="APMS"
SET FBTFROM=$PIECE(FBUCA,U,5)
SET FBTTO=$PIECE(FBUCA,U,6)
SET FBVET=$PIECE(FBUCA,U,4)
SET FBMC=+$PIECE(FBUCA,U,20)
SET FBX=+$ORDER(^FB583("APF",FBVET,FBTFROM,0))
+11 IF FBX'=FBDA
SET FBLINK=1
SET FBI=0
FOR
SET FBI=$ORDER(^FB583("APF",FBVET,FBTFROM,FBI))
if 'FBI
QUIT
SET FBZ=$$FBZ^FBUCUTL(FBI)
IF $PIECE(FBZ,U,6)=FBTTO
IF $$LINKTO^FBUCUTL4(FBI,FBZ,FBDA)
IF FBI'=FBDA
DO DA^FBUCUTL5(FBI,FBIX,.FBDCT,FBMC,FBZ)
+12 DO FBAR^FBUCUTL5(FBDCT)
+13 IF DISP
IF +$GET(FBLINK)
IF +$GET(FBAR)
DO ASK^FBUCLINK
if +$GET(FBOUT)
QUIT
IF FBLINK
DO SELECT^FBUCLINK(+FBAR)
if +$GET(FBOUT)
QUIT
if FBLINK
DO UPD^FBUCLINK(FBDA,FBLINK)
+14 IF 'DISP
IF +$GET(FBLINK)
IF +$GET(FBAR)
SET FBX="< ASSOCIATED CLAIMS >"
WRITE !!?(IOM-$LENGTH(FBX)/2),FBX,!
DO DISPX^FBUCUTL1(0)
+15 KILL ^TMP("FBAR",$JOB),^TMP("FBARY",$JOB)
QUIT
+16 ;
UNLINK(FBGROUP,FBDA,FBZ,FBRELINK) ;unlink claim from group/determine new primary claim
+1 ;INPUT: FBGROUP = # in group^# of programs^1 if auth^# of u/c w/same status^# of diff dispositions
+2 ; FBGROUP(ien of 162.7) = prog^auth ien^status ien^dispositon ien
+3 ; FBDA = ien of unauth claim working with
+4 ; FBZ = zero node of unauth claim (fbda)
+5 ; FBRELINK = <optional> flag to auto relink: 1 for auto-relink
+6 ;OUTPUT: fbda claim is unlinked; if group and fbda primary, new primary
+7 ; if another claim exists with same vet and episode of care,
+8 ; the unlinked claim may be relinked to it.
+9 IF $SELECT('+$GET(FBGROUP):1,'+$GET(FBDA):1,$GET(FBZ)']"":1,1:0)
QUIT
+10 ;other variables
SET FBRELINK=+$GET(FBRELINK)
NEW FBALL,FBD,FBDIRA,FBI,FBMATCH,FBO,FBOUT,FBPRIME,FBTFR,FBTTO,FBVET
+11 SET (FBALL,FBMATCH,FBOUT)=0
+12 SET FBPRIME=$$PRIME^FBUCUTL4(FBDA,FBZ)
if FBPRIME
DO PRIME(.FBGROUP,FBDA,FBZ)
IF 'FBPRIME
DO DIE^FBUCUTL2("^FB583(",FBDA,"20////^S X="_FBDA)
+13 SET FBVET=$PIECE(FBZ,U,4)
SET FBTFR=$PIECE(FBZ,U,5)
SET FBTTO=$PIECE(FBZ,U,6)
SET FBD=FBTFR-.1
+14 FOR
SET FBD=$ORDER(^FB583("APF",FBVET,FBD))
if 'FBD!(FBD>FBTFR)
QUIT
SET FBI=0
FOR
SET FBI=$ORDER(^FB583("APF",FBVET,FBD,FBI))
if 'FBI!(FBMATCH)
QUIT
IF FBI'=FBDA
SET FBO=$GET(^FB583(FBI,0))
IF $PIECE(FBO,U,6)=FBTTO
IF '$DATA(FBGROUP(FBI))
SET FBMATCH=+$PIECE(FBO,U,20)
+15 ;nothing else to which this claim can be grouped
if 'FBMATCH
QUIT
+16 IF 'FBRELINK
SET FBDIRA="Do you want to automatically link this claim with another group"
DO READ^FBUCUTL7(FBDIRA,.FBOUT)
if FBOUT!('FBALL)
QUIT
+17 IF FBALL
DO DIE^FBUCUTL2("^FB583(",FBDA,"20////^S X="_FBMATCH)
+18 QUIT
PRIME(FBGROUP,FBDA,FBZ) ;determine primary claim
+1 ;INPUT: FBGROUP = # in group^# of programs^1 if auth^# of u/c w/same status^# of diff dispositions
+2 ; FBGROUP(ien of 162.7) = prog^auth ien^status ien^dispositon ien
+3 ; FBDA = ien of unauth claim
+4 ; FBZ = zero node of unauth claim (fbda)
+5 ;OUTPUT: if primary, find new primary for other claims in group and update
+6 NEW FBPRIME,FBI,FBO
+7 ;determine new primary claim; reset rest in group to new primary
+8 SET (FBI,FBPRIME)=0
FOR
SET FBI=$ORDER(FBGROUP(FBI))
if 'FBI
QUIT
IF FBI'=FBDA
SET FBPRIME=FBI
if FBPRIME
QUIT
+9 IF FBPRIME
SET FBI=0
FOR
SET FBI=$ORDER(FBGROUP(FBI))
if 'FBI
QUIT
IF FBI'=FBDA
SET FBO=$GET(^FB583(FBI,0))
DO DIE^FBUCUTL2("^FB583(",FBI,"20////^S X="_FBPRIME)
+10 QUIT
