| 1 | PRCHMSE ;WISC/RWS-IFCAP SERVER ROUTINE ;3/1/94 10:28 AM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | READ N X,XMB,XMSUB,XMDUN,XMDUZ,XMZ,Y,Z,XMY
|
|---|
| 6 | N ERR,IFNO,IFSEG,ISNO,LCNT,LCSEG,LIN,SYSEG,TRANSIN,TRNSDA,TRY,TYP
|
|---|
| 7 | S TRANSIN="^PRCF(423.6,"_PRCDA_",0)",TRNSDA=PRCDA
|
|---|
| 8 | I $G(@TRANSIN)="" S ERR="PRCHMSE wants ^PRCF(423.6,"_PRCDA_" which does not (now) exist" G ERROR ; <<<< REW Sometimes PRCDA is not valid but no clear understanding of when/why -- should be a "clean" exit
|
|---|
| 9 | S X=@TRANSIN
|
|---|
| 10 | S TYP=$E(X,1,3),LIN=0,TRANSIN=$Q(@TRANSIN)
|
|---|
| 11 | S XMSUB="ISMS to IFCAP "_TYP_" transaction"
|
|---|
| 12 | S XMDUZ="IFCAP MESSAGE SERVER"
|
|---|
| 13 | F TRY=1:1:5 D GET^XMA2 I TRY<5 Q:XMZ>0
|
|---|
| 14 | I TRY=5,XMZ<1 S ERR=" UNABLE TO GET MAILMAN NUMBER AFTER 5 TRIES." G ERROR
|
|---|
| 15 | I "-832-833-ERR-MSG-ONA-OHS-OHC-OHG-OPE-PFA-PKE-"'[("-"_TYP_"-") S ERR="INVALID TRANSACTION TYPE ENCOUNTERED" G ERROR
|
|---|
| 16 | D @TYP
|
|---|
| 17 | ;
|
|---|
| 18 | SEND ;SEND MAILMAN MESSAGE
|
|---|
| 19 | I $G(ERR)'="" S LIN=$G(LIN)+1,^XMB(3.9,XMZ,2,LIN,0)=ERR
|
|---|
| 20 | S:LIN>0 ^XMB(3.9,XMZ,2,0)="^3.92A^"_LIN_U_LIN_U_DT,XMDUN="IFCAP SERVER",X="G.OGR AUSTIN MESSAGES"
|
|---|
| 21 | D WHO^XMA21 S:'$L($O(XMY(""))) XMY(.5)=""
|
|---|
| 22 | D ENT1^XMD K XMY
|
|---|
| 23 | ;
|
|---|
| 24 | EXIT ;CLEAN UP AND QUIT
|
|---|
| 25 | I '$D(ERR) S DIK="^PRCF(423.6,",DA=TRNSDA D ^DIK K DIK,DA ; DELETE TRANS FROM TEMP FILE
|
|---|
| 26 | Q
|
|---|
| 27 | ;
|
|---|
| 28 | MSG ;INVENTORY MANAGEMENT MESSAGE
|
|---|
| 29 | D MESG Q
|
|---|
| 30 | ;
|
|---|
| 31 | ERR D MESG Q
|
|---|
| 32 | ;
|
|---|
| 33 | 832 ;CATALOG REQUEST VAMC MESSAGE
|
|---|
| 34 | D MESG Q
|
|---|
| 35 | ;
|
|---|
| 36 | 833 ;CATALOG GLOBAL VAMC MSG
|
|---|
| 37 | D MESG Q
|
|---|
| 38 | ;
|
|---|
| 39 | ONA ;ORDER NUMBER ACKNOWLEDGEMENT
|
|---|
| 40 | D ^PRCHMOP Q
|
|---|
| 41 | ;
|
|---|
| 42 | OHS ;ORDER HEADER STATUS
|
|---|
| 43 | D ^PRCHMESH Q
|
|---|
| 44 | ;
|
|---|
| 45 | OHC ;ORDER HEADER CANCEL
|
|---|
| 46 | D ^PRCHMESH Q
|
|---|
| 47 | ;
|
|---|
| 48 | OHG ;ORDER HEADER CHANGE
|
|---|
| 49 | D ^PRCHMESH Q
|
|---|
| 50 | ;
|
|---|
| 51 | OPE ;ERROR ACKNOWLEDGEMENT
|
|---|
| 52 | D ^PRCHMESE Q
|
|---|
| 53 | ;
|
|---|
| 54 | PFA ;PACKAGING FACTOR ADJ
|
|---|
| 55 | D ^PRCHMESP Q
|
|---|
| 56 | ;
|
|---|
| 57 | PKE ;PICKING EXCEPTION
|
|---|
| 58 | D ^PRCHMESP Q
|
|---|
| 59 | ;
|
|---|
| 60 | ERROR S ZTDTH="1H" D REQ^%ZTLOAD Q
|
|---|
| 61 | ;
|
|---|
| 62 | MESG ; READ MESSAGE LINES
|
|---|
| 63 | S X=$Q(@TRANSIN),SYSEG=@X,ISNO=$P(SYSEG,U,7)
|
|---|
| 64 | S ^XMB(3.9,XMZ,2,1,0)=" Message to ISMS mailgroup"
|
|---|
| 65 | S ^XMB(3.9,XMZ,2,2,0)=""
|
|---|
| 66 | S DIWL=0,DIWR=70 K ^UTILITY($J,"W") F LIN=2:1 D Q:Y=""!(X'[(","_PRCDA_","))
|
|---|
| 67 | .S X=$Q(@X),Y=@X I Y?1"MS^".E S Y=$P(Y,U,2)
|
|---|
| 68 | .I Y["$",$P(Y,"$",2)="" S Y=$P(Y,U)
|
|---|
| 69 | .F Q:Y'[" " S Y=$P(Y," ",1)_" "_$P(Y," ",2,99)
|
|---|
| 70 | .I $D(LSTPC) S Y=LSTPC_Y K LSTPC
|
|---|
| 71 | .I $E(Y,$L(Y))?1AN S NOPCS=$L(Y," "),LSTPC=$P(Y," ",NOPCS),Y=$P(Y," ",1,NOPCS-1)
|
|---|
| 72 | .D WP
|
|---|
| 73 | F I=1:1:$G(^UTILITY($J,"W",0)) S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=^UTILITY($J,"W",0,I,0)
|
|---|
| 74 | Q
|
|---|
| 75 | ;
|
|---|
| 76 | WP N X S X=Y D DIWP^PRCUTL($G(DA))
|
|---|
| 77 | Q
|
|---|
