- 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 Feb 18, 2025@23:40:06 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 ;
