| 1 | PRCHMSPD ;WISC/RWS-TRANSMIT DO1 TRANS TO MAILMAN ;8-20-92/10:27
|
|---|
| 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 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 | ;
|
|---|
| 12 | SYSID ; 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 | ;
|
|---|
| 20 | CHK ;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 | ;
|
|---|
| 25 | SEND ;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 | ;
|
|---|
| 31 | EXIT ;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
|
|---|
| 35 | TABLE ;FIELD NAME LOOKUP TABLE ;FIELD # WITHIN SEGMENT,POINTER TO FIELD NAME;
|
|---|
| 36 | AC ;;9,578;11,580;12,581;13,582
|
|---|
| 37 | D FORMAT Q
|
|---|
| 38 | BI ;;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
|
|---|
| 40 | DH ;;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
|
|---|
| 43 | DE ;;
|
|---|
| 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 | ;
|
|---|
| 48 | DL ;;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 | ;
|
|---|
| 55 | ERROR S ZTDTH="1H" D REQ^%ZTLOAD Q
|
|---|
| 56 | ;
|
|---|
| 57 | DSCERR S ERR="DE Segment Line Count Error" Q
|
|---|
| 58 | ;
|
|---|
| 59 | DSCER S ERR="DL Desc Line Count Error" Q
|
|---|
| 60 | ;
|
|---|
| 61 | DLERR S ERR="DL Segment Line Count Error" Q
|
|---|
| 62 | ;
|
|---|
| 63 | FORMAT ;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
|
|---|
