PRCHFPNT ;WISC/RSD/RHD-PRINT FREE FORM 2138 ;10/27/95 2:23 PM
V ;;5.1;IFCAP;**221**;Oct 20, 2000;Build 14
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*221 Modify an item description display to skip '|' logic
; if description contains a undefined display command
; like '| IN '
;
S U="^",PRCH0=$G(^PRC(442,D0,0)),PRCH1=$G(^(1)),PRCH12=$G(^(12))
S PRCHSIT=$P(PRCH0,"-",1)
N PRCHSIT1,PURPIPE,PRCHW,PIPEJ,PRCHI,PRCHDIW ;PRC*5.1*221
S PRCHSIT1=$S($P($G(^PRC(442,D0,23)),U,7)]"":$P(^(23),U,7),1:$P(PRCH0,"-"))
S PRCHDES=$S($D(PRCHQ("DEST")):PRCHQ("DEST"),$D(DEST):DEST,1:"")
I $P(PRCH0,U,2)=8 S PRCHNRQ=1
I $G(PRCHNRQ)=1 D SJD
S:IOBS="" IOBS="$C(8)" Q:PRCH0']""!(PRCH1']"")
;S PRCHFPT=$S($D(PRCHFPT):PRCHFPT,1:0),(PRCHS,PRCHDA,PRCHDTA)=0,PRCHSHP="",$P(PRCHULN,"_",97)="" I +$P(PRCH0,U,2)'=4,$P(PRCH1,U,12)="" S PRCHSHP=$S($D(^PRC(411,PRCHSIT,1,+$P(PRCH1,U,3),0)):^(0),1:"")
S PRCHFPT=+$G(PRCHFPT),(PRCHS,PRCHDA,PRCHDTA)=0,PRCHSHP="",$P(PRCHULN,"_",97)="" I +$P(PRCH0,U,2)'=4,$P(PRCH1,U,12)="" S PRCHSHP=$G(^PRC(411,PRCHSIT1,1,+$P(PRCH1,U,3),0))
;I '$T,$P(PRCH1,U,12)]"" S PRCHSHP=$S($D(^PRC(440.2,$P(PRCH1,U,12),0)):^(0),1:""),PRCHS=1 I +PRCHSHP>0 S $P(PRCHSHP,U,1)=$S($D(^DPT(+PRCHSHP,0)):$E($P(^(0),U,1),1,21),1:"")
I '$T,$P(PRCH1,U,12)]"" S PRCHSHP=$G(^PRC(440.2,$P(PRCH1,U,12),0)),PRCHS=1 I +PRCHSHP>0 S $P(PRCHSHP,U,1)=$E($P($G(^DPT(+PRCHSHP,0)),U,1),1,21)
S PRCHST=$G(^PRC(411,PRCHSIT1,0)),PRCHHSP=$G(^(3)),X=+$P(PRCH12,U,6),PRCHINV=$G(^(4,X,0))
D PIPECK ;PRC*5.1*221
S DIWL=1,DIWR=33,DIWF="",PRCH=0 F I=0:0 S PRCH=$O(^PRC(442,D0,2,PRCH)) Q:'PRCH K ^UTILITY($J,"W") D LC
S DIWL=1,DIWR=64,DIWF="",PRCH=0 K ^PRC(442,D0,15,9999999) I $D(^PRC(442,D0,11,PRCHFPT,0)),$P(^(0),U,10)="Y" S ^PRC(442,D0,15,9999999,0)=9999999
F I=0:0 S PRCH=$O(^PRC(442,D0,15,PRCH)) Q:'PRCH S PRCHI=PRCH,PRCHK=+^(PRCH,0) I $D(^PRC(442.7,PRCHK,0)),$O(^(1,0)) K ^UTILITY($J,"W") D LC1
I $D(PRCHI),PRCHI,$D(^PRC(442,D0,15,PRCHI,0)) S $P(^(0),U,2)=$P(^(0),U,2)-1
K PRCHI
G STP^PRCHFPT0
;
LC Q:'$D(^PRC(442,D0,2,PRCH,1,0)) S PRCHJ=0 F S PRCHJ=$O(^PRC(442,D0,2,PRCH,1,PRCHJ)) Q:PRCHJ="" S X=^(PRCHJ,0) S:PURPIPE DIWF=$G(DIWF)_"|" D DIWP^PRCUTL($G(DA)) ;PRC*5.1*221
S PRCHLC=+^UTILITY($J,"W",1) S:PRCHLC>0 $P(^PRC(442,D0,2,PRCH,2),U,4)=PRCHLC,X=$O(^PRC(442,D0,2,PRCH,3,"AC",PRCHFPT,0))
I PRCHDES="R",X,$D(^PRC(442,D0,2,PRCH,3,X,0)) S PRCHDA=PRCHDA+$P(^(0),U,5),PRCHDTA=PRCHDTA+$P(^(0),U,3)
Q
;
LC1 N PURPIPE S DIWF=""
D PIPECK S PRCHDIW=0 ;PRC*5.1*221
F PRCHJ=0:0 S PRCHJ=$O(^PRC(442.7,PRCHK,1,PRCHJ)) Q:'PRCHJ S X=^(PRCHJ,0) S:PURPIPE DIWF=$G(DIWF)_"|" D DIWP^PRCUTL($G(DA))
S PRCHLC=+^UTILITY($J,"W",1) S:PRCHLC>0 $P(^PRC(442,D0,15,PRCH,0),U,2)=PRCHLC+1
Q
;
FTYP ; RETURN FACILITY TYPE IN 'PRCHFTYP'
N PRCSUB
;S PRCHFTYP="V.A. *FACILITY TYPE UNDEFINED*",X=$S($D(^PRC(411,PRC("SITE"),0)):$P(^(0),"^",7),1:"") S:X="" X=1
S PRCHFTYP="V.A. *FACILITY TYPE UNDEFINED*"
S X=$P($G(^PRC(411,PRC("SITE"),0)),"^",7) S:X="" X=1
I $P($G(^PRC(442,D0,23)),U,7)]"" S PRCSUB=$P(^(23),U,7) D
. S X=$P($G(^PRC(411,PRCSUB,0)),"^",7) S:X="" X=1
;I '$D(PRCHFTP2) S PRCHFTYP=$S($D(^PRC(411.2,+X,0)):$P(^(0),U,2),1:"")
I '$D(PRCHFTP2) S PRCHFTYP=$P($G(^PRC(411.2,+X,0)),U,2)
;I $D(PRCHFTP2) S PRCHFTYP=$S($D(^PRC(411.2,+X,0)):$P(^(0),U,1),1:"")
I $D(PRCHFTP2) S PRCHFTYP=$P($G(^PRC(411.2,+X,0)),U,1)
K PRCHFTP2
Q
;
FTYPS ;ABBREVIATED FACILITY TYPE
S PRCHFTP2="SHORT"
G FTYP
;
SJD ;SET JULIAN DATE
S X=$P(PRCH1,U,15) D JD^PRCFDLN S PRCHJD=$E(Y,4)_$E(Y,1,3)
Q
;
PSNO ;PRINT SERIAL NO.
W:$D(^PRC(442,D0,2,PRCH,4)) $S($P(^(4),U,1):" ("_PRCHJD_"-"_$P(^(4),U,1)_")",1:"")
Q
FTYP1 ; RETURN FACILITY TYPE IN 'PRCHFTYP'
N PRCSUB
S PRCHFTYP="V.A. *FACILITY TYPE UNDEFINED*"
S X=$P($G(^PRC(411,PRC("SITE"),0)),"^",7) S:X="" X=1
I $P($G(^PRCS(410,D0,0)),U,10)]"" S PRCSUB=$P(^(0),U,10) D
. S X=$P($G(^PRC(411,PRCSUB,0)),"^",7) S:X="" X=1
I '$D(PRCHFTP2) S PRCHFTYP=$P($G(^PRC(411.2,+X,0)),U,2)
I $D(PRCHFTP2) S PRCHFTYP=$P($G(^PRC(411.2,+X,0)),U,1)
K PRCHFTP2
Q
PIPECK ;check for invalid pipe '|IN ' command in item description ;PRC*5.1*221
S PURPIPE=0,PRCH=0
F PRCHI=1:1 S PRCH=$O(^PRC(442,D0,2,PRCH)),PRCHDIW=0 Q:'PRCH D Q:PURPIPE
. F PRCHJ=1:1 S PRCHDIW=$O(^PRC(442,D0,2,PRCH,1,PRCHDIW)) Q:PRCHDIW'>0 S X=$S($D(^(PRCHDIW,0)):^(0),1:"") D Q:PURPIPE
. . I X["| IN " S PURPIPE=1
. . Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHFPNT 4442 printed Sep 23, 2025@19:43:41 Page 2
PRCHFPNT ;WISC/RSD/RHD-PRINT FREE FORM 2138 ;10/27/95 2:23 PM
V ;;5.1;IFCAP;**221**;Oct 20, 2000;Build 14
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*221 Modify an item description display to skip '|' logic
+4 ; if description contains a undefined display command
+5 ; like '| IN '
+6 ;
+7 SET U="^"
SET PRCH0=$GET(^PRC(442,D0,0))
SET PRCH1=$GET(^(1))
SET PRCH12=$GET(^(12))
+8 SET PRCHSIT=$PIECE(PRCH0,"-",1)
+9 ;PRC*5.1*221
NEW PRCHSIT1,PURPIPE,PRCHW,PIPEJ,PRCHI,PRCHDIW
+10 SET PRCHSIT1=$SELECT($PIECE($GET(^PRC(442,D0,23)),U,7)]"":$PIECE(^(23),U,7),1:$PIECE(PRCH0,"-"))
+11 SET PRCHDES=$SELECT($DATA(PRCHQ("DEST")):PRCHQ("DEST"),$DATA(DEST):DEST,1:"")
+12 IF $PIECE(PRCH0,U,2)=8
SET PRCHNRQ=1
+13 IF $GET(PRCHNRQ)=1
DO SJD
+14 if IOBS=""
SET IOBS="$C(8)"
if PRCH0']""!(PRCH1']"")
QUIT
+15 ;S PRCHFPT=$S($D(PRCHFPT):PRCHFPT,1:0),(PRCHS,PRCHDA,PRCHDTA)=0,PRCHSHP="",$P(PRCHULN,"_",97)="" I +$P(PRCH0,U,2)'=4,$P(PRCH1,U,12)="" S PRCHSHP=$S($D(^PRC(411,PRCHSIT,1,+$P(PRCH1,U,3),0)):^(0),1:"")
+16 SET PRCHFPT=+$GET(PRCHFPT)
SET (PRCHS,PRCHDA,PRCHDTA)=0
SET PRCHSHP=""
SET $PIECE(PRCHULN,"_",97)=""
IF +$PIECE(PRCH0,U,2)'=4
IF $PIECE(PRCH1,U,12)=""
SET PRCHSHP=$GET(^PRC(411,PRCHSIT1,1,+$PIECE(PRCH1,U,3),0))
+17 ;I '$T,$P(PRCH1,U,12)]"" S PRCHSHP=$S($D(^PRC(440.2,$P(PRCH1,U,12),0)):^(0),1:""),PRCHS=1 I +PRCHSHP>0 S $P(PRCHSHP,U,1)=$S($D(^DPT(+PRCHSHP,0)):$E($P(^(0),U,1),1,21),1:"")
+18 IF '$TEST
IF $PIECE(PRCH1,U,12)]""
SET PRCHSHP=$GET(^PRC(440.2,$PIECE(PRCH1,U,12),0))
SET PRCHS=1
IF +PRCHSHP>0
SET $PIECE(PRCHSHP,U,1)=$EXTRACT($PIECE($GET(^DPT(+PRCHSHP,0)),U,1),1,21)
+19 SET PRCHST=$GET(^PRC(411,PRCHSIT1,0))
SET PRCHHSP=$GET(^(3))
SET X=+$PIECE(PRCH12,U,6)
SET PRCHINV=$GET(^(4,X,0))
+20 ;PRC*5.1*221
DO PIPECK
+21 SET DIWL=1
SET DIWR=33
SET DIWF=""
SET PRCH=0
FOR I=0:0
SET PRCH=$ORDER(^PRC(442,D0,2,PRCH))
if 'PRCH
QUIT
KILL ^UTILITY($JOB,"W")
DO LC
+22 SET DIWL=1
SET DIWR=64
SET DIWF=""
SET PRCH=0
KILL ^PRC(442,D0,15,9999999)
IF $DATA(^PRC(442,D0,11,PRCHFPT,0))
IF $PIECE(^(0),U,10)="Y"
SET ^PRC(442,D0,15,9999999,0)=9999999
+23 FOR I=0:0
SET PRCH=$ORDER(^PRC(442,D0,15,PRCH))
if 'PRCH
QUIT
SET PRCHI=PRCH
SET PRCHK=+^(PRCH,0)
IF $DATA(^PRC(442.7,PRCHK,0))
IF $ORDER(^(1,0))
KILL ^UTILITY($JOB,"W")
DO LC1
+24 IF $DATA(PRCHI)
IF PRCHI
IF $DATA(^PRC(442,D0,15,PRCHI,0))
SET $PIECE(^(0),U,2)=$PIECE(^(0),U,2)-1
+25 KILL PRCHI
+26 GOTO STP^PRCHFPT0
+27 ;
LC ;PRC*5.1*221
if '$DATA(^PRC(442,D0,2,PRCH,1,0))
QUIT
SET PRCHJ=0
FOR
SET PRCHJ=$ORDER(^PRC(442,D0,2,PRCH,1,PRCHJ))
if PRCHJ=""
QUIT
SET X=^(PRCHJ,0)
if PURPIPE
SET DIWF=$GET(DIWF)_"|"
DO DIWP^PRCUTL($GET(DA))
+1 SET PRCHLC=+^UTILITY($JOB,"W",1)
if PRCHLC>0
SET $PIECE(^PRC(442,D0,2,PRCH,2),U,4)=PRCHLC
SET X=$ORDER(^PRC(442,D0,2,PRCH,3,"AC",PRCHFPT,0))
+2 IF PRCHDES="R"
IF X
IF $DATA(^PRC(442,D0,2,PRCH,3,X,0))
SET PRCHDA=PRCHDA+$PIECE(^(0),U,5)
SET PRCHDTA=PRCHDTA+$PIECE(^(0),U,3)
+3 QUIT
+4 ;
LC1 NEW PURPIPE
SET DIWF=""
+1 ;PRC*5.1*221
DO PIPECK
SET PRCHDIW=0
+2 FOR PRCHJ=0:0
SET PRCHJ=$ORDER(^PRC(442.7,PRCHK,1,PRCHJ))
if 'PRCHJ
QUIT
SET X=^(PRCHJ,0)
if PURPIPE
SET DIWF=$GET(DIWF)_"|"
DO DIWP^PRCUTL($GET(DA))
+3 SET PRCHLC=+^UTILITY($JOB,"W",1)
if PRCHLC>0
SET $PIECE(^PRC(442,D0,15,PRCH,0),U,2)=PRCHLC+1
+4 QUIT
+5 ;
FTYP ; RETURN FACILITY TYPE IN 'PRCHFTYP'
+1 NEW PRCSUB
+2 ;S PRCHFTYP="V.A. *FACILITY TYPE UNDEFINED*",X=$S($D(^PRC(411,PRC("SITE"),0)):$P(^(0),"^",7),1:"") S:X="" X=1
+3 SET PRCHFTYP="V.A. *FACILITY TYPE UNDEFINED*"
+4 SET X=$PIECE($GET(^PRC(411,PRC("SITE"),0)),"^",7)
if X=""
SET X=1
+5 IF $PIECE($GET(^PRC(442,D0,23)),U,7)]""
SET PRCSUB=$PIECE(^(23),U,7)
Begin DoDot:1
+6 SET X=$PIECE($GET(^PRC(411,PRCSUB,0)),"^",7)
if X=""
SET X=1
End DoDot:1
+7 ;I '$D(PRCHFTP2) S PRCHFTYP=$S($D(^PRC(411.2,+X,0)):$P(^(0),U,2),1:"")
+8 IF '$DATA(PRCHFTP2)
SET PRCHFTYP=$PIECE($GET(^PRC(411.2,+X,0)),U,2)
+9 ;I $D(PRCHFTP2) S PRCHFTYP=$S($D(^PRC(411.2,+X,0)):$P(^(0),U,1),1:"")
+10 IF $DATA(PRCHFTP2)
SET PRCHFTYP=$PIECE($GET(^PRC(411.2,+X,0)),U,1)
+11 KILL PRCHFTP2
+12 QUIT
+13 ;
FTYPS ;ABBREVIATED FACILITY TYPE
+1 SET PRCHFTP2="SHORT"
+2 GOTO FTYP
+3 ;
SJD ;SET JULIAN DATE
+1 SET X=$PIECE(PRCH1,U,15)
DO JD^PRCFDLN
SET PRCHJD=$EXTRACT(Y,4)_$EXTRACT(Y,1,3)
+2 QUIT
+3 ;
PSNO ;PRINT SERIAL NO.
+1 if $DATA(^PRC(442,D0,2,PRCH,4))
WRITE $SELECT($PIECE(^(4),U,1):" ("_PRCHJD_"-"_$PIECE(^(4),U,1)_")",1:"")
+2 QUIT
FTYP1 ; RETURN FACILITY TYPE IN 'PRCHFTYP'
+1 NEW PRCSUB
+2 SET PRCHFTYP="V.A. *FACILITY TYPE UNDEFINED*"
+3 SET X=$PIECE($GET(^PRC(411,PRC("SITE"),0)),"^",7)
if X=""
SET X=1
+4 IF $PIECE($GET(^PRCS(410,D0,0)),U,10)]""
SET PRCSUB=$PIECE(^(0),U,10)
Begin DoDot:1
+5 SET X=$PIECE($GET(^PRC(411,PRCSUB,0)),"^",7)
if X=""
SET X=1
End DoDot:1
+6 IF '$DATA(PRCHFTP2)
SET PRCHFTYP=$PIECE($GET(^PRC(411.2,+X,0)),U,2)
+7 IF $DATA(PRCHFTP2)
SET PRCHFTYP=$PIECE($GET(^PRC(411.2,+X,0)),U,1)
+8 KILL PRCHFTP2
+9 QUIT
PIPECK ;check for invalid pipe '|IN ' command in item description ;PRC*5.1*221
+1 SET PURPIPE=0
SET PRCH=0
+2 FOR PRCHI=1:1
SET PRCH=$ORDER(^PRC(442,D0,2,PRCH))
SET PRCHDIW=0
if 'PRCH
QUIT
Begin DoDot:1
+3 FOR PRCHJ=1:1
SET PRCHDIW=$ORDER(^PRC(442,D0,2,PRCH,1,PRCHDIW))
if PRCHDIW'>0
QUIT
SET X=$SELECT($DATA(^(PRCHDIW,0)):^(0),1:"")
Begin DoDot:2
+4 IF X["| IN "
SET PURPIPE=1
+5 QUIT
End DoDot:2
if PURPIPE
QUIT
End DoDot:1
if PURPIPE
QUIT
+6 QUIT
