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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECPRVUTL 7730 printed Dec 13, 2024@01:58:29 Page 2
ECPRVUTL ;ALB/JAP - Provider Selection with Person Class ;7 Aug 97
+1 ;;2.0; EVENT CAPTURE ;**5**;8 May 96
+2 ;
PROV(ECDT,ECPROVS) ;get providers - new providers function
+1 ;
+2 ;this function is duplicated in PROV^ECMUTL
+3 ;
+4 ;select provider(s) with active person class
+5 ;no updating of file #721 record is done here
+6 ;
+7 ; input
+8 ; ECDT = date/time of procedure (required)
+9 ; ECPROVS = local array, passed by reference (required)
+10 ;
+11 ; output
+12 ; ECU(1) = provider #1 (mandatory) ien^provider #1 name^person class
+13 ; ECU(2) = provider #2 (optional) ien^provider #2 name^person class
+14 ; ECU(3) = provider #3 (optional) ien^provider #3 name^person class
+15 ;
+16 ; returns
+17 ; 0 ==> provider selection successful; at least
+18 ; provider #1 selected.
+19 ; 1 ==> selection unsuccessful or user timed-out
+20 ; 2 ==> selection unsuccessful or user entered "^"
+21 ;
+22 NEW ECU,ECU2,ECU3,ECDA
+23 DO GET("",ECDT,.ECU,.ECU2,.ECU3,.ECOUT)
+24 SET ECPROVS(1)=ECU
SET ECPROVS(2)=ECU2
SET ECPROVS(3)=ECU3
+25 QUIT ECOUT
+26 ;
GET(ECDA,ECDT,ECU,ECU2,ECU3,ECOUT) ;get providers with person class
+1 ;
+2 ;select provider(s) with active person class
+3 ;no updating of file #721 record is done here
+4 ;
+5 ; input
+6 ; ECDA = ien of pertinent record in file #721 (required)
+7 ; but may be null
+8 ; ECDT = date/time of procedure (required)
+9 ; internal FM format;
+10 ; if null defaults to DT
+11 ; (ECU,ECU2,ECU3) = any (required; pass by reference);
+12 ; will be reset
+13 ; ECOUT = (required; pass by reference)
+14 ;
+15 ; output
+16 ; ECU = provider #1 ien in file #200^provider name^person class OR
+17 ; provider #1 ien in file #200^provider name^null OR
+18 ; null^null^null (if provider not determined)
+19 ; (provider #1 cannot be deleted; required field)
+20 ; ECU2 = provider #2 ien in file #200^provider name^person class OR
+21 ; provider #1 ien in file #200^provider name^null OR
+22 ; null^null^null (if provider not determined) OR
+23 ; @^null^null (if provider deleted)
+24 ; ECU3 = (same format as provider #2)
+25 ; ECOUT = 0 if selection successful OR
+26 ; 1 if user times out; selection unsuccessful
+27 ; 2 if user up-arrows out; selection unsuccessful
+28 ;
+29 ; Note: If user up-arrows out or times out, then
+30 ; ECU,ECU2,ECU3 set back to value at entry.
+31 ;
+32 NEW ECUTN,DA,DIR,DIRUT,DTOUT,DUOUT,X,Y,ECDATA,ECUN,ECUN2,ECUN3,ECUC,ECUC2,ECUC3,OLDP
+33 SET ECOUT=0
SET (ECU,ECU2,ECU3)=""
SET (ECUN,ECUN2,ECUN3)=""
SET (ECUC,ECUC2,ECUC3)=""
SET ECDATA=""
FOR JJ=1:1:3
SET OLDP(JJ)="^^"
+34 ;if using an existing record in file #721, pick-up some basic data
+35 IF +ECDA>0
Begin DoDot:1
+36 SET DA=ECDA
SET ECDATA=$GET(^ECH(ECDA,0))
SET ECDT=$PIECE(ECDATA,"^",3)
+37 SET ECU=$PIECE(ECDATA,"^",11)
SET ECU2=$PIECE(ECDATA,"^",15)
SET ECU3=$PIECE(ECDATA,"^",17)
+38 SET $PIECE(OLDP(1),"^")=ECU
SET $PIECE(OLDP(2),"^")=ECU2
SET $PIECE(OLDP(3),"^")=ECU3
End DoDot:1
+39 IF ECDT=""
SET ECDT=DT
+40 ;allow user to select new or update existing provider(s)
+41 DO PV
+42 IF +ECOUT
Begin DoDot:1
+43 SET ECU=OLDP(1)
+44 SET ECU2=OLDP(2)
+45 SET ECU3=OLDP(3)
End DoDot:1
QUIT
+46 IF '+ECOUT
Begin DoDot:1
+47 SET ECU=ECU_"^"_ECUN_"^"_ECUC
+48 SET ECU2=ECU2_"^"_ECUN2_"^"_ECUC2
+49 SET ECU3=ECU3_"^"_ECUN3_"^"_ECUC3
End DoDot:1
+50 ;make sure no duplicates exist
+51 IF +ECU
Begin DoDot:1
+52 IF +ECU=+ECU2
SET ECU2="@^^"
+53 IF +ECU=+ECU3
SET ECU3="@^^"
End DoDot:1
+54 IF +ECU2
Begin DoDot:1
+55 IF +ECU2=+ECU3
SET ECU3="@^^"
End DoDot:1
+56 ;if an existing 2nd provider is deleted, fill-in using 3rd provider
+57 IF $EXTRACT(ECU2,1)="@"
IF +ECU3
SET ECU2=ECU3
SET ECU3="@^^"
+58 ;make sure info is complete for each provider
+59 IF +ECU>0
DO COMP(.ECU,ECDT)
+60 IF +ECU2>0
DO COMP(.ECU2,ECDT)
+61 IF +ECU3>0
DO COMP(.ECU3,ECDT)
+62 QUIT
+63 ;
+64 ;if ecu,ecu2,ecu3 are already defined (i.e., not null), then y(0),y(0,0) won't be
+65 ;returned from DIR call;
PV ;1st provider - required
+1 ;if 1st provider exists, it can't be deleted; but may be over-written
+2 KILL Y,DIR
SET DIR(0)="721,10"
SET DIR("A")="Provider"
DO ^DIR
KILL DIR
IF Y
Begin DoDot:1
+3 SET ECUN=$GET(Y(0,0))
IF ECUN=""
SET ECUN=$$DICLK(ECU)
+4 SET ECUC=$$CLASS(+Y,ECDT)
End DoDot:1
+5 if $DATA(DTOUT)
SET ECOUT=1
if $DATA(DUOUT)
SET ECOUT=2
+6 if $GET(ECOUT)
QUIT
+7 IF +$GET(ECUC)<0
SET ECUC=""
GOTO PV
+8 SET ECU=+Y
+9 ;
PV2 ;2nd provider - optional
+1 ;if 2nd provider exists, it may be deleted or over-written
+2 KILL Y,DIR
SET DIR(0)="721,15"
SET DIR("A")="Provider #2"
DO ^DIR
KILL DIR
IF Y
Begin DoDot:1
+3 if +Y=+ECU
QUIT
+4 SET ECUN2=$GET(Y(0,0))
IF ECUN2=""
SET ECUN2=$$DICLK(ECU2)
+5 SET ECUC2=$$CLASS(+Y,ECDT)
End DoDot:1
+6 if $DATA(DTOUT)
SET ECOUT=1
if $DATA(DUOUT)
SET ECOUT=2
+7 if $GET(ECOUT)
QUIT
+8 IF 'Y
IF X="@"
IF +ECU2
SET ECU2="@"
SET ECUN2=""
WRITE !,?5,"Provider #2 will be deleted..."
IF +ECU3
GOTO PV3
+9 if ECU2="@"
QUIT
+10 IF +Y=+ECU
WRITE $CHAR(7),!!,?15,"But that's Provider #1... Try again.",!
GOTO PV2
+11 IF +$GET(ECUC2)<0
SET ECUC2=""
GOTO PV2
+12 SET ECU2=$SELECT(+Y>0:+Y,1:"")
+13 if ECU2=""
QUIT
+14 ;
PV3 ;3rd provider - optional
+1 ;if 3rd provider exists, it may be deleted or over-written
+2 KILL Y,DIR
SET DIR(0)="721,17"
SET DIR("A")="Provider #3"
DO ^DIR
KILL DIR
IF Y
Begin DoDot:1
+3 if +Y=+ECU
QUIT
if +Y=+ECU2
QUIT
+4 SET ECUN3=$GET(Y(0,0))
IF ECUN3=""
SET ECUN3=$$DICLK(ECU3)
+5 SET ECUC3=$$CLASS(+Y,ECDT)
End DoDot:1
+6 if $DATA(DTOUT)
SET ECOUT=1
if $DATA(DUOUT)
SET ECOUT=2
+7 if $GET(ECOUT)
QUIT
+8 IF 'Y
IF X="@"
IF +ECU3
SET ECU3="@"
SET ECUN3=""
WRITE !,?5,"Provider #3 will be deleted..."
+9 if ECU3="@"
QUIT
+10 IF +Y=+ECU
WRITE $CHAR(7),!!,?15,"But that's Provider #1... Try again.",!
GOTO PV3
+11 IF +Y=+ECU2
WRITE $CHAR(7),!!,?15,"But that's Provider #2... Try again.",!
GOTO PV3
+12 IF +$GET(ECUC3)<0
SET ECUC3=""
GOTO PV3
+13 SET ECU3=$SELECT(+Y>0:+Y,1:"")
+14 QUIT
+15 ;
CLASS(ECUX,ECDTX) ;get person class - display
+1 ; input
+2 ; ECUX=ien in file #200 (required)
+3 ; ECDTX=date/time of procedure (required)
+4 ; output
+5 ; ECUTN= -1 if no person class
+6 ; or
+7 ; -2 if no active person class
+8 ; or
+9 ; ien in file #8932.1^occupation^specialty^subspecialty^effective date^expiration date^va code
+10 NEW ECUTN,ECDATE,Y
+11 SET Y=ECDTX
DO DD^%DT
SET ECDATE=Y
+12 SET ECUTN=$$GET^XUA4A72(ECUX,ECDTX)
+13 IF +ECUTN>0
Begin DoDot:1
+14 WRITE !?5,"Occupation: ",$PIECE(ECUTN,"^",2)
+15 IF $PIECE(ECUTN,"^",3)]""
WRITE !?5,"Specialty: ",$PIECE(ECUTN,"^",3)
+16 IF $PIECE(ECUTN,"^",4)]""
WRITE !?5,"Subspecialty: ",$PIECE(ECUTN,"^",4)
+17 WRITE !
End DoDot:1
+18 IF '$TEST
DO CMSG
+19 QUIT ECUTN
+20 ;
CMSG ;inactive person class msgs
+1 IF +ECUTN=-1
Begin DoDot:1
+2 WRITE !!?10,"Only Providers with an active Person Class may"
+3 WRITE !?10,"be selected."
End DoDot:1
+4 IF +ECUTN=-2
Begin DoDot:1
+5 WRITE !!?10,"This Provider does not have an active Person Class"
+6 WRITE !?10,"for the date of "_$PIECE(ECDATE,"@",1)_"."
End DoDot:1
+7 WRITE !!?10,"Please check your provider selection and try again.",!
+8 QUIT
+9 ;
DICLK(ECUX) ;use DIC lookup if editing existing provider in file #721
+1 ; input
+2 ; ECUX=ien in file #200 (required)
+3 ; output
+4 ; Y(0,0); i.e., name
+5 NEW DIC,X
+6 SET X=ECUX
SET DIC="^VA(200,"
SET DIC(0)="NZ"
+7 DO ^DIC
+8 QUIT $GET(Y(0,0))
+9 ;
COMP(ECUX,ECDTX) ;check & complete the provider return variables
+1 ;or get user/provider name and person class info
+2 ; input
+3 ; ECUX=ien in file #200^name^person class ien^occupation^specialty^subspecialty^etc.
+4 ; (required)
+5 ; but pieces 3,4,5 may be null;
+6 ; passed by reference
+7 ; ECDTX=pertinent date; internal FM format (required)
+8 ; but may be null
+9 ; output
+10 ; ECUX=ien in file #200^name^compress person class info
+11 NEW ECSPEC,E1,E2,E3,ECUTN,X,Y
+12 ;get provider name, if not there;
+13 IF '$GET(ECDTX)
SET ECDTX=""
+14 IF $PIECE(ECUX,"^",2)=""
Begin DoDot:1
+15 SET $PIECE(ECUX,"^",2)=$$DICLK(+ECUX)
+16 SET ECUTN=$$GET^XUA4A72(+ECUX,ECDTX)
IF +ECUTN<0
SET ECUTN=""
+17 SET $PIECE(ECUX,"^",3)=ECUTN
End DoDot:1
+18 ;compress the person class information into 1 piece
+19 ;if specialty and subspecialty are defined, use that;
+20 ;otherwise use occupation plus specialty (if defined)
+21 IF +$PIECE(ECUX,"^",3)=0
SET ECUX=$PIECE(ECUX,"^",1,2)_"^"_"(Person Class undefined.)"
QUIT
+22 SET E1=$PIECE(ECUX,"^",4)
SET E2=$PIECE(ECUX,"^",5)
SET E3=$PIECE(ECUX,"^",6)
+23 IF $LENGTH(E3)>0
Begin DoDot:1
+24 SET ECSPEC=$EXTRACT(E2,1,18)_"/"_$EXTRACT(E3,1,40)
+25 SET ECUX=$PIECE(ECUX,"^",1,2)_"^"_ECSPEC
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 IF $LENGTH(E2)>0
SET ECSPEC=$EXTRACT(E1,1,18)_"/"_$EXTRACT(E2,1,40)
+28 IF $LENGTH(E2)=0
SET ECSPEC=E1
+29 SET ECUX=$PIECE(ECUX,"^",1,2)_"^"_ECSPEC
End DoDot:1
+30 QUIT
