- 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 Dec 13, 2024@01:58:02 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