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 ;
