Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBCHSL1

FBCHSL1.m

Go to the documentation of this file.
  1. FBCHSL1 ;AISC/DMK-PRINT SUSPENSION LETTERS CONTINUED ;7/NOV/2006
  1. ;;3.5;FEE BASIS;**23,69,101**;JAN 30, 1995;Build 2
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. N FBACRR,FBSCDT
  1. 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
  1. K FBCHAD,FBCHDT,FBAMTC,FBAMTP,FBAMTS Q
  1. 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
  1. Q
  1. GOTV S Y(0)=^FBAAV(K,0),VNAM=$P(Y(0),"^",1),FBSW=0
  1. I VNAM["," S VNAM=$P(VNAM,",",2)_" "_$P(VNAM,",",1)
  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)
  1. W @IOF,!!!!!!!,?5,VNAM,!,?5,VST1,! I VST2]"" W ?5,VST2,!
  1. W ?5,VCITY," ",VSTATE," ",VZIP,!!!!
  1. WPBEG S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W")
  1. 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
  1. D ^DIWW:$D(FBXX) K FBXX
  1. D HED
  1. Q
  1. 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
  1. Q
  1. 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
  1. Q
  1. WPBOT D:$D(FBACRR) ACT^FBAASLP K FBACRR
  1. S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W") W !!
  1. 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
  1. D ^DIWW:$D(FBXX) K FBXX
  1. Q
  1. BOT Q:$S($G(FBDEN):$P(Z(0),U,9)>0,1:0) ;quit if not den (if prn den's only)
  1. N FBY3,FBFPPSC
  1. S FBY3=$G(^FBAAI(L,3))
  1. S FBFPPSC=$P(FBY3,U,1) ; fpps claim id
  1. Q:$S(FBENA=2&(FBFPPSC]""):1,FBENA=1&(FBFPPSC=""):1,1:0)
  1. N FBCSID,FBFPPSL,FBX,FBADJLR,FBADJLA,FBRRMKL,T,TAMT
  1. S FBCSID=$P($G(^FBAAI(L,2)),U,11) ; patient control number
  1. S FBFPPSL=$P(FBY3,U,2) ; fpps line item
  1. S FBX=$$ADJLRA^FBCHFA(L_",")
  1. S T=$P(Z(0),U,11)
  1. I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U)
  1. S TAMT=$FN($P(Z(0),U,10),"",2)
  1. S FBADJLR=$P(FBX,U)
  1. S:FBADJLR]"" FBACRR(FBADJLR)=""
  1. S FBADJLA=$P(FBX,U,2)
  1. S FBRRMKL=$$RRL^FBCHFR(L_",")
  1. I FBSW=1 D GOTV^FBAASLP,HED S FBSW=0,FBGOT=1
  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)
  1. I $Y+4>IOSL W @IOF D HED
  1. W !!,PNAME,?32,PSSN,?56,FBCHAD
  1. W !,FBCSID,?24,FBCHDT,?44,"$ ",FBAMTC,?61,"$ ",FBAMTP,!
  1. ; write adjustment reasons, if null then write suspend code
  1. W ?4,$S(FBADJLR]"":FBADJLR,1:T)
  1. ; write adjustment amounts, if null then write amount suspended
  1. W ?32,"$ ",$S(FBADJLA]"":FBADJLA,1:TAMT)
  1. W ?59,FBRRMKL
  1. I FBFPPSC]"" W !,?4,"FPPS Claim ID: ",FBFPPSC,?32,"FPPS Line Item: ",FBFPPSL,!
  1. I FBADJLR="" G:FBA=4&($D(^FBAAI(L,1,0))) WPFT D
  1. . S DIWL=1,DIWF="WC79",FBI=FBA K ^UTILITY($J,"W")
  1. . F FBRR=0:0 S FBRR=$O(^FBAA(161.27,FBI,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
  1. . D ^DIWW:$D(FBXX) K FBXX
  1. Q
  1. HED W !,"PATIENT NAME",?36,"SSN",?53,"ADMISSION DATE"
  1. W !,"PATIENT CONTROL #",?22,"DISCHARGE DATE",?42,"AMOUNT CLAIMED",?59,"AMOUNT PAID"
  1. W !,"ADJUSTMENT CODE",?29,"ADJUSTMENT AMOUNT",?54,"MEDICARE REMITTANCE REMARK"
  1. W !,UL,! Q
  1. ;
  1. GOTP ; Utilize new API for Name Standardization
  1. ;
  1. S Y(0)=^DPT(J,0),PNAME=$$NAME^FBCHREQ2(J)
  1. S PSSN=$TR($$SSNL4^FBAAUTL($$SSN^FBAAUTL(J)),"-","")
  1. I PNAME["," D
  1. .N FBNAMES
  1. .S FBNAMES("FILE")=2,FBNAMES("IENS")=J_",",FBNAMES("FIELD")=.01
  1. .S PNAME=$$NAMEFMT^XLFNAME(.FBNAMES)
  1. Q
  1. WPFT S DIWL=1,DIWF="WC79" K ^UTILITY($J,"W")
  1. F FBRR=0:0 S FBRR=$O(^FBAAI(L,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
  1. D ^DIWW:$D(FBXX) K FBXX
  1. Q
  1. HELP W !,"Answer 'Yes' to print suspension letters for all suspension",!,"codes, otherwise answer 'No' to select specific codes." G RDCODE^FBAASLP