PRCHMSE ;WISC/RWS-IFCAP SERVER ROUTINE ;3/1/94 10:28 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
READ N X,XMB,XMSUB,XMDUN,XMDUZ,XMZ,Y,Z,XMY
N ERR,IFNO,IFSEG,ISNO,LCNT,LCSEG,LIN,SYSEG,TRANSIN,TRNSDA,TRY,TYP
S TRANSIN="^PRCF(423.6,"_PRCDA_",0)",TRNSDA=PRCDA
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
S X=@TRANSIN
S 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 "-832-833-ERR-MSG-ONA-OHS-OHC-OHG-OPE-PFA-PKE-"'[("-"_TYP_"-") S ERR="INVALID TRANSACTION TYPE ENCOUNTERED" G ERROR
D @TYP
;
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.OGR AUSTIN MESSAGES"
D WHO^XMA21 S:'$L($O(XMY(""))) XMY(.5)=""
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
Q
;
MSG ;INVENTORY MANAGEMENT MESSAGE
D MESG Q
;
ERR D MESG Q
;
832 ;CATALOG REQUEST VAMC MESSAGE
D MESG Q
;
833 ;CATALOG GLOBAL VAMC MSG
D MESG Q
;
ONA ;ORDER NUMBER ACKNOWLEDGEMENT
D ^PRCHMOP Q
;
OHS ;ORDER HEADER STATUS
D ^PRCHMESH Q
;
OHC ;ORDER HEADER CANCEL
D ^PRCHMESH Q
;
OHG ;ORDER HEADER CHANGE
D ^PRCHMESH Q
;
OPE ;ERROR ACKNOWLEDGEMENT
D ^PRCHMESE Q
;
PFA ;PACKAGING FACTOR ADJ
D ^PRCHMESP Q
;
PKE ;PICKING EXCEPTION
D ^PRCHMESP Q
;
ERROR S ZTDTH="1H" D REQ^%ZTLOAD Q
;
MESG ; READ MESSAGE LINES
S X=$Q(@TRANSIN),SYSEG=@X,ISNO=$P(SYSEG,U,7)
S ^XMB(3.9,XMZ,2,1,0)=" Message to ISMS mailgroup"
S ^XMB(3.9,XMZ,2,2,0)=""
S DIWL=0,DIWR=70 K ^UTILITY($J,"W") F LIN=2:1 D Q:Y=""!(X'[(","_PRCDA_","))
.S X=$Q(@X),Y=@X I Y?1"MS^".E S Y=$P(Y,U,2)
.I Y["$",$P(Y,"$",2)="" S Y=$P(Y,U)
.F Q:Y'[" " S Y=$P(Y," ",1)_" "_$P(Y," ",2,99)
.I $D(LSTPC) S Y=LSTPC_Y K LSTPC
.I $E(Y,$L(Y))?1AN S NOPCS=$L(Y," "),LSTPC=$P(Y," ",NOPCS),Y=$P(Y," ",1,NOPCS-1)
.D WP
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)
Q
;
WP N X S X=Y D DIWP^PRCUTL($G(DA))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMSE 2472 printed Dec 13, 2024@02:08:50 Page 2
PRCHMSE ;WISC/RWS-IFCAP SERVER ROUTINE ;3/1/94 10:28 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
READ NEW X,XMB,XMSUB,XMDUN,XMDUZ,XMZ,Y,Z,XMY
+1 NEW ERR,IFNO,IFSEG,ISNO,LCNT,LCSEG,LIN,SYSEG,TRANSIN,TRNSDA,TRY,TYP
+2 SET TRANSIN="^PRCF(423.6,"_PRCDA_",0)"
SET TRNSDA=PRCDA
+3 ; <<<< REW Sometimes PRCDA is not valid but no clear understanding of when/why -- should be a "clean" exit
IF $GET(@TRANSIN)=""
SET ERR="PRCHMSE wants ^PRCF(423.6,"_PRCDA_" which does not (now) exist"
GOTO ERROR
+4 SET X=@TRANSIN
+5 SET TYP=$EXTRACT(X,1,3)
SET LIN=0
SET TRANSIN=$QUERY(@TRANSIN)
+6 SET XMSUB="ISMS to IFCAP "_TYP_" transaction"
+7 SET XMDUZ="IFCAP MESSAGE SERVER"
+8 FOR TRY=1:1:5
DO GET^XMA2
IF TRY<5
if XMZ>0
QUIT
+9 IF TRY=5
IF XMZ<1
SET ERR=" UNABLE TO GET MAILMAN NUMBER AFTER 5 TRIES."
GOTO ERROR
+10 IF "-832-833-ERR-MSG-ONA-OHS-OHC-OHG-OPE-PFA-PKE-"'[("-"_TYP_"-")
SET ERR="INVALID TRANSACTION TYPE ENCOUNTERED"
GOTO ERROR
+11 DO @TYP
+12 ;
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.OGR AUSTIN MESSAGES"
+3 DO WHO^XMA21
if '$LENGTH($ORDER(XMY("")))
SET XMY(.5)=""
+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 QUIT
+3 ;
MSG ;INVENTORY MANAGEMENT MESSAGE
+1 DO MESG
QUIT
+2 ;
ERR DO MESG
QUIT
+1 ;
832 ;CATALOG REQUEST VAMC MESSAGE
+1 DO MESG
QUIT
+2 ;
833 ;CATALOG GLOBAL VAMC MSG
+1 DO MESG
QUIT
+2 ;
ONA ;ORDER NUMBER ACKNOWLEDGEMENT
+1 DO ^PRCHMOP
QUIT
+2 ;
OHS ;ORDER HEADER STATUS
+1 DO ^PRCHMESH
QUIT
+2 ;
OHC ;ORDER HEADER CANCEL
+1 DO ^PRCHMESH
QUIT
+2 ;
OHG ;ORDER HEADER CHANGE
+1 DO ^PRCHMESH
QUIT
+2 ;
OPE ;ERROR ACKNOWLEDGEMENT
+1 DO ^PRCHMESE
QUIT
+2 ;
PFA ;PACKAGING FACTOR ADJ
+1 DO ^PRCHMESP
QUIT
+2 ;
PKE ;PICKING EXCEPTION
+1 DO ^PRCHMESP
QUIT
+2 ;
ERROR SET ZTDTH="1H"
DO REQ^%ZTLOAD
QUIT
+1 ;
MESG ; READ MESSAGE LINES
+1 SET X=$QUERY(@TRANSIN)
SET SYSEG=@X
SET ISNO=$PIECE(SYSEG,U,7)
+2 SET ^XMB(3.9,XMZ,2,1,0)=" Message to ISMS mailgroup"
+3 SET ^XMB(3.9,XMZ,2,2,0)=""
+4 SET DIWL=0
SET DIWR=70
KILL ^UTILITY($JOB,"W")
FOR LIN=2:1
Begin DoDot:1
+5 SET X=$QUERY(@X)
SET Y=@X
IF Y?1"MS^".E
SET Y=$PIECE(Y,U,2)
+6 IF Y["$"
IF $PIECE(Y,"$",2)=""
SET Y=$PIECE(Y,U)
+7 FOR
if Y'[" "
QUIT
SET Y=$PIECE(Y," ",1)_" "_$PIECE(Y," ",2,99)
+8 IF $DATA(LSTPC)
SET Y=LSTPC_Y
KILL LSTPC
+9 IF $EXTRACT(Y,$LENGTH(Y))?1AN
SET NOPCS=$LENGTH(Y," ")
SET LSTPC=$PIECE(Y," ",NOPCS)
SET Y=$PIECE(Y," ",1,NOPCS-1)
+10 DO WP
End DoDot:1
if Y=""!(X'[(","_PRCDA_","))
QUIT
+11 FOR I=1:1:$GET(^UTILITY($JOB,"W",0))
SET LIN=LIN+1
SET ^XMB(3.9,XMZ,2,LIN,0)=^UTILITY($JOB,"W",0,I,0)
+12 QUIT
+13 ;
WP NEW X
SET X=Y
DO DIWP^PRCUTL($GET(DA))
+1 QUIT
