Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LA7VQINS

LA7VQINS.m

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