- 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 Jan 18, 2025@02:59:41 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