- BUDBUPVL ; IHS/CMI/LAB - update visit locations UDS 30 Dec 2014 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 2014 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="^BUDBSITE(" D ^DIC
- I Y=-1 W !!,"No site selected" D EOJ Q
- S BUDSITE=+Y
- S DIE="^BUDBSITE(",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 14 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(^BUDBSITE(BUDSITE,11,X)) Q:X'=+X S BUDLIST($P(^DIC(4,$P(^BUDBSITE(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(^BUDBSITE(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(^BUDBSITE(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(^BUDBSITE(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="^BUDBSITE("_BUDSITE_",11,",DIC(0)="L",DIC("P")=$P(^DD(90666.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(^BUDBSITE(BUDSITE,11,BUDX)) W !,$P(^DIC(4,BUDX,0),U)," --already on list" Q
- .D ^XBFMK
- .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
- .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 ^BUDBSITE(BUDSITE,11,X,0),^BUDBSITE(BUDSITE,11,"B",X,X) W !,$P(^DIC(4,X,0),U)," removed from list"
- S DA=BUDSITE,DIK="^BUDBSITE(" 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
- ;
- 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
- +2 ;
- +3 ;
- START ;update visit locations
- +1 KILL BUDVL,BUDX,BUDY
- +2 IF $DATA(IOF)
- WRITE @IOF
- WRITE !!,"*** Update/Review UDS 2014 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="^BUDBSITE("
- DO ^DIC
- +15 IF Y=-1
- WRITE !!,"No site selected"
- DO EOJ
- QUIT
- +16 SET BUDSITE=+Y
- +17 SET DIE="^BUDBSITE("
- 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 14 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(^BUDBSITE(BUDSITE,11,X))
- IF X'=+X
- QUIT
- SET BUDLIST($PIECE(^DIC(4,$PIECE(^BUDBSITE(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(^BUDBSITE(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(^BUDBSITE(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(^BUDBSITE(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="^BUDBSITE("_BUDSITE_",11,"
- SET DIC(0)="L"
- SET DIC("P")=$PIECE(^DD(90666.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(^BUDBSITE(BUDSITE,11,BUDX))
- WRITE !,$PIECE(^DIC(4,BUDX,0),U)," --already on list"
- QUIT
- +8 DO ^XBFMK
- +9 SET X="`"_BUDX
- SET DIC="^BUDBSITE("_BUDSITE_",11,"
- SET DIC(0)="L"
- SET DIC("P")=$PIECE(^DD(90666.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 ^BUDBSITE(BUDSITE,11,X,0),^BUDBSITE(BUDSITE,11,"B",X,X)
- WRITE !,$PIECE(^DIC(4,X,0),U)," removed from list"
- +6 SET DA=BUDSITE
- SET DIK="^BUDBSITE("
- 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 ;