HBHCAPPT ; LR VAMC(IRMS)/MJT-HBHC batch job to create ^HBHC(632) (visit) nodes from PCE module info => patient, appointment date/time, hospital location (clinic), prov, DX code(s), & CPT code(s), calls ^HBHCCAN, HBHCAPP1 ; Jul 2000
;;1.0;HOSPITAL BASED HOME CARE;**6,8,10,12,13,15,16,14**;NOV 01, 1993
; Daily auto-queued option, also called from ^HBHCFILE, HBHCLSDT, last date to include in transmit set up in ^HBHCFILE
D START^HBHCAPP1
SCAN ; Scan
N HBHCQRY
D OPEN^SDQ(.HBHCQRY)
D INDEX^SDQ(.HBHCQRY,"DATE/TIME","SET")
D DATE^SDQ(.HBHCQRY,HBHCBGDT,HBHCLSDT,"SET")
D SCANCB^SDQ(.HBHCQRY,"D CB^HBHCAPPT(Y,Y0,.SDSTOP)","SET")
D ACTIVE^SDQ(.HBHCQRY,"TRUE","SET")
D SCAN^SDQ(.HBHCQRY,"FORWARD")
D CLOSE^SDQ(.HBHCQRY)
I ($D(^HBHC(634.1,"B")))!($D(^HBHC(634.2,"B")))!($D(^HBHC(634.3,"B")))!($D(^HBHC(634.5,"B"))) D MAIL^HBHCAPP1
; Delete File Update in Progress Flag
S $P(^HBHC(631.9,1,0),U,8)=""
EXIT ; Exit module
D EXIT^HBHCAPP1
Q
CB(HBHCOEP,HBHCSCE0,HBHCSTOP) ;
; Omit Child encounter, (child if Parent Encounter field contains data)
Q:$P(HBHCSCE0,U,6)]""
; Quit if invalid status for HBHC purposes
Q:($P(HBHCSCE0,U,12)=4)!($P(HBHCSCE0,U,12)=5)!($P(HBHCSCE0,U,12)=6)!($P(HBHCSCE0,U,12)=7)!($P(HBHCSCE0,U,12)=9)!($P(HBHCSCE0,U,12)=10)!($P(HBHCSCE0,U,12)=11)!($P(HBHCSCE0,U,12)=13)
; Clinic missing
Q:$P(HBHCSCE0,U,4)=""
; Include only HBHC clinics
Q:'$D(^HBHC(631.6,"B",$P(HBHCSCE0,U,4)))
S HBHCCLN=$P(HBHCSCE0,U,4)
D VERIFY I 'HBHCFLG D PROCESS D:$D(HBHCMSG) ERROR^HBHCAPP1
Q
VERIFY ; Verify record doesn't already exist in ^HBHC(632) file
S HBHCFLG=0,HBHCDPT=$P(HBHCSCE0,U,2),HBHCAPDT=$P(HBHCSCE0,U)
I HBHCDPT="" S HBHCFLG=1 Q
S HBHCBXRF=0 F S HBHCBXRF=$O(^HBHC(632,"B",HBHCDPT,HBHCBXRF)) Q:(HBHCBXRF'>0)!(HBHCFLG) S:($D(^HBHC(632,"AE",HBHCOEP)))&(HBHCAPDT=$P(^HBHC(632,HBHCBXRF,0),U,2))&('$D(^HBHC(632,"AC","C",HBHCBXRF))) HBHCFLG=1
Q
PROCESS ; Process provider, diagnosis (DX), & CPT code data
; Dx
K HBHCDXL,HBHCDX
D GETDX^SDOE(HBHCOEP,"HBHCDXL")
S HBHCCNT=1 F HBHCI=1:1:HBHCDXL S HBHCDX(HBHCI)=""
S HBHCDFN=0 F S HBHCDFN=$O(HBHCDXL(HBHCDFN)) Q:(HBHCDFN'>0)!(HBHCCNT>HBHCDXL) S:$P(HBHCDXL(HBHCDFN),U,12)="P" HBHCDX(1)=$P(HBHCDXL(HBHCDFN),U) S:$P(HBHCDXL(HBHCDFN),U,12)="S" HBHCCNT=HBHCCNT+1,HBHCDX(HBHCCNT)=$P(HBHCDXL(HBHCDFN),U)
; Dx missing
I (+$G(HBHCDXL)'>0) S HBHCMSG=3 Q
; provider, use Encounter Provider (field 1204, file 9000010.18) or V Provider (9000010.06) (if encounter provider doesn't exist), each provider within encounter will become a separate HBHC Visit record
K HBHCPRV1,HBHCPRVL
D GETPRV^SDOE(HBHCOEP,"HBHCPRVL")
S (HBHCPCNT,HBHCDFN,HBHCONE)=0 F S HBHCDFN=$O(HBHCPRVL(HBHCDFN)) Q:HBHCDFN'>0 S HBHCPRV=$P(HBHCPRVL(HBHCDFN),U) D CHECK S:HBHCONE=1 HBHCPCNT=HBHCPCNT+1,HBHCPRV1(HBHCPRV)=""
; Provider missing
I (+$G(HBHCPRVL)'>0) S HBHCMSG=2 Q
; HBHC provider missing
I HBHCONE=0 S HBHCMSG=11 Q
; Multiple HBHC provider numbers
I HBHCONE>1 S HBHCMSG=12 Q
; CPT Code
K HBHCCPTL,HBHCPRV
D GETCPT^SDOE(HBHCOEP,"HBHCCPTL")
S (HBHCDFN,HBHCONE)=0 F S HBHCDFN=$O(HBHCCPTL(HBHCDFN)) Q:(HBHCDFN'>0)!($D(HBHCMSG)) S HBHCPRV=$P($G(HBHCCPTL(HBHCDFN,12)),U,4) D:HBHCPRV]"" CHECK S HBHCNBR=$P(HBHCCPTL(HBHCDFN,0),U,16) D PROV
; Provider mismatch
Q:$D(HBHCMSG)
; Provider ambiguous
I $D(HBHCPRV("ZZ")) S HBHCMSG=5 Q
; CPT Code missing
I (+$G(HBHCCPTL)=0) S HBHCMSG=4 Q
; outpatient encounter must have 'checked-out' status (2) to ensure provider, Dx, & CPT data exist, or inpatient status (8)
I ($P(HBHCSCE0,U,12)'=2)&($P(HBHCSCE0,U,12)'=8) S HBHCMSG=1 Q
SET ; Set node, call ^DIK to set cross-refs in ^HBHC(632) (visit) file
S HBHCPRV="" F S HBHCPRV=$O(HBHCPRV(HBHCPRV)) Q:HBHCPRV="" D SETLOOP
Q
SETLOOP ; Set loop
S HBHC="" F S HBHC=$O(^HBHC(631.4,"C",HBHCPRV,HBHC)) Q:(HBHC="")!('$D(^HBHC(631.4,"AC",1,HBHC)))
L +^HBHC(632,0) F S HBHCDFN=$P(^HBHC(632,0),U,3)+1,$P(^HBHC(632,0),U,3)=HBHCDFN Q:'$D(^HBHC(632,HBHCDFN,0))
S $P(^HBHC(632,0),U,4)=$P(^HBHC(632,0),U,4)+1 L -^HBHC(632,0)
L +^HBHC(632,HBHCDFN,2) S HBHCCPT=""
F S HBHCCPT=$O(HBHCPRV(HBHCPRV,HBHCCPT)) Q:HBHCCPT="" S HBHCNBR="" F S HBHCNBR=$O(HBHCPRV(HBHCPRV,HBHCCPT,HBHCNBR)) Q:HBHCNBR="" D SETCPT S HBHCK=0 F S HBHCK=$O(HBHCPRV(HBHCPRV,HBHCCPT,HBHCNBR,HBHCK)) Q:HBHCK'>0 D SETMOD
L -^HBHC(632,HBHCDFN,2)
L +^HBHC(632,HBHCDFN,3) K DD,DO S DIC="^HBHC(632,",DIC(0)="L",DIC("P")=$P(^DD(632,33,0),U,2),DA(1)=HBHCDFN,DIC=DIC_DA(1)_",3,",HBHCI="" F S HBHCI=$O(HBHCDX(HBHCI)) Q:HBHCI="" S X=HBHCDX(HBHCI) D FILE^DICN
L -^HBHC(632,HBHCDFN,3)
L +^HBHC(632,HBHCDFN,0) S ^HBHC(632,HBHCDFN,0)=HBHCDPT_U_HBHCAPDT_U_HBHCCLN_U_HBHC_U_U_U_U_"N"_U_U_U_U_U_U_U_U_U_U_U_U_U_U_HBHCOEP L -^HBHC(632,HBHCDFN,0)
K DIK S DIK="^HBHC(632,",DA=HBHCDFN D IX^DIK K DIK
Q
CHECK ; Check to ensure provider only has 1 HBHC Provider Number (631.4) or if > 1, has others flagged as Inactive Provider Numbers
S (HBHCONE,HBHCIEN)=0 F S HBHCIEN=$O(^HBHC(631.4,"C",HBHCPRV,HBHCIEN)) Q:(HBHCIEN'>0)!(HBHCONE>1) S:'$D(^HBHC(631.4,"AC",1,HBHCIEN)) HBHCONE=HBHCONE+1
Q
PROV ; Encounter provider & CPT code processing
S:HBHCPCNT=1 HBHCTXT="",HBHCTXT=$O(HBHCPRV1(HBHCTXT))
F HBHCJ=1:1:HBHCNBR D:HBHCPRV="" SUB1 D:HBHCPRV]"" SUB2
Q
SUB1 ; Subroutine 1 for encounter provider & CPT code processing
S HBHCPRV($S(HBHCPCNT=1:HBHCTXT,1:"ZZ"),$P(HBHCCPTL(HBHCDFN,0),U),HBHCJ)=""
S HBHCK=0 F S HBHCK=$O(HBHCCPTL(HBHCDFN,1,HBHCK)) Q:HBHCK'>0 S HBHCPRV($S(HBHCPCNT=1:HBHCTXT,1:"ZZ"),$P(HBHCCPTL(HBHCDFN,0),U),HBHCJ,HBHCK)=HBHCCPTL(HBHCDFN,1,HBHCK,0)
Q
SUB2 ; Subroutine 2 for encounter provider & CPT code processing
I (HBHCONE=1)&($D(HBHCPRV1(HBHCPRV))) S HBHCPRV(HBHCPRV,$P(HBHCCPTL(HBHCDFN,0),U),HBHCJ)="",HBHCK=0 F S HBHCK=$O(HBHCCPTL(HBHCDFN,1,HBHCK)) Q:HBHCK'>0 S HBHCPRV(HBHCPRV,$P(HBHCCPTL(HBHCDFN,0),U),HBHCJ,HBHCK)=HBHCCPTL(HBHCDFN,1,HBHCK,0)
S:'$D(HBHCPRV1(HBHCPRV)) HBHCMSG=13
Q
SETCPT ; Set CPT multiple
K DD,DO S DIC="^HBHC(632,",DIC(0)="L",DIC("P")=$P(^DD(632,32,0),U,2),DA(1)=HBHCDFN,X=HBHCCPT,DIC=DIC_DA(1)_",2," D FILE^DICN
; Set up for CPT Modifier update
S DA=+Y,DA(2)=DA(1),DA(1)=DA
K DD,DO S DIC("P")=$P(^DD(632.032,1,0),U,2),DIC=DIC_DA_",1,"
Q
SETMOD ; Set CPT Modifier multiple
S X=HBHCPRV(HBHCPRV,HBHCCPT,HBHCNBR,HBHCK) D FILE^DICN S DA=+Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCAPPT 6301 printed Sep 23, 2025@19:34:01 Page 2
HBHCAPPT ; LR VAMC(IRMS)/MJT-HBHC batch job to create ^HBHC(632) (visit) nodes from PCE module info => patient, appointment date/time, hospital location (clinic), prov, DX code(s), & CPT code(s), calls ^HBHCCAN, HBHCAPP1 ; Jul 2000
+1 ;;1.0;HOSPITAL BASED HOME CARE;**6,8,10,12,13,15,16,14**;NOV 01, 1993
+2 ; Daily auto-queued option, also called from ^HBHCFILE, HBHCLSDT, last date to include in transmit set up in ^HBHCFILE
+3 DO START^HBHCAPP1
SCAN ; Scan
+1 NEW HBHCQRY
+2 DO OPEN^SDQ(.HBHCQRY)
+3 DO INDEX^SDQ(.HBHCQRY,"DATE/TIME","SET")
+4 DO DATE^SDQ(.HBHCQRY,HBHCBGDT,HBHCLSDT,"SET")
+5 DO SCANCB^SDQ(.HBHCQRY,"D CB^HBHCAPPT(Y,Y0,.SDSTOP)","SET")
+6 DO ACTIVE^SDQ(.HBHCQRY,"TRUE","SET")
+7 DO SCAN^SDQ(.HBHCQRY,"FORWARD")
+8 DO CLOSE^SDQ(.HBHCQRY)
+9 IF ($DATA(^HBHC(634.1,"B")))!($DATA(^HBHC(634.2,"B")))!($DATA(^HBHC(634.3,"B")))!($DATA(^HBHC(634.5,"B")))
DO MAIL^HBHCAPP1
+10 ; Delete File Update in Progress Flag
+11 SET $PIECE(^HBHC(631.9,1,0),U,8)=""
EXIT ; Exit module
+1 DO EXIT^HBHCAPP1
+2 QUIT
CB(HBHCOEP,HBHCSCE0,HBHCSTOP) ;
+1 ; Omit Child encounter, (child if Parent Encounter field contains data)
+2 if $PIECE(HBHCSCE0,U,6)]""
QUIT
+3 ; Quit if invalid status for HBHC purposes
+4 if ($PIECE(HBHCSCE0,U,12)=4)!($PIECE(HBHCSCE0,U,12)=5)!($PIECE(HBHCSCE0,U,12)=6)!($PIECE(HBHCSCE0,U,12)=7)!($PIECE(HBHCSCE0,U,12)=9)!($PIECE(HBHCSCE0,U,12)=10)!($PIECE(HBHCSCE0,U,12)=11)!($PIECE(HBHCSCE0,U,12)=13)
QUIT
+5 ; Clinic missing
+6 if $PIECE(HBHCSCE0,U,4)=""
QUIT
+7 ; Include only HBHC clinics
+8 if '$DATA(^HBHC(631.6,"B",$PIECE(HBHCSCE0,U,4)))
QUIT
+9 SET HBHCCLN=$PIECE(HBHCSCE0,U,4)
+10 DO VERIFY
IF 'HBHCFLG
DO PROCESS
if $DATA(HBHCMSG)
DO ERROR^HBHCAPP1
+11 QUIT
VERIFY ; Verify record doesn't already exist in ^HBHC(632) file
+1 SET HBHCFLG=0
SET HBHCDPT=$PIECE(HBHCSCE0,U,2)
SET HBHCAPDT=$PIECE(HBHCSCE0,U)
+2 IF HBHCDPT=""
SET HBHCFLG=1
QUIT
+3 SET HBHCBXRF=0
FOR
SET HBHCBXRF=$ORDER(^HBHC(632,"B",HBHCDPT,HBHCBXRF))
if (HBHCBXRF'>0)!(HBHCFLG)
QUIT
if ($DATA(^HBHC(632,"AE",HBHCOEP)))&(HBHCAPDT=$PIECE(^HBHC(632,HBHCBXRF,0),U,2))&('$DATA(^HBHC(632,"AC","C",HBHCBXRF)))
SET HBHCFLG=1
+4 QUIT
PROCESS ; Process provider, diagnosis (DX), & CPT code data
+1 ; Dx
+2 KILL HBHCDXL,HBHCDX
+3 DO GETDX^SDOE(HBHCOEP,"HBHCDXL")
+4 SET HBHCCNT=1
FOR HBHCI=1:1:HBHCDXL
SET HBHCDX(HBHCI)=""
+5 SET HBHCDFN=0
FOR
SET HBHCDFN=$ORDER(HBHCDXL(HBHCDFN))
if (HBHCDFN'>0)!(HBHCCNT>HBHCDXL)
QUIT
if $PIECE(HBHCDXL(HBHCDFN),U,12)="P"
SET HBHCDX(1)=$PIECE(HBHCDXL(HBHCDFN),U)
if $PIECE(HBHCDXL(HBHCDFN),U,12)="S"
SET HBHCCNT=HBHCCNT+1
SET HBHCDX(HBHCCNT)=$PIECE(HBHCDXL(HBHCDFN),U)
+6 ; Dx missing
+7 IF (+$GET(HBHCDXL)'>0)
SET HBHCMSG=3
QUIT
+8 ; provider, use Encounter Provider (field 1204, file 9000010.18) or V Provider (9000010.06) (if encounter provider doesn't exist), each provider within encounter will become a separate HBHC Visit record
+9 KILL HBHCPRV1,HBHCPRVL
+10 DO GETPRV^SDOE(HBHCOEP,"HBHCPRVL")
+11 SET (HBHCPCNT,HBHCDFN,HBHCONE)=0
FOR
SET HBHCDFN=$ORDER(HBHCPRVL(HBHCDFN))
if HBHCDFN'>0
QUIT
SET HBHCPRV=$PIECE(HBHCPRVL(HBHCDFN),U)
DO CHECK
if HBHCONE=1
SET HBHCPCNT=HBHCPCNT+1
SET HBHCPRV1(HBHCPRV)=""
+12 ; Provider missing
+13 IF (+$GET(HBHCPRVL)'>0)
SET HBHCMSG=2
QUIT
+14 ; HBHC provider missing
+15 IF HBHCONE=0
SET HBHCMSG=11
QUIT
+16 ; Multiple HBHC provider numbers
+17 IF HBHCONE>1
SET HBHCMSG=12
QUIT
+18 ; CPT Code
+19 KILL HBHCCPTL,HBHCPRV
+20 DO GETCPT^SDOE(HBHCOEP,"HBHCCPTL")
+21 SET (HBHCDFN,HBHCONE)=0
FOR
SET HBHCDFN=$ORDER(HBHCCPTL(HBHCDFN))
if (HBHCDFN'>0)!($DATA(HBHCMSG))
QUIT
SET HBHCPRV=$PIECE($GET(HBHCCPTL(HBHCDFN,12)),U,4)
if HBHCPRV]""
DO CHECK
SET HBHCNBR=$PIECE(HBHCCPTL(HBHCDFN,0),U,16)
DO PROV
+22 ; Provider mismatch
+23 if $DATA(HBHCMSG)
QUIT
+24 ; Provider ambiguous
+25 IF $DATA(HBHCPRV("ZZ"))
SET HBHCMSG=5
QUIT
+26 ; CPT Code missing
+27 IF (+$GET(HBHCCPTL)=0)
SET HBHCMSG=4
QUIT
+28 ; outpatient encounter must have 'checked-out' status (2) to ensure provider, Dx, & CPT data exist, or inpatient status (8)
+29 IF ($PIECE(HBHCSCE0,U,12)'=2)&($PIECE(HBHCSCE0,U,12)'=8)
SET HBHCMSG=1
QUIT
SET ; Set node, call ^DIK to set cross-refs in ^HBHC(632) (visit) file
+1 SET HBHCPRV=""
FOR
SET HBHCPRV=$ORDER(HBHCPRV(HBHCPRV))
if HBHCPRV=""
QUIT
DO SETLOOP
+2 QUIT
SETLOOP ; Set loop
+1 SET HBHC=""
FOR
SET HBHC=$ORDER(^HBHC(631.4,"C",HBHCPRV,HBHC))
if (HBHC="")!('$DATA(^HBHC(631.4,"AC",1,HBHC)))
QUIT
+2 LOCK +^HBHC(632,0)
FOR
SET HBHCDFN=$PIECE(^HBHC(632,0),U,3)+1
SET $PIECE(^HBHC(632,0),U,3)=HBHCDFN
if '$DATA(^HBHC(632,HBHCDFN,0))
QUIT
+3 SET $PIECE(^HBHC(632,0),U,4)=$PIECE(^HBHC(632,0),U,4)+1
LOCK -^HBHC(632,0)
+4 LOCK +^HBHC(632,HBHCDFN,2)
SET HBHCCPT=""
+5 FOR
SET HBHCCPT=$ORDER(HBHCPRV(HBHCPRV,HBHCCPT))
if HBHCCPT=""
QUIT
SET HBHCNBR=""
FOR
SET HBHCNBR=$ORDER(HBHCPRV(HBHCPRV,HBHCCPT,HBHCNBR))
if HBHCNBR=""
QUIT
DO SETCPT
SET HBHCK=0
FOR
SET HBHCK=$ORDER(HBHCPRV(HBHCPRV,HBHCCPT,HBHCNBR,HBHCK))
if HBHCK'>0
QUIT
DO SETMOD
+6 LOCK -^HBHC(632,HBHCDFN,2)
+7 LOCK +^HBHC(632,HBHCDFN,3)
KILL DD,DO
SET DIC="^HBHC(632,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(632,33,0),U,2)
SET DA(1)=HBHCDFN
SET DIC=DIC_DA(1)_",3,"
SET HBHCI=""
FOR
SET HBHCI=$ORDER(HBHCDX(HBHCI))
if HBHCI=""
QUIT
SET X=HBHCDX(HBHCI)
DO FILE^DICN
+8 LOCK -^HBHC(632,HBHCDFN,3)
+9 LOCK +^HBHC(632,HBHCDFN,0)
SET ^HBHC(632,HBHCDFN,0)=HBHCDPT_U_HBHCAPDT_U_HBHCCLN_U_HBHC_U_U_U_U_"N"_U_U_U_U_U_U_U_U_U_U_U_U_U_U_HBHCOEP
LOCK -^HBHC(632,HBHCDFN,0)
+10 KILL DIK
SET DIK="^HBHC(632,"
SET DA=HBHCDFN
DO IX^DIK
KILL DIK
+11 QUIT
CHECK ; Check to ensure provider only has 1 HBHC Provider Number (631.4) or if > 1, has others flagged as Inactive Provider Numbers
+1 SET (HBHCONE,HBHCIEN)=0
FOR
SET HBHCIEN=$ORDER(^HBHC(631.4,"C",HBHCPRV,HBHCIEN))
if (HBHCIEN'>0)!(HBHCONE>1)
QUIT
if '$DATA(^HBHC(631.4,"AC",1,HBHCIEN))
SET HBHCONE=HBHCONE+1
+2 QUIT
PROV ; Encounter provider & CPT code processing
+1 if HBHCPCNT=1
SET HBHCTXT=""
SET HBHCTXT=$ORDER(HBHCPRV1(HBHCTXT))
+2 FOR HBHCJ=1:1:HBHCNBR
if HBHCPRV=""
DO SUB1
if HBHCPRV]""
DO SUB2
+3 QUIT
SUB1 ; Subroutine 1 for encounter provider & CPT code processing
+1 SET HBHCPRV($SELECT(HBHCPCNT=1:HBHCTXT,1:"ZZ"),$PIECE(HBHCCPTL(HBHCDFN,0),U),HBHCJ)=""
+2 SET HBHCK=0
FOR
SET HBHCK=$ORDER(HBHCCPTL(HBHCDFN,1,HBHCK))
if HBHCK'>0
QUIT
SET HBHCPRV($SELECT(HBHCPCNT=1:HBHCTXT,1:"ZZ"),$PIECE(HBHCCPTL(HBHCDFN,0),U),HBHCJ,HBHCK)=HBHCCPTL(HBHCDFN,1,HBHCK,0)
+3 QUIT
SUB2 ; Subroutine 2 for encounter provider & CPT code processing
+1 IF (HBHCONE=1)&($DATA(HBHCPRV1(HBHCPRV)))
SET HBHCPRV(HBHCPRV,$PIECE(HBHCCPTL(HBHCDFN,0),U),HBHCJ)=""
SET HBHCK=0
FOR
SET HBHCK=$ORDER(HBHCCPTL(HBHCDFN,1,HBHCK))
if HBHCK'>0
QUIT
SET HBHCPRV(HBHCPRV,$PIECE(HBHCCPTL(HBHCDFN,0),U),HBHCJ,HBHCK)=HBHCCPTL(HBHCDFN,1,HBHCK,0)
+2 if '$DATA(HBHCPRV1(HBHCPRV))
SET HBHCMSG=13
+3 QUIT
SETCPT ; Set CPT multiple
+1 KILL DD,DO
SET DIC="^HBHC(632,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(632,32,0),U,2)
SET DA(1)=HBHCDFN
SET X=HBHCCPT
SET DIC=DIC_DA(1)_",2,"
DO FILE^DICN
+2 ; Set up for CPT Modifier update
+3 SET DA=+Y
SET DA(2)=DA(1)
SET DA(1)=DA
+4 KILL DD,DO
SET DIC("P")=$PIECE(^DD(632.032,1,0),U,2)
SET DIC=DIC_DA_",1,"
+5 QUIT
SETMOD ; Set CPT Modifier multiple
+1 SET X=HBHCPRV(HBHCPRV,HBHCCPT,HBHCNBR,HBHCK)
DO FILE^DICN
SET DA=+Y
+2 QUIT
