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

BUDBUPVL.m

Go to the documentation of this file.
  1. BUDBUPVL ; IHS/CMI/LAB - update visit locations UDS 30 Dec 2014 10:34 AM ;
  1. ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1. ;
  1. ;
  1. START ;update visit locations
  1. K BUDVL,BUDX,BUDY
  1. W:$D(IOF) @IOF W !!,"*** Update/Review UDS 2014 Site Parameters ***",!!
  1. W !!,"This option is used to set up your site's parameters for UDS reporting,"
  1. W !,"including entering your BPHC UDS id no. and defining visit locations"
  1. W !,"to be ","""","counted",""""," toward the report. ","""","A visit may take place in the health center"
  1. W !,"or at any other approved site or location in which project-supported "
  1. W !,"activities are carried out. Examples...mobile vans, hospitals, patients' homes,"
  1. W !,"schools, nursing homes, homeless shelters, and extended care facilities...",""""
  1. W !!,"Visits will not be counted toward the report if the visit location does not"
  1. W !,"match the locations on the UDS Visit Locations list."
  1. W !!,"Multiple site names can be designated with associated locations. Each site name",!,"must have locations designated."
  1. W !!
  1. I $G(BUDCNT)=2 S DIR(0)="Y",DIR("A")="Do you want to add/edit another site",DIR("B")="N" KILL DA D ^DIR KILL DIR I Y'=1 D EOJ Q
  1. S DIC(0)="AEMLQ",DIC="^BUDBSITE(" D ^DIC
  1. I Y=-1 W !!,"No site selected" D EOJ Q
  1. S BUDSITE=+Y
  1. S DIE="^BUDBSITE(",DR=".02",DA=BUDSITE D ^DIE
  1. D ^XBFMK
  1. D EN
  1. S BUDCNT=2
  1. G START
  1. EN ; -- main entry point for BUD UPDATE VISIT LOCATIONS
  1. D EN^VALM("BUD 14 UPDATE VISIT LOCATIONS")
  1. K BUDVL,BUDX,BUDD,BUDRCNT,BUDLINE,BUDDN
  1. Q
  1. ;
  1. HDR ; -- header code
  1. S VALMHDR(1)=$TR($J(" ",80)," ","-")
  1. S VALMHDR(2)="Site Name: "_$P(^DIC(4,BUDSITE,0),U)
  1. S VALMHDR(3)="Enter all locations to be included in the UDS report."
  1. S VALMHDR(4)=$TR($J(" ",80)," ","-")
  1. Q
  1. ;
  1. GETPAT ;
  1. S DFN=""
  1. W:$D(IOF) @IOF
  1. S DFN=""
  1. S DIC="^BUDPAT(",DIC(0)="AEMQ" D ^DIC K DIC
  1. I Y<0 Q
  1. S DFN=+Y
  1. Q
  1. INIT ; -- init variables and list array
  1. S VALMSG="?? for more actions + next screen - prev screen"
  1. D GATHER ;gather up all records for display
  1. Q
  1. ;
  1. GATHER ;
  1. K BUDDISP,BUDSEL,BUDHIGH,BUDVL
  1. K BUDLIST
  1. S X=0 F S X=$O(^BUDBSITE(BUDSITE,11,X)) Q:X'=+X S BUDLIST($P(^DIC(4,$P(^BUDBSITE(BUDSITE,11,X,0),U),0),U),X)=X
  1. S BUDHIGH=0,X="" F S X=$O(BUDLIST(X)) Q:X="" S Y=0 F S Y=$O(BUDLIST(X,Y)) Q:Y'=+Y S BUDHIGH=BUDHIGH+1,BUDSEL(BUDHIGH)=BUDLIST(X,Y)
  1. S BUDCUT=((BUDHIGH/2)+1)\1
  1. S (C,I)=0,J=1,K=1 F S I=$O(BUDSEL(I)) Q:I'=+I D
  1. .S C=C+1,BUDVL(C,0)=I_") "_$P(^DIC(4,$P(^BUDBSITE(BUDSITE,11,BUDSEL(I),0),U),0),U) S BUDDISP(I)="",BUDVL("IDX",C,C)=BUDSEL(I)
  1. .; J=I+BUDCUT I $D(BUDSEL(J)),'$D(BUDDISP(J)) S $E(BUDVL(C,0),40)=J_") "_$P(^DIC(4,$P(^BUDBSITE(BUDSITE,11,BUDSEL(J),0),U),0),U) S BUDDISP(J)=""
  1. K BUDDISP
  1. S VALMCNT=C
  1. Q
  1. ADD ;EP called from protocol to open a new case
  1. D FULL^VALM1
  1. ;W:$D(IOF) @IOF
  1. W !!
  1. K DIC S DIC(0)="AEMQ",DIC=9999999.06,DIC("A")="Enter Location Name: " D ^DIC
  1. I Y=-1 Q
  1. S BUDLOC=+Y
  1. I $D(^BUDBSITE(BUDSITE,11,BUDLOC)) W !!,$P(^DIC(4,BUDLOC,0),U)," is already on the list." D RETURN,EXIT Q
  1. W !,"Adding UDS Visit Location..."
  1. D ^XBFMK
  1. S X="`"_BUDLOC,DIC="^BUDBSITE("_BUDSITE_",11,",DIC(0)="L",DIC("P")=$P(^DD(90666.1,1101,0),U,2),DA(1)=BUDSITE D ^DIC
  1. I Y=-1 W !!,"adding new location failed"
  1. D EXIT
  1. Q
  1. ADDALL ;EP
  1. ;add all locations for this su
  1. D FULL^VALM1
  1. W !!,"Hold on while I gather up all of ",$$VAL^XBDIQ1(9999999.06,BUDSITE,.05),"'s locations and add them...."
  1. NEW SU
  1. S SU=$P(^AUTTLOC(BUDSITE,0),U,5)
  1. S BUDX=0 F S BUDX=$O(^AUTTLOC(BUDX)) Q:BUDX'=+BUDX I $P(^AUTTLOC(BUDX,0),U,5)=SU D
  1. .I $D(^BUDBSITE(BUDSITE,11,BUDX)) W !,$P(^DIC(4,BUDX,0),U)," --already on list" Q
  1. .D ^XBFMK
  1. .S X="`"_BUDX,DIC="^BUDBSITE("_BUDSITE_",11,",DIC(0)="L",DIC("P")=$P(^DD(90666.1,1101,0),U,2),DA(1)=BUDSITE D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DD,D0,DO,X
  1. .W !,$P(^DIC(4,BUDX,0),U)
  1. .I Y=-1 W !!," --failed to be added" Q
  1. .W " added"
  1. .Q
  1. D PAUSE
  1. D EXIT
  1. Q
  1. EDIT ;
  1. W ! S DIR(0)="LO^1:"_BUDHIGH,DIR("A")="Which item(s)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1. I Y="" W !,"No items selected." D EXIT Q
  1. I $D(DIRUT) W !,"No items selected." D EXIT Q
  1. D FULL^VALM1
  1. S BUDANS=Y,BUDC="" F BUDI=1:1 S BUDC=$P(BUDANS,",",BUDI) Q:BUDC="" S X=BUDVL("IDX",BUDC,BUDC) K ^BUDBSITE(BUDSITE,11,X,0),^BUDBSITE(BUDSITE,11,"B",X,X) W !,$P(^DIC(4,X,0),U)," removed from list"
  1. S DA=BUDSITE,DIK="^BUDBSITE(" D EN^DIK
  1. D ^XBFMK
  1. D PAUSE
  1. D EXIT
  1. Q
  1. RETURN ;EP; -- ask user to press ENTER
  1. Q:IOST'["C-"
  1. NEW Y S Y=$$READ("E","Press ENTER to continue") D ^XBCLS Q
  1. READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN,DIRA) ;EP; calls reader, returns response
  1. NEW DIR,X,Y
  1. S DIR(0)=TYPE
  1. I $D(SCREEN) S DIR("S")=SCREEN
  1. I $G(PROMPT)]"" S DIR("A")=PROMPT
  1. I $G(DEFAULT)]"" S DIR("B")=DEFAULT
  1. I $D(HELP) S DIR("?")=HELP
  1. I $D(DIRA(1)) S Y=0 F S Y=$O(DIRA(Y)) Q:Y="" S DIR("A",Y)=DIRA(Y)
  1. D ^DIR
  1. Q Y
  1. HELP ; -- help code
  1. S X="?" D DISP^XQORM1 W !!
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. K BUDX,BUDVL,BUDPC,BUDR1,BUDY
  1. D TERM^VALM0
  1. S VALMBCK="R"
  1. D GATHER
  1. D HDR
  1. K X,Y,Z,I
  1. Q
  1. PAUSE ;EP
  1. S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1. Q
  1. EOJ ;
  1. K DDSFILE,DIPGM,Y
  1. K X,Y,%,DR,DDS,DA,DIC
  1. D EN^XBVK("BUD")
  1. D:$D(VALMWD) CLEAR^VALM1
  1. K VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,BALMON,VALMEVL,VALMIOXY
  1. Q
  1. ;
  1. EXPND ; -- expand code
  1. Q
  1. ;