source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOE1.m@ 1078

Last change on this file since 1078 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1PRCOE1 ;WISC/DJM/BGJ-IFCAP SEGMENTS ISM,BI,VE,ST ;4/20/98 21:50
2V ;;5.1;IFCAP;**48**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ISM(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
9BI(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)_"^|"
32BI1 S ^TMP($J,"STRING",2)=B Q
33 ;
34VE(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
56VE1 S ^TMP($J,"STRING",3)=B
57 Q
58 ;
59ST(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
74STD 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)_"^|"
77ST1 S ^TMP($J,"STRING",4)=B Q
Note: See TracBrowser for help on using the repository browser.