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 Dec 13, 2024@02:12 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
