- 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 Mar 13, 2025@21:20:38 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
