source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAASLP.m@ 1361

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