FBUCLNK1.m

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 ---FBUCLNK1   4401     printed  Feb 18, 2025@23:26:45                                                                                                                                                                                                    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