HLPA108A ;CIOFO-SF/RJH - HL7 PATCH 108 PRE&POST-INIT ;02/25/04 16:19
;;1.6;HEALTH LEVEL SEVEN;**108**;Oct 13, 1995
;
; Pre-install II:
; Entries: PTR771, PEVE, PMSG, and PMSG, are called from HLPAT108
Q
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^HLPA108A(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^HLPA108A(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
;
HLPA108A ;CIOFO-SF/RJH - HL7 PATCH 108 PRE&POST-INIT ;02/25/04 16:19
+1 ;;1.6;HEALTH LEVEL SEVEN;**108**;Oct 13, 1995
+2 ;
+3 ; Pre-install II:
+4 ; Entries: PTR771, PEVE, PMSG, and PMSG, are called from HLPAT108
+5 QUIT
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^HLPA108A(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^HLPA108A(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 ;
