Routine: ACMSRT1

ACMSRT1 ; IHS/TUCSON/TMJ - ACMSRT SUBROUTINE ;

 ;;2.0;ACM CASE MANAGEMENT SYSTEM;;JAN 10, 1996

SD I BY["DATE LAST PRINTED" S FR=FR_",",TO=TO_"," Q

 W !!

 S %DT("A")="Start with what date: ",%DT="AEQ" D ^%DT

 I X=U S ACMQUIT="" Q

 I X="" S Y=X

 S $P(FR,",",ACMN)=Y

 S %DT("A")="End with what date: ",%DT="AEQ" D ^%DT

 I X=U S ACMQUIT="" Q

 I X="" S Y=X

 S $P(TO,",",ACMN)=Y

SA W !!

GAGE S DIR(0)="NOA^0:120",DIR("A")="Start with what AGE: ",DIR("?")="Enter any AGE in years (including 0)"

 D ^DIR K DIR

 I $E(X)=U S ACMQUIT="" Q

 I X="" S Y=0

 S ACMYX=Y

GAGEA S $P(FR,",",ACMN)=Y

SAGE W !

GAGE1 S DIR(0)="NOA^0:120",DIR("A")="Go to what AGE: ",DIR("?")="Enter any AGE in years (must be at least "_ACMYX_")"

 D ^DIR K DIR

 I $E(X)=U S ACMQUIT="" Q

 I X="" S Y=188

 S ACMYX=Y

SAGE1 S $P(TO,",",ACMN)=Y

SS W !!

 S %=$P(^ACM(48.5,ACMSNO,0),U,5),ACMYX=$P(^(0),U,8),%=U_%_"0)",%=+$P(@%,U,2),%=^DD(%,ACMYX,0),ACMSET=";"_$P(%,U,3)

 W "Do you want to sort by a particular ",ACMSNA

 S %=2 D YN^DICN

 I %Y=U S ACMQUIT="" Q

 I "Nn"[$E(%Y) Q

 D SL

 I %Y?1."?" G SS

SSG S DIR(0)="FOA^1:10",DIR("A")="Your choice: ",DIR("?")="Type either the code or the text of the item you wish to select"

 D ^DIR K DIR

 I U[$E(X) S ACMQUIT="" Q

 Q:X=""

 S ACMYX=Y

 S %=ACMSET,Y=$F(%,(";"_ACMYX))

 I Y S ACMYZ=$E(%,Y,99),ACMYZ=$P(ACMYZ,":",2),ACMYZ=$P(ACMYZ,";"),$P(FR,",",ACMN)=ACMYZ,$P(TO,",",ACMN)=ACMYZ W " = ",ACMYZ Q

 F ACMI=2:1 S ACMYZ=$P(%,":",ACMI) Q:ACMYZ=""  I $E(ACMYZ,1,$L(ACMYX))=ACMYX S ACMYZ=$P(ACMYZ,";"),$P(FR,",",ACMN)=ACMYZ,$P(TO,",",ACMN)=ACMYZ W $E(ACMYZ,$L(ACMYX)+1,99) Q

 I ACMYZ="" W "  ??",*7 G SSG

SL W !!,"You may select one of the following choices",!

 F ACMI=2:1 S %=$P(ACMSET,";",ACMI) Q:%=""  S ACMYX=$P(%,":"),Y=$P(%,":",2) W !,?5,ACMYX," = ",Y

SP W !!

 S DIC=U_$P(^ACM(48.5,ACMSNO,0),U,7)

 S ACMDIC1=U_$P($P(ACMNAV,U,7),",")_")"

 W "Do you want to sort by a particular ",ACMSNA

 S %=2 D YN^DICN

 I %Y=U S ACMQUIT="" Q

 I "Nn"[$E(%Y) Q

SPQ S DIC("A")="Which "_ACMSNA_": "

 I '$P(^ACM(41.1,ACMRG,0),U,8) S:ACMDIC'=41&(ACMDIC'=46)&(ACMDIC'=57)&(ACMDIC'=50)&(DIC'["DPT")&(DIC'["AUTT")&(DIC'["VA")&(ACMDIC1'["^ACM(42.3") DIC("S")="I $D(@ACMDIC1@(+Y,""RG"",""B"",ACMRG))"

 I $D(ACMDM),DIC["41," S DIC("S")="I $P(^(0),U)=ACMRG"

 I $D(ACMDM),DIC["DPT" S DIC("S")="I $D(^ACM(41,""AC"",+Y,ACMRG))"

 S DIC(0)="AEMIQZ"

 N I D DIC K ACMDIC1

 I X=U S ACMQUIT="" Q

 I X="" Q

SPQ1 I BY["[" G SPQ11

 N ACMYX,ACMYZ,% S ACMYX=$L(BY,","),%=$P(BY,",",ACMYX)

 I %="" Q

 I %'[";" S BY=BY_":NUMBER="_+Y Q

 S ACMYZ=$P(%,";")

 S $P(%,";",1)=ACMYZ_":NUMBER="_+Y

 S $P(BY,",",ACMYX)=%

SPQ11 S FR=$P(Y,U,2),TO=FR_"z" Q

SF W !!

 W "Do you want to sort by a particular ",ACMSNA

 S %=2 D YN^DICN

 I %Y=U S ACMQUIT="" Q

 I "Nn"[$E(%Y) Q

SFQ S DIC("A")="Which "_ACMSNA_": "

 S DIC(0)="AEMQZ",DIC=ACMDIC

 I ACMSNA["CURRENT COMMUNITY" S DIC="^AUTTCOM("

 I ACMSNA["REGISTER-" S DIC="^ACM(41.1,"

 D DIC

 I X=U S ACMQUIT="" Q

 I X="" Q

 I ACMSNA["REGISTER-" S FR=Y(0,0),TO=FR_"z" Q

 I FR="" S FR=Y(0,0)

 E  S FR=FR_","_Y(0,0)

 I TO="" S TO=Y(0,0)_"z"

 E  S TO=TO_","_Y(0,0)_"z"

DIC W ! D ^DIC K DIC Q

EXIT ;EP;TO KILL VARIABLES

 K ACMYX,Y,ACMYZ,%Y,%DT,ACMZ,ACMZZ,ACMDIC,ACMN,ACMPTMP,BY,FR,TO,FLDS,I

 K ACMSNO,ACMSNA,ACMU,ACMUB,ACMXZ,ACMQUIT,ACMJ1,ACMUB,ACMU,ACMYII

 K ACMX,ACMY,ACMRPT,ACMSET,ACMMAND,ACMCSTG,ACMMANN,ACMMAN,ACMFILE,ACMSRT

 K APCRREG,APCRREGP,APCRN,APCHSPAT,APCHSTYP,ACMYZ

 D ^%ZISC

 S IOP=ION D ^%ZIS Q

PS ;EP - called from acmsrt

 S DIR(0)="SOA^P:Patient;S:Statistical",DIR("A")="     'P'atient or 'S'tatistical report? ==> ",DIR("?")="Enter 'P' for patient or 'S' for statistical reports"

W !

 D ^DIR K DIR

 I U=$E(X)!(X="") S ACMQUIT="" Q

 S ACMX=Y

 Q:ACMX="P"

 S FLDS="[ACM "_ACMRPT_" COUNT]"

 F ACMJ="@","#" I $D(BY),BY[ACMJ F ACMI=0:0 S ACMBY1=$P(BY,ACMJ),ACMBY2=$P(BY,ACMJ,2),BY=ACMBY1_ACMBY2 Q:BY'[ACMJ

 I $D(BY) S ACMBC=$L(BY,",") F ACMJ=1:1:ACMBC S $P(BY,",",ACMJ)="+"_$P(BY,",",ACMJ)

 K ACMX,ACMBC

ACMSRT1   ; IHS/TUCSON/TMJ - ACMSRT SUBROUTINE ;

 +1       ;;2.0;ACM CASE MANAGEMENT SYSTEM;;JAN 10, 1996

SD         IF BY["DATE LAST PRINTED"

               SET FR=FR_","

               SET TO=TO_","

               QUIT

 +1        WRITE !!

 +2        SET %DT("A")="Start with what date: "

           SET %DT="AEQ"

           DO ^%DT

 +3        IF X=U

               SET ACMQUIT=""

               QUIT

 +4        IF X=""

               SET Y=X

 +5        SET $PIECE(FR,",",ACMN)=Y

 +6        SET %DT("A")="End with what date: "

           SET %DT="AEQ"

           DO ^%DT

 +7        IF X=U

               SET ACMQUIT=""

               QUIT

 +8        IF X=""

               SET Y=X

 +9        SET $PIECE(TO,",",ACMN)=Y

 +10       QUIT

 +11      ;

SA         WRITE !!

GAGE       SET DIR(0)="NOA^0:120"

           SET DIR("A")="Start with what AGE: "

           SET DIR("?")="Enter any AGE in years (including 0)"

 +1        DO ^DIR

           KILL DIR

 +2        IF $EXTRACT(X)=U

               SET ACMQUIT=""

               QUIT

 +3        IF X=""

               SET Y=0

 +4        SET ACMYX=Y

GAGEA      SET $PIECE(FR,",",ACMN)=Y

SAGE       WRITE !

GAGE1      SET DIR(0)="NOA^0:120"

           SET DIR("A")="Go to what AGE: "

           SET DIR("?")="Enter any AGE in years (must be at least "_ACMYX_")"

 +1        DO ^DIR

           KILL DIR

 +2        IF $EXTRACT(X)=U

               SET ACMQUIT=""

               QUIT

 +3        IF X=""

               SET Y=188

 +4        SET ACMYX=Y

SAGE1      SET $PIECE(TO,",",ACMN)=Y

 +1        QUIT

 +2       ;

SS         WRITE !!

 +1        SET %=$PIECE(^ACM(48.5,ACMSNO,0),U,5)

           SET ACMYX=$PIECE(^(0),U,8)

           SET %=U_%_"0)"

           SET %=+$PIECE(@%,U,2)

           SET %=^DD(%,ACMYX,0)

           SET ACMSET=";"_$PIECE(%,U,3)

 +2        WRITE "Do you want to sort by a particular ",ACMSNA

 +3        SET %=2

           DO YN^DICN

 +4        IF %Y=U

               SET ACMQUIT=""

               QUIT

 +5        IF "Nn"[$EXTRACT(%Y)

               QUIT

 +6        DO SL

 +7        IF %Y?1."?"

               GOTO SS

SSG        SET DIR(0)="FOA^1:10"

           SET DIR("A")="Your choice: "

           SET DIR("?")="Type either the code or the text of the item you wish to select"

 +1        DO ^DIR

           KILL DIR

 +2        IF U[$EXTRACT(X)

               SET ACMQUIT=""

               QUIT

 +3        IF X=""

               QUIT

 +4        SET ACMYX=Y

 +5        SET %=ACMSET

           SET Y=$FIND(%,(";"_ACMYX))

 +6        IF Y

               SET ACMYZ=$EXTRACT(%,Y,99)

               SET ACMYZ=$PIECE(ACMYZ,":",2)

               SET ACMYZ=$PIECE(ACMYZ,";")

               SET $PIECE(FR,",",ACMN)=ACMYZ

               SET $PIECE(TO,",",ACMN)=ACMYZ

               WRITE " = ",ACMYZ

               QUIT

 +7        FOR ACMI=2:1

               SET ACMYZ=$PIECE(%,":",ACMI)

               IF ACMYZ=""

                   QUIT

               IF $EXTRACT(ACMYZ,1,$LENGTH(ACMYX))=ACMYX

                   SET ACMYZ=$PIECE(ACMYZ,";")

                   SET $PIECE(FR,",",ACMN)=ACMYZ

                   SET $PIECE(TO,",",ACMN)=ACMYZ

                   WRITE $EXTRACT(ACMYZ,$LENGTH(ACMYX)+1,99)

                   QUIT

 +8        IF ACMYZ=""

               WRITE "  ??",*7

               GOTO SSG

 +9        QUIT

 +10      ;

SL         WRITE !!,"You may select one of the following choices",!

 +1        FOR ACMI=2:1

               SET %=$PIECE(ACMSET,";",ACMI)

               IF %=""

                   QUIT

               SET ACMYX=$PIECE(%,":")

               SET Y=$PIECE(%,":",2)

               WRITE !,?5,ACMYX," = ",Y

 +2        QUIT

 +3       ;

SP         WRITE !!

 +1        SET DIC=U_$PIECE(^ACM(48.5,ACMSNO,0),U,7)

 +2        SET ACMDIC1=U_$PIECE($PIECE(ACMNAV,U,7),",")_")"

 +3        WRITE "Do you want to sort by a particular ",ACMSNA

 +4        SET %=2

           DO YN^DICN

 +5        IF %Y=U

               SET ACMQUIT=""

               QUIT

 +6        IF "Nn"[$EXTRACT(%Y)

               QUIT

SPQ        SET DIC("A")="Which "_ACMSNA_": "

 +1        IF '$PIECE(^ACM(41.1,ACMRG,0),U,8)

               IF ACMDIC'=41&(ACMDIC'=46)&(ACMDIC'=57)&(ACMDIC'=50)&(DIC'["DPT")&(DIC'["AUTT")&(DIC'["VA")&(ACMDIC1'["^ACM(42.3")

                   SET DIC("S")="I $D(@ACMDIC1@(+Y,""RG"",""B"",ACMRG))"

 +2        IF $DATA(ACMDM)

               IF DIC["41,"

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

 +3        IF $DATA(ACMDM)

               IF DIC["DPT"

                   SET DIC("S")="I $D(^ACM(41,""AC"",+Y,ACMRG))"

 +4        SET DIC(0)="AEMIQZ"

 +5        NEW I

           DO DIC

           KILL ACMDIC1

 +6        IF X=U

               SET ACMQUIT=""

               QUIT

 +7        IF X=""

               QUIT

SPQ1       IF BY["["

               GOTO SPQ11

 +1        NEW ACMYX,ACMYZ,%

           SET ACMYX=$LENGTH(BY,",")

           SET %=$PIECE(BY,",",ACMYX)

 +2        IF %=""

               QUIT

 +3        IF %'[";"

               SET BY=BY_":NUMBER="_+Y

               QUIT

 +4        SET ACMYZ=$PIECE(%,";")

 +5        SET $PIECE(%,";",1)=ACMYZ_":NUMBER="_+Y

 +6        SET $PIECE(BY,",",ACMYX)=%

 +7        QUIT

SPQ11      SET FR=$PIECE(Y,U,2)

           SET TO=FR_"z"

           QUIT

 +1       ;

SF         WRITE !!

 +1        WRITE "Do you want to sort by a particular ",ACMSNA

 +2        SET %=2

           DO YN^DICN

 +3        IF %Y=U

               SET ACMQUIT=""

               QUIT

 +4        IF "Nn"[$EXTRACT(%Y)

               QUIT

SFQ        SET DIC("A")="Which "_ACMSNA_": "

 +1        SET DIC(0)="AEMQZ"

           SET DIC=ACMDIC

 +2        IF ACMSNA["CURRENT COMMUNITY"

               SET DIC="^AUTTCOM("

 +3        IF ACMSNA["REGISTER-"

               SET DIC="^ACM(41.1,"

 +4        DO DIC

 +5        IF X=U

               SET ACMQUIT=""

               QUIT

 +6        IF X=""

               QUIT

 +7        IF ACMSNA["REGISTER-"

               SET FR=Y(0,0)

               SET TO=FR_"z"

               QUIT

 +8        IF FR=""

               SET FR=Y(0,0)

 +9       IF '$TEST

               SET FR=FR_","_Y(0,0)

 +10       IF TO=""

               SET TO=Y(0,0)_"z"

 +11      IF '$TEST

               SET TO=TO_","_Y(0,0)_"z"

 +12       QUIT

DIC        WRITE !

           DO ^DIC

           KILL DIC

           QUIT

EXIT      ;EP;TO KILL VARIABLES

 +1        KILL ACMYX,Y,ACMYZ,%Y,%DT,ACMZ,ACMZZ,ACMDIC,ACMN,ACMPTMP,BY,FR,TO,FLDS,I

 +2        KILL ACMSNO,ACMSNA,ACMU,ACMUB,ACMXZ,ACMQUIT,ACMJ1,ACMUB,ACMU,ACMYII

 +3        KILL ACMX,ACMY,ACMRPT,ACMSET,ACMMAND,ACMCSTG,ACMMANN,ACMMAN,ACMFILE,ACMSRT

 +4        KILL APCRREG,APCRREGP,APCRN,APCHSPAT,APCHSTYP,ACMYZ

 +5        DO ^%ZISC

 +6        SET IOP=ION

           DO ^%ZIS

           QUIT

PS        ;EP - called from acmsrt

 +1        SET DIR(0)="SOA^P:Patient;S:Statistical"

           SET DIR("A")="     'P'atient or 'S'tatistical report? ==> "

           SET DIR("?")="Enter 'P' for patient or 'S' for statistical reports"

 +2        WRITE !

 +3        DO ^DIR

           KILL DIR

 +4        IF U=$EXTRACT(X)!(X="")

               SET ACMQUIT=""

               QUIT

 +5        SET ACMX=Y

 +6        IF ACMX="P"

               QUIT

 +7        SET FLDS="[ACM "_ACMRPT_" COUNT]"

 +8        FOR ACMJ="@","#"

               IF $DATA(BY)

                   IF BY[ACMJ

                       FOR ACMI=0:0

                           SET ACMBY1=$PIECE(BY,ACMJ)

                           SET ACMBY2=$PIECE(BY,ACMJ,2)

                           SET BY=ACMBY1_ACMBY2

                           IF BY'[ACMJ

                               QUIT

 +9        IF $DATA(BY)

               SET ACMBC=$LENGTH(BY,",")

               FOR ACMJ=1:1:ACMBC

                   SET $PIECE(BY,",",ACMJ)="+"_$PIECE(BY,",",ACMJ)

 +10       KILL ACMX,ACMBC

 +11       QUIT

ACMSRT1.m