source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMOL1.m@ 1604

PRCHMOL1 ;WISC/RWS-TRANSMIT OLS TRANS TO MAILMAN (CONT) ;1/26/98 1100
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
LOOKUP ;LOOKUP INDIVIDUAL LINES
 F  S X=$Q(@X),SEG=@X,SEGTYP=$E(SEG,1,2) Q:SEG=""  D:"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
 QUIT
ML K RSNS S LIN=LIN+1,^XMB(3.9,XMZ,2,LIN,0)=""
 S 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 LIN=LIN+1,LIN2=LIN,^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)_" "_NSN
 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,16) 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) D
 .S ^XMB(3.9,XMZ,2,LIN,0)="              SUBS "_$J($P(SEG,U,17),4)_$J($P(SEG,U,16)/100,9,2)_"    "_NSN
 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
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