- 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 Feb 18, 2025@23:12:34 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