- 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 Mar 13, 2025@21:11:38 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
