PRCHMSPD ;WISC/RWS-TRANSMIT DO1 TRANS TO MAILMAN ;8-20-92/10:27
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
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)
S XMSUB="ISMS to IFCAP "_TYP_" transaction"
S XMDUZ="IFCAP MESSAGE SERVER"
F TRY=1:1:5 D GET^XMA2 I TRY<5 Q:XMZ>0
I TRY=5,XMZ<1 S ERR=" UNABLE TO GET MAILMAN NUMBER AFTER 5 TRIES." G ERROR
I TYP'="DO1" S ERR="INVALID TRANSACTION TYPE" G ERROR
;
SYSID ; READ SYSID SEGMENT
S X=$Q(@TRANSIN),SYSEG=@X,IFNO=$P(SYSEG,U,7),IFNO=$E(IFNO,1,3)_"-"_$E(IFNO,4,99)
S ^XMB(3.9,XMZ,2,1,0)=""
S ^XMB(3.9,XMZ,2,2,0)="Delivery Order for IFCAP Purchase Order # "_IFNO_" has been received."
S ^XMB(3.9,XMZ,2,3,0)=""
S ^XMB(3.9,XMZ,2,4,0)=""
S ^XMB(3.9,XMZ,2,5,0)=""
;
CHK ;CHECK IFCAP PURCHASE ORDER NUMBER
;I $E($P(SYSEG,U,7))="" S ERR="BLANK PO NUMBER IN HEADER" G ERROR
S DA=$O(^PRC(442,"B",IFNO,0)) I DA="" S ERR="PO NUMBER NOT FOUND" Q
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
;
SEND ;SEND MAILMAN MESSAGE
I $G(ERR)'="" S LIN=$G(LIN)+1,^XMB(3.9,XMZ,2,LIN,0)=ERR
S:LIN>0 ^XMB(3.9,XMZ,2,0)="^3.92A^"_LIN_U_LIN_U_DT,XMDUN="IFCAP SERVER",X="G.ISM@"_^XMB("NETNAME")
D WHO^XMA21 S:'$L($O(XMY(""))) XMY(.5)="" S:$G(PPM)]"" XMY(PPM)=""
D ENT1^XMD K XMY
;
EXIT ;CLEAN UP AND QUIT
I '$D(ERR) S DIK="^PRCF(423.6,",DA=TRNSDA D ^DIK K DIK,DA ; DELETE TRANS FROM TEMP FILE
K DATA,DESEG,ERR,FLDIN,FLDOUT,IFNO,LIN,NODLS,NODSC,PAIR,SEG,SEGTYP,SYSEG,TRANSIN,TRNSDA,TRY,TYP S ZTREQ="@" QUIT
Q
TABLE ;FIELD NAME LOOKUP TABLE ;FIELD # WITHIN SEGMENT,POINTER TO FIELD NAME;
AC ;;9,578;11,580;12,581;13,582
D FORMAT Q
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
D FORMAT Q
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;
S NODSC=$P(SEG,U,20),NODLS=$P(SEG,U,21) D FORMAT,DE:NODSC,DL:NODLS
Q
DE ;;
F J=1:1:NODSC S X=$Q(@X),DESEG=@X G:$P(DESEG,U,1)'="DE" DSCERR D
.S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=" "_$P(DESEG,U,2)
Q
;
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;
F K=1:1:NODLS S X=$Q(@X),SEG=@X,SEGTYP=$P(SEG,U,1) G:SEGTYP'="DL" DLERR D
.D FORMAT
.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
..S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=" "_$P(Y,U,2)
Q
;
ERROR S ZTDTH="1H" D REQ^%ZTLOAD Q
;
DSCERR S ERR="DE Segment Line Count Error" Q
;
DSCER S ERR="DL Desc Line Count Error" Q
;
DLERR S ERR="DL Segment Line Count Error" Q
;
FORMAT ;FORMAT MESSAGE LINES
S Z=$T(@SEGTYP),Z=$P(Z,";;",2,99) F J=1:1 Q:$P(Z,";",J)="" D
.S PAIR=$P(Z,";",J),FLDIN=$P(PAIR,",",1),FLDOUT=$P(PAIR,",",2)
.S DATA=$P(SEG,U,FLDIN) Q:DATA="" S NAME=$S(FLDOUT?.A:FLDOUT,$D(^DD(423,FLDOUT,0)):$P(^(0),U),1:FLDOUT)
.S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=" The "_NAME_$E(" ",$L(NAME),20)_" is "_DATA_". "
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMSPD 3230 printed Dec 13, 2024@02:08:52 Page 2
PRCHMSPD ;WISC/RWS-TRANSMIT DO1 TRANS TO MAILMAN ;8-20-92/10:27
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
READ NEW I,J,K,X,XMB,XMSUB,XMDUN,XMDUZ,XMZ,Y,Z
SET TRANSIN="^PRCF(423.6,"_PRCDA_",0)"
SET TRNSDA=PRCDA
SET X=@TRANSIN
SET TYP=$EXTRACT(X,1,3)
SET LIN=0
SET TRANSIN=$QUERY(@TRANSIN)
+1 SET XMSUB="ISMS to IFCAP "_TYP_" transaction"
+2 SET XMDUZ="IFCAP MESSAGE SERVER"
+3 FOR TRY=1:1:5
DO GET^XMA2
IF TRY<5
if XMZ>0
QUIT
+4 IF TRY=5
IF XMZ<1
SET ERR=" UNABLE TO GET MAILMAN NUMBER AFTER 5 TRIES."
GOTO ERROR
+5 IF TYP'="DO1"
SET ERR="INVALID TRANSACTION TYPE"
GOTO ERROR
+6 ;
SYSID ; READ SYSID SEGMENT
+1 SET X=$QUERY(@TRANSIN)
SET SYSEG=@X
SET IFNO=$PIECE(SYSEG,U,7)
SET IFNO=$EXTRACT(IFNO,1,3)_"-"_$EXTRACT(IFNO,4,99)
+2 SET ^XMB(3.9,XMZ,2,1,0)=""
+3 SET ^XMB(3.9,XMZ,2,2,0)="Delivery Order for IFCAP Purchase Order # "_IFNO_" has been received."
+4 SET ^XMB(3.9,XMZ,2,3,0)=""
+5 SET ^XMB(3.9,XMZ,2,4,0)=""
+6 SET ^XMB(3.9,XMZ,2,5,0)=""
+7 ;
CHK ;CHECK IFCAP PURCHASE ORDER NUMBER
+1 ;I $E($P(SYSEG,U,7))="" S ERR="BLANK PO NUMBER IN HEADER" G ERROR
+2 SET DA=$ORDER(^PRC(442,"B",IFNO,0))
IF DA=""
SET ERR="PO NUMBER NOT FOUND"
QUIT
+3 SET LIN=5
FOR I=1:1
SET X=$QUERY(@X)
SET SEG=@X
SET SEGTYP=$EXTRACT(SEG,1,2)
if "AC BI DH"'[SEGTYP
QUIT
DO @SEGTYP
+4 ;
SEND ;SEND MAILMAN MESSAGE
+1 IF $GET(ERR)'=""
SET LIN=$GET(LIN)+1
SET ^XMB(3.9,XMZ,2,LIN,0)=ERR
+2 if LIN>0
SET ^XMB(3.9,XMZ,2,0)="^3.92A^"_LIN_U_LIN_U_DT
SET XMDUN="IFCAP SERVER"
SET X="G.ISM@"_^XMB("NETNAME")
+3 DO WHO^XMA21
if '$LENGTH($ORDER(XMY("")))
SET XMY(.5)=""
if $GET(PPM)]""
SET XMY(PPM)=""
+4 DO ENT1^XMD
KILL XMY
+5 ;
EXIT ;CLEAN UP AND QUIT
+1 ; DELETE TRANS FROM TEMP FILE
IF '$DATA(ERR)
SET DIK="^PRCF(423.6,"
SET DA=TRNSDA
DO ^DIK
KILL DIK,DA
+2 KILL DATA,DESEG,ERR,FLDIN,FLDOUT,IFNO,LIN,NODLS,NODSC,PAIR,SEG,SEGTYP,SYSEG,TRANSIN,TRNSDA,TRY,TYP
SET ZTREQ="@"
QUIT
+3 QUIT
TABLE ;FIELD NAME LOOKUP TABLE ;FIELD # WITHIN SEGMENT,POINTER TO FIELD NAME;
AC ;;9,578;11,580;12,581;13,582
+1 DO FORMAT
QUIT
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
+1 DO FORMAT
QUIT
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;
+1 SET NODSC=$PIECE(SEG,U,20)
SET NODLS=$PIECE(SEG,U,21)
DO FORMAT
if NODSC
DO DE
if NODLS
DO DL
+2 QUIT
DE ;;
+1 FOR J=1:1:NODSC
SET X=$QUERY(@X)
SET DESEG=@X
if $PIECE(DESEG,U,1)'="DE"
GOTO DSCERR
Begin DoDot:1
+2 SET LIN=LIN+1
SET ^XMB(3.9,XMZ,2,LIN,0)=" "_$PIECE(DESEG,U,2)
End DoDot:1
+3 QUIT
+4 ;
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;
+1 FOR K=1:1:NODLS
SET X=$QUERY(@X)
SET SEG=@X
SET SEGTYP=$PIECE(SEG,U,1)
if SEGTYP'="DL"
GOTO DLERR
Begin DoDot:1
+2 DO FORMAT
+3 SET NODSC=$PIECE(SEG,U,17)
IF NODSC
SET LIN=LIN+1
SET ^XMB(3.9,XMZ,2,LIN,0)=" Lines of Description;"
FOR J=1:1:NODSC
SET X=$QUERY(@X)
SET Y=@X
if $PIECE(Y,U,1)'="DE"
GOTO DSCER
Begin DoDot:2
+4 SET LIN=LIN+1
SET ^XMB(3.9,XMZ,2,LIN,0)=" "_$PIECE(Y,U,2)
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
ERROR SET ZTDTH="1H"
DO REQ^%ZTLOAD
QUIT
+1 ;
DSCERR SET ERR="DE Segment Line Count Error"
QUIT
+1 ;
DSCER SET ERR="DL Desc Line Count Error"
QUIT
+1 ;
DLERR SET ERR="DL Segment Line Count Error"
QUIT
+1 ;
FORMAT ;FORMAT MESSAGE LINES
+1 SET Z=$TEXT(@SEGTYP)
SET Z=$PIECE(Z,";;",2,99)
FOR J=1:1
if $PIECE(Z,";",J)=""
QUIT
Begin DoDot:1
+2 SET PAIR=$PIECE(Z,";",J)
SET FLDIN=$PIECE(PAIR,",",1)
SET FLDOUT=$PIECE(PAIR,",",2)
+3 SET DATA=$PIECE(SEG,U,FLDIN)
if DATA=""
QUIT
SET NAME=$SELECT(FLDOUT?.A:FLDOUT,$DATA(^DD(423,FLDOUT,0)):$PIECE(^(0),U),1:FLDOUT)
+4 SET LIN=LIN+1
SET ^XMB(3.9,XMZ,2,LIN,0)=" The "_NAME_$EXTRACT(" ",$LENGTH(NAME),20)_" is "_DATA_". "
End DoDot:1
+5 QUIT
