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

LA7VORM1.m

Go to the documentation of this file. 
  1. LA7VORM1 ;VA/DALOI/DLR - LAB ORM (Order) message builder ; 13-Aug-2013 09:09 ; MKK
  1.  ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,51,46,61,1018,64,1027,68,1033**;NOV 01, 1997;Build 9
  1.  ;
  1. BUILD(LA7628) ;
  1.  ; Call with LA7628 = ien of entry in file #62.8 Shipping Manifest
  1.  ;
  1.  N LA7101,LA762801,LA7629,LA7NVAF,LA7PIDSN,LA7X,ECNT,GBL,SHP,SHPC,SITE,ORUID,NTST
  1.  ;
  1.  I $G(LA7628)<1!('$D(^LAHM(62.8,+$G(LA7628),0))) D  Q
  1.  . ; Need to add error logging for manifest not found.
  1.  . D EXIT
  1.  ;
  1.  S GBL="^TMP(""HLS"","_$J_")",ECNT=1
  1.  S LA7628(0)=$G(^LAHM(62.8,LA7628,0))
  1.  S LA7629=$P(LA7628(0),U,2)
  1.  S LA7629(0)=$G(^LAHM(62.9,LA7629,0))
  1.  S LA76248=+$P(LA7629(0),"^",7)
  1.  S LA76248(0)=$G(^LAHM(62.48,LA76248,0))
  1.  I '$P(LA76248(0),"^",3) D EXIT Q  ; not active
  1.  ;
  1.  S LA7V("INST")=$P(LA7629(0),U,11)
  1.  Q:LA7V("INST")=$P(LA7629(0),U,6)  ;Same system shipment
  1.  ;
  1.  S LA7NVAF=$$NVAF^LA7VHLU2(+LA7V("INST")),SITE=""
  1.  I LA7NVAF=0 S SITE=$$GET1^DIQ(4,+$P(LA7629(0),U,11)_",",99)
  1.  I LA7NVAF=1 S SITE=$$ID^XUAF4("DMIS",+$P(LA7629(0),U,11))
  1.  S LA7V("NON")=$P(LA7629(0),U,12)
  1.  I LA7V("NON")'="" S SITE=LA7V("NON")
  1.  ;
  1.  S LA7X=$$NVAF^LA7VHLU2(+$P(LA7629(0),U,2))
  1.  I LA7X=0 S LA7V("CLNT")=$$GET1^DIQ(4,+$P(LA7629(0),U,2)_",",99)
  1.  I LA7X=1 S LA7V("CLNT")=$$ID^XUAF4("DMIS",+$P(LA7629(0),U,2))
  1.  S $P(LA7V("CLNT"),U,2)=$$GET1^DIQ(4,+$P(LA7629(0),U,2)_",",.01)
  1.  ;
  1.  S LA7X=$$NVAF^LA7VHLU2(+$P(LA7629(0),U,3))
  1.  I LA7X=0 S LA7V("HOST")=$$GET1^DIQ(4,+$P(LA7629(0),U,3)_",",99)
  1.  I LA7X=1 S LA7V("HOST")=$$ID^XUAF4("DMIS",+$P(LA7629(0),U,3))
  1.  S $P(LA7V("HOST"),U,2)=$$GET1^DIQ(4,+$P(LA7629(0),U,3)_",",.01)
  1.  ;
  1.  ; Assuming the receiving institution is the primary site (site with the computer system)
  1.  ;
  1.  ; Set flag = 0 (multiple PID's/message - build one message)
  1.  ;            1 (one PID/message - build multiple messages)
  1.  ;            2 (one ORC/message - build multiple messages)
  1.  S LA7SMSG=+$P(LA76248(0),"^",8)
  1.  ;
  1.  ; Sort tests by patient,UID,test - only need to build one PID, PV1 per patient
  1.  ; ^TMP("LA7628",$J, LRDFN, accession UID, ien of shipping manifest specimen entry)
  1.  K ^TMP("LA7628",$J)
  1.  S LA762801=0
  1.  F  S LA762801=$O(^LAHM(62.8,LA7628,10,LA762801)) Q:'LA762801  D
  1.  . S X(0)=$G(^LAHM(62.8,LA7628,10,LA762801,0))
  1.  . I $P(X(0),"^",8)=0 Q  ; Removed from manifest
  1.  . I $G(LA7SMSG)'=3 D  ;cmi/maw for LEDI IHS order
  1.  .. I $P(X(0),"^"),$L($P(X(0),"^",5)) S ^TMP("LA7628",$J,+$P(X(0),"^"),$P(X(0),"^",5),LA762801)=""
  1.  . I $G(LA7SMSG)=3 D  ;cmi/maw for LEDI IHS order
  1.  .. I $P(X(0),"^"),$L($P(X(0),"^",5)) S ^TMP("LA7628",$J,$$GETORDA($P(X(0),"^",5)),$P(X(0),"^",5),LA762801)=""
  1.  .. ;I $P(X(0),"^"),$L($P(X(0),"^",5)) S ^TMP("LA7628",$J,+$P(X(0),"^"),$$GETORDA($P(X(0),"^",5))_"~"_$P(X(0),"^",5),LA762801)=""
  1.  K LA762801
  1.  ;
  1.  ; Nothing to send
  1.  I '$D(^TMP("LA7628",$J)) D EXIT Q
  1.  ;
  1.  ;
  1.  I LA7SMSG=0 D  Q:$G(HL)
  1.  . D STARTMSG
  1.  . I $G(HL) D EXIT
  1.  ;
  1.  ;S (LRDFN,LRI,LA7PIDSN,LA7ORD)=0  ;ihs/cmi/maw 11/17/2010
  1.  S (LRDFN,LRI,LA7PIDSN,LA7ORD,LA7OBRSN)=0  ;ihs/cmi/maw 11/17/2010
  1.  F  S LA7ORD=$O(^TMP("LA7628",$J,LA7ORD)) Q:'LA7ORD  D  Q:$G(HL)
  1.  . N LA7PID,LA7PV1,LA7ORDI,LA7ORDD,LA7ORI
  1.  . I LA7SMSG=1 D STARTMSG Q:$G(HL)
  1.  . S LA7ORDI=$Q(^LRO(69,"C",LA7ORD))
  1.  . I $QS(LA7ORDI,3)'=LA7ORD Q
  1.  . S LA7ORDD=$QS(LA7ORDI,4)
  1.  . S LA7ORI=$QS(LA7ORDI,5)
  1.  . S LRDFN=+$G(^LRO(69,LA7ORDD,1,LA7ORI,0))
  1.  . ;S LA7ORD=$$GETORD(LRDFN)  ;cmi/maw get order number
  1.  . I LA7SMSG<2 D PID,PV1,IN1(LA7ORD),GT1(LA7ORD)  ;cmi/maw for billing info
  1.  . I LA7SMSG=3 D STARTMSG Q:$G(HL)  D PID,PV1,IN1(LA7ORD),GT1(LA7ORD)  ;,INS  ;cmi/maw 5/26/2010 insurance added LEDI order
  1.  . S LA7UID=""
  1.  . S (LA7GUAR,LA7DGQ)=0  ;cmi/maw 5/26/2010 insurance
  1.  . F  S LA7UID=$O(^TMP("LA7628",$J,LA7ORD,LA7UID)) Q:LA7UID=""  D
  1.  . . N LA76802,LA7ORC,X
  1.  . . S X=$Q(^LRO(68,"C",LA7UID))
  1.  . . I $QS(X,3)'=LA7UID Q
  1.  . . S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
  1.  . . F I=0,.1,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I))  ;cmi/maw 3/10/2010 get .1 node as well
  1.  . . ;F I=0,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I))  cmi/maw 3/10/2010 orig line
  1.  . . S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
  1.  . . S LA76802(5)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,I,0))
  1.  . . I LA7SMSG=2 D STARTMSG Q:$G(HL)  D PID,PV1,IN1(LA7ORD),GT1(LA7ORD)  ;,INS  ;cmi/maw 5/26/2010 insurance added
  1.  . . S (LA7OBRSN,LA762801)=0  ;ihs/cmi/maw 11/16/2010 orig line changed back 04/04/2011 to this
  1.  . . ;S LA762801=0  ;ihs/cmi/maw 11/17/2010 mod changed back 04/04/2011
  1.  . . F  S LA762801=$O(^TMP("LA7628",$J,LA7ORD,LA7UID,LA762801)) Q:'LA762801  D
  1.  . . . N LA7OBR,I
  1.  . . . F I=0,.1,1,2,5 S LA762801(I)=$G(^LAHM(62.8,LA7628,10,LA762801,I))
  1.  . . . I $$CHKTST^LA7SMU(LA7628,LA762801)'=0 Q  ;deleted accession
  1.  . . . D ORC,OBR^LA7VORM3,DG1(LA7ORD),OBX(LA7ORD,LA7UID)  ;cmi/maw 06/23/2010 added DG1 segment for LEDI
  1.  . . I LA7SMSG=2 D BLG,SENDMSG
  1.  . I LA7SMSG=3 D BLG,SENDMSG  ;cmi/maw 7/1/2010 for ledi insurance
  1.  . S (LA7DGQ,LA7GUAR)=0  ;cmi/maw 5/26/2010 added for insurance
  1.  . I LA7SMSG<2 D BLG
  1.  . I LA7SMSG=1 D SENDMSG
  1.  ;
  1.  I LA7SMSG=0 D SENDMSG
  1.  ;
  1.  ;ihs/cmi/maw 9/27/10 below is original ledi code
  1.  ;S (LRDFN,LRI,LA7PIDSN)=0
  1.  ;F  S LRDFN=$O(^TMP("LA7628",$J,LRDFN)) Q:'LRDFN  D  Q:$G(HL)
  1.  ;. N LA7PID,LA7PV1
  1.  ;. I LA7SMSG=1 D STARTMSG Q:$G(HL)
  1.  ;. S LA7ORD=$$GETORD(LRDFN)  ;cmi/maw get order number
  1.  ;. I LA7SMSG<2 D PID,PV1,IN1(LA7ORD),GT1(LA7ORD)  ;cmi/maw for billing info
  1.  ;. I LA7SMSG=3 D STARTMSG Q:$G(HL)  D PID,PV1,IN1(LA7ORD),GT1(LA7ORD)  ;,INS  ;cmi/maw 5/26/2010 insurance added LEDI order
  1.  ;. S LA7UID=""
  1.  ;. S (LA7GUAR,LA7DGQ)=0  ;cmi/maw 5/26/2010 insurance
  1.  ;. F  S LA7UID=$O(^TMP("LA7628",$J,LRDFN,LA7UID)) Q:LA7UID=""  D
  1.  ;. . N LA76802,LA7ORC,X
  1.  ;. . S X=$Q(^LRO(68,"C",$P(LA7UID,"~",2)))
  1.  ;. . I $QS(X,3)'=$P(LA7UID,"~",2) Q
  1.  ;. . S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
  1.  ;. . F I=0,.1,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I))  ;cmi/maw 3/10/2010 get .1 node as well
  1.  ;. . ;F I=0,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I))  cmi/maw 3/10/2010 orig line
  1.  ;. . S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
  1.  ;. . S LA76802(5)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,I,0))
  1.  ;. . I LA7SMSG=2 D STARTMSG Q:$G(HL)  D PID,PV1,IN1(LA7ORD),GT1(LA7ORD)  ;,INS  ;cmi/maw 5/26/2010 insurance added
  1.  ;. . S (LA7OBRSN,LA762801)=0
  1.  ;. . F  S LA762801=$O(^TMP("LA7628",$J,LRDFN,LA7UID,LA762801)) Q:'LA762801  D
  1.  ;. . . N LA7OBR,I
  1.  ;. . . F I=0,.1,1,2,5 S LA762801(I)=$G(^LAHM(62.8,LA7628,10,LA762801,I))
  1.  ;. . . I $$CHKTST^LA7SMU(LA7628,LA762801)'=0 Q  ;deleted accession
  1.  ;. . . D ORC,OBR^LA7VORM3,DG1(LA7ORD),OBX^LA7VORM3  ;cmi/maw 06/23/2010 added DG1 segment for LEDI
  1.  ;. . I LA7SMSG=2 D BLG,SENDMSG
  1.  ;. . I LA7SMSG=3 D BLG,SENDMSG  ;cmi/maw 7/1/2010 for ledi insurance
  1.  ;. . S (LA7DGQ,LA7GUAR)=0  ;cmi/maw 5/26/2010 added for insurance
  1.  ;. I LA7SMSG<2 D BLG
  1.  ;. I LA7SMSG=1 D SENDMSG
  1.  ;
  1.  ;I LA7SMSG=0 D SENDMSG
  1.  ;ihs/cmi/maw end of orig ledi code
  1.  ;
  1. EXIT ;
  1.  K @GBL,^TMP("LA7628",$J)
  1.  K DIC,DFN,EID,HL,HLCOMP,HLFS,HLQ,HLSUB,INT
  1.  K LA760,LA7628,LA762801,LA7629
  1.  K LA7ECH,LA7FS,LA7MID,LA7V,LA7HDR,LA7OBRSN,LA7OBXSN,LA7VIEN,LAEVNT
  1.  K LRAA,LRACC,LRAD,LRAN,LRDFN,LRI
  1.  K LTST,NLT,NLTIEN,PCNT,RUID,SNIEN,TIEN,X,Y,LA
  1.  D KVAR^LRX
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  Q
  1.  ;
  1.  ;
  1. STARTMSG ; Create/initialize HL message
  1.  ;
  1.  K @GBL
  1.  S (LA76249,LA7PIDSN)=0
  1.  D STARTMSG^LA7VHLU("LA7V Order to "_SITE,.LA76249)
  1.  Q
  1.  ;
  1.  ;
  1. SENDMSG ; File HL7 message with HL and LAB packages.
  1.  ;
  1.  N LA7DATA,LA7ID
  1.  S LA7ID="LA7V HOST "_SITE_"-O-"_$P($G(LA7628(0)),"^")
  1.  ; If no message to send then quit
  1.  I '$D(^TMP("HLS",$J)) D  Q
  1.  . N FDA,LA7ER
  1.  . I $G(LA76248) S FDA(1,62.49,LA76249_",",.5)=LA76248
  1.  . S FDA(1,62.49,LA76249_",",1)="O"
  1.  . S FDA(1,62.49,LA76249_",",2)="E"
  1.  . S FDA(1,62.49,LA76249_",",5)=LA7ID
  1.  . D FILE^DIE("","FDA(1)","LA7ER(1)")
  1.  . D CLEAN^DILF
  1.  . L -^LAHM(62.49,LA76249)
  1.  ;
  1.  D GEN^LA7VHLU
  1.  S LA7DATA="SM06"_"^"_$$NOW^XLFDT
  1.  D SEUP^LA7SMU($P(LA7628(0),"^"),"1",LA7DATA)
  1.  D UPDT6249
  1.  ; Unlock entry
  1.  L -^LAHM(62.49,LA76249)
  1.  Q
  1.  ;
  1.  ;
  1. UPDT6249 ; update entry in 62.49
  1.  ;
  1.  N FDA,LA7ER
  1.  ;
  1.  I $G(LA76248) S FDA(1,62.49,LA76249_",",.5)=LA76248
  1.  S FDA(1,62.49,LA76249_",",1)="O"
  1.  I $P(^LAHM(62.49,LA76249,0),"^",3)'="E" D
  1.  . I $G(HL("APAT"))="AL" S FDA(1,62.49,LA76249_",",2)="A"
  1.  . E  S FDA(1,62.49,LA76249_",",2)="X"
  1.  . I $G(LA7ERR) S FDA(1,62.49,LA76249_",",2)="E"
  1.  S FDA(1,62.49,LA76249_",",5)=LA7ID
  1.  I $G(HL("SAN"))'="" S FDA(1,62.49,LA76249_",",102)=HL("SAN")
  1.  I $G(HL("SAF"))'="" S FDA(1,62.49,LA76249_",",103)=HL("SAF")
  1.  I $G(HL("MTN"))'="" S FDA(1,62.49,LA76249_",",108)=HL("MTN")
  1.  I $G(HL("PID"))'="" S FDA(1,62.49,LA76249_",",110)=HL("PID")
  1.  I $G(HL("VER"))'="" S FDA(1,62.49,LA76249_",",111)=HL("VER")
  1.  I $P($G(LA7MID),"^")'="" S FDA(1,62.49,LA76249_",",109)=$P(LA7MID,"^")
  1.  I $P($G(LA7MID),"^",2) D
  1.  . S FDA(1,62.49,LA76249_",",160)=$P(LA7MID,"^",2)
  1.  . S FDA(1,62.49,LA76249_",",161)=$P(LA7MID,"^",3)
  1.  D FILE^DIE("","FDA(1)","LA7ER(1)")
  1.  D CLEAN^DILF
  1.  Q
  1.  ;
  1.  ;
  1. PID ; Patient identification
  1.  S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
  1.  D DEM^LRX
  1.  D PID^LA7VPID(LRDFN,"",.LA7PID,.LA7PIDSN,.HL,"")
  1.  ; DoD/CHCS facilities only use 1st repetition of PID-3.
  1.  I LA7NVAF=1 D
  1.  . S X=$P(LA7PID(0),LA7FS,4),X=$P(X,$E(LA7ECH,2))
  1.  . S $P(LA7PID(0),LA7FS,4)=X
  1.  D FILESEG^LA7VHLU(GBL,.LA7PID)
  1.  D FILE6249^LA7VHLU(LA76249,.LA7PID)
  1.  Q
  1.  ;
  1.  ;
  1. PV1 ; Location information
  1.  ; DoD/CHCS facilities do not use PV1 segment
  1.  I LA7NVAF=1 Q
  1.  ;
  1.  D PV1^LA7VPID(LRDFN,.LA7PV1,LA7FS,LA7ECH)
  1.  D FILESEG^LA7VHLU(GBL,.LA7PV1)
  1.  D FILE6249^LA7VHLU(LA76249,.LA7PV1)
  1.  Q
  1.  ;
  1.  ;
  1. ORC ;Order Control
  1.  ;
  1.  N ORC,LA7DATA,LA7DUR,LA7DURU,LA76205,LA762801,LA7X
  1.  ;
  1.  S ORC(0)="ORC"
  1.  S ORC(1)=$$ORC1^LA7VORC("NW")
  1.  ;
  1.  ; Place order number - accession UID
  1.  ;S ORC(2)=$$ORC2^LA7VORC($P(LA76802(.3),"^"),LA7FS,LA7ECH)
  1.  S ORC(2)=$$ORC2^LA7VORC($P(LA76802(.1),"^"),LA7FS,LA7ECH)
  1.  ;
  1.  ; Placer group number - shipping manifest invoice #
  1.  S ORC(4)=$$ORC4^LA7VORC($P(LA7628(0),"^"),LA7FS,LA7ECH)
  1.  ;
  1.  ; Quantity/Timing
  1.  S (LA76205,LA7DUR,LA7DURU)=""
  1.  S LA762801=0
  1.  ;F  S LA762801=$O(^TMP("LA7628",$J,LRDFN,LA7UID,LA762801)) Q:'LA762801  D  ;ihs/cmi/maw ledi orig
  1.  F  S LA762801=$O(^TMP("LA7628",$J,LA7ORD,LA7UID,LA762801)) Q:'LA762801  D  ;ihs/cmi/maw 09/27/2010 ledi new
  1.  . N I,LA760
  1.  . ; Test duration
  1.  . F I=0,2 S LA762801(I)=$G(^LAHM(62.8,LA7628,10,LA762801,I))
  1.  . I $P(LA762801(2),"^",4) D
  1.  . . S LA7DUR=$P(LA762801(2),"^",6) ; collection duration
  1.  . . S LA7DURU=$P(LA762801(2),"^",7) ; duration units
  1.  . ; Test urgency - find highest urgency on accession
  1.  . S LA760=+$P(LA762801(0),"^",2)
  1.  . S X=+$$GET1^DIQ(68.04,LA760_","_LRAN_","_LRAD_","_LRAA_",",1,"I")
  1.  . I 'LA76205 S LA76205=X
  1.  . I LA76205,X<LA76205 S LA76205=X
  1.  S ORC(7)=$$ORC7^LA7VORC(LA7DUR,LA7DURU,LA76205,LA7FS,LA7ECH)
  1.  ;
  1.  ; Order Date/Time - if no order date/time then try draw time
  1.  I $P(LA76802(0),"^",4) S ORC(9)=$$ORC9^LA7VORC($P(LA76802(0),"^",4))
  1.  I '$P(LA76802(0),"^",4),$P(LA76802(3),"^") S ORC(9)=$$ORC9^LA7VORC($P(LA76802(3),"^"))
  1.  ;
  1.  ; Ordering provider
  1.  S LA7X=$$FNDOLOC^LA7VHLU2(LA7UID)
  1.  S ORC(12)=$$ORC12^LA7VORC($P(LA76802(0),"^",8),$P(LA7X,"^",3),LA7FS,LA7ECH)
  1.  ;
  1.  ; Entering organization - VA facility
  1.  S ORC(17)=$$ORC17^LA7VORC($P($G(LA7629(0)),U,2),LA7FS,LA7ECH)
  1.  ;
  1.  D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
  1.  D FILESEG^LA7VHLU(GBL,.LA7DATA)
  1.  D FILE6249^LA7VHLU(LA76249,.LA7DATA)
  1.  Q
  1.  ;
  1. GETORD(DF) ;-- get the order number
  1.  N LA7QUID
  1.  S LA7QUID=$O(^TMP("LA7628",$J,DF,0))
  1.  I $G(LA7QUID)="" Q ""
  1.  Q $P(LA7QUID,"~")
  1.  ;
  1. GETORDA(UID) ;-- get the order number
  1.  N X
  1.  S X=$Q(^LRO(68,"C",UID))
  1.  I $QS(X,3)'=UID Q ""
  1.  S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
  1.  F I=0,.1,.3,3 S LA76802(I)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,I))  ;cmi/maw 3/10/2010 get .1 node as well
  1.  Q $G(LA76802(.1))
  1.  ;
  1. DG1(ORD) ;-- handle the diagnosis
  1.  Q:$P($$ACCT^LA7VQINS(ORD),U,4)'="T"
  1.  D DG1^LA7VQINS(ORD)
  1.  Q
  1.  ;
  1. GT1(ORD) ;-- handle the guarantor
  1.  Q:$P($$ACCT^LA7VQINS(ORD),U,4)="C"  ;ihs/cmi/maw 11/18/2010 changed to send if T or P
  1.  D GAR^LA7VQINS(DFN,,,1)
  1.  Q
  1.  ;
  1. IN1(ORD) ;-- handle insurance
  1.  ;Q:$P($$ACCT^LA7VQINS(ORD),U,4)'="T"
  1.  K IN1  ;maybe this is hanging around?
  1.  S CNT=0  ;ihs/cmi/maw resets the IN1 segment counter 1/12/2011
  1.  D INS^LA7VQINS(1,ORD)
  1.  Q
  1.  ;
  1. OBX(ORD,UID) ;-- build the obx ask at order questions
  1.  D OBX^LA7VQINS(ORD,UID)  ;ihs/cmi/maw 11/15/2010 - lets put the local ask at order questions in OBX
  1.  Q
  1. BLG ; Billing segment
  1.  ;
  1.  Q  ;cmi/maw 4/14/2010 no BLG segment, will replace with DG1, IN1, and GT1
  1.  N LA7BLG
  1.  ;
  1.  I $P(LA7629(0),U,13)="" Q
  1.  S LA7BLG(0)=$$BLG^LA7VHLU($P(LA7629(0),"^",13),"CO",LA7FS,LA7ECH)
  1.  D FILESEG^LA7VHLU(GBL,.LA7BLG)
  1.  D FILE6249^LA7VHLU(LA76249,.LA7BLG)
  1.  Q