PRCOESE ;WISC/DJM-IFCAP EDI POA Server Interface ; [8/31/98 1:55pm]
V ;;5.1;IFCAP;**202**;Oct 20, 2000;Build 27
;Per VA Directive 6402, this routine should not be modified.
SERV N A,AA,AC,ACD,B,CC,CU,CU1,CU2,C1L,DA,DC,DIE,DR,EE,ERR,FOB,G,G1,I,IT
N KD,KP,L,LINE,LN,MPN,M1,N,N1,N1L,N2,N2L,N3,N3L,PC,PN,PO,PO1,PPM,PPT
N PRC,PRCNO,PRCOI,PU,QT,QTFLG,RP,S1,UC,UC1,UC2,UNIT,UP,UPN,VP,V1,V2
N X,X1,X2,PRCTC,PRCX,RECORD,STATION,STCK,VENDOR
K ERR
;
;If QTFLG=1, processing stops because the error is serious
;
S (QTFLG,LN)=0
F S LN=$O(^PRCF(423.6,PRCDA,1,LN)) QUIT:'LN G:QTFLG>0 S1 D MAIN
;
D KILL^PRCOSRV3(PRCDA)
QUIT
;
MAIN ;Start processing the POA segments
;
S LINE=^(LN,0)
I LINE["$" D S1 QUIT ;End of this record. Stop and process any errors.
;
S A=$P(LINE,U)
S AA="SEG"_$S(A="ISM":"1",A="HE":"2",A="VE":"3",A="AC":"4",A="ST":"5",A="IT":"6",A="DE":"7",A="AK":"8",A="CO":"9",1:"10")
;
D @AA ;Process segment
;
QUIT
;
SEG1 S B=$P(LINE,U,4)
G:B'="POA" SEG10
S CC=$P(LINE,U,7)
F Q:$A(CC,$L(CC))'=32 S CC=$E(CC,1,$L(CC)-1)
S CC=$E(CC,1,3)_"-"_$E(CC,4,$L(CC))
S ERR(CC,0)=""
S STATION=$P(LINE,U,3)
S STCK=$O(^PRC(411,"B",STATION,0))
I STCK'>0 S ERR("STATION")=STATION,QTFLG=1 Q
S PO=$O(^PRC(442,"B",CC,0))
S:PO="" ERR(CC,0)="*",QTFLG=1
Q:QTFLG>0
S PO1=$G(^PRC(442,PO,1))
S:PO1="" ERR(CC,0)="*",QTFLG=1
Q:QTFLG>0
S PPM=$P(PO1,U,10)
D BUL^PRCOESE1
;
; GATHER DATA FROM CONTROL SEGMENT.
;
S PRCTC=$P(LINE,U,4)
S X1=$E($P(LINE,U,5),1,4)-1700_"0101"
S X2=$E($P(LINE,U,5),5,7)-1
D C^%DTC
S PRCX=X_"."_$P(LINE,U,6)
;
QUIT ;Exit the SEG1 sub routine
;
SEG2 QUIT
;
SEG3 ; GET DATA FROM "VE" SEGMENT.
S VENDOR=$P(LINE,U,2)
;
; NOW LETS FIND THE PROPER RECORD IN FILE 443.75.
;
;Austin did not provide the Vendor_Id. Use the PO to get it.
I VENDOR="" D QUIT:QTFLG=1
. N PO,IEN
. S PO=CC ;PO number
. S IEN=$O(^PRC(442,"B",PO,"")) ;Get IEN
. S VENDOR=$P($G(^PRC(442,IEN,1)),U) ;Internal_Vendor_Number
. S VENDOR=$P($G(^PRC(440,VENDOR,3)),U,3) ;Vendor_Id
. I VENDOR'="" QUIT ;Vendor_Id (yes)
. S $P(ERR("VENDOR"),U)="*",QTFLG=1 ;Vendor_Id (no)
. ;
S RECORD=$O(^PRC(443.75,"AO","PHA",CC,VENDOR,0))
I RECORD="" S $P(ERR("RECORD"),U)="*",QTFLG=1
;
QUIT ;Exit the SEG3 sub routine
;
SEG4 S ERR(CC,"AC")=""
I $P(LINE,U,3)]"" D ;
. S FOB=$G(^PRC(442,PO,1))
. S:FOB="" ERR(CC,"AC")="*"
. S:$P(FOB,U,6)="" ERR(CC,"AC")="*"
. I $P(FOB,U,6)'=$P(LINE,U,3) S $P(ERR(CC,"AC"),U,2)="*"
. Q
. ;
I $P(LINE,U,3)="" D ;
. S FOB=$G(^PRC(442,PO,1))
. S:$P(FOB,U,6)'="" $P(ERR(CC,"AC"),U,3)="*"
. Q
. ;
S KP=$P(LINE,U,5)
S KD=$P(LINE,U,6)
S (EE,G1,PC)=""
S AC=$G(^PRC(442,PO,5,0))
S:AC="" $P(ERR(CC,"AC"),U,4)="*"
S:$P(AC,U,4)'>0 $P(ERR(CC,"AC"),U,4)="*"
Q:$P(ERR(CC,"AC"),U,4)]""
F ACD=1:1:$P(AC,U,4) D ;
. S PPT(ACD)=$G(^PRC(442,PO,5,ACD,0))
. I +$P(PPT(ACD),U)=$P(PPT(ACD),U) S EE=$S(EE]"":EE_"^"_ACD,1:ACD)
. Q
. ;
I EE]"" D ;
. S G=$P(EE,U)
. S PC=$P(PPT(ACD),U)/100
. S G1=$P(PPT(ACD),U,2)
. Q
. ;
I KP]"",PC'>0 S $P(ERR(CC,"AC"),U,7)="*"
I EE]"",KP]"",KP'=PC S $P(ERR(CC,"AC"),U,5)="*"
I KD]"",G1="" S $P(ERR(CC,"AC"),U,8)="*"
I EE]"",KD]"",KD'=G1 S $P(ERR(CC,"AC"),U,6)="*"
I KP="",PC>0 S $P(ERR(CC,"AC"),U,9)="*"
I KD="",G1>0 S $P(ERR(CC,"AC"),U,10)="*"
;
QUIT ;Exit the SEG4 sub routine
;
SEG5 QUIT
;
SEG6 ;Process the "IT" segment from Austin
S B=$P(LINE,U,2) ;item line number
I B'>0 S $P(ERR(CC,.5),U,13)="*" Q
S ERR(CC,B)=""
S IT=$O(^PRC(442,PO,2,"B",B,0))
S:IT="" $P(ERR(CC,B),U,2)="*"
Q:IT=""
S IT=$G(^PRC(442,PO,2,IT,0))
S:IT="" $P(ERR(CC,B),U,2)="*"
Q:IT=""
S VP=$P(IT,U,6)
S:VP="" $P(ERR(CC,B),U,3)="*"
S:$E(VP,1)="#" VP=$E(VP,2,99)
S:VP'=$P(LINE,U,5) $P(ERR(CC,B),U,9)="*"
S QT=$P(IT,U,2)
S:QT="" $P(ERR(CC,B),U,5)="*"
S QT=QT\1+(QT#1>0)_"00"
S:QT'=$P(LINE,U,8) $P(ERR(CC,B),U,10)="*"
S PN=$P(LINE,U,6) ;Product number
I PN]"" D ;
. S RP=$P(IT,U,5)
. S:RP="" $P(ERR(CC,B),U,8)="*"
. I RP]"" D ;
. . S MPN=$G(^PRC(441,RP,3))
. . S:MPN="" $P(ERR(CC,B),U,8)="*"
. . I MPN]"" D ;
. . . S MPN=$P(MPN,U,5)
. . . S:$E(MPN,1)="#" MPN=$E(MPN,2,99)
. . . S:MPN'=PN $P(ERR(CC,B),U,8)="*"
. . . Q
. . Q
. Q
. ;
S DC=$P(LINE,U,7) ;Get the National drug code
I DC]"" D
. S N=$P(IT,U,15)
. S:N="" $P(ERR(CC,B),U,4)="*"
. I N]"" D
. . S N1=$P(N,"-")
. . S N2=$P(N,"-",2)
. . S N3=$P(N,"-",3)
. . S N1="000000"_N1
. . S N1L=$L(N1)
. . S N1=$E(N1,N1L-5,N1L)
. . S N2="0000"_N2
. . S N2L=$L(N2)
. . S N2=$E(N2,N2L-3,N2L)
. . S N3="00"_N3
. . S N3L=$L(N3)
. . S N3=$E(N3,N3L-1,N3L)
. . S N=N1_N2_N3
. . S:N'=DC $P(ERR(CC,B),U,4)="*"
. . Q
. Q
. ;
S UC=$P(LINE,U,10) ;Get the unit cost
S UC1=$E(UC,1,$L(UC)-4)
S UC2=$E(UC,$L(UC)-3,99)
S UC1=$E(UC1+1000000,2,7)
I UC2="0000" S UC=UC1_UC2 G S6B
S UC2="."_UC2
S UC2=$E($E(UC2+.005,2,3)_"0000",1,4)
S UC=UC1_UC2
S6B S CU=$P(IT,U,9)
S:CU="" $P(ERR(CC,B),U,7)="*"
G:CU="" S6A
I CU]"",CU="N/C" D G S6A
. S CU="0000000000"
. S:UC'=CU $P(ERR(CC,B),U,12)="*"
. Q
. ;
S CU1=$P(CU,".")
S CU2=$P(CU,".",2)
S CU1="000000"_CU1
S C1L=$L(CU1)
S CU1=$E(CU1,C1L-5,C1L)
S CU2=CU2_"0000"
S CU2=$E(CU2,1,4)
S CU=CU1_CU2
S:UC'=CU $P(ERR(CC,B),U,12)="*"
S6A S PU=$P(LINE,U,9) ;Get the unit of purchase
S UP=$P(IT,U,3)
S:UP="" $P(ERR(CC,B),U,6)="*"
I UP]"" D ;
. S UPN=$G(^PRCD(420.5,UP,0))
. S:UPN="" $P(ERR(CC,B),U,6)="*"
. I UPN]"" S UNIT=$P(UPN,U) S:UNIT'=PU $P(ERR(CC,B),U,11)="*"
. Q
. ;
S DA(1)=PO
S DIE="^PRC(442,DA(1),2,"
S DR="12///@;12.5///@;13///@;13.5///@"
S DA=B
D ^DIE
S PRC(1,443.75,"?+1,",.01)=$P($G(^PRC(443.75,RECORD,0)),U)
S PRC(1,443.75,"?+1,",23)=PRCTC
S PRC(1,443.75,"?+1,",24)=PRCX
I $G(ERR(CC,B))]"" D ;
. S PRC(1,443.75,"?+1,",19)="E"
. S PRC(1,443.75,"?+1,",20)=ERR(CC,B)
. Q
. ;
D UPDATE^DIE("","PRC(1)")
;
QUIT ;Exit the SEG6 sub routine
;
SEG7 QUIT
;
SEG8 K DIE,DA,DR
S B=$P(LINE,U,2)
I B'>0 S $P(ERR(CC,.5),U,13)="*" Q
S B=$O(^PRC(442,PO,2,"B",B,0))
I B'>0 S $P(ERR(CC,B),U,2)="*" Q
S DA(1)=PO
S DA=B
S DIE="^PRC(442,DA(1),2,"
I $P($G(ERR(CC,B)),U,2)="" D ;
. S V1=$P(LINE,U,3)
. S V2=$P(LINE,U,4)
. S:$P(^PRC(442,PO,2,B,2),U,9)="" DR="12///^S X=V1;12.5///^S X=V2"
. S:'$D(DR) DR="13///^S X=V1;13.5///^S X=V2"
. D ^DIE
. Q
. ;
QUIT ;Exit the SEG8 sub routine
;
SEG9 QUIT
;
SEG10 S ERR("SEG")=A,QTFLG=1
;
QUIT ;Exit the SEG10 sub routine
;
S1 D ^PRCOESE1
;
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOESE 6778 printed Apr 09, 2024@21:21:42 Page 2
PRCOESE ;WISC/DJM-IFCAP EDI POA Server Interface ; [8/31/98 1:55pm]
V ;;5.1;IFCAP;**202**;Oct 20, 2000;Build 27
+1 ;Per VA Directive 6402, this routine should not be modified.
SERV NEW A,AA,AC,ACD,B,CC,CU,CU1,CU2,C1L,DA,DC,DIE,DR,EE,ERR,FOB,G,G1,I,IT
+1 NEW KD,KP,L,LINE,LN,MPN,M1,N,N1,N1L,N2,N2L,N3,N3L,PC,PN,PO,PO1,PPM,PPT
+2 NEW PRC,PRCNO,PRCOI,PU,QT,QTFLG,RP,S1,UC,UC1,UC2,UNIT,UP,UPN,VP,V1,V2
+3 NEW X,X1,X2,PRCTC,PRCX,RECORD,STATION,STCK,VENDOR
+4 KILL ERR
+5 ;
+6 ;If QTFLG=1, processing stops because the error is serious
+7 ;
+8 SET (QTFLG,LN)=0
+9 FOR
SET LN=$ORDER(^PRCF(423.6,PRCDA,1,LN))
if 'LN
QUIT
if QTFLG>0
GOTO S1
DO MAIN
+10 ;
+11 DO KILL^PRCOSRV3(PRCDA)
+12 QUIT
+13 ;
MAIN ;Start processing the POA segments
+1 ;
+2 SET LINE=^(LN,0)
+3 ;End of this record. Stop and process any errors.
IF LINE["$"
DO S1
QUIT
+4 ;
+5 SET A=$PIECE(LINE,U)
+6 SET AA="SEG"_$SELECT(A="ISM":"1",A="HE":"2",A="VE":"3",A="AC":"4",A="ST":"5",A="IT":"6",A="DE":"7",A="AK":"8",A="CO":"9",1:"10")
+7 ;
+8 ;Process segment
DO @AA
+9 ;
+10 QUIT
+11 ;
SEG1 SET B=$PIECE(LINE,U,4)
+1 if B'="POA"
GOTO SEG10
+2 SET CC=$PIECE(LINE,U,7)
+3 FOR
if $ASCII(CC,$LENGTH(CC))'=32
QUIT
SET CC=$EXTRACT(CC,1,$LENGTH(CC)-1)
+4 SET CC=$EXTRACT(CC,1,3)_"-"_$EXTRACT(CC,4,$LENGTH(CC))
+5 SET ERR(CC,0)=""
+6 SET STATION=$PIECE(LINE,U,3)
+7 SET STCK=$ORDER(^PRC(411,"B",STATION,0))
+8 IF STCK'>0
SET ERR("STATION")=STATION
SET QTFLG=1
QUIT
+9 SET PO=$ORDER(^PRC(442,"B",CC,0))
+10 if PO=""
SET ERR(CC,0)="*"
SET QTFLG=1
+11 if QTFLG>0
QUIT
+12 SET PO1=$GET(^PRC(442,PO,1))
+13 if PO1=""
SET ERR(CC,0)="*"
SET QTFLG=1
+14 if QTFLG>0
QUIT
+15 SET PPM=$PIECE(PO1,U,10)
+16 DO BUL^PRCOESE1
+17 ;
+18 ; GATHER DATA FROM CONTROL SEGMENT.
+19 ;
+20 SET PRCTC=$PIECE(LINE,U,4)
+21 SET X1=$EXTRACT($PIECE(LINE,U,5),1,4)-1700_"0101"
+22 SET X2=$EXTRACT($PIECE(LINE,U,5),5,7)-1
+23 DO C^%DTC
+24 SET PRCX=X_"."_$PIECE(LINE,U,6)
+25 ;
+26 ;Exit the SEG1 sub routine
QUIT
+27 ;
SEG2 QUIT
+1 ;
SEG3 ; GET DATA FROM "VE" SEGMENT.
+1 SET VENDOR=$PIECE(LINE,U,2)
+2 ;
+3 ; NOW LETS FIND THE PROPER RECORD IN FILE 443.75.
+4 ;
+5 ;Austin did not provide the Vendor_Id. Use the PO to get it.
+6 IF VENDOR=""
Begin DoDot:1
+7 NEW PO,IEN
+8 ;PO number
SET PO=CC
+9 ;Get IEN
SET IEN=$ORDER(^PRC(442,"B",PO,""))
+10 ;Internal_Vendor_Number
SET VENDOR=$PIECE($GET(^PRC(442,IEN,1)),U)
+11 ;Vendor_Id
SET VENDOR=$PIECE($GET(^PRC(440,VENDOR,3)),U,3)
+12 ;Vendor_Id (yes)
IF VENDOR'=""
QUIT
+13 ;Vendor_Id (no)
SET $PIECE(ERR("VENDOR"),U)="*"
SET QTFLG=1
+14 ;
End DoDot:1
if QTFLG=1
QUIT
+15 SET RECORD=$ORDER(^PRC(443.75,"AO","PHA",CC,VENDOR,0))
+16 IF RECORD=""
SET $PIECE(ERR("RECORD"),U)="*"
SET QTFLG=1
+17 ;
+18 ;Exit the SEG3 sub routine
QUIT
+19 ;
SEG4 SET ERR(CC,"AC")=""
+1 ;
IF $PIECE(LINE,U,3)]""
Begin DoDot:1
+2 SET FOB=$GET(^PRC(442,PO,1))
+3 if FOB=""
SET ERR(CC,"AC")="*"
+4 if $PIECE(FOB,U,6)=""
SET ERR(CC,"AC")="*"
+5 IF $PIECE(FOB,U,6)'=$PIECE(LINE,U,3)
SET $PIECE(ERR(CC,"AC"),U,2)="*"
+6 QUIT
+7 ;
End DoDot:1
+8 ;
IF $PIECE(LINE,U,3)=""
Begin DoDot:1
+9 SET FOB=$GET(^PRC(442,PO,1))
+10 if $PIECE(FOB,U,6)'=""
SET $PIECE(ERR(CC,"AC"),U,3)="*"
+11 QUIT
+12 ;
End DoDot:1
+13 SET KP=$PIECE(LINE,U,5)
+14 SET KD=$PIECE(LINE,U,6)
+15 SET (EE,G1,PC)=""
+16 SET AC=$GET(^PRC(442,PO,5,0))
+17 if AC=""
SET $PIECE(ERR(CC,"AC"),U,4)="*"
+18 if $PIECE(AC,U,4)'>0
SET $PIECE(ERR(CC,"AC"),U,4)="*"
+19 if $PIECE(ERR(CC,"AC"),U,4)]""
QUIT
+20 ;
FOR ACD=1:1:$PIECE(AC,U,4)
Begin DoDot:1
+21 SET PPT(ACD)=$GET(^PRC(442,PO,5,ACD,0))
+22 IF +$PIECE(PPT(ACD),U)=$PIECE(PPT(ACD),U)
SET EE=$SELECT(EE]"":EE_"^"_ACD,1:ACD)
+23 QUIT
+24 ;
End DoDot:1
+25 ;
IF EE]""
Begin DoDot:1
+26 SET G=$PIECE(EE,U)
+27 SET PC=$PIECE(PPT(ACD),U)/100
+28 SET G1=$PIECE(PPT(ACD),U,2)
+29 QUIT
+30 ;
End DoDot:1
+31 IF KP]""
IF PC'>0
SET $PIECE(ERR(CC,"AC"),U,7)="*"
+32 IF EE]""
IF KP]""
IF KP'=PC
SET $PIECE(ERR(CC,"AC"),U,5)="*"
+33 IF KD]""
IF G1=""
SET $PIECE(ERR(CC,"AC"),U,8)="*"
+34 IF EE]""
IF KD]""
IF KD'=G1
SET $PIECE(ERR(CC,"AC"),U,6)="*"
+35 IF KP=""
IF PC>0
SET $PIECE(ERR(CC,"AC"),U,9)="*"
+36 IF KD=""
IF G1>0
SET $PIECE(ERR(CC,"AC"),U,10)="*"
+37 ;
+38 ;Exit the SEG4 sub routine
QUIT
+39 ;
SEG5 QUIT
+1 ;
SEG6 ;Process the "IT" segment from Austin
+1 ;item line number
SET B=$PIECE(LINE,U,2)
+2 IF B'>0
SET $PIECE(ERR(CC,.5),U,13)="*"
QUIT
+3 SET ERR(CC,B)=""
+4 SET IT=$ORDER(^PRC(442,PO,2,"B",B,0))
+5 if IT=""
SET $PIECE(ERR(CC,B),U,2)="*"
+6 if IT=""
QUIT
+7 SET IT=$GET(^PRC(442,PO,2,IT,0))
+8 if IT=""
SET $PIECE(ERR(CC,B),U,2)="*"
+9 if IT=""
QUIT
+10 SET VP=$PIECE(IT,U,6)
+11 if VP=""
SET $PIECE(ERR(CC,B),U,3)="*"
+12 if $EXTRACT(VP,1)="#"
SET VP=$EXTRACT(VP,2,99)
+13 if VP'=$PIECE(LINE,U,5)
SET $PIECE(ERR(CC,B),U,9)="*"
+14 SET QT=$PIECE(IT,U,2)
+15 if QT=""
SET $PIECE(ERR(CC,B),U,5)="*"
+16 SET QT=QT\1+(QT#1>0)_"00"
+17 if QT'=$PIECE(LINE,U,8)
SET $PIECE(ERR(CC,B),U,10)="*"
+18 ;Product number
SET PN=$PIECE(LINE,U,6)
+19 ;
IF PN]""
Begin DoDot:1
+20 SET RP=$PIECE(IT,U,5)
+21 if RP=""
SET $PIECE(ERR(CC,B),U,8)="*"
+22 ;
IF RP]""
Begin DoDot:2
+23 SET MPN=$GET(^PRC(441,RP,3))
+24 if MPN=""
SET $PIECE(ERR(CC,B),U,8)="*"
+25 ;
IF MPN]""
Begin DoDot:3
+26 SET MPN=$PIECE(MPN,U,5)
+27 if $EXTRACT(MPN,1)="#"
SET MPN=$EXTRACT(MPN,2,99)
+28 if MPN'=PN
SET $PIECE(ERR(CC,B),U,8)="*"
+29 QUIT
End DoDot:3
+30 QUIT
End DoDot:2
+31 QUIT
+32 ;
End DoDot:1
+33 ;Get the National drug code
SET DC=$PIECE(LINE,U,7)
+34 IF DC]""
Begin DoDot:1
+35 SET N=$PIECE(IT,U,15)
+36 if N=""
SET $PIECE(ERR(CC,B),U,4)="*"
+37 IF N]""
Begin DoDot:2
+38 SET N1=$PIECE(N,"-")
+39 SET N2=$PIECE(N,"-",2)
+40 SET N3=$PIECE(N,"-",3)
+41 SET N1="000000"_N1
+42 SET N1L=$LENGTH(N1)
+43 SET N1=$EXTRACT(N1,N1L-5,N1L)
+44 SET N2="0000"_N2
+45 SET N2L=$LENGTH(N2)
+46 SET N2=$EXTRACT(N2,N2L-3,N2L)
+47 SET N3="00"_N3
+48 SET N3L=$LENGTH(N3)
+49 SET N3=$EXTRACT(N3,N3L-1,N3L)
+50 SET N=N1_N2_N3
+51 if N'=DC
SET $PIECE(ERR(CC,B),U,4)="*"
+52 QUIT
End DoDot:2
+53 QUIT
+54 ;
End DoDot:1
+55 ;Get the unit cost
SET UC=$PIECE(LINE,U,10)
+56 SET UC1=$EXTRACT(UC,1,$LENGTH(UC)-4)
+57 SET UC2=$EXTRACT(UC,$LENGTH(UC)-3,99)
+58 SET UC1=$EXTRACT(UC1+1000000,2,7)
+59 IF UC2="0000"
SET UC=UC1_UC2
GOTO S6B
+60 SET UC2="."_UC2
+61 SET UC2=$EXTRACT($EXTRACT(UC2+.005,2,3)_"0000",1,4)
+62 SET UC=UC1_UC2
S6B SET CU=$PIECE(IT,U,9)
+1 if CU=""
SET $PIECE(ERR(CC,B),U,7)="*"
+2 if CU=""
GOTO S6A
+3 IF CU]""
IF CU="N/C"
Begin DoDot:1
+4 SET CU="0000000000"
+5 if UC'=CU
SET $PIECE(ERR(CC,B),U,12)="*"
+6 QUIT
+7 ;
End DoDot:1
GOTO S6A
+8 SET CU1=$PIECE(CU,".")
+9 SET CU2=$PIECE(CU,".",2)
+10 SET CU1="000000"_CU1
+11 SET C1L=$LENGTH(CU1)
+12 SET CU1=$EXTRACT(CU1,C1L-5,C1L)
+13 SET CU2=CU2_"0000"
+14 SET CU2=$EXTRACT(CU2,1,4)
+15 SET CU=CU1_CU2
+16 if UC'=CU
SET $PIECE(ERR(CC,B),U,12)="*"
S6A ;Get the unit of purchase
SET PU=$PIECE(LINE,U,9)
+1 SET UP=$PIECE(IT,U,3)
+2 if UP=""
SET $PIECE(ERR(CC,B),U,6)="*"
+3 ;
IF UP]""
Begin DoDot:1
+4 SET UPN=$GET(^PRCD(420.5,UP,0))
+5 if UPN=""
SET $PIECE(ERR(CC,B),U,6)="*"
+6 IF UPN]""
SET UNIT=$PIECE(UPN,U)
if UNIT'=PU
SET $PIECE(ERR(CC,B),U,11)="*"
+7 QUIT
+8 ;
End DoDot:1
+9 SET DA(1)=PO
+10 SET DIE="^PRC(442,DA(1),2,"
+11 SET DR="12///@;12.5///@;13///@;13.5///@"
+12 SET DA=B
+13 DO ^DIE
+14 SET PRC(1,443.75,"?+1,",.01)=$PIECE($GET(^PRC(443.75,RECORD,0)),U)
+15 SET PRC(1,443.75,"?+1,",23)=PRCTC
+16 SET PRC(1,443.75,"?+1,",24)=PRCX
+17 ;
IF $GET(ERR(CC,B))]""
Begin DoDot:1
+18 SET PRC(1,443.75,"?+1,",19)="E"
+19 SET PRC(1,443.75,"?+1,",20)=ERR(CC,B)
+20 QUIT
+21 ;
End DoDot:1
+22 DO UPDATE^DIE("","PRC(1)")
+23 ;
+24 ;Exit the SEG6 sub routine
QUIT
+25 ;
SEG7 QUIT
+1 ;
SEG8 KILL DIE,DA,DR
+1 SET B=$PIECE(LINE,U,2)
+2 IF B'>0
SET $PIECE(ERR(CC,.5),U,13)="*"
QUIT
+3 SET B=$ORDER(^PRC(442,PO,2,"B",B,0))
+4 IF B'>0
SET $PIECE(ERR(CC,B),U,2)="*"
QUIT
+5 SET DA(1)=PO
+6 SET DA=B
+7 SET DIE="^PRC(442,DA(1),2,"
+8 ;
IF $PIECE($GET(ERR(CC,B)),U,2)=""
Begin DoDot:1
+9 SET V1=$PIECE(LINE,U,3)
+10 SET V2=$PIECE(LINE,U,4)
+11 if $PIECE(^PRC(442,PO,2,B,2),U,9)=""
SET DR="12///^S X=V1;12.5///^S X=V2"
+12 if '$DATA(DR)
SET DR="13///^S X=V1;13.5///^S X=V2"
+13 DO ^DIE
+14 QUIT
+15 ;
End DoDot:1
+16 ;Exit the SEG8 sub routine
QUIT
+17 ;
SEG9 QUIT
+1 ;
SEG10 SET ERR("SEG")=A
SET QTFLG=1
+1 ;
+2 ;Exit the SEG10 sub routine
QUIT
+3 ;
S1 DO ^PRCOESE1
+1 ;
+2 QUIT
