Routine: PXCEPRV

PXCEPRV ;ISL/dee - Used to edit and display V PROVIDER ;03/16/2022

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,27,124,211,217**;Aug 12, 1996;Build 134

 ;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 cases.

 ;  (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

 ;;12~1~1201~Event Date and Time:  ~Event Date and Time: ~~EVENTDT^PXCEPRV(.PXCEAFTR)~~~D

 ;;812~2~81202~Package:  ~Package: ~~SKIP^PXCEPRV~~~D

 ;;812~3~81203~Data Source:  ~Data Source: ~~SKIP^PXCEPRV~~~D

;;

 ;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)"

 S DIC("W")="W !,""NPI: "",$$GET1^DIQ(200,Y_"","",41.99)"

 D ^DIC

 K DIR

 I $D(DUOUT)!$D(DTOUT)!(X="") S DIRUT=1 Q

 Q:$D(DIRUT)

 S:'($D(X)#2) X=+Y

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,"^")

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,"^")

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) S PXCEEND=1 Q

 Q:X=""

 S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")

 ;S:'($D(X)#2) X=+Y

 ;********************************

EVENTDT(PXCEAFTR) ;Edit the Event Date and Time.

 N DEFAULT,EVENTDT,HELP,PROMPT

 S DEFAULT=$P(^TMP("PXK",$J,"PRV",1,12,"BEFORE"),U,1)

 S HELP="D EVDTHELP^PXCEPRV"

 S PROMPT="Enter the Event Date and Time"

 S EVENTDT=$$GETDT^PXDATE(-1,-1,-1,DEFAULT,PROMPT,HELP)

 S $P(PXCEAFTR(12),U,1)=EVENTDT

 ;********************************

EVDTHELP ;Event Date and Time help.

 N ERR,RESULT,TEXT

 S RESULT=$$GET1^DID(9000010.06,1201,"","DESCRIPTION","TEXT","ERR")

 D BROWSE^DDBR("TEXT(""DESCRIPTION"")","NR","V Provider Event Date and Time Help")

 I $D(DDS) D REFRESH^DDSUTL S DY=IOSL-7,DX=0 X IOXY S $Y=DY,$X=DX

 ;********************************

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,PXCEDT) ;

 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

 ;********************************

SKIP ;Used to by-pass roll and scroll editing of a field.

 S (X,Y)=""

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCEPRV   6535     printed  Apr 23, 2025@18:42:30                                                                                                                                                                                                     Page 2

PXCEPRV   ;ISL/dee - Used to edit and display V PROVIDER ;03/16/2022

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,27,124,211,217**;Aug 12, 1996;Build 134

 +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 cases.

 +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       ;;12~1~1201~Event Date and Time:  ~Event Date and Time: ~~EVENTDT^PXCEPRV(.PXCEAFTR)~~~D

 +5       ;;812~2~81202~Package:  ~Package: ~~SKIP^PXCEPRV~~~D

 +6       ;;812~3~81203~Data Source:  ~Data Source: ~~SKIP^PXCEPRV~~~D

 +7       ;;

 +8       ;

 +9       ;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       SET DIC("W")="W !,""NPI: "",$$GET1^DIQ(200,Y_"","",41.99)"

 +14       DO ^DIC

 +15       KILL DIR

 +16       IF $DATA(DUOUT)!$DATA(DTOUT)!(X="")

               SET DIRUT=1

               QUIT

 +17       if $DATA(DIRUT)

               QUIT

 +18       if '($DATA(X)#2)

               SET X=+Y

 +19       QUIT

 +20      ;

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)

               SET PXCEEND=1

               QUIT

 +16       if X=""

               QUIT

 +17       SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE(Y,"^")

 +18      ;S:'($D(X)#2) X=+Y

 +19       QUIT

 +20      ;

 +21      ;********************************

EVENTDT(PXCEAFTR) ;Edit the Event Date and Time.

 +1        NEW DEFAULT,EVENTDT,HELP,PROMPT

 +2        SET DEFAULT=$PIECE(^TMP("PXK",$JOB,"PRV",1,12,"BEFORE"),U,1)

 +3        SET HELP="D EVDTHELP^PXCEPRV"

 +4        SET PROMPT="Enter the Event Date and Time"

 +5        SET EVENTDT=$$GETDT^PXDATE(-1,-1,-1,DEFAULT,PROMPT,HELP)

 +6        SET $PIECE(PXCEAFTR(12),U,1)=EVENTDT

 +7        QUIT

 +8       ;

 +9       ;********************************

EVDTHELP  ;Event Date and Time help.

 +1        NEW ERR,RESULT,TEXT

 +2        SET RESULT=$$GET1^DID(9000010.06,1201,"","DESCRIPTION","TEXT","ERR")

 +3        DO BROWSE^DDBR("TEXT(""DESCRIPTION"")","NR","V Provider Event Date and Time Help")

 +4        IF $DATA(DDS)

               DO REFRESH^DDSUTL

               SET DY=IOSL-7

               SET DX=0

               XECUTE IOXY

               SET $Y=DY

               SET $X=DX

 +5        QUIT

 +6       ;

 +7       ;********************************

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,PXCEDT) ;

 +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       ;

 +10      ;********************************

SKIP      ;Used to by-pass roll and scroll editing of a field.

 +1        SET (X,Y)=""

 +2        QUIT

 +3       ;

PXCEPRV.m