Routine: PRCHMOLS

PRCHMOLS ;WISC/RWS-TRANSMIT OLS TRANS TO MAILMAN ;8-20-92/11:01

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,PRCHPO,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'="OLS" S ERR="INVALID TRANSACTION TYPE" G ERROR

SYSID ; READ SYSID SEGMENT

 S X=$Q(@TRANSIN),SYSEG=@X I $P(SYSEG,U,4)'="OLS" S ERR="WRONG TRANSACTION TYPE" G ERROR

 S X=$Q(@X),SEG=@X I $P(SEG,U)'="LC" S ERR="LC SEGMENT ERROR" Q

 S IFNO=$P(SEG,U,3),IFNO=$E(IFNO,1,3)_"-"_$E(IFNO,4,99),LCNT=$P(SEG,U,2) D CHK

 S ^XMB(3.9,XMZ,2,1,0)="                   Line Status Transaction (OLS)"

 S ^XMB(3.9,XMZ,2,2,0)=""

 S ^XMB(3.9,XMZ,2,3,0)="   The following items were Allocated/Backordered/Cancelled"

 S LIN=4,^XMB(3.9,XMZ,2,LIN,0)="         from IFCAP Requisition Number "_IFNO

 I $D(NOTFOUND) S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)="****  THIS REQUISITION WAS NOT FOUND IN THE FILE  ***" K NOTFOUND

 S LIN=LIN+1,^XMB(3.9,XMZ,2,5,0)=""

 S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)="Line F/K Subs Stat RsnCode  Qty  SKU Stock Number Comments/Reason Codes  "

 S BLANKS=$J(" ",57) D LOOKUP^PRCHMOL1

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,JDN,JDF,LCNT,LIN2,LIN,LN,MONS

 K NODLS,NODSC,NSN,PAIR,PPM,RESEG,SEG,SEGTYP,SYSEG,TRANSIN,TRNSDA,TRY,TYP

 S ZTREQ="@"

ERROR S ZTDTH="1H" D REQ^%ZTLOAD

CHK ;CHECK IFCAP PURCHASE ORDER NUMBER

 S DA=$O(^PRC(442,"B",IFNO,0)) I DA="" S NOTFOUND=""

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMOLS   2248     printed  Mar 13, 2025@21:13:35                                                                                                                                                                                                    Page 2

PRCHMOLS  ;WISC/RWS-TRANSMIT OLS TRANS TO MAILMAN ;8-20-92/11:01

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,PRCHPO,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'="OLS"

               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)'="OLS"

               SET ERR="WRONG TRANSACTION TYPE"

               GOTO ERROR

 +2        SET X=$QUERY(@X)

           SET SEG=@X

           IF $PIECE(SEG,U)'="LC"

               SET ERR="LC SEGMENT ERROR"

               QUIT

 +3        SET IFNO=$PIECE(SEG,U,3)

           SET IFNO=$EXTRACT(IFNO,1,3)_"-"_$EXTRACT(IFNO,4,99)

           SET LCNT=$PIECE(SEG,U,2)

           DO CHK

 +4        SET ^XMB(3.9,XMZ,2,1,0)="                   Line Status Transaction (OLS)"

 +5        SET ^XMB(3.9,XMZ,2,2,0)=""

 +6        SET ^XMB(3.9,XMZ,2,3,0)="   The following items were Allocated/Backordered/Cancelled"

 +7        SET LIN=4

           SET ^XMB(3.9,XMZ,2,LIN,0)="         from IFCAP Requisition Number "_IFNO

 +8        IF $DATA(NOTFOUND)

               SET LIN=LIN+1

               SET ^XMB(3.9,XMZ,2,LIN,0)="****  THIS REQUISITION WAS NOT FOUND IN THE FILE  ***"

               KILL NOTFOUND

 +9        SET LIN=LIN+1

           SET ^XMB(3.9,XMZ,2,5,0)=""

 +10       SET LIN=LIN+1

           SET ^XMB(3.9,XMZ,2,LIN,0)="Line F/K Subs Stat RsnCode  Qty  SKU Stock Number Comments/Reason Codes  "

 +11       SET BLANKS=$JUSTIFY(" ",57)

           DO LOOKUP^PRCHMOL1

 +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)=""

           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 BLANKS,DATA,DAYS,DESEG,ERR,FLDIN,FLDOUT,IFNO,JDN,JDF,LCNT,LIN2,LIN,LN,MONS

 +3        KILL NODLS,NODSC,NSN,PAIR,PPM,RESEG,SEG,SEGTYP,SYSEG,TRANSIN,TRNSDA,TRY,TYP

 +4        SET ZTREQ="@"

 +5        QUIT

 +6       ;

ERROR      SET ZTDTH="1H"

           DO REQ^%ZTLOAD

 +1        QUIT

 +2       ;

CHK       ;CHECK IFCAP PURCHASE ORDER NUMBER

 +1        SET DA=$ORDER(^PRC(442,"B",IFNO,0))

           IF DA=""

               SET NOTFOUND=""

 +2        QUIT

PRCHMOLS.m