Routine: AMEROUT1

AMEROUT1 ; IHS/ANMC/GIS - SORT CONTROL FOR OUTPUT ;

 ;;3.0;ER VISIT SYSTEM;**5**;MAR 03, 2009;Build 14

RUN D SEL I $D(AMERQUIT) Q

 D FSET,PRINT

EXIT K ZTSAVE,ZTSK,ZTIO,ZTDESC,ZTRTN

SEL ; SELECT SORT

 W !!

 S DIR("A")="Sort by"

S1 ; SORT BY LOOP REENTRY POINT

 S DIR(0)="N"_$S(AMERRTYP'="A":"O",1:"")_"^1:"_(AMERPTOT+AMERVTOT)_":0"

 S DIR("??")="^D SORT^AMEROUT",DIR("?")="Select an attribute of the patient or the visit.  Enter a number..."

 I $D(AMERNXT) S DIR("A")=AMERNXT K AMERNXT

 D ^DIR K DIR

 I $E(X)=U,X'="" S AMERQUIT="" Q

 D OUT^AMEROUT I $D(AMERQUIT) Q

 I X="",$D(AMERSTAT) Q

 I X="" Q

 I Y?1.2N,$D(^TMP("AMER",$J,7,Y)) S Y=^(Y),AMERATNM=$P(^AMER(2.2,+Y,0),U) W "  (",AMERATNM,")" D MET G LOOP

 S X=Y,DIC="^AMER(2.2,",DIC(0)="EQ",DIC("S")="I $P(^(0),U,2)=AMERRTYP"

 D ^DIC K DIC

 D OUT^AMEROUT I $D(AMERQUIT) Q

 S Y=+Y,AMERATNM=$P(^AMER(2.2,+Y,0),U) D MET

LOOP I $D(AMERQUIT) Q

 I $G(AMERRTYP)="A" Q

 D ADD

 I $G(AMERSTAT) Q

 I AMERRTYP="V"!(AMERRTYP="S") W !! D S1^AMEROUT S DIR("A")="Then sort by" G S1

ADD I $D(AMERBY),$D(AMERFR),$D(AMERTO),$D(BY),$D(FR),$D(TO)

 E  S AMERQUIT="" Q

A1 S:BY="'" BY="" S:BY]"" BY=BY_",",FR=FR_",",TO=TO_","

 S BY=BY_AMERBY,FR=FR_AMERFR,TO=TO_AMERTO

MET ; METADICTIONARY LOOKUP

 K AMERSCR,AMERBY

 I 'Y S AMERQUIT="" W "  ??",*7 Q

 I '$D(^AMER(2.2,+Y,0)) S AMERQUIT="" W " ??",*7 Q

 S %=^AMER(2.2,+Y,0),AMERCAT=$P(%,U,3),AMERGBL=$P(%,U,4) S:$D(^(2)) AMERSCR=^(2) I $D(^(1)) S AMERBY=^(1)

 I AMERRTYP="V" D @("M"_AMERCAT_"^AMEROUT2") Q

 I AMERRTYP="A" D AGE Q

FSET ; FINAL ADJUSTMENTS OF BY,FR,TO

 I AMERRTYP="A" Q

 I $D(AMERSTAT),$G(FLDS)="" S FLDS="!.01"

 I AMERDISP=2,BY="" S BY="'@.01,@.02",FR=AMERD1_",",TO=AMERD2_"," Q

 I AMERDISP=2 D  Q

 .I BY="5,.01" S BY=BY_",5,.01:DIAGNOSIS;N;""DX DESCRIPTION: """

 .S BY=BY_",",FR=FR_",",TO=TO_"," ; FINAL SET OF BY,FR,TO

 .S BY="'@.01,"_BY,FR=AMERD1_","_FR_",",TO=AMERD2_","_TO_","

 .I '$D(AMERSTAT) S BY=BY_",.02"

.Q

 I AMERDISP=3,BY="" S BY="@.01",FR=AMERD1,TO=AMERD2 Q

 I BY="5,.01" S BY=BY_",5,.01:DIAGNOSIS;N;""DX DESCRIPTION: """

 I AMERDISP=3 S BY="'@.01,"_BY S:'$D(AMERSTAT) BY=BY_",@.01" S FR=AMERD1_","_FR_",",TO=AMERD2_","_TO_"," Q

 I BY="" S BY="@.16",FR=(9999999-AMERD2),TO=(9999999-AMERD1) Q

 S BY="'@.01,"_BY S:'$D(AMERSTAT) BY=BY_",@.16" S FR=AMERD1_","_FR_",",TO=AMERD2_","_TO_","

PRINT ; GENERATE OUTPUT - ENTRY POINT FROM AMEROUT

 I AMERRTYP'="A" S DIC="^AMERVSIT(",DIOBEG="S AMERNOTE="""",^UTILITY($J,2)=""D:$D(AMERNOTE) NOTE^AMEROUT1 ""_^UTILITY($J,2)"

 S Y=AMERD1 D DD^%DT S AMERD1=Y

 S Y=AMERD2 D DD^%DT S AMERD2=Y

 I $G(AMERHDR)'="" S DHD=$$AMERDHD^AMERREPT(AMERHDR,AMERD1,AMERD2)

 E  S DHD="ER REPORT"

ENDIP D EN1^DIP

 ;AMER*3.0*5

 D LOG^AMERBUSA("P","Q","AMEROUT1","AMER: Printed "_AMERHDR_" for "_AMERD1_" to "_$P(AMERD2,"@"),"")

 I $D(IOST),IOST["C-",'$D(DIRUT),'$D(DTOUT) W ! S DIR(0)="E",DIR("A")="Press 'Return to continue" D ^DIR

TASK ; BACKGROUND JOB ENTRY POINT

NOTE ;

 K AMERNOTE N I,X

 I '$D(^TMP("AMER",$J,8)) Q

 W "Please note: the following criteria were used to screen entries:",!

 S X="" F I=1:1 S X=$O(^TMP("AMER",$J,8,X)) Q:X=""  W !,?3,I,") ",X," = """,^(X),""""

 W !!!

AGE ; ENTRY POINT

 S DIC="^AMERVSIT(",FR=AMERD1,TO=AMERD2

 S FLDS="!.02:NUMBER,"_AMERBY_",!D ^AMERBIN"

 S BY="'@.01,.02:NUMBER"

 S DHD="@"

EN1 ; ENTRY POINT FORM OPTION AMER LOG

 ; PRINT RECENT VISITS

 N BY,FR,TO,FLDS,DIC,%,AMERRTYP,AMERHDR,AMERD1,AMERD2,AMERDATE

 S AMERRTYP="V"

 D NOW^%DTC

 S X1=X   ;THE DATE THAT X2 WILL BE SUBTRACTED FROM IN FILEMAN FORMAT

 S X2=-1  ;TO GET THE DAY BEFORE...

 D C^%DTC

 S AMERDATE=X

 S FR=$P(X,".",1)

 S TO=FR

 S FLDS="[AMER BRIEF",BY="@.01"

 S DIC="^AMERVSIT("

 S Y=FR D DD^%DT S AMERD1=Y

 S Y=TO D DD^%DT S AMERD2=Y

 D SYNCHERS^AMERERS(AMERD1,AMERD2)

 S AMERHDR="ER DAILY LOG REPORT"

 S DHD=$$AMERDHD^AMERREPT(AMERHDR,AMERD1,AMERD2)

 D EN1^DIP

 ;AMER*3.0*5

 D LOG^AMERBUSA("P","Q","AMEROUT1","AMER: Printed ER Daily Log Report","")

 I $D(IOST),IOST["C-",'$D(DIRUT),'$D(DTOUT) W ! S DIR(0)="E",DIR("A")="Press 'Return to continue" D ^DIR

AMEROUT1  ; IHS/ANMC/GIS - SORT CONTROL FOR OUTPUT ;

 +1       ;;3.0;ER VISIT SYSTEM;**5**;MAR 03, 2009;Build 14

 +2       ;

RUN        DO SEL

           IF $DATA(AMERQUIT)

               QUIT

 +1        DO FSET

           DO PRINT

EXIT       KILL ZTSAVE,ZTSK,ZTIO,ZTDESC,ZTRTN

 +1        QUIT

 +2       ;

SEL       ; SELECT SORT

 +1        WRITE !!

 +2        SET DIR("A")="Sort by"

S1        ; SORT BY LOOP REENTRY POINT

 +1        SET DIR(0)="N"_$SELECT(AMERRTYP'="A":"O",1:"")_"^1:"_(AMERPTOT+AMERVTOT)_":0"

 +2        SET DIR("??")="^D SORT^AMEROUT"

           SET DIR("?")="Select an attribute of the patient or the visit.  Enter a number..."

 +3        IF $DATA(AMERNXT)

               SET DIR("A")=AMERNXT

               KILL AMERNXT

 +4        DO ^DIR

           KILL DIR

 +5        IF $EXTRACT(X)=U

               IF X'=""

                   SET AMERQUIT=""

                   QUIT

 +6        DO OUT^AMEROUT

           IF $DATA(AMERQUIT)

               QUIT

 +7        IF X=""

               IF $DATA(AMERSTAT)

                   QUIT

 +8        IF X=""

               QUIT

 +9        IF Y?1.2N

               IF $DATA(^TMP("AMER",$JOB,7,Y))

                   SET Y=^(Y)

                   SET AMERATNM=$PIECE(^AMER(2.2,+Y,0),U)

                   WRITE "  (",AMERATNM,")"

                   DO MET

                   GOTO LOOP

 +10       SET X=Y

           SET DIC="^AMER(2.2,"

           SET DIC(0)="EQ"

           SET DIC("S")="I $P(^(0),U,2)=AMERRTYP"

 +11       DO ^DIC

           KILL DIC

 +12       DO OUT^AMEROUT

           IF $DATA(AMERQUIT)

               QUIT

 +13       SET Y=+Y

           SET AMERATNM=$PIECE(^AMER(2.2,+Y,0),U)

           DO MET

LOOP       IF $DATA(AMERQUIT)

               QUIT

 +1        IF $GET(AMERRTYP)="A"

               QUIT

 +2        DO ADD

 +3        IF $GET(AMERSTAT)

               QUIT

 +4        IF AMERRTYP="V"!(AMERRTYP="S")

               WRITE !!

               DO S1^AMEROUT

               SET DIR("A")="Then sort by"

               GOTO S1

 +5        QUIT

 +6       ;

ADD        IF $DATA(AMERBY)

               IF $DATA(AMERFR)

                   IF $DATA(AMERTO)

                       IF $DATA(BY)

                           IF $DATA(FR)

                               IF $DATA(TO)

 +1       IF '$TEST

               SET AMERQUIT=""

               QUIT

A1         IF BY="'"

               SET BY=""

           IF BY]""

               SET BY=BY_","

               SET FR=FR_","

               SET TO=TO_","

 +1        SET BY=BY_AMERBY

           SET FR=FR_AMERFR

           SET TO=TO_AMERTO

 +2        QUIT

 +3       ;

MET       ; METADICTIONARY LOOKUP

 +1        KILL AMERSCR,AMERBY

 +2        IF 'Y

               SET AMERQUIT=""

               WRITE "  ??",*7

               QUIT

 +3        IF '$DATA(^AMER(2.2,+Y,0))

               SET AMERQUIT=""

               WRITE " ??",*7

               QUIT

 +4        SET %=^AMER(2.2,+Y,0)

           SET AMERCAT=$PIECE(%,U,3)

           SET AMERGBL=$PIECE(%,U,4)

           IF $DATA(^(2))

               SET AMERSCR=^(2)

           IF $DATA(^(1))

               SET AMERBY=^(1)

 +5        IF AMERRTYP="V"

               DO @("M"_AMERCAT_"^AMEROUT2")

               QUIT

 +6        IF AMERRTYP="A"

               DO AGE

               QUIT

 +7        QUIT

 +8       ;

FSET      ; FINAL ADJUSTMENTS OF BY,FR,TO

 +1        IF AMERRTYP="A"

               QUIT

 +2        IF $DATA(AMERSTAT)

               IF $GET(FLDS)=""

                   SET FLDS="!.01"

 +3        IF AMERDISP=2

               IF BY=""

                   SET BY="'@.01,@.02"

                   SET FR=AMERD1_","

                   SET TO=AMERD2_","

                   QUIT

 +4        IF AMERDISP=2

               Begin DoDot:1

 +5                IF BY="5,.01"

                       SET BY=BY_",5,.01:DIAGNOSIS;N;""DX DESCRIPTION: """

 +6       ; FINAL SET OF BY,FR,TO

                   SET BY=BY_","

                   SET FR=FR_","

                   SET TO=TO_","

 +7                SET BY="'@.01,"_BY

                   SET FR=AMERD1_","_FR_","

                   SET TO=AMERD2_","_TO_","

 +8                IF '$DATA(AMERSTAT)

                       SET BY=BY_",.02"

 +9                QUIT

               End DoDot:1

               QUIT

 +10       IF AMERDISP=3

               IF BY=""

                   SET BY="@.01"

                   SET FR=AMERD1

                   SET TO=AMERD2

                   QUIT

 +11       IF BY="5,.01"

               SET BY=BY_",5,.01:DIAGNOSIS;N;""DX DESCRIPTION: """

 +12       IF AMERDISP=3

               SET BY="'@.01,"_BY

               IF '$DATA(AMERSTAT)

                   SET BY=BY_",@.01"

               SET FR=AMERD1_","_FR_","

               SET TO=AMERD2_","_TO_","

               QUIT

 +13       IF BY=""

               SET BY="@.16"

               SET FR=(9999999-AMERD2)

               SET TO=(9999999-AMERD1)

               QUIT

 +14       SET BY="'@.01,"_BY

           IF '$DATA(AMERSTAT)

               SET BY=BY_",@.16"

           SET FR=AMERD1_","_FR_","

           SET TO=AMERD2_","_TO_","

 +15       QUIT

 +16      ;

PRINT     ; GENERATE OUTPUT - ENTRY POINT FROM AMEROUT

 +1        IF AMERRTYP'="A"

               SET DIC="^AMERVSIT("

               SET DIOBEG="S AMERNOTE="""",^UTILITY($J,2)=""D:$D(AMERNOTE) NOTE^AMEROUT1 ""_^UTILITY($J,2)"

 +2        SET Y=AMERD1

           DO DD^%DT

           SET AMERD1=Y

 +3        SET Y=AMERD2

           DO DD^%DT

           SET AMERD2=Y

 +4        IF $GET(AMERHDR)'=""

               SET DHD=$$AMERDHD^AMERREPT(AMERHDR,AMERD1,AMERD2)

 +5       IF '$TEST

               SET DHD="ER REPORT"

ENDIP      DO EN1^DIP

 +1       ;

 +2       ;AMER*3.0*5

 +3        DO LOG^AMERBUSA("P","Q","AMEROUT1","AMER: Printed "_AMERHDR_" for "_AMERD1_" to "_$PIECE(AMERD2,"@"),"")

 +4       ;

 +5        IF $DATA(IOST)

               IF IOST["C-"

                   IF '$DATA(DIRUT)

                       IF '$DATA(DTOUT)

                           WRITE !

                           SET DIR(0)="E"

                           SET DIR("A")="Press 'Return to continue"

                           DO ^DIR

 +6        QUIT

 +7       ;

TASK      ; BACKGROUND JOB ENTRY POINT

 +1       ;

 +2        QUIT

 +3       ;

NOTE      ;

 +1        KILL AMERNOTE

           NEW I,X

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

               QUIT

 +3        WRITE "Please note: the following criteria were used to screen entries:",!

 +4        SET X=""

           FOR I=1:1

               SET X=$ORDER(^TMP("AMER",$JOB,8,X))

               IF X=""

                   QUIT

               WRITE !,?3,I,") ",X," = """,^(X),""""

 +5        WRITE !!!

 +6        QUIT

 +7       ;

AGE       ; ENTRY POINT

 +1        SET DIC="^AMERVSIT("

           SET FR=AMERD1

           SET TO=AMERD2

 +2        SET FLDS="!.02:NUMBER,"_AMERBY_",!D ^AMERBIN"

 +3        SET BY="'@.01,.02:NUMBER"

 +4        SET DHD="@"

 +5        QUIT

 +6       ;

EN1       ; ENTRY POINT FORM OPTION AMER LOG

 +1       ; PRINT RECENT VISITS

 +2        NEW BY,FR,TO,FLDS,DIC,%,AMERRTYP,AMERHDR,AMERD1,AMERD2,AMERDATE

 +3        SET AMERRTYP="V"

 +4        DO NOW^%DTC

 +5       ;THE DATE THAT X2 WILL BE SUBTRACTED FROM IN FILEMAN FORMAT

           SET X1=X

 +6       ;TO GET THE DAY BEFORE...

           SET X2=-1

 +7        DO C^%DTC

 +8        SET AMERDATE=X

 +9        SET FR=$PIECE(X,".",1)

 +10       SET TO=FR

 +11       SET FLDS="[AMER BRIEF"

           SET BY="@.01"

 +12       SET DIC="^AMERVSIT("

 +13       SET Y=FR

           DO DD^%DT

           SET AMERD1=Y

 +14       SET Y=TO

           DO DD^%DT

           SET AMERD2=Y

 +15       DO SYNCHERS^AMERERS(AMERD1,AMERD2)

 +16       SET AMERHDR="ER DAILY LOG REPORT"

 +17       SET DHD=$$AMERDHD^AMERREPT(AMERHDR,AMERD1,AMERD2)

 +18       DO EN1^DIP

 +19      ;

 +20      ;AMER*3.0*5

 +21       DO LOG^AMERBUSA("P","Q","AMEROUT1","AMER: Printed ER Daily Log Report","")

 +22      ;

 +23       IF $DATA(IOST)

               IF IOST["C-"

                   IF '$DATA(DIRUT)

                       IF '$DATA(DTOUT)

                           WRITE !

                           SET DIR(0)="E"

                           SET DIR("A")="Press 'Return to continue"

                           DO ^DIR

 +24       QUIT

AMEROUT1.m