ACGSRT1.m

ACGSRT1 ;IHS/OIRM/DSD/THL,AEF - ACGSRT SUBROUTINE; [ 03/27/2000   2:22 PM ]

 ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000

SD ;EP;FOR DATE RANGE SELECTION

 W !!

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

 I X=U S ACGQUIT="" Q

 I X="" S Y=X

 S FR=FR_Y_","

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

 I X=U S ACGQUIT="" Q

 I X="" S Y=X

 S TO=TO_Y_","

 Q

 ;

SS ;EP;FOR SET OF CODE SELECTION

 W !!

 S %="^ACGS(0)",ACGYX=$P(^ACGSRT(ACGSNO,0),U,8),%=+$P(@%,U,2),%=^DD(%,ACGYX,0),ACGSET=";"_$P(%,U,3)

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

 S %=2 D YN^DICN

 I %Y=U!(%=2) S:%Y=U ACGQUIT="" S:%=2 FR=FR_",",TO=TO_"," Q

 D SL

 I %Y?1."?" G SS

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

 D DIR^ACGSDIC

 Q:$D(ACGQUIT)!(Y<1)

 S %=ACGSET,Y=$F(%,(";"_Y))

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

 F ACGI=2:1 S ACGYZ=$P(%,":",ACGI) Q:ACGYZ=""  I $E(ACGYZ,1,$L(ACGYX))=ACGYX S ACGYZ=$P(ACGYZ,";"),FR=FR_ACGYZ_",",TO=TO_ACGYZ_"," W $E(ACGYZ,$L(ACGYX)+1,99) Q

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

 Q

 ;

SL ;EP;FOR LIST SELECTION

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

 F ACGI=2:1 S %=$P(ACGSET,";",ACGI) Q:%=""  S ACGYX=$P(%,":"),Y=$P(%,":",2) W !,?5,ACGYX," = ",Y

 Q

 ;

SP ;EP;FOR POINTER SELECTION

 W !!

 S DIC=U_$P(^ACGSRT(ACGSNO,0),U,7),ACGPP=$P(^(0),U,3)

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

 S %=2 D YN^DICN

 I %Y=U S ACGQUIT="" Q

 I %=2 S FR=FR_",",TO=TO_"," Q

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

 S DIC(0)="AEMQZ"

 N I

 W !

 D DIC^ACGSDIC

 K ACGDIC1

 I X=U!(+Y<1) S:X=U ACGQUIT="" K ACGBY Q

SPQ1 G SPQ11

 N ACGYX,ACGYZ,%

 S %=ACGBY

 Q:%=""

SPQ11 S ACGFR=$P(Y(0),U,ACGPP),ACGTO=ACGFR

 S:ACGTO="P" ACGTO="PM"

 S FR=FR_ACGFR_","

 S TO=TO_ACGTO_","

 Q

 ;

SF ;EP;FOR FREE TEST SELECTION

 S ACGLNG1=$P(^ACGSRT(ACGSNO,0),U,6),ACGLNG2=$P(^(0),U,9),ACGXREF=$P(^(0),U,4)

 W !!

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

 S %=2 D YN^DICN

 I %Y=U S ACGQUIT="" Q

 I %=2 S FR=FR_",",TO=TO_"," Q

SFQ S DIR("A")="Which "_ACGSNA_": "

 S DIR(0)="FOA^"_ACGLNG1_":"_ACGLNG2

 S DIR("?",1)="Enter a "_ACGSNA,DIR("?")="from "_ACGLNG1_" to "_ACGLNG2_" characters in length."

 W !!

 D DIR^ACGSDIC

 I $D(ACGQUIT) K:X=U ACGQUIT K ACGBY Q

 I ACGSNA["CONTRACT NUMBER",$L(Y)=9 S Y=Y_"000" ;,DIS(0)="I $P(^ACGS(D0,0),U)=0"

 I ACGXREF'="",$D(^ACGS(ACGXREF,Y)),ACGSNA["CONTRACT NUMBER" S ACGY=$O(^ACGS(ACGXREF,Y,0)) Q:'ACGY  S ACGY=Y G SFQ1

 S ACGUPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789",ACGLOWER="abcdefghijklmnopqrstuvwxyz0123456789",Y=$TR(Y,ACGLOWER,ACGUPPER)

 S ACGY=$E(Y,1,($L(Y)-1))_$C($A($E(Y,$L(Y)))-1)_"z"

 N ACG,ACGX

 I ACGXREF'="" F ACG=1:1 S ACGY=$O(^ACGS(ACGXREF,ACGY)) Q:ACGY=""!(ACGY'[Y)  S ACGY(ACG)=ACGY

 I ACG=1,'$D(ACGY(1)) W !!,"No such ",ACGSNA," found." H 2 S ACGBY="" Q

 I ACG=2,'$D(ACGY(2)),$D(ACGY(1)) D  Q:'$D(ACGBY)

 .S DIR(0)="YO",DIR("A")="Do you mean "_ACGY(1),DIR("B")="NO",ACGY=ACGY(1)

 .W !

 .D DIR^ACGSDIC

 .I +Y'=1 K ACGBY

 .S ACGY=ACGY(1)

 I ACG>1,$D(ACGY(2)) D  I $D(ACGQUIT) K ACGQUIT G SF

 .S ACG=0

 .W !

 .F  S ACG=$O(ACGY(ACG)) Q:'ACG  W !?10,ACG,?15,ACGY(ACG) S ACG1=ACG

 .S DIR(0)="NO^1:"_ACG1,DIR("A")="Which one"

 .K ACG1

 .W !

 .D DIR^ACGSDIC

 .I '+Y K ACGBY,ACGY S ACGQUIT="" Q

 .I $D(ACGY(+Y)) S ACGY=ACGY(+Y) Q

 .K ACGBY,ACGY Q

SFQ1 S:ACGY["," ACGY=$P(ACGY,",")

 S FR=FR_$S(ACGY&(ACGSNA["CONTRACT NUMBER"):ACGY-1,1:ACGY)_","

 I 'ACGY S ACGY=ACGY_"z"

 S TO=TO_ACGY_","

 Q

EXIT ;EP; TO KILL VARIABLES

 K ACGYX,Y,ACGYZ,%Y,ACGZ,ACGZZ,ACGDIC,ACGN,ACGPTMP,BY,FR,TO,FLDS,I,ACGSNO,ACGSNA,ACGU,ACGUB,ACGXZ,ACGQUIT,ACGX,ACGY,ACGRPT,ACGSET,ACGMAND,ACGCSTG,ACGMANN,ACGMAN,ACGFILE,ACGSRT,APCRREG,APCRREGP,APCRN,APCHSPAT,APCHSTYP,ACGYZ,ACGXZ

 K ACGLNG1,ACGLNG2,ACGFR,ACGJJ,ACGPP,ACGXREF,ACGXZZ,ACGYY

 D ^%ZISC

 S IOP=ION D ^%ZIS K IOP

 Q

SN ;EP;FOR NUMBER RANGE SELECTION

 S ACGLNG1=$P(^ACGSRT(ACGSNO,0),U,6),ACGLNG2=$P(^(0),U,9),ACGXREF=$P(^(0),U,4)

 S DIR("A")="Start with "_ACGSNA_": "

 S DIR(0)="NOA^0:99999999"

 S DIR("?",1)="From "_ACGSNA,DIR("?")="from 0 to 99999999"_$S(ACGSNA="DOLLAR AMOUNT":".  Do not include commas or dollar sign.",1:"")

 W !

 D DIR^ACGSDIC

 I X=""!$D(ACGQUIT) K:X=U ACGQUIT K ACGBY Q

 S FR=FR_Y_",",ACGDF=Y

 S DIR("A")="End with "_ACGSNA_": "

 S DIR(0)="NOA^0:99999999"

 S DIR("?",1)="Enter a "_ACGSNA,DIR("?")="from 0 to 99999999"_$S(ACGSNA="DOLLAR AMOUNT":".  Do not include commas or dollar sign.",1:"")

 W !

 D DIR^ACGSDIC

 I X="" S Y=99999999 K ACGQUIT

 I $D(ACGQUIT) K:X=U ACGQUIT K ACGBY Q

 S TO=TO_Y_",",ACGDT=Y

 Q

ACGSRT1   ;IHS/OIRM/DSD/THL,AEF - ACGSRT SUBROUTINE; [ 03/27/2000   2:22 PM ]

 +1       ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000

SD        ;EP;FOR DATE RANGE SELECTION

 +1        WRITE !!

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

           SET %DT="AEQ"

           DO ^%DT

 +3        IF X=U

               SET ACGQUIT=""

               QUIT 

 +4        IF X=""

               SET Y=X

 +5        SET FR=FR_Y_","

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

           SET %DT="AEQ"

           DO ^%DT

 +7        IF X=U

               SET ACGQUIT=""

               QUIT 

 +8        IF X=""

               SET Y=X

 +9        SET TO=TO_Y_","

 +10       QUIT 

 +11      ;

SS        ;EP;FOR SET OF CODE SELECTION

 +1        WRITE !!

 +2        SET %="^ACGS(0)"

           SET ACGYX=$PIECE(^ACGSRT(ACGSNO,0),U,8)

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

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

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

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

 +4        SET %=2

           DO YN^DICN

 +5        IF %Y=U!(%=2)

               IF %Y=U

                   SET ACGQUIT=""

               IF %=2

                   SET FR=FR_","

                   SET TO=TO_","

               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 of the item you wish to select"

 +1        DO DIR^ACGSDIC

 +2        IF $DATA(ACGQUIT)!(Y<1)

               QUIT 

 +3        SET %=ACGSET

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

 +4        IF Y

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

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

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

               SET FR=FR_ACGYZ_","

               SET TO=TO_ACGYZ_","

               WRITE " = ",ACGYZ

               QUIT 

 +5        FOR ACGI=2:1

               SET ACGYZ=$PIECE(%,":",ACGI)

               IF ACGYZ=""

                   QUIT 

               IF $EXTRACT(ACGYZ,1,$LENGTH(ACGYX))=ACGYX

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

                   SET FR=FR_ACGYZ_","

                   SET TO=TO_ACGYZ_","

                   WRITE $EXTRACT(ACGYZ,$LENGTH(ACGYX)+1,99)

                   QUIT 

 +6        IF ACGYZ=""

               WRITE "  ??",*7

               GOTO SSG

 +7        QUIT 

 +8       ;

SL        ;EP;FOR LIST SELECTION

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

 +2        FOR ACGI=2:1

               SET %=$PIECE(ACGSET,";",ACGI)

               IF %=""

                   QUIT 

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

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

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

 +3        QUIT 

 +4       ;

SP        ;EP;FOR POINTER SELECTION

 +1        WRITE !!

 +2        SET DIC=U_$PIECE(^ACGSRT(ACGSNO,0),U,7)

           SET ACGPP=$PIECE(^(0),U,3)

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

 +4        SET %=2

           DO YN^DICN

 +5        IF %Y=U

               SET ACGQUIT=""

               QUIT 

 +6        IF %=2

               SET FR=FR_","

               SET TO=TO_","

               QUIT 

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

 +1        SET DIC(0)="AEMQZ"

 +2        NEW I

 +3        WRITE !

 +4        DO DIC^ACGSDIC

 +5        KILL ACGDIC1

 +6        IF X=U!(+Y<1)

               IF X=U

                   SET ACGQUIT=""

               KILL ACGBY

               QUIT 

SPQ1       GOTO SPQ11

 +1        NEW ACGYX,ACGYZ,%

 +2        SET %=ACGBY

 +3        IF %=""

               QUIT 

SPQ11      SET ACGFR=$PIECE(Y(0),U,ACGPP)

           SET ACGTO=ACGFR

 +1        IF ACGTO="P"

               SET ACGTO="PM"

 +2        SET FR=FR_ACGFR_","

 +3        SET TO=TO_ACGTO_","

 +4        QUIT 

 +5       ;

SF        ;EP;FOR FREE TEST SELECTION

 +1        SET ACGLNG1=$PIECE(^ACGSRT(ACGSNO,0),U,6)

           SET ACGLNG2=$PIECE(^(0),U,9)

           SET ACGXREF=$PIECE(^(0),U,4)

 +2        WRITE !!

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

 +4        SET %=2

           DO YN^DICN

 +5        IF %Y=U

               SET ACGQUIT=""

               QUIT 

 +6        IF %=2

               SET FR=FR_","

               SET TO=TO_","

               QUIT 

SFQ        SET DIR("A")="Which "_ACGSNA_": "

 +1        SET DIR(0)="FOA^"_ACGLNG1_":"_ACGLNG2

 +2        SET DIR("?",1)="Enter a "_ACGSNA

           SET DIR("?")="from "_ACGLNG1_" to "_ACGLNG2_" characters in length."

 +3        WRITE !!

 +4        DO DIR^ACGSDIC

 +5        IF $DATA(ACGQUIT)

               IF X=U

                   KILL ACGQUIT

               KILL ACGBY

               QUIT 

 +6       ;,DIS(0)="I $P(^ACGS(D0,0),U)=0"

           IF ACGSNA["CONTRACT NUMBER"

               IF $LENGTH(Y)=9

                   SET Y=Y_"000"

 +7        IF ACGXREF'=""

               IF $DATA(^ACGS(ACGXREF,Y))

                   IF ACGSNA["CONTRACT NUMBER"

                       SET ACGY=$ORDER(^ACGS(ACGXREF,Y,0))

                       IF 'ACGY

                           QUIT 

                       SET ACGY=Y

                       GOTO SFQ1

 +8        SET ACGUPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"

           SET ACGLOWER="abcdefghijklmnopqrstuvwxyz0123456789"

           SET Y=$TRANSLATE(Y,ACGLOWER,ACGUPPER)

 +9        SET ACGY=$EXTRACT(Y,1,($LENGTH(Y)-1))_$CHAR($ASCII($EXTRACT(Y,$LENGTH(Y)))-1)_"z"

 +10       NEW ACG,ACGX

 +11       IF ACGXREF'=""

               FOR ACG=1:1

                   SET ACGY=$ORDER(^ACGS(ACGXREF,ACGY))

                   IF ACGY=""!(ACGY'[Y)

                       QUIT 

                   SET ACGY(ACG)=ACGY

 +12       IF ACG=1

               IF '$DATA(ACGY(1))

                   WRITE !!,"No such ",ACGSNA," found."

                   HANG 2

                   SET ACGBY=""

                   QUIT 

 +13       IF ACG=2

               IF '$DATA(ACGY(2))

                   IF $DATA(ACGY(1))

                       Begin DoDot:1

 +14                       SET DIR(0)="YO"

                           SET DIR("A")="Do you mean "_ACGY(1)

                           SET DIR("B")="NO"

                           SET ACGY=ACGY(1)

 +15                       WRITE !

 +16                       DO DIR^ACGSDIC

 +17                       IF +Y'=1

                               KILL ACGBY

 +18                       SET ACGY=ACGY(1)

                       End DoDot:1

                       IF '$DATA(ACGBY)

                           QUIT 

 +19       IF ACG>1

               IF $DATA(ACGY(2))

                   Begin DoDot:1

 +20                   SET ACG=0

 +21                   WRITE !

 +22                   FOR 

                           SET ACG=$ORDER(ACGY(ACG))

                           IF 'ACG

                               QUIT 

                           WRITE !?10,ACG,?15,ACGY(ACG)

                           SET ACG1=ACG

 +23                   SET DIR(0)="NO^1:"_ACG1

                       SET DIR("A")="Which one"

 +24                   KILL ACG1

 +25                   WRITE !

 +26                   DO DIR^ACGSDIC

 +27                   IF '+Y

                           KILL ACGBY,ACGY

                           SET ACGQUIT=""

                           QUIT 

 +28                   IF $DATA(ACGY(+Y))

                           SET ACGY=ACGY(+Y)

                           QUIT 

 +29                   KILL ACGBY,ACGY

                       QUIT 

                   End DoDot:1

                   IF $DATA(ACGQUIT)

                       KILL ACGQUIT

                       GOTO SF

SFQ1       IF ACGY[","

               SET ACGY=$PIECE(ACGY,",")

 +1        SET FR=FR_$SELECT(ACGY&(ACGSNA["CONTRACT NUMBER"):ACGY-1,1:ACGY)_","

 +2        IF 'ACGY

               SET ACGY=ACGY_"z"

 +3        SET TO=TO_ACGY_","

 +4        QUIT 

EXIT      ;EP; TO KILL VARIABLES

 +1        KILL ACGYX,Y,ACGYZ,%Y,ACGZ,ACGZZ,ACGDIC,ACGN,ACGPTMP,BY,FR,TO,FLDS,I,ACGSNO,ACGSNA,ACGU,ACGUB,ACGXZ,ACGQUIT,ACGX,ACGY,ACGRPT,ACGSET,ACGMAND,ACGCSTG,ACGMANN,ACGMAN,ACGFILE,ACGSRT,APCRREG,APCRREGP,APCRN,APCHSPAT,APCHSTYP,ACGYZ,ACGXZ

 +2        KILL ACGLNG1,ACGLNG2,ACGFR,ACGJJ,ACGPP,ACGXREF,ACGXZZ,ACGYY

 +3        DO ^%ZISC

 +4        SET IOP=ION

           DO ^%ZIS

           KILL IOP

 +5        QUIT 

SN        ;EP;FOR NUMBER RANGE SELECTION

 +1        SET ACGLNG1=$PIECE(^ACGSRT(ACGSNO,0),U,6)

           SET ACGLNG2=$PIECE(^(0),U,9)

           SET ACGXREF=$PIECE(^(0),U,4)

 +2        SET DIR("A")="Start with "_ACGSNA_": "

 +3        SET DIR(0)="NOA^0:99999999"

 +4        SET DIR("?",1)="From "_ACGSNA

           SET DIR("?")="from 0 to 99999999"_$SELECT(ACGSNA="DOLLAR AMOUNT":".  Do not include commas or dollar sign.",1:"")

 +5        WRITE !

 +6        DO DIR^ACGSDIC

 +7        IF X=""!$DATA(ACGQUIT)

               IF X=U

                   KILL ACGQUIT

               KILL ACGBY

               QUIT 

 +8        SET FR=FR_Y_","

           SET ACGDF=Y

 +9        SET DIR("A")="End with "_ACGSNA_": "

 +10       SET DIR(0)="NOA^0:99999999"

 +11       SET DIR("?",1)="Enter a "_ACGSNA

           SET DIR("?")="from 0 to 99999999"_$SELECT(ACGSNA="DOLLAR AMOUNT":".  Do not include commas or dollar sign.",1:"")

 +12       WRITE !

 +13       DO DIR^ACGSDIC

 +14       IF X=""

               SET Y=99999999

               KILL ACGQUIT

 +15       IF $DATA(ACGQUIT)

               IF X=U

                   KILL ACGQUIT

               KILL ACGBY

               QUIT 

 +16       SET TO=TO_Y_","

           SET ACGDT=Y

 +17       QUIT