AMER1.m

AMER1 ; IHS/ANMC/GIS - ER ADMISSION QUESTIONS ;  

 ;;3.0;ER VISIT SYSTEM;**8**;MAR 03, 2009;Build 23

 ;

 Q

QA1 D QA1^AMER1A ; PATIENT NAME

 Q

 ;

QA2 ; DATE AND TIME OF ADMISSION TO ER

 I $D(^TMP("AMER",$J,1,2)) S Y=^(2) X ^DD("DD") S DIR("B")=Y

 E  S DIR("B")=$S($D(AMERBCH):"",1:"NOW")

 S DIR(0)="D^::ER",DIR("A")="*Date and time of admission to ER",DIR("?")="Enter date and time in the usual Fileman format (e.g. 1/1/2000@1PM)" D ^DIR K DIR

 D NOW^%DTC

 I Y>% D EN^DDIOL("FUTURE DATES NOT ALLOWED","","!!") G QA2

 I $D(AMEREFLG),X=U S AMERRUN=999 Q

 D OUT^AMER

 Q:$D(AMERQUIT)

 D APPNTMNT^AMERBSDU(AMERDFN,1,Y)

 ;

 Q

 ;

QA3 ; PRESENTING COMPLAINT

 K DIR("B") I $D(^TMP("AMER",$J,1,3)) S DIR("B")=^(3)

 I $D(AMERDOA) S DIR("B")="DOA"

 ;AMER*3.0*8;Raised maximum field length

 ;S DIR(0)="F^1:80",DIR("A")="*Presenting complaint",DIR("?")="Enter free text chief complaint (80 characters max.)" D ^DIR K DIR

 S DIR(0)="F^2:240",DIR("A")="*Presenting complaint",DIR("?")="Enter free text chief complaint (240 characters max.)" D ^DIR K DIR

 D CKSC I $D(AMERCKSC)!($TR(Y," ")="") K AMERCKSC G QA3

 D OUT^AMER

 Q

 ;

QA4 ; FULL REG EDIT

 N SDSEX

 S SDFN=AMERDFN,SDAMTYP="P"

 D ^BSDREG

 K SDFN,SDAMTYP

 S (X,Y)=""

 I $D(DUOUT) S X="^"

 I $D(DIROUT) S X="^^"

 K AMER1,AMER2

 I $D(AMERDOA) D

 . S AMERRUN=9,AMEROPT=""

 . S ^TMP("AMER",$J,1,4)=$$OPT^AMER0("EMERG","CLINIC TYPE")_U_"EMERG"

 . S ^TMP("AMER",$J,1,5)=$$OPT^AMER0("UNSCHEDULED REVISIT","VISIT TYPE")_U_"UNSCHEDULED REVISIT"

 . S ^TMP("AMER",$J,1,9)=$$OPT^AMER0("EMERGENT","TRIAGE CAT")_U_"EMERGENT"

 . Q

 Q

 ;

QA5 ; VISIT TYPE

 N AMERVTYP

 S DIC("B")=""

 S DIC("A")="*Visit type: "

 S AMERVTYP=$O(^AMER(3,"B","UNSCHEDULED VISIT",0))

 S:AMERVTYP="" AMERVTYP=$O(^AMER(3,"B","UNSCHEDULED",0))  ;IHS/OIT/SCR 10/10/08 - CHANGED TO MATCH NEW OPTION 

 ;S:AMERVTYP="" AMERVTYP=$O(^AMER(3,"B","FIRST VISIT",0))

 I $D(^TMP("AMER",$J,1,5)) S %=+^(5),DIC("B")=$P(^AMER(3,%,0),U)

 I DIC("B")=""&(AMERVTYP'="") S DIC("B")=$P($G(^AMER(3,AMERVTYP,0)),U,1) ;IF 'FIRST VISIT' exists, set it to default if original entry doesn't exist

 S DIC="^AMER(3,",DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("VISIT TYPE"),DIC(0)="AEQ"

 D ^DIC K DIC

 D OUT^AMER

 Q

 ;

QA10 ; MODE OF TRANSPORT TO HOSPITAL

 S DIC("A")="*Mode of transport to the ER: " K DIC("B")

 I $D(^TMP("AMER",$J,1,10)) S %=+^(10),DIC("B")=$P(^AMER(3,%,0),U)

 E  S DIC("B")="PRIVATE VEHICLE/WALK IN"

 S DIC="^AMER(3,",DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("MODE OF TRANSPORT"),DIC(0)="AEQ"

 D ^DIC K DIC

 D OUT^AMER I $D(AMERQUIT) Q

 I Y'["AMBULANCE",X'?1."^" S AMERRUN=99 K ^TMP("AMER",$J,1,11),^(12),^(13),^(14)

 Q

 ; 

QA11 ; AMBULANCE NUMBER

 S DIR("A")="Ambulance number" D QAXX

 Q

 ;

QA12 ; AMBULANCE HRCN/BILLING NUMBER

 S DIR("A")="Ambulance HRCN/billing number" D QAXX

 I $D(AMERDOA) S AMERRUN=13 Q

 Q

 ;

QA14 ; AMBULANCE COMPANY

 S DIC("A")="Ambulance company: " K DIC("B")

 I $D(^TMP("AMER",$J,1,14)) S %=+^(14),DIC("B")=$P(^AMER(3,%,0),U)

 S DIC="^AMER(3,",DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("AMBULANCE COMPANY"),DIC(0)="AEQ"

 D ^DIC K DIC

 D OUT^AMER I $D(AMERQUIT) Q

 I '$D(AMERDOA) S AMERRUN=20 Q

 S AMERRUN=99

 Q

 ;

QAXX ; TEXT CAPTURE

 K DIR("B") I $D(^TMP("AMER",$J,1,AMERRUN)) S DIR("B")=^(AMERRUN)

 S DIR(0)="FO^1:20",DIR("?")="Enter free text (30 characters max.)" D ^DIR K DIR

 D CKSC I $D(AMERCKSC) K AMERCKSC G QAXX

 D OUT^AMER

 Q

 ;

CKSC ; ENTRY POINT FROM SEVERAL ROUTINES

 N X

 S X=$S(Y[";":"semi-colon",Y[":":"colon",1:"") K AMERCKSC

 I X'="" S AMERCKSC="" W !!,*7,"Sorry, you can't use a ",X," in your answer...Try again",!!

 Q

 ;

CHKINGO(CLINIC) ; return 1 if okay to proceed with checkin

 NEW GO,DATE,END

 S DATE=DT,END=DT+.24,GO=1

 F  S DATE=$O(^DPT(DFN,"S",DATE)) Q:DATE=""  Q:DATE>END  D

 . I +$G(^DPT(DFN,"S",DATE,0))=CLINIC D  S GO=0

 .. W !!,"*** Patient already checked in at "_$$FMTE^XLFDT(DATE)_" ***"

 I GO Q 1

 Q +$$READ("Y","Want to Check Patient In Again")

 ;

READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN,DIRA) ; EP; calls reader, returns response

 NEW DIR,Y,DIRUT

 S DIR(0)=TYPE

 I $E(TYPE,1)="P",$P(TYPE,":",2)["L" S DLAYGO=+$P(TYPE,U,2)

 I $D(SCREEN) S DIR("S")=SCREEN

 I $G(PROMPT)]"" S DIR("A")=PROMPT

 I $G(DEFAULT)]"" S DIR("B")=DEFAULT

 I $D(HELP) S DIR("?")=HELP

 I $D(DIRA(1)) S Y=0 F  S Y=$O(DIRA(Y)) Q:Y=""  S DIR("A",Y)=DIRA(Y)

 D ^DIR

 Q Y

AMER1     ; IHS/ANMC/GIS - ER ADMISSION QUESTIONS ;  

 +1       ;;3.0;ER VISIT SYSTEM;**8**;MAR 03, 2009;Build 23

 +2       ;

 +3        QUIT 

QA1       ; PATIENT NAME

           DO QA1^AMER1A

 +1        QUIT 

 +2       ;

QA2       ; DATE AND TIME OF ADMISSION TO ER

 +1        IF $DATA(^TMP("AMER",$JOB,1,2))

               SET Y=^(2)

               XECUTE ^DD("DD")

               SET DIR("B")=Y

 +2       IF '$TEST

               SET DIR("B")=$SELECT($DATA(AMERBCH):"",1:"NOW")

 +3        SET DIR(0)="D^::ER"

           SET DIR("A")="*Date and time of admission to ER"

           SET DIR("?")="Enter date and time in the usual Fileman format (e.g. 1/1/2000@1PM)"

           DO ^DIR

           KILL DIR

 +4        DO NOW^%DTC

 +5        IF Y>%

               DO EN^DDIOL("FUTURE DATES NOT ALLOWED","","!!")

               GOTO QA2

 +6        IF $DATA(AMEREFLG)

               IF X=U

                   SET AMERRUN=999

                   QUIT 

 +7        DO OUT^AMER

 +8        IF $DATA(AMERQUIT)

               QUIT 

 +9        DO APPNTMNT^AMERBSDU(AMERDFN,1,Y)

 +10      ;

 +11       QUIT 

 +12      ;

QA3       ; PRESENTING COMPLAINT

 +1        KILL DIR("B")

           IF $DATA(^TMP("AMER",$JOB,1,3))

               SET DIR("B")=^(3)

 +2        IF $DATA(AMERDOA)

               SET DIR("B")="DOA"

 +3       ;AMER*3.0*8;Raised maximum field length

 +4       ;S DIR(0)="F^1:80",DIR("A")="*Presenting complaint",DIR("?")="Enter free text chief complaint (80 characters max.)" D ^DIR K DIR

 +5        SET DIR(0)="F^2:240"

           SET DIR("A")="*Presenting complaint"

           SET DIR("?")="Enter free text chief complaint (240 characters max.)"

           DO ^DIR

           KILL DIR

 +6        DO CKSC

           IF $DATA(AMERCKSC)!($TRANSLATE(Y," ")="")

               KILL AMERCKSC

               GOTO QA3

 +7        DO OUT^AMER

 +8        QUIT 

 +9       ;

QA4       ; FULL REG EDIT

 +1        NEW SDSEX

 +2        SET SDFN=AMERDFN

           SET SDAMTYP="P"

 +3        DO ^BSDREG

 +4        KILL SDFN,SDAMTYP

 +5        SET (X,Y)=""

 +6        IF $DATA(DUOUT)

               SET X="^"

 +7        IF $DATA(DIROUT)

               SET X="^^"

 +8        KILL AMER1,AMER2

 +9        IF $DATA(AMERDOA)

               Begin DoDot:1

 +10               SET AMERRUN=9

                   SET AMEROPT=""

 +11               SET ^TMP("AMER",$JOB,1,4)=$$OPT^AMER0("EMERG","CLINIC TYPE")_U_"EMERG"

 +12               SET ^TMP("AMER",$JOB,1,5)=$$OPT^AMER0("UNSCHEDULED REVISIT","VISIT TYPE")_U_"UNSCHEDULED REVISIT"

 +13               SET ^TMP("AMER",$JOB,1,9)=$$OPT^AMER0("EMERGENT","TRIAGE CAT")_U_"EMERGENT"

 +14               QUIT 

               End DoDot:1

 +15       QUIT 

 +16      ;

QA5       ; VISIT TYPE

 +1        NEW AMERVTYP

 +2        SET DIC("B")=""

 +3        SET DIC("A")="*Visit type: "

 +4        SET AMERVTYP=$ORDER(^AMER(3,"B","UNSCHEDULED VISIT",0))

 +5       ;IHS/OIT/SCR 10/10/08 - CHANGED TO MATCH NEW OPTION 

           IF AMERVTYP=""

               SET AMERVTYP=$ORDER(^AMER(3,"B","UNSCHEDULED",0))

 +6       ;S:AMERVTYP="" AMERVTYP=$O(^AMER(3,"B","FIRST VISIT",0))

 +7        IF $DATA(^TMP("AMER",$JOB,1,5))

               SET %=+^(5)

               SET DIC("B")=$PIECE(^AMER(3,%,0),U)

 +8       ;IF 'FIRST VISIT' exists, set it to default if original entry doesn't exist

           IF DIC("B")=""&(AMERVTYP'="")

               SET DIC("B")=$PIECE($GET(^AMER(3,AMERVTYP,0)),U,1)

 +9        SET DIC="^AMER(3,"

           SET DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("VISIT TYPE")

           SET DIC(0)="AEQ"

 +10       DO ^DIC

           KILL DIC

 +11       DO OUT^AMER

 +12       QUIT 

 +13      ;

QA10      ; MODE OF TRANSPORT TO HOSPITAL

 +1        SET DIC("A")="*Mode of transport to the ER: "

           KILL DIC("B")

 +2        IF $DATA(^TMP("AMER",$JOB,1,10))

               SET %=+^(10)

               SET DIC("B")=$PIECE(^AMER(3,%,0),U)

 +3       IF '$TEST

               SET DIC("B")="PRIVATE VEHICLE/WALK IN"

 +4        SET DIC="^AMER(3,"

           SET DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("MODE OF TRANSPORT")

           SET DIC(0)="AEQ"

 +5        DO ^DIC

           KILL DIC

 +6        DO OUT^AMER

           IF $DATA(AMERQUIT)

               QUIT 

 +7        IF Y'["AMBULANCE"

               IF X'?1."^"

                   SET AMERRUN=99

                   KILL ^TMP("AMER",$JOB,1,11),^(12),^(13),^(14)

 +8        QUIT 

 +9       ; 

QA11      ; AMBULANCE NUMBER

 +1        SET DIR("A")="Ambulance number"

           DO QAXX

 +2        QUIT 

 +3       ;

QA12      ; AMBULANCE HRCN/BILLING NUMBER

 +1        SET DIR("A")="Ambulance HRCN/billing number"

           DO QAXX

 +2        IF $DATA(AMERDOA)

               SET AMERRUN=13

               QUIT 

 +3        QUIT 

 +4       ;

QA14      ; AMBULANCE COMPANY

 +1        SET DIC("A")="Ambulance company: "

           KILL DIC("B")

 +2        IF $DATA(^TMP("AMER",$JOB,1,14))

               SET %=+^(14)

               SET DIC("B")=$PIECE(^AMER(3,%,0),U)

 +3        SET DIC="^AMER(3,"

           SET DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("AMBULANCE COMPANY")

           SET DIC(0)="AEQ"

 +4        DO ^DIC

           KILL DIC

 +5        DO OUT^AMER

           IF $DATA(AMERQUIT)

               QUIT 

 +6        IF '$DATA(AMERDOA)

               SET AMERRUN=20

               QUIT 

 +7        SET AMERRUN=99

 +8        QUIT 

 +9       ;

QAXX      ; TEXT CAPTURE

 +1        KILL DIR("B")

           IF $DATA(^TMP("AMER",$JOB,1,AMERRUN))

               SET DIR("B")=^(AMERRUN)

 +2        SET DIR(0)="FO^1:20"

           SET DIR("?")="Enter free text (30 characters max.)"

           DO ^DIR

           KILL DIR

 +3        DO CKSC

           IF $DATA(AMERCKSC)

               KILL AMERCKSC

               GOTO QAXX

 +4        DO OUT^AMER

 +5        QUIT 

 +6       ;

CKSC      ; ENTRY POINT FROM SEVERAL ROUTINES

 +1        NEW X

 +2        SET X=$SELECT(Y[";":"semi-colon",Y[":":"colon",1:"")

           KILL AMERCKSC

 +3        IF X'=""

               SET AMERCKSC=""

               WRITE !!,*7,"Sorry, you can't use a ",X," in your answer...Try again",!!

 +4        QUIT 

 +5       ;

CHKINGO(CLINIC) ; return 1 if okay to proceed with checkin

 +1        NEW GO,DATE,END

 +2        SET DATE=DT

           SET END=DT+.24

           SET GO=1

 +3        FOR 

               SET DATE=$ORDER(^DPT(DFN,"S",DATE))

               IF DATE=""

                   QUIT 

               IF DATE>END

                   QUIT 

               Begin DoDot:1

 +4                IF +$GET(^DPT(DFN,"S",DATE,0))=CLINIC

                       Begin DoDot:2

 +5                        WRITE !!,"*** Patient already checked in at "_$$FMTE^XLFDT(DATE)_" ***"

                       End DoDot:2

                       SET GO=0

               End DoDot:1

 +6        IF GO

               QUIT 1

 +7        QUIT +$$READ("Y","Want to Check Patient In Again")

 +8       ;

READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN,DIRA) ; EP; calls reader, returns response

 +1        NEW DIR,Y,DIRUT

 +2        SET DIR(0)=TYPE

 +3        IF $EXTRACT(TYPE,1)="P"

               IF $PIECE(TYPE,":",2)["L"

                   SET DLAYGO=+$PIECE(TYPE,U,2)

 +4        IF $DATA(SCREEN)

               SET DIR("S")=SCREEN

 +5        IF $GET(PROMPT)]""

               SET DIR("A")=PROMPT

 +6        IF $GET(DEFAULT)]""

               SET DIR("B")=DEFAULT

 +7        IF $DATA(HELP)

               SET DIR("?")=HELP

 +8        IF $DATA(DIRA(1))

               SET Y=0

               FOR 

                   SET Y=$ORDER(DIRA(Y))

                   IF Y=""

                       QUIT 

                   SET DIR("A",Y)=DIRA(Y)

 +9        DO ^DIR

 +10       QUIT Y