FBUCUTL4 ;ALBISC/TET - UTILITY CONTINUATION ;5/14/93 15:06
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
PRIME(FBDA,FBUCP) ;determine if claim is a primary (points to itself)
;INPUT: FBDA = ien of unauthorized claim
; FBUCP = zero node of fbda
;OUTPUT: 1 if yes, 0 if no
Q $S('+$G(FBDA):0,$G(FBUCP)']"":0,FBDA=$P(FBUCP,U,20):1,1:0)
;
SECOND(FBDA,FBUCP) ;determine if claim is a secondary (points to another)
;INPUT: FBDA = ien of unauthorized claim
; FBUCP = zero node of fbda
;OUTPUT: 1 if yes, 0 if no
Q $S('+$G(FBDA):0,$G(FBUCP)']"":0,FBDA'=$P(FBUCP,U,20):1,1:0)
;
LINK(FBDA,FBUCP) ;is this a claim which can be linked to a primary?
;claims which can be linked are only primaries with no secondaries OR only secondaries
;INPUT: FBDA = ien of unauthorized claim
; FBUCP = zero node of unauthorized claim
;OUTPUT: 1 if yes, 0 if no
I $S('+$G(FBDA):1,$G(FBUCP)']"":1,1:0) Q 0
Q $S($$SECOND(FBDA,FBUCP):1,$$PRIME(FBDA,FBUCP)&('+$O(^FB583("AMS",+$P(FBUCP,U,20),0))):1,1:0)
;
LINKTO(FBDA,FBUCP,FBLINK) ;is this a primary claim to which a secondary can be linked?
;claim which is a primary and not claim selected to be linked
;INPUT: FBDA = ien of unauthorized claim
; FBUCP = zero node of unauthorized claim
; FBLINK = claim ien which is to be linked
;OUTPUT: 1 if yes, 0 if no
I $S('+$G(FBDA):1,$G(FBUCP)']"":1,'+$G(FBLINK):1,1:0) Q 0
Q $S($$PRIME(FBDA,FBUCP)&(FBDA'=FBLINK):1,1:0)
;
ID ;display identifiers
N FBZ S FBZ=$$FBZ^FBUCUTL(+Y) Q:Y']"" W ?15,$E($$VET^FBUCUTL(+$P(FBZ,U,4)),1,20),?38,$E($$VEN^FBUCUTL(+$P(FBZ,U,3)),1,20)
W ?61,$E($$PROG^FBUCUTL(+$P(FBZ,U,2)),1,14),!,$E($P($$PTR^FBUCUTL("^FB(162.92,",+$P(FBZ,U,24)),U),1,16)
W ?19,"TREATMENT FROM: ",$$DATX^FBAAUTL(+$P(FBZ,U,5)),?44,"TREATMENT TO: ",$$DATX^FBAAUTL(+$P(FBZ,U,6))
W ! Q
PARSE(FBARY) ;set piece positions variable, and get # of pieces for printing
;INPUT: FBARY = (not subscripted) - piece positions
;OUTPUT: FBW = piece positions
; FBPL = # of pieces
S FBARY=$G(FBARY),FBW=$P(FBARY,";",2),FBPL=($L(FBW,"^"))-1
Q
LINE(FBARY,FBI,FBPL,FBW) ;write line
;INPUT: FBPL = # of pieces
; FBW = piece positions
; FBARY = specific array entry
;OUTPUT: write line of info
N FBP,FBY S FBY=$P(FBARY,";",2) W:$L(FBARY,"^")>5 ! W !,$S($L(FBI)<2:" ",1:""),FBI F FBP=1:1:FBPL Q:$P(FBY,U,FBP)']"" D
.I $P(FBY,U,FBP)="!" W ! I FBP>1 S FBW=$P(FBW,U,1,FBP-1)_U_"!"_U_$P(FBW,U,FBP,FBPL)
.I $P(FBY,U,FBP)'="!" W ?($P(FBW,U,FBP)),$P(FBY,U,FBP)
Q
FBO() ;set fbo string if 0 or not defined
N FBI,Z S FBI=0 F S FBI=$O(^FB(162.92,FBI)) Q:'FBI S Z=$G(^FB(162.92,FBI,0)) I $P(Z,U,2),$P(Z,U,4) S FBO=$S(+$G(FBO):FBO_$P(Z,U,4)_U,1:$P(Z,U,4)_U)
Q $G(FBO)
;
PAD(L,V,C,O) ;set fixed length field
;INPUT: L=length of field/V=variable/C=character to append/O=order
; 1 for beginning,2 for ending
;OUTPUT: fixed length field
N X S $P(X,C,L)="" I O=2 S V=V_($E(X,1,(L-$L(V))))
I O=1 S V=($E(X,1,(L-$L(V))))_V
Q $G(V)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCUTL4 3094 printed Dec 13, 2024@02:00:33 Page 2
FBUCUTL4 ;ALBISC/TET - UTILITY CONTINUATION ;5/14/93 15:06
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
PRIME(FBDA,FBUCP) ;determine if claim is a primary (points to itself)
+1 ;INPUT: FBDA = ien of unauthorized claim
+2 ; FBUCP = zero node of fbda
+3 ;OUTPUT: 1 if yes, 0 if no
+4 QUIT $SELECT('+$GET(FBDA):0,$GET(FBUCP)']"":0,FBDA=$PIECE(FBUCP,U,20):1,1:0)
+5 ;
SECOND(FBDA,FBUCP) ;determine if claim is a secondary (points to another)
+1 ;INPUT: FBDA = ien of unauthorized claim
+2 ; FBUCP = zero node of fbda
+3 ;OUTPUT: 1 if yes, 0 if no
+4 QUIT $SELECT('+$GET(FBDA):0,$GET(FBUCP)']"":0,FBDA'=$PIECE(FBUCP,U,20):1,1:0)
+5 ;
LINK(FBDA,FBUCP) ;is this a claim which can be linked to a primary?
+1 ;claims which can be linked are only primaries with no secondaries OR only secondaries
+2 ;INPUT: FBDA = ien of unauthorized claim
+3 ; FBUCP = zero node of unauthorized claim
+4 ;OUTPUT: 1 if yes, 0 if no
+5 IF $SELECT('+$GET(FBDA):1,$GET(FBUCP)']"":1,1:0)
QUIT 0
+6 QUIT $SELECT($$SECOND(FBDA,FBUCP):1,$$PRIME(FBDA,FBUCP)&('+$ORDER(^FB583("AMS",+$PIECE(FBUCP,U,20),0))):1,1:0)
+7 ;
LINKTO(FBDA,FBUCP,FBLINK) ;is this a primary claim to which a secondary can be linked?
+1 ;claim which is a primary and not claim selected to be linked
+2 ;INPUT: FBDA = ien of unauthorized claim
+3 ; FBUCP = zero node of unauthorized claim
+4 ; FBLINK = claim ien which is to be linked
+5 ;OUTPUT: 1 if yes, 0 if no
+6 IF $SELECT('+$GET(FBDA):1,$GET(FBUCP)']"":1,'+$GET(FBLINK):1,1:0)
QUIT 0
+7 QUIT $SELECT($$PRIME(FBDA,FBUCP)&(FBDA'=FBLINK):1,1:0)
+8 ;
ID ;display identifiers
+1 NEW FBZ
SET FBZ=$$FBZ^FBUCUTL(+Y)
if Y']""
QUIT
WRITE ?15,$EXTRACT($$VET^FBUCUTL(+$PIECE(FBZ,U,4)),1,20),?38,$EXTRACT($$VEN^FBUCUTL(+$PIECE(FBZ,U,3)),1,20)
+2 WRITE ?61,$EXTRACT($$PROG^FBUCUTL(+$PIECE(FBZ,U,2)),1,14),!,$EXTRACT($PIECE($$PTR^FBUCUTL("^FB(162.92,",+$PIECE(FBZ,U,24)),U),1,16)
+3 WRITE ?19,"TREATMENT FROM: ",$$DATX^FBAAUTL(+$PIECE(FBZ,U,5)),?44,"TREATMENT TO: ",$$DATX^FBAAUTL(+$PIECE(FBZ,U,6))
+4 WRITE !
QUIT
PARSE(FBARY) ;set piece positions variable, and get # of pieces for printing
+1 ;INPUT: FBARY = (not subscripted) - piece positions
+2 ;OUTPUT: FBW = piece positions
+3 ; FBPL = # of pieces
+4 SET FBARY=$GET(FBARY)
SET FBW=$PIECE(FBARY,";",2)
SET FBPL=($LENGTH(FBW,"^"))-1
+5 QUIT
LINE(FBARY,FBI,FBPL,FBW) ;write line
+1 ;INPUT: FBPL = # of pieces
+2 ; FBW = piece positions
+3 ; FBARY = specific array entry
+4 ;OUTPUT: write line of info
+5 NEW FBP,FBY
SET FBY=$PIECE(FBARY,";",2)
if $LENGTH(FBARY,"^")>5
WRITE !
WRITE !,$SELECT($LENGTH(FBI)<2:" ",1:""),FBI
FOR FBP=1:1:FBPL
if $PIECE(FBY,U,FBP)']""
QUIT
Begin DoDot:1
+6 IF $PIECE(FBY,U,FBP)="!"
WRITE !
IF FBP>1
SET FBW=$PIECE(FBW,U,1,FBP-1)_U_"!"_U_$PIECE(FBW,U,FBP,FBPL)
+7 IF $PIECE(FBY,U,FBP)'="!"
WRITE ?($PIECE(FBW,U,FBP)),$PIECE(FBY,U,FBP)
End DoDot:1
+8 QUIT
FBO() ;set fbo string if 0 or not defined
+1 NEW FBI,Z
SET FBI=0
FOR
SET FBI=$ORDER(^FB(162.92,FBI))
if 'FBI
QUIT
SET Z=$GET(^FB(162.92,FBI,0))
IF $PIECE(Z,U,2)
IF $PIECE(Z,U,4)
SET FBO=$SELECT(+$GET(FBO):FBO_$PIECE(Z,U,4)_U,1:$PIECE(Z,U,4)_U)
+2 QUIT $GET(FBO)
+3 ;
PAD(L,V,C,O) ;set fixed length field
+1 ;INPUT: L=length of field/V=variable/C=character to append/O=order
+2 ; 1 for beginning,2 for ending
+3 ;OUTPUT: fixed length field
+4 NEW X
SET $PIECE(X,C,L)=""
IF O=2
SET V=V_($EXTRACT(X,1,(L-$LENGTH(V))))
+5 IF O=1
SET V=($EXTRACT(X,1,(L-$LENGTH(V))))_V
+6 QUIT $GET(V)
