- 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 ;