HLERCHK ;SFCIOFO/JC - Interface Debugger ;02/25/2004 14:25
;;1.6;HEALTH LEVEL SEVEN;**57,96,108**;Oct 13, 1995
;This routine requires the following to work:
;EVENT DRIVER PROTOCOL TYPE
;It will report inconsistencies with the event driver, susbscribers,
;applications and logical links (if defined)
W !,"This routine searches for HL7 protocols with possible errors."
S DIR(0)="FAOU"
S DIR("A")="Select an EVENT DRIVER Protocol: "
S DIR("B")="All"
S DIR("?")="^D DICQ^HLERCHK"
D ^DIR
K DIC,DA,DR I Y="All" S HLANS=0 G ASKDEV
S X=Y S DIC="^ORD(101,",DIC(0)="EMQZ"
S DIC("S")="I $P(^(0),U,4)=""E"""
D ^DIC
Q:$D(DTOUT)!($D(DUOUT))
Q:+Y=-1
S HLANS=+Y
ASKDEV ;
S %ZIS="MQ"
D ^%ZIS
G:POP EXIT
I $D(IO("Q")) D G EXIT
.S ZTDESC="HL7 Interface Debugger",ZTRTN="EN^HLERCHK",ZTSAVE("*")=""
.S ZTDTH=$H D ^%ZTLOAD
.D HOME^%ZIS
.W !,$S($D(ZTSK):"Queued to task number: "_ZTSK,1:"NOT QUEUED")
EN ;
U IO
I $D(ZTQUEUED) S ZTREQ="@"
W !," ** HL7 INTERFACE DEBUGGER **"
S HL57=0 I $D(^ORD(101,"AHL21")) S HL57=1
;patch HL*1.6*96 start: add application ack for HL7 v2.4, and others.
S HLACK="ACK,ADR,ARD,EDR,ERP,MCF,MFK,MFR,ORF,ORG,ORR,OSR,RAR,RCI,RCL,"
S HLACK=HLACK_"RDR,RDY,RER,RGR,ROR,RRA,RRD,RRE,RRG,RRI,RSP,RTB,SQR,"
S HLACK=HLACK_"TBR,VXR,VXX"
;patch HL*1.6*96 end
;patch HL*1.6*108 start: add application ack for HL7 v2.5.
S HLACK=HLACK_",BRP,BRT,ORB,ORI"
;patch HL*1.6*108 end
I 'HLANS S HLPIEN=0 F S HLPIEN=$O(^ORD(101,HLPIEN)) Q:HLPIEN<1 D
.Q:$P(^ORD(101,HLPIEN,0),U,4)'="E"
.D CHKED(HLPIEN)
I +HLANS D CHKED(+HLANS)
D EXIT
Q
DICQ ;
N X,Y,DIC
S X="??"
S DIC="^ORD(101,",DIC(0)="EQ"
S DIC("S")="I $P(^(0),U,4)=""E"""
D ^DIC
Q
CHKED(PP) ;Check Event Driver Protocols
K ERR,HLPN,HL770,HLVSP,HLVSN,HLSAPP,HLSAPN,HLMTPP,HLMTPN,HLETPP,HLETPN S ERR=0
S HLPN=$P($G(^ORD(101,PP,0)),U)
I HLPN="" S ERR=ERR+1,ERR(ERR)="Protocol is UNDEFINED." Q
I $P(^ORD(101,PP,0),U,3)]"" S ERR=ERR+1,ERR(ERR)="**PROTOCOL DISABLED**" Q
S HL770=$G(^ORD(101,PP,770))
I HL770="" S ERR=ERR+1,ERR(ERR)="Missing data for all key fields." Q
VSN ;Version
S HLVSP=$P(HL770,U,10)
I HLVSP<1 S ERR=ERR+1,ERR(ERR)="Version ID is required."
S HLVSN="" I HLVSP S HLVSN=$P($G(^HL(771.5,HLVSP,0)),U)
APP ;Sending App
S HLSAPP=$P(HL770,U),HLSAPN=""
I 'HLSAPP S ERR=ERR+1,ERR(ERR)="Missing Required Sending Application."
I HLSAPP S HLSAPN=$P($G(^HL(771,HLSAPP,0)),U)
I HLSAPP,HLSAPN="" S ERR=ERR+1,ERR(ERR)="Broken pointer to App Param (file 771)."
I HLSAPP D CHKAPP(HLSAPP)
MT ;Message Type
S HLMTPP=$P(HL770,U,3),HLMTPN=""
I 'HLMTPP S ERR=ERR+1,ERR(ERR)="Missing required Message Type."
I HLMTPP S HLMTPN=$P($G(^HL(771.2,HLMTPP,0)),U)
I HLMTPP,HLMTPN="" S ERR=ERR+1,ERR(ERR)="Broken pointer to Msg Type (file 771.2)."
I HLMTPN]"",HLACK[HLMTPN S ERR=ERR+1,ERR(ERR)="For Event Driver-Message Type cannot be an acknowledgement."
ET ;Event Type
S HLETPP=$P(HL770,U,4),HLETPN=""
S HLETPN="" I HLETPP S HLETPN=$P($G(^HL(779.001,HLETPP,0)),U)
I HLETPN="" S ERR=ERR+1,ERR(ERR)="Broken pointer to Event Type (file 779.001)."
I 'HLETPP,$G(HLVSN)>2.1 S ERR=ERR+1,ERR(ERR)="Event type is required for versions greater than 2.1."
OUT1 S $P(LINE,"_",75)=""
W !,LINE
W !,"Event Driver: ",HLPN
W !!,"Sending Application: ",HLSAPN
W !,"Version: ",$G(HLVSN)," ","Message Type(770.3): ",$G(HLMTPN)," ","Event Type: ",$G(HLETPN)
W !!,"Event Driver Error Summary:",!
I $G(ERR)<1 W !,"No Event Driver Errors Found."
I $G(ERR) S N=0 F S N=$O(ERR(N)) Q:N<1 W !,N,". ",ERR(N)
SUB ;Check Subscribers
S HL770=$G(^ORD(101,PP,770))
I HL770="" S ERR=ERR+1,ERR(ERR)="Missing data for all key fields." Q
S HLNODE="^ORD(101,PP,10)"
I HL57 S HLNODE="^ORD(101,PP,775)"
I '$D(@HLNODE) W !,"No Subscribers Found."
S HLX=0 F S HLX=$O(@HLNODE@(HLX)) Q:HLX<1 S HLSUBP=$P(@HLNODE@(HLX,0),U) D CHKSUB(HLSUBP)
Q
CHKSUB(PP) ;Scan Subscribers
K ERR,HLPN,HL770,HLVSP,HLVSN,HLRAPP,HLRAPN,HLMTPP,HLMTPN,HLETPP,HLETPN S ERR=0
S HLPN=$P($G(^ORD(101,PP,0)),U)
I HLPN="" S ERR=ERR+1,ERR(ERR)="Subscriber Protocol is UNDEFINED." Q
I $P(^ORD(101,PP,0),U,3)]"" S ERR=ERR+1,ERR(ERR)="**SUBSCRIBER PROTOCOL DISABLED**" Q
S HL770=$G(^ORD(101,PP,770))
I HL770="" S ERR=ERR+1,ERR(ERR)="Missing data for all key fields." Q
S HLRAPP=$P(HL770,U,2),HLRAPN=""
I 'HLRAPP S ERR=ERR+1,ERR(ERR)="Missing Required Receiving Application."
I HLRAPP S HLRAPN=$P($G(^HL(771,HLRAPP,0)),U)
I HLRAPP,HLRAPN="" S ERR=ERR+1,ERR(ERR)="Broken pointer to App Param (file 771)."
I HLRAPP D CHKAPP(HLRAPP)
S HLMTPN="",HLMTPP=$P(HL770,U,11) I HLMTPP D ;Response Message Type
.I HLMTPP S HLMTPN=$P($G(^HL(771.2,HLMTPP,0)),U)
.I HLMTPP,HLMTPN="" S ERR=ERR+1,ERR(ERR)="Broken pointer to Msg Type (file 771.2)."
.I HLMTPN]"",HLACK'[HLMTPN S ERR=ERR+1,ERR(ERR)="Message Type must be an appropriate response/acknowledgement."
S HLETPP=$P(HL770,U,4),HLETPN=""
I HLETPP S HLETPN=$P($G(^HL(779.001,HLETPP,0)),U)
I HLETPP,HLETPN="" S ERR=ERR+1,ERR(ERR)="Broken pointer to Event Type (file 779.001)."
I $G(^ORD(101,PP,774))=""&($G(^ORD(101,PP,771)))="" S ERR=ERR+1,ERR(ERR)="Missing Processing Routine and Routing Logic."
I $G(^ORD(101,PP,774))=""&($P(HL770,U,7))="" S ERR=ERR+1,ERR(ERR)="WARNING-Missing both Logical Link and Routing Logic. Will be local only."
OUT2 ;Print Subscriber Errors
S $P(STAR,"*",40)=""
W !,?10,STAR
W !,?10,"For Subscriber: ",$G(HLPN)
W !!,?10,"Receiving Application: ",$G(HLRAPN)
W !,?10,"Message Type (770.11): ",$G(HLMTPN)," ","Event Type: ",$G(HLETPN),!
I 'ERR W !,?10,"No Subscriber Errors Found."
F ERR=1:1:ERR W !,?10,ERR,". ",ERR(ERR)
Q
CHKAPP(APP) ;Check Application parameters
Q:'$D(^HL(771,APP))
I $P(^HL(771,APP,0),U,2)="I" S ERR=ERR+1,ERR(ERR)="Application is INACTIVE."
Q
EXIT ;
K ZTSK,HL57,HL770,HLACK,HLETPN,HLETPP,HLMTPN,HLMTPP,HLNODE,HLPIEN,HLPN,HLRAPP,HLSAPN,HLSAPP,HLSUBP,HLVSN,HLVSP,HLX,LINE,STAR,SAPP,ERR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLERCHK 5997 printed Sep 23, 2025@19:33:45 Page 2
HLERCHK ;SFCIOFO/JC - Interface Debugger ;02/25/2004 14:25
+1 ;;1.6;HEALTH LEVEL SEVEN;**57,96,108**;Oct 13, 1995
+2 ;This routine requires the following to work:
+3 ;EVENT DRIVER PROTOCOL TYPE
+4 ;It will report inconsistencies with the event driver, susbscribers,
+5 ;applications and logical links (if defined)
+6 WRITE !,"This routine searches for HL7 protocols with possible errors."
+7 SET DIR(0)="FAOU"
+8 SET DIR("A")="Select an EVENT DRIVER Protocol: "
+9 SET DIR("B")="All"
+10 SET DIR("?")="^D DICQ^HLERCHK"
+11 DO ^DIR
+12 KILL DIC,DA,DR
IF Y="All"
SET HLANS=0
GOTO ASKDEV
+13 SET X=Y
SET DIC="^ORD(101,"
SET DIC(0)="EMQZ"
+14 SET DIC("S")="I $P(^(0),U,4)=""E"""
+15 DO ^DIC
+16 if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+17 if +Y=-1
QUIT
+18 SET HLANS=+Y
ASKDEV ;
+1 SET %ZIS="MQ"
+2 DO ^%ZIS
+3 if POP
GOTO EXIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTDESC="HL7 Interface Debugger"
SET ZTRTN="EN^HLERCHK"
SET ZTSAVE("*")=""
+6 SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
+7 DO HOME^%ZIS
+8 WRITE !,$SELECT($DATA(ZTSK):"Queued to task number: "_ZTSK,1:"NOT QUEUED")
End DoDot:1
GOTO EXIT
EN ;
+1 USE IO
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 WRITE !," ** HL7 INTERFACE DEBUGGER **"
+4 SET HL57=0
IF $DATA(^ORD(101,"AHL21"))
SET HL57=1
+5 ;patch HL*1.6*96 start: add application ack for HL7 v2.4, and others.
+6 SET HLACK="ACK,ADR,ARD,EDR,ERP,MCF,MFK,MFR,ORF,ORG,ORR,OSR,RAR,RCI,RCL,"
+7 SET HLACK=HLACK_"RDR,RDY,RER,RGR,ROR,RRA,RRD,RRE,RRG,RRI,RSP,RTB,SQR,"
+8 SET HLACK=HLACK_"TBR,VXR,VXX"
+9 ;patch HL*1.6*96 end
+10 ;patch HL*1.6*108 start: add application ack for HL7 v2.5.
+11 SET HLACK=HLACK_",BRP,BRT,ORB,ORI"
+12 ;patch HL*1.6*108 end
+13 IF 'HLANS
SET HLPIEN=0
FOR
SET HLPIEN=$ORDER(^ORD(101,HLPIEN))
if HLPIEN<1
QUIT
Begin DoDot:1
+14 if $PIECE(^ORD(101,HLPIEN,0),U,4)'="E"
QUIT
+15 DO CHKED(HLPIEN)
End DoDot:1
+16 IF +HLANS
DO CHKED(+HLANS)
+17 DO EXIT
+18 QUIT
DICQ ;
+1 NEW X,Y,DIC
+2 SET X="??"
+3 SET DIC="^ORD(101,"
SET DIC(0)="EQ"
+4 SET DIC("S")="I $P(^(0),U,4)=""E"""
+5 DO ^DIC
+6 QUIT
CHKED(PP) ;Check Event Driver Protocols
+1 KILL ERR,HLPN,HL770,HLVSP,HLVSN,HLSAPP,HLSAPN,HLMTPP,HLMTPN,HLETPP,HLETPN
SET ERR=0
+2 SET HLPN=$PIECE($GET(^ORD(101,PP,0)),U)
+3 IF HLPN=""
SET ERR=ERR+1
SET ERR(ERR)="Protocol is UNDEFINED."
QUIT
+4 IF $PIECE(^ORD(101,PP,0),U,3)]""
SET ERR=ERR+1
SET ERR(ERR)="**PROTOCOL DISABLED**"
QUIT
+5 SET HL770=$GET(^ORD(101,PP,770))
+6 IF HL770=""
SET ERR=ERR+1
SET ERR(ERR)="Missing data for all key fields."
QUIT
VSN ;Version
+1 SET HLVSP=$PIECE(HL770,U,10)
+2 IF HLVSP<1
SET ERR=ERR+1
SET ERR(ERR)="Version ID is required."
+3 SET HLVSN=""
IF HLVSP
SET HLVSN=$PIECE($GET(^HL(771.5,HLVSP,0)),U)
APP ;Sending App
+1 SET HLSAPP=$PIECE(HL770,U)
SET HLSAPN=""
+2 IF 'HLSAPP
SET ERR=ERR+1
SET ERR(ERR)="Missing Required Sending Application."
+3 IF HLSAPP
SET HLSAPN=$PIECE($GET(^HL(771,HLSAPP,0)),U)
+4 IF HLSAPP
IF HLSAPN=""
SET ERR=ERR+1
SET ERR(ERR)="Broken pointer to App Param (file 771)."
+5 IF HLSAPP
DO CHKAPP(HLSAPP)
MT ;Message Type
+1 SET HLMTPP=$PIECE(HL770,U,3)
SET HLMTPN=""
+2 IF 'HLMTPP
SET ERR=ERR+1
SET ERR(ERR)="Missing required Message Type."
+3 IF HLMTPP
SET HLMTPN=$PIECE($GET(^HL(771.2,HLMTPP,0)),U)
+4 IF HLMTPP
IF HLMTPN=""
SET ERR=ERR+1
SET ERR(ERR)="Broken pointer to Msg Type (file 771.2)."
+5 IF HLMTPN]""
IF HLACK[HLMTPN
SET ERR=ERR+1
SET ERR(ERR)="For Event Driver-Message Type cannot be an acknowledgement."
ET ;Event Type
+1 SET HLETPP=$PIECE(HL770,U,4)
SET HLETPN=""
+2 SET HLETPN=""
IF HLETPP
SET HLETPN=$PIECE($GET(^HL(779.001,HLETPP,0)),U)
+3 IF HLETPN=""
SET ERR=ERR+1
SET ERR(ERR)="Broken pointer to Event Type (file 779.001)."
+4 IF 'HLETPP
IF $GET(HLVSN)>2.1
SET ERR=ERR+1
SET ERR(ERR)="Event type is required for versions greater than 2.1."
OUT1 SET $PIECE(LINE,"_",75)=""
+1 WRITE !,LINE
+2 WRITE !,"Event Driver: ",HLPN
+3 WRITE !!,"Sending Application: ",HLSAPN
+4 WRITE !,"Version: ",$GET(HLVSN)," ","Message Type(770.3): ",$GET(HLMTPN)," ","Event Type: ",$GET(HLETPN)
+5 WRITE !!,"Event Driver Error Summary:",!
+6 IF $GET(ERR)<1
WRITE !,"No Event Driver Errors Found."
+7 IF $GET(ERR)
SET N=0
FOR
SET N=$ORDER(ERR(N))
if N<1
QUIT
WRITE !,N,". ",ERR(N)
SUB ;Check Subscribers
+1 SET HL770=$GET(^ORD(101,PP,770))
+2 IF HL770=""
SET ERR=ERR+1
SET ERR(ERR)="Missing data for all key fields."
QUIT
+3 SET HLNODE="^ORD(101,PP,10)"
+4 IF HL57
SET HLNODE="^ORD(101,PP,775)"
+5 IF '$DATA(@HLNODE)
WRITE !,"No Subscribers Found."
+6 SET HLX=0
FOR
SET HLX=$ORDER(@HLNODE@(HLX))
if HLX<1
QUIT
SET HLSUBP=$PIECE(@HLNODE@(HLX,0),U)
DO CHKSUB(HLSUBP)
+7 QUIT
CHKSUB(PP) ;Scan Subscribers
+1 KILL ERR,HLPN,HL770,HLVSP,HLVSN,HLRAPP,HLRAPN,HLMTPP,HLMTPN,HLETPP,HLETPN
SET ERR=0
+2 SET HLPN=$PIECE($GET(^ORD(101,PP,0)),U)
+3 IF HLPN=""
SET ERR=ERR+1
SET ERR(ERR)="Subscriber Protocol is UNDEFINED."
QUIT
+4 IF $PIECE(^ORD(101,PP,0),U,3)]""
SET ERR=ERR+1
SET ERR(ERR)="**SUBSCRIBER PROTOCOL DISABLED**"
QUIT
+5 SET HL770=$GET(^ORD(101,PP,770))
+6 IF HL770=""
SET ERR=ERR+1
SET ERR(ERR)="Missing data for all key fields."
QUIT
+7 SET HLRAPP=$PIECE(HL770,U,2)
SET HLRAPN=""
+8 IF 'HLRAPP
SET ERR=ERR+1
SET ERR(ERR)="Missing Required Receiving Application."
+9 IF HLRAPP
SET HLRAPN=$PIECE($GET(^HL(771,HLRAPP,0)),U)
+10 IF HLRAPP
IF HLRAPN=""
SET ERR=ERR+1
SET ERR(ERR)="Broken pointer to App Param (file 771)."
+11 IF HLRAPP
DO CHKAPP(HLRAPP)
+12 ;Response Message Type
SET HLMTPN=""
SET HLMTPP=$PIECE(HL770,U,11)
IF HLMTPP
Begin DoDot:1
+13 IF HLMTPP
SET HLMTPN=$PIECE($GET(^HL(771.2,HLMTPP,0)),U)
+14 IF HLMTPP
IF HLMTPN=""
SET ERR=ERR+1
SET ERR(ERR)="Broken pointer to Msg Type (file 771.2)."
+15 IF HLMTPN]""
IF HLACK'[HLMTPN
SET ERR=ERR+1
SET ERR(ERR)="Message Type must be an appropriate response/acknowledgement."
End DoDot:1
+16 SET HLETPP=$PIECE(HL770,U,4)
SET HLETPN=""
+17 IF HLETPP
SET HLETPN=$PIECE($GET(^HL(779.001,HLETPP,0)),U)
+18 IF HLETPP
IF HLETPN=""
SET ERR=ERR+1
SET ERR(ERR)="Broken pointer to Event Type (file 779.001)."
+19 IF $GET(^ORD(101,PP,774))=""&($GET(^ORD(101,PP,771)))=""
SET ERR=ERR+1
SET ERR(ERR)="Missing Processing Routine and Routing Logic."
+20 IF $GET(^ORD(101,PP,774))=""&($PIECE(HL770,U,7))=""
SET ERR=ERR+1
SET ERR(ERR)="WARNING-Missing both Logical Link and Routing Logic. Will be local only."
OUT2 ;Print Subscriber Errors
+1 SET $PIECE(STAR,"*",40)=""
+2 WRITE !,?10,STAR
+3 WRITE !,?10,"For Subscriber: ",$GET(HLPN)
+4 WRITE !!,?10,"Receiving Application: ",$GET(HLRAPN)
+5 WRITE !,?10,"Message Type (770.11): ",$GET(HLMTPN)," ","Event Type: ",$GET(HLETPN),!
+6 IF 'ERR
WRITE !,?10,"No Subscriber Errors Found."
+7 FOR ERR=1:1:ERR
WRITE !,?10,ERR,". ",ERR(ERR)
+8 QUIT
CHKAPP(APP) ;Check Application parameters
+1 if '$DATA(^HL(771,APP))
QUIT
+2 IF $PIECE(^HL(771,APP,0),U,2)="I"
SET ERR=ERR+1
SET ERR(ERR)="Application is INACTIVE."
+3 QUIT
EXIT ;
+1 KILL ZTSK,HL57,HL770,HLACK,HLETPN,HLETPP,HLMTPN,HLMTPP,HLNODE,HLPIEN,HLPN,HLRAPP,HLSAPN,HLSAPP,HLSUBP,HLVSN,HLVSP,HLX,LINE,STAR,SAPP,ERR
+2 QUIT
