BHLZP2I ; cmi/sitka/maw - BHL Process Inbound ZP2 Segment ;
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;
;this routine will process the inbound ZP2 segment
;
MAIN ;-- this is the main routine driver
D PROCESS,EOJ
Q
;
PROCESS ;-- process the segment
Q:'$O(@BHLTMP@(0))
S BHLDA=0 F S BHLDA=$O(@BHLTMP@(BHLDA)) Q:BHLDA="" D
. S BHLDE=$G(@BHLTMP@(BHLDA,1))
. S BHLDLRU=$G(@BHLTMP@(BHLDA,2))
. S BHLMRRD=$G(@BHLTMP@(BHLDA,3))
. S BHLMRVD=$G(@BHLTMP@(BHLDA,4))
. S BHLTEN=$G(@BHLTMP@(BHLDA,5))
. S BHLCHS=$P($G(@BHLTMP@(BHLDA,6)),CS,2)
. S BHLBT=$G(@BHLTMP@(BHLDA,7))
. S BHLDLU=$G(@BHLTMP@(BHLDA,8))
. S BHLABOD=$G(@BHLTMP@(BHLDA,9))
. S BHLABED=$G(@BHLTMP@(BHLDA,10))
. S BHLSSN=$P($G(@BHLTMP@(BHLDA,11)),CS)
. S BHLSSNR=$P($G(@BHLTMP@(BHLDA,12)),CS,2)
. S BHLBPC=$P($G(@BHLTMP@(BHLDA,13)),CS)
. S BHLBPS=$S($P($G(@BHLTMP@(BHLDA,13)),CS,2):$P($G(@BHLTMP@(BHLDA,13)),CS,2),1:"")
. S BHLBCN=$G(@BHLTMP@(BHLDA,14))
. S BHLTOM=$P($G(@BHLTMP@(BHLDA,15)),CS,2)
. S BHLTQ=$G(@BHLTMP@(BHLDA,16))
. S BHLIBQ=$G(@BHLTMP@(BHLDA,17))
. S BHLCB=$P($G(@BHLTMP@(BHLDA,18)),CS,2)
. S BHLCRD=$G(@BHLTMP@(BHLDA,19))
. S BHLSOD=$S($G(@BHLTMP@(BHLDA,20)):$O(^DIC(5,"C",$G(@BHLTMP@(BHLDA,20)),0)),1:"")
. S BHLDCN=$G(@BHLTMP@(BHLDA,21))
. S BHLCC=$G(@BHLTMP@(BHLDA,22))
. S BHLTMVF=$P($G(@BHLTMP@(BHLDA,23)),CS,2)
. S BHLRVF=$G(@BHLTMP@(BHLDA,24))
. S BHLDED=$G(@BHLTMP@(BHLDA,25))
. S BHLEMC=$P($G(@BHLTMP@(BHLDA,26)),CS,2)
. S BHLFN=$G(@BHLTMP@(BHLDA,31))
. S BHLFBPC=$P($G(@BHLTMP@(BHLDA,32)),CS)
. S BHLFBPS=$S($P($G(@BHLTMP@(BHLDA,32)),CS,2):$P($G(@BHLTMP@(BHLDA,13)),CS,2),1:"")
. S BHLMBPC=$P($G(@BHLTMP@(BHLDA,33)),CS)
. S BHLMBPS=$S($P($G(@BHLTMP@(BHLDA,33)),CS,2):$P($G(@BHLTMP@(BHLDA,13)),CS,2),1:"")
S BHLFL=9000001,BHLX=BHLPAT
S BHLFLD=.02,BHLVAL=BHLDE X BHLDIE
S BHLFLD=.03,BHLVAL=BHLDLRU X BHLDIE
S BHLFLD=.04,BHLVAL=BHLMRRD X BHLDIE
S BHLFLD=.05,BHLVAL=BHLMRVD X BHLDIE
S BHLFLD=.09,BHLVAL=BHLCHS X BHLDIE
S BHLFLD=.13,BHLVAL=BHLBT X BHLDIE
S BHLFLD=.16,BHLVAL=BHLDLU X BHLDIE
S BHLFLD=.17,BHLVAL=BHLABOD X BHLDIE
S BHLFLD=.18,BHLVAL=BHLABED X BHLDIE
S BHLFLD=.23,BHLVAL=BHLSSN X BHLDIE
S BHLFLD=.24,BHLVAL=BHLSSNR X BHLDIE
S BHLFLD=1105,BHLVAL=BHLBCN X BHLDIE
S BHLFLD=1108,BHLVAL=BHLTOM X BHLDIE
S BHLFLD=1109,BHLVAL=BHLTQ X BHLDIE
S BHLFLD=1110,BHLVAL=BHLIBQ X BHLDIE
S BHLFLD=1111,BHLVAL=BHLCB X BHLDIE
S BHLFLD=1113,BHLVAL=BHLCRD X BHLDIE
S BHLFLD=1115,BHLVAL=BHLSOD X BHLDIE
S BHLFLD=1116,BHLVAL=BHLDCN X BHLDIE
S BHLFLD=1117,BHLVAL=BHLCC X BHLDIE
S BHLFLD=1119,BHLVAL=BHLTMVF X BHLDIE
S BHLFLD=1121,BHLVAL=BHLRVF X BHLDIE
S BHLFLD=1123,BHLVAL=BHLDED X BHLDIE
S BHLFLD=1125,BHLVAL=BHLEMC X BHLDIE
S BHLFLD=2602,BHLVAL=BHLFBPC X BHLDIE
S BHLFLD=2603,BHLVAL=BHLFBPS X BHLDIE
S BHLFLD=2605,BHLVAL=BHLMBPC X BHLDIE
S BHLFLD=2606,BHLVAL=BHLMBPS X BHLDIE
S BHLFL=2
S BHLFLD=.092,BHLVAL=BHLBPC X BHLDIE
S BHLFLD=.093,BHLVAL=BHLBPS X BHLDIE
S BHLFLD=2401,BHLVAL=BHLFN X BHLDIE
Q
;
REGUP ;EP - update registration dates call from BHLPIDI if no ZP2 seg
N BHLFL
S BHLFL=9000001,BHLX=BHLPAT
S BHLDLU=DT,BHLDLRU=DT
S BHLFLD=.03,BHLVAL=BHLDLRU X BHLDIE
S BHLFLD=.16,BHLVAL=BHLDLU X BHLDIE
Q
;
EOJ ;-- kill variables
K @BHLTMP
K BHLDE,BHLDLRU,BHLMRRD,BHLMRVD,BHLTEN,BHLCHS,BHLBT,BHLDLU,BHLABOD
K BHLABED,BHLSSN,BHLSSNR,BHLBPC,BHLBPS,BHLBCN,BHLTOM,BHLTQ,BHLIBQ
K BHLCB,BHLCRD,BHLSOD,BHLDCN,BHLCC,BHLTMVF,BHLRVF,BHLDED,BHLEMC
K BHLFN,BHLFBPC,BHLFBPS,BHLMBPC,BHLMBPS,BHLDA,BHLFLD,BHLFL,BHLVAL
K BHLX
Q
;
BHLZP2I ; cmi/sitka/maw - BHL Process Inbound ZP2 Segment ;
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;
+3 ;this routine will process the inbound ZP2 segment
+4 ;
MAIN ;-- this is the main routine driver
+1 DO PROCESS
DO EOJ
+2 QUIT
+3 ;
PROCESS ;-- process the segment
+1 IF '$ORDER(@BHLTMP@(0))
QUIT
+2 SET BHLDA=0
FOR
SET BHLDA=$ORDER(@BHLTMP@(BHLDA))
IF BHLDA=""
QUIT
Begin DoDot:1
+3 SET BHLDE=$GET(@BHLTMP@(BHLDA,1))
+4 SET BHLDLRU=$GET(@BHLTMP@(BHLDA,2))
+5 SET BHLMRRD=$GET(@BHLTMP@(BHLDA,3))
+6 SET BHLMRVD=$GET(@BHLTMP@(BHLDA,4))
+7 SET BHLTEN=$GET(@BHLTMP@(BHLDA,5))
+8 SET BHLCHS=$PIECE($GET(@BHLTMP@(BHLDA,6)),CS,2)
+9 SET BHLBT=$GET(@BHLTMP@(BHLDA,7))
+10 SET BHLDLU=$GET(@BHLTMP@(BHLDA,8))
+11 SET BHLABOD=$GET(@BHLTMP@(BHLDA,9))
+12 SET BHLABED=$GET(@BHLTMP@(BHLDA,10))
+13 SET BHLSSN=$PIECE($GET(@BHLTMP@(BHLDA,11)),CS)
+14 SET BHLSSNR=$PIECE($GET(@BHLTMP@(BHLDA,12)),CS,2)
+15 SET BHLBPC=$PIECE($GET(@BHLTMP@(BHLDA,13)),CS)
+16 SET BHLBPS=$SELECT($PIECE($GET(@BHLTMP@(BHLDA,13)),CS,2):$PIECE($GET(@BHLTMP@(BHLDA,13)),CS,2),1:"")
+17 SET BHLBCN=$GET(@BHLTMP@(BHLDA,14))
+18 SET BHLTOM=$PIECE($GET(@BHLTMP@(BHLDA,15)),CS,2)
+19 SET BHLTQ=$GET(@BHLTMP@(BHLDA,16))
+20 SET BHLIBQ=$GET(@BHLTMP@(BHLDA,17))
+21 SET BHLCB=$PIECE($GET(@BHLTMP@(BHLDA,18)),CS,2)
+22 SET BHLCRD=$GET(@BHLTMP@(BHLDA,19))
+23 SET BHLSOD=$SELECT($GET(@BHLTMP@(BHLDA,20)):$ORDER(^DIC(5,"C",$GET(@BHLTMP@(BHLDA,20)),0)),1:"")
+24 SET BHLDCN=$GET(@BHLTMP@(BHLDA,21))
+25 SET BHLCC=$GET(@BHLTMP@(BHLDA,22))
+26 SET BHLTMVF=$PIECE($GET(@BHLTMP@(BHLDA,23)),CS,2)
+27 SET BHLRVF=$GET(@BHLTMP@(BHLDA,24))
+28 SET BHLDED=$GET(@BHLTMP@(BHLDA,25))
+29 SET BHLEMC=$PIECE($GET(@BHLTMP@(BHLDA,26)),CS,2)
+30 SET BHLFN=$GET(@BHLTMP@(BHLDA,31))
+31 SET BHLFBPC=$PIECE($GET(@BHLTMP@(BHLDA,32)),CS)
+32 SET BHLFBPS=$SELECT($PIECE($GET(@BHLTMP@(BHLDA,32)),CS,2):$PIECE($GET(@BHLTMP@(BHLDA,13)),CS,2),1:"")
+33 SET BHLMBPC=$PIECE($GET(@BHLTMP@(BHLDA,33)),CS)
+34 SET BHLMBPS=$SELECT($PIECE($GET(@BHLTMP@(BHLDA,33)),CS,2):$PIECE($GET(@BHLTMP@(BHLDA,13)),CS,2),1:"")
End DoDot:1
+35 SET BHLFL=9000001
SET BHLX=BHLPAT
+36 SET BHLFLD=.02
SET BHLVAL=BHLDE
XECUTE BHLDIE
+37 SET BHLFLD=.03
SET BHLVAL=BHLDLRU
XECUTE BHLDIE
+38 SET BHLFLD=.04
SET BHLVAL=BHLMRRD
XECUTE BHLDIE
+39 SET BHLFLD=.05
SET BHLVAL=BHLMRVD
XECUTE BHLDIE
+40 SET BHLFLD=.09
SET BHLVAL=BHLCHS
XECUTE BHLDIE
+41 SET BHLFLD=.13
SET BHLVAL=BHLBT
XECUTE BHLDIE
+42 SET BHLFLD=.16
SET BHLVAL=BHLDLU
XECUTE BHLDIE
+43 SET BHLFLD=.17
SET BHLVAL=BHLABOD
XECUTE BHLDIE
+44 SET BHLFLD=.18
SET BHLVAL=BHLABED
XECUTE BHLDIE
+45 SET BHLFLD=.23
SET BHLVAL=BHLSSN
XECUTE BHLDIE
+46 SET BHLFLD=.24
SET BHLVAL=BHLSSNR
XECUTE BHLDIE
+47 SET BHLFLD=1105
SET BHLVAL=BHLBCN
XECUTE BHLDIE
+48 SET BHLFLD=1108
SET BHLVAL=BHLTOM
XECUTE BHLDIE
+49 SET BHLFLD=1109
SET BHLVAL=BHLTQ
XECUTE BHLDIE
+50 SET BHLFLD=1110
SET BHLVAL=BHLIBQ
XECUTE BHLDIE
+51 SET BHLFLD=1111
SET BHLVAL=BHLCB
XECUTE BHLDIE
+52 SET BHLFLD=1113
SET BHLVAL=BHLCRD
XECUTE BHLDIE
+53 SET BHLFLD=1115
SET BHLVAL=BHLSOD
XECUTE BHLDIE
+54 SET BHLFLD=1116
SET BHLVAL=BHLDCN
XECUTE BHLDIE
+55 SET BHLFLD=1117
SET BHLVAL=BHLCC
XECUTE BHLDIE
+56 SET BHLFLD=1119
SET BHLVAL=BHLTMVF
XECUTE BHLDIE
+57 SET BHLFLD=1121
SET BHLVAL=BHLRVF
XECUTE BHLDIE
+58 SET BHLFLD=1123
SET BHLVAL=BHLDED
XECUTE BHLDIE
+59 SET BHLFLD=1125
SET BHLVAL=BHLEMC
XECUTE BHLDIE
+60 SET BHLFLD=2602
SET BHLVAL=BHLFBPC
XECUTE BHLDIE
+61 SET BHLFLD=2603
SET BHLVAL=BHLFBPS
XECUTE BHLDIE
+62 SET BHLFLD=2605
SET BHLVAL=BHLMBPC
XECUTE BHLDIE
+63 SET BHLFLD=2606
SET BHLVAL=BHLMBPS
XECUTE BHLDIE
+64 SET BHLFL=2
+65 SET BHLFLD=.092
SET BHLVAL=BHLBPC
XECUTE BHLDIE
+66 SET BHLFLD=.093
SET BHLVAL=BHLBPS
XECUTE BHLDIE
+67 SET BHLFLD=2401
SET BHLVAL=BHLFN
XECUTE BHLDIE
+68 QUIT
+69 ;
REGUP ;EP - update registration dates call from BHLPIDI if no ZP2 seg
+1 NEW BHLFL
+2 SET BHLFL=9000001
SET BHLX=BHLPAT
+3 SET BHLDLU=DT
SET BHLDLRU=DT
+4 SET BHLFLD=.03
SET BHLVAL=BHLDLRU
XECUTE BHLDIE
+5 SET BHLFLD=.16
SET BHLVAL=BHLDLU
XECUTE BHLDIE
+6 QUIT
+7 ;
EOJ ;-- kill variables
+1 KILL @BHLTMP
+2 KILL BHLDE,BHLDLRU,BHLMRRD,BHLMRVD,BHLTEN,BHLCHS,BHLBT,BHLDLU,BHLABOD
+3 KILL BHLABED,BHLSSN,BHLSSNR,BHLBPC,BHLBPS,BHLBCN,BHLTOM,BHLTQ,BHLIBQ
+4 KILL BHLCB,BHLCRD,BHLSOD,BHLDCN,BHLCC,BHLTMVF,BHLRVF,BHLDED,BHLEMC
+5 KILL BHLFN,BHLFBPC,BHLFBPS,BHLMBPC,BHLMBPS,BHLDA,BHLFLD,BHLFL,BHLVAL
+6 KILL BHLX
+7 QUIT
+8 ;
