- 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 ;
