- 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 Feb 18, 2025@23:24:22 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