PRCSP121 ;WISC/SAW/BMM-CONTROL POINT ACTIVITY 2237 PRINTOUT CON'T ;6/25/12 14:00
;;5.1;IFCAP;**81,167**;Oct 20, 2000;Build 17
;Per VHA Directive 2004-38, this routine should not be modified.
;
;PRINT ITEMS ; REW fixed next line for Archiving "just in case"
;
;PRC*5.1*81 BMM edit PRCARD to add DM Doc ID (410.02, 17) and Date
;Needed By (410.02, 18) fields to printout
;
I $D(^PRCS(410,DA,1)),$P(^(1),U,5)'="" S P=$P(^(1),U,5),P=$P($G(^PRCS(410.2,P,0),">>> PRCS(410.2,"_P_",0) is not defined but referenced in PRCSP121 for record: "_DA_" <<<"),U) W !,?12,"|",P,":",?38,"|",?48,"|",?53,"|",?63,"|",?73,"|",?84,"|"
S DIWL=19,DIWR=35,DIWF="",P(1)=0
F I=1:1 K ^UTILITY($J,"W") S P(1)=$O(^PRCS(410,DA,"IT",P(1))) G VENDOR:P(1)'>0 D ITEM1
ITEM1 Q:'$D(^PRCS(410,DA,"IT",P(1),0)) S Z=^(0),P(4)=$P(Z,U,6)
S PRCS("SUB")=+$P(Z,U,4),P(3)=$P(Z,U,3) S P(3)=$S($D(^PRCD(420.5,+P(3),0)):$P(^(0),U),1:"")
S P(0)="|"_$S($P(Z,U,2)[".":$J($P(Z,U,2),9,2),1:$J($P(Z,U,2),9))_"|"_$J(P(3),4)_"|"_$S($P(Z,U,7)="N/C":$J("N/C",9),1:$J($P(Z,U,7),9,4))_"|"
G PRCARD:$P(Z,U,5)
S P(2)=0 F I=1:1 S P(2)=$O(^PRCS(410,DA,"IT",P(1),1,P(2))) Q:P(2)="" S X=^(P(2),0) S:I=1 X=$P(^PRCS(410,DA,"IT",P(1),0),U)_" "_X D DIWP^PRCUTL($G(DA))
ITEM2 I '$D(^UTILITY($J,"W",DIWL)) S ^(DIWL)=1,^(DIWL,1,0)="***NO DESCRIPTION***"
S Z=^UTILITY($J,"W",DIWL)
I $L(P(4))>12 W !,$E(P(4),1,12),"|",?38,"|",?48,"|",?53,"|",?63,"|",?73,"|",?84,"|",!,$E(P(4),13,24)
I $L(P(4))<13 W !,P(4)
I Z>1 F J=1:1:(Z-1) W ?12,"|",^UTILITY($J,"W",DIWL,J,0),?38,"|",?48,"|",?53,"|",?63,"|",?73,"|",?84,"|" D:$Y>61 NEWP W !
I Z>1 W ?12,"|",^UTILITY($J,"W",DIWL,Z,0),?38,P(0),?73,"|",?84,"|"
I Z<2 W ?12,"|",^UTILITY($J,"W",DIWL,1,0),?38,P(0),?73,"|",?84,"|"
I $P($G(^PRCS(410,DA,"IT",P(1),4)),U,3)]"" D:$Y>61 NEWP W !?12,"|","eCMS Line ID ",$P(^PRCS(410,DA,"IT",P(1),4),U,3),?38,"|",?48,"|",?53,"|",?63,"|",?73,"|",?84,"|"
D:$Y>61 NEWP W !,?12,"|",?38,"|",?48,"|",?53,"|",?63,"|",?73,"|",?84,"|"
Q
PRCARD S P("PR")=$P(^PRCS(410,DA,"IT",P(1),0),U,5) G ITEM2:'$D(^PRC(441,P("PR"),1,0))
S P("PR1")=0,X=$P(^PRCS(410,DA,"IT",P(1),0),U)_" ITEM ID NO. "_P("PR") D DIWP^PRCUTL($G(DA)) F I=1:1 S P("PR1")=$O(^PRC(441,P("PR"),1,P("PR1"))) Q:P("PR1")="" S X=^(P("PR1"),0) D DIWP^PRCUTL($G(DA))
S Z="" S:$P(^PRC(441,P("PR"),0),U,5)'="" Z=Z_" (NSN: "_$P(^(0),U,5)_")" S Z1=$P(^PRCS(410,DA,3),U,4) I Z1,$D(^PRC(441,P("PR"),2,Z1,0)) S:$P(^(0),U,5)'="" Z=Z_" (NDC: "_$P(^(0),U,5)_")" S:$P(^(0),U,3) Z2=$P(^(0),U,3)
S:$P($G(^PRC(441,P("PR"),3)),U,7)'="" Z=Z_" FOOD GROUP: "_$P(^(3),U,7)
I Z1,$D(^PRC(441,P("PR"),2,Z1,0)) S Z=Z_" PKG: "_$P(^(0),U,8)_" per "_$S($D(^PRCD(420.5,+$P(^(0),U,7),0)):$P(^(0),U),1:"")
I $D(Z2),$D(^PRC(440,+Z1,4,+Z2,0)),$P(^(0),U)'="" S Y=$S($P(^(0),U,2):$P(^(0),U,2),1:"") X:Y ^DD("DD") S Z=Z_" (CONTRACT # "_$P(^PRC(440,Z1,4,Z2,0),U)_$S(Y'="":", EXPIRATION DATE: "_Y_")",1:")") K Z2
S X=Z D:$L(X) DIWP^PRCUTL($G(DA))
;PRC*5.1*81 add DM Doc ID and Date Needed By fields to ^UTILITY
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1,$P($G(^PRCS(410,DA,"IT",P(1),4)),U)]"" D
. S X="DM Doc ID: "_$P(^PRCS(410,DA,"IT",P(1),4),U)_" Date Needed By: "_$$FMTE^XLFDT($P(^(4),U,2)) D DIWP^PRCUTL($G(DA))
G ITEM2
VENDOR ;PRINT VENDOR AND REQ MESSAGES
N Z0
I $Y>60 D NEWP
I $D(^PRCS(410,DA,4)),$P(^(4),U)'="" W !,?12,"|TOTAL COST: ","$"_$J($P(^(4),U),0,2),?38,"|",?48,"|",?53,"|",?63,"|",?73,"|",?84,"|"
W !,$E(L,1,12),"|",$E(L,1,25),"|",$E(L,1,9),"|",$E(L,1,4),"|",$E(L,1,9),"|",$E(L,1,9),"|",$E(L,1,10),"|",$E(L,1,5) I $Y>60 D NEWP
G RM:'$D(^PRCS(410,DA,2))
I $D(^PRCS(410,DA,2)),$P(^(2),U)="" G RM
I $Y>56 D NEWP
S (X,Z0)=$P(^PRCS(410,DA,3),U,4),X=$S(X:"VENDOR INFORMATION: NO. "_X,1:"NEW VENDOR INFORMATION:") W !,X
I Z0,$D(^PRC(440,Z0,3)),$P(^(3),U,2)="Y" W ?38,"EDI"
I Z0,$D(^PRC(440,Z0,10)),$P(^(10),U,6)'="" W ?46,"FAX: "_$P(^(10),U,6)
S X=^PRCS(410,DA,2) W !,"VENDOR: ",$P(X,U) W:$P(X,U,9)'="" ?42,"CONTACT: ",$P(X,U,9)
W:$P(X,U,2)'="" !,?8,$P(X,U,2) W:$P(X,U,10)'="" ?44,"PHONE: ",$P(X,U,10)
W:$P(X,U,3)'="" !,?8,$P(X,U,3) S Z1=$P(^PRCS(410,DA,3),U,4) I Z1,$D(^PRC(440,Z1,2)),$P(^(2),U)'="" W ?42,"ACCT. #: ",$P(^(2),U)
W:$P(X,U,4)'="" !,?8,$P(X,U,4) W:$P(X,U,5)'="" !,?8,$P(X,U,5)
I $P(X,U,6)'="" W !,?8,$P(X,U,6) W:+$P(X,U,7)'=0 ",",$P($G(^DIC(5,$P(X,U,7),0)),U,2) W:$P(X,U,8)'="" " ",$P(X,U,8)
W !,L W !,"Ref. Voucher Number: ",! W:$P($G(^PRCS(410,DA,445)),"^")'="" $P(^(445),"^"),!
RM I $Y>68 D NEWP
Q
NEWP ;PRINT HEADER FOR NEW PAGE
W !,"VA FORM 90-2237-ADP MAR 1985" W:$Y>0 @IOF
S PRCS("P")=PRCS("P")+1 W !,?36,$P(^PRCS(410,DA,0),U),?83,"PAGE ",PRCS("P"),!,L
W !,?16,"REQUEST, TURN-IN, AND RECEIPT FOR PROPERTY OR SERVICES",! I $D(ZTDESC("NOPRINT")) W ?37,"**REPRINT**",!
W !,L
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP121 4753 printed Dec 13, 2024@02:17:56 Page 2
PRCSP121 ;WISC/SAW/BMM-CONTROL POINT ACTIVITY 2237 PRINTOUT CON'T ;6/25/12 14:00
+1 ;;5.1;IFCAP;**81,167**;Oct 20, 2000;Build 17
+2 ;Per VHA Directive 2004-38, this routine should not be modified.
+3 ;
+4 ;PRINT ITEMS ; REW fixed next line for Archiving "just in case"
+5 ;
+6 ;PRC*5.1*81 BMM edit PRCARD to add DM Doc ID (410.02, 17) and Date
+7 ;Needed By (410.02, 18) fields to printout
+8 ;
+9 IF $DATA(^PRCS(410,DA,1))
IF $PIECE(^(1),U,5)'=""
SET P=$PIECE(^(1),U,5)
SET P=$PIECE($GET(^PRCS(410.2,P,0),">>> PRCS(410.2,"_P_",0) is not defined but referenced in PRCSP121 for record: "_DA_" <<<"),U)
WRITE !,?12,"|",P,":",?38,"|",?48,"|",?53,"|",?63,"|",?73,"|",?84,"|"
+10 SET DIWL=19
SET DIWR=35
SET DIWF=""
SET P(1)=0
+11 FOR I=1:1
KILL ^UTILITY($JOB,"W")
SET P(1)=$ORDER(^PRCS(410,DA,"IT",P(1)))
if P(1)'>0
GOTO VENDOR
DO ITEM1
ITEM1 if '$DATA(^PRCS(410,DA,"IT",P(1),0))
QUIT
SET Z=^(0)
SET P(4)=$PIECE(Z,U,6)
+1 SET PRCS("SUB")=+$PIECE(Z,U,4)
SET P(3)=$PIECE(Z,U,3)
SET P(3)=$SELECT($DATA(^PRCD(420.5,+P(3),0)):$PIECE(^(0),U),1:"")
+2 SET P(0)="|"_$SELECT($PIECE(Z,U,2)[".":$JUSTIFY($PIECE(Z,U,2),9,2),1:$JUSTIFY($PIECE(Z,U,2),9))_"|"_$JUSTIFY(P(3),4)_"|"_$SELECT($PIECE(Z,U,7)="N/C":$JUSTIFY("N/C",9),1:$JUSTIFY($PIECE(Z,U,7),9,4))_"|"
+3 if $PIECE(Z,U,5)
GOTO PRCARD
+4 SET P(2)=0
FOR I=1:1
SET P(2)=$ORDER(^PRCS(410,DA,"IT",P(1),1,P(2)))
if P(2)=""
QUIT
SET X=^(P(2),0)
if I=1
SET X=$PIECE(^PRCS(410,DA,"IT",P(1),0),U)_" "_X
DO DIWP^PRCUTL($GET(DA))
ITEM2 IF '$DATA(^UTILITY($JOB,"W",DIWL))
SET ^(DIWL)=1
SET ^(DIWL,1,0)="***NO DESCRIPTION***"
+1 SET Z=^UTILITY($JOB,"W",DIWL)
+2 IF $LENGTH(P(4))>12
WRITE !,$EXTRACT(P(4),1,12),"|",?38,"|",?48,"|",?53,"|",?63,"|",?73,"|",?84,"|",!,$EXTRACT(P(4),13,24)
+3 IF $LENGTH(P(4))<13
WRITE !,P(4)
+4 IF Z>1
FOR J=1:1:(Z-1)
WRITE ?12,"|",^UTILITY($JOB,"W",DIWL,J,0),?38,"|",?48,"|",?53,"|",?63,"|",?73,"|",?84,"|"
if $Y>61
DO NEWP
WRITE !
+5 IF Z>1
WRITE ?12,"|",^UTILITY($JOB,"W",DIWL,Z,0),?38,P(0),?73,"|",?84,"|"
+6 IF Z<2
WRITE ?12,"|",^UTILITY($JOB,"W",DIWL,1,0),?38,P(0),?73,"|",?84,"|"
+7 IF $PIECE($GET(^PRCS(410,DA,"IT",P(1),4)),U,3)]""
if $Y>61
DO NEWP
WRITE !?12,"|","eCMS Line ID ",$PIECE(^PRCS(410,DA,"IT",P(1),4),U,3),?38,"|",?48,"|",?53,"|",?63,"|",?73,"|",?84,"|"
+8 if $Y>61
DO NEWP
WRITE !,?12,"|",?38,"|",?48,"|",?53,"|",?63,"|",?73,"|",?84,"|"
+9 QUIT
PRCARD SET P("PR")=$PIECE(^PRCS(410,DA,"IT",P(1),0),U,5)
if '$DATA(^PRC(441,P("PR"),1,0))
GOTO ITEM2
+1 SET P("PR1")=0
SET X=$PIECE(^PRCS(410,DA,"IT",P(1),0),U)_" ITEM ID NO. "_P("PR")
DO DIWP^PRCUTL($GET(DA))
FOR I=1:1
SET P("PR1")=$ORDER(^PRC(441,P("PR"),1,P("PR1")))
if P("PR1")=""
QUIT
SET X=^(P("PR1"),0)
DO DIWP^PRCUTL($GET(DA))
+2 SET Z=""
if $PIECE(^PRC(441,P("PR"),0),U,5)'=""
SET Z=Z_" (NSN: "_$PIECE(^(0),U,5)_")"
SET Z1=$PIECE(^PRCS(410,DA,3),U,4)
IF Z1
IF $DATA(^PRC(441,P("PR"),2,Z1,0))
if $PIECE(^(0),U,5)'=""
SET Z=Z_" (NDC: "_$PIECE(^(0),U,5)_")"
if $PIECE(^(0),U,3)
SET Z2=$PIECE(^(0),U,3)
+3 if $PIECE($GET(^PRC(441,P("PR"),3)),U,7)'=""
SET Z=Z_" FOOD GROUP: "_$PIECE(^(3),U,7)
+4 IF Z1
IF $DATA(^PRC(441,P("PR"),2,Z1,0))
SET Z=Z_" PKG: "_$PIECE(^(0),U,8)_" per "_$SELECT($DATA(^PRCD(420.5,+$PIECE(^(0),U,7),0)):$PIECE(^(0),U),1:"")
+5 IF $DATA(Z2)
IF $DATA(^PRC(440,+Z1,4,+Z2,0))
IF $PIECE(^(0),U)'=""
SET Y=$SELECT($PIECE(^(0),U,2):$PIECE(^(0),U,2),1:"")
if Y
XECUTE ^DD("DD")
SET Z=Z_" (CONTRACT # "_$PIECE(^PRC(440,Z1,4,Z2,0),U)_$SELECT(Y'="":", EXPIRATION DATE: "_Y_")",1:")")
KILL Z2
+6 SET X=Z
if $LENGTH(X)
DO DIWP^PRCUTL($GET(DA))
+7 ;PRC*5.1*81 add DM Doc ID and Date Needed By fields to ^UTILITY
+8 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
IF $PIECE($GET(^PRCS(410,DA,"IT",P(1),4)),U)]""
Begin DoDot:1
+9 SET X="DM Doc ID: "_$PIECE(^PRCS(410,DA,"IT",P(1),4),U)_" Date Needed By: "_$$FMTE^XLFDT($PIECE(^(4),U,2))
DO DIWP^PRCUTL($GET(DA))
End DoDot:1
+10 GOTO ITEM2
VENDOR ;PRINT VENDOR AND REQ MESSAGES
+1 NEW Z0
+2 IF $Y>60
DO NEWP
+3 IF $DATA(^PRCS(410,DA,4))
IF $PIECE(^(4),U)'=""
WRITE !,?12,"|TOTAL COST: ","$"_$JUSTIFY($PIECE(^(4),U),0,2),?38,"|",?48,"|",?53,"|",?63,"|",?73,"|",?84,"|"
+4 WRITE !,$EXTRACT(L,1,12),"|",$EXTRACT(L,1,25),"|",$EXTRACT(L,1,9),"|",$EXTRACT(L,1,4),"|",$EXTRACT(L,1,9),"|",$EXTRACT(L,1,9),"|",$EXTRACT(L,1,10),"|",$EXTRACT(L,1,5)
IF $Y>60
DO NEWP
+5 if '$DATA(^PRCS(410,DA,2))
GOTO RM
+6 IF $DATA(^PRCS(410,DA,2))
IF $PIECE(^(2),U)=""
GOTO RM
+7 IF $Y>56
DO NEWP
+8 SET (X,Z0)=$PIECE(^PRCS(410,DA,3),U,4)
SET X=$SELECT(X:"VENDOR INFORMATION: NO. "_X,1:"NEW VENDOR INFORMATION:")
WRITE !,X
+9 IF Z0
IF $DATA(^PRC(440,Z0,3))
IF $PIECE(^(3),U,2)="Y"
WRITE ?38,"EDI"
+10 IF Z0
IF $DATA(^PRC(440,Z0,10))
IF $PIECE(^(10),U,6)'=""
WRITE ?46,"FAX: "_$PIECE(^(10),U,6)
+11 SET X=^PRCS(410,DA,2)
WRITE !,"VENDOR: ",$PIECE(X,U)
if $PIECE(X,U,9)'=""
WRITE ?42,"CONTACT: ",$PIECE(X,U,9)
+12 if $PIECE(X,U,2)'=""
WRITE !,?8,$PIECE(X,U,2)
if $PIECE(X,U,10)'=""
WRITE ?44,"PHONE: ",$PIECE(X,U,10)
+13 if $PIECE(X,U,3)'=""
WRITE !,?8,$PIECE(X,U,3)
SET Z1=$PIECE(^PRCS(410,DA,3),U,4)
IF Z1
IF $DATA(^PRC(440,Z1,2))
IF $PIECE(^(2),U)'=""
WRITE ?42,"ACCT. #: ",$PIECE(^(2),U)
+14 if $PIECE(X,U,4)'=""
WRITE !,?8,$PIECE(X,U,4)
if $PIECE(X,U,5)'=""
WRITE !,?8,$PIECE(X,U,5)
+15 IF $PIECE(X,U,6)'=""
WRITE !,?8,$PIECE(X,U,6)
if +$PIECE(X,U,7)'=0
WRITE ",",$PIECE($GET(^DIC(5,$PIECE(X,U,7),0)),U,2)
if $PIECE(X,U,8)'=""
WRITE " ",$PIECE(X,U,8)
+16 WRITE !,L
WRITE !,"Ref. Voucher Number: ",!
if $PIECE($GET(^PRCS(410,DA,445)),"^")'=""
WRITE $PIECE(^(445),"^"),!
RM IF $Y>68
DO NEWP
+1 QUIT
NEWP ;PRINT HEADER FOR NEW PAGE
+1 WRITE !,"VA FORM 90-2237-ADP MAR 1985"
if $Y>0
WRITE @IOF
+2 SET PRCS("P")=PRCS("P")+1
WRITE !,?36,$PIECE(^PRCS(410,DA,0),U),?83,"PAGE ",PRCS("P"),!,L
+3 WRITE !,?16,"REQUEST, TURN-IN, AND RECEIPT FOR PROPERTY OR SERVICES",!
IF $DATA(ZTDESC("NOPRINT"))
WRITE ?37,"**REPRINT**",!
+4 WRITE !,L
+5 QUIT
