source: FOIAVistA/tag/r/CMOP-PSX/PSXDODH1.m@ 1424

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

initial load of FOIAVistA 6/30/08 version

File size: 6.3 KB
Line 
1PSXDODH1 ;BIR/HTW-HL7 Message Conversion ;01/15/02 13:10:52
2 ;;2.0;CMOP;**38,45**;11 Apr 97
3 ; Convert CMOP transmission messages from HL7 V 2.3.1 to V 2.1
4TESTBT ;test the sequence of the messages in the batch
5 ; stored in ^tmp($j,"PSXDOD","MSG0",I)
6 S PSXERR="",LSEG="",PTCNT=0,ORDCNT=0
7 F LNNUM=1:1 S LN=$G(@G@(LNNUM)) Q:LN="" S SEG=$P(LN,"|") S:SEG="NTE" SEG=$P(LN,"|",1,2) D
8 . Q:SEG="FTS"
9 . I LNNUM=1,SEG="FHS" S LSEG=SEG,FHS=LN Q
10 . I '$D(SEGSEQ(LSEG,SEG)) S PSXERR=PSXERR_$S($L(PSXERR):"~",1:"")_"SEQ^"_LSEG_U_SEG S LSEG=SEG Q
11 . S LSEG=SEG
12 . I "BHS,MSH,ORC,RXE,ZR1,PID,BTS"[SEG D CHECK
13 Q
14CHECK ;patient safety check
15 I SEG="BHS" S BATIDB=$P(LN,"|",11),BHS=LN Q
16 I SEG="MSH" S BATIDM=$P(LN,"|",10),ORDSEQ=$P(BATIDM,"-",3),BATIDM=$P(BATIDM,"-",1,2) I BATIDM'=BATIDB S PSXERR=PSXERR_$S($L(PSXERR):"~",1:"")_"22^"_ORDSEQ D Q
17 . I $E(IOST)="C" W !,"Order Sequence ",PSXERR,!,BATIDM,?40,BATIDB
18 I SEG="ORC",LNNUM'=3 S RXIDC=$P(LN,"|",3),RXSEQ=$$GETELM(LN,"5,2","|,^") Q
19 I SEG="RXE" S RXIDE=$P(LN,"|",16),ORDCNT=ORDCNT+1 I RXIDE'=RXIDC S PSXERR=PSXERR_$S($L(PSXERR):"~",1:"")_"41^"_ORDSEQ_U_RXSEQ D Q
20 . I $E(IOST)="C" W !,"Prescription Number ",PSXERR,!,RXIDE,?40,RXIDC
21 I SEG="ZR1" S RXID1=$P(LN,"|",2) I RXID1'=RXIDC S PSXERR=PSXERR_$S($L(PSXERR):"~",1:"")_"44^"_ORDSEQ_U_RXSEQ D Q
22 . I $E(IOST)="C" W !,"RX Number ",PSXERR,!,RXID1,?40,RXIDC
23 I SEG="PID" S PTCNT=PTCNT+1 Q
24 I SEG="BTS" S PTCNTB=$P(LN,"|",2),ORDCNTB=$P(LN,"|",4),BTS=LN D
25 . I PTCNTB'=PTCNT S PSXERR=PSXERR_$S($L(PSXERR):"~",1:"")_"56^" D
26 .. I $E(IOST)="C" W !,"Batch Orders ",PSXERR,!,PTCNTB,?40,PTCNT
27 . I ORDCNTB'=ORDCNT S PSXERR=PSXERR_$S($L(PSXERR):"~",1:"")_"58^" D
28 .. I $E(IOST)="C" W !,"Batch Totals ",PSXERR,!,ORDCNTB,?40,ORDCNT
29 Q
30HEADER ; read FHS,BHS,ORC assemble $$XMIT,NTE|1 called from PSXDODH
31 ;FHS|^~\&|CHCS|BALBOA||CMOP LEAVENWORTH|20020403115125|0124_020931151.TRN
32 ;BHS|^~\&|CHCS||VistA||20020403115100||RAR^RAR||0124-020931151
33 ;ORC|NW||||||||||||||||||||^^^^^^^0124&BALBOA&0124|500 PARK ST^^SAN DIEGO^CA^92130|(858)826-4923
34 ;
35 ;$$XMIT^020931151^BALBOA^CMOP LEAVENWORTH^0124^3020403.115125^DOD Facility^1^8^BALBOA^0124
36 ; NTE|1||673BS\S\CBC-BARTOW\S\673\F\13000 BRUCE B DOWNS BLVD\S\\S\TAMPA\S\FL\S\33612\F\(888) 903-546
37 ; Use document for the mapping of segments & elements between HL7 2.3.1 & CMOP 2.1
38 ; CMOP DOD to Vista Message Mapping 3_24.xls
39 K XM,NTE1
40 S FHS=@G@(1),BHS=@G@(2),ORC=@G@(3)
41 F YY="BATNM^11","FACNM^4","CMOP^6","TRANDTS^7" D PIECE(FHS,"|",YY)
42 S BATNM=$$GETELM(BHS,"11,2","|,-") ; FHS SEGMENT is file name with "_"
43 S TRANDTS=$$FMDATE^HLFNC(TRANDTS)
44 S START=1,END=PTCNTB
45 S ORC=$P(ORC,"ORC|",2)
46 S DIVISION=$$GETELM(ORC,"21,8","|,^")
47 F YY="DIVNUM^1","DIVNM^2","FACNUM^3" D PIECE(DIVISION,"&",YY)
48 F YY="ADDRESS^22","PHONE^23" D PIECE(ORC,"|",YY)
49 F YY="ADD1^1","ADD2^2","CITY^3","STATE^4","ZIP^5" D PIECE(ADDRESS,"^",YY)
50 S DIVNUM="1"_DIVNUM,FACNUM="1"_FACNUM ;****Institution file change
51 ; assemble XM - $$XMIT
52 S XM="$$XMIT"
53 F YY="BATNM^2","FACNM^3","CMOP^4","FACNUM^5","TRANDTS^6","START^8","END^9","DIVNM^10","DIVNUM^11" D PUT(.XM,"^",YY)
54 S $P(XM,"^",7)="DOD Facility"
55 ; change site number for testing to acceptable site number 693
56 ;S XM=$$SETELM(XM,5,"^",693) ;****TESTING
57 ;S XM=$$SETELM(XM,11,"^",693) ;****TESTING
58 ; assemble NTE1(4)
59 S NTE1DIV="" F YY="DIVNUM^1","DIVNM^2","FACNUM^3" D PUT(.NTE1DIV,"\S\",YY)
60 S NTE1ADD="" F YY="ADD1^1","ADD2^2","CITY^3","STATE^4","ZIP^5" D PUT(.NTE1ADD,"\S\",YY)
61 S NTE1LOC="" F YY="NTE1DIV^1","NTE1ADD^2","PHONE^3" D PUT(.NTE1LOC,"\F\",YY)
62 ; assemble NTE1
63 S NTE1="NTE|1||"_NTE1LOC
64 ; change NTE1 site number to 693 for testing
65 ;S NTE1=$$SETELM(NTE1,"4,1,1","|,\F\,\S\",693) ;****TESTING
66 ;S NTE1=$$SETELM(NTE1,"4,1,3","|,\F\,\S\",693) ;****TESTING
67 ; store $$XMIT,NTE1
68 Q
69BLDSEQ ;build check sequence of SEGMENTS
70 K SEGSEQ
71 F I=1:1 S LINE=$P($T(SEGBLD+I),";;",2,99) Q:LINE["$$END" D
72 . S LSEG=$P(LINE,";;")
73 . F J=2:1 S SEG=$P(LINE,";;",J) Q:SEG="" S SEGSEQ(LSEG,SEG)="" ;W !,LSEG,?10,SEG
74 Q
75SEGBLD ; data for checking sequence of segments. ZR1 needs special handling.
76 ;;FHS;;BHS
77 ;;BHS;;ORC
78 ;;ORC;;NTE|2;;NTE|3;;NTE|4;;MSH
79 ;;NTE|2;;NTE|2;;NTE|3;;NTE|4;;MSH
80 ;;NTE|3;;NTE|3;;NTE|4;;MSH
81 ;;NTE|4;;NTE|4;;MSH
82 ;;MSH;;PID
83 ;;PID;;NTE|8;;ORC
84 ;;NTE|8;;ORC;;NTE|8;;ZML;;ZSL
85 ;;ZML;;ZML;;ZSL
86 ;;ZSL;;ZSL;;ORC
87 ;;ORC;;RXE
88 ;;RXE;;ZR1;;NTE|7
89 ;;NTE|7;;NTE|7;;ZR1
90 ;;ZR1;;ORC;;BTS;;MSH;;PID
91 ;;BTS;;FTS
92 ;;$$END
93PIECE(REC,DLM,XX) ;
94 ; Set VAR = piece I of REC using delimiter DLM
95 N Y,I S Y=$P(XX,U),I=$P(XX,U,2),@Y=$P(REC,DLM,I)
96 Q
97PUT(REC,DLM,XX) ;
98 ; Set VAR into piece I of REC using delimiter DLM
99 N Y,I S Y=$P(XX,U),I=$P(XX,U,2)
100 S $P(REC,DLM,I)=$G(@Y)
101 Q
102GETELM(STR,PIECES,SEPS) ;
103 ; uses STRing and
104 ; returns value of the element located by path of pieces and seperators
105 ; ex: PIECES "3,2,1" SEPS "|,^,&"
106 N P,S,PI,V S V=STR
107 F I=1:1 S PI=$P(PIECES,",",I) Q:PI="" S P=I,P(I)=PI,S(I)=$P(SEPS,",",I)
108 F I=1:1:P S V=$P(V,S(I),P(I))
109 Q V
110SETELM(STR,PIECES,SEPS,VALUE) ;
111 ; gets STRing and
112 ; inserts value into element located by path of pieces and separators
113 ; ex: PIECES "3,2,1" SEPS "|,^,&"
114 N P,S,PI,V
115 S (V,V(0))=STR
116 F I=1:1 S PI=$P(PIECES,",",I) Q:PI="" S P=I,P(I)=PI,S(I)=$P(SEPS,",",I)
117 F I=1:1:P S (V,V(I))=$P(V,S(I),P(I)) ; unpack
118 S V(I)=VALUE ; insert value
119 F I=P:-1:1 S $P(V(I-1),S(I),P(I))=V(I) ; repack
120 Q V(0)
121 ;
122STRBLD(STR0,SEPS) ;
123 ; default separators for all segments, fields, components are | ^ &
124 ; other separators can be passed in SEPS ex: "|,^,&" or "|,\F\,\S\"
125 ; or placed within the field and segment nodes STR0( , , ..,"S")= separator
126 ; ex: for NTE|1 of HL7 2.1
127 ; segment NTE|1 STR0("S")="|"
128 ; facility field STR0(4,"S")="\F\"
129 ; address component STR0(4,2,"S")="\S\"
130 N P1,P2,P3,S1,S2,S3,STR
131 S:'$L($G(SEPS)) SEPS="|,^,&"
132 M STR=STR0
133L1 S P1=0,STR=""
134 I '$D(STR("S")) S STR("S")=$P(SEPS,",",1)
135 S S1=STR("S")
136 F S P1=$O(STR(P1)) Q:P1'>0 D
137 . I +$O(STR(P1,0)) D L2
138 . S $P(STR,S1,P1)=STR(P1)
139 Q STR
140L2 S P2=0 ; S STR(P1)=""
141 I '$D(STR(P1,"S")) S STR(P1,"S")=$P(SEPS,",",2)
142 S S2=STR(P1,"S")
143 F S P2=$O(STR(P1,P2)) Q:P2'>0 D
144 . I +$O(STR(P1,P2,0)) D L3
145 . S $P(STR(P1),S2,P2)=STR(P1,P2)
146 I STR(P1)'[S2 S STR(P1)=STR(P1)_S2
147 Q
148L3 S P3=0 ; S STR(P1,P2)=""
149 I '$D(STR(P1,P2,"S")) S STR(P1,P2,"S")=$P(SEPS,",",3)
150 S S3=STR(P1,P2,"S")
151 F S P3=$O(STR(P1,P2,P3)) Q:P3'>0 D
152 . S $P(STR(P1,P2),S3,P3)=STR(P1,P2,P3)
153 I STR(P1,P2)'[S3 S STR(P1,P2)=STR(P1,P2)_S3
154 Q
Note: See TracBrowser for help on using the repository browser.