Routine: HBHCPROV

HBHCPROV ;HPS/DSK;HBHC Provider Definition/Edit; Feb 12, 2021@10:15

 ;;1.0;HOSPITAL BASED HOME CARE;**32**;NOV 01, 1993;Build 58

 ;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")

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

INIT ; -- init variables and list array

 N HBHCSQ,HBHCROW

 D CHGCAP^VALM("HEADER","")

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)

HDR ;

 S VALMHDR(1)="SQ.  Name                       ID   Team"

 S VALMHDR(2)="---- -------------------------- ---- --------------------------"

 D MAX

HDR2 ;

 S VALMHDR(1)="SQ.  Name                       Provider Class            Title"

 S VALMHDR(2)="---- -------------------------  ------------------------- ---------------------"

 S VALMSG="          ""*"" before name = HBPC PROVIDER"

 D MAX

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."

HELP ; -- help code

N X

 S X="?" D DISP^XQORM1 W !!

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

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)

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

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)

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

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

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

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)

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)

PRINT ;Print

 D PRTL^VALM1

EXIT ;

 K ^TMP("HBHC",$J),^TMP("HBHCLIST",$J),^TMP("HBHCSORT",$J)

 S VALMBG=1,VALMBCK="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"

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCPROV   16716     printed  Feb 18, 2025@23:24:32                                                                                                                                                                                                   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

HBHCPROV.m