FBAAUTL ;AISC/GRR,SBW-Fee Basis Utility Routine ; 4/23/10 3:06pm
;;3.5;FEE BASIS;**101,114,108,124,127,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
DATE N FBDT S FBPOP=0 K BEGDATE,ENDDATE K:$G(%DT)'["A" %DT W !!,"**** Date Range Selection ****"
S FBDT=$S($D(%DT):1,1:0) W ! S %DT=$S(FBDT:%DT,1:"APEX"),%DT("A")=" Beginning DATE : " D ^%DT S:Y<0 FBPOP=1 Q:Y<0 S (%DT(0),BEGDATE)=Y
W ! S %DT=$S(FBDT:%DT,1:"AEX"),%DT("A")=" Ending DATE : " D ^%DT K %DT S:Y<0 FBPOP=1 Q:Y<0 W ! S ENDDATE=Y
Q
;
ZIS S ZTRTN=PGM,ZTSAVE="",FBPOP=0 F I=1:1 Q:$P(VAR,"^",I)']"" S ZTSAVE($P(VAR,"^",I))=""
I '$D(ZTDESC) S ZTDESC=$S($D(PGM):PGM,1:"UNKNOWN OPTION")
W ! S %ZIS="QMP" D ^%ZIS S:POP FBPOP=1 Q:POP I $D(IO("Q")) K IO("Q"),ZTIO D ^%ZTLOAD W:$D(ZTSK) !,*7,"REQUEST QUEUED",!,"Task #: ",$G(ZTSK) K I,ZTSK,ZTIO,ZTSAVE,ZTRTN D HOME^%ZIS S FBPOP=1 Q
Q
;
CLOSE I '$D(ZTQUEUED) D ^%ZISC
K IOP,ZTDESC,ZTRTN,ZTSAVE,ZTDTH,VAR,VAL,PGM,FBPOP,POP Q
;
D S Y=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(Y,4,5))_" "_$S(Y#100:$J(Y#100\1,2)_",",1:"")_(Y\10000+1700)_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"") Q
SITEP ;SET FBSITE(0),FBSITE(1) VARIABLE TO FEE SITE PARAMETERS
S FBPOP=0,FBSITE(0)=$G(^FBAA(161.4,1,0)) S:FBSITE(0)']"" FBPOP=1
S FBSITE(1)=$G(^FBAA(161.4,1,1)) S:FBSITE(1)']"" FBPOP=1
S FBSITE("FBNUM")=$G(^FBAA(161.4,1,"FBNUM")) S:FBSITE("FBNUM")']"" FBPOP=1
W:FBPOP !,*7,"Fee Basis Site Parameters must be entered to proceed",!
Q
TM S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M" Q
PDF S:Y Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) Q
GETNXB ;GET NEXT AVAILABLE BATCH NUMBER
L +^FBAA(161.4):$G(DILOCKTM,3) I '$T D G GETNXB
.W !,"Another user is opening a batch. Trying again.",!
I '$D(^FBAA(161.4,1,"FBNUM")) S ^FBAA(161.4,1,"FBNUM")="1^1"
I '$P($G(^FBAA(161.4,1,"FBNUM")),"^") S $P(^("FBNUM"),"^")=1
S FBBN=$P(^FBAA(161.4,1,"FBNUM"),"^")
N FBBATLT ;Batches Left *127
S FBBATLT=$P($G(^FBAA(161.7,0)),U,4)
I FBBATLT>9999499 D WARNBT ;*114,127,FB*3.5*158
S $P(^FBAA(161.4,1,"FBNUM"),"^",1)=$S(FBBN+1>9999999:1,1:FBBN+1) I '$$CHKBI^FBAAUTL4(FBBN,1) L -^FBAA(161.4) G GETNXB
L -^FBAA(161.4) Q
WARNBT W !,*7,"There are ",9999999-FBBATLT," batches left before the BATCH PURGE routine",!,"needs to be run. Contact your IRM Service!",!!
Q
GETNXI ;GET NEXT AVAILABLE INVOICE NUMBER
L +^FBAA(161.4):$G(DILOCKTM,3) I '$T D G GETNXI
.W !,"Another user is obtaining an invoice number. Trying again.",!
I '$D(^FBAA(161.4,1,"FBNUM")) S ^FBAA(161.4,1,"FBNUM")="1^1"
I '$P($G(^FBAA(161.4,1,"FBNUM")),U,2) S $P(^("FBNUM"),U,2)=1
S FBAAIN=$P(^FBAA(161.4,1,"FBNUM"),"^",2),$P(^("FBNUM"),"^",2)=$S(FBAAIN+1>9999999:1,1:FBAAIN+1) I '$$CHKBI^FBAAUTL4(FBAAIN) L -^FBAA(161.4) G GETNXI
L -^FBAA(161.4) Q
PDATE S FBPDT=$P("January^February^March^April^May^June^July^August^September^October^November^December","^",$E(Y,4,5))_" "_$S(Y#100:$J(Y#100\1,2)_", ",1:"")_(Y\10000+1700)_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"") Q
DATCK S HOLDY=Y,HOLDY=$S($P(HOLDY,"^",2):$P(HOLDY,"^",2),1:HOLDY)
I $D(FBAAID),Y>FBAAID D K X Q
.N SHODAT S SHODAT=$E(FBAAID,4,5)_"/"_$E(FBAAID,6,7)_"/"_$E(FBAAID,2,3)
.W !!,*7,?5,"*** Date of Service cannot be later than",!?8," Invoice Received Date ("_SHODAT_") !!!",!
I $D(FBAABDT),$D(FBAAEDT),(Y<FBAABDT!(Y>FBAAEDT)) D K X
.N PRIORLAT,AUTHDAT,SHODAT
.S PRIORLAT=$S($P(Y,"^",2)<FBAABDT:"prior to ",1:"later than ")
.S AUTHDAT=$S($P(Y,"^",2)<FBAABDT:FBAABDT,1:FBAAEDT)
.S SHODAT=$E(AUTHDAT,4,5)_"/"_$E(AUTHDAT,6,7)_"/"_$E(AUTHDAT,2,3)
.W !!,*7,?5,"*** Date of Service cannot be ",PRIORLAT
.W !?8," Authorization period ("_SHODAT_") !!!",!
S Y=HOLDY Q
;
DATX(X) ;external output function for date format
;INPUT = FM internal date format (time optional)
;OUTPUT = date/time with slashes
Q $$FMTE^XLFDT(X,2)
;
STATION ;GET STATION NUMBER FROM INSTITUTION FILE
I '$D(FBSITE(1)) D SITEP
I $S('$D(FBSITE(1)):1,$P(FBSITE(1),"^",3)="":1,'$D(^DIC(4,$P(FBSITE(1),"^",3),0)):1,'$D(^DIC(4,$P(FBSITE(1),"^",3),99)):1,'+$P(^DIC(4,$P(FBSITE(1),"^",3),99),"^"):1,1:0) G NOSTA
S (FBSN,FBAASN)=$S($D(^DIC(4,$P(FBSITE(1),"^",3),99)):$E(^(99),1,3),1:999)
Q
NOSTA S FB("ERROR")=1 I '$D(ZTQUEUED) W !!,*7,"Unable to determine Station Number. Check Fee Site Parameters or Station Number in the Institution File.",!!
Q
;
HD ;set transmission header
I '$D(FBSITE(1)) S FBSITE(1)=$G(^FBAA(161.4,1,1))
S FBHD=$$HDR^FBAAUTL3() I FBHD']"" S FB("ERROR")=1 W !,"Transmission header must exist in FEE BASIS SITE PARAMETER file",!,"before you can proceed.",*7,!
Q
;
SSN(PID,BID,DOD) ;
;PID = DFN of Patient. If this is all that is past,
;full Pt.ID (000-00-0000) will be returned.
;If BID = 1 the call will return last 4 of Pt.ID only.
;If DOD is defined to internal entry # of eligibility the appropriate
;Pt.ID will be returned.
N DFN,FBSSN
S DFN=PID
I 'DFN Q "Unknown"
S:'$D(BID) BID="" S:$D(DOD) VAPTYP=DOD
D PID^VADPT6 I VAERR K VAERR Q "Unknown"
S FBSSN=$S(BID:VA("BID"),1:VA("PID"))
K VA("BID"),VA("PID"),VAERR,VAPTYP
Q FBSSN
;
SSNL4(SSN) ;Convert 1st 5 digits of SSN to X (Only print last 4 digits of SSN)
;Input:
; SSN - SSN in 9 digit or ###-##-#### format
; Pseudo SSN is also allowed as input
;Output
; SSN - SSN in XXXXX#### or XXX-XX-#### format
; Pseudo SSN will be changed as above with passed "P" at end
; X represent actual X and # represent digit
;
S SSN=$G(SSN)
;Change SSN ######### to XXXXX####
S:SSN?9N0.1"P" $E(SSN,1,5)="XXXXX"
;Change SSN ###-##-#### to XXX-XX-####
S:SSN?3N1"-"2N1"-"4N0.1"P" $E(SSN,1,7)="XXX-XX-"
Q SSN
;
PYMTH(CODE) ; Payment Methodology Processing (FB*3.5*158)
; input --> CODE: Fee Schedule/Payment Methodology code
; output --> Payment methodology name or '@' to delete existing value
;
;S CODE="F" ;debug
Q:CODE']"" "@"
N IEN
S IEN=$O(^FBAA(163.98,"C",CODE,""))
Q $S(IEN:$P(^FBAA(163.98,IEN,0),U),1:"@")
;
CRARC(FBADJ,FBRRMK,FBCRARC) ; compile CARCs and RARCs into an array for batch processing
;
N I,J,K,FBADJGI,FBADJGE,FBADJRI,FBADJRE,FBADJA,FBADJAE,FBRRMKI,FBRRMKE,CNT
S (I,CNT)=0
F S I=$O(FBADJ(I)) Q:'I D
. S CNT=I
. S X=$P(FBADJ(I),U,2)_U_$P(FBADJ(I),U)_U_$P(FBADJ(I),U,3)
. S FBADJGI=$P(FBADJ(I),U,2)
. S FBADJGE=$S(FBADJGI:$P($G(^FB(161.92,FBADJGI,0)),U),1:"")
. S FBADJRI=$P(FBADJ(I),U)
. S FBADJRE=$S(FBADJRI:$P($G(^FB(161.91,FBADJRI,0)),U),1:"")
. S FBADJA=$P(FBADJ(I),U,3)
. S FBADJAE=$FN(FBADJA,"",2)
. S FBCRARC(I)=FBADJGE_U_FBADJRE_U_FBADJAE_U
. ; RARCs
. S J=0
. F S J=$O(FBRRMK(FBADJRI,J)) Q:'J D
. . S FBRRMKI=FBRRMK(FBADJRI,J)
. . S FBRRMKE=$S(FBRRMKI:$P($G(^FB(161.93,FBRRMKI,0)),U),1:"")
. . S FBCRARC(I)=FBCRARC(I)_FBRRMKE_U
; CARCless RARCs
S FBADJRI=999,J=0,(FBADJGE,FBADJRE,FBADJAE)="",DONE=0,I=CNT
F D Q:DONE
. S I=I+1
. F K=1:1:2 D I 'J S DONE=1 Q
. . S J=$O(FBRRMK(FBADJRI,J)) Q:'J D
. . S:K=1 FBCRARC(I)=FBADJGE_U_FBADJRE_U_FBADJAE_U
. . S FBRRMKI=FBRRMK(FBADJRI,J)
. . S FBRRMKE=$S(FBRRMKI:$P($G(^FB(161.93,FBRRMKI,0)),U),1:"")
. . S FBCRARC(I)=FBCRARC(I)_FBRRMKE_U
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAUTL 7252 printed Dec 13, 2024@01:56:45 Page 2
FBAAUTL ;AISC/GRR,SBW-Fee Basis Utility Routine ; 4/23/10 3:06pm
+1 ;;3.5;FEE BASIS;**101,114,108,124,127,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
DATE NEW FBDT
SET FBPOP=0
KILL BEGDATE,ENDDATE
if $GET(%DT)'["A"
KILL %DT
WRITE !!,"**** Date Range Selection ****"
+1 SET FBDT=$SELECT($DATA(%DT):1,1:0)
WRITE !
SET %DT=$SELECT(FBDT:%DT,1:"APEX")
SET %DT("A")=" Beginning DATE : "
DO ^%DT
if Y<0
SET FBPOP=1
if Y<0
QUIT
SET (%DT(0),BEGDATE)=Y
+2 WRITE !
SET %DT=$SELECT(FBDT:%DT,1:"AEX")
SET %DT("A")=" Ending DATE : "
DO ^%DT
KILL %DT
if Y<0
SET FBPOP=1
if Y<0
QUIT
WRITE !
SET ENDDATE=Y
+3 QUIT
+4 ;
ZIS SET ZTRTN=PGM
SET ZTSAVE=""
SET FBPOP=0
FOR I=1:1
if $PIECE(VAR,"^",I)']""
QUIT
SET ZTSAVE($PIECE(VAR,"^",I))=""
+1 IF '$DATA(ZTDESC)
SET ZTDESC=$SELECT($DATA(PGM):PGM,1:"UNKNOWN OPTION")
+2 WRITE !
SET %ZIS="QMP"
DO ^%ZIS
if POP
SET FBPOP=1
if POP
QUIT
IF $DATA(IO("Q"))
KILL IO("Q"),ZTIO
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,*7,"REQUEST QUEUED",!,"Task #: ",$GET(ZTSK)
KILL I,ZTSK,ZTIO,ZTSAVE,ZTRTN
DO HOME^%ZIS
SET FBPOP=1
QUIT
+3 QUIT
+4 ;
CLOSE IF '$DATA(ZTQUEUED)
DO ^%ZISC
+1 KILL IOP,ZTDESC,ZTRTN,ZTSAVE,ZTDTH,VAR,VAL,PGM,FBPOP,POP
QUIT
+2 ;
D SET Y=$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$EXTRACT(Y,4,5))_" "_$SELECT(Y#100:$JUSTIFY(Y#100\1,2)_",",1:"")_(Y\10000+1700)_$SELECT(Y#1:" "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12),1:"")
QUIT
SITEP ;SET FBSITE(0),FBSITE(1) VARIABLE TO FEE SITE PARAMETERS
+1 SET FBPOP=0
SET FBSITE(0)=$GET(^FBAA(161.4,1,0))
if FBSITE(0)']""
SET FBPOP=1
+2 SET FBSITE(1)=$GET(^FBAA(161.4,1,1))
if FBSITE(1)']""
SET FBPOP=1
+3 SET FBSITE("FBNUM")=$GET(^FBAA(161.4,1,"FBNUM"))
if FBSITE("FBNUM")']""
SET FBPOP=1
+4 if FBPOP
WRITE !,*7,"Fee Basis Site Parameters must be entered to proceed",!
+5 QUIT
TM SET X=$EXTRACT($PIECE(X,".",2)_"0000",1,4)
SET %=X>1159
if X>1259
SET X=X-1200
SET X=X\100_":"_$EXTRACT(X#100+100,2,3)_" "_$EXTRACT("AP",%+1)_"M"
QUIT
PDF if Y
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
QUIT
GETNXB ;GET NEXT AVAILABLE BATCH NUMBER
+1 LOCK +^FBAA(161.4):$GET(DILOCKTM,3)
IF '$TEST
Begin DoDot:1
+2 WRITE !,"Another user is opening a batch. Trying again.",!
End DoDot:1
GOTO GETNXB
+3 IF '$DATA(^FBAA(161.4,1,"FBNUM"))
SET ^FBAA(161.4,1,"FBNUM")="1^1"
+4 IF '$PIECE($GET(^FBAA(161.4,1,"FBNUM")),"^")
SET $PIECE(^("FBNUM"),"^")=1
+5 SET FBBN=$PIECE(^FBAA(161.4,1,"FBNUM"),"^")
+6 ;Batches Left *127
NEW FBBATLT
+7 SET FBBATLT=$PIECE($GET(^FBAA(161.7,0)),U,4)
+8 ;*114,127,FB*3.5*158
IF FBBATLT>9999499
DO WARNBT
+9 SET $PIECE(^FBAA(161.4,1,"FBNUM"),"^",1)=$SELECT(FBBN+1>9999999:1,1:FBBN+1)
IF '$$CHKBI^FBAAUTL4(FBBN,1)
LOCK -^FBAA(161.4)
GOTO GETNXB
+10 LOCK -^FBAA(161.4)
QUIT
WARNBT WRITE !,*7,"There are ",9999999-FBBATLT," batches left before the BATCH PURGE routine",!,"needs to be run. Contact your IRM Service!",!!
+1 QUIT
GETNXI ;GET NEXT AVAILABLE INVOICE NUMBER
+1 LOCK +^FBAA(161.4):$GET(DILOCKTM,3)
IF '$TEST
Begin DoDot:1
+2 WRITE !,"Another user is obtaining an invoice number. Trying again.",!
End DoDot:1
GOTO GETNXI
+3 IF '$DATA(^FBAA(161.4,1,"FBNUM"))
SET ^FBAA(161.4,1,"FBNUM")="1^1"
+4 IF '$PIECE($GET(^FBAA(161.4,1,"FBNUM")),U,2)
SET $PIECE(^("FBNUM"),U,2)=1
+5 SET FBAAIN=$PIECE(^FBAA(161.4,1,"FBNUM"),"^",2)
SET $PIECE(^("FBNUM"),"^",2)=$SELECT(FBAAIN+1>9999999:1,1:FBAAIN+1)
IF '$$CHKBI^FBAAUTL4(FBAAIN)
LOCK -^FBAA(161.4)
GOTO GETNXI
+6 LOCK -^FBAA(161.4)
QUIT
PDATE SET FBPDT=$PIECE("January^February^March^April^May^June^July^August^September^October^November^December","^",$EXTRACT(Y,4,5))_" "_$SELECT(Y#100:$JUSTIFY(Y#100\1,2)_", ",1:"")_(Y\10000+1700)_$SELECT(Y#1:" "_$EXTRACT(Y_0,9,10)_":"_...
... $EXTRACT(Y_"000",11,12),1:"")
QUIT
DATCK SET HOLDY=Y
SET HOLDY=$SELECT($PIECE(HOLDY,"^",2):$PIECE(HOLDY,"^",2),1:HOLDY)
+1 IF $DATA(FBAAID)
IF Y>FBAAID
Begin DoDot:1
+2 NEW SHODAT
SET SHODAT=$EXTRACT(FBAAID,4,5)_"/"_$EXTRACT(FBAAID,6,7)_"/"_$EXTRACT(FBAAID,2,3)
+3 WRITE !!,*7,?5,"*** Date of Service cannot be later than",!?8," Invoice Received Date ("_SHODAT_") !!!",!
End DoDot:1
KILL X
QUIT
+4 IF $DATA(FBAABDT)
IF $DATA(FBAAEDT)
IF (Y<FBAABDT!(Y>FBAAEDT))
Begin DoDot:1
+5 NEW PRIORLAT,AUTHDAT,SHODAT
+6 SET PRIORLAT=$SELECT($PIECE(Y,"^",2)<FBAABDT:"prior to ",1:"later than ")
+7 SET AUTHDAT=$SELECT($PIECE(Y,"^",2)<FBAABDT:FBAABDT,1:FBAAEDT)
+8 SET SHODAT=$EXTRACT(AUTHDAT,4,5)_"/"_$EXTRACT(AUTHDAT,6,7)_"/"_$EXTRACT(AUTHDAT,2,3)
+9 WRITE !!,*7,?5,"*** Date of Service cannot be ",PRIORLAT
+10 WRITE !?8," Authorization period ("_SHODAT_") !!!",!
End DoDot:1
KILL X
+11 SET Y=HOLDY
QUIT
+12 ;
DATX(X) ;external output function for date format
+1 ;INPUT = FM internal date format (time optional)
+2 ;OUTPUT = date/time with slashes
+3 QUIT $$FMTE^XLFDT(X,2)
+4 ;
STATION ;GET STATION NUMBER FROM INSTITUTION FILE
+1 IF '$DATA(FBSITE(1))
DO SITEP
+2 IF $SELECT('$DATA(FBSITE(1)):1,$PIECE(FBSITE(1),"^",3)="":1,'$DATA(^DIC(4,$PIECE(FBSITE(1),"^",3),0)):1,'$DATA(^DIC(4,$PIECE(FBSITE(1),"^",3),99)):1,'+$PIECE(^DIC(4,$PIECE(FBSITE(1),"^",3),99),"^"):1,1:0)
GOTO NOSTA
+3 SET (FBSN,FBAASN)=$SELECT($DATA(^DIC(4,$PIECE(FBSITE(1),"^",3),99)):$EXTRACT(^(99),1,3),1:999)
+4 QUIT
NOSTA SET FB("ERROR")=1
IF '$DATA(ZTQUEUED)
WRITE !!,*7,"Unable to determine Station Number. Check Fee Site Parameters or Station Number in the Institution File.",!!
+1 QUIT
+2 ;
HD ;set transmission header
+1 IF '$DATA(FBSITE(1))
SET FBSITE(1)=$GET(^FBAA(161.4,1,1))
+2 SET FBHD=$$HDR^FBAAUTL3()
IF FBHD']""
SET FB("ERROR")=1
WRITE !,"Transmission header must exist in FEE BASIS SITE PARAMETER file",!,"before you can proceed.",*7,!
+3 QUIT
+4 ;
SSN(PID,BID,DOD) ;
+1 ;PID = DFN of Patient. If this is all that is past,
+2 ;full Pt.ID (000-00-0000) will be returned.
+3 ;If BID = 1 the call will return last 4 of Pt.ID only.
+4 ;If DOD is defined to internal entry # of eligibility the appropriate
+5 ;Pt.ID will be returned.
+6 NEW DFN,FBSSN
+7 SET DFN=PID
+8 IF 'DFN
QUIT "Unknown"
+9 if '$DATA(BID)
SET BID=""
if $DATA(DOD)
SET VAPTYP=DOD
+10 DO PID^VADPT6
IF VAERR
KILL VAERR
QUIT "Unknown"
+11 SET FBSSN=$SELECT(BID:VA("BID"),1:VA("PID"))
+12 KILL VA("BID"),VA("PID"),VAERR,VAPTYP
+13 QUIT FBSSN
+14 ;
SSNL4(SSN) ;Convert 1st 5 digits of SSN to X (Only print last 4 digits of SSN)
+1 ;Input:
+2 ; SSN - SSN in 9 digit or ###-##-#### format
+3 ; Pseudo SSN is also allowed as input
+4 ;Output
+5 ; SSN - SSN in XXXXX#### or XXX-XX-#### format
+6 ; Pseudo SSN will be changed as above with passed "P" at end
+7 ; X represent actual X and # represent digit
+8 ;
+9 SET SSN=$GET(SSN)
+10 ;Change SSN ######### to XXXXX####
+11 if SSN?9N0.1"P"
SET $EXTRACT(SSN,1,5)="XXXXX"
+12 ;Change SSN ###-##-#### to XXX-XX-####
+13 if SSN?3N1"-"2N1"-"4N0.1"P"
SET $EXTRACT(SSN,1,7)="XXX-XX-"
+14 QUIT SSN
+15 ;
PYMTH(CODE) ; Payment Methodology Processing (FB*3.5*158)
+1 ; input --> CODE: Fee Schedule/Payment Methodology code
+2 ; output --> Payment methodology name or '@' to delete existing value
+3 ;
+4 ;S CODE="F" ;debug
+5 if CODE']""
QUIT "@"
+6 NEW IEN
+7 SET IEN=$ORDER(^FBAA(163.98,"C",CODE,""))
+8 QUIT $SELECT(IEN:$PIECE(^FBAA(163.98,IEN,0),U),1:"@")
+9 ;
CRARC(FBADJ,FBRRMK,FBCRARC) ; compile CARCs and RARCs into an array for batch processing
+1 ;
+2 NEW I,J,K,FBADJGI,FBADJGE,FBADJRI,FBADJRE,FBADJA,FBADJAE,FBRRMKI,FBRRMKE,CNT
+3 SET (I,CNT)=0
+4 FOR
SET I=$ORDER(FBADJ(I))
if 'I
QUIT
Begin DoDot:1
+5 SET CNT=I
+6 SET X=$PIECE(FBADJ(I),U,2)_U_$PIECE(FBADJ(I),U)_U_$PIECE(FBADJ(I),U,3)
+7 SET FBADJGI=$PIECE(FBADJ(I),U,2)
+8 SET FBADJGE=$SELECT(FBADJGI:$PIECE($GET(^FB(161.92,FBADJGI,0)),U),1:"")
+9 SET FBADJRI=$PIECE(FBADJ(I),U)
+10 SET FBADJRE=$SELECT(FBADJRI:$PIECE($GET(^FB(161.91,FBADJRI,0)),U),1:"")
+11 SET FBADJA=$PIECE(FBADJ(I),U,3)
+12 SET FBADJAE=$FNUMBER(FBADJA,"",2)
+13 SET FBCRARC(I)=FBADJGE_U_FBADJRE_U_FBADJAE_U
+14 ; RARCs
+15 SET J=0
+16 FOR
SET J=$ORDER(FBRRMK(FBADJRI,J))
if 'J
QUIT
Begin DoDot:2
+17 SET FBRRMKI=FBRRMK(FBADJRI,J)
+18 SET FBRRMKE=$SELECT(FBRRMKI:$PIECE($GET(^FB(161.93,FBRRMKI,0)),U),1:"")
+19 SET FBCRARC(I)=FBCRARC(I)_FBRRMKE_U
End DoDot:2
End DoDot:1
+20 ; CARCless RARCs
+21 SET FBADJRI=999
SET J=0
SET (FBADJGE,FBADJRE,FBADJAE)=""
SET DONE=0
SET I=CNT
+22 FOR
Begin DoDot:1
+23 SET I=I+1
+24 FOR K=1:1:2
Begin DoDot:2
+25 SET J=$ORDER(FBRRMK(FBADJRI,J))
if 'J
QUIT
Begin DoDot:3
End DoDot:3
+26 if K=1
SET FBCRARC(I)=FBADJGE_U_FBADJRE_U_FBADJAE_U
+27 SET FBRRMKI=FBRRMK(FBADJRI,J)
+28 SET FBRRMKE=$SELECT(FBRRMKI:$PIECE($GET(^FB(161.93,FBRRMKI,0)),U),1:"")
+29 SET FBCRARC(I)=FBCRARC(I)_FBRRMKE_U
End DoDot:2
IF 'J
SET DONE=1
QUIT
End DoDot:1
if DONE
QUIT
+30 QUIT
+31 ;
