- FBAASL1 ;AISC/GRR-PRINT SUSPENSION LETTERS CONTINUED ;7/NOV/2006
- ;;3.5;FEE BASIS;**12,23,69,101**;JAN 30, 1995;Build 2
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- N FBACRR,FBSCDT
- F K=0:0 S K=$O(^FBAA(162.1,"AG",K)) Q:K'>0 I $S($G(IFN):IFN=K,1:1) S FBSW=1,FBDT=BEGDATE-.001 F ZZ=0:0 S FBDT=$O(^FBAA(162.1,"AG",K,FBDT)) D WPBOT:FBDT'>0&(FBSW=0)!(FBDT>ENDDATE)&(FBSW=0) Q:FBDT'>0!(FBDT>ENDDATE) S FBSCDT=FBDT D MORE
- Q
- MORE F J=0:0 S J=$O(^FBAA(162.1,"AG",K,FBDT,J)) Q:J'>0 I $S($G(DFN):DFN=J,1:1) D:$D(^DPT(J,0)) GOTP^FBAASLP 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)
- W @IOF,!!!!!!!,?5,VNAM,!,?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
- D HED
- Q
- MID S FBA=0 F FBAA=0:0 S FBA=$O(^FBAA(162.1,"AG",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(^FBAA(162.1,"AG",K,FBDT,J,FBA,L)) Q:L'>0 F M=0:0 S M=$O(^FBAA(162.1,"AG",K,FBDT,J,FBA,L,M)) Q:M'>0 I $D(^FBAA(162.1,L,"RX",M,0)) S Z(0)=^(0) D:$P(Z(0),"^",20)'="R" BOT
- Q
- WPBOT D:$D(FBACRR) ACT^FBAASLP 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,16)>0,1:0)
- N FBFPPSC S FBFPPSC=$P($G(^FBAA(162.1,L,0)),U,13)
- Q:$S(FBENA=2&(FBFPPSC]""):1,FBENA=1&(FBFPPSC=""):1,1:0)
- N FBFPPSL,FBX,FBADJLR,FBADJLA,FBRRMKL,T,TAMT,FBJ,FBAC
- S FBFPPSL=$P($G(^FBAA(162.1,L,"RX",M,3)),U)
- S FBX=$$ADJLRA^FBRXFA(M_","_L_",")
- 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 T=$P(Z(0),U,8)
- I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U)
- S TAMT=$FN($P(Z(0),U,7),"",2)
- S FBRRMKL=$$RRL^FBRXFR(M_","_L_",")
- I FBSW=1 D GOTV^FBAASLP,HED S FBSW=0,FBGOT=1
- S FBDOS=$P(Z(0),"^",3),FBDRUG=$P(Z(0),"^",2)
- S FBRX=$P(Z(0),"^",1),A1=$P(Z(0),"^",4)+.0001,A2=$P(Z(0),"^",16)+.0001,A1=$P(A1,".",1)_"."_$E($P(A1,".",2),1,2),A2=$P(A2,".",1)_"."_$E($P(A2,".",2),1,2)
- I $Y+4>IOSL W @IOF D HED
- W !!,PNAME,?32,PSSN,?47,$$FMTE^XLFDT(FBDOS),?61,FBRX,!,?15,$J(A1,6),?30,$J(A2,6),?50,FBDRUG,!
- ; write adjustment reasons, if null then write suspend code
- W ?15,$S(FBADJLR]"":FBADJLR,1:T)
- ; write adjustment amounts, if null then write amount suspended
- W ?31,$S(FBADJLA]"":FBADJLA,1:TAMT)
- W ?49,FBRRMKL
- I FBFPPSC]"" W !,?15,"FPPS Claim ID: ",FBFPPSC,?43,"FPPS Line Item: ",FBFPPSL,!
- I FBADJLR="" G:FBA=4&($D(^FBAA(162.1,L,"RX",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
- HED W !,"PATIENT NAME",?36,"SSN",?47,"RX DATE",?61,"RX #",!,?15,"AMT CLAIMED",?30,"AMT PAID",?50,"DRUG NAME"
- W !,?15,"ADJ CODE",?30,"ADJ AMOUNT",?49,"MEDICARE REMITTANCE REMARK"
- 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
- WPFT S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W")
- F FBRR=0:0 S FBRR=$O(^FBAA(162.1,L,"RX",M,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
- D ^DIWW:$D(FBXX) K FBXX
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAASL1 3814 printed Mar 13, 2025@21:01:23 Page 2
- FBAASL1 ;AISC/GRR-PRINT SUSPENSION LETTERS CONTINUED ;7/NOV/2006
- +1 ;;3.5;FEE BASIS;**12,23,69,101**;JAN 30, 1995;Build 2
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 NEW FBACRR,FBSCDT
- +4 FOR K=0:0
- SET K=$ORDER(^FBAA(162.1,"AG",K))
- if K'>0
- QUIT
- IF $SELECT($GET(IFN):IFN=K,1:1)
- SET FBSW=1
- SET FBDT=BEGDATE-.001
- FOR ZZ=0:0
- SET FBDT=$ORDER(^FBAA(162.1,"AG",K,FBDT))
- if FBDT'>0&(FBSW=0)!(FBDT>ENDDATE)&(FBSW=0)
- DO WPBOT
- if FBDT'>0!(FBDT>ENDDATE)
- QUIT
- SET FBSCDT=FBDT
- DO MORE
- +5 QUIT
- MORE FOR J=0:0
- SET J=$ORDER(^FBAA(162.1,"AG",K,FBDT,J))
- if J'>0
- QUIT
- IF $SELECT($GET(DFN):DFN=J,1:1)
- if $DATA(^DPT(J,0))
- DO GOTP^FBAASLP
- 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)
- +3 WRITE @IOF,!!!!!!!,?5,VNAM,!,?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 DO HED
- +4 QUIT
- MID SET FBA=0
- FOR FBAA=0:0
- SET FBA=$ORDER(^FBAA(162.1,"AG",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(^FBAA(162.1,"AG",K,FBDT,J,FBA,L))
- if L'>0
- QUIT
- FOR M=0:0
- SET M=$ORDER(^FBAA(162.1,"AG",K,FBDT,J,FBA,L,M))
- if M'>0
- QUIT
- IF $DATA(^FBAA(162.1,L,"RX",M,0))
- SET Z(0)=^(0)
- if $PIECE(Z(0),"^",20)'="R"
- DO BOT
- +1 QUIT
- WPBOT if $DATA(FBACRR)
- DO ACT^FBAASLP
- 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 FBFPPSC
- SET FBFPPSC=$PIECE($GET(^FBAA(162.1,L,0)),U,13)
- +2 if $SELECT(FBENA=2&(FBFPPSC]"")
- QUIT
- +3 NEW FBFPPSL,FBX,FBADJLR,FBADJLA,FBRRMKL,T,TAMT,FBJ,FBAC
- +4 SET FBFPPSL=$PIECE($GET(^FBAA(162.1,L,"RX",M,3)),U)
- +5 SET FBX=$$ADJLRA^FBRXFA(M_","_L_",")
- +6 SET FBADJLR=$PIECE(FBX,U)
- +7 FOR FBJ=1:1
- SET FBAC=$PIECE(FBADJLR,",",FBJ)
- if FBAC=""
- QUIT
- SET FBACRR(FBAC)=""
- +8 SET FBADJLA=$PIECE(FBX,U,2)
- +9 SET T=$PIECE(Z(0),U,8)
- +10 IF T]""
- SET T=$PIECE($GET(^FBAA(161.27,+T,0)),U)
- +11 SET TAMT=$FNUMBER($PIECE(Z(0),U,7),"",2)
- +12 SET FBRRMKL=$$RRL^FBRXFR(M_","_L_",")
- +13 IF FBSW=1
- DO GOTV^FBAASLP
- DO HED
- SET FBSW=0
- SET FBGOT=1
- +14 SET FBDOS=$PIECE(Z(0),"^",3)
- SET FBDRUG=$PIECE(Z(0),"^",2)
- +15 SET FBRX=$PIECE(Z(0),"^",1)
- SET A1=$PIECE(Z(0),"^",4)+.0001
- SET A2=$PIECE(Z(0),"^",16)+.0001
- SET A1=$PIECE(A1,".",1)_"."_$EXTRACT($PIECE(A1,".",2),1,2)
- SET A2=$PIECE(A2,".",1)_"."_$EXTRACT($PIECE(A2,".",2),1,2)
- +16 IF $Y+4>IOSL
- WRITE @IOF
- DO HED
- +17 WRITE !!,PNAME,?32,PSSN,?47,$$FMTE^XLFDT(FBDOS),?61,FBRX,!,?15,$JUSTIFY(A1,6),?30,$JUSTIFY(A2,6),?50,FBDRUG,!
- +18 ; write adjustment reasons, if null then write suspend code
- +19 WRITE ?15,$SELECT(FBADJLR]"":FBADJLR,1:T)
- +20 ; write adjustment amounts, if null then write amount suspended
- +21 WRITE ?31,$SELECT(FBADJLA]"":FBADJLA,1:TAMT)
- +22 WRITE ?49,FBRRMKL
- +23 IF FBFPPSC]""
- WRITE !,?15,"FPPS Claim ID: ",FBFPPSC,?43,"FPPS Line Item: ",FBFPPSL,!
- +24 IF FBADJLR=""
- if FBA=4&($DATA(^FBAA(162.1,L,"RX",M,1)))
- GOTO WPFT
- Begin DoDot:1
- +25 SET DIWL=1
- SET DIWF="WC79"
- SET FBI=FBA
- KILL ^UTILITY($JOB,"W")
- +26 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
- +27 if $DATA(FBXX)
- DO ^DIWW
- KILL FBXX
- End DoDot:1
- +28 QUIT
- HED WRITE !,"PATIENT NAME",?36,"SSN",?47,"RX DATE",?61,"RX #",!,?15,"AMT CLAIMED",?30,"AMT PAID",?50,"DRUG NAME"
- +1 WRITE !,?15,"ADJ CODE",?30,"ADJ AMOUNT",?49,"MEDICARE REMITTANCE REMARK"
- +2 WRITE !,UL,!
- QUIT
- +3 ;
- 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
- WPFT SET DIWL=1
- SET DIWF="WC79"
- KILL ^UTILITY($JOB,"W")
- +1 FOR FBRR=0:0
- SET FBRR=$ORDER(^FBAA(162.1,L,"RX",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
