- PRCOINV ;WISC/DJM/LEM-INV Server Interface to IFCAP ;12/15/93 1:59 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- SERV 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
- 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
- .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
- SEG1 .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)
- .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
- .S CI1=$G(^PRCF(421.5,CI,1)) S:CI1="" ERR(CC,0)="*",QTFLG=1 Q:QTFLG>0
- .S PPM=$P(CI1,U,10) D BUL^PRCOINV1 Q
- SEG2 .Q
- SEG3 .Q
- SEG4 .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)="*"
- .I $P(LINE,U,3)="" S FOB=$G(^PRCF(421.5,CI,1)) S:$P(FOB,U,6)'="" $P(ERR(CC,"AC"),U,3)="*"
- .S KP=$P(LINE,U,5),KD=$P(LINE,U,6),(EE,G1,PC)="" D Q
- ..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
- ..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)
- ..I EE]"" S G=$P(EE,U),PC=$P(PPT(ACD),U)/100,G1=$P(PPT(ACD),U,2)
- ..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)="*"
- ..Q
- SEG5 .Q
- SEG6 .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=""
- .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) 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)="*"
- .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)="*"
- ..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
- .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
- .S UC2="."_UC2,UC2=$E($E(UC2+.005,2,3)_"0000",1,4),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" S CU="0000000000" S:UC'=CU $P(ERR(CC,B),U,12)="*" G S6A
- .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)="*"
- S6A .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)="*"
- .S DA(1)=CI,DIE="^PRCF(421.5,DA(1),2,",DR="12///@;12.5///@;13///@;13.5///@",DA=B D ^DIE Q
- SEG7 .Q
- SEG8 .K DIE,DA,DR S B=$P(LINE,U,2),DA(1)=CI,DA=B,DIE="^PRCF(421.5,DA(1),2,"
- .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
- .Q
- SEG9 .Q
- SEG10 .Q
- S1 D ^PRCOINV1
- S2 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOINV 3962 printed Feb 18, 2025@23:38:23 Page 2
- PRCOINV ;WISC/DJM/LEM-INV Server Interface to IFCAP ;12/15/93 1:59 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- SERV NEW 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
- +1 KILL ERR
- SET (QTFLG,LN)=0
- FOR
- SET LN=$ORDER(^PRCF(423.6,PRCDA,1,LN))
- if LN=""
- GOTO S1
- SET LINE=^(LN,0)
- Begin DoDot:1
- +2 SET A=$PIECE(LINE,U)
- SET A="SEG"_$SELECT(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")
- GOTO @A
- SEG1 SET B=$PIECE(LINE,U,4)
- if B'="INV"
- GOTO SEG10
- SET CC=$PIECE(LINE,U,7)
- FOR
- if $ASCII(CC,$LENGTH(CC))'=32
- QUIT
- SET CC=$EXTRACT(CC,1,$LENGTH(CC)-1)
- +1 SET CC=$EXTRACT(CC,1,3)_"-"_$EXTRACT(CC,4,$LENGTH(CC))
- SET ERR(CC,0)=""
- SET CI=$ORDER(^PRCF(421.5,"B",CC,0))
- if CI=""
- SET ERR(CC,0)="*"
- SET QTFLG=1
- if QTFLG>0
- QUIT
- +2 SET CI1=$GET(^PRCF(421.5,CI,1))
- if CI1=""
- SET ERR(CC,0)="*"
- SET QTFLG=1
- if QTFLG>0
- QUIT
- +3 SET PPM=$PIECE(CI1,U,10)
- DO BUL^PRCOINV1
- QUIT
- SEG2 QUIT
- SEG3 QUIT
- SEG4 SET ERR(CC,"AC")=""
- IF $PIECE(LINE,U,3)]""
- SET FOB=$GET(^PRCF(421.5,CI,1))
- if FOB=""
- SET ERR(CC,"AC")="*"
- if $PIECE(FOB,U,6)=""
- SET ERR(CC,"AC")="*"
- IF $PIECE(FOB,U,6)'=$PIECE(LINE,U,3)
- SET $PIECE(ERR(CC,"AC"),U,2)="*"
- +1 IF $PIECE(LINE,U,3)=""
- SET FOB=$GET(^PRCF(421.5,CI,1))
- if $PIECE(FOB,U,6)'=""
- SET $PIECE(ERR(CC,"AC"),U,3)="*"
- +2 SET KP=$PIECE(LINE,U,5)
- SET KD=$PIECE(LINE,U,6)
- SET (EE,G1,PC)=""
- Begin DoDot:2
- +3 SET AC=$GET(^PRCF(421.5,CI,5,0))
- if AC=""
- SET $PIECE(ERR(CC,"AC"),U,4)="*"
- if $PIECE(AC,U,4)'>0
- SET $PIECE(ERR(CC,"AC"),U,4)="*"
- IF $PIECE(ERR(CC,"AC"),U,4)]""
- QUIT
- +4 FOR ACD=1:1:$PIECE(AC,U,4)
- SET PPT(ACD)=$GET(^PRCF(421.5,CI,5,ACD,0))
- IF +$PIECE(PPT(ACD),U)=$PIECE(PPT(ACD),U)
- SET EE=$SELECT(EE]"":EE_"^"_ACD,1:ACD)
- +5 IF EE]""
- SET G=$PIECE(EE,U)
- SET PC=$PIECE(PPT(ACD),U)/100
- SET G1=$PIECE(PPT(ACD),U,2)
- +6 IF KP]""
- IF PC'>0
- SET $PIECE(ERR(CC,"AC"),U,7)="*"
- +7 IF EE]""
- IF KP]""
- IF KP'=PC
- SET $PIECE(ERR(CC,"AC"),U,5)="*"
- +8 IF KD]""
- IF G1=""
- SET $PIECE(ERR(CC,"AC"),U,8)="*"
- +9 IF EE]""
- IF KD]""
- IF KD'=G1
- SET $PIECE(ERR(CC,"AC"),U,6)="*"
- +10 IF KP=""
- IF PC>0
- SET $PIECE(ERR(CC,"AC"),U,9)="*"
- +11 IF KD=""
- IF G1>0
- SET $PIECE(ERR(CC,"AC"),U,10)="*"
- +12 QUIT
- End DoDot:2
- QUIT
- SEG5 QUIT
- SEG6 SET B=$PIECE(LINE,U,2)
- SET ERR(CC,B)=""
- SET IT=$ORDER(^PRCF(421.5,CI,2,"B",B,0))
- if IT=""
- SET $PIECE(ERR(CC,B),U,2)="*"
- if IT=""
- QUIT
- SET IT=$GET(^PRCF(421.5,CI,2,IT,0))
- if IT=""
- SET $PIECE(ERR(CC,B),U,2)="*"
- if IT=""
- QUIT
- +1 SET VP=$PIECE(IT,U,6)
- if VP=""
- SET $PIECE(ERR(CC,B),U,3)="*"
- if $EXTRACT(VP,1)="#"
- SET VP=$EXTRACT(VP,2,99)
- if VP'=$PIECE(LINE,U,5)
- SET $PIECE(ERR(CC,B),U,9)="*"
- +2 SET QT=$PIECE(IT,U,2)
- if QT=""
- SET $PIECE(ERR(CC,B),U,5)="*"
- SET QT=QT\1+(QT#1>0)_"00"
- if QT'=$PIECE(LINE,U,8)
- SET $PIECE(ERR(CC,B),U,10)="*"
- +3 SET PN=$PIECE(LINE,U,6)
- IF PN]""
- SET RP=$PIECE(IT,U,5)
- if RP=""
- SET $PIECE(ERR(CC,B),U,8)="*"
- IF RP]""
- SET MPN=$GET(^PRC(441,RP,3))
- if MPN=""
- SET $PIECE(ERR(CC,B),U,8)="*"
- IF MPN]""
- SET MPN=$PIECE(MPN,U,5)
- if $EXTRACT(MPN,1)="#"
- SET MPN=$EXTRACT(MPN,2,99)
- if MPN'=PN
- SET $PIECE(ERR(CC,B),U,8)="*"
- +4 SET DC=$PIECE(LINE,U,7)
- IF DC]""
- SET N=$PIECE(IT,U,15)
- if N=""
- SET $PIECE(ERR(CC,B),U,4)="*"
- IF N]""
- SET N1=$PIECE(N,"-")
- SET N2=$PIECE(N,"-",2)
- SET N3=$PIECE(N,"-",3)
- SET N1="000000"_N1
- SET N1L=$LENGTH(N1)
- SET N1=$EXTRACT(N1,N1L-5,N1L)
- Begin DoDot:2
- +5 SET N2="0000"_N2
- SET N2L=$LENGTH(N2)
- SET N2=$EXTRACT(N2,N2L-3,N2L)
- SET N3="00"_N3
- SET N3L=$LENGTH(N3)
- SET N3=$EXTRACT(N3,N3L-1,N3L)
- SET N=N1_N2_N3
- End DoDot:2
- if N'=DC
- SET $PIECE(ERR(CC,B),U,4)="*"
- +6 SET UC=$PIECE(LINE,U,10)
- SET UC1=$EXTRACT(UC,1,$LENGTH(UC)-4)
- SET UC2=$EXTRACT(UC,$LENGTH(UC)-3,99)
- SET UC1=$EXTRACT(UC1+1000000,2,7)
- IF UC2="0000"
- SET UC=UC1_UC2
- GOTO S6B
- +7 SET UC2="."_UC2
- SET UC2=$EXTRACT($EXTRACT(UC2+.005,2,3)_"0000",1,4)
- SET UC=UC1_UC2
- S6B SET CU=$PIECE(IT,U,9)
- if CU=""
- SET $PIECE(ERR(CC,B),U,7)="*"
- if CU=""
- GOTO S6A
- IF CU]""
- IF CU="N/C"
- SET CU="0000000000"
- if UC'=CU
- SET $PIECE(ERR(CC,B),U,12)="*"
- GOTO S6A
- +1 SET CU1=$PIECE(CU,".")
- SET CU2=$PIECE(CU,".",2)
- SET CU1="000000"_CU1
- SET C1L=$LENGTH(CU1)
- SET CU1=$EXTRACT(CU1,C1L-5,C1L)
- SET CU2=CU2_"0000"
- SET CU2=$EXTRACT(CU2,1,4)
- SET CU=CU1_CU2
- if UC'=CU
- SET $PIECE(ERR(CC,B),U,12)="*"
- S6A SET PU=$PIECE(LINE,U,9)
- SET UP=$PIECE(IT,U,3)
- if UP=""
- SET $PIECE(ERR(CC,B),U,6)="*"
- IF UP]""
- SET UPN=$GET(^PRCD(420.5,UP,0))
- if UPN=""
- SET $PIECE(ERR(CC,B),U,6)="*"
- IF UPN]""
- SET UNIT=$PIECE(UPN,U)
- if UNIT'=PU
- SET $PIECE(ERR(CC,B),U,11)="*"
- +1 SET DA(1)=CI
- SET DIE="^PRCF(421.5,DA(1),2,"
- SET DR="12///@;12.5///@;13///@;13.5///@"
- SET DA=B
- DO ^DIE
- QUIT
- SEG7 QUIT
- SEG8 KILL DIE,DA,DR
- SET B=$PIECE(LINE,U,2)
- SET DA(1)=CI
- SET DA=B
- SET DIE="^PRCF(421.5,DA(1),2,"
- +1 IF $PIECE(ERR(CC,B),U,2)=""
- SET V1=$PIECE(LINE,U,3)
- SET V2=$PIECE(LINE,U,4)
- if $PIECE(^PRCF(421.5,CI,2,B,2),U,9)=""
- SET DR="12///^S X=V1;12.5///^S X=V2"
- if '$DATA(DR)
- SET DR="13///^S X=V1;13.5///^S X=V2"
- DO ^DIE
- +2 QUIT
- SEG9 QUIT
- SEG10 QUIT
- End DoDot:1
- if QTFLG>0
- GOTO S1
- S1 DO ^PRCOINV1
- S2 QUIT
