MAGDHOW4 ;WOIFO/PMK - Capture Consult/GMRC data ;17 Sep 2018 9:39 AM
;;3.0;IMAGING;**138,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 #2056 reference $$GET1^DIQ function call
; Supported IA #4716 reference ^HLOAPI function calls
; Supported IA 3536 reference GETDOCS^TIUSRVLR subroutine call
; Supported IA #10103 reference $$FMTHL7^XLFDT function call
; Controlled IA #4110 to read REQUEST/CONSULTATION file (#123)
; Controlled IA #4171 to read REQUEST SERVICES file (#123.5)
; Controlled IA #1373 to read PROTOCOL file (#101)
; Supported IA #1995 to call CPT^ICPTCOD to get CPT code and short name
; Supported IA #10090 to read INSTITUTION file (#4)
; Supported IA #10040 to read HOSPITAL LOCATION file (#44)
;
OBR(HLMSTATE,GMRCIEN,SAVEORCSEG,SERVICE) ; build the OBR segment (see OBR^GMRCHL72)
N ACNUMB,AUTHOR,CPTCODE,CPTINFO,CPTNAME,CONPROC,ERROR,HL7USID,I,DEL,DEL2,OBRSEG,SUCCESS
N PRIORITY,X,Z
D SET^HLOAPI(.OBRSEG,"OBR",0)
D SET^HLOAPI(.OBRSEG,1,1) ; OBR-1
M OBRSEG(2)=SAVEORCSEG(2) ; OBR-2 placer order number
M OBRSEG(3)=SAVEORCSEG(3) ; OBR-3 filler order number
;
; OBR-4 Universal Service Identifier
; check for Clinical Procedures HL7 Universal Services ID - P208 PMK 4/12/18
I $$CPORDER^MAGDHOWP(GMRCIEN,.HL7USID)>0,HL7USID'="" D ; Clinical Procedures
. D SET^HLOAPI(.OBRSEG,$P(HL7USID,"=",1),4,1)
. D SET^HLOAPI(.OBRSEG,$P(HL7USID,"=",2),4,2)
. Q
E D ; not Clinical Procedures - P208 PMK 4/12/18
. S CPTINFO=$$CPT^ICPTCOD(CPTIEN) ; get basic info on CPT/HCPCS code
. I CPTINFO<0 S CPTINFO="" ; error - no code selected or no such entry
. I $P(CPTINFO,"^",7)=0 S CPTINFO="" ; inactive CPT code
. S CPTCODE=$P(CPTINFO,"^",2) ; CPT code
. S CPTNAME=$P(CPTINFO,"^",3) ; short name
. D SET^HLOAPI(.OBRSEG,CPTCODE,4,1)
. D SET^HLOAPI(.OBRSEG,CPTNAME,4,2)
. D SET^HLOAPI(.OBRSEG,"C4",4,3)
. Q
S CONPROC=$$GET1^DIQ(123,GMRCIEN,13,"I") ; consult/procedure request type
I CONPROC="C" D ; consult request
. D SET^HLOAPI(.OBRSEG,"C"_SERVICE,4,4)
. D SET^HLOAPI(.OBRSEG,$$GET1^DIQ(123.5,SERVICE,.01),4,5)
. D SET^HLOAPI(.OBRSEG,"99CON",4,6)
. Q
E D ; procedure request
. D SET^HLOAPI(.OBRSEG,"P"_(+$$GET1^DIQ(123,GMRCIEN,4,"I")),4,4)
. D SET^HLOAPI(.OBRSEG,$$GET1^DIQ(123,GMRCIEN,4),4,5)
. D SET^HLOAPI(.OBRSEG,"99PROC",4,6)
. Q
;
S PRIORITY=$G(SAVEORCSEG(7,1,6,1))
I PRIORITY'="" D SET^HLOAPI(.OBRSEG,PRIORITY,5) ; OBR-5 priority
;
; OBR-6 to OBR-15 are not used
;
M OBRSEG(16)=SAVEORCSEG(12) ; OBR-16 ordering provider
M OBRSEG(17)=SAVEORCSEG(14) ; OBR-17 call back phone number
;
; store the accession number
S ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN)
D SET^HLOAPI(.OBRSEG,ACNUMB,18) ; OBR-18 placer field 1
;
; store the requested procedure id
D SET^HLOAPI(.OBRSEG,$P(ACNUMB,"-",3),19) ; OBR-19 placer field 2
;
; store misc. consult and clinic info in "filler field 1"
; <request type>
; ` <place of consult>
; ` <clinic ien> _ <clinic name>
; ` <requesting service ien> _ <requesting service name> _ VISTA44
;
S Z=$S(CONPROC="C":"CONSULT",CONPROC="P":"PROCEDURE",1:"UNKNOWN")_"```"
S X=$$GET1^DIQ(123,GMRCIEN,6,"I") ; place of consult
I X S $P(Z,"`",2)=$$GET1^DIQ(101,X,1)
I $D(APTSCHED("CLINIC IEN")),$D(APTSCHED("CLINIC NAME")) D
. S $P(Z,"`",3)=APTSCHED("CLINIC IEN")_"_"_APTSCHED("CLINIC NAME")
. Q
; from service (requesting service)
S X=$$GET1^DIQ(123,GMRCIEN,2,"I") ; pointer to ^SC(Z)
I X S $P(Z,"`",4)=X_"_"_$$GET1^DIQ(44,X,.01)_"_VISTA44"
D SET^HLOAPI(.OBRSEG,Z,20) ; OBR-20 filler field 1
;
; store consult and clinic identification info in "filler field 2"
; <itype code> _ <itype name>
; ` <service ien> _ <service name>
; ` <division station number> _ <division name>
; ` <current CPRS GMRC or Appointment Scheduling status>
;
S Z=ITYPCODE_"_"_ITYPNAME_"```"
S $P(Z,"`",2)=SERVICE_"_"_$$GET1^DIQ(123.5,SERVICE,.01)
S $P(Z,"`",3)=DIVISION_"_"_$S(DIVISION:$$GET1^DIQ(4,DIVISION,.01),1:"")
; store the current CPRS GMRC or Appointment Scheduling status
I '$D(FILLER2) S FILLER2="GMRC-"_$$GET1^DIQ(123,GMRCIEN,8) ; GMRC status
S $P(Z,"`",4)=FILLER2
;
D SET^HLOAPI(.OBRSEG,Z,21) ; OBR-21 filler field 2
;
; CPRS Attention - HL7 "Result Copies To" field
S X=$$GET1^DIQ(123,GMRCIEN,7,"I") ; pointer to ^VA(200)
I X D NAME^MAGDHOW3(X,28,.OBRSEG) ; OBR-28 result copies to
;
; special code for result message or order message, but not both
;
I MSGTYPE="ORU" D ; code for result messages, not orders
. N AUTHOR
. D SET^HLOAPI(.OBRSEG,$$FMTHL7^XLFDT(FMDATETM),22) ; OBR-22
. D SET^HLOAPI(.OBRSEG,$S(ORSTATUS="CM":"F",1:"R"),25) ; OBR-25
. ; directly call rpc TIU GET DOCUMENTS FOR REQUEST
. D GETDOCS^TIUSRVLR(.TIUDOC,GMRCIEN_";GMR(123,") ; ICR 3536
. ; get author of most recent (last) report
. S I=0 F S I=$O(@TIUDOC@(I)) Q:'I S X=@TIUDOC@(I) D
. . S AUTHOR=$P(X,"^",5)
. . Q
. I $D(AUTHOR) D NAME^MAGDHOW3(+AUTHOR,32,.OBRSEG) ; OBR-32
. Q
;
E I MSGTYPE="ORM" D ; code for order messages, not results
. M OBRSEG(27)=SAVEORCSEG(7) ; quantity/timing - OBR-27
. ;
. ; date and time of scheduled appointment
. I $D(APTSCHED("FM DATETIME")) D
. . D SET^HLOAPI(.OBRSEG,$$FMTHL7^XLFDT(APTSCHED("FM DATETIME")),36) ; OBR-36
. . Q
. Q
;
;
S SUCCESS=$$ADDSEG^HLOAPI(.HLMSTATE,.OBRSEG,.ERROR)
I 'SUCCESS D
. N MSG,SUBJECT,VARIABLES
. S SUBJECT="VistA Imaging Clinical Specialty (CPRS) HL7 Generation"
. S MSG(1)="An error occurred in OBR^"_$T(+0)_" where the ADDSEG^HLOAPI invocation"
. S MSG(2)="for the OBR segment failed. The error message is as follows:"
. S MSG(3)=""""_SUCCESS_""""
. S VARIABLES("HLMSTATE")=""
. S VARIABLES("OBRSEG")=""
. S VARIABLES("ERROR")=""
. D ERROR^MAGDHOWA(SUBJECT,.MSG,.VARIABLES)
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDHOW4 6814 printed Apr 09, 2024@21:03:14 Page 2
MAGDHOW4 ;WOIFO/PMK - Capture Consult/GMRC data ;17 Sep 2018 9:39 AM
+1 ;;3.0;IMAGING;**138,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 #2056 reference $$GET1^DIQ function call
+18 ; Supported IA #4716 reference ^HLOAPI function calls
+19 ; Supported IA 3536 reference GETDOCS^TIUSRVLR subroutine call
+20 ; Supported IA #10103 reference $$FMTHL7^XLFDT function call
+21 ; Controlled IA #4110 to read REQUEST/CONSULTATION file (#123)
+22 ; Controlled IA #4171 to read REQUEST SERVICES file (#123.5)
+23 ; Controlled IA #1373 to read PROTOCOL file (#101)
+24 ; Supported IA #1995 to call CPT^ICPTCOD to get CPT code and short name
+25 ; Supported IA #10090 to read INSTITUTION file (#4)
+26 ; Supported IA #10040 to read HOSPITAL LOCATION file (#44)
+27 ;
OBR(HLMSTATE,GMRCIEN,SAVEORCSEG,SERVICE) ; build the OBR segment (see OBR^GMRCHL72)
+1 NEW ACNUMB,AUTHOR,CPTCODE,CPTINFO,CPTNAME,CONPROC,ERROR,HL7USID,I,DEL,DEL2,OBRSEG,SUCCESS
+2 NEW PRIORITY,X,Z
+3 DO SET^HLOAPI(.OBRSEG,"OBR",0)
+4 ; OBR-1
DO SET^HLOAPI(.OBRSEG,1,1)
+5 ; OBR-2 placer order number
MERGE OBRSEG(2)=SAVEORCSEG(2)
+6 ; OBR-3 filler order number
MERGE OBRSEG(3)=SAVEORCSEG(3)
+7 ;
+8 ; OBR-4 Universal Service Identifier
+9 ; check for Clinical Procedures HL7 Universal Services ID - P208 PMK 4/12/18
+10 ; Clinical Procedures
IF $$CPORDER^MAGDHOWP(GMRCIEN,.HL7USID)>0
IF HL7USID'=""
Begin DoDot:1
+11 DO SET^HLOAPI(.OBRSEG,$PIECE(HL7USID,"=",1),4,1)
+12 DO SET^HLOAPI(.OBRSEG,$PIECE(HL7USID,"=",2),4,2)
+13 QUIT
End DoDot:1
+14 ; not Clinical Procedures - P208 PMK 4/12/18
IF '$TEST
Begin DoDot:1
+15 ; get basic info on CPT/HCPCS code
SET CPTINFO=$$CPT^ICPTCOD(CPTIEN)
+16 ; error - no code selected or no such entry
IF CPTINFO<0
SET CPTINFO=""
+17 ; inactive CPT code
IF $PIECE(CPTINFO,"^",7)=0
SET CPTINFO=""
+18 ; CPT code
SET CPTCODE=$PIECE(CPTINFO,"^",2)
+19 ; short name
SET CPTNAME=$PIECE(CPTINFO,"^",3)
+20 DO SET^HLOAPI(.OBRSEG,CPTCODE,4,1)
+21 DO SET^HLOAPI(.OBRSEG,CPTNAME,4,2)
+22 DO SET^HLOAPI(.OBRSEG,"C4",4,3)
+23 QUIT
End DoDot:1
+24 ; consult/procedure request type
SET CONPROC=$$GET1^DIQ(123,GMRCIEN,13,"I")
+25 ; consult request
IF CONPROC="C"
Begin DoDot:1
+26 DO SET^HLOAPI(.OBRSEG,"C"_SERVICE,4,4)
+27 DO SET^HLOAPI(.OBRSEG,$$GET1^DIQ(123.5,SERVICE,.01),4,5)
+28 DO SET^HLOAPI(.OBRSEG,"99CON",4,6)
+29 QUIT
End DoDot:1
+30 ; procedure request
IF '$TEST
Begin DoDot:1
+31 DO SET^HLOAPI(.OBRSEG,"P"_(+$$GET1^DIQ(123,GMRCIEN,4,"I")),4,4)
+32 DO SET^HLOAPI(.OBRSEG,$$GET1^DIQ(123,GMRCIEN,4),4,5)
+33 DO SET^HLOAPI(.OBRSEG,"99PROC",4,6)
+34 QUIT
End DoDot:1
+35 ;
+36 SET PRIORITY=$GET(SAVEORCSEG(7,1,6,1))
+37 ; OBR-5 priority
IF PRIORITY'=""
DO SET^HLOAPI(.OBRSEG,PRIORITY,5)
+38 ;
+39 ; OBR-6 to OBR-15 are not used
+40 ;
+41 ; OBR-16 ordering provider
MERGE OBRSEG(16)=SAVEORCSEG(12)
+42 ; OBR-17 call back phone number
MERGE OBRSEG(17)=SAVEORCSEG(14)
+43 ;
+44 ; store the accession number
+45 SET ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN)
+46 ; OBR-18 placer field 1
DO SET^HLOAPI(.OBRSEG,ACNUMB,18)
+47 ;
+48 ; store the requested procedure id
+49 ; OBR-19 placer field 2
DO SET^HLOAPI(.OBRSEG,$PIECE(ACNUMB,"-",3),19)
+50 ;
+51 ; store misc. consult and clinic info in "filler field 1"
+52 ; <request type>
+53 ; ` <place of consult>
+54 ; ` <clinic ien> _ <clinic name>
+55 ; ` <requesting service ien> _ <requesting service name> _ VISTA44
+56 ;
+57 SET Z=$SELECT(CONPROC="C":"CONSULT",CONPROC="P":"PROCEDURE",1:"UNKNOWN")_"```"
+58 ; place of consult
SET X=$$GET1^DIQ(123,GMRCIEN,6,"I")
+59 IF X
SET $PIECE(Z,"`",2)=$$GET1^DIQ(101,X,1)
+60 IF $DATA(APTSCHED("CLINIC IEN"))
IF $DATA(APTSCHED("CLINIC NAME"))
Begin DoDot:1
+61 SET $PIECE(Z,"`",3)=APTSCHED("CLINIC IEN")_"_"_APTSCHED("CLINIC NAME")
+62 QUIT
End DoDot:1
+63 ; from service (requesting service)
+64 ; pointer to ^SC(Z)
SET X=$$GET1^DIQ(123,GMRCIEN,2,"I")
+65 IF X
SET $PIECE(Z,"`",4)=X_"_"_$$GET1^DIQ(44,X,.01)_"_VISTA44"
+66 ; OBR-20 filler field 1
DO SET^HLOAPI(.OBRSEG,Z,20)
+67 ;
+68 ; store consult and clinic identification info in "filler field 2"
+69 ; <itype code> _ <itype name>
+70 ; ` <service ien> _ <service name>
+71 ; ` <division station number> _ <division name>
+72 ; ` <current CPRS GMRC or Appointment Scheduling status>
+73 ;
+74 SET Z=ITYPCODE_"_"_ITYPNAME_"```"
+75 SET $PIECE(Z,"`",2)=SERVICE_"_"_$$GET1^DIQ(123.5,SERVICE,.01)
+76 SET $PIECE(Z,"`",3)=DIVISION_"_"_$SELECT(DIVISION:$$GET1^DIQ(4,DIVISION,.01),1:"")
+77 ; store the current CPRS GMRC or Appointment Scheduling status
+78 ; GMRC status
IF '$DATA(FILLER2)
SET FILLER2="GMRC-"_$$GET1^DIQ(123,GMRCIEN,8)
+79 SET $PIECE(Z,"`",4)=FILLER2
+80 ;
+81 ; OBR-21 filler field 2
DO SET^HLOAPI(.OBRSEG,Z,21)
+82 ;
+83 ; CPRS Attention - HL7 "Result Copies To" field
+84 ; pointer to ^VA(200)
SET X=$$GET1^DIQ(123,GMRCIEN,7,"I")
+85 ; OBR-28 result copies to
IF X
DO NAME^MAGDHOW3(X,28,.OBRSEG)
+86 ;
+87 ; special code for result message or order message, but not both
+88 ;
+89 ; code for result messages, not orders
IF MSGTYPE="ORU"
Begin DoDot:1
+90 NEW AUTHOR
+91 ; OBR-22
DO SET^HLOAPI(.OBRSEG,$$FMTHL7^XLFDT(FMDATETM),22)
+92 ; OBR-25
DO SET^HLOAPI(.OBRSEG,$SELECT(ORSTATUS="CM":"F",1:"R"),25)
+93 ; directly call rpc TIU GET DOCUMENTS FOR REQUEST
+94 ; ICR 3536
DO GETDOCS^TIUSRVLR(.TIUDOC,GMRCIEN_";GMR(123,")
+95 ; get author of most recent (last) report
+96 SET I=0
FOR
SET I=$ORDER(@TIUDOC@(I))
if 'I
QUIT
SET X=@TIUDOC@(I)
Begin DoDot:2
+97 SET AUTHOR=$PIECE(X,"^",5)
+98 QUIT
End DoDot:2
+99 ; OBR-32
IF $DATA(AUTHOR)
DO NAME^MAGDHOW3(+AUTHOR,32,.OBRSEG)
+100 QUIT
End DoDot:1
+101 ;
+102 ; code for order messages, not results
IF '$TEST
IF MSGTYPE="ORM"
Begin DoDot:1
+103 ; quantity/timing - OBR-27
MERGE OBRSEG(27)=SAVEORCSEG(7)
+104 ;
+105 ; date and time of scheduled appointment
+106 IF $DATA(APTSCHED("FM DATETIME"))
Begin DoDot:2
+107 ; OBR-36
DO SET^HLOAPI(.OBRSEG,$$FMTHL7^XLFDT(APTSCHED("FM DATETIME")),36)
+108 QUIT
End DoDot:2
+109 QUIT
End DoDot:1
+110 ;
+111 ;
+112 SET SUCCESS=$$ADDSEG^HLOAPI(.HLMSTATE,.OBRSEG,.ERROR)
+113 IF 'SUCCESS
Begin DoDot:1
+114 NEW MSG,SUBJECT,VARIABLES
+115 SET SUBJECT="VistA Imaging Clinical Specialty (CPRS) HL7 Generation"
+116 SET MSG(1)="An error occurred in OBR^"_$TEXT(+0)_" where the ADDSEG^HLOAPI invocation"
+117 SET MSG(2)="for the OBR segment failed. The error message is as follows:"
+118 SET MSG(3)=""""_SUCCESS_""""
+119 SET VARIABLES("HLMSTATE")=""
+120 SET VARIABLES("OBRSEG")=""
+121 SET VARIABLES("ERROR")=""
+122 DO ERROR^MAGDHOWA(SUBJECT,.MSG,.VARIABLES)
+123 QUIT
End DoDot:1
+124 QUIT
