20 lines
798 B
Mathematica
20 lines
798 B
Mathematica
PRCHAMU1 ;WISC/DJM-Reprint amendment ;3/1/95 1:22 PM
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
GETPO ;get a valid PO
|
|
;the variable RETURN is either the PO/REQ# or null if no PO is selected
|
|
N DIC,D,Y,X,PRCAM,PRCHQ,D0,D1
|
|
S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))
|
|
S DIC="^PRC(443.6,",DIC(0)="QEAMZ"
|
|
S DIC("A")=$S($D(PRCHREQ):"REQUISITION NO.: ",1:"PURCHASE ORDER: ")
|
|
S DIC("S")="I +$P(^(0),U)=PRC(""SITE"")"_$S($D(PRCHREQ):",$P(^(0),U,2)=8",1:",$P(^(0),U,2)<8")_",$D(^(6))>9,$P($G(^(6,0)),U,4)>0"
|
|
D ^DIC K DIC Q:Y<0
|
|
S PRCHPO=+Y
|
|
S (PRCAM,PRCHAM)=0
|
|
F S PRCAM=$O(^PRC(443.6,+Y,6,PRCAM)) Q:PRCAM'>0 S PRCHAM=PRCAM
|
|
D ^PRCHSF3
|
|
W !,"QUEUED TO SUPPLY PRINTER"
|
|
S PRCHQ="^PRCHPAM8",D0=PRCHPO,D1=PRCHAM,PRCHQ("DEST")="S8"
|
|
D ^PRCHQUE
|
|
Q
|