Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HBHCAPPT

HBHCAPPT.m

Go to the documentation of this file.
  1. 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
  1. ; Daily auto-queued option, also called from ^HBHCFILE, HBHCLSDT, last date to include in transmit set up in ^HBHCFILE
  1. D START^HBHCAPP1
  1. SCAN ; Scan
  1. N HBHCQRY
  1. D OPEN^SDQ(.HBHCQRY)
  1. D INDEX^SDQ(.HBHCQRY,"DATE/TIME","SET")
  1. D DATE^SDQ(.HBHCQRY,HBHCBGDT,HBHCLSDT,"SET")
  1. D SCANCB^SDQ(.HBHCQRY,"D CB^HBHCAPPT(Y,Y0,.SDSTOP)","SET")
  1. D ACTIVE^SDQ(.HBHCQRY,"TRUE","SET")
  1. D SCAN^SDQ(.HBHCQRY,"FORWARD")
  1. D CLOSE^SDQ(.HBHCQRY)
  1. I ($D(^HBHC(634.1,"B")))!($D(^HBHC(634.2,"B")))!($D(^HBHC(634.3,"B")))!($D(^HBHC(634.5,"B"))) D MAIL^HBHCAPP1
  1. ; Delete File Update in Progress Flag
  1. S $P(^HBHC(631.9,1,0),U,8)=""
  1. EXIT ; Exit module
  1. D EXIT^HBHCAPP1
  1. Q
  1. CB(HBHCOEP,HBHCSCE0,HBHCSTOP) ;
  1. ; Omit Child encounter, (child if Parent Encounter field contains data)
  1. Q:$P(HBHCSCE0,U,6)]""
  1. ; Quit if invalid status for HBHC purposes
  1. 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)
  1. ; Clinic missing
  1. Q:$P(HBHCSCE0,U,4)=""
  1. ; Include only HBHC clinics
  1. Q:'$D(^HBHC(631.6,"B",$P(HBHCSCE0,U,4)))
  1. S HBHCCLN=$P(HBHCSCE0,U,4)
  1. D VERIFY I 'HBHCFLG D PROCESS D:$D(HBHCMSG) ERROR^HBHCAPP1
  1. Q
  1. VERIFY ; Verify record doesn't already exist in ^HBHC(632) file
  1. S HBHCFLG=0,HBHCDPT=$P(HBHCSCE0,U,2),HBHCAPDT=$P(HBHCSCE0,U)
  1. I HBHCDPT="" S HBHCFLG=1 Q
  1. 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
  1. Q
  1. PROCESS ; Process provider, diagnosis (DX), & CPT code data
  1. ; Dx
  1. K HBHCDXL,HBHCDX
  1. D GETDX^SDOE(HBHCOEP,"HBHCDXL")
  1. S HBHCCNT=1 F HBHCI=1:1:HBHCDXL S HBHCDX(HBHCI)=""
  1. 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)
  1. ; Dx missing
  1. I (+$G(HBHCDXL)'>0) S HBHCMSG=3 Q
  1. ; 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
  1. K HBHCPRV1,HBHCPRVL
  1. D GETPRV^SDOE(HBHCOEP,"HBHCPRVL")
  1. 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)=""
  1. ; Provider missing
  1. I (+$G(HBHCPRVL)'>0) S HBHCMSG=2 Q
  1. ; HBHC provider missing
  1. I HBHCONE=0 S HBHCMSG=11 Q
  1. ; Multiple HBHC provider numbers
  1. I HBHCONE>1 S HBHCMSG=12 Q
  1. ; CPT Code
  1. K HBHCCPTL,HBHCPRV
  1. D GETCPT^SDOE(HBHCOEP,"HBHCCPTL")
  1. 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
  1. ; Provider mismatch
  1. Q:$D(HBHCMSG)
  1. ; Provider ambiguous
  1. I $D(HBHCPRV("ZZ")) S HBHCMSG=5 Q
  1. ; CPT Code missing
  1. I (+$G(HBHCCPTL)=0) S HBHCMSG=4 Q
  1. ; outpatient encounter must have 'checked-out' status (2) to ensure provider, Dx, & CPT data exist, or inpatient status (8)
  1. I ($P(HBHCSCE0,U,12)'=2)&($P(HBHCSCE0,U,12)'=8) S HBHCMSG=1 Q
  1. SET ; Set node, call ^DIK to set cross-refs in ^HBHC(632) (visit) file
  1. S HBHCPRV="" F S HBHCPRV=$O(HBHCPRV(HBHCPRV)) Q:HBHCPRV="" D SETLOOP
  1. Q
  1. SETLOOP ; Set loop
  1. S HBHC="" F S HBHC=$O(^HBHC(631.4,"C",HBHCPRV,HBHC)) Q:(HBHC="")!('$D(^HBHC(631.4,"AC",1,HBHC)))
  1. 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))
  1. S $P(^HBHC(632,0),U,4)=$P(^HBHC(632,0),U,4)+1 L -^HBHC(632,0)
  1. L +^HBHC(632,HBHCDFN,2) S HBHCCPT=""
  1. 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
  1. L -^HBHC(632,HBHCDFN,2)
  1. 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
  1. L -^HBHC(632,HBHCDFN,3)
  1. 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)
  1. K DIK S DIK="^HBHC(632,",DA=HBHCDFN D IX^DIK K DIK
  1. Q
  1. CHECK ; Check to ensure provider only has 1 HBHC Provider Number (631.4) or if > 1, has others flagged as Inactive Provider Numbers
  1. 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
  1. Q
  1. PROV ; Encounter provider & CPT code processing
  1. S:HBHCPCNT=1 HBHCTXT="",HBHCTXT=$O(HBHCPRV1(HBHCTXT))
  1. F HBHCJ=1:1:HBHCNBR D:HBHCPRV="" SUB1 D:HBHCPRV]"" SUB2
  1. Q
  1. SUB1 ; Subroutine 1 for encounter provider & CPT code processing
  1. S HBHCPRV($S(HBHCPCNT=1:HBHCTXT,1:"ZZ"),$P(HBHCCPTL(HBHCDFN,0),U),HBHCJ)=""
  1. 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)
  1. Q
  1. SUB2 ; Subroutine 2 for encounter provider & CPT code processing
  1. 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)
  1. S:'$D(HBHCPRV1(HBHCPRV)) HBHCMSG=13
  1. Q
  1. SETCPT ; Set CPT multiple
  1. 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
  1. ; Set up for CPT Modifier update
  1. S DA=+Y,DA(2)=DA(1),DA(1)=DA
  1. K DD,DO S DIC("P")=$P(^DD(632.032,1,0),U,2),DIC=DIC_DA_",1,"
  1. Q
  1. SETMOD ; Set CPT Modifier multiple
  1. S X=HBHCPRV(HBHCPRV,HBHCCPT,HBHCNBR,HBHCK) D FILE^DICN S DA=+Y
  1. Q