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