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

BUDHUPVL.m

Go to the documentation of this file. 
  1. BUDHUPVL ;IHS/CMI/LAB - UPDATE VISIT LOCATIONS;
  1.  ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
  1.  ;
  1.  ;
  1. START ;update visit locations
  1.  K BUDVL,BUDX,BUDY
  1.  W:$D(IOF) @IOF W !!,"***  Update/Review UDS 2018 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. ",""""
  1.  W "A visit must take place in health "
  1.  W !,"center sites or other locations that do not meet HRSA's site criteria, "
  1.  W !,"such as hospitals, schools, nursing homes, homeless shelters, "
  1.  W !,"or extended care facilities. Visits at these sites count when they "
  1.  W !,"occur on a regularly scheduled basis at an approved site within"
  1.  W !,"the health center's scope of project."""
  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(BUDDNT)=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="^BUDHSITE(" D ^DIC
  1.  I Y=-1 W !!,"No site selected" D EOJ Q
  1.  S BUDSITE=+Y
  1.  S DIE="^BUDHSITE(",DR=".02",DA=BUDSITE D ^DIE
  1.  D ^XBFMK
  1.  D EN
  1.  S DIR(0)="Y",DIR("A")="Would you like to review/edit the insurance company overrides",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G PCOV
  1.  I 'Y G PCOV
  1.  I '$O(^BUDHSITE(BUDSITE,12,0)) W !,"There are currently no insurance overrides entered.",!
  1.  I $O(^BUDHSITE(BUDSITE,12,0)) W !,"The following insurance overrides are currently entered:",!
  1.  S X=0 F  S X=$O(^BUDHSITE(BUDSITE,12,X)) Q:X'=+X  D
  1.  .W !?5,$P(^AUTNINS($P(^BUDHSITE(BUDSITE,12,X,0),U,1),0),U,1)
  1.  .S Y=$P(^BUDHSITE(BUDSITE,12,X,0),U,2) W ?40,$S(Y="P":"PRIVATE INSURANCE",Y="MCR":"MEDICARE",Y="MCD":"MEDICAID",Y="NI":"NONE/UNINSURED",1:"")
  1.  W ! S DA=BUDSITE,DR=1201,DIE="^BUDHSITE(" D ^DIE K DA,DR,DIE
  1. PCOV ;PROVIDER CLASS OVERRIDE, ADDED V12 T3 FOR HUNTER HEALTH, THESE PROVIDER CLASSES DO NOT COUNT AS A "PROVIDER" FOR UDS VISITS
  1.  W !!!,"Provider Class Exclusions from UDS visit definition."
  1.  W !,"UDS definition of a Provider:"
  1.  W !,"A provider is someone who assumes primary responsibility for assessing the"
  1.  W !,"patient and documenting services in the patient's record. Providers include"
  1.  W !,"only those who exercise independent judgment as to the services rendered to"
  1.  W !,"the patient during a visit."
  1.  W !!,"If there are provider class/disciplines that do not meet the above criteria"
  1.  W !,"you may add them to the list below and any visit on which the primary provider"
  1.  W !,"is of one of those disciplines/classes the visit will NOT be counted as a"
  1.  W !,"UDS visit."
  1.  W !!,"Note: Only exclude provider types who in your facility DO NOT exercise"
  1.  W !,"independent judgment as to the services rendered to the patient during a visit."
  1.  W !!
  1.  S DIR(0)="Y",DIR("A")="Would you like to review/edit the provider class exclusions",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G N
  1.  I 'Y G N
  1.  I '$O(^BUDHSITE(BUDSITE,13,0)) W !,"There are currently no provider class exclusions entered.",!
  1.  I $O(^BUDHSITE(BUDSITE,13,0)) W !,"The following provider class exclusions are currently entered:",!
  1.  S X=0 F  S X=$O(^BUDHSITE(BUDSITE,13,X)) Q:X'=+X  D
  1.  .W !?5,$P(^DIC(7,$P(^BUDHSITE(BUDSITE,13,X,0),U,1),0),U,1),"  ("_$P($G(^DIC(7,$P(^BUDHSITE(BUDSITE,13,X,0),U,1),9999999)),U,1),")"
  1.  W ! S DA=BUDSITE,DR=1301,DIE="^BUDHSITE(" D ^DIE K DA,DR,DIE
  1. N ;
  1.  S BUDDNT=2
  1.  G START
  1. EN ; -- main entry point for BUD UPDATE VISIT LOCATIONS
  1.  D EN^VALM("BUD 18 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(^BUDHSITE(BUDSITE,11,X)) Q:X'=+X  S BUDLIST($P(^DIC(4,$P(^BUDHSITE(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(^BUDHSITE(BUDSITE,11,BUDSEL(I),0),U),0),U) S BUDDISP(I)="",BUDVL("IDX",C,C)=BUDSEL(I)
  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(^BUDHSITE(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="^BUDHSITE("_BUDSITE_",11,",DIC(0)="L",DIC("P")=$P(^DD(90669.901,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(^BUDHSITE(BUDSITE,11,BUDX)) W !,$P(^DIC(4,BUDX,0),U),"     --already on list" Q
  1.  .D ^XBFMK
  1.  .S X="`"_BUDX,DIC="^BUDHSITE("_BUDSITE_",11,",DIC(0)="L",DIC("P")=$P(^DD(90669.901,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,BUDD="" F BUDI=1:1 S BUDD=$P(BUDANS,",",BUDI) Q:BUDD=""  S X=BUDVL("IDX",BUDD,BUDD) K ^BUDHSITE(BUDSITE,11,X,0),^BUDHSITE(BUDSITE,11,"B",X,X) W !,$P(^DIC(4,X,0),U)," removed from list"
  1.  S DA=BUDSITE,DIK="^BUDHSITE(" 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,VALMON,VALMEVL,VALMIOXY
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;