FBCHSL1 ;AISC/DMK-PRINT SUSPENSION LETTERS CONTINUED ;7/NOV/2006
;;3.5;FEE BASIS;**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(^FBAAI("AI",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(^FBAAI("AI",K,FBDT)) D WPBOT:FBDT'>0&(FBSW=0)!(FBDT>ENDDATE)&(FBSW=0) Q:FBDT'>0!(FBDT>ENDDATE) S FBSCDT=FBDT D MORE
K FBCHAD,FBCHDT,FBAMTC,FBAMTP,FBAMTS Q
MORE F J=0:0 S J=$O(^FBAAI("AI",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(^FBAAI("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(^FBAAI("AI",K,FBDT,J,FBA,L)) Q:L'>0 I $D(^FBAAI(L,0)) S Z(0)=^(0) D 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,9)>0,1:0) ;quit if not den (if prn den's only)
N FBY3,FBFPPSC
S FBY3=$G(^FBAAI(L,3))
S FBFPPSC=$P(FBY3,U,1) ; fpps claim id
Q:$S(FBENA=2&(FBFPPSC]""):1,FBENA=1&(FBFPPSC=""):1,1:0)
N FBCSID,FBFPPSL,FBX,FBADJLR,FBADJLA,FBRRMKL,T,TAMT
S FBCSID=$P($G(^FBAAI(L,2)),U,11) ; patient control number
S FBFPPSL=$P(FBY3,U,2) ; fpps line item
S FBX=$$ADJLRA^FBCHFA(L_",")
S T=$P(Z(0),U,11)
I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U)
S TAMT=$FN($P(Z(0),U,10),"",2)
S FBADJLR=$P(FBX,U)
S:FBADJLR]"" FBACRR(FBADJLR)=""
S FBADJLA=$P(FBX,U,2)
S FBRRMKL=$$RRL^FBCHFR(L_",")
I FBSW=1 D GOTV^FBAASLP,HED S FBSW=0,FBGOT=1
S Y=$P(Z(0),"^",7) D PDATE^FBAAUTL S FBCHDT=FBPDT,Y=$P(Z(0),"^",6) D PDATE^FBAAUTL S FBCHAD=FBPDT,FBAMTC=$P(Z(0),"^",8),FBAMTP=$P(Z(0),"^",9),FBAMTS=$P(Z(0),"^",10)
I $Y+4>IOSL W @IOF D HED
W !!,PNAME,?32,PSSN,?56,FBCHAD
W !,FBCSID,?24,FBCHDT,?44,"$ ",FBAMTC,?61,"$ ",FBAMTP,!
; write adjustment reasons, if null then write suspend code
W ?4,$S(FBADJLR]"":FBADJLR,1:T)
; write adjustment amounts, if null then write amount suspended
W ?32,"$ ",$S(FBADJLA]"":FBADJLA,1:TAMT)
W ?59,FBRRMKL
I FBFPPSC]"" W !,?4,"FPPS Claim ID: ",FBFPPSC,?32,"FPPS Line Item: ",FBFPPSL,!
I FBADJLR="" G:FBA=4&($D(^FBAAI(L,1,0))) 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",?53,"ADMISSION DATE"
W !,"PATIENT CONTROL #",?22,"DISCHARGE DATE",?42,"AMOUNT CLAIMED",?59,"AMOUNT PAID"
W !,"ADJUSTMENT CODE",?29,"ADJUSTMENT AMOUNT",?54,"MEDICARE REMITTANCE REMARK"
W !,UL,! Q
;
GOTP ; Utilize new API for Name Standardization
;
S Y(0)=^DPT(J,0),PNAME=$$NAME^FBCHREQ2(J)
S 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(^FBAAI(L,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
D ^DIWW:$D(FBXX) K FBXX
Q
HELP W !,"Answer 'Yes' to print suspension letters for all suspension",!,"codes, otherwise answer 'No' to select specific codes." G RDCODE^FBAASLP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHSL1 3948 printed Dec 13, 2024@01:57:59 Page 2
FBCHSL1 ;AISC/DMK-PRINT SUSPENSION LETTERS CONTINUED ;7/NOV/2006
+1 ;;3.5;FEE BASIS;**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(^FBAAI("AI",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(^FBAAI("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
+5 KILL FBCHAD,FBCHDT,FBAMTC,FBAMTP,FBAMTS
QUIT
MORE FOR J=0:0
SET J=$ORDER(^FBAAI("AI",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(^FBAAI("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(^FBAAI("AI",K,FBDT,J,FBA,L))
if L'>0
QUIT
IF $DATA(^FBAAI(L,0))
SET Z(0)=^(0)
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 ;quit if not den (if prn den's only)
if $SELECT($GET(FBDEN)
QUIT
+1 NEW FBY3,FBFPPSC
+2 SET FBY3=$GET(^FBAAI(L,3))
+3 ; fpps claim id
SET FBFPPSC=$PIECE(FBY3,U,1)
+4 if $SELECT(FBENA=2&(FBFPPSC]"")
QUIT
+5 NEW FBCSID,FBFPPSL,FBX,FBADJLR,FBADJLA,FBRRMKL,T,TAMT
+6 ; patient control number
SET FBCSID=$PIECE($GET(^FBAAI(L,2)),U,11)
+7 ; fpps line item
SET FBFPPSL=$PIECE(FBY3,U,2)
+8 SET FBX=$$ADJLRA^FBCHFA(L_",")
+9 SET T=$PIECE(Z(0),U,11)
+10 IF T]""
SET T=$PIECE($GET(^FBAA(161.27,+T,0)),U)
+11 SET TAMT=$FNUMBER($PIECE(Z(0),U,10),"",2)
+12 SET FBADJLR=$PIECE(FBX,U)
+13 if FBADJLR]""
SET FBACRR(FBADJLR)=""
+14 SET FBADJLA=$PIECE(FBX,U,2)
+15 SET FBRRMKL=$$RRL^FBCHFR(L_",")
+16 IF FBSW=1
DO GOTV^FBAASLP
DO HED
SET FBSW=0
SET FBGOT=1
+17 SET Y=$PIECE(Z(0),"^",7)
DO PDATE^FBAAUTL
SET FBCHDT=FBPDT
SET Y=$PIECE(Z(0),"^",6)
DO PDATE^FBAAUTL
SET FBCHAD=FBPDT
SET FBAMTC=$PIECE(Z(0),"^",8)
SET FBAMTP=$PIECE(Z(0),"^",9)
SET FBAMTS=$PIECE(Z(0),"^",10)
+18 IF $Y+4>IOSL
WRITE @IOF
DO HED
+19 WRITE !!,PNAME,?32,PSSN,?56,FBCHAD
+20 WRITE !,FBCSID,?24,FBCHDT,?44,"$ ",FBAMTC,?61,"$ ",FBAMTP,!
+21 ; write adjustment reasons, if null then write suspend code
+22 WRITE ?4,$SELECT(FBADJLR]"":FBADJLR,1:T)
+23 ; write adjustment amounts, if null then write amount suspended
+24 WRITE ?32,"$ ",$SELECT(FBADJLA]"":FBADJLA,1:TAMT)
+25 WRITE ?59,FBRRMKL
+26 IF FBFPPSC]""
WRITE !,?4,"FPPS Claim ID: ",FBFPPSC,?32,"FPPS Line Item: ",FBFPPSL,!
+27 IF FBADJLR=""
if FBA=4&($DATA(^FBAAI(L,1,0)))
GOTO WPFT
Begin DoDot:1
+28 SET DIWL=1
SET DIWF="WC79"
SET FBI=FBA
KILL ^UTILITY($JOB,"W")
+29 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
+30 if $DATA(FBXX)
DO ^DIWW
KILL FBXX
End DoDot:1
+31 QUIT
HED WRITE !,"PATIENT NAME",?36,"SSN",?53,"ADMISSION DATE"
+1 WRITE !,"PATIENT CONTROL #",?22,"DISCHARGE DATE",?42,"AMOUNT CLAIMED",?59,"AMOUNT PAID"
+2 WRITE !,"ADJUSTMENT CODE",?29,"ADJUSTMENT AMOUNT",?54,"MEDICARE REMITTANCE REMARK"
+3 WRITE !,UL,!
QUIT
+4 ;
GOTP ; Utilize new API for Name Standardization
+1 ;
+2 SET Y(0)=^DPT(J,0)
SET PNAME=$$NAME^FBCHREQ2(J)
+3 SET PSSN=$TRANSLATE($$SSNL4^FBAAUTL($$SSN^FBAAUTL(J)),"-","")
+4 IF PNAME[","
Begin DoDot:1
+5 NEW FBNAMES
+6 SET FBNAMES("FILE")=2
SET FBNAMES("IENS")=J_","
SET FBNAMES("FIELD")=.01
+7 SET PNAME=$$NAMEFMT^XLFNAME(.FBNAMES)
End DoDot:1
+8 QUIT
WPFT SET DIWL=1
SET DIWF="WC79"
KILL ^UTILITY($JOB,"W")
+1 FOR FBRR=0:0
SET FBRR=$ORDER(^FBAAI(L,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
HELP WRITE !,"Answer 'Yes' to print suspension letters for all suspension",!,"codes, otherwise answer 'No' to select specific codes."
GOTO RDCODE^FBAASLP
