Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCOESE

PRCOESE.m

Go to the documentation of this file.
  1. PRCOESE ;WISC/DJM-IFCAP EDI POA Server Interface ; [8/31/98 1:55pm]
  1. V ;;5.1;IFCAP;**202**;Oct 20, 2000;Build 27
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. SERV N A,AA,AC,ACD,B,CC,CU,CU1,CU2,C1L,DA,DC,DIE,DR,EE,ERR,FOB,G,G1,I,IT
  1. N KD,KP,L,LINE,LN,MPN,M1,N,N1,N1L,N2,N2L,N3,N3L,PC,PN,PO,PO1,PPM,PPT
  1. N PRC,PRCNO,PRCOI,PU,QT,QTFLG,RP,S1,UC,UC1,UC2,UNIT,UP,UPN,VP,V1,V2
  1. N X,X1,X2,PRCTC,PRCX,RECORD,STATION,STCK,VENDOR
  1. K ERR
  1. ;
  1. ;If QTFLG=1, processing stops because the error is serious
  1. ;
  1. S (QTFLG,LN)=0
  1. F S LN=$O(^PRCF(423.6,PRCDA,1,LN)) QUIT:'LN G:QTFLG>0 S1 D MAIN
  1. ;
  1. D KILL^PRCOSRV3(PRCDA)
  1. QUIT
  1. ;
  1. MAIN ;Start processing the POA segments
  1. ;
  1. S LINE=^(LN,0)
  1. I LINE["$" D S1 QUIT ;End of this record. Stop and process any errors.
  1. ;
  1. S A=$P(LINE,U)
  1. 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")
  1. ;
  1. D @AA ;Process segment
  1. ;
  1. QUIT
  1. ;
  1. SEG1 S B=$P(LINE,U,4)
  1. G:B'="POA" SEG10
  1. S CC=$P(LINE,U,7)
  1. F Q:$A(CC,$L(CC))'=32 S CC=$E(CC,1,$L(CC)-1)
  1. S CC=$E(CC,1,3)_"-"_$E(CC,4,$L(CC))
  1. S ERR(CC,0)=""
  1. S STATION=$P(LINE,U,3)
  1. S STCK=$O(^PRC(411,"B",STATION,0))
  1. I STCK'>0 S ERR("STATION")=STATION,QTFLG=1 Q
  1. S PO=$O(^PRC(442,"B",CC,0))
  1. S:PO="" ERR(CC,0)="*",QTFLG=1
  1. Q:QTFLG>0
  1. S PO1=$G(^PRC(442,PO,1))
  1. S:PO1="" ERR(CC,0)="*",QTFLG=1
  1. Q:QTFLG>0
  1. S PPM=$P(PO1,U,10)
  1. D BUL^PRCOESE1
  1. ;
  1. ; GATHER DATA FROM CONTROL SEGMENT.
  1. ;
  1. S PRCTC=$P(LINE,U,4)
  1. S X1=$E($P(LINE,U,5),1,4)-1700_"0101"
  1. S X2=$E($P(LINE,U,5),5,7)-1
  1. D C^%DTC
  1. S PRCX=X_"."_$P(LINE,U,6)
  1. ;
  1. QUIT ;Exit the SEG1 sub routine
  1. ;
  1. SEG2 QUIT
  1. ;
  1. SEG3 ; GET DATA FROM "VE" SEGMENT.
  1. S VENDOR=$P(LINE,U,2)
  1. ;
  1. ; NOW LETS FIND THE PROPER RECORD IN FILE 443.75.
  1. ;
  1. ;Austin did not provide the Vendor_Id. Use the PO to get it.
  1. I VENDOR="" D QUIT:QTFLG=1
  1. . N PO,IEN
  1. . S PO=CC ;PO number
  1. . S IEN=$O(^PRC(442,"B",PO,"")) ;Get IEN
  1. . S VENDOR=$P($G(^PRC(442,IEN,1)),U) ;Internal_Vendor_Number
  1. . S VENDOR=$P($G(^PRC(440,VENDOR,3)),U,3) ;Vendor_Id
  1. . I VENDOR'="" QUIT ;Vendor_Id (yes)
  1. . S $P(ERR("VENDOR"),U)="*",QTFLG=1 ;Vendor_Id (no)
  1. . ;
  1. S RECORD=$O(^PRC(443.75,"AO","PHA",CC,VENDOR,0))
  1. I RECORD="" S $P(ERR("RECORD"),U)="*",QTFLG=1
  1. ;
  1. QUIT ;Exit the SEG3 sub routine
  1. ;
  1. SEG4 S ERR(CC,"AC")=""
  1. I $P(LINE,U,3)]"" D ;
  1. . S FOB=$G(^PRC(442,PO,1))
  1. . S:FOB="" ERR(CC,"AC")="*"
  1. . S:$P(FOB,U,6)="" ERR(CC,"AC")="*"
  1. . I $P(FOB,U,6)'=$P(LINE,U,3) S $P(ERR(CC,"AC"),U,2)="*"
  1. . Q
  1. . ;
  1. I $P(LINE,U,3)="" D ;
  1. . S FOB=$G(^PRC(442,PO,1))
  1. . S:$P(FOB,U,6)'="" $P(ERR(CC,"AC"),U,3)="*"
  1. . Q
  1. . ;
  1. S KP=$P(LINE,U,5)
  1. S KD=$P(LINE,U,6)
  1. S (EE,G1,PC)=""
  1. S AC=$G(^PRC(442,PO,5,0))
  1. S:AC="" $P(ERR(CC,"AC"),U,4)="*"
  1. S:$P(AC,U,4)'>0 $P(ERR(CC,"AC"),U,4)="*"
  1. Q:$P(ERR(CC,"AC"),U,4)]""
  1. F ACD=1:1:$P(AC,U,4) D ;
  1. . S PPT(ACD)=$G(^PRC(442,PO,5,ACD,0))
  1. . I +$P(PPT(ACD),U)=$P(PPT(ACD),U) S EE=$S(EE]"":EE_"^"_ACD,1:ACD)
  1. . Q
  1. . ;
  1. I EE]"" D ;
  1. . S G=$P(EE,U)
  1. . S PC=$P(PPT(ACD),U)/100
  1. . S G1=$P(PPT(ACD),U,2)
  1. . Q
  1. . ;
  1. I KP]"",PC'>0 S $P(ERR(CC,"AC"),U,7)="*"
  1. I EE]"",KP]"",KP'=PC S $P(ERR(CC,"AC"),U,5)="*"
  1. I KD]"",G1="" S $P(ERR(CC,"AC"),U,8)="*"
  1. I EE]"",KD]"",KD'=G1 S $P(ERR(CC,"AC"),U,6)="*"
  1. I KP="",PC>0 S $P(ERR(CC,"AC"),U,9)="*"
  1. I KD="",G1>0 S $P(ERR(CC,"AC"),U,10)="*"
  1. ;
  1. QUIT ;Exit the SEG4 sub routine
  1. ;
  1. SEG5 QUIT
  1. ;
  1. SEG6 ;Process the "IT" segment from Austin
  1. S B=$P(LINE,U,2) ;item line number
  1. I B'>0 S $P(ERR(CC,.5),U,13)="*" Q
  1. S ERR(CC,B)=""
  1. S IT=$O(^PRC(442,PO,2,"B",B,0))
  1. S:IT="" $P(ERR(CC,B),U,2)="*"
  1. Q:IT=""
  1. S IT=$G(^PRC(442,PO,2,IT,0))
  1. S:IT="" $P(ERR(CC,B),U,2)="*"
  1. Q:IT=""
  1. S VP=$P(IT,U,6)
  1. S:VP="" $P(ERR(CC,B),U,3)="*"
  1. S:$E(VP,1)="#" VP=$E(VP,2,99)
  1. S:VP'=$P(LINE,U,5) $P(ERR(CC,B),U,9)="*"
  1. S QT=$P(IT,U,2)
  1. S:QT="" $P(ERR(CC,B),U,5)="*"
  1. S QT=QT\1+(QT#1>0)_"00"
  1. S:QT'=$P(LINE,U,8) $P(ERR(CC,B),U,10)="*"
  1. S PN=$P(LINE,U,6) ;Product number
  1. I PN]"" D ;
  1. . S RP=$P(IT,U,5)
  1. . S:RP="" $P(ERR(CC,B),U,8)="*"
  1. . I RP]"" D ;
  1. . . S MPN=$G(^PRC(441,RP,3))
  1. . . S:MPN="" $P(ERR(CC,B),U,8)="*"
  1. . . I MPN]"" D ;
  1. . . . S MPN=$P(MPN,U,5)
  1. . . . S:$E(MPN,1)="#" MPN=$E(MPN,2,99)
  1. . . . S:MPN'=PN $P(ERR(CC,B),U,8)="*"
  1. . . . Q
  1. . . Q
  1. . Q
  1. . ;
  1. S DC=$P(LINE,U,7) ;Get the National drug code
  1. I DC]"" D
  1. . S N=$P(IT,U,15)
  1. . S:N="" $P(ERR(CC,B),U,4)="*"
  1. . I N]"" D
  1. . . S N1=$P(N,"-")
  1. . . S N2=$P(N,"-",2)
  1. . . S N3=$P(N,"-",3)
  1. . . S N1="000000"_N1
  1. . . S N1L=$L(N1)
  1. . . S N1=$E(N1,N1L-5,N1L)
  1. . . S N2="0000"_N2
  1. . . S N2L=$L(N2)
  1. . . S N2=$E(N2,N2L-3,N2L)
  1. . . S N3="00"_N3
  1. . . S N3L=$L(N3)
  1. . . S N3=$E(N3,N3L-1,N3L)
  1. . . S N=N1_N2_N3
  1. . . S:N'=DC $P(ERR(CC,B),U,4)="*"
  1. . . Q
  1. . Q
  1. . ;
  1. S UC=$P(LINE,U,10) ;Get the unit cost
  1. S UC1=$E(UC,1,$L(UC)-4)
  1. S UC2=$E(UC,$L(UC)-3,99)
  1. S UC1=$E(UC1+1000000,2,7)
  1. I UC2="0000" S UC=UC1_UC2 G S6B
  1. S UC2="."_UC2
  1. S UC2=$E($E(UC2+.005,2,3)_"0000",1,4)
  1. S UC=UC1_UC2
  1. S6B S CU=$P(IT,U,9)
  1. S:CU="" $P(ERR(CC,B),U,7)="*"
  1. G:CU="" S6A
  1. I CU]"",CU="N/C" D G S6A
  1. . S CU="0000000000"
  1. . S:UC'=CU $P(ERR(CC,B),U,12)="*"
  1. . Q
  1. . ;
  1. S CU1=$P(CU,".")
  1. S CU2=$P(CU,".",2)
  1. S CU1="000000"_CU1
  1. S C1L=$L(CU1)
  1. S CU1=$E(CU1,C1L-5,C1L)
  1. S CU2=CU2_"0000"
  1. S CU2=$E(CU2,1,4)
  1. S CU=CU1_CU2
  1. S:UC'=CU $P(ERR(CC,B),U,12)="*"
  1. S6A S PU=$P(LINE,U,9) ;Get the unit of purchase
  1. S UP=$P(IT,U,3)
  1. S:UP="" $P(ERR(CC,B),U,6)="*"
  1. I UP]"" D ;
  1. . S UPN=$G(^PRCD(420.5,UP,0))
  1. . S:UPN="" $P(ERR(CC,B),U,6)="*"
  1. . I UPN]"" S UNIT=$P(UPN,U) S:UNIT'=PU $P(ERR(CC,B),U,11)="*"
  1. . Q
  1. . ;
  1. S DA(1)=PO
  1. S DIE="^PRC(442,DA(1),2,"
  1. S DR="12///@;12.5///@;13///@;13.5///@"
  1. S DA=B
  1. D ^DIE
  1. S PRC(1,443.75,"?+1,",.01)=$P($G(^PRC(443.75,RECORD,0)),U)
  1. S PRC(1,443.75,"?+1,",23)=PRCTC
  1. S PRC(1,443.75,"?+1,",24)=PRCX
  1. I $G(ERR(CC,B))]"" D ;
  1. . S PRC(1,443.75,"?+1,",19)="E"
  1. . S PRC(1,443.75,"?+1,",20)=ERR(CC,B)
  1. . Q
  1. . ;
  1. D UPDATE^DIE("","PRC(1)")
  1. ;
  1. QUIT ;Exit the SEG6 sub routine
  1. ;
  1. SEG7 QUIT
  1. ;
  1. SEG8 K DIE,DA,DR
  1. S B=$P(LINE,U,2)
  1. I B'>0 S $P(ERR(CC,.5),U,13)="*" Q
  1. S B=$O(^PRC(442,PO,2,"B",B,0))
  1. I B'>0 S $P(ERR(CC,B),U,2)="*" Q
  1. S DA(1)=PO
  1. S DA=B
  1. S DIE="^PRC(442,DA(1),2,"
  1. I $P($G(ERR(CC,B)),U,2)="" D ;
  1. . S V1=$P(LINE,U,3)
  1. . S V2=$P(LINE,U,4)
  1. . S:$P(^PRC(442,PO,2,B,2),U,9)="" DR="12///^S X=V1;12.5///^S X=V2"
  1. . S:'$D(DR) DR="13///^S X=V1;13.5///^S X=V2"
  1. . D ^DIE
  1. . Q
  1. . ;
  1. QUIT ;Exit the SEG8 sub routine
  1. ;
  1. SEG9 QUIT
  1. ;
  1. SEG10 S ERR("SEG")=A,QTFLG=1
  1. ;
  1. QUIT ;Exit the SEG10 sub routine
  1. ;
  1. S1 D ^PRCOESE1
  1. ;
  1. QUIT