PRCHRP1 ;WISC/KMB-PURCHASE CARD TRANS. STATUS ;9/25/96
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
OBL ;
W @IOF W !!,"NOTE - You cannot use the PURCHASE CARD HOLDER field for lookups.",!! S PRCF("X")="S" D ^PRCFSITE G EXIT:'$D(PRC("SITE"))
S DIC("A")="P.O./REQ. NO.: ",DIC(0)="AEMQZ",D="C",DIC("S")="I $P(^(0),""^"",2)=25",DIC="^PRC(442,"
W !! D IX^DIC K DIC G EXIT:+Y<0 S (DA,ZIP)=+Y
;
D DETAIL1
W !,"Do you wish to print this report" S %=1 D YN^DICN I %'=1 G OBL
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTRTN="DETAIL^PRCHRP1",ZTSAVE("ZIP")="" D ^%ZTLOAD,^%ZISC G OBL
D DETAIL,^%ZISC H 3 G OBL
DETAIL ;
U IO
DETAIL1 ;
S R=$G(^PRC(442,ZIP,0)),S=$G(^PRC(442,ZIP,1)),T=$G(^PRC(442,ZIP,23))
W !,"Transaction Number: ",$P(R,"^"),?40,"FCP: ",$E($P(R,"^",3),1,30)
S PP=$P($G(^PRC(442,ZIP,7)),"^") W !,"Transaction Status: ",$P($G(^PRCD(442.3,+PP,0)),"^")
S Y=$P(S,"^",15),YY=$P(R,"^",10)
D DD^%DT W !,"Date of Request: ",Y S Y=$P(R,"^",10) D DD^%DT W ?40,"Date Required: ",Y
S VRR=$P($G(^PRC(440,+$P(S,"^"),0)),"^") I VRR="SIMPLIFIED",$P($G(^PRC(442,ZIP,24)),"^",2)'="" S VRR=$P($G(^PRC(442,ZIP,24)),"^",2)
W !,"Vendor: ",VRR
W !,"Committed (Estimated) Cost: ",$J($P(R,"^",15),0,2) S Y=YY D DD^%DT W ?40,"Date Committed: ",Y
W !,"Purchase Card Amount: ",$J($P(R,"^",15),0,2) S YY=$P($G(^PRC(442,ZIP,12)),"^",3) S Y=YY D DD^%DT W ?40,"Date Signed: ",Y
W !,"Transaction Amount: ",$J($P(R,"^",15),0,2),?40,"Accounting Data: ",$P(R,"^",4)
;
W !!,"Originator of Request: ",$P($G(^VA(200,+$P(S,"^",10),0)),"^")
W !,"Requesting Service: ",$P($G(^DIC(49,+$P(S,"^",2),0)),"^")
K ^UTILITY($J,"W") S DIWL=1,DIWR=62,DIWF="",PRCSDY=8,PRCSI=0
F PRCSJ=1:1 S PRCSI=$O(^PRC(442,ZIP,4,PRCSI)) Q:'PRCSI S X=^(PRCSI,0) D DIWP^PRCUTL($G(DA))
S I=$S($D(^UTILITY($J,"W",DIWL)):+^(DIWL),1:0)
I I F J=1:1:I W ! W:J=1 "Comments:" W ?15,^UTILITY($J,"W",DIWL,J,0) S PRCSDY=PRCSDY+1
W !,"Delivery Location: ",$P(S,"^",11)
S SORT=$P(T,"^",13) I SORT'="" S PZ1=$P(SORT,";"),PZ2=$P(SORT,";",2),PZ3="^"_PZ2_PZ1_",0)" S SORT=$G(@PZ3) S SORT=$P(SORT,"^")
W !,"Sort Group: ",SORT
D CCDATA
W ! QUIT
ITEM ;
S COUNT=$P(R,"^",14) Q:COUNT=""
D HEADER
F FF=1:1:COUNT D
.S QQ=$G(^PRC(442,ZIP,2,FF,0)) Q:QQ=""
.W !,$P(QQ,"^",6),?12,"|",?50,"|",$P(QQ,"^",2),?60,"|",$P($G(^PRC(420.5,+$P(QQ,"^",3),0)),"^"),?70,"|",$P(QQ,"^",9)
.S C1=0 I $G(^PRC(442,ZIP,2,FF,1,0))'="" F J=1:1 K ^UTILITY($J,"W") S C1=$O(^PRC(442,ZIP,2,FF,1,C1)) Q:+C1=0 D
..N L1,L2,L3 S DIWL=14,DIWR=48,DIWF=""
..S X=^PRC(442,ZIP,2,FF,1,C1,0) S:J=1 X=$P(^PRC(442,ZIP,2,FF,1,0),"^")_" "_X D DIWP^PRCUTL($G(ZIP))
..S Z=^UTILITY($J,"W",DIWL) W !
..I Z>1 F J=1:1:(Z-1) W !,?12,"|",^UTILITY($J,"W",DIWL,J,0),?50,"|",?60,"|",?70,"|" D:$Y>61 HEADER W !,?12,"|",?50,"|",?60,"|",?70,"|"
..I Z>1 W !,?12,"|",^UTILITY($J,"W",DIWL,Z,0),?50,"|",?60,"|",?70,"|" D:$Y>61 HEADER W !,?12,"|",?50,"|",?60,"|",?70,"|"
..I Z<2 W ?12,"|",^UTILITY($J,"W",DIWL,1,0),?50,"|",?60,"|",?70,"|" D:$Y>61 HEADER W !,?12,"|",?50,"|",?60,"|",?70,"|"
QUIT
CCDATA ;
S CCREC="" F S CCREC=$O(^PRCH(440.6,"PO",ZIP,CCREC)) Q:CCREC="" D
.S CCSTR=$G(^PRCH(440.6,CCREC,0)) S Y=$P(CCSTR,"^",7) D DD^%DT W !,"Transaction date: ",Y,?35,"Credit card ref.#: ",$P(CCSTR,"^")
.W !,"Amount: ",$P(CCSTR,"^",14)
QUIT
EXIT K DA,PRCRI,CCREC,CCSTR,SORT,VRR,COUNT,FF,I,J,R,S,T,QQ,Y,YY,PP,PZ1,PZ2,PZ3,SORT,PRCSJ,PRCSI,PRCSDY,ZIP
QUIT
I IO=IO(0) H 5
W @IOF
W !,?30,"ITEM INFORMATION"
W !,"Transaction Number: ",$P(R,"^"),?40,"FCP: ",$E($P(R,"^",3),1,30),!
F I=1:1:8 W "----------"
W !,"STOCK NUMBER",?14,"ITEM DESCRIPTION",?51,"QUANTITY",?64,"U/I",?71,"UNIT COST",!
F I=1:1:8 W "----------"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRP1 3757 printed Mar 13, 2025@21:15:03 Page 2
PRCHRP1 ;WISC/KMB-PURCHASE CARD TRANS. STATUS ;9/25/96
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
OBL ;
+1 WRITE @IOF
WRITE !!,"NOTE - You cannot use the PURCHASE CARD HOLDER field for lookups.",!!
SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
GOTO EXIT
+2 SET DIC("A")="P.O./REQ. NO.: "
SET DIC(0)="AEMQZ"
SET D="C"
SET DIC("S")="I $P(^(0),""^"",2)=25"
SET DIC="^PRC(442,"
+3 WRITE !!
DO IX^DIC
KILL DIC
if +Y<0
GOTO EXIT
SET (DA,ZIP)=+Y
+4 ;
+5 DO DETAIL1
+6 WRITE !,"Do you wish to print this report"
SET %=1
DO YN^DICN
IF %'=1
GOTO OBL
+7 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+8 IF $DATA(IO("Q"))
SET ZTRTN="DETAIL^PRCHRP1"
SET ZTSAVE("ZIP")=""
DO ^%ZTLOAD
DO ^%ZISC
GOTO OBL
+9 DO DETAIL
DO ^%ZISC
HANG 3
GOTO OBL
DETAIL ;
+1 USE IO
DETAIL1 ;
+1 SET R=$GET(^PRC(442,ZIP,0))
SET S=$GET(^PRC(442,ZIP,1))
SET T=$GET(^PRC(442,ZIP,23))
+2 WRITE !,"Transaction Number: ",$PIECE(R,"^"),?40,"FCP: ",$EXTRACT($PIECE(R,"^",3),1,30)
+3 SET PP=$PIECE($GET(^PRC(442,ZIP,7)),"^")
WRITE !,"Transaction Status: ",$PIECE($GET(^PRCD(442.3,+PP,0)),"^")
+4 SET Y=$PIECE(S,"^",15)
SET YY=$PIECE(R,"^",10)
+5 DO DD^%DT
WRITE !,"Date of Request: ",Y
SET Y=$PIECE(R,"^",10)
DO DD^%DT
WRITE ?40,"Date Required: ",Y
+6 SET VRR=$PIECE($GET(^PRC(440,+$PIECE(S,"^"),0)),"^")
IF VRR="SIMPLIFIED"
IF $PIECE($GET(^PRC(442,ZIP,24)),"^",2)'=""
SET VRR=$PIECE($GET(^PRC(442,ZIP,24)),"^",2)
+7 WRITE !,"Vendor: ",VRR
+8 WRITE !,"Committed (Estimated) Cost: ",$JUSTIFY($PIECE(R,"^",15),0,2)
SET Y=YY
DO DD^%DT
WRITE ?40,"Date Committed: ",Y
+9 WRITE !,"Purchase Card Amount: ",$JUSTIFY($PIECE(R,"^",15),0,2)
SET YY=$PIECE($GET(^PRC(442,ZIP,12)),"^",3)
SET Y=YY
DO DD^%DT
WRITE ?40,"Date Signed: ",Y
+10 WRITE !,"Transaction Amount: ",$JUSTIFY($PIECE(R,"^",15),0,2),?40,"Accounting Data: ",$PIECE(R,"^",4)
+11 ;
+12 WRITE !!,"Originator of Request: ",$PIECE($GET(^VA(200,+$PIECE(S,"^",10),0)),"^")
+13 WRITE !,"Requesting Service: ",$PIECE($GET(^DIC(49,+$PIECE(S,"^",2),0)),"^")
+14 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=62
SET DIWF=""
SET PRCSDY=8
SET PRCSI=0
+15 FOR PRCSJ=1:1
SET PRCSI=$ORDER(^PRC(442,ZIP,4,PRCSI))
if 'PRCSI
QUIT
SET X=^(PRCSI,0)
DO DIWP^PRCUTL($GET(DA))
+16 SET I=$SELECT($DATA(^UTILITY($JOB,"W",DIWL)):+^(DIWL),1:0)
+17 IF I
FOR J=1:1:I
WRITE !
if J=1
WRITE "Comments:"
WRITE ?15,^UTILITY($JOB,"W",DIWL,J,0)
SET PRCSDY=PRCSDY+1
+18 WRITE !,"Delivery Location: ",$PIECE(S,"^",11)
+19 SET SORT=$PIECE(T,"^",13)
IF SORT'=""
SET PZ1=$PIECE(SORT,";")
SET PZ2=$PIECE(SORT,";",2)
SET PZ3="^"_PZ2_PZ1_",0)"
SET SORT=$GET(@PZ3)
SET SORT=$PIECE(SORT,"^")
+20 WRITE !,"Sort Group: ",SORT
+21 DO CCDATA
+22 WRITE !
QUIT
ITEM ;
+1 SET COUNT=$PIECE(R,"^",14)
if COUNT=""
QUIT
+2 DO HEADER
+3 FOR FF=1:1:COUNT
Begin DoDot:1
+4 SET QQ=$GET(^PRC(442,ZIP,2,FF,0))
if QQ=""
QUIT
+5 WRITE !,$PIECE(QQ,"^",6),?12,"|",?50,"|",$PIECE(QQ,"^",2),?60,"|",$PIECE($GET(^PRC(420.5,+$PIECE(QQ,"^",3),0)),"^"),?70,"|",$PIECE(QQ,"^",9)
+6 SET C1=0
IF $GET(^PRC(442,ZIP,2,FF,1,0))'=""
FOR J=1:1
KILL ^UTILITY($JOB,"W")
SET C1=$ORDER(^PRC(442,ZIP,2,FF,1,C1))
if +C1=0
QUIT
Begin DoDot:2
+7 NEW L1,L2,L3
SET DIWL=14
SET DIWR=48
SET DIWF=""
+8 SET X=^PRC(442,ZIP,2,FF,1,C1,0)
if J=1
SET X=$PIECE(^PRC(442,ZIP,2,FF,1,0),"^")_" "_X
DO DIWP^PRCUTL($GET(ZIP))
+9 SET Z=^UTILITY($JOB,"W",DIWL)
WRITE !
+10 IF Z>1
FOR J=1:1:(Z-1)
WRITE !,?12,"|",^UTILITY($JOB,"W",DIWL,J,0),?50,"|",?60,"|",?70,"|"
if $Y>61
DO HEADER
WRITE !,?12,"|",?50,"|",?60,"|",?70,"|"
+11 IF Z>1
WRITE !,?12,"|",^UTILITY($JOB,"W",DIWL,Z,0),?50,"|",?60,"|",?70,"|"
if $Y>61
DO HEADER
WRITE !,?12,"|",?50,"|",?60,"|",?70,"|"
+12 IF Z<2
WRITE ?12,"|",^UTILITY($JOB,"W",DIWL,1,0),?50,"|",?60,"|",?70,"|"
if $Y>61
DO HEADER
WRITE !,?12,"|",?50,"|",?60,"|",?70,"|"
End DoDot:2
End DoDot:1
+13 QUIT
CCDATA ;
+1 SET CCREC=""
FOR
SET CCREC=$ORDER(^PRCH(440.6,"PO",ZIP,CCREC))
if CCREC=""
QUIT
Begin DoDot:1
+2 SET CCSTR=$GET(^PRCH(440.6,CCREC,0))
SET Y=$PIECE(CCSTR,"^",7)
DO DD^%DT
WRITE !,"Transaction date: ",Y,?35,"Credit card ref.#: ",$PIECE(CCSTR,"^")
+3 WRITE !,"Amount: ",$PIECE(CCSTR,"^",14)
End DoDot:1
+4 QUIT
EXIT KILL DA,PRCRI,CCREC,CCSTR,SORT,VRR,COUNT,FF,I,J,R,S,T,QQ,Y,YY,PP,PZ1,PZ2,PZ3,SORT,PRCSJ,PRCSI,PRCSDY,ZIP
+1 QUIT
+1 IF IO=IO(0)
HANG 5
+2 WRITE @IOF
+3 WRITE !,?30,"ITEM INFORMATION"
+4 WRITE !,"Transaction Number: ",$PIECE(R,"^"),?40,"FCP: ",$EXTRACT($PIECE(R,"^",3),1,30),!
+5 FOR I=1:1:8
WRITE "----------"
+6 WRITE !,"STOCK NUMBER",?14,"ITEM DESCRIPTION",?51,"QUANTITY",?64,"U/I",?71,"UNIT COST",!
+7 FOR I=1:1:8
WRITE "----------"
+8 QUIT
