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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPSMSI 2677 printed Dec 13, 2024@02:16 Page 2
PRCPSMSI ;WISC/RFJ-isms issue transaction ;27 Jan 92
+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 IF $$ISMSFLAG^PRCPUX2(PRC("SITE"))'=2
WRITE !,"YOU NEED TO TURN THE ISMS SWITCH 'ON' BEFORE YOU CAN USE THIS OPTION."
QUIT
+6 NEW %,COUNT,DATA,DELPT,DISYS,INVPT,PRCPFLAG,PRCPWAIT,SCREEN,TOTAL,TRANID,TRANNO,VOUCHER,WRITE,X
+7 SET IOP="HOME"
DO ^%ZIS
KILL IOP,^TMP($JOB,"STRING")
+8 SET SCREEN="S %=$P(^PRCP(445.2,+Y,0),U,2) I $P(^(0),U)=PRCP(""I""),$E(%)=""R"",+$E(%,2),'$D(DATA(%))"
+9 ; write identifier for fileman for file 445.2 (^prcp(445.2,da,0))
+10 SET WRITE="N %,Y S %=^(0),Y=$P(%,U,17) D DD^%DT W ?35,$P(%,U,2),?50,""posted: "",Y"
TRANREG WRITE !!,"Select TRANSACTION (2237) NUMBER: "
READ X:DTIME
if '$TEST
SET X="^"
if X["^"!(X="")
QUIT
if X=" "
SET X=$PIECE($GET(^PRCP(445.2,+$GET(^DISV(DUZ,"^PRCP(445.2,")),0)),"^",19)
if 'X
SET X="?"
+1 IF X
SET DIC="^PRCP(445.2,"
SET DIC(0)="QE"
SET D="C"
SET DIC("W")=WRITE
SET DIC("S")=SCREEN
SET PRCPPRIV=1
KILL DATA
DO IX^DIC
KILL DIC,PRCPPRIV
IF +Y<0
SET X="?"
+2 IF X["?"
WRITE @IOF,!,"Select the TRANSACTION NUMBER from the list below:",!
KILL DATA,PRCPFLAG
Begin DoDot:1
+3 SET X=""
FOR
SET X=$ORDER(^PRCP(445.2,"C",X))
if X=""
QUIT
SET Y=0
FOR
SET Y=+$ORDER(^PRCP(445.2,"C",X,Y))
if 'Y
QUIT
XECUTE SCREEN
IF $TEST
Begin DoDot:2
+4 IF $DATA(^PRCP(445.2,Y,0))
SET %=$PIECE(^(0),"^",2)
if %'=""
SET DATA(%)=""
WRITE !,$PIECE(^(0),U,19)
XECUTE WRITE
+5 IF $Y>(IOSL-2)
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
WRITE @IOF,"Select the TRANSACTION NUMBER from the list below:",!
End DoDot:2
IF $DATA(PRCPFLAG)
SET X="zzzz"
End DoDot:1
GOTO TRANREG
+6 SET TRANNO=X
SET %=$ORDER(^PRCS(410,"B",TRANNO,0))
SET DELPT=$PIECE($GET(^PRCS(410,+%,9)),"^")
+7 SET DATA=^PRCP(445.2,+Y,0)
SET TRANID=$PIECE(DATA,"^",2)
SET INVPT=$PIECE($$INVNAME^PRCPUX1($PIECE(DATA,"^",18)),"-",2,99)
SET VOUCHER=$PIECE(DATA,"^",15)
SET Y=$PIECE(DATA,"^",17)
DO DD^%DT
+8 WRITE !!,"TRANSACTION NUMBER: ",TRANNO,?40,"DATE DISTRIBUTED: ",Y,!?40,"INVENTORY POINT : ",$EXTRACT(INVPT,1,23)
+9 KILL PRCPFLAG
SET PRCPWAIT=1
WRITE !?5,"...creating code sheets"
DO DQ^PRCPSMPI(TRANNO,TRANID)
+10 IF $ORDER(^TMP($JOB,"STRING",0))=""
WRITE " NO code sheets created!"
QUIT
+11 WRITE @IOF,!,"THE FOLLOWING CODE SHEETS WILL BE TRANSMITTED FOR ISSUES:"
+12 SET COUNT=0
FOR TOTAL=0:1
SET COUNT=$ORDER(^TMP($JOB,"STRING",COUNT))
if 'COUNT
QUIT
WRITE !?6,^(COUNT)
IF $Y>(IOSL-5)
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
WRITE @IOF
+13 IF $DATA(PRCPFLAG)
DO Q
QUIT
+14 WRITE !,"TOTAL CODE SHEETS TO TRANSMIT: ",+TOTAL,!
IF 'TOTAL
DO Q
QUIT
+15 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."
+16 WRITE !!
IF $$YN^PRCPUYN(1)'=1
DO Q
QUIT
+17 DO CODESHT^PRCPSMGO(PRC("SITE"),"ISS",VOUCHER)
Q KILL ^TMP($JOB,"STRING")
QUIT
