PSXDODH ;BIR/HTW-HL7 Message Conversion ;01/15/02 13:10:52
;;2.0;CMOP;**38**;11 Apr 97
; Convert CMOP transmission messages from HL7 V 2.3.1 to V 2.1
START ; Create 2.1 format
EN(PATH,FNAME) ; needs directory & file name
; force an error in the next line
;S X=ERROR ; generate an undefined error
I $L(PATH),$L(FNAME) I 1
E S PSXERR="0^BAD PATH OR FILENAME" G ERRMSG
K ^TMP($J,"PSXDOD")
S GBL="^TMP("_$J_",""PSXDOD"",1)"
S Y=$$FTG^%ZISH(PATH,FNAME,GBL,3)
I Y'>0 S PSXERR="9^"_PATH_U_FNAME_U_" DID NOT LOAD" G ERRMSG
I $D(^TMP($J,"PSXDOD"))'>1 S PSXERR="9^"_PATH_U_FNAME_U_" DID NOT LOAD" G ERRMSG
EN1 ;
S PSXERR=""
S G="^TMP($J,""PSXDOD"")" ; for global indirection
; Perform Patient Safety check and gather a few variables
D BLDSEQ^PSXDODH1,TESTBT^PSXDODH1
;send acknowledgement message
K ACK
S ACK="MSH|^~\&|VistA||CHCS||20010925202704||ORM^O02|573-013240530|P|2.3.1|||NE|NE"
S BATID=BATIDB,PIECE(BHS,"|",11)=BATID
D NOW^%DTC S BATDTM=+$$HLDATE^HLFNC(%)
F YY="BATID^10","BATDTM^7" D PUT(.ACK,"|",YY)
S ACK(1)=ACK,ACK(2)="MSA|CR|"_BATID
I PSXERR'="" S ACK(2)=ACK(2)_"|"_PSXERR
S FNAME2=$P(FNAME,".",1)_".TAC",PATH=$$GET1^DIQ(554,1,21)
I PSXERR'="" D
. F XX=1:1:5 S Y=$$GTF^%ZISH("ACK(1)",1,PATH,FNAME2) Q:Y=1 H 4
. I Y'=1 D FALERT^PSXDODH1(FNAME2,PATH)
. S PATH=$$GET1^DIQ(554,1,22)
. F XX=1:1:5 S Y=$$GTF^%ZISH("ACK(1)",1,PATH,FNAME2) Q:Y=1 H 4
. I Y'=1 D FALERT^PSXDODH1(FNAME2,PATH)
. ;****TESTING
I PSXERR'="" G ERRMSG
EN2 ;entry for processing file into Vista Messages
S (LNCNT,MCNT,LMSGLOC,ORDCNT)=0 ;line count, message line count, last $$MSG location, order count
D HEADER^PSXDODH1 ; build $$XMIT & NTE|1 and set into Message
S XMSUB="DOD CMOP "_FACNUM_"-"_BATNM_" from "_FACNM,XMDUZ=.5
XMZ D XMZ^XMA2
S M="^XMB(3.9,XMZ,2)" ; variable reference to MailMan message for construction
S @M@(1,0)=XM
S @M@(2,0)=NTE1,MCNT=2
S LNNUM=3 F S LNNUM=$O(@G@(LNNUM)) Q:LNNUM'>0 S LN=@G@(LNNUM),SEG=$P(LN,"|") S:SEG["NTE" SEG=$P(LN,"|",1,2) D
. I "NTE|2,NTE|3,NTE|4"[SEG D NTE234
. I SEG="MSH" D MSH
. I SEG="PID" D PID
. I SEG="ORC" D ORC
. I SEG="RXE" D RXE
. I SEG="NTE|7" K NTE7 S NTE7=LN
. I SEG="ZR1" D ZR1,BUILD,SETRX
. I SEG="BTS" D BTS
S ^XMB(3.9,XMZ,2,0)="^^"_MCNT_U_MCNT_U_DT
S XMY("S.PSXX CMOP SERVER")=""
;S XMY(DUZ)="" ;****TESTING
D ENT1^XMD
D EXIT
Q
MSH ;assemble $$MSG, MSH
;MSH|^~\&|CHCS||VistA||20020219144700||ORM^O01|0124-020501408-1|P|2.3.
D NTE234CK
S DODORD=$P(LN,"|",10),DODORD=$P(DODORD,"-",3)
S ORDCNT=ORDCNT+1
S MCNT=MCNT+1,@M@(MCNT,0)="$MSG^"_ORDCNT ; Set current order $MSG order value
I LMSGLOC S $P(@M@(LMSGLOC,0),"^",3)=MCNT-LMSGLOC ; Set last $MSG's location value of line count
S LMSGLOC=MCNT ; store current $MSGs location
S MSH="MSH|^~\&|CHCS||VistA||20020219144700||ORM|0124-020501408-1|P|2.1|" ;****Testing
S $P(MSH,7,"|")=$P(LN,"|",7),$P(MSH,"|",10)=ORDCNT
S MCNT=MCNT+1,@M@(MCNT,0)=MSH
Q
PID ;
;"PID|||98374511^3^M11||DUCK^CONSTANCE SUSAN||||||1804 MAUMPHREY LANE E.^^HIRANDO^CA^36662||2059880101"
S PID0=$P(LN,"PID|",2)
F YY="PTID^3","PNAME^5","PADD^11","PHONE^13" D PIECE(PID0,"|",YY)
S PT1ST=$P(PNAME,"^",3,99),PTLST=$P(PNAME,"^",1,2) ; VENDOR ADJUSTMENT (REMOVE "^")
S PT1ST=$TR(PT1ST,"^"," "),PNAME=PTLST_"^"_PT1ST ; VENDOR ADJUSTMENT (REMOVE "^")
K PT1ST,PTLST ; VENDOR ADJUSTMENT (REMOVE "^")
S PNAME=$P(PNAME,"^",2,99) ; remove leading "^"
S PID="" F YY="PTID^3","PNAME^5","PADD^11","PHONE^13" D PUT(.PID,"|",YY)
S PID="PID|"_PID
S MCNT=MCNT+1,@M@(MCNT,0)=PID
Q
;
ORC ;Patient Data from ORC and RXE(2.3.1) parse date pieces for RX1,ZX1
; element mapping contained in document HL7 2.1_2.3 CONVERSION.xls
;S NODE="ORC|NM|0124-NA1281-2||2^1|||^^^20020213^20020315|||25||^HENDERSON^DIANE|||20020213000000||||||||"
K RX1,ZX1
S ORC=$P(LN,"ORC|",2) ; adjust line for HL7 component counting
F YY="RXINDX^2","RXCNT^4","RXDATES^7","PRVPHY^12","ISSDT^15" D PIECE(ORC,"|",YY)
S RFLDT=$P(RXDATES,"^",4),EXPDT=$P(RXDATES,"^",5)
S MCNT=MCNT+1,@M@(MCNT,0)="ORC|NW|"
Q
RXE ; Start building RX1. RX1 has data elements from ORC and RXE segments from 3.2.1
;S RXE="RXE|100|A0259^AMOXICILLIN 250MG CAP^L|100||CAP||^TAKE ONE FOUR TIMES A DAY AS DIRECTED THEN TAKE 10 THREE TIMES A DAY AS DIRECTE|||||10||25|NA1281|9||20020213151053"
S RXE=$P(LN,"RXE|",2)
F YY="QTY^1","DRUGID^2","SIG^7","NUMRFLS^12","VERPHRM^14","RXNUM^15","RFLRMN^16","LSTRFLDT^18" D PIECE(RXE,"|",YY)
S RXNUM=$P(RXNUM,"-",2)
S ISSDT=$$FMDATE^HLFNC(ISSDT)\1,ISSDT=$$HLDATE^HLFNC(ISSDT) ;strip off time
S LSTRFLDT=$$FMDATE^HLFNC(LSTRFLDT)\1,LSTRFLDT=$$HLDATE^HLFNC(LSTRFLDT)
S SIG=$E(SIG,2,200)
Q
ZR1 ;
;S NODE="ZR1|NA1281|ONSC|1||1|(2of10)|CMOP TEST PHARMACY|30|RXNA1281|||20030213000000|"
S ZR1=$P(LN,"ZR1|",2)
F YY="RXZNUM^1","PATSTAT^2","RNWTYP^3","COPAYID^4","SAFCAP^5","RFLTXT^6","CLNIC^7","DAYSUP^8" D PIECE(ZR1,"|",YY)
F YY="BARCODE^9","WARNFLG^10","RGSTMAIL^11" D PIECE(ZR1,"|",YY)
S MAILID="M",RXCNT=$P(RXCNT,"~",1),PRVPHY=$$FMNAME^HLFNC(PRVPHY,"^")
S LL=$F(PRVPHY," "),$E(PRVPHY,LL-1)="," ;change provider name to FM format "last,first mi jr"
S RXZNUM=$P(RXZNUM,"-",2),SITEID=DIVNUM_"^"_DIVNM
Q
BTS ; FINISH
S MCNT=MCNT+1
I LMSGLOC S $P(@M@(LMSGLOC,0),"^",3)=MCNT-LMSGLOC
S END="$$ENDXMIT^^"_DIVNUM_U_BATNM_U_PTCNTB_U_ORDCNTB
;S END=$$SETELM^PSXDODH1(END,3,"^",693) ;****TESTING
;S END=$$SETELM^PSXDODH1(END,"4,1","^,-",693) ;****TESTING
S @M@(MCNT,0)=END
Q
BUILD ; assemble RX1 & ZX1
;RX1|NA1367|||||||||||60||P0151^PROPRANOLOL HCL 10MG TAB^L|||||3|20020402|2|||20020502|20020226|0124-NA1367-2||||TAKE ONE TABLET TWICE A DAY
;ZX1|NA1367|0124^BALBOA|M|1^1|(2of3)|GORDON ,TEVE||20|20020402||1|1|30||RXNA1367||ONSC|BALBOA
; gather elements from subscripted segment array and assemble the segment
S RXINDX="1"_RXINDX ;****Institution file change for site leading 0s
S RX1=""
F YY="RXINDX^1","QTY^12","DRUGID^14","NUMRFLS^19","ISSDT^20","RFLRMN^21","EXPDT^24","LSTRFLDT^25","RXNUM^26","SIG^30" D PUT(.RX1,"|",YY)
S RX1="RX1|"_RX1
S ZX1=""
S RXCNT=$P(RXCNT,"^",2)
F YY="RXZNUM^1","SITEID^2","MAILID^3","RXCNT^4","RFLTXT^5","PRVPHY^6","RGSTMAIL^7","VERPHRM^8","RFLDT^9" D PUT(.ZX1,"|",YY)
F YY="COPAYID^10","RNWTYP^11","SAFCAP^12","DAYSUP^13","BARCODE^15","WARNFLG^16","PATSTAT^17","CLNIC^18" D PUT(.ZX1,"|",YY)
S ZX1="ZX1|"_ZX1
; change site number for testing
;S RX1=$$SETELM^PSXDODH1(RX1,"2,1","|,-",693) ;****TESTING
;S ZX1=$$SETELM^PSXDODH1(ZX1,"3,1","|,^",693) ;****TESTING
Q
SETRX ;put RX1,ZX1,NTE7 into mail message
S MCNT=MCNT+1,@M@(MCNT,0)=RX1
I $L($G(NTE7)) S MCNT=MCNT+1,@M@(MCNT,0)=NTE7 K NTE7
S MCNT=MCNT+1,@M@(MCNT,0)=ZX1
Q
NTE234 ; insure 2 3 4 sequence is in place
I SEG="NTE|2" S MCNT=MCNT+1,@M@(MCNT,0)=LN,NTE2=1
I SEG="NTE|3" D S MCNT=MCNT+1,@M@(MCNT,0)=LN,NTE3=1
. I '$G(NTE2) S MCNT=MCNT+1,@M@(MCNT,0)="NTE|2||",NTE2=1
I SEG="NTE|4" D S MCNT=MCNT+1,@M@(MCNT,0)=LN,NTE4=1
. I '$G(NTE2) S MCNT=MCNT+1,@M@(MCNT,0)="NTE|2||",NTE2=1
. I '$G(NTE3) S MCNT=MCNT+1,@M@(MCNT,0)="NTE|3||",NTE3=1
Q
NTE234CK ; encounter MSH , insure NTE 2,3,4 in place
I '$G(NTE2) S MCNT=MCNT+1,@M@(MCNT,0)="NTE|2||",NTE2=1
I '$G(NTE3) S MCNT=MCNT+1,@M@(MCNT,0)="NTE|3||",NTE3=1
I '$G(NTE4) S MCNT=MCNT+1,@M@(MCNT,0)="NTE|4||",NTE4=1
Q
PIECE(REC,DLM,XX) ;
; Set variable V = piece P of REC using delimiter DLM
N V,P S V=$P(XX,U),P=$P(XX,U,2),@V=$P(REC,DLM,P)
Q
PUT(REC,DLM,XX) ;
; Set Variable V into piece P of REC using delimiter DLM
N V,P S V=$P(XX,U),P=$P(XX,U,2)
S $P(REC,DLM,P)=$G(@V)
Q
GETELM(STR,PIECES,SEPS) ;
; uses STRing and
; returns value of the element located by path of pieces and separators
; ex: 1st address line = $$getelm(ORC,"22,1","|,^")
; or = $$getelm(XMIT,"4,2,1","|,\F\,\S|")
N P,S,PI,V,I S V=STR
F I=1:1 S PI=$P(PIECES,",",I) Q:PI="" S P=I,P(I)=PI,S(I)=$P(SEPS,",",I)
F I=1:1:P S V=$P(V,S(I),P(I))
Q V
ERRMSG ;
MSGSEQER ;send error message to folks & DOD
;W !,"error ",PSXERR
S DIRHOLD=$$GET1^DIQ(554,1,23)
S Y=$$GTF^%ZISH($NA(^TMP($J,"PSXDOD",1)),3,DIRHOLD,FNAME)
S XMSUB="DOD CMOP Safety "_FNAME
S XMY("G.PSXX CMOP MANAGERS")=""
;S XMY(DUZ)="" ;***TESTING
S XMTEXT="PSXTXT("
S PSXTXT(1,0)="DOD CMOP HL7 Conversion to VA CMOP HL7 experienced an error"
S PSXTXT(2,0)=$G(PSXERR)
S PSXTXT(3,0)="FILE: "_FNAME
S PSXTXT(4,0)="A copy of the file has been placed in the hold directory "_DIRHOLD
D ^XMD
I $E(IOST)="C" W ! F I=1:1:4 W !,PSXTXT(I,0) I I=4 H 3
K PSXTXT,DIRHOLD
Q
EXIT ;
K BATIDB,BATIDM,BHS,BTS,DLM,DODORD,END,FHS,FNAME,G,GBL,I,J,JJ,LL,LINE,LMSGLOC
K LN,LNCNT,LNNUM,LSEG,M,MCNT,MSH,NTE1,NTE2,NTE3,NTE4,NTE7,ORC,ORDCNT,ORDCNTB
K P,P1,P2,P3,PATH,PI,PID,PNAME,PSXERR,PSXTXT,PTCNT,PTCNTB,REC,RX1,RXE,RXID1,RXIDC,RXIDE
K S,S1,S2,S3,SEG,SEGSEQ,SEPS,STR,STR0,V,VALUE,XM,XX,Y,YY,ZR1,ZX1
K ADDRESS,BATDTM,BATID,BATIDB,BATIDM,BATNM,DIVISION,DIVNM,DIVNUM,EXPDT,FACNM,FNAME2,FNAME3,ISSDT
K LSTRFLDT,MAILID,NTE1ADD,NTE1DIV,NTE1LOC,PID0,PIECE,PRVPHY,PSXF,RFLDT,RXCNT,RXDATES,RXNUM,RXZNUM
K SIG,SITEID,START,TRANDTS,XMZ
K ^TMP($J,"PSXDOD"),PSXTXT
Q
LOADTMP ; load data into ^TMP
K ^TMP($J,"PSXDOD")
F I=1:1 S X=$G(^XMB(3.9,125829,2,I,0)) Q:X="" S ^TMP($J,"PSXDOD",I)=X
Q
CLEARFLS(XX,EXT) ;
LOOP K PSXF,PSXL
S PATH=$$GET1^DIQ(554,1,XX),PSXF(EXT)=""
S Y=$$LIST^%ZISH(PATH,"PSXF","PSXL")
W !,"path ",PATH,!,"files ",EXT
Q:$D(PSXL)'>1
S FILE="" F I=0:0 S FILE=$O(PSXL(FILE)) Q:FILE="" W !,FILE S I=I+1
Q:I'>0
K DIR S DIR(0)="Y",DIR("A")="DELETE FILES ?? ",DIR("B")="N" D ^DIR K DIR Q:Y'>0
W $$DEL^%ZISH(PATH,"PSXL")
G LOOP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXDODH 9671 printed Sep 23, 2025@19:20:03 Page 2
PSXDODH ;BIR/HTW-HL7 Message Conversion ;01/15/02 13:10:52
+1 ;;2.0;CMOP;**38**;11 Apr 97
+2 ; Convert CMOP transmission messages from HL7 V 2.3.1 to V 2.1
START ; Create 2.1 format
EN(PATH,FNAME) ; needs directory & file name
+1 ; force an error in the next line
+2 ;S X=ERROR ; generate an undefined error
+3 IF $LENGTH(PATH)
IF $LENGTH(FNAME)
IF 1
+4 IF '$TEST
SET PSXERR="0^BAD PATH OR FILENAME"
GOTO ERRMSG
+5 KILL ^TMP($JOB,"PSXDOD")
+6 SET GBL="^TMP("_$JOB_",""PSXDOD"",1)"
+7 SET Y=$$FTG^%ZISH(PATH,FNAME,GBL,3)
+8 IF Y'>0
SET PSXERR="9^"_PATH_U_FNAME_U_" DID NOT LOAD"
GOTO ERRMSG
+9 IF $DATA(^TMP($JOB,"PSXDOD"))'>1
SET PSXERR="9^"_PATH_U_FNAME_U_" DID NOT LOAD"
GOTO ERRMSG
EN1 ;
+1 SET PSXERR=""
+2 ; for global indirection
SET G="^TMP($J,""PSXDOD"")"
+3 ; Perform Patient Safety check and gather a few variables
+4 DO BLDSEQ^PSXDODH1
DO TESTBT^PSXDODH1
+5 ;send acknowledgement message
+6 KILL ACK
+7 SET ACK="MSH|^~\&|VistA||CHCS||20010925202704||ORM^O02|573-013240530|P|2.3.1|||NE|NE"
+8 SET BATID=BATIDB
SET PIECE(BHS,"|",11)=BATID
+9 DO NOW^%DTC
SET BATDTM=+$$HLDATE^HLFNC(%)
+10 FOR YY="BATID^10","BATDTM^7"
DO PUT(.ACK,"|",YY)
+11 SET ACK(1)=ACK
SET ACK(2)="MSA|CR|"_BATID
+12 IF PSXERR'=""
SET ACK(2)=ACK(2)_"|"_PSXERR
+13 SET FNAME2=$PIECE(FNAME,".",1)_".TAC"
SET PATH=$$GET1^DIQ(554,1,21)
+14 IF PSXERR'=""
Begin DoDot:1
+15 FOR XX=1:1:5
SET Y=$$GTF^%ZISH("ACK(1)",1,PATH,FNAME2)
if Y=1
QUIT
HANG 4
+16 IF Y'=1
DO FALERT^PSXDODH1(FNAME2,PATH)
+17 SET PATH=$$GET1^DIQ(554,1,22)
+18 FOR XX=1:1:5
SET Y=$$GTF^%ZISH("ACK(1)",1,PATH,FNAME2)
if Y=1
QUIT
HANG 4
+19 IF Y'=1
DO FALERT^PSXDODH1(FNAME2,PATH)
+20 ;****TESTING
End DoDot:1
+21 IF PSXERR'=""
GOTO ERRMSG
EN2 ;entry for processing file into Vista Messages
+1 ;line count, message line count, last $$MSG location, order count
SET (LNCNT,MCNT,LMSGLOC,ORDCNT)=0
+2 ; build $$XMIT & NTE|1 and set into Message
DO HEADER^PSXDODH1
+3 SET XMSUB="DOD CMOP "_FACNUM_"-"_BATNM_" from "_FACNM
SET XMDUZ=.5
XMZ DO XMZ^XMA2
+1 ; variable reference to MailMan message for construction
SET M="^XMB(3.9,XMZ,2)"
+2 SET @M@(1,0)=XM
+3 SET @M@(2,0)=NTE1
SET MCNT=2
+4 SET LNNUM=3
FOR
SET LNNUM=$ORDER(@G@(LNNUM))
if LNNUM'>0
QUIT
SET LN=@G@(LNNUM)
SET SEG=$PIECE(LN,"|")
if SEG["NTE"
SET SEG=$PIECE(LN,"|",1,2)
Begin DoDot:1
+5 IF "NTE|2,NTE|3,NTE|4"[SEG
DO NTE234
+6 IF SEG="MSH"
DO MSH
+7 IF SEG="PID"
DO PID
+8 IF SEG="ORC"
DO ORC
+9 IF SEG="RXE"
DO RXE
+10 IF SEG="NTE|7"
KILL NTE7
SET NTE7=LN
+11 IF SEG="ZR1"
DO ZR1
DO BUILD
DO SETRX
+12 IF SEG="BTS"
DO BTS
End DoDot:1
+13 SET ^XMB(3.9,XMZ,2,0)="^^"_MCNT_U_MCNT_U_DT
+14 SET XMY("S.PSXX CMOP SERVER")=""
+15 ;S XMY(DUZ)="" ;****TESTING
+16 DO ENT1^XMD
+17 DO EXIT
+18 QUIT
MSH ;assemble $$MSG, MSH
+1 ;MSH|^~\&|CHCS||VistA||20020219144700||ORM^O01|0124-020501408-1|P|2.3.
+2 DO NTE234CK
+3 SET DODORD=$PIECE(LN,"|",10)
SET DODORD=$PIECE(DODORD,"-",3)
+4 SET ORDCNT=ORDCNT+1
+5 ; Set current order $MSG order value
SET MCNT=MCNT+1
SET @M@(MCNT,0)="$MSG^"_ORDCNT
+6 ; Set last $MSG's location value of line count
IF LMSGLOC
SET $PIECE(@M@(LMSGLOC,0),"^",3)=MCNT-LMSGLOC
+7 ; store current $MSGs location
SET LMSGLOC=MCNT
+8 ;****Testing
SET MSH="MSH|^~\&|CHCS||VistA||20020219144700||ORM|0124-020501408-1|P|2.1|"
+9 SET $PIECE(MSH,7,"|")=$PIECE(LN,"|",7)
SET $PIECE(MSH,"|",10)=ORDCNT
+10 SET MCNT=MCNT+1
SET @M@(MCNT,0)=MSH
+11 QUIT
PID ;
+1 ;"PID|||98374511^3^M11||DUCK^CONSTANCE SUSAN||||||1804 MAUMPHREY LANE E.^^HIRANDO^CA^36662||2059880101"
+2 SET PID0=$PIECE(LN,"PID|",2)
+3 FOR YY="PTID^3","PNAME^5","PADD^11","PHONE^13"
DO PIECE(PID0,"|",YY)
+4 ; VENDOR ADJUSTMENT (REMOVE "^")
SET PT1ST=$PIECE(PNAME,"^",3,99)
SET PTLST=$PIECE(PNAME,"^",1,2)
+5 ; VENDOR ADJUSTMENT (REMOVE "^")
SET PT1ST=$TRANSLATE(PT1ST,"^"," ")
SET PNAME=PTLST_"^"_PT1ST
+6 ; VENDOR ADJUSTMENT (REMOVE "^")
KILL PT1ST,PTLST
+7 ; remove leading "^"
SET PNAME=$PIECE(PNAME,"^",2,99)
+8 SET PID=""
FOR YY="PTID^3","PNAME^5","PADD^11","PHONE^13"
DO PUT(.PID,"|",YY)
+9 SET PID="PID|"_PID
+10 SET MCNT=MCNT+1
SET @M@(MCNT,0)=PID
+11 QUIT
+12 ;
ORC ;Patient Data from ORC and RXE(2.3.1) parse date pieces for RX1,ZX1
+1 ; element mapping contained in document HL7 2.1_2.3 CONVERSION.xls
+2 ;S NODE="ORC|NM|0124-NA1281-2||2^1|||^^^20020213^20020315|||25||^HENDERSON^DIANE|||20020213000000||||||||"
+3 KILL RX1,ZX1
+4 ; adjust line for HL7 component counting
SET ORC=$PIECE(LN,"ORC|",2)
+5 FOR YY="RXINDX^2","RXCNT^4","RXDATES^7","PRVPHY^12","ISSDT^15"
DO PIECE(ORC,"|",YY)
+6 SET RFLDT=$PIECE(RXDATES,"^",4)
SET EXPDT=$PIECE(RXDATES,"^",5)
+7 SET MCNT=MCNT+1
SET @M@(MCNT,0)="ORC|NW|"
+8 QUIT
RXE ; Start building RX1. RX1 has data elements from ORC and RXE segments from 3.2.1
+1 ;S RXE="RXE|100|A0259^AMOXICILLIN 250MG CAP^L|100||CAP||^TAKE ONE FOUR TIMES A DAY AS DIRECTED THEN TAKE 10 THREE TIMES A DAY AS DIRECTE|||||10||25|NA1281|9||20020213151053"
+2 SET RXE=$PIECE(LN,"RXE|",2)
+3 FOR YY="QTY^1","DRUGID^2","SIG^7","NUMRFLS^12","VERPHRM^14","RXNUM^15","RFLRMN^16","LSTRFLDT^18"
DO PIECE(RXE,"|",YY)
+4 SET RXNUM=$PIECE(RXNUM,"-",2)
+5 ;strip off time
SET ISSDT=$$FMDATE^HLFNC(ISSDT)\1
SET ISSDT=$$HLDATE^HLFNC(ISSDT)
+6 SET LSTRFLDT=$$FMDATE^HLFNC(LSTRFLDT)\1
SET LSTRFLDT=$$HLDATE^HLFNC(LSTRFLDT)
+7 SET SIG=$EXTRACT(SIG,2,200)
+8 QUIT
ZR1 ;
+1 ;S NODE="ZR1|NA1281|ONSC|1||1|(2of10)|CMOP TEST PHARMACY|30|RXNA1281|||20030213000000|"
+2 SET ZR1=$PIECE(LN,"ZR1|",2)
+3 FOR YY="RXZNUM^1","PATSTAT^2","RNWTYP^3","COPAYID^4","SAFCAP^5","RFLTXT^6","CLNIC^7","DAYSUP^8"
DO PIECE(ZR1,"|",YY)
+4 FOR YY="BARCODE^9","WARNFLG^10","RGSTMAIL^11"
DO PIECE(ZR1,"|",YY)
+5 SET MAILID="M"
SET RXCNT=$PIECE(RXCNT,"~",1)
SET PRVPHY=$$FMNAME^HLFNC(PRVPHY,"^")
+6 ;change provider name to FM format "last,first mi jr"
SET LL=$FIND(PRVPHY," ")
SET $EXTRACT(PRVPHY,LL-1)=","
+7 SET RXZNUM=$PIECE(RXZNUM,"-",2)
SET SITEID=DIVNUM_"^"_DIVNM
+8 QUIT
BTS ; FINISH
+1 SET MCNT=MCNT+1
+2 IF LMSGLOC
SET $PIECE(@M@(LMSGLOC,0),"^",3)=MCNT-LMSGLOC
+3 SET END="$$ENDXMIT^^"_DIVNUM_U_BATNM_U_PTCNTB_U_ORDCNTB
+4 ;S END=$$SETELM^PSXDODH1(END,3,"^",693) ;****TESTING
+5 ;S END=$$SETELM^PSXDODH1(END,"4,1","^,-",693) ;****TESTING
+6 SET @M@(MCNT,0)=END
+7 QUIT
BUILD ; assemble RX1 & ZX1
+1 ;RX1|NA1367|||||||||||60||P0151^PROPRANOLOL HCL 10MG TAB^L|||||3|20020402|2|||20020502|20020226|0124-NA1367-2||||TAKE ONE TABLET TWICE A DAY
+2 ;ZX1|NA1367|0124^BALBOA|M|1^1|(2of3)|GORDON ,TEVE||20|20020402||1|1|30||RXNA1367||ONSC|BALBOA
+3 ; gather elements from subscripted segment array and assemble the segment
+4 ;****Institution file change for site leading 0s
SET RXINDX="1"_RXINDX
+5 SET RX1=""
+6 FOR YY="RXINDX^1","QTY^12","DRUGID^14","NUMRFLS^19","ISSDT^20","RFLRMN^21","EXPDT^24","LSTRFLDT^25","RXNUM^26","SIG^30"
DO PUT(.RX1,"|",YY)
+7 SET RX1="RX1|"_RX1
+8 SET ZX1=""
+9 SET RXCNT=$PIECE(RXCNT,"^",2)
+10 FOR YY="RXZNUM^1","SITEID^2","MAILID^3","RXCNT^4","RFLTXT^5","PRVPHY^6","RGSTMAIL^7","VERPHRM^8","RFLDT^9"
DO PUT(.ZX1,"|",YY)
+11 FOR YY="COPAYID^10","RNWTYP^11","SAFCAP^12","DAYSUP^13","BARCODE^15","WARNFLG^16","PATSTAT^17","CLNIC^18"
DO PUT(.ZX1,"|",YY)
+12 SET ZX1="ZX1|"_ZX1
+13 ; change site number for testing
+14 ;S RX1=$$SETELM^PSXDODH1(RX1,"2,1","|,-",693) ;****TESTING
+15 ;S ZX1=$$SETELM^PSXDODH1(ZX1,"3,1","|,^",693) ;****TESTING
+16 QUIT
SETRX ;put RX1,ZX1,NTE7 into mail message
+1 SET MCNT=MCNT+1
SET @M@(MCNT,0)=RX1
+2 IF $LENGTH($GET(NTE7))
SET MCNT=MCNT+1
SET @M@(MCNT,0)=NTE7
KILL NTE7
+3 SET MCNT=MCNT+1
SET @M@(MCNT,0)=ZX1
+4 QUIT
NTE234 ; insure 2 3 4 sequence is in place
+1 IF SEG="NTE|2"
SET MCNT=MCNT+1
SET @M@(MCNT,0)=LN
SET NTE2=1
+2 IF SEG="NTE|3"
Begin DoDot:1
+3 IF '$GET(NTE2)
SET MCNT=MCNT+1
SET @M@(MCNT,0)="NTE|2||"
SET NTE2=1
End DoDot:1
SET MCNT=MCNT+1
SET @M@(MCNT,0)=LN
SET NTE3=1
+4 IF SEG="NTE|4"
Begin DoDot:1
+5 IF '$GET(NTE2)
SET MCNT=MCNT+1
SET @M@(MCNT,0)="NTE|2||"
SET NTE2=1
+6 IF '$GET(NTE3)
SET MCNT=MCNT+1
SET @M@(MCNT,0)="NTE|3||"
SET NTE3=1
End DoDot:1
SET MCNT=MCNT+1
SET @M@(MCNT,0)=LN
SET NTE4=1
+7 QUIT
NTE234CK ; encounter MSH , insure NTE 2,3,4 in place
+1 IF '$GET(NTE2)
SET MCNT=MCNT+1
SET @M@(MCNT,0)="NTE|2||"
SET NTE2=1
+2 IF '$GET(NTE3)
SET MCNT=MCNT+1
SET @M@(MCNT,0)="NTE|3||"
SET NTE3=1
+3 IF '$GET(NTE4)
SET MCNT=MCNT+1
SET @M@(MCNT,0)="NTE|4||"
SET NTE4=1
+4 QUIT
PIECE(REC,DLM,XX) ;
+1 ; Set variable V = piece P of REC using delimiter DLM
+2 NEW V,P
SET V=$PIECE(XX,U)
SET P=$PIECE(XX,U,2)
SET @V=$PIECE(REC,DLM,P)
+3 QUIT
PUT(REC,DLM,XX) ;
+1 ; Set Variable V into piece P of REC using delimiter DLM
+2 NEW V,P
SET V=$PIECE(XX,U)
SET P=$PIECE(XX,U,2)
+3 SET $PIECE(REC,DLM,P)=$GET(@V)
+4 QUIT
GETELM(STR,PIECES,SEPS) ;
+1 ; uses STRing and
+2 ; returns value of the element located by path of pieces and separators
+3 ; ex: 1st address line = $$getelm(ORC,"22,1","|,^")
+4 ; or = $$getelm(XMIT,"4,2,1","|,\F\,\S|")
+5 NEW P,S,PI,V,I
SET V=STR
+6 FOR I=1:1
SET PI=$PIECE(PIECES,",",I)
if PI=""
QUIT
SET P=I
SET P(I)=PI
SET S(I)=$PIECE(SEPS,",",I)
+7 FOR I=1:1:P
SET V=$PIECE(V,S(I),P(I))
+8 QUIT V
ERRMSG ;
MSGSEQER ;send error message to folks & DOD
+1 ;W !,"error ",PSXERR
+2 SET DIRHOLD=$$GET1^DIQ(554,1,23)
+3 SET Y=$$GTF^%ZISH($NAME(^TMP($JOB,"PSXDOD",1)),3,DIRHOLD,FNAME)
+4 SET XMSUB="DOD CMOP Safety "_FNAME
+5 SET XMY("G.PSXX CMOP MANAGERS")=""
+6 ;S XMY(DUZ)="" ;***TESTING
+7 SET XMTEXT="PSXTXT("
+8 SET PSXTXT(1,0)="DOD CMOP HL7 Conversion to VA CMOP HL7 experienced an error"
+9 SET PSXTXT(2,0)=$GET(PSXERR)
+10 SET PSXTXT(3,0)="FILE: "_FNAME
+11 SET PSXTXT(4,0)="A copy of the file has been placed in the hold directory "_DIRHOLD
+12 DO ^XMD
+13 IF $EXTRACT(IOST)="C"
WRITE !
FOR I=1:1:4
WRITE !,PSXTXT(I,0)
IF I=4
HANG 3
+14 KILL PSXTXT,DIRHOLD
+15 QUIT
EXIT ;
+1 KILL BATIDB,BATIDM,BHS,BTS,DLM,DODORD,END,FHS,FNAME,G,GBL,I,J,JJ,LL,LINE,LMSGLOC
+2 KILL LN,LNCNT,LNNUM,LSEG,M,MCNT,MSH,NTE1,NTE2,NTE3,NTE4,NTE7,ORC,ORDCNT,ORDCNTB
+3 KILL P,P1,P2,P3,PATH,PI,PID,PNAME,PSXERR,PSXTXT,PTCNT,PTCNTB,REC,RX1,RXE,RXID1,RXIDC,RXIDE
+4 KILL S,S1,S2,S3,SEG,SEGSEQ,SEPS,STR,STR0,V,VALUE,XM,XX,Y,YY,ZR1,ZX1
+5 KILL ADDRESS,BATDTM,BATID,BATIDB,BATIDM,BATNM,DIVISION,DIVNM,DIVNUM,EXPDT,FACNM,FNAME2,FNAME3,ISSDT
+6 KILL LSTRFLDT,MAILID,NTE1ADD,NTE1DIV,NTE1LOC,PID0,PIECE,PRVPHY,PSXF,RFLDT,RXCNT,RXDATES,RXNUM,RXZNUM
+7 KILL SIG,SITEID,START,TRANDTS,XMZ
+8 KILL ^TMP($JOB,"PSXDOD"),PSXTXT
+9 QUIT
LOADTMP ; load data into ^TMP
+1 KILL ^TMP($JOB,"PSXDOD")
+2 FOR I=1:1
SET X=$GET(^XMB(3.9,125829,2,I,0))
if X=""
QUIT
SET ^TMP($JOB,"PSXDOD",I)=X
+3 QUIT
CLEARFLS(XX,EXT) ;
LOOP KILL PSXF,PSXL
+1 SET PATH=$$GET1^DIQ(554,1,XX)
SET PSXF(EXT)=""
+2 SET Y=$$LIST^%ZISH(PATH,"PSXF","PSXL")
+3 WRITE !,"path ",PATH,!,"files ",EXT
+4 if $DATA(PSXL)'>1
QUIT
+5 SET FILE=""
FOR I=0:0
SET FILE=$ORDER(PSXL(FILE))
if FILE=""
QUIT
WRITE !,FILE
SET I=I+1
+6 if I'>0
QUIT
+7 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="DELETE FILES ?? "
SET DIR("B")="N"
DO ^DIR
KILL DIR
if Y'>0
QUIT
+8 WRITE $$DEL^%ZISH(PATH,"PSXL")
+9 GOTO LOOP
+10 QUIT
