Routine: PXCEPOV1

PXCEPOV1 ;ISL/dee - Used to edit and display V POV ;12/23/2020

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**134,149,124,170,203,199,211**;Aug 12, 1996;Build 454

;;

 ;Reference to ICDEX supported by ICR #5747.

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

DINJHELP ;Date of Injury help.

 N RESULT,TEXT

 S RESULT=$$GET1^DID(9000010.07,.13,"","DESCRIPTION","TEXT","ERR")

 D BROWSE^DDBR("TEXT(""DESCRIPTION"")","NR","V POV Date of Injury Help")

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

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

 ;Special cases for display.

DNARRAT(PNAR,PXCEDT) ;Provider Narrative for ICD-9 / ICD-10

 Q $P(^AUTNPOV(PNAR,0),U,1)

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

DPRIMSEC(PRIMSEC,PXCEDT) ;

 I $G(VIEW)="B" Q $S(PRIMSEC="P":"PRIMARY",1:"")

 Q $S(PRIMSEC="P":"PRIMARY",PRIMSEC="S":"SECONDARY",1:"")

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

 ;Special cases for edit.

ENARRAT(REQUIRED,ASK,DEFAULT,FILE,FIELD1,FIELD2) ;Provider Narrative

 ;Used by ALL V-Files with Prov. Nar.

 ; REQUIRED  0 for not required

 ;           1 for required

 ; ASK       0 for do not ask

 ;           1 for ask

 ;           2 for ask only if there is already a value

 ; DEFAULT   0 for do not default

 ;           1 for do default

 ;           changed to 1 if REQUIRED is 1

 N PXKLAYGO,ASKING

 S PXKLAYGO=""

 S ASKING=ASK#2

 S:REQUIRED DEFAULT=1

 I PXCEKEYS["C" S ASKING=1

ENARRAT1 ;

 K DIR,DA,X,Y,C

 S (X,Y)=""

 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 (DIR("B"),X,Y)=$S('$D(DIERR):PXCEEXT,1:PXCEINT)

 S DIR(0)="FAO^1:245"

 S DIR("A")=$P(PXCETEXT,"~",4)

 I $P(PXCETEXT,"~",8)]"" S DIR("?")=$P(PXCETEXT,"~",8)

 E  D

 . S DIR("?",1)="This response must have at least 2 characters and no more than 245"

 . S DIR("?",2)="characters and must not contain embedded uparrows."

 . I REQUIRED S DIR("?")="This field is required."

 . E  S DIR("?")="This field is optional."

 I ASK=2,(Y]"") S ASKING=1

 I ASKING D ^DIR

 K DIR,DA

 I X="@" S Y="@"

 E  I $D(DTOUT)!$D(DUOUT) S PXCEEND=1 S:REQUIRED PXCEQUIT=1 Q

 N PXCEX,PXCEY

 I $E(Y,1)="=" S PXCEX=$E(PXCEIN01_" "_$E($P(Y,"^"),2,245),1,245)

 E  S PXCEX=Y

 ; ***

 ; PX*1.0*199 - ICD-10 Remediation note.

 ; Fields 5 and 10 in file #80 have been modified by STS for ICD-10.

 ; In the following lines of code these two field numbers are intercepted

 ; and an appropriate, alternative data retrieval is implemented.

 ; Other file and field numbers will behave as they previously did.

 ; ***

 N DXCATIEN,PXDXDATE

 S PXDXDATE=$P($G(PXCEAFTR(12)),U,1)

 I PXDXDATE="" S PXDXDATE=$S($D(PXCEVIEN)=1:$$CSDATE^PXDXUTL(PXCEVIEN),$D(PXCEAPDT)=1:PXCEAPDT,1:DT)

 I DEFAULT,PXCEX="" D

 . I $G(FILE)=80,$G(FIELD1)=10 D  Q

 .. S PXCEX=$$DXNARR^PXUTL1($P(PXCEAFTR(0),"^",1),PXDXDATE)

 . I $G(FILE)=80,$G(FIELD1)=5 D  Q

 .. S DXCATIEN=$P($$ICDDATA^ICDXCODE("DIAG",$P(PXCEAFTR(0),"^",1),PXDXDATE,"I"),"^",6)

 .. I $L(DXCATIEN) S PXCEX=$$GET1^DIQ(80.3,DXCATIEN,.01)

 . S PXCEX=$$EXTTEXT^PXUTL1($P(PXCEAFTR(0),"^",1),REQUIRED,$G(FILE),$G(FIELD1),$G(FIELD2))

 I ASKING D

 . W !,PXCEX

 I $L(PXCEX)=1,PXCEX'="@" W !,"Must be 2 to 245 characters." G ENARRAT1

 I PXCEX="@"!(PXCEX=""),REQUIRED W !,"This field is required.",$C(7) G ENARRAT1

 I PXCEX="@"!(PXCEX="") S PXCEY=PXCEX

 E  S PXCEY=$$PROVNARR^PXAPI(PXCEX,PXCEFILE) I ASKING,+PXCEY'>0 W "??",$C(7) G ENARRAT1

 E  I +PXCEY'>0 S PXCEY=""

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

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

EINJURY ;Date/Time of Injury

 ;If not an injury code Q

 N CODEIEN,DIRUT,DOINJ,HELP,INJCODE,PROMPT

 S CODEIEN=$P(PXCEAFTR(0),U,1)

 S INJCODE=$$INJURYC(CODEIEN)

 I INJCODE=0 Q

 S HELP="D DINJHELP^PXCEPOV1"

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

 S PROMPT=$P(PXCETEXT,"~",4)

 S DOINJ=$$GETDT^PXDATE(-1,-1,0,DOINJ,PROMPT,HELP)

 I $D(DIRUT),(DOINJ'="@") S PXCEEND=1 Q

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

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

EVENTDTHELP ;Event Date and Time help.

 N ERR,RESULT,TEXT

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

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

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

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

ICDCODE ;Enter ICD code using Lexicon.

 N CODE,CODEIEN,CODESYS,EVENTDT,HELP,PXCEDT,SERVCAT,SRCHTERM,TEMP

 ;Prompt the user for the Lexicon search term.

 S SRCHTERM=$$GETST^PXLEX

 I SRCHTERM="" S DIRUT=1,(X,Y)="" Q

 ;Prompt the user for the Event Date and Time. This is only

 ;for new entries because it is used in the Lexicon search

 ;to ensure only codes active on that date are returned.

 S TEMP=^AUPNVSIT(PXCEVIEN,0)

 S SERVCAT=$P(TEMP,U,7)

 S HELP="D EVENTDTHELP^PXCEPOV1"

 S EVENTDT=$$EVENTDT^PXDATE("",HELP)

 S PXCEDT=EVENTDT

 ;If the Event Date and Time is null use the Visit Date.

 I PXCEDT="" S PXCEDT=$P(TEMP,U,1)

 ;Set the coding system based on the Date.

 S CODESYS=$P($$ACTDT^PXDXUTL(PXCEDT),U,1)

 ;Let the user select the code, only return active codes.

 S CODE=$$GETCODE^PXLEXS(CODESYS,SRCHTERM,PXCEDT,1)

 I CODE="" S DIRUT=1,(X,Y)="" Q

 ;ICR #5747

 S CODEIEN=$P($$CODEN^ICDCODE(CODE),"~",1)

 S $P(PXCEAFTR(0),U,1)=CODEIEN

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

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

INJURYC(CODEIEN) ;Return 1 if the ICD code is an injury code.

 ;If not an injury code Q

 N CODE,CODESYS,INJCODE

 S CODE=$$CODEC^ICDCODE(CODEIEN)

 S CODESYS=$$CSI^ICDEX(80,CODEIEN)

 S INJCODE=0

 ;ICD-9 codes between 800 and 999.999 are considered injury codes.

 I (CODESYS=1),(CODE'<800),(CODE'>999.999) S INJCODE=1

 ;ICD-10 Codes beginning with S or T are considered Injury codes.

 I CODESYS=30 D

  . N C1

  . S C1=$E(CODE,1)

  . I (C1="S")!(C1="T") S INJCODE=1

 Q INJCODE

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCEPOV1   6099     printed  Mar 13, 2025@21:32:54                                                                                                                                                                                                    Page 2

PXCEPOV1  ;ISL/dee - Used to edit and display V POV ;12/23/2020

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**134,149,124,170,203,199,211**;Aug 12, 1996;Build 454

 +2       ;;

 +3       ;Reference to ICDEX supported by ICR #5747.

 +4       ;

 +5        QUIT

 +6       ;

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

DINJHELP  ;Date of Injury help.

 +1        NEW RESULT,TEXT

 +2        SET RESULT=$$GET1^DID(9000010.07,.13,"","DESCRIPTION","TEXT","ERR")

 +3        DO BROWSE^DDBR("TEXT(""DESCRIPTION"")","NR","V POV Date of Injury 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       ;********************************

 +8       ;Special cases for display.

 +9       ;

DNARRAT(PNAR,PXCEDT) ;Provider Narrative for ICD-9 / ICD-10

 +1        QUIT $PIECE(^AUTNPOV(PNAR,0),U,1)

 +2       ;

 +3       ;********************************

DPRIMSEC(PRIMSEC,PXCEDT) ;

 +1        IF $GET(VIEW)="B"

               QUIT $SELECT(PRIMSEC="P":"PRIMARY",1:"")

 +2        QUIT $SELECT(PRIMSEC="P":"PRIMARY",PRIMSEC="S":"SECONDARY",1:"")

 +3       ;

 +4       ;********************************

 +5       ;Special cases for edit.

 +6       ;

ENARRAT(REQUIRED,ASK,DEFAULT,FILE,FIELD1,FIELD2) ;Provider Narrative

 +1       ;Used by ALL V-Files with Prov. Nar.

 +2       ; REQUIRED  0 for not required

 +3       ;           1 for required

 +4       ; ASK       0 for do not ask

 +5       ;           1 for ask

 +6       ;           2 for ask only if there is already a value

 +7       ; DEFAULT   0 for do not default

 +8       ;           1 for do default

 +9       ;           changed to 1 if REQUIRED is 1

 +10      ;

 +11       NEW PXKLAYGO,ASKING

 +12       SET PXKLAYGO=""

 +13       SET ASKING=ASK#2

 +14       if REQUIRED

               SET DEFAULT=1

 +15       IF PXCEKEYS["C"

               SET ASKING=1

ENARRAT1  ;

 +1        KILL DIR,DA,X,Y,C

 +2        SET (X,Y)=""

 +3        IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))'=""

               Begin DoDot:1

 +4                NEW DIERR,PXCEDILF,PXCEEXT,PXCEINT

 +5                SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))

 +6                SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")

 +7                SET (DIR("B"),X,Y)=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)

               End DoDot:1

 +8        SET DIR(0)="FAO^1:245"

 +9        SET DIR("A")=$PIECE(PXCETEXT,"~",4)

 +10       IF $PIECE(PXCETEXT,"~",8)]""

               SET DIR("?")=$PIECE(PXCETEXT,"~",8)

 +11      IF '$TEST

               Begin DoDot:1

 +12               SET DIR("?",1)="This response must have at least 2 characters and no more than 245"

 +13               SET DIR("?",2)="characters and must not contain embedded uparrows."

 +14               IF REQUIRED

                       SET DIR("?")="This field is required."

 +15              IF '$TEST

                       SET DIR("?")="This field is optional."

               End DoDot:1

 +16       IF ASK=2

               IF (Y]"")

                   SET ASKING=1

 +17       IF ASKING

               DO ^DIR

 +18       KILL DIR,DA

 +19       IF X="@"

               SET Y="@"

 +20      IF '$TEST

               IF $DATA(DTOUT)!$DATA(DUOUT)

                   SET PXCEEND=1

                   if REQUIRED

                       SET PXCEQUIT=1

                   QUIT

 +21       NEW PXCEX,PXCEY

 +22       IF $EXTRACT(Y,1)="="

               SET PXCEX=$EXTRACT(PXCEIN01_" "_$EXTRACT($PIECE(Y,"^"),2,245),1,245)

 +23      IF '$TEST

               SET PXCEX=Y

 +24      ; ***

 +25      ; PX*1.0*199 - ICD-10 Remediation note.

 +26      ; Fields 5 and 10 in file #80 have been modified by STS for ICD-10.

 +27      ; In the following lines of code these two field numbers are intercepted

 +28      ; and an appropriate, alternative data retrieval is implemented.

 +29      ; Other file and field numbers will behave as they previously did.

 +30      ; ***

 +31       NEW DXCATIEN,PXDXDATE

 +32       SET PXDXDATE=$PIECE($GET(PXCEAFTR(12)),U,1)

 +33       IF PXDXDATE=""

               SET PXDXDATE=$SELECT($DATA(PXCEVIEN)=1:$$CSDATE^PXDXUTL(PXCEVIEN),$DATA(PXCEAPDT)=1:PXCEAPDT,1:DT)

 +34       IF DEFAULT

               IF PXCEX=""

                   Begin DoDot:1

 +35                   IF $GET(FILE)=80

                           IF $GET(FIELD1)=10

                               Begin DoDot:2

 +36                               SET PXCEX=$$DXNARR^PXUTL1($PIECE(PXCEAFTR(0),"^",1),PXDXDATE)

                               End DoDot:2

                               QUIT

 +37                   IF $GET(FILE)=80

                           IF $GET(FIELD1)=5

                               Begin DoDot:2

 +38                               SET DXCATIEN=$PIECE($$ICDDATA^ICDXCODE("DIAG",$PIECE(PXCEAFTR(0),"^",1),PXDXDATE,"I"),"^",6)

 +39                               IF $LENGTH(DXCATIEN)

                                       SET PXCEX=$$GET1^DIQ(80.3,DXCATIEN,.01)

                               End DoDot:2

                               QUIT

 +40                   SET PXCEX=$$EXTTEXT^PXUTL1($PIECE(PXCEAFTR(0),"^",1),REQUIRED,$GET(FILE),$GET(FIELD1),$GET(FIELD2))

                   End DoDot:1

 +41       IF ASKING

               Begin DoDot:1

 +42               WRITE !,PXCEX

               End DoDot:1

 +43       IF $LENGTH(PXCEX)=1

               IF PXCEX'="@"

                   WRITE !,"Must be 2 to 245 characters."

                   GOTO ENARRAT1

 +44       IF PXCEX="@"!(PXCEX="")

               IF REQUIRED

                   WRITE !,"This field is required.",$CHAR(7)

                   GOTO ENARRAT1

 +45      ;

 +46       IF PXCEX="@"!(PXCEX="")

               SET PXCEY=PXCEX

 +47      IF '$TEST

               SET PXCEY=$$PROVNARR^PXAPI(PXCEX,PXCEFILE)

               IF ASKING

                   IF +PXCEY'>0

                       WRITE "??",$CHAR(7)

                       GOTO ENARRAT1

 +48      IF '$TEST

               IF +PXCEY'>0

                   SET PXCEY=""

 +49       SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE(PXCEY,"^")

 +50       QUIT

 +51      ;

 +52      ;********************************

EINJURY   ;Date/Time of Injury

 +1       ;If not an injury code Q

 +2        NEW CODEIEN,DIRUT,DOINJ,HELP,INJCODE,PROMPT

 +3        SET CODEIEN=$PIECE(PXCEAFTR(0),U,1)

 +4        SET INJCODE=$$INJURYC(CODEIEN)

 +5        IF INJCODE=0

               QUIT

 +6        SET HELP="D DINJHELP^PXCEPOV1"

 +7        SET DOINJ=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))

 +8        SET PROMPT=$PIECE(PXCETEXT,"~",4)

 +9        SET DOINJ=$$GETDT^PXDATE(-1,-1,0,DOINJ,PROMPT,HELP)

 +10       IF $DATA(DIRUT)

               IF (DOINJ'="@")

                   SET PXCEEND=1

                   QUIT

 +11       SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=DOINJ

 +12       QUIT

 +13      ;

 +14      ;********************************

EVENTDTHELP ;Event Date and Time help.

 +1        NEW ERR,RESULT,TEXT

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

 +3        DO BROWSE^DDBR("TEXT(""DESCRIPTION"")","NR","V POV 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       ;********************************

ICDCODE   ;Enter ICD code using Lexicon.

 +1        NEW CODE,CODEIEN,CODESYS,EVENTDT,HELP,PXCEDT,SERVCAT,SRCHTERM,TEMP

 +2       ;Prompt the user for the Lexicon search term.

 +3        SET SRCHTERM=$$GETST^PXLEX

 +4        IF SRCHTERM=""

               SET DIRUT=1

               SET (X,Y)=""

               QUIT

 +5       ;Prompt the user for the Event Date and Time. This is only

 +6       ;for new entries because it is used in the Lexicon search

 +7       ;to ensure only codes active on that date are returned.

 +8        SET TEMP=^AUPNVSIT(PXCEVIEN,0)

 +9        SET SERVCAT=$PIECE(TEMP,U,7)

 +10       SET HELP="D EVENTDTHELP^PXCEPOV1"

 +11       SET EVENTDT=$$EVENTDT^PXDATE("",HELP)

 +12       SET PXCEDT=EVENTDT

 +13      ;If the Event Date and Time is null use the Visit Date.

 +14       IF PXCEDT=""

               SET PXCEDT=$PIECE(TEMP,U,1)

 +15      ;Set the coding system based on the Date.

 +16       SET CODESYS=$PIECE($$ACTDT^PXDXUTL(PXCEDT),U,1)

 +17      ;Let the user select the code, only return active codes.

 +18       SET CODE=$$GETCODE^PXLEXS(CODESYS,SRCHTERM,PXCEDT,1)

 +19       IF CODE=""

               SET DIRUT=1

               SET (X,Y)=""

               QUIT

 +20      ;ICR #5747

 +21       SET CODEIEN=$PIECE($$CODEN^ICDCODE(CODE),"~",1)

 +22       SET $PIECE(PXCEAFTR(0),U,1)=CODEIEN

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

 +24       QUIT

 +25      ;

 +26      ;********************************

INJURYC(CODEIEN) ;Return 1 if the ICD code is an injury code.

 +1       ;If not an injury code Q

 +2        NEW CODE,CODESYS,INJCODE

 +3        SET CODE=$$CODEC^ICDCODE(CODEIEN)

 +4        SET CODESYS=$$CSI^ICDEX(80,CODEIEN)

 +5        SET INJCODE=0

 +6       ;ICD-9 codes between 800 and 999.999 are considered injury codes.

 +7        IF (CODESYS=1)

               IF (CODE'<800)

                   IF (CODE'>999.999)

                       SET INJCODE=1

 +8       ;ICD-10 Codes beginning with S or T are considered Injury codes.

 +9        IF CODESYS=30

               Begin DoDot:1

 +10               NEW C1

 +11               SET C1=$EXTRACT(CODE,1)

 +12               IF (C1="S")!(C1="T")

                       SET INJCODE=1

               End DoDot:1

 +13       QUIT INJCODE

 +14      ;

PXCEPOV1.m