BMCVDV2 ; IHS/OIT/FCJ - YTD PAID VENDOR INFO BY FY ;
;;4.0;REFERRED CARE INFO SYSTEM;**5**;JAN 09, 2006;Build 101
;BMC*4.0*5 5.13.2009 IHS.OIT.FCJ ORIGIAL ROUTINE FR ACHSVDV2
;
N BMCIEN
S BMCIEN=$O(^BMCVPMT(DUZ(2),1,"B",BMCPROV,0))
I 'BMCIEN W !!,"None on file." Q
I '$D(^BMCVPMT(DUZ(2),1,BMCIEN,1,0)) W !!,"None on file." Q
;
W !!,"FISCAL YEAR",?16,"A M O U N T",?30,"LAST PMT DATE",!!
F BMC=0:0 S BMC=$O(^BMCVPMT(DUZ(2),1,BMCIEN,1,BMC)) Q:'BMC W ?2,BMC,?14,"$",$J($FN($P(^(BMC,0),U,2),",",2),12),?30,$$FMTE^XLFDT($P(^(0),U,3)),!
Q
;
AGRDSP ;EP
G:'$D(^AUTTVNDR(BMCPROV,18,"AGR",BMCAGTP)) AGRNEW
D HDR
S R="",BMCI=0
K BMCAGRL
AGRDSP1 ;
S R=$O(^AUTTVNDR(BMCPROV,18,"AGR",BMCAGTP,R))
G AGRDSPZ:+R=0
A2A ;
S BMCI=BMCI+1,BMCAGRL(BMCI)=R
W !,$J(BMCI,2),?3,BMCAGTP,?9,$E($P(^AUTTVNDR(BMCPROV,18,R,0),U,1),1,2),$S(BMCAGTP="BPA":"-A-",BMCAGTP="PA":"-PA-",BMCAGTP="RQ":"-R-",1:"")
S X=$E($P(^AUTTVNDR(BMCPROV,18,R,0),U,1),3,6)
I BMCAGTP="PA" W $E(X,2,4) G A2C
W $E(X,1,4)
A2C ;
W ?20,$$MDY($P(^AUTTVNDR(BMCPROV,18,R,0),U,8)),?30,$$MDY($P(^AUTTVNDR(BMCPROV,18,R,0),U,9))
S X=$P(^AUTTVNDR(BMCPROV,18,R,0),U,4)
I X="",($P(^AUTTVNDR(BMCPROV,18,R,0),U,2)="") G A2D
S Y=$S(X="Y":"YES",X="N":" NO",1:" ")
I Y=" ",($P(^AUTTVNDR(BMCPROV,18,R,0),U,2)="") G A2D
S Y=Y_" INP: "
S:$P(^AUTTVNDR(BMCPROV,18,R,0),U,2)'="" Y=Y_$P(^(0),U,2)
W ?40,Y,!
A2D ;
S X=$P(^AUTTVNDR(BMCPROV,18,R,0),U,5)
I X="",($P(^AUTTVNDR(BMCPROV,18,R,0),U,3)="") G A2E
S Y=$S(X="Y":"YES",X="N":" NO",1:" ")
I Y=" ",($P(^AUTTVNDR(BMCPROV,18,R,0),U,3)="") G A2E
S Y=Y_" OUT: "
S:$P(^AUTTVNDR(BMCPROV,18,R,0),U,3)'="" Y=Y_$P(^(0),U,3)
W ?40,Y,!
A2E ;
W:$P(^AUTTVNDR(BMCPROV,18,R,0),U,7)'="" ?45,"PRO: ",$P(^(0),U,7),!
G AGRDSP1
;
AGRDSPZ ;
Q:$D(BMCRQFL)!$D(BMCPAFL)!$D(BMCBPFL)
AGRSEL ;
S DA=""
S Y=$$DIR^XBDIR("NO^1:"_BMCI,"Enter # to Edit","","","","",2)
Q:$D(DUOUT)!$D(DTOUT)
I Y="" G AGRNEW
S DA=BMCAGRL(+Y)
Q
;
AGRNEW ;ADD NEW AGREEMENT INFORMATION HERE
Q:'$D(^XUSEC("BMCZVEN",DUZ))
S Y=$$DIR^XBDIR("Y","Want to enter a new Vendor "_$S(BMCAGTP="RQ":"RATE QUOTATION",BMCAGTP="PA":"PROVIDER AGREEMENT",BMCAGTP="BPA":"BLANKET PURCHASE AGREEMENT",1:" "),"N","","","",2)
Q:$D(DTOUT)!$D(DUOUT)
I 'Y S DA="" W @IOF Q
S:'$D(^AUTTVNDR(BMCPROV,18,0)) ^AUTTVNDR(BMCPROV,18,0)=$$ZEROTH^BMC(9999999.11,1801)
S DIC="^AUTTVNDR("_BMCPROV_",18,",DIC(0)="QAZEML",DA(1)=BMCPROV,DIC("W")="W "" "",$P(^(0),U,10)"
D ^DIC
Q:+Y<1
S DA(1)=BMCPROV,DA=+Y
W !
K DIE,DR
S DIE("NO^")="",DIE=DIC,DR=".11///^S X=BMCAGTP;.02;.04;.03;.05;.07;.06;.08;.09"
D ^DIE
K DIE
D AGRDSP
Q
;
HDR ;
W !!," #",?3,"Type",?9,"Number",?20,"Eff-Date",?30,"Exp-Date",?40,"MCR",?45,"Description",!?3,"----",?9,"---------",?20,"--------",?30,"--------",?40,"---",?45,"----------------------------"
Q
;
MDY(X) ;
Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
;
BMCVDV2 ; IHS/OIT/FCJ - YTD PAID VENDOR INFO BY FY ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**5**;JAN 09, 2006;Build 101
+2 ;BMC*4.0*5 5.13.2009 IHS.OIT.FCJ ORIGIAL ROUTINE FR ACHSVDV2
+3 ;
+4 NEW BMCIEN
+5 SET BMCIEN=$ORDER(^BMCVPMT(DUZ(2),1,"B",BMCPROV,0))
+6 IF 'BMCIEN
WRITE !!,"None on file."
QUIT
+7 IF '$DATA(^BMCVPMT(DUZ(2),1,BMCIEN,1,0))
WRITE !!,"None on file."
QUIT
+8 ;
+9 WRITE !!,"FISCAL YEAR",?16,"A M O U N T",?30,"LAST PMT DATE",!!
+10 FOR BMC=0:0
SET BMC=$ORDER(^BMCVPMT(DUZ(2),1,BMCIEN,1,BMC))
IF 'BMC
QUIT
WRITE ?2,BMC,?14,"$",$JUSTIFY($FNUMBER($PIECE(^(BMC,0),U,2),",",2),12),?30,$$FMTE^XLFDT($PIECE(^(0),U,3)),!
+11 QUIT
+12 ;
AGRDSP ;EP
+1 IF '$DATA(^AUTTVNDR(BMCPROV,18,"AGR",BMCAGTP))
GOTO AGRNEW
+2 DO HDR
+3 SET R=""
SET BMCI=0
+4 KILL BMCAGRL
AGRDSP1 ;
+1 SET R=$ORDER(^AUTTVNDR(BMCPROV,18,"AGR",BMCAGTP,R))
+2 IF +R=0
GOTO AGRDSPZ
A2A ;
+1 SET BMCI=BMCI+1
SET BMCAGRL(BMCI)=R
+2 WRITE !,$JUSTIFY(BMCI,2),?3,BMCAGTP,?9,$EXTRACT($PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,1),1,2),$SELECT(BMCAGTP="BPA":"-A-",BMCAGTP="PA":"-PA-",BMCAGTP="RQ":"-R-",1:"")
+3 SET X=$EXTRACT($PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,1),3,6)
+4 IF BMCAGTP="PA"
WRITE $EXTRACT(X,2,4)
GOTO A2C
+5 WRITE $EXTRACT(X,1,4)
A2C ;
+1 WRITE ?20,$$MDY($PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,8)),?30,$$MDY($PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,9))
+2 SET X=$PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,4)
+3 IF X=""
IF ($PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,2)="")
GOTO A2D
+4 SET Y=$SELECT(X="Y":"YES",X="N":" NO",1:" ")
+5 IF Y=" "
IF ($PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,2)="")
GOTO A2D
+6 SET Y=Y_" INP: "
+7 IF $PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,2)'=""
SET Y=Y_$PIECE(^(0),U,2)
+8 WRITE ?40,Y,!
A2D ;
+1 SET X=$PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,5)
+2 IF X=""
IF ($PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,3)="")
GOTO A2E
+3 SET Y=$SELECT(X="Y":"YES",X="N":" NO",1:" ")
+4 IF Y=" "
IF ($PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,3)="")
GOTO A2E
+5 SET Y=Y_" OUT: "
+6 IF $PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,3)'=""
SET Y=Y_$PIECE(^(0),U,3)
+7 WRITE ?40,Y,!
A2E ;
+1 IF $PIECE(^AUTTVNDR(BMCPROV,18,R,0),U,7)'=""
WRITE ?45,"PRO: ",$PIECE(^(0),U,7),!
+2 GOTO AGRDSP1
+3 ;
AGRDSPZ ;
+1 IF $DATA(BMCRQFL)!$DATA(BMCPAFL)!$DATA(BMCBPFL)
QUIT
AGRSEL ;
+1 SET DA=""
+2 SET Y=$$DIR^XBDIR("NO^1:"_BMCI,"Enter # to Edit","","","","",2)
+3 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+4 IF Y=""
GOTO AGRNEW
+5 SET DA=BMCAGRL(+Y)
+6 QUIT
+7 ;
AGRNEW ;ADD NEW AGREEMENT INFORMATION HERE
+1 IF '$DATA(^XUSEC("BMCZVEN",DUZ))
QUIT
+2 SET Y=$$DIR^XBDIR("Y","Want to enter a new Vendor "_$SELECT(BMCAGTP="RQ":"RATE QUOTATION",BMCAGTP="PA":"PROVIDER AGREEMENT",BMCAGTP="BPA":"BLANKET PURCHASE AGREEMENT",1:" "),"N","","","",2)
+3 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+4 IF 'Y
SET DA=""
WRITE @IOF
QUIT
+5 IF '$DATA(^AUTTVNDR(BMCPROV,18,0))
SET ^AUTTVNDR(BMCPROV,18,0)=$$ZEROTH^BMC(9999999.11,1801)
+6 SET DIC="^AUTTVNDR("_BMCPROV_",18,"
SET DIC(0)="QAZEML"
SET DA(1)=BMCPROV
SET DIC("W")="W "" "",$P(^(0),U,10)"
+7 DO ^DIC
+8 IF +Y<1
QUIT
+9 SET DA(1)=BMCPROV
SET DA=+Y
+10 WRITE !
+11 KILL DIE,DR
+12 SET DIE("NO^")=""
SET DIE=DIC
SET DR=".11///^S X=BMCAGTP;.02;.04;.03;.05;.07;.06;.08;.09"
+13 DO ^DIE
+14 KILL DIE
+15 DO AGRDSP
+16 QUIT
+17 ;
HDR ;
+1 WRITE !!," #",?3,"Type",?9,"Number",?20,"Eff-Date",?30,"Exp-Date",?40,"MCR",?45,"Description",!?3,"----",?9,"---------",?20,"--------",?30,"--------",?40,"---",?45,"----------------------------"
+2 QUIT
+3 ;
MDY(X) ;
+1 QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+2 ;
