PXCESK ;ISL/dee - Used to edit and display V SKIN TEST ;Mar 15, 2021@15:16:32
;;1.0;PCE PATIENT CARE ENCOUNTER;**27,124,162,210,211,217**;Aug 12, 1996;Build 134
;; ;
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.)
;
;***Reading (.05) must be the line before Results (.04)***
;Adding/editing diagnosis removed in PX*1.0*211, reference to
;EPOV^PXCEVIMM replaced by SKIP^PXCESK.
;
FORMAT ;;Skin Test~9000010.12~0,12,13,80,811,812~1~^AUPNVSK
;;0~1~.01~Skin Test: ~Skin Test: ~$$DISPLYSK^PXCESK~~~~B
;;12~1~1201~Placement Date and Time: ~Date/Time of Placement: ~~EVENTDT^PXCESK(.PXCEAFTR)~~~D
;;12~2~1202~Ordering Provider: ~Ordering Provider: ~~EPROV12^PXCEPRV~~~D
;;12~4~1204~Administered By: ~Administered By: ~~EPROV12^PXCEPRV~~~D
;;12~12~1212~Anatomic Location: ~Anatomic Location of Placement: ~~~~~D
;;811~1~81101~Placement Comments: ~Placement Comments: ~~~~~D
;;812~2~81202~Package: ~Package: ~~SKIP^PXCESK~~~D
;;812~3~81203~Data Source: ~Data Source: ~~SKIP^PXCESK~~~D
;;0~6~.06~Reading Date and Time: ~Reading Date/Time: ~~EREADDT^PXCESK~~~D
;;12~14~1214~Hours Read Post-Placement: ~Hours Read Post-Placement: ~~~~~D
;;0~5~.05~Reading in millimeters (mm): ~Reading in millimeters (mm): ~~EREADING^PXCESK~~~D
;;0~4~.04~Results~Results: ~~ERESULTS^PXCESK~~~D
;;0~7~.07~Reader: ~Reader: ~~EPROV12^PXCEPRV~~~D
;;13~1~1301~Reading Comments: ~Reading Comments: ~~~~~D
;;80~1~801~Diagnosis: ~Diagnosis: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
;;80~2~802~Diagnosis 2: ~Diagnosis 2: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
;;80~3~803~Diagnosis 3: ~Diagnosis 3: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
;;80~4~804~Diagnosis 4: ~Diagnosis 4: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
;;80~5~805~Diagnosis 5: ~Diagnosis 5: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
;;80~6~806~Diagnosis 6: ~Diagnosis 6: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
;;80~7~807~Diagnosis 7: ~Diagnosis 7: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
;;80~8~808~Diagnosis 8: ~Diagnosis 8: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
;;
;
;The interface for AICS to get list on form for help.
INTRFACE ;;PX SELECT SKIN TEST
;
;********************************
;Special cases for display.
;
;********************************
;Special cases for edit.
;
EREADING ;
I $P(PXCEAFTR(0),"^",5)'="" 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 DIR("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
S DIR(0)="NAO^0:40:0"
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(0),"^",5)=$P(Y,"^")
Q
;
EREADDT ;
N PXVPLACE
I $P(PXCEAFTR(0),"^",6)'="" 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 DIR("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
S DIR(0)="9000010.12,.06AO"
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(0),"^",6)=$P(Y,"^")
N PXVX,X1,X2,X3
S X1=$P(PXCEAFTR(0),"^",6) ; DATE READ
S X2=$P(PXCEAFTR(12),"^") ; EVENT DATE AND TIME
I X2="" S X2=$P($G(^AUPNVSIT(+$P(PXCEAFTR(0),U,3),0)),U,1)
S PXVPLACE=$P(PXCEAFTR(12),U,8) ; PLACEMENT SKIN TEST
I PXVPLACE D
. S X2=$P($G(^AUPNVSK(PXVPLACE,12)),U)
. I X2="" S X2=$P($G(^AUPNVSIT(+$P($G(^AUPNVSK(PXVPLACE,0)),U,3),0)),U,1)
S X3=2 ; return difference in seconds
S PXVX=""
I $G(X1),$L(X1)>7,$G(X2),$L(X2)>7,$G(X2)'>$G(X1) S PXVX=$$FMDIFF^XLFDT(X1,X2,X3)\3600
I PXVX D EN^DDIOL("Hours Read Post-Placement: "_PXVX,"","!")
Q
;
ERESULTS ;
I $P(PXCEAFTR(0),"^",4)'="" 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 DIR("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
S DIR(0)="SOM^P:POSITIVE;N:NEGATIVE;D:DOUBTFUL;O:NO TAKE"
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(0),"^",4)=$P(Y,"^")
Q
;
;********************************
EVENTDT(PXCEAFTR) ;Edit the Event Date and Time.
N DEFAULT,EVENTDT,HELP,IEN,PROMPT
S DEFAULT=$P(^TMP("PXK",$J,"SK",1,12,"BEFORE"),U,1)
S HELP="D EVDTHELP^PXCESK"
S PROMPT="Placement Date and Time"
S EVENTDT=$$GETDT^PXDATE(-1,-1,-1,DEFAULT,PROMPT,HELP)
S $P(PXCEAFTR(12),U,1)=EVENTDT
Q
;
;********************************
EVDTHELP ;Event Date and Time help.
N ERR,RESULT,TEXT
S RESULT=$$GET1^DID(9000010.12,1201,"","DESCRIPTION","TEXT","ERR")
D BROWSE^DDBR("TEXT(""DESCRIPTION"")","NR","V Skin Test Placement Date and Time Help")
I $D(DDS) D REFRESH^DDSUTL S DY=IOSL-7,DX=0 X IOXY S $Y=DY,$X=DX
Q
;
;********************************
;Display text for the .01 field which is a pointer to Skin Test.
;(Must have is called by ASK^PXCEVFI2 and DEL^PXCEVFI2.)
DISPLY01(PXCESK,PXCEDT) ;
N DIERR,PXCEDILF,PXCEINT,PXCEEXT
S PXCEINT=$P(PXCESK,"^",1)
S PXCEEXT=$$EXTERNAL^DILFD(9000010.12,.01,"",PXCEINT,"PXCEDILF")
Q $S('$D(DIERR):PXCEEXT,1:PXCEINT)
;
;********************************
;
SAVE ;Special code for saving a Skin Test.
N PXCERR
S PXCERR=$P(^TMP("PXK",$J,PXCECATS,1,0,"AFTER"),"^",4,5)
Q:PXCERR="^"
I $P(PXCERR,"^",1)'=$P(^TMP("PXK",$J,PXCECATS,1,0,"BEFORE"),"^",4) S $P(^TMP("PXK",$J,PXCECATS,1,0,"AFTER"),"^",4)="@"
I $P(PXCERR,"^",2)'=$P(^TMP("PXK",$J,PXCECATS,1,0,"BEFORE"),"^",5) S $P(^TMP("PXK",$J,PXCECATS,1,0,"AFTER"),"^",5)="@"
D EN1^PXKMAIN
S ^TMP("PXK",$J,PXCECATS,1,0,"AFTER")=PXCEAFTR(0)
S ^TMP("PXK",$J,PXCECATS,1,12,"AFTER")=PXCEAFTR(12)
S ^TMP("PXK",$J,PXCECATS,1,13,"AFTER")=PXCEAFTR(13)
S ^TMP("PXK",$J,PXCECATS,1,80,"AFTER")=PXCEAFTR(80)
S ^TMP("PXK",$J,PXCECATS,1,811,"AFTER")=PXCEAFTR(811)
Q
;********************************
SKIP ;Used to by-pass roll and scroll editing of a field.
S (X,Y)=""
Q
;
;********************************
; When adding a new skin test entry, prompt if recording placement, reading, or both.
; if recording reading, prompt to select corresponding placement entry.
NEW(PXCESKTYP,PXCEAFTR,PXCEPAT,PXCEVIEN) ;
;
N DIR,DIRUT,PXCEEND,PXDATE,PXEND,PXNODE,PXSKIN,PXSKINNM,PXSKINP,PXSKINPDT,PXSKLST,PXSTART,X,Y
;
S PXCEEND=0
;
; For Historical, set both placement and reading fields.
I $P($G(^AUPNVSIT(+PXCEVIEN,0)),U,7)="E" D Q 0
. S PXCESKTYP="B"
;
W !
S DIR(0)="SA^A:ADMINISTRATION;R:READING;B:BOTH"
S DIR("A")="Are you recording a skin test (A)dministration, (R)eading, or (B)oth? "
D ^DIR
;
I $D(DIRUT)!(Y'?1(1"A",1"R",1"B")) Q 1
S PXCESKTYP=Y
;
I Y'="R" Q PXCEEND
;
S PXDATE=$P($G(^AUPNVSIT(+PXCEVIEN,0)),U,1)
S PXSKIN=$P(PXCEAFTR(0),U,1)
S PXSKINNM=$P($G(^AUTTSK(+PXSKIN,12)),U,1)
I PXSKINNM="" S PXSKINNM=$P($G(^AUTTSK(+PXSKIN,0)),U,1)
D SKLIST^PXVRPC8(.PXSKLST,PXCEPAT,PXSKIN,PXDATE,1)
S PXNODE=$G(PXSKLST(1))
S PXSTART=""
S PXEND=""
I $P(PXNODE,U,1)="DATERANGE" D
. S PXSTART=$P(PXNODE,U,2)
. S PXEND=$P(PXNODE,U,3)
S PXNODE=$G(PXSKLST(2))
S PXSKINPDT=""
I $P(PXNODE,U,1)="PLACEMENT" D
. S PXSKINPDT=$P(PXNODE,U,5)
. S PXSKINP=$P(PXNODE,U,2)
;
I 'PXSKINPDT D Q 1
. W !!,"We could not find a "_PXSKINNM_" skin test administered between "_$$FMTE^XLFDT(PXSTART,"D")
. W !,"and "_$$FMTE^XLFDT(PXEND,"D")_" that does not already have a reading."
. D WAIT^PXCEHELP
;
K DIRUT,DIR,Y,X
S DIR(0)="Y"
S DIR("B")="YES"
W !!,"Is this reading for the "_PXSKINNM_" skin test administered on"
S DIR("A")=$$FMTE^XLFDT(PXSKINPDT,"M")
D ^DIR
;
I $D(DIRUT)!(Y'?1(1"1",1"0")) Q 1
I Y D
. W !!,"We will link this skin test reading to that placement entry.",!
. H 1
. S $P(PXCEAFTR(12),U,8)=PXSKINP
I 'Y D
. S PXCEEND=1
. W !!,"You must first record the skin test placement before recording the reading."
. D WAIT^PXCEHELP
;
Q PXCEEND
;
;********************************
; Check if this is a placement or reading entry
EDIT(PXCESKTYP,PXCEAFTR,PXCEFIEN) ;
I $P(PXCEAFTR(12),U,8) S PXCESKTYP="R" Q 0
I $O(^AUPNVSK("APT",PXCEFIEN,0)) S PXCESKTYP="A" Q 0
Q 0
;
;********************************
; Check if user should be prompted for this field.
; Depends on if PXCESKTYP is (A)dministration/(R)eading/(B)oth.
PROMPT(PXCESKTYP,PXFIELD) ;
;
N PXPLACE,PXREAD
;
I $G(PXCESKTYP)?1(1"",1"B") Q 1
;
; Placement fields
S PXPLACE="^.01^.02^.03^1201^1202^1204^1211^1212^81101^81202^81203^"
;
; Reading fields
S PXREAD="^.01^.02^.03^.04^.05^.06^.07^1208^1214^1220^1301^81202^81203^"
;
I PXCESKTYP="A",PXPLACE[(U_PXFIELD_U) Q 1
I PXCESKTYP="R",PXREAD[(U_PXFIELD_U) Q 1
;
Q 0
;
;********************************
; Can this skin test entry be deleted?
CANDEL(PXCEFIEN) ;
;
I '$D(^AUPNVSK("APT",PXCEFIEN)) Q 1
;
W !!,"There is a skin test reading linked to this entry. "
W !,"You must first delete the skin test reading entry (#"_$O(^AUPNVSK("APT",PXCEFIEN,0))_")"
W !,"before deleting this placement entry."
D WAIT^PXCEHELP
;
Q 0
;
;
DISPLYSK(PXCESK,PXCEDT) ;Display the skin test.
N PXREADTYP,PXTEXT
S PXCESK=+PXCESK
S PXTEXT=$P($G(^AUTTSK(PXCESK,0)),U,1)
;
S PXREADTYP=""
I $P($G(^AUPNVSK(+$G(IEN),12)),U,8) S PXREADTYP="R"
I $O(^AUPNVSK("APT",+$G(IEN),0)) S PXREADTYP="A"
S PXTEXT=PXTEXT_$S(PXREADTYP="R":" (Reading)",PXREADTYP="A":" (Placement)",1:"")
;
Q PXTEXT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCESK 10405 printed Dec 13, 2024@02:28:17 Page 2
PXCESK ;ISL/dee - Used to edit and display V SKIN TEST ;Mar 15, 2021@15:16:32
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**27,124,162,210,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 caces.
+13 ; (The .01 field cannot have a special edit.)
+14 ;
+15 ;***Reading (.05) must be the line before Results (.04)***
+16 ;Adding/editing diagnosis removed in PX*1.0*211, reference to
+17 ;EPOV^PXCEVIMM replaced by SKIP^PXCESK.
+18 ;
FORMAT ;;Skin Test~9000010.12~0,12,13,80,811,812~1~^AUPNVSK
+1 ;;0~1~.01~Skin Test: ~Skin Test: ~$$DISPLYSK^PXCESK~~~~B
+2 ;;12~1~1201~Placement Date and Time: ~Date/Time of Placement: ~~EVENTDT^PXCESK(.PXCEAFTR)~~~D
+3 ;;12~2~1202~Ordering Provider: ~Ordering Provider: ~~EPROV12^PXCEPRV~~~D
+4 ;;12~4~1204~Administered By: ~Administered By: ~~EPROV12^PXCEPRV~~~D
+5 ;;12~12~1212~Anatomic Location: ~Anatomic Location of Placement: ~~~~~D
+6 ;;811~1~81101~Placement Comments: ~Placement Comments: ~~~~~D
+7 ;;812~2~81202~Package: ~Package: ~~SKIP^PXCESK~~~D
+8 ;;812~3~81203~Data Source: ~Data Source: ~~SKIP^PXCESK~~~D
+9 ;;0~6~.06~Reading Date and Time: ~Reading Date/Time: ~~EREADDT^PXCESK~~~D
+10 ;;12~14~1214~Hours Read Post-Placement: ~Hours Read Post-Placement: ~~~~~D
+11 ;;0~5~.05~Reading in millimeters (mm): ~Reading in millimeters (mm): ~~EREADING^PXCESK~~~D
+12 ;;0~4~.04~Results~Results: ~~ERESULTS^PXCESK~~~D
+13 ;;0~7~.07~Reader: ~Reader: ~~EPROV12^PXCEPRV~~~D
+14 ;;13~1~1301~Reading Comments: ~Reading Comments: ~~~~~D
+15 ;;80~1~801~Diagnosis: ~Diagnosis: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
+16 ;;80~2~802~Diagnosis 2: ~Diagnosis 2: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
+17 ;;80~3~803~Diagnosis 3: ~Diagnosis 3: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
+18 ;;80~4~804~Diagnosis 4: ~Diagnosis 4: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
+19 ;;80~5~805~Diagnosis 5: ~Diagnosis 5: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
+20 ;;80~6~806~Diagnosis 6: ~Diagnosis 6: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
+21 ;;80~7~807~Diagnosis 7: ~Diagnosis 7: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
+22 ;;80~8~808~Diagnosis 8: ~Diagnosis 8: ~$$DISPLY01^PXCEPOV~SKIP^PXCESK~~S~
+23 ;;
+24 ;
+25 ;The interface for AICS to get list on form for help.
INTRFACE ;;PX SELECT SKIN TEST
+1 ;
+2 ;********************************
+3 ;Special cases for display.
+4 ;
+5 ;********************************
+6 ;Special cases for edit.
+7 ;
EREADING ;
+1 IF $PIECE(PXCEAFTR(0),"^",5)'=""
Begin DoDot:1
+2 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+3 SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+4 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+5 SET DIR("B")=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:1
+6 SET DIR(0)="NAO^0:40:0"
+7 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+8 if $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+9 DO ^DIR
+10 KILL DIR,DA
+11 IF X="@"
SET Y="@"
+12 IF '$TEST
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
QUIT
+13 SET $PIECE(PXCEAFTR(0),"^",5)=$PIECE(Y,"^")
+14 QUIT
+15 ;
EREADDT ;
+1 NEW PXVPLACE
+2 IF $PIECE(PXCEAFTR(0),"^",6)'=""
Begin DoDot:1
+3 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+4 SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+5 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+6 SET DIR("B")=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:1
+7 SET DIR(0)="9000010.12,.06AO"
+8 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+9 if $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+10 DO ^DIR
+11 KILL DIR,DA
+12 IF X="@"
SET Y="@"
+13 IF '$TEST
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
QUIT
+14 SET $PIECE(PXCEAFTR(0),"^",6)=$PIECE(Y,"^")
+15 NEW PXVX,X1,X2,X3
+16 ; DATE READ
SET X1=$PIECE(PXCEAFTR(0),"^",6)
+17 ; EVENT DATE AND TIME
SET X2=$PIECE(PXCEAFTR(12),"^")
+18 IF X2=""
SET X2=$PIECE($GET(^AUPNVSIT(+$PIECE(PXCEAFTR(0),U,3),0)),U,1)
+19 ; PLACEMENT SKIN TEST
SET PXVPLACE=$PIECE(PXCEAFTR(12),U,8)
+20 IF PXVPLACE
Begin DoDot:1
+21 SET X2=$PIECE($GET(^AUPNVSK(PXVPLACE,12)),U)
+22 IF X2=""
SET X2=$PIECE($GET(^AUPNVSIT(+$PIECE($GET(^AUPNVSK(PXVPLACE,0)),U,3),0)),U,1)
End DoDot:1
+23 ; return difference in seconds
SET X3=2
+24 SET PXVX=""
+25 IF $GET(X1)
IF $LENGTH(X1)>7
IF $GET(X2)
IF $LENGTH(X2)>7
IF $GET(X2)'>$GET(X1)
SET PXVX=$$FMDIFF^XLFDT(X1,X2,X3)\3600
+26 IF PXVX
DO EN^DDIOL("Hours Read Post-Placement: "_PXVX,"","!")
+27 QUIT
+28 ;
ERESULTS ;
+1 IF $PIECE(PXCEAFTR(0),"^",4)'=""
Begin DoDot:1
+2 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+3 SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+4 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+5 SET DIR("B")=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:1
+6 SET DIR(0)="SOM^P:POSITIVE;N:NEGATIVE;D:DOUBTFUL;O:NO TAKE"
+7 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+8 if $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+9 DO ^DIR
+10 KILL DIR,DA
+11 IF X="@"
SET Y="@"
+12 IF '$TEST
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
QUIT
+13 SET $PIECE(PXCEAFTR(0),"^",4)=$PIECE(Y,"^")
+14 QUIT
+15 ;
+16 ;********************************
EVENTDT(PXCEAFTR) ;Edit the Event Date and Time.
+1 NEW DEFAULT,EVENTDT,HELP,IEN,PROMPT
+2 SET DEFAULT=$PIECE(^TMP("PXK",$JOB,"SK",1,12,"BEFORE"),U,1)
+3 SET HELP="D EVDTHELP^PXCESK"
+4 SET PROMPT="Placement 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.12,1201,"","DESCRIPTION","TEXT","ERR")
+3 DO BROWSE^DDBR("TEXT(""DESCRIPTION"")","NR","V Skin Test Placement 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 ;********************************
+8 ;Display text for the .01 field which is a pointer to Skin Test.
+9 ;(Must have is called by ASK^PXCEVFI2 and DEL^PXCEVFI2.)
DISPLY01(PXCESK,PXCEDT) ;
+1 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+2 SET PXCEINT=$PIECE(PXCESK,"^",1)
+3 SET PXCEEXT=$$EXTERNAL^DILFD(9000010.12,.01,"",PXCEINT,"PXCEDILF")
+4 QUIT $SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
+5 ;
+6 ;********************************
+7 ;
SAVE ;Special code for saving a Skin Test.
+1 NEW PXCERR
+2 SET PXCERR=$PIECE(^TMP("PXK",$JOB,PXCECATS,1,0,"AFTER"),"^",4,5)
+3 if PXCERR="^"
QUIT
+4 IF $PIECE(PXCERR,"^",1)'=$PIECE(^TMP("PXK",$JOB,PXCECATS,1,0,"BEFORE"),"^",4)
SET $PIECE(^TMP("PXK",$JOB,PXCECATS,1,0,"AFTER"),"^",4)="@"
+5 IF $PIECE(PXCERR,"^",2)'=$PIECE(^TMP("PXK",$JOB,PXCECATS,1,0,"BEFORE"),"^",5)
SET $PIECE(^TMP("PXK",$JOB,PXCECATS,1,0,"AFTER"),"^",5)="@"
+6 DO EN1^PXKMAIN
+7 SET ^TMP("PXK",$JOB,PXCECATS,1,0,"AFTER")=PXCEAFTR(0)
+8 SET ^TMP("PXK",$JOB,PXCECATS,1,12,"AFTER")=PXCEAFTR(12)
+9 SET ^TMP("PXK",$JOB,PXCECATS,1,13,"AFTER")=PXCEAFTR(13)
+10 SET ^TMP("PXK",$JOB,PXCECATS,1,80,"AFTER")=PXCEAFTR(80)
+11 SET ^TMP("PXK",$JOB,PXCECATS,1,811,"AFTER")=PXCEAFTR(811)
+12 QUIT
+13 ;********************************
SKIP ;Used to by-pass roll and scroll editing of a field.
+1 SET (X,Y)=""
+2 QUIT
+3 ;
+4 ;********************************
+5 ; When adding a new skin test entry, prompt if recording placement, reading, or both.
+6 ; if recording reading, prompt to select corresponding placement entry.
NEW(PXCESKTYP,PXCEAFTR,PXCEPAT,PXCEVIEN) ;
+1 ;
+2 NEW DIR,DIRUT,PXCEEND,PXDATE,PXEND,PXNODE,PXSKIN,PXSKINNM,PXSKINP,PXSKINPDT,PXSKLST,PXSTART,X,Y
+3 ;
+4 SET PXCEEND=0
+5 ;
+6 ; For Historical, set both placement and reading fields.
+7 IF $PIECE($GET(^AUPNVSIT(+PXCEVIEN,0)),U,7)="E"
Begin DoDot:1
+8 SET PXCESKTYP="B"
End DoDot:1
QUIT 0
+9 ;
+10 WRITE !
+11 SET DIR(0)="SA^A:ADMINISTRATION;R:READING;B:BOTH"
+12 SET DIR("A")="Are you recording a skin test (A)dministration, (R)eading, or (B)oth? "
+13 DO ^DIR
+14 ;
+15 IF $DATA(DIRUT)!(Y'?1(1"A",1"R",1"B"))
QUIT 1
+16 SET PXCESKTYP=Y
+17 ;
+18 IF Y'="R"
QUIT PXCEEND
+19 ;
+20 SET PXDATE=$PIECE($GET(^AUPNVSIT(+PXCEVIEN,0)),U,1)
+21 SET PXSKIN=$PIECE(PXCEAFTR(0),U,1)
+22 SET PXSKINNM=$PIECE($GET(^AUTTSK(+PXSKIN,12)),U,1)
+23 IF PXSKINNM=""
SET PXSKINNM=$PIECE($GET(^AUTTSK(+PXSKIN,0)),U,1)
+24 DO SKLIST^PXVRPC8(.PXSKLST,PXCEPAT,PXSKIN,PXDATE,1)
+25 SET PXNODE=$GET(PXSKLST(1))
+26 SET PXSTART=""
+27 SET PXEND=""
+28 IF $PIECE(PXNODE,U,1)="DATERANGE"
Begin DoDot:1
+29 SET PXSTART=$PIECE(PXNODE,U,2)
+30 SET PXEND=$PIECE(PXNODE,U,3)
End DoDot:1
+31 SET PXNODE=$GET(PXSKLST(2))
+32 SET PXSKINPDT=""
+33 IF $PIECE(PXNODE,U,1)="PLACEMENT"
Begin DoDot:1
+34 SET PXSKINPDT=$PIECE(PXNODE,U,5)
+35 SET PXSKINP=$PIECE(PXNODE,U,2)
End DoDot:1
+36 ;
+37 IF 'PXSKINPDT
Begin DoDot:1
+38 WRITE !!,"We could not find a "_PXSKINNM_" skin test administered between "_$$FMTE^XLFDT(PXSTART,"D")
+39 WRITE !,"and "_$$FMTE^XLFDT(PXEND,"D")_" that does not already have a reading."
+40 DO WAIT^PXCEHELP
End DoDot:1
QUIT 1
+41 ;
+42 KILL DIRUT,DIR,Y,X
+43 SET DIR(0)="Y"
+44 SET DIR("B")="YES"
+45 WRITE !!,"Is this reading for the "_PXSKINNM_" skin test administered on"
+46 SET DIR("A")=$$FMTE^XLFDT(PXSKINPDT,"M")
+47 DO ^DIR
+48 ;
+49 IF $DATA(DIRUT)!(Y'?1(1"1",1"0"))
QUIT 1
+50 IF Y
Begin DoDot:1
+51 WRITE !!,"We will link this skin test reading to that placement entry.",!
+52 HANG 1
+53 SET $PIECE(PXCEAFTR(12),U,8)=PXSKINP
End DoDot:1
+54 IF 'Y
Begin DoDot:1
+55 SET PXCEEND=1
+56 WRITE !!,"You must first record the skin test placement before recording the reading."
+57 DO WAIT^PXCEHELP
End DoDot:1
+58 ;
+59 QUIT PXCEEND
+60 ;
+61 ;********************************
+62 ; Check if this is a placement or reading entry
EDIT(PXCESKTYP,PXCEAFTR,PXCEFIEN) ;
+1 IF $PIECE(PXCEAFTR(12),U,8)
SET PXCESKTYP="R"
QUIT 0
+2 IF $ORDER(^AUPNVSK("APT",PXCEFIEN,0))
SET PXCESKTYP="A"
QUIT 0
+3 QUIT 0
+4 ;
+5 ;********************************
+6 ; Check if user should be prompted for this field.
+7 ; Depends on if PXCESKTYP is (A)dministration/(R)eading/(B)oth.
PROMPT(PXCESKTYP,PXFIELD) ;
+1 ;
+2 NEW PXPLACE,PXREAD
+3 ;
+4 IF $GET(PXCESKTYP)?1(1"",1"B")
QUIT 1
+5 ;
+6 ; Placement fields
+7 SET PXPLACE="^.01^.02^.03^1201^1202^1204^1211^1212^81101^81202^81203^"
+8 ;
+9 ; Reading fields
+10 SET PXREAD="^.01^.02^.03^.04^.05^.06^.07^1208^1214^1220^1301^81202^81203^"
+11 ;
+12 IF PXCESKTYP="A"
IF PXPLACE[(U_PXFIELD_U)
QUIT 1
+13 IF PXCESKTYP="R"
IF PXREAD[(U_PXFIELD_U)
QUIT 1
+14 ;
+15 QUIT 0
+16 ;
+17 ;********************************
+18 ; Can this skin test entry be deleted?
CANDEL(PXCEFIEN) ;
+1 ;
+2 IF '$DATA(^AUPNVSK("APT",PXCEFIEN))
QUIT 1
+3 ;
+4 WRITE !!,"There is a skin test reading linked to this entry. "
+5 WRITE !,"You must first delete the skin test reading entry (#"_$ORDER(^AUPNVSK("APT",PXCEFIEN,0))_")"
+6 WRITE !,"before deleting this placement entry."
+7 DO WAIT^PXCEHELP
+8 ;
+9 QUIT 0
+10 ;
+11 ;
DISPLYSK(PXCESK,PXCEDT) ;Display the skin test.
+1 NEW PXREADTYP,PXTEXT
+2 SET PXCESK=+PXCESK
+3 SET PXTEXT=$PIECE($GET(^AUTTSK(PXCESK,0)),U,1)
+4 ;
+5 SET PXREADTYP=""
+6 IF $PIECE($GET(^AUPNVSK(+$GET(IEN),12)),U,8)
SET PXREADTYP="R"
+7 IF $ORDER(^AUPNVSK("APT",+$GET(IEN),0))
SET PXREADTYP="A"
+8 SET PXTEXT=PXTEXT_$SELECT(PXREADTYP="R":" (Reading)",PXREADTYP="A":" (Placement)",1:"")
+9 ;
+10 QUIT PXTEXT
