Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHMSE

PRCHMSE.m

Go to the documentation of this file.
  1. PRCHMSE ;WISC/RWS-IFCAP SERVER ROUTINE ;3/1/94 10:28 AM
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. READ N X,XMB,XMSUB,XMDUN,XMDUZ,XMZ,Y,Z,XMY
  1. N ERR,IFNO,IFSEG,ISNO,LCNT,LCSEG,LIN,SYSEG,TRANSIN,TRNSDA,TRY,TYP
  1. S TRANSIN="^PRCF(423.6,"_PRCDA_",0)",TRNSDA=PRCDA
  1. 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
  1. S X=@TRANSIN
  1. S TYP=$E(X,1,3),LIN=0,TRANSIN=$Q(@TRANSIN)
  1. S XMSUB="ISMS to IFCAP "_TYP_" transaction"
  1. S XMDUZ="IFCAP MESSAGE SERVER"
  1. F TRY=1:1:5 D GET^XMA2 I TRY<5 Q:XMZ>0
  1. I TRY=5,XMZ<1 S ERR=" UNABLE TO GET MAILMAN NUMBER AFTER 5 TRIES." G ERROR
  1. I "-832-833-ERR-MSG-ONA-OHS-OHC-OHG-OPE-PFA-PKE-"'[("-"_TYP_"-") S ERR="INVALID TRANSACTION TYPE ENCOUNTERED" G ERROR
  1. D @TYP
  1. ;
  1. SEND ;SEND MAILMAN MESSAGE
  1. I $G(ERR)'="" S LIN=$G(LIN)+1,^XMB(3.9,XMZ,2,LIN,0)=ERR
  1. S:LIN>0 ^XMB(3.9,XMZ,2,0)="^3.92A^"_LIN_U_LIN_U_DT,XMDUN="IFCAP SERVER",X="G.OGR AUSTIN MESSAGES"
  1. D WHO^XMA21 S:'$L($O(XMY(""))) XMY(.5)=""
  1. D ENT1^XMD K XMY
  1. ;
  1. EXIT ;CLEAN UP AND QUIT
  1. I '$D(ERR) S DIK="^PRCF(423.6,",DA=TRNSDA D ^DIK K DIK,DA ; DELETE TRANS FROM TEMP FILE
  1. Q
  1. ;
  1. MSG ;INVENTORY MANAGEMENT MESSAGE
  1. D MESG Q
  1. ;
  1. ERR D MESG Q
  1. ;
  1. 832 ;CATALOG REQUEST VAMC MESSAGE
  1. D MESG Q
  1. ;
  1. 833 ;CATALOG GLOBAL VAMC MSG
  1. D MESG Q
  1. ;
  1. ONA ;ORDER NUMBER ACKNOWLEDGEMENT
  1. D ^PRCHMOP Q
  1. ;
  1. OHS ;ORDER HEADER STATUS
  1. D ^PRCHMESH Q
  1. ;
  1. OHC ;ORDER HEADER CANCEL
  1. D ^PRCHMESH Q
  1. ;
  1. OHG ;ORDER HEADER CHANGE
  1. D ^PRCHMESH Q
  1. ;
  1. OPE ;ERROR ACKNOWLEDGEMENT
  1. D ^PRCHMESE Q
  1. ;
  1. PFA ;PACKAGING FACTOR ADJ
  1. D ^PRCHMESP Q
  1. ;
  1. PKE ;PICKING EXCEPTION
  1. D ^PRCHMESP Q
  1. ;
  1. ERROR S ZTDTH="1H" D REQ^%ZTLOAD Q
  1. ;
  1. MESG ; READ MESSAGE LINES
  1. S X=$Q(@TRANSIN),SYSEG=@X,ISNO=$P(SYSEG,U,7)
  1. S ^XMB(3.9,XMZ,2,1,0)=" Message to ISMS mailgroup"
  1. S ^XMB(3.9,XMZ,2,2,0)=""
  1. S DIWL=0,DIWR=70 K ^UTILITY($J,"W") F LIN=2:1 D Q:Y=""!(X'[(","_PRCDA_","))
  1. .S X=$Q(@X),Y=@X I Y?1"MS^".E S Y=$P(Y,U,2)
  1. .I Y["$",$P(Y,"$",2)="" S Y=$P(Y,U)
  1. .F Q:Y'[" " S Y=$P(Y," ",1)_" "_$P(Y," ",2,99)
  1. .I $D(LSTPC) S Y=LSTPC_Y K LSTPC
  1. .I $E(Y,$L(Y))?1AN S NOPCS=$L(Y," "),LSTPC=$P(Y," ",NOPCS),Y=$P(Y," ",1,NOPCS-1)
  1. .D WP
  1. 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)
  1. Q
  1. ;
  1. WP N X S X=Y D DIWP^PRCUTL($G(DA))
  1. Q