- PRCHMSHA ;WISC/RWS-TRANSMIT SHA TRANS TO MAILMAN ;1/26/98 1130
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- READ N DA,MO,YR,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 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'="SHA" S ERR="INVALID TRANSACTION TYPE" G ERROR
- ;
- SYSID ; READ SYSID SEGMENT
- S X=$Q(@TRANSIN),SYSEG=@X I $P(SYSEG,U,4)'="SHA" S ERR="WRONG TRANSACTION TYPE" G ERROR
- S X=$Q(@X),SEG=@X I $P(SEG,U)'="SH" S ERR="SH SEGMENT ERROR" Q
- S IFNO=$P(SEG,U,4),IFNO=$E(IFNO,1,3)_"-"_$E(IFNO,4,99),SHIPDATE=$P(SEG,U,8),DELDATE=$P(SEG,U,9),CARRIER=$P(SEG,U,7),GBLNO=$P(SEG,U,10)_"-"_$P(SEG,U,11),LCNT=$P(SEG,U,12)
- D JDN(.SHIPDATE),JDN(.DELDATE)
- S ^XMB(3.9,XMZ,2,1,0)=" SHIPPING ACKNOWLEDGEMENT"
- S ^XMB(3.9,XMZ,2,2,0)=""
- S ^XMB(3.9,XMZ,2,3,0)=" Items from IFCAP Purchase Order # "_IFNO_" were shipped on "_SHIPDATE
- S ^XMB(3.9,XMZ,2,4,0)="Via "_CARRIER_". The estimated delivery date is "_DELDATE
- S ^XMB(3.9,XMZ,2,5,0)="on Government Bill of Lading number "_GBLNO_"."
- S ^XMB(3.9,XMZ,2,6,0)=" IFCAP Line # - Quantity - SKU - Stock Number "
- ;
- CHK ;CHECK IFCAP PURCHASE ORDER NUMBER
- S DA=$O(^PRC(442,"B",IFNO,0)) I DA="" S ERR="PO NUMBER NOT FOUND"
- S LIN=6 F I=1:1:LCNT S X=$Q(@X),SEG=@X,SEGTYP=$E(SEG,1,2) G:SEGTYP'="SP" SPERR D
- .S NSN=$P(SEG,U,2),NSN=$E(NSN,1,4)_"-"_$E(NSN,5,6)_"-"_$E(NSN,7,9)_"-"_$E(NSN,10,20)
- .S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=$J($P(SEG,U,5),10)_$J($P(SEG,U,3)/100,20)_" "_$P(SEG,U,4)_" "_NSN
- ;
- 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 DATA,DESEG,ERR,FLDIN,FLDOUT,IFNO,LIN,NODLS,NODSC,PAIR,SEG,SEGTYP,SYSEG,TRANSIN,TRNSDA,TRY,TYP S ZTREQ="@"
- Q
- JDN(JDN) ; CHANGE JULIAN DATE (JDN) TO DA-MON-YEAR (JDF)
- S YR=$E(JDN,1,4),DA=$E(JDN,5,7)
- S $P(DAYS,U,2)=$S(YR#400=0:29,(YR#4=0&(YR#100'=0)):29,1:28)
- F MO=1:1 S DA=DA-$P(DAYS,U,MO) Q:DA'>0
- S DA=DA+$P(DAYS,U,MO),JDN=DA_" "_$P(MONS,U,MO)_" "_YR
- Q
- ;
- ERROR S ZTDTH="1H" D REQ^%ZTLOAD Q
- ;
- SPERR S ERR="SHIPPING LINE ERROR" Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMSHA 2747 printed Jan 18, 2025@03:10:02 Page 2
- PRCHMSHA ;WISC/RWS-TRANSMIT SHA TRANS TO MAILMAN ;1/26/98 1130
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- READ NEW DA,MO,YR,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 MONS="Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec"
- +2 SET DAYS="31^28^31^30^31^30^31^31^30^31^30^31"
- +3 SET XMSUB="ISMS to IFCAP "_TYP_" transaction"
- +4 SET XMDUZ="IFCAP MESSAGE SERVER"
- +5 FOR TRY=1:1:5
- DO GET^XMA2
- IF TRY<5
- if XMZ>0
- QUIT
- +6 IF TRY=5
- IF XMZ<1
- SET ERR=" UNABLE TO GET MAILMAN NUMBER AFTER 5 TRIES."
- GOTO ERROR
- +7 IF TYP'="SHA"
- SET ERR="INVALID TRANSACTION TYPE"
- GOTO ERROR
- +8 ;
- SYSID ; READ SYSID SEGMENT
- +1 SET X=$QUERY(@TRANSIN)
- SET SYSEG=@X
- IF $PIECE(SYSEG,U,4)'="SHA"
- SET ERR="WRONG TRANSACTION TYPE"
- GOTO ERROR
- +2 SET X=$QUERY(@X)
- SET SEG=@X
- IF $PIECE(SEG,U)'="SH"
- SET ERR="SH SEGMENT ERROR"
- QUIT
- +3 SET IFNO=$PIECE(SEG,U,4)
- SET IFNO=$EXTRACT(IFNO,1,3)_"-"_$EXTRACT(IFNO,4,99)
- SET SHIPDATE=$PIECE(SEG,U,8)
- SET DELDATE=$PIECE(SEG,U,9)
- SET CARRIER=$PIECE(SEG,U,7)
- SET GBLNO=$PIECE(SEG,U,10)_"-"_$PIECE(SEG,U,11)
- SET LCNT=$PIECE(SEG,U,12)
- +4 DO JDN(.SHIPDATE)
- DO JDN(.DELDATE)
- +5 SET ^XMB(3.9,XMZ,2,1,0)=" SHIPPING ACKNOWLEDGEMENT"
- +6 SET ^XMB(3.9,XMZ,2,2,0)=""
- +7 SET ^XMB(3.9,XMZ,2,3,0)=" Items from IFCAP Purchase Order # "_IFNO_" were shipped on "_SHIPDATE
- +8 SET ^XMB(3.9,XMZ,2,4,0)="Via "_CARRIER_". The estimated delivery date is "_DELDATE
- +9 SET ^XMB(3.9,XMZ,2,5,0)="on Government Bill of Lading number "_GBLNO_"."
- +10 SET ^XMB(3.9,XMZ,2,6,0)=" IFCAP Line # - Quantity - SKU - Stock Number "
- +11 ;
- CHK ;CHECK IFCAP PURCHASE ORDER NUMBER
- +1 SET DA=$ORDER(^PRC(442,"B",IFNO,0))
- IF DA=""
- SET ERR="PO NUMBER NOT FOUND"
- +2 SET LIN=6
- FOR I=1:1:LCNT
- SET X=$QUERY(@X)
- SET SEG=@X
- SET SEGTYP=$EXTRACT(SEG,1,2)
- if SEGTYP'="SP"
- GOTO SPERR
- Begin DoDot:1
- +3 SET NSN=$PIECE(SEG,U,2)
- SET NSN=$EXTRACT(NSN,1,4)_"-"_$EXTRACT(NSN,5,6)_"-"_$EXTRACT(NSN,7,9)_"-"_$EXTRACT(NSN,10,20)
- +4 SET LIN=LIN+1
- SET ^XMB(3.9,XMZ,2,LIN,0)=$JUSTIFY($PIECE(SEG,U,5),10)_$JUSTIFY($PIECE(SEG,U,3)/100,20)_" "_$PIECE(SEG,U,4)_" "_NSN
- End DoDot:1
- +5 ;
- 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 ; 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="@"
- +3 QUIT
- JDN(JDN) ; CHANGE JULIAN DATE (JDN) TO DA-MON-YEAR (JDF)
- +1 SET YR=$EXTRACT(JDN,1,4)
- SET DA=$EXTRACT(JDN,5,7)
- +2 SET $PIECE(DAYS,U,2)=$SELECT(YR#400=0:29,(YR#4=0&(YR#100'=0)):29,1:28)
- +3 FOR MO=1:1
- SET DA=DA-$PIECE(DAYS,U,MO)
- if DA'>0
- QUIT
- +4 SET DA=DA+$PIECE(DAYS,U,MO)
- SET JDN=DA_" "_$PIECE(MONS,U,MO)_" "_YR
- +5 QUIT
- +6 ;
- ERROR SET ZTDTH="1H"
- DO REQ^%ZTLOAD
- QUIT
- +1 ;
- SPERR SET ERR="SHIPPING LINE ERROR"
- QUIT