source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPSMSI.m@ 1801

Last change on this file since 1801 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.6 KB
RevLine 
[613]1PRCPSMSI ;WISC/RFJ-isms issue transaction ;27 Jan 92
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCPUSEL Q:'$G(PRCP("I"))
5 I PRCP("DPTYPE")'="W" W !,"THIS OPTION SHOULD ONLY BE USED BY THE WAREHOUSE INVENTORY POINT." Q
6 I $$ISMSFLAG^PRCPUX2(PRC("SITE"))'=2 W !,"YOU NEED TO TURN THE ISMS SWITCH 'ON' BEFORE YOU CAN USE THIS OPTION." Q
7 N %,COUNT,DATA,DELPT,DISYS,INVPT,PRCPFLAG,PRCPWAIT,SCREEN,TOTAL,TRANID,TRANNO,VOUCHER,WRITE,X
8 S IOP="HOME" D ^%ZIS K IOP,^TMP($J,"STRING")
9 S SCREEN="S %=$P(^PRCP(445.2,+Y,0),U,2) I $P(^(0),U)=PRCP(""I""),$E(%)=""R"",+$E(%,2),'$D(DATA(%))"
10 ; write identifier for fileman for file 445.2 (^prcp(445.2,da,0))
11 S WRITE="N %,Y S %=^(0),Y=$P(%,U,17) D DD^%DT W ?35,$P(%,U,2),?50,""posted: "",Y"
12TRANREG 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="?"
13 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="?"
14 I X["?" W @IOF,!,"Select the TRANSACTION NUMBER from the list below:",! K DATA,PRCPFLAG D G TRANREG
15 . 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"
16 . . I $D(^PRCP(445.2,Y,0)) S %=$P(^(0),"^",2) S:%'="" DATA(%)="" W !,$P(^(0),U,19) X WRITE
17 . . I $Y>(IOSL-2) D P^PRCPUREP Q:$D(PRCPFLAG) W @IOF,"Select the TRANSACTION NUMBER from the list below:",!
18 S TRANNO=X,%=$O(^PRCS(410,"B",TRANNO,0)),DELPT=$P($G(^PRCS(410,+%,9)),"^")
19 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
20 W !!,"TRANSACTION NUMBER: ",TRANNO,?40,"DATE DISTRIBUTED: ",Y,!?40,"INVENTORY POINT : ",$E(INVPT,1,23)
21 K PRCPFLAG S PRCPWAIT=1 W !?5,"...creating code sheets" D DQ^PRCPSMPI(TRANNO,TRANID)
22 I $O(^TMP($J,"STRING",0))="" W " NO code sheets created!" Q
23 W @IOF,!,"THE FOLLOWING CODE SHEETS WILL BE TRANSMITTED FOR ISSUES:"
24 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
25 I $D(PRCPFLAG) D Q Q
26 W !,"TOTAL CODE SHEETS TO TRANSMIT: ",+TOTAL,! I 'TOTAL D Q Q
27 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."
28 W !! I $$YN^PRCPUYN(1)'=1 D Q Q
29 D CODESHT^PRCPSMGO(PRC("SITE"),"ISS",VOUCHER)
30Q K ^TMP($J,"STRING") Q
Note: See TracBrowser for help on using the repository browser.