- 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
