BHLPIDI.m

BHLPIDI ; cmi/flag/maw - BHL Process Inbound PID Segment ;

 ;;3.01;BHL IHS Interfaces with GIS;**1**;JUN 01, 2002

 ;

 ;this routine will process the inbound PID segment

 ;

MAIN ;-- this is the main routine driver

 D CHKPAT I $D(BHLERR("FATAL")) L -^TMP("BHL",BHLPHR) Q

 D PROCESS,EOJ

 Q

 ;

PROCESS ;-- process the segment

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

 . S BHLMMN=$$HLPN^INHUT($G(@BHLTMP@(BHLDA,6)),CS)

 . S BHLAL=$G(@BHLTMP@(BHLDA,9))

 . S BHLST1=$P(@BHLTMP@(BHLDA,11),CS,1)

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

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

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

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

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

 . S BHLCTRY=$P(@BHLTMP@(BHLDA,11),CS,6)

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

 . S BHLWPH=$G(@BHLTMP@(BHLDA,14))

 . S BHLREL=$G(@BHLTMP@(BHLDA,17))

 . S BHLACCT=$G(@BHLTMP@(BHLDA,18))

 . ;I BHLREL'="" S BHLREL=$S($O(^DIC(13,"MT",BHLREL,0)):$O(^DIC(13,"MT",BHLREL,0)),1:"") this will be used to convert religion if not rpms compat

 . S BHLVMS=$P($G(@BHLTMP@(BHLDA,27)),CS)

 . S BHLDDT=$$HDATE^INHUT($G(@BHLTMP@(BHLDA,29)))

 . S BHLDI=$G(@BHLTMP@(BHLDA,30))

 . I '$O(BHL("ZP2",0)) D REGUP^BHLZP2I

 S BHLFL=2,BHLX=BHLPAT

 S BHLFLD=.2403,BHLVAL=BHLMMN X BHLDIE

 S BHLFLD=.111,BHLVAL=BHLST1 X BHLDIE

 S BHLFLD=.112,BHLVAL=BHLST2 X BHLDIE

 S BHLFLD=.114,BHLVAL=BHLCTY X BHLDIE

 S BHLFLD=.115,BHLVAL=BHLST X BHLDIE

 S BHLFLD=.116,BHLVAL=BHLZIP X BHLDIE

 S BHLFLD=.131,BHLVAL=BHLHPH X BHLDIE

 S BHLFLD=.132,BHLVAL=BHLWPH X BHLDIE

 S BHLFLD=.08,BHLVAL=BHLREL X BHLDIE

 S BHLFLD=1901,BHLVAL=BHLVMS X BHLDIE

 S BHLFLD=.351,BHLVAL=BHLDDT X BHLDIE

 S ^AGPATCH($$NOW,DUZ(2),BHLPAT)=""

 Q

 ;

CHKPAT ;EP - check the patient by their identifiers

 D PRS3

 Q

 ;

PRS3 ;-- parse sequence 3

 S BHLDA=$O(@BHLTMP@(0)) ;there is only one PID

 S BHLPHR=+$E($P(@BHLTMP@(BHLDA,3),U),7,12)

 L +^TMP("BHL",BHLPHR):60

 I '$T S BHLERCD="NOLOCK" X BHLERR Q

 S BHLASU=$E($P(@BHLTMP@(BHLDA,3),U),1,6)

 S BHLLOC=$O(^AUTTLOC("C",+BHLASU,0))

 I BHLLOC="" S BHLERCD="NOLOC" X BHLERR

 Q:$D(BHLERR("FATAL"))

 S BHLDUZ=BHLLOC

 S BHLXDA=0 F  S BHLXDA=$O(^AUPNPAT("D",BHLPHR,BHLXDA)) Q:'BHLXDA!($G(BHLPAT))  D

 . S BHLYDA=0 F  S BHLYDA=$O(^AUPNPAT("D",BHLPHR,BHLXDA,BHLYDA)) Q:'BHLYDA!($G(BHLPAT))  I BHLYDA=BHLDUZ S BHLPAT=BHLXDA

 I '$G(BHLPAT) D SSNC Q

 Q:$D(BHLERR("FATAL"))

 I '$G(BHLPAT) D ADDPAT Q

 D OCHKS

 Q

 ;

PRS4 ;-- parse sequence 4

 Q  ;not currently used unless site wants to look at other facility num

 S BHLPID4=$G(@BHLTMP@(BHLDA,4))

 I BHLPID4="" D ADDPAT Q

 F I=1:1 S BHLPID4(I)=$P(@BHLTMP@(BHLDA,4),RS,I) Q:'$P(@BHLTMP@(BHLDA,4),RS,I)

 S BHL4DA=0 F  S BHL4DA=$O(BHLPID4(BHL4DA)) Q:'BHL4DA!($G(BHLPAT))  D

 . Q:'$G(BHLPID4(BHL4DA))

 . Q:$L($G(BHLPID4(BHL4DA)))'=12

 . S BHLPHR=+$E($P(BHLPID4(BHL4DA),U),7,12)

 . S BHLASU=$E($P(BHLPID4(BHL4DA),U),1,6)

 . S BHLLOC=$O(^AUTTLOC("C",BHLASU,0))

 . Q:BHLLOC=""

 . S BHLDUZ=BHLLOC

 . S BHLXDA=0 F  S BHLXDA=$O(^AUPNPAT("D",BHLPHR,BHLXDA)) Q:'BHLXDA!($G(BHLPAT))  D

 .. S BHLYDA=0 F  S BHLYDA=$O(^AUPNPAT("D",BHLPHR,BHLXDA,BHLYDA)) Q:'BHLYDA!($G(BHLPAT))  I BHLYDA=BHLDUZ S BHLPAT=BHLXDA

 . I '$G(BHLPAT) D SSNC Q

 . Q:$D(BHLERR("FATAL"))

 . I '$G(BHLPAT) D ADDPAT Q

 . Q:BHLPAT=""

 . D OCHKS

 . Q:$G(BHLPAT)

 Q:$D(BHLERR("FATAL"))

 Q

 ;

SSNC ;-- check for ssn, dob, sex match

 S BHLSSN=$G(@BHLTMP@(BHLDA,19))

 I BHLSSN["-" S BHLSSN=$TR(BHLSSN,"-")

 I BHLSSN="" S BHLERCD="NOSSN" X BHLERR Q

 S BHLDOB=$$HDATE^INHUT($G(@BHLTMP@(BHLDA,7)))

 I BHLDOB="" S BHLERCD="NODOB" X BHLERR Q

 S BHLSX=$G(@BHLTMP@(BHLDA,8))

 I BHLSX="" S BHLERCD="NOSX" X BHLERR Q

 S BHLNM=$$HLPN^INHUT($G(@BHLTMP@(BHLDA,5)),CS)

 S BHLTPAT=$O(^DPT("SSN",BHLSSN,0))

 I BHLTPAT="" S BHLERCD="NOSSN" X BHLERR Q

 I $P(^DPT(BHLTPAT,0),U,3)'=BHLDOB S BHLERCD="NODOBM" X BHLERR Q

 I $P(^DPT(BHLTPAT,0),U,2)'=BHLSX S BHLERCD="NOSXM" X BHLERR Q

 S BHLPAT=BHLTPAT

 D CHT

 Q

 ;

OCHKS ;check sex, ssn, and dob

 S BHLDOB=$$HDATE^INHUT($G(@BHLTMP@(BHLDA,7)))

 I BHLDOB="" S BHLERCD="NODOB" X BHLERR Q

 S BHLSX=$G(@BHLTMP@(BHLDA,8))

 I BHLSX="" S BHLERCD="NOSX" X BHLERR Q

 S BHLSSN=$G(@BHLTMP@(BHLDA,19))

 I BHLSSN["-" S BHLSSN=$TR(BHLSSN,"-")

 I BHLSSN="" S BHLERCD="NOSSN" X BHLERR

 S BHLNM=$$HLPN^INHUT($G(@BHLTMP@(BHLDA,5)),CS)

 I $P(^DPT(BHLPAT,0),U,3)'=BHLDOB S BHLERCD="NODOBM" X BHLERR Q

 I $P(^DPT(BHLPAT,0),U,2)'=BHLSX S BHLERCD="NOSXM" X BHLERR Q

 I BHLSSN'="" D  Q:$G(BHLERR("FATAL"))

 . I $P(^DPT(BHLPAT,0),U,9)'=BHLSSN S BHLERCD="NOSSNM" X BHLERR Q

 Q

 ;

ADDPAT ;-- add a patient to the system

 S BHLDOB=$$HDATE^INHUT($G(@BHLTMP@(BHLDA,7)))

 I BHLDOB="" S BHLERCD="NODOB" X BHLERR Q

 S BHLSX=$G(@BHLTMP@(BHLDA,8))

 I BHLSX="" S BHLERCD="NOSX" X BHLERR Q

 S BHLSSN=$G(@BHLTMP@(BHLDA,19))

 I BHLSSN="" S BHLERCD="NOSSN" X BHLERR

 S BHLNM=$$HLPN^INHUT($G(@BHLTMP@(BHLDA,5)),CS)

 K DIC,DR,DA,DIADD,DLAYGO

 S X=BHLNM,DIC(0)="L",DIADD=2,DLAYGO=2,DIC="^DPT(" D ^DIC

 I Y<0 S BHLERCD="NOADDPT" X BHLERR Q

 S BHLPAT=+Y

 K DIC,DIADD,DLAYGO,DR,DA

 S BHLFL=2,BHLFLD=.02,BHLX=BHLPAT,BHLVAL=BHLSX X BHLDIE

 I $D(Y) D CLEAN Q

 S BHLFLD=.03,BHLVAL=BHLDOB X BHLDIE

 I $D(Y) D CLEAN Q

 S BHLFLD=.09,BHLVAL=BHLSSN X BHLDIE

 S ^AUPNPAT(BHLPAT,0)=BHLPAT,^AUPNPAT("B",BHLPAT,BHLPAT)=""

 S BHLFL=9000001,BHLFLD=.02,BHLVAL=DT X BHLDIE

 S ^AGPATCH($$NOW,DUZ(2),BHLPAT)="NEW"

 D CHT

 Q

 ;

CLEAN ;-- clean up file 2

 S BHLERCD="NOF2UP" X BHLERR

 S DA=BHLPAT,DIK="^DPT(" D ^DIK

 K ^AUPNPAT(BHLPAT),^AUPNPAT("B",BHLPAT,BHLPAT)

 Q

 ;

EOJ ;-- kill variables

 L -^TMP("BHL",BHLPHR)

 K @BHLTMP

 K BHLDA,BHLVAL,BHLFL,BHLFLD,BHLDR,BHLMMN,BHLSX,BHLSSN,BHLDOB

 K BHLST1,BHLST2,BHLCTY,BHLST,BHLZIP,BHLREL,BHLHPH,BHLWPH,BHLDDT,BHLCTRY

 K BHLX,BHLVMS,BHL4DA

 Q

 ;

CHT ;-- add the chart number

 Q  ;this is used if the site wants to create an auto chart #

 S:'$D(^AUPNPAT(BHLPAT,41,0)) ^AUPNPAT(BHLPAT,41,0)="^9000001.41IP^^"

 K DIC,DR S X=$P(^DIC(4,DUZ(2),0),U)

 S DIC="^AUPNPAT("_BHLPAT_",41,",DA(1)=BHLPAT,DIC(0)="ML" D ^DIC

 S DIE="^AUPNPAT("_BHLPAT_",41,",DA=DUZ(2)

 S DA(1)=BHLPAT,DR=".02///"_BHLPHR

 D ^DIE

 K DA,DIE,DR

 Q

 ;

NOW() ;-- get now

 D NOW^%DTC

 Q %

 Q

 ;

BHLPIDI   ; cmi/flag/maw - BHL Process Inbound PID Segment ;

 +1       ;;3.01;BHL IHS Interfaces with GIS;**1**;JUN 01, 2002

 +2       ;

 +3       ;this routine will process the inbound PID segment

 +4       ;

MAIN      ;-- this is the main routine driver

 +1        DO CHKPAT

           IF $DATA(BHLERR("FATAL"))

               LOCK -^TMP("BHL",BHLPHR)

               QUIT 

 +2        DO PROCESS

           DO EOJ

 +3        QUIT 

 +4       ;

PROCESS   ;-- process the segment

 +1        SET BHLDA=0

           FOR 

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

               IF BHLDA=""

                   QUIT 

               Begin DoDot:1

 +2                SET BHLMMN=$$HLPN^INHUT($GET(@BHLTMP@(BHLDA,6)),CS)

 +3                SET BHLAL=$GET(@BHLTMP@(BHLDA,9))

 +4                SET BHLST1=$PIECE(@BHLTMP@(BHLDA,11),CS,1)

 +5                SET BHLST2=$PIECE(@BHLTMP@(BHLDA,11),CS,2)

 +6                SET BHLCTY=$PIECE(@BHLTMP@(BHLDA,11),CS,3)

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

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

 +9                SET BHLZIP=$PIECE(@BHLTMP@(BHLDA,11),CS,5)

 +10               SET BHLCTRY=$PIECE(@BHLTMP@(BHLDA,11),CS,6)

 +11               SET BHLHPH=$GET(@BHLTMP@(BHLDA,13))

 +12               SET BHLWPH=$GET(@BHLTMP@(BHLDA,14))

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

 +14               SET BHLACCT=$GET(@BHLTMP@(BHLDA,18))

 +15      ;I BHLREL'="" S BHLREL=$S($O(^DIC(13,"MT",BHLREL,0)):$O(^DIC(13,"MT",BHLREL,0)),1:"") this will be used to convert religion if not rpms compat

 +16               SET BHLVMS=$PIECE($GET(@BHLTMP@(BHLDA,27)),CS)

 +17               SET BHLDDT=$$HDATE^INHUT($GET(@BHLTMP@(BHLDA,29)))

 +18               SET BHLDI=$GET(@BHLTMP@(BHLDA,30))

 +19               IF '$ORDER(BHL("ZP2",0))

                       DO REGUP^BHLZP2I

               End DoDot:1

 +20       SET BHLFL=2

           SET BHLX=BHLPAT

 +21       SET BHLFLD=.2403

           SET BHLVAL=BHLMMN

           XECUTE BHLDIE

 +22       SET BHLFLD=.111

           SET BHLVAL=BHLST1

           XECUTE BHLDIE

 +23       SET BHLFLD=.112

           SET BHLVAL=BHLST2

           XECUTE BHLDIE

 +24       SET BHLFLD=.114

           SET BHLVAL=BHLCTY

           XECUTE BHLDIE

 +25       SET BHLFLD=.115

           SET BHLVAL=BHLST

           XECUTE BHLDIE

 +26       SET BHLFLD=.116

           SET BHLVAL=BHLZIP

           XECUTE BHLDIE

 +27       SET BHLFLD=.131

           SET BHLVAL=BHLHPH

           XECUTE BHLDIE

 +28       SET BHLFLD=.132

           SET BHLVAL=BHLWPH

           XECUTE BHLDIE

 +29       SET BHLFLD=.08

           SET BHLVAL=BHLREL

           XECUTE BHLDIE

 +30       SET BHLFLD=1901

           SET BHLVAL=BHLVMS

           XECUTE BHLDIE

 +31       SET BHLFLD=.351

           SET BHLVAL=BHLDDT

           XECUTE BHLDIE

 +32       SET ^AGPATCH($$NOW,DUZ(2),BHLPAT)=""

 +33       QUIT 

 +34      ;

CHKPAT    ;EP - check the patient by their identifiers

 +1        DO PRS3

 +2        QUIT 

 +3       ;

PRS3      ;-- parse sequence 3

 +1       ;there is only one PID

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

 +2        SET BHLPHR=+$EXTRACT($PIECE(@BHLTMP@(BHLDA,3),U),7,12)

 +3        LOCK +^TMP("BHL",BHLPHR):60

 +4        IF '$TEST

               SET BHLERCD="NOLOCK"

               XECUTE BHLERR

               QUIT 

 +5        SET BHLASU=$EXTRACT($PIECE(@BHLTMP@(BHLDA,3),U),1,6)

 +6        SET BHLLOC=$ORDER(^AUTTLOC("C",+BHLASU,0))

 +7        IF BHLLOC=""

               SET BHLERCD="NOLOC"

               XECUTE BHLERR

 +8        IF $DATA(BHLERR("FATAL"))

               QUIT 

 +9        SET BHLDUZ=BHLLOC

 +10       SET BHLXDA=0

           FOR 

               SET BHLXDA=$ORDER(^AUPNPAT("D",BHLPHR,BHLXDA))

               IF 'BHLXDA!($GET(BHLPAT))

                   QUIT 

               Begin DoDot:1

 +11               SET BHLYDA=0

                   FOR 

                       SET BHLYDA=$ORDER(^AUPNPAT("D",BHLPHR,BHLXDA,BHLYDA))

                       IF 'BHLYDA!($GET(BHLPAT))

                           QUIT 

                       IF BHLYDA=BHLDUZ

                           SET BHLPAT=BHLXDA

               End DoDot:1

 +12       IF '$GET(BHLPAT)

               DO SSNC

               QUIT 

 +13       IF $DATA(BHLERR("FATAL"))

               QUIT 

 +14       IF '$GET(BHLPAT)

               DO ADDPAT

               QUIT 

 +15       DO OCHKS

 +16       QUIT 

 +17      ;

PRS4      ;-- parse sequence 4

 +1       ;not currently used unless site wants to look at other facility num

           QUIT 

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

 +3        IF BHLPID4=""

               DO ADDPAT

               QUIT 

 +4        FOR I=1:1

               SET BHLPID4(I)=$PIECE(@BHLTMP@(BHLDA,4),RS,I)

               IF '$PIECE(@BHLTMP@(BHLDA,4),RS,I)

                   QUIT 

 +5        SET BHL4DA=0

           FOR 

               SET BHL4DA=$ORDER(BHLPID4(BHL4DA))

               IF 'BHL4DA!($GET(BHLPAT))

                   QUIT 

               Begin DoDot:1

 +6                IF '$GET(BHLPID4(BHL4DA))

                       QUIT 

 +7                IF $LENGTH($GET(BHLPID4(BHL4DA)))'=12

                       QUIT 

 +8                SET BHLPHR=+$EXTRACT($PIECE(BHLPID4(BHL4DA),U),7,12)

 +9                SET BHLASU=$EXTRACT($PIECE(BHLPID4(BHL4DA),U),1,6)

 +10               SET BHLLOC=$ORDER(^AUTTLOC("C",BHLASU,0))

 +11               IF BHLLOC=""

                       QUIT 

 +12               SET BHLDUZ=BHLLOC

 +13               SET BHLXDA=0

                   FOR 

                       SET BHLXDA=$ORDER(^AUPNPAT("D",BHLPHR,BHLXDA))

                       IF 'BHLXDA!($GET(BHLPAT))

                           QUIT 

                       Begin DoDot:2

 +14                       SET BHLYDA=0

                           FOR 

                               SET BHLYDA=$ORDER(^AUPNPAT("D",BHLPHR,BHLXDA,BHLYDA))

                               IF 'BHLYDA!($GET(BHLPAT))

                                   QUIT 

                               IF BHLYDA=BHLDUZ

                                   SET BHLPAT=BHLXDA

                       End DoDot:2

 +15               IF '$GET(BHLPAT)

                       DO SSNC

                       QUIT 

 +16               IF $DATA(BHLERR("FATAL"))

                       QUIT 

 +17               IF '$GET(BHLPAT)

                       DO ADDPAT

                       QUIT 

 +18               IF BHLPAT=""

                       QUIT 

 +19               DO OCHKS

 +20               IF $GET(BHLPAT)

                       QUIT 

               End DoDot:1

 +21       IF $DATA(BHLERR("FATAL"))

               QUIT 

 +22       QUIT 

 +23      ;

SSNC      ;-- check for ssn, dob, sex match

 +1        SET BHLSSN=$GET(@BHLTMP@(BHLDA,19))

 +2        IF BHLSSN["-"

               SET BHLSSN=$TRANSLATE(BHLSSN,"-")

 +3        IF BHLSSN=""

               SET BHLERCD="NOSSN"

               XECUTE BHLERR

               QUIT 

 +4        SET BHLDOB=$$HDATE^INHUT($GET(@BHLTMP@(BHLDA,7)))

 +5        IF BHLDOB=""

               SET BHLERCD="NODOB"

               XECUTE BHLERR

               QUIT 

 +6        SET BHLSX=$GET(@BHLTMP@(BHLDA,8))

 +7        IF BHLSX=""

               SET BHLERCD="NOSX"

               XECUTE BHLERR

               QUIT 

 +8        SET BHLNM=$$HLPN^INHUT($GET(@BHLTMP@(BHLDA,5)),CS)

 +9        SET BHLTPAT=$ORDER(^DPT("SSN",BHLSSN,0))

 +10       IF BHLTPAT=""

               SET BHLERCD="NOSSN"

               XECUTE BHLERR

               QUIT 

 +11       IF $PIECE(^DPT(BHLTPAT,0),U,3)'=BHLDOB

               SET BHLERCD="NODOBM"

               XECUTE BHLERR

               QUIT 

 +12       IF $PIECE(^DPT(BHLTPAT,0),U,2)'=BHLSX

               SET BHLERCD="NOSXM"

               XECUTE BHLERR

               QUIT 

 +13       SET BHLPAT=BHLTPAT

 +14       DO CHT

 +15       QUIT 

 +16      ;

OCHKS     ;check sex, ssn, and dob

 +1        SET BHLDOB=$$HDATE^INHUT($GET(@BHLTMP@(BHLDA,7)))

 +2        IF BHLDOB=""

               SET BHLERCD="NODOB"

               XECUTE BHLERR

               QUIT 

 +3        SET BHLSX=$GET(@BHLTMP@(BHLDA,8))

 +4        IF BHLSX=""

               SET BHLERCD="NOSX"

               XECUTE BHLERR

               QUIT 

 +5        SET BHLSSN=$GET(@BHLTMP@(BHLDA,19))

 +6        IF BHLSSN["-"

               SET BHLSSN=$TRANSLATE(BHLSSN,"-")

 +7        IF BHLSSN=""

               SET BHLERCD="NOSSN"

               XECUTE BHLERR

 +8        SET BHLNM=$$HLPN^INHUT($GET(@BHLTMP@(BHLDA,5)),CS)

 +9        IF $PIECE(^DPT(BHLPAT,0),U,3)'=BHLDOB

               SET BHLERCD="NODOBM"

               XECUTE BHLERR

               QUIT 

 +10       IF $PIECE(^DPT(BHLPAT,0),U,2)'=BHLSX

               SET BHLERCD="NOSXM"

               XECUTE BHLERR

               QUIT 

 +11       IF BHLSSN'=""

               Begin DoDot:1

 +12               IF $PIECE(^DPT(BHLPAT,0),U,9)'=BHLSSN

                       SET BHLERCD="NOSSNM"

                       XECUTE BHLERR

                       QUIT 

               End DoDot:1

               IF $GET(BHLERR("FATAL"))

                   QUIT 

 +13       QUIT 

 +14      ;

ADDPAT    ;-- add a patient to the system

 +1        SET BHLDOB=$$HDATE^INHUT($GET(@BHLTMP@(BHLDA,7)))

 +2        IF BHLDOB=""

               SET BHLERCD="NODOB"

               XECUTE BHLERR

               QUIT 

 +3        SET BHLSX=$GET(@BHLTMP@(BHLDA,8))

 +4        IF BHLSX=""

               SET BHLERCD="NOSX"

               XECUTE BHLERR

               QUIT 

 +5        SET BHLSSN=$GET(@BHLTMP@(BHLDA,19))

 +6        IF BHLSSN=""

               SET BHLERCD="NOSSN"

               XECUTE BHLERR

 +7        SET BHLNM=$$HLPN^INHUT($GET(@BHLTMP@(BHLDA,5)),CS)

 +8        KILL DIC,DR,DA,DIADD,DLAYGO

 +9        SET X=BHLNM

           SET DIC(0)="L"

           SET DIADD=2

           SET DLAYGO=2

           SET DIC="^DPT("

           DO ^DIC

 +10       IF Y<0

               SET BHLERCD="NOADDPT"

               XECUTE BHLERR

               QUIT 

 +11       SET BHLPAT=+Y

 +12       KILL DIC,DIADD,DLAYGO,DR,DA

 +13       SET BHLFL=2

           SET BHLFLD=.02

           SET BHLX=BHLPAT

           SET BHLVAL=BHLSX

           XECUTE BHLDIE

 +14       IF $DATA(Y)

               DO CLEAN

               QUIT 

 +15       SET BHLFLD=.03

           SET BHLVAL=BHLDOB

           XECUTE BHLDIE

 +16       IF $DATA(Y)

               DO CLEAN

               QUIT 

 +17       SET BHLFLD=.09

           SET BHLVAL=BHLSSN

           XECUTE BHLDIE

 +18       SET ^AUPNPAT(BHLPAT,0)=BHLPAT

           SET ^AUPNPAT("B",BHLPAT,BHLPAT)=""

 +19       SET BHLFL=9000001

           SET BHLFLD=.02

           SET BHLVAL=DT

           XECUTE BHLDIE

 +20       SET ^AGPATCH($$NOW,DUZ(2),BHLPAT)="NEW"

 +21       DO CHT

 +22       QUIT 

 +23      ;

CLEAN     ;-- clean up file 2

 +1        SET BHLERCD="NOF2UP"

           XECUTE BHLERR

 +2        SET DA=BHLPAT

           SET DIK="^DPT("

           DO ^DIK

 +3        KILL ^AUPNPAT(BHLPAT),^AUPNPAT("B",BHLPAT,BHLPAT)

 +4        QUIT 

 +5       ;

EOJ       ;-- kill variables

 +1        LOCK -^TMP("BHL",BHLPHR)

 +2        KILL @BHLTMP

 +3        KILL BHLDA,BHLVAL,BHLFL,BHLFLD,BHLDR,BHLMMN,BHLSX,BHLSSN,BHLDOB

 +4        KILL BHLST1,BHLST2,BHLCTY,BHLST,BHLZIP,BHLREL,BHLHPH,BHLWPH,BHLDDT,BHLCTRY

 +5        KILL BHLX,BHLVMS,BHL4DA

 +6        QUIT 

 +7       ;

CHT       ;-- add the chart number

 +1       ;this is used if the site wants to create an auto chart #

           QUIT 

 +2        IF '$DATA(^AUPNPAT(BHLPAT,41,0))

               SET ^AUPNPAT(BHLPAT,41,0)="^9000001.41IP^^"

 +3        KILL DIC,DR

           SET X=$PIECE(^DIC(4,DUZ(2),0),U)

 +4        SET DIC="^AUPNPAT("_BHLPAT_",41,"

           SET DA(1)=BHLPAT

           SET DIC(0)="ML"

           DO ^DIC

 +5        SET DIE="^AUPNPAT("_BHLPAT_",41,"

           SET DA=DUZ(2)

 +6        SET DA(1)=BHLPAT

           SET DR=".02///"_BHLPHR

 +7        DO ^DIE

 +8        KILL DA,DIE,DR

 +9        QUIT 

 +10      ;

NOW()     ;-- get now

 +1        DO NOW^%DTC

 +2        QUIT %

 +3        QUIT 

 +4       ;