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

HBHCUPD.m

Go to the documentation of this file.
  1. HBHCUPD ;LR VAMC(IRMS)/MJT - HBHC update missing data in ^HBHC(631) using ^HBHC(634.1) & ^HBHC(634.3) as input for which records/fields to update, HBHC(634.2 errors must be corrected using PCE, 634.2 data killed @ end of processing ;3/18/14
  1. ;;1.0;HOSPITAL BASED HOME CARE;**2,6,8,10,24,25**;NOV 01, 1993;Build 45
  1. ; HBHC(634.7 MFH errors must be corrected using MFH option, 634.7 killed here so validity processing can occur again
  1. ;
  1. ; Reference to $$SINFO^ICDEX supported by ICR #5747
  1. ; $$SINFO^ICDEX is also called from the [HBHC UPDATE DISCHARGE] input template
  1. ;
  1. I $P($G(^HBHC(631.9,1,0)),U,9)]"" K ^HBHC(634.7) S ^HBHC(634.7,0)="HBHC MEDICAL FOSTER HOME ERROR(S)^634.7P"
  1. I ('$D(^HBHC(634.1,"B")))&($D(^HBHC(634.2,"B")))&('$D(^HBHC(634.3,"B")))&('$D(^HBHC(634.5,"B"))) D PCEMSG^HBHCUTL3 S HBHCFLAG=1 G PSEUDO
  1. PROMPT ; Prompt user for patient name
  1. W ! K DIC S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC
  1. G:Y=-1 PSEUDO
  1. S HBHCDPT=+Y
  1. I ('$D(^HBHC(634.1,"B",HBHCDPT)))&('$D(^HBHC(634.2,"B",HBHCDPT)))&('$D(^HBHC(634.3,"B",HBHCDPT)))&('$D(^HBHC(634.5,"B",HBHCDPT))) W $C(7),!!,"This patient has no records containing errors on file.",! H 3 G PROMPT
  1. F HBHCFILE=634.1,634.3 I $D(^HBHC(HBHCFILE,"B",HBHCDPT)) K DR S HBHCFORM=$S(HBHCFILE=634.1:3,1:5) S:HBHCFORM=5 HBHCCNT=1 S HBHCIEN="" F S HBHCIEN=$O(^HBHC(HBHCFILE,"B",HBHCDPT,HBHCIEN)) Q:HBHCIEN="" D PROCESS
  1. G PROMPT
  1. PSEUDO ; Process pseudo SSN message
  1. I '$D(HBHCFLAG) D:$D(^HBHC(634.2,"B")) PCEMSG^HBHCUTL3
  1. I $D(^HBHC(634.5,"B")) D PSEUDO^HBHCUTL3 K ^HBHC(634.5) S ^HBHC(634.5,0)="HBHC PSEUDO SSN ERROR(S)^634.5P^"
  1. EXIT ; Exit module
  1. ; HBHC(634.2 visit errors must be corrected using PCE software, 634.2 killed here so validity processing can occur again
  1. K ^HBHC(634.2) S ^HBHC(634.2,0)="HBHC VISIT ERROR(S)^634.2P^"
  1. K DA,DIC,DIE,DIK,DR,HBHC,HBHC12,HBHC359,HBHCAFLG,HBHCCNT,HBHCCOLM,HBHCDATE,HBHCDFLG,HBHCDFN,HBHCDIED,HBHCDPT,HBHCDR,HBHCDT,HBHCFILE,HBHCFLAG,HBHCFLG,HBHCFORM,HBHCI,HBHCIEN,HBHCJ,HBHCKEEP,HBHCL,HBHCM,HBHCMSG,HBHCNOD1,HBHCPC,HBHCQ
  1. K HBHCQ1,HBHCRFLG,HBHCSUB,HBHCTFLG,HBHCTXT,HBHCUPD,HBHCWRD1,HBHCWRD2,HBHCWRD3,HBHCY0,Y
  1. Q
  1. PROCESS ; Process errors via DIE
  1. N HBHCDRA,HBHCDRD,HBHC39,HBHC46
  1. S HBHCDRA="" ;Test for ICD-9 second ^DIE call
  1. S DA=$P(^HBHC(HBHCFILE,HBHCIEN,0),U,2),HBHCTXT=$S(HBHCFORM=3:"Evaluation/Admission",1:"Discharge")
  1. L +^HBHC(631,DA):0 I '$T W $C(7),!!,"Another user is editing this "_HBHCTXT_" entry.",! H 3 Q
  1. ; If Pri DX @ Admission (#18) call DXCHKA to adjust for ICD-9/ICD-10
  1. I HBHCFORM=3 D
  1. .S (DR,HBHCDR)=^HBHC(HBHCFILE,HBHCIEN,1)
  1. .I DR["18;" D DXCHKA1(DA)
  1. ; For Discharges check for #39 and/or #46
  1. I HBHCFORM=5 D
  1. .; Call DXCHKD1 now to update the necessary fields in the Global which is indexed sequentially
  1. .; and adjust DR string;
  1. .; If DISCHARGE DATE #39 AND PRI DX @ DISCHARGE #46 are being edited, #46 and all remaining fields
  1. .; will be saved off in HBHCDRD and prompted for in second ^DIE call after #39 was edited in first ^DIE call
  1. .D DXCHKD1(DA,HBHCIEN)
  1. .S HBHCSUB=0
  1. .; Load fields to be edited from #634.3 into DR array
  1. .F S HBHCSUB=$O(^HBHC(HBHCFILE,HBHCIEN,HBHCSUB)) Q:HBHCSUB'>0 D SET
  1. K DIE S DIE="^HBHC(631,",DIE("NO^")="OUTOK"
  1. S HBHC=HBHCIEN,HBHCPC=$S(HBHCFORM=5:40,1:18),HBHCCOLM=$S(HBHCFORM=3:14,1:19)
  1. S HBHCDT=$P($G(^HBHC(631,DA,0)),U,HBHCPC) S:HBHCDT="" HBHCDT=$P($G(^HBHC(631,DA,0)),U,2) S HBHCDATE=$S(HBHCDT]"":$E(HBHCDT,4,5)_"-"_$E(HBHCDT,6,7)_"-"_$E(HBHCDT,2,3),1:"")
  1. W !!!?HBHCCOLM,"=== Editing "_$S(HBHCDATE]"":HBHCDATE_" "_HBHCTXT,1:HBHCTXT)_" data ===",!
  1. D ^DIE K DR,ICDVDT,ICDSYS,ICDFMT,HBHCDFN
  1. ; Admissions - Check for second ^DIE call to process #18
  1. I HBHCFORM=3,HBHCDRA'="" D
  1. .; Load remaining Admissions fields into DR
  1. .D DXCHKA2(DA)
  1. .K DIE S DIE="^HBHC(631,",DIE("NO^")="OUTOK"
  1. .D ^DIE
  1. .K DR,ICDVDT,ICDSYS,ICDFMT,HBHCDFN
  1. ; Discharges - Check for second ^DIE call to process #46
  1. I HBHCFORM=5,$D(HBHCDRD)=10 D
  1. .; Load remaining Discharge fields into DR
  1. .D DXCHKD2(DA)
  1. .K DIE S DIE="^HBHC(631,",DIE("NO^")="OUTOK"
  1. .D ^DIE
  1. .K DR,ICDVDT,ICDSYS,ICDFMT
  1. ; Admit/Reject Action branch
  1. S:HBHCDR["14;" DR="K HBHCQ;S X=$P(^HBHC(631,DA,0),U,15);D ACTION^HBHCUTL;15;16;I $D(HBHCQ) K HBHCQ S Y=17;"_$S($$ICD^HBHCUPD:"18:36",1:"D ADMDX^HBHCLKU1;19:36")
  1. ; Discharge Status branch
  1. S:HBHCDR["43;" DR="[HBHC UPDATE DISCHARGE]"
  1. I $D(DR) I '$D(Y) I (DR["D ACTION")!(DR["[HBHC UPDATE") S HBHCDFN=DA,HBHCUPD=1 D ^DIE K HBHCUPD
  1. L -^HBHC(631,DA) I '$D(HBHCKEEP) I '$D(Y) K DIK S DIK="^HBHC(HBHCFILE,",DA=HBHC D ^DIK K HBHCKEEP
  1. Q
  1. SET ; Set DR string(s) for Discharge data
  1. S:$D(DR) DR(1,631,HBHCCNT)=^HBHC(HBHCFILE,HBHCIEN,HBHCSUB),HBHCCNT=HBHCCNT+1
  1. S:'$D(DR) (DR,HBHCDR)=^HBHC(HBHCFILE,HBHCIEN,HBHCSUB)
  1. Q
  1. ICD() ;
  1. ; Set ICDVDT based on whether process Admission or Discharge
  1. S ICDVDT=$S(HBHCDR["14;":$P(^HBHC(631,DA,0),U,18),1:$P(^HBHC(631,DA,0),U,40))
  1. S ICDSYS=+$$SINFO^ICDEX("DIAG",ICDVDT)
  1. I ICDSYS=1 S ICDFMT=1
  1. Q $S(ICDSYS=1:1,1:0)
  1. ;
  1. DXCHKA1(DA) ; Admissions - Check for DX codes and adjust DR as needed for first ^DIE call
  1. N HBHCFND,HBHCIDX
  1. S HBHCFND=0
  1. ; If no DATE field, Determine if 9 or 10 lookup needed based on current value in DATE
  1. I DR'["17;" D Q
  1. .D GETDT(DA)
  1. .I ICDSYS=1 Q
  1. .F HBHCIDX=1:1 Q:$P(DR,";",HBHCIDX)="" D Q:HBHCFND
  1. ..Q:$P(DR,";",HBHCIDX)'=18
  1. ..S $P(DR,";",HBHCIDX)="D ADMDX^HBHCLKU1",HBHCDFN=DA,HBHCFND=1
  1. ; If DATE field included, break DR into 2 separate calls
  1. S HBHCDRA=$P(DR,"17;",2)_";"
  1. S DR=$P(DR,"17;",1)_"17;"
  1. Q
  1. ;
  1. DXCHKA2(DA) ; Admissions - adjust DR as needed for second ^DIE call
  1. N HBHCFND,HBHCIDX
  1. ; Get current DATE to use for Date of Interest
  1. D GETDT(DA)
  1. ; For ICD-9 era records use FileMan
  1. I ICDSYS=1 S DR=HBHCDRA Q
  1. ; For ICD-10 era records use ADMDX^HBHCLKU1
  1. F HBHCIDX=1:1 Q:$P(HBHCDRA,";",HBHCIDX)="" D Q:HBHCFND
  1. .Q:$P(HBHCDRA,";",HBHCIDX)'="18"
  1. .S $P(HBHCDRA,";",HBHCIDX)="D ADMDX^HBHCLKU1",HBHCDFN=DA,HBHCFND=1,DR=HBHCDRA
  1. Q
  1. ;
  1. DXCHKD1(DA,HBHCIEN) ; Discharges - Check for DX codes as adjust as needed for first ^DIE call
  1. ; DA = #631 IEN
  1. ; HBHCIEN = #634.3 IEN
  1. ; Loop through DR looking for DISCHARGE DATE #39 & PRI DX @ DISCHARGE (#46).
  1. ; Fields are stored in numerical sequence so if DISCHARGE DATE (#39) is defined, it will be processed first
  1. N HBHCCNT,HBHCDATA,HBHCIDX1,HBHCIDX2
  1. S HBHCCNT=0,(HBHC39,HBHC46)=""
  1. F S HBHCCNT=$O(^HBHC(634.3,HBHCIEN,HBHCCNT)) Q:'HBHCCNT!((HBHC39'="")&(HBHC46'="")) D
  1. .S HBHCDATA=^HBHC(634.3,HBHCIEN,HBHCCNT)
  1. .I HBHCDATA["39;" S HBHC39=$$FNDIT(39,HBHCCNT,HBHCDATA) ; Line^Piece
  1. .; Since the DX @ Discharge can be defaulted, we can't check for 46;
  1. .; Since the DX @ Discharge can be the first field we can't check for ;46 so just check for 46
  1. .I HBHCDATA["46" S HBHC46=$$FNDIT(46,HBHCCNT,HBHCDATA) ; Line^Piece
  1. ; QUIT If neither #39 or #46 are being edited
  1. Q:HBHC39=""&(HBHC46="")
  1. ; QUIT If #39 edited but #46 not edited
  1. Q:HBHC39'=""&(HBHC46="")
  1. ; If no #39 but #46 check date in #39 as adjust as needed
  1. I HBHC39="",HBHC46'="" D Q
  1. .D GETDT(DA)
  1. .; If ICD-9 era data, special lookup vars are now set
  1. .Q:ICDSYS=1
  1. .; If ICD-10 era date update DR to call DCDX^HBHCLKU1
  1. .S $P(^HBHC(634.3,HBHCIEN,$P(HBHC46,U,1)),";",$P(HBHC46,U,2))="D DCDX^HBHCLKU1(DA)"
  1. .Q
  1. ; If #39 & #46 are in the same Node, OR in different Nodes, take everything from #46 to
  1. ; end of Node(s) and store it in HBHCDRD until after #39 is set in first ^DIE call
  1. S HBHCDRD(1,631,$P(HBHC46,U,1))=$P(^HBHC(634.3,HBHCIEN,$P(HBHC46,U,1)),";",$P(HBHC46,U,2),999)
  1. ; Delete everything from #46 to end of ^HBHC node
  1. S ^HBHC(634.3,HBHCIEN,$P(HBHC46,U,1))=$P(^HBHC(634.3,HBHCIEN,$P(HBHC46,U,1)),";",1,$P(HBHC46,U,2)-1)
  1. ; Save off any other Nodes after Node containing #46
  1. F HBHCIDX=$P(HBHC46,U,1)+1:1 Q:'$D(^HBHC(634.3,HBHCIEN,HBHCIDX)) D
  1. .S HBHCDRD(1,631,HBHCIDX)=^HBHC(634.3,HBHCIEN,HBHCIDX)
  1. .; Delete Node in #634.3 prior to first ^DIE call
  1. .K ^HBHC(634.3,HBHCIEN,HBHCIDX)
  1. Q
  1. ;
  1. DXCHKD2(DA) ; Discharges - Load fields in HBHCDRD into DR for second ^DIE call
  1. ; Determine Date of Interest based on current value in #39
  1. D GETDT(DA)
  1. ; For ICD-9 era dates, key DX lookup variables are now set so we just need to reload DR
  1. ; For ICD-10 era dates, update HBHCDRD to call DCDX^HBHCLKU1
  1. I ICDSYS=30 S $P(HBHCDRD(1,631,$P(HBHC46,U,1)),";",1)="D DCDX^HBHCLKU1(DA)"
  1. ; Restore DR from HBHCDRD and re-index to start at 1
  1. S HBHCIDX2=1
  1. F HBHCIDX1=$P(HBHC46,U,1):1 Q:'$D(HBHCDRD(1,631,HBHCIDX1)) D
  1. .S:$D(DR) DR(1,631,HBHCIDX2)=HBHCDRD(1,631,HBHCIDX1),HBHCIDX2=HBHCIDX2+1
  1. .S:'$D(DR) DR=HBHCDRD(1,631,HBHCIDX1)
  1. Q
  1. FNDIT(HBHCFLD,HBHCCNT,HBHCDATA) ;
  1. ; Find target HBHCFLD in string HBHBDATA
  1. ; Return either HBHC39 or HBHC46 = Line^Piece
  1. N HBHCI,HBHCFND
  1. S HBHCFND=""
  1. F HBHCI=1:1 Q:($P(HBHCDATA,";",HBHCI)="")!HBHCFND D
  1. .Q:$P(HBHCDATA,";",HBHCI)'[HBHCFLD
  1. .S @$S(HBHCFLD=39:"HBHC39",1:"HBHC46")=HBHCCNT_U_HBHCI,HBHCFND=1
  1. Q $S(HBHCFLD=39:HBHC39,1:HBHC46)
  1. ;
  1. GETDT(DA) ;
  1. S ICDVDT=$P(^HBHC(631,DA,0),U,18)
  1. S ICDSYS=+$$SINFO^ICDEX("DIAG",ICDVDT)
  1. I ICDSYS=1 S ICDFMT=1
  1. Q