source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBUCLNK1.m@ 862

Last change on this file since 862 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.2 KB
Line 
1FBUCLNK1 ;ALBISC/TET - LINK CLAIM DISPLAY
2 ;;3.5;FEE BASIS;;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4LINK(FBDA,FBIX,FBSET) ;determine if link claims exist
5 ;INPUT: FBDA = ien of unauthoriezed claim
6 ; FBIX = xref indicating how user is looking up (APMS,AVMS,AOMS)
7 ; FBSET = (optional) 1 to set global array, 0 to not set
8 ;OUTPUT: 1 if claim is linked to others, 0 if not
9 ; TMP("FBAR" global array (if 1 and flagged to set)
10 I '+$G(FBDA) Q 0 S:$G(FBSET)']"" FBSET=0
11 N FBCT,FBDCT,FBI,FBMC,FBZ S FBMC=+$P($$FBZ^FBUCUTL(FBDA),U,20) I 'FBMC Q 0
12 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
13 .;set array
14 .D DA^FBUCUTL5(FBI,"APMS",.FBDCT,+$P(FBZ,U,20),FBZ)
15 I FBCT,FBSET D FBAR^FBUCUTL5(FBCT)
16 Q $S(FBCT:1,1:0)
17 ;
18ENTER(FBDA,FBUCA,DISP,FBIX) ;link claim on entry
19 ;called from fbucen - enter new unauth claim
20 ;INPUT: FBDA = ien of unauthorized claim
21 ; FBUCA = after node of unauthorized claim
22 ; DISP = 0 to display only, 1 to update
23 ; FBIX = cross-ref (optional)
24 ;VAR: FBTFROM-treatment from date/FBTTO-treatment to date/FBVET-veteran
25 ;OUTPUT: link new claim to existing claim, if user so designates
26 ; data stored in tmp(fbar/tmp(fbary global arrays
27 N FBAR,FBARY,FBCNT,FBDCT,FBI,FBLINK,FBMC,FBOUT,FBTFROM,FBTTO,FBVET,FBX,FBZ S FBDCT=0
28 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))
29 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)
30 D FBAR^FBUCUTL5(FBDCT)
31 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)
32 I 'DISP,+$G(FBLINK),+$G(FBAR) S FBX="< ASSOCIATED CLAIMS >" W !!?(IOM-$L(FBX)/2),FBX,! D DISPX^FBUCUTL1(0)
33 K ^TMP("FBAR",$J),^TMP("FBARY",$J) Q
34 ;
35UNLINK(FBGROUP,FBDA,FBZ,FBRELINK) ;unlink claim from group/determine new primary claim
36 ;INPUT: FBGROUP = # in group^# of programs^1 if auth^# of u/c w/same status^# of diff dispositions
37 ; FBGROUP(ien of 162.7) = prog^auth ien^status ien^dispositon ien
38 ; FBDA = ien of unauth claim working with
39 ; FBZ = zero node of unauth claim (fbda)
40 ; FBRELINK = <optional> flag to auto relink: 1 for auto-relink
41 ;OUTPUT: fbda claim is unlinked; if group and fbda primary, new primary
42 ; if another claim exists with same vet and episode of care,
43 ; the unlinked claim may be relinked to it.
44 I $S('+$G(FBGROUP):1,'+$G(FBDA):1,$G(FBZ)']"":1,1:0) Q
45 S FBRELINK=+$G(FBRELINK) N FBALL,FBD,FBDIRA,FBI,FBMATCH,FBO,FBOUT,FBPRIME,FBTFR,FBTTO,FBVET ;other variables
46 S (FBALL,FBMATCH,FBOUT)=0
47 S FBPRIME=$$PRIME^FBUCUTL4(FBDA,FBZ) D:FBPRIME PRIME(.FBGROUP,FBDA,FBZ) I 'FBPRIME D DIE^FBUCUTL2("^FB583(",FBDA,"20////^S X="_FBDA)
48 S FBVET=$P(FBZ,U,4),FBTFR=$P(FBZ,U,5),FBTTO=$P(FBZ,U,6),FBD=FBTFR-.1
49 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)
50 Q:'FBMATCH ;nothing else to which this claim can be grouped
51 I 'FBRELINK S FBDIRA="Do you want to automatically link this claim with another group" D READ^FBUCUTL7(FBDIRA,.FBOUT) Q:FBOUT!('FBALL)
52 I FBALL D DIE^FBUCUTL2("^FB583(",FBDA,"20////^S X="_FBMATCH)
53 Q
54PRIME(FBGROUP,FBDA,FBZ) ;determine primary claim
55 ;INPUT: FBGROUP = # in group^# of programs^1 if auth^# of u/c w/same status^# of diff dispositions
56 ; FBGROUP(ien of 162.7) = prog^auth ien^status ien^dispositon ien
57 ; FBDA = ien of unauth claim
58 ; FBZ = zero node of unauth claim (fbda)
59 ;OUTPUT: if primary, find new primary for other claims in group and update
60 N FBPRIME,FBI,FBO
61 ;determine new primary claim; reset rest in group to new primary
62 S (FBI,FBPRIME)=0 F S FBI=$O(FBGROUP(FBI)) Q:'FBI I FBI'=FBDA S FBPRIME=FBI Q:FBPRIME
63 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)
64 Q
Note: See TracBrowser for help on using the repository browser.