- 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 Feb 18, 2025@23:38:21 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