- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMOL1 2682 printed Apr 23, 2025@18:23:16 Page 2
- PRCHMOL1 ;WISC/RWS-TRANSMIT OLS TRANS TO MAILMAN (CONT) ;1/26/98 1100
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- LOOKUP ;LOOKUP INDIVIDUAL LINES
- +1 FOR
- SET X=$QUERY(@X)
- SET SEG=@X
- SET SEGTYP=$EXTRACT(SEG,1,2)
- if SEG=""
- QUIT
- if "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
- +2 QUIT
- ML KILL RSNS
- SET LIN=LIN+1
- SET ^XMB(3.9,XMZ,2,LIN,0)=""
- +1 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 LIN=LIN+1
- SET LIN2=LIN
- 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)_" "_NSN
- +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,16)
- 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)
- Begin DoDot:1
- +6 SET ^XMB(3.9,XMZ,2,LIN,0)=" SUBS "_$JUSTIFY($PIECE(SEG,U,17),4)_$JUSTIFY($PIECE(SEG,U,16)/100,9,2)_" "_NSN
- End DoDot: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
- RE SET LIN=LIN+1
- SET ^XMB(3.9,XMZ,2,LIN,0)=$$MSG^PRCHMHL2($PIECE(SEG,U,3))
- QUIT
- 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
- QUIT
