PSXDODB ;BIR/HTW-HL7 Message Conversion ;25 Jul 2002 10:02 PM
;;2.0;CMOP;**38,45**;11 Apr 97
; This routine loads a Businessware-converted 2.1 message into a mailman message
EN(PATH,FNAME) ; needs directory & file name
; force an error in the next line
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=""
D EN^PSXDODB1 ;returns PSXERR="" if file is OK ; otherwise it sends negative ack, mail message, copies to pending
G:PSXERR'="" EXIT
S GL="^TMP($J,""PSXDOD"")" ; for global indirection
; Work through translated 2.1 file and add 1 prefix to site ids
; correct Patient name. provider name, remove BTS segment
F Z=0:0 S Z=$O(^TMP($J,"PSXDOD",Z)) Q:$G(Z)'>0 S G="^TMP($J,""PSXDOD"""_","_Z_")" D
.I $G(@G)["BTS|" S @G=^TMP($J,"PSXDOD",Z+1) K ^TMP($J,"PSXDOD",Z+1) ;remove BTS segment if found
.I $G(@G)["$END" S $P(@G,"^",3)=("1"_$P(@G,"^",3)) Q
.I $G(@G)["$XMIT" S SITE="1"_$P(@G,"^",5),$P(@G,"^",5)=SITE,$P(@G,"^",11)=SITE,BATNM=$P(@G,"^",2),FACNM=$P(@G,"^",3),BATID=SITE_BATNM,XX=$P(@G,U,6),$P(@G,U,6)=$$FMDATE^HLFNC(XX),XM=$G(@G)
.;I $G(@G)["NTE|1" S $P(@G,"|",4)=1_$P(@G,"|",4),$P(@G,"\S\",3)=SITE,NTE1=$G(@G)
.I $G(@G)["NTE|1" S $P(@G,"|",4)=1_$P(@G,"|",4),F1=$P(@G,"\F\",1),$P(F1,"\S\",3)=SITE,$P(@G,"\F\",1)=F1,NTE1=$G(@G)
.I $G(@G)["RX1" S $P(@G,"|",2)=1_$P(@G,"|",2)
.;I $G(@G)["ZX1" S $P(@G,"|",3)=SITE
.I $G(@G)["ZX1|" S $P(@G,"|",3)=1_$P(@G,"|",3) D
..S PRVNM=$P(@G,"|",7) Q:PRVNM'[" ,"
..S PRVNML=$P(PRVNM," ,"),PRVNMF=$P(PRVNM," ,",2),PRVNM=PRVNML_", "_PRVNMF
..S $P(@G,"|",7)=PRVNM
..K PRVNM,PRVNML,PRVNMF
.;remore 2nd and following "^" in patient name
.I $G(@G)["PID|" D
.. S PTNM=$P(@G,"|",6),PTNML=$P(PTNM,"^"),PTNMF=$P(PTNM,"^",2,99),PTNMF=$TR(PTNMF,"^"," ")
.. S PTNM=PTNML_"^"_PTNMF,$P(@G,"|",6)=PTNM
.. K PTNM,PTNML,PTNMF
;
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 "_SITE_"-"_BATNM_" from "_FACNM,XMDUZ=.5
XMZ D XMZ^XMA2 G:XMZ'>0 XMZ
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(@GL@(LNNUM)) Q:LNNUM'>0 S LN=@GL@(LNNUM),@M@(MCNT,0)=LN,MCNT=MCNT+1
S ^XMB(3.9,XMZ,2,0)="^^"_MCNT_U_MCNT_U_DT
S XMY("S.PSXX CMOP SERVER")="" ;****testing comment out
;S XMY(DUZ)="" H 1 ;****TESTING S.PSXX
D ENT1^XMD
D EXIT
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 Safty "_FNAME
;S XMY(DUZ)="" ;****TESTING
S XMY("G.PSXX CMOP MANAGERS")=""
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[HPSXDODB 5130 printed Sep 23, 2025@19:20:01 Page 2
PSXDODB ;BIR/HTW-HL7 Message Conversion ;25 Jul 2002 10:02 PM
+1 ;;2.0;CMOP;**38,45**;11 Apr 97
+2 ; This routine loads a Businessware-converted 2.1 message into a mailman message
EN(PATH,FNAME) ; needs directory & file name
+1 ; force an error in the next line
+2 IF $LENGTH(PATH)
IF $LENGTH(FNAME)
IF 1
+3 IF '$TEST
SET PSXERR="0^BAD PATH OR FILENAME"
GOTO ERRMSG
+4 KILL ^TMP($JOB,"PSXDOD")
+5 SET GBL="^TMP("_$JOB_",""PSXDOD"",1)"
+6 SET Y=$$FTG^%ZISH(PATH,FNAME,GBL,3)
+7 IF Y'>0
SET PSXERR="9^"_PATH_U_FNAME_U_" DID NOT LOAD"
GOTO ERRMSG
+8 IF $DATA(^TMP($JOB,"PSXDOD"))'>1
SET PSXERR="9^"_PATH_U_FNAME_U_" DID NOT LOAD"
GOTO ERRMSG
EN1 ;
+1 SET PSXERR=""
+2 ;returns PSXERR="" if file is OK ; otherwise it sends negative ack, mail message, copies to pending
DO EN^PSXDODB1
+3 if PSXERR'=""
GOTO EXIT
+4 ; for global indirection
SET GL="^TMP($J,""PSXDOD"")"
+5 ; Work through translated 2.1 file and add 1 prefix to site ids
+6 ; correct Patient name. provider name, remove BTS segment
+7 FOR Z=0:0
SET Z=$ORDER(^TMP($JOB,"PSXDOD",Z))
if $GET(Z)'>0
QUIT
SET G="^TMP($J,""PSXDOD"""_","_Z_")"
Begin DoDot:1
+8 ;remove BTS segment if found
IF $GET(@G)["BTS|"
SET @G=^TMP($JOB,"PSXDOD",Z+1)
KILL ^TMP($JOB,"PSXDOD",Z+1)
+9 IF $GET(@G)["$END"
SET $PIECE(@G,"^",3)=("1"_$PIECE(@G,"^",3))
QUIT
+10 IF $GET(@G)["$XMIT"
SET SITE="1"_$PIECE(@G,"^",5)
SET $PIECE(@G,"^",5)=SITE
SET $PIECE(@G,"^",11)=SITE
SET BATNM=$PIECE(@G,"^",2)
SET FACNM=$PIECE(@G,"^",3)
SET BATID=SITE_BATNM
SET XX=$PIECE(@G,U,6)
SET $PIECE(@G,U,6)=$$FMDATE^HLFNC(XX)
SET XM=$GET(@G)
+11 ;I $G(@G)["NTE|1" S $P(@G,"|",4)=1_$P(@G,"|",4),$P(@G,"\S\",3)=SITE,NTE1=$G(@G)
+12 IF $GET(@G)["NTE|1"
SET $PIECE(@G,"|",4)=1_$PIECE(@G,"|",4)
SET F1=$PIECE(@G,"\F\",1)
SET $PIECE(F1,"\S\",3)=SITE
SET $PIECE(@G,"\F\",1)=F1
SET NTE1=$GET(@G)
+13 IF $GET(@G)["RX1"
SET $PIECE(@G,"|",2)=1_$PIECE(@G,"|",2)
+14 ;I $G(@G)["ZX1" S $P(@G,"|",3)=SITE
+15 IF $GET(@G)["ZX1|"
SET $PIECE(@G,"|",3)=1_$PIECE(@G,"|",3)
Begin DoDot:2
+16 SET PRVNM=$PIECE(@G,"|",7)
if PRVNM'[" ,"
QUIT
+17 SET PRVNML=$PIECE(PRVNM," ,")
SET PRVNMF=$PIECE(PRVNM," ,",2)
SET PRVNM=PRVNML_", "_PRVNMF
+18 SET $PIECE(@G,"|",7)=PRVNM
+19 KILL PRVNM,PRVNML,PRVNMF
End DoDot:2
+20 ;remore 2nd and following "^" in patient name
+21 IF $GET(@G)["PID|"
Begin DoDot:2
+22 SET PTNM=$PIECE(@G,"|",6)
SET PTNML=$PIECE(PTNM,"^")
SET PTNMF=$PIECE(PTNM,"^",2,99)
SET PTNMF=$TRANSLATE(PTNMF,"^"," ")
+23 SET PTNM=PTNML_"^"_PTNMF
SET $PIECE(@G,"|",6)=PTNM
+24 KILL PTNM,PTNML,PTNMF
End DoDot:2
End DoDot:1
+25 ;
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 ;
+3 ;D HEADER^PSXDODH1 ; build $$XMIT & NTE|1 and set into Message
+4 SET XMSUB="DOD CMOP "_SITE_"-"_BATNM_" from "_FACNM
SET XMDUZ=.5
XMZ DO XMZ^XMA2
if XMZ'>0
GOTO XMZ
+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(@GL@(LNNUM))
if LNNUM'>0
QUIT
SET LN=@GL@(LNNUM)
SET @M@(MCNT,0)=LN
SET MCNT=MCNT+1
+5 SET ^XMB(3.9,XMZ,2,0)="^^"_MCNT_U_MCNT_U_DT
+6 ;****testing comment out
SET XMY("S.PSXX CMOP SERVER")=""
+7 ;S XMY(DUZ)="" H 1 ;****TESTING S.PSXX
+8 DO ENT1^XMD
+9 DO EXIT
+10 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 Safty "_FNAME
+5 ;S XMY(DUZ)="" ;****TESTING
+6 SET XMY("G.PSXX CMOP MANAGERS")=""
+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
