BLRAG05C.m

BLRAG05C ; IHS/MSC/SAT - SUPPORT FOR LABORATORY ACCESSION GUI RPCS ; 17-Oct-2014 09:22 ; MKK

 ;;5.2;IHS LABORATORY;**1031,1034,1039**;NOV 01, 1997;Build 38

 Q

 ;

BILL ;-- this is where we ask billing type

 Q:$G(BLRRL("BILL TYPE"))'="T"

 D SETINS

 F BLRJK=1:1:$L(BLRAGDX,":") D

 .S BLRADX=0

 .; S BLRDXS=$$ICDDX^ICDCODE($P(BLRAGDX,":",BLRJK))

 .S BLRDXS=$$ICDDX^ICDEX($P(BLRAGDX,":",BLRJK),,,"I")     ; IHS/MSC/MKK - LR*5.2*1034

 .D SETDX

 Q

 ;

DX(PAT) ;-- get the diagnosis for billing

 K DIC,BLRDXS,BLRADX,BLRDXA

 ;

 S BLRADX=1

 ;

 ; S DIC="^ICD9("

 ; S DIC("S")="I '$P($G(^(0)),U,9)"

 ; S DIC(0)="AEMQZ",DIC("A")="What is the ICD Diagnosis code for billing: "

 ; D ^DIC

 ;

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034

 ; AICD 4.0 re-structured File 80.  There is no longer an INACTIVE FLAG.

 ; STATUS is now a multiple.  Note that STATUS=1 is ACTIVE; STATUS=0 is INACTIVE.

 ; This means the D ^DIC call will no longer work: have to use D ^DIR.

 NEW ICD10DT,ICD10PTR

 ;

 D ^XBFMK

 ;

 ; Try to use 80.4 to determine ICD-10 Date

 S ICD10PTR=+$$FIND1^DIC(80.4,,,"ICD-10-CM")

 S ICD10DT=+$P($$GET1^DIQ(80.4,ICD10PTR,"IMPLEMENTATION DATE","I"),".")

 S:ICD10DT<1 ICD10DT=3151001   ; If no ICD10DT, hard set to 10/1/2015.

 ;

 ; If Date >= ICD-10 date, just return ACTIVE ICD-9 & ICD-10 entries

 I $$DT^XLFDT>=ICD10DT S DIR("S")="I $P($G(^ICD9(+Y,66,+$O(^ICD9(+Y,66,""A""),-1),0)),""^"",2)"

 ;

 ; If Date < ICD-10 date, only ICD-9 AND ACTIVE entries are returned

 I $$DT^XLFDT<ICD10DT S DIR("S")="I +$G(^ICD9(+Y,1))<30&($P($G(^ICD9(+Y,66,+$O(^ICD9(+Y,66,""A""),-1),0)),""^"",2))"

 ;

 S DIR(0)="PO^80:AEMQZ"

 S DIR("A")="What is the ICD Diagnosis code for billing: "

 D ^DIR

 ; ----- END IHS/MSC/MKK - LR*5.2*1034

 ;

 I Y<0 D  Q

 . D ADDDX(BLRTSTDA)

 . K BLRADX

 ;

 ; S BLRDXS=$$ICDDX^ICDCODE(+Y)

 S BLRDXS=$$ICDDX^ICDEX(+Y,,,"I")       ; IHS/MSC/MKK - LR*5.2*1034

 I $G(BLRDXA(+Y)) D  G ENDDX

 . W !,"You have already selected this Diagnosis"

 S BLRDXA(+Y)=1

 S BLRDX(DXCNT)=BLRDXS

SETDX I '$G(BLRADX) D ADDDX(BLRTSTDA) Q

 ;S BLRRL(BLRTSTDA,"DX",DXCNT)=$P(BLRDXS,U,2)

 S BLRRL("DX",DXCNT)=$P(BLRDXS,U,2)

 S BLRRL("DX")=$P(BLRDXS,U,2)

 ;S BLRRL(BLRTSTDA,"DXE",DXCNT)=$P(BLRDXS,U,4)

 S DXCNT=DXCNT+1

ENDDX D DX(BLRRL("PAT"))

 Q

 ;

ADDDX(TSTDA) ;-- add the diagnosis to the test since it is not there, this happens when they want all dx for mult accessions

 N TDA

 S TDA=0 F  S TDA=$O(BLRDX(TDA)) Q:'TDA  D

 . N DXS

 . S DXS=$G(BLRDX(TDA))

 . S BLRRL(TSTDA,"DX",TDA)=$P(DXS,U,2)

 . S BLRRL(TSTDA,"DXE",TDA)=$P(DXS,U,4)

 . S BLRRL(TSTDA,"DX")=$P(DXS,U,2)  ;cmi/maw 01/20/2010

 . S BLRRL(TSTDA,"DXE")=$P(DXS,U,4)  ;cmi/maw 01/20/2010

 Q

 ;

SETINS I '$G(PAT) S PAT=DFN

 I $G(BLRRL(BLRTSTDA,"CDT")) S BLRRLCDT=BLRRL(BLRTSTDA,"CDT")

 ;D SEQINS(.AGINS,PAT,$G(BLRRLCDT))

 I 0&'$D(BLRSEQ(1)) D  Q

 . ; W !,"Patient Insurance has not been Sequenced, changing Bill Type to Patient"

 . S BLRRL("BILL TYPE")="Patient"

 . S BLRRL("INSCOV")=BLRRL("BILL TYPE")

 ;K AGINS

 ;M AGINS=BLRSEQ

 ;K BLRSEQ

 S BLRINS=1

 S BLRRL(BLRTSTDA,"INSE")=$P(BLRAGINS,U)

 S BLRRL("INSE")=$P(BLRAGINS,U)

 S BLRRL(BLRTSTDA,"INSI")=$P(BLRAGINS,U,2)

 I 0&'$G(BLRRL(BLRTSTDA,"INSI")) D  Q

 . ; W !,"The entry for "_$G(BLRRL("INSE"))_" for this patient does not have a valid pointer to the INSURER file, this needs to be fixed to proceed"

 . S BLRRL("BILL TYPE")="Patient"

 . S BLRRL("INSCOV")=BLRRL("BILL TYPE")

 S BLRRL(BLRTSTDA,"INSCOV")=$E($G(BLRRL("BILL TYPE")),1,1)

 S BLRRL(BLRTSTDA,"INSPH")=$P(BLRAGINS,U,7)

 S BLRRL(BLRTSTDA,"INSGRP")=$P(BLRAGINS,U,20)

 S BLRRL(BLRTSTDA,"INSREL")=$S($P(BLRAGINS,U,16):$P($G(^AUTTRLSH($P(BLRAGINS,U,16),0)),U),1:"")

 S BLRRL(BLRTSTDA,"INSRELE")=BLRRL(BLRTSTDA,"INSREL")

 I $G(BLRRL(BLRTSTDA,"INSREL"))]"" D

 . I BLRRL(BLRTSTDA,"INSREL")="SELF" S BLRRL(BLRTSTDA,"INSREL")=$S(BLRRL("RLE")["QUEST":2,1:1) Q

 . I BLRRL(BLRTSTDA,"INSREL")="SPOUSE" S BLRRL(BLRTSTDA,"INSREL")=$S(BLRRL("RLE")["QUEST":2,1:2),BLRRL(BLRTSTDA,"INSRELE")="SPOUSE" Q

 . I BLRRL(BLRTSTDA,"INSREL")="HUSBAND" S BLRRL(BLRTSTDA,"INSREL")=$S(BLRRL("RLE")["QUEST":2,1:2),BLRRL(BLRTSTDA,"INSRELE")="SPOUSE" Q

 . I BLRRL(BLRTSTDA,"INSREL")="WIFE" S BLRRL(BLRTSTDA,"INSREL")=$S(BLRRL("RLE")["QUEST":2,1:2),BLRRL(BLRTSTDA,"INSRELE")="SPOUSE" Q

 . S BLRRL(BLRTSTDA,"INSREL")=$S(BLRRL("RLE")["QUEST":8,1:3),BLRRL(BLRTSTDA,"INSRELE")="OTHER" Q

 I $G(BLRRL(BLRTSTDA,"INSREL"))="" S BLRRL(BLRTSTDA,"INSREL")=$S(BLRRL("RLE")["QUEST":1,1:1),BLRRL(BLRTSTDA,"INSRELE")="SELF"

 S BLRRL(BLRTSTDA,"INSPOL")=$P(BLRAGINS,U,9)

 S BLRRL(BLRTSTDA,"INSELG")=$P(BLRAGINS,U,5)

 S BLRRL(BLRTSTDA,"INSEXP")=$P(BLRAGINS,U,6)

 ; S BLRRL(BLRTSTDA,"INSPLN")=$S(BLRRL(BLRTSTDA,"INSE")["MEDICARE":"MC",BLRRL(BLRTSTDA,"INSE")["MEDICAID":"MD",1:"PI")

 S BLRRL(BLRTSTDA,"INSPLN")=$S($G(BLRRL(BLRTSTDA,"INSE"))["MEDICARE":"MC",$G(BLRRL(BLRTSTDA,"INSE"))["MEDICAID":"MD",1:"PI")     ; IHS/MSC/MKK - LR*5.2*1039

 ; S BLRRL(BLRTSTDA,"INSTYP")=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),2)),U)

 S BLRRL(BLRTSTDA,"INSTYP")=$P($G(^AUTNINS(+$G(BLRRL(BLRTSTDA,"INSI")),2)),U)  ; IHS/MSC/MKK - LR*5.2*1039

 I BLRRL(BLRTSTDA,"INSI")]"" D

 . ;S BLRRL(BLRTSTDA,"INSID")=$TR($P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),2)),U,10),"~")  ;cmi/maw 2/17/2009 changed to piece 10 external group name from external id 2

 . S BLRRL(BLRTSTDA,"INSID")=$TR($P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),2)),U,19),"~")  ;cmi/maw 2/17/2009 changed to piece 19 external ID 3

 . S BLRRL(BLRTSTDA,"INSCNME")=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),0)),U)  ;insurance company name

 . S BLRRL(BLRTSTDA,"INSADD")=$$INSADD(BLRRL(BLRTSTDA,"INSI"))

 . S BLRRL(BLRTSTDA,"INSADDE")=$TR($P(BLRRL(BLRTSTDA,"INSADD"),U),U," ")_"~"_$TR($P(BLRRL(BLRTSTDA,"INSADD"),U,3,99),U," ")

 . S BLRRL(BLRTSTDA,"INSPHO")=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),0)),U,6)

 . S BLRRL(BLRTSTDA,"INSTYP")=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),2)),U)

 S BLRRL(BLRTSTDA,"PATADD")=$$PATADD(PAT)

 S BLRRL(BLRTSTDA,"PATADDE")=$TR($P($$PATADD(BLRRL("PAT")),U),U," ")_"~"_$TR($P($$PATADD(BLRRL("PAT")),U,3,99),U," ")

 S BLRRL(BLRTSTDA,"INSEMP")=$$GET1^DIQ(2,PAT,.3111)

 S BLRRL(BLRTSTDA,"INSNOI")=$$HLNAME^XLFNAME($P(^DPT(PAT,0),U))

 S BLRRL(BLRTSTDA,"INSNOIE")=$P(^DPT(PAT,0),U)

 ;next set of lines for hl7 in1 segments

 D HL7

 S BLRRL(BLRTSTDA,"GT1PHI")=$P(BLRAGINS,U,7)

 I $E(BLRRL(BLRTSTDA,"GT1PHI"),1,1)="P" D  Q

 . S BLRRL(BLRTSTDA,"GT1NM")=$$HLNAME^XLFNAME($P(^AUPN3PPH($E(BLRRL(BLRTSTDA,"GT1PHI"),2,99),0),U))

 . S BLRRL(BLRTSTDA,"GT1ADD")=$$GT1ADD($E(BLRRL(BLRTSTDA,"GT1PHI"),2,99))

 . S BLRRL(BLRTSTDA,"GT1PHO")=$P($G(^AUPN3PPH($E(BLRRL(BLRTSTDA,"GT1PHI"),2,99),0)),U,14)

 . D INSTYP(BLRTSTDA)

 . S BLRRL(BLRTSTDA,"GT1ADDE")=$TR($P($G(BLRRL(BLRTSTDA,"GT1ADD")),U),U," ")_"~"_$TR($P($G(BLRRL(BLRTSTDA,"GT1ADD")),U,3,99),U," ")

 . S BLRRL(BLRTSTDA,"GT1NME")=$TR($G(BLRRL(BLRTSTDA,"GT1NM")),U," ")

 I BLRRL(BLRTSTDA,"GT1PHI") D

 . S BLRRL(BLRTSTDA,"GT1NM")=$$HLNAME^XLFNAME($P(^DPT(PAT,0),U))

 . S BLRRL(BLRTSTDA,"GT1ADD")=$$PATADD(PAT)

 . S BLRRL(BLRTSTDA,"GT1PHO")=$P($G(^DPT(PAT,.131)),U)

 I $G(BLRRL(BLRTSTDA,"GT1NM"))="" D

 . S BLRRL(BLRTSTDA,"GT1NM")=BLRRL(BLRTSTDA,"INSNOI")

 . S BLRRL(BLRTSTDA,"GT1ADD")=BLRRL(BLRTSTDA,"PATADD")

 D INSTYP(BLRTSTDA)

 S BLRRL(BLRTSTDA,"GT1ADDE")=$TR($P($G(BLRRL(BLRTSTDA,"GT1ADD")),U),U," ")_"~"_$TR($P($G(BLRRL(BLRTSTDA,"GT1ADD")),U,3,99),U," ")

 S BLRRL(BLRTSTDA,"GT1NME")=$TR($G(BLRRL(BLRTSTDA,"GT1NM")),U," ")

 Q

 ;

INSTYP(TDA) ;-- get insurance type

 I $G(BLRRL(TDA,"INSTYP"))]"" D

 . I BLRRL(TDA,"INSTYP")="H" S BLRRL(TDA,"INSTYP")="HMO"

 . I BLRRL(TDA,"INSTYP")="MD" S BLRRL(TDA,"INSTYP")="Medicare"

 . I BLRRL(TDA,"INSTYP")="M" S BLRRL(TDA,"INSTYP")="Medicare"

 . I BLRRL(TDA,"INSTYP")="P" S BLRRL(TDA,"INSTYP")="Private Insurance"

 . I BLRRL(TDA,"INSTYP")="D" S BLRRL(TDA,"INSTYP")="Medicaid"

 . I BLRRL(TDA,"INSTYP")="R" S BLRRL(TDA,"INSTYP")="Medicare"

 . I BLRRL(TDA,"INSTYP")="MH" S BLRRL(TDA,"INSTYP")="Medicaid"

 I $G(BLRRL(TDA,"INSTYP"))="" S BLRRL(TDA,"INSTYP")="Private Insurance"

 S BLRRL("INSTYP")=$G(BLRRL(TDA,"INSTYP"))

 Q

 ;

INSADD(INSI) ;-- return the insurance address is HL7 format

 N ADD,DATA,STR,CTY,ST,ZIP

 S DATA=$G(^AUTNINS(INSI,0))

 S STR=$P(DATA,U,2)

 S CTY=$P(DATA,U,3)

 S ST=$S($P(DATA,U,4):$P($G(^DIC(5,$P(DATA,U,4),0)),U,2),1:"")

 S ZIP=$P(DATA,U,5)

 S ADD=STR_U_U_CTY_U_ST_U_ZIP

 Q ADD

 ;

PATADD(PAT) ;-- return insured address

 N ADD,DATA,STR,CTY,ST,ZIP

 S DATA=$G(^DPT(PAT,.11))

 S STR=$P(DATA,U)

 S CTY=$P(DATA,U,4)

 S ST=$S($P(DATA,U,5):$P($G(^DIC(5,$P(DATA,U,5),0)),U,2),1:"")

 S ZIP=$P(DATA,U,6)

 S ADD=STR_U_U_CTY_U_ST_U_ZIP

 Q ADD

 ;

GT1ADD(PH) ;-- return insured address

 N ADD,DATA,STR,CTY,ST,ZIP

 S DATA=$G(^AUPN3PPH(PH,0))

 S STR=$P(DATA,U,9)

 S CTY=$P(DATA,U,11)

 S ST=$S($P(DATA,U,12):$P($G(^DIC(5,$P(DATA,U,12),0)),U,2),1:"")

 S ZIP=$P(DATA,U,13)

 S ADD=STR_U_U_CTY_U_ST_U_ZIP

 Q ADD

 ;

HL7 ;-- setup hl7 lines

 N HLDA

 S HLDA=0 F  S HLDA=$O(AGINS(HLDA)) Q:'HLDA  D

 . D HLSET(HLDA)

 Q

 ;

HLSET(BLRINS) ;-- setup hl7 variables

 S INSCNT=BLRINS

 S BLRRL(BLRTSTDA,"INSE",INSCNT)=$P(BLRAGINS,U)

 S BLRRL("INSE",INSCNT)=$P(BLRAGINS,U)

 S BLRRL(BLRTSTDA,"INSI",INSCNT)=$P(BLRAGINS,U,2)

 ;S BLRRL(BLRTSTDA,"INSCOV")=$P(BLRAGINS,U,4)

 S BLRRL(BLRTSTDA,"INSCOV",INSCNT)=$E($G(BLRRL("BILL TYPE")),1,1)

 S BLRRL(BLRTSTDA,"INSPH",INSCNT)=$P(BLRAGINS,U,7)

 S BLRRL(BLRTSTDA,"INSGRP",INSCNT)=$P(BLRAGINS,U,20)

 S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S($P(BLRAGINS,U,16):$P($G(^AUTTRLSH($P(BLRAGINS,U,16),0)),U),1:"")

 S BLRRL(BLRTSTDA,"INSRELE",INSCNT)=BLRRL(BLRTSTDA,"INSREL",INSCNT)

 I $G(BLRRL(BLRTSTDA,"INSREL",INSCNT))]"" D

 . I BLRRL(BLRTSTDA,"INSREL",INSCNT)="SELF" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":2,1:1) Q

 . I BLRRL(BLRTSTDA,"INSREL",INSCNT)="SPOUSE" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":2,1:2),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SPOUSE" Q

 . I BLRRL(BLRTSTDA,"INSREL",INSCNT)="HUSBAND" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":2,1:2),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SPOUSE" Q

 . I BLRRL(BLRTSTDA,"INSREL",INSCNT)="WIFE" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":2,1:2),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SPOUSE" Q

 . S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":8,1:3),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="OTHER" Q

 I $G(BLRRL(BLRTSTDA,"INSREL",INSCNT))="" S BLRRL(BLRTSTDA,"INSREL",INSCNT)=$S(BLRRL("RLE")["QUEST":1,1:1),BLRRL(BLRTSTDA,"INSRELE",INSCNT)="SELF"

 S BLRRL(BLRTSTDA,"INSPOL",INSCNT)=$P(BLRAGINS,U,9)

 S BLRRL(BLRTSTDA,"INSELG",INSCNT)=$P(BLRAGINS,U,5)

 S BLRRL(BLRTSTDA,"INSEXP",INSCNT)=$P(BLRAGINS,U,6)

 S BLRRL(BLRTSTDA,"INSPLN",INSCNT)=$S(BLRRL(BLRTSTDA,"INSE",INSCNT)["MEDICARE":"MC",BLRRL(BLRTSTDA,"INSE",INSCNT)["MEDICAID":"MD",1:"PI")

 ; S BLRRL(BLRTSTDA,"INSTYP",INSCNT)=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI",INSCNT),2)),U)

 S BLRRL(BLRTSTDA,"INSTYP",INSCNT)=$P($G(^AUTNINS(+$G(BLRRL(BLRTSTDA,"INSI",INSCNT)),2)),U)   ; IHS/MSC/MKK - LR*5.2*1039

 ; I BLRRL(BLRTSTDA,"INSI",INSCNT)]"" D

 I $G(BLRRL(BLRTSTDA,"INSI",INSCNT))]"" D   ; IHS/MSC/MKK - LR*5.2*1039

 . S BLRRL(BLRTSTDA,"INSID",INSCNT)=$TR($P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI",INSCNT),2)),U,19),"~")  ;cmi/maw 2/17/2009 changed to piece 10 external group name from external id 2

 . S BLRRL(BLRTSTDA,"INSCNME",INSCNT)=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI",INSCNT),0)),U)  ;insurance company name

 . S BLRRL(BLRTSTDA,"INSADD",INSCNT)=$$INSADD(BLRRL(BLRTSTDA,"INSI",INSCNT))

 . S BLRRL(BLRTSTDA,"INSADDE",INSCNT)=$TR($P(BLRRL(BLRTSTDA,"INSADD",INSCNT),U),U," ")_"~"_$TR($P(BLRRL(BLRTSTDA,"INSADD",INSCNT),U,3,99),U," ")

 . S BLRRL(BLRTSTDA,"INSPHO",INSCNT)=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),0)),U,6)

 . S BLRRL(BLRTSTDA,"INSTYP",INSCNT)=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),2)),U)

 S BLRRL(BLRTSTDA,"INSEMP",INSCNT)=$$GET1^DIQ(2,PAT,.3111)

 S BLRRL(BLRTSTDA,"INSNOI",INSCNT)=$$HLNAME^XLFNAME($P(^DPT(PAT,0),U))

 S BLRRL(BLRTSTDA,"INSNOIE",INSCNT)=$P(^DPT(PAT,0),U)

 S INSCNT=INSCNT+1

 ;end of hl7 lines

 Q

BLRAG05C  ; IHS/MSC/SAT - SUPPORT FOR LABORATORY ACCESSION GUI RPCS ; 17-Oct-2014 09:22 ; MKK

 +1       ;;5.2;IHS LABORATORY;**1031,1034,1039**;NOV 01, 1997;Build 38

 +2        QUIT 

 +3       ;

BILL      ;-- this is where we ask billing type

 +1        IF $GET(BLRRL("BILL TYPE"))'="T"

               QUIT 

 +2        DO SETINS

 +3        FOR BLRJK=1:1:$LENGTH(BLRAGDX,":")

               Begin DoDot:1

 +4                SET BLRADX=0

 +5       ; S BLRDXS=$$ICDDX^ICDCODE($P(BLRAGDX,":",BLRJK))

 +6       ; IHS/MSC/MKK - LR*5.2*1034

                   SET BLRDXS=$$ICDDX^ICDEX($PIECE(BLRAGDX,":",BLRJK),,,"I")

 +7                DO SETDX

               End DoDot:1

 +8        QUIT 

 +9       ;

DX(PAT)   ;-- get the diagnosis for billing

 +1        KILL DIC,BLRDXS,BLRADX,BLRDXA

 +2       ;

 +3        SET BLRADX=1

 +4       ;

 +5       ; S DIC="^ICD9("

 +6       ; S DIC("S")="I '$P($G(^(0)),U,9)"

 +7       ; S DIC(0)="AEMQZ",DIC("A")="What is the ICD Diagnosis code for billing: "

 +8       ; D ^DIC

 +9       ;

 +10      ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034

 +11      ; AICD 4.0 re-structured File 80.  There is no longer an INACTIVE FLAG.

 +12      ; STATUS is now a multiple.  Note that STATUS=1 is ACTIVE; STATUS=0 is INACTIVE.

 +13      ; This means the D ^DIC call will no longer work: have to use D ^DIR.

 +14       NEW ICD10DT,ICD10PTR

 +15      ;

 +16       DO ^XBFMK

 +17      ;

 +18      ; Try to use 80.4 to determine ICD-10 Date

 +19       SET ICD10PTR=+$$FIND1^DIC(80.4,,,"ICD-10-CM")

 +20       SET ICD10DT=+$PIECE($$GET1^DIQ(80.4,ICD10PTR,"IMPLEMENTATION DATE","I"),".")

 +21      ; If no ICD10DT, hard set to 10/1/2015.

           IF ICD10DT<1

               SET ICD10DT=3151001

 +22      ;

 +23      ; If Date >= ICD-10 date, just return ACTIVE ICD-9 & ICD-10 entries

 +24       IF $$DT^XLFDT>=ICD10DT

               SET DIR("S")="I $P($G(^ICD9(+Y,66,+$O(^ICD9(+Y,66,""A""),-1),0)),""^"",2)"

 +25      ;

 +26      ; If Date < ICD-10 date, only ICD-9 AND ACTIVE entries are returned

 +27       IF $$DT^XLFDT<ICD10DT

               SET DIR("S")="I +$G(^ICD9(+Y,1))<30&($P($G(^ICD9(+Y,66,+$O(^ICD9(+Y,66,""A""),-1),0)),""^"",2))"

 +28      ;

 +29       SET DIR(0)="PO^80:AEMQZ"

 +30       SET DIR("A")="What is the ICD Diagnosis code for billing: "

 +31       DO ^DIR

 +32      ; ----- END IHS/MSC/MKK - LR*5.2*1034

 +33      ;

 +34       IF Y<0

               Begin DoDot:1

 +35               DO ADDDX(BLRTSTDA)

 +36               KILL BLRADX

               End DoDot:1

               QUIT 

 +37      ;

 +38      ; S BLRDXS=$$ICDDX^ICDCODE(+Y)

 +39      ; IHS/MSC/MKK - LR*5.2*1034

           SET BLRDXS=$$ICDDX^ICDEX(+Y,,,"I")

 +40       IF $GET(BLRDXA(+Y))

               Begin DoDot:1

 +41               WRITE !,"You have already selected this Diagnosis"

               End DoDot:1

               GOTO ENDDX

 +42       SET BLRDXA(+Y)=1

 +43       SET BLRDX(DXCNT)=BLRDXS

SETDX      IF '$GET(BLRADX)

               DO ADDDX(BLRTSTDA)

               QUIT 

 +1       ;S BLRRL(BLRTSTDA,"DX",DXCNT)=$P(BLRDXS,U,2)

 +2        SET BLRRL("DX",DXCNT)=$PIECE(BLRDXS,U,2)

 +3        SET BLRRL("DX")=$PIECE(BLRDXS,U,2)

 +4       ;S BLRRL(BLRTSTDA,"DXE",DXCNT)=$P(BLRDXS,U,4)

 +5        SET DXCNT=DXCNT+1

ENDDX      DO DX(BLRRL("PAT"))

 +1        QUIT 

 +2       ;

ADDDX(TSTDA) ;-- add the diagnosis to the test since it is not there, this happens when they want all dx for mult accessions

 +1        NEW TDA

 +2        SET TDA=0

           FOR 

               SET TDA=$ORDER(BLRDX(TDA))

               IF 'TDA

                   QUIT 

               Begin DoDot:1

 +3                NEW DXS

 +4                SET DXS=$GET(BLRDX(TDA))

 +5                SET BLRRL(TSTDA,"DX",TDA)=$PIECE(DXS,U,2)

 +6                SET BLRRL(TSTDA,"DXE",TDA)=$PIECE(DXS,U,4)

 +7       ;cmi/maw 01/20/2010

                   SET BLRRL(TSTDA,"DX")=$PIECE(DXS,U,2)

 +8       ;cmi/maw 01/20/2010

                   SET BLRRL(TSTDA,"DXE")=$PIECE(DXS,U,4)

               End DoDot:1

 +9        QUIT 

 +10      ;

SETINS     IF '$GET(PAT)

               SET PAT=DFN

 +1        IF $GET(BLRRL(BLRTSTDA,"CDT"))

               SET BLRRLCDT=BLRRL(BLRTSTDA,"CDT")

 +2       ;D SEQINS(.AGINS,PAT,$G(BLRRLCDT))

 +3        IF 0&'$DATA(BLRSEQ(1))

               Begin DoDot:1

 +4       ; W !,"Patient Insurance has not been Sequenced, changing Bill Type to Patient"

 +5                SET BLRRL("BILL TYPE")="Patient"

 +6                SET BLRRL("INSCOV")=BLRRL("BILL TYPE")

               End DoDot:1

               QUIT 

 +7       ;K AGINS

 +8       ;M AGINS=BLRSEQ

 +9       ;K BLRSEQ

 +10       SET BLRINS=1

 +11       SET BLRRL(BLRTSTDA,"INSE")=$PIECE(BLRAGINS,U)

 +12       SET BLRRL("INSE")=$PIECE(BLRAGINS,U)

 +13       SET BLRRL(BLRTSTDA,"INSI")=$PIECE(BLRAGINS,U,2)

 +14       IF 0&'$GET(BLRRL(BLRTSTDA,"INSI"))

               Begin DoDot:1

 +15      ; W !,"The entry for "_$G(BLRRL("INSE"))_" for this patient does not have a valid pointer to the INSURER file, this needs to be fixed to proceed"

 +16               SET BLRRL("BILL TYPE")="Patient"

 +17               SET BLRRL("INSCOV")=BLRRL("BILL TYPE")

               End DoDot:1

               QUIT 

 +18       SET BLRRL(BLRTSTDA,"INSCOV")=$EXTRACT($GET(BLRRL("BILL TYPE")),1,1)

 +19       SET BLRRL(BLRTSTDA,"INSPH")=$PIECE(BLRAGINS,U,7)

 +20       SET BLRRL(BLRTSTDA,"INSGRP")=$PIECE(BLRAGINS,U,20)

 +21       SET BLRRL(BLRTSTDA,"INSREL")=$SELECT($PIECE(BLRAGINS,U,16):$PIECE($GET(^AUTTRLSH($PIECE(BLRAGINS,U,16),0)),U),1:"")

 +22       SET BLRRL(BLRTSTDA,"INSRELE")=BLRRL(BLRTSTDA,"INSREL")

 +23       IF $GET(BLRRL(BLRTSTDA,"INSREL"))]""

               Begin DoDot:1

 +24               IF BLRRL(BLRTSTDA,"INSREL")="SELF"

                       SET BLRRL(BLRTSTDA,"INSREL")=$SELECT(BLRRL("RLE")["QUEST":2,1:1)

                       QUIT 

 +25               IF BLRRL(BLRTSTDA,"INSREL")="SPOUSE"

                       SET BLRRL(BLRTSTDA,"INSREL")=$SELECT(BLRRL("RLE")["QUEST":2,1:2)

                       SET BLRRL(BLRTSTDA,"INSRELE")="SPOUSE"

                       QUIT 

 +26               IF BLRRL(BLRTSTDA,"INSREL")="HUSBAND"

                       SET BLRRL(BLRTSTDA,"INSREL")=$SELECT(BLRRL("RLE")["QUEST":2,1:2)

                       SET BLRRL(BLRTSTDA,"INSRELE")="SPOUSE"

                       QUIT 

 +27               IF BLRRL(BLRTSTDA,"INSREL")="WIFE"

                       SET BLRRL(BLRTSTDA,"INSREL")=$SELECT(BLRRL("RLE")["QUEST":2,1:2)

                       SET BLRRL(BLRTSTDA,"INSRELE")="SPOUSE"

                       QUIT 

 +28               SET BLRRL(BLRTSTDA,"INSREL")=$SELECT(BLRRL("RLE")["QUEST":8,1:3)

                   SET BLRRL(BLRTSTDA,"INSRELE")="OTHER"

                   QUIT 

               End DoDot:1

 +29       IF $GET(BLRRL(BLRTSTDA,"INSREL"))=""

               SET BLRRL(BLRTSTDA,"INSREL")=$SELECT(BLRRL("RLE")["QUEST":1,1:1)

               SET BLRRL(BLRTSTDA,"INSRELE")="SELF"

 +30       SET BLRRL(BLRTSTDA,"INSPOL")=$PIECE(BLRAGINS,U,9)

 +31       SET BLRRL(BLRTSTDA,"INSELG")=$PIECE(BLRAGINS,U,5)

 +32       SET BLRRL(BLRTSTDA,"INSEXP")=$PIECE(BLRAGINS,U,6)

 +33      ; S BLRRL(BLRTSTDA,"INSPLN")=$S(BLRRL(BLRTSTDA,"INSE")["MEDICARE":"MC",BLRRL(BLRTSTDA,"INSE")["MEDICAID":"MD",1:"PI")

 +34      ; IHS/MSC/MKK - LR*5.2*1039

           SET BLRRL(BLRTSTDA,"INSPLN")=$SELECT($GET(BLRRL(BLRTSTDA,"INSE"))["MEDICARE":"MC",$GET(BLRRL(BLRTSTDA,"INSE"))["MEDICAID":"MD",1:"PI")

 +35      ; S BLRRL(BLRTSTDA,"INSTYP")=$P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),2)),U)

 +36      ; IHS/MSC/MKK - LR*5.2*1039

           SET BLRRL(BLRTSTDA,"INSTYP")=$PIECE($GET(^AUTNINS(+$GET(BLRRL(BLRTSTDA,"INSI")),2)),U)

 +37       IF BLRRL(BLRTSTDA,"INSI")]""

               Begin DoDot:1

 +38      ;S BLRRL(BLRTSTDA,"INSID")=$TR($P($G(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),2)),U,10),"~")  ;cmi/maw 2/17/2009 changed to piece 10 external group name from external id 2

 +39      ;cmi/maw 2/17/2009 changed to piece 19 external ID 3

                   SET BLRRL(BLRTSTDA,"INSID")=$TRANSLATE($PIECE($GET(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),2)),U,19),"~")

 +40      ;insurance company name

                   SET BLRRL(BLRTSTDA,"INSCNME")=$PIECE($GET(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),0)),U)

 +41               SET BLRRL(BLRTSTDA,"INSADD")=$$INSADD(BLRRL(BLRTSTDA,"INSI"))

 +42               SET BLRRL(BLRTSTDA,"INSADDE")=$TRANSLATE($PIECE(BLRRL(BLRTSTDA,"INSADD"),U),U," ")_"~"_$TRANSLATE($PIECE(BLRRL(BLRTSTDA,"INSADD"),U,3,99),U," ")

 +43               SET BLRRL(BLRTSTDA,"INSPHO")=$PIECE($GET(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),0)),U,6)

 +44               SET BLRRL(BLRTSTDA,"INSTYP")=$PIECE($GET(^AUTNINS(BLRRL(BLRTSTDA,"INSI"),2)),U)

               End DoDot:1

 +45       SET BLRRL(BLRTSTDA,"PATADD")=$$PATADD(PAT)

 +46       SET BLRRL(BLRTSTDA,"PATADDE")=$TRANSLATE($PIECE($$PATADD(BLRRL("PAT")),U),U," ")_"~"_$TRANSLATE($PIECE($$PATADD(BLRRL("PAT")),U,3,99),U," ")

 +47       SET BLRRL(BLRTSTDA,"INSEMP")=$$GET1^DIQ(2,PAT,.3111)

 +48       SET BLRRL(BLRTSTDA,"INSNOI")=$$HLNAME^XLFNAME($PIECE(^DPT(PAT,0),U))

 +49       SET BLRRL(BLRTSTDA,"INSNOIE")=$PIECE(^DPT(PAT,0),U)

 +50      ;next set of lines for hl7 in1 segments

 +51       DO HL7

 +52       SET BLRRL(BLRTSTDA,"GT1PHI")=$PIECE(BLRAGINS,U,7)

 +53       IF $EXTRACT(BLRRL(BLRTSTDA,"GT1PHI"),1,1)="P"

               Begin DoDot:1

 +54               SET BLRRL(BLRTSTDA,"GT1NM")=$$HLNAME^XLFNAME($PIECE(^AUPN3PPH($EXTRACT(BLRRL(BLRTSTDA,"GT1PHI"),2,99),0),U))

 +55               SET BLRRL(BLRTSTDA,"GT1ADD")=$$GT1ADD($EXTRACT(BLRRL(BLRTSTDA,"GT1PHI"),2,99))

 +56               SET BLRRL(BLRTSTDA,"GT1PHO")=$PIECE($GET(^AUPN3PPH($EXTRACT(BLRRL(BLRTSTDA,"GT1PHI"),2,99),0)),U,14)

 +57               DO INSTYP(BLRTSTDA)

 +58               SET BLRRL(BLRTSTDA,"GT1ADDE")=$TRANSLATE($PIECE($GET(BLRRL(BLRTSTDA,"GT1ADD")),U),U," ")_"~"_$TRANSLATE($PIECE($GET(BLRRL(BLRTSTDA,"GT1ADD")),U,3,99),U," ")

 +59               SET BLRRL(BLRTSTDA,"GT1NME")=$TRANSLATE($GET(BLRRL(BLRTSTDA,"GT1NM")),U," ")

               End DoDot:1

               QUIT 

 +60       IF BLRRL(BLRTSTDA,"GT1PHI")

               Begin DoDot:1

 +61               SET BLRRL(BLRTSTDA,"GT1NM")=$$HLNAME^XLFNAME($PIECE(^DPT(PAT,0),U))

 +62               SET BLRRL(BLRTSTDA,"GT1ADD")=$$PATADD(PAT)

 +63               SET BLRRL(BLRTSTDA,"GT1PHO")=$PIECE($GET(^DPT(PAT,.131)),U)

               End DoDot:1

 +64       IF $GET(BLRRL(BLRTSTDA,"GT1NM"))=""

               Begin DoDot:1

 +65               SET BLRRL(BLRTSTDA,"GT1NM")=BLRRL(BLRTSTDA,"INSNOI")

 +66               SET BLRRL(BLRTSTDA,"GT1ADD")=BLRRL(BLRTSTDA,"PATADD")

               End DoDot:1

 +67       DO INSTYP(BLRTSTDA)

 +68       SET BLRRL(BLRTSTDA,"GT1ADDE")=$TRANSLATE($PIECE($GET(BLRRL(BLRTSTDA,"GT1ADD")),U),U," ")_"~"_$TRANSLATE($PIECE($GET(BLRRL(BLRTSTDA,"GT1ADD")),U,3,99),U," ")

 +69       SET BLRRL(BLRTSTDA,"GT1NME")=$TRANSLATE($GET(BLRRL(BLRTSTDA,"GT1NM")),U," ")

 +70       QUIT 

 +71      ;

INSTYP(TDA) ;-- get insurance type

 +1        IF $GET(BLRRL(TDA,"INSTYP"))]""

               Begin DoDot:1

 +2                IF BLRRL(TDA,"INSTYP")="H"

                       SET BLRRL(TDA,"INSTYP")="HMO"

 +3                IF BLRRL(TDA,"INSTYP")="MD"

                       SET BLRRL(TDA,"INSTYP")="Medicare"

 +4                IF BLRRL(TDA,"INSTYP")="M"

                       SET BLRRL(TDA,"INSTYP")="Medicare"

 +5                IF BLRRL(TDA,"INSTYP")="P"

                       SET BLRRL(TDA,"INSTYP")="Private Insurance"

 +6                IF BLRRL(TDA,"INSTYP")="D"

                       SET BLRRL(TDA,"INSTYP")="Medicaid"

 +7                IF BLRRL(TDA,"INSTYP")="R"

                       SET BLRRL(TDA,"INSTYP")="Medicare"

 +8                IF BLRRL(TDA,"INSTYP")="MH"

                       SET BLRRL(TDA,"INSTYP")="Medicaid"

               End DoDot:1

 +9        IF $GET(BLRRL(TDA,"INSTYP"))=""

               SET BLRRL(TDA,"INSTYP")="Private Insurance"

 +10       SET BLRRL("INSTYP")=$GET(BLRRL(TDA,"INSTYP"))

 +11       QUIT 

 +12      ;

INSADD(INSI) ;-- return the insurance address is HL7 format

 +1        NEW ADD,DATA,STR,CTY,ST,ZIP

 +2        SET DATA=$GET(^AUTNINS(INSI,0))

 +3        SET STR=$PIECE(DATA,U,2)

 +4        SET CTY=$PIECE(DATA,U,3)

 +5        SET ST=$SELECT($PIECE(DATA,U,4):$PIECE($GET(^DIC(5,$PIECE(DATA,U,4),0)),U,2),1:"")

 +6        SET ZIP=$PIECE(DATA,U,5)

 +7        SET ADD=STR_U_U_CTY_U_ST_U_ZIP

 +8        QUIT ADD

 +9       ;

PATADD(PAT) ;-- return insured address

 +1        NEW ADD,DATA,STR,CTY,ST,ZIP

 +2        SET DATA=$GET(^DPT(PAT,.11))

 +3        SET STR=$PIECE(DATA,U)

 +4        SET CTY=$PIECE(DATA,U,4)

 +5        SET ST=$SELECT($PIECE(DATA,U,5):$PIECE($GET(^DIC(5,$PIECE(DATA,U,5),0)),U,2),1:"")

 +6        SET ZIP=$PIECE(DATA,U,6)

 +7        SET ADD=STR_U_U_CTY_U_ST_U_ZIP

 +8        QUIT ADD

 +9       ;

GT1ADD(PH) ;-- return insured address

 +1        NEW ADD,DATA,STR,CTY,ST,ZIP

 +2        SET DATA=$GET(^AUPN3PPH(PH,0))

 +3        SET STR=$PIECE(DATA,U,9)

 +4        SET CTY=$PIECE(DATA,U,11)

 +5        SET ST=$SELECT($PIECE(DATA,U,12):$PIECE($GET(^DIC(5,$PIECE(DATA,U,12),0)),U,2),1:"")

 +6        SET ZIP=$PIECE(DATA,U,13)

 +7        SET ADD=STR_U_U_CTY_U_ST_U_ZIP

 +8        QUIT ADD

 +9       ;

HL7       ;-- setup hl7 lines

 +1        NEW HLDA

 +2        SET HLDA=0

           FOR 

               SET HLDA=$ORDER(AGINS(HLDA))

               IF 'HLDA

                   QUIT 

               Begin DoDot:1

 +3                DO HLSET(HLDA)

               End DoDot:1

 +4        QUIT 

 +5       ;

HLSET(BLRINS) ;-- setup hl7 variables

 +1        SET INSCNT=BLRINS

 +2        SET BLRRL(BLRTSTDA,"INSE",INSCNT)=$PIECE(BLRAGINS,U)

 +3        SET BLRRL("INSE",INSCNT)=$PIECE(BLRAGINS,U)

 +4        SET BLRRL(BLRTSTDA,"INSI",INSCNT)=$PIECE(BLRAGINS,U,2)

 +5       ;S BLRRL(BLRTSTDA,"INSCOV")=$P(BLRAGINS,U,4)