HBHCPS12 ; LR VAMC(IRMS)/MJT-HBHC POST initialization routine, re-create visits for FY98 in HBHC(632 file, cleanup corresponding files, send IRM message when complete ;9808
;;1.0;HOSPITAL BASED HOME CARE;**12**;NOV 01, 1993
; Modeles copied from HBHCFILE routine: POP, EXIT1 (EXIT renamed EXIT1), MAIL
S HBHCDUZ=DUZ
6314 ; Retain IENs w/Inactive Provider Number (field 6, file 631.4) in HBHC Provider
; Count number of provider numbers per provider, create local array
S HBHCPRV=0 F S HBHCPRV=$O(^HBHC(631.4,"C",HBHCPRV)) Q:HBHCPRV'>0 S HBHCIEN=0 F S HBHCIEN=$O(^HBHC(631.4,"C",HBHCPRV,HBHCIEN)) Q:HBHCIEN'>0 D ARRAY
; Check to see whether provider has unique 'Active' provider number (HBHCFLAG = 1 if yes)
S HBHCPRV=0 F S HBHCPRV=$O(HBHC6314(HBHCPRV)) Q:HBHCPRV'>0 D LOOP2 K HBHC6314(HBHCPRV) S:HBHCFLAG=0 HBHC6314(HBHCPRV)=1,HBHC6314(HBHCPRV,HBHCLAST)=""
; Delete 'Active' & Unique provider number entries from local array, leaving local array of records to be processed (delete Inactive)
S HBHCPRV=0 F S HBHCPRV=$O(HBHC6314(HBHCPRV)) Q:HBHCPRV'>0 S HBHCIEN=0 F S HBHCIEN=$O(HBHC6314(HBHCPRV,HBHCIEN)) Q:HBHCIEN'>0 S $P(^HBHC(631.4,HBHCIEN,0),U,7)="" K ^HBHC(631.4,"AC",1,HBHCIEN)
PARAM ; Retain/Set Number of Visit Days to Scan (field 3, file 631.9) System Parameter
S HBHCMJ=$P(^HBHC(631.9,1,0),U,4)
S $P(^HBHC(631.9,1,0),U,4)=365
; Variable needed by HBHCFILE routine
S HBHCLSDT=$S($E(DT,4,5)>9:2980930.9999,1:2980831.9999)
; Variable needed by HBHCAPPT routine
S HBHCFLAG=1
S ZTIO="",ZTDTH=$H,ZTRTN="DQ^HBHCPS12",ZTSAVE("HBHC*")="",ZTDESC="HBHC Patch 12 Post Install" D ^%ZTLOAD
W $C(7),!!,"HBHC Patch 12 Post Install processing has been queued. Task number: ",ZTSK H 3
G EXIT
DQ ; De-queue entry point
632 ; Delete FY98 entries from 632 (Visit) file
S DIK="^HBHC(632,",HBHCDAT=2970930.9999999 F S HBHCDAT=$O(^HBHC(632,"C",HBHCDAT)) Q:HBHCDAT'>0 S DA=0 F S DA=$O(^HBHC(632,"C",HBHCDAT,DA)) Q:DA'>0 D ^DIK
634 ; Delete entries from 634 (Transmit) file
K ^HBHC(634) S ^HBHC(634,0)="HBHC TRANSMIT^634"
6341 ; Delete entries from 634.1 (Admission Errors) file
K ^HBHC(634.1) S ^HBHC(634.1,0)="HBHC EVALUATION/ADMISSION ERROR(S)^634.1"
6342 ; Delete entries from 634.2 (Visit Errors) file
K ^HBHC(634.2) S ^HBHC(634.2,0)="HBHC VISIT ERROR(S)^634.2P"
6343 ; Delete entries from 634.3 (Discharge Errors) file
K ^HBHC(634.3) S ^HBHC(634.3,0)="HBHC DISCHARGE ERROR(S)^634.3"
6346 ; Delete FY98 entries from 634.6 (Transmit History) file
S DIK="^HBHC(634.6,",HBHCDAT=2970930 F S HBHCDAT=$O(^HBHC(634.6,"C",HBHCDAT)) Q:HBHCDAT'>0 S DA=0 F S DA=$O(^HBHC(634.6,"C",HBHCDAT,DA)) Q:DA'>0 D ^DIK
CREATE ; Re-create visits for FY98 from Outpatient Encounter (409.68) file data, update Transmit (634) file &/or error files (634.1 thru 634.3)
POP ; Populate ^HBHC(634) or ^HBHC(634.1/634.2/634.3/634.5 Error files
D ^HBHCAPPT,^HBHCXMC,^HBHCXMA,^HBHCXMV,^HBHCXMD
; Send mail message
D:('$D(^HBHC(634.1,"B")))&('$D(^HBHC(634.2,"B")))&('$D(^HBHC(634.3,"B")))&('$D(^HBHC(634.5,"B"))) MAIL
EXIT1 ; Exit module
L -^HBHC(634.5,0)
K DA,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,HBHCAPDT,HBHCCKDT,HBHCDAT,HBHCDAYS,HBHCDTE,HBHCDIR,HBHCFLAG,HBHCLEAP,HBHCLSDT,HBHCNOW,HBHCSTDT,HBHCYEAR,%,TMP,X,X1,X2,Y
; Reset Inactive Provider Number (field 6, file 631.4) in HBHC Provider
S HBHCPRV=0 F S HBHCPRV=$O(HBHC6314(HBHCPRV)) Q:HBHCPRV'>0 S HBHCIEN=0 F S HBHCIEN=$O(HBHC6314(HBHCPRV,HBHCIEN)) Q:HBHCIEN'>0 S $P(^HBHC(631.4,HBHCIEN,0),U,7)=1 S ^HBHC(631.4,"AC",1,HBHCIEN)=""
; Reset Number of Visit Days to Scan (field 3, file 631.9) System Parameter
S $P(^HBHC(631.9,1,0),U,4)=HBHCMJ
MAILIRM ; Send mail message to IRM
S TMP(1)="HBH*1*12 post installation is complete. Please inform HBPC Users.",XMDUZ="HBHC Post Install",XMSUB="HBH*1*12 Post Install Complete",XMY(HBHCDUZ)="",XMTEXT="TMP("
N DIFROM
D ^XMD
EXIT ; Exit module
K HBHCDAT,HBHCDTE,HBHCDUZ,HBHCIEN,HBHCFLAG,HBHCLAST,HBHCLSDT,HBHCMJ,HBHCNOW,HBHCPRV,HBHC6314
Q
ARRAY ; Set HBHC6314 array
S:$D(HBHC6314(HBHCPRV)) HBHC6314(HBHCPRV)=HBHC6314(HBHCPRV)+1
S:'$D(HBHC6314(HBHCPRV)) HBHC6314(HBHCPRV)=1
S HBHC6314(HBHCPRV,HBHCIEN)=""
Q
LOOP2 ; Loop 2, determine whether record is Inactive or has Unique provider number
S (HBHCFLAG,HBHCIEN)=0 F S HBHCIEN=$O(HBHC6314(HBHCPRV,HBHCIEN)) Q:(HBHCIEN'>0)!(HBHCFLAG=1) S HBHCLAST=HBHCIEN S:$P(^HBHC(631.4,HBHCIEN,0),U,7)="" HBHCFLAG=1
Q
MAIL ; Send completed mail message
S TMP(1)=$P(HBHCDAT,"@")_" HBHC Build Transmit File is complete with no errors found.",TMP(2)="",TMP(3)=" Number of Visit Days to Scan system parameter: "_$P(^HBHC(631.9,1,0),U,4),TMP(4)=""
S Y=$P($P(HBHCDTE,U),"@") X ^DD("DD") S HBHCINFO=Y,Y=$P($P(HBHCDTE,U,2),"@") X ^DD("DD") S TMP(5)=" Date range: "_$P(HBHCINFO,"@")_" thru "_$P(Y,"@"),TMP(6)=""
D NOW^%DTC S Y=% X ^DD("DD")
S TMP(7)=" Start time: "_$P(HBHCDAT,"@",2)_" End time: "_$P(Y,"@",2)_" Elapsed minutes: "_($E(%_"000",9,10)-$E(HBHCNOW_"000",9,10)*60+$E(%_"00000",11,12)-$E(HBHCNOW_"00000",11,12)),TMP(8)=""
S TMP(9)="***** Reminder: Please run Transmit File to Austin option. *****"
S XMDUZ="HBHC Build Transmit File Mail Group",XMSUB=$P(HBHCDAT,"@")_" HBHC Build Transmit File",XMY(DUZ)="",XMTEXT="TMP("
N DIFROM
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCPS12 5288 printed Sep 23, 2025@19:34:12 Page 2
HBHCPS12 ; LR VAMC(IRMS)/MJT-HBHC POST initialization routine, re-create visits for FY98 in HBHC(632 file, cleanup corresponding files, send IRM message when complete ;9808
+1 ;;1.0;HOSPITAL BASED HOME CARE;**12**;NOV 01, 1993
+2 ; Modeles copied from HBHCFILE routine: POP, EXIT1 (EXIT renamed EXIT1), MAIL
+3 SET HBHCDUZ=DUZ
6314 ; Retain IENs w/Inactive Provider Number (field 6, file 631.4) in HBHC Provider
+1 ; Count number of provider numbers per provider, create local array
+2 SET HBHCPRV=0
FOR
SET HBHCPRV=$ORDER(^HBHC(631.4,"C",HBHCPRV))
if HBHCPRV'>0
QUIT
SET HBHCIEN=0
FOR
SET HBHCIEN=$ORDER(^HBHC(631.4,"C",HBHCPRV,HBHCIEN))
if HBHCIEN'>0
QUIT
DO ARRAY
+3 ; Check to see whether provider has unique 'Active' provider number (HBHCFLAG = 1 if yes)
+4 SET HBHCPRV=0
FOR
SET HBHCPRV=$ORDER(HBHC6314(HBHCPRV))
if HBHCPRV'>0
QUIT
DO LOOP2
KILL HBHC6314(HBHCPRV)
if HBHCFLAG=0
SET HBHC6314(HBHCPRV)=1
SET HBHC6314(HBHCPRV,HBHCLAST)=""
+5 ; Delete 'Active' & Unique provider number entries from local array, leaving local array of records to be processed (delete Inactive)
+6 SET HBHCPRV=0
FOR
SET HBHCPRV=$ORDER(HBHC6314(HBHCPRV))
if HBHCPRV'>0
QUIT
SET HBHCIEN=0
FOR
SET HBHCIEN=$ORDER(HBHC6314(HBHCPRV,HBHCIEN))
if HBHCIEN'>0
QUIT
SET $PIECE(^HBHC(631.4,HBHCIEN,0),U,7)=""
KILL ^HBHC(631.4,"AC",1,HBHCIEN)
PARAM ; Retain/Set Number of Visit Days to Scan (field 3, file 631.9) System Parameter
+1 SET HBHCMJ=$PIECE(^HBHC(631.9,1,0),U,4)
+2 SET $PIECE(^HBHC(631.9,1,0),U,4)=365
+3 ; Variable needed by HBHCFILE routine
+4 SET HBHCLSDT=$SELECT($EXTRACT(DT,4,5)>9:2980930.9999,1:2980831.9999)
+5 ; Variable needed by HBHCAPPT routine
+6 SET HBHCFLAG=1
+7 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTRTN="DQ^HBHCPS12"
SET ZTSAVE("HBHC*")=""
SET ZTDESC="HBHC Patch 12 Post Install"
DO ^%ZTLOAD
+8 WRITE $CHAR(7),!!,"HBHC Patch 12 Post Install processing has been queued. Task number: ",ZTSK
HANG 3
+9 GOTO EXIT
DQ ; De-queue entry point
632 ; Delete FY98 entries from 632 (Visit) file
+1 SET DIK="^HBHC(632,"
SET HBHCDAT=2970930.9999999
FOR
SET HBHCDAT=$ORDER(^HBHC(632,"C",HBHCDAT))
if HBHCDAT'>0
QUIT
SET DA=0
FOR
SET DA=$ORDER(^HBHC(632,"C",HBHCDAT,DA))
if DA'>0
QUIT
DO ^DIK
634 ; Delete entries from 634 (Transmit) file
+1 KILL ^HBHC(634)
SET ^HBHC(634,0)="HBHC TRANSMIT^634"
6341 ; Delete entries from 634.1 (Admission Errors) file
+1 KILL ^HBHC(634.1)
SET ^HBHC(634.1,0)="HBHC EVALUATION/ADMISSION ERROR(S)^634.1"
6342 ; Delete entries from 634.2 (Visit Errors) file
+1 KILL ^HBHC(634.2)
SET ^HBHC(634.2,0)="HBHC VISIT ERROR(S)^634.2P"
6343 ; Delete entries from 634.3 (Discharge Errors) file
+1 KILL ^HBHC(634.3)
SET ^HBHC(634.3,0)="HBHC DISCHARGE ERROR(S)^634.3"
6346 ; Delete FY98 entries from 634.6 (Transmit History) file
+1 SET DIK="^HBHC(634.6,"
SET HBHCDAT=2970930
FOR
SET HBHCDAT=$ORDER(^HBHC(634.6,"C",HBHCDAT))
if HBHCDAT'>0
QUIT
SET DA=0
FOR
SET DA=$ORDER(^HBHC(634.6,"C",HBHCDAT,DA))
if DA'>0
QUIT
DO ^DIK
CREATE ; Re-create visits for FY98 from Outpatient Encounter (409.68) file data, update Transmit (634) file &/or error files (634.1 thru 634.3)
POP ; Populate ^HBHC(634) or ^HBHC(634.1/634.2/634.3/634.5 Error files
+1 DO ^HBHCAPPT
DO ^HBHCXMC
DO ^HBHCXMA
DO ^HBHCXMV
DO ^HBHCXMD
+2 ; Send mail message
+3 if ('$DATA(^HBHC(634.1,"B")))&('$DATA(^HBHC(634.2,"B")))&('$DATA(^HBHC(634.3,"B")))&('$DATA(^HBHC(634.5,"B")))
DO MAIL
EXIT1 ; Exit module
+1 LOCK -^HBHC(634.5,0)
+2 KILL DA,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,HBHCAPDT,HBHCCKDT,HBHCDAT,HBHCDAYS,HBHCDTE,HBHCDIR,HBHCFLAG,HBHCLEAP,HBHCLSDT,HBHCNOW,HBHCSTDT,HBHCYEAR,%,TMP,X,X1,X2,Y
+3 ; Reset Inactive Provider Number (field 6, file 631.4) in HBHC Provider
+4 SET HBHCPRV=0
FOR
SET HBHCPRV=$ORDER(HBHC6314(HBHCPRV))
if HBHCPRV'>0
QUIT
SET HBHCIEN=0
FOR
SET HBHCIEN=$ORDER(HBHC6314(HBHCPRV,HBHCIEN))
if HBHCIEN'>0
QUIT
SET $PIECE(^HBHC(631.4,HBHCIEN,0),U,7)=1
SET ^HBHC(631.4,"AC",1,HBHCIEN)=""
+5 ; Reset Number of Visit Days to Scan (field 3, file 631.9) System Parameter
+6 SET $PIECE(^HBHC(631.9,1,0),U,4)=HBHCMJ
MAILIRM ; Send mail message to IRM
+1 SET TMP(1)="HBH*1*12 post installation is complete. Please inform HBPC Users."
SET XMDUZ="HBHC Post Install"
SET XMSUB="HBH*1*12 Post Install Complete"
SET XMY(HBHCDUZ)=""
SET XMTEXT="TMP("
+2 NEW DIFROM
+3 DO ^XMD
EXIT ; Exit module
+1 KILL HBHCDAT,HBHCDTE,HBHCDUZ,HBHCIEN,HBHCFLAG,HBHCLAST,HBHCLSDT,HBHCMJ,HBHCNOW,HBHCPRV,HBHC6314
+2 QUIT
ARRAY ; Set HBHC6314 array
+1 if $DATA(HBHC6314(HBHCPRV))
SET HBHC6314(HBHCPRV)=HBHC6314(HBHCPRV)+1
+2 if '$DATA(HBHC6314(HBHCPRV))
SET HBHC6314(HBHCPRV)=1
+3 SET HBHC6314(HBHCPRV,HBHCIEN)=""
+4 QUIT
LOOP2 ; Loop 2, determine whether record is Inactive or has Unique provider number
+1 SET (HBHCFLAG,HBHCIEN)=0
FOR
SET HBHCIEN=$ORDER(HBHC6314(HBHCPRV,HBHCIEN))
if (HBHCIEN'>0)!(HBHCFLAG=1)
QUIT
SET HBHCLAST=HBHCIEN
if $PIECE(^HBHC(631.4,HBHCIEN,0),U,7)=""
SET HBHCFLAG=1
+2 QUIT
MAIL ; Send completed mail message
+1 SET TMP(1)=$PIECE(HBHCDAT,"@")_" HBHC Build Transmit File is complete with no errors found."
SET TMP(2)=""
SET TMP(3)=" Number of Visit Days to Scan system parameter: "_$PIECE(^HBHC(631.9,1,0),U,4)
SET TMP(4)=""
+2 SET Y=$PIECE($PIECE(HBHCDTE,U),"@")
XECUTE ^DD("DD")
SET HBHCINFO=Y
SET Y=$PIECE($PIECE(HBHCDTE,U,2),"@")
XECUTE ^DD("DD")
SET TMP(5)=" Date range: "_$PIECE(HBHCINFO,"@")_" thru "_$PIECE(Y,"@")
SET TMP(6)=""
+3 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+4 SET TMP(7)=" Start time: "_$PIECE(HBHCDAT,"@",2)_" End time: "_$PIECE(Y,"@",2)_" Elapsed minutes: "_($EXTRACT(%_"000",9,10)-$EXTRACT(HBHCNOW_"000",9,10)*60+$EXTRACT(%_"00000",11,12)-$EXTRACT(HBHCNOW_"00000",11,12))
SET TMP(8)=""
+5 SET TMP(9)="***** Reminder: Please run Transmit File to Austin option. *****"
+6 SET XMDUZ="HBHC Build Transmit File Mail Group"
SET XMSUB=$PIECE(HBHCDAT,"@")_" HBHC Build Transmit File"
SET XMY(DUZ)=""
SET XMTEXT="TMP("
+7 NEW DIFROM
+8 DO ^XMD
+9 QUIT
