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
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 ****"
Q
;
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"
Q
;
RE S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=$$MSG^PRCHMHL2($P(SEG,U,3))
Q
;
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_". "
Q
;
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 "
Q
;
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
Q
;
ERROR S ZTDTH="1H" D REQ^%ZTLOAD
Q
;
MLERR S ERR="MAINTENANCE LINE ERROR"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMHL1 4115 printed Apr 09, 2024@21:21:04 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
