- AMQQATR2 ; IHS/CMI/THL - DSO FOR TAX ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;-----
- I '$D(AMQQHIDE) W !,"Computing Search Efficiency Rating...."
- S Q=AMQQQ
- S S=^AMQQ(1,+Q,3)
- K AMQQOK
- S %=$P(Q,U,9)
- I $P(%,";",5)="ANY" S AMQQSER=-1 G EXIT
- S AMQQSERF="^AUPNPAT"
- S AMQQDSCF=1
- I $P(^AMQQ(1,+Q,0),U,12) S AMQQDSCF=$P(^(0),U,12)
- I AMQQCCLS="V" D VISIT
- I AMQQCCLS="H" D PROV
- S AMQQTAX=$P(Q,U,17)
- S %=$P(Q,U,9)
- S N=9999999.999999
- S X=N-$P(%,";",2)
- S AMQQD1=X-.0000001
- S AMQQD2=N-(+%)
- S AMQQTDFN=1
- S AMQQENUM=0
- S X=$P(@AMQQSERF@(0),U,4)
- S AMQQEINC=$S(X<50:0,1:(X\50))
- S AMQQECNT=0
- SAMPLE F AMQQEDEN=0:1 S AMQQTDFN=$O(@AMQQSERF@(AMQQTDFN)) Q:AMQQTDFN'=+AMQQTDFN S AMQQECMP=$G(AMQQECMP) X S S AMQQTDFN=AMQQTDFN+AMQQEINC,AMQQECNT=AMQQECNT+1 W:'$D(AMQQHIDE) "." I AMQQECNT>50 Q
- SER S X=AMQQENUM/AMQQEDEN
- I X=0 S X=.01
- I $D(^UTILITY("AMQQ TAX",$J,AMQQURGN,"NULL")) S X=1-X G SETSER
- S X=(1-X)/$S($P(^AMQQ(1,+Q,0),U,8):X,1:1)
- S X=X/AMQQDSCF
- SETSER S X=$J(X,1,2)
- I $P(AMQQQ,U,3)="G",+AMQQQ>689.9999,+AMQQQ<706 S X=X_":900" G SS1
- SS1 S AMQQSER=X
- S $P(AMQQQ,U,11)=X
- EXIT K AMQQTAX,AMQQTPFN,%,X,Y,Z,A,B,C,D,N,I,AMQQD1,AMQQD2,AMQQTDFN,S,AMQQDSCF,AMQQENUM,AMQQEDEN,AMQQEINC,AMQQECNT,AMQQETGB,AMQQETAX,AMQQSERF
- Q
- ;
- MTEST F X=AMQQD1:0 S X=$O(@AMQQETGB@(X)) Q:'X Q:X>AMQQD2 F AMQQTPFN=0:0 S AMQQTPFN=$O(@AMQQETGB@(X,AMQQTPFN)) Q:'AMQQTPFN I (($D(^UTILITY("AMQQ TAX",$J,AMQQURGN,+$G(@AMQQETAX)))=10)+($P(Q,U,18)=3))=1 S AMQQENUM=AMQQENUM+1 G MEXIT
- MEXIT Q
- ;
- TTEST I $D(^UTILITY("AMQQ TAX",$J,AMQQURGN,"*")),AMQQETGB'="" S AMQQENUM=AMQQENUM+1 Q
- I $D(^UTILITY("AMQQ TAX",$J,AMQQURGN,"-")),AMQQETGB="" S AMQQENUM=AMQQENUM+1 Q
- I AMQQETGB'="",$D(^UTILITY("AMQQ TAX",$J,AMQQURGN,AMQQETGB)),'$D(^("--")) S AMQQENUM=AMQQENUM+1 Q
- I '$D(^UTILITY("AMQQ TAX",$J,AMQQURGN,"--")) Q
- I AMQQETGB="" S AMQQENUM=AMQQENUM+1 Q
- I AMQQETGB'="",'$D(^UTILITY("AMQQ TAX",$J,AMQQURGN,AMQQETGB)) S AMQQENUM=AMQQENUM+1
- Q
- ;
- VFILE ; ENTRY POINT FROM AMMQATR1
- D VSET
- RINCI S I=I+1
- W:'$D(AMQQHIDE) "."
- I I>50 G RSET
- S B=B+A
- S B=$O(@G@(B))
- G RSET:'B
- S D=0
- RINCD S D=$O(@G@(B,D))
- G RINCI:'D
- S C=-999999999
- RINCC S C=$O(@G@(B,D,C))
- G RINCD:'C
- S R=$P(@F@(C,S),U,T)
- I $D(AMQQLTR) X AMQQLTR S Y=AMQQLTB1_AMQQLTR1,Z=AMQQLTB2_AMQQLTR2
- I $D(AMQQRTXT) X AMQQRTXT G INCJ
- I Z="" S %="I R"_Y X % G INCJ
- S %="I R"_Y_",R"_Z
- X %
- INCJ I S J=J+1 G RINCI
- G RINCC
- RSET S:'K K=1
- S %=(J/I)
- S:'% %=.01
- S %=(1-%)/(%*K)
- S %=$J(%,1,2)
- S AMQQSER=%
- REXIT K %,A,B,C,D,E,F,G,H,I,J,K,M,N,P,R,S,T
- Q
- ;
- VSET S %=^AMQQ(1,+AMQQQ,0)
- S F=U_$P(%,U,10)
- S G=F_"(""AA"")"
- S P=$P(^DPT(0),U,4)
- S (B,I,J)=0
- S A=(P\50)+(P<50)
- S S=$P(%,U,11)
- S T=$P(S,";",2)
- S S=+S
- S K=$P(%,U,12)
- S %=$P(AMQQQ,U,9)
- S Y=$P(%,";",4)
- S Y=$P(Y,":")_$P(Y,":",2)
- S Z=$P(%,";",5)
- S Z=$P(Z,":")_$P(Z,":",2)
- Q
- ;
- VISIT N %,X,Y
- S AMQQSERF="^AUPNVSIT"
- S %=^AMQQ(1,+Q,0)
- S %=$P(%,U,3)
- I %=9000010 Q
- S %=^DIC(%,0,"GL")
- S X=$E(%,$L(%))
- S Y=$E(%,1,$L(%)-1)
- S AMQQSERF=Y_$S(X=",":")",1:"")
- S X=$P(^AUPNVSIT(0),U,4)
- S Y=$P(@AMQQSERF@(0),U,4)
- I X,Y S AMQQDSCF=(X/Y)*AMQQDSCF
- Q
- ;
- PROV S AMQQSERF=AMQQ200(6)
- Q
- ;
- AMQQATR2 ; IHS/CMI/THL - DSO FOR TAX ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 ;-----
- +3 IF '$DATA(AMQQHIDE)
- WRITE !,"Computing Search Efficiency Rating...."
- +4 SET Q=AMQQQ
- +5 SET S=^AMQQ(1,+Q,3)
- +6 KILL AMQQOK
- +7 SET %=$PIECE(Q,U,9)
- +8 IF $PIECE(%,";",5)="ANY"
- SET AMQQSER=-1
- GOTO EXIT
- +9 SET AMQQSERF="^AUPNPAT"
- +10 SET AMQQDSCF=1
- +11 IF $PIECE(^AMQQ(1,+Q,0),U,12)
- SET AMQQDSCF=$PIECE(^(0),U,12)
- +12 IF AMQQCCLS="V"
- DO VISIT
- +13 IF AMQQCCLS="H"
- DO PROV
- +14 SET AMQQTAX=$PIECE(Q,U,17)
- +15 SET %=$PIECE(Q,U,9)
- +16 SET N=9999999.999999
- +17 SET X=N-$PIECE(%,";",2)
- +18 SET AMQQD1=X-.0000001
- +19 SET AMQQD2=N-(+%)
- +20 SET AMQQTDFN=1
- +21 SET AMQQENUM=0
- +22 SET X=$PIECE(@AMQQSERF@(0),U,4)
- +23 SET AMQQEINC=$SELECT(X<50:0,1:(X\50))
- +24 SET AMQQECNT=0
- SAMPLE FOR AMQQEDEN=0:1
- SET AMQQTDFN=$ORDER(@AMQQSERF@(AMQQTDFN))
- IF AMQQTDFN'=+AMQQTDFN
- QUIT
- SET AMQQECMP=$GET(AMQQECMP)
- XECUTE S
- SET AMQQTDFN=AMQQTDFN+AMQQEINC
- SET AMQQECNT=AMQQECNT+1
- IF '$DATA(AMQQHIDE)
- WRITE "."
- IF AMQQECNT>50
- QUIT
- SER SET X=AMQQENUM/AMQQEDEN
- +1 IF X=0
- SET X=.01
- +2 IF $DATA(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,"NULL"))
- SET X=1-X
- GOTO SETSER
- +3 SET X=(1-X)/$SELECT($PIECE(^AMQQ(1,+Q,0),U,8):X,1:1)
- +4 SET X=X/AMQQDSCF
- SETSER SET X=$JUSTIFY(X,1,2)
- +1 IF $PIECE(AMQQQ,U,3)="G"
- IF +AMQQQ>689.9999
- IF +AMQQQ<706
- SET X=X_":900"
- GOTO SS1
- SS1 SET AMQQSER=X
- +1 SET $PIECE(AMQQQ,U,11)=X
- EXIT KILL AMQQTAX,AMQQTPFN,%,X,Y,Z,A,B,C,D,N,I,AMQQD1,AMQQD2,AMQQTDFN,S,AMQQDSCF,AMQQENUM,AMQQEDEN,AMQQEINC,AMQQECNT,AMQQETGB,AMQQETAX,AMQQSERF
- +1 QUIT
- +2 ;
- MTEST FOR X=AMQQD1:0
- SET X=$ORDER(@AMQQETGB@(X))
- IF 'X
- QUIT
- IF X>AMQQD2
- QUIT
- FOR AMQQTPFN=0:0
- SET AMQQTPFN=$ORDER(@AMQQETGB@(X,AMQQTPFN))
- IF 'AMQQTPFN
- QUIT
- IF (($DATA(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,+$GET(@AMQQETAX)))=10)+($PIECE(Q,U,18)=3))=1
- SET AMQQENUM=AMQQENUM+1
- GOTO MEXIT
- MEXIT QUIT
- +1 ;
- TTEST IF $DATA(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,"*"))
- IF AMQQETGB'=""
- SET AMQQENUM=AMQQENUM+1
- QUIT
- +1 IF $DATA(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,"-"))
- IF AMQQETGB=""
- SET AMQQENUM=AMQQENUM+1
- QUIT
- +2 IF AMQQETGB'=""
- IF $DATA(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,AMQQETGB))
- IF '$DATA(^("--"))
- SET AMQQENUM=AMQQENUM+1
- QUIT
- +3 IF '$DATA(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,"--"))
- QUIT
- +4 IF AMQQETGB=""
- SET AMQQENUM=AMQQENUM+1
- QUIT
- +5 IF AMQQETGB'=""
- IF '$DATA(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,AMQQETGB))
- SET AMQQENUM=AMQQENUM+1
- +6 QUIT
- +7 ;
- VFILE ; ENTRY POINT FROM AMMQATR1
- +1 DO VSET
- RINCI SET I=I+1
- +1 IF '$DATA(AMQQHIDE)
- WRITE "."
- +2 IF I>50
- GOTO RSET
- +3 SET B=B+A
- +4 SET B=$ORDER(@G@(B))
- +5 IF 'B
- GOTO RSET
- +6 SET D=0
- RINCD SET D=$ORDER(@G@(B,D))
- +1 IF 'D
- GOTO RINCI
- +2 SET C=-999999999
- RINCC SET C=$ORDER(@G@(B,D,C))
- +1 IF 'C
- GOTO RINCD
- +2 SET R=$PIECE(@F@(C,S),U,T)
- +3 IF $DATA(AMQQLTR)
- XECUTE AMQQLTR
- SET Y=AMQQLTB1_AMQQLTR1
- SET Z=AMQQLTB2_AMQQLTR2
- +4 IF $DATA(AMQQRTXT)
- XECUTE AMQQRTXT
- GOTO INCJ
- +5 IF Z=""
- SET %="I R"_Y
- XECUTE %
- GOTO INCJ
- +6 SET %="I R"_Y_",R"_Z
- +7 XECUTE %
- INCJ IF $TEST
- SET J=J+1
- GOTO RINCI
- +1 GOTO RINCC
- RSET IF 'K
- SET K=1
- +1 SET %=(J/I)
- +2 IF '%
- SET %=.01
- +3 SET %=(1-%)/(%*K)
- +4 SET %=$JUSTIFY(%,1,2)
- +5 SET AMQQSER=%
- REXIT KILL %,A,B,C,D,E,F,G,H,I,J,K,M,N,P,R,S,T
- +1 QUIT
- +2 ;
- VSET SET %=^AMQQ(1,+AMQQQ,0)
- +1 SET F=U_$PIECE(%,U,10)
- +2 SET G=F_"(""AA"")"
- +3 SET P=$PIECE(^DPT(0),U,4)
- +4 SET (B,I,J)=0
- +5 SET A=(P\50)+(P<50)
- +6 SET S=$PIECE(%,U,11)
- +7 SET T=$PIECE(S,";",2)
- +8 SET S=+S
- +9 SET K=$PIECE(%,U,12)
- +10 SET %=$PIECE(AMQQQ,U,9)
- +11 SET Y=$PIECE(%,";",4)
- +12 SET Y=$PIECE(Y,":")_$PIECE(Y,":",2)
- +13 SET Z=$PIECE(%,";",5)
- +14 SET Z=$PIECE(Z,":")_$PIECE(Z,":",2)
- +15 QUIT
- +16 ;
- VISIT NEW %,X,Y
- +1 SET AMQQSERF="^AUPNVSIT"
- +2 SET %=^AMQQ(1,+Q,0)
- +3 SET %=$PIECE(%,U,3)
- +4 IF %=9000010
- QUIT
- +5 SET %=^DIC(%,0,"GL")
- +6 SET X=$EXTRACT(%,$LENGTH(%))
- +7 SET Y=$EXTRACT(%,1,$LENGTH(%)-1)
- +8 SET AMQQSERF=Y_$SELECT(X=",":")",1:"")
- +9 SET X=$PIECE(^AUPNVSIT(0),U,4)
- +10 SET Y=$PIECE(@AMQQSERF@(0),U,4)
- +11 IF X
- IF Y
- SET AMQQDSCF=(X/Y)*AMQQDSCF
- +12 QUIT
- +13 ;
- PROV SET AMQQSERF=AMQQ200(6)
- +1 QUIT
- +2 ;
