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