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
