Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLPAT54

HLPAT54.m

Go to the documentation of this file.
  1. 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
  1. ;;1.6;HEALTH LEVEL SEVEN;**54**;Oct 13, 1995
  1. ;
  1. ; Pre-install:
  1. ; 1. change event entries from "X01" to "P07", from "B01" to "PC1",
  1. ; and from "G01" to "PC6"
  1. ; 2. change message entries from "ERQ" to "RQQ", from "ROD" to
  1. ; "RQP", and from "VTQ" to "VQQ"
  1. ; 3. find the duplicate entries in file #779.001 and #771.2
  1. ; 4. resolve the pointers for fields: #101,770.4(event type),
  1. ; #101,770.3(message type), #101,770.11(message type).
  1. ; 5. resolve the pointers for fields: #773,16(event type),
  1. ; #773,15(message type).
  1. ; 6. resolve the pointer for sub-field: #771.06,.01(message type)
  1. ; of field #771,6.
  1. ; 7. delete duplicates in files #779.001 and #771.2
  1. ; 8. disable identifiers for files #779.001 and #771.2
  1. ; before bringing the data
  1. ;
  1. ; Post-install:
  1. ; enable identifiers for file #779.001 and #771.2 after installation
  1. ;
  1. Q
  1. PRE ;
  1. N HLTEMP
  1. S HLTEMP=$$NEWCP^XPDUTL("PRE1","PRE1^HLPAT54")
  1. S HLTEMP=$$NEWCP^XPDUTL("PRE2","PRE2^HLPAT54")
  1. S HLTEMP=$$NEWCP^XPDUTL("PRE3","PRE3^HLPAT54")
  1. S HLTEMP=$$NEWCP^XPDUTL("PRE4","PRE4^HLPAT54")
  1. S HLTEMP=$$NEWCP^XPDUTL("PRE5","PRE5^HLPAT54")
  1. S HLTEMP=$$NEWCP^XPDUTL("PRE6","PRE6^HLPAT54")
  1. Q
  1. PRE1 ;
  1. D CHANGE1
  1. D CHANGE2
  1. Q
  1. PRE2 ;
  1. N HLEVNARY,HLMSGARY
  1. D EVN
  1. D MSG
  1. I $D(^XTMP("HLPAT54")) K ^XTMP("HLPAT54")
  1. I $D(HLEVNARY) M ^XTMP("HLPAT54","EVN")=HLEVNARY
  1. I $D(HLMSGARY) M ^XTMP("HLPAT54","MSG")=HLMSGARY
  1. I $D(HLEVNARY)!$D(HLMSGARY) S ^XTMP("HLPAT54",0)=$$FMADD^XLFDT(DT,7)_U_DT
  1. Q
  1. PRE3 ;
  1. Q:'$D(^XTMP("HLPAT54","EVN"))&'$D(^XTMP("HLPAT54","MSG"))
  1. I $D(^XTMP("HLPAT54","EVN")) M HLEVNARY=^XTMP("HLPAT54","EVN")
  1. I $D(^XTMP("HLPAT54","MSG")) M HLMSGARY=^XTMP("HLPAT54","MSG")
  1. D PTR101
  1. Q
  1. PRE4 ;
  1. Q:'$D(^XTMP("HLPAT54","EVN"))&'$D(^XTMP("HLPAT54","MSG"))
  1. I $D(^XTMP("HLPAT54","EVN")) M HLEVNARY=^XTMP("HLPAT54","EVN")
  1. I $D(^XTMP("HLPAT54","MSG")) M HLMSGARY=^XTMP("HLPAT54","MSG")
  1. D PTR773
  1. Q
  1. PRE5 ;
  1. Q:'$D(^XTMP("HLPAT54","EVN"))&'$D(^XTMP("HLPAT54","MSG"))
  1. I $D(^XTMP("HLPAT54","EVN")) M HLEVNARY=^XTMP("HLPAT54","EVN")
  1. I $D(^XTMP("HLPAT54","MSG")) M HLMSGARY=^XTMP("HLPAT54","MSG")
  1. D PTR771
  1. D DELETE
  1. Q
  1. PRE6 ;
  1. D IDOFF
  1. Q
  1. CHANGE1 ; change event entries from "X01" to "P07", from "B01" to "PC1",
  1. ; and from "G01" to "PC6"
  1. N HLIEN,DIE,DA,DR
  1. S DIE="^HL(779.001,"
  1. S HLIEN=0
  1. F S HLIEN=$O(^HL(779.001,"B","X01",HLIEN)) Q:'HLIEN D
  1. . I $D(^HL(779.001,HLIEN)) D
  1. .. S DA=HLIEN
  1. .. S DR=".01///P07"
  1. .. D ^DIE
  1. S HLIEN=0
  1. F S HLIEN=$O(^HL(779.001,"B","B01",HLIEN)) Q:'HLIEN D
  1. . I $D(^HL(779.001,HLIEN)) D
  1. .. S DA=HLIEN
  1. .. S DR=".01///PC1"
  1. .. D ^DIE
  1. S HLIEN=0
  1. F S HLIEN=$O(^HL(779.001,"B","G01",HLIEN)) Q:'HLIEN D
  1. . I $D(^HL(779.001,HLIEN)) D
  1. .. S DA=HLIEN
  1. .. S DR=".01///PC6"
  1. .. D ^DIE
  1. Q
  1. CHANGE2 ; change message entries from "ERQ" to "RQQ", from "ROD" to "RQP",
  1. ; and from "VTQ" to "VQQ"
  1. N HLIEN,DIE,DA,DR
  1. S DIE="^HL(771.2,"
  1. S HLIEN=0
  1. F S HLIEN=$O(^HL(771.2,"B","ERQ",HLIEN)) Q:'HLIEN D
  1. . I $D(^HL(771.2,HLIEN)) D
  1. .. S DA=HLIEN
  1. .. S DR=".01///RQQ"
  1. .. D ^DIE
  1. S HLIEN=0
  1. F S HLIEN=$O(^HL(771.2,"B","ROD",HLIEN)) Q:'HLIEN D
  1. . I $D(^HL(771.2,HLIEN)) D
  1. .. S DA=HLIEN
  1. .. S DR=".01///RQP"
  1. .. D ^DIE
  1. S HLIEN=0
  1. F S HLIEN=$O(^HL(771.2,"B","VTQ",HLIEN)) Q:'HLIEN D
  1. . I $D(^HL(771.2,HLIEN)) D
  1. .. S DA=HLIEN
  1. .. S DR=".01///VQQ"
  1. .. D ^DIE
  1. Q
  1. EVN ; find duplicate entries in file #779.001(Event Type)
  1. N HLEVN,HLIEN,SUB
  1. S HLEVN=""
  1. F S HLEVN=$O(^HL(779.001,"B",HLEVN)) Q:HLEVN="" D
  1. . S HLIEN=0,SUB=0
  1. . F S HLIEN=$O(^HL(779.001,"B",HLEVN,HLIEN)) Q:'HLIEN D
  1. .. I $D(^HL(779.001,HLIEN,0)),$P(^HL(779.001,HLIEN,0),"^")=HLEVN D
  1. ... S SUB=SUB+1
  1. ... S HLEVNARY(HLEVN,SUB)=HLIEN
  1. . I SUB=1 K HLEVNARY(HLEVN)
  1. Q
  1. MSG ; find duplicate entries in file #771.2(Message Type)
  1. N HLMSG,HLIEN,SUB
  1. S HLMSG=""
  1. F S HLMSG=$O(^HL(771.2,"B",HLMSG)) Q:HLMSG="" D
  1. . S HLIEN=0,SUB=0
  1. . F S HLIEN=$O(^HL(771.2,"B",HLMSG,HLIEN)) Q:'HLIEN D
  1. .. I $D(^HL(771.2,HLIEN,0)),$P(^HL(771.2,HLIEN,0),"^")=HLMSG D
  1. ... S SUB=SUB+1
  1. ... S HLMSGARY(HLMSG,SUB)=HLIEN
  1. . I SUB=1 K HLMSGARY(HLMSG)
  1. Q
  1. PTR101 ; resolve pointers for file #101
  1. ;
  1. ; HLEVNP: pointer to file #779.001
  1. ; HLMSGP: pointer to file #771.2
  1. ; HLEVNPN: redirected new pointer to file #779.001
  1. ; HLMSGPN: redirected new pointer to file #771.2
  1. ;
  1. N HLIEN,HLEVNP,HLMSGP,HLEVNPN,HLMSGPN,DIE,DA,DR
  1. S HLIEN=0
  1. S DIE="^ORD(101,"
  1. F S HLIEN=$O(^ORD(101,HLIEN)) Q:'HLIEN D
  1. . I $D(^ORD(101,HLIEN,770)) D
  1. .. S HLEVNP=$P(^ORD(101,HLIEN,770),"^",4)
  1. .. S HLEVNPN=0
  1. .. I HLEVNP>0 S HLEVNPN=$$PEVN(HLEVNP)
  1. .. ; redirect pointer for field #101,770.4
  1. .. I HLEVNPN D
  1. ... S DA=HLIEN
  1. ... S DR="770.4////"_HLEVNPN
  1. ... D ^DIE
  1. .. ;
  1. .. S HLMSGP=$P(^ORD(101,HLIEN,770),"^",3)
  1. .. S HLMSGPN=0
  1. .. I HLMSGP>0 S HLMSGPN=$$PMSG(HLMSGP)
  1. .. ; redirect pointer for filed #101,770.3
  1. .. I HLMSGPN D
  1. ... S DA=HLIEN
  1. ... S DR="770.3////"_HLMSGPN
  1. ... D ^DIE
  1. .. ;
  1. .. S HLMSGP=$P(^ORD(101,HLIEN,770),"^",11)
  1. .. S HLMSGPN=0
  1. .. I HLMSGP>0 S HLMSGPN=$$PMSG(HLMSGP)
  1. .. ; redirect pointer for field #101,770.11
  1. .. I HLMSGPN D
  1. ... S DA=HLIEN
  1. ... S DR="770.11////"_HLMSGPN
  1. ... D ^DIE
  1. Q
  1. ;
  1. PEVN(HLIEN) ; resolve event pointer
  1. ;
  1. ; HLEVN: original event type name
  1. ; HLEVN2: the event type name in the duplicate event array
  1. ; HLSUB: the 2nd subscript of the duplicate event array
  1. ; HLIEN: the IEN for the original event type
  1. ; HLNIEN: the IEN for the first event type found in the file
  1. ; output: HLNIEN - return 0 if no duplicate,
  1. ; return the new pointer HLNIEN if duplicate
  1. ;
  1. N HLEVN,HLEVN2,HLSUB,HLDONE,HLNIEN
  1. Q:'$D(^HL(779.001,HLIEN,0)) 0
  1. S HLNIEN=0
  1. S HLEVN=$P(^HL(779.001,HLIEN,0),"^")
  1. I HLEVN'="" D
  1. . S HLEVN2=""
  1. . F S HLEVN2=$O(HLEVNARY(HLEVN2)) Q:(HLEVN2="") D Q:(HLEVN2=HLEVN)
  1. .. I HLEVN2=HLEVN D
  1. ... S HLSUB=0,HLDONE=0,HLNIEN=0
  1. ... F S HLSUB=$O(HLEVNARY(HLEVN,HLSUB)) Q:('HLSUB) D Q:HLDONE
  1. .... I HLEVNARY(HLEVN,HLSUB)=HLIEN S HLDONE=1 D
  1. ..... I HLSUB>1 S HLNIEN=HLEVNARY(HLEVN,1)
  1. Q HLNIEN
  1. ;
  1. PMSG(HLIEN) ; resolve message pointer
  1. ;
  1. ; HLMSG: original message type name
  1. ; HLMSG2: the message type name in the duplicate message array
  1. ; HLSUB: the 2nd subscript of the duplicate message array
  1. ; HLIEN: the IEN for the original message type
  1. ; HLNIEN: the IEN for the first message type found in the file
  1. ; output: HLNIEN - return 0 if no duplicate,
  1. ; return the new pointer HLNIEN if duplicate
  1. ;
  1. N HLMSG,HLMSG2,HLSUB,HLDONE,HLNIEN
  1. Q:'$D(^HL(771.2,HLIEN,0)) 0
  1. S HLNIEN=0
  1. S HLMSG=$P(^HL(771.2,HLIEN,0),"^")
  1. I HLMSG'="" D
  1. . S HLMSG2=""
  1. . F S HLMSG2=$O(HLMSGARY(HLMSG2)) Q:(HLMSG2="") D Q:(HLMSG2=HLMSG)
  1. .. I HLMSG2=HLMSG D
  1. ... S HLSUB=0,HLDONE=0,HLNIEN=0
  1. ... F S HLSUB=$O(HLMSGARY(HLMSG,HLSUB)) Q:('HLSUB) D Q:HLDONE
  1. .... I HLMSGARY(HLMSG,HLSUB)=HLIEN S HLDONE=1 D
  1. ..... I HLSUB>1 S HLNIEN=HLMSGARY(HLMSG,1)
  1. Q HLNIEN
  1. ;
  1. PTR773 ; resolve pointers for file #773
  1. ;
  1. ; HLEVNP: pointer to file #779.001
  1. ; HLMSGP: pointer to file #771.2
  1. ; HLEVNPN: redirected new pointer to file #779.001
  1. ; HLMSGPN: redirected new pointer to file #771.2
  1. ;
  1. N HLIEN,HLEVNP,HLMSGP,HLEVNPN,HLMSGPN,DIE,DA,DR
  1. S HLIEN=0
  1. S DIE="^HLMA("
  1. F S HLIEN=$O(^HLMA(HLIEN)) Q:'HLIEN D
  1. . I $D(^HLMA(HLIEN,0)) D
  1. .. S HLEVNP=$P(^HLMA(HLIEN,0),"^",14)
  1. .. S HLEVNPN=0
  1. .. I HLEVNP>0 S HLEVNPN=$$PEVN(HLEVNP)
  1. .. ; redirect pointer for field #773,16
  1. .. I HLEVNPN D
  1. ... S DA=HLIEN
  1. ... S DR="16////"_HLEVNPN
  1. ... D ^DIE
  1. .. ;
  1. .. S HLMSGP=$P(^HLMA(HLIEN,0),"^",13)
  1. .. S HLMSGPN=0
  1. .. I HLMSGP>0 S HLMSGPN=$$PMSG(HLMSGP)
  1. .. ; redirect pointer for filed #773,15
  1. .. I HLMSGPN D
  1. ... S DA=HLIEN
  1. ... S DR="15////"_HLMSGPN
  1. ... D ^DIE
  1. Q
  1. ;
  1. PTR771 ; resolve pointers for sub-field #771.06,.01 of field #771,6
  1. ;
  1. ; HLMSGP: pointer to file #771.2
  1. ; HLMSGPN: redirected new pointer to file #771.2
  1. ;
  1. N HLIEN,HLIEN2,HLMSGP,HLMSGPN,DIE,DA,DR
  1. S HLIEN=0
  1. F S HLIEN=$O(^HL(771,HLIEN)) Q:'HLIEN D
  1. . I $D(^HL(771,HLIEN,"MSG")) D
  1. .. S HLIEN2=0
  1. .. F S HLIEN2=$O(^HL(771,HLIEN,"MSG",HLIEN2)) Q:'HLIEN2 D
  1. ... I $D(^HL(771,HLIEN,"MSG",HLIEN2,0)) D
  1. .... S HLMSGP=$P(^HL(771,HLIEN,"MSG",HLIEN2,0),"^")
  1. .... S HLMSGPN=0
  1. .... I HLMSGP>0 S HLMSGPN=$$PMSG(HLMSGP)
  1. .... ; redirect pointer for SUB-field #771.06,.01 of field #771,6
  1. .... I HLMSGPN D
  1. ..... S DIE="^HL(771,"_HLIEN_",""MSG"","
  1. ..... S DA(1)=HLIEN
  1. ..... S DA=HLIEN2
  1. ..... S DR=".01////"_HLMSGPN
  1. ..... D ^DIE
  1. Q
  1. ;
  1. DELETE ; delete duplicate entries in file #779.001 and #771.2
  1. N HLEVN,HLMSG,HLSUB,DIK,DA
  1. ; delete duplicate entries in file #779.001
  1. S HLEVN="",DIK="^HL(779.001,"
  1. F S HLEVN=$O(HLEVNARY(HLEVN)) Q:HLEVN="" D
  1. . S HLSUB=1
  1. . F S HLSUB=$O(HLEVNARY(HLEVN,HLSUB)) Q:'HLSUB D
  1. .. S DA=HLEVNARY(HLEVN,HLSUB)
  1. .. D ^DIK
  1. ;
  1. ; delete duplicate entries in file #771.2
  1. S HLMSG="",DIK="^HL(771.2,"
  1. F S HLMSG=$O(HLMSGARY(HLMSG)) Q:HLMSG="" D
  1. . S HLSUB=1
  1. . F S HLSUB=$O(HLMSGARY(HLMSG,HLSUB)) Q:'HLSUB D
  1. .. S DA=HLMSGARY(HLMSG,HLSUB)
  1. .. D ^DIK
  1. ;
  1. Q
  1. IDOFF ; disable identifier for file #779.001 and #771.2
  1. K ^DD(779.001,0,"ID")
  1. K ^DD(771.2,0,"ID")
  1. Q
  1. POST ;enable identifier for file #779.001 and #771.2
  1. S ^DD(779.001,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
  1. S ^DD(771.2,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
  1. Q