source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAUTL2.m@ 1154

FBAAUTL2 ;AISC/GRR-FEE UTILITY ROUTINE ;19APR90
 ;;3.5;FEE BASIS;**8**;JAN 30, 1995
 ;;Per VHA Directive 10-93-142, 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
 S (FBTT,POV)="" Q:'$D(^FBAAC(K,1,L,1,M,0))  S POV(0)=$P(^(0),"^",4) Q:POV(0)=""
 Q:'$D(^FBAAA(K,1,POV(0),0))  S POV=$P(^(0),"^",7),FBTT=$P(^(0),"^",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))