- 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 Feb 18, 2025@23:25:53 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