PRCHPNT2 ;ID/RSD/RHD-CONT. OF PRINT ;5/4/98 14:17
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
ITEM S DIWL=1,DIWR=33,DIWF="",PRCHD=0 K ^UTILITY($J,"W")
F K=0:0 S PRCHD=$O(^PRC(442,D0,2,PRCH,1,PRCHD)) Q:PRCHD=""!(PRCHD<0) S X=$G(^(PRCHD,0)) D DIWP^PRCUTL($G(DA))
S PRCHCNT=$G(^UTILITY($J,"W",1)),PRCHL=PRCHL+PRCHCNT+1 W !?2,$J($P(PRCHI2,U,5)_+$P(PRCHI0,U,1),3),?8,$G(^(1,1,0))
W ?48,$J($P(PRCHI0,U,2),7),?57,$P($G(^PRCD(420.5,+$P(PRCHI0,U,3),0)),U,1)
S X=$P($P(PRCHI0,U,9),".",2) W ?59,$S($L(X)>3:$J($P(PRCHI0,U,9),8,4),$L(X)>2:$J($P(PRCHI0,U,9),8,3),$P(PRCHI0,U,9)="N/C":" N/C",1:$J($P(PRCHI0,U,9),8,2)) S PRCHC=1 I $P(PRCHI2,U,1)<10000 D AMT
I PRCHCNT>1 F K=2:1:$P(^TMP($J,"P",P,PRCH),U,2) W:$D(^TMP($J,"W",1,K,0)) !?8,^(0) D:PRCHC AMT
W ! S PRCHL=PRCHL+1 I $P(PRCHI0,U,6)]"" W ?8,"STK#: ",$P(PRCHI0,U,6),! S PRCHL=PRCHL+1
I $P(PRCHI0,U,13)]"" W ?8,"NSN: ",$P(PRCHI0,U,13) D:$D(PRCHNRQ) PSNO^PRCHFPNT W ! S PRCHL=PRCHL+1
I $P($G(^PRC(442,D0,2,PRCH,4)),U,12)]"" W ?8,"FOOD GROUP: ",$P(^(4),U,12),! S PRCHL=PRCHL+1
D EDISTAT^PRCHUTL(D0,PRCH,.PRCHL)
I $P(PRCHI0,U,12) W ?8,"Items per ",$P($G(^PRCD(420.5,+$P(PRCHI0,U,3),0)),U,1),": ",$P(PRCHI0,U,12),! S PRCHL=PRCHL+1
D:PRCHC AMT Q
;
AMT W ?67,$J($P(PRCHI2,U,1),8,2) S PRCHC=0,PRCHPT=PRCHPT+$P(PRCHI2,U,1)
Q
;
FOB ;
I $P($G(^PRC(442,D0,0)),U,2)=25 D G FA
. N PRCA,PRCB,PRCC
. S PRCHINV(1)="** No Purchase Card Info",PRCHINV(2)="",PRCHINV(3)="",PRCHINV(4)="",PRCHINV(5)=""
. S PRCA=$P($G(^PRC(442,D0,23)),U,8) Q:PRCA'>0
. S PRCB=$G(^PRC(440.5,PRCA,0)) Q:PRCB=""
. S PRCC=$P(PRCB,U,8) S:PRCC>0 PRCC=$P($G(^VA(200,PRCC,0)),U)
. S PRCA=$P(PRCB,U,11),PRCHINV(1)="PURCHASE CARD HOLDER"
. S PRCHINV(2)=" "_$E(PRCC,1,25),PRCHINV(3)="PURCHASE CARD NAME"
. S PRCHINV(4)=" "_$E(PRCA,1,25),PRCHINV(5)=""
S PRCHINV(1)=$P(PRCHINV,U,1),PRCHINV(2)=$P(PRCHINV,U,2),X=3 S:$P(PRCHINV,U,3)]"" PRCHINV(X)=$P(PRCHINV,U,3),X=X+1 S:$P(PRCHINV,U,4)]"" PRCHINV(X)=$P(PRCHINV,U,4),X=X+1
S PRCHINV(X)=$P(PRCHINV,U,5)_", "_$P($G(^DIC(5,+$P(PRCHINV,U,6),0)),U,2)_" "_$P(PRCHINV,U,7) F X=X+1:1:5 S PRCHINV(X)=""
FA S PRCHSC=$P($G(^PRCD(420.8,+$P(PRCH1,U,7),0)),U,1) W !!?2,$S("O"=$E($P(PRCH1,U,6)):"ORIGIN","D"=$E($P(PRCH1,U,6)):"DESTINATION",1:""),?30,$J($P(PRCH1,U,14),3),?33,$S("2B"[PRCHSC:"X",1:"")
S DIWL=1,DIWR=16,DIWF="",X=$P(PRCH1,U,8) K ^UTILITY($J,"W") D DIWP^PRCUTL($G(DA))
W ?48,$G(^UTILITY($J,"W",1,1,0)),?69,PRCHINV(1),!?48,$G(^UTILITY($J,"W",1,2,0)),?69,PRCHINV(2)
W !?2,$P(PRCH12,U,7),?48,$G(^UTILITY($J,"W",1,3,0)),?69,PRCHINV(3)
;
DIS W !?24,"ON OR",?33,$S(PRCHSC]""&(PRCHSC'=2):"X",1:""),?69,PRCHINV(4),!?2
S PRCH=0 I $D(^PRC(442,D0,5,0)) F I=1:1:2 S PRCH=$O(^PRC(442,D0,5,PRCH)) Q:PRCH=""!(PRCH'>0) W $P(^(PRCH,0),U,4),$P(^(0),U,1) W:$P(^(0),U,1)=+$P(^(0),U,1) "%" W $P(^(0),U,2)," "
W ?14,"BEFORE",?23 S Y=$P(PRCH0,U,10) D DT S PRCH=0
;
CON F I=0:1:3 S PRCH=$O(^PRC(442,D0,2,"AC",PRCH)) Q:PRCH="" W:I=2 ?2,$P(PRCH12,U,8) S Y=$O(^(PRCH,0)) W:^(Y)]"" ?45,$J(^(Y),3) W ?49,PRCH W:I=0 ?69,PRCHINV(5) W !
F Y=I:1:4 W:Y=0 ?69,PRCHINV(5) W:Y=2 ?2,$P(PRCH12,U,8) W !
K PRCHHSP,PRCHINV,PRCHSHP,PRCHST,S,V S PRCHL=18,P=1,PRCH=0
;
CNTI S PRCH=$O(^PRC(442,D0,2,PRCH)) G:PRCH=""!(PRCH'>0) CNTD S PRCHLB=1,PRCHL1=$P(^(PRCH,2),U,4) S:$P(^(0),U,6)]"" PRCHL1=PRCHL1+1 S:$P(^(0),U,13)]"" PRCHL1=PRCHL1+1 S:$P(^(0),U,9) PRCHL1=PRCHL1+1 S:$P(^(0),U,11) PRCHL1=PRCHL1+1
S:$P(^PRC(442,D0,2,PRCH,0),U,9)!($P(^(0),U,11)) PRCHL1=PRCHL1+2
D P:PRCHL-1<PRCHL1 S ^TMP($J,"P",P,PRCH)=PRCHLB_U_PRCHL1,PRCHL=PRCHL-PRCHL1-1
G CNTI
;
CNTD S (PRCHLE,PRCHLB,PRCH)=0 F J=0:0 S PRCH=$O(^PRC(442,D0,3,PRCH)) Q:PRCH=""!(PRCH'>0) S:PRCHLB=0 PRCHLB=PRCH S PRCHLE=PRCH D P1:PRCHL-2<1 S ^TMP($J,"P",P,"D")=PRCHLB_U_PRCHLE,PRCHL=PRCHL-2
I $P(PRCH0,U,13)>0!($P(PRCH0,U,18)>0) D:PRCHL-2<1 P1 S ^TMP($J,"P",P,"E")=$P(PRCH0,U,13),PRCHL=PRCHL-2
I $D(^PRC(442,D0,15)) F J=0:0 S J=$O(^PRC(442,D0,15,J)) Q:'J S PRCHJ=^(J,0),PRCH="F"_J_U_+PRCHJ,PRCHLB=1,PRCHL1=$P(PRCHJ,U,2) D P:PRCHL-1<PRCHL1 S ^TMP($J,"P",P,PRCH)=PRCHLB_U_PRCHL1,PRCHL=PRCHL-PRCHL1-1
G REQ:'$D(^PRC(442,D0,4,0)) K ^UTILITY($J,"W") S DIWL=1,DIWR=54,DIWF="",PRCH="W",PRCHJ=0 F S PRCHJ=$O(^PRC(442,D0,4,PRCHJ)) Q:PRCHJ=""!(PRCHJ<0) S X=^(PRCHJ,0) D DIWP^PRCUTL($G(DA))
S PRCHL1=+^UTILITY($J,"W",1),PRCHLB=1 D P:PRCHL-1<PRCHL1 S ^TMP($J,"P",P,"W")=PRCHLB_U_PRCHL1,PRCHL=PRCHL-PRCHL1-1
;
REQ I $D(^PRC(442,D0,13,0)) S (PRCHLE,PRCHLB,PRCH)=0 F J=0:0 S PRCH=$O(^PRC(442,D0,13,PRCH)) Q:'PRCH S:PRCHLB=0 I=3,PRCHLB=PRCH S PRCHLE=PRCH D P1:PRCHL-I<1 S ^TMP($J,"P",P,"X")=PRCHLB_U_PRCHLE,PRCHL=PRCHL-1,I=2
G ^PRCHPNT1
;
P I PRCHL<5 S PRCHL=45,P=P+1 Q
S PRCHLE=PRCHL-2,^TMP($J,"P",P,PRCH)=PRCHLB_U_PRCHLE,P=P+1,PRCHLB=PRCHLE+1,PRCHL=45
Q
;
P1 S PRCHLB=PRCHLE,PRCHL=45,P=P+1
Q
;
DT I Y W Y\100#100,"/",Y#100\1,"/",Y\10000+1700
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHPNT2 4853 printed Sep 23, 2025@19:45:30 Page 2
PRCHPNT2 ;ID/RSD/RHD-CONT. OF PRINT ;5/4/98 14:17
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
ITEM SET DIWL=1
SET DIWR=33
SET DIWF=""
SET PRCHD=0
KILL ^UTILITY($JOB,"W")
+1 FOR K=0:0
SET PRCHD=$ORDER(^PRC(442,D0,2,PRCH,1,PRCHD))
if PRCHD=""!(PRCHD<0)
QUIT
SET X=$GET(^(PRCHD,0))
DO DIWP^PRCUTL($GET(DA))
+2 SET PRCHCNT=$GET(^UTILITY($JOB,"W",1))
SET PRCHL=PRCHL+PRCHCNT+1
WRITE !?2,$JUSTIFY($PIECE(PRCHI2,U,5)_+$PIECE(PRCHI0,U,1),3),?8,$GET(^(1,1,0))
+3 WRITE ?48,$JUSTIFY($PIECE(PRCHI0,U,2),7),?57,$PIECE($GET(^PRCD(420.5,+$PIECE(PRCHI0,U,3),0)),U,1)
+4 SET X=$PIECE($PIECE(PRCHI0,U,9),".",2)
WRITE ?59,$SELECT($LENGTH(X)>3:$JUSTIFY($PIECE(PRCHI0,U,9),8,4),$LENGTH(X)>2:$JUSTIFY($PIECE(PRCHI0,U,9),8,3),$PIECE(PRCHI0,U,9)="N/C":" N/C",1:$JUSTIFY($PIECE(PRCHI0,U,9),8,2))
SET PRCHC=1
IF $PIECE(PRCHI2,U,1)<10000
DO AMT
+5 IF PRCHCNT>1
FOR K=2:1:$PIECE(^TMP($JOB,"P",P,PRCH),U,2)
if $DATA(^TMP($JOB,"W",1,K,0))
WRITE !?8,^(0)
if PRCHC
DO AMT
+6 WRITE !
SET PRCHL=PRCHL+1
IF $PIECE(PRCHI0,U,6)]""
WRITE ?8,"STK#: ",$PIECE(PRCHI0,U,6),!
SET PRCHL=PRCHL+1
+7 IF $PIECE(PRCHI0,U,13)]""
WRITE ?8,"NSN: ",$PIECE(PRCHI0,U,13)
if $DATA(PRCHNRQ)
DO PSNO^PRCHFPNT
WRITE !
SET PRCHL=PRCHL+1
+8 IF $PIECE($GET(^PRC(442,D0,2,PRCH,4)),U,12)]""
WRITE ?8,"FOOD GROUP: ",$PIECE(^(4),U,12),!
SET PRCHL=PRCHL+1
+9 DO EDISTAT^PRCHUTL(D0,PRCH,.PRCHL)
+10 IF $PIECE(PRCHI0,U,12)
WRITE ?8,"Items per ",$PIECE($GET(^PRCD(420.5,+$PIECE(PRCHI0,U,3),0)),U,1),": ",$PIECE(PRCHI0,U,12),!
SET PRCHL=PRCHL+1
+11 if PRCHC
DO AMT
QUIT
+12 ;
AMT WRITE ?67,$JUSTIFY($PIECE(PRCHI2,U,1),8,2)
SET PRCHC=0
SET PRCHPT=PRCHPT+$PIECE(PRCHI2,U,1)
+1 QUIT
+2 ;
FOB ;
+1 IF $PIECE($GET(^PRC(442,D0,0)),U,2)=25
Begin DoDot:1
+2 NEW PRCA,PRCB,PRCC
+3 SET PRCHINV(1)="** No Purchase Card Info"
SET PRCHINV(2)=""
SET PRCHINV(3)=""
SET PRCHINV(4)=""
SET PRCHINV(5)=""
+4 SET PRCA=$PIECE($GET(^PRC(442,D0,23)),U,8)
if PRCA'>0
QUIT
+5 SET PRCB=$GET(^PRC(440.5,PRCA,0))
if PRCB=""
QUIT
+6 SET PRCC=$PIECE(PRCB,U,8)
if PRCC>0
SET PRCC=$PIECE($GET(^VA(200,PRCC,0)),U)
+7 SET PRCA=$PIECE(PRCB,U,11)
SET PRCHINV(1)="PURCHASE CARD HOLDER"
+8 SET PRCHINV(2)=" "_$EXTRACT(PRCC,1,25)
SET PRCHINV(3)="PURCHASE CARD NAME"
+9 SET PRCHINV(4)=" "_$EXTRACT(PRCA,1,25)
SET PRCHINV(5)=""
End DoDot:1
GOTO FA
+10 SET PRCHINV(1)=$PIECE(PRCHINV,U,1)
SET PRCHINV(2)=$PIECE(PRCHINV,U,2)
SET X=3
if $PIECE(PRCHINV,U,3)]""
SET PRCHINV(X)=$PIECE(PRCHINV,U,3)
SET X=X+1
if $PIECE(PRCHINV,U,4)]""
SET PRCHINV(X)=$PIECE(PRCHINV,U,4)
SET X=X+1
+11 SET PRCHINV(X)=$PIECE(PRCHINV,U,5)_", "_$PIECE($GET(^DIC(5,+$PIECE(PRCHINV,U,6),0)),U,2)_" "_$PIECE(PRCHINV,U,7)
FOR X=X+1:1:5
SET PRCHINV(X)=""
FA SET PRCHSC=$PIECE($GET(^PRCD(420.8,+$PIECE(PRCH1,U,7),0)),U,1)
WRITE !!?2,$SELECT("O"=$EXTRACT($PIECE(PRCH1,U,6)):"ORIGIN","D"=$EXTRACT($PIECE(PRCH1,U,6)):"DESTINATION",1:""),?30,$JUSTIFY($PIECE(PRCH1,U,14),3),?33,$SELECT("2B"[PRCHSC:"X",1:"")
+1 SET DIWL=1
SET DIWR=16
SET DIWF=""
SET X=$PIECE(PRCH1,U,8)
KILL ^UTILITY($JOB,"W")
DO DIWP^PRCUTL($GET(DA))
+2 WRITE ?48,$GET(^UTILITY($JOB,"W",1,1,0)),?69,PRCHINV(1),!?48,$GET(^UTILITY($JOB,"W",1,2,0)),?69,PRCHINV(2)
+3 WRITE !?2,$PIECE(PRCH12,U,7),?48,$GET(^UTILITY($JOB,"W",1,3,0)),?69,PRCHINV(3)
+4 ;
DIS WRITE !?24,"ON OR",?33,$SELECT(PRCHSC]""&(PRCHSC'=2):"X",1:""),?69,PRCHINV(4),!?2
+1 SET PRCH=0
IF $DATA(^PRC(442,D0,5,0))
FOR I=1:1:2
SET PRCH=$ORDER(^PRC(442,D0,5,PRCH))
if PRCH=""!(PRCH'>0)
QUIT
WRITE $PIECE(^(PRCH,0),U,4),$PIECE(^(0),U,1)
if $PIECE(^(0),U,1)=+$PIECE(^(0),U,1)
WRITE "%"
WRITE $PIECE(^(0),U,2)," "
+2 WRITE ?14,"BEFORE",?23
SET Y=$PIECE(PRCH0,U,10)
DO DT
SET PRCH=0
+3 ;
CON FOR I=0:1:3
SET PRCH=$ORDER(^PRC(442,D0,2,"AC",PRCH))
if PRCH=""
QUIT
if I=2
WRITE ?2,$PIECE(PRCH12,U,8)
SET Y=$ORDER(^(PRCH,0))
if ^(Y)]""
WRITE ?45,$JUSTIFY(^(Y),3)
WRITE ?49,PRCH
if I=0
WRITE ?69,PRCHINV(5)
WRITE !
+1 FOR Y=I:1:4
if Y=0
WRITE ?69,PRCHINV(5)
if Y=2
WRITE ?2,$PIECE(PRCH12,U,8)
WRITE !
+2 KILL PRCHHSP,PRCHINV,PRCHSHP,PRCHST,S,V
SET PRCHL=18
SET P=1
SET PRCH=0
+3 ;
CNTI SET PRCH=$ORDER(^PRC(442,D0,2,PRCH))
if PRCH=""!(PRCH'>0)
GOTO CNTD
SET PRCHLB=1
SET PRCHL1=$PIECE(^(PRCH,2),U,4)
if $PIECE(^(0),U,6)]""
SET PRCHL1=PRCHL1+1
if $PIECE(^(0),U,13)]""
SET PRCHL1=PRCHL1+1
if $PIECE(^(0),U,9)
SET PRCHL1=PRCHL1+1
if $PIECE(^(0),U,11)
SET PRCHL1=PRCHL1+1
+1 if $PIECE(^PRC(442,D0,2,PRCH,0),U,9)!($PIECE(^(0),U,11))
SET PRCHL1=PRCHL1+2
+2 if PRCHL-1<PRCHL1
DO P
SET ^TMP($JOB,"P",P,PRCH)=PRCHLB_U_PRCHL1
SET PRCHL=PRCHL-PRCHL1-1
+3 GOTO CNTI
+4 ;
CNTD SET (PRCHLE,PRCHLB,PRCH)=0
FOR J=0:0
SET PRCH=$ORDER(^PRC(442,D0,3,PRCH))
if PRCH=""!(PRCH'>0)
QUIT
if PRCHLB=0
SET PRCHLB=PRCH
SET PRCHLE=PRCH
if PRCHL-2<1
DO P1
SET ^TMP($JOB,"P",P,"D")=PRCHLB_U_PRCHLE
SET PRCHL=PRCHL-2
+1 IF $PIECE(PRCH0,U,13)>0!($PIECE(PRCH0,U,18)>0)
if PRCHL-2<1
DO P1
SET ^TMP($JOB,"P",P,"E")=$PIECE(PRCH0,U,13)
SET PRCHL=PRCHL-2
+2 IF $DATA(^PRC(442,D0,15))
FOR J=0:0
SET J=$ORDER(^PRC(442,D0,15,J))
if 'J
QUIT
SET PRCHJ=^(J,0)
SET PRCH="F"_J_U_+PRCHJ
SET PRCHLB=1
SET PRCHL1=$PIECE(PRCHJ,U,2)
if PRCHL-1<PRCHL1
DO P
SET ^TMP($JOB,"P",P,PRCH)=PRCHLB_U_PRCHL1
SET PRCHL=PRCHL-PRCHL1-1
+3 if '$DATA(^PRC(442,D0,4,0))
GOTO REQ
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=54
SET DIWF=""
SET PRCH="W"
SET PRCHJ=0
FOR
SET PRCHJ=$ORDER(^PRC(442,D0,4,PRCHJ))
if PRCHJ=""!(PRCHJ<0)
QUIT
SET X=^(PRCHJ,0)
DO DIWP^PRCUTL($GET(DA))
+4 SET PRCHL1=+^UTILITY($JOB,"W",1)
SET PRCHLB=1
if PRCHL-1<PRCHL1
DO P
SET ^TMP($JOB,"P",P,"W")=PRCHLB_U_PRCHL1
SET PRCHL=PRCHL-PRCHL1-1
+5 ;
REQ IF $DATA(^PRC(442,D0,13,0))
SET (PRCHLE,PRCHLB,PRCH)=0
FOR J=0:0
SET PRCH=$ORDER(^PRC(442,D0,13,PRCH))
if 'PRCH
QUIT
if PRCHLB=0
SET I=3
SET PRCHLB=PRCH
SET PRCHLE=PRCH
if PRCHL-I<1
DO P1
SET ^TMP($JOB,"P",P,"X")=PRCHLB_U_PRCHLE
SET PRCHL=PRCHL-1
SET I=2
+1 GOTO ^PRCHPNT1
+2 ;
P IF PRCHL<5
SET PRCHL=45
SET P=P+1
QUIT
+1 SET PRCHLE=PRCHL-2
SET ^TMP($JOB,"P",P,PRCH)=PRCHLB_U_PRCHLE
SET P=P+1
SET PRCHLB=PRCHLE+1
SET PRCHL=45
+2 QUIT
+3 ;
P1 SET PRCHLB=PRCHLE
SET PRCHL=45
SET P=P+1
+1 QUIT
+2 ;
DT IF Y
WRITE Y\100#100,"/",Y#100\1,"/",Y\10000+1700
+1 QUIT
