HLPAT54 ;CIOFO-SF/RJH - HL7 PATCH 54 PRE&POST-INIT ;10/26/99 12:46
;;1.6;HEALTH LEVEL SEVEN;**54**;Oct 13, 1995
;
; Pre-install:
; 1. change event entries from "X01" to "P07", from "B01" to "PC1",
; and from "G01" to "PC6"
; 2. change message entries from "ERQ" to "RQQ", from "ROD" to
; "RQP", and from "VTQ" to "VQQ"
; 3. find the duplicate entries in file #779.001 and #771.2
; 4. resolve the pointers for fields: #101,770.4(event type),
; #101,770.3(message type), #101,770.11(message type).
; 5. resolve the pointers for fields: #773,16(event type),
; #773,15(message type).
; 6. resolve the pointer for sub-field: #771.06,.01(message type)
; of field #771,6.
; 7. delete duplicates in files #779.001 and #771.2
; 8. disable identifiers for files #779.001 and #771.2
; before bringing the data
;
; Post-install:
; enable identifiers for file #779.001 and #771.2 after installation
;
Q
PRE ;
N HLTEMP
S HLTEMP=$$NEWCP^XPDUTL("PRE1","PRE1^HLPAT54")
S HLTEMP=$$NEWCP^XPDUTL("PRE2","PRE2^HLPAT54")
S HLTEMP=$$NEWCP^XPDUTL("PRE3","PRE3^HLPAT54")
S HLTEMP=$$NEWCP^XPDUTL("PRE4","PRE4^HLPAT54")
S HLTEMP=$$NEWCP^XPDUTL("PRE5","PRE5^HLPAT54")
S HLTEMP=$$NEWCP^XPDUTL("PRE6","PRE6^HLPAT54")
Q
PRE1 ;
D CHANGE1
D CHANGE2
Q
PRE2 ;
N HLEVNARY,HLMSGARY
D EVN
D MSG
I $D(^XTMP("HLPAT54")) K ^XTMP("HLPAT54")
I $D(HLEVNARY) M ^XTMP("HLPAT54","EVN")=HLEVNARY
I $D(HLMSGARY) M ^XTMP("HLPAT54","MSG")=HLMSGARY
I $D(HLEVNARY)!$D(HLMSGARY) S ^XTMP("HLPAT54",0)=$$FMADD^XLFDT(DT,7)_U_DT
Q
PRE3 ;
Q:'$D(^XTMP("HLPAT54","EVN"))&'$D(^XTMP("HLPAT54","MSG"))
I $D(^XTMP("HLPAT54","EVN")) M HLEVNARY=^XTMP("HLPAT54","EVN")
I $D(^XTMP("HLPAT54","MSG")) M HLMSGARY=^XTMP("HLPAT54","MSG")
D PTR101
Q
PRE4 ;
Q:'$D(^XTMP("HLPAT54","EVN"))&'$D(^XTMP("HLPAT54","MSG"))
I $D(^XTMP("HLPAT54","EVN")) M HLEVNARY=^XTMP("HLPAT54","EVN")
I $D(^XTMP("HLPAT54","MSG")) M HLMSGARY=^XTMP("HLPAT54","MSG")
D PTR773
Q
PRE5 ;
Q:'$D(^XTMP("HLPAT54","EVN"))&'$D(^XTMP("HLPAT54","MSG"))
I $D(^XTMP("HLPAT54","EVN")) M HLEVNARY=^XTMP("HLPAT54","EVN")
I $D(^XTMP("HLPAT54","MSG")) M HLMSGARY=^XTMP("HLPAT54","MSG")
D PTR771
D DELETE
Q
PRE6 ;
D IDOFF
Q
CHANGE1 ; change event entries from "X01" to "P07", from "B01" to "PC1",
; and from "G01" to "PC6"
N HLIEN,DIE,DA,DR
S DIE="^HL(779.001,"
S HLIEN=0
F S HLIEN=$O(^HL(779.001,"B","X01",HLIEN)) Q:'HLIEN D
. I $D(^HL(779.001,HLIEN)) D
.. S DA=HLIEN
.. S DR=".01///P07"
.. D ^DIE
S HLIEN=0
F S HLIEN=$O(^HL(779.001,"B","B01",HLIEN)) Q:'HLIEN D
. I $D(^HL(779.001,HLIEN)) D
.. S DA=HLIEN
.. S DR=".01///PC1"
.. D ^DIE
S HLIEN=0
F S HLIEN=$O(^HL(779.001,"B","G01",HLIEN)) Q:'HLIEN D
. I $D(^HL(779.001,HLIEN)) D
.. S DA=HLIEN
.. S DR=".01///PC6"
.. D ^DIE
Q
CHANGE2 ; change message entries from "ERQ" to "RQQ", from "ROD" to "RQP",
; and from "VTQ" to "VQQ"
N HLIEN,DIE,DA,DR
S DIE="^HL(771.2,"
S HLIEN=0
F S HLIEN=$O(^HL(771.2,"B","ERQ",HLIEN)) Q:'HLIEN D
. I $D(^HL(771.2,HLIEN)) D
.. S DA=HLIEN
.. S DR=".01///RQQ"
.. D ^DIE
S HLIEN=0
F S HLIEN=$O(^HL(771.2,"B","ROD",HLIEN)) Q:'HLIEN D
. I $D(^HL(771.2,HLIEN)) D
.. S DA=HLIEN
.. S DR=".01///RQP"
.. D ^DIE
S HLIEN=0
F S HLIEN=$O(^HL(771.2,"B","VTQ",HLIEN)) Q:'HLIEN D
. I $D(^HL(771.2,HLIEN)) D
.. S DA=HLIEN
.. S DR=".01///VQQ"
.. D ^DIE
Q
EVN ; find duplicate entries in file #779.001(Event Type)
N HLEVN,HLIEN,SUB
S HLEVN=""
F S HLEVN=$O(^HL(779.001,"B",HLEVN)) Q:HLEVN="" D
. S HLIEN=0,SUB=0
. F S HLIEN=$O(^HL(779.001,"B",HLEVN,HLIEN)) Q:'HLIEN D
.. I $D(^HL(779.001,HLIEN,0)),$P(^HL(779.001,HLIEN,0),"^")=HLEVN D
... S SUB=SUB+1
... S HLEVNARY(HLEVN,SUB)=HLIEN
. I SUB=1 K HLEVNARY(HLEVN)
Q
MSG ; find duplicate entries in file #771.2(Message Type)
N HLMSG,HLIEN,SUB
S HLMSG=""
F S HLMSG=$O(^HL(771.2,"B",HLMSG)) Q:HLMSG="" D
. S HLIEN=0,SUB=0
. F S HLIEN=$O(^HL(771.2,"B",HLMSG,HLIEN)) Q:'HLIEN D
.. I $D(^HL(771.2,HLIEN,0)),$P(^HL(771.2,HLIEN,0),"^")=HLMSG D
... S SUB=SUB+1
... S HLMSGARY(HLMSG,SUB)=HLIEN
. I SUB=1 K HLMSGARY(HLMSG)
Q
PTR101 ; resolve pointers for file #101
;
; HLEVNP: pointer to file #779.001
; HLMSGP: pointer to file #771.2
; HLEVNPN: redirected new pointer to file #779.001
; HLMSGPN: redirected new pointer to file #771.2
;
N HLIEN,HLEVNP,HLMSGP,HLEVNPN,HLMSGPN,DIE,DA,DR
S HLIEN=0
S DIE="^ORD(101,"
F S HLIEN=$O(^ORD(101,HLIEN)) Q:'HLIEN D
. I $D(^ORD(101,HLIEN,770)) D
.. S HLEVNP=$P(^ORD(101,HLIEN,770),"^",4)
.. S HLEVNPN=0
.. I HLEVNP>0 S HLEVNPN=$$PEVN(HLEVNP)
.. ; redirect pointer for field #101,770.4
.. I HLEVNPN D
... S DA=HLIEN
... S DR="770.4////"_HLEVNPN
... D ^DIE
.. ;
.. S HLMSGP=$P(^ORD(101,HLIEN,770),"^",3)
.. S HLMSGPN=0
.. I HLMSGP>0 S HLMSGPN=$$PMSG(HLMSGP)
.. ; redirect pointer for filed #101,770.3
.. I HLMSGPN D
... S DA=HLIEN
... S DR="770.3////"_HLMSGPN
... D ^DIE
.. ;
.. S HLMSGP=$P(^ORD(101,HLIEN,770),"^",11)
.. S HLMSGPN=0
.. I HLMSGP>0 S HLMSGPN=$$PMSG(HLMSGP)
.. ; redirect pointer for field #101,770.11
.. I HLMSGPN D
... S DA=HLIEN
... S DR="770.11////"_HLMSGPN
... D ^DIE
Q
;
PEVN(HLIEN) ; resolve event pointer
;
; HLEVN: original event type name
; HLEVN2: the event type name in the duplicate event array
; HLSUB: the 2nd subscript of the duplicate event array
; HLIEN: the IEN for the original event type
; HLNIEN: the IEN for the first event type found in the file
; output: HLNIEN - return 0 if no duplicate,
; return the new pointer HLNIEN if duplicate
;
N HLEVN,HLEVN2,HLSUB,HLDONE,HLNIEN
Q:'$D(^HL(779.001,HLIEN,0)) 0
S HLNIEN=0
S HLEVN=$P(^HL(779.001,HLIEN,0),"^")
I HLEVN'="" D
. S HLEVN2=""
. F S HLEVN2=$O(HLEVNARY(HLEVN2)) Q:(HLEVN2="") D Q:(HLEVN2=HLEVN)
.. I HLEVN2=HLEVN D
... S HLSUB=0,HLDONE=0,HLNIEN=0
... F S HLSUB=$O(HLEVNARY(HLEVN,HLSUB)) Q:('HLSUB) D Q:HLDONE
.... I HLEVNARY(HLEVN,HLSUB)=HLIEN S HLDONE=1 D
..... I HLSUB>1 S HLNIEN=HLEVNARY(HLEVN,1)
Q HLNIEN
;
PMSG(HLIEN) ; resolve message pointer
;
; HLMSG: original message type name
; HLMSG2: the message type name in the duplicate message array
; HLSUB: the 2nd subscript of the duplicate message array
; HLIEN: the IEN for the original message type
; HLNIEN: the IEN for the first message type found in the file
; output: HLNIEN - return 0 if no duplicate,
; return the new pointer HLNIEN if duplicate
;
N HLMSG,HLMSG2,HLSUB,HLDONE,HLNIEN
Q:'$D(^HL(771.2,HLIEN,0)) 0
S HLNIEN=0
S HLMSG=$P(^HL(771.2,HLIEN,0),"^")
I HLMSG'="" D
. S HLMSG2=""
. F S HLMSG2=$O(HLMSGARY(HLMSG2)) Q:(HLMSG2="") D Q:(HLMSG2=HLMSG)
.. I HLMSG2=HLMSG D
... S HLSUB=0,HLDONE=0,HLNIEN=0
... F S HLSUB=$O(HLMSGARY(HLMSG,HLSUB)) Q:('HLSUB) D Q:HLDONE
.... I HLMSGARY(HLMSG,HLSUB)=HLIEN S HLDONE=1 D
..... I HLSUB>1 S HLNIEN=HLMSGARY(HLMSG,1)
Q HLNIEN
;
PTR773 ; resolve pointers for file #773
;
; HLEVNP: pointer to file #779.001
; HLMSGP: pointer to file #771.2
; HLEVNPN: redirected new pointer to file #779.001
; HLMSGPN: redirected new pointer to file #771.2
;
N HLIEN,HLEVNP,HLMSGP,HLEVNPN,HLMSGPN,DIE,DA,DR
S HLIEN=0
S DIE="^HLMA("
F S HLIEN=$O(^HLMA(HLIEN)) Q:'HLIEN D
. I $D(^HLMA(HLIEN,0)) D
.. S HLEVNP=$P(^HLMA(HLIEN,0),"^",14)
.. S HLEVNPN=0
.. I HLEVNP>0 S HLEVNPN=$$PEVN(HLEVNP)
.. ; redirect pointer for field #773,16
.. I HLEVNPN D
... S DA=HLIEN
... S DR="16////"_HLEVNPN
... D ^DIE
.. ;
.. S HLMSGP=$P(^HLMA(HLIEN,0),"^",13)
.. S HLMSGPN=0
.. I HLMSGP>0 S HLMSGPN=$$PMSG(HLMSGP)
.. ; redirect pointer for filed #773,15
.. I HLMSGPN D
... S DA=HLIEN
... S DR="15////"_HLMSGPN
... D ^DIE
Q
;
PTR771 ; resolve pointers for sub-field #771.06,.01 of field #771,6
;
; HLMSGP: pointer to file #771.2
; HLMSGPN: redirected new pointer to file #771.2
;
N HLIEN,HLIEN2,HLMSGP,HLMSGPN,DIE,DA,DR
S HLIEN=0
F S HLIEN=$O(^HL(771,HLIEN)) Q:'HLIEN D
. I $D(^HL(771,HLIEN,"MSG")) D
.. S HLIEN2=0
.. F S HLIEN2=$O(^HL(771,HLIEN,"MSG",HLIEN2)) Q:'HLIEN2 D
... I $D(^HL(771,HLIEN,"MSG",HLIEN2,0)) D
.... S HLMSGP=$P(^HL(771,HLIEN,"MSG",HLIEN2,0),"^")
.... S HLMSGPN=0
.... I HLMSGP>0 S HLMSGPN=$$PMSG(HLMSGP)
.... ; redirect pointer for SUB-field #771.06,.01 of field #771,6
.... I HLMSGPN D
..... S DIE="^HL(771,"_HLIEN_",""MSG"","
..... S DA(1)=HLIEN
..... S DA=HLIEN2
..... S DR=".01////"_HLMSGPN
..... D ^DIE
Q
;
DELETE ; delete duplicate entries in file #779.001 and #771.2
N HLEVN,HLMSG,HLSUB,DIK,DA
; delete duplicate entries in file #779.001
S HLEVN="",DIK="^HL(779.001,"
F S HLEVN=$O(HLEVNARY(HLEVN)) Q:HLEVN="" D
. S HLSUB=1
. F S HLSUB=$O(HLEVNARY(HLEVN,HLSUB)) Q:'HLSUB D
.. S DA=HLEVNARY(HLEVN,HLSUB)
.. D ^DIK
;
; delete duplicate entries in file #771.2
S HLMSG="",DIK="^HL(771.2,"
F S HLMSG=$O(HLMSGARY(HLMSG)) Q:HLMSG="" D
. S HLSUB=1
. F S HLSUB=$O(HLMSGARY(HLMSG,HLSUB)) Q:'HLSUB D
.. S DA=HLMSGARY(HLMSG,HLSUB)
.. D ^DIK
;
Q
IDOFF ; disable identifier for file #779.001 and #771.2
K ^DD(779.001,0,"ID")
K ^DD(771.2,0,"ID")
Q
POST ;enable identifier for file #779.001 and #771.2
S ^DD(779.001,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
S ^DD(771.2,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLPAT54 9489 printed Dec 13, 2024@01:59:38 Page 2
HLPAT54 ;CIOFO-SF/RJH - HL7 PATCH 54 PRE&POST-INIT ;10/26/99 12:46
+1 ;;1.6;HEALTH LEVEL SEVEN;**54**;Oct 13, 1995
+2 ;
+3 ; Pre-install:
+4 ; 1. change event entries from "X01" to "P07", from "B01" to "PC1",
+5 ; and from "G01" to "PC6"
+6 ; 2. change message entries from "ERQ" to "RQQ", from "ROD" to
+7 ; "RQP", and from "VTQ" to "VQQ"
+8 ; 3. find the duplicate entries in file #779.001 and #771.2
+9 ; 4. resolve the pointers for fields: #101,770.4(event type),
+10 ; #101,770.3(message type), #101,770.11(message type).
+11 ; 5. resolve the pointers for fields: #773,16(event type),
+12 ; #773,15(message type).
+13 ; 6. resolve the pointer for sub-field: #771.06,.01(message type)
+14 ; of field #771,6.
+15 ; 7. delete duplicates in files #779.001 and #771.2
+16 ; 8. disable identifiers for files #779.001 and #771.2
+17 ; before bringing the data
+18 ;
+19 ; Post-install:
+20 ; enable identifiers for file #779.001 and #771.2 after installation
+21 ;
+22 QUIT
PRE ;
+1 NEW HLTEMP
+2 SET HLTEMP=$$NEWCP^XPDUTL("PRE1","PRE1^HLPAT54")
+3 SET HLTEMP=$$NEWCP^XPDUTL("PRE2","PRE2^HLPAT54")
+4 SET HLTEMP=$$NEWCP^XPDUTL("PRE3","PRE3^HLPAT54")
+5 SET HLTEMP=$$NEWCP^XPDUTL("PRE4","PRE4^HLPAT54")
+6 SET HLTEMP=$$NEWCP^XPDUTL("PRE5","PRE5^HLPAT54")
+7 SET HLTEMP=$$NEWCP^XPDUTL("PRE6","PRE6^HLPAT54")
+8 QUIT
PRE1 ;
+1 DO CHANGE1
+2 DO CHANGE2
+3 QUIT
PRE2 ;
+1 NEW HLEVNARY,HLMSGARY
+2 DO EVN
+3 DO MSG
+4 IF $DATA(^XTMP("HLPAT54"))
KILL ^XTMP("HLPAT54")
+5 IF $DATA(HLEVNARY)
MERGE ^XTMP("HLPAT54","EVN")=HLEVNARY
+6 IF $DATA(HLMSGARY)
MERGE ^XTMP("HLPAT54","MSG")=HLMSGARY
+7 IF $DATA(HLEVNARY)!$DATA(HLMSGARY)
SET ^XTMP("HLPAT54",0)=$$FMADD^XLFDT(DT,7)_U_DT
+8 QUIT
PRE3 ;
+1 if '$DATA(^XTMP("HLPAT54","EVN"))&'$DATA(^XTMP("HLPAT54","MSG"))
QUIT
+2 IF $DATA(^XTMP("HLPAT54","EVN"))
MERGE HLEVNARY=^XTMP("HLPAT54","EVN")
+3 IF $DATA(^XTMP("HLPAT54","MSG"))
MERGE HLMSGARY=^XTMP("HLPAT54","MSG")
+4 DO PTR101
+5 QUIT
PRE4 ;
+1 if '$DATA(^XTMP("HLPAT54","EVN"))&'$DATA(^XTMP("HLPAT54","MSG"))
QUIT
+2 IF $DATA(^XTMP("HLPAT54","EVN"))
MERGE HLEVNARY=^XTMP("HLPAT54","EVN")
+3 IF $DATA(^XTMP("HLPAT54","MSG"))
MERGE HLMSGARY=^XTMP("HLPAT54","MSG")
+4 DO PTR773
+5 QUIT
PRE5 ;
+1 if '$DATA(^XTMP("HLPAT54","EVN"))&'$DATA(^XTMP("HLPAT54","MSG"))
QUIT
+2 IF $DATA(^XTMP("HLPAT54","EVN"))
MERGE HLEVNARY=^XTMP("HLPAT54","EVN")
+3 IF $DATA(^XTMP("HLPAT54","MSG"))
MERGE HLMSGARY=^XTMP("HLPAT54","MSG")
+4 DO PTR771
+5 DO DELETE
+6 QUIT
PRE6 ;
+1 DO IDOFF
+2 QUIT
CHANGE1 ; change event entries from "X01" to "P07", from "B01" to "PC1",
+1 ; and from "G01" to "PC6"
+2 NEW HLIEN,DIE,DA,DR
+3 SET DIE="^HL(779.001,"
+4 SET HLIEN=0
+5 FOR
SET HLIEN=$ORDER(^HL(779.001,"B","X01",HLIEN))
if 'HLIEN
QUIT
Begin DoDot:1
+6 IF $DATA(^HL(779.001,HLIEN))
Begin DoDot:2
+7 SET DA=HLIEN
+8 SET DR=".01///P07"
+9 DO ^DIE
End DoDot:2
End DoDot:1
+10 SET HLIEN=0
+11 FOR
SET HLIEN=$ORDER(^HL(779.001,"B","B01",HLIEN))
if 'HLIEN
QUIT
Begin DoDot:1
+12 IF $DATA(^HL(779.001,HLIEN))
Begin DoDot:2
+13 SET DA=HLIEN
+14 SET DR=".01///PC1"
+15 DO ^DIE
End DoDot:2
End DoDot:1
+16 SET HLIEN=0
+17 FOR
SET HLIEN=$ORDER(^HL(779.001,"B","G01",HLIEN))
if 'HLIEN
QUIT
Begin DoDot:1
+18 IF $DATA(^HL(779.001,HLIEN))
Begin DoDot:2
+19 SET DA=HLIEN
+20 SET DR=".01///PC6"
+21 DO ^DIE
End DoDot:2
End DoDot:1
+22 QUIT
CHANGE2 ; change message entries from "ERQ" to "RQQ", from "ROD" to "RQP",
+1 ; and from "VTQ" to "VQQ"
+2 NEW HLIEN,DIE,DA,DR
+3 SET DIE="^HL(771.2,"
+4 SET HLIEN=0
+5 FOR
SET HLIEN=$ORDER(^HL(771.2,"B","ERQ",HLIEN))
if 'HLIEN
QUIT
Begin DoDot:1
+6 IF $DATA(^HL(771.2,HLIEN))
Begin DoDot:2
+7 SET DA=HLIEN
+8 SET DR=".01///RQQ"
+9 DO ^DIE
End DoDot:2
End DoDot:1
+10 SET HLIEN=0
+11 FOR
SET HLIEN=$ORDER(^HL(771.2,"B","ROD",HLIEN))
if 'HLIEN
QUIT
Begin DoDot:1
+12 IF $DATA(^HL(771.2,HLIEN))
Begin DoDot:2
+13 SET DA=HLIEN
+14 SET DR=".01///RQP"
+15 DO ^DIE
End DoDot:2
End DoDot:1
+16 SET HLIEN=0
+17 FOR
SET HLIEN=$ORDER(^HL(771.2,"B","VTQ",HLIEN))
if 'HLIEN
QUIT
Begin DoDot:1
+18 IF $DATA(^HL(771.2,HLIEN))
Begin DoDot:2
+19 SET DA=HLIEN
+20 SET DR=".01///VQQ"
+21 DO ^DIE
End DoDot:2
End DoDot:1
+22 QUIT
EVN ; find duplicate entries in file #779.001(Event Type)
+1 NEW HLEVN,HLIEN,SUB
+2 SET HLEVN=""
+3 FOR
SET HLEVN=$ORDER(^HL(779.001,"B",HLEVN))
if HLEVN=""
QUIT
Begin DoDot:1
+4 SET HLIEN=0
SET SUB=0
+5 FOR
SET HLIEN=$ORDER(^HL(779.001,"B",HLEVN,HLIEN))
if 'HLIEN
QUIT
Begin DoDot:2
+6 IF $DATA(^HL(779.001,HLIEN,0))
IF $PIECE(^HL(779.001,HLIEN,0),"^")=HLEVN
Begin DoDot:3
+7 SET SUB=SUB+1
+8 SET HLEVNARY(HLEVN,SUB)=HLIEN
End DoDot:3
End DoDot:2
+9 IF SUB=1
KILL HLEVNARY(HLEVN)
End DoDot:1
+10 QUIT
MSG ; find duplicate entries in file #771.2(Message Type)
+1 NEW HLMSG,HLIEN,SUB
+2 SET HLMSG=""
+3 FOR
SET HLMSG=$ORDER(^HL(771.2,"B",HLMSG))
if HLMSG=""
QUIT
Begin DoDot:1
+4 SET HLIEN=0
SET SUB=0
+5 FOR
SET HLIEN=$ORDER(^HL(771.2,"B",HLMSG,HLIEN))
if 'HLIEN
QUIT
Begin DoDot:2
+6 IF $DATA(^HL(771.2,HLIEN,0))
IF $PIECE(^HL(771.2,HLIEN,0),"^")=HLMSG
Begin DoDot:3
+7 SET SUB=SUB+1
+8 SET HLMSGARY(HLMSG,SUB)=HLIEN
End DoDot:3
End DoDot:2
+9 IF SUB=1
KILL HLMSGARY(HLMSG)
End DoDot:1
+10 QUIT
PTR101 ; resolve pointers for file #101
+1 ;
+2 ; HLEVNP: pointer to file #779.001
+3 ; HLMSGP: pointer to file #771.2
+4 ; HLEVNPN: redirected new pointer to file #779.001
+5 ; HLMSGPN: redirected new pointer to file #771.2
+6 ;
+7 NEW HLIEN,HLEVNP,HLMSGP,HLEVNPN,HLMSGPN,DIE,DA,DR
+8 SET HLIEN=0
+9 SET DIE="^ORD(101,"
+10 FOR
SET HLIEN=$ORDER(^ORD(101,HLIEN))
if 'HLIEN
QUIT
Begin DoDot:1
+11 IF $DATA(^ORD(101,HLIEN,770))
Begin DoDot:2
+12 SET HLEVNP=$PIECE(^ORD(101,HLIEN,770),"^",4)
+13 SET HLEVNPN=0
+14 IF HLEVNP>0
SET HLEVNPN=$$PEVN(HLEVNP)
+15 ; redirect pointer for field #101,770.4
+16 IF HLEVNPN
Begin DoDot:3
+17 SET DA=HLIEN
+18 SET DR="770.4////"_HLEVNPN
+19 DO ^DIE
End DoDot:3
+20 ;
+21 SET HLMSGP=$PIECE(^ORD(101,HLIEN,770),"^",3)
+22 SET HLMSGPN=0
+23 IF HLMSGP>0
SET HLMSGPN=$$PMSG(HLMSGP)
+24 ; redirect pointer for filed #101,770.3
+25 IF HLMSGPN
Begin DoDot:3
+26 SET DA=HLIEN
+27 SET DR="770.3////"_HLMSGPN
+28 DO ^DIE
End DoDot:3
+29 ;
+30 SET HLMSGP=$PIECE(^ORD(101,HLIEN,770),"^",11)
+31 SET HLMSGPN=0
+32 IF HLMSGP>0
SET HLMSGPN=$$PMSG(HLMSGP)
+33 ; redirect pointer for field #101,770.11
+34 IF HLMSGPN
Begin DoDot:3
+35 SET DA=HLIEN
+36 SET DR="770.11////"_HLMSGPN
+37 DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+38 QUIT
+39 ;
PEVN(HLIEN) ; resolve event pointer
+1 ;
+2 ; HLEVN: original event type name
+3 ; HLEVN2: the event type name in the duplicate event array
+4 ; HLSUB: the 2nd subscript of the duplicate event array
+5 ; HLIEN: the IEN for the original event type
+6 ; HLNIEN: the IEN for the first event type found in the file
+7 ; output: HLNIEN - return 0 if no duplicate,
+8 ; return the new pointer HLNIEN if duplicate
+9 ;
+10 NEW HLEVN,HLEVN2,HLSUB,HLDONE,HLNIEN
+11 if '$DATA(^HL(779.001,HLIEN,0))
QUIT 0
+12 SET HLNIEN=0
+13 SET HLEVN=$PIECE(^HL(779.001,HLIEN,0),"^")
+14 IF HLEVN'=""
Begin DoDot:1
+15 SET HLEVN2=""
+16 FOR
SET HLEVN2=$ORDER(HLEVNARY(HLEVN2))
if (HLEVN2="")
QUIT
Begin DoDot:2
+17 IF HLEVN2=HLEVN
Begin DoDot:3
+18 SET HLSUB=0
SET HLDONE=0
SET HLNIEN=0
+19 FOR
SET HLSUB=$ORDER(HLEVNARY(HLEVN,HLSUB))
if ('HLSUB)
QUIT
Begin DoDot:4
+20 IF HLEVNARY(HLEVN,HLSUB)=HLIEN
SET HLDONE=1
Begin DoDot:5
+21 IF HLSUB>1
SET HLNIEN=HLEVNARY(HLEVN,1)
End DoDot:5
End DoDot:4
if HLDONE
QUIT
End DoDot:3
End DoDot:2
if (HLEVN2=HLEVN)
QUIT
End DoDot:1
+22 QUIT HLNIEN
+23 ;
PMSG(HLIEN) ; resolve message pointer
+1 ;
+2 ; HLMSG: original message type name
+3 ; HLMSG2: the message type name in the duplicate message array
+4 ; HLSUB: the 2nd subscript of the duplicate message array
+5 ; HLIEN: the IEN for the original message type
+6 ; HLNIEN: the IEN for the first message type found in the file
+7 ; output: HLNIEN - return 0 if no duplicate,
+8 ; return the new pointer HLNIEN if duplicate
+9 ;
+10 NEW HLMSG,HLMSG2,HLSUB,HLDONE,HLNIEN
+11 if '$DATA(^HL(771.2,HLIEN,0))
QUIT 0
+12 SET HLNIEN=0
+13 SET HLMSG=$PIECE(^HL(771.2,HLIEN,0),"^")
+14 IF HLMSG'=""
Begin DoDot:1
+15 SET HLMSG2=""
+16 FOR
SET HLMSG2=$ORDER(HLMSGARY(HLMSG2))
if (HLMSG2="")
QUIT
Begin DoDot:2
+17 IF HLMSG2=HLMSG
Begin DoDot:3
+18 SET HLSUB=0
SET HLDONE=0
SET HLNIEN=0
+19 FOR
SET HLSUB=$ORDER(HLMSGARY(HLMSG,HLSUB))
if ('HLSUB)
QUIT
Begin DoDot:4
+20 IF HLMSGARY(HLMSG,HLSUB)=HLIEN
SET HLDONE=1
Begin DoDot:5
+21 IF HLSUB>1
SET HLNIEN=HLMSGARY(HLMSG,1)
End DoDot:5
End DoDot:4
if HLDONE
QUIT
End DoDot:3
End DoDot:2
if (HLMSG2=HLMSG)
QUIT
End DoDot:1
+22 QUIT HLNIEN
+23 ;
PTR773 ; resolve pointers for file #773
+1 ;
+2 ; HLEVNP: pointer to file #779.001
+3 ; HLMSGP: pointer to file #771.2
+4 ; HLEVNPN: redirected new pointer to file #779.001
+5 ; HLMSGPN: redirected new pointer to file #771.2
+6 ;
+7 NEW HLIEN,HLEVNP,HLMSGP,HLEVNPN,HLMSGPN,DIE,DA,DR
+8 SET HLIEN=0
+9 SET DIE="^HLMA("
+10 FOR
SET HLIEN=$ORDER(^HLMA(HLIEN))
if 'HLIEN
QUIT
Begin DoDot:1
+11 IF $DATA(^HLMA(HLIEN,0))
Begin DoDot:2
+12 SET HLEVNP=$PIECE(^HLMA(HLIEN,0),"^",14)
+13 SET HLEVNPN=0
+14 IF HLEVNP>0
SET HLEVNPN=$$PEVN(HLEVNP)
+15 ; redirect pointer for field #773,16
+16 IF HLEVNPN
Begin DoDot:3
+17 SET DA=HLIEN
+18 SET DR="16////"_HLEVNPN
+19 DO ^DIE
End DoDot:3
+20 ;
+21 SET HLMSGP=$PIECE(^HLMA(HLIEN,0),"^",13)
+22 SET HLMSGPN=0
+23 IF HLMSGP>0
SET HLMSGPN=$$PMSG(HLMSGP)
+24 ; redirect pointer for filed #773,15
+25 IF HLMSGPN
Begin DoDot:3
+26 SET DA=HLIEN
+27 SET DR="15////"_HLMSGPN
+28 DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;
PTR771 ; resolve pointers for sub-field #771.06,.01 of field #771,6
+1 ;
+2 ; HLMSGP: pointer to file #771.2
+3 ; HLMSGPN: redirected new pointer to file #771.2
+4 ;
+5 NEW HLIEN,HLIEN2,HLMSGP,HLMSGPN,DIE,DA,DR
+6 SET HLIEN=0
+7 FOR
SET HLIEN=$ORDER(^HL(771,HLIEN))
if 'HLIEN
QUIT
Begin DoDot:1
+8 IF $DATA(^HL(771,HLIEN,"MSG"))
Begin DoDot:2
+9 SET HLIEN2=0
+10 FOR
SET HLIEN2=$ORDER(^HL(771,HLIEN,"MSG",HLIEN2))
if 'HLIEN2
QUIT
Begin DoDot:3
+11 IF $DATA(^HL(771,HLIEN,"MSG",HLIEN2,0))
Begin DoDot:4
+12 SET HLMSGP=$PIECE(^HL(771,HLIEN,"MSG",HLIEN2,0),"^")
+13 SET HLMSGPN=0
+14 IF HLMSGP>0
SET HLMSGPN=$$PMSG(HLMSGP)
+15 ; redirect pointer for SUB-field #771.06,.01 of field #771,6
+16 IF HLMSGPN
Begin DoDot:5
+17 SET DIE="^HL(771,"_HLIEN_",""MSG"","
+18 SET DA(1)=HLIEN
+19 SET DA=HLIEN2
+20 SET DR=".01////"_HLMSGPN
+21 DO ^DIE
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
DELETE ; delete duplicate entries in file #779.001 and #771.2
+1 NEW HLEVN,HLMSG,HLSUB,DIK,DA
+2 ; delete duplicate entries in file #779.001
+3 SET HLEVN=""
SET DIK="^HL(779.001,"
+4 FOR
SET HLEVN=$ORDER(HLEVNARY(HLEVN))
if HLEVN=""
QUIT
Begin DoDot:1
+5 SET HLSUB=1
+6 FOR
SET HLSUB=$ORDER(HLEVNARY(HLEVN,HLSUB))
if 'HLSUB
QUIT
Begin DoDot:2
+7 SET DA=HLEVNARY(HLEVN,HLSUB)
+8 DO ^DIK
End DoDot:2
End DoDot:1
+9 ;
+10 ; delete duplicate entries in file #771.2
+11 SET HLMSG=""
SET DIK="^HL(771.2,"
+12 FOR
SET HLMSG=$ORDER(HLMSGARY(HLMSG))
if HLMSG=""
QUIT
Begin DoDot:1
+13 SET HLSUB=1
+14 FOR
SET HLSUB=$ORDER(HLMSGARY(HLMSG,HLSUB))
if 'HLSUB
QUIT
Begin DoDot:2
+15 SET DA=HLMSGARY(HLMSG,HLSUB)
+16 DO ^DIK
End DoDot:2
End DoDot:1
+17 ;
+18 QUIT
IDOFF ; disable identifier for file #779.001 and #771.2
+1 KILL ^DD(779.001,0,"ID")
+2 KILL ^DD(771.2,0,"ID")
+3 QUIT
POST ;enable identifier for file #779.001 and #771.2
+1 SET ^DD(779.001,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
+2 SET ^DD(771.2,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
+3 QUIT
