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