210 lines
7.3 KiB
Mathematica
210 lines
7.3 KiB
Mathematica
ECPRVUTL ;ALB/JAP - Provider Selection with Person Class ;7 Aug 97
|
|
;;2.0; EVENT CAPTURE ;**5**;8 May 96
|
|
;
|
|
PROV(ECDT,ECPROVS) ;get providers - new providers function
|
|
;
|
|
;this function is duplicated in PROV^ECMUTL
|
|
;
|
|
;select provider(s) with active person class
|
|
;no updating of file #721 record is done here
|
|
;
|
|
; input
|
|
; ECDT = date/time of procedure (required)
|
|
; ECPROVS = local array, passed by reference (required)
|
|
;
|
|
; output
|
|
; ECU(1) = provider #1 (mandatory) ien^provider #1 name^person class
|
|
; ECU(2) = provider #2 (optional) ien^provider #2 name^person class
|
|
; ECU(3) = provider #3 (optional) ien^provider #3 name^person class
|
|
;
|
|
; returns
|
|
; 0 ==> provider selection successful; at least
|
|
; provider #1 selected.
|
|
; 1 ==> selection unsuccessful or user timed-out
|
|
; 2 ==> selection unsuccessful or user entered "^"
|
|
;
|
|
N ECU,ECU2,ECU3,ECDA
|
|
D GET("",ECDT,.ECU,.ECU2,.ECU3,.ECOUT)
|
|
S ECPROVS(1)=ECU,ECPROVS(2)=ECU2,ECPROVS(3)=ECU3
|
|
Q ECOUT
|
|
;
|
|
GET(ECDA,ECDT,ECU,ECU2,ECU3,ECOUT) ;get providers with person class
|
|
;
|
|
;select provider(s) with active person class
|
|
;no updating of file #721 record is done here
|
|
;
|
|
; input
|
|
; ECDA = ien of pertinent record in file #721 (required)
|
|
; but may be null
|
|
; ECDT = date/time of procedure (required)
|
|
; internal FM format;
|
|
; if null defaults to DT
|
|
; (ECU,ECU2,ECU3) = any (required; pass by reference);
|
|
; will be reset
|
|
; ECOUT = (required; pass by reference)
|
|
;
|
|
; output
|
|
; ECU = provider #1 ien in file #200^provider name^person class OR
|
|
; provider #1 ien in file #200^provider name^null OR
|
|
; null^null^null (if provider not determined)
|
|
; (provider #1 cannot be deleted; required field)
|
|
; ECU2 = provider #2 ien in file #200^provider name^person class OR
|
|
; provider #1 ien in file #200^provider name^null OR
|
|
; null^null^null (if provider not determined) OR
|
|
; @^null^null (if provider deleted)
|
|
; ECU3 = (same format as provider #2)
|
|
; ECOUT = 0 if selection successful OR
|
|
; 1 if user times out; selection unsuccessful
|
|
; 2 if user up-arrows out; selection unsuccessful
|
|
;
|
|
; Note: If user up-arrows out or times out, then
|
|
; ECU,ECU2,ECU3 set back to value at entry.
|
|
;
|
|
N ECUTN,DA,DIR,DIRUT,DTOUT,DUOUT,X,Y,ECDATA,ECUN,ECUN2,ECUN3,ECUC,ECUC2,ECUC3,OLDP
|
|
S ECOUT=0,(ECU,ECU2,ECU3)="",(ECUN,ECUN2,ECUN3)="",(ECUC,ECUC2,ECUC3)="",ECDATA="" F JJ=1:1:3 S OLDP(JJ)="^^"
|
|
;if using an existing record in file #721, pick-up some basic data
|
|
I +ECDA>0 D
|
|
.S DA=ECDA,ECDATA=$G(^ECH(ECDA,0)),ECDT=$P(ECDATA,"^",3)
|
|
.S ECU=$P(ECDATA,"^",11),ECU2=$P(ECDATA,"^",15),ECU3=$P(ECDATA,"^",17)
|
|
.S $P(OLDP(1),"^")=ECU,$P(OLDP(2),"^")=ECU2,$P(OLDP(3),"^")=ECU3
|
|
I ECDT="" S ECDT=DT
|
|
;allow user to select new or update existing provider(s)
|
|
D PV
|
|
I +ECOUT D Q
|
|
.S ECU=OLDP(1)
|
|
.S ECU2=OLDP(2)
|
|
.S ECU3=OLDP(3)
|
|
I '+ECOUT D
|
|
.S ECU=ECU_"^"_ECUN_"^"_ECUC
|
|
.S ECU2=ECU2_"^"_ECUN2_"^"_ECUC2
|
|
.S ECU3=ECU3_"^"_ECUN3_"^"_ECUC3
|
|
;make sure no duplicates exist
|
|
I +ECU D
|
|
.I +ECU=+ECU2 S ECU2="@^^"
|
|
.I +ECU=+ECU3 S ECU3="@^^"
|
|
I +ECU2 D
|
|
.I +ECU2=+ECU3 S ECU3="@^^"
|
|
;if an existing 2nd provider is deleted, fill-in using 3rd provider
|
|
I $E(ECU2,1)="@",+ECU3 S ECU2=ECU3,ECU3="@^^"
|
|
;make sure info is complete for each provider
|
|
I +ECU>0 D COMP(.ECU,ECDT)
|
|
I +ECU2>0 D COMP(.ECU2,ECDT)
|
|
I +ECU3>0 D COMP(.ECU3,ECDT)
|
|
Q
|
|
;
|
|
;if ecu,ecu2,ecu3 are already defined (i.e., not null), then y(0),y(0,0) won't be
|
|
;returned from DIR call;
|
|
PV ;1st provider - required
|
|
;if 1st provider exists, it can't be deleted; but may be over-written
|
|
K Y,DIR S DIR(0)="721,10",DIR("A")="Provider" D ^DIR K DIR I Y D
|
|
.S ECUN=$G(Y(0,0)) I ECUN="" S ECUN=$$DICLK(ECU)
|
|
.S ECUC=$$CLASS(+Y,ECDT)
|
|
S:$D(DTOUT) ECOUT=1 S:$D(DUOUT) ECOUT=2
|
|
Q:$G(ECOUT)
|
|
I +$G(ECUC)<0 S ECUC="" G PV
|
|
S ECU=+Y
|
|
;
|
|
PV2 ;2nd provider - optional
|
|
;if 2nd provider exists, it may be deleted or over-written
|
|
K Y,DIR S DIR(0)="721,15",DIR("A")="Provider #2" D ^DIR K DIR I Y D
|
|
.Q:+Y=+ECU
|
|
.S ECUN2=$G(Y(0,0)) I ECUN2="" S ECUN2=$$DICLK(ECU2)
|
|
.S ECUC2=$$CLASS(+Y,ECDT)
|
|
S:$D(DTOUT) ECOUT=1 S:$D(DUOUT) ECOUT=2
|
|
Q:$G(ECOUT)
|
|
I 'Y,X="@",+ECU2 S ECU2="@",ECUN2="" W !,?5,"Provider #2 will be deleted..." I +ECU3 G PV3
|
|
Q:ECU2="@"
|
|
I +Y=+ECU W $C(7),!!,?15,"But that's Provider #1... Try again.",! G PV2
|
|
I +$G(ECUC2)<0 S ECUC2="" G PV2
|
|
S ECU2=$S(+Y>0:+Y,1:"")
|
|
Q:ECU2=""
|
|
;
|
|
PV3 ;3rd provider - optional
|
|
;if 3rd provider exists, it may be deleted or over-written
|
|
K Y,DIR S DIR(0)="721,17",DIR("A")="Provider #3" D ^DIR K DIR I Y D
|
|
.Q:+Y=+ECU Q:+Y=+ECU2
|
|
.S ECUN3=$G(Y(0,0)) I ECUN3="" S ECUN3=$$DICLK(ECU3)
|
|
.S ECUC3=$$CLASS(+Y,ECDT)
|
|
S:$D(DTOUT) ECOUT=1 S:$D(DUOUT) ECOUT=2
|
|
Q:$G(ECOUT)
|
|
I 'Y,X="@",+ECU3 S ECU3="@",ECUN3="" W !,?5,"Provider #3 will be deleted..."
|
|
Q:ECU3="@"
|
|
I +Y=+ECU W $C(7),!!,?15,"But that's Provider #1... Try again.",! G PV3
|
|
I +Y=+ECU2 W $C(7),!!,?15,"But that's Provider #2... Try again.",! G PV3
|
|
I +$G(ECUC3)<0 S ECUC3="" G PV3
|
|
S ECU3=$S(+Y>0:+Y,1:"")
|
|
Q
|
|
;
|
|
CLASS(ECUX,ECDTX) ;get person class - display
|
|
; input
|
|
; ECUX=ien in file #200 (required)
|
|
; ECDTX=date/time of procedure (required)
|
|
; output
|
|
; ECUTN= -1 if no person class
|
|
; or
|
|
; -2 if no active person class
|
|
; or
|
|
; ien in file #8932.1^occupation^specialty^subspecialty^effective date^expiration date^va code
|
|
N ECUTN,ECDATE,Y
|
|
S Y=ECDTX D DD^%DT S ECDATE=Y
|
|
S ECUTN=$$GET^XUA4A72(ECUX,ECDTX)
|
|
I +ECUTN>0 D
|
|
.W !?5,"Occupation: ",$P(ECUTN,"^",2)
|
|
.I $P(ECUTN,"^",3)]"" W !?5,"Specialty: ",$P(ECUTN,"^",3)
|
|
.I $P(ECUTN,"^",4)]"" W !?5,"Subspecialty: ",$P(ECUTN,"^",4)
|
|
.W !
|
|
E D CMSG
|
|
Q ECUTN
|
|
;
|
|
CMSG ;inactive person class msgs
|
|
I +ECUTN=-1 D
|
|
.W !!?10,"Only Providers with an active Person Class may"
|
|
.W !?10,"be selected."
|
|
I +ECUTN=-2 D
|
|
.W !!?10,"This Provider does not have an active Person Class"
|
|
.W !?10,"for the date of "_$P(ECDATE,"@",1)_"."
|
|
W !!?10,"Please check your provider selection and try again.",!
|
|
Q
|
|
;
|
|
DICLK(ECUX) ;use DIC lookup if editing existing provider in file #721
|
|
; input
|
|
; ECUX=ien in file #200 (required)
|
|
; output
|
|
; Y(0,0); i.e., name
|
|
N DIC,X
|
|
S X=ECUX,DIC="^VA(200,",DIC(0)="NZ"
|
|
D ^DIC
|
|
Q $G(Y(0,0))
|
|
;
|
|
COMP(ECUX,ECDTX) ;check & complete the provider return variables
|
|
;or get user/provider name and person class info
|
|
; input
|
|
; ECUX=ien in file #200^name^person class ien^occupation^specialty^subspecialty^etc.
|
|
; (required)
|
|
; but pieces 3,4,5 may be null;
|
|
; passed by reference
|
|
; ECDTX=pertinent date; internal FM format (required)
|
|
; but may be null
|
|
; output
|
|
; ECUX=ien in file #200^name^compress person class info
|
|
N ECSPEC,E1,E2,E3,ECUTN,X,Y
|
|
;get provider name, if not there;
|
|
I '$G(ECDTX) S ECDTX=""
|
|
I $P(ECUX,"^",2)="" D
|
|
.S $P(ECUX,"^",2)=$$DICLK(+ECUX)
|
|
.S ECUTN=$$GET^XUA4A72(+ECUX,ECDTX) I +ECUTN<0 S ECUTN=""
|
|
.S $P(ECUX,"^",3)=ECUTN
|
|
;compress the person class information into 1 piece
|
|
;if specialty and subspecialty are defined, use that;
|
|
;otherwise use occupation plus specialty (if defined)
|
|
I +$P(ECUX,"^",3)=0 S ECUX=$P(ECUX,"^",1,2)_"^"_"(Person Class undefined.)" Q
|
|
S E1=$P(ECUX,"^",4),E2=$P(ECUX,"^",5),E3=$P(ECUX,"^",6)
|
|
I $L(E3)>0 D
|
|
.S ECSPEC=$E(E2,1,18)_"/"_$E(E3,1,40)
|
|
.S ECUX=$P(ECUX,"^",1,2)_"^"_ECSPEC
|
|
E D
|
|
.I $L(E2)>0 S ECSPEC=$E(E1,1,18)_"/"_$E(E2,1,40)
|
|
.I $L(E2)=0 S ECSPEC=E1
|
|
.S ECUX=$P(ECUX,"^",1,2)_"^"_ECSPEC
|
|
Q
|