BHLNK1I.m

BHLNK1I ; cmi/sitka/maw - BHL Process Inbound NK1 Segment ;  

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

 ;

 ;this routine will file the inbound NK1 segment

 ;

MAIN ;-- this is the main routine driver

 D PROCESS,EOJ

 Q

 ;

PROCESS ;-- let's go through and setup the data by relationship type

 S BHLDA=0 F  S BHLDA=$O(@BHLTMP@(BHLDA)) Q:BHLDA=""  D

 . S BHLCR=$P($G(@BHLTMP@(BHLDA,7)),CS,2)

 . Q:BHLCR=""

 . S BHLNM=$G(@BHLTMP@(BHLDA,2))

 . Q:BHLNM=""

 . S BHLREL=$P($G(@BHLTMP@(BHLDA,3)),CS,2)

 . Q:BHLREL=""

 . S BHLST1=$P($G(@BHLTMP@(BHLDA,4)),CS)

 . S BHLST2=$P($G(@BHLTMP@(BHLDA,4)),CS,2)

 . S BHLCTY=$P($G(@BHLTMP@(BHLDA,4)),CS,3)

 . S BHLST=$P($G(@BHLTMP@(BHLDA,4)),CS,4)

 . S BHLST=$S(BHLST'="":$O(^DIC(5,"C",BHLST,0)),1:"")

 . S BHLZIP=$P($G(@BHLTMP@(BHLDA,4)),CS,5)

 . S BHLPH=$G(@BHLTMP@(BHLDA,5))

 . I BHLCR="SELF" D

 .. S BHLCR="SELF"

 .. S BHLEN=$G(@BHLTMP@(BHLDA,13))

 .. S BHLES=$G(@BHLTMP@(BHLDA,34))

 . I BHLCR="SPOUSE" D

 .. S BHLEN=$G(@BHLTMP@(BHLDA,13))

 . I BHLCR="EMERGENCY CONTACT" S BHLCR="EC"

 . I BHLCR="NEXT OF KIN" S BHLCR="NOK"

 . Q:'$L($T(@BHLCR))

 . D @BHLCR

 Q

 ;

EC ;-- file emergency contact

 S BHLX=BHLPAT

 S BHLFL=2,BHLFLD=.331,BHLVAL=BHLNM X BHLDIE

 ;S BHLFLD=.332,BHLVAL=BHLREL X BHLDIE  ;gets triggered from 9000001

 S BHLFLD=.333,BHLVAL=BHLST1 X BHLDIE

 S BHLFLD=.334,BHLVAL=BHLST2 X BHLDIE

 S BHLFLD=.336,BHLVAL=BHLCTY X BHLDIE

 S BHLFLD=.337,BHLVAL=BHLST X BHLDIE

 S BHLFLD=.338,BHLVAL=BHLZIP X BHLDIE

 S BHLFLD=.339,BHLVAL=BHLPH X BHLDIE

 S BHLFL=9000001,BHLFLD=3102,BHLVAL=BHLREL X BHLDIE

 Q

 ;

NOK ;-- file next of kin

 S BHLFL=2,BHLFLD=.211,BHLVAL=BHLNM,BHLX=BHLPAT X BHLDIE

 ;S BHLFLD=.212,BHLVAL=BHLREL X BHLDIE  ;gets triggered from 9000001

 S BHLFLD=.213,BHLVAL=BHLST1 X BHLDIE

 S BHLFLD=.214,BHLVAL=BHLST2 X BHLDIE

 S BHLFLD=.216,BHLVAL=BHLCTY X BHLDIE

 S BHLFLD=.217,BHLVAL=BHLST X BHLDIE

 S BHLFLD=.218,BHLVAL=BHLZIP X BHLDIE

 S BHLFLD=.219,BHLVAL=BHLPH X BHLDIE

 S BHLFL=9000001,BHLFLD=2802,BHLVAL=BHLREL X BHLDIE

 Q

 ;

SELF ;-- file self

 S BHLFL=9000001,BHLFLD=.19,BHLVAL=BHLEN,BHLX=BHLPAT X BHLDIE

 S BHLFLD=.21,BHLVAL=BHLES X BHLDIE

 Q

 ;

SPOUSE ;-- file spouse

 S BHLFL=9000001,BHLFLD=.22,BHLVAL=BHLEN,BHLX=BHLPAT X BHLDIE

 Q

 ;

EOJ ;-- kill variables and quit

 K @BHLTMP

 K BHLDA,BHLNM,BHLCR,BHLREL,BHLST1,BHLST2,BHLCTY,BHLST,BHLZIP,BHLPH

 K BHLEN,BHLES,BHLFL,BHLFLD,BHLVAL,BHLX

 Q

 ;

BHLNK1I   ; cmi/sitka/maw - BHL Process Inbound NK1 Segment ;  

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

 +2       ;

 +3       ;this routine will file the inbound NK1 segment

 +4       ;

MAIN      ;-- this is the main routine driver

 +1        DO PROCESS

           DO EOJ

 +2        QUIT 

 +3       ;

PROCESS   ;-- let's go through and setup the data by relationship type

 +1        SET BHLDA=0

           FOR 

               SET BHLDA=$ORDER(@BHLTMP@(BHLDA))

               IF BHLDA=""

                   QUIT 

               Begin DoDot:1

 +2                SET BHLCR=$PIECE($GET(@BHLTMP@(BHLDA,7)),CS,2)

 +3                IF BHLCR=""

                       QUIT 

 +4                SET BHLNM=$GET(@BHLTMP@(BHLDA,2))

 +5                IF BHLNM=""

                       QUIT 

 +6                SET BHLREL=$PIECE($GET(@BHLTMP@(BHLDA,3)),CS,2)

 +7                IF BHLREL=""

                       QUIT 

 +8                SET BHLST1=$PIECE($GET(@BHLTMP@(BHLDA,4)),CS)

 +9                SET BHLST2=$PIECE($GET(@BHLTMP@(BHLDA,4)),CS,2)

 +10               SET BHLCTY=$PIECE($GET(@BHLTMP@(BHLDA,4)),CS,3)

 +11               SET BHLST=$PIECE($GET(@BHLTMP@(BHLDA,4)),CS,4)

 +12               SET BHLST=$SELECT(BHLST'="":$ORDER(^DIC(5,"C",BHLST,0)),1:"")

 +13               SET BHLZIP=$PIECE($GET(@BHLTMP@(BHLDA,4)),CS,5)

 +14               SET BHLPH=$GET(@BHLTMP@(BHLDA,5))

 +15               IF BHLCR="SELF"

                       Begin DoDot:2

 +16                       SET BHLCR="SELF"

 +17                       SET BHLEN=$GET(@BHLTMP@(BHLDA,13))

 +18                       SET BHLES=$GET(@BHLTMP@(BHLDA,34))

                       End DoDot:2

 +19               IF BHLCR="SPOUSE"

                       Begin DoDot:2

 +20                       SET BHLEN=$GET(@BHLTMP@(BHLDA,13))

                       End DoDot:2

 +21               IF BHLCR="EMERGENCY CONTACT"

                       SET BHLCR="EC"

 +22               IF BHLCR="NEXT OF KIN"

                       SET BHLCR="NOK"

 +23               IF '$LENGTH($TEXT(@BHLCR))

                       QUIT 

 +24               DO @BHLCR

               End DoDot:1

 +25       QUIT 

 +26      ;

EC        ;-- file emergency contact

 +1        SET BHLX=BHLPAT

 +2        SET BHLFL=2

           SET BHLFLD=.331

           SET BHLVAL=BHLNM

           XECUTE BHLDIE

 +3       ;S BHLFLD=.332,BHLVAL=BHLREL X BHLDIE  ;gets triggered from 9000001

 +4        SET BHLFLD=.333

           SET BHLVAL=BHLST1

           XECUTE BHLDIE

 +5        SET BHLFLD=.334

           SET BHLVAL=BHLST2

           XECUTE BHLDIE

 +6        SET BHLFLD=.336

           SET BHLVAL=BHLCTY

           XECUTE BHLDIE

 +7        SET BHLFLD=.337

           SET BHLVAL=BHLST

           XECUTE BHLDIE

 +8        SET BHLFLD=.338

           SET BHLVAL=BHLZIP

           XECUTE BHLDIE

 +9        SET BHLFLD=.339

           SET BHLVAL=BHLPH

           XECUTE BHLDIE

 +10       SET BHLFL=9000001

           SET BHLFLD=3102

           SET BHLVAL=BHLREL

           XECUTE BHLDIE

 +11       QUIT 

 +12      ;

NOK       ;-- file next of kin

 +1        SET BHLFL=2

           SET BHLFLD=.211

           SET BHLVAL=BHLNM

           SET BHLX=BHLPAT

           XECUTE BHLDIE

 +2       ;S BHLFLD=.212,BHLVAL=BHLREL X BHLDIE  ;gets triggered from 9000001

 +3        SET BHLFLD=.213

           SET BHLVAL=BHLST1

           XECUTE BHLDIE

 +4        SET BHLFLD=.214

           SET BHLVAL=BHLST2

           XECUTE BHLDIE

 +5        SET BHLFLD=.216

           SET BHLVAL=BHLCTY

           XECUTE BHLDIE

 +6        SET BHLFLD=.217

           SET BHLVAL=BHLST

           XECUTE BHLDIE

 +7        SET BHLFLD=.218

           SET BHLVAL=BHLZIP

           XECUTE BHLDIE

 +8        SET BHLFLD=.219

           SET BHLVAL=BHLPH

           XECUTE BHLDIE

 +9        SET BHLFL=9000001

           SET BHLFLD=2802

           SET BHLVAL=BHLREL

           XECUTE BHLDIE

 +10       QUIT 

 +11      ;

SELF      ;-- file self

 +1        SET BHLFL=9000001

           SET BHLFLD=.19

           SET BHLVAL=BHLEN

           SET BHLX=BHLPAT

           XECUTE BHLDIE

 +2        SET BHLFLD=.21

           SET BHLVAL=BHLES

           XECUTE BHLDIE

 +3        QUIT 

 +4       ;

SPOUSE    ;-- file spouse

 +1        SET BHLFL=9000001

           SET BHLFLD=.22

           SET BHLVAL=BHLEN

           SET BHLX=BHLPAT

           XECUTE BHLDIE

 +2        QUIT 

 +3       ;

EOJ       ;-- kill variables and quit

 +1        KILL @BHLTMP

 +2        KILL BHLDA,BHLNM,BHLCR,BHLREL,BHLST1,BHLST2,BHLCTY,BHLST,BHLZIP,BHLPH

 +3        KILL BHLEN,BHLES,BHLFL,BHLFLD,BHLVAL,BHLX

 +4        QUIT 

 +5       ;