GMRCITST ;SLC/JFR - test IFC setup ; 11/30/01 10:30
;;3.0;CONSULT/REQUEST TRACKING;**22**;DEC 27, 1997
EN ; start here
;Prompt for choice of consult service or procedure
;route to the ROUTING FACILITY and see if it's a GO
N DIR,X,Y,DIROUT,DIRUT,DTOUT
S DIR(0)="SO^P:procedure;C:consult service"
S DIR("A")="Would you like to test a procedure or consult service"
D ^DIR
I $D(DIRUT) Q
W !!
D RUN(Y)
W !!
K DIR,X,Y
S DIR(0)="YA",DIR("A")="Would you like to test another implementation? "
D ^DIR
I Y=1 G EN
Q
RUN(GMRCTYP) ; check the procedure or service for proper setup
N DIR,X,Y,DIROUT,DIRUT,DTOUT,SERV,PROC,GMRC773,HLL,LINK,HL
I GMRCTYP="P" D
. S DIR(0)="PA^123.3:EMQ"
. S DIR("A")="Select the GMRC Procedure that you'd like to test: "
I GMRCTYP="C" D
. S DIR(0)="PA^123.5:EMQ"
. S DIR("A")="Select the Consult service that you'd like to test: "
. S DIR("A")="Select the Consult service that you'd like to test: "
D ^DIR
I $G(Y)'>0 W !,"No procedure or service selected." Q
I GMRCTYP="P" S PROC=+Y I '$$TSTPROC(PROC) Q
I GMRCTYP="C" S SERV=+Y I '$$TSTSERV(SERV) Q
;
;send msg
K ^TMP("HLS",$J)
D INIT^HLFNC2("GMRC IFC ORM TEST",.HL)
S ^TMP("HLS",$J,1)=$$ORCTST^GMRCISG1
I $G(PROC) S ^TMP("HLS",$J,2)=$$OBRTST^GMRCISG1(PROC,"P")
I $G(SERV) S ^TMP("HLS",$J,2)=$$OBRTST^GMRCISG1(SERV,"C")
S LINK=$$ROUTE($S($G(PROC):PROC_";GMR(123.3,",1:SERV_";GMR(123.5,"))
I '$L(LINK) D Q ;problem with the HL LOGICAL LINK
. W !!,"The proper HL LOGICAL link could not be located!"
. W !,"Can't continue to test. Contact IRM."
S HLL("LINKS",1)=LINK
W !!," attempting to connect to remote system...",!
D DIRECT^HLMA("GMRC IFC ORM TEST","GM",1,.GMRC773)
I +$P(GMRC773,U,2) D Q ;problem with the HL link
. W !,"There was a problem communicating with the remote site."
. W !,"IRM may need to check the HL7 communications."
N HLNODE,SEG,I ;process response
K ^TMP("GMRCIF",$J)
F I=1:1 X HLNEXT Q:HLQUIT'>0 D
.S ^TMP("GMRCIF",$J,$P(HLNODE,"|"))=$E(HLNODE,5,999)
I $P(^TMP("GMRCIF",$J,"MSA"),"|")="AA" D
. W !!,"Congratulations! You're configured correctly."
I $P(^TMP("GMRCIF",$J,"MSA"),"|")="AR" D
. N ERR,GMRCER
. W !!,"There is an implementation problem. The remote site indicated:"
. S ERR=$P(^TMP("GMRCIF",$J,"MSA"),"|",3),GMRCER=+ERR
. I ERR S ERR="ERR"_ERR_"^GMRCIUTL" S ERR=$T(@ERR),ERR=$P(ERR,";",2)
. W !,?5,ERR_$S(+GMRCER:" ("_GMRCER_")",1:" (HL7 ERROR)")
K ^TMP("GMRCIF",$J),^TMP("HLS",$J),HLNEXT,HLQUIT
Q
;
TSTPROC(GMRCPR) ;check procedure and make sure it has required fields for IFC
; Input:
; GMRCPR = ien from file 123.3
;
; Output:
; 1 = configured correctly
; 0 = one or more fields missing
;
I '$D(^GMR(123.3,GMRCPR,"IFC")) D Q 0
. W !!,"This procedure is not configured for Inter-facility purposes."
I '$P(^GMR(123.3,GMRCPR,"IFC"),U) D Q 0
. W !!,"This procedure has no IFC ROUTING FACILITY entered."
I '$L($P(^GMR(123.3,GMRCPR,"IFC"),U,2)) D Q 0
. W !!,"This procedure has no IFC REMOTE NAME entered."
Q 1
;
TSTSERV(GMRCSS) ;check service and make sure it has required fields for IFC
; Input:
; GMRCSS = ien from file 123.5
;
; Output:
; 1 = configured correctly
; 0 = one or more fields missing
;
I '$D(^GMR(123.5,GMRCSS,"IFC")) D Q 0
. W !!,"This service is not configured for Inter-facility purposes."
I '$P(^GMR(123.5,GMRCSS,"IFC"),U) D Q 0
. W !!,"This service has no IFC ROUTING FACILITY entered."
I '$L($P(^GMR(123.5,GMRCSS,"IFC"),U,2)) D Q 0
. W !!,"This service has no IFC REMOTE NAME entered."
Q 1
;
ROUTE(GMRCOI) ; get the right HL link for testing
;Input:
; GMRCOI = ien from file 123.3 or 123.5 in var ptr format
;
;Output:
; the logical link to send the message to in format
; "GMRC IFC SUBSC^VHAHIN"
;
N SITE,GMRCLINK,STA
I '$G(GMRCOI) Q ""
I $P(GMRCOI,";",2)[123.3 D
. S SITE=$P($G(^GMR(123.3,+GMRCOI,"IFC")),U)
I $P(GMRCOI,";",2)[123.5 D
. S SITE=$P($G(^GMR(123.5,+GMRCOI,"IFC")),U)
I '$G(SITE) Q ""
S STA=$$STA^XUAF4(SITE)
I '$L(STA) Q ""
D LINK^HLUTIL3(STA,.GMRCLINK,"I")
S GMRCLINK=$O(GMRCLINK(0)) I 'GMRCLINK Q "" ; no link for that site
S GMRCLINK=GMRCLINK(GMRCLINK) I '$L(GMRCLINK) Q "" ;no link name
Q "GMRC IFC SUBSC^"_GMRCLINK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCITST 4308 printed Apr 09, 2024@20:51:45 Page 2
GMRCITST ;SLC/JFR - test IFC setup ; 11/30/01 10:30
+1 ;;3.0;CONSULT/REQUEST TRACKING;**22**;DEC 27, 1997
EN ; start here
+1 ;Prompt for choice of consult service or procedure
+2 ;route to the ROUTING FACILITY and see if it's a GO
+3 NEW DIR,X,Y,DIROUT,DIRUT,DTOUT
+4 SET DIR(0)="SO^P:procedure;C:consult service"
+5 SET DIR("A")="Would you like to test a procedure or consult service"
+6 DO ^DIR
+7 IF $DATA(DIRUT)
QUIT
+8 WRITE !!
+9 DO RUN(Y)
+10 WRITE !!
+11 KILL DIR,X,Y
+12 SET DIR(0)="YA"
SET DIR("A")="Would you like to test another implementation? "
+13 DO ^DIR
+14 IF Y=1
GOTO EN
+15 QUIT
RUN(GMRCTYP) ; check the procedure or service for proper setup
+1 NEW DIR,X,Y,DIROUT,DIRUT,DTOUT,SERV,PROC,GMRC773,HLL,LINK,HL
+2 IF GMRCTYP="P"
Begin DoDot:1
+3 SET DIR(0)="PA^123.3:EMQ"
+4 SET DIR("A")="Select the GMRC Procedure that you'd like to test: "
End DoDot:1
+5 IF GMRCTYP="C"
Begin DoDot:1
+6 SET DIR(0)="PA^123.5:EMQ"
+7 SET DIR("A")="Select the Consult service that you'd like to test: "
+8 SET DIR("A")="Select the Consult service that you'd like to test: "
End DoDot:1
+9 DO ^DIR
+10 IF $GET(Y)'>0
WRITE !,"No procedure or service selected."
QUIT
+11 IF GMRCTYP="P"
SET PROC=+Y
IF '$$TSTPROC(PROC)
QUIT
+12 IF GMRCTYP="C"
SET SERV=+Y
IF '$$TSTSERV(SERV)
QUIT
+13 ;
+14 ;send msg
+15 KILL ^TMP("HLS",$JOB)
+16 DO INIT^HLFNC2("GMRC IFC ORM TEST",.HL)
+17 SET ^TMP("HLS",$JOB,1)=$$ORCTST^GMRCISG1
+18 IF $GET(PROC)
SET ^TMP("HLS",$JOB,2)=$$OBRTST^GMRCISG1(PROC,"P")
+19 IF $GET(SERV)
SET ^TMP("HLS",$JOB,2)=$$OBRTST^GMRCISG1(SERV,"C")
+20 SET LINK=$$ROUTE($SELECT($GET(PROC):PROC_";GMR(123.3,",1:SERV_";GMR(123.5,"))
+21 ;problem with the HL LOGICAL LINK
IF '$LENGTH(LINK)
Begin DoDot:1
+22 WRITE !!,"The proper HL LOGICAL link could not be located!"
+23 WRITE !,"Can't continue to test. Contact IRM."
End DoDot:1
QUIT
+24 SET HLL("LINKS",1)=LINK
+25 WRITE !!," attempting to connect to remote system...",!
+26 DO DIRECT^HLMA("GMRC IFC ORM TEST","GM",1,.GMRC773)
+27 ;problem with the HL link
IF +$PIECE(GMRC773,U,2)
Begin DoDot:1
+28 WRITE !,"There was a problem communicating with the remote site."
+29 WRITE !,"IRM may need to check the HL7 communications."
End DoDot:1
QUIT
+30 ;process response
NEW HLNODE,SEG,I
+31 KILL ^TMP("GMRCIF",$JOB)
+32 FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+33 SET ^TMP("GMRCIF",$JOB,$PIECE(HLNODE,"|"))=$EXTRACT(HLNODE,5,999)
End DoDot:1
+34 IF $PIECE(^TMP("GMRCIF",$JOB,"MSA"),"|")="AA"
Begin DoDot:1
+35 WRITE !!,"Congratulations! You're configured correctly."
End DoDot:1
+36 IF $PIECE(^TMP("GMRCIF",$JOB,"MSA"),"|")="AR"
Begin DoDot:1
+37 NEW ERR,GMRCER
+38 WRITE !!,"There is an implementation problem. The remote site indicated:"
+39 SET ERR=$PIECE(^TMP("GMRCIF",$JOB,"MSA"),"|",3)
SET GMRCER=+ERR
+40 IF ERR
SET ERR="ERR"_ERR_"^GMRCIUTL"
SET ERR=$TEXT(@ERR)
SET ERR=$PIECE(ERR,";",2)
+41 WRITE !,?5,ERR_$SELECT(+GMRCER:" ("_GMRCER_")",1:" (HL7 ERROR)")
End DoDot:1
+42 KILL ^TMP("GMRCIF",$JOB),^TMP("HLS",$JOB),HLNEXT,HLQUIT
+43 QUIT
+44 ;
TSTPROC(GMRCPR) ;check procedure and make sure it has required fields for IFC
+1 ; Input:
+2 ; GMRCPR = ien from file 123.3
+3 ;
+4 ; Output:
+5 ; 1 = configured correctly
+6 ; 0 = one or more fields missing
+7 ;
+8 IF '$DATA(^GMR(123.3,GMRCPR,"IFC"))
Begin DoDot:1
+9 WRITE !!,"This procedure is not configured for Inter-facility purposes."
End DoDot:1
QUIT 0
+10 IF '$PIECE(^GMR(123.3,GMRCPR,"IFC"),U)
Begin DoDot:1
+11 WRITE !!,"This procedure has no IFC ROUTING FACILITY entered."
End DoDot:1
QUIT 0
+12 IF '$LENGTH($PIECE(^GMR(123.3,GMRCPR,"IFC"),U,2))
Begin DoDot:1
+13 WRITE !!,"This procedure has no IFC REMOTE NAME entered."
End DoDot:1
QUIT 0
+14 QUIT 1
+15 ;
TSTSERV(GMRCSS) ;check service and make sure it has required fields for IFC
+1 ; Input:
+2 ; GMRCSS = ien from file 123.5
+3 ;
+4 ; Output:
+5 ; 1 = configured correctly
+6 ; 0 = one or more fields missing
+7 ;
+8 IF '$DATA(^GMR(123.5,GMRCSS,"IFC"))
Begin DoDot:1
+9 WRITE !!,"This service is not configured for Inter-facility purposes."
End DoDot:1
QUIT 0
+10 IF '$PIECE(^GMR(123.5,GMRCSS,"IFC"),U)
Begin DoDot:1
+11 WRITE !!,"This service has no IFC ROUTING FACILITY entered."
End DoDot:1
QUIT 0
+12 IF '$LENGTH($PIECE(^GMR(123.5,GMRCSS,"IFC"),U,2))
Begin DoDot:1
+13 WRITE !!,"This service has no IFC REMOTE NAME entered."
End DoDot:1
QUIT 0
+14 QUIT 1
+15 ;
ROUTE(GMRCOI) ; get the right HL link for testing
+1 ;Input:
+2 ; GMRCOI = ien from file 123.3 or 123.5 in var ptr format
+3 ;
+4 ;Output:
+5 ; the logical link to send the message to in format
+6 ; "GMRC IFC SUBSC^VHAHIN"
+7 ;
+8 NEW SITE,GMRCLINK,STA
+9 IF '$GET(GMRCOI)
QUIT ""
+10 IF $PIECE(GMRCOI,";",2)[123.3
Begin DoDot:1
+11 SET SITE=$PIECE($GET(^GMR(123.3,+GMRCOI,"IFC")),U)
End DoDot:1
+12 IF $PIECE(GMRCOI,";",2)[123.5
Begin DoDot:1
+13 SET SITE=$PIECE($GET(^GMR(123.5,+GMRCOI,"IFC")),U)
End DoDot:1
+14 IF '$GET(SITE)
QUIT ""
+15 SET STA=$$STA^XUAF4(SITE)
+16 IF '$LENGTH(STA)
QUIT ""
+17 DO LINK^HLUTIL3(STA,.GMRCLINK,"I")
+18 ; no link for that site
SET GMRCLINK=$ORDER(GMRCLINK(0))
IF 'GMRCLINK
QUIT ""
+19 ;no link name
SET GMRCLINK=GMRCLINK(GMRCLINK)
IF '$LENGTH(GMRCLINK)
QUIT ""
+20 QUIT "GMRC IFC SUBSC^"_GMRCLINK
