- AMQQATS1 ; IHS/CMI/THL - SETS MULTIPLES ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;-----
- MULT S %=$P(Q,U,9)
- I $P(%,";",6) S %=$P(%,";",1,5),AMQQSQNL="" S:$P(%,";",5)="" %=$P(%,";",1,4) S $P(Q,U,9)=%,AMQQQ=Q
- I $P(Q,U,3)="E"!($P(Q,U,3)="V") D BP Q
- F I=1,2,3,6,7 S AMQQF(I)=$P(%,";",I)
- I $P(Q,U,3)="I" S AMQQF(4)=$P(%,";",4),AMQQF(5)="" S:$P(%,";",5)="ANY" AMQQF(5)="ANY",AMQQF(4)=AMQQF(4)_"~~ANY" G MY ; &&& FIXES IMMUNIZATION ANY BUG
- I $P(Q,U,3)="F" S AMQQF(4)="'[",AMQQF(5)="```" D:$P(%,";",4)[":" TEXT G MY
- I $P(Q,U,3)="S" S AMQQF(4)=$P($P(%,";",4),":"),AMQQF(5)=$P($P(%,";",4),":",2) G MY
- I "QZ"'[$P(Q,U,3) S X=$P(%,":",2) I X'="",X'=+X D TEXT G MY
- I $P(Q,U,16)>1,AMQQF(2)>9990000 S AMQQF(2)=AMQQF(1)+.0000001,AMQQF(1)=0 G MX
- I $P(Q,U,16)>1,AMQQF(1)<1 S AMQQF(1)=AMQQF(2)-.0000001,AMQQF(2)=9999999
- I AMQQF(1)>0,AMQQF(2)<9990000 S:AMQQF(1)=AMQQF(2) AMQQF(2)=AMQQF(2)+.2359 S AMQQF(1)=AMQQF(1)-.76
- MX I $P(Q,U,3)="Z" D ZERO G MY
- I $P(Q,U,3)="Q" D QUAL G MY
- I $P(Q,U,17) S %=$P(Q,U,9) F I=1:1:5 S:'$D(AMQQF(I)) AMQQF(I)=$P(%,";",I) I I=5 G MY
- MZ D RANGE
- S AMQQF(4)=$P(X,":")
- S AMQQF(5)=$P(X,":",2)
- MY S %="0^9999999^9999999^-999999999^999999999^"_AMQQUATN_U_$D(AMQQMULT)
- F I=1:1:7 I AMQQF(I)="" S AMQQF(I)=$P(%,U,I)
- I $D(AMQQSQNL)!($D(^UTILITY("AMQQ",$J,"SQ",+$G(AMQQUSQN),"NULL"))&$D(AMQQFSQN))!$D(AMQQFSQX) K AMQQFSQX,AMQQSQNL,AMQQFSQN S %=$P(Q,U,9),$P(%,";",6)="NULL",$P(Q,U,9)=%
- Q
- ;
- ZERO S X=$P(%,";",4)
- I $P(X,":",4)'="",$P(Q,U,8)="'" S Y=$P(X,":",2) D ZTR S AMQQF(5)=Y S Y=$P(X,":",4) D ZTR S AMQQF(4)=Y Q
- I $P(X,":",4)'="" S Y=$P(X,":",2) D ZTR S Y=Y-.1,AMQQF(4)=Y S Y=$P(X,":",4) D ZTR S AMQQF(5)=Y Q
- S Y=$P(X,":",2)
- D ZTR
- S X=$P(X,":")
- I X=">" S AMQQF(4)=Y+.01,AMQQF(5)=9 Q
- I X="<" S AMQQF(4)=-1,AMQQF(5)=Y-.01 Q
- I X="=" S AMQQF(4)=Y,AMQQF(5)=Y Q
- I X="'>" S AMQQF(4)=-1,AMQQF(5)=Y Q
- I X="'<" S AMQQF(4)=Y,AMQQF(5)=9 Q
- I X="'=" S AMQQF(4)=Y+.01,AMQQF(5)=Y-.01 Q
- S AMQQF(4)=-1
- S AMQQF(5)=5
- Q
- ;
- ZTR S Y=$E(Y)
- S Y=$S(Y="N":0,Y="T":1,1:(Y+1))
- Q
- ;
- QUAL I %="" S AMQQF(4)=-1,AMQQF(5)=2 Q
- S X=$P(%,";",4)
- I X="=:POS"!(X="'=:NEG") S AMQQF(4)=1,AMQQF(5)=1 Q
- I X="=:NEG"!(X="'=:POS") S AMQQF(4)=0,AMQQF(5)=0 Q
- S AMQQF(4)=""
- S AMQQF(5)=""
- Q
- ;
- RANGE S %=$P(AMQQCOMP,";",4)
- S Y=$P(%,":")
- S Z=$P(%,":",2)
- S N=.00000001
- I $P(%,":",4),$P(Q,U,16) S X=$P(%,":",4)_":"_Z Q
- I $L(Y)=1,"[]?="[Y S X=Y_":"_Z I Z'=+Z S X="=:"_Z
- I Y="=" S X=Z_":"_Z Q
- I Y="'=" S X=(Z+N)_":"_(Z-N) Q
- I $P(%,":",4) S X=(Z-N)_":"_($P(%,":",4)+.00000001) Q
- S X=-999999999
- I Y="<" S X=X_":"_(Z-N) Q
- I Y="'>" S X=X_":"_Z Q
- S X=999999999
- I Y=">" S X=Z_":"_X Q
- S X=(Z-N)_":"_X
- Q
- ;
- TEXT S Y=$P(%,";",4)
- S AMQQF(4)=$P(Y,":",1)_":"_$P(Y,":",3)
- S AMQQF(5)=$P(Y,":",2)_":"_$P(Y,":",4)
- Q
- ;
- BP N AMQQCOMP
- I %'["~" S (AMQQCOMP,AMQQCOM2)=">:0",AMQQBOOL="!",AMQQCOMP=%_";>:0;>:0"
- E S AMQQCOMP=$P(%,"~"),AMQQCOM2=$P(%,"~",2),AMQQBOOL=$P(%,"~",3)
- S AMQQF(6)=$S($D(AMQQ("BP COHORT FLG")):"",1:2)
- F I=1:1:5,7 S AMQQF(I)=$P(AMQQCOMP,";",I)
- D MZ
- S AMQQF=""
- F I=1:1:7 S AMQQF=AMQQF_AMQQF(I)_U
- S AMQQF=AMQQF_AMQQBOOL
- S AMQQCOMP=";;;"_AMQQCOM2
- D MZ
- S AMQQF=AMQQF_U_AMQQF(4)_U_AMQQF(5)
- F I=1:1:10 S AMQQF(I)=$P(AMQQF,U,I)
- K AMQQBOOL,AMQQCOM2
- Q
- ;
- AMQQATS1 ; IHS/CMI/THL - SETS MULTIPLES ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 ;-----
- MULT SET %=$PIECE(Q,U,9)
- +1 IF $PIECE(%,";",6)
- SET %=$PIECE(%,";",1,5)
- SET AMQQSQNL=""
- IF $PIECE(%,";",5)=""
- SET %=$PIECE(%,";",1,4)
- SET $PIECE(Q,U,9)=%
- SET AMQQQ=Q
- +2 IF $PIECE(Q,U,3)="E"!($PIECE(Q,U,3)="V")
- DO BP
- QUIT
- +3 FOR I=1,2,3,6,7
- SET AMQQF(I)=$PIECE(%,";",I)
- +4 ; &&& FIXES IMMUNIZATION ANY BUG
- IF $PIECE(Q,U,3)="I"
- SET AMQQF(4)=$PIECE(%,";",4)
- SET AMQQF(5)=""
- IF $PIECE(%,";",5)="ANY"
- SET AMQQF(5)="ANY"
- SET AMQQF(4)=AMQQF(4)_"~~ANY"
- GOTO MY
- +5 IF $PIECE(Q,U,3)="F"
- SET AMQQF(4)="'["
- SET AMQQF(5)="```"
- IF $PIECE(%,";",4)["
- DO TEXT
- GOTO MY
- +6 IF $PIECE(Q,U,3)="S"
- SET AMQQF(4)=$PIECE($PIECE(%,";",4),":")
- SET AMQQF(5)=$PIECE($PIECE(%,";",4),":",2)
- GOTO MY
- +7 IF "QZ"'[$PIECE(Q,U,3)
- SET X=$PIECE(%,":",2)
- IF X'=""
- IF X'=+X
- DO TEXT
- GOTO MY
- +8 IF $PIECE(Q,U,16)>1
- IF AMQQF(2)>9990000
- SET AMQQF(2)=AMQQF(1)+.0000001
- SET AMQQF(1)=0
- GOTO MX
- +9 IF $PIECE(Q,U,16)>1
- IF AMQQF(1)<1
- SET AMQQF(1)=AMQQF(2)-.0000001
- SET AMQQF(2)=9999999
- +10 IF AMQQF(1)>0
- IF AMQQF(2)<9990000
- IF AMQQF(1)=AMQQF(2)
- SET AMQQF(2)=AMQQF(2)+.2359
- SET AMQQF(1)=AMQQF(1)-.76
- MX IF $PIECE(Q,U,3)="Z"
- DO ZERO
- GOTO MY
- +1 IF $PIECE(Q,U,3)="Q"
- DO QUAL
- GOTO MY
- +2 IF $PIECE(Q,U,17)
- SET %=$PIECE(Q,U,9)
- FOR I=1:1:5
- IF '$DATA(AMQQF(I))
- SET AMQQF(I)=$PIECE(%,";",I)
- IF I=5
- GOTO MY
- MZ DO RANGE
- +1 SET AMQQF(4)=$PIECE(X,":")
- +2 SET AMQQF(5)=$PIECE(X,":",2)
- MY SET %="0^9999999^9999999^-999999999^999999999^"_AMQQUATN_U_$DATA(AMQQMULT)
- +1 FOR I=1:1:7
- IF AMQQF(I)=""
- SET AMQQF(I)=$PIECE(%,U,I)
- +2 IF $DATA(AMQQSQNL)!($DATA(^UTILITY("AMQQ",$JOB,"SQ",+$GET(AMQQUSQN),"NULL"))&$DATA(AMQQFSQN))!$DATA(AMQQFSQX)
- KILL AMQQFSQX,AMQQSQNL,AMQQFSQN
- SET %=$PIECE(Q,U,9)
- SET $PIECE(%,";",6)="NULL"
- SET $PIECE(Q,U,9)=%
- +3 QUIT
- +4 ;
- ZERO SET X=$PIECE(%,";",4)
- +1 IF $PIECE(X,":",4)'=""
- IF $PIECE(Q,U,8)="'"
- SET Y=$PIECE(X,":",2)
- DO ZTR
- SET AMQQF(5)=Y
- SET Y=$PIECE(X,":",4)
- DO ZTR
- SET AMQQF(4)=Y
- QUIT
- +2 IF $PIECE(X,":",4)'=""
- SET Y=$PIECE(X,":",2)
- DO ZTR
- SET Y=Y-.1
- SET AMQQF(4)=Y
- SET Y=$PIECE(X,":",4)
- DO ZTR
- SET AMQQF(5)=Y
- QUIT
- +3 SET Y=$PIECE(X,":",2)
- +4 DO ZTR
- +5 SET X=$PIECE(X,":")
- +6 IF X=">"
- SET AMQQF(4)=Y+.01
- SET AMQQF(5)=9
- QUIT
- +7 IF X="<"
- SET AMQQF(4)=-1
- SET AMQQF(5)=Y-.01
- QUIT
- +8 IF X="="
- SET AMQQF(4)=Y
- SET AMQQF(5)=Y
- QUIT
- +9 IF X="'>"
- SET AMQQF(4)=-1
- SET AMQQF(5)=Y
- QUIT
- +10 IF X="'<"
- SET AMQQF(4)=Y
- SET AMQQF(5)=9
- QUIT
- +11 IF X="'="
- SET AMQQF(4)=Y+.01
- SET AMQQF(5)=Y-.01
- QUIT
- +12 SET AMQQF(4)=-1
- +13 SET AMQQF(5)=5
- +14 QUIT
- +15 ;
- ZTR SET Y=$EXTRACT(Y)
- +1 SET Y=$SELECT(Y="N":0,Y="T":1,1:(Y+1))
- +2 QUIT
- +3 ;
- QUAL IF %=""
- SET AMQQF(4)=-1
- SET AMQQF(5)=2
- QUIT
- +1 SET X=$PIECE(%,";",4)
- +2 IF X="=:POS"!(X="'=:NEG")
- SET AMQQF(4)=1
- SET AMQQF(5)=1
- QUIT
- +3 IF X="=:NEG"!(X="'=:POS")
- SET AMQQF(4)=0
- SET AMQQF(5)=0
- QUIT
- +4 SET AMQQF(4)=""
- +5 SET AMQQF(5)=""
- +6 QUIT
- +7 ;
- RANGE SET %=$PIECE(AMQQCOMP,";",4)
- +1 SET Y=$PIECE(%,":")
- +2 SET Z=$PIECE(%,":",2)
- +3 SET N=.00000001
- +4 IF $PIECE(%,":",4)
- IF $PIECE(Q,U,16)
- SET X=$PIECE(%,":",4)_":"_Z
- QUIT
- +5 IF $LENGTH(Y)=1
- IF "[]?="[Y
- SET X=Y_":"_Z
- IF Z'=+Z
- SET X="=:"_Z
- +6 IF Y="="
- SET X=Z_":"_Z
- QUIT
- +7 IF Y="'="
- SET X=(Z+N)_":"_(Z-N)
- QUIT
- +8 IF $PIECE(%,":",4)
- SET X=(Z-N)_":"_($PIECE(%,":",4)+.00000001)
- QUIT
- +9 SET X=-999999999
- +10 IF Y="<"
- SET X=X_":"_(Z-N)
- QUIT
- +11 IF Y="'>"
- SET X=X_":"_Z
- QUIT
- +12 SET X=999999999
- +13 IF Y=">"
- SET X=Z_":"_X
- QUIT
- +14 SET X=(Z-N)_":"_X
- +15 QUIT
- +16 ;
- TEXT SET Y=$PIECE(%,";",4)
- +1 SET AMQQF(4)=$PIECE(Y,":",1)_":"_$PIECE(Y,":",3)
- +2 SET AMQQF(5)=$PIECE(Y,":",2)_":"_$PIECE(Y,":",4)
- +3 QUIT
- +4 ;
- BP NEW AMQQCOMP
- +1 IF %'["~"
- SET (AMQQCOMP,AMQQCOM2)=">:0"
- SET AMQQBOOL="!"
- SET AMQQCOMP=%_";>:0;>:0"
- +2 IF '$TEST
- SET AMQQCOMP=$PIECE(%,"~")
- SET AMQQCOM2=$PIECE(%,"~",2)
- SET AMQQBOOL=$PIECE(%,"~",3)
- +3 SET AMQQF(6)=$SELECT($DATA(AMQQ("BP COHORT FLG")):"",1:2)
- +4 FOR I=1:1:5,7
- SET AMQQF(I)=$PIECE(AMQQCOMP,";",I)
- +5 DO MZ
- +6 SET AMQQF=""
- +7 FOR I=1:1:7
- SET AMQQF=AMQQF_AMQQF(I)_U
- +8 SET AMQQF=AMQQF_AMQQBOOL
- +9 SET AMQQCOMP=";;;"_AMQQCOM2
- +10 DO MZ
- +11 SET AMQQF=AMQQF_U_AMQQF(4)_U_AMQQF(5)
- +12 FOR I=1:1:10
- SET AMQQF(I)=$PIECE(AMQQF,U,I)
- +13 KILL AMQQBOOL,AMQQCOM2
- +14 QUIT
- +15 ;
