- 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 Jan 18, 2025@02:57:58 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 ;