HLP145 ;OITFO-SF/RJH - HL7 PATCH 145 PRE&POST-INIT ;02/17/2009 17:08
;;1.6;HEALTH LEVEL SEVEN;**145**;Oct 13, 1995;Build 4
;
; Pre-install:
; 1. find the duplicate entries in file #779.001, #771.2 and #771.3
; 2. resolve the pointers for fields: #101,770.4(event type),
; #101,770.3(message type), #101,770.11(message type).
; 3. resolve the pointers for fields: #773,16(event type),
; #773,15(message type).
; 4. resolve the pointer for sub-field: #771.06,.01(message type)
; of field #771,6, and #771.05,.01(segment type) of field #771,5.
; 5. delete duplicates in files #779.001, #771.2 and #771.3.
; and disable the Identifiers for files: #779.001, #771.2, #771.3
; and #779.005
Q
PRE ;
N HLTEMP
S HLTEMP=$$NEWCP^XPDUTL("PRE1","PRE1^HLP145")
S HLTEMP=$$NEWCP^XPDUTL("PRE2","PRE2^HLP145")
S HLTEMP=$$NEWCP^XPDUTL("PRE3","PRE3^HLP145")
S HLTEMP=$$NEWCP^XPDUTL("PRE4","PRE4^HLP145")
S HLTEMP=$$NEWCP^XPDUTL("PRE5","PRE5^HLP145")
Q
PRE1 ;
N HLEVNARY,HLMSGARY,HLSEGARY
D EVN^HLP145
D MSG^HLP145
D SEG^HLP145
I $D(^XTMP("HLP145")) K ^XTMP("HLP145")
I $D(HLEVNARY) M ^XTMP("HLP145","EVN")=HLEVNARY
I $D(HLMSGARY) M ^XTMP("HLP145","MSG")=HLMSGARY
I $D(HLSEGARY) M ^XTMP("HLP145","SEG")=HLSEGARY
I $D(HLEVNARY)!$D(HLMSGARY)!$D(HLSEGARY) S ^XTMP("HLP145",0)=$$FMADD^XLFDT(DT,90)_U_DT
Q
PRE2 ;
Q:'$D(^XTMP("HLP145","EVN"))&'$D(^XTMP("HLP145","MSG"))&'$D(^XTMP("HLP145","SEG"))
I $D(^XTMP("HLP145","EVN")) M HLEVNARY=^XTMP("HLP145","EVN")
I $D(^XTMP("HLP145","MSG")) M HLMSGARY=^XTMP("HLP145","MSG")
D PTR101
Q
PRE3 ;
Q:'$D(^XTMP("HLP145","EVN"))&'$D(^XTMP("HLP145","MSG"))&'$D(^XTMP("HLP145","SEG"))
I $D(^XTMP("HLP145","EVN")) M HLEVNARY=^XTMP("HLP145","EVN")
I $D(^XTMP("HLP145","MSG")) M HLMSGARY=^XTMP("HLP145","MSG")
D PTR773
Q
PRE4 ;
Q:'$D(^XTMP("HLP145","EVN"))&'$D(^XTMP("HLP145","MSG"))&'$D(^XTMP("HLP145","SEG"))
I $D(^XTMP("HLP145","EVN")) M HLEVNARY=^XTMP("HLP145","EVN")
I $D(^XTMP("HLP145","MSG")) M HLMSGARY=^XTMP("HLP145","MSG")
I $D(^XTMP("HLP145","SEG")) M HLSEGARY=^XTMP("HLP145","SEG")
D PTR771^HLP145
Q
PRE5 ;
D IDOFF^HLP145
Q:'$D(^XTMP("HLP145","EVN"))&'$D(^XTMP("HLP145","MSG"))&'$D(^XTMP("HLP145","SEG"))
I $D(^XTMP("HLP145","EVN")) M HLEVNARY=^XTMP("HLP145","EVN")
I $D(^XTMP("HLP145","MSG")) M HLMSGARY=^XTMP("HLP145","MSG")
I $D(^XTMP("HLP145","SEG")) M HLSEGARY=^XTMP("HLP145","SEG")
D DELETE^HLP145
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^HLP145(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^HLP145(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^HLP145(HLMSGP)
.. ; redirect pointer for field #101,770.11
.. I HLMSGPN D
... S DA=HLIEN
... S DR="770.11////"_HLMSGPN
... D ^DIE
Q
;
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^HLP145(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^HLP145(HLMSGP)
.. ; redirect pointer for filed #773,15
.. I HLMSGPN D
... S DA=HLIEN
... S DR="15////"_HLMSGPN
... D ^DIE
Q
;
HLP145A ; Pre-install II
; Entries: PTR771, PEVE, PMSG, and PMSG
;
PTR771 ; resolve pointers for sub-field #771.06,.01 of field #771,6
; and #771.05,.01 of field #771,5
;
; HLMSGP: pointer to file #771.2
; HLMSGPN: redirected new pointer to file #771.2
; HLSEGP: pointer to file #771.3
; HLSEGPN: redirected new pointer to file #771.3
;
N HLIEN,HLIEN2,HLMSGP,HLMSGPN,DIE,DA,DR
N HLSEGP,HLSEGPN
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^HLP145(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
. I $D(^HL(771,HLIEN,"SEG")) D
.. S HLIEN2=0
.. F S HLIEN2=$O(^HL(771,HLIEN,"SEG",HLIEN2)) Q:'HLIEN2 D
... I $D(^HL(771,HLIEN,"SEG",HLIEN2,0)) D
.... S HLSEGP=$P(^HL(771,HLIEN,"SEG",HLIEN2,0),"^")
.... S HLSEGPN=0
.... I HLSEGP>0 S HLSEGPN=$$PSEG^HLP145(HLSEGP)
.... ; redirect pointer for SUB-field #771.05,.01 of field #771,5
.... I HLSEGPN D
..... S DIE="^HL(771,"_HLIEN_",""SEG"","
..... S DA(1)=HLIEN
..... S DA=HLIEN2
..... S DR=".01////"_HLSEGPN
..... 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
;
PSEG(HLIEN) ; resolve segment pointer
;
; HLSEG: original segment type name
; HLSEG2: the segment type name in the duplicate segment array
; HLSUB: the 2nd subscript of the duplicate segment array
; HLIEN: the IEN for the original segment type
; HLNIEN: the IEN for the first segment type found in the file
; output: HLNIEN - return 0 if no duplicate,
; return the new pointer HLNIEN if duplicate
;
N HLSEG,HLSEG2,HLSUB,HLDONE,HLNIEN
Q:'$D(^HL(771.3,HLIEN,0)) 0
S HLNIEN=0
S HLSEG=$P(^HL(771.3,HLIEN,0),"^")
I HLSEG'="" D
. S HLSEG2=""
. F S HLSEG2=$O(HLSEGARY(HLSEG2)) Q:(HLSEG2="") D Q:(HLSEG2=HLSEG)
.. I HLSEG2=HLSEG D
... S HLSUB=0,HLDONE=0,HLNIEN=0
... F S HLSUB=$O(HLSEGARY(HLSEG,HLSUB)) Q:('HLSUB) D Q:HLDONE
.... I HLSEGARY(HLSEG,HLSUB)=HLIEN S HLDONE=1 D
..... I HLSUB>1 S HLNIEN=HLSEGARY(HLSEG,1)
Q HLNIEN
;
HLP145B ; Part III of Pre-install and Post-install
; Entries: EVN, MSG, SEG, DELETE, and IDOFF
;
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
SEG ; find duplicate entries in file #771.3(Segment Type)
N HLSEG,HLIEN,SUB
S HLSEG=""
F S HLSEG=$O(^HL(771.3,"B",HLSEG)) Q:HLSEG="" D
. S HLIEN=0,SUB=0
. F S HLIEN=$O(^HL(771.3,"B",HLSEG,HLIEN)) Q:'HLIEN D
.. I $D(^HL(771.3,HLIEN,0)),$P(^HL(771.3,HLIEN,0),"^")=HLSEG D
... S SUB=SUB+1
... S HLSEGARY(HLSEG,SUB)=HLIEN
. I SUB=1 K HLSEGARY(HLSEG)
Q
DELETE ; delete duplicate entries in file #779.001, #771.2 and #771.3
N HLEVN,HLMSG,HLSEG,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
;
; delete duplicate entries in file #771.3
S HLSEG="",DIK="^HL(771.3,"
F S HLSEG=$O(HLSEGARY(HLSEG)) Q:HLSEG="" D
. S HLSUB=1
. F S HLSUB=$O(HLSEGARY(HLSEG,HLSUB)) Q:'HLSUB D
.. S DA=HLSEGARY(HLSEG,HLSUB)
.. D ^DIK
;
Q
IDOFF ; disable identifier for file #779.001, #771.2, #771.3,
; and 779.005
K ^DD(779.001,0,"ID")
K ^DD(771.2,0,"ID")
K ^DD(771.3,0,"ID")
K ^DD(779.005,0,"ID")
Q
POST ;enable identifier for file #779.001, #771.2, and #771.3
; and 779.005
S ^DD(779.001,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
S ^DD(771.2,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
S ^DD(771.3,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
S ^DD(779.005,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLP145 11082 printed Dec 13, 2024@01:59:29 Page 2
HLP145 ;OITFO-SF/RJH - HL7 PATCH 145 PRE&POST-INIT ;02/17/2009 17:08
+1 ;;1.6;HEALTH LEVEL SEVEN;**145**;Oct 13, 1995;Build 4
+2 ;
+3 ; Pre-install:
+4 ; 1. find the duplicate entries in file #779.001, #771.2 and #771.3
+5 ; 2. resolve the pointers for fields: #101,770.4(event type),
+6 ; #101,770.3(message type), #101,770.11(message type).
+7 ; 3. resolve the pointers for fields: #773,16(event type),
+8 ; #773,15(message type).
+9 ; 4. resolve the pointer for sub-field: #771.06,.01(message type)
+10 ; of field #771,6, and #771.05,.01(segment type) of field #771,5.
+11 ; 5. delete duplicates in files #779.001, #771.2 and #771.3.
+12 ; and disable the Identifiers for files: #779.001, #771.2, #771.3
+13 ; and #779.005
+14 QUIT
PRE ;
+1 NEW HLTEMP
+2 SET HLTEMP=$$NEWCP^XPDUTL("PRE1","PRE1^HLP145")
+3 SET HLTEMP=$$NEWCP^XPDUTL("PRE2","PRE2^HLP145")
+4 SET HLTEMP=$$NEWCP^XPDUTL("PRE3","PRE3^HLP145")
+5 SET HLTEMP=$$NEWCP^XPDUTL("PRE4","PRE4^HLP145")
+6 SET HLTEMP=$$NEWCP^XPDUTL("PRE5","PRE5^HLP145")
+7 QUIT
PRE1 ;
+1 NEW HLEVNARY,HLMSGARY,HLSEGARY
+2 DO EVN^HLP145
+3 DO MSG^HLP145
+4 DO SEG^HLP145
+5 IF $DATA(^XTMP("HLP145"))
KILL ^XTMP("HLP145")
+6 IF $DATA(HLEVNARY)
MERGE ^XTMP("HLP145","EVN")=HLEVNARY
+7 IF $DATA(HLMSGARY)
MERGE ^XTMP("HLP145","MSG")=HLMSGARY
+8 IF $DATA(HLSEGARY)
MERGE ^XTMP("HLP145","SEG")=HLSEGARY
+9 IF $DATA(HLEVNARY)!$DATA(HLMSGARY)!$DATA(HLSEGARY)
SET ^XTMP("HLP145",0)=$$FMADD^XLFDT(DT,90)_U_DT
+10 QUIT
PRE2 ;
+1 if '$DATA(^XTMP("HLP145","EVN"))&'$DATA(^XTMP("HLP145","MSG"))&'$DATA(^XTMP("HLP145","SEG"))
QUIT
+2 IF $DATA(^XTMP("HLP145","EVN"))
MERGE HLEVNARY=^XTMP("HLP145","EVN")
+3 IF $DATA(^XTMP("HLP145","MSG"))
MERGE HLMSGARY=^XTMP("HLP145","MSG")
+4 DO PTR101
+5 QUIT
PRE3 ;
+1 if '$DATA(^XTMP("HLP145","EVN"))&'$DATA(^XTMP("HLP145","MSG"))&'$DATA(^XTMP("HLP145","SEG"))
QUIT
+2 IF $DATA(^XTMP("HLP145","EVN"))
MERGE HLEVNARY=^XTMP("HLP145","EVN")
+3 IF $DATA(^XTMP("HLP145","MSG"))
MERGE HLMSGARY=^XTMP("HLP145","MSG")
+4 DO PTR773
+5 QUIT
PRE4 ;
+1 if '$DATA(^XTMP("HLP145","EVN"))&'$DATA(^XTMP("HLP145","MSG"))&'$DATA(^XTMP("HLP145","SEG"))
QUIT
+2 IF $DATA(^XTMP("HLP145","EVN"))
MERGE HLEVNARY=^XTMP("HLP145","EVN")
+3 IF $DATA(^XTMP("HLP145","MSG"))
MERGE HLMSGARY=^XTMP("HLP145","MSG")
+4 IF $DATA(^XTMP("HLP145","SEG"))
MERGE HLSEGARY=^XTMP("HLP145","SEG")
+5 DO PTR771^HLP145
+6 QUIT
PRE5 ;
+1 DO IDOFF^HLP145
+2 if '$DATA(^XTMP("HLP145","EVN"))&'$DATA(^XTMP("HLP145","MSG"))&'$DATA(^XTMP("HLP145","SEG"))
QUIT
+3 IF $DATA(^XTMP("HLP145","EVN"))
MERGE HLEVNARY=^XTMP("HLP145","EVN")
+4 IF $DATA(^XTMP("HLP145","MSG"))
MERGE HLMSGARY=^XTMP("HLP145","MSG")
+5 IF $DATA(^XTMP("HLP145","SEG"))
MERGE HLSEGARY=^XTMP("HLP145","SEG")
+6 DO DELETE^HLP145
+7 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^HLP145(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^HLP145(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^HLP145(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 ;
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^HLP145(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^HLP145(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 ;
HLP145A ; Pre-install II
+1 ; Entries: PTR771, PEVE, PMSG, and PMSG
+2 ;
PTR771 ; resolve pointers for sub-field #771.06,.01 of field #771,6
+1 ; and #771.05,.01 of field #771,5
+2 ;
+3 ; HLMSGP: pointer to file #771.2
+4 ; HLMSGPN: redirected new pointer to file #771.2
+5 ; HLSEGP: pointer to file #771.3
+6 ; HLSEGPN: redirected new pointer to file #771.3
+7 ;
+8 NEW HLIEN,HLIEN2,HLMSGP,HLMSGPN,DIE,DA,DR
+9 NEW HLSEGP,HLSEGPN
+10 SET HLIEN=0
+11 FOR
SET HLIEN=$ORDER(^HL(771,HLIEN))
if 'HLIEN
QUIT
Begin DoDot:1
+12 IF $DATA(^HL(771,HLIEN,"MSG"))
Begin DoDot:2
+13 SET HLIEN2=0
+14 FOR
SET HLIEN2=$ORDER(^HL(771,HLIEN,"MSG",HLIEN2))
if 'HLIEN2
QUIT
Begin DoDot:3
+15 IF $DATA(^HL(771,HLIEN,"MSG",HLIEN2,0))
Begin DoDot:4
+16 SET HLMSGP=$PIECE(^HL(771,HLIEN,"MSG",HLIEN2,0),"^")
+17 SET HLMSGPN=0
+18 IF HLMSGP>0
SET HLMSGPN=$$PMSG^HLP145(HLMSGP)
+19 ; redirect pointer for SUB-field #771.06,.01 of field #771,6
+20 IF HLMSGPN
Begin DoDot:5
+21 SET DIE="^HL(771,"_HLIEN_",""MSG"","
+22 SET DA(1)=HLIEN
+23 SET DA=HLIEN2
+24 SET DR=".01////"_HLMSGPN
+25 DO ^DIE
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+26 IF $DATA(^HL(771,HLIEN,"SEG"))
Begin DoDot:2
+27 SET HLIEN2=0
+28 FOR
SET HLIEN2=$ORDER(^HL(771,HLIEN,"SEG",HLIEN2))
if 'HLIEN2
QUIT
Begin DoDot:3
+29 IF $DATA(^HL(771,HLIEN,"SEG",HLIEN2,0))
Begin DoDot:4
+30 SET HLSEGP=$PIECE(^HL(771,HLIEN,"SEG",HLIEN2,0),"^")
+31 SET HLSEGPN=0
+32 IF HLSEGP>0
SET HLSEGPN=$$PSEG^HLP145(HLSEGP)
+33 ; redirect pointer for SUB-field #771.05,.01 of field #771,5
+34 IF HLSEGPN
Begin DoDot:5
+35 SET DIE="^HL(771,"_HLIEN_",""SEG"","
+36 SET DA(1)=HLIEN
+37 SET DA=HLIEN2
+38 SET DR=".01////"_HLSEGPN
+39 DO ^DIE
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+40 QUIT
+41 ;
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 ;
PSEG(HLIEN) ; resolve segment pointer
+1 ;
+2 ; HLSEG: original segment type name
+3 ; HLSEG2: the segment type name in the duplicate segment array
+4 ; HLSUB: the 2nd subscript of the duplicate segment array
+5 ; HLIEN: the IEN for the original segment type
+6 ; HLNIEN: the IEN for the first segment type found in the file
+7 ; output: HLNIEN - return 0 if no duplicate,
+8 ; return the new pointer HLNIEN if duplicate
+9 ;
+10 NEW HLSEG,HLSEG2,HLSUB,HLDONE,HLNIEN
+11 if '$DATA(^HL(771.3,HLIEN,0))
QUIT 0
+12 SET HLNIEN=0
+13 SET HLSEG=$PIECE(^HL(771.3,HLIEN,0),"^")
+14 IF HLSEG'=""
Begin DoDot:1
+15 SET HLSEG2=""
+16 FOR
SET HLSEG2=$ORDER(HLSEGARY(HLSEG2))
if (HLSEG2="")
QUIT
Begin DoDot:2
+17 IF HLSEG2=HLSEG
Begin DoDot:3
+18 SET HLSUB=0
SET HLDONE=0
SET HLNIEN=0
+19 FOR
SET HLSUB=$ORDER(HLSEGARY(HLSEG,HLSUB))
if ('HLSUB)
QUIT
Begin DoDot:4
+20 IF HLSEGARY(HLSEG,HLSUB)=HLIEN
SET HLDONE=1
Begin DoDot:5
+21 IF HLSUB>1
SET HLNIEN=HLSEGARY(HLSEG,1)
End DoDot:5
End DoDot:4
if HLDONE
QUIT
End DoDot:3
End DoDot:2
if (HLSEG2=HLSEG)
QUIT
End DoDot:1
+22 QUIT HLNIEN
+23 ;
HLP145B ; Part III of Pre-install and Post-install
+1 ; Entries: EVN, MSG, SEG, DELETE, and IDOFF
+2 ;
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
SEG ; find duplicate entries in file #771.3(Segment Type)
+1 NEW HLSEG,HLIEN,SUB
+2 SET HLSEG=""
+3 FOR
SET HLSEG=$ORDER(^HL(771.3,"B",HLSEG))
if HLSEG=""
QUIT
Begin DoDot:1
+4 SET HLIEN=0
SET SUB=0
+5 FOR
SET HLIEN=$ORDER(^HL(771.3,"B",HLSEG,HLIEN))
if 'HLIEN
QUIT
Begin DoDot:2
+6 IF $DATA(^HL(771.3,HLIEN,0))
IF $PIECE(^HL(771.3,HLIEN,0),"^")=HLSEG
Begin DoDot:3
+7 SET SUB=SUB+1
+8 SET HLSEGARY(HLSEG,SUB)=HLIEN
End DoDot:3
End DoDot:2
+9 IF SUB=1
KILL HLSEGARY(HLSEG)
End DoDot:1
+10 QUIT
DELETE ; delete duplicate entries in file #779.001, #771.2 and #771.3
+1 NEW HLEVN,HLMSG,HLSEG,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 ; delete duplicate entries in file #771.3
+19 SET HLSEG=""
SET DIK="^HL(771.3,"
+20 FOR
SET HLSEG=$ORDER(HLSEGARY(HLSEG))
if HLSEG=""
QUIT
Begin DoDot:1
+21 SET HLSUB=1
+22 FOR
SET HLSUB=$ORDER(HLSEGARY(HLSEG,HLSUB))
if 'HLSUB
QUIT
Begin DoDot:2
+23 SET DA=HLSEGARY(HLSEG,HLSUB)
+24 DO ^DIK
End DoDot:2
End DoDot:1
+25 ;
+26 QUIT
IDOFF ; disable identifier for file #779.001, #771.2, #771.3,
+1 ; and 779.005
+2 KILL ^DD(779.001,0,"ID")
+3 KILL ^DD(771.2,0,"ID")
+4 KILL ^DD(771.3,0,"ID")
+5 KILL ^DD(779.005,0,"ID")
+6 QUIT
POST ;enable identifier for file #779.001, #771.2, and #771.3
+1 ; and 779.005
+2 SET ^DD(779.001,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
+3 SET ^DD(771.2,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
+4 SET ^DD(771.3,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
+5 SET ^DD(779.005,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
+6 QUIT
