- 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 Jan 18, 2025@02:58 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))