PRCHDR ;WISC/RHD-DISPLAY REQUEST ;2/12/98 2:43 PM
V ;;5.1;IFCAP;**179**;Oct 20, 2000;Build 6
;Per VHA Directive 2004-038, this routine should not be modified.
;
;PRC*5.1*179 Do not skip Accountable Officer, Purchasing Agent and
;comments if File 443 entry is not defined
;
EN ; DISPLAY 2237
S PRCH0=$G(^PRCS(410,D0,0))
S PRCHTC=$P(PRCH0,"^",2),PRCHTP="" I PRCHTC'="" S X=$P(^DD(410,1,0),U,3) F I=1:1 S Y=$P(X,";",I) Q:Y="" I $P(Y,":",1)=PRCHTC S PRCHTP=$P(Y,":",2) Q
W !,"Transaction Number: ",$P(PRCH0,U,1),?41,"Transaction Type: ",PRCHTP K ^UTILITY($J,"W")
I $O(^PRCS(410,D0,"RM",0)) S DIWL=3,DIWR=75,DIWF="" F PRCHI=0:0 S PRCHI=$O(^PRCS(410,D0,"RM",PRCHI)) Q:'PRCHI S X=^(PRCHI,0) D DIWP^PRCUTL($G(DA))
I $D(^UTILITY($J,"W",3)) F I=0:0 S I=$O(^UTILITY($J,"W",3,I)) Q:'I W !?3,^(I,0)
G:PRCHTC="CA" Q
O S X="" D STATUS^PRCSES W !,"Supply Status: ",X I $D(^PRC(443,D0,0)) S PRCHR0=^(0) ;PRC*5.1*179
W !,"Accountable Officer: " I $D(PRCHR0) S X=$P(PRCHR0,U,2) D US W ?45,"Date: " S Y=$P(PRCHR0,U,4) D DT ;PRC*5.1*179
W !,"Purchasing Agent: " I $D(PRCHR0) S X=$P(PRCHR0,U,5) D US W ?45,"Date: " S Y=$P(PRCHR0,U,6) D DT ;PRC*5.1*179
I $P($G(^PRCS(410,D0,0)),"^",2)["O",$D(^PRCS(410,D0,"CO",0)) W !,"Comments: " N COM S COM=0 F S COM=$O(^PRCS(410,D0,"CO",COM)) Q:'COM W !,$G(^(COM,0))
W1 W ! S %A="Would you like to print this request now",%B="",%=2 D ^PRCFYN I %=1 S DA=D0,PRCSF=1,ZTDESC="QUE^PRCSP12" D PRF1^PRCSP1 K X,PRCSF
Q K A,B,C,DA,PRCHI,PRCH0,PRCHTC,PRCHTP,PRCHR0,Y,^UTILITY($J,"W")
Q
US ;S X=$S($D(^VA(200,+X,0)):$P(^(0),U,1),1:"") W $P(X,",",2)," ",$P(X,",",1) Q
S X=$P($G(^VA(200,+X,0)),U,1) W $P(X,",",2)," ",$P(X,",",1)
Q
DT W:Y Y\100#100,"/",Y#100\1,"/",Y\10000+1700
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDR 1736 printed Sep 23, 2025@19:42:55 Page 2
PRCHDR ;WISC/RHD-DISPLAY REQUEST ;2/12/98 2:43 PM
V ;;5.1;IFCAP;**179**;Oct 20, 2000;Build 6
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*179 Do not skip Accountable Officer, Purchasing Agent and
+4 ;comments if File 443 entry is not defined
+5 ;
EN ; DISPLAY 2237
+1 SET PRCH0=$GET(^PRCS(410,D0,0))
+2 SET PRCHTC=$PIECE(PRCH0,"^",2)
SET PRCHTP=""
IF PRCHTC'=""
SET X=$PIECE(^DD(410,1,0),U,3)
FOR I=1:1
SET Y=$PIECE(X,";",I)
if Y=""
QUIT
IF $PIECE(Y,":",1)=PRCHTC
SET PRCHTP=$PIECE(Y,":",2)
QUIT
+3 WRITE !,"Transaction Number: ",$PIECE(PRCH0,U,1),?41,"Transaction Type: ",PRCHTP
KILL ^UTILITY($JOB,"W")
+4 IF $ORDER(^PRCS(410,D0,"RM",0))
SET DIWL=3
SET DIWR=75
SET DIWF=""
FOR PRCHI=0:0
SET PRCHI=$ORDER(^PRCS(410,D0,"RM",PRCHI))
if 'PRCHI
QUIT
SET X=^(PRCHI,0)
DO DIWP^PRCUTL($GET(DA))
+5 IF $DATA(^UTILITY($JOB,"W",3))
FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,"W",3,I))
if 'I
QUIT
WRITE !?3,^(I,0)
+6 if PRCHTC="CA"
GOTO Q
O ;PRC*5.1*179
SET X=""
DO STATUS^PRCSES
WRITE !,"Supply Status: ",X
IF $DATA(^PRC(443,D0,0))
SET PRCHR0=^(0)
+1 ;PRC*5.1*179
WRITE !,"Accountable Officer: "
IF $DATA(PRCHR0)
SET X=$PIECE(PRCHR0,U,2)
DO US
WRITE ?45,"Date: "
SET Y=$PIECE(PRCHR0,U,4)
DO DT
+2 ;PRC*5.1*179
WRITE !,"Purchasing Agent: "
IF $DATA(PRCHR0)
SET X=$PIECE(PRCHR0,U,5)
DO US
WRITE ?45,"Date: "
SET Y=$PIECE(PRCHR0,U,6)
DO DT
+3 IF $PIECE($GET(^PRCS(410,D0,0)),"^",2)["O"
IF $DATA(^PRCS(410,D0,"CO",0))
WRITE !,"Comments: "
NEW COM
SET COM=0
FOR
SET COM=$ORDER(^PRCS(410,D0,"CO",COM))
if 'COM
QUIT
WRITE !,$GET(^(COM,0))
W1 WRITE !
SET %A="Would you like to print this request now"
SET %B=""
SET %=2
DO ^PRCFYN
IF %=1
SET DA=D0
SET PRCSF=1
SET ZTDESC="QUE^PRCSP12"
DO PRF1^PRCSP1
KILL X,PRCSF
Q KILL A,B,C,DA,PRCHI,PRCH0,PRCHTC,PRCHTP,PRCHR0,Y,^UTILITY($JOB,"W")
+1 QUIT
US ;S X=$S($D(^VA(200,+X,0)):$P(^(0),U,1),1:"") W $P(X,",",2)," ",$P(X,",",1) Q
+1 SET X=$PIECE($GET(^VA(200,+X,0)),U,1)
WRITE $PIECE(X,",",2)," ",$PIECE(X,",",1)
+2 QUIT
DT if Y
WRITE Y\100#100,"/",Y#100\1,"/",Y\10000+1700
+1 QUIT
