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.
;
Q
;
;********************************
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
Q
;
;********************************
;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,"^")
Q
;
;********************************
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
Q
;
;********************************
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
Q
;
;********************************
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
Q
;
;********************************
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 Apr 09, 2024@21:33:49 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 ;
