- HLPAT54 ;CIOFO-SF/RJH - HL7 PATCH 54 PRE&POST-INIT ;10/26/99 12:46 [ 04/02/2003 8:38 AM ]
- ;;1.6;HEALTH LEVEL SEVEN;**1004**;APR 1, 2003
- ;;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
- HLPAT54 ;CIOFO-SF/RJH - HL7 PATCH 54 PRE&POST-INIT ;10/26/99 12:46 [ 04/02/2003 8:38 AM ]
- +1 ;;1.6;HEALTH LEVEL SEVEN;**1004**;APR 1, 2003
- +2 ;;1.6;HEALTH LEVEL SEVEN;**54**;Oct 13, 1995
- +3 ;
- +4 ; Pre-install:
- +5 ; 1. change event entries from "X01" to "P07", from "B01" to "PC1",
- +6 ; and from "G01" to "PC6"
- +7 ; 2. change message entries from "ERQ" to "RQQ", from "ROD" to
- +8 ; "RQP", and from "VTQ" to "VQQ"
- +9 ; 3. find the duplicate entries in file #779.001 and #771.2
- +10 ; 4. resolve the pointers for fields: #101,770.4(event type),
- +11 ; #101,770.3(message type), #101,770.11(message type).
- +12 ; 5. resolve the pointers for fields: #773,16(event type),
- +13 ; #773,15(message type).
- +14 ; 6. resolve the pointer for sub-field: #771.06,.01(message type)
- +15 ; of field #771,6.
- +16 ; 7. delete duplicates in files #779.001 and #771.2
- +17 ; 8. disable identifiers for files #779.001 and #771.2
- +18 ; before bringing the data
- +19 ;
- +20 ; Post-install:
- +21 ; enable identifiers for file #779.001 and #771.2 after installation
- +22 ;
- +23 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