HBHCEDSP ; LR VAMC(IRMS)/MJT-HBHC Edit System Parameters; Apr 30, 2021@17:39
;;1.0;HOSPITAL BASED HOME CARE;**6,8,32**;NOV 01, 1993;Build 58
;
; Reference to:
; ^DG(40.8 supported by ICR #7024
; ^DIC(4 supported by ICR #10090
;
EN ;
K DIE S DIE="^HBHC(631.9,",DA=1,DR="3;6" D ^DIE
N HBHCPREV,HBHCPRNM,HBHCPREVX,HBHCQUIT
S HBHCQUIT=0
;Determine which site was sent to AITC before the
;install of HBH*1.0*32.
S HBHCPREV=$P(^HBHC(631.9,1,0),"^",5)
S HBHCPRNM=$P(^DIC(4,HBHCPREV,0),"^")
;Retrieve the name from file 40.8 because it could
;differ from the name in file 4.
S HBHCPREVX=$O(^DG(40.8,"AD",HBHCPREV,""))
;The previous site should be in file 40.8.
;But if not, use the name from file 4.
I HBHCPREVX]"" D
. S HBHCPRNM=$P(^DG(40.8,HBHCPREVX,0),"^")
;
PARENT ;
;The parent site field is a multiple which points to the
;MEDICAL CENTER (#40.8) file.
N HBHCFLG,HBHCNUM,Y,DTOUT,DUOUT
S HBHCFLG=1
W !!,"The ""Parent Site"" prompt selection should reflect the Austin"
W !,"Mainframe HBPC Sanctioned Program facility number at your VA."
W !,"You must select a VA HBPC sanctioned site number or the HBPC"
W !,"Admission Form will be rejected in Austin when the non-sanctioned"
W !,"site number is used.",!
K DIE S DIE="^HBHC(631.9,",DA=1
S DR=9 D ^DIE
K DA,DIE,DR,X,Y
S HBHCNUM=+$P($G(^HBHC(631.9,1,1,0)),"^",4)
I HBHCNUM=1 D CHECK1
Q:HBHCQUIT
I 'HBHCFLG G PARENT
D CHECKALL
Q:HBHCQUIT
I 'HBHCFLG G PARENT
Q
;
CHECK1 ;if only one parent site defined and it's not the same as
;the site which the site already had defined in the now unused
;HOSPITAL NUMBER (#4) field (after install of HBH*1.0*32,
;force user to verify the entry.
N HBHCPR1
S HBHCPR1=$O(^HBHC(631.9,1,1,"B",""))
;stop if for some unknown reason HBHCPR1 is null - shouldn't be, though.
Q:HBHCPR1=""
S HBHCPR1=$P(^DG(40.8,HBHCPR1,0),"^",7)
I HBHCPR1'=HBHCPREV D
. W !!,"Only one parent site is defined, and it is not ",HBHCPRNM," (",HBHCPREV,")."
. W !,"Site ",HBHCPRNM," was previously transmitted to AITC."
. N DIR
. S DIR("A")="Are you sure site "_HBHCPRNM_" should not be added"
. S DIR("B")="NO",DIR(0)="YN"
. D ^DIR
I $G(DTOUT)!($G(DUOUT)) S HBHCQUIT=1 Q
I $D(Y) S HBHCFLG=+Y
Q
;
CHECKALL ;
;Ask user to verify again that these sites are valid.
I $P($G(^HBHC(631.9,1,1,0)),"^",4)>0 D
. W !!,"Parent Site",$S(HBHCNUM>1:"s",1:""),":"
. W !!,"Institution ID Name of Site"
. W !,"-------------- -----------------------------------"
N HBHCSQ,HBHCSTR,HBHCHIT
;HBHCHIT determines whether any parent site is the same site
;which previously transmitted to AITC prior to install of HBH*1.0*32.
S HBHCSQ="",HBHCHIT=0
F S HBHCSQ=$O(^HBHC(631.9,1,1,"B",HBHCSQ)) Q:HBHCSQ="" D
. S HBHCSTR=$G(^DG(40.8,HBHCSQ,0))
. W !,$P(HBHCSTR,"^",7),?17,$P(HBHCSTR,"^")
. I $P(HBHCSTR,"^",7)=HBHCPREV S HBHCHIT=1
I 'HBHCHIT D
. W !!,"A parent site for ",HBHCPRNM," (",HBHCPREV,") is not defined."
. W !,HBHCPRNM," was previously transmitted to AITC."
. W !!,"Are you sure ",HBHCPRNM," should not be"
. N DIR
. S DIR("A")="defined as a parent site"
. S DIR("B")="NO",DIR(0)="YN"
. D ^DIR
. I $G(DTOUT)!($G(DUOUT)) S HBHCQUIT=1 Q
. S HBHCFLG=+Y
Q:HBHCQUIT
Q:'HBHCFLG
Q:$P($G(^HBHC(631.9,1,1,0)),"^",4)'>0
N DIR
S DIR("A")="Are you sure "_$S(HBHCNUM>1:"these are",1:"this is a")_" VA HBPC sanctioned site"_$S(HBHCNUM>1:"s",1:"")
S DIR("B")="NO",DIR(0)="YN"
W !
D ^DIR
I $G(DTOUT)!($G(DUOUT)) S HBHCQUIT=1 Q
W !
S HBHCFLG=+Y
I 'HBHCFLG D
. W !,"You are being taken back to the Parent Site prompt."
. W !,"Delete entries (using ""@"") which are not VA HBPC sanctioned sites."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCEDSP 3726 printed Oct 16, 2024@17:58:49 Page 2
HBHCEDSP ; LR VAMC(IRMS)/MJT-HBHC Edit System Parameters; Apr 30, 2021@17:39
+1 ;;1.0;HOSPITAL BASED HOME CARE;**6,8,32**;NOV 01, 1993;Build 58
+2 ;
+3 ; Reference to:
+4 ; ^DG(40.8 supported by ICR #7024
+5 ; ^DIC(4 supported by ICR #10090
+6 ;
EN ;
+1 KILL DIE
SET DIE="^HBHC(631.9,"
SET DA=1
SET DR="3;6"
DO ^DIE
+2 NEW HBHCPREV,HBHCPRNM,HBHCPREVX,HBHCQUIT
+3 SET HBHCQUIT=0
+4 ;Determine which site was sent to AITC before the
+5 ;install of HBH*1.0*32.
+6 SET HBHCPREV=$PIECE(^HBHC(631.9,1,0),"^",5)
+7 SET HBHCPRNM=$PIECE(^DIC(4,HBHCPREV,0),"^")
+8 ;Retrieve the name from file 40.8 because it could
+9 ;differ from the name in file 4.
+10 SET HBHCPREVX=$ORDER(^DG(40.8,"AD",HBHCPREV,""))
+11 ;The previous site should be in file 40.8.
+12 ;But if not, use the name from file 4.
+13 IF HBHCPREVX]""
Begin DoDot:1
+14 SET HBHCPRNM=$PIECE(^DG(40.8,HBHCPREVX,0),"^")
End DoDot:1
+15 ;
PARENT ;
+1 ;The parent site field is a multiple which points to the
+2 ;MEDICAL CENTER (#40.8) file.
+3 NEW HBHCFLG,HBHCNUM,Y,DTOUT,DUOUT
+4 SET HBHCFLG=1
+5 WRITE !!,"The ""Parent Site"" prompt selection should reflect the Austin"
+6 WRITE !,"Mainframe HBPC Sanctioned Program facility number at your VA."
+7 WRITE !,"You must select a VA HBPC sanctioned site number or the HBPC"
+8 WRITE !,"Admission Form will be rejected in Austin when the non-sanctioned"
+9 WRITE !,"site number is used.",!
+10 KILL DIE
SET DIE="^HBHC(631.9,"
SET DA=1
+11 SET DR=9
DO ^DIE
+12 KILL DA,DIE,DR,X,Y
+13 SET HBHCNUM=+$PIECE($GET(^HBHC(631.9,1,1,0)),"^",4)
+14 IF HBHCNUM=1
DO CHECK1
+15 if HBHCQUIT
QUIT
+16 IF 'HBHCFLG
GOTO PARENT
+17 DO CHECKALL
+18 if HBHCQUIT
QUIT
+19 IF 'HBHCFLG
GOTO PARENT
+20 QUIT
+21 ;
CHECK1 ;if only one parent site defined and it's not the same as
+1 ;the site which the site already had defined in the now unused
+2 ;HOSPITAL NUMBER (#4) field (after install of HBH*1.0*32,
+3 ;force user to verify the entry.
+4 NEW HBHCPR1
+5 SET HBHCPR1=$ORDER(^HBHC(631.9,1,1,"B",""))
+6 ;stop if for some unknown reason HBHCPR1 is null - shouldn't be, though.
+7 if HBHCPR1=""
QUIT
+8 SET HBHCPR1=$PIECE(^DG(40.8,HBHCPR1,0),"^",7)
+9 IF HBHCPR1'=HBHCPREV
Begin DoDot:1
+10 WRITE !!,"Only one parent site is defined, and it is not ",HBHCPRNM," (",HBHCPREV,")."
+11 WRITE !,"Site ",HBHCPRNM," was previously transmitted to AITC."
+12 NEW DIR
+13 SET DIR("A")="Are you sure site "_HBHCPRNM_" should not be added"
+14 SET DIR("B")="NO"
SET DIR(0)="YN"
+15 DO ^DIR
End DoDot:1
+16 IF $GET(DTOUT)!($GET(DUOUT))
SET HBHCQUIT=1
QUIT
+17 IF $DATA(Y)
SET HBHCFLG=+Y
+18 QUIT
+19 ;
CHECKALL ;
+1 ;Ask user to verify again that these sites are valid.
+2 IF $PIECE($GET(^HBHC(631.9,1,1,0)),"^",4)>0
Begin DoDot:1
+3 WRITE !!,"Parent Site",$SELECT(HBHCNUM>1:"s",1:""),":"
+4 WRITE !!,"Institution ID Name of Site"
+5 WRITE !,"-------------- -----------------------------------"
End DoDot:1
+6 NEW HBHCSQ,HBHCSTR,HBHCHIT
+7 ;HBHCHIT determines whether any parent site is the same site
+8 ;which previously transmitted to AITC prior to install of HBH*1.0*32.
+9 SET HBHCSQ=""
SET HBHCHIT=0
+10 FOR
SET HBHCSQ=$ORDER(^HBHC(631.9,1,1,"B",HBHCSQ))
if HBHCSQ=""
QUIT
Begin DoDot:1
+11 SET HBHCSTR=$GET(^DG(40.8,HBHCSQ,0))
+12 WRITE !,$PIECE(HBHCSTR,"^",7),?17,$PIECE(HBHCSTR,"^")
+13 IF $PIECE(HBHCSTR,"^",7)=HBHCPREV
SET HBHCHIT=1
End DoDot:1
+14 IF 'HBHCHIT
Begin DoDot:1
+15 WRITE !!,"A parent site for ",HBHCPRNM," (",HBHCPREV,") is not defined."
+16 WRITE !,HBHCPRNM," was previously transmitted to AITC."
+17 WRITE !!,"Are you sure ",HBHCPRNM," should not be"
+18 NEW DIR
+19 SET DIR("A")="defined as a parent site"
+20 SET DIR("B")="NO"
SET DIR(0)="YN"
+21 DO ^DIR
+22 IF $GET(DTOUT)!($GET(DUOUT))
SET HBHCQUIT=1
QUIT
+23 SET HBHCFLG=+Y
End DoDot:1
+24 if HBHCQUIT
QUIT
+25 if 'HBHCFLG
QUIT
+26 if $PIECE($GET(^HBHC(631.9,1,1,0)),"^",4)'>0
QUIT
+27 NEW DIR
+28 SET DIR("A")="Are you sure "_$SELECT(HBHCNUM>1:"these are",1:"this is a")_" VA HBPC sanctioned site"_$SELECT(HBHCNUM>1:"s",1:"")
+29 SET DIR("B")="NO"
SET DIR(0)="YN"
+30 WRITE !
+31 DO ^DIR
+32 IF $GET(DTOUT)!($GET(DUOUT))
SET HBHCQUIT=1
QUIT
+33 WRITE !
+34 SET HBHCFLG=+Y
+35 IF 'HBHCFLG
Begin DoDot:1
+36 WRITE !,"You are being taken back to the Parent Site prompt."
+37 WRITE !,"Delete entries (using ""@"") which are not VA HBPC sanctioned sites."
End DoDot:1
+38 QUIT
