| 1 | PRCOE1 ;WISC/DJM/BGJ-IFCAP SEGMENTS ISM,BI,VE,ST ;4/20/98 21:50
|
|---|
| 2 | V ;;5.1;IFCAP;**48**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ISM(A) ;STANDARD CONTROL STRING - REQUIRED AT BEGINNING OF EACH TRANSACTION
|
|---|
| 6 | N %,B,JD,TIME,X,Y
|
|---|
| 7 | 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_"^"
|
|---|
| 8 | S B=B_$P($P(A,U),"-")_$P($P(A,U),"-",2)_" "_"^"_"001"_"^"_"001"_"^"_"001"_"^|",PRCFA("STRING")=B Q
|
|---|
| 9 | BI(A,VAR1,VAR2) ;BILL TO INFORMATION SEGMENT
|
|---|
| 10 | N A12,A23,B,BTS,IA,INV,SITE,ST
|
|---|
| 11 | 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))
|
|---|
| 12 | I $P(A23,U,11)="P" S B="BI^^^^^^^^^^|" G BI1
|
|---|
| 13 | S B=""
|
|---|
| 14 | I $P(A,U,2)=25 D G BI1
|
|---|
| 15 | . N PRCA,PRCB,PRCC
|
|---|
| 16 | . S PRCA=$P(A23,U,8) Q:PRCA'>0
|
|---|
| 17 | . S PRCB=$G(^PRC(440.5,PRCA,0)) Q:PRCB=""
|
|---|
| 18 | . S PRCC=$P(PRCB,U,8) S:PRCC>0 PRCC=$P($G(^VA(200,PRCC,0)),U)
|
|---|
| 19 | . S B="BI^^"_PRCC_"^"_$$ENCODE^PRCOCRYP($P(PRCB,U),VAR1)
|
|---|
| 20 | . S PRCC=$P($G(^PRC(440.5,PRCA,2)),U,4),PRCB=""
|
|---|
| 21 | . I PRCC'="" D
|
|---|
| 22 | . . S PRCB=$E(PRCC,4,5) S:$E(PRCC,6,7)>0 PRCB=PRCB_"/"_$E(PRCC,6,7)
|
|---|
| 23 | . . S PRCB=PRCB_"/"_$E(PRCC,2,3)
|
|---|
| 24 | . S B=B_"^"_$$ENCODE^PRCOCRYP(PRCB,VAR1)_"^"_"CC"_VAR1_"^^^^^|"
|
|---|
| 25 | S A12=$G(^PRC(442,VAR1,12)) S:A12="" VAR2="NP12" Q:A12=""
|
|---|
| 26 | S IA=$P(A12,U,6)
|
|---|
| 27 | S:IA="" VAR2="NPIA" Q:IA="" S INV=$G(^PRC(411,SITE,4,IA,0)) S:INV="" VAR2="NMIL" Q:INV=""
|
|---|
| 28 | 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]""
|
|---|
| 29 | S B="BI^",BTS=$P(INV,U,8),B=B_$S(BTS]"":BTS,1:"")
|
|---|
| 30 | S B=B_"^"_$P(INV,U)_"^"_$P(INV,U,2)_"^"_$P(INV,U,3)_"^"_$P(INV,U,4)_"^^"_$P(INV,U,5)_"^"
|
|---|
| 31 | 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)_"^|"
|
|---|
| 32 | BI1 S ^TMP($J,"STRING",2)=B Q
|
|---|
| 33 | ;
|
|---|
| 34 | VE(A1,VAR2) ;VENDOR INFORMATION SEGMENT
|
|---|
| 35 | N B,EDI,ST,V,V3,VEN,VID
|
|---|
| 36 | S VEN=$P(A1,U)
|
|---|
| 37 | S V3=$G(^PRC(440,VEN,3))
|
|---|
| 38 | S V=$G(^PRC(440,VEN,0))
|
|---|
| 39 | S:V="" VAR2="NV0"
|
|---|
| 40 | Q:V=""
|
|---|
| 41 | S:$P(V,U,7)'>0 VAR2="NSTP"
|
|---|
| 42 | Q:VAR2]""
|
|---|
| 43 | S B="VE^" ; FIELD 1
|
|---|
| 44 | S EDI=$P(V3,U,2)
|
|---|
| 45 | S VID=$P(V3,U,3)
|
|---|
| 46 | I EDI="Y",VID="" S VAR2="NVID"
|
|---|
| 47 | Q:VAR2]""
|
|---|
| 48 | S B=B_$S(VID]"":VID,1:"") ; FIELD 2
|
|---|
| 49 | 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
|
|---|
| 50 | S ST=$G(^DIC(5,$P(V,U,7),0))
|
|---|
| 51 | S:ST="" VAR2="NST0"
|
|---|
| 52 | Q:ST=""
|
|---|
| 53 | S:$P(ST,U,2)="" VAR2="NSTA"
|
|---|
| 54 | Q:VAR2]""
|
|---|
| 55 | 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
|
|---|
| 56 | VE1 S ^TMP($J,"STRING",3)=B
|
|---|
| 57 | Q
|
|---|
| 58 | ;
|
|---|
| 59 | ST(A,A1,VAR1,VAR2) ;SHIP TO INFORMATION SEGMENT
|
|---|
| 60 | N B,DDP,DDP0,EDI,FT,FT0,MP,NM,RL,SP0,ST,STS,VEN,SITE1
|
|---|
| 61 | S MP=$P(A,U,2),DDP=$P(A1,U,12),B="ST^" G:MP=4&(DDP]"") STD
|
|---|
| 62 | S VEN=$P(A1,U),V3=$G(^PRC(440,VEN,3)),EDI=$P(V3,U,2)
|
|---|
| 63 | S SITE1=$G(^PRC(442,VAR1,23)) S:SITE1]"" SITE=$P(SITE1,U,7) S SITE=$S($G(SITE)]"":SITE,1:+$P(A,U))
|
|---|
| 64 | S:SITE="" VAR2="NSIT" Q:SITE=""
|
|---|
| 65 | S ST=$P(A1,U,3)
|
|---|
| 66 | I $P(SITE1,U,11)="P",ST="" S B=B_"^^^^^^^^^|" G ST1
|
|---|
| 67 | 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]""
|
|---|
| 68 | S STS=$P(RL,U,9) I EDI="Y",STS="",SITE'=101 S VAR2="NSTS" Q
|
|---|
| 69 | 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=""
|
|---|
| 70 | S B=B_"^"_$S($P(FT0,U,2)]"":$P(FT0,U,2),1:"V.A. *NO FACILITY TYPE*")_"^"
|
|---|
| 71 | 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)_"^"
|
|---|
| 72 | 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]""
|
|---|
| 73 | S B=B_$E($P(ST,U,2),1,2)_"^"_$P($P(RL,U,7),"-")_$P($P(RL,U,7),"-",2)_"^|" G ST1
|
|---|
| 74 | 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,",")
|
|---|
| 75 | 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]""
|
|---|
| 76 | 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)_"^|"
|
|---|
| 77 | ST1 S ^TMP($J,"STRING",4)=B Q
|
|---|
