LREPI3 ;VA/DALOI/SED-EMERGING PATHOGENS HL7 SEGMENTS ; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**1002,132,175,1018,260,281,320,1030,315,1031,1034**;NOV 1, 1997;Build 188
;
; Reference to ^DGPT supported by IA #418
; Reference to ^SC supported by IA #10040
; Reference to ^DIC(21 supported by IA #4280
; Reference to ^ICD9 supported by IA #10082
; Reference to ICN supported by IA #2701
; Reference to VAFHLPID supported by IA # 263
; Reference to VAFHLPV1 supporte by IA # 3018
; Reference to ^DIC(5 supported by IA # 10056
; Reference to $$HOMELESS supported by IA #1528
; Reference to VADPT suppoted by IA #10061
; Reference to ^AUPNVPOV supported by IA # 3094
; Reference to ^AUPNVSIT supported by IA #3530
; Reference to $$STA^XUAF4(IEN) supported by IA #2171
; Reference to $$PTR2CODE^DGUTL4 supported by IA #3799
NTE ;TO BUILD THE NTE SEGMENT TO DEFINE THE EPI
S LRDATA="NTE"_HLFS_LRNTE_HLFS_$P(^LAB(69.5,LRPATH,0),U,9)_LRCS_$P(^LAB(69.5,LRPATH,0),U,1)
S LRCNT=LRCNT+1,^TMP("HLS",$J,LRCNT)=$$UP^XLFSTR(LRDATA)
S ^TMP("LREPIREP",$J,LRCNT)=$$UP^XLFSTR(LRDATA)
S LRMSGSZ=LRMSGSZ+$L(LRDATA)
S LRNTE=LRNTE+1
Q
DG1 ;BUILD THE DG1 FOR ICD9 CODES
K ^TMP($J,"DG1")
S IFN=+$G(^TMP($J,LRPROT,DFN,LRENDT,LRPATH,LRINVD,LRND))
DG11 Q:+IFN'>0
Q:'$D(^DGPT(IFN))
;
NEW ICD10DT ; IHS/MSC/MKK - LR*5.2*1034
D ICD10IDT(.ICD10DT)
;
;SEARCH FOR LEGIONAIRS HERE
I $P($G(^DGPT(IFN,300)),U,3)=1 D
.;S ICD9=$O(^ICD9("BA","482.84 ",0)) Q:+ICD9'>0
.; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034 - Take into account ICD-10 coding as well
.S:$$DT^XLFDT<ICD10DT ICD9=$O(^ICD9("BA","482.84 ",0))
.S:$$DT^XLFDT'<ICD10DT ICD9=$O(^ICD9("BA","A48.1 ",0))
.Q:+ICD9<1
.; ----- END IHS/MSC/MKK - LR*5.2*1034
.S ^TMP($J,"DG1",ICD9)=$P($G(^DGPT(IFN,70)),"^",10)_"^"_$$HLDATE^HLFNC($P($G(^DGPT(IFN,0)),"^",2))
I $D(^DGPT(IFN,70)) F LRI=10,11,16:1:24 D
.S ICD9=$P(^DGPT(IFN,70),U,LRI) Q:+ICD9'>0
.S ^TMP($J,"DG1",ICD9)=$P($G(^DGPT(IFN,70)),"^",10)_"^"_$$HLDATE^HLFNC($P($G(^DGPT(IFN,0)),"^",2))
;SEARCH SUB FIELDS
S LRMV=0 F S LRMV=$O(^DGPT(IFN,"M",LRMV)) Q:+LRMV'>0 D
.;SEARCH FOR LEGIONAIRS HERE IN SUB FILE
.I $P($G(^DGPT(IFN,"M",LRMV,300)),U,3)=1 D
..; S ICD9=$O(^ICD9("BA","482.84 ",0)) Q:+ICD9'>0
..; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034 - Take into account ICD-10 coding as well
..S:$$DT^XLFDT<ICD10DT ICD9=$O(^ICD9("BA","482.84 ",0))
..S:$$DT^XLFDT'<ICD10DT ICD9=$O(^ICD9("BA","A48.1 ",0))
..Q:+ICD9<1
..; ----- END IHS/MSC/MKK - LR*5.2*1034
..S ^TMP($J,"DG1",ICD9)=$P($G(^DGPT(IFN,70)),"^",10)_"^"_$$HLDATE^HLFNC($P($G(^DGPT(IFN,0)),"^",2))
.I $D(^DGPT(IFN,"M",LRMV,0)) F LRI=5:1:9,11:1:15 D
..S ICD9=$P(^DGPT(IFN,"M",LRMV,0),U,LRI) Q:+ICD9'>0
..S ^TMP($J,"DG1",ICD9)=$P($G(^DGPT(IFN,70)),"^",10)_"^"_$$HLDATE^HLFNC($P($G(^DGPT(IFN,0)),"^",2))
Q:'$D(^TMP($J,"DG1"))
BLD S ICD9=0 F S ICD9=$O(^TMP($J,"DG1",ICD9)) Q:+ICD9'>0 D
.S:'$D(DGCNT) DGCNT=1
.N LRTMP
.; S LRTMP=$$ICDDX^ICDCODE(ICD9,,,1)
. S LRTMP=$$ICDDX^ICDEX(ICD9,,,"I",1) ; IHS/MSC/MKK - LR*5.2*1034
.K LRDATA
.S LRDATA="DG1"_HLFS_DGCNT_HLFS_HLFS_$P(LRTMP,U,2)
.S LRDATA=LRDATA_LRCS_$P(LRTMP,U,4)_LRCS_"I9"
.I LRPROT=LRPROTX S LRDATA=LRDATA_HLFS_$P(^TMP($J,"DG1",ICD9),"^",2)_HLFS_HLFS_$S(ICD9=$P(^TMP($J,"DG1",ICD9),"^"):"PR",1:"")
.S ^TMP("HL7",$J,DGCNT)=$$UP^XLFSTR(LRDATA),DGCNT=DGCNT+1
K ^TMP($J,"DG1"),LRDATA,DGCNT,ICD9,LRMV
Q
PID ;TO BUILD PID SEGMENT
K MSG
S FLDS="1,2,3,5,7,8,10BT,19,22BT" S MSG=$$EN^VAFHLPID(DFN,FLDS,LRPID)
;MADE CHANGE FOR PID SEGMENTS TOO LONG;CKA;06/30/04
D DEM^VADPT
I $D(VAFPID(1)) D
.S $P(MSG,HLFS,11)=VADM(12),MSG=MSG_VAFPID(1),$P(MSG,HLFS,23)=VADM(11)
; S ICN=$$GETICN^MPIF001(DFN)
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
; If MPIF001 routine exists, use it, otherwise indicate site is not a MPI Node
S ICN=$S($$EXIST^%R("MPIF001.INT"):$$GETICN^MPIF001(DFN),1:"-1^NO MPI NODE")
; ----- END IHS/MSC/MKK - LR*5.2*1031
S:ICN<0 $P(MSG,HLFS,4)=$P(MSG,HLFS,4)_LRCS_""""""_LRCS_"VAMPI"
S:ICN>0 $P(MSG,HLFS,4)=$P(MSG,HLFS,4)_LRCS_ICN_LRCS_"VAMPI"
;ADDITIONAL DATA ADDED HERE HOMELESSNESS
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
; If SOWKHIRM routine exists, use it
I $$EXIST^%R("SOWKHIRM.INT") S:$$HOMELESS^SOWKHIRM(DFN) $P(MSG,HLFS,12)="HOMELESS"
; ----- END IHS/MSC/MKK - LR*5.2*1031
;NOW GET PERIOD OF SERVICE
K VAEL D ELIG^VADPT
S:$G(VAEL(2))'="" $P(MSG,HLFS,28)=$P($G(^DIC(21,+VAEL(2),0)),U,3)
K VAEL
;GET ZIP IF THERE
K VAPA D ADD^VADPT
S $P(MSG,HLFS,12)=$P(MSG,HLFS,12)_LRCS_LRCS_LRCS_VAPA(5)_LRCS_$G(VAPA(6))_LRCS_LRCS_LRCS_LRCS
I VAPA(7)'="",VAPA(5)'="" S CTY=$P(VAPA(7),U,2),CTYN=$P(VAPA(7),U) I CTYN'="" S CTYCD=$P($G(^DIC(5,$P(VAPA(5),U),1,CTYN,0)),U,3) D
.S $P(MSG,HLFS,12)=$P(MSG,HLFS,12)_$G(CTYCD)_"^"_$G(CTY)
K VAPA,CTY,CTYN,CTYCD,LRRACE
I $P(MSG,HLFS,12)="~~~~~~~~" S $P(MSG,HLFS,12)=""
S LRRACE=$$PTR2CODE^DGUTL4($P(VADM(8),U))
I $L(MSG)>245 D
.S $P(MSG,HLFS,11)=VADM(12),$P(MSG,HLFS,23)=VADM(11)
S:$P(MSG,HLFS,11)="""""~""""~0005~""""~""""~CDC" $P(MSG,HLFS,11)=""
S:$P(MSG,HLFS,23)="""""~""""~0189~""""~""""~CDC" $P(MSG,HLFS,23)=""
S $P(MSG,HLFS,11)=LRRACE_"~"_$P(MSG,HLFS,11)
I $P(MSG,HLFS,11)="~" S $P(MSG,HLFS,11)=""
S LRPID=LRPID+1,LRCNT=LRCNT+1,^TMP("HLS",$J,LRCNT)=$$UP^XLFSTR(MSG)
S ^TMP("LREPIREP",$J,LRCNT)=$$UP^XLFSTR(MSG)
S LRMSGSZ=LRMSGSZ+$L(MSG)
K FLDS,VAEL,ICN,VAFPID,VADM
Q
PV1 ;TO BUILD PV1 SEGMENT
K PTF,Y,C,LRDATA,MSG,LRPATLOC
S LRDATA=""
I $P(^TMP($J,LRPROT,DFN,LRENDT),U)="I" D
.S FLDS="1,2,3,36,39,44,45" S LRDATA=$$IN^VAFHLPV1(DFN,LRENDT,FLDS,"","","","")
I $P(LRDATA,HLFS)="" S $P(LRDATA,HLFS)="PV1"
S $P(LRDATA,HLFS,2)=LRPV1
S $P(LRDATA,HLFS,7)=""
S $P(LRDATA,HLFS,3)=$P(^TMP($J,LRPROT,DFN,LRENDT),U)
I $P(LRDATA,HLFS,3)="O" D
.S LRPATLOC=$P(^TMP($J,LRPROT,DFN,LRENDT),U,2)
.S LRFILE=$P(LRPATLOC,";",2)
.S LRIFN=$P(LRPATLOC,";")
.I LRFILE="SC(" D
..I $P($G(^SC(LRIFN,0)),U,4)'="" D
...S LRPATLOC=$$STA^XUAF4($P($G(^SC(LRIFN,0)),U,4))
.I LRFILE="DIC(4" D
..I $$STA^XUAF4(LRIFN)'="" D
...S LRPATLOC=$$STA^XUAF4(LRIFN)
.S $P(LRDATA,HLFS,39)=LRPATLOC
.K LRPATLOC,LRFILE,LRIFN
S:$P(^TMP($J,LRPROT,DFN,LRENDT),U,3)="UPDT" $P(LRDATA,HLFS,3)="U"
S $P(LRDATA,HLFS,45)=$$HLDATE^HLFNC(LRENDT)
S:$P(LRDATA,HLFS,46)="""""" $P(LRDATA,HLFS,46)=""
;MADE CHANGE FOR FUTURE DISCHARGE DATES;CKA 6/30/2004
S:$P(LRDATA,HLFS,46)>LRRPE $P(LRDATA,HLFS,46)=""
S PTF=$P(^TMP($J,LRPROT,DFN,LRENDT),U,2) I +PTF>0 D
.Q:'$D(^DGPT(PTF,0))
.Q:$P(^DGPT(PTF,0),U,6)'=3
.Q:'$D(^DGPT(PTF,70))
.I +$P(^DGPT(PTF,70),U)>0,+$P(^DGPT(PTF,70),U)<LRRPE S $P(LRDATA,HLFS,46)=$$HLDATE^HLFNC($P(^DGPT(PTF,70),U))
.S (Y,LRDTY)=$P(^DGPT(PTF,70),U,3)
.Q:+Y'>0
.S Y=$$EXTERNAL^DILFD(45,72,,Y) ;removed direct reference to ^DD(45,72
.;S C=$P(^DD(45,72,0),U,2) D Y^DIQ ;RLM
.S $P(LRDATA,HLFS,37)=LRDTY_LRCS_Y_LRCS_"VA45"
.S $P(LRDATA,HLFS,40)=$P(^DGPT(PTF,0),U,3)
S LRCNT=LRCNT+1,^TMP("HLS",$J,LRCNT)=$$UP^XLFSTR(LRDATA),LRPV1=LRPV1+1
S ^TMP("LREPIREP",$J,LRCNT)=$$UP^XLFSTR(LRDATA)
S LRMSGSZ=LRMSGSZ+$L(LRDATA)
I $P(LRDATA,HLFS,3)="O" D D MOVE^LREPI2
.S VIFN=0
.F S VIFN=$O(^AUPNVPOV("AA",DFN,9999999-$P(LRENDT,"."),VIFN)) Q:+VIFN'>0 D
..S LRVISIT=$P(^AUPNVSIT($P(^AUPNVPOV(VIFN,0),U,3),812),U,2)
..I LRVISIT'=26 S LRVISIT=0 Q
..S ICD9N=$P($G(^AUPNVPOV(VIFN,0)),U)
..Q:ICD9N=""
..N LRTMP
..; S LRTMP=$$ICDDX^ICDCODE(ICD9N,,,1)
.. S LRTMP=$$ICDDX^ICDEX(ICD9N,,,"I",1) ; IHS/MSC/MKK - LR*5.2*1034
..S:'$D(DGCNT) DGCNT=1
..S LRDATA="DG1"_HLFS_DGCNT_HLFS_HLFS_$P(LRTMP,U,2)
..S LRDATA=LRDATA_LRCS_$P(LRTMP,U,4)_LRCS_"I9"
..S LRDATA=LRDATA_HLFS_$$HLDATE^HLFNC(LRENDT)_HLFS_HLFS_$S($P(^AUPNVPOV(VIFN,0),U,12)="P":"PR",1:"")
..S ^TMP("HL7",$J,DGCNT)=$$UP^XLFSTR(LRDATA)
.. S DGCNT=DGCNT+1
K DGCNT,VIFN,ICD9N,ICD9,LRDATA,LRVISIT
Q:$G(PTF)'>0
Q:'$D(^DGPT(PTF,0))
Q:$P(^DGPT(PTF,0),U,6)'=3
S IFN=PTF D DG11
D MOVE^LREPI2
K PTF,Y,C,LRDATA,LRDTY,IFN,ICD9,ICD9N,LROLLOC,VIFN
Q
;
LREPI3 ;VA/DALOI/SED-EMERGING PATHOGENS HL7 SEGMENTS ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**1002,132,175,1018,260,281,320,1030,315,1031,1034**;NOV 1, 1997;Build 188
+2 ;
+3 ; Reference to ^DGPT supported by IA #418
+4 ; Reference to ^SC supported by IA #10040
+5 ; Reference to ^DIC(21 supported by IA #4280
+6 ; Reference to ^ICD9 supported by IA #10082
+7 ; Reference to ICN supported by IA #2701
+8 ; Reference to VAFHLPID supported by IA # 263
+9 ; Reference to VAFHLPV1 supporte by IA # 3018
+10 ; Reference to ^DIC(5 supported by IA # 10056
+11 ; Reference to $$HOMELESS supported by IA #1528
+12 ; Reference to VADPT suppoted by IA #10061
+13 ; Reference to ^AUPNVPOV supported by IA # 3094
+14 ; Reference to ^AUPNVSIT supported by IA #3530
+15 ; Reference to $$STA^XUAF4(IEN) supported by IA #2171
+16 ; Reference to $$PTR2CODE^DGUTL4 supported by IA #3799
NTE ;TO BUILD THE NTE SEGMENT TO DEFINE THE EPI
+1 SET LRDATA="NTE"_HLFS_LRNTE_HLFS_$PIECE(^LAB(69.5,LRPATH,0),U,9)_LRCS_$PIECE(^LAB(69.5,LRPATH,0),U,1)
+2 SET LRCNT=LRCNT+1
SET ^TMP("HLS",$JOB,LRCNT)=$$UP^XLFSTR(LRDATA)
+3 SET ^TMP("LREPIREP",$JOB,LRCNT)=$$UP^XLFSTR(LRDATA)
+4 SET LRMSGSZ=LRMSGSZ+$LENGTH(LRDATA)
+5 SET LRNTE=LRNTE+1
+6 QUIT
DG1 ;BUILD THE DG1 FOR ICD9 CODES
+1 KILL ^TMP($JOB,"DG1")
+2 SET IFN=+$GET(^TMP($JOB,LRPROT,DFN,LRENDT,LRPATH,LRINVD,LRND))
DG11 IF +IFN'>0
QUIT
+1 IF '$DATA(^DGPT(IFN))
QUIT
+2 ;
+3 ; IHS/MSC/MKK - LR*5.2*1034
NEW ICD10DT
+4 DO ICD10IDT(.ICD10DT)
+5 ;
+6 ;SEARCH FOR LEGIONAIRS HERE
+7 IF $PIECE($GET(^DGPT(IFN,300)),U,3)=1
Begin DoDot:1
+8 ;S ICD9=$O(^ICD9("BA","482.84 ",0)) Q:+ICD9'>0
+9 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034 - Take into account ICD-10 coding as well
+10 IF $$DT^XLFDT<ICD10DT
SET ICD9=$ORDER(^ICD9("BA","482.84 ",0))
+11 IF $$DT^XLFDT'<ICD10DT
SET ICD9=$ORDER(^ICD9("BA","A48.1 ",0))
+12 IF +ICD9<1
QUIT
+13 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+14 SET ^TMP($JOB,"DG1",ICD9)=$PIECE($GET(^DGPT(IFN,70)),"^",10)_"^"_$$HLDATE^HLFNC($PIECE($GET(^DGPT(IFN,0)),"^",2))
End DoDot:1
+15 IF $DATA(^DGPT(IFN,70))
FOR LRI=10,11,16:1:24
Begin DoDot:1
+16 SET ICD9=$PIECE(^DGPT(IFN,70),U,LRI)
IF +ICD9'>0
QUIT
+17 SET ^TMP($JOB,"DG1",ICD9)=$PIECE($GET(^DGPT(IFN,70)),"^",10)_"^"_$$HLDATE^HLFNC($PIECE($GET(^DGPT(IFN,0)),"^",2))
End DoDot:1
+18 ;SEARCH SUB FIELDS
+19 SET LRMV=0
FOR
SET LRMV=$ORDER(^DGPT(IFN,"M",LRMV))
IF +LRMV'>0
QUIT
Begin DoDot:1
+20 ;SEARCH FOR LEGIONAIRS HERE IN SUB FILE
+21 IF $PIECE($GET(^DGPT(IFN,"M",LRMV,300)),U,3)=1
Begin DoDot:2
+22 ; S ICD9=$O(^ICD9("BA","482.84 ",0)) Q:+ICD9'>0
+23 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034 - Take into account ICD-10 coding as well
+24 IF $$DT^XLFDT<ICD10DT
SET ICD9=$ORDER(^ICD9("BA","482.84 ",0))
+25 IF $$DT^XLFDT'<ICD10DT
SET ICD9=$ORDER(^ICD9("BA","A48.1 ",0))
+26 IF +ICD9<1
QUIT
+27 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+28 SET ^TMP($JOB,"DG1",ICD9)=$PIECE($GET(^DGPT(IFN,70)),"^",10)_"^"_$$HLDATE^HLFNC($PIECE($GET(^DGPT(IFN,0)),"^",2))
End DoDot:2
+29 IF $DATA(^DGPT(IFN,"M",LRMV,0))
FOR LRI=5:1:9,11:1:15
Begin DoDot:2
+30 SET ICD9=$PIECE(^DGPT(IFN,"M",LRMV,0),U,LRI)
IF +ICD9'>0
QUIT
+31 SET ^TMP($JOB,"DG1",ICD9)=$PIECE($GET(^DGPT(IFN,70)),"^",10)_"^"_$$HLDATE^HLFNC($PIECE($GET(^DGPT(IFN,0)),"^",2))
End DoDot:2
End DoDot:1
+32 IF '$DATA(^TMP($JOB,"DG1"))
QUIT
BLD SET ICD9=0
FOR
SET ICD9=$ORDER(^TMP($JOB,"DG1",ICD9))
IF +ICD9'>0
QUIT
Begin DoDot:1
+1 IF '$DATA(DGCNT)
SET DGCNT=1
+2 NEW LRTMP
+3 ; S LRTMP=$$ICDDX^ICDCODE(ICD9,,,1)
+4 ; IHS/MSC/MKK - LR*5.2*1034
SET LRTMP=$$ICDDX^ICDEX(ICD9,,,"I",1)
+5 KILL LRDATA
+6 SET LRDATA="DG1"_HLFS_DGCNT_HLFS_HLFS_$PIECE(LRTMP,U,2)
+7 SET LRDATA=LRDATA_LRCS_$PIECE(LRTMP,U,4)_LRCS_"I9"
+8 IF LRPROT=LRPROTX
SET LRDATA=LRDATA_HLFS_$PIECE(^TMP($JOB,"DG1",ICD9),"^",2)_HLFS_HLFS_$SELECT(ICD9=$PIECE(^TMP($JOB,"DG1",ICD9),"^"):"PR",1:"")
+9 SET ^TMP("HL7",$JOB,DGCNT)=$$UP^XLFSTR(LRDATA)
SET DGCNT=DGCNT+1
End DoDot:1
+10 KILL ^TMP($JOB,"DG1"),LRDATA,DGCNT,ICD9,LRMV
+11 QUIT
PID ;TO BUILD PID SEGMENT
+1 KILL MSG
+2 SET FLDS="1,2,3,5,7,8,10BT,19,22BT"
SET MSG=$$EN^VAFHLPID(DFN,FLDS,LRPID)
+3 ;MADE CHANGE FOR PID SEGMENTS TOO LONG;CKA;06/30/04
+4 DO DEM^VADPT
+5 IF $DATA(VAFPID(1))
Begin DoDot:1
+6 SET $PIECE(MSG,HLFS,11)=VADM(12)
SET MSG=MSG_VAFPID(1)
SET $PIECE(MSG,HLFS,23)=VADM(11)
End DoDot:1
+7 ; S ICN=$$GETICN^MPIF001(DFN)
+8 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+9 ; If MPIF001 routine exists, use it, otherwise indicate site is not a MPI Node
+10 SET ICN=$SELECT($$EXIST^%R("MPIF001.INT"):$$GETICN^MPIF001(DFN),1:"-1^NO MPI NODE")
+11 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+12 IF ICN<0
SET $PIECE(MSG,HLFS,4)=$PIECE(MSG,HLFS,4)_LRCS_""""""_LRCS_"VAMPI"
+13 IF ICN>0
SET $PIECE(MSG,HLFS,4)=$PIECE(MSG,HLFS,4)_LRCS_ICN_LRCS_"VAMPI"
+14 ;ADDITIONAL DATA ADDED HERE HOMELESSNESS
+15 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+16 ; If SOWKHIRM routine exists, use it
+17 IF $$EXIST^%R("SOWKHIRM.INT")
IF $$HOMELESS^SOWKHIRM(DFN)
SET $PIECE(MSG,HLFS,12)="HOMELESS"
+18 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+19 ;NOW GET PERIOD OF SERVICE
+20 KILL VAEL
DO ELIG^VADPT
+21 IF $GET(VAEL(2))'=""
SET $PIECE(MSG,HLFS,28)=$PIECE($GET(^DIC(21,+VAEL(2),0)),U,3)
+22 KILL VAEL
+23 ;GET ZIP IF THERE
+24 KILL VAPA
DO ADD^VADPT
+25 SET $PIECE(MSG,HLFS,12)=$PIECE(MSG,HLFS,12)_LRCS_LRCS_LRCS_VAPA(5)_LRCS_$GET(VAPA(6))_LRCS_LRCS_LRCS_LRCS
+26 IF VAPA(7)'=""
IF VAPA(5)'=""
SET CTY=$PIECE(VAPA(7),U,2)
SET CTYN=$PIECE(VAPA(7),U)
IF CTYN'=""
SET CTYCD=$PIECE($GET(^DIC(5,$PIECE(VAPA(5),U),1,CTYN,0)),U,3)
Begin DoDot:1
+27 SET $PIECE(MSG,HLFS,12)=$PIECE(MSG,HLFS,12)_$GET(CTYCD)_"^"_$GET(CTY)
End DoDot:1
+28 KILL VAPA,CTY,CTYN,CTYCD,LRRACE
+29 IF $PIECE(MSG,HLFS,12)="~~~~~~~~"
SET $PIECE(MSG,HLFS,12)=""
+30 SET LRRACE=$$PTR2CODE^DGUTL4($PIECE(VADM(8),U))
+31 IF $LENGTH(MSG)>245
Begin DoDot:1
+32 SET $PIECE(MSG,HLFS,11)=VADM(12)
SET $PIECE(MSG,HLFS,23)=VADM(11)
End DoDot:1
+33 IF $PIECE(MSG,HLFS,11)="""""~""""~0005~""""~""""~CDC"
SET $PIECE(MSG,HLFS,11)=""
+34 IF $PIECE(MSG,HLFS,23)="""""~""""~0189~""""~""""~CDC"
SET $PIECE(MSG,HLFS,23)=""
+35 SET $PIECE(MSG,HLFS,11)=LRRACE_"~"_$PIECE(MSG,HLFS,11)
+36 IF $PIECE(MSG,HLFS,11)="~"
SET $PIECE(MSG,HLFS,11)=""
+37 SET LRPID=LRPID+1
SET LRCNT=LRCNT+1
SET ^TMP("HLS",$JOB,LRCNT)=$$UP^XLFSTR(MSG)
+38 SET ^TMP("LREPIREP",$JOB,LRCNT)=$$UP^XLFSTR(MSG)
+39 SET LRMSGSZ=LRMSGSZ+$LENGTH(MSG)
+40 KILL FLDS,VAEL,ICN,VAFPID,VADM
+41 QUIT
PV1 ;TO BUILD PV1 SEGMENT
+1 KILL PTF,Y,C,LRDATA,MSG,LRPATLOC
+2 SET LRDATA=""
+3 IF $PIECE(^TMP($JOB,LRPROT,DFN,LRENDT),U)="I"
Begin DoDot:1
+4 SET FLDS="1,2,3,36,39,44,45"
SET LRDATA=$$IN^VAFHLPV1(DFN,LRENDT,FLDS,"","","","")
End DoDot:1
+5 IF $PIECE(LRDATA,HLFS)=""
SET $PIECE(LRDATA,HLFS)="PV1"
+6 SET $PIECE(LRDATA,HLFS,2)=LRPV1
+7 SET $PIECE(LRDATA,HLFS,7)=""
+8 SET $PIECE(LRDATA,HLFS,3)=$PIECE(^TMP($JOB,LRPROT,DFN,LRENDT),U)
+9 IF $PIECE(LRDATA,HLFS,3)="O"
Begin DoDot:1
+10 SET LRPATLOC=$PIECE(^TMP($JOB,LRPROT,DFN,LRENDT),U,2)
+11 SET LRFILE=$PIECE(LRPATLOC,";",2)
+12 SET LRIFN=$PIECE(LRPATLOC,";")
+13 IF LRFILE="SC("
Begin DoDot:2
+14 IF $PIECE($GET(^SC(LRIFN,0)),U,4)'=""
Begin DoDot:3
+15 SET LRPATLOC=$$STA^XUAF4($PIECE($GET(^SC(LRIFN,0)),U,4))
End DoDot:3
End DoDot:2
+16 IF LRFILE="DIC(4"
Begin DoDot:2
+17 IF $$STA^XUAF4(LRIFN)'=""
Begin DoDot:3
+18 SET LRPATLOC=$$STA^XUAF4(LRIFN)
End DoDot:3
End DoDot:2
+19 SET $PIECE(LRDATA,HLFS,39)=LRPATLOC
+20 KILL LRPATLOC,LRFILE,LRIFN
End DoDot:1
+21 IF $PIECE(^TMP($JOB,LRPROT,DFN,LRENDT),U,3)="UPDT"
SET $PIECE(LRDATA,HLFS,3)="U"
+22 SET $PIECE(LRDATA,HLFS,45)=$$HLDATE^HLFNC(LRENDT)
+23 IF $PIECE(LRDATA,HLFS,46)=""""""
SET $PIECE(LRDATA,HLFS,46)=""
+24 ;MADE CHANGE FOR FUTURE DISCHARGE DATES;CKA 6/30/2004
+25 IF $PIECE(LRDATA,HLFS,46)>LRRPE
SET $PIECE(LRDATA,HLFS,46)=""
+26 SET PTF=$PIECE(^TMP($JOB,LRPROT,DFN,LRENDT),U,2)
IF +PTF>0
Begin DoDot:1
+27 IF '$DATA(^DGPT(PTF,0))
QUIT
+28 IF $PIECE(^DGPT(PTF,0),U,6)'=3
QUIT
+29 IF '$DATA(^DGPT(PTF,70))
QUIT
+30 IF +$PIECE(^DGPT(PTF,70),U)>0
IF +$PIECE(^DGPT(PTF,70),U)<LRRPE
SET $PIECE(LRDATA,HLFS,46)=$$HLDATE^HLFNC($PIECE(^DGPT(PTF,70),U))
+31 SET (Y,LRDTY)=$PIECE(^DGPT(PTF,70),U,3)
+32 IF +Y'>0
QUIT
+33 ;removed direct reference to ^DD(45,72
SET Y=$$EXTERNAL^DILFD(45,72,,Y)
+34 ;S C=$P(^DD(45,72,0),U,2) D Y^DIQ ;RLM
+35 SET $PIECE(LRDATA,HLFS,37)=LRDTY_LRCS_Y_LRCS_"VA45"
+36 SET $PIECE(LRDATA,HLFS,40)=$PIECE(^DGPT(PTF,0),U,3)
End DoDot:1
+37 SET LRCNT=LRCNT+1
SET ^TMP("HLS",$JOB,LRCNT)=$$UP^XLFSTR(LRDATA)
SET LRPV1=LRPV1+1
+38 SET ^TMP("LREPIREP",$JOB,LRCNT)=$$UP^XLFSTR(LRDATA)
+39 SET LRMSGSZ=LRMSGSZ+$LENGTH(LRDATA)
+40 IF $PIECE(LRDATA,HLFS,3)="O"
Begin DoDot:1
+41 SET VIFN=0
+42 FOR
SET VIFN=$ORDER(^AUPNVPOV("AA",DFN,9999999-$PIECE(LRENDT,"."),VIFN))
IF +VIFN'>0
QUIT
Begin DoDot:2
+43 SET LRVISIT=$PIECE(^AUPNVSIT($PIECE(^AUPNVPOV(VIFN,0),U,3),812),U,2)
+44 IF LRVISIT'=26
SET LRVISIT=0
QUIT
+45 SET ICD9N=$PIECE($GET(^AUPNVPOV(VIFN,0)),U)
+46 IF ICD9N=""
QUIT
+47 NEW LRTMP
+48 ; S LRTMP=$$ICDDX^ICDCODE(ICD9N,,,1)
+49 ; IHS/MSC/MKK - LR*5.2*1034
SET LRTMP=$$ICDDX^ICDEX(ICD9N,,,"I",1)
+50 IF '$DATA(DGCNT)
SET DGCNT=1
+51 SET LRDATA="DG1"_HLFS_DGCNT_HLFS_HLFS_$PIECE(LRTMP,U,2)
+52 SET LRDATA=LRDATA_LRCS_$PIECE(LRTMP,U,4)_LRCS_"I9"
+53 SET LRDATA=LRDATA_HLFS_$$HLDATE^HLFNC(LRENDT)_HLFS_HLFS_$SELECT($PIECE(^AUPNVPOV(VIFN,0),U,12)="P":"PR",1:"")
+54 SET ^TMP("HL7",$JOB,DGCNT)=$$UP^XLFSTR(LRDATA)
+55 SET DGCNT=DGCNT+1
End DoDot:2
End DoDot:1
DO MOVE^LREPI2
+56 KILL DGCNT,VIFN,ICD9N,ICD9,LRDATA,LRVISIT
+57 IF $GET(PTF)'>0
QUIT
+58 IF '$DATA(^DGPT(PTF,0))
QUIT
+59 IF $PIECE(^DGPT(PTF,0),U,6)'=3
QUIT
+60 SET IFN=PTF
DO DG11
+61 DO MOVE^LREPI2
+62 KILL PTF,Y,C,LRDATA,LRDTY,IFN,ICD9,ICD9N,LROLLOC,VIFN
+63 QUIT
+64 ;
