Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECPRVMUT

ECPRVMUT.m

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