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