BLRREFLA ;IHS/MSC/MKK - REFerence Lab Address functions ; 17-Oct-2014 09:22 ; MKK
;;5.2;IHS LABORATORY;**1033,1034**;NOV 01, 1997;Build 88
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
; API Function.
PCCRLADR(VFILENUM,VFILEIEN,ARRAY) ; EP - Get Address for Lab V File entry
; VFILENUM = Number of the Lab V File
; VFILEIEN = IEN of the test in the Lab V File
;
; Returns 1 if successful or 0 if failure.
;
; If successful, the ARRAY will be set as:
; ARRAY("ST1")=Street Address 1
; ARRAY("ST2")=Street Address 2 (array element only exists if Street Address 2 element exists)
; ARRAY("CITY")=City
; ARRAY("STATE")=STATE
; ARRAY("ZIP")=Zipcode
;
; If failure, the returned string is of the form
; 0^VFILENUM^DESCRIPTION
; where DESCRIPTION is a brief explanation of its failure (if possible)
;
; Uses the INSTITUTION number to determine the address.
;
; Initialize the array
K ARRAY
;
Q:+$G(VFILENUM)<1 "0^^V FILE NUMBER < 1"
Q:+$G(VFILEIEN)<1 "0^"_VFILENUM_"^Lab V FILE IEN missing"
;
Q:VFILENUM=9000010.09 $$CHPCCSUB(VFILEIEN,.ARRAY)
;
Q:VFILENUM=9000010.25 $$MIPCCSUB(VFILEIEN,.ARRAY)
;
Q "0^Lab V FILE NUMBER '"_VFILENUM_"' INVALID"
;
CHPCCSUB(VLABIEN,ARRAY) ; EP - "CH" subscripted tests
NEW (ARRAY,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,VLABIEN,XPARSYS,XQXFLG)
;
S INST=0
;
S F60IEN=+$$GET1^DIQ(9000010.09,VLABIEN,.01,"I") ; File 60 IEN
S LRDN=+$$GET1^DIQ(60,F60IEN,400,"I") ; DataName IEN
;
S DFN=$$GET1^DIQ(9000010.09,VLABIEN,.02,"I") ; DFN = File 2 IEN
S LRDFN=+$$GET1^DIQ(2,DFN,63) ; File 63 IEN
;
S COLLDATE=+$$GET1^DIQ(9000010.09,VLABIEN,1201,"I") ; Collection Date
;
S LRIDT=9999999-COLLDATE ; Inverse Date
S LRSS="CH" ; File 63 Subscript
;
I LRDN,LRDFN,COLLDATE D
. S INST=+$P($G(^LR(LRDFN,LRSS,LRIDT,LRDN)),"^",9) ; Get Institution from Lab Data file
;
S IENS=LRIDT_","_LRDFN_","
;
S VPIEN=+$$GET1^DIQ(63.04,IENS,.04,"I") ; Verify Person
;
; If Institution IEN still < 1, use Verify Person
S:INST<1 INST=+$$IHSDIV^XUS1(VPIEN)
;
; If Institution IEN still < 1, set to Accessioning Institution
S:INST<1 INST=+$$GET1^DIQ(63.04,IENS,.112,"I")
;
I INST<1 D ; If Institution IEN still < 1, use Requesting Location
. S REQLOC=+$$GET1^DIQ(63.04,IENS,.111,"I")
. S INST=+$$GET1^DIQ(44,REQLOC,"INSTITUTION","I")
;
; If Institution IEN still < 1, set to Default Institution in 69.9
S:INST<1 INST=+$$GET1^DIQ(69.9,1_",",3,"I")
;
; If cannot determine Institution, Quit with 0 (failure)
Q:INST<1 "0^9000010.09^Institution < 1"
;
; Call 'Get Address' function
Q $$RLADDRES(INST,.ARRAY)
;
MIPCCSUB(VLMICIEN,ARRAY) ; EP - "MI" subscripted tests
NEW (ARRAY,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,VLMICIEN,XPARSYS,XQXFLG)
;
S INST=0
;
S F60IEN=+$$GET1^DIQ(9000010.25,VLMICIEN,.01,"I") ; File 60 IEN
S DFN=$$GET1^DIQ(9000010.09,VLMICIEN,.02,"I") ; DFN = File 2 IEN
S LRDFN=+$$GET1^DIQ(2,DFN,63) ; File 63 IEN
;
S COLLDATE=+$$GET1^DIQ(9000010.09,VLMICIEN,1201,"I") ; Collection Date
S LRIDT=9999999-COLLDATE ; Inverse Date
;
S IENS=LRIDT_","_LRDFN_","
;
S VPIEN=+$$GET1^DIQ(63.04,IENS,.04,"I") ; Verify Person
;
; Use Verify Person
S:INST<1 INST=+$$IHSDIV^XUS1(VPIEN)
;
; If Institution IEN still < 1, set to Accessioning Institution
S:INST<1 INST=+$$GET1^DIQ(63.04,IENS,.112,"I")
;
S VFLRAS=$$GET1^DIQ(9000010.25,VLMICIEN,.06) ; Accession Number
S LRAAAB=$P(VFLRAS," ")
;
K ERRS
S LRAA=$$FIND1^DIC(68,,,LRAAAB,,,"ERRS") ; Get Accession IEN
;
; Find the Institution associated with the Accession's IEN
I F60IEN,LRAA D
. S (INSTIEN,INST)=0
. F S INSTIEN=$O(^LAB(60,F60IEN,8,INSTIEN)) Q:INSTIEN<1!(INST) D
.. S:$P($G(^LAB(60,F60IEN,8,INSTIEN,0)),"^",2)=LRAA INST=INSTIEN
;
; If Institution IEN still < 1, set to Default Institution in 69.9
S:INST<1 INST=+$$GET1^DIQ(69.9,1_",",3,"I")
;
; If cannot determine Institution, Quit with 0 (failure)
Q:INST<1 "0^9000010.25^Institution < 1"
;
; Call 'Get Address' function
Q $$RLADDRES(INST,.ARRAY)
;
; API Function.
; Given an IEN from file 4.
;
; If not successful, the function returns 0.
;
; If successful, the fucntion returns returns 1.
; The Reference Lab ADDRESS is returned in the ARRAY from file 4
; The array will be defined as the following:
; ARRAY("ST1")=Street Address 1
; ARRAY("ST2")=Street Address 2 (array element only exists if Street Address 2 element exists)
; ARRAY("CITY")=City
; ARRAY("STATE")=STATE
; ARRAY("ZIP")=Zipcode
;
RLADDRES(F4IEN,ARRAY) ; EP
; F4IEN = IEN from INSTITUTION (#4) file.
; Output (if any) will be put into the ARRAY
; Returns 1 if successful or 0 if failure.
NEW (ARRAY,DILOCKTM,DISYS,DT,DTIME,DUZ,F4IEN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
K ARRAY ; Make sure array is initialized
;
; File IEN not positive. Quit with 0 (failure)
Q:+$G(F4IEN)<1 "0^INSTITUTION"
;
S NAME=$$GET1^DIQ(4,F4IEN,"NAME")
S ST1=$$GET1^DIQ(4,F4IEN,"STREET ADDR. 1")
S ST2=$$GET1^DIQ(4,F4IEN,"STREET ADDR. 2")
S CITY=$$GET1^DIQ(4,F4IEN,"CITY")
S STATE=$$GET1^DIQ(4,F4IEN,"STATE")
S ZIP=$$GET1^DIQ(4,F4IEN,"ZIP")
;
; All necessary address entries exist. Put into ARRAY and exit.
I $L(NAME),$L(ST1),$L(CITY),$L(STATE),$L(ZIP) D Q 1
. S ARRAY("NAME")=NAME,ARRAY("ST1")=ST1
. S:$L(ST2) ARRAY("ST2")=ST2
. S ARRAY("CITY")=CITY,ARRAY("STATE")=STATE,ARRAY("ZIP")=ZIP
;
;
; Data does NOT exist. Quit with 0 (failure)
Q "0^"_F4IEN_"^ADDRESS missing"
;
FINDSOME ; EP - DEBUG
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
W !!,"DUZ(2)=",DUZ(2),!!,?4
;
S (CNTACC,CNT)=0,MAX=29
S LRDFN=.9999999
F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1!(CNT>MAX) D
. S LRIDT=.9999999
. F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1!(CNT>MAX) D
.. S IENS=LRIDT_","_LRDFN_","
.. ;
.. S IFIELD=.112
.. S INST=+$$GET1^DIQ(63.04,IENS,.112,"I") ; Accessioning Institution
.. I INST<1 D ; If no Accessioning Institution, use Requesting Location
... S REQLOC=+$$GET1^DIQ(63.04,IENS,.111,"I")
... S INST=$$GET1^DIQ(44,REQLOC,"INSTITUTION","I")
... S IFIELD=.111
.. ;
.. Q:INST=DUZ(2)
.. ;
.. S REFLAB=+$$GET1^DIQ(9009029,INST,3001,"I")
.. Q:REFLAB<1
.. ;
.. S REFLNAME=$$GET1^DIQ(9009026,REFLAB,.01)
.. ;
.. S CNTACC=CNTACC+1
.. I CNT<1 W:(CNTACC#100)=0 "." W:$X>74 !,?4
.. ;
.. S CNT=CNT+1
.. W:CNT=1 !!
.. W LRDFN
.. W ?9,LRIDT
.. W ?25,IFIELD
.. W ?35,INST
.. W ?45,REFLAB
.. W ?55,REFLNAME
.. W !
;
Q
;
FINDVISL ; EP - Find VLAB visits
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S TESTIEN=175 ; Hard set to Glucose
;
S HEADER(1)="VLAB Visits"
S HEADER(2)=" "
S HEADER(3)="IEN"
S $E(HEADER(3),10)="Visit IEN"
S $E(HEADER(3),20)="LR ACCESSION"
S $E(HEADER(3),35)="ICD CODE"
S $E(HEADER(3),45)="LOINC"
S $E(HEADER(3),55)="PROVIDER NARRATIVE"
; S $E(HEADER(3),75)="LABPC"
S $E(HEADER(3),75)="DFN"
;
D HEADERDT^BLRGMENU
;
S CNT=0,MAX=15
S VLABIEN="A"
F S VLABIEN=$O(^AUPNVLAB(VLABIEN),-1) Q:VLABIEN<1!(CNT>MAX) D
. K TARGET,ERRS
. D GETS^DIQ(9000010.09,VLABIEN,".01;.02;.03;.06;1112;1113;1601;1602","I","TARGET","ERRS")
. ;
. ; Don't duplicate patient
. S DFN=$G(TARGET(9000010.09,VLABIEN_",",.02,"I"))
. Q:$D(DFN(DFN))
. S DFN(DFN)=""
. ;
. W VLABIEN
. W ?9,$G(TARGET(9000010.09,VLABIEN_",",.03,"I"))
. W ?19,$G(TARGET(9000010.09,VLABIEN_",",.06,"I"))
. ; W ?34,$G(TARGET(9000010.09,VLABIEN_",",1112,"I"))
. W ?34,$$SHOWICD($G(TARGET(9000010.09,VLABIEN_",",1112,"I"))) ; IHS/MSC/MKK - LR*5.2*1034
. W ?44,$G(TARGET(9000010.09,VLABIEN_",",1113,"I"))
. W ?54,$E($G(TARGET(9000010.09,VLABIEN_",",1601,"I")),1,18)
. ; W ?74,$E($G(TARGET(9000010.09,VLABIEN_",",1602,"I")),1,6)
. W:$D(^DPT(DFN,"LR")) ?73,"*"
. W ?74,DFN
. W !
. S CNT=CNT+1
;
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
SHOWICD(ICD) ; EP -
NEW ICDSTR
;
S ICDSTR=$P($$ICDDX^ICDEX(ICD),"^",2)
S:ICDSTR["No Code Selected" ICDSTR=""
S:ICDSTR["Invalid" ICDSTR=ICD
Q ICDSTR
; ----- END IHS/MSC/MKK - LR*5.2*1034
;
VLABDATA(VLABIEN) ; EP - Display VLAB Data
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,VLABIEN,XPARSYS,XQXFLG)
;
S F60IEN=+$$GET1^DIQ(9000010.09,VLABIEN,.01,"I")
S VISITIEN=+$$GET1^DIQ(9000010.09,VLABIEN,.03,"I")
S DFN=$$GET1^DIQ(9000010.09,VLABIEN,.02,"I")
S COLLDATE=+$$GET1^DIQ(9000010.09,VLABIEN,1201,"I")
;
S DATANAME=$$GET1^DIQ(60,F60IEN,400,"I")
S LRDFN=+$$GET1^DIQ(2,+DFN,63)
;
S LRIDT=$S(+COLLDATE:(9999999-COLLDATE),1:" ")
;
S VISIENS=VISITIEN_","
S VLOCEIEN=$$GET1^DIQ(9000010,VISIENS,.06,"I")
S VLOCENIEN=$$GET1^DIQ(9999999.06,+VLOCEIEN,.01,"I")
S VHLOCIEN=$$GET1^DIQ(9000010,VISIENS,.22,"I")
;
W !!
W "VLABIEN:",VLABIEN,!
W ?4,"F60IEN:",F60IEN
W ?24,"DFN:",DFN
W ?39,"COLLDATE:",COLLDATE
W !!
;
W ?4,"DATANAME:",DATANAME
W ?19,"LRDFN:",LRDFN
W ?34,"LRIDT:",LRIDT
W !!
;
W ?4,"VISIT ",VISIENS," Data:",!
W ?9,"LOC. OF ENCOUNTER:",VLOCEIEN
W:$L(VLOCENIEN) ?39,VLOCENIEN,?49,$$GET1^DIQ(4,VLOCENIEN,.01)
W !
W ?9,"HOSPITAL LOCATION:",VHLOCIEN
W !!
;
S IENS=LRIDT_","_LRDFN_","
;
W "Last $PIECE from File 63 '",DATANAME,"' Node: ",$RE($P($RE($G(^LR(+LRDFN,"CH",+LRIDT,+DATANAME))),"^")),!
W ?4,"Raw Data:",$E($G(^LR(+LRDFN,"CH",+LRIDT,+DATANAME)),1,65),!!
;
S VPIEN=$$GET1^DIQ(63.04,IENS,.04,"I")
W "'Division' from File 63 Verify Person '",VPIEN,"' IEN: ",$$IHSDIV^XUS1(VPIEN),!!
;
S REQLOC=$TR($$GET1^DIQ(63.04,IENS,.11),".")
W "Requesting Location: ",REQLOC,!
I $L(REQLOC) D
. S F44IEN=$$FIND1^DIC(44,,,REQLOC)
. W:+F44IEN<1 ?4,"Lookup of ",REQLOC,": ",!
. I +F44IEN D
.. W ?4,"Lookup of '",REQLOC,"' in File 44 --",!
.. W ?19,"IEN: ",F44IEN,!
.. W ?19,"NAME: ",$$GET1^DIQ(44,F44IEN,"NAME"),!
.. W ?19,"INSTITUTION: ",$$GET1^DIQ(44,F44IEN,"INSTITUTION","I")
.. W !
. W !
;
W "Requesting LOC/DIV: ",$$GET1^DIQ(63.04,IENS,.111),!!
;
W "Accessioning Institituion: ",$$GET1^DIQ(63.04,IENS,.112),!!
;
S REQLOC=$$GET1^DIQ(63.04,IENS,.111,"I")
W:$L(REQLOC)<1 "Requesting Location Institution:",!!
W:$L(REQLOC) "Requesting Location '",REQLOC,"' Institution:",$$GET1^DIQ(44,REQLOC,"INSTITUTION","I"),!!
;
W "Default Institution in 69.9: ",$$GET1^DIQ(69.9,1_",",3,"I"),!!
Q
;
FINDVFVI ; EP - Find V File visits
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S HEADER(1)="VFile Visits"
S HEADER(2)=" "
S HEADER(3)="V File"
S $E(HEADER(3),13)="Visit"
S $E(HEADER(3),23)="File 60"
S HEADER(4)="Number"
S $E(HEADER(4),13)="IEN"
S $E(HEADER(4),23)="IEN"
S $E(HEADER(4),33)="LR ACCESSION"
S $E(HEADER(4),53)="DFN"
S $E(HEADER(4),63)="LRDFN"
;
D HEADERDT^BLRGMENU
;
; First, VLAB entries
S TESTIEN=175 ; Hard set to Glucose
S CNT=0,MAX=15
S VLABIEN="A"
F S VLABIEN=$O(^AUPNVLAB(VLABIEN),-1) Q:VLABIEN<1!(CNT>MAX) D
. K TARGET,ERRS
. ;
. D LISTVISD(9000010.09,VLABIEN)
;
W !
;
; NEXT, V MICRO Entries
S CNT=0,MAX=15
S VMICIEN=.9999999
F S VMICIEN=$O(^AUPNVMIC(VMICIEN)) Q:VMICIEN<1!(CNT>MAX) D
. D LISTVISD(9000010.25,VMICIEN)
;
Q
;
LISTVISD(VFILEIEN,VISITIEN) ; EP - List Visit Data
K TARGET,ERRS
;
D GETS^DIQ(VFILEIEN,VISITIEN,".01;.02;.06","I","TARGET","ERRS")
;
S DFN=+$G(TARGET(VFILEIEN,VISITIEN_",",.02,"I"))
S LRDFN=$$GET1^DIQ(2,+DFN,63)
Q:$L(LRDFN)<1
;
W VFILEIEN
W ?12,VISITIEN
W ?22,$G(TARGET(VFILEIEN,VISITIEN_",",.01,"I"))
W ?32,$G(TARGET(VFILEIEN,VISITIEN_",",.06,"I"))
S DFN=+$G(TARGET(VFILEIEN,VISITIEN_",",.02,"I"))
W ?52,DFN
W ?62,LRDFN
W !
S CNT=CNT+1
Q
BLRREFLA ;IHS/MSC/MKK - REFerence Lab Address functions ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1033,1034**;NOV 01, 1997;Build 88
+2 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
+4 ; API Function.
PCCRLADR(VFILENUM,VFILEIEN,ARRAY) ; EP - Get Address for Lab V File entry
+1 ; VFILENUM = Number of the Lab V File
+2 ; VFILEIEN = IEN of the test in the Lab V File
+3 ;
+4 ; Returns 1 if successful or 0 if failure.
+5 ;
+6 ; If successful, the ARRAY will be set as:
+7 ; ARRAY("ST1")=Street Address 1
+8 ; ARRAY("ST2")=Street Address 2 (array element only exists if Street Address 2 element exists)
+9 ; ARRAY("CITY")=City
+10 ; ARRAY("STATE")=STATE
+11 ; ARRAY("ZIP")=Zipcode
+12 ;
+13 ; If failure, the returned string is of the form
+14 ; 0^VFILENUM^DESCRIPTION
+15 ; where DESCRIPTION is a brief explanation of its failure (if possible)
+16 ;
+17 ; Uses the INSTITUTION number to determine the address.
+18 ;
+19 ; Initialize the array
+20 KILL ARRAY
+21 ;
+22 IF +$GET(VFILENUM)<1
QUIT "0^^V FILE NUMBER < 1"
+23 IF +$GET(VFILEIEN)<1
QUIT "0^"_VFILENUM_"^Lab V FILE IEN missing"
+24 ;
+25 IF VFILENUM=9000010.09
QUIT $$CHPCCSUB(VFILEIEN,.ARRAY)
+26 ;
+27 IF VFILENUM=9000010.25
QUIT $$MIPCCSUB(VFILEIEN,.ARRAY)
+28 ;
+29 QUIT "0^Lab V FILE NUMBER '"_VFILENUM_"' INVALID"
+30 ;
CHPCCSUB(VLABIEN,ARRAY) ; EP - "CH" subscripted tests
+1 NEW (ARRAY,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,VLABIEN,XPARSYS,XQXFLG)
+2 ;
+3 SET INST=0
+4 ;
+5 ; File 60 IEN
SET F60IEN=+$$GET1^DIQ(9000010.09,VLABIEN,.01,"I")
+6 ; DataName IEN
SET LRDN=+$$GET1^DIQ(60,F60IEN,400,"I")
+7 ;
+8 ; DFN = File 2 IEN
SET DFN=$$GET1^DIQ(9000010.09,VLABIEN,.02,"I")
+9 ; File 63 IEN
SET LRDFN=+$$GET1^DIQ(2,DFN,63)
+10 ;
+11 ; Collection Date
SET COLLDATE=+$$GET1^DIQ(9000010.09,VLABIEN,1201,"I")
+12 ;
+13 ; Inverse Date
SET LRIDT=9999999-COLLDATE
+14 ; File 63 Subscript
SET LRSS="CH"
+15 ;
+16 IF LRDN
IF LRDFN
IF COLLDATE
Begin DoDot:1
+17 ; Get Institution from Lab Data file
SET INST=+$PIECE($GET(^LR(LRDFN,LRSS,LRIDT,LRDN)),"^",9)
End DoDot:1
+18 ;
+19 SET IENS=LRIDT_","_LRDFN_","
+20 ;
+21 ; Verify Person
SET VPIEN=+$$GET1^DIQ(63.04,IENS,.04,"I")
+22 ;
+23 ; If Institution IEN still < 1, use Verify Person
+24 IF INST<1
SET INST=+$$IHSDIV^XUS1(VPIEN)
+25 ;
+26 ; If Institution IEN still < 1, set to Accessioning Institution
+27 IF INST<1
SET INST=+$$GET1^DIQ(63.04,IENS,.112,"I")
+28 ;
+29 ; If Institution IEN still < 1, use Requesting Location
IF INST<1
Begin DoDot:1
+30 SET REQLOC=+$$GET1^DIQ(63.04,IENS,.111,"I")
+31 SET INST=+$$GET1^DIQ(44,REQLOC,"INSTITUTION","I")
End DoDot:1
+32 ;
+33 ; If Institution IEN still < 1, set to Default Institution in 69.9
+34 IF INST<1
SET INST=+$$GET1^DIQ(69.9,1_",",3,"I")
+35 ;
+36 ; If cannot determine Institution, Quit with 0 (failure)
+37 IF INST<1
QUIT "0^9000010.09^Institution < 1"
+38 ;
+39 ; Call 'Get Address' function
+40 QUIT $$RLADDRES(INST,.ARRAY)
+41 ;
MIPCCSUB(VLMICIEN,ARRAY) ; EP - "MI" subscripted tests
+1 NEW (ARRAY,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,VLMICIEN,XPARSYS,XQXFLG)
+2 ;
+3 SET INST=0
+4 ;
+5 ; File 60 IEN
SET F60IEN=+$$GET1^DIQ(9000010.25,VLMICIEN,.01,"I")
+6 ; DFN = File 2 IEN
SET DFN=$$GET1^DIQ(9000010.09,VLMICIEN,.02,"I")
+7 ; File 63 IEN
SET LRDFN=+$$GET1^DIQ(2,DFN,63)
+8 ;
+9 ; Collection Date
SET COLLDATE=+$$GET1^DIQ(9000010.09,VLMICIEN,1201,"I")
+10 ; Inverse Date
SET LRIDT=9999999-COLLDATE
+11 ;
+12 SET IENS=LRIDT_","_LRDFN_","
+13 ;
+14 ; Verify Person
SET VPIEN=+$$GET1^DIQ(63.04,IENS,.04,"I")
+15 ;
+16 ; Use Verify Person
+17 IF INST<1
SET INST=+$$IHSDIV^XUS1(VPIEN)
+18 ;
+19 ; If Institution IEN still < 1, set to Accessioning Institution
+20 IF INST<1
SET INST=+$$GET1^DIQ(63.04,IENS,.112,"I")
+21 ;
+22 ; Accession Number
SET VFLRAS=$$GET1^DIQ(9000010.25,VLMICIEN,.06)
+23 SET LRAAAB=$PIECE(VFLRAS," ")
+24 ;
+25 KILL ERRS
+26 ; Get Accession IEN
SET LRAA=$$FIND1^DIC(68,,,LRAAAB,,,"ERRS")
+27 ;
+28 ; Find the Institution associated with the Accession's IEN
+29 IF F60IEN
IF LRAA
Begin DoDot:1
+30 SET (INSTIEN,INST)=0
+31 FOR
SET INSTIEN=$ORDER(^LAB(60,F60IEN,8,INSTIEN))
IF INSTIEN<1!(INST)
QUIT
Begin DoDot:2
+32 IF $PIECE($GET(^LAB(60,F60IEN,8,INSTIEN,0)),"^",2)=LRAA
SET INST=INSTIEN
End DoDot:2
End DoDot:1
+33 ;
+34 ; If Institution IEN still < 1, set to Default Institution in 69.9
+35 IF INST<1
SET INST=+$$GET1^DIQ(69.9,1_",",3,"I")
+36 ;
+37 ; If cannot determine Institution, Quit with 0 (failure)
+38 IF INST<1
QUIT "0^9000010.25^Institution < 1"
+39 ;
+40 ; Call 'Get Address' function
+41 QUIT $$RLADDRES(INST,.ARRAY)
+42 ;
+43 ; API Function.
+44 ; Given an IEN from file 4.
+45 ;
+46 ; If not successful, the function returns 0.
+47 ;
+48 ; If successful, the fucntion returns returns 1.
+49 ; The Reference Lab ADDRESS is returned in the ARRAY from file 4
+50 ; The array will be defined as the following:
+51 ; ARRAY("ST1")=Street Address 1
+52 ; ARRAY("ST2")=Street Address 2 (array element only exists if Street Address 2 element exists)
+53 ; ARRAY("CITY")=City
+54 ; ARRAY("STATE")=STATE
+55 ; ARRAY("ZIP")=Zipcode
+56 ;
RLADDRES(F4IEN,ARRAY) ; EP
+1 ; F4IEN = IEN from INSTITUTION (#4) file.
+2 ; Output (if any) will be put into the ARRAY
+3 ; Returns 1 if successful or 0 if failure.
+4 NEW (ARRAY,DILOCKTM,DISYS,DT,DTIME,DUZ,F4IEN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+5 ;
+6 ; Make sure array is initialized
KILL ARRAY
+7 ;
+8 ; File IEN not positive. Quit with 0 (failure)
+9 IF +$GET(F4IEN)<1
QUIT "0^INSTITUTION"
+10 ;
+11 SET NAME=$$GET1^DIQ(4,F4IEN,"NAME")
+12 SET ST1=$$GET1^DIQ(4,F4IEN,"STREET ADDR. 1")
+13 SET ST2=$$GET1^DIQ(4,F4IEN,"STREET ADDR. 2")
+14 SET CITY=$$GET1^DIQ(4,F4IEN,"CITY")
+15 SET STATE=$$GET1^DIQ(4,F4IEN,"STATE")
+16 SET ZIP=$$GET1^DIQ(4,F4IEN,"ZIP")
+17 ;
+18 ; All necessary address entries exist. Put into ARRAY and exit.
+19 IF $LENGTH(NAME)
IF $LENGTH(ST1)
IF $LENGTH(CITY)
IF $LENGTH(STATE)
IF $LENGTH(ZIP)
Begin DoDot:1
+20 SET ARRAY("NAME")=NAME
SET ARRAY("ST1")=ST1
+21 IF $LENGTH(ST2)
SET ARRAY("ST2")=ST2
+22 SET ARRAY("CITY")=CITY
SET ARRAY("STATE")=STATE
SET ARRAY("ZIP")=ZIP
End DoDot:1
QUIT 1
+23 ;
+24 ;
+25 ; Data does NOT exist. Quit with 0 (failure)
+26 QUIT "0^"_F4IEN_"^ADDRESS missing"
+27 ;
FINDSOME ; EP - DEBUG
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 WRITE !!,"DUZ(2)=",DUZ(2),!!,?4
+4 ;
+5 SET (CNTACC,CNT)=0
SET MAX=29
+6 SET LRDFN=.9999999
+7 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
IF LRDFN<1!(CNT>MAX)
QUIT
Begin DoDot:1
+8 SET LRIDT=.9999999
+9 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
IF LRIDT<1!(CNT>MAX)
QUIT
Begin DoDot:2
+10 SET IENS=LRIDT_","_LRDFN_","
+11 ;
+12 SET IFIELD=.112
+13 ; Accessioning Institution
SET INST=+$$GET1^DIQ(63.04,IENS,.112,"I")
+14 ; If no Accessioning Institution, use Requesting Location
IF INST<1
Begin DoDot:3
+15 SET REQLOC=+$$GET1^DIQ(63.04,IENS,.111,"I")
+16 SET INST=$$GET1^DIQ(44,REQLOC,"INSTITUTION","I")
+17 SET IFIELD=.111
End DoDot:3
+18 ;
+19 IF INST=DUZ(2)
QUIT
+20 ;
+21 SET REFLAB=+$$GET1^DIQ(9009029,INST,3001,"I")
+22 IF REFLAB<1
QUIT
+23 ;
+24 SET REFLNAME=$$GET1^DIQ(9009026,REFLAB,.01)
+25 ;
+26 SET CNTACC=CNTACC+1
+27 IF CNT<1
IF (CNTACC#100)=0
WRITE "."
IF $X>74
WRITE !,?4
+28 ;
+29 SET CNT=CNT+1
+30 IF CNT=1
WRITE !!
+31 WRITE LRDFN
+32 WRITE ?9,LRIDT
+33 WRITE ?25,IFIELD
+34 WRITE ?35,INST
+35 WRITE ?45,REFLAB
+36 WRITE ?55,REFLNAME
+37 WRITE !
End DoDot:2
End DoDot:1
+38 ;
+39 QUIT
+40 ;
FINDVISL ; EP - Find VLAB visits
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 ; Hard set to Glucose
SET TESTIEN=175
+4 ;
+5 SET HEADER(1)="VLAB Visits"
+6 SET HEADER(2)=" "
+7 SET HEADER(3)="IEN"
+8 SET $EXTRACT(HEADER(3),10)="Visit IEN"
+9 SET $EXTRACT(HEADER(3),20)="LR ACCESSION"
+10 SET $EXTRACT(HEADER(3),35)="ICD CODE"
+11 SET $EXTRACT(HEADER(3),45)="LOINC"
+12 SET $EXTRACT(HEADER(3),55)="PROVIDER NARRATIVE"
+13 ; S $E(HEADER(3),75)="LABPC"
+14 SET $EXTRACT(HEADER(3),75)="DFN"
+15 ;
+16 DO HEADERDT^BLRGMENU
+17 ;
+18 SET CNT=0
SET MAX=15
+19 SET VLABIEN="A"
+20 FOR
SET VLABIEN=$ORDER(^AUPNVLAB(VLABIEN),-1)
IF VLABIEN<1!(CNT>MAX)
QUIT
Begin DoDot:1
+21 KILL TARGET,ERRS
+22 DO GETS^DIQ(9000010.09,VLABIEN,".01;.02;.03;.06;1112;1113;1601;1602","I","TARGET","ERRS")
+23 ;
+24 ; Don't duplicate patient
+25 SET DFN=$GET(TARGET(9000010.09,VLABIEN_",",.02,"I"))
+26 IF $DATA(DFN(DFN))
QUIT
+27 SET DFN(DFN)=""
+28 ;
+29 WRITE VLABIEN
+30 WRITE ?9,$GET(TARGET(9000010.09,VLABIEN_",",.03,"I"))
+31 WRITE ?19,$GET(TARGET(9000010.09,VLABIEN_",",.06,"I"))
+32 ; W ?34,$G(TARGET(9000010.09,VLABIEN_",",1112,"I"))
+33 ; IHS/MSC/MKK - LR*5.2*1034
WRITE ?34,$$SHOWICD($GET(TARGET(9000010.09,VLABIEN_",",1112,"I")))
+34 WRITE ?44,$GET(TARGET(9000010.09,VLABIEN_",",1113,"I"))
+35 WRITE ?54,$EXTRACT($GET(TARGET(9000010.09,VLABIEN_",",1601,"I")),1,18)
+36 ; W ?74,$E($G(TARGET(9000010.09,VLABIEN_",",1602,"I")),1,6)
+37 IF $DATA(^DPT(DFN,"LR"))
WRITE ?73,"*"
+38 WRITE ?74,DFN
+39 WRITE !
+40 SET CNT=CNT+1
End DoDot:1
+41 ;
+42 QUIT
+43 ;
+44 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
SHOWICD(ICD) ; EP -
+1 NEW ICDSTR
+2 ;
+3 SET ICDSTR=$PIECE($$ICDDX^ICDEX(ICD),"^",2)
+4 IF ICDSTR["No Code Selected"
SET ICDSTR=""
+5 IF ICDSTR["Invalid"
SET ICDSTR=ICD
+6 QUIT ICDSTR
+7 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+8 ;
VLABDATA(VLABIEN) ; EP - Display VLAB Data
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,VLABIEN,XPARSYS,XQXFLG)
+2 ;
+3 SET F60IEN=+$$GET1^DIQ(9000010.09,VLABIEN,.01,"I")
+4 SET VISITIEN=+$$GET1^DIQ(9000010.09,VLABIEN,.03,"I")
+5 SET DFN=$$GET1^DIQ(9000010.09,VLABIEN,.02,"I")
+6 SET COLLDATE=+$$GET1^DIQ(9000010.09,VLABIEN,1201,"I")
+7 ;
+8 SET DATANAME=$$GET1^DIQ(60,F60IEN,400,"I")
+9 SET LRDFN=+$$GET1^DIQ(2,+DFN,63)
+10 ;
+11 SET LRIDT=$SELECT(+COLLDATE:(9999999-COLLDATE),1:" ")
+12 ;
+13 SET VISIENS=VISITIEN_","
+14 SET VLOCEIEN=$$GET1^DIQ(9000010,VISIENS,.06,"I")
+15 SET VLOCENIEN=$$GET1^DIQ(9999999.06,+VLOCEIEN,.01,"I")
+16 SET VHLOCIEN=$$GET1^DIQ(9000010,VISIENS,.22,"I")
+17 ;
+18 WRITE !!
+19 WRITE "VLABIEN:",VLABIEN,!
+20 WRITE ?4,"F60IEN:",F60IEN
+21 WRITE ?24,"DFN:",DFN
+22 WRITE ?39,"COLLDATE:",COLLDATE
+23 WRITE !!
+24 ;
+25 WRITE ?4,"DATANAME:",DATANAME
+26 WRITE ?19,"LRDFN:",LRDFN
+27 WRITE ?34,"LRIDT:",LRIDT
+28 WRITE !!
+29 ;
+30 WRITE ?4,"VISIT ",VISIENS," Data:",!
+31 WRITE ?9,"LOC. OF ENCOUNTER:",VLOCEIEN
+32 IF $LENGTH(VLOCENIEN)
WRITE ?39,VLOCENIEN,?49,$$GET1^DIQ(4,VLOCENIEN,.01)
+33 WRITE !
+34 WRITE ?9,"HOSPITAL LOCATION:",VHLOCIEN
+35 WRITE !!
+36 ;
+37 SET IENS=LRIDT_","_LRDFN_","
+38 ;
+39 WRITE "Last $PIECE from File 63 '",DATANAME,"' Node: ",$REVERSE($PIECE($REVERSE($GET(^LR(+LRDFN,"CH",+LRIDT,+DATANAME))),"^")),!
+40 WRITE ?4,"Raw Data:",$EXTRACT($GET(^LR(+LRDFN,"CH",+LRIDT,+DATANAME)),1,65),!!
+41 ;
+42 SET VPIEN=$$GET1^DIQ(63.04,IENS,.04,"I")
+43 WRITE "'Division' from File 63 Verify Person '",VPIEN,"' IEN: ",$$IHSDIV^XUS1(VPIEN),!!
+44 ;
+45 SET REQLOC=$TRANSLATE($$GET1^DIQ(63.04,IENS,.11),".")
+46 WRITE "Requesting Location: ",REQLOC,!
+47 IF $LENGTH(REQLOC)
Begin DoDot:1
+48 SET F44IEN=$$FIND1^DIC(44,,,REQLOC)
+49 IF +F44IEN<1
WRITE ?4,"Lookup of ",REQLOC,": ",!
+50 IF +F44IEN
Begin DoDot:2
+51 WRITE ?4,"Lookup of '",REQLOC,"' in File 44 --",!
+52 WRITE ?19,"IEN: ",F44IEN,!
+53 WRITE ?19,"NAME: ",$$GET1^DIQ(44,F44IEN,"NAME"),!
+54 WRITE ?19,"INSTITUTION: ",$$GET1^DIQ(44,F44IEN,"INSTITUTION","I")
+55 WRITE !
End DoDot:2
+56 WRITE !
End DoDot:1
+57 ;
+58 WRITE "Requesting LOC/DIV: ",$$GET1^DIQ(63.04,IENS,.111),!!
+59 ;
+60 WRITE "Accessioning Institituion: ",$$GET1^DIQ(63.04,IENS,.112),!!
+61 ;
+62 SET REQLOC=$$GET1^DIQ(63.04,IENS,.111,"I")
+63 IF $LENGTH(REQLOC)<1
WRITE "Requesting Location Institution:",!!
+64 IF $LENGTH(REQLOC)
WRITE "Requesting Location '",REQLOC,"' Institution:",$$GET1^DIQ(44,REQLOC,"INSTITUTION","I"),!!
+65 ;
+66 WRITE "Default Institution in 69.9: ",$$GET1^DIQ(69.9,1_",",3,"I"),!!
+67 QUIT
+68 ;
FINDVFVI ; EP - Find V File visits
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET HEADER(1)="VFile Visits"
+4 SET HEADER(2)=" "
+5 SET HEADER(3)="V File"
+6 SET $EXTRACT(HEADER(3),13)="Visit"
+7 SET $EXTRACT(HEADER(3),23)="File 60"
+8 SET HEADER(4)="Number"
+9 SET $EXTRACT(HEADER(4),13)="IEN"
+10 SET $EXTRACT(HEADER(4),23)="IEN"
+11 SET $EXTRACT(HEADER(4),33)="LR ACCESSION"
+12 SET $EXTRACT(HEADER(4),53)="DFN"
+13 SET $EXTRACT(HEADER(4),63)="LRDFN"
+14 ;
+15 DO HEADERDT^BLRGMENU
+16 ;
+17 ; First, VLAB entries
+18 ; Hard set to Glucose
SET TESTIEN=175
+19 SET CNT=0
SET MAX=15
+20 SET VLABIEN="A"
+21 FOR
SET VLABIEN=$ORDER(^AUPNVLAB(VLABIEN),-1)
IF VLABIEN<1!(CNT>MAX)
QUIT
Begin DoDot:1
+22 KILL TARGET,ERRS
+23 ;
+24 DO LISTVISD(9000010.09,VLABIEN)
End DoDot:1
+25 ;
+26 WRITE !
+27 ;
+28 ; NEXT, V MICRO Entries
+29 SET CNT=0
SET MAX=15
+30 SET VMICIEN=.9999999
+31 FOR
SET VMICIEN=$ORDER(^AUPNVMIC(VMICIEN))
IF VMICIEN<1!(CNT>MAX)
QUIT
Begin DoDot:1
+32 DO LISTVISD(9000010.25,VMICIEN)
End DoDot:1
+33 ;
+34 QUIT
+35 ;
LISTVISD(VFILEIEN,VISITIEN) ; EP - List Visit Data
+1 KILL TARGET,ERRS
+2 ;
+3 DO GETS^DIQ(VFILEIEN,VISITIEN,".01;.02;.06","I","TARGET","ERRS")
+4 ;
+5 SET DFN=+$GET(TARGET(VFILEIEN,VISITIEN_",",.02,"I"))
+6 SET LRDFN=$$GET1^DIQ(2,+DFN,63)
+7 IF $LENGTH(LRDFN)<1
QUIT
+8 ;
+9 WRITE VFILEIEN
+10 WRITE ?12,VISITIEN
+11 WRITE ?22,$GET(TARGET(VFILEIEN,VISITIEN_",",.01,"I"))
+12 WRITE ?32,$GET(TARGET(VFILEIEN,VISITIEN_",",.06,"I"))
+13 SET DFN=+$GET(TARGET(VFILEIEN,VISITIEN_",",.02,"I"))
+14 WRITE ?52,DFN
+15 WRITE ?62,LRDFN
+16 WRITE !
+17 SET CNT=CNT+1
+18 QUIT
