- AMQQN1 ; IHS/CMI/THL - NATL LANGUAGE PRELIMINARY PASS ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;-----
- RUN D SUBJ
- W $C(13),?79,$C(13)
- I '$D(AMQQFAIL),$D(AMQQNSBJ),$D(AMQQFEN2) W !!,"Sorry...You cannot change the subject of your search",!!,*7 H 3 S AMQQQUIT="",AMQQFAIL=-1 G EXIT
- I '$D(AMQQNSBJ),$D(AMQQSAUT),'$D(AMQQFAIL) I $L(AMQQSAUT,U)>3 S (AMQQNSBJ,Y)=AMQQSAUT D AUTO1^AMQQ1
- I $D(AMQQQUIT) G EXIT
- I '$D(AMQQNSBJ) S AMQQFAIL=4 G EXIT
- S AMQQSAUT=AMQQNSBJ
- S AMQQCCLS="P"
- EXIT ;
- Q
- ;
- SUBJ S %="LIVING PATIENTS^PATIENTS^INFANTS^FEMALES^MALES^BOYS^GIRLS^MEN^WOMEN"
- F I=1:1 S A=$P(%,U,I) Q:A="" I X[A D PAT G SUBEXIT
- I X'["OF " G SUBJ1
- F Y=1:1 S Z=$P(X," ",Y) I Z="OF" Q
- I $P(X," ",Y+3)'="" S Z=$P(X," ",Y+1,Y+3) D SB1 I $D(AMQQNSBJ) D SB2 Q
- I $P(X," ",Y+2)'="" S Z=$P(X," ",Y+1,Y+2) D SB1 I $D(AMQQNSBJ) D SB2 Q
- SUBJ1 I X'["'S",X'["S'" Q
- F Y=1:1 S Z=$P(X," ",Y) I Z["S'"!(Z["'S") Q
- I Y>2 S Z=$P(X," ",Y-2,Y) D SB1 I $D(AMQQNSBJ) D SB2 Q
- S Z=$P(X," ",Y-1,Y) D SB1 I $D(AMQQNSBJ) D SB2
- Q
- ;
- SB1 S %=Z
- I %["'S" S %=$P(%,"'S")_$P(%,"'S",2) G SB10
- I %["S'" S %=$P(%,"S'")_"S"_$P(%,"S'",2)
- SB10 W !
- N X,Y,Z
- S X=%,AMQQXX=""
- D ^AMQQ2
- I '$D(Y) W:'$D(AMQQNECO) !!,"Sorry, I'm unable to determine the SUBJECT of the query...The search is aborted",!!,*7 S AMQQFAIL=1 Q
- S AMQQNSBJ=Y
- D AUTO1^AMQQ1
- SUBEXIT K %,A,Z
- Q
- ;
- SB2 S Z=Z_" "
- S X=$P(X,Z)_$P(X,Z,2,99)
- I X["OF " S X=$P(X,"OF ")
- Q
- ;
- PAT S X=$P(X,A)_" "_$P(X,A,2)
- F Q:X'[" " S X=$P(X," ")_" "_$P(X," ",2,99)
- I $E(X)=" " S X=$E(X,2,240)
- I X[" OF " S X=$P(X," OF ",1)_" "_$P(X," OF ",2,99)
- S AMQQNSBJ=A
- S AMQQCCLS="P"
- N X
- S X=A
- S AMQQXX=""
- D AUTO^AMQQ1
- Q
- ;
- AMQQN1 ; IHS/CMI/THL - NATL LANGUAGE PRELIMINARY PASS ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 ;-----
- RUN DO SUBJ
- +1 WRITE $CHAR(13),?79,$CHAR(13)
- +2 IF '$DATA(AMQQFAIL)
- IF $DATA(AMQQNSBJ)
- IF $DATA(AMQQFEN2)
- WRITE !!,"Sorry...You cannot change the subject of your search",!!,*7
- HANG 3
- SET AMQQQUIT=""
- SET AMQQFAIL=-1
- GOTO EXIT
- +3 IF '$DATA(AMQQNSBJ)
- IF $DATA(AMQQSAUT)
- IF '$DATA(AMQQFAIL)
- IF $LENGTH(AMQQSAUT,U)>3
- SET (AMQQNSBJ,Y)=AMQQSAUT
- DO AUTO1^AMQQ1
- +4 IF $DATA(AMQQQUIT)
- GOTO EXIT
- +5 IF '$DATA(AMQQNSBJ)
- SET AMQQFAIL=4
- GOTO EXIT
- +6 SET AMQQSAUT=AMQQNSBJ
- +7 SET AMQQCCLS="P"
- EXIT ;
- +1 QUIT
- +2 ;
- SUBJ SET %="LIVING PATIENTS^PATIENTS^INFANTS^FEMALES^MALES^BOYS^GIRLS^MEN^WOMEN"
- +1 FOR I=1:1
- SET A=$PIECE(%,U,I)
- IF A=""
- QUIT
- IF X[A
- DO PAT
- GOTO SUBEXIT
- +2 IF X'["OF "
- GOTO SUBJ1
- +3 FOR Y=1:1
- SET Z=$PIECE(X," ",Y)
- IF Z="OF"
- QUIT
- +4 IF $PIECE(X," ",Y+3)'=""
- SET Z=$PIECE(X," ",Y+1,Y+3)
- DO SB1
- IF $DATA(AMQQNSBJ)
- DO SB2
- QUIT
- +5 IF $PIECE(X," ",Y+2)'=""
- SET Z=$PIECE(X," ",Y+1,Y+2)
- DO SB1
- IF $DATA(AMQQNSBJ)
- DO SB2
- QUIT
- SUBJ1 IF X'["'S"
- IF X'["S'"
- QUIT
- +1 FOR Y=1:1
- SET Z=$PIECE(X," ",Y)
- IF Z["S'"!(Z["'S")
- QUIT
- +2 IF Y>2
- SET Z=$PIECE(X," ",Y-2,Y)
- DO SB1
- IF $DATA(AMQQNSBJ)
- DO SB2
- QUIT
- +3 SET Z=$PIECE(X," ",Y-1,Y)
- DO SB1
- IF $DATA(AMQQNSBJ)
- DO SB2
- +4 QUIT
- +5 ;
- SB1 SET %=Z
- +1 IF %["'S"
- SET %=$PIECE(%,"'S")_$PIECE(%,"'S",2)
- GOTO SB10
- +2 IF %["S'"
- SET %=$PIECE(%,"S'")_"S"_$PIECE(%,"S'",2)
- SB10 WRITE !
- +1 NEW X,Y,Z
- +2 SET X=%
- SET AMQQXX=""
- +3 DO ^AMQQ2
- +4 IF '$DATA(Y)
- IF '$DATA(AMQQNECO)
- WRITE !!,"Sorry, I'm unable to determine the SUBJECT of the query...The search is aborted",!!,*7
- SET AMQQFAIL=1
- QUIT
- +5 SET AMQQNSBJ=Y
- +6 DO AUTO1^AMQQ1
- SUBEXIT KILL %,A,Z
- +1 QUIT
- +2 ;
- SB2 SET Z=Z_" "
- +1 SET X=$PIECE(X,Z)_$PIECE(X,Z,2,99)
- +2 IF X["OF "
- SET X=$PIECE(X,"OF ")
- +3 QUIT
- +4 ;
- PAT SET X=$PIECE(X,A)_" "_$PIECE(X,A,2)
- +1 FOR
- IF X'[" "
- QUIT
- SET X=$PIECE(X," ")_" "_$PIECE(X," ",2,99)
- +2 IF $EXTRACT(X)=" "
- SET X=$EXTRACT(X,2,240)
- +3 IF X[" OF "
- SET X=$PIECE(X," OF ",1)_" "_$PIECE(X," OF ",2,99)
- +4 SET AMQQNSBJ=A
- +5 SET AMQQCCLS="P"
- +6 NEW X
- +7 SET X=A
- +8 SET AMQQXX=""
- +9 DO AUTO^AMQQ1
- +10 QUIT
- +11 ;
