source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOINV.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1PRCOINV ;WISC/DJM/LEM-INV Server Interface to IFCAP ;12/15/93 1:59 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4SERV N A,AC,ACD,B,CC,CU,CU1,CU2,C1L,DA,DC,DIE,DR,EE,ERR,FOB,G,G1,I,IT,KD,KP,L,LINE,LN,MPM,M1,N,N1,N1L,N2,N2L,N3,N3L,PC,PN,CI,CI1,PPM,PPT,PRCOI,PU,QT,QTFLG,RP,S1,UC,UC1,UC2,UNIT,UP,UPN,VP,V1,V2
5 K ERR S (QTFLG,LN)=0 F S LN=$O(^PRCF(423.6,PRCDA,1,LN)) G:LN="" S1 S LINE=^(LN,0) D G:QTFLG>0 S1
6 .S A=$P(LINE,U),A="SEG"_$S(A="INV":"1",A="HE":"2",A="VE":"3",A="AC":"4",A="SF":"5",A="IT":"6",A="DE":"7",A="AK":"8",A="CO":"9",1:"10") G @A
7SEG1 .S B=$P(LINE,U,4) G:B'="INV" SEG10 S CC=$P(LINE,U,7) F Q:$A(CC,$L(CC))'=32 S CC=$E(CC,1,$L(CC)-1)
8 .S CC=$E(CC,1,3)_"-"_$E(CC,4,$L(CC)),ERR(CC,0)="",CI=$O(^PRCF(421.5,"B",CC,0)) S:CI="" ERR(CC,0)="*",QTFLG=1 Q:QTFLG>0
9 .S CI1=$G(^PRCF(421.5,CI,1)) S:CI1="" ERR(CC,0)="*",QTFLG=1 Q:QTFLG>0
10 .S PPM=$P(CI1,U,10) D BUL^PRCOINV1 Q
11SEG2 .Q
12SEG3 .Q
13SEG4 .S ERR(CC,"AC")="" I $P(LINE,U,3)]"" S FOB=$G(^PRCF(421.5,CI,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)="*"
14 .I $P(LINE,U,3)="" S FOB=$G(^PRCF(421.5,CI,1)) S:$P(FOB,U,6)'="" $P(ERR(CC,"AC"),U,3)="*"
15 .S KP=$P(LINE,U,5),KD=$P(LINE,U,6),(EE,G1,PC)="" D Q
16 ..S AC=$G(^PRCF(421.5,CI,5,0)) S:AC="" $P(ERR(CC,"AC"),U,4)="*" S:$P(AC,U,4)'>0 $P(ERR(CC,"AC"),U,4)="*" I $P(ERR(CC,"AC"),U,4)]"" Q
17 ..F ACD=1:1:$P(AC,U,4) S PPT(ACD)=$G(^PRCF(421.5,CI,5,ACD,0)) I +$P(PPT(ACD),U)=$P(PPT(ACD),U) S EE=$S(EE]"":EE_"^"_ACD,1:ACD)
18 ..I EE]"" S G=$P(EE,U),PC=$P(PPT(ACD),U)/100,G1=$P(PPT(ACD),U,2)
19 ..I KP]"",PC'>0 S $P(ERR(CC,"AC"),U,7)="*"
20 ..I EE]"",KP]"",KP'=PC S $P(ERR(CC,"AC"),U,5)="*"
21 ..I KD]"",G1="" S $P(ERR(CC,"AC"),U,8)="*"
22 ..I EE]"",KD]"",KD'=G1 S $P(ERR(CC,"AC"),U,6)="*"
23 ..I KP="",PC>0 S $P(ERR(CC,"AC"),U,9)="*"
24 ..I KD="",G1>0 S $P(ERR(CC,"AC"),U,10)="*"
25 ..Q
26SEG5 .Q
27SEG6 .S B=$P(LINE,U,2),ERR(CC,B)="",IT=$O(^PRCF(421.5,CI,2,"B",B,0)) S:IT="" $P(ERR(CC,B),U,2)="*" Q:IT="" S IT=$G(^PRCF(421.5,CI,2,IT,0)) S:IT="" $P(ERR(CC,B),U,2)="*" Q:IT=""
28 .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)="*"
29 .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)="*"
30 .S PN=$P(LINE,U,6) I PN]"" S RP=$P(IT,U,5) S:RP="" $P(ERR(CC,B),U,8)="*" I RP]"" S MPN=$G(^PRC(441,RP,3)) S:MPN="" $P(ERR(CC,B),U,8)="*" I MPN]"" S MPN=$P(MPN,U,5) S:$E(MPN,1)="#" MPN=$E(MPN,2,99) S:MPN'=PN $P(ERR(CC,B),U,8)="*"
31 .S DC=$P(LINE,U,7) I DC]"" S N=$P(IT,U,15) S:N="" $P(ERR(CC,B),U,4)="*" I N]"" S N1=$P(N,"-"),N2=$P(N,"-",2),N3=$P(N,"-",3),N1="000000"_N1,N1L=$L(N1),N1=$E(N1,N1L-5,N1L) D S:N'=DC $P(ERR(CC,B),U,4)="*"
32 ..S N2="0000"_N2,N2L=$L(N2),N2=$E(N2,N2L-3,N2L),N3="00"_N3,N3L=$L(N3),N3=$E(N3,N3L-1,N3L),N=N1_N2_N3
33 .S UC=$P(LINE,U,10),UC1=$E(UC,1,$L(UC)-4),UC2=$E(UC,$L(UC)-3,99),UC1=$E(UC1+1000000,2,7) I UC2="0000" S UC=UC1_UC2 G S6B
34 .S UC2="."_UC2,UC2=$E($E(UC2+.005,2,3)_"0000",1,4),UC=UC1_UC2
35S6B .S CU=$P(IT,U,9) S:CU="" $P(ERR(CC,B),U,7)="*" G:CU="" S6A I CU]"",CU="N/C" S CU="0000000000" S:UC'=CU $P(ERR(CC,B),U,12)="*" G S6A
36 .S CU1=$P(CU,"."),CU2=$P(CU,".",2),CU1="000000"_CU1,C1L=$L(CU1),CU1=$E(CU1,C1L-5,C1L),CU2=CU2_"0000",CU2=$E(CU2,1,4),CU=CU1_CU2 S:UC'=CU $P(ERR(CC,B),U,12)="*"
37S6A .S PU=$P(LINE,U,9),UP=$P(IT,U,3) S:UP="" $P(ERR(CC,B),U,6)="*" I UP]"" 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)="*"
38 .S DA(1)=CI,DIE="^PRCF(421.5,DA(1),2,",DR="12///@;12.5///@;13///@;13.5///@",DA=B D ^DIE Q
39SEG7 .Q
40SEG8 .K DIE,DA,DR S B=$P(LINE,U,2),DA(1)=CI,DA=B,DIE="^PRCF(421.5,DA(1),2,"
41 .I $P(ERR(CC,B),U,2)="" S V1=$P(LINE,U,3),V2=$P(LINE,U,4) S:$P(^PRCF(421.5,CI,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
42 .Q
43SEG9 .Q
44SEG10 .Q
45S1 D ^PRCOINV1
46S2 Q
Note: See TracBrowser for help on using the repository browser.