- PRCHMHLS ;WISC/RWS-TRANSMIT HLS TRANS TO MAILMAN ;9-17-92/09:53
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- READ N A,B,DA,MO,YR,I,J,K,NSN,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 MONS="Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec"
- S DAYS="31^28^31^30^31^30^31^31^30^31^30^31"
- 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'="HLS" S ERR="INVALID TRANSACTION TYPE" G ERROR
- ;
- SYSID ; READ SYSID SEGMENT
- S X=$Q(@TRANSIN),SYSEG=@X,ISNO=$P(SYSEG,U,7) I $P(SYSEG,U,4)'="HLS" S ERR="WRONG TRANSACTION TYPE" G ERROR
- S ^XMB(3.9,XMZ,2,1,0)=" Header Status Transaction (HLS)"
- S ^XMB(3.9,XMZ,2,2,0)=""
- S ^XMB(3.9,XMZ,2,3,0)=" The following items were changed on ISMS TO/SO number "_ISNO
- S ^XMB(3.9,XMZ,2,4,0)=""
- S BLANKS=$J(" ",57),LIN=4 D LOOKUP^PRCHMHL1
- ;
- 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)="" 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 BLANKS,DATA,DAYS,DESEG,ERR,FLDIN,FLDOUT,IFNO,ISNO,JDN,JDF,LCNT,LIN,LIN2,LN,NAME
- K MONS,NODLS,NODSC,PAIR,PPM,RESEG,SEG,SEGTYP,SYSEG,TITLE,TRANSIN,TRNSDA,TRY,TYP
- S ZTREQ="@"
- Q
- ;
- ERROR S ZTDTH="1H" D REQ^%ZTLOAD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMHLS 1724 printed Feb 18, 2025@23:35:09 Page 2
- PRCHMHLS ;WISC/RWS-TRANSMIT HLS TRANS TO MAILMAN ;9-17-92/09:53
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- READ NEW A,B,DA,MO,YR,I,J,K,NSN,X,XMB,XMSUB,XMDUN,XMDUZ,XMZ,Y,Z
- +1 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)
- +2 SET MONS="Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec"
- +3 SET DAYS="31^28^31^30^31^30^31^31^30^31^30^31"
- +4 SET XMSUB="ISMS to IFCAP "_TYP_" transaction"
- +5 SET XMDUZ="IFCAP MESSAGE SERVER"
- +6 FOR TRY=1:1:5
- DO GET^XMA2
- IF TRY<5
- if XMZ>0
- QUIT
- +7 IF TRY=5
- IF XMZ<1
- SET ERR=" UNABLE TO GET MAILMAN NUMBER AFTER 5 TRIES."
- GOTO ERROR
- +8 IF TYP'="HLS"
- SET ERR="INVALID TRANSACTION TYPE"
- GOTO ERROR
- +9 ;
- SYSID ; READ SYSID SEGMENT
- +1 SET X=$QUERY(@TRANSIN)
- SET SYSEG=@X
- SET ISNO=$PIECE(SYSEG,U,7)
- IF $PIECE(SYSEG,U,4)'="HLS"
- SET ERR="WRONG TRANSACTION TYPE"
- GOTO ERROR
- +2 SET ^XMB(3.9,XMZ,2,1,0)=" Header Status Transaction (HLS)"
- +3 SET ^XMB(3.9,XMZ,2,2,0)=""
- +4 SET ^XMB(3.9,XMZ,2,3,0)=" The following items were changed on ISMS TO/SO number "_ISNO
- +5 SET ^XMB(3.9,XMZ,2,4,0)=""
- +6 SET BLANKS=$JUSTIFY(" ",57)
- SET LIN=4
- DO LOOKUP^PRCHMHL1
- +7 ;
- 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)=""
- if $GET(PPM)]""
- SET XMY(PPM)=""
- +4 DO ENT1^XMD
- KILL XMY
- +5 ;
- EXIT ;CLEAN UP AND QUIT
- +1 ;I '$D(ERR) S DIK="^PRCF(423.6,",DA=TRNSDA D ^DIK K DIK,DA ; DELETE TRANS FROM TEMP FILE
- +2 KILL BLANKS,DATA,DAYS,DESEG,ERR,FLDIN,FLDOUT,IFNO,ISNO,JDN,JDF,LCNT,LIN,LIN2,LN,NAME
- +3 KILL MONS,NODLS,NODSC,PAIR,PPM,RESEG,SEG,SEGTYP,SYSEG,TITLE,TRANSIN,TRNSDA,TRY,TYP
- +4 SET ZTREQ="@"
- +5 QUIT
- +6 ;
- ERROR SET ZTDTH="1H"
- DO REQ^%ZTLOAD
- +1 QUIT