- FBAASLP ;AISC/GRR-PRINT SUSPENSION LETTERS ;7/NOV/2006
- ;;3.5;FEE BASIS;**12,4,23,69,101**;JAN 30, 1995;Build 2
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- D DATE^FBAAUTL G END:FBPOP K FBAAS S (FBAAOUT,FBSLW,FBPRG,FBCTR,FBY)=0,UL="",$P(UL,"=",80)="="
- D ^FBAASL G END:FBAAOUT
- RDCODE S DIR(0)="Y",DIR("A")="For All Suspension codes",DIR("B")="YES",DIR("?")="'Yes' to print suspension letters for all suspension codes, 'No' to select specific codes." D ^DIR K DIR W ! G END:$D(DUOUT),END:$D(DTOUT),SEL:'Y
- ;ask edi/non-edi/all claims
- AHEAD S DIR(0)="SA^1:EDI;2:NON-EDI;3:ALL",DIR("A")="Only print letters for claims that were submitted via (EDI/NON-EDI/ALL):",DIR("B")="ALL"
- S DIR("?",1)=" Enter EDI to just print suspension letters for EDI claims from the FPPS system."
- S DIR("?",2)=" Enter NON-EDI to just print suspension letters for claims that are not EDI."
- S DIR("?",3)=" Enter ALL to print suspension letters for both EDI and NON-EDI claims."
- S DIR("?")=" "
- D ^DIR K DIR G END:$D(DIRUT)
- S FBENA=Y
- S VAR="BEGDATE^ENDDATE^FBSLW",VAL=BEGDATE_"^"_ENDDATE_"^"_FBSLW
- I $G(DFN) S VAR="DFN^"_VAR,VAL=DFN_"^"_VAL
- I $G(IFN) S VAR="IFN^"_VAR,VAL=IFN_"^"_VAL
- I $G(FBDEN) S VAR="FBDEN^"_VAR,VAL=FBDEN_"^"_VAL
- I $G(FBENA) S VAR="FBENA^"_VAR,VAL=FBENA_"^"_VAL
- S K=0 F J=1:1:FBCTR S K=$O(FBPRG(K)) S VAR=VAR_"^FBPRG("""_K_""")",VAL=VAL_"^"_+FBPRG(K)
- I $D(FBAAS) F J=0:0 S J=$O(FBAAS(J)) Q:J'>0 S VAR=VAR_"^FBAAS("_J_")",VAL=VAL_"^"
- S PGM="START^FBAASLP",IOP="Q" D ZIS^FBAAUTL G:FBPOP END
- START K ^UTILITY($J),^TMP($J) U IO S UL="",$P(UL,"=",80)="=",FBPG=1
- I $G(FBPRG("O")) S FBLET=+FBPRG("O") F K=0:0 S K=$O(^FBAAC("AI",K)) Q:K'>0 I $S($G(IFN):IFN=K,1:1) D STRT
- I $G(FBPRG("P")),$D(^FBAA(162.1,"AG")) S FBLET=+FBPRG("P") D ^FBAASL1 K ^TMP($J)
- I $G(FBPRG("C")),$D(^FBAA(162.2,"AI")) S FBLET=+FBPRG("C") D ^FBCHSLP
- I $G(FBPRG("I")),$D(^FBAAI("AI")) S FBLET=+FBPRG("I") D ^FBCHSL1
- I '$G(FBGOT) W !,"There are no suspension letters found that meet the criteria you have",!,"specified."
- END K FBAAS,UL,X,J,K,L,M,VNAM,VST1,VST2,VCITY,VSTATE,FBDT,FBA,VZIP,PNAME,A1,A2,CPT,FBDOS,FBRR,FBXX,DIC,DIWL,DIWF,BEGDATE,ENDDATE,FBAA,FBDRUG,FBFORM,FBI,FBLET,FBPDT,FBRX,FBSLW,FBSW,I,PGM,VAL,VAR,Z,ZZ,FBAAPGM,Y,PSSN,DIRUT
- K FBAAOUT,FBCTR,FBPRG,FBY,FBMOD,FBMODLE,DFN,IFN,FBDEN,FBGOT,FBENA
- K ^UTILITY($J),^TMP($J)
- D CLOSE^FBAAUTL Q
- MORE F J=0:0 S J=$O(^FBAAC("AI",K,FBDT,J)) Q:J'>0 I $S($G(DFN):DFN=J,1:1) D:$D(^DPT(J,0)) GOTP I $D(^FBAAV(K,0)) D MID
- Q
- GOTV S Y(0)=^FBAAV(K,0),VNAM=$P(Y(0),"^",1),FBSW=0
- I VNAM["," S VNAM=$P(VNAM,",",2)_" "_$P(VNAM,",",1)
- S VST1=$P(Y(0),"^",3),VST2=$P(Y(0),"^",14),VCITY=$P(Y(0),"^",4),VSTATE=$S($D(^DIC(5,+$P(Y(0),"^",5),0)):$P(^(0),"^",2),1:" "),VZIP=$P(Y(0),"^",6) S Y=DT D PDATE^FBAAUTL
- W:'$G(FBPG) @IOF K:$G(FBPG) FBPG W:(IOSL)>70 !!!! W !!!!!!!!!!!,?5,VNAM,?60,FBPDT,!,?5,VST1,! I VST2]"" W ?5,VST2,!
- W ?5,VCITY," ",VSTATE," ",VZIP,!!!!
- WPBEG S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W")
- I $D(^FBAA(161.3,FBLET,1,1)) F FBRR=0:0 S FBRR=$O(^FBAA(161.3,FBLET,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
- D ^DIWW:$D(FBXX) K FBXX
- Q
- MID S FBA=0 F FBAA=0:0 S FBA=$O(^FBAAC("AI",K,FBDT,J,FBA)) Q:FBA="" I $S(FBSLW=0:1,FBSLW=1&($D(FBAAS(FBA))):1,1:0) D MORE2
- Q
- MORE2 F L=0:0 S L=$O(^FBAAC("AI",K,FBDT,J,FBA,L)) Q:L'>0 F M=0:0 S M=$O(^FBAAC("AI",K,FBDT,J,FBA,L,M)) Q:M'>0 I $D(^FBAAC(J,1,K,1,L,1,M,0)) S Z(0)=^(0) D:$P(Z(0),"^",20)'="R" BOT
- Q
- WPBOT D ACT:$D(FBACRR) K FBACRR
- S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W") W !!
- I $D(^FBAA(161.3,FBLET,2)) F FBRR=0:0 S FBRR=$O(^FBAA(161.3,FBLET,2,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
- D ^DIWW:$D(FBXX) K FBXX
- Q
- BOT Q:$S($G(FBDEN):$P(Z(0),U,3)>0,1:0)
- N FBY3,FBFPPSC
- S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3))
- S FBFPPSC=$P(FBY3,U)
- Q:$S(FBENA=2&(FBFPPSC]""):1,FBENA=1&(FBFPPSC=""):1,1:0)
- N FBY,FBX,T,TAMT,FBAC,FBJ,FBCSID,FBUNITS,FBADJLR,FBADJLA,FBRRMKL,FBFPPSL
- I FBSW=1 D GOTV,HED S FBSW=0,FBGOT=1
- S FBDOS=$S($D(^FBAAC(J,1,K,1,L,0)):$P(^(0),"^",1),1:"")
- S CPT=$P(Z(0),"^",1),A1=$P(Z(0),"^",2)+.0001,A2=$P(Z(0),"^",3)+.0001,A1=$P(A1,".",1)_"."_$E($P(A1,".",2),1,2),A2=$P(A2,".",1)_"."_$E($P(A2,".",2),1,2)
- I CPT]"" S CPT=$$CPT^FBAAUTL4(CPT)
- S T=$P(Z(0),U,5)
- I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U)
- S TAMT=$FN($P(Z(0),U,4),"",2)
- S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")
- S FBY=$G(^FBAAC(J,1,K,1,L,1,M,2))
- S FBFPPSL=$P(FBY3,U,2)
- S FBCSID=$P(FBY,U,16)
- S FBUNITS=$P(FBY,U,14)
- S FBADJLR=$P(FBX,U)
- F FBJ=1:1 S FBAC=$P(FBADJLR,",",FBJ) Q:FBAC="" S FBACRR(FBAC)=""
- S FBADJLA=$P(FBX,U,2)
- S FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",")
- S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")
- I $Y+4>IOSL W @IOF D HED
- W !!,$E(PNAME,1,26),?33,PSSN,?49,FBCSID
- W !,$$DATX^FBAAUTL(FBDOS),?10,CPT_$S($G(FBMODLE)]"":"-"_$P(FBMODLE,","),1:""),?33,FBUNITS
- I $P($G(FBMODLE),",",2)]"" D
- . N FBI
- . F FBI=2:1 S FBMOD=$P(FBMODLE,",",FBI) Q:FBMOD="" D
- . . I $Y+4>IOSL W @IOF D HED W !," (continued)"
- . . W !,?15,"-",FBMOD
- W !,?10,$J(A1,6),?24,$J(A2,6)
- ; write adjustment reasons, if null then write suspend code
- W ?35,$S(FBADJLR]"":FBADJLR,1:T)
- ; write adjustment amounts, if null then write amount suspended
- W ?49,$S(FBADJLA]"":FBADJLA,1:TAMT)
- W ?66,FBRRMKL
- I FBFPPSC]"" W !,?10,"FPPS Claim ID: ",FBFPPSC,?38,"FPPS Line Item: ",FBFPPSL
- W !
- I FBADJLR="" G:FBA=4&($D(^FBAAC(J,1,K,1,L,1,M,1))) WPFT D
- . S DIWL=1,DIWF="WC79",FBI=FBA K ^UTILITY($J,"W")
- . F FBRR=0:0 S FBRR=$O(^FBAA(161.27,FBI,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
- . D ^DIWW:$D(FBXX) K FBXX
- Q
- ACT ; print table of adjustment reason descriptions
- ; Input
- ; FBACRR( - required, array
- ; FBACRR(FBADJRE)=""
- ; where FBADJRE = adjustment reason code, external value
- N FBADJRE,FBI,FBACT
- W !,"*Adjustment Code Text:"
- S FBADJRE="" F S FBADJRE=$O(FBACRR(FBADJRE)) Q:FBADJRE="" D
- . ; get description of code in FBACT
- . I $$AR^FBUTL1(,FBADJRE,FBSCDT,"FBACT")<0 Q ; quit if error
- . ; print code and description
- . K ^UTILITY($J,"W")
- . S DIWL=1,DIWF="WC79"
- . ; include code in output
- . S X=$$LJ^XLFSTR("("_FBADJRE_")",7," ") D ^DIWP
- . S DIWF="WC79I7"
- . ; include description in output
- . S FBI=0 F S FBI=$O(FBACT(FBI)) Q:FBI="" S X=FBACT(FBI) I X]"" D ^DIWP
- . D ^DIWW
- Q
- ;
- HED W !,"PATIENT NAME",?33,"SSN",?49,"PATIENT ACCOUNT NUMBER"
- W !,"SVC DATE",?10,"CPT-MOD",?33,"UNITS"
- W !,?10,"AMT CLAIMED",?24,"AMT PAID",?35,"ADJ CODE",?49,"ADJ AMT",?66,"REMIT REMARKS"
- W !,UL Q
- ;
- GOTP ; Utilize new API for Name Standardization
- ;
- S Y(0)=^DPT(J,0),PNAME=$P(Y(0),"^",1),PSSN=$TR($$SSNL4^FBAAUTL($$SSN^FBAAUTL(J)),"-","")
- I PNAME["," D
- .N FBNAMES
- .S FBNAMES("FILE")=2,FBNAMES("IENS")=J_",",FBNAMES("FIELD")=.01
- .S PNAME=$$NAMEFMT^XLFNAME(.FBNAMES)
- Q
- SEL W !! S DIC="^FBAA(161.27,",DIC(0)="AEQM" D ^DIC G ENDSL:X=""!(X="^"),SEL:Y<0 S DA=+Y,FBAAS(DA)="",FBSLW=1 G SEL
- ENDSL I '$D(FBAAS) W !!,*7,"No suspension codes selected!" G END
- G AHEAD
- PSEL F FBA=0:0 S FBA=$O(FBAAS(FBA)) Q:FBA'>0 I $D(^FBAAC("AI",FBA)) F FBDT=BEGDATE-.001:0 S FBDT=$O(^FBAAC("AI",FBA,FBDT)) Q:FBDT'>0!(FBDT>ENDDATE) D MORE
- G END
- WPFT S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W")
- F FBRR=0:0 S FBRR=$O(^FBAAC(J,1,K,1,L,1,M,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
- D ^DIWW:$D(FBXX) K FBXX
- Q
- STRT N FBACRR,FBSCDT S FBSW=1 S Z=$O(^FBAAC("AI",K,BEGDATE-.001)) S FBDT=BEGDATE-.001 F ZZ=0:0 S FBDT=$O(^FBAAC("AI",K,FBDT)) D WPBOT:FBDT'>0&(FBSW=0)!(FBDT>ENDDATE)&(FBSW=0) Q:FBDT'>0!(FBDT>ENDDATE) S FBSCDT=FBDT D MORE
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAASLP 7591 printed Feb 18, 2025@23:23:07 Page 2
- FBAASLP ;AISC/GRR-PRINT SUSPENSION LETTERS ;7/NOV/2006
- +1 ;;3.5;FEE BASIS;**12,4,23,69,101**;JAN 30, 1995;Build 2
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 DO DATE^FBAAUTL
- if FBPOP
- GOTO END
- KILL FBAAS
- SET (FBAAOUT,FBSLW,FBPRG,FBCTR,FBY)=0
- SET UL=""
- SET $PIECE(UL,"=",80)="="
- +4 DO ^FBAASL
- if FBAAOUT
- GOTO END
- RDCODE SET DIR(0)="Y"
- SET DIR("A")="For All Suspension codes"
- SET DIR("B")="YES"
- SET DIR("?")="'Yes' to print suspension letters for all suspension codes, 'No' to select specific codes."
- DO ^DIR
- KILL DIR
- WRITE !
- if $DATA(DUOUT)
- GOTO END
- if $DATA(DTOUT)
- GOTO END
- if 'Y
- GOTO SEL
- +1 ;ask edi/non-edi/all claims
- AHEAD SET DIR(0)="SA^1:EDI;2:NON-EDI;3:ALL"
- SET DIR("A")="Only print letters for claims that were submitted via (EDI/NON-EDI/ALL):"
- SET DIR("B")="ALL"
- +1 SET DIR("?",1)=" Enter EDI to just print suspension letters for EDI claims from the FPPS system."
- +2 SET DIR("?",2)=" Enter NON-EDI to just print suspension letters for claims that are not EDI."
- +3 SET DIR("?",3)=" Enter ALL to print suspension letters for both EDI and NON-EDI claims."
- +4 SET DIR("?")=" "
- +5 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END
- +6 SET FBENA=Y
- +7 SET VAR="BEGDATE^ENDDATE^FBSLW"
- SET VAL=BEGDATE_"^"_ENDDATE_"^"_FBSLW
- +8 IF $GET(DFN)
- SET VAR="DFN^"_VAR
- SET VAL=DFN_"^"_VAL
- +9 IF $GET(IFN)
- SET VAR="IFN^"_VAR
- SET VAL=IFN_"^"_VAL
- +10 IF $GET(FBDEN)
- SET VAR="FBDEN^"_VAR
- SET VAL=FBDEN_"^"_VAL
- +11 IF $GET(FBENA)
- SET VAR="FBENA^"_VAR
- SET VAL=FBENA_"^"_VAL
- +12 SET K=0
- FOR J=1:1:FBCTR
- SET K=$ORDER(FBPRG(K))
- SET VAR=VAR_"^FBPRG("""_K_""")"
- SET VAL=VAL_"^"_+FBPRG(K)
- +13 IF $DATA(FBAAS)
- FOR J=0:0
- SET J=$ORDER(FBAAS(J))
- if J'>0
- QUIT
- SET VAR=VAR_"^FBAAS("_J_")"
- SET VAL=VAL_"^"
- +14 SET PGM="START^FBAASLP"
- SET IOP="Q"
- DO ZIS^FBAAUTL
- if FBPOP
- GOTO END
- START KILL ^UTILITY($JOB),^TMP($JOB)
- USE IO
- SET UL=""
- SET $PIECE(UL,"=",80)="="
- SET FBPG=1
- +1 IF $GET(FBPRG("O"))
- SET FBLET=+FBPRG("O")
- FOR K=0:0
- SET K=$ORDER(^FBAAC("AI",K))
- if K'>0
- QUIT
- IF $SELECT($GET(IFN):IFN=K,1:1)
- DO STRT
- +2 IF $GET(FBPRG("P"))
- IF $DATA(^FBAA(162.1,"AG"))
- SET FBLET=+FBPRG("P")
- DO ^FBAASL1
- KILL ^TMP($JOB)
- +3 IF $GET(FBPRG("C"))
- IF $DATA(^FBAA(162.2,"AI"))
- SET FBLET=+FBPRG("C")
- DO ^FBCHSLP
- +4 IF $GET(FBPRG("I"))
- IF $DATA(^FBAAI("AI"))
- SET FBLET=+FBPRG("I")
- DO ^FBCHSL1
- +5 IF '$GET(FBGOT)
- WRITE !,"There are no suspension letters found that meet the criteria you have",!,"specified."
- END KILL FBAAS,UL,X,J,K,L,M,VNAM,VST1,VST2,VCITY,VSTATE,FBDT,FBA,VZIP,PNAME,A1,A2,CPT,FBDOS,FBRR,FBXX,DIC,DIWL,DIWF,BEGDATE,ENDDATE,FBAA,FBDRUG,FBFORM,FBI,FBLET,FBPDT,FBRX,FBSLW,FBSW,I,PGM,VAL,VAR,Z,ZZ,FBAAPGM,Y,PSSN,DIRUT
- +1 KILL FBAAOUT,FBCTR,FBPRG,FBY,FBMOD,FBMODLE,DFN,IFN,FBDEN,FBGOT,FBENA
- +2 KILL ^UTILITY($JOB),^TMP($JOB)
- +3 DO CLOSE^FBAAUTL
- QUIT
- MORE FOR J=0:0
- SET J=$ORDER(^FBAAC("AI",K,FBDT,J))
- if J'>0
- QUIT
- IF $SELECT($GET(DFN):DFN=J,1:1)
- if $DATA(^DPT(J,0))
- DO GOTP
- IF $DATA(^FBAAV(K,0))
- DO MID
- +1 QUIT
- GOTV SET Y(0)=^FBAAV(K,0)
- SET VNAM=$PIECE(Y(0),"^",1)
- SET FBSW=0
- +1 IF VNAM[","
- SET VNAM=$PIECE(VNAM,",",2)_" "_$PIECE(VNAM,",",1)
- +2 SET VST1=$PIECE(Y(0),"^",3)
- SET VST2=$PIECE(Y(0),"^",14)
- SET VCITY=$PIECE(Y(0),"^",4)
- SET VSTATE=$SELECT($DATA(^DIC(5,+$PIECE(Y(0),"^",5),0)):$PIECE(^(0),"^",2),1:" ")
- SET VZIP=$PIECE(Y(0),"^",6)
- SET Y=DT
- DO PDATE^FBAAUTL
- +3 if '$GET(FBPG)
- WRITE @IOF
- if $GET(FBPG)
- KILL FBPG
- if (IOSL)>70
- WRITE !!!!
- WRITE !!!!!!!!!!!,?5,VNAM,?60,FBPDT,!,?5,VST1,!
- IF VST2]""
- WRITE ?5,VST2,!
- +4 WRITE ?5,VCITY," ",VSTATE," ",VZIP,!!!!
- WPBEG SET DIWL=1
- SET DIWF="WC79"
- KILL ^UTILITY($JOB,"W")
- +1 IF $DATA(^FBAA(161.3,FBLET,1,1))
- FOR FBRR=0:0
- SET FBRR=$ORDER(^FBAA(161.3,FBLET,1,FBRR))
- if FBRR'>0
- QUIT
- SET FBXX=^(FBRR,0)
- SET X=FBXX
- DO ^DIWP
- +2 if $DATA(FBXX)
- DO ^DIWW
- KILL FBXX
- +3 QUIT
- MID SET FBA=0
- FOR FBAA=0:0
- SET FBA=$ORDER(^FBAAC("AI",K,FBDT,J,FBA))
- if FBA=""
- QUIT
- IF $SELECT(FBSLW=0:1,FBSLW=1&($DATA(FBAAS(FBA))):1,1:0)
- DO MORE2
- +1 QUIT
- MORE2 FOR L=0:0
- SET L=$ORDER(^FBAAC("AI",K,FBDT,J,FBA,L))
- if L'>0
- QUIT
- FOR M=0:0
- SET M=$ORDER(^FBAAC("AI",K,FBDT,J,FBA,L,M))
- if M'>0
- QUIT
- IF $DATA(^FBAAC(J,1,K,1,L,1,M,0))
- SET Z(0)=^(0)
- if $PIECE(Z(0),"^",20)'="R"
- DO BOT
- +1 QUIT
- WPBOT if $DATA(FBACRR)
- DO ACT
- KILL FBACRR
- +1 SET DIWL=1
- SET DIWF="WC79"
- KILL ^UTILITY($JOB,"W")
- WRITE !!
- +2 IF $DATA(^FBAA(161.3,FBLET,2))
- FOR FBRR=0:0
- SET FBRR=$ORDER(^FBAA(161.3,FBLET,2,FBRR))
- if FBRR'>0
- QUIT
- SET FBXX=^(FBRR,0)
- SET X=FBXX
- DO ^DIWP
- +3 if $DATA(FBXX)
- DO ^DIWW
- KILL FBXX
- +4 QUIT
- BOT if $SELECT($GET(FBDEN)
- QUIT
- +1 NEW FBY3,FBFPPSC
- +2 SET FBY3=$GET(^FBAAC(J,1,K,1,L,1,M,3))
- +3 SET FBFPPSC=$PIECE(FBY3,U)
- +4 if $SELECT(FBENA=2&(FBFPPSC]"")
- QUIT
- +5 NEW FBY,FBX,T,TAMT,FBAC,FBJ,FBCSID,FBUNITS,FBADJLR,FBADJLA,FBRRMKL,FBFPPSL
- +6 IF FBSW=1
- DO GOTV
- DO HED
- SET FBSW=0
- SET FBGOT=1
- +7 SET FBDOS=$SELECT($DATA(^FBAAC(J,1,K,1,L,0)):$PIECE(^(0),"^",1),1:"")
- +8 SET CPT=$PIECE(Z(0),"^",1)
- SET A1=$PIECE(Z(0),"^",2)+.0001
- SET A2=$PIECE(Z(0),"^",3)+.0001
- SET A1=$PIECE(A1,".",1)_"."_$EXTRACT($PIECE(A1,".",2),1,2)
- SET A2=$PIECE(A2,".",1)_"."_$EXTRACT($PIECE(A2,".",2),1,2)
- +9 IF CPT]""
- SET CPT=$$CPT^FBAAUTL4(CPT)
- +10 SET T=$PIECE(Z(0),U,5)
- +11 IF T]""
- SET T=$PIECE($GET(^FBAA(161.27,+T,0)),U)
- +12 SET TAMT=$FNUMBER($PIECE(Z(0),U,4),"",2)
- +13 SET FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")
- +14 SET FBY=$GET(^FBAAC(J,1,K,1,L,1,M,2))
- +15 SET FBFPPSL=$PIECE(FBY3,U,2)
- +16 SET FBCSID=$PIECE(FBY,U,16)
- +17 SET FBUNITS=$PIECE(FBY,U,14)
- +18 SET FBADJLR=$PIECE(FBX,U)
- +19 FOR FBJ=1:1
- SET FBAC=$PIECE(FBADJLR,",",FBJ)
- if FBAC=""
- QUIT
- SET FBACRR(FBAC)=""
- +20 SET FBADJLA=$PIECE(FBX,U,2)
- +21 SET FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",")
- +22 SET FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")
- +23 IF $Y+4>IOSL
- WRITE @IOF
- DO HED
- +24 WRITE !!,$EXTRACT(PNAME,1,26),?33,PSSN,?49,FBCSID
- +25 WRITE !,$$DATX^FBAAUTL(FBDOS),?10,CPT_$SELECT($GET(FBMODLE)]"":"-"_$PIECE(FBMODLE,","),1:""),?33,FBUNITS
- +26 IF $PIECE($GET(FBMODLE),",",2)]""
- Begin DoDot:1
- +27 NEW FBI
- +28 FOR FBI=2:1
- SET FBMOD=$PIECE(FBMODLE,",",FBI)
- if FBMOD=""
- QUIT
- Begin DoDot:2
- +29 IF $Y+4>IOSL
- WRITE @IOF
- DO HED
- WRITE !," (continued)"
- +30 WRITE !,?15,"-",FBMOD
- End DoDot:2
- End DoDot:1
- +31 WRITE !,?10,$JUSTIFY(A1,6),?24,$JUSTIFY(A2,6)
- +32 ; write adjustment reasons, if null then write suspend code
- +33 WRITE ?35,$SELECT(FBADJLR]"":FBADJLR,1:T)
- +34 ; write adjustment amounts, if null then write amount suspended
- +35 WRITE ?49,$SELECT(FBADJLA]"":FBADJLA,1:TAMT)
- +36 WRITE ?66,FBRRMKL
- +37 IF FBFPPSC]""
- WRITE !,?10,"FPPS Claim ID: ",FBFPPSC,?38,"FPPS Line Item: ",FBFPPSL
- +38 WRITE !
- +39 IF FBADJLR=""
- if FBA=4&($DATA(^FBAAC(J,1,K,1,L,1,M,1)))
- GOTO WPFT
- Begin DoDot:1
- +40 SET DIWL=1
- SET DIWF="WC79"
- SET FBI=FBA
- KILL ^UTILITY($JOB,"W")
- +41 FOR FBRR=0:0
- SET FBRR=$ORDER(^FBAA(161.27,FBI,1,FBRR))
- if FBRR'>0
- QUIT
- SET FBXX=^(FBRR,0)
- SET X=FBXX
- DO ^DIWP
- +42 if $DATA(FBXX)
- DO ^DIWW
- KILL FBXX
- End DoDot:1
- +43 QUIT
- ACT ; print table of adjustment reason descriptions
- +1 ; Input
- +2 ; FBACRR( - required, array
- +3 ; FBACRR(FBADJRE)=""
- +4 ; where FBADJRE = adjustment reason code, external value
- +5 NEW FBADJRE,FBI,FBACT
- +6 WRITE !,"*Adjustment Code Text:"
- +7 SET FBADJRE=""
- FOR
- SET FBADJRE=$ORDER(FBACRR(FBADJRE))
- if FBADJRE=""
- QUIT
- Begin DoDot:1
- +8 ; get description of code in FBACT
- +9 ; quit if error
- IF $$AR^FBUTL1(,FBADJRE,FBSCDT,"FBACT")<0
- QUIT
- +10 ; print code and description
- +11 KILL ^UTILITY($JOB,"W")
- +12 SET DIWL=1
- SET DIWF="WC79"
- +13 ; include code in output
- +14 SET X=$$LJ^XLFSTR("("_FBADJRE_")",7," ")
- DO ^DIWP
- +15 SET DIWF="WC79I7"
- +16 ; include description in output
- +17 SET FBI=0
- FOR
- SET FBI=$ORDER(FBACT(FBI))
- if FBI=""
- QUIT
- SET X=FBACT(FBI)
- IF X]""
- DO ^DIWP
- +18 DO ^DIWW
- End DoDot:1
- +19 QUIT
- +20 ;
- HED WRITE !,"PATIENT NAME",?33,"SSN",?49,"PATIENT ACCOUNT NUMBER"
- +1 WRITE !,"SVC DATE",?10,"CPT-MOD",?33,"UNITS"
- +2 WRITE !,?10,"AMT CLAIMED",?24,"AMT PAID",?35,"ADJ CODE",?49,"ADJ AMT",?66,"REMIT REMARKS"
- +3 WRITE !,UL
- QUIT
- +4 ;
- GOTP ; Utilize new API for Name Standardization
- +1 ;
- +2 SET Y(0)=^DPT(J,0)
- SET PNAME=$PIECE(Y(0),"^",1)
- SET PSSN=$TRANSLATE($$SSNL4^FBAAUTL($$SSN^FBAAUTL(J)),"-","")
- +3 IF PNAME[","
- Begin DoDot:1
- +4 NEW FBNAMES
- +5 SET FBNAMES("FILE")=2
- SET FBNAMES("IENS")=J_","
- SET FBNAMES("FIELD")=.01
- +6 SET PNAME=$$NAMEFMT^XLFNAME(.FBNAMES)
- End DoDot:1
- +7 QUIT
- SEL WRITE !!
- SET DIC="^FBAA(161.27,"
- SET DIC(0)="AEQM"
- DO ^DIC
- if X=""!(X="^")
- GOTO ENDSL
- if Y<0
- GOTO SEL
- SET DA=+Y
- SET FBAAS(DA)=""
- SET FBSLW=1
- GOTO SEL
- ENDSL IF '$DATA(FBAAS)
- WRITE !!,*7,"No suspension codes selected!"
- GOTO END
- +1 GOTO AHEAD
- PSEL FOR FBA=0:0
- SET FBA=$ORDER(FBAAS(FBA))
- if FBA'>0
- QUIT
- IF $DATA(^FBAAC("AI",FBA))
- FOR FBDT=BEGDATE-.001:0
- SET FBDT=$ORDER(^FBAAC("AI",FBA,FBDT))
- if FBDT'>0!(FBDT>ENDDATE)
- QUIT
- DO MORE
- +1 GOTO END
- WPFT SET DIWL=1
- SET DIWF="WC79"
- KILL ^UTILITY($JOB,"W")
- +1 FOR FBRR=0:0
- SET FBRR=$ORDER(^FBAAC(J,1,K,1,L,1,M,1,FBRR))
- if FBRR'>0
- QUIT
- SET FBXX=^(FBRR,0)
- SET X=FBXX
- DO ^DIWP
- +2 if $DATA(FBXX)
- DO ^DIWW
- KILL FBXX
- +3 QUIT
- STRT NEW FBACRR,FBSCDT
- SET FBSW=1
- SET Z=$ORDER(^FBAAC("AI",K,BEGDATE-.001))
- SET FBDT=BEGDATE-.001
- FOR ZZ=0:0
- SET FBDT=$ORDER(^FBAAC("AI",K,FBDT))
- if FBDT'>0&(FBSW=0)!(FBDT>ENDDATE)&(FBSW=0)
- DO WPBOT
- if FBDT'>0!(FBDT>ENDDATE)
- QUIT
- SET FBSCDT=FBDT
- DO MORE
- +1 QUIT