PRCOE1 ;WISC/DJM/BGJ-IFCAP SEGMENTS ISM,BI,VE,ST ;4/20/98 21:50
V ;;5.1;IFCAP;**48**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
ISM(A) ;STANDARD CONTROL STRING - REQUIRED AT BEGINNING OF EACH TRANSACTION
N %,B,JD,TIME,X,Y
S B="ISM^"_+$P(A,U)_"^200^PHA^" D NOW^%DTC S X=$P(%,".") D JD^PRCFDLN S JD=$E(X,1,3)+1700_$E(Y,1,3),TIME=$P(%,".",2)_"000000",TIME=$E(TIME,1,6),B=B_JD_"^"_TIME_"^"
S B=B_$P($P(A,U),"-")_$P($P(A,U),"-",2)_" "_"^"_"001"_"^"_"001"_"^"_"001"_"^|",PRCFA("STRING")=B Q
BI(A,VAR1,VAR2) ;BILL TO INFORMATION SEGMENT
N A12,A23,B,BTS,IA,INV,SITE,ST
S (A23,SITE)=$G(^PRC(442,VAR1,23)) S:SITE]"" SITE=$P(SITE,U,7) S SITE=$S($G(SITE)]"":SITE,1:+$P(A,U))
I $P(A23,U,11)="P" S B="BI^^^^^^^^^^|" G BI1
S B=""
I $P(A,U,2)=25 D G BI1
. N PRCA,PRCB,PRCC
. S PRCA=$P(A23,U,8) Q:PRCA'>0
. S PRCB=$G(^PRC(440.5,PRCA,0)) Q:PRCB=""
. S PRCC=$P(PRCB,U,8) S:PRCC>0 PRCC=$P($G(^VA(200,PRCC,0)),U)
. S B="BI^^"_PRCC_"^"_$$ENCODE^PRCOCRYP($P(PRCB,U),VAR1)
. S PRCC=$P($G(^PRC(440.5,PRCA,2)),U,4),PRCB=""
. I PRCC'="" D
. . S PRCB=$E(PRCC,4,5) S:$E(PRCC,6,7)>0 PRCB=PRCB_"/"_$E(PRCC,6,7)
. . S PRCB=PRCB_"/"_$E(PRCC,2,3)
. S B=B_"^"_$$ENCODE^PRCOCRYP(PRCB,VAR1)_"^"_"CC"_VAR1_"^^^^^|"
S A12=$G(^PRC(442,VAR1,12)) S:A12="" VAR2="NP12" Q:A12=""
S IA=$P(A12,U,6)
S:IA="" VAR2="NPIA" Q:IA="" S INV=$G(^PRC(411,SITE,4,IA,0)) S:INV="" VAR2="NMIL" Q:INV=""
S VAR2="" S:$P(INV,U,5)="" VAR2="NMIC" Q:VAR2]"" S:$P(INV,U,6)="" VAR2="NMIS" Q:VAR2]"" S:$P(INV,U,7)="" VAR2="NMIZ" Q:VAR2]""
S B="BI^",BTS=$P(INV,U,8),B=B_$S(BTS]"":BTS,1:"")
S B=B_"^"_$P(INV,U)_"^"_$P(INV,U,2)_"^"_$P(INV,U,3)_"^"_$P(INV,U,4)_"^^"_$P(INV,U,5)_"^"
S ST=$G(^DIC(5,$P(INV,U,6),0)) S:ST="" VAR2="NST0" Q:VAR2]"" S:$P(ST,U,2)="" VAR2="NSTA" Q:VAR2]"" S B=B_$E($P(ST,U,2),1,2)_"^"_$P($P(INV,U,7),"-")_$P($P(INV,U,7),"-",2)_"^|"
BI1 S ^TMP($J,"STRING",2)=B Q
;
VE(A1,VAR2) ;VENDOR INFORMATION SEGMENT
N B,EDI,ST,V,V3,VEN,VID
S VEN=$P(A1,U)
S V3=$G(^PRC(440,VEN,3))
S V=$G(^PRC(440,VEN,0))
S:V="" VAR2="NV0"
Q:V=""
S:$P(V,U,7)'>0 VAR2="NSTP"
Q:VAR2]""
S B="VE^" ; FIELD 1
S EDI=$P(V3,U,2)
S VID=$P(V3,U,3)
I EDI="Y",VID="" S VAR2="NVID"
Q:VAR2]""
S B=B_$S(VID]"":VID,1:"") ; FIELD 2
S B=B_"^"_$P(V,U)_"^"_$P(V,U,2)_"^"_$P(V,U,3)_"^"_$P(V,U,4)_"^"_$P(V,U,6)_"^" ; FIELDS 3, 4, 5, 6, 7
S ST=$G(^DIC(5,$P(V,U,7),0))
S:ST="" VAR2="NST0"
Q:ST=""
S:$P(ST,U,2)="" VAR2="NSTA"
Q:VAR2]""
S B=B_$E($P(ST,U,2),1,2)_"^"_$P($P(V,U,8),"-")_$P($P(V,U,8),"-",2)_"^"_$P(V,U,10)_"^^^^^^^^^^|" ; FIELDS 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20
VE1 S ^TMP($J,"STRING",3)=B
Q
;
ST(A,A1,VAR1,VAR2) ;SHIP TO INFORMATION SEGMENT
N B,DDP,DDP0,EDI,FT,FT0,MP,NM,RL,SP0,ST,STS,VEN,SITE1
S MP=$P(A,U,2),DDP=$P(A1,U,12),B="ST^" G:MP=4&(DDP]"") STD
S VEN=$P(A1,U),V3=$G(^PRC(440,VEN,3)),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="NSIT" Q:SITE=""
S ST=$P(A1,U,3)
I $P(SITE1,U,11)="P",ST="" S B=B_"^^^^^^^^^|" G ST1
S:ST="" VAR2="NSTL" Q:ST="" S RL=$G(^PRC(411,SITE,1,ST,0)) S:RL="" VAR2="NRL" Q:RL="" S:$P(RL,U,6)'>0 VAR2="NSTT" Q:VAR2]""
S STS=$P(RL,U,9) I EDI="Y",STS="",SITE'=101 S VAR2="NSTS" Q
S B=B_$S(STS]"":STS,1:""),SP0=$G(^PRC(411,SITE,0)) S:SP0="" VAR2="NSP0^"_SITE Q:SP0="" S FT=$P(SP0,U,7) S:FT="" VAR2="NFT^"_SITE Q:FT="" S FT0=$G(^PRC(411.2,FT,0)) S:FT0="" VAR2="NFT0^"_SITE Q:FT0=""
S B=B_"^"_$S($P(FT0,U,2)]"":$P(FT0,U,2),1:"V.A. *NO FACILITY TYPE*")_"^"
S B=B_$E($P(RL,U,1),1,17)_" "_$P($P(A,U),"-",2)_"^"_$P(RL,U,2)_"^"_$P(RL,U,3)_"^"_$P(RL,U,4)_"^"_$P(RL,U,5)_"^"
S ST=$G(^DIC(5,$P(RL,U,6),0)) S:ST="" VAR2="NST0" Q:ST="" S:$P(ST,U,2)="" VAR2="NSTA" Q:VAR2]""
S B=B_$E($P(ST,U,2),1,2)_"^"_$P($P(RL,U,7),"-")_$P($P(RL,U,7),"-",2)_"^|" G ST1
STD S NM=$G(^DPT(DDP,0)) S:NM="" VAR2="NOPT" 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="NDP0" Q:DDP0="" S B=B_"^"_NM_"^"_$P(DDP0,U,2)_"^"_$P(DDP0,U,3)_"^"_$P(DDP0,U,4)_"^^" S:$P(DDP0,U,6)'>0 VAR2="NSTDP" Q:VAR2]""
S ST=$G(^DIC(5,$P(DDP0,U,6),0)) S:ST="" VAR2="NST0" Q:ST="" S:$P(ST,U,2)="" VAR2="NSTA" Q:VAR2]"" S B=B_$P(DDP0,U,5)_"^"_$E($P(ST,U,2),1,2)_"^"_$P($P(DDP0,U,7),"-")_$P($P(DDP0,U,7),"-",2)_"^|"
ST1 S ^TMP($J,"STRING",4)=B Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOE1 4377 printed Dec 13, 2024@02:11:42 Page 2
PRCOE1 ;WISC/DJM/BGJ-IFCAP SEGMENTS ISM,BI,VE,ST ;4/20/98 21:50
V ;;5.1;IFCAP;**48**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
ISM(A) ;STANDARD CONTROL STRING - REQUIRED AT BEGINNING OF EACH TRANSACTION
+1 NEW %,B,JD,TIME,X,Y
+2 SET B="ISM^"_+$PIECE(A,U)_"^200^PHA^"
DO NOW^%DTC
SET X=$PIECE(%,".")
DO JD^PRCFDLN
SET JD=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)
SET TIME=$PIECE(%,".",2)_"000000"
SET TIME=$EXTRACT(TIME,1,6)
SET B=B_JD_"^"_TIME_"^"
+3 SET B=B_$PIECE($PIECE(A,U),"-")_$PIECE($PIECE(A,U),"-",2)_" "_"^"_"001"_"^"_"001"_"^"_"001"_"^|"
SET PRCFA("STRING")=B
QUIT
BI(A,VAR1,VAR2) ;BILL TO INFORMATION SEGMENT
+1 NEW A12,A23,B,BTS,IA,INV,SITE,ST
+2 SET (A23,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 IF $PIECE(A23,U,11)="P"
SET B="BI^^^^^^^^^^|"
GOTO BI1
+4 SET B=""
+5 IF $PIECE(A,U,2)=25
Begin DoDot:1
+6 NEW PRCA,PRCB,PRCC
+7 SET PRCA=$PIECE(A23,U,8)
if PRCA'>0
QUIT
+8 SET PRCB=$GET(^PRC(440.5,PRCA,0))
if PRCB=""
QUIT
+9 SET PRCC=$PIECE(PRCB,U,8)
if PRCC>0
SET PRCC=$PIECE($GET(^VA(200,PRCC,0)),U)
+10 SET B="BI^^"_PRCC_"^"_$$ENCODE^PRCOCRYP($PIECE(PRCB,U),VAR1)
+11 SET PRCC=$PIECE($GET(^PRC(440.5,PRCA,2)),U,4)
SET PRCB=""
+12 IF PRCC'=""
Begin DoDot:2
+13 SET PRCB=$EXTRACT(PRCC,4,5)
if $EXTRACT(PRCC,6,7)>0
SET PRCB=PRCB_"/"_$EXTRACT(PRCC,6,7)
+14 SET PRCB=PRCB_"/"_$EXTRACT(PRCC,2,3)
End DoDot:2
+15 SET B=B_"^"_$$ENCODE^PRCOCRYP(PRCB,VAR1)_"^"_"CC"_VAR1_"^^^^^|"
End DoDot:1
GOTO BI1
+16 SET A12=$GET(^PRC(442,VAR1,12))
if A12=""
SET VAR2="NP12"
if A12=""
QUIT
+17 SET IA=$PIECE(A12,U,6)
+18 if IA=""
SET VAR2="NPIA"
if IA=""
QUIT
SET INV=$GET(^PRC(411,SITE,4,IA,0))
if INV=""
SET VAR2="NMIL"
if INV=""
QUIT
+19 SET VAR2=""
if $PIECE(INV,U,5)=""
SET VAR2="NMIC"
if VAR2]""
QUIT
if $PIECE(INV,U,6)=""
SET VAR2="NMIS"
if VAR2]""
QUIT
if $PIECE(INV,U,7)=""
SET VAR2="NMIZ"
if VAR2]""
QUIT
+20 SET B="BI^"
SET BTS=$PIECE(INV,U,8)
SET B=B_$SELECT(BTS]"":BTS,1:"")
+21 SET B=B_"^"_$PIECE(INV,U)_"^"_$PIECE(INV,U,2)_"^"_$PIECE(INV,U,3)_"^"_$PIECE(INV,U,4)_"^^"_$PIECE(INV,U,5)_"^"
+22 SET ST=$GET(^DIC(5,$PIECE(INV,U,6),0))
if ST=""
SET VAR2="NST0"
if VAR2]""
QUIT
if $PIECE(ST,U,2)=""
SET VAR2="NSTA"
if VAR2]""
QUIT
SET B=B_$EXTRACT($PIECE(ST,U,2),1,2)_"^"_$PIECE($PIECE(INV,U,7),"-")_$PIECE($PIECE(INV,U,7),"-",2)_"^|"
BI1 SET ^TMP($JOB,"STRING",2)=B
QUIT
+1 ;
VE(A1,VAR2) ;VENDOR INFORMATION SEGMENT
+1 NEW B,EDI,ST,V,V3,VEN,VID
+2 SET VEN=$PIECE(A1,U)
+3 SET V3=$GET(^PRC(440,VEN,3))
+4 SET V=$GET(^PRC(440,VEN,0))
+5 if V=""
SET VAR2="NV0"
+6 if V=""
QUIT
+7 if $PIECE(V,U,7)'>0
SET VAR2="NSTP"
+8 if VAR2]""
QUIT
+9 ; FIELD 1
SET B="VE^"
+10 SET EDI=$PIECE(V3,U,2)
+11 SET VID=$PIECE(V3,U,3)
+12 IF EDI="Y"
IF VID=""
SET VAR2="NVID"
+13 if VAR2]""
QUIT
+14 ; FIELD 2
SET B=B_$SELECT(VID]"":VID,1:"")
+15 ; FIELDS 3, 4, 5, 6, 7
SET B=B_"^"_$PIECE(V,U)_"^"_$PIECE(V,U,2)_"^"_$PIECE(V,U,3)_"^"_$PIECE(V,U,4)_"^"_$PIECE(V,U,6)_"^"
+16 SET ST=$GET(^DIC(5,$PIECE(V,U,7),0))
+17 if ST=""
SET VAR2="NST0"
+18 if ST=""
QUIT
+19 if $PIECE(ST,U,2)=""
SET VAR2="NSTA"
+20 if VAR2]""
QUIT
+21 ; FIELDS 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20
SET B=B_$EXTRACT($PIECE(ST,U,2),1,2)_"^"_$PIECE($PIECE(V,U,8),"-")_$PIECE($PIECE(V,U,8),"-",2)_"^"_$PIECE(V,U,10)_"^^^^^^^^^^|"
VE1 SET ^TMP($JOB,"STRING",3)=B
+1 QUIT
+2 ;
ST(A,A1,VAR1,VAR2) ;SHIP TO INFORMATION SEGMENT
+1 NEW B,DDP,DDP0,EDI,FT,FT0,MP,NM,RL,SP0,ST,STS,VEN,SITE1
+2 SET MP=$PIECE(A,U,2)
SET DDP=$PIECE(A1,U,12)
SET B="ST^"
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="NSIT"
if SITE=""
QUIT
+6 SET ST=$PIECE(A1,U,3)
+7 IF $PIECE(SITE1,U,11)="P"
IF ST=""
SET B=B_"^^^^^^^^^|"
GOTO ST1
+8 if ST=""
SET VAR2="NSTL"
if ST=""
QUIT
SET RL=$GET(^PRC(411,SITE,1,ST,0))
if RL=""
SET VAR2="NRL"
if RL=""
QUIT
if $PIECE(RL,U,6)'>0
SET VAR2="NSTT"
if VAR2]""
QUIT
+9 SET STS=$PIECE(RL,U,9)
IF EDI="Y"
IF STS=""
IF SITE'=101
SET VAR2="NSTS"
QUIT
+10 SET B=B_$SELECT(STS]"":STS,1:"")
SET SP0=$GET(^PRC(411,SITE,0))
if SP0=""
SET VAR2="NSP0^"_SITE
if SP0=""
QUIT
SET FT=$PIECE(SP0,U,7)
if FT=""
SET VAR2="NFT^"_SITE
if FT=""
QUIT
SET FT0=$GET(^PRC(411.2,FT,0))
if FT0=""
SET VAR2="NFT0^"_SITE
if FT0=""
QUIT
+11 SET B=B_"^"_$SELECT($PIECE(FT0,U,2)]"":$PIECE(FT0,U,2),1:"V.A. *NO FACILITY TYPE*")_"^"
+12 SET B=B_$EXTRACT($PIECE(RL,U,1),1,17)_" "_$PIECE($PIECE(A,U),"-",2)_"^"_$PIECE(RL,U,2)_"^"_$PIECE(RL,U,3)_"^"_$PIECE(RL,U,4)_"^"_$PIECE(RL,U,5)_"^"
+13 SET ST=$GET(^DIC(5,$PIECE(RL,U,6),0))
if ST=""
SET VAR2="NST0"
if ST=""
QUIT
if $PIECE(ST,U,2)=""
SET VAR2="NSTA"
if VAR2]""
QUIT
+14 SET B=B_$EXTRACT($PIECE(ST,U,2),1,2)_"^"_$PIECE($PIECE(RL,U,7),"-")_$PIECE($PIECE(RL,U,7),"-",2)_"^|"
GOTO ST1
STD SET NM=$GET(^DPT(DDP,0))
if NM=""
SET VAR2="NOPT"
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="NDP0"
if DDP0=""
QUIT
SET B=B_"^"_NM_"^"_$PIECE(DDP0,U,2)_"^"_$PIECE(DDP0,U,3)_"^"_$PIECE(DDP0,U,4)_"^^"
if $PIECE(DDP0,U,6)'>0
SET VAR2="NSTDP"
if VAR2]""
QUIT
+2 SET ST=$GET(^DIC(5,$PIECE(DDP0,U,6),0))
if ST=""
SET VAR2="NST0"
if ST=""
QUIT
if $PIECE(ST,U,2)=""
SET VAR2="NSTA"
if VAR2]""
QUIT
SET B=B_$PIECE(DDP0,U,5)_"^"_$EXTRACT($PIECE(ST,U,2),1,2)_"^"_$PIECE($PIECE(DDP0,U,7),"-")_$PIECE($PIECE(DDP0,U,7),"-",2)_"^|"
ST1 SET ^TMP($JOB,"STRING",4)=B
QUIT
