PRCPRPIQ ;WISC/RFJ-print picking ticket end of report ;07 Feb 92
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
END ; come here to print at bottom of picking ticket
N TEXT,X,Y
S Y=$P($G(^PRCS(410,+TRANDA,3)),"^",2)
S DATA(1)="SPECIAL INSTRUCTIONS/COMMENTS:",TEXT=2
F X=1:1 Q:'$D(^PRCS(410,TRANDA,"RM",X,0)) S DATA(TEXT)=^(0),TEXT=TEXT+1
F X=1:1 Q:'$D(^PRCS(410,TRANDA,"CO",X,0)) S DATA(TEXT)=^(0),TEXT=TEXT+1
F X=1:1 S DATA=$P($T(DATA+X),";",3,99) Q:DATA="" S:DATA["xxxx" DATA=$TR(DATA,"x")_Y S DATA(TEXT)=DATA,TEXT=TEXT+1
I $Y>(IOSL-TEXT) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H^PRCPRPIR
W !!,"TOTAL DOLLAR AMOUNT OF TRANSACTION: ",$J(TOTAL,0,2)
W !!,"INVENTORY AMOUNT OF TRANSACTION (BY ACCOUNT CODE):",! S X="" F %=1:1 S X=$O(ACCT(X)) Q:X="" W ?((%-1)*20),X," : ",$J(ACCT(X),0,2) I %=4 S %=0 W !
I $Y>(IOSL-TEXT-1) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H^PRCPRPIR
W ! S %=0 F S %=$O(DATA(%)) Q:'% W !,DATA(%)
I '$D(PRCPFLAG) D END^PRCPUREP
Q
;
;
DATA ;; print signature at bottom of report
;;FUND CERTIFICATION--- THE SUPPLIES LISTED ON THIS REQUEST ARE PROPERLY
;;CHARGEABLE TO THE FOLLOWING ALLOTMENTS, THE AVAILABLE BALANCES OF WHICH
;;ARE SUFFICIENT TO COVER COST THEREOF, AND FUNDS HAVE BEEN OBLIGATED.
;;
;;APPROPRIATION AND ACCOUNTING SYMBOLS: xxxx
;;
;;OBLIGATED BY:______________________________ DATE:___________________
;;
;;SERVICE SIGNATURE:_________________________ PULLED BY:_______________
;;
;; TITLE:_________________________ VERIFIED BY:_______________
;;
;; DATE RECEIVED:_________________________ DATE TO DELIVER ON:_______________
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRPIQ 1750 printed Oct 16, 2024@18:16:04 Page 2
PRCPRPIQ ;WISC/RFJ-print picking ticket end of report ;07 Feb 92
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
END ; come here to print at bottom of picking ticket
+1 NEW TEXT,X,Y
+2 SET Y=$PIECE($GET(^PRCS(410,+TRANDA,3)),"^",2)
+3 SET DATA(1)="SPECIAL INSTRUCTIONS/COMMENTS:"
SET TEXT=2
+4 FOR X=1:1
if '$DATA(^PRCS(410,TRANDA,"RM",X,0))
QUIT
SET DATA(TEXT)=^(0)
SET TEXT=TEXT+1
+5 FOR X=1:1
if '$DATA(^PRCS(410,TRANDA,"CO",X,0))
QUIT
SET DATA(TEXT)=^(0)
SET TEXT=TEXT+1
+6 FOR X=1:1
SET DATA=$PIECE($TEXT(DATA+X),";",3,99)
if DATA=""
QUIT
if DATA["xxxx"
SET DATA=$TRANSLATE(DATA,"x")_Y
SET DATA(TEXT)=DATA
SET TEXT=TEXT+1
+7 IF $Y>(IOSL-TEXT)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H^PRCPRPIR
+8 WRITE !!,"TOTAL DOLLAR AMOUNT OF TRANSACTION: ",$JUSTIFY(TOTAL,0,2)
+9 WRITE !!,"INVENTORY AMOUNT OF TRANSACTION (BY ACCOUNT CODE):",!
SET X=""
FOR %=1:1
SET X=$ORDER(ACCT(X))
if X=""
QUIT
WRITE ?((%-1)*20),X," : ",$JUSTIFY(ACCT(X),0,2)
IF %=4
SET %=0
WRITE !
+10 IF $Y>(IOSL-TEXT-1)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H^PRCPRPIR
+11 WRITE !
SET %=0
FOR
SET %=$ORDER(DATA(%))
if '%
QUIT
WRITE !,DATA(%)
+12 IF '$DATA(PRCPFLAG)
DO END^PRCPUREP
+13 QUIT
+14 ;
+15 ;
DATA ;; print signature at bottom of report
+1 ;;FUND CERTIFICATION--- THE SUPPLIES LISTED ON THIS REQUEST ARE PROPERLY
+2 ;;CHARGEABLE TO THE FOLLOWING ALLOTMENTS, THE AVAILABLE BALANCES OF WHICH
+3 ;;ARE SUFFICIENT TO COVER COST THEREOF, AND FUNDS HAVE BEEN OBLIGATED.
+4 ;;
+5 ;;APPROPRIATION AND ACCOUNTING SYMBOLS: xxxx
+6 ;;
+7 ;;OBLIGATED BY:______________________________ DATE:___________________
+8 ;;
+9 ;;SERVICE SIGNATURE:_________________________ PULLED BY:_______________
+10 ;;
+11 ;; TITLE:_________________________ VERIFIED BY:_______________
+12 ;;
+13 ;; DATE RECEIVED:_________________________ DATE TO DELIVER ON:_______________
