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