PRCPAWC0 ;WISC/RFJ-adjustment code sheets create and trans ;9.9.97
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
CODESHTS(INVPT,TRANID) ; create and transmit code sheets
; for invpt and transaction register id
N %,%H,%X,%Y,ACCT,DA,DATA,INVVALUE,ISMSCNT,ISMSFLAG,ITEMDA,NSN,PRCPXMZ,QSIGN,QTY,SELVALUE,STRING,VOUCHER,VSIGN
S ISMSFLAG=$$ISMSFLAG^PRCPUX2(PRC("SITE"))
K ^TMP($J,"PRCPAWN1")
S ISMSCNT=0
S DA=0 F S DA=$O(^PRCP(445.2,"T",INVPT,TRANID,DA)) Q:'DA S DATA=$G(^PRCP(445.2,DA,0)) I DATA'="" D
. I '$D(VOUCHER),$L($P(DATA,"^",15)) S VOUCHER=$P(DATA,"^",15)
. S ITEMDA=+$P(DATA,"^",5) I 'ITEMDA Q
. S NSN=$$NSN^PRCPUX1(ITEMDA),ACCT=$$ACCT1^PRCPUX1($E(NSN,1,4))
. S QTY=+$P(DATA,"^",7),INVVALUE=+$P(DATA,"^",22),SELVALUE=+$P(DATA,"^",23)
. I ISMSFLAG=2 D ISMS Q
. D LOG
;
; transmit isms code sheets
I ISMSFLAG=2,ISMSCNT D
. K ^TMP($J,"STRING")
. S %X="^TMP("_$J_",""PRCPAWN1"",",%Y="^TMP("_$J_",""STRING""," D %XY^%RCR
. D CODESHT^PRCPSMGO(PRC("SITE"),"ADJ",VOUCHER)
;
; transmit log code sheets to isms
I ISMSFLAG'=2,ISMSCNT D
. K ^TMP($J,"STRING")
. S %X="^TMP("_$J_",""PRCPAWN1"",",%Y="^TMP("_$J_",""STRING""," D %XY^%RCR
. D TRANSMIT^PRCPSMCL(PRC("SITE"),605,"LOG")
. W !!?4,"LOG 605 Transmitted in MailMan Messages:" I $D(PRCPXMZ) S %=0 F S %=$O(PRCPXMZ(%)) Q:'% W " ",PRCPXMZ(%)," "
K ^TMP($J,"PRCPAWN1"),^TMP($J,"STRING")
Q
;
;
ISMS ; format isms code sheet
I QTY D ADJUST^PRCPSMA0(INVPT,ITEMDA,QTY,"","","") I STRING("AT")'="" S ISMSCNT=ISMSCNT+1,^TMP($J,"PRCPAWN1",ISMSCNT)=STRING("AT")
I INVVALUE D ADJUST^PRCPSMA0(INVPT,ITEMDA,"",INVVALUE,+$P($G(^PRCP(445,INVPT,1,ITEMDA,0)),"^",22),"") I STRING("AT")'="" S ISMSCNT=ISMSCNT+1,^TMP($J,"PRCPAWN1",ISMSCNT)=STRING("AT")
Q
;
;
LOG ; format log code sheets for isms
S NSN=$E($TR($P(NSN,"-",2,4),"-")_" ",1,10)
; format quantity
S QSIGN="+"
I QTY<0 S QSIGN="-",QTY=QTY*-1
S QTY=$S(QTY=0:" ",1:$E("00000",$L(QTY)+1,5)_QTY)
; format inventory value
S VSIGN=QSIGN
I INVVALUE S INVVALUE=$TR($J(INVVALUE,0,2),"."),VSIGN="+" I INVVALUE<0 S VSIGN="-",INVVALUE=INVVALUE*-1
S INVVALUE=$S('INVVALUE:" ",1:$E("0000000",$L(INVVALUE)+1,7)_INVVALUE)
; build code sheets
S %="",$P(%," ",80)=""
I '$D(VOUCHER) S VOUCHER=" "
I QSIGN=VSIGN S ISMSCNT=ISMSCNT+1,^TMP($J,"PRCPAWN1",ISMSCNT)=" "_NSN_PRC("SITE")_"605A"_ACCT_QTY_INVVALUE_QSIGN_VOUCHER_$E(DT,4,7)_$E(DT,2,3)_$E(%,1,35) Q
I +QTY S ISMSCNT=ISMSCNT+1,^TMP($J,"PRCPAWN1",ISMSCNT)=" "_NSN_PRC("SITE")_"605A"_ACCT_QTY_"0000000"_QSIGN_VOUCHER_$E(DT,4,7)_$E(DT,2,3)_$E(%,1,35)
I +INVVALUE S ISMSCNT=ISMSCNT+1,^TMP($J,"PRCPAWN1",ISMSCNT)=" "_NSN_PRC("SITE")_"605A"_ACCT_"00000"_INVVALUE_VSIGN_VOUCHER_$E(DT,4,5)_$E(DT,6,7)_$E(DT,2,3)_$E(%,1,35)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAWC0 2878 printed Dec 13, 2024@02:12:50 Page 2
PRCPAWC0 ;WISC/RFJ-adjustment code sheets create and trans ;9.9.97
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
CODESHTS(INVPT,TRANID) ; create and transmit code sheets
+1 ; for invpt and transaction register id
+2 NEW %,%H,%X,%Y,ACCT,DA,DATA,INVVALUE,ISMSCNT,ISMSFLAG,ITEMDA,NSN,PRCPXMZ,QSIGN,QTY,SELVALUE,STRING,VOUCHER,VSIGN
+3 SET ISMSFLAG=$$ISMSFLAG^PRCPUX2(PRC("SITE"))
+4 KILL ^TMP($JOB,"PRCPAWN1")
+5 SET ISMSCNT=0
+6 SET DA=0
FOR
SET DA=$ORDER(^PRCP(445.2,"T",INVPT,TRANID,DA))
if 'DA
QUIT
SET DATA=$GET(^PRCP(445.2,DA,0))
IF DATA'=""
Begin DoDot:1
+7 IF '$DATA(VOUCHER)
IF $LENGTH($PIECE(DATA,"^",15))
SET VOUCHER=$PIECE(DATA,"^",15)
+8 SET ITEMDA=+$PIECE(DATA,"^",5)
IF 'ITEMDA
QUIT
+9 SET NSN=$$NSN^PRCPUX1(ITEMDA)
SET ACCT=$$ACCT1^PRCPUX1($EXTRACT(NSN,1,4))
+10 SET QTY=+$PIECE(DATA,"^",7)
SET INVVALUE=+$PIECE(DATA,"^",22)
SET SELVALUE=+$PIECE(DATA,"^",23)
+11 IF ISMSFLAG=2
DO ISMS
QUIT
+12 DO LOG
End DoDot:1
+13 ;
+14 ; transmit isms code sheets
+15 IF ISMSFLAG=2
IF ISMSCNT
Begin DoDot:1
+16 KILL ^TMP($JOB,"STRING")
+17 SET %X="^TMP("_$JOB_",""PRCPAWN1"","
SET %Y="^TMP("_$JOB_",""STRING"","
DO %XY^%RCR
+18 DO CODESHT^PRCPSMGO(PRC("SITE"),"ADJ",VOUCHER)
End DoDot:1
+19 ;
+20 ; transmit log code sheets to isms
+21 IF ISMSFLAG'=2
IF ISMSCNT
Begin DoDot:1
+22 KILL ^TMP($JOB,"STRING")
+23 SET %X="^TMP("_$JOB_",""PRCPAWN1"","
SET %Y="^TMP("_$JOB_",""STRING"","
DO %XY^%RCR
+24 DO TRANSMIT^PRCPSMCL(PRC("SITE"),605,"LOG")
+25 WRITE !!?4,"LOG 605 Transmitted in MailMan Messages:"
IF $DATA(PRCPXMZ)
SET %=0
FOR
SET %=$ORDER(PRCPXMZ(%))
if '%
QUIT
WRITE " ",PRCPXMZ(%)," "
End DoDot:1
+26 KILL ^TMP($JOB,"PRCPAWN1"),^TMP($JOB,"STRING")
+27 QUIT
+28 ;
+29 ;
ISMS ; format isms code sheet
+1 IF QTY
DO ADJUST^PRCPSMA0(INVPT,ITEMDA,QTY,"","","")
IF STRING("AT")'=""
SET ISMSCNT=ISMSCNT+1
SET ^TMP($JOB,"PRCPAWN1",ISMSCNT)=STRING("AT")
+2 IF INVVALUE
DO ADJUST^PRCPSMA0(INVPT,ITEMDA,"",INVVALUE,+$PIECE($GET(^PRCP(445,INVPT,1,ITEMDA,0)),"^",22),"")
IF STRING("AT")'=""
SET ISMSCNT=ISMSCNT+1
SET ^TMP($JOB,"PRCPAWN1",ISMSCNT)=STRING("AT")
+3 QUIT
+4 ;
+5 ;
LOG ; format log code sheets for isms
+1 SET NSN=$EXTRACT($TRANSLATE($PIECE(NSN,"-",2,4),"-")_" ",1,10)
+2 ; format quantity
+3 SET QSIGN="+"
+4 IF QTY<0
SET QSIGN="-"
SET QTY=QTY*-1
+5 SET QTY=$SELECT(QTY=0:" ",1:$EXTRACT("00000",$LENGTH(QTY)+1,5)_QTY)
+6 ; format inventory value
+7 SET VSIGN=QSIGN
+8 IF INVVALUE
SET INVVALUE=$TRANSLATE($JUSTIFY(INVVALUE,0,2),".")
SET VSIGN="+"
IF INVVALUE<0
SET VSIGN="-"
SET INVVALUE=INVVALUE*-1
+9 SET INVVALUE=$SELECT('INVVALUE:" ",1:$EXTRACT("0000000",$LENGTH(INVVALUE)+1,7)_INVVALUE)
+10 ; build code sheets
+11 SET %=""
SET $PIECE(%," ",80)=""
+12 IF '$DATA(VOUCHER)
SET VOUCHER=" "
+13 IF QSIGN=VSIGN
SET ISMSCNT=ISMSCNT+1
SET ^TMP($JOB,"PRCPAWN1",ISMSCNT)=" "_NSN_PRC("SITE")_"605A"_ACCT_QTY_INVVALUE_QSIGN_VOUCHER_$EXTRACT(DT,4,7)_$EXTRACT(DT,2,3)_$EXTRACT(%,1,35)
QUIT
+14 IF +QTY
SET ISMSCNT=ISMSCNT+1
SET ^TMP($JOB,"PRCPAWN1",ISMSCNT)=" "_NSN_PRC("SITE")_"605A"_ACCT_QTY_"0000000"_QSIGN_VOUCHER_$EXTRACT(DT,4,7)_$EXTRACT(DT,2,3)_$EXTRACT(%,1,35)
+15 IF +INVVALUE
SET ISMSCNT=ISMSCNT+1
SET ^TMP($JOB,"PRCPAWN1",ISMSCNT)=" "_NSN_PRC("SITE")_"605A"_ACCT_"00000"_INVVALUE_VSIGN_VOUCHER_$EXTRACT(DT,4,5)_$EXTRACT(DT,6,7)_$EXTRACT(DT,2,3)_$EXTRACT(%,1,35)
+16 QUIT
