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 Dec 13, 2024@01:59:59 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
