ECPRVMUT ;ALB/JAM - Event Capture Multiple Provider Utilities ;24 Aug 05
;;2.0; EVENT CAPTURE ;**72**;8 May 96
;
GETPRV(ECIEN,OUTARR) ;Returns providers associated with an encounter
;*** This recall replaces GET^ECPRVUTL to allow for multiple providers
; instead of three.
; Input: ECIEN - IEN entry in file 721/^ECH(
;
; Output: OUTARR - output array with providers
; ^ECH IEN^provider ien^provider description^
; Primary/Secondary code^Primary/Secondary description
; returns 0 if successful or 1 if unsuccessful
;
I $G(ECIEN)="" Q 1 ;IEN not define.
I '$D(^ECH(ECIEN)) Q 1 ;IEN does not exist in file 721/^ECH(
I $O(^ECH(ECIEN,"PRV",0))="" Q 1 ;No provider on file for entry
N PRV,IEN,ECERR,SEQ,TYP,TYD,TMPARR,PRI,CNT,PRVARY
S PRI=0
D GETS^DIQ(721,ECIEN,"42*","IE","PRVARY","ECERR")
I $D(ECERR) Q 1 ;Error looking up entry
S SEQ="" F S SEQ=$O(PRVARY(721.042,SEQ)) Q:SEQ="" D
. S IEN=$G(PRVARY(721.042,SEQ,.01,"I")) I IEN="" Q
. S PRV=$G(PRVARY(721.042,SEQ,.01,"E")) I PRV="" S PRV="Unknown"
. S TYP=$G(PRVARY(721.042,SEQ,.02,"I")) I TYP="" S TYP="Ukn"
. S TYD=$G(PRVARY(721.042,SEQ,.02,"E")) I TYD="" S TYD="Unknown"
. I 'PRI,TYP="P" S PRI=1_U_$P(SEQ,",")
. I $P(SEQ,",")'="" S TMPARR($P(SEQ,","))=IEN_U_PRV_U_TYP_U_TYD
;set primary provider as first subscript
S CNT=1,PRI=$S(PRI:$P(PRI,U,2),1:$O(TMPARR(0))),OUTARR(CNT)=TMPARR(PRI)
K TMPARR(PRI)
S IEN=0 F S IEN=$O(TMPARR(IEN)) Q:'IEN D
. S CNT=CNT+1,OUTARR(CNT)=TMPARR(IEN)
Q $S($D(OUTARR):0,1:1)
;
GETPPRV(ECIEN,ECPPROV) ;returns primary provider associated with an encounter
; Input: ECIEN - IEN entry in file 721/^ECH(
;
; Output: ECPPROV - primary provider
; provider ien^provider description
; returns 0 if successful or 1 if unsuccessful
;
I $G(ECIEN)="" Q 1 ;IEN not define.
I '$D(^ECH(ECIEN)) Q 1 ;IEN does not exist in file 721/^ECH(
I $O(^ECH(ECIEN,"PRV",0))="" Q 1 ;No provider on file for entry
N PRVARY,PRV,IEN,ECERR,SEQ,ECOUT,TYP
S ECOUT=0
D GETS^DIQ(721,ECIEN,"42*","IE","PRVARY","ECERR")
I $D(ECERR) Q 1 ;Error looking up entry
S SEQ="" F S SEQ=$O(PRVARY(721.042,SEQ)) Q:SEQ="" D I ECOUT Q
. S IEN=$G(PRVARY(721.042,SEQ,.01,"I")) I IEN="" Q
. S PRV=$G(PRVARY(721.042,SEQ,.01,"E")) I PRV="" S PRV="Unknown"
. S TYP=$G(PRVARY(721.042,SEQ,.02,"I")) I TYP="" S TYD="Unknown"
. I TYP="P" S ECPPROV=IEN_U_PRV,ECOUT=1
Q $S($D(ECPPROV):0,1:1)
;
FILPRV(ECIEN,ECPRVARY,ECOUT) ;File multiple providers for an encounter
; Input: ECIEN - IEN entry in file 721/^ECH(
; ECPRVARY - array with providers
; ECOUT - Error flag (1/0)
;
; Output: returns 1 if successful or 0 if unsuccessful
;
I $G(ECIEN)="" Q 0 ;IEN not define.
I '$D(^ECH(ECIEN)) Q 0 ;IEN does not exist in file 721/^ECH(
I '$O(ECPRVARY(0)) Q 0 ;No entry in provider array
N SIEN,ECERR,ERR,ECPRVDA,ECDATA,DA,DIK
;delete old entries
S DA(1)=ECIEN,DIK="^ECH("_DA(1)_",""PRV"",",DA=0
F S DA=$O(^ECH(DA(1),"PRV",DA)) Q:'DA D ^DIK
S SIEN=0,ERR=""
F S SIEN=$O(ECPRVARY(SIEN)) Q:SIEN="" D
.K ECPRVDA,ECERR
.S ECDATA=ECPRVARY(SIEN)
.S ECPRVDA(721,"?1,",.01)=ECIEN
.S ECPRVDA(721.042,"+2,?1,",.01)=$P(ECDATA,U)
.S ECPRVDA(721.042,"+2,?1,",.02)=$P(ECDATA,U,3)
.D UPDATE^DIE("","ECPRVDA","","ECERR")
.I $D(ECERR) S ERR=ERR_SIEN_";"
Q $S(ERR="":1,1:"0^"_ERR)
;
DSPPRV ;Display providers
N ECX,ECDAT,ECW
W "Encounter Providers"
S ECX=0 F S ECX=$O(ECPRVARY(ECX)) Q:'ECX D
.S ECDAT=ECPRVARY(ECX)
.W !,?3,$P(ECDAT,U),?15,$P(ECDAT,U,2) I $P(ECDAT,U,3)="P" W " (Primary)"
Q
ASKPRV(ECIEN,ECDT,ECPRVARY,ECOUT) ;ask provider question (primary and multiple secondary)
; Variables: ECIEN - IEN entry in file 721/^ECH(
; ECDT - date/time of encounter
; ECPRVARY - array with providers
; ECOUT - Error flag (1/0)
;
; Output: returns 1 if successful or 0 if unsuccessful
N ECINF
K ECPRVARY,ECPRV,ECPRVN
;get providers
I $G(ECIEN)'="" D
.S ECINF=$$GETPRV(ECIEN,.ECPRVARY)
.S ECINF=$$GETPPRV(ECIEN,.ECPRVN) I 'ECINF S ECPRV=$P(ECPRVN,U),ECPRVN=$P(ECPRVN,U,2)
;display providers
I $O(ECPRVARY(""))'="" D DSPPRV
;ask for primary provider
D PPRV I $G(ECOUT) Q
;ask for secondary provider
D SPRV
Q
PPRV ;Ask primary provider
; Variables: ECPRV = Primary provider ien
; ECPRVN = Primary provider descript, default if define
; ECPRVARY= Array with providers
; subscript=provider IEN,
; data=(P)rimary_^_provider description
; ECOUT = Error flag (1/0)
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECW,X,Y,IEN
S ECPRV=$G(ECPRV),ECPRVN=$G(ECPRVN)
S DIR(0)="P^VA(200,:AEZQM",DIR("A")="Primary Provider"
S DIR("?")="Enter the provider responsible for providing primary care for this encounter."
I ECPRV'="" S DIR("B")=$$DICLK^ECPRVUTL(ECPRV)
;get provider with active person class
S DIR("S")="I +$$GET^XUA4A72(+Y,$G(ECDT,DT))>0"
D ^DIR
I +Y>0 D Q
.;check if provider exist as secondary and remove.
.S IEN=0
.F S IEN=$O(ECPRVARY(IEN)) Q:'IEN I $P(ECPRVARY(IEN),U,3)'="P" D
..I +ECPRVARY(IEN)=+Y D
...W !?25,"*** (Provider removed as secondary.) ***" K ECPRVARY(IEN)
.S ECW=$$CLASS^ECPRVUTL(+Y,$G(ECDT,DT))
.S ECPRV=+Y,ECPRVN=Y(0,0),ECPRVARY(1)=ECPRV_"^"_Y(0,0)_"^P^PRIMARY"
S ECOUT=1 Q
Q
SPRV ;Ask secondary provider(s)
; Variables: ECPRV = Primary provider ien, default if define
; ECPRVARY= Array with providers
; subscript=provider IEN,
; data=(S)econdary_^_provider description
;
N Y,X,DEF,DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,CNT,X,Y
;create "B" xref and subscript by provider ien in array ECPRVARY
;set last provider as default
S DEF="",IEN=$O(ECPRVARY(""),-1),CNT=+IEN+1 I IEN D
.I $P(ECPRVARY(IEN),U)'=$G(ECPRV) S DEF=$P(ECPRVARY(IEN),U)
S IEN=0
F S IEN=$O(ECPRVARY(IEN)) Q:'IEN I $P(ECPRVARY(IEN),U,3)'="P" D
.S ECPRVARY("B",+ECPRVARY(IEN))=IEN
S:DEF'="" DIR("B")=$$DICLK^ECPRVUTL(DEF) ;DIR("B")="`"_DEF
S DIR(0)="PO^VA(200,:AEZQM",DIR("A")="Secondary Provider"
S DIR("?")="^D PRVHLP^ECPRVMUT"
;get providers with active person class
S DIR("S")="I +$$GET^XUA4A72(+Y,$G(ECDT,DT))>0"
F D ^DIR S:$D(DUOUT) ECOUT=1 Q:(X="")!($D(DTOUT))!($D(DUOUT)) D
.I +Y>0,+Y=$G(ECPRV) W " Provider already entered as primary." Q
.I +Y=DEF K DIR("B") S DEF="" Q
.I X="@",DEF'="" D Q
..I DEF=$G(ECPRV) W " Provider flag as primary. Can't delete." Q
..W " "_$$GET1^DIQ(200,DEF,.01)_"...deleted"
..K ECPRVARY(ECPRVARY("B",DEF)),ECPRVARY("B",DEF),DIR("B")
.Q:+Y<0 I $D(ECPRVARY("B",+Y)) S DEF=+Y,DIR("B")=$$DICLK^ECPRVUTL(DEF) Q
.S ECW=$$CLASS^ECPRVUTL(+Y,$G(ECDT,DT))
.S ECPRVARY("B",+Y)=CNT,ECPRVARY(CNT)=+Y_"^"_Y(0,0)_"^S^SECONDARY"
.S DEF="",CNT=CNT+1 K DIR("B")
K ECPRVARY("B")
Q
PRVHLP ;Help for Provider Code
N DIC,PRV,D
I $D(ECPRVARY) D
.W !?1,"Provider Already Entered:" S PRV=0
.F S PRV=$O(ECPRVARY(PRV)) Q:'PRV D
..W !,?3,$P(ECPRVARY(PRV),U),?15,$P(ECPRVARY(PRV),U,2)
..I $P(ECPRVARY(PRV),U,3)="P" W " (Primary)"
W !?1,"You may enter a new Provider, if you wish. Enter the secondary Provider"
W !?1,"for this procedure."
Q
;
COMP(ECUX,ECDTX) ;get provider information, similar to COMP^ECPRVUTL
;Input: ECUX = IEN in file #200
; ECDTX = Date of encounter
;
;Output: ECUX = ien in file #200^name^compress person class info
;
I $G(ECUX)="" Q
S ECDTX=$G(ECDTX,DT)
;build ECUX=ien in file #200^name^person class ien^occupation^specialty^
; subspecialty^etc.
S ECUX=+ECUX_"^"_$$GET1^DIQ(200,+ECUX,.01)_"^"_$$GET^XUA4A72(+ECUX,ECDTX)
D COMP^ECPRVUTL(.ECUX,ECDTX)
Q
DSP1416(ECPRVARY) ;Display providers for data entry options
N ECI,ECDAT,ECUP,CNT
S (ECI,CNT)=0 F S ECI=$O(ECPRVARY(ECI)) Q:'ECI D
.S ECDAT=ECPRVARY(ECI),CNT=CNT+1
.W !,"Provider"_$S(CNT=1:"",1:" #"_CNT)_":",?14,$P(ECDAT,U,2)
.I +$P(ECDAT,U) S ECUP=+$P(ECDAT,U) D COMP(.ECUP,$G(ECDT,DT)) D
..W !?16,$P(ECUP,"^",3)
Q
DSP1442(ECPRVARY) ;Display providers for data entry options
N ECI,ECDAT,ECUP,CNT
S (ECI,CNT)=0 F S ECI=$O(ECPRVARY(ECI)) Q:'ECI D
.S ECDAT=ECPRVARY(ECI),CNT=CNT+1
.W !,"Provider"_$S(CNT=1:"",1:" #"_CNT)_":",?14,$E($P(ECDAT,U,2),1,24)
.I +$P(ECDAT,U) S ECUP=+$P(ECDAT,U) D COMP^ECPRVMUT(.ECUP,$G(ECDT,DT)) D
..W ?42,$E($P(ECUP,U,3),1,36)
Q
DSP1444(ECPRVARY) ;Display providers for data entry options
N ECI,ECDAT,ECUP,CNT
S (ECI,CNT)=0 F S ECI=$O(ECPRVARY(ECI)) Q:'ECI D
.S ECDAT=ECPRVARY(ECI),CNT=CNT+1
.W !,"Provider"_$S(CNT=1:"",1:" #"_CNT)_":",?14,$E($P(ECDAT,U,2),1,24)
.I +$P(ECDAT,U) S ECUP=+$P(ECDAT,U) D COMP^ECPRVMUT(.ECUP,$G(ECDT,DT)) D
..W ?44,$E($P(ECUP,U,3),1,34)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECPRVMUT 8938 printed Apr 09, 2024@21:02:06 Page 2
ECPRVMUT ;ALB/JAM - Event Capture Multiple Provider Utilities ;24 Aug 05
+1 ;;2.0; EVENT CAPTURE ;**72**;8 May 96
+2 ;
GETPRV(ECIEN,OUTARR) ;Returns providers associated with an encounter
+1 ;*** This recall replaces GET^ECPRVUTL to allow for multiple providers
+2 ; instead of three.
+3 ; Input: ECIEN - IEN entry in file 721/^ECH(
+4 ;
+5 ; Output: OUTARR - output array with providers
+6 ; ^ECH IEN^provider ien^provider description^
+7 ; Primary/Secondary code^Primary/Secondary description
+8 ; returns 0 if successful or 1 if unsuccessful
+9 ;
+10 ;IEN not define.
IF $GET(ECIEN)=""
QUIT 1
+11 ;IEN does not exist in file 721/^ECH(
IF '$DATA(^ECH(ECIEN))
QUIT 1
+12 ;No provider on file for entry
IF $ORDER(^ECH(ECIEN,"PRV",0))=""
QUIT 1
+13 NEW PRV,IEN,ECERR,SEQ,TYP,TYD,TMPARR,PRI,CNT,PRVARY
+14 SET PRI=0
+15 DO GETS^DIQ(721,ECIEN,"42*","IE","PRVARY","ECERR")
+16 ;Error looking up entry
IF $DATA(ECERR)
QUIT 1
+17 SET SEQ=""
FOR
SET SEQ=$ORDER(PRVARY(721.042,SEQ))
if SEQ=""
QUIT
Begin DoDot:1
+18 SET IEN=$GET(PRVARY(721.042,SEQ,.01,"I"))
IF IEN=""
QUIT
+19 SET PRV=$GET(PRVARY(721.042,SEQ,.01,"E"))
IF PRV=""
SET PRV="Unknown"
+20 SET TYP=$GET(PRVARY(721.042,SEQ,.02,"I"))
IF TYP=""
SET TYP="Ukn"
+21 SET TYD=$GET(PRVARY(721.042,SEQ,.02,"E"))
IF TYD=""
SET TYD="Unknown"
+22 IF 'PRI
IF TYP="P"
SET PRI=1_U_$PIECE(SEQ,",")
+23 IF $PIECE(SEQ,",")'=""
SET TMPARR($PIECE(SEQ,","))=IEN_U_PRV_U_TYP_U_TYD
End DoDot:1
+24 ;set primary provider as first subscript
+25 SET CNT=1
SET PRI=$SELECT(PRI:$PIECE(PRI,U,2),1:$ORDER(TMPARR(0)))
SET OUTARR(CNT)=TMPARR(PRI)
+26 KILL TMPARR(PRI)
+27 SET IEN=0
FOR
SET IEN=$ORDER(TMPARR(IEN))
if 'IEN
QUIT
Begin DoDot:1
+28 SET CNT=CNT+1
SET OUTARR(CNT)=TMPARR(IEN)
End DoDot:1
+29 QUIT $SELECT($DATA(OUTARR):0,1:1)
+30 ;
GETPPRV(ECIEN,ECPPROV) ;returns primary provider associated with an encounter
+1 ; Input: ECIEN - IEN entry in file 721/^ECH(
+2 ;
+3 ; Output: ECPPROV - primary provider
+4 ; provider ien^provider description
+5 ; returns 0 if successful or 1 if unsuccessful
+6 ;
+7 ;IEN not define.
IF $GET(ECIEN)=""
QUIT 1
+8 ;IEN does not exist in file 721/^ECH(
IF '$DATA(^ECH(ECIEN))
QUIT 1
+9 ;No provider on file for entry
IF $ORDER(^ECH(ECIEN,"PRV",0))=""
QUIT 1
+10 NEW PRVARY,PRV,IEN,ECERR,SEQ,ECOUT,TYP
+11 SET ECOUT=0
+12 DO GETS^DIQ(721,ECIEN,"42*","IE","PRVARY","ECERR")
+13 ;Error looking up entry
IF $DATA(ECERR)
QUIT 1
+14 SET SEQ=""
FOR
SET SEQ=$ORDER(PRVARY(721.042,SEQ))
if SEQ=""
QUIT
Begin DoDot:1
+15 SET IEN=$GET(PRVARY(721.042,SEQ,.01,"I"))
IF IEN=""
QUIT
+16 SET PRV=$GET(PRVARY(721.042,SEQ,.01,"E"))
IF PRV=""
SET PRV="Unknown"
+17 SET TYP=$GET(PRVARY(721.042,SEQ,.02,"I"))
IF TYP=""
SET TYD="Unknown"
+18 IF TYP="P"
SET ECPPROV=IEN_U_PRV
SET ECOUT=1
End DoDot:1
IF ECOUT
QUIT
+19 QUIT $SELECT($DATA(ECPPROV):0,1:1)
+20 ;
FILPRV(ECIEN,ECPRVARY,ECOUT) ;File multiple providers for an encounter
+1 ; Input: ECIEN - IEN entry in file 721/^ECH(
+2 ; ECPRVARY - array with providers
+3 ; ECOUT - Error flag (1/0)
+4 ;
+5 ; Output: returns 1 if successful or 0 if unsuccessful
+6 ;
+7 ;IEN not define.
IF $GET(ECIEN)=""
QUIT 0
+8 ;IEN does not exist in file 721/^ECH(
IF '$DATA(^ECH(ECIEN))
QUIT 0
+9 ;No entry in provider array
IF '$ORDER(ECPRVARY(0))
QUIT 0
+10 NEW SIEN,ECERR,ERR,ECPRVDA,ECDATA,DA,DIK
+11 ;delete old entries
+12 SET DA(1)=ECIEN
SET DIK="^ECH("_DA(1)_",""PRV"","
SET DA=0
+13 FOR
SET DA=$ORDER(^ECH(DA(1),"PRV",DA))
if 'DA
QUIT
DO ^DIK
+14 SET SIEN=0
SET ERR=""
+15 FOR
SET SIEN=$ORDER(ECPRVARY(SIEN))
if SIEN=""
QUIT
Begin DoDot:1
+16 KILL ECPRVDA,ECERR
+17 SET ECDATA=ECPRVARY(SIEN)
+18 SET ECPRVDA(721,"?1,",.01)=ECIEN
+19 SET ECPRVDA(721.042,"+2,?1,",.01)=$PIECE(ECDATA,U)
+20 SET ECPRVDA(721.042,"+2,?1,",.02)=$PIECE(ECDATA,U,3)
+21 DO UPDATE^DIE("","ECPRVDA","","ECERR")
+22 IF $DATA(ECERR)
SET ERR=ERR_SIEN_";"
End DoDot:1
+23 QUIT $SELECT(ERR="":1,1:"0^"_ERR)
+24 ;
DSPPRV ;Display providers
+1 NEW ECX,ECDAT,ECW
+2 WRITE "Encounter Providers"
+3 SET ECX=0
FOR
SET ECX=$ORDER(ECPRVARY(ECX))
if 'ECX
QUIT
Begin DoDot:1
+4 SET ECDAT=ECPRVARY(ECX)
+5 WRITE !,?3,$PIECE(ECDAT,U),?15,$PIECE(ECDAT,U,2)
IF $PIECE(ECDAT,U,3)="P"
WRITE " (Primary)"
End DoDot:1
+6 QUIT
ASKPRV(ECIEN,ECDT,ECPRVARY,ECOUT) ;ask provider question (primary and multiple secondary)
+1 ; Variables: ECIEN - IEN entry in file 721/^ECH(
+2 ; ECDT - date/time of encounter
+3 ; ECPRVARY - array with providers
+4 ; ECOUT - Error flag (1/0)
+5 ;
+6 ; Output: returns 1 if successful or 0 if unsuccessful
+7 NEW ECINF
+8 KILL ECPRVARY,ECPRV,ECPRVN
+9 ;get providers
+10 IF $GET(ECIEN)'=""
Begin DoDot:1
+11 SET ECINF=$$GETPRV(ECIEN,.ECPRVARY)
+12 SET ECINF=$$GETPPRV(ECIEN,.ECPRVN)
IF 'ECINF
SET ECPRV=$PIECE(ECPRVN,U)
SET ECPRVN=$PIECE(ECPRVN,U,2)
End DoDot:1
+13 ;display providers
+14 IF $ORDER(ECPRVARY(""))'=""
DO DSPPRV
+15 ;ask for primary provider
+16 DO PPRV
IF $GET(ECOUT)
QUIT
+17 ;ask for secondary provider
+18 DO SPRV
+19 QUIT
PPRV ;Ask primary provider
+1 ; Variables: ECPRV = Primary provider ien
+2 ; ECPRVN = Primary provider descript, default if define
+3 ; ECPRVARY= Array with providers
+4 ; subscript=provider IEN,
+5 ; data=(P)rimary_^_provider description
+6 ; ECOUT = Error flag (1/0)
+7 ;
+8 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECW,X,Y,IEN
+9 SET ECPRV=$GET(ECPRV)
SET ECPRVN=$GET(ECPRVN)
+10 SET DIR(0)="P^VA(200,:AEZQM"
SET DIR("A")="Primary Provider"
+11 SET DIR("?")="Enter the provider responsible for providing primary care for this encounter."
+12 IF ECPRV'=""
SET DIR("B")=$$DICLK^ECPRVUTL(ECPRV)
+13 ;get provider with active person class
+14 SET DIR("S")="I +$$GET^XUA4A72(+Y,$G(ECDT,DT))>0"
+15 DO ^DIR
+16 IF +Y>0
Begin DoDot:1
+17 ;check if provider exist as secondary and remove.
+18 SET IEN=0
+19 FOR
SET IEN=$ORDER(ECPRVARY(IEN))
if 'IEN
QUIT
IF $PIECE(ECPRVARY(IEN),U,3)'="P"
Begin DoDot:2
+20 IF +ECPRVARY(IEN)=+Y
Begin DoDot:3
+21 WRITE !?25,"*** (Provider removed as secondary.) ***"
KILL ECPRVARY(IEN)
End DoDot:3
End DoDot:2
+22 SET ECW=$$CLASS^ECPRVUTL(+Y,$GET(ECDT,DT))
+23 SET ECPRV=+Y
SET ECPRVN=Y(0,0)
SET ECPRVARY(1)=ECPRV_"^"_Y(0,0)_"^P^PRIMARY"
End DoDot:1
QUIT
+24 SET ECOUT=1
QUIT
+25 QUIT
SPRV ;Ask secondary provider(s)
+1 ; Variables: ECPRV = Primary provider ien, default if define
+2 ; ECPRVARY= Array with providers
+3 ; subscript=provider IEN,
+4 ; data=(S)econdary_^_provider description
+5 ;
+6 NEW Y,X,DEF,DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,CNT,X,Y
+7 ;create "B" xref and subscript by provider ien in array ECPRVARY
+8 ;set last provider as default
+9 SET DEF=""
SET IEN=$ORDER(ECPRVARY(""),-1)
SET CNT=+IEN+1
IF IEN
Begin DoDot:1
+10 IF $PIECE(ECPRVARY(IEN),U)'=$GET(ECPRV)
SET DEF=$PIECE(ECPRVARY(IEN),U)
End DoDot:1
+11 SET IEN=0
+12 FOR
SET IEN=$ORDER(ECPRVARY(IEN))
if 'IEN
QUIT
IF $PIECE(ECPRVARY(IEN),U,3)'="P"
Begin DoDot:1
+13 SET ECPRVARY("B",+ECPRVARY(IEN))=IEN
End DoDot:1
+14 ;DIR("B")="`"_DEF
if DEF'=""
SET DIR("B")=$$DICLK^ECPRVUTL(DEF)
+15 SET DIR(0)="PO^VA(200,:AEZQM"
SET DIR("A")="Secondary Provider"
+16 SET DIR("?")="^D PRVHLP^ECPRVMUT"
+17 ;get providers with active person class
+18 SET DIR("S")="I +$$GET^XUA4A72(+Y,$G(ECDT,DT))>0"
+19 FOR
DO ^DIR
if $DATA(DUOUT)
SET ECOUT=1
if (X="")!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
Begin DoDot:1
+20 IF +Y>0
IF +Y=$GET(ECPRV)
WRITE " Provider already entered as primary."
QUIT
+21 IF +Y=DEF
KILL DIR("B")
SET DEF=""
QUIT
+22 IF X="@"
IF DEF'=""
Begin DoDot:2
+23 IF DEF=$GET(ECPRV)
WRITE " Provider flag as primary. Can't delete."
QUIT
+24 WRITE " "_$$GET1^DIQ(200,DEF,.01)_"...deleted"
+25 KILL ECPRVARY(ECPRVARY("B",DEF)),ECPRVARY("B",DEF),DIR("B")
End DoDot:2
QUIT
+26 if +Y<0
QUIT
IF $DATA(ECPRVARY("B",+Y))
SET DEF=+Y
SET DIR("B")=$$DICLK^ECPRVUTL(DEF)
QUIT
+27 SET ECW=$$CLASS^ECPRVUTL(+Y,$GET(ECDT,DT))
+28 SET ECPRVARY("B",+Y)=CNT
SET ECPRVARY(CNT)=+Y_"^"_Y(0,0)_"^S^SECONDARY"
+29 SET DEF=""
SET CNT=CNT+1
KILL DIR("B")
End DoDot:1
+30 KILL ECPRVARY("B")
+31 QUIT
PRVHLP ;Help for Provider Code
+1 NEW DIC,PRV,D
+2 IF $DATA(ECPRVARY)
Begin DoDot:1
+3 WRITE !?1,"Provider Already Entered:"
SET PRV=0
+4 FOR
SET PRV=$ORDER(ECPRVARY(PRV))
if 'PRV
QUIT
Begin DoDot:2
+5 WRITE !,?3,$PIECE(ECPRVARY(PRV),U),?15,$PIECE(ECPRVARY(PRV),U,2)
+6 IF $PIECE(ECPRVARY(PRV),U,3)="P"
WRITE " (Primary)"
End DoDot:2
End DoDot:1
+7 WRITE !?1,"You may enter a new Provider, if you wish. Enter the secondary Provider"
+8 WRITE !?1,"for this procedure."
+9 QUIT
+10 ;
COMP(ECUX,ECDTX) ;get provider information, similar to COMP^ECPRVUTL
+1 ;Input: ECUX = IEN in file #200
+2 ; ECDTX = Date of encounter
+3 ;
+4 ;Output: ECUX = ien in file #200^name^compress person class info
+5 ;
+6 IF $GET(ECUX)=""
QUIT
+7 SET ECDTX=$GET(ECDTX,DT)
+8 ;build ECUX=ien in file #200^name^person class ien^occupation^specialty^
+9 ; subspecialty^etc.
+10 SET ECUX=+ECUX_"^"_$$GET1^DIQ(200,+ECUX,.01)_"^"_$$GET^XUA4A72(+ECUX,ECDTX)
+11 DO COMP^ECPRVUTL(.ECUX,ECDTX)
+12 QUIT
DSP1416(ECPRVARY) ;Display providers for data entry options
+1 NEW ECI,ECDAT,ECUP,CNT
+2 SET (ECI,CNT)=0
FOR
SET ECI=$ORDER(ECPRVARY(ECI))
if 'ECI
QUIT
Begin DoDot:1
+3 SET ECDAT=ECPRVARY(ECI)
SET CNT=CNT+1
+4 WRITE !,"Provider"_$SELECT(CNT=1:"",1:" #"_CNT)_":",?14,$PIECE(ECDAT,U,2)
+5 IF +$PIECE(ECDAT,U)
SET ECUP=+$PIECE(ECDAT,U)
DO COMP(.ECUP,$GET(ECDT,DT))
Begin DoDot:2
+6 WRITE !?16,$PIECE(ECUP,"^",3)
End DoDot:2
End DoDot:1
+7 QUIT
DSP1442(ECPRVARY) ;Display providers for data entry options
+1 NEW ECI,ECDAT,ECUP,CNT
+2 SET (ECI,CNT)=0
FOR
SET ECI=$ORDER(ECPRVARY(ECI))
if 'ECI
QUIT
Begin DoDot:1
+3 SET ECDAT=ECPRVARY(ECI)
SET CNT=CNT+1
+4 WRITE !,"Provider"_$SELECT(CNT=1:"",1:" #"_CNT)_":",?14,$EXTRACT($PIECE(ECDAT,U,2),1,24)
+5 IF +$PIECE(ECDAT,U)
SET ECUP=+$PIECE(ECDAT,U)
DO COMP^ECPRVMUT(.ECUP,$GET(ECDT,DT))
Begin DoDot:2
+6 WRITE ?42,$EXTRACT($PIECE(ECUP,U,3),1,36)
End DoDot:2
End DoDot:1
+7 QUIT
DSP1444(ECPRVARY) ;Display providers for data entry options
+1 NEW ECI,ECDAT,ECUP,CNT
+2 SET (ECI,CNT)=0
FOR
SET ECI=$ORDER(ECPRVARY(ECI))
if 'ECI
QUIT
Begin DoDot:1
+3 SET ECDAT=ECPRVARY(ECI)
SET CNT=CNT+1
+4 WRITE !,"Provider"_$SELECT(CNT=1:"",1:" #"_CNT)_":",?14,$EXTRACT($PIECE(ECDAT,U,2),1,24)
+5 IF +$PIECE(ECDAT,U)
SET ECUP=+$PIECE(ECDAT,U)
DO COMP^ECPRVMUT(.ECUP,$GET(ECDT,DT))
Begin DoDot:2
+6 WRITE ?44,$EXTRACT($PIECE(ECUP,U,3),1,34)
End DoDot:2
End DoDot:1
+7 QUIT
