FBAAUTL2 ;AISC/GRR - FEE UTILITY ROUTINE ;9/21/14 21:48
;;3.5;FEE BASIS;**8,143,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
CONDAT ;called from input transform in 161.21,.02-.03
S (FBOUT,Z)=0
F S Z=$O(^FBAA(161.21,"C",+$G(FBVIEN),Z)) Q:'Z I $P($G(^FBAA(161.21,Z,0)),U,2) S Z(0)=^(0),FBVCON($P(Z(0),U,2))=$P(Z(0),U,3)
K FBVCON(+$P(^FBAA(161.21,DA,0),U,2))
S Z=0 F S Z=$O(FBVCON(Z)) Q:Z'>0!(FBOUT) I X'<Z&(X'>FBVCON(Z)) S FBOUT=1 W !,*7,"Date entered overlaps existing contract dates!",! K X,Z,FBVCON Q
K Z,FBVCON
Q
DATES ;ASK FROM AND TO DATES AND ENSURE THEY DO NOT OVERLAP PRIOR AUTHORIZATIONS
;variables FBO and FB1 are set in FBNHEDAT as default dates
S FBFLAG=1 K FBAUT
FDAT S (FBBEGDT,FBENDDT)="",%DT("A")="Select FROM DATE: ",%DT="AEX" S:$S($G(FBO):1,1:0) %DT("B")=$$FMTE^XLFDT(FBO,1) D ^%DT G:Y'>0 END S FBBEGDT=Y
G:FBFLAG=2 EN1
EDAT S FBOUT=0,%DT("A")="Select TO DATE: ",%DT="AEX",%DT(0)=FBBEGDT S:$S($G(FB1):1,1:0) %DT("B")=$$FMTE^XLFDT(FB1,1) D ^%DT K %DT(0) G:Y'>0 END S FBENDDT=Y
EN1 ;CHECK WHETHER AUTHORIZATION FROM DATE OVERLAPS PREVIOUS ENTRIES
S (FBOUT,FBLG)=0 F Z=0:0 S Z=$O(^FBAAA(DFN,1,Z)) Q:Z'>0 I $D(^(Z,0)) S Z(0)=^(0) I $P(Z(0),"^",3)=FBPROG S FBAUT($P(Z(0),"^"))=$P(Z(0),"^",2)
I $G(FBO),($G(FB1)),($G(FBAUT(FBO))=FB1) K FBAUT(FBO)
F Z=0:0 S Z=$O(FBAUT(Z)) Q:Z'>0!(FBOUT) D CHKDT:FBFLAG=1,CHKBO:FBFLAG=2,ERRD:FBLG>0
I FBOUT S FBOUT=0 G:FBLG>0&(FBFLAG=1) FDAT
Q
END S (FBBEGDT,FBENDDT)="" K Z,FBAUT,FBOUT,FBLG Q
CHKDT I FBBEGDT<Z&(FBENDDT<Z) S FBLG=0,FBOUT=1 Q
I FBBEGDT<Z&(FBENDDT'<Z) S FBLG=2,FBOUT=1 Q
I FBPROG=7,FBAUT(Z)>DT S FBLG=0,FBOUT=1,FBBEGDT="" K FBAUT W !!?5,"There already is an active CNH authorization on file.",!?5,"Use the 'Edit CNH Authorization' option.",! Q
I FBPROG=7,FBBEGDT=FBAUT(Z) Q
CHKBO I FBBEGDT'<Z&(FBBEGDT'>FBAUT(Z)) S FBLG=1,FBOUT=1 Q
Q
ERRD W !,*7,$S(FBLG=1:"FROM ",1:"TO "),"DATE entered overlaps a previous Authorization!",!
Q
;
UPDT ;UPDATE BATCH STATUS
S DA=J,(DIC,DIE)="^FBAA(161.7,",DR="11////^S X=FBSTAT;12////^S X=DT" D ^DIE Q
Q
;
PAT S FBSSN=$P(Y(0),"^",9) S:$L(FBSSN)=9 FBSSN=FBSSN_" " S FBSEX=$P(Y(0),"^",2),FBSEX=$S(FBSEX="F":FBSEX,1:"M")
S FBDOB=$P(Y(0),"^",3),FBDOB=$S(FBDOB="":" ",1:$E(FBDOB,4,7)_($E(FBDOB,1,3)+1700))
S FBNAME=$P(Y(0),"^",1),FBLNAM=$E($P(FBNAME,",",1),1,5),FBFLNAM=$E($P(FBNAME,",",1),1,21),FBFLNAM=FBFLNAM_$E(PAD,$L(FBFLNAM)+1,21)
S:$L(FBLNAM)<5 FBLNAM=FBLNAM_$E(" ",$L(FBLNAM)+1,5)
S FBFI=$E($P(FBNAME,",",2),1),FBMI=$P(FBNAME,",",2),A=$F(FBMI," "),FBMI=$S(A<1:" ",1:$E(FBMI,A)),FBMI=$S(FBMI="":" ",1:FBMI)
Q
;
ASKVOK S DIR(0)="Y",DIR("A")="Is this the correct vendor",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT) VENOUT S:'Y FBVENO=1
Q
VENOUT S FBVENOT=1 K DIRUT Q
;
FBPH W ! S DIR("A")="Want to review fee pharmacy payment history",DIR("B")="No",DIR(0)="Y" D ^DIR K DIR
I Y,$D(DFN),$D(^DPT(+DFN,0)) S N=$P(^(0),"^"),FBHDFN=DFN N FBAAOUT D LIST^FBAAPPH S DFN=FBHDFN K FBHDFN
Q
PRPRDT D NOW^%DTC S Y=% X ^DD("DD") W ?60,Y
Q
IFCAP S PRCF("X")="S" D ^PRCFSITE S PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:"") I PRC("SITE")="" S FBERR(1)=1 Q
S FB("SITE")=PRC("SITE")
Q
POV ;GET POV/TREATMENT TYPE FROM 161 FOR TRANSMISSION OF PAYMENTS
; in K, L, M, N - IENs for File 162 service provided multiple
; out POV - purpose of visit (internal pointer) or null
; out FBTT - treatment type (internal code) or null
S (FBTT,POV)=""
N FTP
S FTP=$P($G(^FBAAC(K,1,L,1,M,1,N,3)),U,9)
I FTP D
. N FBY
. S FBY=$G(^FBAAA(K,1,FTP,0))
. S POV=$P(FBY,"^",7)
. S FBTT=$P(FBY,"^",13)
Q
XREF ;SET X-REF FOR PRINT AUTHORIZATION FIELD (161.01,1)
Q:'$D(^FBAAA(DA(1),1,DA,0)) N FBZZ S FBZZ(0)=^(0),FBZZ(1)=$P(FBZZ(0),"^",3)
S FBZZ(2)=$S(FBZZ(1)=2:"",FBZZ(1)=3:"",FBZZ(1)=11:"",1:1) I FBZZ(2) S ZZZ="" Q
S ZZZ=$P(FBZZ(0),"^",13),ZZZ=$S(ZZZ=1:$P(FBZZ(0),"^"),ZZZ=2:$P(FBZZ(0),"^"),ZZZ=3:$S($D(^FBAAA(DA(1),4)):$P(^(4),"^",2),1:""),1:"")
Q
ADD S ZZZ="" D XREF Q:ZZZ="" S ^FBAAA("AF",$P(^FBAAA(DA(1),1,DA,0),"^",3),ZZZ,DA(1),DA)=""
Q
KILL S ZZZ="" D XREF Q:ZZZ="" K ^FBAAA("AF",$P(^FBAAA(DA(1),1,DA,0),"^",3),ZZZ,DA(1),DA)
Q
;
VER(X) ;determine version of a file based on DD node
;X= file number
Q $S('X:0,1:+$P($G(^DD(X,0,"VR")),U))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAUTL2 4294 printed Dec 13, 2024@01:56:47 Page 2
FBAAUTL2 ;AISC/GRR - FEE UTILITY ROUTINE ;9/21/14 21:48
+1 ;;3.5;FEE BASIS;**8,143,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
CONDAT ;called from input transform in 161.21,.02-.03
+1 SET (FBOUT,Z)=0
+2 FOR
SET Z=$ORDER(^FBAA(161.21,"C",+$GET(FBVIEN),Z))
if 'Z
QUIT
IF $PIECE($GET(^FBAA(161.21,Z,0)),U,2)
SET Z(0)=^(0)
SET FBVCON($PIECE(Z(0),U,2))=$PIECE(Z(0),U,3)
+3 KILL FBVCON(+$PIECE(^FBAA(161.21,DA,0),U,2))
+4 SET Z=0
FOR
SET Z=$ORDER(FBVCON(Z))
if Z'>0!(FBOUT)
QUIT
IF X'<Z&(X'>FBVCON(Z))
SET FBOUT=1
WRITE !,*7,"Date entered overlaps existing contract dates!",!
KILL X,Z,FBVCON
QUIT
+5 KILL Z,FBVCON
+6 QUIT
DATES ;ASK FROM AND TO DATES AND ENSURE THEY DO NOT OVERLAP PRIOR AUTHORIZATIONS
+1 ;variables FBO and FB1 are set in FBNHEDAT as default dates
+2 SET FBFLAG=1
KILL FBAUT
FDAT SET (FBBEGDT,FBENDDT)=""
SET %DT("A")="Select FROM DATE: "
SET %DT="AEX"
if $SELECT($GET(FBO)
SET %DT("B")=$$FMTE^XLFDT(FBO,1)
DO ^%DT
if Y'>0
GOTO END
SET FBBEGDT=Y
+1 if FBFLAG=2
GOTO EN1
EDAT SET FBOUT=0
SET %DT("A")="Select TO DATE: "
SET %DT="AEX"
SET %DT(0)=FBBEGDT
if $SELECT($GET(FB1)
SET %DT("B")=$$FMTE^XLFDT(FB1,1)
DO ^%DT
KILL %DT(0)
if Y'>0
GOTO END
SET FBENDDT=Y
EN1 ;CHECK WHETHER AUTHORIZATION FROM DATE OVERLAPS PREVIOUS ENTRIES
+1 SET (FBOUT,FBLG)=0
FOR Z=0:0
SET Z=$ORDER(^FBAAA(DFN,1,Z))
if Z'>0
QUIT
IF $DATA(^(Z,0))
SET Z(0)=^(0)
IF $PIECE(Z(0),"^",3)=FBPROG
SET FBAUT($PIECE(Z(0),"^"))=$PIECE(Z(0),"^",2)
+2 IF $GET(FBO)
IF ($GET(FB1))
IF ($GET(FBAUT(FBO))=FB1)
KILL FBAUT(FBO)
+3 FOR Z=0:0
SET Z=$ORDER(FBAUT(Z))
if Z'>0!(FBOUT)
QUIT
if FBFLAG=1
DO CHKDT
if FBFLAG=2
DO CHKBO
if FBLG>0
DO ERRD
+4 IF FBOUT
SET FBOUT=0
if FBLG>0&(FBFLAG=1)
GOTO FDAT
+5 QUIT
END SET (FBBEGDT,FBENDDT)=""
KILL Z,FBAUT,FBOUT,FBLG
QUIT
CHKDT IF FBBEGDT<Z&(FBENDDT<Z)
SET FBLG=0
SET FBOUT=1
QUIT
+1 IF FBBEGDT<Z&(FBENDDT'<Z)
SET FBLG=2
SET FBOUT=1
QUIT
+2 IF FBPROG=7
IF FBAUT(Z)>DT
SET FBLG=0
SET FBOUT=1
SET FBBEGDT=""
KILL FBAUT
WRITE !!?5,"There already is an active CNH authorization on file.",!?5,"Use the 'Edit CNH Authorization' option.",!
QUIT
+3 IF FBPROG=7
IF FBBEGDT=FBAUT(Z)
QUIT
CHKBO IF FBBEGDT'<Z&(FBBEGDT'>FBAUT(Z))
SET FBLG=1
SET FBOUT=1
QUIT
+1 QUIT
ERRD WRITE !,*7,$SELECT(FBLG=1:"FROM ",1:"TO "),"DATE entered overlaps a previous Authorization!",!
+1 QUIT
+2 ;
UPDT ;UPDATE BATCH STATUS
+1 SET DA=J
SET (DIC,DIE)="^FBAA(161.7,"
SET DR="11////^S X=FBSTAT;12////^S X=DT"
DO ^DIE
QUIT
+2 QUIT
+3 ;
PAT SET FBSSN=$PIECE(Y(0),"^",9)
if $LENGTH(FBSSN)=9
SET FBSSN=FBSSN_" "
SET FBSEX=$PIECE(Y(0),"^",2)
SET FBSEX=$SELECT(FBSEX="F":FBSEX,1:"M")
+1 SET FBDOB=$PIECE(Y(0),"^",3)
SET FBDOB=$SELECT(FBDOB="":" ",1:$EXTRACT(FBDOB,4,7)_($EXTRACT(FBDOB,1,3)+1700))
+2 SET FBNAME=$PIECE(Y(0),"^",1)
SET FBLNAM=$EXTRACT($PIECE(FBNAME,",",1),1,5)
SET FBFLNAM=$EXTRACT($PIECE(FBNAME,",",1),1,21)
SET FBFLNAM=FBFLNAM_$EXTRACT(PAD,$LENGTH(FBFLNAM)+1,21)
+3 if $LENGTH(FBLNAM)<5
SET FBLNAM=FBLNAM_$EXTRACT(" ",$LENGTH(FBLNAM)+1,5)
+4 SET FBFI=$EXTRACT($PIECE(FBNAME,",",2),1)
SET FBMI=$PIECE(FBNAME,",",2)
SET A=$FIND(FBMI," ")
SET FBMI=$SELECT(A<1:" ",1:$EXTRACT(FBMI,A))
SET FBMI=$SELECT(FBMI="":" ",1:FBMI)
+5 QUIT
+6 ;
ASKVOK SET DIR(0)="Y"
SET DIR("A")="Is this the correct vendor"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO VENOUT
if 'Y
SET FBVENO=1
+1 QUIT
VENOUT SET FBVENOT=1
KILL DIRUT
QUIT
+1 ;
FBPH WRITE !
SET DIR("A")="Want to review fee pharmacy payment history"
SET DIR("B")="No"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
+1 IF Y
IF $DATA(DFN)
IF $DATA(^DPT(+DFN,0))
SET N=$PIECE(^(0),"^")
SET FBHDFN=DFN
NEW FBAAOUT
DO LIST^FBAAPPH
SET DFN=FBHDFN
KILL FBHDFN
+2 QUIT
PRPRDT DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
WRITE ?60,Y
+1 QUIT
IFCAP SET PRCF("X")="S"
DO ^PRCFSITE
SET PRC("SITE")=$SELECT($DATA(PRC("SITE")):PRC("SITE"),1:"")
IF PRC("SITE")=""
SET FBERR(1)=1
QUIT
+1 SET FB("SITE")=PRC("SITE")
+2 QUIT
POV ;GET POV/TREATMENT TYPE FROM 161 FOR TRANSMISSION OF PAYMENTS
+1 ; in K, L, M, N - IENs for File 162 service provided multiple
+2 ; out POV - purpose of visit (internal pointer) or null
+3 ; out FBTT - treatment type (internal code) or null
+4 SET (FBTT,POV)=""
+5 NEW FTP
+6 SET FTP=$PIECE($GET(^FBAAC(K,1,L,1,M,1,N,3)),U,9)
+7 IF FTP
Begin DoDot:1
+8 NEW FBY
+9 SET FBY=$GET(^FBAAA(K,1,FTP,0))
+10 SET POV=$PIECE(FBY,"^",7)
+11 SET FBTT=$PIECE(FBY,"^",13)
End DoDot:1
+12 QUIT
XREF ;SET X-REF FOR PRINT AUTHORIZATION FIELD (161.01,1)
+1 if '$DATA(^FBAAA(DA(1),1,DA,0))
QUIT
NEW FBZZ
SET FBZZ(0)=^(0)
SET FBZZ(1)=$PIECE(FBZZ(0),"^",3)
+2 SET FBZZ(2)=$SELECT(FBZZ(1)=2:"",FBZZ(1)=3:"",FBZZ(1)=11:"",1:1)
IF FBZZ(2)
SET ZZZ=""
QUIT
+3 SET ZZZ=$PIECE(FBZZ(0),"^",13)
SET ZZZ=$SELECT(ZZZ=1:$PIECE(FBZZ(0),"^"),ZZZ=2:$PIECE(FBZZ(0),"^"),ZZZ=3:$SELECT($DATA(^FBAAA(DA(1),4)):$PIECE(^(4),"^",2),1:""),1:"")
+4 QUIT
ADD SET ZZZ=""
DO XREF
if ZZZ=""
QUIT
SET ^FBAAA("AF",$PIECE(^FBAAA(DA(1),1,DA,0),"^",3),ZZZ,DA(1),DA)=""
+1 QUIT
KILL SET ZZZ=""
DO XREF
if ZZZ=""
QUIT
KILL ^FBAAA("AF",$PIECE(^FBAAA(DA(1),1,DA,0),"^",3),ZZZ,DA(1),DA)
+1 QUIT
+2 ;
VER(X) ;determine version of a file based on DD node
+1 ;X= file number
+2 QUIT $SELECT('X:0,1:+$PIECE($GET(^DD(X,0,"VR")),U))
