- 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 Feb 18, 2025@23:26:36 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