BMCVUCN ; IHS/OIT/FCJ - SELECT &/OR PRINT VENDOR CONTRACT INFO ;
;;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 ACHSUCN
;
K BMCAHDR,BMCRT
S E=9999999-BMCEDOS ;CALCULATE THE WEIRD DATE THING
S (S,C,L)=""
S BMCCTNA=0
S BMCACO=$G(BMCACO)
;
;LOOP THRU THE "E" X-REF EIN NO. AND SUFFIX X-REF
L1 ;
S S=""
F S S=$O(^AUTTVNDR(BMCPROV,"E",S)) Q:S=""!(S>E) D L2
D L3
Q
;
L2 ;
S N=""
F S N=$O(^AUTTVNDR(BMCPROV,"E",S,N)) Q:N="" D
.Q:'$D(^AUTTVNDR(BMCPROV,"CN",N,0)) ;QUIT IF NO CONTRACT NODE
.;
.;QUIT IF 'BEGINNING DATE' > EST DATE DATE SERVICE
.Q:$P($G(^AUTTVNDR(BMCPROV,"CN",N,0)),U,2)>BMCEDOS
.S BMCCTNA=BMCCTNA+1
.S C=C+1
.;
.;L= CONTRACT #_WEIRD SERVICE DATE_CONTRACT NUMBER
.S L=N_U_S_U_$P($G(^AUTTVNDR(BMCPROV,"CN",N,0)),U)
.;
.;GET 'CONTRACT NUMBER'
.S $P(BMCRT(BMCCTNA),U)=$P(^AUTTVNDR(BMCPROV,"CN",N,0),U)
.;
.;GET 'BEGINNING DATE'
.S $P(BMCRT(BMCCTNA),U,8)=$P(^AUTTVNDR(BMCPROV,"CN",N,0),U,2)
.;
.;GET 'ENDING DATE'
.S $P(BMCRT(BMCCTNA),U,9)=$P(^AUTTVNDR(BMCPROV,"CN",N,0),U,3)
.;
.;GET 'DESCRIPTION'
.S $P(BMCRT(BMCCTNA),U,2)=$P(^AUTTVNDR(BMCPROV,"CN",N,0),U,5)
.;
.;?????
.S $P(BMCRT(BMCCTNA),U,10)="CNT" ;?????
.;
.;SET THE COUNT
.S BMCRT("CNT")=C
.;
.;SET CONTRACT # AS PIECE 11
.S $P(BMCRT(BMCCTNA),U,11)=N
.;
.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
.;
.;
.I BMCACO["L" D
..D SBT:C=1 ;WRITE THE HEADINGS
..;
..;PRINT 'CONTRACT NUMBER'
..W !,$J(C,2),?3,"CNT",?8,$J($P($G(^AUTTVNDR(BMCPROV,"CN",N,0)),U),10)
..W ?20,$P(BMCRT(BMCCTNA),U,8) ;'BEGINNING DATE'
..W ?30,$P(BMCRT(BMCCTNA),U,9) ;'ENDING DATE'
..W ?45,$E($P(^AUTTVNDR(BMCPROV,"CN",N,0),U,5),1,28) ;DESCRIPTION
.;
.;WHERE IS F DEFINED??????
.I BMCACO["F",C=$G(F) D L3 Q ; 'F' is defined only if BMCACO["F".
Q
;
;
L3 ;
I BMCACO="L" W !,$J(C+1,2),?8,$J("Open Mkgt",10)
S:S>E&(+C=0) BMCACO="N"
Q
;
SBT ;
W !!?3,"Type",?9,"CNT Numb.",?20,"Eff-Date",?30,"Exp-Date",?40,"MCR",?45,"Description",!?3,"____",?9,"_________",?20,"________",?30,"________",?40,"___",?45,"____________________________",!
S BMCAHDR=""
Q
;
BMCVUCN ; IHS/OIT/FCJ - SELECT &/OR PRINT VENDOR CONTRACT INFO ;
+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 ACHSUCN
+3 ;
+4 KILL BMCAHDR,BMCRT
+5 ;CALCULATE THE WEIRD DATE THING
SET E=9999999-BMCEDOS
+6 SET (S,C,L)=""
+7 SET BMCCTNA=0
+8 SET BMCACO=$GET(BMCACO)
+9 ;
+10 ;LOOP THRU THE "E" X-REF EIN NO. AND SUFFIX X-REF
L1 ;
+1 SET S=""
+2 FOR
SET S=$ORDER(^AUTTVNDR(BMCPROV,"E",S))
IF S=""!(S>E)
QUIT
DO L2
+3 DO L3
+4 QUIT
+5 ;
L2 ;
+1 SET N=""
+2 FOR
SET N=$ORDER(^AUTTVNDR(BMCPROV,"E",S,N))
IF N=""
QUIT
Begin DoDot:1
+3 ;QUIT IF NO CONTRACT NODE
IF '$DATA(^AUTTVNDR(BMCPROV,"CN",N,0))
QUIT
+4 ;
+5 ;QUIT IF 'BEGINNING DATE' > EST DATE DATE SERVICE
+6 IF $PIECE($GET(^AUTTVNDR(BMCPROV,"CN",N,0)),U,2)>BMCEDOS
QUIT
+7 SET BMCCTNA=BMCCTNA+1
+8 SET C=C+1
+9 ;
+10 ;L= CONTRACT #_WEIRD SERVICE DATE_CONTRACT NUMBER
+11 SET L=N_U_S_U_$PIECE($GET(^AUTTVNDR(BMCPROV,"CN",N,0)),U)
+12 ;
+13 ;GET 'CONTRACT NUMBER'
+14 SET $PIECE(BMCRT(BMCCTNA),U)=$PIECE(^AUTTVNDR(BMCPROV,"CN",N,0),U)
+15 ;
+16 ;GET 'BEGINNING DATE'
+17 SET $PIECE(BMCRT(BMCCTNA),U,8)=$PIECE(^AUTTVNDR(BMCPROV,"CN",N,0),U,2)
+18 ;
+19 ;GET 'ENDING DATE'
+20 SET $PIECE(BMCRT(BMCCTNA),U,9)=$PIECE(^AUTTVNDR(BMCPROV,"CN",N,0),U,3)
+21 ;
+22 ;GET 'DESCRIPTION'
+23 SET $PIECE(BMCRT(BMCCTNA),U,2)=$PIECE(^AUTTVNDR(BMCPROV,"CN",N,0),U,5)
+24 ;
+25 ;?????
+26 ;?????
SET $PIECE(BMCRT(BMCCTNA),U,10)="CNT"
+27 ;
+28 ;SET THE COUNT
+29 SET BMCRT("CNT")=C
+30 ;
+31 ;SET CONTRACT # AS PIECE 11
+32 SET $PIECE(BMCRT(BMCCTNA),U,11)=N
+33 ;
+34 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
+35 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
+36 ;
+37 ;
+38 IF BMCACO["L"
Begin DoDot:2
+39 ;WRITE THE HEADINGS
IF C=1
DO SBT
+40 ;
+41 ;PRINT 'CONTRACT NUMBER'
+42 WRITE !,$JUSTIFY(C,2),?3,"CNT",?8,$JUSTIFY($PIECE($GET(^AUTTVNDR(BMCPROV,"CN",N,0)),U),10)
+43 ;'BEGINNING DATE'
WRITE ?20,$PIECE(BMCRT(BMCCTNA),U,8)
+44 ;'ENDING DATE'
WRITE ?30,$PIECE(BMCRT(BMCCTNA),U,9)
+45 ;DESCRIPTION
WRITE ?45,$EXTRACT($PIECE(^AUTTVNDR(BMCPROV,"CN",N,0),U,5),1,28)
End DoDot:2
+46 ;
+47 ;WHERE IS F DEFINED??????
+48 ; 'F' is defined only if BMCACO["F".
IF BMCACO["F"
IF C=$GET(F)
DO L3
QUIT
End DoDot:1
+49 QUIT
+50 ;
+51 ;
L3 ;
+1 IF BMCACO="L"
WRITE !,$JUSTIFY(C+1,2),?8,$JUSTIFY("Open Mkgt",10)
+2 IF S>E&(+C=0)
SET BMCACO="N"
+3 QUIT
+4 ;
SBT ;
+1 WRITE !!?3,"Type",?9,"CNT Numb.",?20,"Eff-Date",?30,"Exp-Date",?40,"MCR",?45,"Description",!?3,"____",?9,"_________",?20,"________",?30,"________",?40,"___",?45,"____________________________",!
+2 SET BMCAHDR=""
+3 QUIT
+4 ;
