PRCOEC1 ;WISC/DJM/BGJ-IFCAP SEGMENTS BI,VE,ST,AC ;9/11/96 11:51
V ;;5.1;IFCAP;**7**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
BI(A,VAR1,VAR2) ;BILL TO INFORMATION SEGMENT
N A12,IA,INV,SITE,ST
S SITE=$G(^PRC(442,VAR1,23)) S:SITE]"" SITE=$P(SITE,U,7) S SITE=$S($G(SITE)]"":SITE,1:+$P(A,U))
S A23=$G(^PRC(442,VAR1,23))
Q:$P(A23,U,11)="P"
S A12=$G(^PRC(442,VAR1,12)) S:A12="" VAR2="ERROR" W:A12="" !,"NP12-INVOICE ADDRESS pointer is missing." Q:A12=""
S IA=$P(A12,U,6) S:$P(A,U,19)=2 IA=0,IA=$O(^PRC(411,SITE,4,IA))
S:IA="" VAR2="ERROR" W:IA="" !,"NPIA-Invoice address missing."
Q:IA="" S INV=$G(^PRC(411,SITE,4,IA,0)) S:INV="" VAR2="ERROR" W:INV="" !,"NMIL-MAIL INVOICE LOCATION information in file 411 missing." Q:INV=""
S:$P(INV,U,5)="" VAR2="ERROR" W:$P(INV,U,5)="" !,"NMIC-No mail invoice city in file 411." S:$P(INV,U,6)="" VAR2="ERROR" W:$P(INV,U,6)="" !,"NMIS-No state file pointer in file 411."
S:$P(INV,U,7)="" VAR2="ERROR" W:$P(INV,U,7)="" !,"NMIZ-No mail invoice ZIP CODE entry in file 411."
I $P(INV,U,6)>0 S ST=$G(^DIC(5,$P(INV,U,6),0)) S:ST="" VAR2="ERROR" W:ST="" !,"NST0-'STATE' record is missing in STATE file." Q:VAR2]"" S:$P(ST,U,2)="" VAR2="ERROR" W:$P(ST,U,2)="" "NSTA-Abbreviation missing in state file entry."
Q
VE(A1,VAR2) ;VENDOR INFORMATION SEGMENT
N EDI,ST,V,V2,V3,VEN,VID
S VEN=$P(A1,U),V3=$G(^PRC(440,VEN,3)),V2=$G(^PRC(440,VEN,2)),V=$G(^PRC(440,VEN,0))
S:V="" VAR2="ERROR" W:V="" "NV0-No vendor record found in vendor file." Q:V="" I $P(V,U,7)'>0 S VAR2="ERROR" W !,"NSTP-No Vendor Address pointer to the State file."
S EDI=$P(V3,U,2),VID=$P(V3,U,3) I EDI="Y",VID="" W !,"NVID-Missing a vendor ID number for an EDI vendor." S VAR2="ERROR"
I $P(V,U,7)>0 S ST=$G(^DIC(5,$P(V,U,7),0)) S:ST="" VAR2="ERROR" W:ST="" !,"NST0-No state file record." Q:ST="" S:$P(ST,U,2)="" VAR2="ERROR" W:$P(ST,U,2)="" !,"NSTA-No abbreviation in state file."
I $P(V2,U,3)="" S VAR2="ERROR" W !,"NBT-No Vendor Business Type."
Q
;
ST(A,A1,VAR1,VAR2) ;SHIP TO INFORMATION SEGMENT
N DDP,DDP0,EDI,FT,FT0,MP,NM,RL,SITE,SP0,ST,STS,VEN
S MP=$P(A,U,2),DDP=$P(A1,U,12) G:MP=4&(DDP]"") STD
S VEN=$P(A1,U),V3=$G(^PRC(440,VEN,3)) S EDI=$P(V3,U,2)
S SITE1=$G(^PRC(442,VAR1,23)) S:SITE1]"" SITE=$P(SITE1,U,7) S SITE=$S($G(SITE)]"":SITE,1:+$P(A,U))
S:SITE="" VAR2="ERROR" W:SITE="" !,"NSIT-No site entry in file 442." Q:SITE=""
I $P(SITE1,U,11)="P" Q
S ST=$P(A1,U,3) S:ST="" VAR2="ERROR"
W:ST="" !,"NSTL-No ship to pointer to entry in file 411." Q:ST="" S RL=$G(^PRC(411,SITE,1,ST,0)) S:RL="" VAR2="ERROR" W:RL="" !,"NRL-No receiving location record in file 411." Q:RL=""
I $P(RL,U,6)'>0 S VAR2="ERROR" W !,"NSTT-No State file pointer in Receiving Location in file 411."
S STS=$P(RL,U,9) I EDI="Y",STS="",SITE'=101 S VAR2="ERROR" W !,"NSTS-There is no ship to suffix for receiving location for",!,"this EDI P.O." Q
S SP0=$G(^PRC(411,SITE,0)) S:SP0="" VAR2="ERROR" W:SP0="" !,"NSP0^"_SITE_"-No SITE information in file 411." Q:SP0=""
S FT=$P(SP0,U,7) S:FT="" VAR2="ERROR" W:FT="" !,"NFT^"_SITE_"-No facility type pointer for SITE in file 411." Q:FT=""
S FT0=$G(^PRC(411.2,FT,0)) S:FT0="" VAR2="ERROR" W:FT0="" !,"NFT0^"_SITE_"-No entry in file 411.2 for facility type pointer from file 411." Q:FT0=""
I $P(RL,U,6)>0 S ST=$G(^DIC(5,$P(RL,U,6),0)) S:ST="" VAR2="ERROR" W:ST="" !,"NST0-No record in state file." Q:ST="" S:$P(ST,U,2)="" VAR2="ERROR" W:$P(ST,U,2)="" !,"NSTA-Abbreviation missing in state file entry."
Q
STD S NM=$G(^DPT(DDP,0)) S:NM="" VAR2="ERROR" W:NM="" !,"NOPT-No patient file entry for direct delivery patient pointer." Q:NM="" S NM=$E($P(NM,U),1,30),NM=$P(NM,",",2)_" "_$P(NM,",")
S DDP0=$G(^PRC(440.2,DDP,0)) S:DDP0="" VAR2="ERROR" W:DDP0="" !,"NDP0-No record for direct delivery patient pointer." Q:DDP0=""
I $P(DDP0,U,6)'>0 S VAR2="ERROR" W !,"NSTDP-No State file pointer in Direct Delivery Address."
I $P(DDP0,U,6)>0 S ST=$G(^DIC(5,$P(DDP0,U,6),0)) S:ST="" VAR2="ERROR" W:ST="" !,"NST0-No record in the state file." Q:ST=""
S:$P(ST,U,2)="" VAR2="ERROR" W:$P(ST,U,2)="" !,"NSTA-Abbreviation missing in state file entry." Q
AC(A1,VAR1,VAR2) ;ACCOUNTING INFORMATION SEGMENT
N Q
S A23=$G(^PRC(442,VAR1,23))
I '$G(PRCHPHAM),$P(A23,U,11)'="P",+A1>0 I $D(^PRC(440,+A1,3)),$P(^(3),U,2)="Y" S Q=$P($G(^PRC(442,VAR1,5,0)),U,4) S:Q'>0 VAR2="ERROR" W:Q'>0 !,"NPPT-No prompt payment terms entered in P.O." Q:VAR2]""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOEC1 4458 printed Oct 16, 2024@18:12:31 Page 2
PRCOEC1 ;WISC/DJM/BGJ-IFCAP SEGMENTS BI,VE,ST,AC ;9/11/96 11:51
V ;;5.1;IFCAP;**7**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
BI(A,VAR1,VAR2) ;BILL TO INFORMATION SEGMENT
+1 NEW A12,IA,INV,SITE,ST
+2 SET SITE=$GET(^PRC(442,VAR1,23))
if SITE]""
SET SITE=$PIECE(SITE,U,7)
SET SITE=$SELECT($GET(SITE)]"":SITE,1:+$PIECE(A,U))
+3 SET A23=$GET(^PRC(442,VAR1,23))
+4 if $PIECE(A23,U,11)="P"
QUIT
+5 SET A12=$GET(^PRC(442,VAR1,12))
if A12=""
SET VAR2="ERROR"
if A12=""
WRITE !,"NP12-INVOICE ADDRESS pointer is missing."
if A12=""
QUIT
+6 SET IA=$PIECE(A12,U,6)
if $PIECE(A,U,19)=2
SET IA=0
SET IA=$ORDER(^PRC(411,SITE,4,IA))
+7 if IA=""
SET VAR2="ERROR"
if IA=""
WRITE !,"NPIA-Invoice address missing."
+8 if IA=""
QUIT
SET INV=$GET(^PRC(411,SITE,4,IA,0))
if INV=""
SET VAR2="ERROR"
if INV=""
WRITE !,"NMIL-MAIL INVOICE LOCATION information in file 411 missing."
if INV=""
QUIT
+9 if $PIECE(INV,U,5)=""
SET VAR2="ERROR"
if $PIECE(INV,U,5)=""
WRITE !,"NMIC-No mail invoice city in file 411."
if $PIECE(INV,U,6)=""
SET VAR2="ERROR"
if $PIECE(INV,U,6)=""
WRITE !,"NMIS-No state file pointer in file 411."
+10 if $PIECE(INV,U,7)=""
SET VAR2="ERROR"
if $PIECE(INV,U,7)=""
WRITE !,"NMIZ-No mail invoice ZIP CODE entry in file 411."
+11 IF $PIECE(INV,U,6)>0
SET ST=$GET(^DIC(5,$PIECE(INV,U,6),0))
if ST=""
SET VAR2="ERROR"
if ST=""
WRITE !,"NST0-'STATE' record is missing in STATE file."
if VAR2]""
QUIT
if $PIECE(ST,U,2)=""
SET VAR2="ERROR"
if $PIECE(ST,U,2)=""
WRITE "NSTA-Abbreviation missing in state file entry."
+12 QUIT
VE(A1,VAR2) ;VENDOR INFORMATION SEGMENT
+1 NEW EDI,ST,V,V2,V3,VEN,VID
+2 SET VEN=$PIECE(A1,U)
SET V3=$GET(^PRC(440,VEN,3))
SET V2=$GET(^PRC(440,VEN,2))
SET V=$GET(^PRC(440,VEN,0))
+3 if V=""
SET VAR2="ERROR"
if V=""
WRITE "NV0-No vendor record found in vendor file."
if V=""
QUIT
IF $PIECE(V,U,7)'>0
SET VAR2="ERROR"
WRITE !,"NSTP-No Vendor Address pointer to the State file."
+4 SET EDI=$PIECE(V3,U,2)
SET VID=$PIECE(V3,U,3)
IF EDI="Y"
IF VID=""
WRITE !,"NVID-Missing a vendor ID number for an EDI vendor."
SET VAR2="ERROR"
+5 IF $PIECE(V,U,7)>0
SET ST=$GET(^DIC(5,$PIECE(V,U,7),0))
if ST=""
SET VAR2="ERROR"
if ST=""
WRITE !,"NST0-No state file record."
if ST=""
QUIT
if $PIECE(ST,U,2)=""
SET VAR2="ERROR"
if $PIECE(ST,U,2)=""
WRITE !,"NSTA-No abbreviation in state file."
+6 IF $PIECE(V2,U,3)=""
SET VAR2="ERROR"
WRITE !,"NBT-No Vendor Business Type."
+7 QUIT
+8 ;
ST(A,A1,VAR1,VAR2) ;SHIP TO INFORMATION SEGMENT
+1 NEW DDP,DDP0,EDI,FT,FT0,MP,NM,RL,SITE,SP0,ST,STS,VEN
+2 SET MP=$PIECE(A,U,2)
SET DDP=$PIECE(A1,U,12)
if MP=4&(DDP]"")
GOTO STD
+3 SET VEN=$PIECE(A1,U)
SET V3=$GET(^PRC(440,VEN,3))
SET EDI=$PIECE(V3,U,2)
+4 SET SITE1=$GET(^PRC(442,VAR1,23))
if SITE1]""
SET SITE=$PIECE(SITE1,U,7)
SET SITE=$SELECT($GET(SITE)]"":SITE,1:+$PIECE(A,U))
+5 if SITE=""
SET VAR2="ERROR"
if SITE=""
WRITE !,"NSIT-No site entry in file 442."
if SITE=""
QUIT
+6 IF $PIECE(SITE1,U,11)="P"
QUIT
+7 SET ST=$PIECE(A1,U,3)
if ST=""
SET VAR2="ERROR"
+8 if ST=""
WRITE !,"NSTL-No ship to pointer to entry in file 411."
if ST=""
QUIT
SET RL=$GET(^PRC(411,SITE,1,ST,0))
if RL=""
SET VAR2="ERROR"
if RL=""
WRITE !,"NRL-No receiving location record in file 411."
if RL=""
QUIT
+9 IF $PIECE(RL,U,6)'>0
SET VAR2="ERROR"
WRITE !,"NSTT-No State file pointer in Receiving Location in file 411."
+10 SET STS=$PIECE(RL,U,9)
IF EDI="Y"
IF STS=""
IF SITE'=101
SET VAR2="ERROR"
WRITE !,"NSTS-There is no ship to suffix for receiving location for",!,"this EDI P.O."
QUIT
+11 SET SP0=$GET(^PRC(411,SITE,0))
if SP0=""
SET VAR2="ERROR"
if SP0=""
WRITE !,"NSP0^"_SITE_"-No SITE information in file 411."
if SP0=""
QUIT
+12 SET FT=$PIECE(SP0,U,7)
if FT=""
SET VAR2="ERROR"
if FT=""
WRITE !,"NFT^"_SITE_"-No facility type pointer for SITE in file 411."
if FT=""
QUIT
+13 SET FT0=$GET(^PRC(411.2,FT,0))
if FT0=""
SET VAR2="ERROR"
if FT0=""
WRITE !,"NFT0^"_SITE_"-No entry in file 411.2 for facility type pointer from file 411."
if FT0=""
QUIT
+14 IF $PIECE(RL,U,6)>0
SET ST=$GET(^DIC(5,$PIECE(RL,U,6),0))
if ST=""
SET VAR2="ERROR"
if ST=""
WRITE !,"NST0-No record in state file."
if ST=""
QUIT
if $PIECE(ST,U,2)=""
SET VAR2="ERROR"
if $PIECE(ST,U,2)=""
WRITE !,"NSTA-Abbreviation missing in state file entry."
+15 QUIT
STD SET NM=$GET(^DPT(DDP,0))
if NM=""
SET VAR2="ERROR"
if NM=""
WRITE !,"NOPT-No patient file entry for direct delivery patient pointer."
if NM=""
QUIT
SET NM=$EXTRACT($PIECE(NM,U),1,30)
SET NM=$PIECE(NM,",",2)_" "_$PIECE(NM,",")
+1 SET DDP0=$GET(^PRC(440.2,DDP,0))
if DDP0=""
SET VAR2="ERROR"
if DDP0=""
WRITE !,"NDP0-No record for direct delivery patient pointer."
if DDP0=""
QUIT
+2 IF $PIECE(DDP0,U,6)'>0
SET VAR2="ERROR"
WRITE !,"NSTDP-No State file pointer in Direct Delivery Address."
+3 IF $PIECE(DDP0,U,6)>0
SET ST=$GET(^DIC(5,$PIECE(DDP0,U,6),0))
if ST=""
SET VAR2="ERROR"
if ST=""
WRITE !,"NST0-No record in the state file."
if ST=""
QUIT
+4 if $PIECE(ST,U,2)=""
SET VAR2="ERROR"
if $PIECE(ST,U,2)=""
WRITE !,"NSTA-Abbreviation missing in state file entry."
QUIT
AC(A1,VAR1,VAR2) ;ACCOUNTING INFORMATION SEGMENT
+1 NEW Q
+2 SET A23=$GET(^PRC(442,VAR1,23))
+3 IF '$GET(PRCHPHAM)
IF $PIECE(A23,U,11)'="P"
IF +A1>0
IF $DATA(^PRC(440,+A1,3))
IF $PIECE(^(3),U,2)="Y"
SET Q=$PIECE($GET(^PRC(442,VAR1,5,0)),U,4)
if Q'>0
SET VAR2="ERROR"
if Q'>0
WRITE !,"NPPT-No prompt payment terms entered in P.O."
if VAR2]""
QUIT
+4 QUIT
