51. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 11/9/2018 12:33:47 AM Central Standard Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

51.1 Files compared

# Location File Last Modified
1 CPEE_Build9_Sprint27.zip\HAC_CPE_CH CHICDAI.m Mon Nov 5 16:42:08 2018 UTC
2 CPEE_Build9_Sprint27.zip\HAC_CPE_CH CHICDAI.m Fri Nov 9 01:21:35 2018 UTC

51.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 3 3504
Changed 2 4
Inserted 0 0
Removed 0 0

51.3 Comparison options

Whitespace
Character case Differences in character case are significant
Line endings Differences in line endings (CR and LF characters) are ignored
CR/LF characters Not shown in the comparison detail

51.4 Active regular expressions

No regular expressions were active.

51.5 Comparison detail

  1   CHICDAI ;
  2    ;
  3    ;      CU RRENTPX                                           281               PCS
  4    ;      DI AGNOSES FO R CLAIM                       19                DX
  5    ;      OT HER PROCED URES SAME  DAY        74               PCS
  6    ;      PR OCEDURE                                           47                PCS
  7    ;      PR OCEDURES F OR CLAIM              15               PCS
  8    ;      CU RRENT NDC  CODE                          12 0              Neithe r
  9    ;   DIAGN OSIS PRIMA RY                    263              DX
  10    Q
  11    ;
  12   CNVT ;
  13    D SETUP
  14    ;R !,"Tes t IEN or n ame (RETUR N for ALL) : ",AIEN I  AIEN'=""  S:AIEN'?1. N AIEN=$O( @GLAZDIC@( 741100,"B" ,AIEN,""))  G:AIEN'=" "&$D(@GLAZ DIC@(74110 0,+AIEN))  ONEAI W !, "Not valid  " Q
  15    S AIEN=0  F  S AIEN= $O(@GLAZDI C@(741100, AIEN)) Q:' AIEN  D ON EAI
  16    W !,"****   The AI T est Conver sion has s uccessfull y complete d ****"
  17    I '$D(^DD (741100.00 4)) W !,"A I Test INC LUDE HISTO RY NOUNS i nitializat ion failed  since DD  table is n ot updated  yet" Q
  18    D HIST
  19    W !,"****  The AI Te st INCLUDE  HISTORY N OUNS multi ple has be en initial ized"
  20    Q
  21   ONEAI ;
  22    S U="^"
  23    K STATUSD
  24    I '$G(ACT IVE(AIEN))  Q
  25    S WHEAD=A IEN_" "_$P (@GLAZDIC@ (741100,AI EN,0),"^")
  26    S RIEN=0, TTR=0
  27    S MAX=1 ;  max numbe r of codes  we are no t replacin g with lis t
  28    F  S RIEN =$O(@GLAZD IC@(741100 ,AIEN,100, RIEN)) Q:' RIEN  D
  29    . S STATU S="AS-IS"
  30    . K AI M  AI=@GLAZDI C@(741100, AIEN,100,R IEN,100)
  31    . K NOUN, TAI,ICD10L  S TEIEN=0  
  32    . ; check  if any of  the affec ted nouns  are presen t and make  list
  33    . S TR=0
  34    . F EIEN= 1:1 Q:'$D( AI(EIEN))   D
  35    . . ; cla ssify elem ent as (1)  as is, (2 ) ICD10 or  (3) new l ist
  36    . . S ELT YP=1,NIEN= ""
  37    . . F NIE NZ=15,19,4 7,74,120,2 63,281,297 ,298,307,3 08 D  
  38    . . . Q:' $F(AI(EIEN ,1),"$n"_N IENZ_"^$o" )  S NIEN= NIENZ
  39    . . . S O PER=+$P(AI (EIEN,1)," $o",2),VAL =$TR($P(AI (EIEN,1)," ^$o"_OPER_ "^",2),""" ")
  40    . . . ; f ound in/no t found in  (remediat e list)
  41    . . . I O PER=8!(OPE R=9) D  Q
  42    . . . . K  VALLIST S  LISTIEN=$ P(VAL,"n", 2),L1=0
  43    . . . . S  LISTGL="^ "_$P(@GLAZ DIC@(74110 0.01,LISTI EN,1),"^", 6),EXPANDI NG=" expan ding list  "
  44    . . . . S  LISTSZ=$P ($G(@(LIST GL_"0)")), "^",4)
  45    . . . . F   S L1=$O( @(LISTGL_" L1)")) Q:' L1  D
  46    . . . . .  S ICD9=@( LISTGL_"L1 ,0)")
  47    . . . . .  S LISTCNT =$$EXICD9( NIEN,ICD9, .VALLIST,L ISTGL_"""B "")") 
  48    . . . . .  I LISTCNT >1 S STATU S="LIST "_ LISTIEN_"  EXPANDED"
  49    . . . . .  ;I LISTCN T>1 S EXPA N(AIEN,RIE N,1)=@GLAZ DIC@(74110 0.01,LISTI EN,0) I EX PANDING'=" " W !,PREF IX,EXPANDI NG,LISTIEN ," ",$P(@G LAZDIC@(74 1100.01,LI STIEN,0)," ^",3) S EX PANDING="" ,PREFIX=""
  50    . . . . .  ;W !,"ICD 9=",ICD9,"   LISTCNT= ",LISTCNT
  51    . . . . S  L1=0
  52    . . . . F   S L1=$O( @(LISTGL_" L1)")) Q:L 1=""  K @( LISTGL_"L1 )")
  53    . . . . F  L1=1:1:$G (VALLIST)  S @(LISTGL _"L1,0)")= VALLIST(L1 ) S @(LIST GL_"""B"", VALLIST(L1 ),L1)")=""
  54    . . . . S  $P(@(LIST GL_"0)")," ^",3,4)=$G (VALLIST)_ "^"_$G(VAL LIST) S:ST ATUS?1"LIS T "1.N1" E XPANDED".E  STATUS=ST ATUS_"  "_ LISTSZ_"-> "_$G(VALLI ST)
  55    . . . ; L T, GT, NLT , NGT, STA RTS, NOT S TARTS (<,  >, !<, !>)
  56    . . . I O PER=2!(OPE R=3)!(OPER =6)!(OPER= 7)!(OPER=1 0)!(OPER=1 1) Q
  57    . . . ; E Q, NEQ
  58    . . . I O PER'=1,OPE R'=5 W 1/0
  59    . . . ; n ot as is,  so check i f part of  ongoing li st or not
  60    . . . S E LTYP=2
  61    . . . ; n o ongoing  list so po tentially  start one
  62    . . . I ' TR S TR=NI EN_"^$o"_O PER S ELTY P=3,ORV=+$ P(AI(EIEN, 1),"$v",2)  Q
  63    . . . ;I  TR=(NIEN_" ^$o"_OPER)  W "." S T RCNT=TRCNT +1,NEWLIST (RIEN,$I(N EWLIST(RIE N)))=VAL,A TOL=1
  64    . . ; if  as is just  copy elem ent across
  65    . . I ELT YP=1 M TAI ($I(TEIEN) )=AI(EIEN)  S TAI(TEI EN,0)=TEIE N Q
  66    . . ; if  element is  potential ly part of  new list,  then ...
  67    . . I ELT YP=3 D  Q: ELTYP=3
  68    . . . K V ALLIST
  69    . . . S L ISTCNT=$$E XICD9(NIEN ,VAL,.VALL IST)
  70    . . . S E IEN1=EIEN, EIEN2=EIEN
  71    . . . F   S EIEN1=$O (AI(EIEN1) ) Q:'EIEN1   Q:'$F(AI (EIEN1,1), "$n"_TR)   S EIEN2=EI EN1,XX=$$E XICD9(NIEN ,$TR($P(AI (EIEN1,1), "^$o"_OPER _"^",2),"" ""),.VALLI ST),LISTCN T=LISTCNT+ XX
  72    . . . I L ISTCNT>MAX !((AIEN=34 8)&(RIEN=4 )) D  Q
  73    . . . . ;  commit to  list
  74    . . . . ;  check if  this list  exists and  can be ma tched on C RC
  75    . . . . S  LIEN=0,MA TCH=0,NEWC RC=0,MATCH L=0
  76    . . . . F  I=1:1:VAL LIST S NEW CRC=NEWCRC +$ZCRC(VAL LIST(I),7)
  77    . . . . ; W !,"NEWCR C=",NEWCRC
  78    . . . . F   S LIEN=$ O(@GLAZDIC @(741100.0 1,LIEN)) Q :'LIEN  D   Q:MATCH
  79    . . . . .  I $P($G(@ GLAZDIC@(7 41100.01,L IEN,1)),"^ ",6)="" Q
  80    . . . . .  ;W !,"Att empting to  match ",L IEN," ",@G LAZDIC@(74 1100.01,LI EN,0)," ", $$LISTCRC( LIEN)," ", NEWCRC
  81    . . . . .  I $$LISTC RC(LIEN)=N EWCRC S MA TCH=LIEN Q
  82    . . . . ; Per Gene's  request,  matching i s disabled  for these  tests
  83    . . . . I  AIEN=223  S MATCH=0, MATCHL=0 
  84    . . . . I  AIEN=314  S MATCH=0, MATCHL=0
  85    . . . . I  MATCH S E XPAN(AIEN, RIEN,3)=$G (@GLAZDIC@ (741100.01 ,MATCH,0))  S STATUS= "MATCHED " _MATCH,MAT CHL=MATCH
  86    . . . . ;  make new  list
  87    . . . . I  'MATCH D
  88    . . . . .  S FILENUM =741112.04 _AIEN_RIEN
  89    . . . . .  ;S FILENA M="CHAMPVA  AIFD CONV ERSION LIS T "_AIEN_"  "_RIEN
  90    . . . . .  ;S NOUNNA M="CONVERS ION TEST " _AIEN_" "_ RIEN
  91    . . . . .  S FILENAM ="CHAMPVA  AIFD CONVE RSION LIST  "_$P(@GLA ZDIC@(7411 00,AIEN,0) ,U)_" "_RI EN
  92    . . . . .  S NOUNNAM ="CONVERSI ON FOR "_$ P(@GLAZDIC @(741100,A IEN,0),U)_ " "_RIEN
  93    . . . . .  S MATCHL= $$MKNNEW(F ILENUM,.FI LENAM,NOUN NAM)
  94    . . . . .  S EXPAN(A IEN,RIEN,2 )=$G(DIC(7 41100.01,M ATCHL,0)) 
  95    . . . . .  ;w !,PREF IX," made  new list " ,MATCHL,"  ",$P(EXPAN (AIEN,RIEN ,2),"^",3)  S PREFIX= ""
  96    . . . . .  S STATUS= "NEW LIST  "_MATCHL
  97    . . . . .  S STATUSD ($I(STATUS D))=MATCHL _" = "_$G( DIC(741100 .01,MATCHL ,0)) 
  98    . . . . .  M @GLAZDD =DD
  99    . . . . .  M @GLAZDI C=DIC
  100    . . . . .  K @GLAZCH M@(FILENUM )
  101    . . . . .  ; populat e new list
  102    . . . . .  F I=1:1 Q :$G(VALLIS T(I))=""   D
  103    . . . . .  . S VAL=V ALLIST(I)  S:$E(VAL,* )'="Z" VAL =VAL_"Z"
  104    . . . . .  . S @GLAZ CHM@(FILEN UM,I,0)=VA L
  105    . . . . .  . S @GLAZ CHM@(FILEN UM,"B",VAL ,I)="" 
  106    . . . . .  S @GLAZCH M@(FILENUM ,0)=FILENA M_U_FILENU M_U_(I-1)_ U_(I-1)
  107    . . . . ; S NZ=$P(NZ ,"$n999")_ "$n"_NNIEN
  108    . . . . ; S AI(EIEN, 1)=NZ
  109    . . . . ;  add the F OUNDIN (or  not found  in) to TA I
  110    . . . . S  TAI($I(TE IEN),1)="$ v"_ORV_"^$ n"_$P(TR," ^")_"^$o8^ $n"_MATCHL
  111    . . . . S  TAI(TEIEN )=TEIEN
  112    . . . . S  TR=0,EIEN =EIEN2
  113    . . . ; n ot big eno ugh for li st.  set E LTYP to 2  to at leas t ICD10 re mediate
  114    . . . S E LTYP=2
  115    . . I ELT YP=2 D  Q
  116    . . . ;M  TAI($I(TEI EN))=AI(EI EN) S TAI( TEIEN,0)=T EIEN
  117    . . . ;K  VALLIST S  LISTCNT=$$ EXICD9(NIE N,VAL,.VAL LIST) 
  118    . . . F V IEN=1:1:VA LLIST S TA I($I(TEIEN ),1)="$v"_ $S($G(ORV) :ORV,1:2)_ "^$n"_TR_" ^"_$S(VALL IST(VIEN)? 1.N:VALLIS T(VIEN),1: """"_VALLI ST(VIEN)_" """) S ORV =0,TAI(TEI EN)=TEIEN
  119    . . . S:( EIEN1-1)'= TEIEN STAT US=$S($G(S TATUS)["MA TCHED":STA TUS,$G(STA TUS)["NEW  LIST":STAT US,1:"EXPA ND ICD") S  EIEN=EIEN 1-1 
  120    . S F=0 F  I=1:1 S F =$G(AI(I,1 ))_$G(TAI( I,1)) Q:$G (AI(I,1))= ""&($G(TAI (I,1))="")   Q:$TR($G (AI(I,1)), """")'=$TR ($G(TAI(I, 1)),"""")
  121    . ;I F=""  W "  Rule  #",RIEN,"  of test " ,AIEN,"(", $P(@GLAZDI C@(741100, AIEN,0),"^ "),") is s ame"
  122    . I F'=""  D
  123    . . ;I PR EFIX'="" W  !,PREFIX, "(",$P(@GL AZDIC@(741 100,AIEN,0 ),"^"),")  changed"
  124    . . M EXP AN(AIEN,RI EN,"AI")=A I,EXPAN(AI EN,RIEN,"T AI")=TAI
  125    . . S EXP AN(AIEN,RI EN,4)=""
  126    . . ;F I= 1:1 Q:'$D( AI(I,1))   W !,"AI(", I,",1)=",A I(I,1)
  127    . . ;W !
  128    . . ;F I= 1:1 Q:'$D( TAI(I,1))   W !,"TAI( ",I,",1)=" ,TAI(I,1)
  129    . . S A=0  F  S A=$O (@GLAZDIC@ (741100,AI EN,100,RIE N,100,A))  Q:A=""  D
  130    . . . K @ GLAZDIC@(7 41100,AIEN ,100,RIEN, 100,A)
  131    . . S A=0  F  S A=$O (TAI(A)) Q :A=""  D
  132    . . . M @ GLAZDIC@(7 41100,AIEN ,100,RIEN, 100,A)=TAI (A)
  133    . I STATU S'="AS-IS"  W:WHEAD'= "" !,WHEAD ,! W "Rule  ",RIEN,"( ",STATUS," ) " S WHEA D="" 
  134    I $D(STAT USD) F I=1 :1:STATUSD  W !,"     ",STATUSD( I)
  135    Q 
  136    /*
  137   ONEAIX ;
  138    S U="^"
  139    I $G(ACTI VE(AIEN))' =1 Q
  140    W !,AIEN, " ",$P(@GL AZDIC@(741 100,AIEN,0 ),"^"),!
  141    ;S TESTTY PE="" 
  142    S RIEN=0, TTR=0
  143    S MAX=999  ; max num ber of cod es we are  not replac ing with l ist
  144    F  S RIEN =$O(@GLAZD IC@(741100 ,AIEN,100, RIEN)) Q:' RIEN  D
  145    . S STATU S="AS-IS"
  146    . K AI M  AI=@GLAZDI C@(741100, AIEN,100,R IEN,100)
  147    . K NOUN, TAI,ICD10L  S TEIEN=0  
  148    . ; check  if any of  the affec ted nouns  are presen t and make  list
  149    . S TR=0, ELTYP=1
  150    . F EIEN= 1:1 Q:'$D( AI(EIEN))   D
  151    . . ; cla ssify elem ent as (1)  as is, (2 ) ICD10 or  (3) new l ist
  152    . . S NIE N="" F NIE NZ=15,19,4 7,74,281 D   
  153    . . . Q:' $F(AI(EIEN ,1),"$n"_N IEN_"^$o")  
  154    . . . S N IEN=NIENZ
  155    . . . S O PER=+$P(AI (EIEN,1)," $o",2),VAL =$TR($P(AI (EIEN,1)," ^$o"_OPER_ "^",2),""" ")
  156    . . . ; f ound in/no t found in  (remediat e list)
  157    . . . I O PER=8!(OPE R=9) D  Q
  158    . . . . K  VALLIST S  LISTIEN=$ P(VAL,"n", 2),L1=0
  159    . . . . S  LISTGL="^ "_$P(@GLAZ DIC@(74110 0.01,LISTI EN,1),"^", 6) ;,EXPAN DING=" exp anding lis t "
  160    . . . . F   S L1=$O( @(LISTGL_" L1)")) Q:' L1  D
  161    . . . . .  S ICD9=@( LISTGL_"L1 ,0)")
  162    . . . . .  S LISTCNT =$$EXICD9( NIEN,ICD9, .VALLIST,L ISTGL_"""B "")") 
  163    . . . . .  I LISTCNT >1 S STATU S="LIST EX PANDED"
  164    . . . . .  ;I LISTCN T>1 S EXPA N(AIEN,RIE N,1)=@GLAZ DIC@(74110 0.01,LISTI EN,0) I EX PANDING'=" " W !,PREF IX,EXPANDI NG,LISTIEN ," ",$P(@G LAZDIC@(74 1100.01,LI STIEN,0)," ^",3) S EX PANDING="" ,PREFIX=""
  165    . . . . .  ;W !,"ICD 9=",ICD9,"   LISTCNT= ",LISTCNT
  166    . . . . S  L1=0
  167    . . . . F   S L1=$O( @(LISTGL_" L1)")) Q:L 1=""  K @( LISTGL_"L1 )")
  168    . . . . F  L1=1:1:VA LLIST S @( LISTGL_"L1 ,0)")=VALL IST(L1) S  @(LISTGL_" ""B"",VALL IST(L1),L1 )")=""
  169    . . . . S  $P(@(LIST GL_"0)")," ^",3,4)=VA LLIST_"^"_ VALLIST
  170    . . . ; L T, GT, NLT , NGT (<,  >, !<, !>)
  171    . . . I O PER=2!(OPE R=3)!(OPER =6)!(OPER= 7) Q
  172    . . . ; E Q, NEQ
  173    . . . I O PER'=1,OPE R'=5 W 1/0
  174    . . . ; n ot as is,  so check i f part of  ongoing li st or not
  175    . . . ;S  ELTYP=2
  176    . . . ; n o ongoing  list so po tentially  start one
  177    . . . I ' TR S TR=NI EN_"^$o"_O PER S ELTY P=3,ORV=+$ P(AI(EIEN, 1),"$v",2)  Q
  178    . . . ;I  TR=(NIEN_" ^$o"_OPER)  W "." S T RCNT=TRCNT +1,NEWLIST (RIEN,$I(N EWLIST(RIE N)))=VAL,A TOL=1
  179    . . ; if  as is just  copy elem ent across
  180    . . I ELT YP=1 M TAI ($I(TEIEN) )=AI(EIEN)  S TAI(TEI EN,0)=TEIE N Q
  181    . . ; if  element is  potential ly part of  new list,  then ...
  182    . . I ELT YP=3 D  Q: ELTYP=3
  183    . . . K V ALLIST
  184    . . . S L ISTCNT=$$E XICD9(NIEN ,VAL,.VALL IST)
  185    . . . S E IEN1=EIEN, EIEN2=EIEN
  186    . . . F   S EIEN1=$O (AI(EIEN1) ) Q:'EIEN1   Q:'$F(AI (EIEN1,1), "$n"_TR)   S EIEN2=EI EN1,XX=$$E XICD9(NIEN ,$TR($P(AI (EIEN1,1), "^$o"_OPER _"^",2),"" ""),.VALLI ST),LISTCN T=LISTCNT+ XX
  187    . . . S G LAZZ=1
  188    . . . I L ISTCNT>MAX  D  Q
  189    . . . . ;  commit to  list
  190    . . . . ;  check if  this list  exists and  can be ma tched on C RC
  191    . . . . S  LIEN=7411 00,MATCH=0 ,NEWCRC=0, MATCHL=0
  192    . . . . F  I=1:1:VAL LIST S NEW CRC=NEWCRC +$ZCRC(VAL LIST(I),7)
  193    . . . . F   S LIEN=$ O(@GLAZDIC @(LIEN)) Q :'LIEN  D   Q:MATCH
  194    . . . . .  I $G(@GLA ZDIC@(LIEN ,0))'["AIF D" Q
  195    . . . . .  ;W !,"Att empting to  match ",L IEN," ",@G LAZDIC@(LI EN,0)," ", $$LISTCRC( LIEN)," ", NEWCRC
  196    . . . . .  I $$LISTC RC(LIEN)=N EWCRC S MA TCH=LIEN Q
  197    . . . . I  MATCH D  
  198    . . . . .  S I=0 
  199    . . . . .  F  S I=$O (@GLAZDIC@ (741100.01 ,I)) Q:'I   I $G(@GLA ZDIC@(7411 00.01,I,1) )[("CHMDIC ("_LIEN_", ") S MATCH L=I Q
  200    . . . . I  MATCHL S  EXPAN(AIEN ,RIEN,3)=$ G(@GLAZDIC @(741100.0 1,MATCHL,0 )) S STATU S="MATCHED  "_MATCHL  ;W !,PREFI X," reuse  matched li st ",MATCH L," ",$P(E XPAN(AIEN, RIEN,3),"^ ",3) S PRE FIX=""
  201    . . . . ;  make new  list
  202    . . . . I  'MATCHL D
  203    . . . . .  S FILENUM =741112.04 _AIEN_RIEN
  204    . . . . .  ;S FILENA M="CHAMPVA  AIFD CONV ERSION LIS T "_AIEN_"  "_RIEN
  205    . . . . .  ;S NOUNNA M="CONVERS ION TEST " _AIEN_" "_ RIEN
  206    . . . . .  S FILENAM ="CHAMPVA  AIFD CONVE RSION LIST  "_$P(@GLA ZDIC@(7411 00,AIEN,0) ,U)_" "_RI EN
  207    . . . . .  S NOUNNAM ="CONVERSI ON FOR "_$ P(@GLAZDIC @(741100,A IEN,0),U)_ " "_RIEN
  208    . . . . .  S MATCHL= $$MKNNEW(F ILENUM,FIL ENAM,NOUNN AM)
  209    . . . . .  S EXPAN(A IEN,RIEN,2 )=$G(DIC(7 41100.01,M ATCHL,0)) 
  210    . . . . .  ;w !,PREF IX," made  new list " ,MATCHL,"  ",$P(EXPAN (AIEN,RIEN ,2),"^",3)  S PREFIX= ""
  211    . . . . .  S STATUS= "NEW LIST  "_MATCHL
  212    . . . . .  M @GLAZDD =DD
  213    . . . . .  M @GLAZDI C=DIC
  214    . . . . .  ; populat e new list
  215    . . . . .  F I=1:1 Q :$G(VALLIS T(I))=""   D
  216    . . . . .  . S VAL=V ALLIST(I)  S:$E(VAL,* )'="Z" VAL =VAL_"Z"
  217    . . . . .  . S @GLAZ CHM@(FILEN UM,I,0)=VA L
  218    . . . . .  . S @GLAZ CHM@(FILEN UM,"B",VAL ,I)=""
  219    . . . . .  S @GLAZCH M@(FILENUM ,0)=FILENA M_U_FILENU M_U_(I-1)_ U_(I-1)
  220    . . . . ; S NZ=$P(NZ ,"$n999")_ "$n"_NNIEN
  221    . . . . ; S AI(EIEN, 1)=NZ
  222    . . . . ;  add the F OUNDIN (or  not found  in) to TA I
  223    . . . . S  TAI($I(TE IEN),1)="$ v"_ORV_"^$ n"_$P(TR," ^")_"^$o8^ $n"_MATCHL
  224    . . . . S  TAI(TEIEN )=TEIEN
  225    . . . . S  TR=0,EIEN =EIEN2
  226    . . . ; n ot big eno ugh for li st.  set E LTYP to 2  to at leas t ICD10 re mediate
  227    . . . S E LTYP=2
  228    . . I ELT YP=2 D  Q
  229    . . . ;M  TAI($I(TEI EN))=AI(EI EN) S TAI( TEIEN,0)=T EIEN
  230    . . . K V ALLIST S L ISTCNT=$$E XICD9(NIEN ,VAL,.VALL IST) 
  231    . . . F V IEN=1:1:LI STCNT S TA I($I(TEIEN ),1)="$v"_ $S($G(ORV) :ORV,1:2)_ "^$n"_TR_" ^"_$S(VALL IST(VIEN)? 1.N:VALLIS T(VIEN),1: """"_VALLI ST(VIEN)_" """) S ORV =0,TAI(TEI EN)=TEIEN
  232    . S F=0 F  I=1:1 S F =$G(AI(I,1 ))_$G(TAI( I,1)) Q:$G (AI(I,1))= ""&($G(TAI (I,1))="")   Q:$TR($G (AI(I,1)), """")'=$TR ($G(TAI(I, 1)),"""")
  233    . ;I F=""  W "  Rule  #",RIEN,"  of test " ,AIEN,"(", $P(@GLAZDI C@(741100, AIEN,0),"^ "),") is s ame"
  234    . I F'=""  D
  235    . . ;I PR EFIX'="" W  !,PREFIX, "(",$P(@GL AZDIC@(741 100,AIEN,0 ),"^"),")  changed"
  236    . . M EXP AN(AIEN,RI EN,"AI")=A I,EXPAN(AI EN,RIEN,"T AI")=TAI
  237    . . S EXP AN(AIEN,RI EN,4)=""
  238    . . ;F I= 1:1 Q:'$D( AI(I,1))   W !,"AI(", I,",1)=",A I(I,1)
  239    . . ;W !
  240    . . ;F I= 1:1 Q:'$D( TAI(I,1))   W !,"TAI( ",I,",1)=" ,TAI(I,1)
  241    . . S A=0  F  S A=$O (@GLAZDIC@ (741100,AI EN,100,RIE N,100,A))  Q:A=""  D
  242    . . . K @ GLAZDIC@(7 41100,AIEN ,100,RIEN, 100,A)
  243    . . . M @ GLAZDIC@(7 41100,AIEN ,100,RIEN, 100,A)=TAI (A)
  244    . W "Rule  ",RIEN,"( ",STATUS," ) "
  245    Q 
  246    ;
  247    */
  248   WEXPAN ;
  249    S AIEN=0
  250    F  S AIEN =$O(EXPAN( AIEN)) Q:A IEN=""  D
  251    . S RIEN= ""
  252    . F  S RI EN=$O(EXPA N(AIEN,RIE N)) Q:RIEN =""  D
  253    . . I $D( EXPAN(AIEN ,RIEN,1))  D  
  254    . . . W ! ,"Rule #", RIEN," of  test ",AIE N,"(",$P(@ GLAZDIC@(7 41100,AIEN ,0),"^")," )" 
  255    . . . W "  expanded  list ",$P( EXPAN(AIEN ,RIEN,1)," ^")
  256    . . I $D( EXPAN(AIEN ,RIEN,2))  D  
  257    . . . W ! ,"Rule #", RIEN," of  test ",AIE N,"(",$P(@ GLAZDIC@(7 41100,AIEN ,0),"^")," )" 
  258    . . . W "  created l ist ",$P(E XPAN(AIEN, RIEN,2),"^ ")
  259    . . I $D( EXPAN(AIEN ,RIEN,3))  D  
  260    . . . W ! ,"Rule #", RIEN," of  test ",AIE N,"(",$P(@ GLAZDIC@(7 41100,AIEN ,0),"^")," )" 
  261    . . . W "  reused li st ",$P(EX PAN(AIEN,R IEN,3),"^" )
  262    . . I $O( EXPAN(AIEN ,RIEN,"")) =4 D
  263    . . . W ! ,"Rule #", RIEN," of  test ",AIE N,"(",$P(@ GLAZDIC@(7 41100,AIEN ,0),"^")," )" 
  264    . . . W "  in-test e xpanded co de list"
  265    Q
  266    ; Write t est elemen t with val ue NZ
  267   WRTELEM(AI EN,RIEN,EI EN,NZ) ;
  268    ;W !,AIEN ,"~",RIEN, "~",EIEN," ~",NZ
  269    ;S X=NZ,F L="A" D AI 4^CHMGDTS  W "~",Y
  270    ;S X=NZ,F L="F" D AI 4^CHMGDTS  W "~",Y
  271    ;W !,AIEN ,",",RIEN, ",",EIEN,? 20
  272    D WL,WS,W S S X=NZ,F L="F" D AI 4 D:EIEN>1  WS,WS W Y
  273    Q
  274    ; Web wri te line
  275   WL ;
  276    I $d(%req uest) w "< /BR>" W !
  277    E  W !
  278    Q
  279    ; web wri te space
  280   WS I $d(%r equest) w  "&nbsp;"
  281    E  W " "
  282    Q
  283    ; ai conv ersion - m ake new no un
  284   MKNNEW(FIL ENUM,FILEN AM,NOUNNAM E)
  285    K DD,DIC, INFO
  286    D NINFO($ P($P($G(@G LAZDIC@(74 1100,AIEN, 0)),"^")," #",2),RIEN ,.INFO)
  287    ;I '$D(IN FO) W 1/0
  288    I $D(INFO ("SHORT"))  S FILENAM ="CHAMPVA  AIFD "_INF O("SHORT")
  289    ;
  290    ; If we a re creatin g Noun PHL EBOTOMY_DI AGNOSIS_AC CEPT, rena me existin g one
  291    ; to UNUS ED_PHLEBOT OMY_DIAGNO SIS_ACCEPT
  292    I $G(INFO ("FULL"))= "PHLEBOTOM Y_DIAGNOSI S_ACCEPT"  D
  293    . S OPDAI EN=$O(@GLA ZDIC@(7411 00.01,"B", INFO("FULL "),""))
  294    . Q:'OPDA IEN
  295    . K @GLAZ DIC@(74110 0.01,"B",I NFO("FULL" ),OPDAIEN)
  296    . S OPDAN N=$P(@GLAZ DIC@(74110 0.01,OPDAI EN,0),"^")
  297    . S OPDAF D=$P(@GLAZ DIC@(74110 0.01,OPDAI EN,0),"^", 3)
  298    . S $P(@G LAZDIC@(74 1100.01,OP DAIEN,0)," ^")="UNUSE D_"_OPDANN
  299    . S $P(@G LAZDIC@(74 1100.01,OP DAIEN,0)," ^",3)="UNU SED_"_OPDA FD
  300    . S @GLAZ DIC@(74110 0.01,"B"," UNUSED_"_O PDANN,OPDA IEN)=1
  301    . S @GLAZ DIC@(74110 0.01,"B"," UNUSED_"_O PDAFD,OPDA IEN)=1
  302    ; make DD
  303    S DD(FILE NUM,0)="FI ELD^^.01^1 "
  304    S DD(FILE NUM,0,"DT" )=3040217
  305    S DD(FILE NUM,0,"IX" ,"B",FILEN UM,.01)=""
  306    S DD(FILE NUM,0,"NM" ,FILENAM)= ""
  307    S DD(FILE NUM,.01,0) ="PROCEDUR E/DIAGNOSI S/NDC CODE ^RF^^0;1^K :$L(X)>15! ($L(X)<1)! '(X'?1P.E)  X"
  308    S DD(FILE NUM,.01,1, 0)="^.1"
  309    S DD(FILE NUM,.01,1, 1,0)=FILEN UM_"^B"
  310    S DD(FILE NUM,.01,1, 1,1)="S ^C HMDIC("_FI LENUM_","" B"",$E(X,1 ,30),DA)=" """"
  311       S DD(F ILENUM,.01 ,1,1,2)="K  ^CHMDIC(" _FILENUM_" ,""B"",$E( X,1,30),DA )"
  312    S DD(FILE NUM,.01,3) ="Answer m ust be 1-1 5 characte rs in leng th."
  313       S DD(F ILENUM,.01 ,"DT")=304 0217
  314    S DD(FILE NUM,"B","P ROCEDURE/D IAGNOSIS/N DC CODE",. 01)=""
  315    S DD(FILE NUM,"GL",0 ,1,.01)=""
  316    S DD(FILE NUM,"IX",. 01)=""
  317    S DD(FILE NUM,"RQ",. 01)=""
  318    ; make DI C
  319    S DIC(FIL ENUM,0)=FI LENAM_"^"_ FILENUM
  320    S DIC(FIL ENUM,0,"AU DIT")="@"
  321       S DIC( FILENUM,0, "DD")="@"
  322       S DIC( FILENUM,0, "DEL")="@"
  323       S DIC( FILENUM,0, "GL")="^CH MDIC("_FIL ENUM_","
  324       S DIC( FILENUM,0, "LAYGO")=" @"
  325       S DIC( FILENUM,0, "RD")="@"
  326       S DIC( FILENUM,0, "WR")="@"
  327    S DIC(FIL ENUM,0,"%A ")="0^3040 217"
  328    S DIC("B" ,FILENAM,F ILENUM)=""
  329    ; make ne w AI noun
  330    S NNIEN=$ O(@GLAZDIC @(741100.0 1," "),-1) +1
  331    S DIC(741 100.01,0)= @GLAZDIC@( 741100.01, 0)
  332    S $P(DIC( 741100.01, 0),U,3)=NN IEN,$P(DIC (741100.01 ,0),U,4)=$ P(DIC(7411 00.01,0),U ,4)+1
  333    S DIC(741 100.01,NNI EN,0)=NOUN NAME_U_NOU NNAME_U_NO UNNAME
  334    I $D(INFO ("NOUN"))  S $P(DIC(7 41100.01,N NIEN,0),U) =INFO("NOU N")
  335    I $D(INFO ("SHORT"))  S $P(DIC( 741100.01, NNIEN,0),U ,2)=INFO(" SHORT")
  336    I $D(INFO ("FULL"))  S $P(DIC(7 41100.01,N NIEN,0),U, 3)=INFO("F ULL")
  337       S DIC( 741100.01, NNIEN,1)=" F^^^^1^CHM DIC("_FILE NUM_","
  338    I $D(INFO ),$TR($G(I NFO("SYN") )," ","")' ="" D
  339    . S DIC(7 41100.01,N NIEN,100,0 )="^741100 .011^1^1"
  340    . S DIC(7 41100.01,N NIEN,100,1 ,0)=INFO(" SYN")
  341    . S DIC(7 41100.01,N NIEN,100," B",INFO("S YN"),1)=""
  342    S DIC(741 100.01,"B" ,$P(DIC(74 1100.01,NN IEN,0),U), NNIEN)=""
  343    ; descrip tion
  344    I $D(INFO ("DESC"))  S DIC(7411 00.01,NNIE N,101,1,0) =INFO("DES C"),I=-1
  345    E  D
  346    . S DIC(7 41100.01,N NIEN,101,1 ,0)="Sourc e Test: "_ AIEN_" ("_ $TR($P($G( @GLAZDIC@( 741100,AIE N,0)),U,1, 2),U,"/")_ ")"
  347    . S DIC(7 41100.01,N NIEN,101,2 ,0)="Sourc e Rule: "_ RIEN_" ("_ $G(@GLAZDI C@(741100, AIEN,100,R IEN,0))_") "
  348    . S DIC(7 41100.01,N NIEN,101,3 ,0)=""
  349    . F I=1:1  Q:'$D(@GL AZDIC@(741 100,AIEN,1 01,I))  S  DIC(741100 .01,NNIEN, 101,I+3,0) =@GLAZDIC@ (741100,AI EN,101,I,0 )
  350    S DIC(741 100.01,NNI EN,101,0)= "^741100.0 12^"_(I+2) _U_(I+2)
  351    Q NNIEN
  352    ; expand  ICD9 code  for NIEN ( need that  to see if  DX/PCS/oth ers)
  353   EXICD9(NIE N,ICD9,RET ,XREF) ;
  354    ;W !,NIEN ," ",ICD9
  355    S OICD9=I CD9
  356    I $E(ICD9 ,*)="Z" S  ICD9=$E(IC D9,1,*-1)
  357    S ICD9=$T R(ICD9,"." )
  358    S RET($I( RET))=OICD
  359    S REPL=1
  360    ; 120 is  neither so  we just g et 1
  361    I NIEN=12 0 G EXICD9 X
  362    ; 19,263  are the on ly DX
  363    I NIEN=19 !(NIEN=263 ) D  
  364    . ;W !,AI (EIEN,1),!
  365    . S ICD10 IEN=0
  366    . ; 10 to  9 transla tion file
  367    . F  S IC D10IEN=$O( ^CHIVM(741 033.7,"AB" ,$TR(ICD9, "."),ICD10 IEN)) Q:'I CD10IEN  D
  368    . . Q:$P( ^CHIVM(741 033.7,ICD1 0IEN,0),"^ ",2)'="CM"
  369    . . S ICD 10=$P(^CHI VM(741033. 7,ICD10IEN ,0),"^")
  370    . . I OIC D9?.E1"Z"  S ICD10=IC D10_"Z"
  371    . . I $D( ICD10L(ICD 10)) Q 
  372    . . I $G( XREF)'="", $D(@XREF@( ICD10)) Q
  373    . . S RET ($I(RET))= ICD10,ICD1 0L(ICD10)= 1,REPL=REP L+1
  374    . ; 9 to  10 transla tion file
  375    . S ICD9I EN=""
  376    . F  S IC D9IEN=$O(^ CHMDIC(741 033.5,"B", OICD9,ICD9 IEN)) Q:'I CD9IEN  Q: $P(^CHMDIC (741033.5, ICD9IEN,0) ,"^",2)="C M"
  377    . Q:'ICD9 IEN
  378    . S ICD10 XI=0 F  S  ICD10XI=$O (^CHMDIC(7 41033.5,IC D9IEN,3,IC D10XI)) Q: 'ICD10XI   D
  379    . . S ICD 10=^CHMDIC (741033.5, ICD9IEN,3, ICD10XI,0)  
  380    . . I $L( ICD10)>3 S  ICD10=$E( ICD10,1,3) _"."_$E(IC D10,4,*)
  381    . . I $D( ICD10L(ICD 10))!$D(IC D10L(ICD10 _"Z")) Q
  382    . . I $G( XREF)'="", $D(@XREF@( ICD10))!$D (@XREF@(IC D10_"Z"))  Q
  383    . . S RET ($I(RET))= ICD10,ICD1 0L(ICD10)= 1,REPL=REP L+1
  384    ; NIEN be sides 19,2 63 and 120  are servi ces
  385    I NIEN'=1 9,NIEN'=26 3 D
  386    . S ICD9I EN=""
  387    . F  S IC D9IEN=$O(^ CHMSERV("B ",ICD9,ICD 9IEN)) Q:' ICD9IEN  Q :$P($G(^CH MSERV(ICD9 IEN,0)),"^ ",5)="ICD- 9"
  388    . Q:'ICD9 IEN
  389    . ; 10 TO  9
  390    . S ICD10 IEN=0
  391    . F  S IC D10IEN=$O( ^CHIVM(741 033.7,"AB" ,$TR(ICD9, "."),ICD10 IEN)) Q:'I CD10IEN  D
  392    . . Q:$P( ^CHIVM(741 033.7,ICD1 0IEN,0),"^ ",2)'="PCS "
  393    . . S ICD 10=$P(^CHI VM(741033. 7,ICD10IEN ,0),"^")
  394    . . I OIC D9?.E1"Z"  S ICD10=IC D10_"Z"
  395    . . I $D( ICD10L(ICD 10)) Q
  396    . . I $G( XREF)'="", $D(@XREF@( ICD10)) Q
  397    . . S RET ($I(RET))= $TR(ICD10, "."),ICD10 L(ICD10)=1 ,REPL=REPL +1
  398    . ; 9 TO  10
  399    . S ICD9I EN=""
  400    . F  S IC D9IEN=$O(^ CHMDIC(741 033.5,"B", ICD9,""))  Q:'ICD9IEN   Q:$P(^CH MDIC(74103 3.5,ICD9IE N,0),"^",2 )="PCS"
  401    . Q:'ICD9 IEN
  402    . S ICD10 XI=0 F  S  ICD10XI=$O (^CHMDIC(7 41033.5,IC D9IEN,3,IC D10XI)) Q: 'ICD10XI   D
  403    . . S ICD 10=^CHMDIC (741033.5, ICD9IEN,3, ICD10XI,0)
  404    . . I $D( ICD10L(ICD 10))!$D(IC D10L(ICD10 _"Z")) Q
  405    . . I $G( XREF)'="", $D(@XREF@( ICD10))!$D (@XREF@(IC D10_"Z"))  Q
  406    . . S RET ($I(RET))= $TR(ICD10, "."),ICD10 L(ICD10)=1 ,REPL=REPL +1
  407   EXICD9X ;
  408    Q REPL
  409    ; scan AI  tests for  partticul ar noun/ve rb/operati on
  410   FIND ;
  411    R !,"Find : ",FND S  FND="^"_FN D
  412    S AIIEN=0  K GLAZ
  413    F  S AIIE N=$O(^DIC( 741100,AII EN)) Q:'AI IEN  D
  414    . S DATA= $g(^DIC(74 1100,AIIEN ,1)) I "^" _DATA[FND  W !,$ZR,"    ",DATA,"    ",$$AID C(DATA)
  415    . I DATA' ="" F I=1: 1:$L(DATA, "^") S GLA Z($P(DATA, "^",I),AII EN)=DATA
  416    . S RULE= 0
  417    . F  S RU LE=$O(^DIC (741100,AI IEN,100,RU LE)) Q:'RU LE  D
  418    . . S ELE M=0
  419    . . F  S  ELEM=$O(^D IC(741100, AIIEN,100, RULE,100,E LEM)) Q:'E LEM  D
  420    . . . S D ATA=^DIC(7 41100,AIIE N,100,RULE ,100,ELEM, 1) ;w !,DA TA
  421    . . . F I =1:1:$L(DA TA,"^") S  GLAZ($P(DA TA,"^",I), AIIEN)=DAT A
  422    . . . I " ^"_DATA_"^ "[FND W !, $ZR,"   ", DATA,"   " ,$$AIDC(DA TA)
  423    Q
  424    ; Printab le version  of AI tes t element  (used but  a bit obso lete.   AI 4 is alter native)
  425   AIDC(D) ;
  426    N I,DP
  427    F I=1:1:$ L(D,"^") D
  428    . S DP=$P (D,"^",I)
  429    . D 
  430    . . I DP? 1"$v".N S  DP=$P("IF, OR,AND,THE N,SET,KILL ,QUIT,PROC EDURE,AITE ST",",",$E (DP,3)) Q
  431    . . I DP? 1"$o".N S  DP=$P(^DIC (741100.03 ,$E(DP,3), 0),"^") Q
  432    . . I DP? 1"$F".N S  DP=$P(^DIC (741100.02 ,$E(DP,3,4 ),0),"^")  Q
  433    . . I DP? 1"$n".E S  DP=$P(^DIC (741100.01 ,$E(DP,3,9 ),0),"^")  Q
  434    . S $P(D, "^",I)=DP
  435    Q D 
  436    ;; lifted  from CHMG DTS - disp lay AI ele ment in X.    
  437    ;; FL is  "F" for fu ll, "A" fo r abbrevia ted
  438   AI4 S:'$D( FL) FL="F"  ;S FL="A"
  439    S Y=X F I =1:1 S Z=$ P(Y,"^",I)  Q:Z=""  D  SB11:Z?1" $"1.E
  440    S R="^",W =" " D SBR P^CHMGDTS
  441    Q
  442   SB11 S V=$ E(Z,2) G S 1:V="o",S2 :V="n",S3: V="F",S4:V ="v",SE
  443   S1 S V=+$E (Z,3,999)  G SE:'V,SE :'$D(@GLAZ DIC@(74110 0.03,V,0))  S W=^(0)  G S21
  444   S21 D SB2  S $P(Y,"^" ,I)=T Q
  445   S2 S V=+$E (Z,3,999)  G SE:'V,SE :'$D(@GLAZ DIC@(74110 0.01,V,0))  S W=^(0)  G S22
  446   S22 D SB2  D SBF2 S $ P(Y,"^",I) =T Q
  447   S3 S V=+$E (Z,3,999)  G SE:'V,SE :'$D(@GLAZ DIC@(74110 0.02,V,0))  S W=^(0)  D SB2
  448    S TY="$FU NCTION("_T ,VD=$P(Z," ,",2,999)
  449    F K=1:1 S  Z=$P(VD," ,",K) Q:Z= ""  S T=Z  D:Z?1"$n"1 .E  S TY=T Y_","_T
  450    . S V=+$E (Z,3,999)  Q:'V!'$D(@ GLAZDIC@(7 41100.01,V ,0))  S W= ^(0) D SB2
  451    S $P(Y,"^ ",I)=TY_") " Q
  452    ;G S9
  453   S4 S V=+$E (Z,3,999)  G SE:'V S  W=$P($T(VE RB+V),";", 3) G SE:W= ""
  454    S $P(Y,"^ ",I)=W
  455    G SE
  456   S9 ;D SB2  S $P(Y,"^" ,I)=T
  457   SE Q
  458   SB2 S T=$P (W,"^",FL' ="A"+2) S: T="" T=$P( W,"^",1)
  459    Q
  460   SBF2 S FDF LAG=0
  461    G SE:'$D( @GLAZDIC@( 741100.01, V,1)) S WW =^(1)
  462    I $P(WW," ^",1)="F"  S FDFLAG=1 ,FDNAME="^ "_$P(WW,"^ ",6) Q
  463    E  Q
  464   VERB ;;
  465    ;;IF
  466    ;;OR
  467    ;;AND
  468    ;;THEN
  469    ;;SET
  470    ;;KILL
  471    ;;QUIT
  472    ;;PROCEDU RE
  473    ;;AI_TEST
  474    ;;
  475    ; Evaluat e all noun s and put  them into  object OBJ
  476   ENTRY ;
  477    S PASS=1
  478   ENTRY2 ;
  479    ;S $ZT="E R0^CHICDAI " ; commen ted out fo r now sinc e we want  to see the  errors
  480    S OBJ=##C LASS(Claim Service.cl aimData).% New()
  481    ;S cdef=# #class(%Di ctionary.C lassDefini tion).%Ope nId($P(OBJ ,"@",2))
  482    ;S count= cdef.Prope rties.Coun t()
  483    ;F i=1:1: count D
  484    ;. S OBJP ROPS(cdef. Properties .GetAt(i). Name)=cdef .Propertie s.GetAt(i) .Collectio n
  485    ;. S A=cd ef.Propert ies.GetAt( i).Name 
  486    ;. I A?1" date".E!(A ["Date") S  OBJPROPS( cdef.Prope rties.GetA t(i).Name) ="date"
  487    ;D
  488    ;. K OBJP ROPS 
  489    ;. S OBJ. aiTestName =$P(^DIC(A HFILE,AHTS ,0),"^")
  490       ;. S O BJ.claimNu mber="9999 "
  491       ;. S S ERVICE=##c lass(Claim Service.Cl aimSoap11) .%New()
  492    ;. S USER TOKEN=##cl ass(%SOAP. Security.U sernameTok en).Create ("icdjrule user","res 2012")
  493    ;. D SERV ICE.Securi tyOut.AddT oken(USERT OKEN)
  494       ;. S s c=SERVICE. claim(OBJ, .RESPONSE)
  495       ;. F M L=1:1:RESP ONSE.messa geList.Cou nt() D
  496       ;. . S  PN=RESPON SE.message List.GetAt (ML).key,O K=0
  497       ;. . F  ML2=1:1:c def.Proper ties.Count () D  Q:OK
  498       ;. . .  I cdef.Pr operties.G etAt(ML2). Name=PN D
  499       ;. . .  . S OBJPR OPS(PN)=cd ef.Propert ies.GetAt( i).Collect ion,OK=1
  500       ;. . .  . I PN?1" date".E!(P N["Date")  S OBJPROPS (cdef.Prop erties.Get At(i).Name )="date"
  501           S  (AHSTV,AHE RV,AHRTE,A HQUIT,AHCT C)="",U="^ "
  502    G END:'$D (AHFILE),E ND:'AHFILE ,END:'$D(A HTS)
  503    G END:'$D (^DIC(AHFI LE,AHTS,0) ) S AHTSX= ^(0)
  504    S Y=+$P(A HTSX,U,4)  G END:'Y S  AHOPDIC=Y
  505    S Y=+$P(A HTSX,U,5)  G END:'Y S  AHNODIC=Y
  506    S Y=+$P(A HTSX,U,6)  G END:'Y S  AHFNDIC=Y
  507    S Y=+$P(A HTSX,U,7)  G END:'Y S  AHPRDIC=Y
  508    K OBJPROP
  509    S I=0 F   S I=$O(^DI C(AHFILE,A HTS,102,I) ) Q:'I  S  DATA=^(I,0 ),OBJPROPS ($P(DATA,U ))=$P(DATA ,U,2)
  510    ; Backgro und tests
  511    ;F I="ccA geConflict Result","c cAsstSurge onResult", "ccCosmetU nlsResult"  S OBJPROP S(I)=""
  512    ;F I="ccE xperimenta lResult"," ccLineOrig ination"," ccObsolete ProcResult " S OBJPRO PS(I)=""
  513    ;F I="ccR esult","cc SexConflic tResult"," rebundleCo dePresent"  S OBJPROP S(I)=""
  514    ;S OBJ.AI TestNumber =AHTS
  515    S OBJ.aiT estName=$P (AHTSX,U)
  516    S OBJ.cla imNumber=$ G(CN)
  517    S AHRTE=+ $O(^DIC(AH NODIC,"B", "ROUTE",0) )
  518    S AHSTV=+ $O(^DIC(AH NODIC,"B", "STATUS",0 ))
  519    S AHCTC=+ $O(^DIC(AH NODIC,"B", "CTC",0))
  520    S AHQUIT= +$O(^DIC(A HNODIC,"B" ,"QUIT",0) )
  521    S AHDATA( AHQUIT,1)= $P(^DIC(AH NODIC,AHQU IT,1),"^", 2),V=AHQUI T D XREFN( V)
  522    S X=$O(^D IC(AHNODIC ,"B","ERRO R",0))
  523    I X,$D(^D IC(AHNODIC ,X,1)) S A HERV=$P(^( 1),U,2)
  524    I AHSTV,A HERV K AHD ATA(AHSTV)  S AHDATA( AHSTV,1)=A HERV,V=AHS TV
  525    ; Compile  list of a ll needed  variables.    
  526    ; backgro und AI tas ks 
  527    I $D(^DIC (AHFILE,AH TS,2)),^(2 )'="",'$D( AHTSBG) X  ^(2) G:AHD ATA(AHQUIT ,1)=1 END3
  528    ; Compile  list of a ll needed  AI nouns.    
  529    K AINOUNS  
  530    ; Derivin g list of  nouns from  the AI te st definit on in Cach e is obsol ete.  Inst ead
  531    ; we will  be using  102 area,  obtain fro m Jrules.
  532    ;S J=0 
  533    ;F  S J=$ O(^DIC(AHF ILE,AHTS,1 00,J)) Q:' J  D
  534    ;. S K=0 
  535    ;. F  S K =$O(^DIC(A HFILE,AHTS ,100,J,100 ,K)) Q:'K   D
  536    ;. . S V= ^DIC(AHFIL E,AHTS,100 ,J,100,K,1 )
  537    ;. . F L= 1:1:$L(V,U ) I $P(V,U ,L)?1"$n"1 .N S AINOU NS($P($P(V ,U,L),"n", 2))=1
  538    ; also ad d all noun s that cam e from bac kground ta sks
  539    ;;S A=""  F  S A=$O( AHDATA(A))  Q:'A  S A INOUNS(A)=
  540    ;
  541    ; this is  if we wan t to popul ate all no uns define d in reque st object.    
  542    ; Since w e are filt ering by O BJPROPS, t his is fin e
  543    S A=0 F   S A=$O(^DI C(AHNODIC, A)) Q:'A   D
  544    . S NZ=$$ PAR($P($G( ^DIC(AHNOD IC,A,0)),U ,3)) I NZ' ="",$D(OBJ PROPS(NZ))  S AINOUNS (A)=2
  545    ;
  546    S:'$D(AHD T) AHDT=DT  S:AHDT'?7 N AHDT=DT
  547    S:'$D(AHR T) AHRT="T " S AHRT=$ E(AHRT,1)  S:"TBI"'[A HRT AHRT=" T"
  548    S A=+$P(A HTSX,U,10) ,B=+$P(AHT SX,U,11) S :'A A=AHDT  S:'B B=AH DT
  549    I (AHDT<A )!(AHDT>B)  G END2
  550    ; default  outcome.   All of th em are SET  STATUS EQ UALS XXX s o do that
  551    I $D(^DIC (AHFILE,AH TS,1)) S A HEX=^(1) I  AHEX?1"$v 5^".E S AH DF=$E($P(A HEX,"^",4) ,3,99) D N EVAL("$n"_ AHDF,"",$$ PAR($P(^DI C(AHNODIC, AHDF,0),U, 3))) S AHD ATA(AHSTV, 1)=AHDATA( AHDF,1)
  552           ;  flat all n oun evalua tion
  553           D  NEVAL("$F1 2",OBJ,"qu alityAssur anceCheck"
  554    S NIEN=0 
  555    F  S NIEN =$O(AINOUN S(NIEN)) Q :'NIEN  D
  556           .  S NZ=$$PAR ($P($G(^DI C(AHNODIC, NIEN,0)),U ,3)) Q:NZ= ""
  557           .  I '$D(OBJP ROPS(NZ))  Q
  558           .  D NEVAL("$ n"_NIEN,OB J,NZ) Q
  559           ;  create pla ceholder R ESULT OF Q A REVIEW i f not ther e.
  560           S  RST=+$O(^D IC(AHNODIC ,"B","REVI EW",0)) 
  561           I  $G(AHDATA( RST,1))=""  S AHDATA( RST,1)=0 D  XREFN(RST ) S OBJ.re sultOfQaRe view=0
  562           ;  run the ca ll to remo te system
  563    S SERVICE =##class(C laimServic e.ClaimSoa p11).%New( )
  564    S USERTOK EN=##class (%SOAP.Sec urity.User nameToken) .Create("i cdjruleuse r","res201 2")
  565    D SERVICE .SecurityO ut.AddToke n(USERTOKE N)
  566    S ZH=$ZH, RESULT=""
  567    S AISTATU S=SERVICE. claim(OBJ, .RESULT)
  568    ; Check i f RESULT w ants to re populate t he NOUN PR OPERTIES m ultiple
  569    S MD=0
  570    I RESULT. messageLis t.Count()  D  G:MD EN TRY2:PASS< 3
  571    . S cdef= ##class(%D ictionary. ClassDefin ition).%Op enId($P(OB J,"@",2))
  572       . F ML =1:1:RESUL T.messageL ist.Count( ) D
  573       . . S  PN=RESULT. messageLis t.GetAt(ML ).key,OK=0
  574       . . I  RESULT.mes sageList.G etAt(ML).v alue'["is  missing" Q
  575       . . F  ML2=1:1:cd ef.Propert ies.Count( ) D  Q:OK
  576       . . .  I cdef.Pro perties.Ge tAt(ML2).N ame=PN D
  577       . . .  . S OK=1,M D=1,PASS=$ G(PASS)+1
  578       . . .  . S NZ=$G( ^DIC(AHFIL E,AHTS,102 ,0)) S:NZ= "" NZ="^74 1100.004^0 ^0"
  579       . . .  . S $P(NZ, U,3)=$P(NZ ,U,3)+1,$P (NZ,U,4)=$ P(NZ,U,4)+ 1 S ^DIC(A HFILE,AHTS ,102,0)=NZ
  580       . . .  . S ^DIC(A HFILE,AHTS ,102,"B",P N,$P(NZ,U, 3))=""
  581       . . .  . S ^DIC(A HFILE,AHTS ,102,$P(NZ ,U,3),0)=P N_$S(PN?1" date".E:"d ate",PN["D ate":"date ",1:cdef.P roperties. GetAt(ML2) .Collectio n)
  582    I AISTATU S="ERROR"  G ER0
  583    S sTv("SE RVICE")=$Z H-ZH
  584    I '$ISOBJ ECT(RESULT ) G ER0
  585    ; Result  should hav e
  586    ;Property  Status As  %Integer;  (AHSTV)
  587    S AHDATA( AHSTV,1)=R ESULT.stat us D XREFN (AHSTV)
  588    ;Property  Reason As  %Integer;
  589    S AHREAS= +$O(^DIC(A HNODIC,"B" ,"REASON", 0)) 
  590    S AHDATA( AHREAS,1)= RESULT.rea son D XREF N(AHREAS)
  591    ;Property  SpecialPa ymentMetho d As %Inte ger;
  592    S AHSPEC= +$O(^DIC(A HNODIC,"B" ,"SP_PAY", 0)) 
  593    S AHDATA( AHSPEC,1)= RESULT.spe cialPaymen tMethod D  XREFN(AHSP EC)
  594    ;Property  Route As  %Integer;  (AHRTE)
  595    S AHDATA( AHRTE,1)=R ESULT.rout e D XREFN( AHRTE)
  596    ; Last ru le/element
  597    S RULENAM E=RESULT.l astFiredRu leName,RN= 0 S:RULENA ME["." RUL ENAME=$P(R ULENAME,". ",2)
  598    F I=1:1 Q :'$D(^DIC( AHFILE,AHT S,100,I))   I $G(^DIC (AHFILE,AH TS,100,I,0 ))=RULENAM E S RN=I Q
  599    S EN=1
  600    S T=$S(RU LENAME="": END,1:"QUI T")
  601    S AHLTS=A HFILE_U_AH TS_U_RN_U_ EN_U_T
  602    ; cost to  check fla g and stat us of 0 se ts route t o 1
  603   END ;
  604   END2 I $D( AHDATA(AHS TV)),$D(AH DATA(AHCTC )),AHDATA( AHSTV,1)=0 ,AHDATA(AH CTC,1)=1 S  AHDATA(AH RTE,1)=1
  605    ;K A,AHEX ,AHIF,AHDT ,B,EN,I,P, PR,R1,R2,R EG,RN,T,V, VAR,X,Y,Z
  606   END3 ;K OB J,OBJPROPS ,cdef,coun t,SERVICE, USERTOKEN, RESULT
  607    K V,X,AIN OUNS,J,K,L ,A,B,FIEN, NIEN,NZ,SE RVICE
  608    K RN,EN,T ,DEBUG
  609    K AHEX,AH IF,AHDT,P, PR,R1,R2,R EG,VAR,Y,Z         
  610    Q
  611    ; evaluat e AI test.    Copy of  AHCJAE
  612    /*
  613   ENTRY ;
  614    K OBJ,ALL NOUNS
  615   ENTRY1 ;
  616    S (AHSTV, AHERV,AHRT E,AHQUIT,A HCTC)="",U ="^"
  617    G END:'$D (AHFILE),E ND:'AHFILE ,END:'$D(A HTS)
  618    G END:'$D (^DIC(AHFI LE,AHTS,0) ) S AHTSX= ^(0)
  619    S Y=+$P(A HTSX,U,4)  G END:'Y S  AHOPDIC=Y
  620    S Y=+$P(A HTSX,U,5)  G END:'Y S  AHNODIC=Y
  621    S Y=+$P(A HTSX,U,6)  G END:'Y S  AHFNDIC=Y
  622    S Y=+$P(A HTSX,U,7)  G END:'Y S  AHPRDIC=Y
  623    S AHRTE=+ $O(^DIC(AH NODIC,"B", "ROUTE",0) )
  624    S AHSTV=+ $O(^DIC(AH NODIC,"B", "STATUS",0 ))
  625    S AHCTC=+ $O(^DIC(AH NODIC,"B", "CTC",0))
  626    S AHQUIT= +$O(^DIC(A HNODIC,"B" ,"QUIT",0) )
  627    S AHDATA( AHQUIT,1)= $P(^DIC(AH NODIC,AHQU IT,1),"^", 2),V=AHQUI T D XREFN( V)
  628    S X=$O(^D IC(AHNODIC ,"B","ERRO R",0))
  629    I X,$D(^D IC(AHNODIC ,X,1)) S A HERV=$P(^( 1),U,2)
  630    I AHSTV,A HERV K AHD ATA(AHSTV)  S AHDATA( AHSTV,1)=A HERV,V=AHS TV
  631    ; backgro und AI tas ks 
  632    ;I $D(^DI C(AHFILE,A HTS,2)),^( 2)'="",'$D (AHTSBG) X  ^(2) G:AH DATA(AHQUI T,1)=1 END 3
  633    S:'$D(AHD T) AHDT=DT  S:AHDT'?7 N AHDT=DT
  634    S:'$D(AHR T) AHRT="T " S AHRT=$ E(AHRT,1)  S:"TBI"'[A HRT AHRT=" T"
  635    K:AHRT="B " AHTR
  636    S A=+$P(A HTSX,U,10) ,B=+$P(AHT SX,U,11) S :'A A=AHDT  S:'B B=AH DT
  637    I (AHDT<A )!(AHDT>B)  G END2
  638    ; default  outcome.   How do we  do that?
  639    ;I $D(^DI C(AHFILE,A HTS,1)) S  AHEX=^(1)  I AHEX?1"$ v5^".E D S ET
  640           ;  flat all n oun evalua tion
  641           I  $D(ALLNOUN S) D  Q
  642           .  F FIEN=12, 13 D NEVAL ("$F"_FIEN ,"") 
  643           .  K ANO F I= 1:1:7 S TX T=$T(ANOUN S+I),TXT=$ P(TXT,";", 2) F J=1:1 :$L(TXT,U)  S ANO(+$P (TXT,U,J)) =($P(TXT,U ,J)["*")
  644           .  S NIEN=0 F   S NIEN=$ O(^DIC(AHN ODIC,NIEN) ) Q:'NIEN   D
  645           .  . Q:'$D(AN O(NIEN)) 
  646           .  . S STM=$Z H D NEVAL( "$n"_NIEN, "") ;W:$D( AHDATA(NIE N)) " (Tim e=",$ZH-ST M,")"
  647           .  Q
  648           ;  start proc essing spe cific test
  649           S  RN=0,EN=0 
  650   A1 S RN=$O (^DIC(AHFI LE,AHTS,10 0,RN))
  651           I  RN="" S EN ="",T="END " G A9
  652           S  EN=0,AHIF= 1
  653   A2 S EN=$O (^DIC(AHFI LE,AHTS,10 0,RN,100,E N)) G A1:E N="",ER1:' $D(^(EN,1) )
  654           S  AHEX=^DIC( AHFILE,AHT S,100,RN,1 00,EN,1) W  !,AHEX
  655           S  AHEL=0
  656   A3 S AHEL= AHEL+1,VAR =$P(AHEX,U ,AHEL),V=+ $E(VAR,3,9 99) G A2:V AR=""
  657    D NEVAL(V AR,"")
  658    G A3 */
  659    ; evaluat e noun (ex cept for p roblems on es) and pu t it into  object or  write it
  660   NEVAL(VAR, OBJ,NZ) ;
  661    I VAR?1"$ v".E Q
  662    I VAR?1"$ o".E Q
  663    S V=$E(VA R,3,9999)
  664    ;W !,"Eva luating No un ",V," " ,VAR," ",$ G(NZ) I VA R?1"$n".E  W ! ZW AHD ATA(V)
  665    ; if noun  evaluated  by BG tes t already
  666    I $D(AHDA TA(V)) K Y  M Y=AHDAT A(V) G NEV ALX
  667    ; 
  668    ; 3 - DIA GNOSIS (bu g in code)
  669    I V=3 Q
  670    ; 29 - BU G AT GETDX +9^CHMJ116  (using IC D code as  IEN)
  671    I V=29 Q
  672    ; 37 - Va riable CPC  used but  not define d
  673    I V=37 Q
  674    ; 44 - OP VSD^CHMJ11 7 (Should  be 118)
  675    I V=44 Q
  676    ; 59 - "D X_ADM^DX/A DM^DIAGNOS IS_AT_ADMI SSON" ADMI SSION is m isspelled
  677    I V=59 Q
  678    ; 69 - CH MJ124 is n ot there
  679    I V=69 Q
  680    ; 87 - "N UM_PROC_3_ DAYS_PRIOR ^#_PROC_3_ DAYS_PRIOR ^NUMBER_OF _PROC_3_DA YS_PRIOR"
  681    ;    - co de is look ing for NU MBER_PROC_ 3_DAYS
  682    I V=87 Q
  683    ; 92 - "N UMBER_PROC EDURES_WEE K_PRIOR^NP WP^NUMBER_ PROCEDURES _WEEK_PRIO R"
  684    ;    - co de is look ing for NU MBER_PROC_ WEEK_PRIOR
  685    I V=92 Q
  686    ; 97 - "N UM_PROC_YE AR_PRIOR^N PYP^NUMBER _PROCEDURE S_YEAR_PRI OR"
  687    ;    - co de is look ing for NU MBER_PROC_ YEAR_PRIOR
  688    I V=97 Q
  689    ; 99 - "N UM_PROC_5_ DAYS_AFTER ^NP5DA^NUM BER_PROCED URES_5_DAY S_AFTER"
  690    ;    - co de is look ing for NU MBER_PROC_ 5_DAYS_AFT ER
  691    I V=99 Q
  692    ; 101 - " NUM_PROC_5 _DAYS_PRIO R^NP5DP^NU MBER_PROCE DURES_5_DA YS_PRIOR"
  693    ;     - c ode is loo king for N UMBER_PROC _5_DAYS_PR IOR
  694    I V=101 Q
  695    W:$D(DEBU G) !,"Proc essing tes t ",AHTS,"  rule ",$G (RN)," ele ment numbe r ",$G(EN) ," VAR ",V AR
  696    I VAR?1"$ F".E D  Q
  697    . Q:'$D(^ DIC(AHFNDI C,V,1))
  698    . ; for n ow, use lo ng descrip tion as th e name for  the funct ion
  699    . S P=$P( ^DIC(AHFND IC,V,1),U, 3,4),REG=$ P(^DIC(AHF NDIC,V,0), U,3),REG=$ TR(REG,"_" ," ")
  700    . ; for n ow, use F#  as name
  701    . D XREFF (V)
  702    . Q:$L(P) <2
  703    . S X=$P( VAR,",",2, 999) K Y D  @P
  704           .  K AHDATA(V ) F I=1:1  Q:'$D(Y(I) )  S AHDAT A("F"_V,I) =Y(I)
  705           .  W:$D(DEBUG ) !,"Funct ion ",V,"( ",$P(^DIC( AHFNDIC,V, 0),U,1,3), ") evaluat ed to ",Y( 1)
  706           .  I $isobjec t(OBJ) X " S OBJ."_NZ _"=$G(Y(1) )"
  707    I VAR'?1" $n".E Q 
  708    D XREFN(V )
  709    K Y S Y(1 )="",X=""  ;G A3:$D(A HDATA(V))
  710    Q:'$D(^DI C(AHNODIC, V,1))
  711           S  X=^DIC(AHN ODIC,V,1)  S:$E(X,1)= "V" Y(1)=$ P(X,U,2)
  712    S P=$P(X, U,3,4) D:$ L(P)>1 @P
  713    S X=^DIC( AHNODIC,V, 1) 
  714    ; file li st (disabl ed for now )
  715    I $E(X)=" F" Q
  716    I $E(X)=" F" K Y S Y (1)="^"_$P (X,U,6)_"" "B"","
  717    ; variabl
  718    I $E(X)=" V" S Y(1)= $P(X,U,2)
  719    ; data (d o we need  to do anyt hing else)
  720    I $E(X)=" D"
  721    F I=1:1 Q :'$D(Y(I))   S AHDATA (V,I)=Y(I)
  722    ; DOUBLE
  723    I V=303 S :Y(1)'?1.N 1"."1.N Y( 1)=Y(1)_". 00"
  724    ; 300 is  bugged.  C lear 2-n
  725    I V=300 F  I=2:1:$O( Y(""),-1)  K Y(I)
  726    ;I $D(DEB UG) D
  727    . W !,X
  728           .  W !,"Noun  ",V,"(",$P (^DIC(AHNO DIC,V,0),U ),U,$P(^DI C(AHNODIC, V,0),U,3), ") "
  729           .  W:'$D(ANO( V)) "(unus ed) "
  730           .  W "- type  "
  731           .  S VT=^DIC( AHNODIC,V, 1)
  732    . I $E(VT )="F" W "L ist"
  733           .  I $E(VT)=" V",$P(VT,U ,3,4)?.1"^ " W:$P(VT, U,2)="" "V ariable (b lank)" W:$ P(VT,U,2)' ="" "Varia ble (",$P( VT,U,2),") "
  734           .  I $E(VT)=" V",$P(VT,U ,3,4)'?.1" ^" W "Vari able"
  735           .  I $E(VT)=" D" W "Data "
  736           .  W "   ",?7 5," evalua ted to ",$ G(Y(1))
  737   NEVALX ;
  738           I  $isobject( OBJ) D
  739           .  ;;S NZ=$$P AR($P(^DIC (AHNODIC,V ,0),U,3))
  740           .  ;;Q:'$D(OB JPROPS(NZ) )
  741           .  I OBJPROPS (NZ)="" D   Q
  742           .  . I $O(Y(1 ))="" X:$G (Y(1))'=""  "S OBJ."_ NZ_"=$G(Y( 1))" Q ;W  !,"OBJ.",N Z,"=",$G(Y (1)) 
  743           .  . S X=1/0  ; error ou t trying t o put mult iple data  into singl e field
  744           .  I OBJPROPS (NZ)="date " D  Q
  745           .  . S X=Y(1)  D H^%DTC  X "S OBJ." _NZ_"=$ZDA TE(%H,3)"
  746           .  I '$O(Y(1) ),$G(Y(1)) ="" Q
  747           .  F I=1:1 Q: '$D(Y(I))   X "D OBJ. "_NZ_".Ins ert(Y(I))"  ;W !,"OBJ .",NZ,".In sert(""",Y (I),""")"
  748           .  ;I $O(Y(1) ),OBJPROPS (NZ)'="lis t" W !,NZ, " fails mu ltiple tes t",! ZW Y
  749           Q
  750           ;  exit
  751   ER0 ;
  752   ER1 ;
  753    S:'$D(AHF ILE) AHFIL E="" S:'$D (AHTS) AHT S="" S:'$D (RN) RN=""
  754    S:'$D(EN)  EN="" S:' $D(AHSTV)  AHSTV="" S :'$D(AHERV ) AHERV=""
  755    S AHLTS=A HFILE_U_AH TS_U_RN_U_ EN_U_"ERRO R",AHERROR =""
  756       I AHST V,AHERV K  AHDATA(AHS TV) S AHDA TA(AHSTV,1 )=AHERV,V= AHSTV D XR EFN(V)
  757    G END
  758    ; part of  evaluate  AI logic
  759   XREFN(V) Q :'$D(^DIC( AHNODIC,V, 0))  
  760    S Z=$P(^D IC(AHNODIC ,V,0),U,1)  S:Z'="" A HDATA("XR" ,Z,V)="" 
  761    S Z=$P(^D IC(AHNODIC ,V,0),U,3)  S:Z'="" A HDATA("XR" ,Z,V)=""
  762    Q
  763    ; part of  evaluate  AI logic
  764   XREFF(V) Q :'$D(^DIC( AHFNDIC,V, 0))
  765    S Z=$P(^D IC(AHFNDIC ,V,0),U,1)  S:Z'="" A HDATA("XR" ,"F"_Z,V)= "" 
  766    S Z=$P(^D IC(AHFNDIC ,V,0),U,3)  S:Z'="" A HDATA("XR" ,"F"_Z,V)= ""
  767    S Z=$P(^( 0),U,3) S: Z'="" AHDA TA("XR","F "_Z,V)=""  Q
  768    ; DD tabl e display?
  769   DUMPAI ;
  770    Q:$G(DIC) ="" 
  771    S U="^" K  GLAZ 
  772    D DAI1(DI C)
  773    S IEN=0
  774    ;F I
  775    F C=1:1:G LAZ D
  776    Q
  777   DAI1(DIC)  ;
  778    N FLD S F LD=0
  779    N GLAZ1,G LAZS
  780    F  S FLD= $O(^DD(DIC ,FLD)) Q:' FLD  D
  781    . S DZ=^D D(DIC,FLD, 0) W !,FLD ," = ",DZ
  782    . I $P(DZ ,U,2)'?1.N .1"."1.N S  GLAZ($I(G LAZ),$P(DZ ,U,4))=1 W  ! ZW GLAZ  Q
  783    . I $P(^D D($P(DZ,U, 2),.01,0), U,2)="W" S  GLAZ($I(G LAZ),$P(DZ ,U,4))=1 W  ! ZW GLAZ  Q
  784    . K GLAZS  M GLAZS=G LAZ K GLAZ  
  785    . D DAI1( $P(DZ,U,2) )
  786    . M GLAZ1 =GLAZ K GL AZ M GLAZ= GLAZS
  787    . S SFLD= "" S DZ=^D D(DIC,FLD, 0) 
  788    . W !,"Me rging",! Z W GLAZ1 W  ! ZW GLAZ
  789    . F  S SF LD=$O(GLAZ 1(SFLD)) Q :'SFLD  D
  790    . . W !,S FLD
  791    . . M GLA Z($I(GLAZ) ,$P(DZ,U,4 ))=GLAZ1(S FLD) W ! Z W GLAZ K G LAZ1(SFLD)
  792    . W !,"Do ne merging " W ! ZW G LAZ
  793    Q
  794    ; write t ests in sp readsheet  format
  795   DTEST ;
  796    R !,"Excl ude expire d: Y/",EXP  S:EXP=""  EXP="Y"
  797    R !,"Summ ary or Det ail: D/",D S S:DS=""  DS="D"
  798    S DIC=741 100,U="^", IEN1=0 K N OUNS
  799    I DS="S"  D
  800    . S FLIST =".01^.02^ .04^.05^.0 6^.07^.1^. 11^.12^1.0 1^3.01"  
  801    . W !,"IE N"
  802    . F F=1:1 :$L(FLIST, U) S FD=^D D(DIC,$P(F LIST,U,F), 0) W ",",$ P(FD,U) W: FD["DEFAUL T OUTCOME"  ",",$P(FD ,U)
  803    E  W !,"I EN,RULE IE N,RULE DES CRIPTION,E LEMENT DAT A,ELEMENT  DATA"
  804    F  S IEN1 =$O(^DIC(D IC,IEN1))  Q:'IEN1  D
  805    . S DATA= ^DIC(DIC,I EN1,0),DC= 0,WRT=""
  806    . I EXP=" Y",$P(DATA ,U,11)'=""  Q
  807    . F F=1:1 :$L(FLIST, U) S FD=^D D(DIC,$P(F LIST,U,F), 0) D
  808    . . S I=$ P(FD,U,4)
  809    . . S V=$ P($G(^DIC( DIC,IEN1,+ $P(I,";")) ),U,$P(I," ;",2),$S(+ I=1:999,1: $P(I,";",2 )))
  810    . . S $P( WRT,",",$I (DC))=V
  811    . . I +I= 1 S $P(WRT ,",",$I(DC ))=$$AIDC( V)
  812    . S RIEN=
  813    . I $G(DS )="S" W !, IEN1,",",W RT Q
  814    . S DC=0, WRT=""
  815    . F  S RI EN=$O(^DIC (DIC,IEN1, 100,RIEN))  Q:'RIEN   D
  816    . . S $P( WRT,",",1) =RIEN
  817    . . S $P( WRT,",",2) =$G(^DIC(D IC,IEN1,10 0,RIEN,0))
  818    . . S EIE N=0
  819    . . F  S  EIEN=$O(^D IC(DIC,IEN 1,100,RIEN ,100,EIEN) ) Q:'EIEN   D
  820    . . . S E L=^DIC(DIC ,IEN1,100, RIEN,100,E IEN,1)
  821    . . . S $ P(WRT,",", 3)=EL
  822    . . . S $ P(WRT,",", 4)=$$AIDC( EL)
  823    . . . I E L["$n" F J =1:1:$L(EL ,"$n") S N OUNS(+$P(E L,"$n",J)) =1
  824    . . . W ! ,IEN1,",", WRT
  825    Q
  826    ; write N OUNS in sp readsheet  format
  827   DNOUN ;
  828    S DIC=741 100.01,U=" ^",IEN1=0
  829    S FLIST=" .01^.02^.0 3^1.01^1.0 2^1.03^1.0 4^1.05^1.0 6"  
  830    W !,"IEN"
  831    F F=1:1:$ L(FLIST,U)  S FD=^DD( DIC,$P(FLI ST,U,F),0)  W ",",$P( FD,U) 
  832    F  S IEN1 =$O(^DIC(D IC,IEN1))  Q:'IEN1  D
  833    . I $D(NO UNS),'$D(N OUNS(IEN1) ) Q
  834    . S DATA= ^DIC(DIC,I EN1,0),DC= 0,WRT=""
  835    . F F=1:1 :$L(FLIST, U) S FD=^D D(DIC,$P(F LIST,U,F), 0) D
  836    . . S I=$ P(FD,U,4)
  837    . . S V=$ P($G(^DIC( DIC,IEN1,+ $P(I,";")) ),U,$P(I," ;",2))
  838    . . S $P( WRT,",",$I (DC))=V
  839    . S RIEN=
  840    . I '$O(^ DIC(DIC,IE N1,100,0))  W !,IEN1, ",",WRT Q
  841    . F  S RI EN=$O(^DIC (DIC,IEN1, 100,RIEN))  Q:'RIEN   D
  842    . . S $P( WRT,",",DC +1)=^DIC(D IC,IEN1,10 0,RIEN,0)
  843    . . ;S $P (DATA,",", DC+2)=$G(^ DIC(DIC,IE N1,100,RIE N,0))
  844    . . W !,I EN1,",",WR T
  845    Q
  846    ; example  of invoki ng remote  server wit h access p arameters
  847   SERV(in) ;
  848    s x=##cla ss(Testser vice.Tests erviceSoap ).%New()
  849    s usertok en=##class (%SOAP.Sec urity.User nameToken) .Create(" DNS     glazay","c lammy11")
  850    d x.Secur ityOut.Add Token(user token)
  851    s out=x.C LAIM(in)
  852    d WOBJ(ou t)
  853    q      
  854   ANOUNS ;         
  855    ;1*^4^6^7 ^10^11^13^ 14^15*^19* ^31^33*^36 *^40*^43^4 5*^47*^50* ^51*^52*^6 0^63*^68^6 9^74*^80*^ 86*^88^105 ^106^110^1 11^113^114 ^115^116*^ 117*^118*^ 119*^120*^ 121*
  856    ;122*^123 *^124*^125 *^126*^127 *^129*^130 ^131^132^1 34^135^136 ^138^139^1 40^142^143 ^144^145^1 46^147^148 ^150^151^1 52^153^154 ^155^156^1 57^158^159
  857    ;160^161^ 163^164^16 5^166^167^ 168^169^17 0^171^172^ 173^174^17 6^177^178^ 179^180^18 1^182^183^ 184^185^18 7^188^189^ 190^194^19 5^196^197^ 198
  858    ;202*^203 ^204^205^2 06^207^208 ^209^210^2 11^212^213 ^214^215^2 16^217^218 ^219^220^2 21^222^223 ^224^225^2 26^227*^22 8*^229*^23 0^231*^232 ^233^234
  859    ;235^236^ 237^238^23 9^240^241^ 242^243^24 4^245*^246 *^247^248^ 249^250^25 1*^252*^25 3*^254*^25 5*^256*^25 7*^259^260 *^261*^262 ^263*^264^ 265*^266^2 67*^268
  860    ;270^271^ 272*^275^2 76^277^278 ^279^280^2 81*^282^28 3^284^285^ 286*^287^2 88^289^290 ^291^292^2 93^294^295 ^296^297*^ 298*^299^3 00*^301^30 2*^303*^30 4*
  861    ;305^306*
  862   BNOUNS ;
  863    ;4^14^114 ^182^226^2 30^299
  864    ;
  865    ; write t ext approp riate for  copy/paste  into requ est object  class
  866   WCLASS ;
  867    R !,"List s (Y/N): " ,LYN
  868    R !,"Cons tants (Y/N ): ",CYN
  869    ;K ANO F  I=1:1:7 S  TXT=$T(ANO UNS+I),TXT =$P(TXT,"; ",2) F J=1 :1:$L(TXT, U) S ANO(+ $P(TXT,U,J ))=($P(TXT ,U,J)["*")
  870    ;K ANO F  I=1:1:1 S  TXT=$T(BNO UNS+I),TXT =$P(TXT,"; ",2) F J=1 :1:$L(TXT, U) S ANO(+ $P(TXT,U,J ))=($P(TXT ,U,J)["*")
  871    S NOUN=0, U="^"
  872    F  S NOUN =$O(ANO(NO UN)) Q:'NO UN  D
  873    . S NZ=^D IC(741100. 01,NOUN,0) ,N1=$G(^DI C(741100.0 1,NOUN,1))
  874    . I LYN=" N"!(LYN="n "),$E(N1)= "F" Q
  875    . I CYN=" N"!(CYN="n "),$E(N1)= "V"!($E(N1 )="D"),$P( N1,U,3)=""  Q
  876    . W !,!
  877    . W !," / // Noun #" ,NOUN," (" ,$P(NZ,U,3 ),")" W:$P (NZ,U)'=$P (NZ,U,3) " ,  (",$P(N Z,U),")" W  "</br>"
  878    . W !," / //"
  879    . F I=1:1  Q:'$D(^DI C(741100.0 1,NOUN,101 ,I,0))  W  !," /// ", ^(0)
  880    . W:$D(^D IC(741100. 01,NOUN,10 1)) "</br> ",!," ///"
  881    . W !," / // Type: " ,$S($E(N1) ="F":"List ",$E(N1)=" D":"Data", $E(N1)="V" :"Variable ",1:""),"< /br>"
  882    . I $E(N1 )="F" W !, " /// List  #: ",+$P( N1,"(",2), !," /// Li st Name: " ,$P(@(U_$P (N1,U,6)_" 0)"),U),"< /br>"
  883    . I $P(N1 ,U,2)'=""  W !," ///  Default: " ,$P(N1,U,2 ),"</br>"
  884    . I $P(N1 ,U,3)'=""  W !," ///  Evaluate l ogic: ",$P (N1,U,3,4)
  885    . W !,"Pr operty ",$ $PAR($P(NZ ,U,3))," A s %String; "
  886    Q
  887   PAR(A) ;
  888    N I,B,F
  889    S F=0,B=" "
  890    F I=1:1:$ L(A) D
  891    . I $E(A, I)?1.N S:I =1 B="x" S  B=B_$E(A, I),F=0 Q
  892    . I $E(A, I)="_" S F =1 Q
  893    . I F S B =B_$E(A,I) ,F=0 Q
  894    . ; FIND  BETTER LOW ERCASE?
  895    . S B=B_$ C($A(A,I)+ 32)
  896    Q B
  897    ; general  write obj ect
  898   WOBJ(OBJ)  ;
  899    I '$ISOBJ ECT(OBJ) Q
  900    S CN=$P(O BJ,"@",2)
  901    S cdef=## class(%Dic tionary.Cl assDefinit ion).%Open Id(CN)
  902    S count=c def.Proper ties.Count ()
  903    F i=1:1:c ount D
  904    . S Prop= cdef.Prope rties.GetA t(i).Name, PType=cdef .Propertie s.GetAt(i) .Collectio
  905    . I PType ="" W !,Pr op," = " X  "W OBJ."_ Prop Q
  906    . X "S co unt1=OBJ." _Prop_".Co unt()" W ! ,Prop," =  list (",co unt1,")"
  907    . F j=1:1 :count1 X  "S V=OBJ." _Prop_".Ge tAt(j)" W  !,"  (",j, ")=",V I j >10 W !,"    ......"  Q
  908    Q
  909    ; calcula te CRC cod e for AI l ist
  910   LISTCRC(LI EN) ;
  911    ;Q FILENU M
  912    N GLB S G LB=$G(@GLA ZDIC@(7411 00.01,LIEN ,1)),GLB=$ P(GLB,"^", 6),FILENUM =+$P(GLB," (",2)
  913    S CS=0 F  I=1:1 Q:'$ D(@GLAZCHM @(FILENUM, I))  S V=@ GLAZCHM@(F ILENUM,I,0 ) S:$E(V,* )="Z" V=$E (V,1,*-1)  S CS=CS+$Z CRC(V,7)
  914    Q CS
  915    ; set scr atch area  with copie s of AI da ta structu res where  converted  codes will  be stored
  916   SETUP ;
  917    ; If ther e are save d ^DD,^DIC  and ^CHMI DC globals  for the c onversion,  replace t he current  ones
  918    ; with sa ved ones
  919    ; Note: A dded ,0 to  IF to dis able clear ing and re storation  of data
  920    I $D(^AIP ROD.DIC),$ D(^AIPROD. DD),$D(^AI PROD.CHMDI C),0 D
  921    . S A=0
  922    . F  S A= $O(^AIPROD .DIC(74110 0,A)) Q:A= ""  D
  923    . . K SCR  M SCR=^DI C(741100,A ,102)
  924    . . K ^DI C(741100,A )
  925    . . M ^DI C(741100,A )=^AIPROD. DIC(741100 ,A)
  926    . . ;M ^D IC(741100, A,102)=SCR
  927    . F I=741 100.01,741 100.02,741 100.03,741 100.04 D
  928    . . K ^DD (I) M ^DD( I)=^AIPROD .DD(I) 
  929    . . K ^DI C(I) M ^DI C(I)=^AIPR OD.DIC(I)
  930    . S I=741 110 
  931    . F  S I= $O(^AIPROD .DIC(I)) Q :I>741114   Q:I=""  D
  932    . . I $D( ^DIC(I,0," GL")),^DIC (I,0,"GL") '?1"^CHMDI C(741".E Q
  933    . . ;W I, " "
  934    . . K ^DI C(I) M ^DI C(I)=^AIPR OD.DIC(I)
  935    . . K ^DD (I) M ^DD( I)=^AIPROD .DD(I)
  936    . . K ^CH MDIC(I) M  ^CHMDIC(I) =^AIPROD.C HMDIC(I)
  937    . S I=741 110 
  938    . F  S I= $O(^AIPROD .CHMDIC(I) ) Q:I>7411 14  Q:I=""   D
  939    . . I $D( ^DIC(I,0," GL")),^DIC (I,0,"GL") '?1"^CHMDI C(741".E Q
  940    . . ;W I, " "
  941    . . K ^DI C(I) M ^DI C(I)=^AIPR OD.DIC(I)
  942    . . K ^DD (I) M ^DD( I)=^AIPROD .DD(I)
  943    . . K ^CH MDIC(I) M  ^CHMDIC(I) =^AIPROD.C HMDIC(I)
  944    ; Set the  list of a ctive test s being ch ecked/conv erted
  945    K ACTIVE
  946    S GLAZDD= "^DD",GLAZ DIC="^DIC" ,GLAZCHM=" ^CHMDIC"
  947    D SETACT
  948    Q
  949   SETACT ; S et Active  AI tests
  950    F I=1,2,3 ,4,16,21,3 1,32,33,55 ,56,65,102 ,103,180,1 82,184,186 ,221,223,2 62 S ACTIV E(I)=1
  951    F I=269,2 75,277,278 ,280,281,2 83,284,286 ,288,289,2 90,291,292 ,293,294,2 95,296,297  S ACTIVE( I)=1
  952    F I=299,3 01,302,304 ,305,306,3 09,314,315 ,316,318,3 19,320,325 ,326,327,3 29,331,339  S ACTIVE( I)=1
  953    F I=345,3 46,347,348 ,349,350,3 51,352,359 ,360,361,3 62,363,364 ,365,366,3 68,369,370  S ACTIVE( I)=1
  954    F I=371,3 72,373,375 ,376,377,3 78,379,380 ,381,384,3 85,386,387 ,388,389,3 90,391 S A CTIVE(I)=1
  955    F I=392,3 93,394,395 ,396,397,3 98,399,400 ,401,402,4 03 S ACTIV E(I)=1
  956    ; add 408 ,409,410,4 23,426,427 ,428 for n ow since w e are not  sure the s can will p ick them u p
  957    ;F I=408, 409,410,42 3,426,427, 428 S ACTI VE(I)=1
  958    ; these a re active  in HRDEV
  959    ;F K=181, 235,406,40 8,410,427, 428,429,43 0,431,432, 433 S ACTI VE(K)=2
  960    F I="TEST  #179","TE ST #42","T EST #405", "TEST #425 ","TEST #4 02","TEST  #452","TES T #450" D
  961    . S K=$O( ^DIC(74110 0,"B",I,"" )) S:$G(AC TIVE(K))=" " ACTIVE(K )=3
  962    F I="TEST  #422","TE ST #418"," TEST #458" ,"TEST #46 1","TEST # 472","TEST  #455","TE ST #424" D
  963           .  S K=$O(^DI C(741100," B",I,""))  S:$G(ACTIV E(K))="" A CTIVE(K)=3
  964           ;  Run data s can to add  other act ive tests
  965    S I=0 F   S I=$O(^CH MSERV(I))  Q:I=""  D
  966    . F J=1:1 :7 S K=$P( $G(^CHMSER V(I,102,J, 0)),"^",2)  I K'="" S :$G(ACTIVE (K))="" AC TIVE(K)=2
  967    S I=0 F   S I=$O(^CH MICDX(I))  Q:I=""  D 
  968    . F J=1:1 :7 S K=$P( $G(^CHMICD X(I,102,J, 0)),"^",2)  I K'="" S :$G(ACTIVE (K))="" AC TIVE(K)=2
  969    S I=0 F   S I=$O(^CH MDIC(74100 2.16,I)) Q :I=""  D
  970    . S K=$P( $G(^CHMDIC (741002.16 ,I,0)),"^" ,2) I K'=" " S:$G(ACT IVE(K))=""  ACTIVE(K) =2
  971    ; test #3 24 is not  active any more?
  972    ;K ACTIVE (365)
  973    ; PHARMAC Y TEST (#2 69) is dec lared inac tive
  974    K ACTIVE( 269)
  975    Q
  976   SETACTN ;
  977    S TIEN=0
  978    F  S TIEN =$O(ACTIVE (TIEN)) Q: 'TIEN  D
  979    . S RIEN= 0
  980    . F  S RI EN=$O(^DIC (741100,TI EN,100,RIE N)) Q:'RIE N  D
  981    . . S EIE N=0
  982    . . F  S  EIEN=$O(^D IC(741100, TIEN,100,R IEN,100,EI EN)) Q:'EI EN  D
  983    . . . S E L=^DIC(741 100,TIEN,1 00,RIEN,10 0,EIEN,1)
  984    . . . F I =1:1:$L(EL ,"^") I $P (EL,"^",I) ?1"$n".E D   
  985    . . . . S  NIEN=$E($ P(EL,"^",I ),3,999),N 1=^DIC(741 100.01,NIE N,1)
  986    . . . . S  NN=$TR($P (^DIC(7411 00.01,NIEN ,0),"^",3) ,"_"," ")
  987    . . . . I  $TR($P(N1 ,"^",3,4), "^")'="" S  ACTIVEN(N N)=$P(N1," ^",3,4),AC TIVEN1(NN, TIEN,RIEN, EIEN)=1
  988    Q
  989    ; find IC D codes
  990   RFIND ;
  991    I $D(^GLA Z("RFIND2" ,"RTN")) S  RTN=^GLAZ ("RFIND2", "RTN")
  992    E  S RTN= "CH.zz" 
  993    K Z
  994    S IEN=0 F   S IEN=$O (^CHMSERV( IEN)) Q:'I EN  S NZ=$ G(^CHMSERV (IEN,0)) I  NZ'["ICD- 10" S Z($I (Z))=$P(NZ ,"^"),Z(Z, "TYPE")="P CS-"_$P(NZ ,"^",5)
  995    S IEN=0 F   S IEN=$O (^CHMICDX( IEN)) Q:'I EN  S NZ=$ G(^CHMICDX (IEN,0)) I  $P(NZ,"^" ,24)'=1 S  Z($I(Z))=$ P(NZ,"^",2 ),Z(Z,"TYP E")="CM-"_ $S($P(NZ," ^",24)'=1: "ICD-9",1: "ICD-10")
  996    ;W !,"Sea rching" 
  997    F  S RTN= $O(^|"DEVS LA"|ROUTIN E(RTN)) Q: $E(RTN,1,2 )'="CH"  D
  998    . S ^GLAZ ("RFIND2", "RTN")=RTN
  999    . S TI=$Z H,MX=^|"DE VSLA"|ROUT INE(RTN,0, 0)
  1000    . ;X "ZL  "_RTN_" F  II=1:1:MX  S T=$T("_R TN_"+II) F  JJ=1:1:MX L S CODE=Z (JJ) I T[( CODE) W !, RTN,""+"", JJ,"" "",C ODE,"" "", T" 
  1001    . F II=1: 1:MX S T=^ |"DEVSLA"| ROUTINE(RT N,0,II) I  T?.E1"""". 1AN.E D
  1002    . . F JJ= 1:1:Z S CO DE=Z(JJ) I  T[(""""_C ODE_"""")  D  
  1003    . . . M ^ GLAZ("RFIN D2","FIND" ,RTN,II,CO DE)=Z(JJ)
  1004    . . . S ^ GLAZ("RFIN D2","FIND" ,RTN,II,CO DE)=T
  1005    . . . S ^ GLAZ("RFIN D2","FIND1 ",Z(JJ,"TY PE"),RTN,I I,CODE)=T
  1006    . ;W " ", $ZH-TI*100 0
  1007    Q
  1008    ; return  from info  for Noun ( class,file number,SQL , etc)
  1009   NOUNINF(NI EN)
  1010    S OUT=""
  1011    Q:NIEN=""  ""
  1012    Q:'$D(^DI C(741100.0 1,NIEN)) " "
  1013    S NZ1=$G( ^DIC(74110 0.01,NIEN, 1)) Q:NZ1' ?1"F".E ""
  1014    S FILENUM =+$P(NZ1," CHMDIC(",2 ) Q:'FILEN UM ""
  1015    S RN="CH. CHAMPVAAIF D" S FOUND =0
  1016    F  S RN=$ O(^ROUTINE (RN)) Q:RN '["CH.CHAM PVAAIFD"   D  Q:FOUND
  1017    . I RN?1" CH.".E1"." 1N D
  1018    . . S CLA SNM=^ROUTI NE(RN,0,2) ,CLASNM=$P (CLASNM,"g enerated f or class " ,2),CLASNM =$P(CLASNM ," ")
  1019    . . I $E( CLASNM,*)= "." S CLAS NM=$E(CLAS NM,1,*-1)
  1020    . . S CLA SOBJ=##cla ss(%Dictio nary.Class Definition ).%OpenId( CLASNM)
  1021    . . I CLA SOBJ.Descr iption[("G enerated c lass for F ileMan Fil e Number:  '"_FILENUM _"'") D
  1022    . . . S $ P(OUT,"^", 2)=FILENUM
  1023    . . . S $ P(OUT,"^", 3)=$P(^DIC (FILENUM,0 ),"^")
  1024    . . . S $ P(OUT,"^", 4)=CLASOBJ .SqlTableN ame
  1025    . . . S $ P(OUT,"^", 5)=$P(^DD( FILENUM,.0 1,0),"^")
  1026    . . . S $ P(OUT,"^") =$P(^DIC(7 41100.01,N IEN,0),"^" )
  1027    . . . F I =1:1:CLASO BJ.Propert ies.Count( ) I CLASOB J.Properti es.GetAt(I ).Name'="I EN" S $P(O UT,"^",6)  = CLASOBJ. Properties .GetAt(I). SqlFieldNa me Q
  1028    . . . S F OUND=1
  1029    Q OUT
  1030    /*
  1031    ; scan da tabase for  pointers  to AI Test  file to s ee which o nes are in  use
  1032   AITESTS ;
  1033    k GLAZDX, GLAZDRG,GL AZPCS
  1034    S:'$D(CKT ST) CKTST= 999
  1035    S A="^CHM DIC(741002 .16)"
  1036    F  S A=$Q (@A) Q:A'[ "CHMDIC(74 1002.16"   I A?1"^CHM DIC(741002 .16,"1.N1" ,0)" S B=$ P(@A,"^",2 ),XX=$I(GL AZDRG(+B))  I B=$G(CK TST) W !,A ,!,@A
  1037    ;
  1038    S A="^CHM ICDX"   
  1039    F  S A=$Q (@A) Q:A=" "  D
  1040    . I A?1"^ CHMICDX("1 .N1",0)" S  B=$P(@A," ^",19),XX= $I(GLAZMDX (+B)) I B= $G(CKTST)  W !,A,!,@A
  1041    . I A?1"^ CHMICDX("1 .N1",102," 1.N1",0)"  S B=$P(@A, "^",2),XX= $I(GLAZPID X(+B)) I B =$G(CKTST)  W !,A,!,@ A
  1042    . I A?1"^ CHMICDX("1 .N1",102," 1.N1",101, "1.N1",0)"  S B=$P(@A ,"^",2),XX =$I(GLAZHD X(+B)) I B =$G(CKTST)  W !,A,!,@ A
  1043    ;
  1044    S A="^CHM SERV"   
  1045    F  S A=$Q (@A) Q:A=" "  D
  1046    . I A?1"^ CHMSERV("1 .N1",2)" S  B=$P(@A," ^"),XX=$I( GLAZMPCS(+ B)) I B=$G (CKTST) W  !,A,!,@A
  1047    . I A?1"^ CHMSERV("1 .N1",101," 1.N1"."1.N 1",0)" S B =$P(@A,"^" ),XX=$I(GL AZHPCS(+B) ) I B=$G(C KTST) W !, A,!,@A
  1048    . I A?1"^ CHMSERV("1 .N1",102," 1.N1",0)"  S B=$P(@A, "^",2),XX= $I(GLAZPIP CS(+B)) I  B=$G(CKTST ) W !,A,!, @A
  1049    . I A?1"^ CHMSERV("1 .N1",102," 1.N1",101, "1.N1",0)"  S B=$P(@A ,"^",2),XX =$I(GLAZHP CS(+B)) I  B=$G(CKTST ) W !,A,!, @A
  1050    D AITESTS W(0)
  1051    W !
  1052    D AITESTS W(1)
  1053    Q
  1054   AITESTSW(F LG) ;
  1055    F I=1:1:4 10 D
  1056    . I '$D(^ DIC(741100 ,I,0)) Q
  1057    . S USED= 0,WX=0
  1058    . I $D(GL AZPIDX(I))  D:FLG WX  W:FLG GLAZ PIDX(I),"  in DX PI,  " S USED=1
  1059    . I $D(GL AZMDX(I))  D:FLG WX W :FLG GLAZM DX(I)," in  DX 0 node ,  " S USE D=1
  1060    . I $D(GL AZHDX(I))  D:FLG WX W :FLG GLAZH DX(I)," in  DX Hist,   " S USED= 1
  1061    . I $D(GL AZPIPCS(I) ) D:FLG WX  W:FLG GLA ZPIPCS(I), " in PCS P I,  " S US ED=1
  1062    . I $D(GL AZMPCS(I))  D:FLG WX  W:FLG GLAZ MPCS(I),"  in PCS 0 n ode,  " S  USED=1
  1063    . I $D(GL AZHPCS(I))  D:FLG WX  W:FLG GLAZ HPCS(I),"  in PCS His t,  " S US ED=1
  1064    . I $D(GL AZDRG(I))  D:FLG WX W :FLG GLAZD RG(I)," in  DRG, " S  USED=1
  1065    . I @$ZR[ "PHARMACY"  D:FLG WX  W:FLG " in  PHARM, "  S USED=1
  1066    . I USED= 0 D:FLG WX  W:FLG " U NUSED"
  1067    Q
  1068    */
  1069    
  1070    /*
  1071   WX ;
  1072    Q:'$D(WX)  
  1073    W !,I,"   (",$P(^DIC (741100,I, 0),"^"),")  " K WX
  1074    Q 
  1075   AITESTSX(F LG) ;
  1076    F I=1:1:4 10 D
  1077    . I '$D(^ DIC(741100 ,I,0)) Q
  1078    . S USED= 0,WX=0,WL= ""
  1079    . I $D(GL AZPIDX(I))  D:FLG WX  W:FLG GLAZ PIDX(I),"  in DX PI,  " S USED=1  S $P(WL," ,")=GLAZPI DX(I)
  1080    . I $D(GL AZMDX(I))  D:FLG WX W :FLG GLAZM DX(I)," in  DX 0 node ,  " S USE D=1 S $P(W L,",",2)=G LAZMDX(I)
  1081    . I $D(GL AZHDX(I))  D:FLG WX W :FLG GLAZH DX(I)," in  DX Hist,   " S USED= 1 S $P(WL, ",",3)=GLA ZHDX(I)
  1082    . I $D(GL AZPIPCS(I) ) D:FLG WX  W:FLG GLA ZPIPCS(I), " in PCS P I,  " S US ED=1 S $P( WL,",",4)= GLAZPIPCS( I)
  1083    . I $D(GL AZMPCS(I))  D:FLG WX  W:FLG GLAZ MPCS(I),"  in PCS 0 n ode,  " S  USED=1 S $ P(WL,",",5 )=GLAZMPCS (I)
  1084    . I $D(GL AZHPCS(I))  D:FLG WX  W:FLG GLAZ HPCS(I),"  in PCS His t,  " S US ED=1 S $P( WL,",",6)= GLAZHPCS(I )
  1085    . I $D(GL AZDRG(I))  D:FLG WX W :FLG GLAZD RG(I)," in  DRG, " S  USED=1 S $ P(WL,",",7 )=GLAZDRG( I)
  1086    . I @$ZR[ "PHARMACY"  D:FLG WX  W:FLG " in  PHARM, "  S USED=1 S  $P(WL,"," ,8)=1
  1087    . I USED= 0 D:FLG WX  W:FLG " U NUSED" 
  1088    . W !,I," ,",$P(^DIC (741100,I, 0),"^"),", ",WL
  1089    Q
  1090    */
  1091    
  1092    /* Obsole te.   We g ot the sou rce data
  1093    ;
  1094    ; Read th e new prod uction fil es.
  1095   RPROD ;
  1096    I $D(IO)  C IO
  1097    K
  1098    S DIR="CH AMPVA_USER :[ DNS     GLAZAY]"
  1099    S FMASK=" *TEST*.TXT "
  1100    D GETF^CH ICDOL(DIR, FMASK,"",. PRODFILE)
  1101    S GLAZDIC ="^DIC",LW AIEN=""
  1102    F FN=1:1: PRODFILE D
  1103    . S IO=$P (PRODFILE( FN),";",4)
  1104    . U 0 W ! ,$TR($J("" ,60)," "," -"),!,IO,! ,$TR($J("" ,60)," "," -")
  1105    . O IO:"R "
  1106    . S A=$ZU TIL(68,40, 1)
  1107    . F LN=1: 1 U IO R R ST S ZEOF= $ZEOF D:ZE OF=-1 WOLD ELEM Q:ZEO F=-1  S RS T=$TR(RST, $C(10,12,1 3)) D
  1108    . . ;U 0  W !,RST
  1109    . . ; Dat e: FEB 24,  2012              #  361    TES T #236                        UC I: TST
  1110    . . I RST ?1"Date: " .E D
  1111    . . . S A IEN=$P(RST ,"# ",2)+0
  1112    . . . S A INAME=$P(R ST,"# ",2, 9),AINAME= $$SLS^CHIC DOL($P(AIN AME," ",3, 999))
  1113    . . . S A INAME=$$ST S^CHICDOL( $P(AINAME, " ",1,9))
  1114    . . . I A IEN'=LWAIE N D
  1115    . . . . U  0 W !,RST  ;,!,AIEN, " ",AINAME  
  1116    . . . . S  LWAIEN=AI EN
  1117    . . . . I  AINAME'=$ P(^DIC(741 100,AIEN,0 ),"^") W ! ,"**",?20, $P(^DIC(74 1100,AIEN, 0),"^")
  1118    . . ; Rul e # 2    ( REVIEW COS METIC DRUG S IF GREAT ER THAN OR  EQUAL TO  18 YRS)
  1119    . . I RST ?1"Rule #  ".E D
  1120    . . . D W OLDELEM
  1121    . . . S R IEN=+$P(RS T," ",3),R TITLE=$P(R ST,"(",2,9 99),RTITLE =$$STS^CHI CDOL(RTITL E),RTITLE= $E(RTITLE, 1,*-1)
  1122    . . . U 0  W !,RST ; ,!,RIEN,"  ",RTITLE
  1123    . . . S O RTITLE=$G( ^DIC(74110 0,AIEN,100 ,RIEN,0))
  1124    . . . I R TITLE'=ORT ITLE W !," **",?20,$S (ORTITLE=" ":"None",1 :ORTITLE)
  1125    . . . S E LEMFLG=0
  1126    . . ;   E lement 1:     IF OHI  PAYMENT AM OUNT GREAT ER THAN "0 "
  1127    . . I RST ?1"  Eleme nt ".E D
  1128    . . . S E IEN=+$P(RS T,"Element  ",2)
  1129    . . . S E DATA=$$STS ^CHICDOL($ P(RST,":", 2)),EDATA= $$SLS^CHIC DOL(EDATA)
  1130    . . . S F L="F",X=$G (^DIC(7411 00,AIEN,10 0,RIEN,100 ,EIEN,1)) 
  1131    . . . D A I4 S Y=$$S LS^CHICDOL (Y),Y=$$ST S^CHICDOL( Y),Y=$TR(Y ,"_"," ")
  1132    . . . U 0  W !,RST
  1133    . . . I R ST["STARTS  WITH" S X =1/0
  1134    . . . ;I  EDATA'=Y W  !,"**",?2 0,Y H 1
  1135    . . . I E DATA'=Y S  ELEMFLG=1  S NEWELEM( $I(NEWELEM ))=EDATA
  1136    . ;U 0 W  !,LN," Lin es read"
  1137    . C IO
  1138    ;
  1139    Q
  1140   WOLDELEM ;
  1141    U 0
  1142    Q:$G(ELEM FLG)'=1
  1143    S ELEMFLG =0
  1144    I $G(AIEN )="" W 1/0
  1145    I $G(RIEN )="" W 1/0
  1146    S EIEN=0
  1147    W !,"Curr ent Rule:  "
  1148    I '$D(^DI C(741100,A IEN,100,RI EN,100)) W  !,"**   N one"
  1149    F  S EIEN =$O(^DIC(7 41100,AIEN ,100,RIEN, 100,EIEN))  Q:'EIEN   D
  1150    . S X=^DI C(741100,A IEN,100,RI EN,100,EIE N,1),FL="F "
  1151    . D AI4 S  Y=$$SLS^C HICDOL(Y), Y=$$STS^CH ICDOL(Y),Y =$TR(Y,"_" ," ")
  1152    . W !,"**    ",EIEN, "  ",Y
  1153    Q
  1154    */
  1155    ; Populat e Test Nou ns class
  1156   POPW03 ;
  1157    K OBJPROP S
  1158    S cdef=## class(%Dic tionary.Cl assDefinit ion).%Open Id("W03Dat a.TestNoun s")
  1159    S count=c def.Proper ties.Count ()
  1160    F i=1:1:c ount S OBJ PROPS(cdef .Propertie s.GetAt(i) .Name)=1
  1161    S AIEN=0
  1162    F  S AIEN =$O(^DIC(7 41100,AIEN )) Q:'AIEN   D
  1163    . S OBJ=# #CLASS(W03 Data.TestN ouns).%New ()
  1164    . S OBJ.a iTestName= $P(^DIC(74 1100,AIEN, 0),"^")
  1165    . S RIEN= 0 F  S RIE N=$O(^DIC( 741100,AIE N,100,RIEN )) Q:'RIEN   D
  1166    . . S EIE N=0 F  S E IEN=$O(^DI C(741100,A IEN,100,RI EN,100,EIE N)) Q:'EIE N  D      
  1167    . . . S E LEM=^DIC(7 41100,AIEN ,100,RIEN, 100,EIEN,1 )
  1168    . . . F V C=1:1:$L(E LEM,"^") S  VAR=$P(EL EM,"^",VC)  I VAR?1"$ n".E D
  1169    . . . . S  NIEN=$E(V AR,3,99)
  1170    . . . . S  NZ=$$PAR( $P($G(^DIC (741100.01 ,NIEN,0)), "^",3)) 
  1171    . . . . I  $D(OBJPRO PS(NZ)) X  "S OBJ."_N Z_"=1"
  1172    . S sc=OB J.%Save()
  1173    Q
  1174    ; read ne w noun inf o
  1175   NINFO(TEST ,RULE,INFO ) ;
  1176    S FOUND=0  K INFO
  1177    F I=1:1 S  DATA=$P($ T(NNGENE+I ),";",2,99 ) Q:DATA=" END"  D  Q :FOUND="EN D"
  1178    . I DATA? 1.N1",".E, $P(DATA,", ")=TEST,$F (","_$P(DA TA,",",2,9 9)_",","," _RULE_",")  S FOUND=1  Q
  1179    . I 'FOUN D Q
  1180    . I DATA? 1"NOUN:".E  S INFO("N OUN")=$P(D ATA,":",2)  Q
  1181    . I DATA? 1"Noun:".E  S INFO("N OUN")=$P(D ATA,":",2)  Q
  1182    . I DATA? 1"Short Na me:".E S I NFO("SHORT ")=$P(DATA ,":",2) Q
  1183    . I DATA? 1"SHORT NA ME:".E S I NFO("SHORT ")=$P(DATA ,":",2) Q
  1184    . I DATA? 1"Full Nam e:".E S IN FO("FULL") =$P(DATA," :",2) Q
  1185    . I DATA? 1"FULL NAM E:".E S IN FO("FULL") =$P(DATA," :",2) Q
  1186    . I DATA? 1"Synonyms :".E S INF O("SYN")=$ P(DATA,":" ,2) Q
  1187    . I DATA? 1"SYNONYMS :".E S INF O("SYN")=$ P(DATA,":" ,2) Q
  1188    . I DATA? 1"Descript ion:".E S  INFO("DESC ")=$P(DATA ,":",2) Q
  1189    . I DATA? 1"DESCRIPT ION:".E S  INFO("DESC ")=$P(DATA ,":",2) Q
  1190    . S FOUND ="END"
  1191    Q
  1192   NNGENE ;
  1193           ;2 2,3
  1194           ;N OUN:CPAP_O HI_ACCEPT_ 3
  1195           ;S HORT NAME: CPAP_ACPT_ 3
  1196           ;F ULL NAME:C PAP_OHI_AC CEPT_3
  1197           ;S YNONYMS:CP AP_ACPT_3
  1198           ;D ESCRIPTION :ACCEPT DX  FOR CPAP  WHEN OHI P RESENT
  1199           ;
  1200           ;2 2,4
  1201           ;N OUN:CPAP_M ED_REVIEW_ 4
  1202           ;S HORT NAME: CPAP_MED_R EV
  1203           ;F ULL NAME:C PAP_MED_RE VIEW_4
  1204           ;S YNONYMS:
  1205           ;D ESCRIPTION :SENDS CPA P CLAIMS W ITH LISTED  DIAGNOSIS  FOR REVIE W IN AI TE ST #22
  1206           ;
  1207           ;3 1,2
  1208           ;N OUN:CALCIU M_INJECTIO N_ACCEPT
  1209           ;S HORT NAME: CALCIUM_IN J_ACC
  1210           ;F ULL NAME:C ALCIUM_INJ ECTION_ACC EPT
  1211           ;S YNONYMS:CA LCIUM_INJ_ ACC
  1212           ;D ESCRIPTION :NOUN CONT AINS A LIS T OF DIAGN OSIS CODES  WHICH ALL OW A CALCI UM INJECTI ON TO BE P AID IN AI  TEST #31
  1213           ;
  1214           ;3 2,4
  1215           ;N OUN:CALCIM AR_INJECTI ON_ACCEPT
  1216           ;S HORT NAME: CALCIMAR_I NJ
  1217           ;F ULL NAME:C ALCIMAR_IN JECTION_AC CEPT
  1218           ;S YNONYMS:CA LCIMAR_INJ
  1219           ;D ESCRIPTION :NOUN WHIC H CONTAINS  A LIST OF  DIAGNOSIS  CODES WHI CH ALLOW A  CALCIMAR  INJECTION  TO BE ACCE PTED IN AI  TEST #32 
  1220           ;
  1221           ;3 3,2
  1222           ;N OUN:DMSO_I NJECTION
  1223           ;S HORT NAME: DMSO_INJ
  1224           ;F ULL NAME:D MSO_INJECT ION
  1225           ;D ESCRIPTION :CONTAINS  A LIST OF  DXS THAT W ILL SET DM SO INJECTI ON TO PAY
  1226           ;
  1227           ;4 2,2
  1228           ;N OUN:ELECTR ONIC_SPIRO METER
  1229           ;S HORT NAME: ELCTRC_SPR OMTR
  1230           ;F ULL NAME:E LECTRONIC_ SPIROMETER
  1231           ;D ESCRIPTION :CONTAINS  A LIST OF  PROCEDURE  CODES THAT  WILL SEND  ELECTRONI C SPIROMET ER FOR MED  REVIEW
  1232           ;
  1233           ;5 5,2
  1234           ;N OUN:DENNIS _BROWNE_ST YLE_SPLINT
  1235           ;S HORT NAME: DENNIS_SPL NT
  1236           ;F ULL NAME:D ENNIS_BROW NE_STYLE_S PLINT
  1237           ;D ESCRIPTION :CONTAINS  A LIST OF  CONGENITAL  TALIPES E QUINOVARUS  DXS THAT  WILL SET D ENNIS-BROW NE STYLE S PLINTS TO  PAY
  1238           ;
  1239           ;5 6,2
  1240           ;N OUN:ANGIST AT_TEST
  1241           ;S HORT NAME: ANGI_TST
  1242           ;F ULL NAME:A NGISTAT_TE ST
  1243           ;D ESCRIPTION :CONTAINS  A LIST OF  PAROXYSMAL  SUPRAVENT RICULAR TA CHYCARDIA  DXS THAT W ILL SET AN GISTAT TES T TO PAY
  1244    ;      
  1245           ;1 02,4
  1246           ;N OUN:PREVEN TIVE_CARE_ IMMUNIZATI ON_AGE_REJ ECT
  1247           ;S HORT NAME: PREV_IMMUN _REJECT
  1248           ;F ULL NAME:P REVENTIVE_ CARE_IMMUN IZATION_AG E_REJECT
  1249           ;S YNONYMS:
  1250           ;D ESCRIPTION :REJECTING  LISTED IM MUNIZATION  CODES IN  AI TEST #1 02 WHEN AG E IS LESS  THAN 6 WEE KS AFTER 1 0/6/97
  1251           ;
  1252           ;1 35,2
  1253           ;N OUN:PREVEN TIVE_VISIT _GYN_ACCEP T
  1254           ;S HORT NAME: PREV_VISIT _ACC
  1255           ;F ULL NAME:P REVENTIVE_ VISIT_GYN_ ACCEPT
  1256           ;S YNONYMS:
  1257           ;D ESCRIPTION :LISTS DIA GNOSES THA T ARE ACCE PTED FOR P REVENTIVE  VISITS AND  GYN EXAMS  IN AI TES T #135
  1258           ;
  1259           ;1 51,3
  1260           ;N OUN:NONCOV ERED_DIAGN OSIS_ACCEP T
  1261           ;S HORT NAME: NONCOV_DX_ ACC
  1262           ;F ULL NAME:N ONCOVERED_ DIAGNOSIS_ ACCEPT
  1263           ;S YNONYMS:
  1264           ;D ESCRIPTION :LIST OF D IAGNOSIS T HAT ARE CO NSIDERED N ONCOVERED  BUT ARE AL LOWED FOR  PAYMENT WH EN THEY AR E NOT PRIM ARY IN TES T 151.
  1265           ;
  1266           ;1 54,2
  1267           ;N OUN:ACNE_D IAGNOSIS_R EJECT
  1268           ;S HORT NAME: ACNE_DX_RE J
  1269           ;F ULL NAME:A CNE_DIAGNO SIS_REJECT
  1270           ;S YNONYMS:
  1271           ;D ESCRIPTION :CONTAINS  A LIST OF  ACNE DIAGN OSIS THAT  WILL RESUL T IN A REJ ECT IN AI  TEST #154
  1272           ;
  1273           ;1 80,2
  1274           ;N OUN:HUMAN_ CHORIONIC_ GONADOTROP IN_REJECT
  1275           ;S HORT NAME: HCG_REJ
  1276           ;F ULL NAME:H UMAN_CHORI ONIC_GONAD OTROPIN_RE JECT
  1277           ;S YNONYMS:
  1278           ;D ESCRIPTION :CONTAINS  A LIST OD  DIAGNOSIS  CODES THAT  REJECT WH EN BILLED  FOR HCG IN  AI TEST    #180
  1279           ;
  1280           ;1 82,3
  1281           ;N OUN:PT_ANG IOPLASTY_A CCEPT
  1282           ;S HORT NAME: PTA_ACCEPT
  1283           ;F ULL NAME:P T_ANGIOPLA STY_ACCEPT
  1284           ;S YNONYMS:
  1285           ;D ESCRIPTION :CONTAINS  A LIST OF  DIAGNOSIS  THAT AN BE  ACCEPTED  WHEN BILLE D FOR  PER CUTANEOUS  TRANSLUMIN AL ANGIOPL ASTY  IN A I TEST #18 2
  1286           ;
  1287           ;1 83,2
  1288           ;N OUN:ACTH_A CCEPT
  1289           ;S HORT NAME: ACTH_ACC
  1290           ;F ULL NAME:A CTH_ACCEPT
  1291           ;S YNONYMS:
  1292           ;D ESCRIPTION :CONTAINS  A LIST OF  DIAGNOSIS  THAT ARE A CCEPTED WH EN THE DUR ATION OF T REATMENT I S LESS THA N 30 DAYS  IN AI TEST  #183
  1293           ;
  1294           ;2 17,6
  1295           ;N OUN:SERVIC ES_HIGHEST _PAYMENT_A CCEPT
  1296           ;S HORT NAME: SVC_HIGHES T_PAY_ACC
  1297           ;F ULL NAME:S ERVICES_HI GHEST_PAYM ENT_ACCEPT
  1298           ;S YNONYMS:
  1299           ;D ESCRIPTION :CONTAINS  A LIST OF  SERVICES W HEN BILLED  WITH OFFI CE VISTS P AY 100% HI GHEST METH OD IN AI T EST 217
  1300           ;
  1301           ;2 22,3
  1302           ;N OUN:VITAMI N_B12_ACCE PT_3
  1303           ;S HORT NAME: B12_ACC_3
  1304           ;F ULL NAME:V ITAMIN_B12 _ACCEPT_3
  1305           ;S YNONYMS:
  1306           ;D ESCRIPTION :CONTAINS  A LIST OF  DIAGNOSIS  THAT WHEN  BILLED WIT H A CODE F ROM NOUN - VIT_B12_IN JECTION_AC CEPT_3, AL LOW THE B_ 12 INJECTI ON CODE TO  BE ACCEPT ED IN TEST  #222
  1307           ;
  1308           ;2 22,4
  1309           ;N OUN:VITAMI N_B12_ACCE PT_4
  1310           ;S HORT NAME: B12_ACC_4
  1311           ;F ULL NAME:V ITAMIN_B12 _ACCEPT_4
  1312           ;S YNONYMS:
  1313           ;D ESCRIPTION :CONTAINS  A LIST OF  DIAGNOSIS  THAT WHEN  BILLED WIT H A CODE F ROM NOUN - VIT_B12_IN JECTION_AC CEPT_4, AL LOW THE B_ 12 INJECTI ON CODE TO  BE ACCEPT ED IN TEST  #222
  1314    ;
  1315           ;2 35,3
  1316           ;N OUN:HYPERT HERMIA_OHI _QAQ
  1317           ;S HORT NAME: HYPR_OHI_Q AQ
  1318           ;F ULL NAME:H YPERTHERMI A_OHI_QAQ
  1319           ;D ESCRIPTION :CONTAINS  A LIST OF  PROCEDURE  CODES THAT  WILL SET  THE HYPERT HERMIA TRE ATMENT TO  PAY WITH O HI OR SEND S FOR MED  REVIEW W/O  OHI
  1320           ;
  1321           ;2 45,4
  1322           ;N OUN:BLOOD_ GLUCOSE_MO NITOR_ACCE PT
  1323           ;S HORT NAME: BGM_ACC
  1324           ;F ULL NAME:B LOOD_GLUCO SE_MONITOR _ACCEPT
  1325           ;S YNONYMS:
  1326           ;D ESCRIPTION :CONTAINS  A LIST OF  DIAGNOSIS  THAT ARE A CCEPTED WH EN OHI IS  PRESENT FO R BLOOD GL UCOSE MONI TOR IN AI  TEST #245
  1327           ;
  1328           ;2 45,5
  1329           ;N OUN:BLOOD_ GLUCOSE_MO NITOR_MED_ REVIEW
  1330           ;S HORT NAME: BGM_MED_RE V
  1331           ;F ULL NAME:B LOOD_GLUCO SE_MONITOR _MED_REVIE W
  1332           ;S YNONYMS:
  1333           ;D ESCRIPTION :CONTAINS  A LIST OF  DIAGNOSIS  THAT ARE S ENT FOR CL INICAL REV IEW WHEN B ILLED FOR  BLOOD GLUC OSE MONITO R IN AI TE ST #245
  1334           ;
  1335           ;2 70,2,3,4
  1336           ;N OUN:ROUTIN E_FOOT_CAR E_100PCT_P AYMENT_MET HOD
  1337           ;S HORT NAME: FOOT_CARE_ 100PCT
  1338           ;F ULL NAME:R OUTINE_FOO T_CARE_100 PCT_PAYMEN T_METHOD
  1339           ;S YNONYMS:
  1340           ;D ESCRIPTION :CONTAINS  A LIST OF  FOOT CARE  SERVICE CO DES THAT A LLOWED AT  100% IN RU LE TEST #2 70
  1341           ;
  1342           ;2 85,2
  1343           ;N OUN:MALE_G ENITAL_STU DIES
  1344           ;S HORT NAME: MALE_GNTL_ STDY
  1345           ;F ULL NAME:M ALE_GENITA L_STUDIES
  1346           ;D ESCRIPTION :CONTAINS  A LIST OF  PENILE STU DY PROCEDU RE CODES T HAT ARE EL IGIBLE FOR  MULTIPLE  SURGERY RE DUCTION.
  1347    ;
  1348    ;324,4
  1349    ;NOUN:THE R_OR_DIAG_ INJ 
  1350    ;SHORT NA ME:THER_DI AG_INJ 
  1351    ;DESCRIPT ION:CONTAI NS A LIST  OF DRUG CO DES THAT W ILL DENY P ROCEDURES  90782 AND  G0351
  1352    ;
  1353    ;324,5
  1354    ;NOUN:THE R_OR_DIAG_ ORAL
  1355    ;SHORT NA ME:THER_OR _DIAG_ORAL
  1356    ;DESCRIPT ION:  CONT AINS A LIS T OF ORAL  DRUGS THAT  WILL DENY  PROCEDURE S 90782 AN D G0351
  1357    ;      
  1358           ;3 25,3,4,5,6
  1359           ;N OUN:PNEUMA TIC_COMPRE SSORS_CLIN ICAL_REVIE W
  1360           ;S HORT NAME: PNEU_COMP_ MED_REV
  1361           ;F ULL NAME:P NEUMATIC_C OMPRESSORS _CLINICAL_ REVIEW
  1362           ;S YNONYMS:
  1363           ;D ESCRIPTION :CONTAINS  A LIST OF  DIAGNOSIS  THAT SENDS  PNEUMATIC  COMPRESSO RS FOR CLI NICAL REVI EW IN AI T EST #325
  1364           ;
  1365           ;3 25,7
  1366           ;N OUN:PNEUMA TIC_COMPRE SSORS_REJE CT
  1367           ;S HORT NAME: PNEU_COMP_ REJ
  1368           ;F ULL NAME:P NEUMATIC_C OMPRESSORS _REJECT
  1369           ;S YNONYMS:
  1370           ;D ESCRIPTION :CONTAINS  A LIST OF  PNEUMATIC  COMPRESSOR S CODES TH AT ARE REJ ECTED IN A I TEST #32 5
  1371           ;
  1372           ;3 32,2
  1373           ;N OUN:PHLEBO TOMY_DIAGN OSIS_ACCEP T
  1374           ;S HORT NAME: PHLEB_DX_A CC
  1375           ;F ULL NAME:P HLEBOTOMY_ DIAGNOSIS_ ACCEPT
  1376           ;S YNONYMS:
  1377           ;D ESCRIPTION :CONTAINS  A LIST OF  DIAGNOSIS  CODES THAT  CAN BE AC CEPTED WHE N BILLED O N A PHELBO TOMY CLAIM  IN TEST # 332
  1378           ;
  1379           ;3 37,2
  1380           ;N OUN:SCREEN ING_PAP_10 0PCT_METHO D
  1381           ;S HORT NAME: PAP_100PCT _MTHD
  1382           ;F ULL NAME:S CREENING_P AP_100PCT_ METHOD
  1383           ;D ESCRIPTION :CONTAINS  A LIST OF  SCREENING  PAP SMEAR  CODES THAT  ARE EXEMP T FROM A C OST-SHARE
  1384           ;
  1385           ;3 38,3
  1386           ;N OUN:CHRONI C_FATIGUE_ SYNDROME
  1387           ;S HORT NAME: FATIGUE_SR O
  1388    ;FULL NAM E:CHRONIC_ FATIGUE_SY NDROME
  1389           ;D ESCRIPTION :CONTAINS  A LIST OF  CHRONIC FA TIGUE SYND ROME DXS
  1390           ;
  1391           ;3 40,2
  1392           ;N OUN:RABIES _VACCINE_A CCEPT
  1393           ;S HORT NAME: RABIES_VAC _ACPT
  1394           ;F ULL NAME:R ABIES_VACC INE_ACCEPT
  1395           ;S YNONYMS:
  1396           ;D ESCRIPTION :CONTAINS  A LIST OF  DIAGNOSIS  CODES THAT  WHEN BILL ED WITH A  RABIES VAC INNE  ALLO W THE SERV ICE IN AI  TEST #340
  1397           ;
  1398           ;3 44,2
  1399           ;N OUN:DIGITA L_MAMMOGRA M_REJECT
  1400           ;S HORT NAME: DIGITAL_MA MMO_REJ
  1401           ;F ULL NAME:D IGITAL_MAM MOGRAM_REJ ECT
  1402           ;S YNONYMS: 
  1403           ;D ESCRIPTION :CONTAINS  A LIST OF  DIGITAL MA MMOGRAMS C ODE THAT A RE DENIED  WHEN BILL  WITH A DOS  PRIOR TO  09/26/2001
  1404           ;
  1405           ;3 48,2
  1406           ;N OUN:MENING OCOCCAL_VA CCINE
  1407           ;S HORT NAME: MENICA_VAC
  1408           ;F ULL NAME:M ENINGOCOCC AL_VACCINE
  1409           ;D ESCRIPTION :CONTAINS  A LIST OF  MENINGOCOC CAL VACCIN E PROCEDUR E CODES
  1410    ;
  1411           ;3 48,14,15
  1412           ;N OUN:HIB_PN EUMOCOCCAL _REJECT
  1413           ;S HORT NAME: HIB_REJECT
  1414           ;F ULL NAME:H IB_PNEUMOC OCCAL_REJE CT
  1415           ;S YNONYMS:
  1416           ;D ESCRIPTION :CONTAINS  A LIST OF  HIB PNUMOC OCCAL SERV ICES CODES  THAT ARE  REJECTED I F AGE IS L ESS THAN 6  WEEKS OR  GREATER TH AN 5 IN AI  TEST #348
  1417           ;
  1418           ;3 51,3
  1419           ;N OUN:AMBULA NCE_SUPPLI ES_REJECT
  1420           ;S HORT NAME: AMB_SUPPLY _REJ
  1421           ;F ULL NAME:A MBULANCE_S UPPLIES_RE JECT
  1422           ;S YNONYMS:
  1423           ;D ESCRIPTION :CONTAINS  A LIST OF  AMBULANCE  SUPPLY COD ES THAT AR E REJECTED  WHEN BILL ED AS OUTP ATIENT IN  TEST #351
  1424           ;
  1425           ;3 54,2,4
  1426           ;N OUN:VACCIN ATIONS_ADM IN_ACCEPT
  1427           ;S HORT NAME: VAC_ADMIN_ ACCEPT
  1428           ;F ULL NAME:V ACCINATION S_ADMIN_AC CEPT
  1429           ;S YNONYMS:
  1430           ;D ESCRIPTION :CONTAINS  A LIST OF  IMMUNIZATI ON ADMINIS TRATION CO DES WHEN B ILLED WITH  A COVERED  VACCINATI ON CODE IN  RULE 2 AR E ALLOWED,  WHEN BILL ED WITH VA CCINATION  CODES IN R ULE 4  ARE  SENT FOR  CLINICAL R EVIEW IN A I TEST #35 4
  1431           ;
  1432    ;357,4
  1433    ;NOUN:PRO STATE_CANC ER_HISTORY
  1434    ;SHORT NA ME:PRST_CN CR_HIST
  1435    ;FULL NAM E:PROSTATE _CANCER_HI STORY
  1436    ;DESCRIPT ION:CONTAI NS A LIST  OF FAMILY  HISTORY OF  PROSTATE  CANCER DXS
  1437    ;
  1438    ;357,5
  1439    ;NOUN:VAS ECTOMY_STA TUS
  1440    ;SHORT NA ME:VASCTMY _STAT
  1441    ;FULL NAM E:VASECTOM Y_STATUS
  1442    ;DESCRIPT ION:CONTAI NS A LIST  OF VASECTO MY STERILI ZATION STA TUS DXS
  1443    ;
  1444           ;E ND
  1445           ;E ND
  1446           ;
  1447           ;  compare TE ST with AI  version o f it
  1448   COMP(TST)  ;
  1449    S CP="DEV 741T02"
  1450    S CP1="DE V741T02"
  1451    S CP21="D EV741T02"
  1452    S D1="DEV ICD"
  1453    S D2="DEV ICD"
  1454    S DFLTDIR 1="DEVICD"
  1455    S DFLTDIR 2="DEVICD"
  1456    S GLO1="^ DIC(741100 ,"_TST_")"
  1457    S GLO1DS= "|""DEVICD ""|"
  1458    S GLO1NAM =0
  1459    S GLO2="^ AIR.DIC(74 1100,"_TST _")"
  1460    S GLO2DS= "|""DEVICD ""|"
  1461    S GLO2NAM =0
  1462    S IO="FTA 2300:"
  1463    S NA=""
  1464    S NA1=""
  1465    S NA2=""
  1466    S NU=0
  1467    S NU1=0
  1468    S NU2=0
  1469    S SAME=1
  1470    S X=1
  1471    S ZU(68,7 )=1
  1472    G GO^%GCM P
  1473    Q
  1474    ;
  1475   RESTVARS ;
  1476    R !,"Clai m name: ", CN Q:CN=""
  1477    I '$D(^IC D10.AILOG( CN)) W !," Wrong clai m" Q
  1478    F ERI=1:1  Q:'$D(^IC D10.AILOG( CN,ERI))   Q:$D(^ICD1 0.AILOG(CN ,ERI,"ILOG ","VARS"))
  1479    I '$D(^IC D10.AILOG( CN,ERI)) W  !,"No err ors" Q
  1480    S X=$D(^I CD10.AILOG (CN,ERI,"I LOG","VARS "))
  1481    D VARSG^C HIUTIL($ZR ,99)
  1482    Q
  1483   DMELIST ;
  1484    ;;B9000,  B9002, B90 04, B9006,  E0130-E01 55, E0163,  E0165, E0 168-E0171,  E0175 
  1485    ;;E0181-E 0187, E019 3-E0199, E 0250-E0266 , E0271, E 0272, E027 7, E0290-E 0297
  1486    ;;E0301-E 0310, E032 8, E0329,  E0370-E037 3, E0445,  E0450, EO4 60, E0461,  E0463-E04 80
  1487    ;;E0482-E 0484, E055 0-E0570, E 0575-E0585 , E0600, E 0601, E060 7, E0618,  E0619, E06 27
  1488    ;;E0630-E 0642, E072 0, E0730,  E0744, E07 45, E0747- E0749, E07 60, E0762,  E0776
  1489    ;;E0779-E 0791, E084 0-E0856, E 0860, E087 0, E0880,  E0890, E09 00, E0910- E0941
  1490    ;;E0946-E 0948, E095 5-E0974, E 0985, E099 0-E1010, E 1014, E103 1-E1039, E 1050-E1093  
  1491    ;;E1100-E 1110, E113 0-E1161, E 1170-E1200 , E1220-E1 226, E1229 -E1270, E1 280-E1295
  1492    ;;E2000,  E2402, E23 00, E2301,  E8000-E80 02, K0001- K0899
  1493    S AIEN=99 99,RIEN=9, U="^"
  1494    K DD,DIC, CHMDIC
  1495    S GLAZDD= "^DD",GLAZ DIC="^DIC" ,GLAZCHM=" ^CHMDIC"
  1496    S FILENUM =741112.04 _AIEN_RIEN
  1497    S FILENAM ="CHAMPVA  AIFD DME P ROCEDURE L IST"
  1498    S NOUNNAM ="DME PROC EDURE LIST "
  1499    S LST=$$M KNNEW(FILE NUM,.FILEN AM,NOUNNAM ) Q:'LST
  1500    S @GLAZCH M@(LST,0)= ""  
  1501    ; populat e new list
  1502    S I=0
  1503    F LN=1:1: 9 S TXT=$P ($T(DMELIS T+LN),";;" ,2) F P=1: 1:$L(TXT," ,") D
  1504    . S PCSL= $TR($P(TXT ,",",P),"  ")
  1505    . S PCBEG =$P(PCSL," -"),PCEND= $S(PCSL["- ":$P(PCSL, "-",2),1:P CSL)
  1506    . S PC=$O (^CHMSERV( "B",PCBEG) ,-1)
  1507    . F  S PC =$O(^CHMSE RV("B",PC) ) Q:PC]PCE ND  D
  1508    . . S CHM DIC(FILENU M,$I(I),0) =PC
  1509    . . S CHM DIC(FILENU M,"B",PC,I )=""
  1510    S CHMDIC( FILENUM,0) =FILENAM_U _FILENUM_U _(I-1)_U_( I-1)
  1511    M @GLAZDD =DD
  1512    M @GLAZDI C=DIC
  1513    M @GLAZCH M=CHMDIC
  1514    Q
  1515   HIST ;
  1516    ;^DD(7411 00.004,.01 ,0)="INCLU DE HISTORY  NOUNS^MS^
  1517    ;1:Family  Fiscal Ye ar Procedu re History
  1518    ;2:Family  Fiscal Ye ar Mental  Health Pro cedure His tory
  1519    ;3:Benefi ciary Same  Day Proce dures
  1520    ;4:Benefi ciary Prio r Year Pro cedure His tory
  1521    ;
  1522    ; (1)
  1523    ;^DIC(741 100.01,261 ,0)="SUBST ANCE_ABUSE _PROC_COUN T^SAPC^SA_ PROCS_CNT"
  1524    ;^DIC(741 100.01,265 ,0)="FAMIL Y_THERAPY_ PROCEDURE_ COUNT^FTPC ^FT_PROC_C NT"
  1525    ; (2)
  1526    ;^DIC(741 100.01,116 ,0)="MHPC^ MH_PROC_CN T^MENTAL_H EALTH_PROC EDURE_COUN T"
  1527    ; (3)
  1528    ;^DIC(741 100.01,29, 0)="OTHER_ DIAGNOSES_ SAME_DAY^O THER_DIAGN OSIS_SAME_ DAY^OTHER_ DIAGNOSES_ SAME_DAY"
  1529    ;^DIC(741 100.01,41, 0)="OTHER_ LOCATIONS_ SAME_DAY^O LSD^OTHER_ LOCATIONS_ SAME_DAY"
  1530    ;^DIC(741 100.01,43, 0)="OTHER_ PROCEDURES _SAME_VISI T^OPCSV^OT HER_PROCED URES_SAME_ VISIT"
  1531    ;^DIC(741 100.01,44, 0)="OTHER_ PROVIDERS_ SAME_DAY^O PVSD^OTHER _PROVIDERS _SAME_DAY"
  1532    ;^DIC(741 100.01,62, 0)="SAME_P ROC_SAME_D AY^SAME_PR C_SAME_DAY ^SAME_PROC _SAME_DAY"
  1533    ;^DIC(741 100.01,63, 0)="PROC_D AY^PROC_DA Y^PROCEDUR ES_SAME_DA Y"
  1534    ;^DIC(741 100.01,73, 0)="NUMBER _PROC_SAME _PROV_DAY^ NUM_PROC_S AME_PROV_D AY^NUMBER_ PROC_SAME_ PROV_SAME_ DAY"
  1535    ;^DIC(741 100.01,74, 0)="OTHER_ PROC_SAME_ DAY^OPSD^O THER_PROCE DURES_SAME _DAY"
  1536    ;^DIC(741 100.01,80, 0)="NUMBER _PROC_SAME _DAY^NPSD^ NUMBER_SAM E_PROCEDUR E_SAME_DAY "
  1537    ;^DIC(741 100.01,89, 0)="NUM_PR OC_SAME_DA Y_SAME_PRO V^NPSDSP^N UMBER_PROC _SAME_DAY_ SAME_PROV"
  1538    ;^DIC(741 100.01,90, 0)="NUMBER _OTH_PROC_ SAME_DAY^N OPSD^NUMBE R_OTHER_PR OC_SAME_DA Y"
  1539    ;^DIC(741 100.01,102 ,0)="OTHER _CLAIMS_SA ME_DAY^OCL SD^OTHER_C LAIMS_SAME _DAY"
  1540    ; (4)
  1541    ;^DIC(741 100.01,96, 0)="PROC_Y R_PRIOR^PC YP^PROCEDU RES_YEAR_P RIOR"
  1542    ;^DIC(741 100.01,97, 0)="NUM_PR OC_YEAR_PR IOR^NPYP^N UMBER_PROC EDURES_YEA R_PRIOR"
  1543    K HISTN
  1544    D SETACT
  1545    F A="SA_P ROCS_CNT", "FT_PROC_C NT" D
  1546    . S HISTN ($O(^DIC(7 41100.01," B",A,""))) =1
  1547    F A="MENT AL_HEALTH_ PROCEDURE_ COUNT" D
  1548    . S HISTN ($O(^DIC(7 41100.01," B",A,""))) =2
  1549    F A="OTHE R_DIAGNOSE S_SAME_DAY ","OTHER_L OCATIONS_S AME_DAY"," OTHER_PROC EDURES_SAM E_VISIT" D
  1550    . S HISTN ($O(^DIC(7 41100.01," B",A,""))) =3
  1551    F A="OTHE R_PROVIDER S_SAME_DAY ","SAME_PR OC_SAME_DA Y","PROCED URES_SAME_ DAY" D
  1552    . S HISTN ($O(^DIC(7 41100.01," B",A,""))) =3
  1553    F A="NUMB ER_PROC_SA ME_PROV_SA ME_DAY","O THER_PROCE DURES_SAME _DAY","NUM BER_SAME_P ROCEDURE_S AME_DAY" D
  1554    . S HISTN ($O(^DIC(7 41100.01," B",A,""))) =3
  1555    F A="NUMB ER_PROC_SA ME_DAY_SAM E_PROV","N UMBER_OTHE R_PROC_SAM E_DAY","OT HER_CLAIMS _SAME_DAY"  D
  1556    . S HISTN ($O(^DIC(7 41100.01," B",A,""))) =3
  1557    F A="PROC EDURES_YEA R_PRIOR"," NUMBER_PRO CEDURES_YE AR_PRIOR"  D
  1558    . S HISTN ($O(^DIC(7 41100.01," B",A,""))) =4
  1559    S I=0 F   S I=$O(^DI C(741100,I )) Q:'I  K  ^DIC(7411 00,I,4)
  1560    S A="^DIC (741100)"
  1561    F  S A=$Q (@A) Q:A'? 1"^DIC(741 100,".E  D
  1562    . S TIEN= $P(A,",",2 )+0
  1563    . Q:'$D(A CTIVE(TIEN ))
  1564    . S EL=@A _"^"
  1565    . I EL'[" $n" Q
  1566    . S N=""  F  S N=$O( HISTN(N))  Q:N=""  I  EL[("$n"_N _"^") D
  1567    . . Q:$D( ^DIC(74110 0,TIEN,4," B",HISTN(N )))
  1568    . . S HIE N=$O(^DIC( 741100,TIE N,4,"A"),- 1)+1
  1569    . . S ^DI C(741100,T IEN,4,HIEN ,0)=HISTN( N)
  1570    . . S ^DI C(741100,T IEN,4,"B", HISTN(N),H IEN)=""
  1571    . . S $P( ^DIC(74110 0,TIEN,4,0 ),"^",2)=7 41100.004
  1572    . . S $P( ^DIC(74110 0,TIEN,4,0 ),"^",3)=H IEN
  1573    . . S $P( ^DIC(74110 0,TIEN,4,0 ),"^",4)=$ P(^DIC(741 100,TIEN,4 ,0),"^",4) +1
  1574    Q
  1575    ;
  1576    //D OBJ^C HICDAI("CH AIR.HACAI. sch.champv aClaim",0)
  1577   OBJ(OBJ,IN D) ;
  1578    N PRO,PRO T,PROL
  1579    S PRO=""
  1580    ;W !,$J(" ",IND),OBJ ,"--->"
  1581    F  S PRO= $O(^oddDEF (OBJ,"a",P RO)) Q:PRO =""  D
  1582    . S PROT= ^oddDEF(OB J,"a",PRO, 5)
  1583    . S PROL= $G(^oddDEF (OBJ,"a",P RO,27))
  1584    . I $P(PR OT,".")'=$ P(OBJ,".")  W !,$J("" ,IND),PRO, " As " W:P ROL="list"  "list of  " W PROT Q
  1585    F  S PRO= $O(^oddDEF (OBJ,"a",P RO)) Q:PRO =""  D
  1586    . S PROT= ^oddDEF(OB J,"a",PRO, 5)
  1587    . S PROL= $G(^oddDEF (OBJ,"a",P RO,27))
  1588    . I $P(PR OT,".")'=$ P(OBJ,".")  Q
  1589    . W !,$J( "",IND),PR O," As " W :PROL="lis t" "list o f " W PROT
  1590    . D OBJ(P ROT,IND+5)
  1591    Q
  1592   CR25 ;Add  AI tests # 525-#650
  1593    D NOW^%DT C S DT=X
  1594    F AITN=52 5:1:650 D
  1595    . S AITNA ME="TEST # "_AITN
  1596    . I $D(^D IC(741100, "B",AITNAM E)) W !,"A I test ",A ITNAME," i s already  defined" Q
  1597    . S AITIE N=$O(^DIC( 741100,"%" ),-1)+1
  1598    . S ^DIC( 741100,AIT IEN,0)=AIT NAME_"^^^7 41100.03^7 41100.01^7 41100.02^7 41100.04^^ ^"_DT_"^^C T"
  1599    . S ^DIC( 741100,AIT IEN,3)="35 0*351*363"
  1600    . S ^DIC( 741100,AIT IEN,101,0) ="^^1^1^"_ DT
  1601    . S ^DIC( 741100,AIT IEN,101,1, 0)="Placeh older AI t est"
  1602    . S ^DIC( 741100,"B" ,AITNAME,A ITIEN)=""
  1603    . S $P(^D IC(741100, 0),"^",3)= AITIEN
  1604    . S $P(^D IC(741100, 0),"^",4)= $P(^DIC(74 1100,0),"^ ",4)+1
  1605    . W !,"AI  test ",AI TNAME," ad ded as IEN  ",AITIEN
  1606    Q
  1607   CR24 ; Cha nge field  names from  LAST ELEM ENT to LAS T RULE PRI ORITY
  1608    ;^DD(7410 00.0203,.0 7,0)="LAST  ELEMENT^F ^^0;6^K:$L (X)>7!($L( X)<1) X"
  1609    ;^DD(7410 00.0205,.0 6,0)="LAST  ELEMENT^F ^^0;6^K:$L (X)>7!($L( X)<1) X"
  1610    ;^DD(7410 00.06,.06, 0)="LAST E LEMENT^F^^ 0;6^K:$L(X )>5!($L(X) <1) X"
  1611    ;^DD(7413 001.0203,. 07,0)="LAS T ELEMENT^ F^^0;6^K:$ L(X)>7!($L (X)<1) X"
  1612    ;^DD(7413 001.0205,. 06,0)="LAS T ELEMENT^ F^^0;6^K:$ L(X)>7!($L (X)<1) X"
  1613    ;^DD(7413 001.06,.06 ,0)="LAST  ELEMENT^F^ ^0;6^K:$L( X)>5!($L(X )<1) X"
  1614    F FILE=74 1000.0203, 741000.020 5,741000.0 6,7413001. 0203,74130 01.0205,74 13001.06 D
  1615    . S FIELD =$S(FILE[" 0203":.07, 1:.06)
  1616    . S DDZ=^ DD(FILE,FI ELD,0)
  1617    . I $P(DD Z,"^")'="L AST ELEMEN T" Q
  1618    . K ^DD(F ILE,"B",$P (DDZ,"^"))
  1619    . S ^DD(F ILE,"B","L AST RULE P RIORITY",F IELD)=""
  1620    . S $P(^D D(FILE,FIE LD,0),"^") ="LAST RUL E PRIORITY "
  1621    Q
  1622   MDQ ;
  1623    ; Modifie d copy of:
  1624    ; CHBPF94  ;CVA/JEH; REMOVE CLA IMS IN THE  MDQ;01/02 /93  11:41  AM
  1625    ;V1.0
  1626    I $G(DUZ) ="" S DUZ= 9944
  1627    I $T(STAT INP^CHTFLI BC)="" W ! ,"DEV02122 4 is not i nstalled.   Please in stall befo re continu ing" Q
  1628    W !,"Plea se note th at if you  don't sele ct time, i t will be  assumed to  be midnig ht of sele cted day", !
  1629    S %DT="AE PT",%DT("A ")="Select  starting  Date/Time:  " D ^%DT
  1630    I Y'?7N.1 ".".6N W ! ,"Invalid  starting D ate/Time"  Q
  1631    S STARTDT =Y
  1632    S %DT="AE PT",%DT("A ")="Select  ending Da te/Time: "  D ^%DT
  1633    I Y'?7N.1 ".".6N W ! ,"Invalid  ending Dat e/Time" Q
  1634    S ENDDT=Y
  1635    W !,"Rele asing AI e rrors clai ms from MD Q",!
  1636           S  IDT=STARTD T,CTR=0
  1637           F   S IDT=$O( ^CHMMDQ("D ",0,IDT))  Q:'IDT  Q: IDT>ENDDT   D   ; 
  1638           .  S MDQI=0 
  1639           .  F  S MDQI= $O(^CHMMDQ ("D",0,IDT ,MDQI)) Q: 'MDQI  D
  1640    . . S REC =$G(^CHMMD Q(MDQI,0))
  1641    . . I $P( REC,"^",3) '=0 Q        ; make s ure still  pending
  1642    . . I $P( REC,"^",6) '=0 Q        ; make s ure it is  due to bad  AI
  1643           .  . S CI=$P( REC,"^",2)
  1644           .  . S CTR=CT R+1
  1645           .  . S CLNM=$ P(^CHMPAY( CI,0),"^")
  1646           .  . S Y=IDT  D DD^%DT 
  1647           .  . ; comple te claims  should not  be in MDQ  anyway, b ut check
  1648           .  . I $P($G( ^CHMPAY(CI ,0)),"^",2 )=4 Q
  1649           .  . S PDII=$ O(^CHMPAY( CI,"PDI",0 )) Q:'PDII   
  1650           .  . S CHMFPD I=$P(^CHMP AY(CI,"PDI ",PDII,0), "^") Q:'CH MFPDI
  1651           .  . W !,CTR, ")",?8,"MD Q = ",MDQI ," @ ",Y,"   CLAIM =  ",CI," (", CLNM,")"
  1652           .  . S X1=CI  D PROGTYP^ CHFCD001
  1653           .  . K DIE,DA ,DR 
  1654    . . S DIE =741010.11 ,DA=MDQI,D R=".03//// 2;.04////9 944" D ^DI E
  1655    . . K DIE ,DA,DR
  1656    . . K CHE LQFLG
  1657    . . S CHM QNAM="CHMM DQ(",CHMOU T="" K CHM IN D ^CHMI S041   ; Q UEUE UPDAT ES TO IN/O UT REPORT
  1658    . . D STA TINP^CHTFL IBC(CI) ;s ets claim  status to  IN PROGRES S
  1659    . . D REV CCD^CHTFLI BC(CI)  ;r everse & c lear ded/c .s./cat ca p from cla im
  1660       . . D  CONENDE^CH TFLIBC(CI)  ;kill ONE  node of ^ CHMPAY but  retain OH I & INPATI ENT data
  1661       . . D  CREJREA^CH TFLIBC(CI)  ;kill rej ect reason  node
  1662       . . D  CCDTREJ^CH TFLIBC(CI)  ;clear co mpl. date  & claim re j. reason
  1663       . . D  CCOMMON^CH TFLIBC(CI)  ;clear ca lculated d ata in com mon node
  1664       . . D  CUNITS^CHT FLIBC(CI)   ;clear ou t calculat ed data at  unit leve l
  1665       . . D  KRULE^CHTF LIBC(CI)    ;kill RUL E nodes fo r reproces sing
  1666       . . D  CREOPFL^CH TFLIBC(CI)  ;clear re open calcu lation fla g
  1667       . . K  CHMFCLMS,C HMFRS   ;  CLEAN OUT  ARRAY
  1668           .  . S CHMFCL MS(CLNM)=C I,CHMFRS(C LNM)="",CH ELQFLG=""
  1669           .  . D WORKFL 3^CHFCDUTL  ; Update  workflow
  1670    . . ;S CH MFCLMS(CLN M)=CL,CHRS TSRT=1,CHR EOPN=1 
  1671    . . D ^CH FCDDRV
  1672           .  . ;D QUE2^ CHFCDUTL    ; Submiss ion queued  for check  data and  benefit ca lc
  1673           W  !,"DONE PR OCESSING C LAIMS IN M DQ..."
  1674    W !!,"TOT AL NUMBER  OF CLAIMS  REMOVED FR OM MISSING  DATA QUEU E: ",CTR
  1675           K  IDT,MDQI,C TR,REC,CL, CLNM
  1676           Q
  1677   RUNNOUN ;
  1678    ; needs C I
  1679    D NOW^%DT C
  1680    I $G(CI)= "" R !,"Cl aim: ",CI  S CI=$O(^C HMPAY("B", CI,""))
  1681    I $G(CI)= "" R !,"Cl aim IEN: " ,CI
  1682    I $G(GLPA Y)="" S X1 =CI D PROG TYP^CHFCD0 01
  1683    R !,"0:DR G  1:DIAGN OSIS  2:PR OCEDURE    3:PHARMACY :  ",CHMFC T
  1684    I CHMFCT= 0 S CHMFJP =1 
  1685    E  W !,"I EN of ",$C ASE(CHMFCT ,0:"DRG",1 :"DIAGNOSI S",2:"PROC EDURE",3:" PHARMACY")  R CHMFJP 
  1686    S NM=CHMF JP
  1687    R !,"Noun : ",NNAME  Q:NNAME=""   S NNAME= $TR(NNAME, " ","_")
  1688    S NOUN=$O (^DIC(7411 00.01,"B", NNAME,""))
  1689    I NOUN=""  W !,"Not  Found" Q
  1690    S NOUNX=$ P($G(^DIC( 741100.01, NOUN,1))," ^",3,4)
  1691    K Y D @NO UNX
  1692    W !,"Resu lt is :",!  ZW Y
  1693    Q
  1694   WKFLOW(CI)  ;
  1695    W !,"CLAI M WORKFLOW "
  1696           I  '$D(^CHMPA Y(CI)) W ! ,"Claim Wo rkflow doe s not exis t for this  claim, OR  it has be en archive d." Q
  1697           W  "CLAIM NUM BER - "_$P ($G(^CHMPA Y(CI,0))," ^")
  1698           S  CHWFPTR=0
  1699    F  S CHWF PTR=$O(^CH MPAYW(CI,2 ,CHWFPTR))  Q:'CHWFPT R  D  
  1700           .  S REC=$G(^ CHMPAYW(CI ,2,CHWFPTR ,0)) Q:REC =""
  1701           .  S PT=$P(RE C,"^",1) Q :'$D(^CHMD IC(741002. 25,PT,0))
  1702           .  S NM=$TR($ P(^CHMDIC( 741002.25, PT,0),"^", 1,2),"^"," /")
  1703           .  S ZPA1=$P( REC,"^",2)
  1704           .  S CHFWDT=$ $FMTE^XLFD T(ZPA1,1)
  1705           .  S ZPA4=$P( REC,"^",3)  I ZPA4=""  S CHFWDUZ ="UNKNOWN"  G ENWK
  1706           .  I '$D(^VA( 200,ZPA4,0 )) S CHFWD UZ="UNKNOW N" G ENWK
  1707           .  S CHFWDUZ= $P(^VA(200 ,ZPA4,0)," ^",1)
  1708   ENWK . W ! ,CHFWDT_"   --  "_CHF WDUZ
  1709           .  W !,"                         "_ PT_" - "_N M
  1710    Q
  1711   INITSUBD ;
  1712    S IEN=0,S UBAI=$O(^D IC(741100, "B","TEST  #215",""))
  1713    F  S IEN= $O(^CHMSER V(IEN)) Q: 'IEN  D
  1714    . I $P($G (^CHMSERV( IEN,0)),"^ ",9)'=1 Q
  1715    . S CVA=$ P($G(^CHMS ERV(IEN,10 2,1,0)),"^ ",2)
  1716    . S SB=$P ($G(^CHMSE RV(IEN,102 ,6,0)),"^" ,2)
  1717    . ; if al ready assi gned to ne eded test,  skip
  1718    . I CVA=S UBAI,SB=SU BAI Q
  1719    . ; if al ready assi gned to so me other t est, tell  user and s kip.
  1720    . ;I CVA' ="",SB'=""  W !,IEN,"  ",CVA," " ,SB," PCS  already as signed to  ",CVA,"/", SB,", skip ping" Q
  1721    . F PE=1, 6,7 D
  1722    . . S CUR R=$G(^CHMS ERV(IEN,10 2,PE,0))
  1723    . . S ^CH MSERV(IEN, 102,PE,0)= PE_"^"_SUB AI_"^9921^ 3150129"
  1724    . . S ^CH MSERV(IEN, 102,"B",PE ,PE)=""
  1725    . . ; Upd ate histor y
  1726    . . I CUR R="" Q
  1727    . . S HIS T=$O(^CHMS ERV(IEN,10 2,PE,101," B"),-1)+1
  1728    . . S ^CH MSERV(IEN, 102,PE,101 ,HIST,0)=C URR
  1729    . . ; B x ref at 101  history l evel is co rrupted an d useless.   Don't bo ther setti ng it.
  1730    . . S ^CH MSERV(IEN, 102,PE,101 ,0)="^7410 06.102101P ^"_HIST_"^ "_HIST
  1731    . S ^CHMS ERV(IEN,10 2,0)="^741 006.0102P^ 7^3"
  1732    . Q
  1733    S IEN=0,S UBAI=$O(^D IC(741100, "B","TEST  #153",""))
  1734    F  S IEN= $O(^CHMICD X(IEN)) Q: 'IEN  D
  1735    . I $P($G (^CHMICDX( IEN,0)),"^ ",16)'=1 Q
  1736    . S CVA=$ P($G(^CHMI CDX(IEN,10 2,1,0)),"^ ",2)
  1737    . S SB=$P ($G(^CHMIC DX(IEN,102 ,6,0)),"^" ,2)
  1738    . ; if al ready assi gned to ne eded test,  skip
  1739    . I CVA=S UBAI,SB=SU BAI Q
  1740    . ; if al ready assi gned to so me other t est, tell  user and s kip.
  1741    . ;I CVA' ="",SB'=""  W !,IEN,"  ",CVA," " ,SB," DX a lready ass igned to " ,CVA,"/",S B,", skipp ing" Q
  1742    . F PE=1, 6,7 D
  1743    . . S CUR R=$G(^CHMI CDX(IEN,10 2,PE,0))
  1744    . . S ^CH MICDX(IEN, 102,PE,0)= PE_"^"_SUB AI_"^9921^ 3150129"
  1745    . . S ^CH MICDX(IEN, 102,"B",PE ,PE)=""
  1746    . . ; Upd ate histor y
  1747    . . I CUR R="" Q
  1748    . . S HIS T=$O(^CHMI CDX(IEN,10 2,PE,101," B"),-1)+1
  1749    . . S ^CH MICDX(IEN, 102,PE,101 ,HIST,0)=C URR
  1750    . . ; B x ref at 101  history l evel is co rrupted an d useless.   Don't bo ther setti ng it.
  1751    . . S ^CH MICDX(IEN, 102,PE,101 ,0)="^7410 06.0510210 1P^"_HIST_ "^"_HIST
  1752    . S ^CHMI CDX(IEN,10 2,0)="^741 006.05102P ^7^3"
  1753    . ;W !,IE N," BLANK  DX"
  1754    . Q