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