PRCOESE ;WISC/DJM-IFCAP EDI POA Server Interface ; [8/31/98 1:55pm]
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, 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
 ;
 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