LREPI3 ;DALOI/SED - EMERGING PATHOGENS HL7 SEGMENTS ;Aug 20, 2021@09:32
;;5.2;LAB SERVICE;**132,175,260,281,320,315,421,442,526,552**;Sep 27, 1994;Build 2
;
; Reference to ^DGPT supported by IA #418
; Reference to DGPTFUT supported by IA #6130
; Reference to ^SC supported by IA #10040
; Reference to ^DIC(21 supported by IA #4280
; Reference to ICN supported by IA #2701
; Reference to VAFHLPID supported by IA # 263
; Reference to VAFHLPV1 supported by IA # 3018
; Reference to ^DIC(5 supported by IA # 10056
; Reference to $$BADADR^DGUTL3 supported by IA #4080
; Reference to VADPT supported 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
; Reference to $$CODEN^ICDEX supported by IA #5747
;
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 ICD CODES
K ^TMP($J,"DG1")
S IFN=+$G(^TMP($J,LRPROT,DFN,LRENDT,LRPATH,LRINVD,LRND))
DG11 Q:+IFN'>0
N LRDGPT,LRPDX,LRADMDT,LRDGMV
D PTFICD^DGPTFUT("701",IFN,,.LRDGPT)
Q:$G(LRDGPT)=""
S LRPDX=$P($G(LRDGPT(0)),"^")
S LRADMDT=$$HLDATE^HLFNC($P(LRDGPT,"^",3))
; Date of Interest is Discharge Date if present, otherwise Current
; System Date
N LRDTINT S LRDTINT=$S($P(LRDGPT,"^",10)]"":$P(LRDGPT,"^",10),1:DT)
;SEARCH FOR LEGIONAIRS HERE
I $P($G(^DGPT(IFN,300)),U,3)=1 D
.I '$D(LRICDX) S LRCSYS=$$ICDSYS^LREPICD(LRDTINT,"D"),LRICDX=$S(LRCSYS="ICD":0,LRCSYS="10D":1,1:-1)
.I 'LRICDX S LRICDIEN=+$$CODEN^ICDEX("482.84 ",80) Q:+LRICDIEN'>0 S ^TMP($J,"DG1",LRICDIEN)=LRPDX_"^"_LRADMDT
.I LRICDX,LRICDX'=-1 F XCODE="A48.1","A48.2","A48.8" D Q:'$D(LRICDIEN)
..S LRICDIEN(XCODE)=+$$CODEN^ICDEX(XCODE,80) I +LRICDIEN(XCODE)'>0 K LRICDIEN(XCODE) Q
..S ^TMP($J,"DG1",LRICDIEN(XCODE))=LRPDX_"^"_LRADMDT
S LRI=-1 F S LRI=$O(LRDGPT(LRI)) Q:LRI="" D
.S LRICDIEN=$P(LRDGPT(LRI),"^") Q:+LRICDIEN'>0
.S ^TMP($J,"DG1",LRICDIEN)=LRPDX_"^"_LRADMDT
;SEARCH SUB FIELDS
D PTFIEN^DGPTFUT("501",IFN,.LRDGMV)
S LRMV=0 F S LRMV=$O(LRDGMV(LRMV)) Q:'LRMV K LRDGPT D PTFICD^DGPTFUT("501",IFN,LRMV,.LRDGPT) D:$D(LRDGPT)>9
.;SEARCH FOR LEGIONAIRS HERE IN SUB FILE
.I $P($G(^DGPT(IFN,"M",LRMV,300)),U,3)=1 D
..I 'LRICDX S LRICDIEN=$$CODEN^ICDEX("482.84 ",80) Q:+LRICDIEN'>0 S ^TMP($J,"DG1",LRICDIEN)=LRPDX_"^"_LRADMDT
..I LRICDX,LRICDX'=-1 F XCODE="A48.1","A48.2","A48.8" D Q:'$D(LRICDIEN)
...S LRICDIEN(XCODE)=+$$CODEN^ICDEX(XCODE,80) I +LRICDIEN(XCODE)'>0 K LRICDIEN(XCODE) Q
...S ^TMP($J,"DG1",LRICDIEN(XCODE))=LRPDX_"^"_LRADMDT
.S LRI=0 F S LRI=$O(LRDGPT(LRI)) Q:'LRI D
..S LRICDIEN=$P(LRDGPT(LRI),"^") Q:+LRICDIEN'>0
..S ^TMP($J,"DG1",LRICDIEN)=LRPDX_"^"_LRADMDT
Q:'$D(^TMP($J,"DG1"))
BLD S LRICDIEN=0 F S LRICDIEN=$O(^TMP($J,"DG1",LRICDIEN)) Q:+LRICDIEN'>0 D
.S:'$D(DGCNT) DGCNT=1
.N LRTMP,LRXSYS
.K LRCSYS S LRCSYS=$$ICDSYS^LREPICD(LRDTINT,"D") Q:$P(LRCSYS,U,1)=-1
.S LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,$G(LRDTINT,""),)
.K LRDATA,LREPICSY
.S LREPICSY=$S($P(LRTMP,U,20)=1:" I9",$P(LRTMP,U,20)=30:"I10",1:"UNKNOWN CODE SYSTEM"),LRXSYS=$S(LRCSYS="ICD":" I9",1:"I10")
.Q:LREPICSY'=LRXSYS
.S LRDATA="DG1"_HLFS_DGCNT_HLFS_HLFS_$P(LRTMP,U,2)
.S LRDATA=LRDATA_LRCS_$P(LRTMP,U,4)_LRCS_LREPICSY
.I LRPROT=LRPROTX S LRDATA=LRDATA_HLFS_$P(^TMP($J,"DG1",LRICDIEN),"^",2)_HLFS_HLFS_$S(LRICDIEN=$P(^TMP($J,"DG1",LRICDIEN),"^"):"PR",1:"")
.S ^TMP("HL7",$J,DGCNT)=$$UP^XLFSTR(LRDATA),DGCNT=DGCNT+1
K ^TMP($J,"DG1"),LRDATA,DGCNT,LRICDIEN,LRMV,LRICDX,LRCSYS,XCODE
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)
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
S:$$BADADR^DGUTL3(DFN)=2 $P(MSG,HLFS,12)="HOMELESS"
;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 LRICDN=$P($G(^AUPNVPOV(VIFN,0)),U)
..Q:LRICDN=""
..N LRTMP
..I $G(LRCSYS)="" S LRCSYS=$$CSI^ICDEX(80,LRICDN)
..S LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDN,,)
..;LR*5.2*552: correct undef error on LREPICSY
..;Section BLD has different calls to determine LRCSYS and LRTMP.
..;But the output generated is the same.
..S LREPICSY=$S($P(LRTMP,U,20)=1:" I9",$P(LRTMP,U,20)=30:"I10",1:"UNKNOWN CODE SYSTEM"),LRXSYS=$S(LRCSYS=1:" I9",1:"I10")
..Q:LREPICSY'=LRXSYS
..;end LR*5.2*552
..S:'$D(DGCNT) DGCNT=1
..S LRDATA="DG1"_HLFS_DGCNT_HLFS_LREPICSY_HLFS_$P(LRTMP,U,2)
..S LRDATA=LRDATA_LRCS_$P(LRTMP,U,4)_LRCS_LREPICSY
..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,LRICDN,LRICDIEN,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,LRICDIEN,LRICDN,LROLLOC,VIFN
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLREPI3 8372 printed Dec 13, 2024@02:14:13 Page 2
LREPI3 ;DALOI/SED - EMERGING PATHOGENS HL7 SEGMENTS ;Aug 20, 2021@09:32
+1 ;;5.2;LAB SERVICE;**132,175,260,281,320,315,421,442,526,552**;Sep 27, 1994;Build 2
+2 ;
+3 ; Reference to ^DGPT supported by IA #418
+4 ; Reference to DGPTFUT supported by IA #6130
+5 ; Reference to ^SC supported by IA #10040
+6 ; Reference to ^DIC(21 supported by IA #4280
+7 ; Reference to ICN supported by IA #2701
+8 ; Reference to VAFHLPID supported by IA # 263
+9 ; Reference to VAFHLPV1 supported by IA # 3018
+10 ; Reference to ^DIC(5 supported by IA # 10056
+11 ; Reference to $$BADADR^DGUTL3 supported by IA #4080
+12 ; Reference to VADPT supported 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
+17 ; Reference to $$CODEN^ICDEX supported by IA #5747
+18 ;
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 ICD CODES
+1 KILL ^TMP($JOB,"DG1")
+2 SET IFN=+$GET(^TMP($JOB,LRPROT,DFN,LRENDT,LRPATH,LRINVD,LRND))
DG11 if +IFN'>0
QUIT
+1 NEW LRDGPT,LRPDX,LRADMDT,LRDGMV
+2 DO PTFICD^DGPTFUT("701",IFN,,.LRDGPT)
+3 if $GET(LRDGPT)=""
QUIT
+4 SET LRPDX=$PIECE($GET(LRDGPT(0)),"^")
+5 SET LRADMDT=$$HLDATE^HLFNC($PIECE(LRDGPT,"^",3))
+6 ; Date of Interest is Discharge Date if present, otherwise Current
+7 ; System Date
+8 NEW LRDTINT
SET LRDTINT=$SELECT($PIECE(LRDGPT,"^",10)]"":$PIECE(LRDGPT,"^",10),1:DT)
+9 ;SEARCH FOR LEGIONAIRS HERE
+10 IF $PIECE($GET(^DGPT(IFN,300)),U,3)=1
Begin DoDot:1
+11 IF '$DATA(LRICDX)
SET LRCSYS=$$ICDSYS^LREPICD(LRDTINT,"D")
SET LRICDX=$SELECT(LRCSYS="ICD":0,LRCSYS="10D":1,1:-1)
+12 IF 'LRICDX
SET LRICDIEN=+$$CODEN^ICDEX("482.84 ",80)
if +LRICDIEN'>0
QUIT
SET ^TMP($JOB,"DG1",LRICDIEN)=LRPDX_"^"_LRADMDT
+13 IF LRICDX
IF LRICDX'=-1
FOR XCODE="A48.1","A48.2","A48.8"
Begin DoDot:2
+14 SET LRICDIEN(XCODE)=+$$CODEN^ICDEX(XCODE,80)
IF +LRICDIEN(XCODE)'>0
KILL LRICDIEN(XCODE)
QUIT
+15 SET ^TMP($JOB,"DG1",LRICDIEN(XCODE))=LRPDX_"^"_LRADMDT
End DoDot:2
if '$DATA(LRICDIEN)
QUIT
End DoDot:1
+16 SET LRI=-1
FOR
SET LRI=$ORDER(LRDGPT(LRI))
if LRI=""
QUIT
Begin DoDot:1
+17 SET LRICDIEN=$PIECE(LRDGPT(LRI),"^")
if +LRICDIEN'>0
QUIT
+18 SET ^TMP($JOB,"DG1",LRICDIEN)=LRPDX_"^"_LRADMDT
End DoDot:1
+19 ;SEARCH SUB FIELDS
+20 DO PTFIEN^DGPTFUT("501",IFN,.LRDGMV)
+21 SET LRMV=0
FOR
SET LRMV=$ORDER(LRDGMV(LRMV))
if 'LRMV
QUIT
KILL LRDGPT
DO PTFICD^DGPTFUT("501",IFN,LRMV,.LRDGPT)
if $DATA(LRDGPT)>9
Begin DoDot:1
+22 ;SEARCH FOR LEGIONAIRS HERE IN SUB FILE
+23 IF $PIECE($GET(^DGPT(IFN,"M",LRMV,300)),U,3)=1
Begin DoDot:2
+24 IF 'LRICDX
SET LRICDIEN=$$CODEN^ICDEX("482.84 ",80)
if +LRICDIEN'>0
QUIT
SET ^TMP($JOB,"DG1",LRICDIEN)=LRPDX_"^"_LRADMDT
+25 IF LRICDX
IF LRICDX'=-1
FOR XCODE="A48.1","A48.2","A48.8"
Begin DoDot:3
+26 SET LRICDIEN(XCODE)=+$$CODEN^ICDEX(XCODE,80)
IF +LRICDIEN(XCODE)'>0
KILL LRICDIEN(XCODE)
QUIT
+27 SET ^TMP($JOB,"DG1",LRICDIEN(XCODE))=LRPDX_"^"_LRADMDT
End DoDot:3
if '$DATA(LRICDIEN)
QUIT
End DoDot:2
+28 SET LRI=0
FOR
SET LRI=$ORDER(LRDGPT(LRI))
if 'LRI
QUIT
Begin DoDot:2
+29 SET LRICDIEN=$PIECE(LRDGPT(LRI),"^")
if +LRICDIEN'>0
QUIT
+30 SET ^TMP($JOB,"DG1",LRICDIEN)=LRPDX_"^"_LRADMDT
End DoDot:2
End DoDot:1
+31 if '$DATA(^TMP($JOB,"DG1"))
QUIT
BLD SET LRICDIEN=0
FOR
SET LRICDIEN=$ORDER(^TMP($JOB,"DG1",LRICDIEN))
if +LRICDIEN'>0
QUIT
Begin DoDot:1
+1 if '$DATA(DGCNT)
SET DGCNT=1
+2 NEW LRTMP,LRXSYS
+3 KILL LRCSYS
SET LRCSYS=$$ICDSYS^LREPICD(LRDTINT,"D")
if $PIECE(LRCSYS,U,1)=-1
QUIT
+4 SET LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDIEN,$GET(LRDTINT,""),)
+5 KILL LRDATA,LREPICSY
+6 SET LREPICSY=$SELECT($PIECE(LRTMP,U,20)=1:" I9",$PIECE(LRTMP,U,20)=30:"I10",1:"UNKNOWN CODE SYSTEM")
SET LRXSYS=$SELECT(LRCSYS="ICD":" I9",1:"I10")
+7 if LREPICSY'=LRXSYS
QUIT
+8 SET LRDATA="DG1"_HLFS_DGCNT_HLFS_HLFS_$PIECE(LRTMP,U,2)
+9 SET LRDATA=LRDATA_LRCS_$PIECE(LRTMP,U,4)_LRCS_LREPICSY
+10 IF LRPROT=LRPROTX
SET LRDATA=LRDATA_HLFS_$PIECE(^TMP($JOB,"DG1",LRICDIEN),"^",2)_HLFS_HLFS_$SELECT(LRICDIEN=$PIECE(^TMP($JOB,"DG1",LRICDIEN),"^"):"PR",1:"")
+11 SET ^TMP("HL7",$JOB,DGCNT)=$$UP^XLFSTR(LRDATA)
SET DGCNT=DGCNT+1
End DoDot:1
+12 KILL ^TMP($JOB,"DG1"),LRDATA,DGCNT,LRICDIEN,LRMV,LRICDX,LRCSYS,XCODE
+13 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 SET ICN=$$GETICN^MPIF001(DFN)
+8 if ICN<0
SET $PIECE(MSG,HLFS,4)=$PIECE(MSG,HLFS,4)_LRCS_""""""_LRCS_"VAMPI"
+9 if ICN>0
SET $PIECE(MSG,HLFS,4)=$PIECE(MSG,HLFS,4)_LRCS_ICN_LRCS_"VAMPI"
+10 ;ADDITIONAL DATA ADDED HERE HOMELESSNESS
+11 if $$BADADR^DGUTL3(DFN)=2
SET $PIECE(MSG,HLFS,12)="HOMELESS"
+12 ;NOW GET PERIOD OF SERVICE
+13 KILL VAEL
DO ELIG^VADPT
+14 if $GET(VAEL(2))'=""
SET $PIECE(MSG,HLFS,28)=$PIECE($GET(^DIC(21,+VAEL(2),0)),U,3)
+15 KILL VAEL
+16 ;GET ZIP IF THERE
+17 KILL VAPA
DO ADD^VADPT
+18 SET $PIECE(MSG,HLFS,12)=$PIECE(MSG,HLFS,12)_LRCS_LRCS_LRCS_VAPA(5)_LRCS_$GET(VAPA(6))_LRCS_LRCS_LRCS_LRCS
+19 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
+20 SET $PIECE(MSG,HLFS,12)=$PIECE(MSG,HLFS,12)_$GET(CTYCD)_"^"_$GET(CTY)
End DoDot:1
+21 KILL VAPA,CTY,CTYN,CTYCD,LRRACE
+22 IF $PIECE(MSG,HLFS,12)="~~~~~~~~"
SET $PIECE(MSG,HLFS,12)=""
+23 SET LRRACE=$$PTR2CODE^DGUTL4($PIECE(VADM(8),U))
+24 IF $LENGTH(MSG)>245
Begin DoDot:1
+25 SET $PIECE(MSG,HLFS,11)=VADM(12)
SET $PIECE(MSG,HLFS,23)=VADM(11)
End DoDot:1
+26 if $PIECE(MSG,HLFS,11)="""""~""""~0005~""""~""""~CDC"
SET $PIECE(MSG,HLFS,11)=""
+27 if $PIECE(MSG,HLFS,23)="""""~""""~0189~""""~""""~CDC"
SET $PIECE(MSG,HLFS,23)=""
+28 SET $PIECE(MSG,HLFS,11)=LRRACE_"~"_$PIECE(MSG,HLFS,11)
+29 IF $PIECE(MSG,HLFS,11)="~"
SET $PIECE(MSG,HLFS,11)=""
+30 SET LRPID=LRPID+1
SET LRCNT=LRCNT+1
SET ^TMP("HLS",$JOB,LRCNT)=$$UP^XLFSTR(MSG)
+31 SET ^TMP("LREPIREP",$JOB,LRCNT)=$$UP^XLFSTR(MSG)
+32 SET LRMSGSZ=LRMSGSZ+$LENGTH(MSG)
+33 KILL FLDS,VAEL,ICN,VAFPID,VADM
+34 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 LRICDN=$PIECE($GET(^AUPNVPOV(VIFN,0)),U)
+46 if LRICDN=""
QUIT
+47 NEW LRTMP
+48 IF $GET(LRCSYS)=""
SET LRCSYS=$$CSI^ICDEX(80,LRICDN)
+49 SET LRTMP=$$ICDDATA^ICDXCODE(LRCSYS,LRICDN,,)
+50 ;LR*5.2*552: correct undef error on LREPICSY
+51 ;Section BLD has different calls to determine LRCSYS and LRTMP.
+52 ;But the output generated is the same.
+53 SET LREPICSY=$SELECT($PIECE(LRTMP,U,20)=1:" I9",$PIECE(LRTMP,U,20)=30:"I10",1:"UNKNOWN CODE SYSTEM")
SET LRXSYS=$SELECT(LRCSYS=1:" I9",1:"I10")
+54 if LREPICSY'=LRXSYS
QUIT
+55 ;end LR*5.2*552
+56 if '$DATA(DGCNT)
SET DGCNT=1
+57 SET LRDATA="DG1"_HLFS_DGCNT_HLFS_LREPICSY_HLFS_$PIECE(LRTMP,U,2)
+58 SET LRDATA=LRDATA_LRCS_$PIECE(LRTMP,U,4)_LRCS_LREPICSY
+59 SET LRDATA=LRDATA_HLFS_$$HLDATE^HLFNC(LRENDT)_HLFS_HLFS_$SELECT($PIECE(^AUPNVPOV(VIFN,0),U,12)="P":"PR",1:"")
+60 SET ^TMP("HL7",$JOB,DGCNT)=$$UP^XLFSTR(LRDATA)
+61 SET DGCNT=DGCNT+1
End DoDot:2
End DoDot:1
DO MOVE^LREPI2
+62 KILL DGCNT,VIFN,LRICDN,LRICDIEN,LRDATA,LRVISIT
+63 if $GET(PTF)'>0
QUIT
+64 if '$DATA(^DGPT(PTF,0))
QUIT
+65 if $PIECE(^DGPT(PTF,0),U,6)'=3
QUIT
+66 SET IFN=PTF
DO DG11
+67 DO MOVE^LREPI2
+68 KILL PTF,Y,C,LRDATA,LRDTY,IFN,LRICDIEN,LRICDN,LROLLOC,VIFN
+69 QUIT
+70 ;
