31 lines
2.6 KiB
Mathematica
31 lines
2.6 KiB
Mathematica
PRCPSMSI ;WISC/RFJ-isms issue transaction ;27 Jan 92
|
|
;;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 %,COUNT,DATA,DELPT,DISYS,INVPT,PRCPFLAG,PRCPWAIT,SCREEN,TOTAL,TRANID,TRANNO,VOUCHER,WRITE,X
|
|
S IOP="HOME" D ^%ZIS K IOP,^TMP($J,"STRING")
|
|
S SCREEN="S %=$P(^PRCP(445.2,+Y,0),U,2) I $P(^(0),U)=PRCP(""I""),$E(%)=""R"",+$E(%,2),'$D(DATA(%))"
|
|
; write identifier for fileman for file 445.2 (^prcp(445.2,da,0))
|
|
S WRITE="N %,Y S %=^(0),Y=$P(%,U,17) D DD^%DT W ?35,$P(%,U,2),?50,""posted: "",Y"
|
|
TRANREG W !!,"Select TRANSACTION (2237) NUMBER: " R X:DTIME S:'$T X="^" Q:X["^"!(X="") S:X=" " X=$P($G(^PRCP(445.2,+$G(^DISV(DUZ,"^PRCP(445.2,")),0)),"^",19) S:'X X="?"
|
|
I X S DIC="^PRCP(445.2,",DIC(0)="QE",D="C",DIC("W")=WRITE,DIC("S")=SCREEN,PRCPPRIV=1 K DATA D IX^DIC K DIC,PRCPPRIV I +Y<0 S X="?"
|
|
I X["?" W @IOF,!,"Select the TRANSACTION NUMBER from the list below:",! K DATA,PRCPFLAG D G TRANREG
|
|
. S X="" F S X=$O(^PRCP(445.2,"C",X)) Q:X="" S Y=0 F S Y=+$O(^PRCP(445.2,"C",X,Y)) Q:'Y X SCREEN I $T D I $D(PRCPFLAG) S X="zzzz"
|
|
. . I $D(^PRCP(445.2,Y,0)) S %=$P(^(0),"^",2) S:%'="" DATA(%)="" W !,$P(^(0),U,19) X WRITE
|
|
. . I $Y>(IOSL-2) D P^PRCPUREP Q:$D(PRCPFLAG) W @IOF,"Select the TRANSACTION NUMBER from the list below:",!
|
|
S TRANNO=X,%=$O(^PRCS(410,"B",TRANNO,0)),DELPT=$P($G(^PRCS(410,+%,9)),"^")
|
|
S DATA=^PRCP(445.2,+Y,0),TRANID=$P(DATA,"^",2),INVPT=$P($$INVNAME^PRCPUX1($P(DATA,"^",18)),"-",2,99),VOUCHER=$P(DATA,"^",15),Y=$P(DATA,"^",17) D DD^%DT
|
|
W !!,"TRANSACTION NUMBER: ",TRANNO,?40,"DATE DISTRIBUTED: ",Y,!?40,"INVENTORY POINT : ",$E(INVPT,1,23)
|
|
K PRCPFLAG S PRCPWAIT=1 W !?5,"...creating code sheets" D DQ^PRCPSMPI(TRANNO,TRANID)
|
|
I $O(^TMP($J,"STRING",0))="" W " NO code sheets created!" Q
|
|
W @IOF,!,"THE FOLLOWING CODE SHEETS WILL BE TRANSMITTED FOR ISSUES:"
|
|
S COUNT=0 F TOTAL=0:1 S COUNT=$O(^TMP($J,"STRING",COUNT)) Q:'COUNT W !?6,^(COUNT) I $Y>(IOSL-5) D P^PRCPUREP Q:$D(PRCPFLAG) W @IOF
|
|
I $D(PRCPFLAG) D Q Q
|
|
W !,"TOTAL CODE SHEETS TO TRANSMIT: ",+TOTAL,! I 'TOTAL 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 CODESHT^PRCPSMGO(PRC("SITE"),"ISS",VOUCHER)
|
|
Q K ^TMP($J,"STRING") Q
|