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

MAGDHLS.m

Go to the documentation of this file.
  1. MAGDHLS ;WOIFO/MLH/JSL/SAF/PMK - IHE-based ADT interface for PACS - segments ;13 Sep 2018 3:55 PM
  1. ;;3.0;IMAGING;**49,123,141,138,183,208**;Mar 19, 2002;Build 6;Sep 03, 2013
  1. ;; Per VHA Directive 2004-038, this routine should not be modified.
  1. ;; +---------------------------------------------------------------+
  1. ;; | Property of the US Government. |
  1. ;; | No permission to copy or redistribute this software is given. |
  1. ;; | Use of unreleased versions of this software requires the user |
  1. ;; | to execute a written test agreement with the VistA Imaging |
  1. ;; | Development Office of the Department of Veterans Affairs, |
  1. ;; | telephone (301) 734-0100. |
  1. ;; | The Food and Drug Administration classifies this software as |
  1. ;; | a medical device. As such, it may not be changed in any way. |
  1. ;; | Modifications to this software may result in an adulterated |
  1. ;; | medical device under 21CFR820, the use of which is considered |
  1. ;; | to be a violation of US Federal Statutes. |
  1. ;; +---------------------------------------------------------------+
  1. ;;
  1. ; Supported IA #928 reference ACTIVE^GMPLUTL subroutine call
  1. ; Supported IA #10099 reference EN1^GMRADPT subroutine call
  1. ; Supported IA #2710 reference ^MPIF001 function calls ($$ISIHS,$$GETICN,$$IFOCAL)
  1. ; Supported IA #10061 reference ^VADPT subroutine calls (DEM,IN5,PID)
  1. ; Supported IA #263 reference $$EN^VAFHLPID function call
  1. ; Supported IA #10103 reference $$FMTHL7^XLFDT function call
  1. ;
  1. Q
  1. ;
  1. ; It is always expected that the HL7 environment variables will have
  1. ; been initialized by a call to INIT^HLFNC2 for the appropriate event
  1. ; driver protocol.
  1. ;
  1. AL1(XDFN,XYMSG) ; patient allergies
  1. ; input: XDFN internal entry number of the patient on global ^DPT
  1. ; XYMSG name of array to which to add message elts
  1. ; output: @XYMSG input array plus new subtree containing EVN elts
  1. ; function return 0 (success) always
  1. ;
  1. N DFN ; ------ internal entry number on ^DPT
  1. N GMRAL ;----- return allergy array from EN1^GMRADPT
  1. N IXAL ; ----- allergy index (on GMRAL array)
  1. N SETID ; ---- index of the AL1 segment on this message
  1. N ALDTA ; ---- allergy data
  1. N IXREAC ; --- reaction index
  1. N REPIX ; ---- field repetition index
  1. N VA,VADPT ; - return arrays from DEM^VADPT containing patient demographics
  1. ;
  1. D DEM^VADPT
  1. ;
  1. K YSEGA
  1. S DFN=XDFN D EN1^GMRADPT ; get patient's allergies
  1. S IXAL=0
  1. F SETID=1:1 S IXAL=$O(GMRAL(IXAL)) Q:'IXAL D
  1. . S ALDTA=$G(GMRAL(IXAL))
  1. . S SEGIX=$O(@XYMSG@(" "),-1)+1
  1. . S @XYMSG@(SEGIX,0)="AL1"
  1. . S @XYMSG@(SEGIX,1,1,1,1)=SETID
  1. . S @XYMSG@(SEGIX,2,1,1,1)=$P(ALDTA,U,7) ; type
  1. . S @XYMSG@(SEGIX,3,1,2,1)=$P(ALDTA,U,2) ; description
  1. . S IXREAC=0
  1. . F REPIX=1:1 S IXREAC=$O(GMRAL(IXAL,"S",IXREAC)) Q:'IXREAC D
  1. . . S @XYMSG@(SEGIX,5,REPIX,1,1)=$P($G(GMRAL(IXAL,"S",IXREAC)),";",1) ; reaction
  1. . . Q
  1. . Q
  1. Q 0
  1. ;
  1. DG1(XDFN,XYMSG) ; FUNCTION - diagnosis
  1. ; input: XDFN internal entry number of the patient on global ^DPT
  1. ; XYMSG name of array to which to add message elts
  1. ; output: @XYMSG input array plus new subtree containing EVN elts
  1. ; function return 0 (success) always
  1. ;
  1. N DFN ; ----- internal entry number on ^DPT
  1. N VAIP ; ---- inpatient episode data array
  1. N SETID ; --- segment index for diagnoses
  1. N APROB ; --- problem list array
  1. N PROBIX ; -- problem list index
  1. ;
  1. S SETID=0 ; segment increment base
  1. S DFN=XDFN D IN5^VADPT ; get patient's inpatient episode data
  1. I $G(VAIP(9))'="" D ; is there a diag assoc'd w/the latest movement?
  1. . ; yes, populate data for the DG1 segment
  1. . S SEGIX=$O(@XYMSG@(" "),-1)+1
  1. . S @XYMSG@(SEGIX,0)="DG1" ; segment ID
  1. . ; populate element leaves
  1. . S SETID=SETID+1
  1. . S @XYMSG@(SEGIX,1,1,1,1)=SETID
  1. . S @XYMSG@(SEGIX,3,1,2,1)=$E(VAIP(9),1,249) ; diagnosis text
  1. . ; either admitting or working diagnosis
  1. . S @XYMSG@(SEGIX,6,1,1,1)=$S($P($G(VAIP(2)),"^",1)=1:"A",1:"W")
  1. . Q
  1. ;
  1. ; get patient's active problem list
  1. D ACTIVE^GMPLUTL(XDFN,.APROB)
  1. S PROBIX=0
  1. F S PROBIX=$O(APROB(PROBIX)) Q:'PROBIX D
  1. . S SEGIX=$O(@XYMSG@(" "),-1)+1
  1. . S @XYMSG@(SEGIX,0)="DG1" ; segment ID
  1. . ; populate element leaves
  1. . S SETID=SETID+1
  1. . S @XYMSG@(SEGIX,1,1,1,1)=SETID
  1. . S @XYMSG@(SEGIX,3,1,2,1)=$E($P(APROB(PROBIX,1),"^",2),1,249) ; problem text
  1. . S @XYMSG@(SEGIX,6,1,1,1)="W" ; working diagnosis
  1. . Q
  1. ;
  1. Q 0
  1. ;
  1. EVN(XEVENT,XEVNRDT,XEVNODT,XYMSG) ; FUNCTION - event
  1. ; input: XEVENT trigger event code
  1. ; XEVNRDT date/time the event was recorded (FM format)
  1. ; XEVNODT date/time the event occurred (FM format)
  1. ; XYMSG name of array to which to add message elts
  1. ; output: @XYMSG input array plus new subtree containing EVN elts
  1. ; function return 0 (success) always
  1. ;
  1. N SEGIX ; ---- segment index on @XYMSG
  1. N STAT ; ----- status return from function calls
  1. N FLDIX ; ---- field index on @XYMSG
  1. ;
  1. S SEGIX=$O(@XYMSG@(" "),-1)+1
  1. S @XYMSG@(SEGIX,0)="EVN"
  1. ; populate trigger event code and dates into element leaves
  1. S @XYMSG@(SEGIX,1,1,1,1)=XEVENT
  1. S @XYMSG@(SEGIX,2,1,1,1)=$$FMTHL7^XLFDT(XEVNRDT)
  1. S @XYMSG@(SEGIX,6,1,1,1)=$$FMTHL7^XLFDT(XEVNODT)
  1. F FLDIX=2,6 S STAT=$$STRIP0^MAG7UD($NA(@XYMSG@(SEGIX,FLDIX,1,1,1)))
  1. Q 0
  1. ;
  1. MRG(XMRGSSN,XYMSG) ; FUNCTION - update SSN - P183 PMK 3/10/17
  1. ; input: XMRGSSN Previous value of SSN
  1. ; XYMSG name of array to which to add MRG segment
  1. ; output: @XYMSG input array plus new subtree containing MRG elts
  1. ; function return 0 (success) always
  1. ;
  1. N SEGIX ; ---- segment index on @XYMSG
  1. N STAT ; ----- status return from function calls
  1. ;
  1. S SEGIX=$O(@XYMSG@(" "),-1)+1
  1. S @XYMSG@(SEGIX,0)="MRG"
  1. ; populate SSN info into element leaves
  1. S @XYMSG@(SEGIX,1,1,1,1)=XMRGSSN
  1. S @XYMSG@(SEGIX,1,1,4,1)=$S($$ISIHS^MAGSPID():"USIHS",1:"USVHA") ; P123
  1. S @XYMSG@(SEGIX,1,1,5,1)="NI"
  1. Q 0
  1. ;
  1. OBXADT(XDFN,XYMSG) G OBXADT^MAGDHLSO ; FUNCTION - patient height/weight
  1. ;
  1. PID(XDFN,XYMSG) ; FUNCTION - patient ID/demo
  1. ; input: XDFN internal entry number of the pt on gbl ^DPT
  1. ; XYMSG name of array to which to add message elts
  1. ; output: @XYMSG input array plus new subtree containing PID elts
  1. ; function return 0 (success) always
  1. ;
  1. N PIDARY ; --- array for segment to be returned by VistA HL7 fcn
  1. N HL ; ------- array containing delims, etc. expected by VistA HL7 fcn
  1. N MSGDMY ; --- dummy array of scalar message lines for parser
  1. N I ; -------- loop counter
  1. N IX,IX1,IX2,IX3,IX4 ; dummy indices
  1. N SEGIX ; ---- segment index on @XYMSG
  1. N NUL ; ------ null return from called function
  1. N MSGTREE ; -- tree of message elements to be returned by $$PARSE^MAG7UP
  1. N STAT ; ----- status return from function calls
  1. N PTICN ; ---- patient integration control number
  1. N DFN ; ------ patient internal entry number (needed for VADPT call)
  1. N VAFPID ; --- overflow array from $$EN^VAFHLPID() ; P141 PMK 5/6/2013
  1. ;
  1. S HL("ECH")=HLECH,HL("FS")=HLFS,HL("Q")=HLQ
  1. ; does pt have a national ICN?
  1. I $L($T(IFLOCAL^MPIF001)) I $$IFLOCAL^MPIF001(XDFN)'=1 D ; P123 - ICN is local, not national
  1. . S PTICN=$$GETICN^MPIF001(XDFN)
  1. . K:+PTICN<0 PTICN ; no ICN exists
  1. . Q
  1. ; build a dummy message including MSH, PID
  1. ; (MSH required for $$PARSE^MAG7UP to work)
  1. S MSGDMY(1)="MSH"_HLFS_HLECH
  1. S MSGDMY(2)=$$EN^VAFHLPID(XDFN,"5,7,8,10BN,11,13,14,19,22B"),IX=0 ; P141 PMK 5/6/2013, P183 PMK 3/9/2017
  1. ; if the result string is longer than 245, the remaining characters are
  1. ; returned in VAFPID(n), where n is a sequential number beginning with 1
  1. F I=1:1 Q:'$D(VAFPID(I)) S MSGDMY(2)=MSGDMY(2)_VAFPID(I) ; P141 PMK 5/6/2013
  1. S NUL=$$PARSE^MAG7UP("MSGDMY","MSGTREE") ; parse the message
  1. S DFN=XDFN D PID^VADPT ;Get patient Identifiers in VA array
  1. ;
  1. I $G(CPINVOCATION) K MSGTREE(2,1) S MSGTREE(2,1,1,1,1)=1 ; set PID-1 to 1 for CP compatibility - P208 PMK 4/25/2018
  1. ;
  1. ; purge patient identifiers PID-2 thru PID-4
  1. F IX=2,3,4 K MSGTREE(2,IX)
  1. ; assign station number-dfn to PID-2
  1. S MSGTREE(2,2,1,1,1)=$$STATNUMB^MAGDFCNV()_"-"_XDFN
  1. S MSGTREE(2,2,1,2,1)=""
  1. S MSGTREE(2,2,1,3,1)=""
  1. S MSGTREE(2,2,1,4,1)=$S($$ISIHS^MAGSPID():"USIHS",1:"USVHA") ; P123
  1. S MSGTREE(2,2,1,5,1)="PI"
  1. ; assign HRN or social security number to PID-3
  1. S MSGTREE(2,3,1,1,1)=$S($$ISIHS^MAGSPID():VA("PID"),1:$G(MSGTREE(2,19,1,1,1))) ; P123
  1. S MSGTREE(2,3,1,2,1)=""
  1. S MSGTREE(2,3,1,3,1)=""
  1. S MSGTREE(2,3,1,4,1)=$S($$ISIHS^MAGSPID():"USIHS",1:"USVHA") ; P123
  1. S MSGTREE(2,3,1,5,1)=$S($$ISIHS^MAGSPID():"MR",1:"NI") ; P110
  1. D:$D(PTICN) ; use nat'l ICN (if available) as the alternate pt id in PID-4
  1. . S MSGTREE(2,4,1,1,1)=PTICN
  1. . S MSGTREE(2,4,1,2,1)="" ; no checksum (included in ICN)
  1. . S MSGTREE(2,4,1,3,1)="" ; no checksum (included in ICN)
  1. . S MSGTREE(2,4,1,4,1)=$S($$ISIHS^MAGSPID():"USIHS",1:"USVHA") ; P123
  1. . S MSGTREE(2,4,1,5,1)="NI"
  1. . Q
  1. ; strip suffix, if any, off race and ethnicity codes
  1. F IX1=10,22 D
  1. . S IX2="" F S IX2=$O(MSGTREE(2,IX1,IX2)) Q:IX2="" D
  1. . . S:$G(MSGTREE(2,IX1,IX2,1,1))["-" MSGTREE(2,IX1,IX2,1,1)=$P(MSGTREE(2,IX1,IX2,1,1),"-",1,2)
  1. . . Q
  1. . Q
  1. ; insert PID subtree into passed-in element array
  1. ; this code eliminates values on intermediate (i.e., non-leaf) nodes
  1. S SEGIX=$O(@XYMSG@(" "),-1)+1
  1. S @XYMSG@(SEGIX,0)="PID" ; segment tag
  1. S IX1=0 F S IX1=$O(MSGTREE(2,IX1)) Q:'IX1 D
  1. . S IX2=0 F S IX2=$O(MSGTREE(2,IX1,IX2)) Q:'IX2 D
  1. . . S IX3=0 F S IX3=$O(MSGTREE(2,IX1,IX2,IX3)) Q:'IX3 D
  1. . . . S IX4=0 F S IX4=$O(MSGTREE(2,IX1,IX2,IX3,IX4)) Q:'IX4 D
  1. . . . . S @XYMSG@(SEGIX,IX1,IX2,IX3,IX4)=MSGTREE(2,IX1,IX2,IX3,IX4)
  1. . . . . Q
  1. . . . Q
  1. . . Q
  1. . Q
  1. S STAT=$$STRIP0^MAG7UD($NA(@XYMSG@(SEGIX,7,1,1,1))) ; strip 0's off DOB
  1. Q 0
  1. ;
  1. PV1(XDFN,XEVN,XEVNDT,XYMSG) G PV1^MAGDHLSV ; FUNCTION - patient visit
  1. ;
  1. ROL(XDFN,XYMSG) ; FUNCTION role (for physicians) - propagate from PV1
  1. ; assumes PV1 segment is already populated
  1. ;
  1. ; input: XDFN internal entry number of the pt on gbl ^DPT
  1. ; XYMSG name of array to which to add message elts
  1. ; output: @XYMSG input array plus new subtree containing PID elts
  1. ; function return 0 (success) always
  1. ;
  1. N PRCTYP ; -- type of practitioner
  1. N NUL ; ----- null return from called function
  1. N SETID ; --- sequential index of ROL seg(s) in this message
  1. N PV1IX ; --- index of PV1 segment in message array
  1. N PHYSELT ; - element index of attending / referring physician on PV1 segment
  1. N I ; ------- scratch loop counter
  1. ;
  1. S DFN=XDFN,SETID=0
  1. S PV1IX="",I=0 F S I=$O(@XYMSG@(I)) Q:'I I @XYMSG@(I,0)="PV1" S PV1IX=I Q
  1. Q:'PV1IX ; no physicians to propagate
  1. F PRCTYP="ATT","REF" D
  1. . S PHYSELT=$S(PRCTYP="ATT":7,1:8) Q:'$D(@XYMSG@(PV1IX,PHYSELT))
  1. . S SEGIX=$O(@XYMSG@(" "),-1)+1,SETID=SETID+1
  1. . S @XYMSG@(SEGIX,0)="ROL"
  1. . S @XYMSG@(SEGIX,1,1,1,1)=SETID
  1. . S @XYMSG@(SEGIX,2,1,1,1)="UP" ; receiver should always update
  1. . S @XYMSG@(SEGIX,3,1,1,1)=$S(PRCTYP="ATT":"AT",1:"RP")
  1. . M @XYMSG@(SEGIX,4)=@XYMSG@(PV1IX,PHYSELT)
  1. . S NUL=$$NPFON^MAG7UFO($NA(@XYMSG@(SEGIX,12)),$G(@XYMSG@(SEGIX,4,1,1,1)))
  1. . Q
  1. Q 0