Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HBHCEDSP

HBHCEDSP.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to:
  1. ; ^DG(40.8 supported by ICR #7024
  1. ; ^DIC(4 supported by ICR #10090
  1. ;
  1. EN ;
  1. K DIE S DIE="^HBHC(631.9,",DA=1,DR="3;6" D ^DIE
  1. N HBHCPREV,HBHCPRNM,HBHCPREVX,HBHCQUIT
  1. S HBHCQUIT=0
  1. ;Determine which site was sent to AITC before the
  1. ;install of HBH*1.0*32.
  1. S HBHCPREV=$P(^HBHC(631.9,1,0),"^",5)
  1. S HBHCPRNM=$P(^DIC(4,HBHCPREV,0),"^")
  1. ;Retrieve the name from file 40.8 because it could
  1. ;differ from the name in file 4.
  1. S HBHCPREVX=$O(^DG(40.8,"AD",HBHCPREV,""))
  1. ;The previous site should be in file 40.8.
  1. ;But if not, use the name from file 4.
  1. I HBHCPREVX]"" D
  1. . S HBHCPRNM=$P(^DG(40.8,HBHCPREVX,0),"^")
  1. ;
  1. PARENT ;
  1. ;The parent site field is a multiple which points to the
  1. ;MEDICAL CENTER (#40.8) file.
  1. N HBHCFLG,HBHCNUM,Y,DTOUT,DUOUT
  1. S HBHCFLG=1
  1. W !!,"The ""Parent Site"" prompt selection should reflect the Austin"
  1. W !,"Mainframe HBPC Sanctioned Program facility number at your VA."
  1. W !,"You must select a VA HBPC sanctioned site number or the HBPC"
  1. W !,"Admission Form will be rejected in Austin when the non-sanctioned"
  1. W !,"site number is used.",!
  1. K DIE S DIE="^HBHC(631.9,",DA=1
  1. S DR=9 D ^DIE
  1. K DA,DIE,DR,X,Y
  1. S HBHCNUM=+$P($G(^HBHC(631.9,1,1,0)),"^",4)
  1. I HBHCNUM=1 D CHECK1
  1. Q:HBHCQUIT
  1. I 'HBHCFLG G PARENT
  1. D CHECKALL
  1. Q:HBHCQUIT
  1. I 'HBHCFLG G PARENT
  1. Q
  1. ;
  1. 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
  1. ;HOSPITAL NUMBER (#4) field (after install of HBH*1.0*32,
  1. ;force user to verify the entry.
  1. N HBHCPR1
  1. S HBHCPR1=$O(^HBHC(631.9,1,1,"B",""))
  1. ;stop if for some unknown reason HBHCPR1 is null - shouldn't be, though.
  1. Q:HBHCPR1=""
  1. S HBHCPR1=$P(^DG(40.8,HBHCPR1,0),"^",7)
  1. I HBHCPR1'=HBHCPREV D
  1. . W !!,"Only one parent site is defined, and it is not ",HBHCPRNM," (",HBHCPREV,")."
  1. . W !,"Site ",HBHCPRNM," was previously transmitted to AITC."
  1. . N DIR
  1. . S DIR("A")="Are you sure site "_HBHCPRNM_" should not be added"
  1. . S DIR("B")="NO",DIR(0)="YN"
  1. . D ^DIR
  1. I $G(DTOUT)!($G(DUOUT)) S HBHCQUIT=1 Q
  1. I $D(Y) S HBHCFLG=+Y
  1. Q
  1. ;
  1. CHECKALL ;
  1. ;Ask user to verify again that these sites are valid.
  1. I $P($G(^HBHC(631.9,1,1,0)),"^",4)>0 D
  1. . W !!,"Parent Site",$S(HBHCNUM>1:"s",1:""),":"
  1. . W !!,"Institution ID Name of Site"
  1. . W !,"-------------- -----------------------------------"
  1. N HBHCSQ,HBHCSTR,HBHCHIT
  1. ;HBHCHIT determines whether any parent site is the same site
  1. ;which previously transmitted to AITC prior to install of HBH*1.0*32.
  1. S HBHCSQ="",HBHCHIT=0
  1. F S HBHCSQ=$O(^HBHC(631.9,1,1,"B",HBHCSQ)) Q:HBHCSQ="" D
  1. . S HBHCSTR=$G(^DG(40.8,HBHCSQ,0))
  1. . W !,$P(HBHCSTR,"^",7),?17,$P(HBHCSTR,"^")
  1. . I $P(HBHCSTR,"^",7)=HBHCPREV S HBHCHIT=1
  1. I 'HBHCHIT D
  1. . W !!,"A parent site for ",HBHCPRNM," (",HBHCPREV,") is not defined."
  1. . W !,HBHCPRNM," was previously transmitted to AITC."
  1. . W !!,"Are you sure ",HBHCPRNM," should not be"
  1. . N DIR
  1. . S DIR("A")="defined as a parent site"
  1. . S DIR("B")="NO",DIR(0)="YN"
  1. . D ^DIR
  1. . I $G(DTOUT)!($G(DUOUT)) S HBHCQUIT=1 Q
  1. . S HBHCFLG=+Y
  1. Q:HBHCQUIT
  1. Q:'HBHCFLG
  1. Q:$P($G(^HBHC(631.9,1,1,0)),"^",4)'>0
  1. N DIR
  1. S DIR("A")="Are you sure "_$S(HBHCNUM>1:"these are",1:"this is a")_" VA HBPC sanctioned site"_$S(HBHCNUM>1:"s",1:"")
  1. S DIR("B")="NO",DIR(0)="YN"
  1. W !
  1. D ^DIR
  1. I $G(DTOUT)!($G(DUOUT)) S HBHCQUIT=1 Q
  1. W !
  1. S HBHCFLG=+Y
  1. I 'HBHCFLG D
  1. . W !,"You are being taken back to the Parent Site prompt."
  1. . W !,"Delete entries (using ""@"") which are not VA HBPC sanctioned sites."
  1. Q