Routine: PRCHRP1

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

HEADER ;

 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 "----------"

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRP1   3757     printed  Apr 23, 2025@18:24:45                                                                                                                                                                                                     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

HEADER    ;

 +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

PRCHRP1.m