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
