PXCEPOV1 ;ISL/dee - Used to edit and display V POV ;6/20/96
;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996
;; ;
Q
;
;********************************
;Special cases for display.
;
DNARRAT(PNAR) ;Provider Narrative for ICD-9
N PXCEPNAR
S PXCEPNAR=$P(^AUTNPOV(PNAR,0),"^")
I $G(VIEW)="B",$D(ENTRY)>0 D
. N DIC,DR,DA,DIQ,PXCEDIQ1
. S DIC=80
. S DR="3"
. S DA=$P(ENTRY(0),"^",1)
. S DIQ="PXCEDIQ1("
. S DIQ(0)="E"
. D EN^DIQ1
. S:PXCEDIQ1(80,DA,3,"E")=PXCEPNAR PXCEPNAR=""
Q PXCEPNAR
;
DPRIMSEC(PRIMSEC) ;
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 uparrow."
. 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
I DEFAULT,PXCEX="" 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
;I not an injury code Q
N DIC,DR,DA,DIQ,PXCEDIQ1
S DIC=80
S DR=".01"
S DA=$P(PXCEAFTR(0),"^",1)
S DIQ="PXCEDIQ1("
S DIQ(0)="E"
D EN^DIQ1
I PXCEDIQ1(80,DA,.01,"E")'<800,PXCEDIQ1(80,DA,.01,"E")'>999.999 D E1201^PXCEPOV1(-1,-1,0)
Q
;
;********************************
;Special cases for edit for Event Date and Time field number 1201
; and other date and times.
;
E1201(REQTIME,BEFORE,AFTER,DEFAULT) ;
;REQTIME is 1 if time is required,
; 0 if time is optional
; -1 if the date can be imprecise
;BEFORE is the number of days before the visit that the date can
; not be before or -1 for any amount before.
;AFTER is the number of days after the visit that the date can
; not be after or -1 for any amount. In any case the date
; can not be later than today.
;DEFAULT is the default date/time is there is not one in the file.
; If it is -1 then NOW will be used as the default.
; If it is 0 then TODAY will be used as the default.
N X1,X2,X,%Y,%H,%I,%
N PXCEVST S PXCEVST=$P(+^TMP("PXK",$J,"VST",1,0,"BEFORE"),".")
N PXCEBEF,PXCEAFT S (PXCEBEF,PXCEAFT)=""
I $D(AFTER)#2,AFTER'<0 D
. I AFTER=0 S PXCEAFT=PXCEVST+.9
. E D
.. S X1=DT
.. S X2=$P(+^TMP("PXK",$J,"VST",1,0,"BEFORE"),".")
.. D ^%DTC
.. I X'>AFTER S PXCEAFT=DT+.9
.. E D
... S X1=$P(+^TMP("PXK",$J,"VST",1,0,"BEFORE"),".")
... S X2=AFTER
... D C^%DTC
... S PXCEAFT=X+.9
I $D(BEFORE)#2,BEFORE'<0 D
. I BEFORE=0 S PXCEBEF=PXCEVST
. E D
.. S X1=$P(+^TMP("PXK",$J,"VST",1,0,"BEFORE"),".")
.. S X2=-BEFORE
.. D C^%DTC
.. S PXCEBEF=X
S DIR(0)="DO^"_PXCEBEF_":"_PXCEAFT_":ESP"
I $G(REQTIME)=1 S DIR(0)=DIR(0)_"RX"
E I $G(REQTIME)=-1 S DIR(0)=DIR(0)_"T"
E S DIR(0)=DIR(0)_"TX"
I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" S DIR("B")=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
E I ($D(DEFAULT)#2) D
. I DEFAULT>0 S DIR("B")=DEFAULT
. E I DEFAULT=0 S DIR("B")=DT
. E I DEFAULT=-1 D NOW^%DTC S DIR("B")=%
I $D(DIR("B"))#2 S Y=DIR("B") D DD^%DT S DIR("B")=Y
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
S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
Q
;
PXCEPOV1 ;ISL/dee - Used to edit and display V POV ;6/20/96
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996
+2 ;; ;
+3 QUIT
+4 ;
+5 ;********************************
+6 ;Special cases for display.
+7 ;
DNARRAT(PNAR) ;Provider Narrative for ICD-9
+1 NEW PXCEPNAR
+2 SET PXCEPNAR=$PIECE(^AUTNPOV(PNAR,0),"^")
+3 IF $GET(VIEW)="B"
IF $DATA(ENTRY)>0
Begin DoDot:1
+4 NEW DIC,DR,DA,DIQ,PXCEDIQ1
+5 SET DIC=80
+6 SET DR="3"
+7 SET DA=$PIECE(ENTRY(0),"^",1)
+8 SET DIQ="PXCEDIQ1("
+9 SET DIQ(0)="E"
+10 DO EN^DIQ1
+11 IF PXCEDIQ1(80,DA,3,"E")=PXCEPNAR
SET PXCEPNAR=""
End DoDot:1
+12 QUIT PXCEPNAR
+13 ;
DPRIMSEC(PRIMSEC) ;
+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 -- Used by ALL V-Files with Prov. Nar.
+1 ; REQUIRED 0 for not required
+2 ; 1 for required
+3 ; ASK 0 for do not ask
+4 ; 1 for ask
+5 ; 2 for ask only if there is already a value
+6 ; DEFAULT 0 for do not default
+7 ; 1 for do default
+8 ; changed to 1 if REQUIRED is 1
+9 ;
+10 NEW PXKLAYGO,ASKING
+11 SET PXKLAYGO=""
+12 SET ASKING=ASK#2
+13 IF REQUIRED
SET DEFAULT=1
+14 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 uparrow."
+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 IF DEFAULT
IF PXCEX=""
SET PXCEX=$$EXTTEXT^PXUTL1($PIECE(PXCEAFTR(0),"^",1),REQUIRED,$GET(FILE),$GET(FIELD1),$GET(FIELD2))
+25 IF ASKING
Begin DoDot:1
+26 WRITE !,PXCEX
End DoDot:1
+27 IF $LENGTH(PXCEX)=1
IF PXCEX'="@"
WRITE !,"Must be 2 to 245 characters."
GOTO ENARRAT1
+28 IF PXCEX="@"!(PXCEX="")
IF REQUIRED
WRITE !,"This field is required.",$CHAR(7)
GOTO ENARRAT1
+29 ;
+30 IF PXCEX="@"!(PXCEX="")
SET PXCEY=PXCEX
+31 IF '$TEST
SET PXCEY=$$PROVNARR^PXAPI(PXCEX,PXCEFILE)
IF ASKING
IF +PXCEY'>0
WRITE "??",$CHAR(7)
GOTO ENARRAT1
+32 IF '$TEST
IF +PXCEY'>0
SET PXCEY=""
+33 SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE(PXCEY,"^")
+34 QUIT
+35 ;
EINJURY ;Date/Time of Injury
+1 ;I not an injury code Q
+2 NEW DIC,DR,DA,DIQ,PXCEDIQ1
+3 SET DIC=80
+4 SET DR=".01"
+5 SET DA=$PIECE(PXCEAFTR(0),"^",1)
+6 SET DIQ="PXCEDIQ1("
+7 SET DIQ(0)="E"
+8 DO EN^DIQ1
+9 IF PXCEDIQ1(80,DA,.01,"E")'<800
IF PXCEDIQ1(80,DA,.01,"E")'>999.999
DO E1201^PXCEPOV1(-1,-1,0)
+10 QUIT
+11 ;
+12 ;********************************
+13 ;Special cases for edit for Event Date and Time field number 1201
+14 ; and other date and times.
+15 ;
E1201(REQTIME,BEFORE,AFTER,DEFAULT) ;
+1 ;REQTIME is 1 if time is required,
+2 ; 0 if time is optional
+3 ; -1 if the date can be imprecise
+4 ;BEFORE is the number of days before the visit that the date can
+5 ; not be before or -1 for any amount before.
+6 ;AFTER is the number of days after the visit that the date can
+7 ; not be after or -1 for any amount. In any case the date
+8 ; can not be later than today.
+9 ;DEFAULT is the default date/time is there is not one in the file.
+10 ; If it is -1 then NOW will be used as the default.
+11 ; If it is 0 then TODAY will be used as the default.
+12 NEW X1,X2,X,%Y,%H,%I,%
+13 NEW PXCEVST
SET PXCEVST=$PIECE(+^TMP("PXK",$JOB,"VST",1,0,"BEFORE"),".")
+14 NEW PXCEBEF,PXCEAFT
SET (PXCEBEF,PXCEAFT)=""
+15 IF $DATA(AFTER)#2
IF AFTER'<0
Begin DoDot:1
+16 IF AFTER=0
SET PXCEAFT=PXCEVST+.9
+17 IF '$TEST
Begin DoDot:2
+18 SET X1=DT
+19 SET X2=$PIECE(+^TMP("PXK",$JOB,"VST",1,0,"BEFORE"),".")
+20 DO ^%DTC
+21 IF X'>AFTER
SET PXCEAFT=DT+.9
+22 IF '$TEST
Begin DoDot:3
+23 SET X1=$PIECE(+^TMP("PXK",$JOB,"VST",1,0,"BEFORE"),".")
+24 SET X2=AFTER
+25 DO C^%DTC
+26 SET PXCEAFT=X+.9
End DoDot:3
End DoDot:2
End DoDot:1
+27 IF $DATA(BEFORE)#2
IF BEFORE'<0
Begin DoDot:1
+28 IF BEFORE=0
SET PXCEBEF=PXCEVST
+29 IF '$TEST
Begin DoDot:2
+30 SET X1=$PIECE(+^TMP("PXK",$JOB,"VST",1,0,"BEFORE"),".")
+31 SET X2=-BEFORE
+32 DO C^%DTC
+33 SET PXCEBEF=X
End DoDot:2
End DoDot:1
+34 SET DIR(0)="DO^"_PXCEBEF_":"_PXCEAFT_":ESP"
+35 IF $GET(REQTIME)=1
SET DIR(0)=DIR(0)_"RX"
+36 IF '$TEST
IF $GET(REQTIME)=-1
SET DIR(0)=DIR(0)_"T"
+37 IF '$TEST
SET DIR(0)=DIR(0)_"TX"
+38 IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))'=""
SET DIR("B")=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+39 IF '$TEST
IF ($DATA(DEFAULT)#2)
Begin DoDot:1
+40 IF DEFAULT>0
SET DIR("B")=DEFAULT
+41 IF '$TEST
IF DEFAULT=0
SET DIR("B")=DT
+42 IF '$TEST
IF DEFAULT=-1
DO NOW^%DTC
SET DIR("B")=%
End DoDot:1
+43 IF $DATA(DIR("B"))#2
SET Y=DIR("B")
DO DD^%DT
SET DIR("B")=Y
+44 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+45 IF $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+46 DO ^DIR
+47 KILL DIR,DA
+48 IF X="@"
SET Y="@"
+49 IF '$TEST
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
QUIT
+50 SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE(Y,"^")
+51 QUIT
+52 ;
