HBHCPROV ;HPS/DSK;HBHC Provider Definition/Edit; Feb 12, 2021@10:15
;;1.0;HOSPITAL BASED HOME CARE;**32**;NOV 01, 1993;Build 58
;
Q
;
;Integration Control Agreements:
;10060 - NEW PERSON (#200) file
;7262 - PROVIDER CLASS (53.5) field in the NEW PERSON (#200) file
;10104 - $$UP^XLFSTR
;
EN ;
;Entry point from the option.
;VALM variables are not new'd
N HBHCNAM,HBHCDDX,HBHCNP,HBHCFLAG,HBHCQUIT,HBHCPRT,HBHCMAX
;checking to see if 9999 providers have already been defined.
F HBHCMAX=1:1:10000 Q:'$D(^HBHC(631.4,"B",HBHCMAX))
S HBHCNP=1,HBHCQUIT=0
S VALMAR="^TMP(""HBHCLIST"",$J)"
D EN2
Q:HBHCQUIT
D EN^VALM("HBHC EDIT PROVIDER")
Q
;
EN2 ;
;Entry point from protocols
N DIR,Y,DTOUT,DUOUT
S HBHCFLAG=0
S DIR("A")="Partial or full name"
S DIR("B")=$G(HBHCNAM)
S DIR(0)="F"
D ^DIR
I $G(DTOUT)!($G(DUOUT))!($G(Y)="")!('$T) D Q
. S HBHCQUIT=1
. S VALMBCK="R"
S HBHCNAM=Y
I HBHCNAM=""!(HBHCNAM="^") Q
;convert to uppercase if lowercase entered
S HBHCNAM=$$UP^XLFSTR(HBHCNAM)
S HBHCDDX=0
K ^TMP("HBHC",$J),^TMP("HBHCLIST",$J)
I $G(HBHCNP) D
. D FIND^DIC(200,,".01;53.5","B",HBHCNAM,,,,,"^TMP(""HBHC"",$J)")
. D F200
I '$G(HBHCNP) D
. D FIND^DIC(631.4,,".01;1;5;6","M",HBHCNAM,,,,,"^TMP(""HBHC"",$J)")
. D F6314
S VALMBCK="R"
D INIT2
Q
;
INIT ; -- init variables and list array
N HBHCSQ,HBHCROW
D CHGCAP^VALM("HEADER","")
Q
;
INIT2 ;
S HBHCSQ="",VALMCNT=0,VALMBG=1
F S HBHCSQ=$O(^TMP("HBHCLIST",$J,HBHCSQ)) Q:HBHCSQ="" D
. S HBHCROW=^TMP("HBHCLIST",$J,HBHCSQ)
. S VALMCNT=VALMCNT+1
. D SET^VALM10(.VALMCNT,HBHCROW)
Q
;
HDR ;
S VALMHDR(1)="SQ. Name ID Team"
S VALMHDR(2)="---- -------------------------- ---- --------------------------"
D MAX
Q
;
HDR2 ;
S VALMHDR(1)="SQ. Name Provider Class Title"
S VALMHDR(2)="---- ------------------------- ------------------------- ---------------------"
S VALMSG=" ""*"" before name = HBPC PROVIDER"
D MAX
Q
;
MAX ;display warning message in toolbar
;re-checking to see if 9999 providers have already been defined.
F HBHCMAX=1:1:10000 Q:'$D(^HBHC(631.4,"B",HBHCMAX))
I HBHCMAX=10000 S VALMSG="*** ATTN *** NO MORE HBPC PROVIDERS MAY BE DEFINED." Q
I HBHCMAX>9800 S VALMSG="*** ATTN *** ONLY "_(10000-HBHCMAX)_" HBPC PROVIDER NUMBERS LEFT."
Q
;
HELP ; -- help code
N X
S X="?" D DISP^XQORM1 W !!
Q
;
F6314 ;
N HBHCSQ,HBHCARR,HBHCSP,HBHCLEN,HBHCSEQ
;HBHCLIST used for display.
;HBHCEDIT used for the edit option, detail display, and print.
K ^TMP("HBHCLIST",$J),^TMP("HBHCEDIT",$J)
D HDR
I $O(^TMP("HBHC",$J,"DILIST",0))="" D Q
. S ^TMP("HBHCLIST",$J,1)="No matching active entries in the HBPC PROVIDER (#631.4) file."
. S HBHCFLAG=1
S HBHCSP=" "
S HBHCLEN=$L($G(HBHCNAM))
S (HBHCSQ,HBHCSEQ,HBHCNP)=0
F S HBHCSQ=$O(^TMP("HBHC",$J,"DILIST","ID",HBHCSQ)) Q:HBHCSQ="" D
. K HBHCARR
. M HBHCARR=^TMP("HBHC",$J,"DILIST","ID",HBHCSQ)
. ;do not display inactive HBPC providers
. I HBHCARR(6)]"" Q
. I '$G(HBHCIENX),$G(HBHCNAM)]"",$E(HBHCARR(1),1,HBHCLEN)'=HBHCNAM Q
. I $G(HBHCIENX),HBHCARR(.01)'=HBHCIENX Q
. S HBHCSEQ=HBHCSEQ+1
. S ^TMP("HBHCLIST",$J,HBHCSEQ)=$E(HBHCSP,1,4-$L(HBHCSEQ))_HBHCSEQ_" "_$E($G(HBHCARR(1)),1,26)_" "
. S ^TMP("HBHCLIST",$J,HBHCSEQ)=^TMP("HBHCLIST",$J,HBHCSEQ)_$E(HBHCSP,1,26-$L($G(HBHCARR(1))))
. S ^TMP("HBHCLIST",$J,HBHCSEQ)=^TMP("HBHCLIST",$J,HBHCSEQ)_$G(HBHCARR(.01))_$E(HBHCSP,1,5-$L($G(HBHCARR(.01))))
. S ^TMP("HBHCLIST",$J,HBHCSEQ)=^TMP("HBHCLIST",$J,HBHCSEQ)_$E($G(HBHCARR(5)),1,25)_" "
. I $L($G(HBHCARR(5)))<25 S ^TMP("HBHCLIST",$J,HBHCSEQ)=^TMP("HBHCLIST",$J,HBHCSEQ)_$E(HBHCSP,1,26-$L($G(HBHCARR(5))))
. M ^TMP("HBHCEDIT",$J,HBHCSEQ)=HBHCARR
. ;Keep track of IEN in file 631.4
. S ^TMP("HBHCIDX",$J,HBHCSEQ)=^TMP("HBHC",$J,"DILIST",2,HBHCSQ)
I '$O(^TMP("HBHCLIST",$J,0)) D Q
. S ^TMP("HBHCLIST",$J,1)="No matching active entries in the HBPC PROVIDER (#631.4) file."
. S HBHCFLAG=1
Q
;
F200 ;
N HBHCSQ,HBHCARR,HBHCSP,HBHC200,HBHCTITLE,Y
K ^TMP("HBHCLIST",$J),^TMP("HBHCEDIT",$J),^TMP("HBHCIDX",$J)
D HDR2
I '$O(^TMP("HBHC",$J,"DILIST",0)) D Q
. S ^TMP("HBHCLIST",$J,1)="No matching entries in the NEW PERSON (#200) file."
S HBHCSP=" "
S HBHCSQ=""
F S HBHCSQ=$O(^TMP("HBHC",$J,"DILIST","ID",HBHCSQ)) Q:'HBHCSQ D
. K HBHCARR
. M HBHCARR=^TMP("HBHC",$J,"DILIST","ID",HBHCSQ)
. S ^TMP("HBHCLIST",$J,HBHCSQ)=$E(HBHCSP,1,4-$L(HBHCSQ))_HBHCSQ_" "
. S HBHC200=^TMP("HBHC",$J,"DILIST",2,HBHCSQ)
. ;Prefix with "*" if an active HBHC provider.
. I $D(^HBHC(631.4,"C",HBHC200)) D
. . N HBHCHIT,HBHCIEN
. . S (HBHCHIT,HBHCIEN)=0
. . F S HBHCIEN=$O(^HBHC(631.4,"C",HBHC200,HBHCIEN)) Q:HBHCIEN="" Q:HBHCHIT D
. . . I '$P(^HBHC(631.4,HBHCIEN,0),"^",7) S HBHCHIT=1
. . I HBHCHIT S HBHCARR(.01)="*"_HBHCARR(.01)
. S ^TMP("HBHCLIST",$J,HBHCSQ)=^TMP("HBHCLIST",$J,HBHCSQ)_$E($G(HBHCARR(.01)),1,25)_" "
. I $L($G(HBHCARR(.01)))<25 D
. . S ^TMP("HBHCLIST",$J,HBHCSQ)=^TMP("HBHCLIST",$J,HBHCSQ)_$E(HBHCSP,1,25-$L($G(HBHCARR(.01))))
. S ^TMP("HBHCLIST",$J,HBHCSQ)=^TMP("HBHCLIST",$J,HBHCSQ)_$E($G(HBHCARR(53.5)),1,25)_" "
. I $L($G(HBHCARR(53.5)))<25 D
. . S ^TMP("HBHCLIST",$J,HBHCSQ)=^TMP("HBHCLIST",$J,HBHCSQ)_$E(HBHCSP,1,25-$L($G(HBHCARR(53.5))))
. ;adding two spaces so columns will line up if no provider class
. I $G(HBHCARR(53.5))="" S ^TMP("HBHCLIST",$J,HBHCSQ)=^TMP("HBHCLIST",$J,HBHCSQ)_" "
. S HBHCTITLE=$$GET1^DIQ(200,HBHC200_",",8)
. S ^TMP("HBHCLIST",$J,HBHCSQ)=^TMP("HBHCLIST",$J,HBHCSQ)_$E(HBHCTITLE,1,20)
Q
;
ADD ;
N HBHCSQ,HBHCNAMX,HBHCNMX,HBHCTEAM,HBHCIEN,DIC
N X,HBHCNUM,HBHCNUMX,DIR,DTOUT,DUOUT,DA,HBHCLOCK,HBHCHIT
I HBHCMAX=10000 D Q
. W !,"NO MORE HBPC PROVIDERS MAY BE DEFINED."
. D PAUSE^VALM1
I '$G(HBHCNP) D Q
. W !,"This option may only be used after NP is invoked and a list displays."
. D PAUSE^VALM1
I $G(^TMP("HBHCLIST",$J,1))["No matching" D Q
. W !,"Display a list of entries from the New Person file."
. D PAUSE^VALM1
R !,"Enter sequence number of provider to add: ",HBHCSQ:DTIME
I HBHCSQ=""!(HBHCSQ="^") Q
I '$D(^TMP("HBHCLIST",$J,HBHCSQ)) D G ADD
. W !!,"Enter a valid sequence in the display."
S (HBHCHIT,HBHCLOCK)=0
S HBHCNAMX=^TMP("HBHC",$J,"DILIST",1,HBHCSQ),HBHCNMX=^TMP("HBHC",$J,"DILIST",2,HBHCSQ)
;Check to determine if: (1) entry is locked; (2) provider already has an active number
I $D(^HBHC(631.4,"C",+HBHCNMX)) D
. ;another user might be in the process of defining but is still in the session
. N HBHCIENX S HBHCIENX=""
. F S HBHCIENX=$O(^HBHC(631.4,"C",+HBHCNMX,HBHCIENX)) Q:HBHCIENX="" D
. . ;if the HBHC TEAM (#5) field is not yet defined, the other user is in
. . ;the process of adding this provider. The HBHC TEAM (#5) field is required.
. . I '$P(^HBHC(631.4,HBHCIENX,0),"^",6) D Q
. . . S HBHCLOCK=1
. . . W !,"Another user is in the process of adding this provider."
. . . D PAUSE^VALM1
. Q:HBHCLOCK
. ;Check all entries and allow a new entry if only inactive entries on file.
. N HBHCDUP
. S HBHCDUP=""
. F S HBHCDUP=$O(^HBHC(631.4,"C",+HBHCNMX,HBHCDUP)) Q:HBHCDUP="" D
. . I $P(^HBHC(631.4,HBHCDUP,0),"^",7)="" S HBHCHIT=HBHCDUP
. I HBHCHIT D
. . W !,"This provider has already been added with the HBPC Provider number of "
. . ;Only display last active entry if more than exists. (Procedurally, only one
. . ;active HBPC Provider number should be defined per new person entry. However,
. . ;sites might use FileMan for some reason.)
. . S HBHCNUMX=$P(^HBHC(631.4,+HBHCHIT,0),"^")
. . W HBHCNUMX,"."
. . D PAUSE^VALM1
I HBHCHIT!(HBHCLOCK) Q
W !,"NAME: ",HBHCNAMX
S DIR(0)="Y",DIR("A")="Do you wish to add this provider to the HBPC Provider file"
S DIR("B")="NO" D ^DIR
I $G(DTOUT)!($G(DUOUT))!('Y) Q
S HBHCIEN=^TMP("HBHC",$J,"DILIST",2,HBHCSQ)
F HBHCNUM=1:1:9999 Q:'$D(^HBHC(631.4,"B",HBHCNUM))
K DD,DO
S DIC="^HBHC(631.4,"
S DIC(0)=""
S DIC("DR")="1///^S X=""`""_HBHCIEN;5"
S X=HBHCNUM
D FILE^DICN
;refresh display
K ^TMP("HBHC",$J)
S HBHCIENX=HBHCNUM
D FIND^DIC(631.4,,".01;1;5;6","M",HBHCNAMX,,,,,"^TMP(""HBHC"",$J)")
D F6314
D INIT2
Q
;
EDIT ;
N HBHCSQ,HBHCARR,HBHCIENX,DA,DIE,DR,DIR,HBHCSAVE,HBHCSEQZ
;HBHCDDX = a detailed display was displayed previously
;'$D(HBHCNP) = a list of providers is not displayed
;$G(HBHCFLAG) = no matching providers in display
;$G(HBHCNP) = a New Person (#200) list is displayed
I $G(HBHCDDX)!('$D(HBHCNP))!($G(HBHCFLAG))!($G(HBHCNP)) D Q
. W !,"Display an HBPC Provider list first."
. D PAUSE^VALM1
. S VALMBCK="R"
I $G(^TMP("HBHCLIST",$J,1))["No matching" D Q
. W !,"Display a list of entries."
. D PAUSE^VALM1
R !,"Enter sequence number of provider to edit: ",HBHCSQ:DTIME
I HBHCSQ=""!(HBHCSQ="^") Q
I '$D(^TMP("HBHCLIST",$J,HBHCSQ)) D G EDIT
. W !!,"Enter a valid sequence in the display."
S HBHCSEQZ=HBHCSQ
M HBHCARR=^TMP("HBHCEDIT",$J,HBHCSQ)
S HBHCIENX=^TMP("HBHCIDX",$J,HBHCSQ)
L +^HBHC(631.4,HBHCIENX):2
I '$T D Q
. W !,"Another user is editing this entry."
. D PAUSE^VALM1
S HBHCFLAG=1
W !,"HBHC Provider Number: ",HBHCARR(.01)," Name: ",HBHCARR(1)
S DA=HBHCIENX
S DIE="^HBHC(631.4,"
S DR="5"
D ^DIE
L -^HBHC(631.4,HBHCIENX)
;Redisplay provider
S HBHCSAVE=$G(VALMBG)
D SAVE
S HBHCIENX=HBHCARR(.01)
D FIND^DIC(631.4,,".01;1;5;6","B",HBHCIENX,,,,,"^TMP(""HBHC"",$J)")
D F6314
K ^TMP("HBHCZ",$J)
M ^TMP("HBHCZ",$J)=^TMP("HBHCLIST",$J)
D INIT2
D EN^VALM("HBHC EDIT PROVIDER")
;After user hits enter, re-display previous list.
D GET
M ^TMP("HBHCLIST",$J,HBHCSEQZ)=^TMP("HBHCZ",$J,1)
S ^TMP("HBHCLIST",$J,HBHCSEQZ)=$E(" ",1,4-$L(HBHCSEQZ))_HBHCSEQZ_$E(^TMP("HBHCLIST",$J,HBHCSEQZ),5,99)
S ^TMP("HBHCLIST",$J,HBHCSEQZ,0)=^TMP("HBHCLIST",$J,HBHCSEQZ)
D INIT2
S VALMBCK="R",VALMBG=HBHCSAVE
S HBHCFLAG=0
K ^TMP("HBHCZ",$J)
Q
;
ALLPROV ;Display all active entries in the HBHC PROVIDER (#631.4) file
N DIR,HBHCSORT,HBHCSQ,HBHCSTR,HBHCNAME,HBHCSUB,HBHCSEQX,HBHCNUMX,HBHCSUB,HBHCIENX
S HBHCDDX=0
K ^TMP("HBHC",$J),^TMP("HBHCSORT",$J),^TMP("HBHCLIST",$J)
S DIR(0)="SB^A:ALPHABETICALLY;N:NUMERICALLY"
S DIR("A")="Sort alphabetically or numerically"
D ^DIR
I $G(DTOUT)!($G(DUOUT))!($G(Y)="")!('$T) S VALMBCK="R" Q
S HBHCSORT=Y,HBHCNAM=""
S (HBHCSQ,HBHCSEQX,HBHCIENX,HBHCFLAG)=0
F S HBHCSQ=$O(^HBHC(631.4,HBHCSQ)) Q:'HBHCSQ D
. S HBHCSEQX=HBHCSEQX+1
. S HBHCSTR=^HBHC(631.4,HBHCSQ,0)
. ;do not display inactive HBHC providers
. Q:$P(HBHCSTR,"^",7)]""
. ;store ien from file 631.4
. S $P(HBHCSTR,"^",8)=HBHCSQ
. S HBHCNAME=$P(HBHCSTR,"^",2),HBHCNAME=$P(^VA(200,+HBHCNAME,0),"^")
. S HBHCNUMX=$P(HBHCSTR,"^")
. ;Concatenate name with sequence if more than one provider has same name
. ;Concatenate with "." and new sequence if somehow two providers have the
. ;same number. (The only way for this to occur after install is if the site
. ;uses FileMan to define HBPC providers. Sites should not use FileMan.)
. I HBHCSORT="N",$D(^TMP("HBHCSORT",$J,HBHCNUMX)) D
. . F Q:'$D(^TMP("HBHCSORT",$J,HBHCNUMX)) S HBHCNUMX=HBHCNUMX+.01,HBHCNUMX=+(HBHCNUMX)
. S HBHCSUB=$S(HBHCSORT="A":HBHCNAME_HBHCSEQX,1:HBHCNUMX)
. S ^TMP("HBHCSORT",$J,HBHCSUB)=HBHCSTR
S (HBHCSQ,HBHCSEQX)=0
F S HBHCSQ=$O(^TMP("HBHCSORT",$J,HBHCSQ)) Q:HBHCSQ="" D
. S HBHCSTR=^TMP("HBHCSORT",$J,HBHCSQ)
. S HBHCSEQX=HBHCSEQX+1
. S ^TMP("HBHC",$J,"DILIST",1,HBHCSEQX)=$P(HBHCSTR,"^")
. S ^TMP("HBHC",$J,"DILIST",2,HBHCSEQX)=$P(HBHCSTR,"^",8)
. S ^TMP("HBHC",$J,"DILIST","ID",HBHCSEQX,.01)=$P(HBHCSTR,"^")
. S HBHCNAME=$P(HBHCSTR,"^",2),HBHCNAME=$P(^VA(200,+HBHCNAME,0),"^")
. S ^TMP("HBHC",$J,"DILIST","ID",HBHCSEQX,1)=HBHCNAME
. S ^TMP("HBHC",$J,"DILIST","ID",HBHCSEQX,5)=$G(^HBHC(633,+$P(HBHCSTR,"^",6),0))
. S ^TMP("HBHC",$J,"DILIST","ID",HBHCSEQX,6)=""
D F6314
S VALMBCK="R"
D INIT2
Q
;
DD ;Detailed display
I $G(HBHCDDX)!('$D(HBHCNP)) D Q
. W !,"Display a New Person or HBPC Provider list first."
. D PAUSE^VALM1
. S VALMBCK="R"
I $G(^TMP("HBHCLIST",$J,1))["No matching" D Q
. W !,"Display a list of entries."
. D PAUSE^VALM1
. S VALMBCK="R"
N HBHCSQ,HBHCNAMX,HBHCTEAM,HBHCTITLE,HBHCSERV,HBHCNUM,HBHCNUMX,HBHCARR,HBHCST
R !,"Enter sequence number of provider to display: ",HBHCSQ:DTIME
I HBHCSQ=""!(HBHCSQ="^") S VALMBCK="R" Q
I '$D(^TMP("HBHCLIST",$J,HBHCSQ)) D G DD
. W !,"Please try again: ",HBHCSQ," is an invalid sequence."
S HBHCDDX=1
;HBHCNP = Display is currently from New Person (#200) file.
S:HBHCNP HBHCNAMX=^TMP("HBHC",$J,"DILIST",1,HBHCSQ),HBHCNMX=^TMP("HBHC",$J,"DILIST",2,HBHCSQ)
I '$G(HBHCNP) D
. ;must perform several manipulations to find the IEN (HBHCNMX) in file 200.
. S HBHCNMX=^TMP("HBHCEDIT",$J,HBHCSQ,.01)
. S HBHCNMX=^TMP("HBHC",$J,"DILIST",2,HBHCSQ)
. S HBHCNMX=$P(^HBHC(631.4,HBHCNMX,0),"^",2)
. ;HBHCARR(53.5) = Provider Class
. S HBHCARR(53.5)=$$GET1^DIQ(200,HBHCNMX_",",53.5)
. ;HBHCNAMX = Provider Name
. S HBHCNAMX=^TMP("HBHCEDIT",$J,HBHCSQ,1)
. K ^TMP("HBHCLIST",$J)
. ;Display is from HBHC Provider (#631.4) file, so display that data first.
. D DDHP
K:HBHCNP ^TMP("HBHCLIST",$J)
S HBHCTITLE=$$GET1^DIQ(200,HBHCNMX_",",8)
S HBHCSERV=$$GET1^DIQ(200,HBHCNMX_",",29)
S HBHCST=$$GET1^DIQ(200,HBHCNMX_",",.115)
S ^TMP("HBHCLIST",$J,HBHCDDX)="New Person (#200) file IEN: "_HBHCNMX
S HBHCDDX=HBHCDDX+1
S ^TMP("HBHCLIST",$J,HBHCDDX)="Name: "_HBHCNAMX
S HBHCDDX=HBHCDDX+1
S ^TMP("HBHCLIST",$J,HBHCDDX)="Title: "_HBHCTITLE
S HBHCDDX=HBHCDDX+1
S ^TMP("HBHCLIST",$J,HBHCDDX)="Service/Section: "_HBHCSERV
S HBHCDDX=HBHCDDX+1
S ^TMP("HBHCLIST",$J,HBHCDDX)="Provider Class: "_$G(HBHCARR(53.5))
S HBHCDDX=HBHCDDX+1
S ^TMP("HBHCLIST",$J,HBHCDDX)="City, ST: "_$P($G(^VA(200,HBHCNMX,.11)),"^",4)
I HBHCST]"" S ^TMP("HBHCLIST",$J,HBHCDDX)=^TMP("HBHCLIST",$J,HBHCDDX)_", "_HBHCST
S HBHCDDX=HBHCDDX+1
S ^TMP("HBHCLIST",$J,HBHCDDX)="Date Entered in the New Person file: "_$$FMTE^XLFDT($P(^VA(200,HBHCNMX,1),"^",7))
S HBHCDDX=HBHCDDX+1
G:'HBHCNP DDFINISH
;
DDHP ;
N HBHCNUMX,HBHCDET,HBHCHIT
;Display all active entries in the HBHC Provider file for this provider.
;(There should be only one active entry, but it is possible using FileMan
; to define more than one.)
S (HBHCNUM,HBHCHIT)=0
F S HBHCNUM=$O(^HBHC(631.4,"C",HBHCNMX,HBHCNUM)) Q:HBHCNUM="" D
. ;do not display inactive HBHC Provider information
. Q:$P(^HBHC(631.4,HBHCNUM,0),"^",7)]""
. S HBHCDET(HBHCNUM)="",HBHCHIT=HBHCHIT+1
I '$D(HBHCDET) D
. S ^TMP("HBHCLIST",$J,HBHCDDX)="Defined as HBPC Provider number: None"
. S HBHCDDX=HBHCDDX+1
. S ^TMP("HBHCLIST",$J,HBHCDDX)="Member of HBPC Team: None"
S HBHCNUM=""
F S HBHCNUM=$O(HBHCDET(HBHCNUM)) Q:HBHCNUM="" D
. I HBHCHIT>1 S HBHCDDX=HBHCDDX+1
. S HBHCNUMX=$P(^HBHC(631.4,HBHCNUM,0),"^")
. S ^TMP("HBHCLIST",$J,HBHCDDX)="Defined as HBPC Provider number: "_HBHCNUMX
. S HBHCDDX=HBHCDDX+1
. S HBHCTEAM=$P(^HBHC(631.4,HBHCNUM,0),"^",6)
. S HBHCTEAM=$P(^HBHC(633,HBHCTEAM,0),"^")
. S ^TMP("HBHCLIST",$J,HBHCDDX)="Member of HBPC Team: "_HBHCTEAM
S:'HBHCNP HBHCDDX=HBHCDDX+1
I HBHCNP D DDFINISH
Q
;
DDFINISH ;
S VALMBCK="R"
S VALMHDR(1)=" Detailed Display"
S VALMHDR(2)="-------------------------------------------------------------------------------"
;Set HBHCNP to zero so user is forced to re-display New Person list if chooses to Add
S HBHCNP=0
D INIT2
Q
;
SAVE ;
K ^TMP("HBHCSAVE",$J),^TMP("HBHCLISTZ",$J),^TMP("HBHCEDITZ",$J)
M ^TMP("HBHCSAVE",$J)=^TMP("HBHC",$J)
M ^TMP("HBHCLISTZ",$J)=^TMP("HBHCLIST",$J)
M ^TMP("HBHCEDITZ",$J)=^TMP("HBHCEDIT",$J)
K ^TMP("HBHC",$J),^TMP("HBHCLIST",$J),^TMP("HBHCEDIT",$J)
Q
;
GET ;
K ^TMP("HBHC",$J),^TMP("HBHCLIST",$J),^TMP("HBHCEDIT",$J)
M ^TMP("HBHC",$J)=^TMP("HBHCSAVE",$J)
M ^TMP("HBHCLIST",$J)=^TMP("HBHCLISTZ",$J)
M ^TMP("HBHCEDIT",$J)=^TMP("HBHCEDITZ",$J)
Q
;
PRINT ;Print
D PRTL^VALM1
Q
;
EXIT ;
K ^TMP("HBHC",$J),^TMP("HBHCLIST",$J),^TMP("HBHCSORT",$J)
S VALMBG=1,VALMBCK="Q"
Q
;
EXITOPT ;
;called from EXIT ACTION of option HBHC EDIT PROVIDER
K ^TMP("HBHC",$J),^TMP("HBHCLIST",$J),^TMP("HBHCSORT",$J)
K ^TMP("HBHCLISTZ",$J),^TMP("HBHCSAVE",$J)
K ^TMP("HBHCEDIT",$J),^TMP("HBHCEDITZ",$J)
K ^TMP("HBHCIDX",$J)
S VALMBG=1,VALMBCK="Q"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCPROV 16716 printed Oct 16, 2024@17:58:56 Page 2
HBHCPROV ;HPS/DSK;HBHC Provider Definition/Edit; Feb 12, 2021@10:15
+1 ;;1.0;HOSPITAL BASED HOME CARE;**32**;NOV 01, 1993;Build 58
+2 ;
+3 QUIT
+4 ;
+5 ;Integration Control Agreements:
+6 ;10060 - NEW PERSON (#200) file
+7 ;7262 - PROVIDER CLASS (53.5) field in the NEW PERSON (#200) file
+8 ;10104 - $$UP^XLFSTR
+9 ;
EN ;
+1 ;Entry point from the option.
+2 ;VALM variables are not new'd
+3 NEW HBHCNAM,HBHCDDX,HBHCNP,HBHCFLAG,HBHCQUIT,HBHCPRT,HBHCMAX
+4 ;checking to see if 9999 providers have already been defined.
+5 FOR HBHCMAX=1:1:10000
if '$DATA(^HBHC(631.4,"B",HBHCMAX))
QUIT
+6 SET HBHCNP=1
SET HBHCQUIT=0
+7 SET VALMAR="^TMP(""HBHCLIST"",$J)"
+8 DO EN2
+9 if HBHCQUIT
QUIT
+10 DO EN^VALM("HBHC EDIT PROVIDER")
+11 QUIT
+12 ;
EN2 ;
+1 ;Entry point from protocols
+2 NEW DIR,Y,DTOUT,DUOUT
+3 SET HBHCFLAG=0
+4 SET DIR("A")="Partial or full name"
+5 SET DIR("B")=$GET(HBHCNAM)
+6 SET DIR(0)="F"
+7 DO ^DIR
+8 IF $GET(DTOUT)!($GET(DUOUT))!($GET(Y)="")!('$TEST)
Begin DoDot:1
+9 SET HBHCQUIT=1
+10 SET VALMBCK="R"
End DoDot:1
QUIT
+11 SET HBHCNAM=Y
+12 IF HBHCNAM=""!(HBHCNAM="^")
QUIT
+13 ;convert to uppercase if lowercase entered
+14 SET HBHCNAM=$$UP^XLFSTR(HBHCNAM)
+15 SET HBHCDDX=0
+16 KILL ^TMP("HBHC",$JOB),^TMP("HBHCLIST",$JOB)
+17 IF $GET(HBHCNP)
Begin DoDot:1
+18 DO FIND^DIC(200,,".01;53.5","B",HBHCNAM,,,,,"^TMP(""HBHC"",$J)")
+19 DO F200
End DoDot:1
+20 IF '$GET(HBHCNP)
Begin DoDot:1
+21 DO FIND^DIC(631.4,,".01;1;5;6","M",HBHCNAM,,,,,"^TMP(""HBHC"",$J)")
+22 DO F6314
End DoDot:1
+23 SET VALMBCK="R"
+24 DO INIT2
+25 QUIT
+26 ;
INIT ; -- init variables and list array
+1 NEW HBHCSQ,HBHCROW
+2 DO CHGCAP^VALM("HEADER","")
+3 QUIT
+4 ;
INIT2 ;
+1 SET HBHCSQ=""
SET VALMCNT=0
SET VALMBG=1
+2 FOR
SET HBHCSQ=$ORDER(^TMP("HBHCLIST",$JOB,HBHCSQ))
if HBHCSQ=""
QUIT
Begin DoDot:1
+3 SET HBHCROW=^TMP("HBHCLIST",$JOB,HBHCSQ)
+4 SET VALMCNT=VALMCNT+1
+5 DO SET^VALM10(.VALMCNT,HBHCROW)
End DoDot:1
+6 QUIT
+7 ;
HDR ;
+1 SET VALMHDR(1)="SQ. Name ID Team"
+2 SET VALMHDR(2)="---- -------------------------- ---- --------------------------"
+3 DO MAX
+4 QUIT
+5 ;
HDR2 ;
+1 SET VALMHDR(1)="SQ. Name Provider Class Title"
+2 SET VALMHDR(2)="---- ------------------------- ------------------------- ---------------------"
+3 SET VALMSG=" ""*"" before name = HBPC PROVIDER"
+4 DO MAX
+5 QUIT
+6 ;
MAX ;display warning message in toolbar
+1 ;re-checking to see if 9999 providers have already been defined.
+2 FOR HBHCMAX=1:1:10000
if '$DATA(^HBHC(631.4,"B",HBHCMAX))
QUIT
+3 IF HBHCMAX=10000
SET VALMSG="*** ATTN *** NO MORE HBPC PROVIDERS MAY BE DEFINED."
QUIT
+4 IF HBHCMAX>9800
SET VALMSG="*** ATTN *** ONLY "_(10000-HBHCMAX)_" HBPC PROVIDER NUMBERS LEFT."
+5 QUIT
+6 ;
HELP ; -- help code
+1 NEW X
+2 SET X="?"
DO DISP^XQORM1
WRITE !!
+3 QUIT
+4 ;
F6314 ;
+1 NEW HBHCSQ,HBHCARR,HBHCSP,HBHCLEN,HBHCSEQ
+2 ;HBHCLIST used for display.
+3 ;HBHCEDIT used for the edit option, detail display, and print.
+4 KILL ^TMP("HBHCLIST",$JOB),^TMP("HBHCEDIT",$JOB)
+5 DO HDR
+6 IF $ORDER(^TMP("HBHC",$JOB,"DILIST",0))=""
Begin DoDot:1
+7 SET ^TMP("HBHCLIST",$JOB,1)="No matching active entries in the HBPC PROVIDER (#631.4) file."
+8 SET HBHCFLAG=1
End DoDot:1
QUIT
+9 SET HBHCSP=" "
+10 SET HBHCLEN=$LENGTH($GET(HBHCNAM))
+11 SET (HBHCSQ,HBHCSEQ,HBHCNP)=0
+12 FOR
SET HBHCSQ=$ORDER(^TMP("HBHC",$JOB,"DILIST","ID",HBHCSQ))
if HBHCSQ=""
QUIT
Begin DoDot:1
+13 KILL HBHCARR
+14 MERGE HBHCARR=^TMP("HBHC",$JOB,"DILIST","ID",HBHCSQ)
+15 ;do not display inactive HBPC providers
+16 IF HBHCARR(6)]""
QUIT
+17 IF '$GET(HBHCIENX)
IF $GET(HBHCNAM)]""
IF $EXTRACT(HBHCARR(1),1,HBHCLEN)'=HBHCNAM
QUIT
+18 IF $GET(HBHCIENX)
IF HBHCARR(.01)'=HBHCIENX
QUIT
+19 SET HBHCSEQ=HBHCSEQ+1
+20 SET ^TMP("HBHCLIST",$JOB,HBHCSEQ)=$EXTRACT(HBHCSP,1,4-$LENGTH(HBHCSEQ))_HBHCSEQ_" "_$EXTRACT($GET(HBHCARR(1)),1,26)_" "
+21 SET ^TMP("HBHCLIST",$JOB,HBHCSEQ)=^TMP("HBHCLIST",$JOB,HBHCSEQ)_$EXTRACT(HBHCSP,1,26-$LENGTH($GET(HBHCARR(1))))
+22 SET ^TMP("HBHCLIST",$JOB,HBHCSEQ)=^TMP("HBHCLIST",$JOB,HBHCSEQ)_$GET(HBHCARR(.01))_$EXTRACT(HBHCSP,1,5-$LENGTH($GET(HBHCARR(.01))))
+23 SET ^TMP("HBHCLIST",$JOB,HBHCSEQ)=^TMP("HBHCLIST",$JOB,HBHCSEQ)_$EXTRACT($GET(HBHCARR(5)),1,25)_" "
+24 IF $LENGTH($GET(HBHCARR(5)))<25
SET ^TMP("HBHCLIST",$JOB,HBHCSEQ)=^TMP("HBHCLIST",$JOB,HBHCSEQ)_$EXTRACT(HBHCSP,1,26-$LENGTH($GET(HBHCARR(5))))
+25 MERGE ^TMP("HBHCEDIT",$JOB,HBHCSEQ)=HBHCARR
+26 ;Keep track of IEN in file 631.4
+27 SET ^TMP("HBHCIDX",$JOB,HBHCSEQ)=^TMP("HBHC",$JOB,"DILIST",2,HBHCSQ)
End DoDot:1
+28 IF '$ORDER(^TMP("HBHCLIST",$JOB,0))
Begin DoDot:1
+29 SET ^TMP("HBHCLIST",$JOB,1)="No matching active entries in the HBPC PROVIDER (#631.4) file."
+30 SET HBHCFLAG=1
End DoDot:1
QUIT
+31 QUIT
+32 ;
F200 ;
+1 NEW HBHCSQ,HBHCARR,HBHCSP,HBHC200,HBHCTITLE,Y
+2 KILL ^TMP("HBHCLIST",$JOB),^TMP("HBHCEDIT",$JOB),^TMP("HBHCIDX",$JOB)
+3 DO HDR2
+4 IF '$ORDER(^TMP("HBHC",$JOB,"DILIST",0))
Begin DoDot:1
+5 SET ^TMP("HBHCLIST",$JOB,1)="No matching entries in the NEW PERSON (#200) file."
End DoDot:1
QUIT
+6 SET HBHCSP=" "
+7 SET HBHCSQ=""
+8 FOR
SET HBHCSQ=$ORDER(^TMP("HBHC",$JOB,"DILIST","ID",HBHCSQ))
if 'HBHCSQ
QUIT
Begin DoDot:1
+9 KILL HBHCARR
+10 MERGE HBHCARR=^TMP("HBHC",$JOB,"DILIST","ID",HBHCSQ)
+11 SET ^TMP("HBHCLIST",$JOB,HBHCSQ)=$EXTRACT(HBHCSP,1,4-$LENGTH(HBHCSQ))_HBHCSQ_" "
+12 SET HBHC200=^TMP("HBHC",$JOB,"DILIST",2,HBHCSQ)
+13 ;Prefix with "*" if an active HBHC provider.
+14 IF $DATA(^HBHC(631.4,"C",HBHC200))
Begin DoDot:2
+15 NEW HBHCHIT,HBHCIEN
+16 SET (HBHCHIT,HBHCIEN)=0
+17 FOR
SET HBHCIEN=$ORDER(^HBHC(631.4,"C",HBHC200,HBHCIEN))
if HBHCIEN=""
QUIT
if HBHCHIT
QUIT
Begin DoDot:3
+18 IF '$PIECE(^HBHC(631.4,HBHCIEN,0),"^",7)
SET HBHCHIT=1
End DoDot:3
+19 IF HBHCHIT
SET HBHCARR(.01)="*"_HBHCARR(.01)
End DoDot:2
+20 SET ^TMP("HBHCLIST",$JOB,HBHCSQ)=^TMP("HBHCLIST",$JOB,HBHCSQ)_$EXTRACT($GET(HBHCARR(.01)),1,25)_" "
+21 IF $LENGTH($GET(HBHCARR(.01)))<25
Begin DoDot:2
+22 SET ^TMP("HBHCLIST",$JOB,HBHCSQ)=^TMP("HBHCLIST",$JOB,HBHCSQ)_$EXTRACT(HBHCSP,1,25-$LENGTH($GET(HBHCARR(.01))))
End DoDot:2
+23 SET ^TMP("HBHCLIST",$JOB,HBHCSQ)=^TMP("HBHCLIST",$JOB,HBHCSQ)_$EXTRACT($GET(HBHCARR(53.5)),1,25)_" "
+24 IF $LENGTH($GET(HBHCARR(53.5)))<25
Begin DoDot:2
+25 SET ^TMP("HBHCLIST",$JOB,HBHCSQ)=^TMP("HBHCLIST",$JOB,HBHCSQ)_$EXTRACT(HBHCSP,1,25-$LENGTH($GET(HBHCARR(53.5))))
End DoDot:2
+26 ;adding two spaces so columns will line up if no provider class
+27 IF $GET(HBHCARR(53.5))=""
SET ^TMP("HBHCLIST",$JOB,HBHCSQ)=^TMP("HBHCLIST",$JOB,HBHCSQ)_" "
+28 SET HBHCTITLE=$$GET1^DIQ(200,HBHC200_",",8)
+29 SET ^TMP("HBHCLIST",$JOB,HBHCSQ)=^TMP("HBHCLIST",$JOB,HBHCSQ)_$EXTRACT(HBHCTITLE,1,20)
End DoDot:1
+30 QUIT
+31 ;
ADD ;
+1 NEW HBHCSQ,HBHCNAMX,HBHCNMX,HBHCTEAM,HBHCIEN,DIC
+2 NEW X,HBHCNUM,HBHCNUMX,DIR,DTOUT,DUOUT,DA,HBHCLOCK,HBHCHIT
+3 IF HBHCMAX=10000
Begin DoDot:1
+4 WRITE !,"NO MORE HBPC PROVIDERS MAY BE DEFINED."
+5 DO PAUSE^VALM1
End DoDot:1
QUIT
+6 IF '$GET(HBHCNP)
Begin DoDot:1
+7 WRITE !,"This option may only be used after NP is invoked and a list displays."
+8 DO PAUSE^VALM1
End DoDot:1
QUIT
+9 IF $GET(^TMP("HBHCLIST",$JOB,1))["No matching"
Begin DoDot:1
+10 WRITE !,"Display a list of entries from the New Person file."
+11 DO PAUSE^VALM1
End DoDot:1
QUIT
+12 READ !,"Enter sequence number of provider to add: ",HBHCSQ:DTIME
+13 IF HBHCSQ=""!(HBHCSQ="^")
QUIT
+14 IF '$DATA(^TMP("HBHCLIST",$JOB,HBHCSQ))
Begin DoDot:1
+15 WRITE !!,"Enter a valid sequence in the display."
End DoDot:1
GOTO ADD
+16 SET (HBHCHIT,HBHCLOCK)=0
+17 SET HBHCNAMX=^TMP("HBHC",$JOB,"DILIST",1,HBHCSQ)
SET HBHCNMX=^TMP("HBHC",$JOB,"DILIST",2,HBHCSQ)
+18 ;Check to determine if: (1) entry is locked; (2) provider already has an active number
+19 IF $DATA(^HBHC(631.4,"C",+HBHCNMX))
Begin DoDot:1
+20 ;another user might be in the process of defining but is still in the session
+21 NEW HBHCIENX
SET HBHCIENX=""
+22 FOR
SET HBHCIENX=$ORDER(^HBHC(631.4,"C",+HBHCNMX,HBHCIENX))
if HBHCIENX=""
QUIT
Begin DoDot:2
+23 ;if the HBHC TEAM (#5) field is not yet defined, the other user is in
+24 ;the process of adding this provider. The HBHC TEAM (#5) field is required.
+25 IF '$PIECE(^HBHC(631.4,HBHCIENX,0),"^",6)
Begin DoDot:3
+26 SET HBHCLOCK=1
+27 WRITE !,"Another user is in the process of adding this provider."
+28 DO PAUSE^VALM1
End DoDot:3
QUIT
End DoDot:2
+29 if HBHCLOCK
QUIT
+30 ;Check all entries and allow a new entry if only inactive entries on file.
+31 NEW HBHCDUP
+32 SET HBHCDUP=""
+33 FOR
SET HBHCDUP=$ORDER(^HBHC(631.4,"C",+HBHCNMX,HBHCDUP))
if HBHCDUP=""
QUIT
Begin DoDot:2
+34 IF $PIECE(^HBHC(631.4,HBHCDUP,0),"^",7)=""
SET HBHCHIT=HBHCDUP
End DoDot:2
+35 IF HBHCHIT
Begin DoDot:2
+36 WRITE !,"This provider has already been added with the HBPC Provider number of "
+37 ;Only display last active entry if more than exists. (Procedurally, only one
+38 ;active HBPC Provider number should be defined per new person entry. However,
+39 ;sites might use FileMan for some reason.)
+40 SET HBHCNUMX=$PIECE(^HBHC(631.4,+HBHCHIT,0),"^")
+41 WRITE HBHCNUMX,"."
+42 DO PAUSE^VALM1
End DoDot:2
End DoDot:1
+43 IF HBHCHIT!(HBHCLOCK)
QUIT
+44 WRITE !,"NAME: ",HBHCNAMX
+45 SET DIR(0)="Y"
SET DIR("A")="Do you wish to add this provider to the HBPC Provider file"
+46 SET DIR("B")="NO"
DO ^DIR
+47 IF $GET(DTOUT)!($GET(DUOUT))!('Y)
QUIT
+48 SET HBHCIEN=^TMP("HBHC",$JOB,"DILIST",2,HBHCSQ)
+49 FOR HBHCNUM=1:1:9999
if '$DATA(^HBHC(631.4,"B",HBHCNUM))
QUIT
+50 KILL DD,DO
+51 SET DIC="^HBHC(631.4,"
+52 SET DIC(0)=""
+53 SET DIC("DR")="1///^S X=""`""_HBHCIEN;5"
+54 SET X=HBHCNUM
+55 DO FILE^DICN
+56 ;refresh display
+57 KILL ^TMP("HBHC",$JOB)
+58 SET HBHCIENX=HBHCNUM
+59 DO FIND^DIC(631.4,,".01;1;5;6","M",HBHCNAMX,,,,,"^TMP(""HBHC"",$J)")
+60 DO F6314
+61 DO INIT2
+62 QUIT
+63 ;
EDIT ;
+1 NEW HBHCSQ,HBHCARR,HBHCIENX,DA,DIE,DR,DIR,HBHCSAVE,HBHCSEQZ
+2 ;HBHCDDX = a detailed display was displayed previously
+3 ;'$D(HBHCNP) = a list of providers is not displayed
+4 ;$G(HBHCFLAG) = no matching providers in display
+5 ;$G(HBHCNP) = a New Person (#200) list is displayed
+6 IF $GET(HBHCDDX)!('$DATA(HBHCNP))!($GET(HBHCFLAG))!($GET(HBHCNP))
Begin DoDot:1
+7 WRITE !,"Display an HBPC Provider list first."
+8 DO PAUSE^VALM1
+9 SET VALMBCK="R"
End DoDot:1
QUIT
+10 IF $GET(^TMP("HBHCLIST",$JOB,1))["No matching"
Begin DoDot:1
+11 WRITE !,"Display a list of entries."
+12 DO PAUSE^VALM1
End DoDot:1
QUIT
+13 READ !,"Enter sequence number of provider to edit: ",HBHCSQ:DTIME
+14 IF HBHCSQ=""!(HBHCSQ="^")
QUIT
+15 IF '$DATA(^TMP("HBHCLIST",$JOB,HBHCSQ))
Begin DoDot:1
+16 WRITE !!,"Enter a valid sequence in the display."
End DoDot:1
GOTO EDIT
+17 SET HBHCSEQZ=HBHCSQ
+18 MERGE HBHCARR=^TMP("HBHCEDIT",$JOB,HBHCSQ)
+19 SET HBHCIENX=^TMP("HBHCIDX",$JOB,HBHCSQ)
+20 LOCK +^HBHC(631.4,HBHCIENX):2
+21 IF '$TEST
Begin DoDot:1
+22 WRITE !,"Another user is editing this entry."
+23 DO PAUSE^VALM1
End DoDot:1
QUIT
+24 SET HBHCFLAG=1
+25 WRITE !,"HBHC Provider Number: ",HBHCARR(.01)," Name: ",HBHCARR(1)
+26 SET DA=HBHCIENX
+27 SET DIE="^HBHC(631.4,"
+28 SET DR="5"
+29 DO ^DIE
+30 LOCK -^HBHC(631.4,HBHCIENX)
+31 ;Redisplay provider
+32 SET HBHCSAVE=$GET(VALMBG)
+33 DO SAVE
+34 SET HBHCIENX=HBHCARR(.01)
+35 DO FIND^DIC(631.4,,".01;1;5;6","B",HBHCIENX,,,,,"^TMP(""HBHC"",$J)")
+36 DO F6314
+37 KILL ^TMP("HBHCZ",$JOB)
+38 MERGE ^TMP("HBHCZ",$JOB)=^TMP("HBHCLIST",$JOB)
+39 DO INIT2
+40 DO EN^VALM("HBHC EDIT PROVIDER")
+41 ;After user hits enter, re-display previous list.
+42 DO GET
+43 MERGE ^TMP("HBHCLIST",$JOB,HBHCSEQZ)=^TMP("HBHCZ",$JOB,1)
+44 SET ^TMP("HBHCLIST",$JOB,HBHCSEQZ)=$EXTRACT(" ",1,4-$LENGTH(HBHCSEQZ))_HBHCSEQZ_$EXTRACT(^TMP("HBHCLIST",$JOB,HBHCSEQZ),5,99)
+45 SET ^TMP("HBHCLIST",$JOB,HBHCSEQZ,0)=^TMP("HBHCLIST",$JOB,HBHCSEQZ)
+46 DO INIT2
+47 SET VALMBCK="R"
SET VALMBG=HBHCSAVE
+48 SET HBHCFLAG=0
+49 KILL ^TMP("HBHCZ",$JOB)
+50 QUIT
+51 ;
ALLPROV ;Display all active entries in the HBHC PROVIDER (#631.4) file
+1 NEW DIR,HBHCSORT,HBHCSQ,HBHCSTR,HBHCNAME,HBHCSUB,HBHCSEQX,HBHCNUMX,HBHCSUB,HBHCIENX
+2 SET HBHCDDX=0
+3 KILL ^TMP("HBHC",$JOB),^TMP("HBHCSORT",$JOB),^TMP("HBHCLIST",$JOB)
+4 SET DIR(0)="SB^A:ALPHABETICALLY;N:NUMERICALLY"
+5 SET DIR("A")="Sort alphabetically or numerically"
+6 DO ^DIR
+7 IF $GET(DTOUT)!($GET(DUOUT))!($GET(Y)="")!('$TEST)
SET VALMBCK="R"
QUIT
+8 SET HBHCSORT=Y
SET HBHCNAM=""
+9 SET (HBHCSQ,HBHCSEQX,HBHCIENX,HBHCFLAG)=0
+10 FOR
SET HBHCSQ=$ORDER(^HBHC(631.4,HBHCSQ))
if 'HBHCSQ
QUIT
Begin DoDot:1
+11 SET HBHCSEQX=HBHCSEQX+1
+12 SET HBHCSTR=^HBHC(631.4,HBHCSQ,0)
+13 ;do not display inactive HBHC providers
+14 if $PIECE(HBHCSTR,"^",7)]""
QUIT
+15 ;store ien from file 631.4
+16 SET $PIECE(HBHCSTR,"^",8)=HBHCSQ
+17 SET HBHCNAME=$PIECE(HBHCSTR,"^",2)
SET HBHCNAME=$PIECE(^VA(200,+HBHCNAME,0),"^")
+18 SET HBHCNUMX=$PIECE(HBHCSTR,"^")
+19 ;Concatenate name with sequence if more than one provider has same name
+20 ;Concatenate with "." and new sequence if somehow two providers have the
+21 ;same number. (The only way for this to occur after install is if the site
+22 ;uses FileMan to define HBPC providers. Sites should not use FileMan.)
+23 IF HBHCSORT="N"
IF $DATA(^TMP("HBHCSORT",$JOB,HBHCNUMX))
Begin DoDot:2
+24 FOR
if '$DATA(^TMP("HBHCSORT",$JOB,HBHCNUMX))
QUIT
SET HBHCNUMX=HBHCNUMX+.01
SET HBHCNUMX=+(HBHCNUMX)
End DoDot:2
+25 SET HBHCSUB=$SELECT(HBHCSORT="A":HBHCNAME_HBHCSEQX,1:HBHCNUMX)
+26 SET ^TMP("HBHCSORT",$JOB,HBHCSUB)=HBHCSTR
End DoDot:1
+27 SET (HBHCSQ,HBHCSEQX)=0
+28 FOR
SET HBHCSQ=$ORDER(^TMP("HBHCSORT",$JOB,HBHCSQ))
if HBHCSQ=""
QUIT
Begin DoDot:1
+29 SET HBHCSTR=^TMP("HBHCSORT",$JOB,HBHCSQ)
+30 SET HBHCSEQX=HBHCSEQX+1
+31 SET ^TMP("HBHC",$JOB,"DILIST",1,HBHCSEQX)=$PIECE(HBHCSTR,"^")
+32 SET ^TMP("HBHC",$JOB,"DILIST",2,HBHCSEQX)=$PIECE(HBHCSTR,"^",8)
+33 SET ^TMP("HBHC",$JOB,"DILIST","ID",HBHCSEQX,.01)=$PIECE(HBHCSTR,"^")
+34 SET HBHCNAME=$PIECE(HBHCSTR,"^",2)
SET HBHCNAME=$PIECE(^VA(200,+HBHCNAME,0),"^")
+35 SET ^TMP("HBHC",$JOB,"DILIST","ID",HBHCSEQX,1)=HBHCNAME
+36 SET ^TMP("HBHC",$JOB,"DILIST","ID",HBHCSEQX,5)=$GET(^HBHC(633,+$PIECE(HBHCSTR,"^",6),0))
+37 SET ^TMP("HBHC",$JOB,"DILIST","ID",HBHCSEQX,6)=""
End DoDot:1
+38 DO F6314
+39 SET VALMBCK="R"
+40 DO INIT2
+41 QUIT
+42 ;
DD ;Detailed display
+1 IF $GET(HBHCDDX)!('$DATA(HBHCNP))
Begin DoDot:1
+2 WRITE !,"Display a New Person or HBPC Provider list first."
+3 DO PAUSE^VALM1
+4 SET VALMBCK="R"
End DoDot:1
QUIT
+5 IF $GET(^TMP("HBHCLIST",$JOB,1))["No matching"
Begin DoDot:1
+6 WRITE !,"Display a list of entries."
+7 DO PAUSE^VALM1
+8 SET VALMBCK="R"
End DoDot:1
QUIT
+9 NEW HBHCSQ,HBHCNAMX,HBHCTEAM,HBHCTITLE,HBHCSERV,HBHCNUM,HBHCNUMX,HBHCARR,HBHCST
+10 READ !,"Enter sequence number of provider to display: ",HBHCSQ:DTIME
+11 IF HBHCSQ=""!(HBHCSQ="^")
SET VALMBCK="R"
QUIT
+12 IF '$DATA(^TMP("HBHCLIST",$JOB,HBHCSQ))
Begin DoDot:1
+13 WRITE !,"Please try again: ",HBHCSQ," is an invalid sequence."
End DoDot:1
GOTO DD
+14 SET HBHCDDX=1
+15 ;HBHCNP = Display is currently from New Person (#200) file.
+16 if HBHCNP
SET HBHCNAMX=^TMP("HBHC",$JOB,"DILIST",1,HBHCSQ)
SET HBHCNMX=^TMP("HBHC",$JOB,"DILIST",2,HBHCSQ)
+17 IF '$GET(HBHCNP)
Begin DoDot:1
+18 ;must perform several manipulations to find the IEN (HBHCNMX) in file 200.
+19 SET HBHCNMX=^TMP("HBHCEDIT",$JOB,HBHCSQ,.01)
+20 SET HBHCNMX=^TMP("HBHC",$JOB,"DILIST",2,HBHCSQ)
+21 SET HBHCNMX=$PIECE(^HBHC(631.4,HBHCNMX,0),"^",2)
+22 ;HBHCARR(53.5) = Provider Class
+23 SET HBHCARR(53.5)=$$GET1^DIQ(200,HBHCNMX_",",53.5)
+24 ;HBHCNAMX = Provider Name
+25 SET HBHCNAMX=^TMP("HBHCEDIT",$JOB,HBHCSQ,1)
+26 KILL ^TMP("HBHCLIST",$JOB)
+27 ;Display is from HBHC Provider (#631.4) file, so display that data first.
+28 DO DDHP
End DoDot:1
+29 if HBHCNP
KILL ^TMP("HBHCLIST",$JOB)
+30 SET HBHCTITLE=$$GET1^DIQ(200,HBHCNMX_",",8)
+31 SET HBHCSERV=$$GET1^DIQ(200,HBHCNMX_",",29)
+32 SET HBHCST=$$GET1^DIQ(200,HBHCNMX_",",.115)
+33 SET ^TMP("HBHCLIST",$JOB,HBHCDDX)="New Person (#200) file IEN: "_HBHCNMX
+34 SET HBHCDDX=HBHCDDX+1
+35 SET ^TMP("HBHCLIST",$JOB,HBHCDDX)="Name: "_HBHCNAMX
+36 SET HBHCDDX=HBHCDDX+1
+37 SET ^TMP("HBHCLIST",$JOB,HBHCDDX)="Title: "_HBHCTITLE
+38 SET HBHCDDX=HBHCDDX+1
+39 SET ^TMP("HBHCLIST",$JOB,HBHCDDX)="Service/Section: "_HBHCSERV
+40 SET HBHCDDX=HBHCDDX+1
+41 SET ^TMP("HBHCLIST",$JOB,HBHCDDX)="Provider Class: "_$GET(HBHCARR(53.5))
+42 SET HBHCDDX=HBHCDDX+1
+43 SET ^TMP("HBHCLIST",$JOB,HBHCDDX)="City, ST: "_$PIECE($GET(^VA(200,HBHCNMX,.11)),"^",4)
+44 IF HBHCST]""
SET ^TMP("HBHCLIST",$JOB,HBHCDDX)=^TMP("HBHCLIST",$JOB,HBHCDDX)_", "_HBHCST
+45 SET HBHCDDX=HBHCDDX+1
+46 SET ^TMP("HBHCLIST",$JOB,HBHCDDX)="Date Entered in the New Person file: "_$$FMTE^XLFDT($PIECE(^VA(200,HBHCNMX,1),"^",7))
+47 SET HBHCDDX=HBHCDDX+1
+48 if 'HBHCNP
GOTO DDFINISH
+49 ;
DDHP ;
+1 NEW HBHCNUMX,HBHCDET,HBHCHIT
+2 ;Display all active entries in the HBHC Provider file for this provider.
+3 ;(There should be only one active entry, but it is possible using FileMan
+4 ; to define more than one.)
+5 SET (HBHCNUM,HBHCHIT)=0
+6 FOR
SET HBHCNUM=$ORDER(^HBHC(631.4,"C",HBHCNMX,HBHCNUM))
if HBHCNUM=""
QUIT
Begin DoDot:1
+7 ;do not display inactive HBHC Provider information
+8 if $PIECE(^HBHC(631.4,HBHCNUM,0),"^",7)]""
QUIT
+9 SET HBHCDET(HBHCNUM)=""
SET HBHCHIT=HBHCHIT+1
End DoDot:1
+10 IF '$DATA(HBHCDET)
Begin DoDot:1
+11 SET ^TMP("HBHCLIST",$JOB,HBHCDDX)="Defined as HBPC Provider number: None"
+12 SET HBHCDDX=HBHCDDX+1
+13 SET ^TMP("HBHCLIST",$JOB,HBHCDDX)="Member of HBPC Team: None"
End DoDot:1
+14 SET HBHCNUM=""
+15 FOR
SET HBHCNUM=$ORDER(HBHCDET(HBHCNUM))
if HBHCNUM=""
QUIT
Begin DoDot:1
+16 IF HBHCHIT>1
SET HBHCDDX=HBHCDDX+1
+17 SET HBHCNUMX=$PIECE(^HBHC(631.4,HBHCNUM,0),"^")
+18 SET ^TMP("HBHCLIST",$JOB,HBHCDDX)="Defined as HBPC Provider number: "_HBHCNUMX
+19 SET HBHCDDX=HBHCDDX+1
+20 SET HBHCTEAM=$PIECE(^HBHC(631.4,HBHCNUM,0),"^",6)
+21 SET HBHCTEAM=$PIECE(^HBHC(633,HBHCTEAM,0),"^")
+22 SET ^TMP("HBHCLIST",$JOB,HBHCDDX)="Member of HBPC Team: "_HBHCTEAM
End DoDot:1
+23 if 'HBHCNP
SET HBHCDDX=HBHCDDX+1
+24 IF HBHCNP
DO DDFINISH
+25 QUIT
+26 ;
DDFINISH ;
+1 SET VALMBCK="R"
+2 SET VALMHDR(1)=" Detailed Display"
+3 SET VALMHDR(2)="-------------------------------------------------------------------------------"
+4 ;Set HBHCNP to zero so user is forced to re-display New Person list if chooses to Add
+5 SET HBHCNP=0
+6 DO INIT2
+7 QUIT
+8 ;
SAVE ;
+1 KILL ^TMP("HBHCSAVE",$JOB),^TMP("HBHCLISTZ",$JOB),^TMP("HBHCEDITZ",$JOB)
+2 MERGE ^TMP("HBHCSAVE",$JOB)=^TMP("HBHC",$JOB)
+3 MERGE ^TMP("HBHCLISTZ",$JOB)=^TMP("HBHCLIST",$JOB)
+4 MERGE ^TMP("HBHCEDITZ",$JOB)=^TMP("HBHCEDIT",$JOB)
+5 KILL ^TMP("HBHC",$JOB),^TMP("HBHCLIST",$JOB),^TMP("HBHCEDIT",$JOB)
+6 QUIT
+7 ;
GET ;
+1 KILL ^TMP("HBHC",$JOB),^TMP("HBHCLIST",$JOB),^TMP("HBHCEDIT",$JOB)
+2 MERGE ^TMP("HBHC",$JOB)=^TMP("HBHCSAVE",$JOB)
+3 MERGE ^TMP("HBHCLIST",$JOB)=^TMP("HBHCLISTZ",$JOB)
+4 MERGE ^TMP("HBHCEDIT",$JOB)=^TMP("HBHCEDITZ",$JOB)
+5 QUIT
+6 ;
PRINT ;Print
+1 DO PRTL^VALM1
+2 QUIT
+3 ;
EXIT ;
+1 KILL ^TMP("HBHC",$JOB),^TMP("HBHCLIST",$JOB),^TMP("HBHCSORT",$JOB)
+2 SET VALMBG=1
SET VALMBCK="Q"
+3 QUIT
+4 ;
EXITOPT ;
+1 ;called from EXIT ACTION of option HBHC EDIT PROVIDER
+2 KILL ^TMP("HBHC",$JOB),^TMP("HBHCLIST",$JOB),^TMP("HBHCSORT",$JOB)
+3 KILL ^TMP("HBHCLISTZ",$JOB),^TMP("HBHCSAVE",$JOB)
+4 KILL ^TMP("HBHCEDIT",$JOB),^TMP("HBHCEDITZ",$JOB)
+5 KILL ^TMP("HBHCIDX",$JOB)
+6 SET VALMBG=1
SET VALMBCK="Q"
+7 QUIT
