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

HLP145.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Pre-install:
  1. ; 1. find the duplicate entries in file #779.001, #771.2 and #771.3
  1. ; 2. resolve the pointers for fields: #101,770.4(event type),
  1. ; #101,770.3(message type), #101,770.11(message type).
  1. ; 3. resolve the pointers for fields: #773,16(event type),
  1. ; #773,15(message type).
  1. ; 4. resolve the pointer for sub-field: #771.06,.01(message type)
  1. ; of field #771,6, and #771.05,.01(segment type) of field #771,5.
  1. ; 5. delete duplicates in files #779.001, #771.2 and #771.3.
  1. ; and disable the Identifiers for files: #779.001, #771.2, #771.3
  1. ; and #779.005
  1. Q
  1. PRE ;
  1. N HLTEMP
  1. S HLTEMP=$$NEWCP^XPDUTL("PRE1","PRE1^HLP145")
  1. S HLTEMP=$$NEWCP^XPDUTL("PRE2","PRE2^HLP145")
  1. S HLTEMP=$$NEWCP^XPDUTL("PRE3","PRE3^HLP145")
  1. S HLTEMP=$$NEWCP^XPDUTL("PRE4","PRE4^HLP145")
  1. S HLTEMP=$$NEWCP^XPDUTL("PRE5","PRE5^HLP145")
  1. Q
  1. PRE1 ;
  1. N HLEVNARY,HLMSGARY,HLSEGARY
  1. D EVN^HLP145
  1. D MSG^HLP145
  1. D SEG^HLP145
  1. I $D(^XTMP("HLP145")) K ^XTMP("HLP145")
  1. I $D(HLEVNARY) M ^XTMP("HLP145","EVN")=HLEVNARY
  1. I $D(HLMSGARY) M ^XTMP("HLP145","MSG")=HLMSGARY
  1. I $D(HLSEGARY) M ^XTMP("HLP145","SEG")=HLSEGARY
  1. I $D(HLEVNARY)!$D(HLMSGARY)!$D(HLSEGARY) S ^XTMP("HLP145",0)=$$FMADD^XLFDT(DT,90)_U_DT
  1. Q
  1. PRE2 ;
  1. Q:'$D(^XTMP("HLP145","EVN"))&'$D(^XTMP("HLP145","MSG"))&'$D(^XTMP("HLP145","SEG"))
  1. I $D(^XTMP("HLP145","EVN")) M HLEVNARY=^XTMP("HLP145","EVN")
  1. I $D(^XTMP("HLP145","MSG")) M HLMSGARY=^XTMP("HLP145","MSG")
  1. D PTR101
  1. Q
  1. PRE3 ;
  1. Q:'$D(^XTMP("HLP145","EVN"))&'$D(^XTMP("HLP145","MSG"))&'$D(^XTMP("HLP145","SEG"))
  1. I $D(^XTMP("HLP145","EVN")) M HLEVNARY=^XTMP("HLP145","EVN")
  1. I $D(^XTMP("HLP145","MSG")) M HLMSGARY=^XTMP("HLP145","MSG")
  1. D PTR773
  1. Q
  1. PRE4 ;
  1. Q:'$D(^XTMP("HLP145","EVN"))&'$D(^XTMP("HLP145","MSG"))&'$D(^XTMP("HLP145","SEG"))
  1. I $D(^XTMP("HLP145","EVN")) M HLEVNARY=^XTMP("HLP145","EVN")
  1. I $D(^XTMP("HLP145","MSG")) M HLMSGARY=^XTMP("HLP145","MSG")
  1. I $D(^XTMP("HLP145","SEG")) M HLSEGARY=^XTMP("HLP145","SEG")
  1. D PTR771^HLP145
  1. Q
  1. PRE5 ;
  1. D IDOFF^HLP145
  1. Q:'$D(^XTMP("HLP145","EVN"))&'$D(^XTMP("HLP145","MSG"))&'$D(^XTMP("HLP145","SEG"))
  1. I $D(^XTMP("HLP145","EVN")) M HLEVNARY=^XTMP("HLP145","EVN")
  1. I $D(^XTMP("HLP145","MSG")) M HLMSGARY=^XTMP("HLP145","MSG")
  1. I $D(^XTMP("HLP145","SEG")) M HLSEGARY=^XTMP("HLP145","SEG")
  1. D DELETE^HLP145
  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^HLP145(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^HLP145(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^HLP145(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. 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^HLP145(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^HLP145(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. HLP145A ; Pre-install II
  1. ; Entries: PTR771, PEVE, PMSG, and PMSG
  1. ;
  1. PTR771 ; resolve pointers for sub-field #771.06,.01 of field #771,6
  1. ; and #771.05,.01 of field #771,5
  1. ;
  1. ; HLMSGP: pointer to file #771.2
  1. ; HLMSGPN: redirected new pointer to file #771.2
  1. ; HLSEGP: pointer to file #771.3
  1. ; HLSEGPN: redirected new pointer to file #771.3
  1. ;
  1. N HLIEN,HLIEN2,HLMSGP,HLMSGPN,DIE,DA,DR
  1. N HLSEGP,HLSEGPN
  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^HLP145(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. . I $D(^HL(771,HLIEN,"SEG")) D
  1. .. S HLIEN2=0
  1. .. F S HLIEN2=$O(^HL(771,HLIEN,"SEG",HLIEN2)) Q:'HLIEN2 D
  1. ... I $D(^HL(771,HLIEN,"SEG",HLIEN2,0)) D
  1. .... S HLSEGP=$P(^HL(771,HLIEN,"SEG",HLIEN2,0),"^")
  1. .... S HLSEGPN=0
  1. .... I HLSEGP>0 S HLSEGPN=$$PSEG^HLP145(HLSEGP)
  1. .... ; redirect pointer for SUB-field #771.05,.01 of field #771,5
  1. .... I HLSEGPN D
  1. ..... S DIE="^HL(771,"_HLIEN_",""SEG"","
  1. ..... S DA(1)=HLIEN
  1. ..... S DA=HLIEN2
  1. ..... S DR=".01////"_HLSEGPN
  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. PSEG(HLIEN) ; resolve segment pointer
  1. ;
  1. ; HLSEG: original segment type name
  1. ; HLSEG2: the segment type name in the duplicate segment array
  1. ; HLSUB: the 2nd subscript of the duplicate segment array
  1. ; HLIEN: the IEN for the original segment type
  1. ; HLNIEN: the IEN for the first segment type found in the file
  1. ; output: HLNIEN - return 0 if no duplicate,
  1. ; return the new pointer HLNIEN if duplicate
  1. ;
  1. N HLSEG,HLSEG2,HLSUB,HLDONE,HLNIEN
  1. Q:'$D(^HL(771.3,HLIEN,0)) 0
  1. S HLNIEN=0
  1. S HLSEG=$P(^HL(771.3,HLIEN,0),"^")
  1. I HLSEG'="" D
  1. . S HLSEG2=""
  1. . F S HLSEG2=$O(HLSEGARY(HLSEG2)) Q:(HLSEG2="") D Q:(HLSEG2=HLSEG)
  1. .. I HLSEG2=HLSEG D
  1. ... S HLSUB=0,HLDONE=0,HLNIEN=0
  1. ... F S HLSUB=$O(HLSEGARY(HLSEG,HLSUB)) Q:('HLSUB) D Q:HLDONE
  1. .... I HLSEGARY(HLSEG,HLSUB)=HLIEN S HLDONE=1 D
  1. ..... I HLSUB>1 S HLNIEN=HLSEGARY(HLSEG,1)
  1. Q HLNIEN
  1. ;
  1. HLP145B ; Part III of Pre-install and Post-install
  1. ; Entries: EVN, MSG, SEG, DELETE, and IDOFF
  1. ;
  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. SEG ; find duplicate entries in file #771.3(Segment Type)
  1. N HLSEG,HLIEN,SUB
  1. S HLSEG=""
  1. F S HLSEG=$O(^HL(771.3,"B",HLSEG)) Q:HLSEG="" D
  1. . S HLIEN=0,SUB=0
  1. . F S HLIEN=$O(^HL(771.3,"B",HLSEG,HLIEN)) Q:'HLIEN D
  1. .. I $D(^HL(771.3,HLIEN,0)),$P(^HL(771.3,HLIEN,0),"^")=HLSEG D
  1. ... S SUB=SUB+1
  1. ... S HLSEGARY(HLSEG,SUB)=HLIEN
  1. . I SUB=1 K HLSEGARY(HLSEG)
  1. Q
  1. DELETE ; delete duplicate entries in file #779.001, #771.2 and #771.3
  1. N HLEVN,HLMSG,HLSEG,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. ; delete duplicate entries in file #771.3
  1. S HLSEG="",DIK="^HL(771.3,"
  1. F S HLSEG=$O(HLSEGARY(HLSEG)) Q:HLSEG="" D
  1. . S HLSUB=1
  1. . F S HLSUB=$O(HLSEGARY(HLSEG,HLSUB)) Q:'HLSUB D
  1. .. S DA=HLSEGARY(HLSEG,HLSUB)
  1. .. D ^DIK
  1. ;
  1. Q
  1. IDOFF ; disable identifier for file #779.001, #771.2, #771.3,
  1. ; and 779.005
  1. K ^DD(779.001,0,"ID")
  1. K ^DD(771.2,0,"ID")
  1. K ^DD(771.3,0,"ID")
  1. K ^DD(779.005,0,"ID")
  1. Q
  1. POST ;enable identifier for file #779.001, #771.2, and #771.3
  1. ; and 779.005
  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. S ^DD(771.3,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
  1. S ^DD(779.005,0,"ID",2)="W "_""""_" "_""""_",$P(^(0),U,2)"
  1. Q