- 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 ;
