BMCVURT ; IHS/OIT/FCJ - SELECT/DISPLAY RATE QUOTATIONS ;
;;4.0;REFERRED CARE INFO SYSTEM;**5**;JAN 09, 2006;Build 101
;BMC*4.0*5 IHS.OIT.FCJ ORIGIAL ROUTINE FR ACHSURT
;
A1 ;EP
S BMCI=""
S:'$D(BMCCTNA) BMCCTNA=0
A1A ;
S BMCI=$O(^AUTTVNDR(BMCPROV,18,"AGR",BMCI))
Q:BMCI=""
S BMCJ=""
A1C ;
S BMCJ=$O(^AUTTVNDR(BMCPROV,18,"AGR",BMCI,BMCJ))
G A1A:BMCJ=""
S X=$G(^AUTTVNDR(BMCPROV,18,BMCJ,0)) ;GET 'AGREEMENT/RATE/BPA NUMBER NODE
S:'$D(BMCRT(BMCI)) BMCRT(BMCI)=0
S BMCRT(BMCI)=BMCRT(BMCI)+1
;
;IF 'EFFECTIVE DATE' > EST. DATE OF SERVICE
;OR EST. DATE OF SERVICE > 'EXPIRATION DATE'
I ($P(X,U,8)>BMCEDOS)!(BMCEDOS>$P(X,U,9)) G A1C
A1D ;
S BMCCTNA=BMCCTNA+1
S BMCRT(BMCCTNA)=X
S:'$D(BMCRT(BMCI,"ACTIVE")) BMCRT(BMCI,"ACTIVE")=0
S BMCRT(BMCI,"ACTIVE")=$G(BMCRT(BMCI,"ACTIVE"))+1
S:'$D(BMCRT(0,"ACTIVE")) BMCRT(0,"ACTIVE")=0
S BMCRT(0,"ACTIVE")=BMCRT(0,"ACTIVE")+1
S BMCRT(BMCI)=$G(BMCRT(BMCI))+1
S X=$P(BMCRT(BMCCTNA),U,6),Y=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3),$P(BMCRT(BMCCTNA),U,6)=Y
S X=$P(BMCRT(BMCCTNA),U,8),Y=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3),$P(BMCRT(BMCCTNA),U,8)=Y
S X=$P(BMCRT(BMCCTNA),U,9),Y=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3),$P(BMCRT(BMCCTNA),U,9)=Y
S $P(BMCRT(BMCCTNA),U,11)=BMCJ
G A1C
;
A2 ;EP
I BMCCTNA=1 S BMCAGRN=1,BMCAGRP=$P(BMCRT(BMCCTNA),U,11) G A2A
G A3:'BMCAGRN
A2A ;
W !!,"Enter Corresponding CONTRACT, AGREEMENT OR RATE QUOTE #. "
I BMCAGRN,$D(BMCRT(BMCAGRN)) S BMCI=BMCAGRN,BMCJ=$P(BMCRT(BMCAGRN),U,10) D NODISP W Y,"// "
D READ^BMC
G:(Y?1"?".E)!(Y="?") A3
I Y="@" S (BMCAGRN,BMCAGRP)="" W " DELETED" Q
S Y=$E(Y)
Q:$D(DUOUT)!$D(DTOUT)!(Y="")
I (Y>BMCCTNA)!(Y<1) W !!,"Please enter 1 thru "_BMCCTNA_" " G A2A
S BMCAGRN=+Y,BMCAGRP=$P(BMCRT(+Y),U,11),BMCCONP=""
S:$P(BMCRT(+Y),U,10)="CNT" BMCCONP=BMCAGRP,BMCAGRP=""
G A2A
;
A3 ;
D HDR:'$D(BMCAHDR)
S BMCI=C
I BMCCTNA>C S BMCI=0
A3B ;
S BMCI=$O(BMCRT(BMCI))
G A2A:+BMCI=0
S BMCJ=$P(BMCRT(BMCI),U,10)
W !,$J(BMCI,2),?3,BMCJ
D NODISP ;BPA AGREEMENT NUMBER DISPLAY
W ?9,Y
A3C ;
W ?20,$P(BMCRT(BMCI),U,8),?30,$P(BMCRT(BMCI),U,9)
I BMCJ="CNT" W ?45,$P(BMCRT(BMCI),U,2),! G A3B
S X=$P(BMCRT(BMCI),U,4)
I X="",($P(BMCRT(BMCI),U,2)="") G A3D
S Y=$S(X="Y":"YES",X="N":" NO",1:" ")
I Y=" ",$P(BMCRT(BMCI),U,2)="" G A3D
S Y=Y_" INP: "
S:$P(BMCRT(BMCI),U,2)'="" Y=Y_$P(BMCRT(BMCI),U,2)
W ?40,Y,!
A3D ;
S X=$P(BMCRT(BMCI),U,5)
I X=""&($P(BMCRT(BMCI),U,3)="") G A3E
S Y=$S(X="Y":"YES",X="N":" NO",1:" ")
I Y=" ",$P(BMCRT(BMCI),U,3)="" G A3E
S Y=Y_" OUT: "
S:$P(BMCRT(BMCI),U,3)'="" Y=Y_$P(BMCRT(BMCI),U,3)
W ?40,Y,!
A3E ;
W:$P(BMCRT(BMCI),U,7)'="" ?45,"PRO: ",$P(BMCRT(BMCI),U,7),!
G A3B
;
EXIT ;
K Y,X,BMCCT
Q
;
HDR ;
W !!," #",?3,"Type",?9,"Number",?20,"Eff-Date",?30,"Exp-Date",?40,"MCR",?45,"Description",!?3,"----",?9,"---------",?20,"--------",?30,"--------",?40,"---",?45,"----------------------------"
Q
;
NODISP ;DISPLAY BPA AGREEMENT STUFF
S Y=""
I BMCJ="CNT" S Y=$P(BMCRT(BMCI),U) Q
S Y=$E($P(BMCRT(BMCI),U),1,2)_$S(BMCJ="BPA":"-A-",BMCJ="PA":"-PA-",BMCJ="RQ":"-R-",1:"")
S X=$E($P(BMCRT(BMCI),U),3,6)
I BMCJ="PA" S Y=Y_$E(X,2,4) Q
S Y=Y_$E(X,1,4)
Q
;
BMCVURT ; IHS/OIT/FCJ - SELECT/DISPLAY RATE QUOTATIONS ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**5**;JAN 09, 2006;Build 101
+2 ;BMC*4.0*5 IHS.OIT.FCJ ORIGIAL ROUTINE FR ACHSURT
+3 ;
A1 ;EP
+1 SET BMCI=""
+2 IF '$DATA(BMCCTNA)
SET BMCCTNA=0
A1A ;
+1 SET BMCI=$ORDER(^AUTTVNDR(BMCPROV,18,"AGR",BMCI))
+2 IF BMCI=""
QUIT
+3 SET BMCJ=""
A1C ;
+1 SET BMCJ=$ORDER(^AUTTVNDR(BMCPROV,18,"AGR",BMCI,BMCJ))
+2 IF BMCJ=""
GOTO A1A
+3 ;GET 'AGREEMENT/RATE/BPA NUMBER NODE
SET X=$GET(^AUTTVNDR(BMCPROV,18,BMCJ,0))
+4 IF '$DATA(BMCRT(BMCI))
SET BMCRT(BMCI)=0
+5 SET BMCRT(BMCI)=BMCRT(BMCI)+1
+6 ;
+7 ;IF 'EFFECTIVE DATE' > EST. DATE OF SERVICE
+8 ;OR EST. DATE OF SERVICE > 'EXPIRATION DATE'
+9 IF ($PIECE(X,U,8)>BMCEDOS)!(BMCEDOS>$PIECE(X,U,9))
GOTO A1C
A1D ;
+1 SET BMCCTNA=BMCCTNA+1
+2 SET BMCRT(BMCCTNA)=X
+3 IF '$DATA(BMCRT(BMCI,"ACTIVE"))
SET BMCRT(BMCI,"ACTIVE")=0
+4 SET BMCRT(BMCI,"ACTIVE")=$GET(BMCRT(BMCI,"ACTIVE"))+1
+5 IF '$DATA(BMCRT(0,"ACTIVE"))
SET BMCRT(0,"ACTIVE")=0
+6 SET BMCRT(0,"ACTIVE")=BMCRT(0,"ACTIVE")+1
+7 SET BMCRT(BMCI)=$GET(BMCRT(BMCI))+1
+8 SET X=$PIECE(BMCRT(BMCCTNA),U,6)
SET Y=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)
SET $PIECE(BMCRT(BMCCTNA),U,6)=Y
+9 SET X=$PIECE(BMCRT(BMCCTNA),U,8)
SET Y=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)
SET $PIECE(BMCRT(BMCCTNA),U,8)=Y
+10 SET X=$PIECE(BMCRT(BMCCTNA),U,9)
SET Y=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)
SET $PIECE(BMCRT(BMCCTNA),U,9)=Y
+11 SET $PIECE(BMCRT(BMCCTNA),U,11)=BMCJ
+12 GOTO A1C
+13 ;
A2 ;EP
+1 IF BMCCTNA=1
SET BMCAGRN=1
SET BMCAGRP=$PIECE(BMCRT(BMCCTNA),U,11)
GOTO A2A
+2 IF 'BMCAGRN
GOTO A3
A2A ;
+1 WRITE !!,"Enter Corresponding CONTRACT, AGREEMENT OR RATE QUOTE #. "
+2 IF BMCAGRN
IF $DATA(BMCRT(BMCAGRN))
SET BMCI=BMCAGRN
SET BMCJ=$PIECE(BMCRT(BMCAGRN),U,10)
DO NODISP
WRITE Y,"// "
+3 DO READ^BMC
+4 IF (Y?1"?".E)!(Y="?")
GOTO A3
+5 IF Y="@"
SET (BMCAGRN,BMCAGRP)=""
WRITE " DELETED"
QUIT
+6 SET Y=$EXTRACT(Y)
+7 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y="")
QUIT
+8 IF (Y>BMCCTNA)!(Y<1)
WRITE !!,"Please enter 1 thru "_BMCCTNA_" "
GOTO A2A
+9 SET BMCAGRN=+Y
SET BMCAGRP=$PIECE(BMCRT(+Y),U,11)
SET BMCCONP=""
+10 IF $PIECE(BMCRT(+Y),U,10)="CNT"
SET BMCCONP=BMCAGRP
SET BMCAGRP=""
+11 GOTO A2A
+12 ;
A3 ;
+1 IF '$DATA(BMCAHDR)
DO HDR
+2 SET BMCI=C
+3 IF BMCCTNA>C
SET BMCI=0
A3B ;
+1 SET BMCI=$ORDER(BMCRT(BMCI))
+2 IF +BMCI=0
GOTO A2A
+3 SET BMCJ=$PIECE(BMCRT(BMCI),U,10)
+4 WRITE !,$JUSTIFY(BMCI,2),?3,BMCJ
+5 ;BPA AGREEMENT NUMBER DISPLAY
DO NODISP
+6 WRITE ?9,Y
A3C ;
+1 WRITE ?20,$PIECE(BMCRT(BMCI),U,8),?30,$PIECE(BMCRT(BMCI),U,9)
+2 IF BMCJ="CNT"
WRITE ?45,$PIECE(BMCRT(BMCI),U,2),!
GOTO A3B
+3 SET X=$PIECE(BMCRT(BMCI),U,4)
+4 IF X=""
IF ($PIECE(BMCRT(BMCI),U,2)="")
GOTO A3D
+5 SET Y=$SELECT(X="Y":"YES",X="N":" NO",1:" ")
+6 IF Y=" "
IF $PIECE(BMCRT(BMCI),U,2)=""
GOTO A3D
+7 SET Y=Y_" INP: "
+8 IF $PIECE(BMCRT(BMCI),U,2)'=""
SET Y=Y_$PIECE(BMCRT(BMCI),U,2)
+9 WRITE ?40,Y,!
A3D ;
+1 SET X=$PIECE(BMCRT(BMCI),U,5)
+2 IF X=""&($PIECE(BMCRT(BMCI),U,3)="")
GOTO A3E
+3 SET Y=$SELECT(X="Y":"YES",X="N":" NO",1:" ")
+4 IF Y=" "
IF $PIECE(BMCRT(BMCI),U,3)=""
GOTO A3E
+5 SET Y=Y_" OUT: "
+6 IF $PIECE(BMCRT(BMCI),U,3)'=""
SET Y=Y_$PIECE(BMCRT(BMCI),U,3)
+7 WRITE ?40,Y,!
A3E ;
+1 IF $PIECE(BMCRT(BMCI),U,7)'=""
WRITE ?45,"PRO: ",$PIECE(BMCRT(BMCI),U,7),!
+2 GOTO A3B
+3 ;
EXIT ;
+1 KILL Y,X,BMCCT
+2 QUIT
+3 ;
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 ;
NODISP ;DISPLAY BPA AGREEMENT STUFF
+1 SET Y=""
+2 IF BMCJ="CNT"
SET Y=$PIECE(BMCRT(BMCI),U)
QUIT
+3 SET Y=$EXTRACT($PIECE(BMCRT(BMCI),U),1,2)_$SELECT(BMCJ="BPA":"-A-",BMCJ="PA":"-PA-",BMCJ="RQ":"-R-",1:"")
+4 SET X=$EXTRACT($PIECE(BMCRT(BMCI),U),3,6)
+5 IF BMCJ="PA"
SET Y=Y_$EXTRACT(X,2,4)
QUIT
+6 SET Y=Y_$EXTRACT(X,1,4)
+7 QUIT
+8 ;
