ACHSUCN ; IHS/ITSC/PMF - SELECT &/OR PRINT VENDOR CONTRACT INFO ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
K ACHSAHDR,ACHSRT
S E=9999999-ACHSEDOS ;CALCULATE THE WEIRD DATE THING
S (S,C,L)=""
S ACHSCTNA=0
S ACHSACO=$G(ACHSACO)
;
;LOOP THRU THE "E" X-REF EIN NO. AND SUFFIX X-REF
L1 ;
S S=""
F S S=$O(^AUTTVNDR(ACHSPROV,"E",S)) Q:S=""!(S>E) D L2
D L3
Q
;
L2 ;
S N=""
F S N=$O(^AUTTVNDR(ACHSPROV,"E",S,N)) Q:N="" D
.Q:'$D(^AUTTVNDR(ACHSPROV,"CN",N,0)) ;QUIT IF NO CONTRACT NODE
.;
.;QUIT IF 'BEGINNING DATE' > EST DATE DATE SERVICE
.Q:$P($G(^AUTTVNDR(ACHSPROV,"CN",N,0)),U,2)>ACHSEDOS
.S ACHSCTNA=ACHSCTNA+1
.S C=C+1
.;
.;L= CONTRACT #_WEIRD SERVICE DATE_CONTRACT NUMBER
.S L=N_U_S_U_$P($G(^AUTTVNDR(ACHSPROV,"CN",N,0)),U)
.;
.;GET 'CONTRACT NUMBER'
.S $P(ACHSRT(ACHSCTNA),U)=$P(^AUTTVNDR(ACHSPROV,"CN",N,0),U)
.;
.;GET 'BEGINNING DATE'
.S $P(ACHSRT(ACHSCTNA),U,8)=$P(^AUTTVNDR(ACHSPROV,"CN",N,0),U,2)
.;
.;GET 'ENDING DATE'
.S $P(ACHSRT(ACHSCTNA),U,9)=$P(^AUTTVNDR(ACHSPROV,"CN",N,0),U,3)
.;
.;GET 'DESCRIPTION'
.S $P(ACHSRT(ACHSCTNA),U,2)=$P(^AUTTVNDR(ACHSPROV,"CN",N,0),U,5)
.;
.;?????
.S $P(ACHSRT(ACHSCTNA),U,10)="CNT" ;?????
.;
.;SET THE COUNT
.S ACHSRT("CNT")=C
.;
.;SET CONTRACT # AS PIECE 11
.S $P(ACHSRT(ACHSCTNA),U,11)=N
.;
.S X=$P(ACHSRT(ACHSCTNA),U,8),Y=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3),$P(ACHSRT(ACHSCTNA),U,8)=Y
.S X=$P(ACHSRT(ACHSCTNA),U,9),Y=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3),$P(ACHSRT(ACHSCTNA),U,9)=Y
.;
.;
.I ACHSACO["L" D
..D SBT:C=1 ;WRITE THE HEADINGS
..;
..;PRINT 'CONTRACT NUMBER'
..W !,$J(C,2),?3,"CNT",?8,$J($P($G(^AUTTVNDR(ACHSPROV,"CN",N,0)),U),10)
..W ?20,$P(ACHSRT(ACHSCTNA),U,8) ;'BEGINNING DATE'
..W ?30,$P(ACHSRT(ACHSCTNA),U,9) ;'ENDING DATE'
..W ?45,$E($P(^AUTTVNDR(ACHSPROV,"CN",N,0),U,5),1,28) ;DESCRIPTION
.;
.;WHERE IS F DEFINED??????
.I ACHSACO["F",C=$G(F) D L3 Q ; 'F' is defined only if ACHSACO["F".
Q
;
;
L3 ;
I ACHSACO="L" W !,$J(C+1,2),?8,$J("Open Mkgt",10)
S:S>E&(+C=0) ACHSACO="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 ACHSAHDR=""
Q
;
ACHSUCN ; IHS/ITSC/PMF - SELECT &/OR PRINT VENDOR CONTRACT INFO ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 KILL ACHSAHDR,ACHSRT
+4 ;CALCULATE THE WEIRD DATE THING
SET E=9999999-ACHSEDOS
+5 SET (S,C,L)=""
+6 SET ACHSCTNA=0
+7 SET ACHSACO=$GET(ACHSACO)
+8 ;
+9 ;LOOP THRU THE "E" X-REF EIN NO. AND SUFFIX X-REF
L1 ;
+1 SET S=""
+2 FOR
SET S=$ORDER(^AUTTVNDR(ACHSPROV,"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(ACHSPROV,"E",S,N))
IF N=""
QUIT
Begin DoDot:1
+3 ;QUIT IF NO CONTRACT NODE
IF '$DATA(^AUTTVNDR(ACHSPROV,"CN",N,0))
QUIT
+4 ;
+5 ;QUIT IF 'BEGINNING DATE' > EST DATE DATE SERVICE
+6 IF $PIECE($GET(^AUTTVNDR(ACHSPROV,"CN",N,0)),U,2)>ACHSEDOS
QUIT
+7 SET ACHSCTNA=ACHSCTNA+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(ACHSPROV,"CN",N,0)),U)
+12 ;
+13 ;GET 'CONTRACT NUMBER'
+14 SET $PIECE(ACHSRT(ACHSCTNA),U)=$PIECE(^AUTTVNDR(ACHSPROV,"CN",N,0),U)
+15 ;
+16 ;GET 'BEGINNING DATE'
+17 SET $PIECE(ACHSRT(ACHSCTNA),U,8)=$PIECE(^AUTTVNDR(ACHSPROV,"CN",N,0),U,2)
+18 ;
+19 ;GET 'ENDING DATE'
+20 SET $PIECE(ACHSRT(ACHSCTNA),U,9)=$PIECE(^AUTTVNDR(ACHSPROV,"CN",N,0),U,3)
+21 ;
+22 ;GET 'DESCRIPTION'
+23 SET $PIECE(ACHSRT(ACHSCTNA),U,2)=$PIECE(^AUTTVNDR(ACHSPROV,"CN",N,0),U,5)
+24 ;
+25 ;?????
+26 ;?????
SET $PIECE(ACHSRT(ACHSCTNA),U,10)="CNT"
+27 ;
+28 ;SET THE COUNT
+29 SET ACHSRT("CNT")=C
+30 ;
+31 ;SET CONTRACT # AS PIECE 11
+32 SET $PIECE(ACHSRT(ACHSCTNA),U,11)=N
+33 ;
+34 SET X=$PIECE(ACHSRT(ACHSCTNA),U,8)
SET Y=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)
SET $PIECE(ACHSRT(ACHSCTNA),U,8)=Y
+35 SET X=$PIECE(ACHSRT(ACHSCTNA),U,9)
SET Y=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)
SET $PIECE(ACHSRT(ACHSCTNA),U,9)=Y
+36 ;
+37 ;
+38 IF ACHSACO["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(ACHSPROV,"CN",N,0)),U),10)
+43 ;'BEGINNING DATE'
WRITE ?20,$PIECE(ACHSRT(ACHSCTNA),U,8)
+44 ;'ENDING DATE'
WRITE ?30,$PIECE(ACHSRT(ACHSCTNA),U,9)
+45 ;DESCRIPTION
WRITE ?45,$EXTRACT($PIECE(^AUTTVNDR(ACHSPROV,"CN",N,0),U,5),1,28)
End DoDot:2
+46 ;
+47 ;WHERE IS F DEFINED??????
+48 ; 'F' is defined only if ACHSACO["F".
IF ACHSACO["F"
IF C=$GET(F)
DO L3
QUIT
End DoDot:1
+49 QUIT
+50 ;
+51 ;
L3 ;
+1 IF ACHSACO="L"
WRITE !,$JUSTIFY(C+1,2),?8,$JUSTIFY("Open Mkgt",10)
+2 IF S>E&(+C=0)
SET ACHSACO="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 ACHSAHDR=""
+3 QUIT
+4 ;
