Routine: PRCHMHL1

PRCHMHL1 ;WISC/RWS-TRANSMIT HLS TRANS TO MAILMAN (CONTINUED) ;1/26/98 1100

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

LOOKUP F  S X=$Q(@X),SEG=@X,SEGTYP=$E(SEG,1,2) Q:SEGTYP=""  D:"AC-CU-BI-ST-LC-ML-RE"[SEGTYP @SEGTYP Q:SEG["$"  S A=$F(X,"PRCF"),B=$E(X,A-4,999) I $P(B,",",2)'=PRCDA S ERR="Information in transaction is incomplete." Q

TABLE ;FIELD NAME LOOKUP TABLE  ;FIELD # WITHIN SEGMENT,POINTER TO FIELD NAME;

AC ;;9,578;11,580;12,581;13,582

 D FORMAT Q

CU ;;2,512.2;3,512.1;4,512.3;5,512.4;6,512.5;8,512.7;9,512.8;10,512.9

 D FORMAT Q

BI ;;2,513.1;3,513.2;4,513.3;5,513.4;6,513.5;8,513.7;9,513.8;10,513.9

 D FORMAT Q

ST ;;2,514.1;3,514.2;4,514.3;5,514.4;6,514.5;8,514.7;9,514.8;10,514.9

 D FORMAT Q

LC ;;

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

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

 S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=" The source for this document is IFCAP REQ # "_IFNO

 I '$O(^PRC(442,"B",IFNO,0)) S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=" ****  THIS REQUISITION WAS NOT FOUND IN THE FILE ****"

ML K RSNS D:$G(TITLE)<1 TITLE S TITLE=TITLE-1,LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=""

 S LIN=LIN+1,LIN2=LIN,NSN=$P(SEG,U,6) S:NSN NSN=$E(NSN,1,4)_"-"_$E(NSN,5,6)_"-"_$E(NSN,7,9)_"-"_$E(NSN,10,20)

 S ^XMB(3.9,XMZ,2,LIN,0)=$J($P(SEG,U,3),4)_$J($P(SEG,U,9),3)_" "_$J($P(SEG,U,10),3)_"   ORIG    "_$J($P(SEG,U,8),7)_"    "_$J($P(SEG,U,7),3)_" "_$S(NSN:NSN,1:"")

 I $P(SEG,U,11) S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)="              RLSD"_$J($P(SEG,U,11)/100,14,2)

 I $P(SEG,U,12) S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)="              B/O "_$J($P(SEG,U,12)/100,14,2)

 I $P(SEG,U,15) S LIN=LIN+1,NSN=$P(SEG,U,15),NSN=$E(NSN,1,4)_"-"_$E(NSN,5,6)_"-"_$E(NSN,7,9)_"-"_$E(NSN,10,20)

 S ^XMB(3.9,XMZ,2,LIN,0)="              SUBS "_$J($P(SEG,U,17),4)_$J($P(SEG,U,16)/100,9,2)_"    "_$S(NSN:NSN,1:"")

 I $P(SEG,U,4)'=""!$P(SEG,U,5) S Z=$G(^XMB(3.9,XMZ,2,LIN2,0)),Z=Z_$E(BLANKS,$L(Z)+1,54)_"ACCNT CODE/SUB: "_$P(SEG,U,4)_"/"_$P(SEG,U,5),^(0)=Z,LIN2=LIN2+1

 I $P(SEG,U,13) S JDN=$P(SEG,U,13) D JDN S Z=$G(^XMB(3.9,XMZ,2,LIN2,0)),Z=Z_$E(BLANKS,$L(Z)+1,54)_"EST DEL DATE: "_JDF,^(0)=Z,LIN2=LIN2+1

 I $P(SEG,U,14) S JDN=$P(SEG,U,14) D JDN S Z=$G(^XMB(3.9,XMZ,2,LIN2,0)),Z=Z_$E(BLANKS,$L(Z)+1,54)_"PROMISD DATE: "_JDF,^(0)=Z,LIN2=LIN2+1

 I $P(SEG,U,21)'="" S Z=$G(^XMB(3.9,XMZ,2,LIN2,0)),Z=Z_$E(BLANKS,$L(Z)+1,54)_"ORIG WHSE: "_$P(SEG,U,21),^(0)=Z,LIN2=LIN2+1

 I $P(SEG,U,22)'="" S Z=$G(^XMB(3.9,XMZ,2,LIN2,0)),Z=Z_$E(BLANKS,$L(Z)+1,54)_"UNIT PRICE: "_$J($P(SEG,U,22)/10000,9,4),^(0)=Z,LIN2=LIN2+1

 I $P(SEG,U,23)'="" S Z=$G(^XMB(3.9,XMZ,2,LIN2,0)),Z=Z_$E(BLANKS,$L(Z)+1,54)_"EXTND PRICE: "_$J($P(SEG,U,23)/100,9,2),^(0)=Z,LIN2=LIN2+1

 S LIN=$S(LIN2>LIN:LIN2,1:LIN)+1

 I $P(SEG,U,2)="C" S ^XMB(3.9,XMZ,2,LIN,0)="              CANCELLED                         "_$P(SEG,U,19),LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=$$MSG^PRCHMHL2($P(SEG,U,18))

 I $P(SEG,U,2)="G" S ^XMB(3.9,XMZ,2,LIN,0)="              CHANGED",LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=$$MSG^PRCHMHL2($P(SEG,U,17))

 I $P(SEG,U,2)="A" S ^XMB(3.9,XMZ,2,LIN,0)="              ALLOCATED"

RE S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=$$MSG^PRCHMHL2($P(SEG,U,3))

FORMAT ;FORMAT MESSAGE LINES

 S Z=$T(@SEGTYP),Z=$P(Z,";;",2,99) F J=1:1 Q:$P(Z,";",J)=""  D

 .S PAIR=$P(Z,";",J),FLDIN=$P(PAIR,",",1),FLDOUT=$P(PAIR,",",2)

 .S DATA=$P(SEG,U,FLDIN) Q:DATA=""  S NAME=$S(FLDOUT?.A:FLDOUT,$D(^DD(423,FLDOUT,0)):$P(^(0),U),1:FLDOUT)

 .S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)="  The new "_NAME_$E("                    ",$L(NAME),20)_" is "_DATA_".  "

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

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

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),JDF=DA_" "_$P(MONS,U,MO)_" "_YR

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

MLERR S ERR="MAINTENANCE LINE ERROR"

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMHL1   4115     printed  Mar 13, 2025@21:13:32                                                                                                                                                                                                    Page 2

PRCHMHL1  ;WISC/RWS-TRANSMIT HLS TRANS TO MAILMAN (CONTINUED) ;1/26/98 1100

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;

LOOKUP     FOR

               SET X=$QUERY(@X)

               SET SEG=@X

               SET SEGTYP=$EXTRACT(SEG,1,2)

               if SEGTYP=""

                   QUIT

               if "AC-CU-BI-ST-LC-ML-RE"[SEGTYP

                   DO @SEGTYP

               if SEG["$"

                   QUIT

               SET A=$FIND(X,"PRCF")

               SET B=$EXTRACT(X,A-4,999)

               IF $PIECE(B,",",2)'=PRCDA

                   SET ERR="Information in transaction is incomplete."

                   QUIT

 +1        QUIT

 +2       ;

TABLE     ;FIELD NAME LOOKUP TABLE  ;FIELD # WITHIN SEGMENT,POINTER TO FIELD NAME;

AC        ;;9,578;11,580;12,581;13,582

 +1        DO FORMAT

           QUIT

CU        ;;2,512.2;3,512.1;4,512.3;5,512.4;6,512.5;8,512.7;9,512.8;10,512.9

 +1        DO FORMAT

           QUIT

BI        ;;2,513.1;3,513.2;4,513.3;5,513.4;6,513.5;8,513.7;9,513.8;10,513.9

 +1        DO FORMAT

           QUIT

ST        ;;2,514.1;3,514.2;4,514.3;5,514.4;6,514.5;8,514.7;9,514.8;10,514.9

 +1        DO FORMAT

           QUIT

LC        ;;

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

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

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

 +2        SET LIN=LIN+1

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

 +3        SET LIN=LIN+1

           SET ^XMB(3.9,XMZ,2,LIN,0)=" The source for this document is IFCAP REQ # "_IFNO

 +4        IF '$ORDER(^PRC(442,"B",IFNO,0))

               SET LIN=LIN+1

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

 +5        QUIT

 +6       ;

ML         KILL RSNS

           if $GET(TITLE)<1

               DO TITLE

           SET TITLE=TITLE-1

           SET LIN=LIN+1

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

 +1        SET LIN=LIN+1

           SET LIN2=LIN

           SET NSN=$PIECE(SEG,U,6)

           if NSN

               SET NSN=$EXTRACT(NSN,1,4)_"-"_$EXTRACT(NSN,5,6)_"-"_$EXTRACT(NSN,7,9)_"-"_$EXTRACT(NSN,10,20)

 +2        SET ^XMB(3.9,XMZ,2,LIN,0)=$JUSTIFY($PIECE(SEG,U,3),4)_$JUSTIFY($PIECE(SEG,U,9),3)_" "_$JUSTIFY($PIECE(SEG,U,10),3)_"   ORIG    "_$JUSTIFY($PIECE(SEG,U,8),7)_"    "_$JUSTIFY($PIECE(SEG,U,7),3)_" "_$SELECT(NSN:NSN,1:"")

 +3        IF $PIECE(SEG,U,11)

               SET LIN=LIN+1

               SET ^XMB(3.9,XMZ,2,LIN,0)="              RLSD"_$JUSTIFY($PIECE(SEG,U,11)/100,14,2)

 +4        IF $PIECE(SEG,U,12)

               SET LIN=LIN+1

               SET ^XMB(3.9,XMZ,2,LIN,0)="              B/O "_$JUSTIFY($PIECE(SEG,U,12)/100,14,2)

 +5        IF $PIECE(SEG,U,15)

               SET LIN=LIN+1

               SET NSN=$PIECE(SEG,U,15)

               SET NSN=$EXTRACT(NSN,1,4)_"-"_$EXTRACT(NSN,5,6)_"-"_$EXTRACT(NSN,7,9)_"-"_$EXTRACT(NSN,10,20)

 +6        SET ^XMB(3.9,XMZ,2,LIN,0)="              SUBS "_$JUSTIFY($PIECE(SEG,U,17),4)_$JUSTIFY($PIECE(SEG,U,16)/100,9,2)_"    "_$SELECT(NSN:NSN,1:"")

 +7        IF $PIECE(SEG,U,4)'=""!$PIECE(SEG,U,5)

               SET Z=$GET(^XMB(3.9,XMZ,2,LIN2,0))

               SET Z=Z_$EXTRACT(BLANKS,$LENGTH(Z)+1,54)_"ACCNT CODE/SUB: "_$PIECE(SEG,U,4)_"/"_$PIECE(SEG,U,5)

               SET ^(0)=Z

               SET LIN2=LIN2+1

 +8        IF $PIECE(SEG,U,13)

               SET JDN=$PIECE(SEG,U,13)

               DO JDN

               SET Z=$GET(^XMB(3.9,XMZ,2,LIN2,0))

               SET Z=Z_$EXTRACT(BLANKS,$LENGTH(Z)+1,54)_"EST DEL DATE: "_JDF

               SET ^(0)=Z

               SET LIN2=LIN2+1

 +9        IF $PIECE(SEG,U,14)

               SET JDN=$PIECE(SEG,U,14)

               DO JDN

               SET Z=$GET(^XMB(3.9,XMZ,2,LIN2,0))

               SET Z=Z_$EXTRACT(BLANKS,$LENGTH(Z)+1,54)_"PROMISD DATE: "_JDF

               SET ^(0)=Z

               SET LIN2=LIN2+1

 +10       IF $PIECE(SEG,U,21)'=""

               SET Z=$GET(^XMB(3.9,XMZ,2,LIN2,0))

               SET Z=Z_$EXTRACT(BLANKS,$LENGTH(Z)+1,54)_"ORIG WHSE: "_$PIECE(SEG,U,21)

               SET ^(0)=Z

               SET LIN2=LIN2+1

 +11       IF $PIECE(SEG,U,22)'=""

               SET Z=$GET(^XMB(3.9,XMZ,2,LIN2,0))

               SET Z=Z_$EXTRACT(BLANKS,$LENGTH(Z)+1,54)_"UNIT PRICE: "_$JUSTIFY($PIECE(SEG,U,22)/10000,9,4)

               SET ^(0)=Z

               SET LIN2=LIN2+1

 +12       IF $PIECE(SEG,U,23)'=""

               SET Z=$GET(^XMB(3.9,XMZ,2,LIN2,0))

               SET Z=Z_$EXTRACT(BLANKS,$LENGTH(Z)+1,54)_"EXTND PRICE: "_$JUSTIFY($PIECE(SEG,U,23)/100,9,2)

               SET ^(0)=Z

               SET LIN2=LIN2+1

 +13       SET LIN=$SELECT(LIN2>LIN:LIN2,1:LIN)+1

 +14       IF $PIECE(SEG,U,2)="C"

               SET ^XMB(3.9,XMZ,2,LIN,0)="              CANCELLED                         "_$PIECE(SEG,U,19)

               SET LIN=LIN+1

               SET ^XMB(3.9,XMZ,2,LIN,0)=$$MSG^PRCHMHL2($PIECE(SEG,U,18))

 +15       IF $PIECE(SEG,U,2)="G"

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

               SET LIN=LIN+1

               SET ^XMB(3.9,XMZ,2,LIN,0)=$$MSG^PRCHMHL2($PIECE(SEG,U,17))

 +16       IF $PIECE(SEG,U,2)="A"

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

 +17       QUIT

 +18      ;

RE         SET LIN=LIN+1

           SET ^XMB(3.9,XMZ,2,LIN,0)=$$MSG^PRCHMHL2($PIECE(SEG,U,3))

 +1        QUIT

 +2       ;

FORMAT    ;FORMAT MESSAGE LINES

 +1        SET Z=$TEXT(@SEGTYP)

           SET Z=$PIECE(Z,";;",2,99)

           FOR J=1:1

               if $PIECE(Z,";",J)=""

                   QUIT

               Begin DoDot:1

 +2                SET PAIR=$PIECE(Z,";",J)

                   SET FLDIN=$PIECE(PAIR,",",1)

                   SET FLDOUT=$PIECE(PAIR,",",2)

 +3                SET DATA=$PIECE(SEG,U,FLDIN)

                   if DATA=""

                       QUIT

                   SET NAME=$SELECT(FLDOUT?.A:FLDOUT,$DATA(^DD(423,FLDOUT,0)):$PIECE(^(0),U),1:FLDOUT)

 +4                SET LIN=LIN+1

                   SET ^XMB(3.9,XMZ,2,LIN,0)="  The new "_NAME_$EXTRACT("                    ",$LENGTH(NAME),20)_" is "_DATA_".  "

               End DoDot:1

 +5        QUIT

 +6       ;

TITLE      SET LIN=LIN+1

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

           SET TITLE=10

 +1        SET LIN=LIN+1

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

 +2        QUIT

 +3       ;

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 JDF=DA_" "_$PIECE(MONS,U,MO)_" "_YR

 +5        QUIT

 +6       ;

ERROR      SET ZTDTH="1H"

           DO REQ^%ZTLOAD

 +1        QUIT

 +2       ;

MLERR      SET ERR="MAINTENANCE LINE ERROR"

 +1        QUIT

PRCHMHL1.m