- ACRFVCTR ;IHS/OIRM/DSD/THL,AEF - LOOKUP CONTRACT NUMBER FOR ITEM VENDOR; [ 11/01/2001 9:44 AM ]
- ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
- ;;ROUTINE TO LOOKUP CONTRACT NUMBER FOR ITEM VENDOR
- EN I '$D(^AUTTVNDR(ACRVENDA,"CN")) D Q
- .W !?10,"NO CONTRACTS ON FILE FOR ",$P(^AUTTVNDR(ACRVENDA,0),U)
- .H 2
- F D EN1 Q:$D(ACRQUIT)!$D(ACROUT)
- EXIT K ACRQUIT
- Q
- EN1 D DISPLAY
- D SELECT:ACRJ
- I 'ACRJ D
- .S ACRQUIT=""
- .W !?10,"NO CONTRACTS ON FILE FOR ",$P(^AUTTVNDR(ACRVENDA,0),U)
- .H 2
- Q
- DISPLAY D HEAD
- S (ACR,ACRJ)=0
- F S ACR=$O(^AUTTVNDR(ACRVENDA,"CN",ACR)) Q:'ACR D
- .S ACRX=ACR_U_^AUTTVNDR(ACRVENDA,"CN",ACR,0)
- .D DATE
- Q
- SELECT S DIR(0)="NO^1:"_ACRJ
- S DIR("A")="Contract for this item"
- W !
- D DIR^ACRFDIC
- Q:$D(ACRQUIT)!$D(ACROUT)
- S $P(^ACRITEM(ACRITMDA,"DT1"),U,10)=$P(ACRX(Y),U)
- S ACRQUIT=""
- Q
- DATE S X1=DT
- S (ACRB,X2)=$P(ACRX,U,3)
- D ^%DTC
- I X<1 K ACRX(ACR) Q
- S Y=ACRB
- X ^DD("DD")
- S ACRB=Y
- S X2=DT
- S (ACRE,X1)=$P(ACRX,U,4)
- D ^%DTC
- I X<1 K ACRX(ACR) Q
- S Y=ACRE
- X ^DD("DD")
- S ACRE=Y
- S ACRJ=ACRJ+1
- S ACRX(ACRJ)=ACRX
- W W !,$P(ACRX,U,2)
- W ?13,ACRB
- W ?25,ACRE
- W ?37,$J($FN($P(ACRX,U,5),"P",2),12)
- W ?50,$P(ACRX,U,6)
- Q
- HEAD W:$P(^ACRITEM(ACRITMDA,"DT1"),U,10)]"" !,"CONTRACT NO.........: ",$P(^("DT1"),U,10)
- W !!,"CONTRACT NO."
- W ?13,"BEGINNING"
- W ?27,"ENDING"
- W ?39,"AMOUNT"
- W ?50,"DESCRIPTION"
- W !,"------------ ----------- ----------- ------------ ------------------------------"
- Q
- ACRFVCTR ;IHS/OIRM/DSD/THL,AEF - LOOKUP CONTRACT NUMBER FOR ITEM VENDOR; [ 11/01/2001 9:44 AM ]
- +1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
- +2 ;;ROUTINE TO LOOKUP CONTRACT NUMBER FOR ITEM VENDOR
- EN IF '$DATA(^AUTTVNDR(ACRVENDA,"CN"))
- Begin DoDot:1
- +1 WRITE !?10,"NO CONTRACTS ON FILE FOR ",$PIECE(^AUTTVNDR(ACRVENDA,0),U)
- +2 HANG 2
- End DoDot:1
- QUIT
- +3 FOR
- DO EN1
- IF $DATA(ACRQUIT)!$DATA(ACROUT)
- QUIT
- EXIT KILL ACRQUIT
- +1 QUIT
- EN1 DO DISPLAY
- +1 IF ACRJ
- DO SELECT
- +2 IF 'ACRJ
- Begin DoDot:1
- +3 SET ACRQUIT=""
- +4 WRITE !?10,"NO CONTRACTS ON FILE FOR ",$PIECE(^AUTTVNDR(ACRVENDA,0),U)
- +5 HANG 2
- End DoDot:1
- +6 QUIT
- DISPLAY DO HEAD
- +1 SET (ACR,ACRJ)=0
- +2 FOR
- SET ACR=$ORDER(^AUTTVNDR(ACRVENDA,"CN",ACR))
- IF 'ACR
- QUIT
- Begin DoDot:1
- +3 SET ACRX=ACR_U_^AUTTVNDR(ACRVENDA,"CN",ACR,0)
- +4 DO DATE
- End DoDot:1
- +5 QUIT
- SELECT SET DIR(0)="NO^1:"_ACRJ
- +1 SET DIR("A")="Contract for this item"
- +2 WRITE !
- +3 DO DIR^ACRFDIC
- +4 IF $DATA(ACRQUIT)!$DATA(ACROUT)
- QUIT
- +5 SET $PIECE(^ACRITEM(ACRITMDA,"DT1"),U,10)=$PIECE(ACRX(Y),U)
- +6 SET ACRQUIT=""
- +7 QUIT
- DATE SET X1=DT
- +1 SET (ACRB,X2)=$PIECE(ACRX,U,3)
- +2 DO ^%DTC
- +3 IF X<1
- KILL ACRX(ACR)
- QUIT
- +4 SET Y=ACRB
- +5 XECUTE ^DD("DD")
- +6 SET ACRB=Y
- +7 SET X2=DT
- +8 SET (ACRE,X1)=$PIECE(ACRX,U,4)
- +9 DO ^%DTC
- +10 IF X<1
- KILL ACRX(ACR)
- QUIT
- +11 SET Y=ACRE
- +12 XECUTE ^DD("DD")
- +13 SET ACRE=Y
- +14 SET ACRJ=ACRJ+1
- +15 SET ACRX(ACRJ)=ACRX
- W WRITE !,$PIECE(ACRX,U,2)
- +1 WRITE ?13,ACRB
- +2 WRITE ?25,ACRE
- +3 WRITE ?37,$JUSTIFY($FNUMBER($PIECE(ACRX,U,5),"P",2),12)
- +4 WRITE ?50,$PIECE(ACRX,U,6)
- +5 QUIT
- HEAD IF $PIECE(^ACRITEM(ACRITMDA,"DT1"),U,10)]""
- WRITE !,"CONTRACT NO.........: ",$PIECE(^("DT1"),U,10)
- +1 WRITE !!,"CONTRACT NO."
- +2 WRITE ?13,"BEGINNING"
- +3 WRITE ?27,"ENDING"
- +4 WRITE ?39,"AMOUNT"
- +5 WRITE ?50,"DESCRIPTION"
- +6 WRITE !,"------------ ----------- ----------- ------------ ------------------------------"
- +7 QUIT
