source: FOIAVistA/trunk/r/HOSPITAL_BASED_HOME_CARE-HBH/HBHCAPPT.m@ 1783

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