92. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 11/9/2018 12:33:53 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.

92.1 Files compared

# Location File Last Modified
1 CPEE_Build9_Sprint27.zip\HAC_CPE_CH CHMCRZC7.m Mon Nov 5 16:42:47 2018 UTC
2 CPEE_Build9_Sprint27.zip\HAC_CPE_CH CHMCRZC7.m Mon Nov 5 17:43:18 2018 UTC

92.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 2 1028
Changed 1 2
Inserted 0 0
Removed 0 0

92.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

92.4 Active regular expressions

No regular expressions were active.

92.5 Comparison detail

  1   CHMCRZC7 ; JAH/CEP -  A28/A31 MS G Builder  CP&E Spons ors ; 5/6/ 13 4:08pm
  2    ;;1.3;CHA MPVA;**225 28**;;Buil d 17
  3    ;**22528  - JAH/CEP
  4    ;
  5    Q
  6    ;
  7   GENACTPR(R ETURN,BILL NUM) ; gen erate acco unt profil e
  8    ;
  9    ;EXAMPLE:  
  10    ;     D G ENACTPR^CH MCRZ02(.RE TURN,"K400 S4Q",1)
  11    ;       r un account  profile r eport to h ost file a nd read ba ck into gl obal
  12    N ERRORS, CHRAWD,BIL LIEN,HFSDI R,FILENAME ,POP
  13    ;
  14    S RETURN= $NA(^TMP(" CHMCR ACCO UNT",$J))
  15    K @RETURN
  16    S CHRAWD= $NA(^TMP(" CHMCR RAW  ACCOUNT",$ J))
  17    K @CHRAWD
  18    ;
  19    D CHKBILL ^CHMCRUT3( .ERRORS,.B ILLIEN,BIL LNUM)
  20    ;If error s found XM Lize error s and quit
  21    I +$G(ERR ORS(0))>0  D  Q
  22    .  D GEOB XML^CHMCRC 31(.RETURN ,"",.ERROR S)
  23    ;
  24    ; Open Ho st File fo r Output o f EOB repo rt
  25    ;
  26    ; sample  EOB tempor ary HFS Fi le Directo ry USER$:[ TEMP]
  27    ;         CHMCR_EOB_ 111334533_ 542069954_ 52013.DAT; 1
  28    ;
  29    S HFSDIR= $$DEFDIR^% ZISH()
  30    S FILENAM E="CHMCR_A CCOUNT_"_B ILLIEN_"_" _$J_"_"_$P ($H,",",2) _".DAT"
  31    ;
  32    ; set EOF  handling  for Kernel  calls to
  33    X "D $SYS TEM.Proces s.SetZEOF( 1)"
  34    ;
  35    D OPEN^%Z ISH("WRITE FILE",HFSD IR,FILENAM E,"W")
  36    ;
  37    ;If can't  open file  for writi ng get xml  error mes sage and q uit
  38    ;
  39    D CHKPOP^ CHMCRUT1(. ERRORS,POP ,"W")
  40    ;
  41    I +$G(ERR ORS(0))>0  D  Q
  42    .  D CLOS E^%ZISH("W RITEFILE")
  43    .  D CLEA N(FILENAME ,HFSDIR)
  44    .  D GEOB XML^CHMCRC 31(.RETURN ,"",.ERROR S)
  45    ;
  46    ; set TMP  for call  to run EOB  that look s there fo r claim ie n (CLAIMIE N)
  47    ; and typ e provider  or benefi ciary (PRO VIDER)
  48    ;
  49    U IO
  50    S D0=BILL IEN   ;NEE DED FOR EN TRY POINT
  51    D PROC^PR CAPRO
  52    ;D INDIVI ^CHMG430
  53    D CLOSE^% ZISH("WRIT EFILE")
  54    ;
  55    ; this is  clean up  for extern al call to  EOB Repor t in INDIV ^CHMG430
  56    ;K ^TMP($ J,"ACCOUNT ")
  57    ;
  58    ; Read fi le back in to a globa l
  59    ;
  60    K POP
  61    X "D $SYS TEM.Proces s.SetZEOF( 1)"
  62    D OPEN^%Z ISH("READF ILE",HFSDI R,FILENAME ,"R")
  63    ;
  64    ;If can't  open file  for writi ne get xml  error mes sage and q uit
  65    ;
  66    D CHKPOP^ CHMCRUT1(. ERRORS,POP ,"R")
  67    ;
  68    I +$G(ERR ORS(0))>0  D  Q
  69    .  D CLOS E^%ZISH("R EADFILE")
  70    .  D CLEA N(FILENAME ,HFSDIR)
  71    .  D GEOB XML^CHMCRC 31(.RETURN ,"",.ERROR S)
  72    ;
  73    N I,X
  74    X "D $SYS TEM.Proces s.SetZEOF( 1)"
  75    U IO F I= 1:1 R X:DT IME Q:$$ST ATUS^%ZISH ()  S @CHR AWD@("repo rt",I)=X
  76    D CLOSE^% ZISH("READ FILE")
  77    ;
  78    D GEOBXML ^CHMCRC31( .RETURN,.C HRAWD,.ERR ORS)     ; NO CUST AR RAY
  79    ;
  80    ; destroy  ^TMP glob als
  81    ;
  82    K @CHRAWD
  83    D CLEAN(F ILENAME,HF SDIR)
  84    ;
  85    Q
  86   CLEAN(FILE NAME,HFSDI R) ;
  87    ; destroy  readfile
  88    ;
  89    N Y,FILES PEC
  90    S FILESPE C(FILENAME )=""
  91    S Y=$$DEL ^%ZISH(HFS DIR,$NA(FI LESPEC))
  92    Q
  93   FMPCLMHI(R ETURN,CHDF N,CHBDATE, CHEDATE) ;
  94    ; FMP CLA IM HISTORY
  95    ;INPUT: C HDFN
  96    ;       - SHOULD ADD  BEGIN DAT E, END DAT E
  97    ;OUTPUT:  NOTHIN YET .
  98    ;
  99    ;TODO: CA LL INPUT C HECK, GET  RID OF QUI TS
  100    N ERRORS
  101    ;
  102    ;TODO: ne w rawd aft er testing  is done
  103    ;N CHRAWD
  104    ;
  105    S RETURN= $NA(^TMP(" CHMCR CLAI M HISTORY" ,$J))
  106    K @RETURN
  107    S CHRAWD= $NA(^TMP(" CHMCR RAW  CLAIM HIST ORY",$J))
  108    K @CHRAWD
  109    ;
  110    ;TODO: de al with da te format  (convert t o fileman  dates)
  111    S CHBDATE =$G(CHBDAT E)
  112    S CHEDATE =$G(CHEDAT E)
  113    ;
  114    S CHFIO=" "
  115    ;S CHFIO= $G(ION)
  116    S CHZN=$G (^AHCHVA(C HDFN,0)) Q :CHZN=""
  117    S CHFLNM= $P(CHZN,U, 1) Q:CHFLN M=""
  118    S CHVET=C HFLNM
  119    S CHSSN=$ P(CHZN,U,9 ) Q:CHSSN= ""
  120    I CHSSN'= "" D
  121    .  S CHSS N=$E(CHSSN ,1,3)_"-"_ $E(CHSSN,4 ,5)_"-"_$E (CHSSN,6,9 )   ;CALL  HAS TO HAV E CHSSN FO RMATTED
  122    I CHEDATE ="" D  
  123    .  D NOW^ %DTC
  124    .  S CHED ATE=$E(%,1 ,7)                   ;END DATE  - COULD AD D TO PARAM S
  125    S CHBDATE =""                              ;NO BEGIN  DATE - COU LD ADD TO  PARAMS
  126    S CHPRINT =0
  127    S CHVIEW= 1
  128    S CHCOUNT =0
  129    ;;CODE CO PY FROM EO BHFS CALL
  130    ;;NOT SUR E WHAT COD E TO COPY  :-/
  131    ;
  132    N HFSDIR, FILENAME,P OP
  133    S HFSDIR= $$DEFDIR^% ZISH()
  134    S FILENAM E="CHMCR_C LM_HIST_"_ $J_"_"_$P( $H,",",2)_ ".DAT"
  135    ;
  136    ; set EOF  handling  for Kernel  calls to
  137    X "D $SYS TEM.Proces s.SetZEOF( 1)"
  138    ;
  139    D OPEN^%Z ISH("WRITE FILE",HFSD IR,FILENAM E,"W")
  140    ;
  141    ;If can't  open file  for writi ng get xml  error mes sage and q uit
  142    ;
  143    D CHKPOP^ CHMCRUT1(. ERRORS,POP ,"W")
  144    ;
  145    ;
  146    I +$G(ERR ORS(0))>0  D  Q
  147    .  D CLOS E^%ZISH("W RITEFILE")
  148    .  D CLEA N(FILENAME ,HFSDIR)
  149    .;TODO ER ROR PROCES SING FOR C LAIM HISTO RY
  150    .;  D GEO BXML^CHMCR C31(.RETUR N,"",.ERRO RS)
  151    ;
  152    W !,"JUST  PRIOR WRI TING TO FI LE, AFTER  OPEN FILE" ,!,"  ",HF SDIR,FILEN AME,!!
  153    S CHVIEW= 1
  154    U IO
  155    D CALC^CH FMPR6C
  156    D PRINT^C HFMPR6P
  157    ;
  158    D CLOSE^% ZISH("WRIT EFILE")
  159    ;
  160    ; TODO: d oes anythi ng need cl ean up fro m report?
  161    ;  K ^TMP ($J,"EOB")
  162    ;
  163    ; Read fi le back in to a globa l
  164    ;
  165    K POP
  166    X "D $SYS TEM.Proces s.SetZEOF( 1)"
  167    D OPEN^%Z ISH("READF ILE",HFSDI R,FILENAME ,"R")
  168    ;
  169    ;If can't  open file  for writi ne get xml  error mes sage and q uit
  170    ;
  171    D CHKPOP^ CHMCRUT1(. ERRORS,POP ,"R")
  172    ;
  173    I +$G(ERR ORS(0))>0  D  Q
  174    .  D CLOS E^%ZISH("R EADFILE")
  175    .  D CLEA N(FILENAME ,HFSDIR)
  176    .; return  claim his tory error s
  177    .;  D GEO BXML^CHMCR C31(.RETUR N,"",.ERRO RS)
  178    ;
  179    N I,X
  180    X "D $SYS TEM.Proces s.SetZEOF( 1)"
  181    U IO F I= 1:1 R X:DT IME Q:$$ST ATUS^%ZISH ()  S @CHR AWD@("repo rt",I)=X
  182    D CLOSE^% ZISH("READ FILE")
  183    Q
  184   TEST(I) ;
  185    Q:I>0  W  !,"DID WE  QUIT THIS  LINE?"
  186    W !,"BUT  WE DIDN'T  QUIT THE S UB ROUTINE "
  187    Q
  188   T2 ;
  189    N MOST,I, J,B
  190    S (MOST,I )=0
  191    F  S I=$O (^PRCA(430 ,"C",I)) Q :I'>0  D
  192    .  W !,"I :",I
  193    .  S (J,B )=0
  194    .  F  S J =$O(^PRCA( 430,"C",I, J)) Q:J'>0   D
  195    ..    W ! ,?2,J
  196    ..    S B =B+1
  197    ..    I B >MOST S MO ST=B,BIGE= I W !,?10, "MOST: ",M OST
  198    Q
  199   AMTPD(BILL IEN) ;
  200    ;NOT SURE  THIS IS C ORRECT
  201    ;BILL IEN  FROM PRCA (430
  202    ;TOTALS N ODE 7 PIEC ES 7-10
  203    N ND7,I,T OT
  204    S TOT=0
  205    S ND7=$G( ^PRCA(430, BILLIEN,7) ) Q:ND7=""  -1
  206    F I=7:1:1 0 D
  207    .  S TOT= TOT+$P(ND7 ,U,I)
  208    Q TOT
  209   AMTOWED(BI LLIEN) ;
  210    N ND7,I,T OT
  211    S TOT=0
  212    S ND7=$G( ^PRCA(430, BILLIEN,7) ) Q:ND7=""  -1
  213    F I=1:1:5  D
  214    .  S TOT= TOT+$P(ND7 ,U,I)
  215    Q TOT
  216   GETBILLS(R AWD,DIEN)  ;
  217    ;GET BILL  LIST FOR  DEBTOR IEN  (DIEN)
  218    N I,SIEN, TOP4,TOP6, ACTFTOP,TO TTOP,TOPHL DDT,STATTO T,BILLTYPE
  219    S SIEN=0
  220    S RAWD=$N A(^TMP($J, "CHMCR2 AC T PROFILE" ))
  221    K @RAWD
  222    S (ACTFTO P,TOTTOP,T OPHLDDT)=" "
  223       I $D(^ RCD(340,"T OP",+DIEN) )  D
  224       .  S T OP4=$G(^RC D(340,+DIE N,4))
  225       .  S T OP6=$G(^RC D(340,+DIE N,6))
  226       .  S A CTFTOP=$$B ULLETDT^CH MCRUT2($P( TOP6,U))            ; ACCOUNT FO RWARDED TO  TOP (DATE )
  227       .  S T OTTOP=$P(T OP4,U,3)           ;T OTAL TOP A MOUNT
  228       .  S T OPHLDDT=$$ BULLETDT^C HMCRUT2($P (TOP6,"^", 6))
  229    ;                  A CT FOW2TOP  TOTAL TOP      TOP H OLD DT   S TATEMENT D AY   
  230    S @RAWD@( DIEN)=$G(A CTFTOP)_U_ $G(TOTTOP) _U_$G(TOPH LDDT)_U_$P ($G(^RCD(3 40,DIEN,0) ),U,3)
  231       ;S @RA WD@(DIEN," ADDRESS")= $G(^RCD(34 0,DIEN,5))
  232       D GETN MADD(.RAWD ,$P($G(^RC D(340,DIEN ,0)),U,1))
  233       F  S S IEN=$O(^PR CA(430,"AS ",DIEN,SIE N)) Q:SIEN '>0  D
  234    .  S @RAW D@(DIEN,SI EN)=$P($G( ^PRCA(430. 3,SIEN,0)) ,U,1)
  235    .  S I=0
  236    .  S STAT TOT=0
  237    .  F  S I =$O(^PRCA( 430,"AS",D IEN,SIEN,I )) Q:I'>0   D
  238    ..    ;I  IS NOW BIL L IEN
  239    ..    ;RA WD(DIEN,ST ATIEN,BILL IEN)=BILL  NUM^BILL T YPE^ESTDT^ PRINC^INT^ ADMIN^AMTO WED^AMTPD
  240    ..    S X =$G(^PRCA( 430,I,0))
  241    ..    ;BE LOW LINE A  COPY
  242    ..    S B ILLTYPE=$S ($P(X,"^", 2)=31:"TRI C PT",1:$E ($P($G(^PR CA(430.2,$ S($O(^PRCA (430.2,"AC ",24,0))=$ P(X,"^",2) :+$P(X,"^" ,16),1:+$P (X,"^",2)) ,0)),"^"), 1,7))
  243    ..    S @ RAWD@(DIEN ,SIEN,I)=$ P($G(^PRCA (430,I,0)) ,U,1)_U_BI LLTYPE_U_$ $BULLETDT^ CHMCRUT2($ P($G(^PRCA (430,I,0)) ,U,10))
  244    ..    S @ RAWD@(DIEN ,SIEN,I)=$ G(@RAWD@(D IEN,SIEN,I ))_U_$P($G (^PRCA(430 ,I,7)),U,1 ,3)_U
  245    ..    S @ RAWD@(DIEN ,SIEN,I)=$ G(@RAWD@(D IEN,SIEN,I ))_$$AMTOW ED(I)_U_$$ AMTPD(I)
  246    ..    S $ P(@RAWD@(D IEN,SIEN), U,2)=+$P(@ RAWD@(DIEN ,SIEN),U,2 )+$$AMTOWE D(I)
  247    Q
  248   GETNMADD(R AWD,ENTPTR ) ;
  249    ;RAWDATA  REF; ENTIT Y POINTER  EG 79729;P RC(440,
  250    N IEN,FIL E,REF,NM,A D,ST
  251    S IEN=$P( ENTPTR,";" ,1)
  252    S FILE=$P (ENTPTR,"; ",2)
  253    I FILE="P RC(440," D
  254    .  S REF= "^"_FILE_I EN_",0)"
  255    .  S NM=$ P($G(@REF) ,U,1)
  256    .  S @RAW D@("NAME") =NM
  257    .  S AD=$ P($G(@REF) ,U,2,8)
  258    .  S ST=$ P(AD,U,6)
  259    .  S $P(A D,U,6)=$P( $G(^DIC(5, ST,0)),U,2 )
  260    .  S @RAW D@("ADDRES S")=AD
  261    I FILE="D PT(" D
  262    .  S REF= "^"_FILE_I EN_",0)"
  263    .  S NM=$ P($G(@REF) ,U,1)
  264    .  S REF= "^"_FILE_I EN_",.11)"
  265    .  S AD=$ P($G(@REF) ,U,1,6)
  266    .  S ST=$ P(AD,U,5)
  267    .  S $P(A D,U,5)=$P( $G(^DIC(5, ST,0)),U,2 )
  268    .  S @RAW D@("ADDRES S")=AD
  269    Q
  270   MASSAGE ;  get data i n format f or process ing in the  XML proce ssing rout ines
  271    ;SAFE KEE PING
  272    N CNO,REA SDX,RSCODE ,XMLDT,FMD T,X,RSCODE S
  273    S (CNO)=0
  274    F  S CNO= $O(@CHRAWD @("CLAIMS" ,CNO)) Q:C NO=""  D
  275    .  S CLAI MNO=CNO
  276    .  S DUP= 1
  277    .  I CNO[ "-" D 
  278    ..   S DU P=$P(CNO," -",2)
  279    ..   S CL AIMNO=$P(C NO,"-",1)
  280    .  S @CHR AWD@("CLMS VISITS",CL AIMNO,"DUP ")=DUP
  281    .  S @CHR AWD@("CLMS VISITS",CL AIMNO)=$G( @CHRAWD@(" CLAIMS",CN O))
  282    .  S FMDT =$P(@CHRAW D@("CLMSVI SITS",CLAI MNO),U)
  283    .  S XMLD T=$$BULLET DT^CHMCRUT 2(FMDT,-1)
  284    .  S $P(@ CHRAWD@("C LMSVISITS" ,CLAIMNO), U)=XMLDT
  285    .  S RSCO DES=$P(@CH RAWD@("CLM SVISITS",C LAIMNO),U, 10)
  286    .  F X=1: 1 S RSCODE =$P(RSCODE S,"*",X) Q :RSCODE=""   D
  287    ..   S RE ASDX=$$GET 1^DIQ(7410 02.22,RSCO DE_",",.02 )
  288    ..   S (@ CHRAWD@("C LMSVISITS" ,CLAIMNO," RSN",X))=R SCODE_U_RE ASDX
  289    Q
  290    ;
  291   CHMBLACA ;  TESTING C HMBLACA EX TRACT REPL ACEMENT CO DE BELOW
  292    Q
  293    ;
  294   IRSLTRFQ ;
  295    ;
  296    N LSTWD
  297    S LSTWD=^ CHMZHOLD(" REISU-1095 -B")
  298    S DAY=$$S ETDAY^CHMB LACA()
  299    ;TESTING  A FORWARD  DATE - CEP
  300    S DAY=317 1220
  301    ;COMMENTI NG FOR TES TING
  302    ;S ^CHMZH OLD("REISU -1095-B")= DAY
  303    S DIR="HA C_HFS$:[SC R.TEMP_FIL ES]"
  304    X ^%ZOSF( "UCI") S U CI=$P(Y,", ",1)
  305    I UCI'="H AC" S DIR= "HAC_HFS$: [DSMMANAG. CHAMPVA]"
  306    ;
  307    K ^ZTMPYR ($J)
  308    S LSTWD=L STWD-1 F   S LSTWD=$O (^CHMZHOLD ("REISU-10 95-B",LSTW D)) Q:(LST WD=DAY)!(' +LSTWD)  D
  309    . S IYR=0  F  S IYR= $O(^CHMZHO LD("REISU- 1095-B",LS TWD,IYR))  Q:'+IYR  D
  310    . . S ^ZT MPYR($J,IY R)=0
  311    . . S INM ="" F  S I NM=$O(^CHM ZHOLD("REI SU-1095-B" ,LSTWD,IYR ,INM)) Q:I NM=""  D
  312    . . . S ^ ZTMPYR($J, IYR,LSTWD, INM)=^CHMZ HOLD("REIS U-1095-B", LSTWD,IYR, INM)
  313    . . . Q
  314    . . Q
  315    . Q
  316    ;
  317    S IYR=0 F   S IYR=$O (^ZTMPYR($ J,IYR)) Q: '+IYR  D
  318    . S DT=$Z DATE($H,1) ,DTYR=$P(D T,"/",3),D TYR1=DTYR_ $P(DT,"/") _$P(DT,"/" ,2)
  319    . D NOW^% DTC S TM=$ P(%,".",2)
  320    . S FNAME ="MEC_Data Extract_O_ "_IYR_"_B_ "_DTYR1_TM _".TXT"
  321    . S CHFIO =DIR_FNAME
  322    . I '$$OP ENFIWR^CHT FLIB9(.CHF IO,"CHFIO" ) Q
  323    . I UCI'= "HAC" U CH FIO W UCI, !!
  324    . ;
  325    . S LSTWD ="" F  S L STWD=$O(^Z TMPYR($J,I YR,LSTWD))  Q:LSTWD=" "  D
  326    . . S INM ="" F  S I NM=$O(^ZTM PYR($J,IYR ,LSTWD,INM )) Q:INM=" "  D
  327    . . . U C HFIO W ^ZT MPYR($J,IY R,LSTWD,IN M),!
  328    . . . Q
  329    . ;
  330    . D CLOSE F^CHTFLIB9 (CHFIO,"CH FIO")
  331    . H 5
  332    . ;D FTPF ILE^CHTFLI B9(CHFIO," DNS     fs3. DNS             ","/FS3BIG /IRS_LETTE RS","PUT")
  333    . H 5
  334    . Q
  335    ;D KILLRG BL(DAY)
  336    K ^ZTMPYR ($J)
  337    Q
  338    ;
  339   KILLRGBL(D AY) ;
  340    ;
  341    K ^CHMZHO LD("REISU- 1095-B",DA Y)
  342    K ^ZTMPYR ($J)
  343    Q
  344   TXTRPCLS(R ET) ;
  345    ;TXT RPC  LIST - FOR  RPC LIST  TESTER
  346    N OUT,OUT 2,COUNT,I, J,K,DESC,R NAM,RIEN,E NTRYPT,FLD NO,PARAMNM ,PARAMSEQ, PARAMREQ,P ARAMDSC,RP DESC,APPEN D
  347    S RPCSRCH =$$GETSRCH ()
  348    Q:$G(RPCS RCH)=""
  349    S CTXT2RE Q=$$GETCTX T()
  350    Q:$G(CTXT 2REQ)=""
  351    S FORMXML =$$GETXMLR Q()
  352    S APPEND= $$GETAPND( )
  353    S RET(0)= 0
  354    D FIND^DI C(8994,"", "","",RPCS RCH,"","B" ,"","","OU T")
  355    S COUNT =  $P($G(OUT ("DILIST", 0)),U)
  356    F I=1:1:C OUNT D
  357    .  S RNAM  = $G(OUT( "DILIST",1 ,I))
  358    .  S RIEN  = $G(OUT( "DILIST",2 ,I))
  359    .  S RET( 0)=RET(0)+ 1, RET(RET (0))=RNAM_ "["_CTXT2R EQ_"]{"_RN AM_APPEND_ "}|"_FORMX ML_"|"
  360    D PRTLST( .RET)
  361    Q
  362   XMLRPCLS(R ET,RPCSRCH ,CTXT2REQ, FORMXML) ;
  363    ;XML RPC  LIST - FOR  RPC LIST  TESTER
  364    ;RPCSRCH:   RPC NAME  SEARCH VA LUE 
  365    ;CTXT2REQ : CONTEXT  TO REQUIRE  FOR ALL R PCS IN RES ULT
  366    ;FORMXML:   FORMAT A S XML FLAG  FOR ALL R PCS IN SET
  367    N OUT,OUT 2,COUNT,I, J,K,DESC,R NAM,RIEN,E NTRYPT,FLD NO,PARAMNM ,PARAMSEQ, PARAMREQ,P ARAMDSC,RP DESC
  368    Q:$G(RPCS RCH)=""
  369    Q:$G(CTXT 2REQ)=""
  370    S:(($G(FO RMXML)="") !($G(FORMX ML)'="true ")) FORMXM L="false"
  371    S RET(0)= 0
  372    S RET(0)= RET(0)+1,  RET(RET(0) )="<?xml v ersion=""1 .0"" encod ing=""UTF- 8""?>"
  373    S RET(0)= RET(0)+1,  RET(RET(0) )="<rpcLis t xmlns:xs i=""http:/ /www.w3.or g/2001/XML Schema-ins tance"">"
  374    D FIND^DI C(8994,"", "","",RPCS RCH,"","B" ,"","","OU T")
  375    S COUNT =  $P($G(OUT ("DILIST", 0)),U)
  376    F I=1:1:C OUNT D
  377    .  K OUT2
  378    .  S RNAM  = $G(OUT( "DILIST",1 ,I))
  379    .  S RIEN  = $G(OUT( "DILIST",2 ,I))
  380    .  D GETS ^DIQ(8994, RIEN,".01; .02;.03;.0 4;1;2*;3;" ,"X","OUT2 ")
  381    .  S ENTR YPT=$G(OUT 2(8994,RIE N_",",.02) )_U_$G(OUT 2(8994,RIE N_",",.03) )
  382    .  S J=0
  383    .  S DESC =""
  384    .  F  S J =$O(OUT2(8 994,RIEN_" ,",1,J)) Q :J'>0  D
  385    ..   S DL N=$G(OUT2( 8994,RIEN_ ",",1,J))
  386    ..   S DL N=$$XMLSAF E^CHMCRUTX (DLN)
  387    ..   S DE SC=DESC_DL N_"&#13;"   ;;XML'ABL E LINE FEE D
  388    .  S J=0
  389    .  S RPDE SC=""
  390    .  F  S J =$O(OUT2(8 994,RIEN_" ,",3,J)) Q :J'>0  D
  391    ..   S RL N=$G(OUT2( 8994,RIEN_ ",",3,J))
  392    ..   S RL N=$$XMLSAF E^CHMCRUTX (RLN)
  393    ..   S RP DESC=RPDES C_RLN_"&#1 3;"  ;;XML 'ABLE LINE  FEED
  394    .  S RET( 0)=RET(0)+ 1, RET(RET (0))="<rpc >"
  395    .  S RET( 0)=RET(0)+ 1, RET(RET (0))="<nam e>"_RNAM_" </name>"
  396    .  S RET( 0)=RET(0)+ 1, RET(RET (0))="<cal lableName> "_RNAM_"</ callableNa me>"
  397    .  S RET( 0)=RET(0)+ 1, RET(RET (0))="<con text>"_CTX T2REQ_"</c ontext>"
  398    .  S RET( 0)=RET(0)+ 1, RET(RET (0))="<for matAsXML>" _FORMXML_" </formatAs XML>"
  399    .  S RET( 0)=RET(0)+ 1, RET(RET (0))="<ent ryPoint>"_ ENTRYPT_"< /entryPoin t>"
  400    .  S RET( 0)=RET(0)+ 1, RET(RET (0))="<des cription>" _DESC_"</d escription >"
  401    .  S RET( 0)=RET(0)+ 1, RET(RET (0))="<ret urnParamet erDescript ion>"_RPDE SC_"</retu rnParamete rDescripti on>"
  402    .  S RET( 0)=RET(0)+ 1, RET(RET (0))="<par ams>"
  403    .  ;;NOW  GET THE PA RAMS...
  404    .  S FLDN O=""
  405    .  F  S F LDNO=$O(OU T2(8994.02 ,FLDNO)) Q :FLDNO=""   D
  406    ..   S PA RAMSEQ=$G( OUT2(8994. 02,FLDNO,. 05))
  407    ..   S PA RAMNM=$G(O UT2(8994.0 2,FLDNO,.0 1))
  408    ..   S PA RAMREQ="fa lse" S:$G( OUT2(8994. 02,FLDNO,. 04))="YES"  PARAMREQ= "true"
  409    ..   S K= 0
  410    ..   S PA RAMDSC=""
  411    ..   F  S  K=$O(OUT2 (8994.02,F LDNO,1,K))  Q:K'>0  D
  412    ...    S  PLN=$G(OUT 2(8994.02, FLDNO,1,K) )
  413    ...    S  PLN=$$XMLS AFE^CHMCRU TX(PLN)
  414    ...    S  PARAMDSC=P ARAMDSC_PL N_"&#13;"   ;;XML'ABL E LINE FEE D
  415    ..   ;;XM LIZE THE P ARAM
  416    ..   S RE T(0)=RET(0 )+1, RET(R ET(0))="<p aram>"
  417    ..   S RE T(0)=RET(0 )+1, RET(R ET(0))="<p arameterNa me>"_PARAM NM_"</para meterName> "
  418    ..   S RE T(0)=RET(0 )+1, RET(R ET(0))="<p arameterDe scription> "_PARAMDSC _"</parame terDescrip tion>"
  419    ..   S RE T(0)=RET(0 )+1, RET(R ET(0))="<p arameterRe quired>"_P ARAMREQ_"< /parameter Required>"
  420    ..   S RE T(0)=RET(0 )+1, RET(R ET(0))="<p arameterSe quence>"_P ARAMSEQ_"< /parameter Sequence>"
  421    ..   S RE T(0)=RET(0 )+1, RET(R ET(0))="</ param>"
  422    .  S RET( 0)=RET(0)+ 1, RET(RET (0))="</pa rams>"
  423    .  S RET( 0)=RET(0)+ 1, RET(RET (0))="</rp c>"
  424    S RET(0)= RET(0)+1,  RET(RET(0) )="</rpcLi st>"
  425    Q
  426   MOSTROCS ; FIND BENE/ SPONS WITH  MOST ROCS
  427    N DFN,BFN ,COUNT,HIG H
  428    S (HIGH,C OUNT)=0
  429    S DFN=999 9999
  430    F  S DFN= $O(^AHCHVA (DFN),-1)  Q:DFN'>0   D
  431    .   S BFN =0
  432    .   F  S  BFN=$O(^AH CHVA(DFN,1 00,BFN)) Q :BFN'>0  D
  433    ..    S C OUNT=0
  434    ..    D G ETRAWRO(.C OUNT,DFN,B FN)
  435    ..    I C OUNT>HIGH  D
  436    ...     S  HIGH=COUN T
  437    ...     W  !,"CURREN T HIGH: ", HIGH,"  DF N-BFN: ",D FN,"-",BFN
  438    Q
  439   GETRAWRO(C OUNT,CHDFN ,CHBFN) ;  Get raw da ta custome r ROC
  440    ; standar dize the s ponsor and  bene name s
  441    ;
  442    N ROCIEN, ZNODE,NODE 1,GLOB
  443    ;
  444    ;
  445    ;WARNING  DO NOT KIL L @GLOB as  this will  kill the  global dat a
  446    ;FIRST -  GET BENE R EGULAR ROC S
  447    S GLOB="^ AHCHVA("_C HDFN_",100 ,"_CHBFN_" ,106)"
  448    D GETROCS (.ROCOUNT, GLOB,"BENE ",554801.1 106)
  449    S COUNT=C OUNT+ROCOU NT
  450    ;SECOND -  GET BENE  SPINA ROCS
  451    S GLOB="^ AHCHVA("_C HDFN_",100 ,"_CHBFN_" ,116)"
  452    D GETROCS (.ROCOUNT, GLOB,"BENE SB",554801 .1116)
  453    S COUNT=C OUNT+ROCOU NT
  454    ;THIRD -  GET SPONSO R SPINA RO CS
  455    S GLOB="^ AHCHVA("_C HDFN_",106 )"
  456    D GETROCS (.ROCOUNT, GLOB,"SPON ",554801.0 106)
  457    S COUNT=C OUNT+ROCOU NT
  458    ;LAST - G ET SPONSOR  SPINA ROC S
  459    S GLOB="^ AHCHVA("_C HDFN_",116 )"
  460    D GETROCS (.ROCOUNT, GLOB,"SPON SB",554801 .0116)
  461    S COUNT=C OUNT+ROCOU NT
  462    ;
  463   GETROCS(CN T,GLOB,RET BASE,ROCFL D) ;
  464       ;GET T HE ROCS 
  465       ;INPUT : CHRET (R EF)
  466       ;        GLOB - T HE ROOT FO R THE ROC  EG AHCHVA( DFN,100,BF N,106
  467       ;    R ETBASE - T HE NODE IN  CHRET TO  PUT THE DA TA
  468       ;    R OCFLD   -  THE FIELD  NUM OF THE  MULTIPLE  OF THE ROC  OR SBROC  FOR THAT L EVEL - EG  554801.010 6, .0116,  .1106, .11 16
  469       N MYAU DIT
  470       S CNT= 0
  471    S ROCIEN= 9999999
  472    Q:$G(ROCF LD)'>0
  473    F  S ROCI EN=$O(@GLO B@(ROCIEN) ,-1) Q:ROC IEN'>0  D
  474    .  S CNT= CNT+1
  475    Q
  476   GETSRCH()  ;prompt us er RPC NAM E SEARCH
  477    ;
  478    N DIR,X,Y ,DIRUT
  479    S DIR("B" )=""
  480    S DIR(0)= "FO"
  481    S DIR("A" )="Enter f irst-chara cters sear ch to matc h RPCs"
  482    D ^DIR
  483    Q X
  484    ;
  485   GETCTXT()  ;PROMPT US ER FOR CON TEXT
  486    ;
  487    S DIC("A" )="Enter C ontext Nam e: "
  488    S DIC="^D IC(19,"
  489    S DIC("S" )="I $P(^( 0),U,4)="" B"""   ;SC REEN - ONL Y LIST BRO KER-TYPE O PTIONS
  490    S DIC(0)= "AEQMZ"
  491    D ^DIC
  492    ;
  493    Q $P($G(Y ),U,2)
  494   GETXMLRQ()  ;GET XML  REQUIRED T RUE/FALSE
  495           N  DIR,X,Y,DI RUT
  496           S  DIR("B")=" F"
  497           S  DIR(0)="SX ^T:true;F: false"
  498           S  DIR("A")=" Enter whet her ALL RP Cs in resu lt will be  marked as  response  is xml-for matted = [ true] or [ false]"
  499           D  ^DIR
  500           Q  Y(0)
  501   GETAPND()  ;GET TEXT  TO APPEND  TO DISPLAY  NAME
  502    ;
  503    ;N DIR,X, Y,DIRUT
  504    S DIR("B" )=""
  505    S DIR(0)= "FO"
  506    S DIR("A" )="Enter t ext to app end to dis play name  (eg. ""-TF "") or ent er for non e"
  507    D ^DIR
  508    Q X
  509    ;
  510   PRTLST(RES P)
  511    N I
  512    S I=0
  513    F  S I=$O (RESP(I))  Q:I'>0  W  !,RESP(I)
  514    Q
  515    ;