BHLFO.m

BHLFO ; cmi/flag/maw - BHL Get Inbound Filing Order ;

 ;;3.01;BHL IHS Interfaces with GIS;**12**;JUL 01, 2001

 ;

 ;

 ;this routine will look at the message and get the inbound filing

 ;order

 ;

MAIN ;-- this is the main routine driver

 D FO,PRS

 Q

 ;

FO ;-- get the inbound filing order

 S BHLCNT=0

 S BHLMDA=0 F  S BHLMDA=$O(^INTHL7M(BHLMIEN,1,"AS",BHLMDA)) Q:'BHLMDA  D

 . S BHLMFN=$O(^INTHL7M(BHLMIEN,1,"AS",BHLMDA,0))

 . S BHLSEG=$P($G(^INTHL7S(+$P($G(^INTHL7M(BHLMIEN,1,BHLMFN,0)),U),0)),U,2)

 . S BHLCNT=BHLCNT+1

 . S BHLFO(BHLCNT)=BHLSEG

 Q

 ;

PRS ;-- reparse INV for filer

 S BHLINV=0 F  S BHLINV=$O(INV(BHLINV)) Q:BHLINV=""  D

 . S BHLSEG=$E(BHLINV,1,3)

 . S BHLSEQ=+$E(BHLINV,4,6)

 . S BHLML=$O(INV(BHLINV,0))

 . I BHLML="" S BHL(BHLSEG,1,BHLSEQ)=$G(INV(BHLINV)) Q

 . S BHLML=0 F  S BHLML=$O(INV(BHLINV,BHLML)) Q:'BHLML  D

 .. I $O(INV(BHLINV,BHLML,0)) D PAR Q

 .. S BHL(BHLSEG,BHLML,BHLSEQ)=$G(INV(BHLINV,BHLML)) Q

 Q

 ;

PAR ;-- break down array into lower level

 S BHLPR=0 F  S BHLPR=$O(INV(BHLINV,BHLML,BHLPR)) Q:'BHLPR  D

 . I $O(INV(BHLINV,BHLML,BHLPR,0)) D SUBPAR Q

 . S BHL(BHLSEG,BHLML,BHLPR,BHLSEQ)=$G(INV(BHLINV,BHLML,BHLPR))

 Q

 ;

SUBPAR ;-- break down the relationship to the next level

 S BHLSPR=0 F  S BHLSPR=$O(INV(BHLINV,BHLML,BHLPR,BHLSPR)) Q:'BHLSPR  D

 . S BHL(BHLSEG,BHLML,BHLPR,BHLSPR,BHLSEQ)=$G(INV(BHLINV,BHLML,BHLPR,BHLSPR))

 Q

 ;

BHLFO     ; cmi/flag/maw - BHL Get Inbound Filing Order ;

 +1       ;;3.01;BHL IHS Interfaces with GIS;**12**;JUL 01, 2001

 +2       ;

 +3       ;

 +4       ;this routine will look at the message and get the inbound filing

 +5       ;order

 +6       ;

MAIN      ;-- this is the main routine driver

 +1        DO FO

           DO PRS

 +2        QUIT 

 +3       ;

FO        ;-- get the inbound filing order

 +1        SET BHLCNT=0

 +2        SET BHLMDA=0

           FOR 

               SET BHLMDA=$ORDER(^INTHL7M(BHLMIEN,1,"AS",BHLMDA))

               IF 'BHLMDA

                   QUIT 

               Begin DoDot:1

 +3                SET BHLMFN=$ORDER(^INTHL7M(BHLMIEN,1,"AS",BHLMDA,0))

 +4                SET BHLSEG=$PIECE($GET(^INTHL7S(+$PIECE($GET(^INTHL7M(BHLMIEN,1,BHLMFN,0)),U),0)),U,2)

 +5                SET BHLCNT=BHLCNT+1

 +6                SET BHLFO(BHLCNT)=BHLSEG

               End DoDot:1

 +7        QUIT 

 +8       ;

PRS       ;-- reparse INV for filer

 +1        SET BHLINV=0

           FOR 

               SET BHLINV=$ORDER(INV(BHLINV))

               IF BHLINV=""

                   QUIT 

               Begin DoDot:1

 +2                SET BHLSEG=$EXTRACT(BHLINV,1,3)

 +3                SET BHLSEQ=+$EXTRACT(BHLINV,4,6)

 +4                SET BHLML=$ORDER(INV(BHLINV,0))

 +5                IF BHLML=""

                       SET BHL(BHLSEG,1,BHLSEQ)=$GET(INV(BHLINV))

                       QUIT 

 +6                SET BHLML=0

                   FOR 

                       SET BHLML=$ORDER(INV(BHLINV,BHLML))

                       IF 'BHLML

                           QUIT 

                       Begin DoDot:2

 +7                        IF $ORDER(INV(BHLINV,BHLML,0))

                               DO PAR

                               QUIT 

 +8                        SET BHL(BHLSEG,BHLML,BHLSEQ)=$GET(INV(BHLINV,BHLML))

                           QUIT 

                       End DoDot:2

               End DoDot:1

 +9        QUIT 

 +10      ;

PAR       ;-- break down array into lower level

 +1        SET BHLPR=0

           FOR 

               SET BHLPR=$ORDER(INV(BHLINV,BHLML,BHLPR))

               IF 'BHLPR

                   QUIT 

               Begin DoDot:1

 +2                IF $ORDER(INV(BHLINV,BHLML,BHLPR,0))

                       DO SUBPAR

                       QUIT 

 +3                SET BHL(BHLSEG,BHLML,BHLPR,BHLSEQ)=$GET(INV(BHLINV,BHLML,BHLPR))

               End DoDot:1

 +4        QUIT 

 +5       ;

SUBPAR    ;-- break down the relationship to the next level

 +1        SET BHLSPR=0

           FOR 

               SET BHLSPR=$ORDER(INV(BHLINV,BHLML,BHLPR,BHLSPR))

               IF 'BHLSPR

                   QUIT 

               Begin DoDot:1

 +2                SET BHL(BHLSEG,BHLML,BHLPR,BHLSPR,BHLSEQ)=$GET(INV(BHLINV,BHLML,BHLPR,BHLSPR))

               End DoDot:1

 +3        QUIT 

 +4       ;