PRCPSMB0 ;WISC/RFJ-isms transaction: balance update ;25 Oct 91
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
I PRCP("DPTYPE")'="W" W !,"THIS OPTION SHOULD ONLY BE USED BY THE WAREHOUSE INVENTORY POINT." Q
;I $$ISMSFLAG^PRCPUX2(PRC("SITE"))'=2 W !,"YOU NEED TO TURN THE ISMS SWITCH 'ON' BEFORE YOU CAN USE THIS OPTION." Q
N %,CODESHT,COUNT,DESCR,ITEMDA,PRCPFLAG,PRCPXMZ,ZTSK
S IOP="HOME" D ^%ZIS K IOP D Q
W !!,"To select ALL items, press RETURN."
F S ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","") Q:'ITEMDA D
. S CODESHT=$$BALANCE^PRCPSMB1(PRCP("I"),ITEMDA) I $E(CODESHT,1,2)'="BU" W !?5,CODESHT Q
. S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
. W @IOF,!!,"I WILL TRANSMIT THE FOLLOWING BALANCES TO ISMS:"
. W !,ITEMDA,?7,$E(DESCR,1,50),?60,$P(CODESHT,"^",2),!!?5,"ISSUE UNIT",?23,": ",$P(CODESHT,"^",3),!?5,"QUANTITY ON-HAND",?23,": ",$P(CODESHT,"^",4)/100
. W !?5,"ON-HAND VALUE",?23,": ",$J(+$P(CODESHT,"^",5)/100,0,2),!?5,"QUANTITY DUE-OUT",?23,": ",+$P(CODESHT,"^",6)/100
. W !?5,"AVERAGE COST",?23,": ",$J(+$P(CODESHT,"^",7)/10000,0,3),!?5,"LAST RECEIPT COST",?23,": ",$J(+$P(CODESHT,"^",8)/10000,0,3),!?5,"LAST SALE COST",?23,": ",$J(+$P(CODESHT,"^",9)/10000,0,3)
. W !!?1,"CS: ",CODESHT
. S ^TMP($J,"BAL",ITEMDA)=DESCR_"^"_$P(CODESHT,"^",2),^TMP($J,"BAL",ITEMDA,"CS")=CODESHT
I ITEMDA["^" D Q Q
I '$O(^TMP($J,"BAL",0)) S XP="Do you want to select ALL items",XH="Enter 'YES' to select ALL items, 'NO' or '^' to exit." W ! I $$YN^PRCPUYN(1)=1 D D Q Q
. W !!,"I will queue this to run as a background job. When I finish building the",!,"code sheet, I will send you a mailman message with the code sheet number",!,"and items NOT transmitted because of errors found."
. S ZTRTN="DQ^PRCPSMB0",ZTIO="",ZTDESC="ISMS Balance Transaction:All Items",ZTSAVE("PRC*")="",ZTSAVE("ZTREQ")="@" D ^%ZTLOAD K ZTSK
I '$O(^TMP($J,"BAL",0)) W !,"NO ITEMS SELECTED." D Q Q
W @IOF,!,"YOU HAVE SELECTED THE FOLLOWING ITEMS TO UPDATE ISMS BALANCES:" S ITEMDA=0,COUNT=1 F S ITEMDA=$O(^TMP($J,"BAL",ITEMDA)) Q:'ITEMDA!($D(PRCPFLAG)) S %=^(ITEMDA) I %'="",$D(^TMP($J,"BAL",ITEMDA,"CS")) D
. W !,ITEMDA,?7,$E($P(%,"^"),1,50),?60,$P(%,"^",2) S ^TMP($J,"STRING",COUNT)=^TMP($J,"BAL",ITEMDA,"CS"),COUNT=COUNT+1
. I $Y>(IOSL-5) D P^PRCPUREP
I $D(PRCPFLAG) D Q Q
I '$O(^TMP($J,"STRING",0)) W !!,"NO CODE SHEETS CREATED." D Q Q
S XP="*** ARE YOU SURE YOU WANT TO CREATE THE ISMS TRANSACTION",XP(1)=" AND TRANSMIT IT TO AUSTIN",XH="ENTER 'YES' TO CREATE THE ISMS TRANSACTION AND TRANSMIT IT TO AUSTIN",XH(1)="ENTER 'NO' OR '^' TO EXIT."
W !! I $$YN^PRCPUYN(1)'=1 D Q Q
D TRANSMIT^PRCPSMCS(PRC("SITE"),"BAL","","ISM","")
W !!?4,"Transmitted in MailMan Messages:" I $D(PRCPXMZ) S %=0 F S %=$O(PRCPXMZ(%)) Q:'% W " ",PRCPXMZ(%)," "
Q K ^TMP($J,"BAL"),^TMP($J,"STRING"),^TMP($J,"MAIL")
Q
;
;
DQ ; queue comes here to send all items to isms
N CODESHT,COUNT,ITEMDA,LINE,PRCPCS,XMDUZ,XMSUB,XMTEXT,XMY
K ^TMP($J,"MAIL"),^TMP($J,"STRING")
S COUNT=1,LINE=5,ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA D
. L +^PRCP(445,PRCP("I"),1,ITEMDA)
. S CODESHT=$$BALANCE^PRCPSMB1(PRCP("I"),ITEMDA)
. I $E(CODESHT,1,2)'="BU" D Q
. . S ^TMP($J,"MAIL",LINE)="ITEM # "_ITEMDA_$E(" ",$L(ITEMDA),8)_$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,50),LINE=LINE+1
. . S ^TMP($J,"MAIL",LINE)=" "_CODESHT,LINE=LINE+1
. S ^TMP($J,"STRING",COUNT)=CODESHT,COUNT=COUNT+1
. L -^PRCP(445,PRCP("I"),1,ITEMDA)
;
; create mailman messages
K PRCPXMZ I COUNT>1 D TRANSMIT^PRCPSMCS(PRC("SITE"),"BAL","","ISM","")
S ^TMP($J,"MAIL",1)="ISMS BALANCE UPDATE TRANSACTION (IM-6): ALL ITEMS SELECTED"
S ^TMP($J,"MAIL",2)=$S('$D(PRCPXMZ):" *** BALANCE UPDATE TRANSACTION WAS NOT CREATED AND TRANSMITTED TO ISMS ***",1:" MAILMAN MESSAGE(S):")
I $D(PRCPXMZ) S %=0 F S %=$O(PRCPXMZ(%)) Q:'% S ^(2)=^TMP($J,"MAIL",2)_" "_+PRCPXMZ(%)
S ^TMP($J,"MAIL",3)="",^(4)=$S(LINE=5:"ALL INVENTORY ITEM BALANCES HAVE BEEN TRANSMITTED TO ISMS.",1:"THE FOLLOWING ITEMS DID NOT HAVE THEIR BALANCES TRANSMITTED TO ISMS:")
S XMSUB="ISMS BALANCE UPDATE TRANSACTION",XMTEXT="^TMP($J,""MAIL"",",XMDUZ=DUZ,XMY(DUZ)="" D ^XMD
D Q Q
;
;
TASKMAN ; taskman comes here to transmit all balances in the background
S PRCP("I")=0 F S PRCP("I")=$O(^PRCP(445,"AC","W",PRCP("I"))) Q:'PRCP("I") S PRC("SITE")=+$G(^PRCP(445,PRCP("I"),0)) I PRC("SITE") D DQ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPSMB0 4533 printed Sep 23, 2025@19:51:56 Page 2
PRCPSMB0 ;WISC/RFJ-isms transaction: balance update ;25 Oct 91
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 IF PRCP("DPTYPE")'="W"
WRITE !,"THIS OPTION SHOULD ONLY BE USED BY THE WAREHOUSE INVENTORY POINT."
QUIT
+5 ;I $$ISMSFLAG^PRCPUX2(PRC("SITE"))'=2 W !,"YOU NEED TO TURN THE ISMS SWITCH 'ON' BEFORE YOU CAN USE THIS OPTION." Q
+6 NEW %,CODESHT,COUNT,DESCR,ITEMDA,PRCPFLAG,PRCPXMZ,ZTSK
+7 SET IOP="HOME"
DO ^%ZIS
KILL IOP
DO Q
+8 WRITE !!,"To select ALL items, press RETURN."
+9 FOR
SET ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","")
if 'ITEMDA
QUIT
Begin DoDot:1
+10 SET CODESHT=$$BALANCE^PRCPSMB1(PRCP("I"),ITEMDA)
IF $EXTRACT(CODESHT,1,2)'="BU"
WRITE !?5,CODESHT
QUIT
+11 SET DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
+12 WRITE @IOF,!!,"I WILL TRANSMIT THE FOLLOWING BALANCES TO ISMS:"
+13 WRITE !,ITEMDA,?7,$EXTRACT(DESCR,1,50),?60,$PIECE(CODESHT,"^",2),!!?5,"ISSUE UNIT",?23,": ",$PIECE(CODESHT,"^",3),!?5,"QUANTITY ON-HAND",?23,": ",$PIECE(CODESHT,"^",4)/100
+14 WRITE !?5,"ON-HAND VALUE",?23,": ",$JUSTIFY(+$PIECE(CODESHT,"^",5)/100,0,2),!?5,"QUANTITY DUE-OUT",?23,": ",+$PIECE(CODESHT,"^",6)/100
+15 WRITE !?5,"AVERAGE COST",?23,": ",$JUSTIFY(+$PIECE(CODESHT,"^",7)/10000,0,3),!?5,"LAST RECEIPT COST",?23,": ",$JUSTIFY(+$PIECE(CODESHT,"^",8)/10000,0,3),!?5,"LAST SALE COST",?23,": ",$JUSTIFY(+$PIECE(CODESHT,"^",9)/10000,0,3)
+16 WRITE !!?1,"CS: ",CODESHT
+17 SET ^TMP($JOB,"BAL",ITEMDA)=DESCR_"^"_$PIECE(CODESHT,"^",2)
SET ^TMP($JOB,"BAL",ITEMDA,"CS")=CODESHT
End DoDot:1
+18 IF ITEMDA["^"
DO Q
QUIT
+19 IF '$ORDER(^TMP($JOB,"BAL",0))
SET XP="Do you want to select ALL items"
SET XH="Enter 'YES' to select ALL items, 'NO' or '^' to exit."
WRITE !
IF $$YN^PRCPUYN(1)=1
Begin DoDot:1
+20 WRITE !!,"I will queue this to run as a background job. When I finish building the",!,"code sheet, I will send you a mailman message with the code sheet number",!,"and items NOT transmitted because of errors found."
+21 SET ZTRTN="DQ^PRCPSMB0"
SET ZTIO=""
SET ZTDESC="ISMS Balance Transaction:All Items"
SET ZTSAVE("PRC*")=""
SET ZTSAVE("ZTREQ")="@"
DO ^%ZTLOAD
KILL ZTSK
End DoDot:1
DO Q
QUIT
+22 IF '$ORDER(^TMP($JOB,"BAL",0))
WRITE !,"NO ITEMS SELECTED."
DO Q
QUIT
+23 WRITE @IOF,!,"YOU HAVE SELECTED THE FOLLOWING ITEMS TO UPDATE ISMS BALANCES:"
SET ITEMDA=0
SET COUNT=1
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"BAL",ITEMDA))
if 'ITEMDA!($DATA(PRCPFLAG))
QUIT
SET %=^(ITEMDA)
IF %'=""
IF $DATA(^TMP($JOB,"BAL",ITEMDA,"CS"))
Begin DoDot:1
+24 WRITE !,ITEMDA,?7,$EXTRACT($PIECE(%,"^"),1,50),?60,$PIECE(%,"^",2)
SET ^TMP($JOB,"STRING",COUNT)=^TMP($JOB,"BAL",ITEMDA,"CS")
SET COUNT=COUNT+1
+25 IF $Y>(IOSL-5)
DO P^PRCPUREP
End DoDot:1
+26 IF $DATA(PRCPFLAG)
DO Q
QUIT
+27 IF '$ORDER(^TMP($JOB,"STRING",0))
WRITE !!,"NO CODE SHEETS CREATED."
DO Q
QUIT
+28 SET XP="*** ARE YOU SURE YOU WANT TO CREATE THE ISMS TRANSACTION"
SET XP(1)=" AND TRANSMIT IT TO AUSTIN"
SET XH="ENTER 'YES' TO CREATE THE ISMS TRANSACTION AND TRANSMIT IT TO AUSTIN"
SET XH(1)="ENTER 'NO' OR '^' TO EXIT."
+29 WRITE !!
IF $$YN^PRCPUYN(1)'=1
DO Q
QUIT
+30 DO TRANSMIT^PRCPSMCS(PRC("SITE"),"BAL","","ISM","")
+31 WRITE !!?4,"Transmitted in MailMan Messages:"
IF $DATA(PRCPXMZ)
SET %=0
FOR
SET %=$ORDER(PRCPXMZ(%))
if '%
QUIT
WRITE " ",PRCPXMZ(%)," "
Q KILL ^TMP($JOB,"BAL"),^TMP($JOB,"STRING"),^TMP($JOB,"MAIL")
+1 QUIT
+2 ;
+3 ;
DQ ; queue comes here to send all items to isms
+1 NEW CODESHT,COUNT,ITEMDA,LINE,PRCPCS,XMDUZ,XMSUB,XMTEXT,XMY
+2 KILL ^TMP($JOB,"MAIL"),^TMP($JOB,"STRING")
+3 SET COUNT=1
SET LINE=5
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
Begin DoDot:1
+4 LOCK +^PRCP(445,PRCP("I"),1,ITEMDA)
+5 SET CODESHT=$$BALANCE^PRCPSMB1(PRCP("I"),ITEMDA)
+6 IF $EXTRACT(CODESHT,1,2)'="BU"
Begin DoDot:2
+7 SET ^TMP($JOB,"MAIL",LINE)="ITEM # "_ITEMDA_$EXTRACT(" ",$LENGTH(ITEMDA),8)_$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,50)
SET LINE=LINE+1
+8 SET ^TMP($JOB,"MAIL",LINE)=" "_CODESHT
SET LINE=LINE+1
End DoDot:2
QUIT
+9 SET ^TMP($JOB,"STRING",COUNT)=CODESHT
SET COUNT=COUNT+1
+10 LOCK -^PRCP(445,PRCP("I"),1,ITEMDA)
End DoDot:1
+11 ;
+12 ; create mailman messages
+13 KILL PRCPXMZ
IF COUNT>1
DO TRANSMIT^PRCPSMCS(PRC("SITE"),"BAL","","ISM","")
+14 SET ^TMP($JOB,"MAIL",1)="ISMS BALANCE UPDATE TRANSACTION (IM-6): ALL ITEMS SELECTED"
+15 SET ^TMP($JOB,"MAIL",2)=$SELECT('$DATA(PRCPXMZ):" *** BALANCE UPDATE TRANSACTION WAS NOT CREATED AND TRANSMITTED TO ISMS ***",1:" MAILMAN MESSAGE(S):")
+16 IF $DATA(PRCPXMZ)
SET %=0
FOR
SET %=$ORDER(PRCPXMZ(%))
if '%
QUIT
SET ^(2)=^TMP($JOB,"MAIL",2)_" "_+PRCPXMZ(%)
+17 SET ^TMP($JOB,"MAIL",3)=""
SET ^(4)=$SELECT(LINE=5:"ALL INVENTORY ITEM BALANCES HAVE BEEN TRANSMITTED TO ISMS.",1:"THE FOLLOWING ITEMS DID NOT HAVE THEIR BALANCES TRANSMITTED TO ISMS:")
+18 SET XMSUB="ISMS BALANCE UPDATE TRANSACTION"
SET XMTEXT="^TMP($J,""MAIL"","
SET XMDUZ=DUZ
SET XMY(DUZ)=""
DO ^XMD
+19 DO Q
QUIT
+20 ;
+21 ;
TASKMAN ; taskman comes here to transmit all balances in the background
+1 SET PRCP("I")=0
FOR
SET PRCP("I")=$ORDER(^PRCP(445,"AC","W",PRCP("I")))
if 'PRCP("I")
QUIT
SET PRC("SITE")=+$GET(^PRCP(445,PRCP("I"),0))
IF PRC("SITE")
DO DQ
+2 QUIT
