PRCHAMU1.m

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCHAMU1   817     printed  Mar 13, 2025@21:10:33                                                                                                                                                                                                     Page 2

PRCHAMU1  ;WISC/DJM-Reprint amendment ;3/1/95  1:22 PM

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

GETPO     ;get a valid PO

 +1       ;the variable RETURN is either the PO/REQ# or null if no PO is selected

 +2        NEW DIC,D,Y,X,PRCAM,PRCHQ,D0,D1

 +3        SET PRCF("X")="S"

           DO ^PRCFSITE

           if '$DATA(PRC("SITE"))

               QUIT 

 +4        SET DIC="^PRC(443.6,"

           SET DIC(0)="QEAMZ"

 +5        SET DIC("A")=$SELECT($DATA(PRCHREQ):"REQUISITION NO.: ",1:"PURCHASE ORDER: ")

 +6        SET DIC("S")="I +$P(^(0),U)=PRC(""SITE"")"_$SELECT($DATA(PRCHREQ):",$P(^(0),U,2)=8",1:",$P(^(0),U,2)<8")_",$D(^(6))>9,$P($G(^(6,0)),U,4)>0"

 +7        DO ^DIC

           KILL DIC

           if Y<0

               QUIT 

 +8        SET PRCHPO=+Y

 +9        SET (PRCAM,PRCHAM)=0

 +10       FOR 

               SET PRCAM=$ORDER(^PRC(443.6,+Y,6,PRCAM))

               if PRCAM'>0

                   QUIT 

               SET PRCHAM=PRCAM

 +11       DO ^PRCHSF3

 +12       WRITE !,"QUEUED TO SUPPLY PRINTER"

 +13       SET PRCHQ="^PRCHPAM8"

           SET D0=PRCHPO

           SET D1=PRCHAM

           SET PRCHQ("DEST")="S8"

 +14       DO ^PRCHQUE

 +15       QUIT