HBHC32EN ;HPS/DSK - Pre-install environment check; May 02, 2021@14:20
;;1.0;HOSPITAL BASED HOME CARE;**32**;NOV 01, 1993;Build 58
;
;NEW PERSON (#200) file - IA #10060 (supported)
;BMES^XPDUTL - IA #10141 (supported)
;^XUSEC - IA #10076 (supported)
;
EN ;
;Variable XPDQUIT is new'd by XPD routines.
;Setting XPDQUIT=2 leaves install in ^XTMP but
;aborts install until after issues are resolved.
D BMES^XPDUTL("*** Environment check starting.... ***")
N HBHCSEQ
S HBHCSEQ=5,XPDQUIT=0
K ^XTMP("HBHC32 ENV CHECK")
S ^XTMP("HBHC32 ENV CHECK",0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^HBH*1.0*32 Environment Check"
D ID,PROV
S HBHCMZ=$$MESS()
I $G(HBHCMZ) D
. D BMES^XPDUTL("*** Environment Check Failed - Install Aborted. ***")
. D BMES^XPDUTL("MailMan message #"_HBHCMZ_" has been sent to")
. D BMES^XPDUTL("holders of the HBHC MANAGER security key and")
. D BMES^XPDUTL("the patch installer "_$P($G(^VA(200,+DUZ,0)),"^")_".")
;
D BMES^XPDUTL("*** Environment check finished. ***")
Q
;
ID ;
;First check: are any HBHC ID's assigned to
; more than one active provider.
N HBHCA,HBHCB,HBHCHIT,HBHCCHK,HBHCNAME,HBHCZ
S (HBHCA,HBHCB)="",HBHCCHK=0
F S HBHCA=$O(^HBHC(631.4,"B",HBHCA)) Q:HBHCA="" D
. S HBHCHIT=0
. F S HBHCB=$O(^HBHC(631.4,"B",HBHCA,HBHCB)) Q:HBHCB="" D
. . Q:$P(^HBHC(631.4,HBHCB,0),"^",7)=1
. . ;found an active provider
. . S HBHCHIT=HBHCHIT+1
. . I HBHCHIT=1 S HBHCZ=HBHCB
. . Q:HBHCHIT=1
. . ;generate list for MailMan message
. . I 'HBHCCHK D
. . . S HBHCSEQ=HBHCSEQ+1
. . . S ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)=" "
. . . S HBHCSEQ=HBHCSEQ+1
. . . S ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)="HBHC ID's assigned to more than one provider"
. . . S HBHCSEQ=HBHCSEQ+1
. . . S ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)="------------------------------------------------------------------"
. . . S HBHCCHK=1
. . I HBHCHIT=2 D
. . . ;If HBHCHIT=2, more than one active provider
. . . ;is assigned to this ID, and install should be aborted.
. . . S:'XPDQUIT XPDQUIT=2
. . . ;retrieve name from first occurrence
. . . S HBHCNAME=$P(^HBHC(631.4,HBHCZ,0),"^",2)
. . . S HBHCNAME=$P($G(^VA(200,HBHCNAME,0)),"^")
. . . S HBHCSEQ=HBHCSEQ+1
. . . S ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)=HBHCA_$E(" ",1,6-($L(HBHCA)))_HBHCNAME
. . S HBHCNAME=$P(^HBHC(631.4,HBHCB,0),"^",2)
. . S HBHCNAME=$P($G(^VA(200,HBHCNAME,0)),"^")
. . S HBHCSEQ=HBHCSEQ+1
. . S ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)=" "_HBHCNAME
Q
;
PROV ;
;Second check: are any providers assigned to
; more than one active HBHC ID.
N HBHCA,HBHCB,HBHCHIT,HBHCZ,HBHCCHK,HBHCSPACE,HBHCNAME
S HBHCSPACE=" "
S (HBHCA,HBHCB)="",HBHCCHK=0
F S HBHCA=$O(^HBHC(631.4,"C",HBHCA)) Q:HBHCA="" D
. S HBHCHIT=0
. F S HBHCB=$O(^HBHC(631.4,"C",HBHCA,HBHCB)) Q:HBHCB="" D
. . Q:$P(^HBHC(631.4,HBHCB,0),"^",7)=1
. . ;found an active provider number
. . S HBHCHIT=HBHCHIT+1
. . I HBHCHIT=1 S HBHCZ=HBHCB
. . Q:HBHCHIT=1
. . ;generate list for MailMan message
. . I 'HBHCCHK D
. . . S HBHCSEQ=HBHCSEQ+1
. . . S ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)=" "
. . . S HBHCSEQ=HBHCSEQ+1
. . . S ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)="Providers assigned to more than one active HBHC ID"
. . . S HBHCSEQ=HBHCSEQ+1
. . . S ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)="------------------------------------------------------------------"
. . . S HBHCCHK=1
. . I HBHCHIT=2 D
. . . S HBHCNAME=$P($G(^VA(200,HBHCA,0)),"^")
. . . S HBHCNAME=HBHCNAME_$E(HBHCSPACE,1,37-$L(HBHCNAME))
. . . ;If HBHCHIT=2, more than one active ID is assigned to this
. . . ;provider, and install should be aborted.
. . . S:'XPDQUIT XPDQUIT=2
. . . ;pick up the first occurrence
. . . S HBHCSEQ=HBHCSEQ+1
. . . S ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)=HBHCNAME_$E(HBHCSPACE,1,(37-$L(HBHCNAME)))_$P(^HBHC(631.4,HBHCZ,0),"^")
. . S HBHCSEQ=HBHCSEQ+1
. . S ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)=HBHCSPACE_$P(^HBHC(631.4,HBHCB,0),"^")
Q
;
MESS() ;
;Display results of environment check.
;Generate MailMan message if issues found.
N HBHCSUB,HBHCMIN,HBHCTEXT,HBHCDUZ,HBHCMY,HBHCMZ
S HBHCMZ=0
I 'XPDQUIT D BMES^XPDUTL("No issues found during environment check.") Q HBHCMZ
;
I XPDQUIT D
. S HBHCSUB="HBH*1.0*32 Install Failed Environment Check"
. S HBHCMIN=DUZ
. S HBHCMY(DUZ)=""
. S HBHCTEXT="^XTMP(""HBHC32 ENV CHECK"")"
. S HBHCDUZ=""
. F S HBHCDUZ=$O(^XUSEC("HBHC MANAGER",HBHCDUZ)) Q:HBHCDUZ="" D
. . S HBHCMY(HBHCDUZ)=""
. S ^XTMP("HBHC32 ENV CHECK",1)="If this message lists active ID's assigned to more than one provider,"
. S ^XTMP("HBHC32 ENV CHECK",2)="assign each provider to a unique active ID."
. S ^XTMP("HBHC32 ENV CHECK",3)=" "
. S ^XTMP("HBHC32 ENV CHECK",4)="If the message lists providers assigned to more than one active ID,"
. S ^XTMP("HBHC32 ENV CHECK",5)="inactivate all ID's except one."
. D SENDMSG^XMXAPI(HBHCDUZ,HBHCSUB,HBHCTEXT,.HBHCMY,.HBHCMIN,.HBHCMZ,"")
Q HBHCMZ
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHC32EN 5073 printed Sep 23, 2025@19:33:57 Page 2
HBHC32EN ;HPS/DSK - Pre-install environment check; May 02, 2021@14:20
+1 ;;1.0;HOSPITAL BASED HOME CARE;**32**;NOV 01, 1993;Build 58
+2 ;
+3 ;NEW PERSON (#200) file - IA #10060 (supported)
+4 ;BMES^XPDUTL - IA #10141 (supported)
+5 ;^XUSEC - IA #10076 (supported)
+6 ;
EN ;
+1 ;Variable XPDQUIT is new'd by XPD routines.
+2 ;Setting XPDQUIT=2 leaves install in ^XTMP but
+3 ;aborts install until after issues are resolved.
+4 DO BMES^XPDUTL("*** Environment check starting.... ***")
+5 NEW HBHCSEQ
+6 SET HBHCSEQ=5
SET XPDQUIT=0
+7 KILL ^XTMP("HBHC32 ENV CHECK")
+8 SET ^XTMP("HBHC32 ENV CHECK",0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^HBH*1.0*32 Environment Check"
+9 DO ID
DO PROV
+10 SET HBHCMZ=$$MESS()
+11 IF $GET(HBHCMZ)
Begin DoDot:1
+12 DO BMES^XPDUTL("*** Environment Check Failed - Install Aborted. ***")
+13 DO BMES^XPDUTL("MailMan message #"_HBHCMZ_" has been sent to")
+14 DO BMES^XPDUTL("holders of the HBHC MANAGER security key and")
+15 DO BMES^XPDUTL("the patch installer "_$PIECE($GET(^VA(200,+DUZ,0)),"^")_".")
End DoDot:1
+16 ;
+17 DO BMES^XPDUTL("*** Environment check finished. ***")
+18 QUIT
+19 ;
ID ;
+1 ;First check: are any HBHC ID's assigned to
+2 ; more than one active provider.
+3 NEW HBHCA,HBHCB,HBHCHIT,HBHCCHK,HBHCNAME,HBHCZ
+4 SET (HBHCA,HBHCB)=""
SET HBHCCHK=0
+5 FOR
SET HBHCA=$ORDER(^HBHC(631.4,"B",HBHCA))
if HBHCA=""
QUIT
Begin DoDot:1
+6 SET HBHCHIT=0
+7 FOR
SET HBHCB=$ORDER(^HBHC(631.4,"B",HBHCA,HBHCB))
if HBHCB=""
QUIT
Begin DoDot:2
+8 if $PIECE(^HBHC(631.4,HBHCB,0),"^",7)=1
QUIT
+9 ;found an active provider
+10 SET HBHCHIT=HBHCHIT+1
+11 IF HBHCHIT=1
SET HBHCZ=HBHCB
+12 if HBHCHIT=1
QUIT
+13 ;generate list for MailMan message
+14 IF 'HBHCCHK
Begin DoDot:3
+15 SET HBHCSEQ=HBHCSEQ+1
+16 SET ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)=" "
+17 SET HBHCSEQ=HBHCSEQ+1
+18 SET ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)="HBHC ID's assigned to more than one provider"
+19 SET HBHCSEQ=HBHCSEQ+1
+20 SET ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)="------------------------------------------------------------------"
+21 SET HBHCCHK=1
End DoDot:3
+22 IF HBHCHIT=2
Begin DoDot:3
+23 ;If HBHCHIT=2, more than one active provider
+24 ;is assigned to this ID, and install should be aborted.
+25 if 'XPDQUIT
SET XPDQUIT=2
+26 ;retrieve name from first occurrence
+27 SET HBHCNAME=$PIECE(^HBHC(631.4,HBHCZ,0),"^",2)
+28 SET HBHCNAME=$PIECE($GET(^VA(200,HBHCNAME,0)),"^")
+29 SET HBHCSEQ=HBHCSEQ+1
+30 SET ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)=HBHCA_$EXTRACT(" ",1,6-($LENGTH(HBHCA)))_HBHCNAME
End DoDot:3
+31 SET HBHCNAME=$PIECE(^HBHC(631.4,HBHCB,0),"^",2)
+32 SET HBHCNAME=$PIECE($GET(^VA(200,HBHCNAME,0)),"^")
+33 SET HBHCSEQ=HBHCSEQ+1
+34 SET ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)=" "_HBHCNAME
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
PROV ;
+1 ;Second check: are any providers assigned to
+2 ; more than one active HBHC ID.
+3 NEW HBHCA,HBHCB,HBHCHIT,HBHCZ,HBHCCHK,HBHCSPACE,HBHCNAME
+4 SET HBHCSPACE=" "
+5 SET (HBHCA,HBHCB)=""
SET HBHCCHK=0
+6 FOR
SET HBHCA=$ORDER(^HBHC(631.4,"C",HBHCA))
if HBHCA=""
QUIT
Begin DoDot:1
+7 SET HBHCHIT=0
+8 FOR
SET HBHCB=$ORDER(^HBHC(631.4,"C",HBHCA,HBHCB))
if HBHCB=""
QUIT
Begin DoDot:2
+9 if $PIECE(^HBHC(631.4,HBHCB,0),"^",7)=1
QUIT
+10 ;found an active provider number
+11 SET HBHCHIT=HBHCHIT+1
+12 IF HBHCHIT=1
SET HBHCZ=HBHCB
+13 if HBHCHIT=1
QUIT
+14 ;generate list for MailMan message
+15 IF 'HBHCCHK
Begin DoDot:3
+16 SET HBHCSEQ=HBHCSEQ+1
+17 SET ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)=" "
+18 SET HBHCSEQ=HBHCSEQ+1
+19 SET ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)="Providers assigned to more than one active HBHC ID"
+20 SET HBHCSEQ=HBHCSEQ+1
+21 SET ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)="------------------------------------------------------------------"
+22 SET HBHCCHK=1
End DoDot:3
+23 IF HBHCHIT=2
Begin DoDot:3
+24 SET HBHCNAME=$PIECE($GET(^VA(200,HBHCA,0)),"^")
+25 SET HBHCNAME=HBHCNAME_$EXTRACT(HBHCSPACE,1,37-$LENGTH(HBHCNAME))
+26 ;If HBHCHIT=2, more than one active ID is assigned to this
+27 ;provider, and install should be aborted.
+28 if 'XPDQUIT
SET XPDQUIT=2
+29 ;pick up the first occurrence
+30 SET HBHCSEQ=HBHCSEQ+1
+31 SET ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)=HBHCNAME_$EXTRACT(HBHCSPACE,1,(37-$LENGTH(HBHCNAME)))_$PIECE(^HBHC(631.4,HBHCZ,0),"^")
End DoDot:3
+32 SET HBHCSEQ=HBHCSEQ+1
+33 SET ^XTMP("HBHC32 ENV CHECK",HBHCSEQ)=HBHCSPACE_$PIECE(^HBHC(631.4,HBHCB,0),"^")
End DoDot:2
End DoDot:1
+34 QUIT
+35 ;
MESS() ;
+1 ;Display results of environment check.
+2 ;Generate MailMan message if issues found.
+3 NEW HBHCSUB,HBHCMIN,HBHCTEXT,HBHCDUZ,HBHCMY,HBHCMZ
+4 SET HBHCMZ=0
+5 IF 'XPDQUIT
DO BMES^XPDUTL("No issues found during environment check.")
QUIT HBHCMZ
+6 ;
+7 IF XPDQUIT
Begin DoDot:1
+8 SET HBHCSUB="HBH*1.0*32 Install Failed Environment Check"
+9 SET HBHCMIN=DUZ
+10 SET HBHCMY(DUZ)=""
+11 SET HBHCTEXT="^XTMP(""HBHC32 ENV CHECK"")"
+12 SET HBHCDUZ=""
+13 FOR
SET HBHCDUZ=$ORDER(^XUSEC("HBHC MANAGER",HBHCDUZ))
if HBHCDUZ=""
QUIT
Begin DoDot:2
+14 SET HBHCMY(HBHCDUZ)=""
End DoDot:2
+15 SET ^XTMP("HBHC32 ENV CHECK",1)="If this message lists active ID's assigned to more than one provider,"
+16 SET ^XTMP("HBHC32 ENV CHECK",2)="assign each provider to a unique active ID."
+17 SET ^XTMP("HBHC32 ENV CHECK",3)=" "
+18 SET ^XTMP("HBHC32 ENV CHECK",4)="If the message lists providers assigned to more than one active ID,"
+19 SET ^XTMP("HBHC32 ENV CHECK",5)="inactivate all ID's except one."
+20 DO SENDMSG^XMXAPI(HBHCDUZ,HBHCSUB,HBHCTEXT,.HBHCMY,.HBHCMIN,.HBHCMZ,"")
End DoDot:1
+21 QUIT HBHCMZ
+22 ;
