PRCPSMPI.m

PRCPSMPI ;WISC/RFJ-issue code sheets to isms                        ;29 May 92

 ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 Q

 ;

 ;

DQ(TRANNO,TRANID) ;  create/trans issue code sheet to isms

 ;  tranno=issue transaction number (full 5 pieces of '-')

 ;  tranid=transaction register id

 N COUNT,DATA,ISSUCOST,ITEMDA,NSN,QTY,TRANREG,UI,VALUSOLD,VOUCHER

 ;

 ;  start gathering items posted

 S COUNT=1 K ^TMP($J,"STRING")

 S TRANREG=0 F  S TRANREG=$O(^PRCP(445.2,"C",TRANNO,TRANREG)) Q:'TRANREG  S DATA=$G(^PRCP(445.2,TRANREG,0)) I DATA'="",$P(DATA,"^",2)=TRANID D

 .   I '$D(VOUCHER) S VOUCHER=$P(DATA,"^",15)

 .   S ITEMDA=+$P(DATA,"^",5),NSN=$TR($$NSN^PRCPUX1(ITEMDA),"-"),UI=$P($P(DATA,"^",6),"/",2)

 .   S QTY=-$P(DATA,"^",7) I 'QTY Q

 .   S VALUSOLD=-$TR($J($P(DATA,"^",22),0,2),"."),ISSUCOST=-$TR($J($P(DATA,"^",23),0,4),".")

 .   S ^TMP($J,"STRING",COUNT)="IS^"_NSN_"^"_UI_"^"_QTY_"00^"_VALUSOLD_"^0^"_ISSUCOST_"^|",COUNT=COUNT+1

 I COUNT=1 Q

 ;

 ;  prcpwait used in routine prcpsmsi when retransmitting

 ;  isms code sheets

 I '$G(PRCPWAIT) D CODESHT^PRCPSMGO(PRC("SITE"),"ISS",VOUCHER)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCPSMPI   1171     printed  Apr 09, 2024@21:14:02                                                                                                                                                                                                    Page 2

PRCPSMPI  ;WISC/RFJ-issue code sheets to isms                        ;29 May 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       ;

DQ(TRANNO,TRANID) ;  create/trans issue code sheet to isms

 +1       ;  tranno=issue transaction number (full 5 pieces of '-')

 +2       ;  tranid=transaction register id

 +3        NEW COUNT,DATA,ISSUCOST,ITEMDA,NSN,QTY,TRANREG,UI,VALUSOLD,VOUCHER

 +4       ;

 +5       ;  start gathering items posted

 +6        SET COUNT=1

           KILL ^TMP($JOB,"STRING")

 +7        SET TRANREG=0

           FOR 

               SET TRANREG=$ORDER(^PRCP(445.2,"C",TRANNO,TRANREG))

               if 'TRANREG

                   QUIT 

               SET DATA=$GET(^PRCP(445.2,TRANREG,0))

               IF DATA'=""

                   IF $PIECE(DATA,"^",2)=TRANID

                       Begin DoDot:1

 +8                        IF '$DATA(VOUCHER)

                               SET VOUCHER=$PIECE(DATA,"^",15)

 +9                        SET ITEMDA=+$PIECE(DATA,"^",5)

                           SET NSN=$TRANSLATE($$NSN^PRCPUX1(ITEMDA),"-")

                           SET UI=$PIECE($PIECE(DATA,"^",6),"/",2)

 +10                       SET QTY=-$PIECE(DATA,"^",7)

                           IF 'QTY

                               QUIT 

 +11                       SET VALUSOLD=-$TRANSLATE($JUSTIFY($PIECE(DATA,"^",22),0,2),".")

                           SET ISSUCOST=-$TRANSLATE($JUSTIFY($PIECE(DATA,"^",23),0,4),".")

 +12                       SET ^TMP($JOB,"STRING",COUNT)="IS^"_NSN_"^"_UI_"^"_QTY_"00^"_VALUSOLD_"^0^"_ISSUCOST_"^|"

                           SET COUNT=COUNT+1

                       End DoDot:1

 +13       IF COUNT=1

               QUIT 

 +14      ;

 +15      ;  prcpwait used in routine prcpsmsi when retransmitting

 +16      ;  isms code sheets

 +17       IF '$GET(PRCPWAIT)

               DO CODESHT^PRCPSMGO(PRC("SITE"),"ISS",VOUCHER)

 +18       QUIT