PXCEPRV ;ISL/dee - Used to edit and display V PROVIDER ;3/19/97
;;1.0;PCE PATIENT CARE ENCOUNTER;**7,27**;Aug 12, 1996
;
Q
;
;Line with the line label "FORMAT"
;;Long name~File Number~Node Subscripts~Allow Duplicate entries (1=yes, 0=no)~File global name
; 1 2 3 4 5
;
;Followning lines:
;;Node~Piece~,Field Number~Edit Label~Display Label~Display Routine~Edit Routine~Help Text for DIR("?")~Set of PXCEKEYS that can Edit~D if Detail Display Only~
; 1 ~ 2 ~ 3 ~ 4 ~ 5 ~ 6 ~ 7 ~ 8 ~ 9 ~ 10
;The Display & Edit routines are for special caces.
; (The .01 field cannot have a special edit.)
;
FORMAT ;;Provider~9000010.06~0,12,811,812~0~^AUPNVPRV
;;0~1~.01~Provider: ~Provider: ~$$DISPLY01^PXCEPRV~EPROV^PXCEPRV~^D HELP^PXCEHELP~~B
;;0~4~.04~Is this Provider Primary: ~Primary: ~$$DISPPRIM^PXCEPRV~EPRIMSEC^PXCEPRV~~~N
;;0~5~.05~Is this Provider Attending: ~Attending: ~~EATTEND^PXCEPRV~~~N
;;
;
;The interface for AICS to get list on form for help.
INTRFACE ;;SD SELECT PROVIDER
;
;********************************
;Special cases for display.
;
DISPPRIM(PXCEPRIM) ;
Q $S(PXCEPRIM="P":$$EXTERNAL^DILFD(9000010.06,".04","",PXCEPRIM,"PXCEDILF"),1:"")
;
;********************************
;Special cases for edit.
;
EPROV ;
K DIRUT
N DIC,DA,PXPRVDT
S PXPRVDT=+^TMP("PXK",$J,"VST",1,0,"AFTER")
I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D
. N DIERR,PXCEDILF,PXCEINT,PXCEEXT
. S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
. S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
. S DIC("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
S DIC=200
S DIC(0)="AEMQ"
S DIC("A")=$P(PXCETEXT,"~",4)
S DIC("S")="I $$ACTIVPRV^PXAPI(Y,PXPRVDT)"
D ^DIC
K DIR
I $D(DUOUT)!$D(DTOUT)!(X="") S DIRUT=1 Q
Q:$D(DIRUT)
S:'($D(X)#2) X=+Y
Q
;
EPRIMSEC ;For Primary/Secondary field only allows one primary.
; Also used by V-POV
K Y,DTOUT,DUOUT,PXCEPRIM
;See if there is already a primary provider in V Provider for this Visit
S PXCEPRIM=$$PRIMSEC^PXUTL1(PXCEVIEN,PXCEAUPN,$P(PXCETEXT,"~",1),$P(PXCETEXT,"~",2))
I 'PXCEPRIM S Y="PRIMARY"
I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D
. N DIERR,PXCEDILF,PXCEEXT,PXCEINT
. S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
. S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
. S Y=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
I $D(Y),'PXCEPRIM!($E(Y)="P") D
. S DIR("B")=$S($E(Y)="P":"YES",1:"NO")
. S DIR(0)="YAO"
. S DIR("A")=$P(PXCETEXT,"~",4)
. S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
. D ^DIR
. K DIR,DA
. S Y=$S(Y:"P",1:"S")
E S Y="S"
I $D(DTOUT)!$D(DUOUT) S (PXCEEND,PXCEQUIT)=1 Q ;This field is required.
S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
Q
;
EATTEND ;Attending/Operating field only ask for Attending
S DIR("B")=$S($P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))="A":"YES",1:"NO")
S DIR(0)="YAO"
S DIR("A")=$P(PXCETEXT,"~",4)
S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
D ^DIR
K DIR,DA
I X="@" S Y="@"
E I $D(DTOUT)!$D(DUOUT) S PXCEEND=1 Q
E I +Y S Y="A"
E I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))="A" S Y="@"
E S Y=""
S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
Q
;
EPROV12 ;
K DIRUT
N DIC,DA,PXPRVDT
S PXPRVDT=+^TMP("PXK",$J,"VST",1,0,"AFTER")
I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D
. N DIERR,PXCEDILF,PXCEINT,PXCEEXT
. S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
. S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
. S DIC("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
S DIC=200
S DIC(0)="AEMQ"
S DIC("A")=$P(PXCETEXT,"~",4)
S DIC("S")="I $$ACTIVPRV^PXAPI(Y,PXPRVDT)"
D ^DIC
K DIR
I $D(DUOUT)!$D(DTOUT)!(X="") S DIRUT=1 Q
Q:$D(DIRUT)
S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
;S:'($D(X)#2) X=+Y
Q
;
;********************************
PERCLASS(PXCEPRV) ;Returns text for person class
N PXCEPERC
S PXCEPERC=$$OCCUP^PXBGPRV(PXCEPRV,+^AUPNVSIT(PXCEVIEN,0),"",2)
G PRCL
DPERCLAS(PXCECLAS) ;Returns text for person class
N PXCEPERC
S PXCEPERC=$S(PXCECLAS>0:$$OCCUP^PXBGPRV("","","",2,PXCECLAS),1:"")
PRCL ;
I PXCEPERC="" S PXCEPERC="## No Person Class ##"
E I PXCEPERC=-1 S PXCEPERC="!! No Person Class Defined !!"
E I PXCEPERC=-2 S PXCEPERC="** No Active Person Class **"
E I +PXCEPERC<0 S PXCEPERC=""
Q PXCEPERC
;
;********************************
;Display text for the .01 field which is a pointer to ^ICPT.
;(Must have is called by ASK^PXCEVFI2 and DEL^PXCEVFI2.)
DISPLY01(PXCEPRV) ;
N DIERR,PXCEDILF,PXCEEPRV,PXCEEPS,PXCEEAO,PXCEPERC,PXCERET
S PXCEEPRV=$$EXTERNAL^DILFD(9000010.06,".01","",$P(PXCEPRV,"^",1),"PXCEDILF")
S PXCEEPS=$$EXTERNAL^DILFD(9000010.06,".04","",$P(PXCEPRV,"^",4),"PXCEDILF")
S PXCEEAO=$$EXTERNAL^DILFD(9000010.06,".05","",$P(PXCEPRV,"^",5),"PXCEDILF")
S PXCEPERC=$$DPERCLAS($P(PXCEPRV,"^",6))
S PXCERET=PXCEEPRV_" "_$S($E(PXCEEPS)="P":PXCEEPS_" ",1:"")_$S(PXCEEAO]"":PXCEEAO_" ",1:"")
S PXCERET=PXCERET_$E(PXCEPERC,1,(65-$L(PXCERET)))
Q PXCERET
;
PXCEPRV ;ISL/dee - Used to edit and display V PROVIDER ;3/19/97
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,27**;Aug 12, 1996
+2 ;
+3 QUIT
+4 ;
+5 ;Line with the line label "FORMAT"
+6 ;;Long name~File Number~Node Subscripts~Allow Duplicate entries (1=yes, 0=no)~File global name
+7 ; 1 2 3 4 5
+8 ;
+9 ;Followning lines:
+10 ;;Node~Piece~,Field Number~Edit Label~Display Label~Display Routine~Edit Routine~Help Text for DIR("?")~Set of PXCEKEYS that can Edit~D if Detail Display Only~
+11 ; 1 ~ 2 ~ 3 ~ 4 ~ 5 ~ 6 ~ 7 ~ 8 ~ 9 ~ 10
+12 ;The Display & Edit routines are for special caces.
+13 ; (The .01 field cannot have a special edit.)
+14 ;
FORMAT ;;Provider~9000010.06~0,12,811,812~0~^AUPNVPRV
+1 ;;0~1~.01~Provider: ~Provider: ~$$DISPLY01^PXCEPRV~EPROV^PXCEPRV~^D HELP^PXCEHELP~~B
+2 ;;0~4~.04~Is this Provider Primary: ~Primary: ~$$DISPPRIM^PXCEPRV~EPRIMSEC^PXCEPRV~~~N
+3 ;;0~5~.05~Is this Provider Attending: ~Attending: ~~EATTEND^PXCEPRV~~~N
+4 ;;
+5 ;
+6 ;The interface for AICS to get list on form for help.
INTRFACE ;;SD SELECT PROVIDER
+1 ;
+2 ;********************************
+3 ;Special cases for display.
+4 ;
DISPPRIM(PXCEPRIM) ;
+1 QUIT $SELECT(PXCEPRIM="P":$$EXTERNAL^DILFD(9000010.06,".04","",PXCEPRIM,"PXCEDILF"),1:"")
+2 ;
+3 ;********************************
+4 ;Special cases for edit.
+5 ;
EPROV ;
+1 KILL DIRUT
+2 NEW DIC,DA,PXPRVDT
+3 SET PXPRVDT=+^TMP("PXK",$JOB,"VST",1,0,"AFTER")
+4 IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))'=""
Begin DoDot:1
+5 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+6 SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+7 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+8 SET DIC("B")=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:1
+9 SET DIC=200
+10 SET DIC(0)="AEMQ"
+11 SET DIC("A")=$PIECE(PXCETEXT,"~",4)
+12 SET DIC("S")="I $$ACTIVPRV^PXAPI(Y,PXPRVDT)"
+13 DO ^DIC
+14 KILL DIR
+15 IF $DATA(DUOUT)!$DATA(DTOUT)!(X="")
SET DIRUT=1
QUIT
+16 IF $DATA(DIRUT)
QUIT
+17 IF '($DATA(X)#2)
SET X=+Y
+18 QUIT
+19 ;
EPRIMSEC ;For Primary/Secondary field only allows one primary.
+1 ; Also used by V-POV
+2 KILL Y,DTOUT,DUOUT,PXCEPRIM
+3 ;See if there is already a primary provider in V Provider for this Visit
+4 SET PXCEPRIM=$$PRIMSEC^PXUTL1(PXCEVIEN,PXCEAUPN,$PIECE(PXCETEXT,"~",1),$PIECE(PXCETEXT,"~",2))
+5 IF 'PXCEPRIM
SET Y="PRIMARY"
+6 IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))'=""
Begin DoDot:1
+7 NEW DIERR,PXCEDILF,PXCEEXT,PXCEINT
+8 SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+9 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+10 SET Y=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:1
+11 IF $DATA(Y)
IF 'PXCEPRIM!($EXTRACT(Y)="P")
Begin DoDot:1
+12 SET DIR("B")=$SELECT($EXTRACT(Y)="P":"YES",1:"NO")
+13 SET DIR(0)="YAO"
+14 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+15 IF $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+16 DO ^DIR
+17 KILL DIR,DA
+18 SET Y=$SELECT(Y:"P",1:"S")
End DoDot:1
+19 IF '$TEST
SET Y="S"
+20 ;This field is required.
IF $DATA(DTOUT)!$DATA(DUOUT)
SET (PXCEEND,PXCEQUIT)=1
QUIT
+21 SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE(Y,"^")
+22 QUIT
+23 ;
EATTEND ;Attending/Operating field only ask for Attending
+1 SET DIR("B")=$SELECT($PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))="A":"YES",1:"NO")
+2 SET DIR(0)="YAO"
+3 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+4 IF $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+5 DO ^DIR
+6 KILL DIR,DA
+7 IF X="@"
SET Y="@"
+8 IF '$TEST
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
QUIT
+9 IF '$TEST
IF +Y
SET Y="A"
+10 IF '$TEST
IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))="A"
SET Y="@"
+11 IF '$TEST
SET Y=""
+12 SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE(Y,"^")
+13 QUIT
+14 ;
EPROV12 ;
+1 KILL DIRUT
+2 NEW DIC,DA,PXPRVDT
+3 SET PXPRVDT=+^TMP("PXK",$JOB,"VST",1,0,"AFTER")
+4 IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))'=""
Begin DoDot:1
+5 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+6 SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+7 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+8 SET DIC("B")=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:1
+9 SET DIC=200
+10 SET DIC(0)="AEMQ"
+11 SET DIC("A")=$PIECE(PXCETEXT,"~",4)
+12 SET DIC("S")="I $$ACTIVPRV^PXAPI(Y,PXPRVDT)"
+13 DO ^DIC
+14 KILL DIR
+15 IF $DATA(DUOUT)!$DATA(DTOUT)!(X="")
SET DIRUT=1
QUIT
+16 IF $DATA(DIRUT)
QUIT
+17 SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE(Y,"^")
+18 ;S:'($D(X)#2) X=+Y
+19 QUIT
+20 ;
+21 ;********************************
PERCLASS(PXCEPRV) ;Returns text for person class
+1 NEW PXCEPERC
+2 SET PXCEPERC=$$OCCUP^PXBGPRV(PXCEPRV,+^AUPNVSIT(PXCEVIEN,0),"",2)
+3 GOTO PRCL
DPERCLAS(PXCECLAS) ;Returns text for person class
+1 NEW PXCEPERC
+2 SET PXCEPERC=$SELECT(PXCECLAS>0:$$OCCUP^PXBGPRV("","","",2,PXCECLAS),1:"")
PRCL ;
+1 IF PXCEPERC=""
SET PXCEPERC="## No Person Class ##"
+2 IF '$TEST
IF PXCEPERC=-1
SET PXCEPERC="!! No Person Class Defined !!"
+3 IF '$TEST
IF PXCEPERC=-2
SET PXCEPERC="** No Active Person Class **"
+4 IF '$TEST
IF +PXCEPERC<0
SET PXCEPERC=""
+5 QUIT PXCEPERC
+6 ;
+7 ;********************************
+8 ;Display text for the .01 field which is a pointer to ^ICPT.
+9 ;(Must have is called by ASK^PXCEVFI2 and DEL^PXCEVFI2.)
DISPLY01(PXCEPRV) ;
+1 NEW DIERR,PXCEDILF,PXCEEPRV,PXCEEPS,PXCEEAO,PXCEPERC,PXCERET
+2 SET PXCEEPRV=$$EXTERNAL^DILFD(9000010.06,".01","",$PIECE(PXCEPRV,"^",1),"PXCEDILF")
+3 SET PXCEEPS=$$EXTERNAL^DILFD(9000010.06,".04","",$PIECE(PXCEPRV,"^",4),"PXCEDILF")
+4 SET PXCEEAO=$$EXTERNAL^DILFD(9000010.06,".05","",$PIECE(PXCEPRV,"^",5),"PXCEDILF")
+5 SET PXCEPERC=$$DPERCLAS($PIECE(PXCEPRV,"^",6))
+6 SET PXCERET=PXCEEPRV_" "_$SELECT($EXTRACT(PXCEEPS)="P":PXCEEPS_" ",1:"")_$SELECT(PXCEEAO]"":PXCEEAO_" ",1:"")
+7 SET PXCERET=PXCERET_$EXTRACT(PXCEPERC,1,(65-$LENGTH(PXCERET)))
+8 QUIT PXCERET
+9 ;
