LA7VQINS ;VA/DALOI/DLR - LAB ORM (Order) message builder ; 17-Oct-2014 09:22 ; MKK
;;5.2;AUTOMATED LAB INSTRUMENTS;**1027,1033,1034,1042**;NOV 01, 1997;Build 9
;
;
INS(STORE,OR) ;Handle insurance
N ORI,BDA,STR,IIEN,IPIEN,IEIEN
S ORI=$O(^BLRRLO("B",OR,0))
I 'ORI S ORI=$O(^BLRRLO("ACC",OR,0))
Q:'ORI
I $P($G(^BLRRLO(ORI,0)),U,5)="P"!($P($G(^BLRRLO(ORI,0)),U,5)="C") D Q
. S CNT=CNT+1
. S IN1(48)=$S($P($G(^BLRRLO(ORI,0)),U,5)="P":"P",1:"C")
. D IN1(.IN1)
S BDA=0 F S BDA=$O(^BLRRLO(ORI,2,BDA)) Q:'BDA D
. S STR=$G(^BLRRLO(ORI,2,BDA,0))
. S IIEN=$P($P(STR,"~",11),",")
. I $P(STR,"~",10)="D" D Q
.. S IEIEN=$P($P(STR,"~",11),",",3)
.. D MCD(IIEN,STORE)
. I $P(STR,"~",10)="M" D Q
.. S IEIEN=$P($P(STR,"~",11),",",3)
.. D MCR(IIEN,IEIEN,STORE)
. I $P(STR,"~",10)="R",$E($P(STR,"~",7),1,1)="M" D Q
.. S IEIEN=$P($P(STR,"~",11),",",3)
.. D MCR(IIEN,IEIEN,STORE)
. I $E($P(STR,"~",7),1,1)="R" D Q ;cmi/maw 05/05/2018 p1042
.. S IEIEN=$P($P(STR,"~",11),",",3)
.. D RR(IIEN,IEIEN,STORE)
. I $P(STR,"~",10)="P" D
.. S IPIEN=$E($P(STR,"~",7),2,99)
.. S IEIEN=$P($P(STR,"~",11),",",3)
.. D PI(IPIEN,IEIEN,STORE)
Q
;
MCR(IEN,PE,ST) ;medicare.
S CNT=$G(CNT)+1
N IENS S IENS=IEN_","
D GETS^DIQ(9000003,IENS,"*","EI","IN")
S EINS=PE_","_IENS D GETS^DIQ(9000003.11,EINS,"*","EI","IN")
S INS=$G(IN(9000003,IENS,.02,"I"))_","
D GETS^DIQ(9999999.18,INS,"*","EI","IN")
S IN1(4)=$G(IN(9999999.18,INS,.66,"E"))
S IN1(5)=$G(IN(9999999.18,INS,.01,"E"))
S IN1(7)=$G(IN(9999999.18,INS,.06,"E"))
S IN1(16)="MC"
S IN1(18)=1
S IN1(17)=$$HLNAME^HLFNC($G(IN(9000003,IENS,2101,"E")),LA7ECH)
I IN1(17)="" S IN1(17)=$$HLNAME^HLFNC($G(IN(9000003,IENS,.01,"E")),LA7ECH)
;S IN1(37)=$G(IN(9000003,IENS,.03,"I"))_$G(IN(9000003,IENS,.04,"E")) ;cmi/maw p1042
S IN1(37)=$$GETMCR^AGUTL(IEN,DT) ;cmi/maw 05/08/2018 p1042 NMCI
S IN1(4)=$G(IN(9999999.18,INS,.66,"E"))
S IN1(9)=$G(IN(9000003.11,IENS,.11,"I"))
S IN1(9)=$S($G(IN1(9)):$P($G(^AUTNEGRP(IN1(9),0)),U,2),1:"")
S IN1(10)=$G(IN(9000003,IENS,.06,"E"))
S IN1(6)=$$ADD()
S IN1(20)=$$ADD(2)
S IN1(48)=$S($G(ORD):$P($$ACCT^LA7VQINS(ORD),U,4),1:"")
Q:'ST
D IN1(.IN1)
Q
;
MCD(IEN,ST) ;medicaid
S CNT=$G(CNT)+1
N IENS
S IENS=IEN_","
D GETS^DIQ(9000004,IENS,"*","EI","IN")
S INS=$G(IN(9000004,IENS,.02,"I"))_","
D GETS^DIQ(9999999.18,INS,"*","EI","IN")
S IN1(4)=$G(IN(9999999.18,INS,.66,"E"))
S IN1(5)=$G(IN(9999999.18,INS,.01,"E"))
S IN1(6)=$$ADD()
S IN1(7)=$G(IN(9999999.18,INS,.06,"E"))
S IN1(16)="MD"
S IN1(17)=$$HLNAME^HLFNC($G(IN(9000004,IENS,.05,"E")),LA7ECH)
S IN1(18)=1
S PE=$G(IN(9000004,IENS,.06,"I"))
S IN1(18)=+$P($G(^AUTTRLSH(+PE,0)),U,3)
S IN1("18E")=$P($G(^AUTTRLSH(+PE,0)),U)
S IN1(18)=$S(IN1(18)=2:2,IN1(18)=1:1,IN1(18)=0:1,1:8)
S IN1(37)=$G(IN(9000004,IENS,.03,"I"))
S IN1(9)=$G(IN(9000004,IENS,.17,"I"))
S IN1(9)=$S($G(IN1(9)):$P($G(^AUTNEGRP(IN1(9),0)),U,2),1:"")
S IN1(48)=$P($$ACCT^LA7VQINS(ORD),U,4)
S IN1(20)=$$ADD(2)
Q:'ST
D IN1(.IN1)
Q
;
PI(IEN,PE,ST) ;private insurance
S CNT=$G(CNT)+1
N IENS
S IENS=IEN_","
D GETS^DIQ(9000003.1,IENS,"*","EI","IN")
S INS=$G(IN(9000003.1,IENS,.03,"I"))_","
D GETS^DIQ(9999999.18,INS,"*","EI","IN")
S IN1(4)=$G(IN(9999999.18,INS,.66,"E"))
S IN1(5)=$G(IN(9999999.18,INS,.01,"E"))
S IN1(6)=$$ADD()
S IN1(7)=$G(IN(9999999.18,INS,.06,"E"))
S IN1(9)=$G(IN(9000003.1,IENS,.06,"I"))
S IN1(9)=$S($G(IN1(9)):$P($G(^AUTNEGRP(IN1(9),0)),U,2),1:"")
S IN1(10)=$G(IN(9000003.1,IENS,.06,"E"))
S IN1(16)=$S($G(IN(9999999.18,INS,.21,"I"))="H":"HM",1:"PI")
S IN1(17)=$$HLNAME^HLFNC($G(IN(9000003.1,IENS,.01,"E")),LA7ECH)
;S IN1(18)=$G(IN(9000006.11,IENS,.05,"E"))
S IN1(20)=$$ADD(9000003.1)
S IN1(37)=$G(IN(9000003.1,IENS,.04,"E"))
S IN1(48)=$S($G(ORD):$P($$ACCT^LA7VQINS(ORD),U,4),1:"")
S IN1(18)=+$P($G(^AUTTRLSH(+$P($G(^AUPNPRVT(DFN,11,+PE,0)),U,5),0)),U,3)
S IN1(18)=$S(IN1(18)=2:2,IN1(18)=1:1,IN1(18)=0:1,1:8)
S IN1("18E")=$S(IN1(18)=1:"SELF",IN1(18)=2:"SPOUSE",1:"OTHER") ;$P($G(^AUTTRLSH(+$P($G(^AUPNPRVT(DFN,11,+PE,0)),U,5),0)),U)
Q:'ST
D IN1(.IN1)
Q
;
WC(INS,IEN,ST) ;-- workmans comp
K DFNS
S CNT=$G(CNT)+1
N IENS
S IENS=IEN_","
S IN=$P(IEN,",")_","
D GETS^DIQ(9000042,IN,"*","EI","IN")
D GETS^DIQ(9000042.11,IENS,"*","EI","IN")
S INS=INS_","
S DFNS=DFN_","
D GETS^DIQ(9999999.18,INS,"*","EI","IN")
D GETS^DIQ(2,DFNS,".111;.112;.114;.115;.116","EI","IN")
S IN1(4)=$G(IN(9999999.18,INS,.66,"E"))
S IN1(5)=$G(IN(9999999.18,INS,.01,"E"))
S IN1(6)=$$ADD()
S IN1(7)=$G(IN(9999999.18,INS,.06,"E"))
S IN1(9)=$G(IN(9000042.11,IENS,.12,"I"))
S IN1(9)=$S($G(IN1(9)):$P($G(^AUTNEGRP(IN1(9),0)),U,2),1:"")
S IN1(10)=$G(IN(9000042.11,IENS,.12,"E"))
S IN1(16)=$S($G(IN(9999999.18,INS,.21,"I"))="H":"HM",1:"PI")
S IN1(17)=$$HLNAME^HLFNC($G(IN(9000042,IN,.01,"E")),LA7ECH)
;S IN1(18)=$G(IN(9000006.11,IENS,.05,"E"))
S IN1(20)=$$ADD(2)
S IN1(37)=$G(IN(9000042.11,IENS,.04,"E"))
S IN1(48)=$S($G(ORD):$P($$ACCT^LA7VQINS(ORD),U,4),1:"")
;S IN1(18)=+$P($G(^AUTTRLSH(+$P($G(^AUPNPRVT(DFN,11,+PE,0)),U,5),0)),U,3)
S IN1(18)=1
S IN1("18E")=$S(IN1(18)=1:"SELF",IN1(18)=2:"SPOUSE",1:"OTHER") ;$P($G(^AUTTRLSH(+$P($G(^AUPNPRVT(DFN,11,+PE,0)),U,5),0)),U)
K DFNS
Q:'ST
D IN1(.IN1)
Q
;
RR(IEN,PE,ST) ;-- get railroad insurance
S CNT=$G(CNT)+1
N IENS S IENS=IEN_","
D GETS^DIQ(9000005,IENS,"*","EI","IN")
S EINS=PE_","_IENS D GETS^DIQ(9000005.11,EINS,"*","EI","IN")
S INS=$G(IN(9000005,IENS,.02,"I"))_","
D GETS^DIQ(9999999.18,INS,"*","EI","IN")
S IN1(4)=$G(IN(9999999.18,INS,.66,"E"))
S IN1(5)=$G(IN(9999999.18,INS,.01,"E"))
S IN1(7)=$G(IN(9999999.18,INS,.06,"E"))
S IN1(16)="RR"
S IN1(18)=1
S IN1(17)=$$HLNAME^HLFNC($G(IN(9000005,IENS,2101,"E")),LA7ECH)
I IN1(17)="" S IN1(17)=$$HLNAME^HLFNC($G(IN(9000005,IENS,.01,"E")),LA7ECH)
;S IN1(37)=$G(IN(9000003,IENS,.03,"I"))_$G(IN(9000003,IENS,.04,"E")) ;cmi/maw p1042
S IN1(37)=$$GETRRE^AGUTL(IEN,DT) ;cmi/maw 05/08/2018 p1042 NMCI
S IN1(4)=$G(IN(9999999.18,INS,.66,"E"))
S IN1(9)=$G(IN(9000005.11,IENS,.11,"I"))
S IN1(9)=$S($G(IN1(9)):$P($G(^AUTNEGRP(IN1(9),0)),U,2),1:"")
S IN1(10)=$G(IN(9000005,IENS,.06,"E"))
S IN1(6)=$$ADD()
S IN1(20)=$$ADD(2)
S IN1(48)=$S($G(ORD):$P($$ACCT^LA7VQINS(ORD),U,4),1:"")
Q:'ST
D IN1(.IN1)
Q
;
ADD(FILE) ;
;set address component
I '$G(FILE) S FILE=9999999.18
N LINE S LINE=".02^999^.03^.04^.05"
I FILE[3 S LINE=".09^999^.11^.12^.13"
I FILE=2 S LINE=".111^.112^.114^.115^.116"
N X,I S X=""
F I=1:1:5 S X=X_$G(IN(FILE,$S(FILE[3:IENS,1:INS),$P(LINE,U,I),"E"))_$E(LA7ECH)
S $P(X,$E(LA7ECH),4)=$P($G(^DIC(5,+$G(IN(FILE,$S(FILE[3:IENS,1:INS),$P(LINE,U,4),"I")),0)),U,2)
Q X
IN1(IN1) ;
;
K LA7BLG(0)
S LA7BLG(0)="IN1"_LA7FS_$G(CNT,1)
;F I=0:0 S I=$O(IN1(I)) Q:'I S $P(LA7BLG(0),LA7FS,I)=IN1(I)
S I=0 F S I=$O(IN1(I)) Q:'I I I'="18E" S $P(LA7BLG(0),LA7FS,I)=IN1(I) ;ihs/cmi/maw 3/7/11 added for external relationship filter
D FILESEG^LA7VHLU(GBL,.LA7BLG)
D FILE6249^LA7VHLU(LA76249,.LA7BLG)
Q
GAR(DFN,REL,PAT,ST) ;SELF AS GUARANTOR
K INS ;1034
Q:$G(LA7GUAR)
N DFN1 S DFN1=$G(DFN)
I '$G(PAT) S PAT=$G(DFN)
K GT1
S I=$O(^AUPNGUAR(PAT,1,"A"),-1) I I S DFN=+$G(^(I,0)) I DFN'=DFN1 K REL
S INS=DFN_","
D GETS^DIQ(2,INS,".01;.09;.111;.112;.113;.114;.115;.116;.117;.131;.3111","EI","IN")
S GT1(4)=$$HLNAME^HLFNC($G(IN(2,INS,.01,"E")),$E(LA7ECH))
S GT1(6)=$$ADD(2)
S GT1(7)=$G(IN(2,INS,.131,"I"))
S GT1(12)=$S($G(REL):REL,1:1)
S GT1(13)=$G(IN(2,INS,.09,"I"))
I $G(GT1(17))="" S GT1(17)=$G(IN(2,INS,.3111,"E"))
Q:'ST
D GT1(.GT1)
S LA7GUAR=1
Q
GT1(GT1) ;
Q:$G(LA7GUAR)
S LA7BLG(0)="GT1"_LA7FS_"1"
S GT1(7)=$TR($G(GT1(7)),"- ()")
F I=0:0 S I=$O(GT1(I)) Q:'I S $P(LA7BLG(0),LA7FS,I)=GT1(I)
D FILESEG^LA7VHLU(GBL,.LA7BLG)
D FILE6249^LA7VHLU(LA76249,.LA7BLG)
Q
DG1(UID) ;
N BDA,ORI,DX,DXE,CNT
S CNT=0
S ORI=$O(^BLRRLO("B",UID,0))
Q:'ORI
S BDA=0 F S BDA=$O(^BLRRLO(ORI,1,BDA)) Q:'BDA D
. S CNT=CNT+1
. S DX=$P($G(^BLRRLO(ORI,1,BDA,0)),U)
. S DXE=$P($G(^ICD9(DX,0)),U)
. N ICDT
. I $D(^ICDS(0)) S ICDT=$P($$ICDDX^ICDEX(DX,DT),U,20) ;get the icd type based on the code
. S LA7BLG(0)="DG1"_LA7FS_CNT_LA7FS_$S($G(ICDT)="30":"I10",1:"I9")_LA7FS_$G(DXE)
. D FILESEG^LA7VHLU(GBL,.LA7BLG)
. D FILE6249^LA7VHLU(LA76249,.LA7BLG)
S LA7DGQ=1
Q
;
ACCT(OR) ;-- get the account number and billing type string
N ORI,ACCT,BTP,DATA
S ORI=$O(^BLRRLO("B",OR,0))
I '$G(ORI) Q ""
S DATA=$G(^BLRRLO(ORI,0))
S ACCT=$P(DATA,U,3)
S BTP=$P(DATA,U,5)
Q ACCT_U_U_U_BTP
;
SFMAP(MNE) ;-- get sliding fee scale if mnemonic is Labcorp sliding scale
I '$G(MNE) Q ""
I $G(MNE)=">0" Q "S10"
I $G(MNE)=">1" Q "S15"
I $G(MNE)="L2" Q "S20"
I $G(MNE)=">2" Q "S25"
I $G(MNE)="L3" Q "S30"
I $G(MNE)=">3" Q "S35"
I $G(MNE)="L4" Q "S40"
I $G(MNE)=">4" Q "S45"
I $G(MNE)="L5" Q "S50"
I $G(MNE)=">5" Q "S55"
I $G(MNE)="L6" Q "S60"
I $G(MNE)=">6" Q "S65"
I $G(MNE)="L7" Q "S70"
I $G(MNE)=">7" Q "S75"
I $G(MNE)="L8" Q "S80"
I $G(MNE)=">8" Q "S85"
I $G(MNE)="L9" Q "S90"
I $G(MNE)=">9" Q "S95"
I $G(MNE)="L1" Q "SXN"
I $G(MNE)="03" Q "SSC"
I $G(MNE)="00" Q "S00"
Q ""
;
PRT(UID) ;EP -- print out insurance information on manifest
N ORI,STR,IIEN,IEIEN,IPIEN,BTP,ORD,NINS,CNT
K INS,DFNS ;1034
S NINS=$S($P($G(^BLRSITE(DUZ(2),"RL")),U,23):$P($G(^BLRSITE(DUZ(2),"RL")),U,23),1:99) ;number of insurances to print
S LA7ECH="^~&\"
S ORI=$O(^BLRRLO("ACC",UID,0))
Q:'ORI
S ORD=$$GET1^DIQ(9009026.3,ORI,.01,"I")
Q:$G(^TMP($J,"LA7SMP",ORD)) ;already printed once
S ^TMP($J,"LA7SMP",ORD)=UID
S BTP=$$GET1^DIQ(9009026.3,ORI,.05,"I")
D GAR(DFN,,,0)
W !,?11,$E(LA7LINE,1,41) ;put in a dashed line here
D WR("Account Number: ",$$GET1^DIQ(9009026.3,ORI,.03),11,1)
D WR("Bill Type: ",BTP,11,1)
I $P($G(^BLRRLO(ORI,0)),U,5)="P" D Q
. D WR("Guarantor: ",$TR(GT1(4),"^"," "),11,1)
. D WR("Telephone: ",GT1(7),55)
. D WR("Guarantor Address: ",$TR(GT1(6),"^"," "),11,1)
S CNT=0
S BDA=0 F S BDA=$O(^BLRRLO(ORI,2,BDA)) Q:'BDA D
. Q:CNT>$G(NINS)
. S STR=$G(^BLRRLO(ORI,2,BDA,0))
. S IIEN=$P($P(STR,"~",11),",")
. I $P(STR,"~",10)="D" D
.. S IEIEN=$P($P(STR,"~",11),",",3)
.. D MCD(IIEN,0)
. I $P(STR,"~",10)="M" D
.. S IEIEN=$P($P(STR,"~",11),",",3)
.. D MCR(IIEN,IEIEN,0)
. I $P(STR,"~",10)="R",$E($P(STR,"~",7),1,1)="M" D
.. S IEIEN=$P($P(STR,"~",11),",",3)
.. D MCR(IIEN,IEIEN,0)
. I $E($P(STR,"~",7),1,1)="R" D ;cmi/maw 05/08/2018 p1042
.. S IEIEN=$P($P(STR,"~",11),",",3)
.. D RR(IIEN,IEIEN,0)
. I $P(STR,"~",10)="P" D
.. S IPIEN=$E($P(STR,"~",7),2,99)
.. S IEIEN=$P($P(STR,"~",11),",",3)
.. D PI(IPIEN,IEIEN,0)
. D WR("Insurer ID: ",IN1(4),11,1)
. I $P(STR,"~",10)="P" D
.. D WR("Group: ",$G(IN1(9)),59) ;ihs/cmi/maw 04/04/2011 added group to manifest
. D WR("Insurer Name: ",$TR(IN1(5),"^"," "),11,1)
. D WR("Telephone: ",IN1(7),55)
. D WR("Insurer Address: ",$TR(IN1(6),"^"," "),11,1)
. D WR("Insured Name: ",$TR(IN1(17),"^"," "),11,1)
. D WR("Relationship: ",$S($G(IN1("18E"))]"":IN1("18E"),1:"Self"),52)
. D WR("Insured Address: ",$TR(IN1(20),"^"," "),11,1)
. D WR("Guarantor: ",$TR(GT1(4),"^"," "),11,1)
. D WR("Telephone: ",GT1(7),55)
. D WR("Guarantor Address: ",$TR(GT1(6),"^"," "),11,1)
. D WR("Insured ID: ",IN1(37),11,1)
. W !,?11,$E(LA7LINE,1,41)
. D DGP(ORI)
. S CNT=CNT+1
Q
;
WR(CAP,VAL,TAB,NL) ;-- write out the line
I $G(NL) W !
W ?TAB,CAP,VAL
Q
;
DGP(ORI) ;
N BDA,DX,DXE,DXEE,CNT
S CNT=0
S BDA=0 F S BDA=$O(^BLRRLO(ORI,1,BDA)) Q:'BDA D
. S CNT=CNT+1
. S DX=$P($G(^BLRRLO(ORI,1,BDA,0)),U)
. S DXE=$P($G(^ICD9(DX,0)),U)
. ;S DXEE=$E($P($G(^ICD9(DX,0)),U,3),1,39)
. S DXEE=$E($$DIAGICD^BLRICDU0(DX),1,39) ; IHS/MSC/MKK - LR*5.2*1034
. D WR("Diagnosis: ",DXE,11,1)
. D WR("Description: ",DXEE,30)
Q
;
AO(UID) ;-- print ask at order questions/responses
N ORI,HEAD,TB
S ORI=$O(^BLRRLO("ACC",UID,0))
Q:'ORI
N ODA,DATA,ACC,QUES,ANS,RSC,LA7OBX
S ODA=0 F S ODA=$O(^BLRRLO(ORI,4,ODA)) Q:'ODA D
. S DATA=$G(^BLRRLO(ORI,4,ODA,0))
. S ACC=$P(DATA,U,2)
. Q:ACC'=UID
. I '$G(HEAD) D
.. S HEAD=1
.. W !!,"ORDER ENTRY QUESTIONS: "
. S QUES=$P(DATA,U,3)
. S ANS=$P(DATA,U,4)
. S RSC=$P(DATA,U,5)
. D WR("",QUES,11,1)
. S TB=$L(QUES)+3
. D WR(" ",ANS,TB)
K HEAD
Q
;
OBX(ORD,UI) ;-- build the OBX segment for ask at order questions
N OR
S OR=$O(^BLRRLO("B",ORD,0))
Q:'OR
N ODA,DATA,ACC,QUES,ANS,RSC,LA7OBX
S ODA=0 F S ODA=$O(^BLRRLO(OR,4,ODA)) Q:'ODA D
. S DATA=$G(^BLRRLO(OR,4,ODA,0))
. S ACC=$P(DATA,U,2)
. Q:ACC'=UI
. S QUES=$P(DATA,U,3)
. S ANS=$P(DATA,U,4)
. S RSC=$P(DATA,U,5)
. S LA7OBX(2)="ST"
. ;lets add code here so if quest add 3 component separators to obx if not then it goes it first piece
. S LA7OBX(3)=U_U_U_RSC_U_QUES ; ask at order question and code
. S LA7OBX(5)=ANS ; ask at order value/response
. D GEN
Q
;
GEN ;-- generate the OBX segment
N LA7DATA
;
S LA7OBX(0)="OBX"
; OBX segment id
S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
;S LA7OBX(11)="F"
; Facility that performed the testing
;S LA7OBX(15)=$$OBX15^LA7VOBX(LA74,LA7FS,LA7ECH)
;
D BUILDSEG^LA7VHLU(.LA7OBX,.LA7DATA,LA7FS)
D FILESEG^LA7VHLU(GBL,.LA7DATA)
D FILE6249^LA7VHLU(LA76249,.LA7DATA)
Q
LA7VQINS ;VA/DALOI/DLR - LAB ORM (Order) message builder ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**1027,1033,1034,1042**;NOV 01, 1997;Build 9
+2 ;
+3 ;
INS(STORE,OR) ;Handle insurance
+1 NEW ORI,BDA,STR,IIEN,IPIEN,IEIEN
+2 SET ORI=$ORDER(^BLRRLO("B",OR,0))
+3 IF 'ORI
SET ORI=$ORDER(^BLRRLO("ACC",OR,0))
+4 IF 'ORI
QUIT
+5 IF $PIECE($GET(^BLRRLO(ORI,0)),U,5)="P"!($PIECE($GET(^BLRRLO(ORI,0)),U,5)="C")
Begin DoDot:1
+6 SET CNT=CNT+1
+7 SET IN1(48)=$SELECT($PIECE($GET(^BLRRLO(ORI,0)),U,5)="P":"P",1:"C")
+8 DO IN1(.IN1)
End DoDot:1
QUIT
+9 SET BDA=0
FOR
SET BDA=$ORDER(^BLRRLO(ORI,2,BDA))
IF 'BDA
QUIT
Begin DoDot:1
+10 SET STR=$GET(^BLRRLO(ORI,2,BDA,0))
+11 SET IIEN=$PIECE($PIECE(STR,"~",11),",")
+12 IF $PIECE(STR,"~",10)="D"
Begin DoDot:2
+13 SET IEIEN=$PIECE($PIECE(STR,"~",11),",",3)
+14 DO MCD(IIEN,STORE)
End DoDot:2
QUIT
+15 IF $PIECE(STR,"~",10)="M"
Begin DoDot:2
+16 SET IEIEN=$PIECE($PIECE(STR,"~",11),",",3)
+17 DO MCR(IIEN,IEIEN,STORE)
End DoDot:2
QUIT
+18 IF $PIECE(STR,"~",10)="R"
IF $EXTRACT($PIECE(STR,"~",7),1,1)="M"
Begin DoDot:2
+19 SET IEIEN=$PIECE($PIECE(STR,"~",11),",",3)
+20 DO MCR(IIEN,IEIEN,STORE)
End DoDot:2
QUIT
+21 ;cmi/maw 05/05/2018 p1042
IF $EXTRACT($PIECE(STR,"~",7),1,1)="R"
Begin DoDot:2
+22 SET IEIEN=$PIECE($PIECE(STR,"~",11),",",3)
+23 DO RR(IIEN,IEIEN,STORE)
End DoDot:2
QUIT
+24 IF $PIECE(STR,"~",10)="P"
Begin DoDot:2
+25 SET IPIEN=$EXTRACT($PIECE(STR,"~",7),2,99)
+26 SET IEIEN=$PIECE($PIECE(STR,"~",11),",",3)
+27 DO PI(IPIEN,IEIEN,STORE)
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;
MCR(IEN,PE,ST) ;medicare.
+1 SET CNT=$GET(CNT)+1
+2 NEW IENS
SET IENS=IEN_","
+3 DO GETS^DIQ(9000003,IENS,"*","EI","IN")
+4 SET EINS=PE_","_IENS
DO GETS^DIQ(9000003.11,EINS,"*","EI","IN")
+5 SET INS=$GET(IN(9000003,IENS,.02,"I"))_","
+6 DO GETS^DIQ(9999999.18,INS,"*","EI","IN")
+7 SET IN1(4)=$GET(IN(9999999.18,INS,.66,"E"))
+8 SET IN1(5)=$GET(IN(9999999.18,INS,.01,"E"))
+9 SET IN1(7)=$GET(IN(9999999.18,INS,.06,"E"))
+10 SET IN1(16)="MC"
+11 SET IN1(18)=1
+12 SET IN1(17)=$$HLNAME^HLFNC($GET(IN(9000003,IENS,2101,"E")),LA7ECH)
+13 IF IN1(17)=""
SET IN1(17)=$$HLNAME^HLFNC($GET(IN(9000003,IENS,.01,"E")),LA7ECH)
+14 ;S IN1(37)=$G(IN(9000003,IENS,.03,"I"))_$G(IN(9000003,IENS,.04,"E")) ;cmi/maw p1042
+15 ;cmi/maw 05/08/2018 p1042 NMCI
SET IN1(37)=$$GETMCR^AGUTL(IEN,DT)
+16 SET IN1(4)=$GET(IN(9999999.18,INS,.66,"E"))
+17 SET IN1(9)=$GET(IN(9000003.11,IENS,.11,"I"))
+18 SET IN1(9)=$SELECT($GET(IN1(9)):$PIECE($GET(^AUTNEGRP(IN1(9),0)),U,2),1:"")
+19 SET IN1(10)=$GET(IN(9000003,IENS,.06,"E"))
+20 SET IN1(6)=$$ADD()
+21 SET IN1(20)=$$ADD(2)
+22 SET IN1(48)=$SELECT($GET(ORD):$PIECE($$ACCT^LA7VQINS(ORD),U,4),1:"")
+23 IF 'ST
QUIT
+24 DO IN1(.IN1)
+25 QUIT
+26 ;
MCD(IEN,ST) ;medicaid
+1 SET CNT=$GET(CNT)+1
+2 NEW IENS
+3 SET IENS=IEN_","
+4 DO GETS^DIQ(9000004,IENS,"*","EI","IN")
+5 SET INS=$GET(IN(9000004,IENS,.02,"I"))_","
+6 DO GETS^DIQ(9999999.18,INS,"*","EI","IN")
+7 SET IN1(4)=$GET(IN(9999999.18,INS,.66,"E"))
+8 SET IN1(5)=$GET(IN(9999999.18,INS,.01,"E"))
+9 SET IN1(6)=$$ADD()
+10 SET IN1(7)=$GET(IN(9999999.18,INS,.06,"E"))
+11 SET IN1(16)="MD"
+12 SET IN1(17)=$$HLNAME^HLFNC($GET(IN(9000004,IENS,.05,"E")),LA7ECH)
+13 SET IN1(18)=1
+14 SET PE=$GET(IN(9000004,IENS,.06,"I"))
+15 SET IN1(18)=+$PIECE($GET(^AUTTRLSH(+PE,0)),U,3)
+16 SET IN1("18E")=$PIECE($GET(^AUTTRLSH(+PE,0)),U)
+17 SET IN1(18)=$SELECT(IN1(18)=2:2,IN1(18)=1:1,IN1(18)=0:1,1:8)
+18 SET IN1(37)=$GET(IN(9000004,IENS,.03,"I"))
+19 SET IN1(9)=$GET(IN(9000004,IENS,.17,"I"))
+20 SET IN1(9)=$SELECT($GET(IN1(9)):$PIECE($GET(^AUTNEGRP(IN1(9),0)),U,2),1:"")
+21 SET IN1(48)=$PIECE($$ACCT^LA7VQINS(ORD),U,4)
+22 SET IN1(20)=$$ADD(2)
+23 IF 'ST
QUIT
+24 DO IN1(.IN1)
+25 QUIT
+26 ;
PI(IEN,PE,ST) ;private insurance
+1 SET CNT=$GET(CNT)+1
+2 NEW IENS
+3 SET IENS=IEN_","
+4 DO GETS^DIQ(9000003.1,IENS,"*","EI","IN")
+5 SET INS=$GET(IN(9000003.1,IENS,.03,"I"))_","
+6 DO GETS^DIQ(9999999.18,INS,"*","EI","IN")
+7 SET IN1(4)=$GET(IN(9999999.18,INS,.66,"E"))
+8 SET IN1(5)=$GET(IN(9999999.18,INS,.01,"E"))
+9 SET IN1(6)=$$ADD()
+10 SET IN1(7)=$GET(IN(9999999.18,INS,.06,"E"))
+11 SET IN1(9)=$GET(IN(9000003.1,IENS,.06,"I"))
+12 SET IN1(9)=$SELECT($GET(IN1(9)):$PIECE($GET(^AUTNEGRP(IN1(9),0)),U,2),1:"")
+13 SET IN1(10)=$GET(IN(9000003.1,IENS,.06,"E"))
+14 SET IN1(16)=$SELECT($GET(IN(9999999.18,INS,.21,"I"))="H":"HM",1:"PI")
+15 SET IN1(17)=$$HLNAME^HLFNC($GET(IN(9000003.1,IENS,.01,"E")),LA7ECH)
+16 ;S IN1(18)=$G(IN(9000006.11,IENS,.05,"E"))
+17 SET IN1(20)=$$ADD(9000003.1)
+18 SET IN1(37)=$GET(IN(9000003.1,IENS,.04,"E"))
+19 SET IN1(48)=$SELECT($GET(ORD):$PIECE($$ACCT^LA7VQINS(ORD),U,4),1:"")
+20 SET IN1(18)=+$PIECE($GET(^AUTTRLSH(+$PIECE($GET(^AUPNPRVT(DFN,11,+PE,0)),U,5),0)),U,3)
+21 SET IN1(18)=$SELECT(IN1(18)=2:2,IN1(18)=1:1,IN1(18)=0:1,1:8)
+22 ;$P($G(^AUTTRLSH(+$P($G(^AUPNPRVT(DFN,11,+PE,0)),U,5),0)),U)
SET IN1("18E")=$SELECT(IN1(18)=1:"SELF",IN1(18)=2:"SPOUSE",1:"OTHER")
+23 IF 'ST
QUIT
+24 DO IN1(.IN1)
+25 QUIT
+26 ;
WC(INS,IEN,ST) ;-- workmans comp
+1 KILL DFNS
+2 SET CNT=$GET(CNT)+1
+3 NEW IENS
+4 SET IENS=IEN_","
+5 SET IN=$PIECE(IEN,",")_","
+6 DO GETS^DIQ(9000042,IN,"*","EI","IN")
+7 DO GETS^DIQ(9000042.11,IENS,"*","EI","IN")
+8 SET INS=INS_","
+9 SET DFNS=DFN_","
+10 DO GETS^DIQ(9999999.18,INS,"*","EI","IN")
+11 DO GETS^DIQ(2,DFNS,".111;.112;.114;.115;.116","EI","IN")
+12 SET IN1(4)=$GET(IN(9999999.18,INS,.66,"E"))
+13 SET IN1(5)=$GET(IN(9999999.18,INS,.01,"E"))
+14 SET IN1(6)=$$ADD()
+15 SET IN1(7)=$GET(IN(9999999.18,INS,.06,"E"))
+16 SET IN1(9)=$GET(IN(9000042.11,IENS,.12,"I"))
+17 SET IN1(9)=$SELECT($GET(IN1(9)):$PIECE($GET(^AUTNEGRP(IN1(9),0)),U,2),1:"")
+18 SET IN1(10)=$GET(IN(9000042.11,IENS,.12,"E"))
+19 SET IN1(16)=$SELECT($GET(IN(9999999.18,INS,.21,"I"))="H":"HM",1:"PI")
+20 SET IN1(17)=$$HLNAME^HLFNC($GET(IN(9000042,IN,.01,"E")),LA7ECH)
+21 ;S IN1(18)=$G(IN(9000006.11,IENS,.05,"E"))
+22 SET IN1(20)=$$ADD(2)
+23 SET IN1(37)=$GET(IN(9000042.11,IENS,.04,"E"))
+24 SET IN1(48)=$SELECT($GET(ORD):$PIECE($$ACCT^LA7VQINS(ORD),U,4),1:"")
+25 ;S IN1(18)=+$P($G(^AUTTRLSH(+$P($G(^AUPNPRVT(DFN,11,+PE,0)),U,5),0)),U,3)
+26 SET IN1(18)=1
+27 ;$P($G(^AUTTRLSH(+$P($G(^AUPNPRVT(DFN,11,+PE,0)),U,5),0)),U)
SET IN1("18E")=$SELECT(IN1(18)=1:"SELF",IN1(18)=2:"SPOUSE",1:"OTHER")
+28 KILL DFNS
+29 IF 'ST
QUIT
+30 DO IN1(.IN1)
+31 QUIT
+32 ;
RR(IEN,PE,ST) ;-- get railroad insurance
+1 SET CNT=$GET(CNT)+1
+2 NEW IENS
SET IENS=IEN_","
+3 DO GETS^DIQ(9000005,IENS,"*","EI","IN")
+4 SET EINS=PE_","_IENS
DO GETS^DIQ(9000005.11,EINS,"*","EI","IN")
+5 SET INS=$GET(IN(9000005,IENS,.02,"I"))_","
+6 DO GETS^DIQ(9999999.18,INS,"*","EI","IN")
+7 SET IN1(4)=$GET(IN(9999999.18,INS,.66,"E"))
+8 SET IN1(5)=$GET(IN(9999999.18,INS,.01,"E"))
+9 SET IN1(7)=$GET(IN(9999999.18,INS,.06,"E"))
+10 SET IN1(16)="RR"
+11 SET IN1(18)=1
+12 SET IN1(17)=$$HLNAME^HLFNC($GET(IN(9000005,IENS,2101,"E")),LA7ECH)
+13 IF IN1(17)=""
SET IN1(17)=$$HLNAME^HLFNC($GET(IN(9000005,IENS,.01,"E")),LA7ECH)
+14 ;S IN1(37)=$G(IN(9000003,IENS,.03,"I"))_$G(IN(9000003,IENS,.04,"E")) ;cmi/maw p1042
+15 ;cmi/maw 05/08/2018 p1042 NMCI
SET IN1(37)=$$GETRRE^AGUTL(IEN,DT)
+16 SET IN1(4)=$GET(IN(9999999.18,INS,.66,"E"))
+17 SET IN1(9)=$GET(IN(9000005.11,IENS,.11,"I"))
+18 SET IN1(9)=$SELECT($GET(IN1(9)):$PIECE($GET(^AUTNEGRP(IN1(9),0)),U,2),1:"")
+19 SET IN1(10)=$GET(IN(9000005,IENS,.06,"E"))
+20 SET IN1(6)=$$ADD()
+21 SET IN1(20)=$$ADD(2)
+22 SET IN1(48)=$SELECT($GET(ORD):$PIECE($$ACCT^LA7VQINS(ORD),U,4),1:"")
+23 IF 'ST
QUIT
+24 DO IN1(.IN1)
+25 QUIT
+26 ;
ADD(FILE) ;
+1 ;set address component
+2 IF '$GET(FILE)
SET FILE=9999999.18
+3 NEW LINE
SET LINE=".02^999^.03^.04^.05"
+4 IF FILE[3
SET LINE=".09^999^.11^.12^.13"
+5 IF FILE=2
SET LINE=".111^.112^.114^.115^.116"
+6 NEW X,I
SET X=""
+7 FOR I=1:1:5
SET X=X_$GET(IN(FILE,$SELECT(FILE[3:IENS,1:INS),$PIECE(LINE,U,I),"E"))_$EXTRACT(LA7ECH)
+8 SET $PIECE(X,$EXTRACT(LA7ECH),4)=$PIECE($GET(^DIC(5,+$GET(IN(FILE,$SELECT(FILE[3:IENS,1:INS),$PIECE(LINE,U,4),"I")),0)),U,2)
+9 QUIT X
IN1(IN1) ;
+1 ;
+2 KILL LA7BLG(0)
+3 SET LA7BLG(0)="IN1"_LA7FS_$GET(CNT,1)
+4 ;F I=0:0 S I=$O(IN1(I)) Q:'I S $P(LA7BLG(0),LA7FS,I)=IN1(I)
+5 ;ihs/cmi/maw 3/7/11 added for external relationship filter
SET I=0
FOR
SET I=$ORDER(IN1(I))
IF 'I
QUIT
IF I'="18E"
SET $PIECE(LA7BLG(0),LA7FS,I)=IN1(I)
+6 DO FILESEG^LA7VHLU(GBL,.LA7BLG)
+7 DO FILE6249^LA7VHLU(LA76249,.LA7BLG)
+8 QUIT
GAR(DFN,REL,PAT,ST) ;SELF AS GUARANTOR
+1 ;1034
KILL INS
+2 IF $GET(LA7GUAR)
QUIT
+3 NEW DFN1
SET DFN1=$GET(DFN)
+4 IF '$GET(PAT)
SET PAT=$GET(DFN)
+5 KILL GT1
+6 SET I=$ORDER(^AUPNGUAR(PAT,1,"A"),-1)
IF I
SET DFN=+$GET(^(I,0))
IF DFN'=DFN1
KILL REL
+7 SET INS=DFN_","
+8 DO GETS^DIQ(2,INS,".01;.09;.111;.112;.113;.114;.115;.116;.117;.131;.3111","EI","IN")
+9 SET GT1(4)=$$HLNAME^HLFNC($GET(IN(2,INS,.01,"E")),$EXTRACT(LA7ECH))
+10 SET GT1(6)=$$ADD(2)
+11 SET GT1(7)=$GET(IN(2,INS,.131,"I"))
+12 SET GT1(12)=$SELECT($GET(REL):REL,1:1)
+13 SET GT1(13)=$GET(IN(2,INS,.09,"I"))
+14 IF $GET(GT1(17))=""
SET GT1(17)=$GET(IN(2,INS,.3111,"E"))
+15 IF 'ST
QUIT
+16 DO GT1(.GT1)
+17 SET LA7GUAR=1
+18 QUIT
GT1(GT1) ;
+1 IF $GET(LA7GUAR)
QUIT
+2 SET LA7BLG(0)="GT1"_LA7FS_"1"
+3 SET GT1(7)=$TRANSLATE($GET(GT1(7)),"- ()")
+4 FOR I=0:0
SET I=$ORDER(GT1(I))
IF 'I
QUIT
SET $PIECE(LA7BLG(0),LA7FS,I)=GT1(I)
+5 DO FILESEG^LA7VHLU(GBL,.LA7BLG)
+6 DO FILE6249^LA7VHLU(LA76249,.LA7BLG)
+7 QUIT
DG1(UID) ;
+1 NEW BDA,ORI,DX,DXE,CNT
+2 SET CNT=0
+3 SET ORI=$ORDER(^BLRRLO("B",UID,0))
+4 IF 'ORI
QUIT
+5 SET BDA=0
FOR
SET BDA=$ORDER(^BLRRLO(ORI,1,BDA))
IF 'BDA
QUIT
Begin DoDot:1
+6 SET CNT=CNT+1
+7 SET DX=$PIECE($GET(^BLRRLO(ORI,1,BDA,0)),U)
+8 SET DXE=$PIECE($GET(^ICD9(DX,0)),U)
+9 NEW ICDT
+10 ;get the icd type based on the code
IF $DATA(^ICDS(0))
SET ICDT=$PIECE($$ICDDX^ICDEX(DX,DT),U,20)
+11 SET LA7BLG(0)="DG1"_LA7FS_CNT_LA7FS_$SELECT($GET(ICDT)="30":"I10",1:"I9")_LA7FS_$GET(DXE)
+12 DO FILESEG^LA7VHLU(GBL,.LA7BLG)
+13 DO FILE6249^LA7VHLU(LA76249,.LA7BLG)
End DoDot:1
+14 SET LA7DGQ=1
+15 QUIT
+16 ;
ACCT(OR) ;-- get the account number and billing type string
+1 NEW ORI,ACCT,BTP,DATA
+2 SET ORI=$ORDER(^BLRRLO("B",OR,0))
+3 IF '$GET(ORI)
QUIT ""
+4 SET DATA=$GET(^BLRRLO(ORI,0))
+5 SET ACCT=$PIECE(DATA,U,3)
+6 SET BTP=$PIECE(DATA,U,5)
+7 QUIT ACCT_U_U_U_BTP
+8 ;
SFMAP(MNE) ;-- get sliding fee scale if mnemonic is Labcorp sliding scale
+1 IF '$GET(MNE)
QUIT ""
+2 IF $GET(MNE)=">0"
QUIT "S10"
+3 IF $GET(MNE)=">1"
QUIT "S15"
+4 IF $GET(MNE)="L2"
QUIT "S20"
+5 IF $GET(MNE)=">2"
QUIT "S25"
+6 IF $GET(MNE)="L3"
QUIT "S30"
+7 IF $GET(MNE)=">3"
QUIT "S35"
+8 IF $GET(MNE)="L4"
QUIT "S40"
+9 IF $GET(MNE)=">4"
QUIT "S45"
+10 IF $GET(MNE)="L5"
QUIT "S50"
+11 IF $GET(MNE)=">5"
QUIT "S55"
+12 IF $GET(MNE)="L6"
QUIT "S60"
+13 IF $GET(MNE)=">6"
QUIT "S65"
+14 IF $GET(MNE)="L7"
QUIT "S70"
+15 IF $GET(MNE)=">7"
QUIT "S75"
+16 IF $GET(MNE)="L8"
QUIT "S80"
+17 IF $GET(MNE)=">8"
QUIT "S85"
+18 IF $GET(MNE)="L9"
QUIT "S90"
+19 IF $GET(MNE)=">9"
QUIT "S95"
+20 IF $GET(MNE)="L1"
QUIT "SXN"
+21 IF $GET(MNE)="03"
QUIT "SSC"
+22 IF $GET(MNE)="00"
QUIT "S00"
+23 QUIT ""
+24 ;
PRT(UID) ;EP -- print out insurance information on manifest
+1 NEW ORI,STR,IIEN,IEIEN,IPIEN,BTP,ORD,NINS,CNT
+2 ;1034
KILL INS,DFNS
+3 ;number of insurances to print
SET NINS=$SELECT($PIECE($GET(^BLRSITE(DUZ(2),"RL")),U,23):$PIECE($GET(^BLRSITE(DUZ(2),"RL")),U,23),1:99)
+4 SET LA7ECH="^~&\"
+5 SET ORI=$ORDER(^BLRRLO("ACC",UID,0))
+6 IF 'ORI
QUIT
+7 SET ORD=$$GET1^DIQ(9009026.3,ORI,.01,"I")
+8 ;already printed once
IF $GET(^TMP($JOB,"LA7SMP",ORD))
QUIT
+9 SET ^TMP($JOB,"LA7SMP",ORD)=UID
+10 SET BTP=$$GET1^DIQ(9009026.3,ORI,.05,"I")
+11 DO GAR(DFN,,,0)
+12 ;put in a dashed line here
WRITE !,?11,$EXTRACT(LA7LINE,1,41)
+13 DO WR("Account Number: ",$$GET1^DIQ(9009026.3,ORI,.03),11,1)
+14 DO WR("Bill Type: ",BTP,11,1)
+15 IF $PIECE($GET(^BLRRLO(ORI,0)),U,5)="P"
Begin DoDot:1
+16 DO WR("Guarantor: ",$TRANSLATE(GT1(4),"^"," "),11,1)
+17 DO WR("Telephone: ",GT1(7),55)
+18 DO WR("Guarantor Address: ",$TRANSLATE(GT1(6),"^"," "),11,1)
End DoDot:1
QUIT
+19 SET CNT=0
+20 SET BDA=0
FOR
SET BDA=$ORDER(^BLRRLO(ORI,2,BDA))
IF 'BDA
QUIT
Begin DoDot:1
+21 IF CNT>$GET(NINS)
QUIT
+22 SET STR=$GET(^BLRRLO(ORI,2,BDA,0))
+23 SET IIEN=$PIECE($PIECE(STR,"~",11),",")
+24 IF $PIECE(STR,"~",10)="D"
Begin DoDot:2
+25 SET IEIEN=$PIECE($PIECE(STR,"~",11),",",3)
+26 DO MCD(IIEN,0)
End DoDot:2
+27 IF $PIECE(STR,"~",10)="M"
Begin DoDot:2
+28 SET IEIEN=$PIECE($PIECE(STR,"~",11),",",3)
+29 DO MCR(IIEN,IEIEN,0)
End DoDot:2
+30 IF $PIECE(STR,"~",10)="R"
IF $EXTRACT($PIECE(STR,"~",7),1,1)="M"
Begin DoDot:2
+31 SET IEIEN=$PIECE($PIECE(STR,"~",11),",",3)
+32 DO MCR(IIEN,IEIEN,0)
End DoDot:2
+33 ;cmi/maw 05/08/2018 p1042
IF $EXTRACT($PIECE(STR,"~",7),1,1)="R"
Begin DoDot:2
+34 SET IEIEN=$PIECE($PIECE(STR,"~",11),",",3)
+35 DO RR(IIEN,IEIEN,0)
End DoDot:2
+36 IF $PIECE(STR,"~",10)="P"
Begin DoDot:2
+37 SET IPIEN=$EXTRACT($PIECE(STR,"~",7),2,99)
+38 SET IEIEN=$PIECE($PIECE(STR,"~",11),",",3)
+39 DO PI(IPIEN,IEIEN,0)
End DoDot:2
+40 DO WR("Insurer ID: ",IN1(4),11,1)
+41 IF $PIECE(STR,"~",10)="P"
Begin DoDot:2
+42 ;ihs/cmi/maw 04/04/2011 added group to manifest
DO WR("Group: ",$GET(IN1(9)),59)
End DoDot:2
+43 DO WR("Insurer Name: ",$TRANSLATE(IN1(5),"^"," "),11,1)
+44 DO WR("Telephone: ",IN1(7),55)
+45 DO WR("Insurer Address: ",$TRANSLATE(IN1(6),"^"," "),11,1)
+46 DO WR("Insured Name: ",$TRANSLATE(IN1(17),"^"," "),11,1)
+47 DO WR("Relationship: ",$SELECT($GET(IN1("18E"))]"":IN1("18E"),1:"Self"),52)
+48 DO WR("Insured Address: ",$TRANSLATE(IN1(20),"^"," "),11,1)
+49 DO WR("Guarantor: ",$TRANSLATE(GT1(4),"^"," "),11,1)
+50 DO WR("Telephone: ",GT1(7),55)
+51 DO WR("Guarantor Address: ",$TRANSLATE(GT1(6),"^"," "),11,1)
+52 DO WR("Insured ID: ",IN1(37),11,1)
+53 WRITE !,?11,$EXTRACT(LA7LINE,1,41)
+54 DO DGP(ORI)
+55 SET CNT=CNT+1
End DoDot:1
+56 QUIT
+57 ;
WR(CAP,VAL,TAB,NL) ;-- write out the line
+1 IF $GET(NL)
WRITE !
+2 WRITE ?TAB,CAP,VAL
+3 QUIT
+4 ;
DGP(ORI) ;
+1 NEW BDA,DX,DXE,DXEE,CNT
+2 SET CNT=0
+3 SET BDA=0
FOR
SET BDA=$ORDER(^BLRRLO(ORI,1,BDA))
IF 'BDA
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
+5 SET DX=$PIECE($GET(^BLRRLO(ORI,1,BDA,0)),U)
+6 SET DXE=$PIECE($GET(^ICD9(DX,0)),U)
+7 ;S DXEE=$E($P($G(^ICD9(DX,0)),U,3),1,39)
+8 ; IHS/MSC/MKK - LR*5.2*1034
SET DXEE=$EXTRACT($$DIAGICD^BLRICDU0(DX),1,39)
+9 DO WR("Diagnosis: ",DXE,11,1)
+10 DO WR("Description: ",DXEE,30)
End DoDot:1
+11 QUIT
+12 ;
AO(UID) ;-- print ask at order questions/responses
+1 NEW ORI,HEAD,TB
+2 SET ORI=$ORDER(^BLRRLO("ACC",UID,0))
+3 IF 'ORI
QUIT
+4 NEW ODA,DATA,ACC,QUES,ANS,RSC,LA7OBX
+5 SET ODA=0
FOR
SET ODA=$ORDER(^BLRRLO(ORI,4,ODA))
IF 'ODA
QUIT
Begin DoDot:1
+6 SET DATA=$GET(^BLRRLO(ORI,4,ODA,0))
+7 SET ACC=$PIECE(DATA,U,2)
+8 IF ACC'=UID
QUIT
+9 IF '$GET(HEAD)
Begin DoDot:2
+10 SET HEAD=1
+11 WRITE !!,"ORDER ENTRY QUESTIONS: "
End DoDot:2
+12 SET QUES=$PIECE(DATA,U,3)
+13 SET ANS=$PIECE(DATA,U,4)
+14 SET RSC=$PIECE(DATA,U,5)
+15 DO WR("",QUES,11,1)
+16 SET TB=$LENGTH(QUES)+3
+17 DO WR(" ",ANS,TB)
End DoDot:1
+18 KILL HEAD
+19 QUIT
+20 ;
OBX(ORD,UI) ;-- build the OBX segment for ask at order questions
+1 NEW OR
+2 SET OR=$ORDER(^BLRRLO("B",ORD,0))
+3 IF 'OR
QUIT
+4 NEW ODA,DATA,ACC,QUES,ANS,RSC,LA7OBX
+5 SET ODA=0
FOR
SET ODA=$ORDER(^BLRRLO(OR,4,ODA))
IF 'ODA
QUIT
Begin DoDot:1
+6 SET DATA=$GET(^BLRRLO(OR,4,ODA,0))
+7 SET ACC=$PIECE(DATA,U,2)
+8 IF ACC'=UI
QUIT
+9 SET QUES=$PIECE(DATA,U,3)
+10 SET ANS=$PIECE(DATA,U,4)
+11 SET RSC=$PIECE(DATA,U,5)
+12 SET LA7OBX(2)="ST"
+13 ;lets add code here so if quest add 3 component separators to obx if not then it goes it first piece
+14 ; ask at order question and code
SET LA7OBX(3)=U_U_U_RSC_U_QUES
+15 ; ask at order value/response
SET LA7OBX(5)=ANS
+16 DO GEN
End DoDot:1
+17 QUIT
+18 ;
GEN ;-- generate the OBX segment
+1 NEW LA7DATA
+2 ;
+3 SET LA7OBX(0)="OBX"
+4 ; OBX segment id
+5 SET LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
+6 ;S LA7OBX(11)="F"
+7 ; Facility that performed the testing
+8 ;S LA7OBX(15)=$$OBX15^LA7VOBX(LA74,LA7FS,LA7ECH)
+9 ;
+10 DO BUILDSEG^LA7VHLU(.LA7OBX,.LA7DATA,LA7FS)
+11 DO FILESEG^LA7VHLU(GBL,.LA7DATA)
+12 DO FILE6249^LA7VHLU(LA76249,.LA7DATA)
+13 QUIT
