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

FBAAUTL.m

Go to the documentation of this file.
  1. FBAAUTL ;AISC/GRR,SBW-Fee Basis Utility Routine ; 4/23/10 3:06pm
  1. ;;3.5;FEE BASIS;**101,114,108,124,127,158**;JAN 30, 1995;Build 94
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. DATE N FBDT S FBPOP=0 K BEGDATE,ENDDATE K:$G(%DT)'["A" %DT W !!,"**** Date Range Selection ****"
  1. S FBDT=$S($D(%DT):1,1:0) W ! S %DT=$S(FBDT:%DT,1:"APEX"),%DT("A")=" Beginning DATE : " D ^%DT S:Y<0 FBPOP=1 Q:Y<0 S (%DT(0),BEGDATE)=Y
  1. W ! S %DT=$S(FBDT:%DT,1:"AEX"),%DT("A")=" Ending DATE : " D ^%DT K %DT S:Y<0 FBPOP=1 Q:Y<0 W ! S ENDDATE=Y
  1. Q
  1. ;
  1. ZIS S ZTRTN=PGM,ZTSAVE="",FBPOP=0 F I=1:1 Q:$P(VAR,"^",I)']"" S ZTSAVE($P(VAR,"^",I))=""
  1. I '$D(ZTDESC) S ZTDESC=$S($D(PGM):PGM,1:"UNKNOWN OPTION")
  1. W ! S %ZIS="QMP" D ^%ZIS S:POP FBPOP=1 Q:POP I $D(IO("Q")) K IO("Q"),ZTIO D ^%ZTLOAD W:$D(ZTSK) !,*7,"REQUEST QUEUED",!,"Task #: ",$G(ZTSK) K I,ZTSK,ZTIO,ZTSAVE,ZTRTN D HOME^%ZIS S FBPOP=1 Q
  1. Q
  1. ;
  1. CLOSE I '$D(ZTQUEUED) D ^%ZISC
  1. K IOP,ZTDESC,ZTRTN,ZTSAVE,ZTDTH,VAR,VAL,PGM,FBPOP,POP Q
  1. ;
  1. D S Y=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(Y,4,5))_" "_$S(Y#100:$J(Y#100\1,2)_",",1:"")_(Y\10000+1700)_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"") Q
  1. SITEP ;SET FBSITE(0),FBSITE(1) VARIABLE TO FEE SITE PARAMETERS
  1. S FBPOP=0,FBSITE(0)=$G(^FBAA(161.4,1,0)) S:FBSITE(0)']"" FBPOP=1
  1. S FBSITE(1)=$G(^FBAA(161.4,1,1)) S:FBSITE(1)']"" FBPOP=1
  1. S FBSITE("FBNUM")=$G(^FBAA(161.4,1,"FBNUM")) S:FBSITE("FBNUM")']"" FBPOP=1
  1. W:FBPOP !,*7,"Fee Basis Site Parameters must be entered to proceed",!
  1. Q
  1. TM S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M" Q
  1. PDF S:Y Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) Q
  1. GETNXB ;GET NEXT AVAILABLE BATCH NUMBER
  1. L +^FBAA(161.4):$G(DILOCKTM,3) I '$T D G GETNXB
  1. .W !,"Another user is opening a batch. Trying again.",!
  1. I '$D(^FBAA(161.4,1,"FBNUM")) S ^FBAA(161.4,1,"FBNUM")="1^1"
  1. I '$P($G(^FBAA(161.4,1,"FBNUM")),"^") S $P(^("FBNUM"),"^")=1
  1. S FBBN=$P(^FBAA(161.4,1,"FBNUM"),"^")
  1. N FBBATLT ;Batches Left *127
  1. S FBBATLT=$P($G(^FBAA(161.7,0)),U,4)
  1. I FBBATLT>9999499 D WARNBT ;*114,127,FB*3.5*158
  1. S $P(^FBAA(161.4,1,"FBNUM"),"^",1)=$S(FBBN+1>9999999:1,1:FBBN+1) I '$$CHKBI^FBAAUTL4(FBBN,1) L -^FBAA(161.4) G GETNXB
  1. L -^FBAA(161.4) Q
  1. WARNBT W !,*7,"There are ",9999999-FBBATLT," batches left before the BATCH PURGE routine",!,"needs to be run. Contact your IRM Service!",!!
  1. Q
  1. GETNXI ;GET NEXT AVAILABLE INVOICE NUMBER
  1. L +^FBAA(161.4):$G(DILOCKTM,3) I '$T D G GETNXI
  1. .W !,"Another user is obtaining an invoice number. Trying again.",!
  1. I '$D(^FBAA(161.4,1,"FBNUM")) S ^FBAA(161.4,1,"FBNUM")="1^1"
  1. I '$P($G(^FBAA(161.4,1,"FBNUM")),U,2) S $P(^("FBNUM"),U,2)=1
  1. S FBAAIN=$P(^FBAA(161.4,1,"FBNUM"),"^",2),$P(^("FBNUM"),"^",2)=$S(FBAAIN+1>9999999:1,1:FBAAIN+1) I '$$CHKBI^FBAAUTL4(FBAAIN) L -^FBAA(161.4) G GETNXI
  1. L -^FBAA(161.4) Q
  1. PDATE S FBPDT=$P("January^February^March^April^May^June^July^August^September^October^November^December","^",$E(Y,4,5))_" "_$S(Y#100:$J(Y#100\1,2)_", ",1:"")_(Y\10000+1700)_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"") Q
  1. DATCK S HOLDY=Y,HOLDY=$S($P(HOLDY,"^",2):$P(HOLDY,"^",2),1:HOLDY)
  1. I $D(FBAAID),Y>FBAAID D K X Q
  1. .N SHODAT S SHODAT=$E(FBAAID,4,5)_"/"_$E(FBAAID,6,7)_"/"_$E(FBAAID,2,3)
  1. .W !!,*7,?5,"*** Date of Service cannot be later than",!?8," Invoice Received Date ("_SHODAT_") !!!",!
  1. I $D(FBAABDT),$D(FBAAEDT),(Y<FBAABDT!(Y>FBAAEDT)) D K X
  1. .N PRIORLAT,AUTHDAT,SHODAT
  1. .S PRIORLAT=$S($P(Y,"^",2)<FBAABDT:"prior to ",1:"later than ")
  1. .S AUTHDAT=$S($P(Y,"^",2)<FBAABDT:FBAABDT,1:FBAAEDT)
  1. .S SHODAT=$E(AUTHDAT,4,5)_"/"_$E(AUTHDAT,6,7)_"/"_$E(AUTHDAT,2,3)
  1. .W !!,*7,?5,"*** Date of Service cannot be ",PRIORLAT
  1. .W !?8," Authorization period ("_SHODAT_") !!!",!
  1. S Y=HOLDY Q
  1. ;
  1. DATX(X) ;external output function for date format
  1. ;INPUT = FM internal date format (time optional)
  1. ;OUTPUT = date/time with slashes
  1. Q $$FMTE^XLFDT(X,2)
  1. ;
  1. STATION ;GET STATION NUMBER FROM INSTITUTION FILE
  1. I '$D(FBSITE(1)) D SITEP
  1. I $S('$D(FBSITE(1)):1,$P(FBSITE(1),"^",3)="":1,'$D(^DIC(4,$P(FBSITE(1),"^",3),0)):1,'$D(^DIC(4,$P(FBSITE(1),"^",3),99)):1,'+$P(^DIC(4,$P(FBSITE(1),"^",3),99),"^"):1,1:0) G NOSTA
  1. S (FBSN,FBAASN)=$S($D(^DIC(4,$P(FBSITE(1),"^",3),99)):$E(^(99),1,3),1:999)
  1. Q
  1. NOSTA S FB("ERROR")=1 I '$D(ZTQUEUED) W !!,*7,"Unable to determine Station Number. Check Fee Site Parameters or Station Number in the Institution File.",!!
  1. Q
  1. ;
  1. HD ;set transmission header
  1. I '$D(FBSITE(1)) S FBSITE(1)=$G(^FBAA(161.4,1,1))
  1. S FBHD=$$HDR^FBAAUTL3() I FBHD']"" S FB("ERROR")=1 W !,"Transmission header must exist in FEE BASIS SITE PARAMETER file",!,"before you can proceed.",*7,!
  1. Q
  1. ;
  1. SSN(PID,BID,DOD) ;
  1. ;PID = DFN of Patient. If this is all that is past,
  1. ;full Pt.ID (000-00-0000) will be returned.
  1. ;If BID = 1 the call will return last 4 of Pt.ID only.
  1. ;If DOD is defined to internal entry # of eligibility the appropriate
  1. ;Pt.ID will be returned.
  1. N DFN,FBSSN
  1. S DFN=PID
  1. I 'DFN Q "Unknown"
  1. S:'$D(BID) BID="" S:$D(DOD) VAPTYP=DOD
  1. D PID^VADPT6 I VAERR K VAERR Q "Unknown"
  1. S FBSSN=$S(BID:VA("BID"),1:VA("PID"))
  1. K VA("BID"),VA("PID"),VAERR,VAPTYP
  1. Q FBSSN
  1. ;
  1. SSNL4(SSN) ;Convert 1st 5 digits of SSN to X (Only print last 4 digits of SSN)
  1. ;Input:
  1. ; SSN - SSN in 9 digit or ###-##-#### format
  1. ; Pseudo SSN is also allowed as input
  1. ;Output
  1. ; SSN - SSN in XXXXX#### or XXX-XX-#### format
  1. ; Pseudo SSN will be changed as above with passed "P" at end
  1. ; X represent actual X and # represent digit
  1. ;
  1. S SSN=$G(SSN)
  1. ;Change SSN ######### to XXXXX####
  1. S:SSN?9N0.1"P" $E(SSN,1,5)="XXXXX"
  1. ;Change SSN ###-##-#### to XXX-XX-####
  1. S:SSN?3N1"-"2N1"-"4N0.1"P" $E(SSN,1,7)="XXX-XX-"
  1. Q SSN
  1. ;
  1. PYMTH(CODE) ; Payment Methodology Processing (FB*3.5*158)
  1. ; input --> CODE: Fee Schedule/Payment Methodology code
  1. ; output --> Payment methodology name or '@' to delete existing value
  1. ;
  1. ;S CODE="F" ;debug
  1. Q:CODE']"" "@"
  1. N IEN
  1. S IEN=$O(^FBAA(163.98,"C",CODE,""))
  1. Q $S(IEN:$P(^FBAA(163.98,IEN,0),U),1:"@")
  1. ;
  1. CRARC(FBADJ,FBRRMK,FBCRARC) ; compile CARCs and RARCs into an array for batch processing
  1. ;
  1. N I,J,K,FBADJGI,FBADJGE,FBADJRI,FBADJRE,FBADJA,FBADJAE,FBRRMKI,FBRRMKE,CNT
  1. S (I,CNT)=0
  1. F S I=$O(FBADJ(I)) Q:'I D
  1. . S CNT=I
  1. . S X=$P(FBADJ(I),U,2)_U_$P(FBADJ(I),U)_U_$P(FBADJ(I),U,3)
  1. . S FBADJGI=$P(FBADJ(I),U,2)
  1. . S FBADJGE=$S(FBADJGI:$P($G(^FB(161.92,FBADJGI,0)),U),1:"")
  1. . S FBADJRI=$P(FBADJ(I),U)
  1. . S FBADJRE=$S(FBADJRI:$P($G(^FB(161.91,FBADJRI,0)),U),1:"")
  1. . S FBADJA=$P(FBADJ(I),U,3)
  1. . S FBADJAE=$FN(FBADJA,"",2)
  1. . S FBCRARC(I)=FBADJGE_U_FBADJRE_U_FBADJAE_U
  1. . ; RARCs
  1. . S J=0
  1. . F S J=$O(FBRRMK(FBADJRI,J)) Q:'J D
  1. . . S FBRRMKI=FBRRMK(FBADJRI,J)
  1. . . S FBRRMKE=$S(FBRRMKI:$P($G(^FB(161.93,FBRRMKI,0)),U),1:"")
  1. . . S FBCRARC(I)=FBCRARC(I)_FBRRMKE_U
  1. ; CARCless RARCs
  1. S FBADJRI=999,J=0,(FBADJGE,FBADJRE,FBADJAE)="",DONE=0,I=CNT
  1. F D Q:DONE
  1. . S I=I+1
  1. . F K=1:1:2 D I 'J S DONE=1 Q
  1. . . S J=$O(FBRRMK(FBADJRI,J)) Q:'J D
  1. . . S:K=1 FBCRARC(I)=FBADJGE_U_FBADJRE_U_FBADJAE_U
  1. . . S FBRRMKI=FBRRMK(FBADJRI,J)
  1. . . S FBRRMKE=$S(FBRRMKI:$P($G(^FB(161.93,FBRRMKI,0)),U),1:"")
  1. . . S FBCRARC(I)=FBCRARC(I)_FBRRMKE_U
  1. Q
  1. ;