source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMSPD.m@ 623

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

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1PRCHMSPD ;WISC/RWS-TRANSMIT DO1 TRANS TO MAILMAN ;8-20-92/10:27
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5READ N I,J,K,X,XMB,XMSUB,XMDUN,XMDUZ,XMZ,Y,Z S TRANSIN="^PRCF(423.6,"_PRCDA_",0)",TRNSDA=PRCDA,X=@TRANSIN,TYP=$E(X,1,3),LIN=0,TRANSIN=$Q(@TRANSIN)
6 S XMSUB="ISMS to IFCAP "_TYP_" transaction"
7 S XMDUZ="IFCAP MESSAGE SERVER"
8 F TRY=1:1:5 D GET^XMA2 I TRY<5 Q:XMZ>0
9 I TRY=5,XMZ<1 S ERR=" UNABLE TO GET MAILMAN NUMBER AFTER 5 TRIES." G ERROR
10 I TYP'="DO1" S ERR="INVALID TRANSACTION TYPE" G ERROR
11 ;
12SYSID ; READ SYSID SEGMENT
13 S X=$Q(@TRANSIN),SYSEG=@X,IFNO=$P(SYSEG,U,7),IFNO=$E(IFNO,1,3)_"-"_$E(IFNO,4,99)
14 S ^XMB(3.9,XMZ,2,1,0)=""
15 S ^XMB(3.9,XMZ,2,2,0)="Delivery Order for IFCAP Purchase Order # "_IFNO_" has been received."
16 S ^XMB(3.9,XMZ,2,3,0)=""
17 S ^XMB(3.9,XMZ,2,4,0)=""
18 S ^XMB(3.9,XMZ,2,5,0)=""
19 ;
20CHK ;CHECK IFCAP PURCHASE ORDER NUMBER
21 ;I $E($P(SYSEG,U,7))="" S ERR="BLANK PO NUMBER IN HEADER" G ERROR
22 S DA=$O(^PRC(442,"B",IFNO,0)) I DA="" S ERR="PO NUMBER NOT FOUND" Q
23 S LIN=5 F I=1:1 S X=$Q(@X),SEG=@X,SEGTYP=$E(SEG,1,2) Q:"AC BI DH"'[SEGTYP D @SEGTYP
24 ;
25SEND ;SEND MAILMAN MESSAGE
26 I $G(ERR)'="" S LIN=$G(LIN)+1,^XMB(3.9,XMZ,2,LIN,0)=ERR
27 S:LIN>0 ^XMB(3.9,XMZ,2,0)="^3.92A^"_LIN_U_LIN_U_DT,XMDUN="IFCAP SERVER",X="G.ISM@"_^XMB("NETNAME")
28 D WHO^XMA21 S:'$L($O(XMY(""))) XMY(.5)="" S:$G(PPM)]"" XMY(PPM)=""
29 D ENT1^XMD K XMY
30 ;
31EXIT ;CLEAN UP AND QUIT
32 I '$D(ERR) S DIK="^PRCF(423.6,",DA=TRNSDA D ^DIK K DIK,DA ; DELETE TRANS FROM TEMP FILE
33 K DATA,DESEG,ERR,FLDIN,FLDOUT,IFNO,LIN,NODLS,NODSC,PAIR,SEG,SEGTYP,SYSEG,TRANSIN,TRNSDA,TRY,TYP S ZTREQ="@" QUIT
34 Q
35TABLE ;FIELD NAME LOOKUP TABLE ;FIELD # WITHIN SEGMENT,POINTER TO FIELD NAME;
36AC ;;9,578;11,580;12,581;13,582
37 D FORMAT Q
38BI ;;2,513.1;3,513.2;4,513.3;5,513.4;6,513.5;8,513.7;9,513.8;10,513.9
39 D FORMAT Q
40DH ;;2,533;3,534;4,535;5,541;6,536;7,534.5;8,543;9,543.3;10,543.4;11,538.5;15,514.1;16,515.2;
41 S NODSC=$P(SEG,U,20),NODLS=$P(SEG,U,21) D FORMAT,DE:NODSC,DL:NODLS
42 Q
43DE ;;
44 F J=1:1:NODSC S X=$Q(@X),DESEG=@X G:$P(DESEG,U,1)'="DE" DSCERR D
45 .S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=" "_$P(DESEG,U,2)
46 Q
47 ;
48DL ;;4,NSN;5,P/O LINE #;6,CONT #;7,CONT LIN #;8,REQ DEL DATE;9,QUANTITY;10,UNIT OF PURCH;11,SKU FACTOR;12,UNIT COST;13,SKU;14,DISCOUNT;15,INSP QTY;16,STATUS;
49 F K=1:1:NODLS S X=$Q(@X),SEG=@X,SEGTYP=$P(SEG,U,1) G:SEGTYP'="DL" DLERR D
50 .D FORMAT
51 .S NODSC=$P(SEG,U,17) I NODSC S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=" Lines of Description;" F J=1:1:NODSC S X=$Q(@X),Y=@X G:$P(Y,U,1)'="DE" DSCER D
52 ..S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=" "_$P(Y,U,2)
53 Q
54 ;
55ERROR S ZTDTH="1H" D REQ^%ZTLOAD Q
56 ;
57DSCERR S ERR="DE Segment Line Count Error" Q
58 ;
59DSCER S ERR="DL Desc Line Count Error" Q
60 ;
61DLERR S ERR="DL Segment Line Count Error" Q
62 ;
63FORMAT ;FORMAT MESSAGE LINES
64 S Z=$T(@SEGTYP),Z=$P(Z,";;",2,99) F J=1:1 Q:$P(Z,";",J)="" D
65 .S PAIR=$P(Z,";",J),FLDIN=$P(PAIR,",",1),FLDOUT=$P(PAIR,",",2)
66 .S DATA=$P(SEG,U,FLDIN) Q:DATA="" S NAME=$S(FLDOUT?.A:FLDOUT,$D(^DD(423,FLDOUT,0)):$P(^(0),U),1:FLDOUT)
67 .S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=" The "_NAME_$E(" ",$L(NAME),20)_" is "_DATA_". "
68 Q
Note: See TracBrowser for help on using the repository browser.