APCLSRT1 ; IHS/CMI/LAB - APCLSRT SUBROUTINE ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
SD W !!
S %DT("A")="Start with what date: ",%DT="AEQ" D ^%DT
I X=U S APCLQUIT="" Q
I X="" S Y=X
S APCLBEGD=Y
S $P(FR,",",APCLN)=Y
S %DT("A")="End with what date: ",%DT="AEQ" D ^%DT
I X=U S APCLQUIT="" Q
I X="" S Y=X
I Y]"",APCLBEGD]"",APCLBEGD>Y W $C(7),$C(7),!!,"ENDING DATE MUST BE GREATER THAN START DATE!" G SD
S $P(TO,",",APCLN)=Y
Q
;
SA W !!
GAGE W "Start with what AGE: " R X:DTIME I '$T S APCLQUIT="" Q
I X="" S Y=0 G GAGEA
I X=U S APCLQUIT="" Q
I X?1."?" W !,"Enter any AGE in years (including 0)",!! G GAGE
I X'?1.3N W " ??",$C(7),! G GAGE
GAGEA S Y=X,$P(FR,",",APCLN)=Y
SAGE ;S Y=X,Z=DT-(X*10000)
W !
GAGE1 W "Go to what AGE: " R X:DTIME I '$T S APCLQUIT="" Q
I X="" S X=188 G SAGE1
I X=U S APCLQUIT="" Q
I X?1."?" W !,"Enter any AGE in years (must be at least ",Y,")",!! G GAGE1
I X?1.3N,X'<Y G SAGE1
W " ??",$C(7),! G GAGE1
SAGE1 S $P(TO,",",APCLN)=X
;S $P(FR,",",APCLN)=1+(DT-((X+1)*10000)),$P(TO,",",APCLN)=Z
Q
;
SS W !!
S %=$P(^APCLSRT(APCLSNO,0),U,5),X=$P(^(0),U,8),%=U_%_"0)",%=+$P(@%,U,2),%=^DD(%,X,0),APCLSET=";"_$P(%,U,3)
W "Do you want to sort by a particular ",APCLSNA
S %=2 D YN^DICN
I %Y=U S APCLQUIT="" Q
I "Nn"[$E(%Y) Q
D SL
I %Y?1."?" G SS
SSG W !!,"Your choice: " R X:DTIME I '$T S APCLQUIT="" Q
I X=U S APCLQUIT="" Q
I X="" Q
I X?1."?" W !,"Type either the code or the text of the item you wish to select",!! G SSG
S %=APCLSET,Y=$F(%,(";"_X))
I Y S Z=$E(%,Y,99),Z=$P(Z,":",2),Z=$P(Z,";"),$P(FR,",",APCLN)=Z,$P(TO,",",APCLN)=Z W " = ",Z Q
F I=2:1 S Z=$P(%,":",I) Q:Z="" I $E(Z,1,$L(X))=X S Z=$P(Z,";"),$P(FR,",",APCLN)=Z,$P(TO,",",APCLN)=Z W $E(Z,$L(X)+1,99) Q
I Z="" W " ??",$C(7) G SSG
Q
;
SL W !!,"You may select one of the following choices",!
F I=2:1 S %=$P(APCLSET,";",I) Q:%="" S X=$P(%,":"),Y=$P(%,":",2) W !?5,X," = ",Y
Q
;
SP W !!
S DIC=U_$P(^APCLSRT(APCLSNO,0),U,7)
W "Do you want to sort by a particular ",APCLSNA
S %=2 D YN^DICN
I %Y=U S APCLQUIT="" Q
I "Nn"[$E(%Y) Q
SPQ S DIC("A")="Which "_APCLSNA_": "
I $D(APCLDM),DIC["41," S DIC("S")="I $P(^APCL(41,+Y,0),U)=APCLRG"
S DIC(0)="AEMQ"
D DIC K APCLDIC1
I X=U S APCLQUIT="" Q
I X="" Q
SPQ1 I BY["[" G SPQ11
N X,Z,% S X=$L(BY,","),%=$P(BY,",",X)
I %="" Q
I %'[";" S BY=BY_":NUMBER="_+Y Q
S Z=$P(%,";")
S $P(%,";")=Z_":NUMBER="_+Y
S $P(BY,",",X)=%
Q
SPQ11 S FR=$P(Y,U,2),TO=FR_"z" Q
;
SF W !!
W "Do you want to sort by a particular ",APCLSNA
S %=2 D YN^DICN
I %Y=U S APCLQUIT="" Q
I "Nn"[$E(%Y) Q
SFQ S DIC("A")="Which "_APCLSNA_": "
S DIC(0)="AEMQZ",DIC=APCLDIC
I APCLSNA["CURRENT COMMUNITY" S DIC="^AUTTCOM("
D DIC
I X=U S APCLQUIT="" Q
I X="" 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"
Q
DIC W ! D ^DIC K DIC Q
APCLSRT1 ; IHS/CMI/LAB - APCLSRT SUBROUTINE ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
SD WRITE !!
+1 SET %DT("A")="Start with what date: "
SET %DT="AEQ"
DO ^%DT
+2 IF X=U
SET APCLQUIT=""
QUIT
+3 IF X=""
SET Y=X
+4 SET APCLBEGD=Y
+5 SET $PIECE(FR,",",APCLN)=Y
+6 SET %DT("A")="End with what date: "
SET %DT="AEQ"
DO ^%DT
+7 IF X=U
SET APCLQUIT=""
QUIT
+8 IF X=""
SET Y=X
+9 IF Y]""
IF APCLBEGD]""
IF APCLBEGD>Y
WRITE $CHAR(7),$CHAR(7),!!,"ENDING DATE MUST BE GREATER THAN START DATE!"
GOTO SD
+10 SET $PIECE(TO,",",APCLN)=Y
+11 QUIT
+12 ;
SA WRITE !!
GAGE WRITE "Start with what AGE: "
READ X:DTIME
IF '$TEST
SET APCLQUIT=""
QUIT
+1 IF X=""
SET Y=0
GOTO GAGEA
+2 IF X=U
SET APCLQUIT=""
QUIT
+3 IF X?1."?"
WRITE !,"Enter any AGE in years (including 0)",!!
GOTO GAGE
+4 IF X'?1.3N
WRITE " ??",$CHAR(7),!
GOTO GAGE
GAGEA SET Y=X
SET $PIECE(FR,",",APCLN)=Y
SAGE ;S Y=X,Z=DT-(X*10000)
+1 WRITE !
GAGE1 WRITE "Go to what AGE: "
READ X:DTIME
IF '$TEST
SET APCLQUIT=""
QUIT
+1 IF X=""
SET X=188
GOTO SAGE1
+2 IF X=U
SET APCLQUIT=""
QUIT
+3 IF X?1."?"
WRITE !,"Enter any AGE in years (must be at least ",Y,")",!!
GOTO GAGE1
+4 IF X?1.3N
IF X'<Y
GOTO SAGE1
+5 WRITE " ??",$CHAR(7),!
GOTO GAGE1
SAGE1 SET $PIECE(TO,",",APCLN)=X
+1 ;S $P(FR,",",APCLN)=1+(DT-((X+1)*10000)),$P(TO,",",APCLN)=Z
+2 QUIT
+3 ;
SS WRITE !!
+1 SET %=$PIECE(^APCLSRT(APCLSNO,0),U,5)
SET X=$PIECE(^(0),U,8)
SET %=U_%_"0)"
SET %=+$PIECE(@%,U,2)
SET %=^DD(%,X,0)
SET APCLSET=";"_$PIECE(%,U,3)
+2 WRITE "Do you want to sort by a particular ",APCLSNA
+3 SET %=2
DO YN^DICN
+4 IF %Y=U
SET APCLQUIT=""
QUIT
+5 IF "Nn"[$EXTRACT(%Y)
QUIT
+6 DO SL
+7 IF %Y?1."?"
GOTO SS
SSG WRITE !!,"Your choice: "
READ X:DTIME
IF '$TEST
SET APCLQUIT=""
QUIT
+1 IF X=U
SET APCLQUIT=""
QUIT
+2 IF X=""
QUIT
+3 IF X?1."?"
WRITE !,"Type either the code or the text of the item you wish to select",!!
GOTO SSG
+4 SET %=APCLSET
SET Y=$FIND(%,(";"_X))
+5 IF Y
SET Z=$EXTRACT(%,Y,99)
SET Z=$PIECE(Z,":",2)
SET Z=$PIECE(Z,";")
SET $PIECE(FR,",",APCLN)=Z
SET $PIECE(TO,",",APCLN)=Z
WRITE " = ",Z
QUIT
+6 FOR I=2:1
SET Z=$PIECE(%,":",I)
IF Z=""
QUIT
IF $EXTRACT(Z,1,$LENGTH(X))=X
SET Z=$PIECE(Z,";")
SET $PIECE(FR,",",APCLN)=Z
SET $PIECE(TO,",",APCLN)=Z
WRITE $EXTRACT(Z,$LENGTH(X)+1,99)
QUIT
+7 IF Z=""
WRITE " ??",$CHAR(7)
GOTO SSG
+8 QUIT
+9 ;
SL WRITE !!,"You may select one of the following choices",!
+1 FOR I=2:1
SET %=$PIECE(APCLSET,";",I)
IF %=""
QUIT
SET X=$PIECE(%,":")
SET Y=$PIECE(%,":",2)
WRITE !?5,X," = ",Y
+2 QUIT
+3 ;
SP WRITE !!
+1 SET DIC=U_$PIECE(^APCLSRT(APCLSNO,0),U,7)
+2 WRITE "Do you want to sort by a particular ",APCLSNA
+3 SET %=2
DO YN^DICN
+4 IF %Y=U
SET APCLQUIT=""
QUIT
+5 IF "Nn"[$EXTRACT(%Y)
QUIT
SPQ SET DIC("A")="Which "_APCLSNA_": "
+1 IF $DATA(APCLDM)
IF DIC["41,"
SET DIC("S")="I $P(^APCL(41,+Y,0),U)=APCLRG"
+2 SET DIC(0)="AEMQ"
+3 DO DIC
KILL APCLDIC1
+4 IF X=U
SET APCLQUIT=""
QUIT
+5 IF X=""
QUIT
SPQ1 IF BY["["
GOTO SPQ11
+1 NEW X,Z,%
SET X=$LENGTH(BY,",")
SET %=$PIECE(BY,",",X)
+2 IF %=""
QUIT
+3 IF %'[";"
SET BY=BY_":NUMBER="_+Y
QUIT
+4 SET Z=$PIECE(%,";")
+5 SET $PIECE(%,";")=Z_":NUMBER="_+Y
+6 SET $PIECE(BY,",",X)=%
+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 ",APCLSNA
+2 SET %=2
DO YN^DICN
+3 IF %Y=U
SET APCLQUIT=""
QUIT
+4 IF "Nn"[$EXTRACT(%Y)
QUIT
SFQ SET DIC("A")="Which "_APCLSNA_": "
+1 SET DIC(0)="AEMQZ"
SET DIC=APCLDIC
+2 IF APCLSNA["CURRENT COMMUNITY"
SET DIC="^AUTTCOM("
+3 DO DIC
+4 IF X=U
SET APCLQUIT=""
QUIT
+5 IF X=""
QUIT
+6 IF FR=""
SET FR=Y(0,0)
+7 IF '$TEST
SET FR=FR_","_Y(0,0)
+8 IF TO=""
SET TO=Y(0,0)_"z"
+9 IF '$TEST
SET TO=TO_","_Y(0,0)_"z"
+10 QUIT
DIC WRITE !
DO ^DIC
KILL DIC
QUIT
