- 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 Feb 18, 2025@23:35:14 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