AMER3 ; IHS/ANMC/GIS - MORE DISCHARGE QUESTIONS ;
;;3.0;ER VISIT SYSTEM;**6**;MAR 03, 2009;Build 30
;
QD10 ; ER PROCEDURES
N AMERNONE S AMERNONE=$$OPT^AMER0("NONE","ER PROCEDURES")
; W "Type '??' to see choices"
S AMEROPT=""
I $D(^TMP("AMER",$J,2,10,AMERNONE))!('$D(^TMP("AMER",$J,2,10))) S DIC("B")="NONE" G DIC
D PREV(10)
DIC S DIC("A")="Enter "_$S($O(^TMP("AMER",$J,2,10,0)):"another ",1:"")_"procedure: "
S DIC="^AMER(3,",DIC(0)="AEQ",DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("ER PROCEDURES")
D ^DIC K DIC
I $P(Y,U,2)="NONE" K ^TMP("AMER",$J,2,10) S ^TMP("AMER",$J,2,10,AMERNONE)=Y Q
I X?2."^" S DIROUT=""
D OUT^AMER I $D(AMERQUIT) Q
I "^"[$E(X) S Y="" Q
I $D(^TMP("AMER",$J,2,10,+Y)) D REM(10,Y) Q:$D(AMERQUIT) G DIC
S ^TMP("AMER",$J,2,10,+Y)=Y I +Y'=AMERNONE K ^(AMERNONE)
G DIC
;
REM(X,Y) W !,*7,$P(Y,U,2)," has already been selected. Want to cancel it"
S %=2 D YN^DICN S:%Y?2."^" DIROUT="" D OUT^AMER I $D(AMERQUIT) Q
I "Nn"[$E(%Y) Q
K ^TMP("AMER",$J,2,X,+Y) W !,$P(Y,U,2)," cancelled...",!!
Q
;
PREV(X) ; ENTRY POINT FROM AMER31
W !,"You have already selected =>",!
F %=0:0 S %=$O(^TMP("AMER",$J,2,X,%)) Q:'% W ?3,$P(^(%),U,2),!
W !
Q
;
QD11 ; FINAL DIAGNOSES
D QD11^AMER31
Q
;
QD12 ; FINAL TRIAGE CATEGORY
S DIR("B")=$G(^TMP("AMER",$J,2,12))
S DIR("?")="Enter a number from 1 to 5"
S DIR("?",1)="This is a site-specified value that indicates severity of visit"
S DIR(0)="N^1:5:0",DIR("A")="*Enter final acuity assessment from provider" KILL DA D ^DIR KILL DIR
D OUT^AMER
Q
;
QD14 ; DISPOSITION AND SCHEDULING
N AMERDISP ;IHS/OIT/SCR 10/10/08
S DIC("A")="*Disposition: " K DIC("B")
I $G(^TMP("AMER",$J,2,14))>0 S %=+^(14),DIC("B")=$P(^AMER(3,%,0),U)
;I $D(^TMP("AMER",$J,2,14)) S %=+^(14),DIC("B")=$P(^AMER(3,%,0),U) ;IHS/OIT/SCR 10/10/08
I $D(AMERDOA) S DIC("B")="DEATH"
I $D(AMERDNA) D
.;IHS/OIT/SCR 01/20/09 - OPTION MAY BE 'LEFT WITHOUT BEING SEEN' OR 'LEFT WITHOUT BEING DISCHARGED'
.S DIC="^AMER(3,",DIC(0)="",X="LEFT WITHOUT"
.D ^DIC
.I Y>0 S DIC("B")=$P(Y,"^",2)
.E S DIC("B")=""
.Q
S DIC="^AMER(3,",DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("DISPOSITION"),DIC(0)="AEQ"
D ^DIC K DIC D OUT^AMER I $D(AMERQUIT) Q
I Y=-1 Q
S AMERDISP=+Y
I AMERDISP=$$OPT^AMER0("REGISTERED IN ERROR","DISPOSITION") D Q
.D EN^DDIOL("Using this DISPOSITION will cause the entire VISIT to be deleted!!","","!")
.D EN^DDIOL("This DISPOSITION can not be changed!!","","!")
.S DIR(0)="Y",DIR("A")="Do you still wish use this DISPOSITION"
.S DIR("B")="YES"
.D ^DIR
.I Y=0 D
..S AMERRUN=13
..S ^TMP("AMER",$J,2,14)=""
..Q
.I Y=1 S AMERRUN=95
.Q
Q:AMERRUN=95
;I +Y=$$OPT^AMER0("HOME","DISPOSITION") S AMERRUN=15 D SCHEDULE Q
I AMERDISP'=$$OPT^AMER0("TRANSFER TO ANOTHER FACILITY","DISPOSITION") S AMERRUN=15
I AMERDISP'=$$OPT^AMER0($P($G(^AMER(3,AMERDISP,0)),U),"DISPOSITION") K ^TMP("AMER",$J,2,15)
S Y=AMERDISP
Q
;
QD15 ; OTHER FACILITIES
;W "If location lookup fails, try entering 'OTHER'" - IHS/OIT/SCR 10/09/08 commented out
S DIR("A")="Where is patient being transferred" K DIR("B")
I $D(^TMP("AMER",$J,2,15)) S %=+^(15),DIR("B")=$P(^AMER(2.1,%,0),U)
;S DIR(0)="P^9009082.1:EMZ" D ^DIR K DIR
S DIR(0)="PO^9009082.1:OEMZ" D ^DIR K DIR ;SCR/CNI/OIT - MAKE RESPONSE OPTIONAL
D OUT^AMER
Q
;
QD16 ; DISCHARGE INSTRUCTIONS
NEW FIIEN,CNT,FI,DIR,%,INS
;
;Get the default entry
I $G(^TMP("AMER",$J,2,16))]"" S %=+^(16) S:%]"" DIR("B")=$$GET1^DIQ(9009083,%_",",.01,"I")
;
S CNT=0
S DIR(0)="SO^"
S FIIEN=$O(^AMER(2,"B","FOLLOW UP INSTRUCTIONS",""))
S FI="" F S FI=$O(^AMER(3,"AC",FIIEN,FI)) Q:FI="" D
. NEW INSNM
. S CNT=CNT+1
. S INSNM=$$GET1^DIQ(9009083,FI_",",".01","I") Q:INSNM=""
. S INS(CNT)=INSNM_U_FI
. S DIR(0)=DIR(0)_$S(CNT>1:";",1:"")_CNT_":"_INSNM
. I INSNM="RTC PRN, INSTRUCTIONS GIVEN",'$D(DIR("B")) S DIR("B")=INSNM
;
S DIR("A")="Follow up instructions"
D ^DIR
;
;Process invalid entries
I +Y<1,X'="@" S X="^",Y="^" D OUT^AMER Q
;
;Handle proper selection
I +Y>0 S Y=$P(INS(+Y),U,2)
;
I X="@" S X="",Y=""
D OUT^AMER
Q
;
QD17 ; DISCHARGE PHYSICIAN
S DIC("A")="*(PRIMARY)Provider who signed PCC form: " K DIC("B")
I '$D(^TMP("AMER",$J,2,17)) S %=$G(^TMP("AMER",$J,2,21)) I %]"" S ^TMP("AMER",$J,2,17)=%
I $D(^TMP("AMER",$J,2,17)) S %=+^(17),DIC("B")=$P(^VA(200,%,0),U)
S DIC="^VA(200,",DIC(0)="AEMQ"
; Screening so that only valid PCC providers identified
S DIC("?")="Only active providers can be selected"
S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
D ^DIC K DIC
D OUT^AMER
Q
;
QD18 ; DISCHARGE NURSE
S DIC("A")="*Discharge nurse: " K DIC("B")
I $D(^TMP("AMER",$J,2,18)) S %=+^(18),DIC("B")=$P(^VA(200,%,0),U)
S DIC="^VA(200,",DIC(0)="AEQM"
; Screening so that only valid PCC providers identified
S DIC("?")="Only active providers can be selected"
S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
D ^DIC K DIC
D OUT^AMER
I $D(AMERDOA) D
.S %=$$OPT^AMER0("NONE","ER PROCEDURES"),^TMP("AMER",$J,2,10,%)=%_U_"NONE"
.S ^TMP("AMER",$J,1,6)=^TMP("AMER",$J,2,17)
.S ^TMP("AMER",$J,1,7)=Y
.S ^TMP("AMER",$J,2,12)=$G(^TMP("AMER",$J,1,9))
.S %=$$OPT^AMER0("DEATH","DISPOSITION"),^TMP("AMER",$J,2,14)=%_"^DEATH"
.Q
Q
;
QD19 ; TIME OF DEPARTURE
I $D(^TMP("AMER",$J,2,19)) S Y=^(19) X ^DD("DD") S DIR("B")=Y
I '$T S DIR("B")="NOW"
;IHS/OIT/SCR 10/10/08 - Mark question mandatory
;S DIR(0)="DO^::ER",DIR("A")="What time did the patient depart from the ER",DIR("?")="Enter an exact date and time in Fileman format (e.g. 1/3/90@1PM)" D ^DIR K DIR
S DIR(0)="DO^::ER",DIR("A")="*What time did the patient depart from the ER"
S DIR("?")="Enter an exact date and time in Fileman format (e.g. 1/3/90@1PM)" D ^DIR K DIR
I Y,$$TCK^AMER2A($G(^TMP("AMER",$J,1,2)),Y,1,"admission") K Y G QD19
I Y,$$TCK^AMER2A($G(^TMP("AMER",$J,2,24)),Y,1,"triage") K Y G QD19
I Y,$$TCK^AMER2A($G(^TMP("AMER",$J,2,25)),Y,1,"the provider visit") K Y G QD19
I Y,$$TVAL^AMER2A($G(^TMP("AMER",$J,1,2)),Y,6) K Y G QD19
I Y="" S Y=-1
D OUT^AMER
S AMERRUN=99
Q
;
SCHEDULE ; APPOINTMENT STUB
Q
AMER3 ; IHS/ANMC/GIS - MORE DISCHARGE QUESTIONS ;
+1 ;;3.0;ER VISIT SYSTEM;**6**;MAR 03, 2009;Build 30
+2 ;
QD10 ; ER PROCEDURES
+1 NEW AMERNONE
SET AMERNONE=$$OPT^AMER0("NONE","ER PROCEDURES")
+2 ; W "Type '??' to see choices"
+3 SET AMEROPT=""
+4 IF $DATA(^TMP("AMER",$JOB,2,10,AMERNONE))!('$DATA(^TMP("AMER",$JOB,2,10)))
SET DIC("B")="NONE"
GOTO DIC
+5 DO PREV(10)
DIC SET DIC("A")="Enter "_$SELECT($ORDER(^TMP("AMER",$JOB,2,10,0)):"another ",1:"")_"procedure: "
+1 SET DIC="^AMER(3,"
SET DIC(0)="AEQ"
SET DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("ER PROCEDURES")
+2 DO ^DIC
KILL DIC
+3 IF $PIECE(Y,U,2)="NONE"
KILL ^TMP("AMER",$JOB,2,10)
SET ^TMP("AMER",$JOB,2,10,AMERNONE)=Y
QUIT
+4 IF X?2."^"
SET DIROUT=""
+5 DO OUT^AMER
IF $DATA(AMERQUIT)
QUIT
+6 IF "^"[$EXTRACT(X)
SET Y=""
QUIT
+7 IF $DATA(^TMP("AMER",$JOB,2,10,+Y))
DO REM(10,Y)
IF $DATA(AMERQUIT)
QUIT
GOTO DIC
+8 SET ^TMP("AMER",$JOB,2,10,+Y)=Y
IF +Y'=AMERNONE
KILL ^(AMERNONE)
+9 GOTO DIC
+10 ;
REM(X,Y) WRITE !,*7,$PIECE(Y,U,2)," has already been selected. Want to cancel it"
+1 SET %=2
DO YN^DICN
IF %Y?2."^"
SET DIROUT=""
DO OUT^AMER
IF $DATA(AMERQUIT)
QUIT
+2 IF "Nn"[$EXTRACT(%Y)
QUIT
+3 KILL ^TMP("AMER",$JOB,2,X,+Y)
WRITE !,$PIECE(Y,U,2)," cancelled...",!!
+4 QUIT
+5 ;
PREV(X) ; ENTRY POINT FROM AMER31
+1 WRITE !,"You have already selected =>",!
+2 FOR %=0:0
SET %=$ORDER(^TMP("AMER",$JOB,2,X,%))
IF '%
QUIT
WRITE ?3,$PIECE(^(%),U,2),!
+3 WRITE !
+4 QUIT
+5 ;
QD11 ; FINAL DIAGNOSES
+1 DO QD11^AMER31
+2 QUIT
+3 ;
QD12 ; FINAL TRIAGE CATEGORY
+1 SET DIR("B")=$GET(^TMP("AMER",$JOB,2,12))
+2 SET DIR("?")="Enter a number from 1 to 5"
+3 SET DIR("?",1)="This is a site-specified value that indicates severity of visit"
+4 SET DIR(0)="N^1:5:0"
SET DIR("A")="*Enter final acuity assessment from provider"
KILL DA
DO ^DIR
KILL DIR
+5 DO OUT^AMER
+6 QUIT
+7 ;
QD14 ; DISPOSITION AND SCHEDULING
+1 ;IHS/OIT/SCR 10/10/08
NEW AMERDISP
+2 SET DIC("A")="*Disposition: "
KILL DIC("B")
+3 IF $GET(^TMP("AMER",$JOB,2,14))>0
SET %=+^(14)
SET DIC("B")=$PIECE(^AMER(3,%,0),U)
+4 ;I $D(^TMP("AMER",$J,2,14)) S %=+^(14),DIC("B")=$P(^AMER(3,%,0),U) ;IHS/OIT/SCR 10/10/08
+5 IF $DATA(AMERDOA)
SET DIC("B")="DEATH"
+6 IF $DATA(AMERDNA)
Begin DoDot:1
+7 ;IHS/OIT/SCR 01/20/09 - OPTION MAY BE 'LEFT WITHOUT BEING SEEN' OR 'LEFT WITHOUT BEING DISCHARGED'
+8 SET DIC="^AMER(3,"
SET DIC(0)=""
SET X="LEFT WITHOUT"
+9 DO ^DIC
+10 IF Y>0
SET DIC("B")=$PIECE(Y,"^",2)
+11 IF '$TEST
SET DIC("B")=""
+12 QUIT
End DoDot:1
+13 SET DIC="^AMER(3,"
SET DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("DISPOSITION")
SET DIC(0)="AEQ"
+14 DO ^DIC
KILL DIC
DO OUT^AMER
IF $DATA(AMERQUIT)
QUIT
+15 IF Y=-1
QUIT
+16 SET AMERDISP=+Y
+17 IF AMERDISP=$$OPT^AMER0("REGISTERED IN ERROR","DISPOSITION")
Begin DoDot:1
+18 DO EN^DDIOL("Using this DISPOSITION will cause the entire VISIT to be deleted!!","","!")
+19 DO EN^DDIOL("This DISPOSITION can not be changed!!","","!")
+20 SET DIR(0)="Y"
SET DIR("A")="Do you still wish use this DISPOSITION"
+21 SET DIR("B")="YES"
+22 DO ^DIR
+23 IF Y=0
Begin DoDot:2
+24 SET AMERRUN=13
+25 SET ^TMP("AMER",$JOB,2,14)=""
+26 QUIT
End DoDot:2
+27 IF Y=1
SET AMERRUN=95
+28 QUIT
End DoDot:1
QUIT
+29 IF AMERRUN=95
QUIT
+30 ;I +Y=$$OPT^AMER0("HOME","DISPOSITION") S AMERRUN=15 D SCHEDULE Q
+31 IF AMERDISP'=$$OPT^AMER0("TRANSFER TO ANOTHER FACILITY","DISPOSITION")
SET AMERRUN=15
+32 IF AMERDISP'=$$OPT^AMER0($PIECE($GET(^AMER(3,AMERDISP,0)),U),"DISPOSITION")
KILL ^TMP("AMER",$JOB,2,15)
+33 SET Y=AMERDISP
+34 QUIT
+35 ;
QD15 ; OTHER FACILITIES
+1 ;W "If location lookup fails, try entering 'OTHER'" - IHS/OIT/SCR 10/09/08 commented out
+2 SET DIR("A")="Where is patient being transferred"
KILL DIR("B")
+3 IF $DATA(^TMP("AMER",$JOB,2,15))
SET %=+^(15)
SET DIR("B")=$PIECE(^AMER(2.1,%,0),U)
+4 ;S DIR(0)="P^9009082.1:EMZ" D ^DIR K DIR
+5 ;SCR/CNI/OIT - MAKE RESPONSE OPTIONAL
SET DIR(0)="PO^9009082.1:OEMZ"
DO ^DIR
KILL DIR
+6 DO OUT^AMER
+7 QUIT
+8 ;
QD16 ; DISCHARGE INSTRUCTIONS
+1 NEW FIIEN,CNT,FI,DIR,%,INS
+2 ;
+3 ;Get the default entry
+4 IF $GET(^TMP("AMER",$JOB,2,16))]""
SET %=+^(16)
IF %]""
SET DIR("B")=$$GET1^DIQ(9009083,%_",",.01,"I")
+5 ;
+6 SET CNT=0
+7 SET DIR(0)="SO^"
+8 SET FIIEN=$ORDER(^AMER(2,"B","FOLLOW UP INSTRUCTIONS",""))
+9 SET FI=""
FOR
SET FI=$ORDER(^AMER(3,"AC",FIIEN,FI))
IF FI=""
QUIT
Begin DoDot:1
+10 NEW INSNM
+11 SET CNT=CNT+1
+12 SET INSNM=$$GET1^DIQ(9009083,FI_",",".01","I")
IF INSNM=""
QUIT
+13 SET INS(CNT)=INSNM_U_FI
+14 SET DIR(0)=DIR(0)_$SELECT(CNT>1:";",1:"")_CNT_":"_INSNM
+15 IF INSNM="RTC PRN, INSTRUCTIONS GIVEN"
IF '$DATA(DIR("B"))
SET DIR("B")=INSNM
End DoDot:1
+16 ;
+17 SET DIR("A")="Follow up instructions"
+18 DO ^DIR
+19 ;
+20 ;Process invalid entries
+21 IF +Y<1
IF X'="@"
SET X="^"
SET Y="^"
DO OUT^AMER
QUIT
+22 ;
+23 ;Handle proper selection
+24 IF +Y>0
SET Y=$PIECE(INS(+Y),U,2)
+25 ;
+26 IF X="@"
SET X=""
SET Y=""
+27 DO OUT^AMER
+28 QUIT
+29 ;
QD17 ; DISCHARGE PHYSICIAN
+1 SET DIC("A")="*(PRIMARY)Provider who signed PCC form: "
KILL DIC("B")
+2 IF '$DATA(^TMP("AMER",$JOB,2,17))
SET %=$GET(^TMP("AMER",$JOB,2,21))
IF %]""
SET ^TMP("AMER",$JOB,2,17)=%
+3 IF $DATA(^TMP("AMER",$JOB,2,17))
SET %=+^(17)
SET DIC("B")=$PIECE(^VA(200,%,0),U)
+4 SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
+5 ; Screening so that only valid PCC providers identified
+6 SET DIC("?")="Only active providers can be selected"
+7 SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
+8 DO ^DIC
KILL DIC
+9 DO OUT^AMER
+10 QUIT
+11 ;
QD18 ; DISCHARGE NURSE
+1 SET DIC("A")="*Discharge nurse: "
KILL DIC("B")
+2 IF $DATA(^TMP("AMER",$JOB,2,18))
SET %=+^(18)
SET DIC("B")=$PIECE(^VA(200,%,0),U)
+3 SET DIC="^VA(200,"
SET DIC(0)="AEQM"
+4 ; Screening so that only valid PCC providers identified
+5 SET DIC("?")="Only active providers can be selected"
+6 SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P($G(^VA(200,+Y,0)),U),+Y))"
+7 DO ^DIC
KILL DIC
+8 DO OUT^AMER
+9 IF $DATA(AMERDOA)
Begin DoDot:1
+10 SET %=$$OPT^AMER0("NONE","ER PROCEDURES")
SET ^TMP("AMER",$JOB,2,10,%)=%_U_"NONE"
+11 SET ^TMP("AMER",$JOB,1,6)=^TMP("AMER",$JOB,2,17)
+12 SET ^TMP("AMER",$JOB,1,7)=Y
+13 SET ^TMP("AMER",$JOB,2,12)=$GET(^TMP("AMER",$JOB,1,9))
+14 SET %=$$OPT^AMER0("DEATH","DISPOSITION")
SET ^TMP("AMER",$JOB,2,14)=%_"^DEATH"
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
QD19 ; TIME OF DEPARTURE
+1 IF $DATA(^TMP("AMER",$JOB,2,19))
SET Y=^(19)
XECUTE ^DD("DD")
SET DIR("B")=Y
+2 IF '$TEST
SET DIR("B")="NOW"
+3 ;IHS/OIT/SCR 10/10/08 - Mark question mandatory
+4 ;S DIR(0)="DO^::ER",DIR("A")="What time did the patient depart from the ER",DIR("?")="Enter an exact date and time in Fileman format (e.g. 1/3/90@1PM)" D ^DIR K DIR
+5 SET DIR(0)="DO^::ER"
SET DIR("A")="*What time did the patient depart from the ER"
+6 SET DIR("?")="Enter an exact date and time in Fileman format (e.g. 1/3/90@1PM)"
DO ^DIR
KILL DIR
+7 IF Y
IF $$TCK^AMER2A($GET(^TMP("AMER",$JOB,1,2)),Y,1,"admission")
KILL Y
GOTO QD19
+8 IF Y
IF $$TCK^AMER2A($GET(^TMP("AMER",$JOB,2,24)),Y,1,"triage")
KILL Y
GOTO QD19
+9 IF Y
IF $$TCK^AMER2A($GET(^TMP("AMER",$JOB,2,25)),Y,1,"the provider visit")
KILL Y
GOTO QD19
+10 IF Y
IF $$TVAL^AMER2A($GET(^TMP("AMER",$JOB,1,2)),Y,6)
KILL Y
GOTO QD19
+11 IF Y=""
SET Y=-1
+12 DO OUT^AMER
+13 SET AMERRUN=99
+14 QUIT
+15 ;
SCHEDULE ; APPOINTMENT STUB
+1 QUIT
