Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VENPCCG2

VENPCCG2.m

Go to the documentation of this file. 
  1. VENPCCG2 ; IHS/OIT/GIS - GET ICD PREFERENCES: FILER ; 
  1.  ;;2.6;PCC+;;NOV 12, 2007
  1.  ;
  1.  ;
  1.  ;
  1. FILE ;   --EP--   CALLED FROM VENPCCG1
  1.  ;
  1.  N VENIO K @TMP@("SORT")
  1.  I '$G(NEWDXP) U 0 W !!,"Creating text files......"
  1.  D ICD
  1.  K @TMP@("SORT")
  1.  K ^TMP("VEN PREF")
  1.  D ^XBFMK
  1.  Q
  1. ICD ;
  1.  ;
  1.  I $P(@TMP@("VPOV",0),"^",3)'="" S PROVFLG=$P(@TMP@("VPOV",0),"^",3)
  1.  E  S PROVFLG="-1"
  1.  ;
  1.  ;
  1.  K @TMP@("SORT","VPOV")
  1.  K @TMP@("SORT","VPOV2AGE")
  1.  S ICDPTR=0
  1.  F  S ICDPTR=$O(@TMP@("VPOV",ICDPTR)) Q:+ICDPTR=0  D
  1.  .S TOT=@TMP@("VPOV",ICDPTR)
  1.  .S DESALL=9999999-TOT
  1.  .S @TMP@("SORT","VPOV",DESALL,ICDPTR)=""
  1.  .S CODE=$P($G(^ICD9(ICDPTR,0)),"^",1)
  1.  .D GETNARR
  1.  .S AGEBUK=0
  1.  .F  S AGEBUK=$O(@TMP@("VPOV",ICDPTR,"B",AGEBUK)) Q:AGEBUK=""  D
  1.  ..S TOT=@TMP@("VPOV",ICDPTR,"B",AGEBUK)
  1.  ..S DES=9999999-TOT
  1.  ..S @TMP@("SORT","VPOV2AGE",AGEBUK,DES,CODE)=NAME
  1.  .S AGESEX=0
  1.  .S @TMP@("SORT","VPOV","AS","C",CODE)=DESALL
  1.  .F  S AGESEX=$O(@TMP@("VPOV",ICDPTR,AGESEX)) Q:+AGESEX=0  D
  1.  ..S TOT=@TMP@("VPOV",ICDPTR,AGESEX)
  1.  ..S DES=9999999-TOT
  1.  ..S @TMP@("SORT","VPOV","AS",AGESEX,DES,CODE)=NAME
  1.  ..Q
  1.  . Q
  1. NEWAGSEX ;  save out actual counts for age and sex groups not 1 or 0
  1.  S VENFLNO=$G(@TMP@("VPOV","FILECT"))+1
  1.  I '$G(NEWDXP) D
  1.  . D OPEN^%ZISH("",PATH,("ilc_icd"_VENFLNO_".txt"),"W") I POP Q
  1.  . S VENIO=IO
  1.  . Q
  1.  K @TMP@("SORT","VPOV","ASP")
  1.  ;
  1.  ;
  1.  ;   save all data to temp file to consolidate the top 100 for each
  1.  ;   age and sex bucket so that there is only one record for each code
  1.  ;
  1.  ;
  1.  S AG=0
  1.  F  S CT=0 S AG=$O(@TMP@("SORT","VPOV","AS",AG)) Q:+AG=0  D
  1.  .S DES=0
  1.  .F  S DES=$O(@TMP@("SORT","VPOV","AS",AG,DES)) Q:+DES=0  D  Q:CT>99
  1.  ..S CODE=""
  1.  ..F  S CODE=$O(@TMP@("SORT","VPOV","AS",AG,DES,CODE)) Q:CODE=""  D  Q:CT>99
  1.  ...S NAME=@TMP@("SORT","VPOV","AS",AG,DES,CODE)
  1.  ...I '$D(@TMP@("SORT","VPOV","ASP",CODE)) S @TMP@("SORT","VPOV","ASP",CODE)=NAME_"^"_(9999999-@TMP@("SORT","VPOV","AS","C",CODE))
  1.  ...S $P(@TMP@("SORT","VPOV","ASP",CODE,"A"),"^",AG)=(9999999-DES)
  1.  ...S CT=CT+1
  1.  ...Q
  1.  .. Q
  1.  . Q
  1. CLN I $G(NEWDXP),$G(DXPRV) D CLEAN(NEWDXP,DXPRV) I '$G(QUIET) W !!,"Saving new preference list..."
  1.  S C=""
  1.  F  S C=$O(@TMP@("SORT","VPOV","ASP",C)) Q:C=""  D
  1.  . S REC=@TMP@("SORT","VPOV","ASP",C)
  1.  . S RECA=@TMP@("SORT","VPOV","ASP",C,"A")
  1.  . S NAME=$P(REC,"^",1)
  1.  . S ICDNAME=$$INM(C)
  1.  . S TOT=$P(REC,"^",2)
  1.  . S OUTREC=C_$C(9)_NAME_$C(9)_ICDNAME
  1.  . F I=1:1:8 S PVAL=+$P(RECA,"^",I) S OUTREC=OUTREC_$C(9)_PVAL
  1.  . S OUTREC=OUTREC_$C(9)_TOT_$C(9)_PROVFLG
  1.  . I $G(NEWDXP),$G(DXPRV),$L(OUTREC) D STUFF(NEWDXP,DXPRV,OUTREC) Q  ; STUFF RESULT INTO THE VEN EHP IDC ITEM FILE
  1.  . U VENIO W OUTREC,!
  1.  . Q
  1. END ;
  1.  K OUTREC,REC,RECA,TOT,CODE,NAME,FREQ,CT,PVAL,DES,AG,ICDNAME
  1.  I $G(NEWDXP) Q
  1.  S @TMP@("VPOV","FILECT")=VENFLNO
  1.  D CLOSE^%ZISH(VENIO)
  1.  Q
  1.  ;
  1. CLEAN(GIEN,PIEN) ; CLEAN OUT THE OLD ENTRIES IN THE FILE FOR THIS PROVIDER AND ICD GROUP
  1.  I '$G(QUIET) W !!,"Cleaning out this user's old preference list..."
  1.  N DIK,DA,X
  1.  I '$D(^VEN(7.33,+$G(GIEN),0)) Q
  1.  I '$D(^VA(200,+$G(PIEN),0)) Q
  1.  S DIK="^VEN(7.34,",DA=0
  1.  F  S DA=$O(^VEN(7.34,DA)) Q:'DA  D
  1.  . S X=$G(^VEN(7.34,DA,0))
  1.  . I '$L(X) Q
  1.  . I PIEN'=+X Q
  1.  . I GIEN'=$P(X,U,2) Q
  1.  . D ^DIK
  1.  . Q
  1.  D ^XBFMK
  1.  Q
  1.  ; 
  1. STUFF(GIEN,PIEN,STG) ; NEW WAY TO STORE PREFERENCES
  1.  I '$L(STG) Q
  1.  I '$D(^VEN(7.33,+$G(GIEN),0)) Q
  1.  I '$D(^VA(200,+$G(PIEN),0)) Q
  1.  N T,INF,CHLD,TM,TF,AM,AF,SM,SF,ICD,ICDTXT,TXT,UID
  1.  N DIC,DIE,DA,DR,X,Y,DIK
  1.  S T=$C(9) ; TAB DELIMITER IS USED IN THIS STG
  1.  S ICD=$P(STG,T)
  1.  S TXT=$P(STG,T,2)
  1.  S ICDTXT=$P(STG,T,3)
  1.  S INF=$P(STG,T,4)
  1.  S CHLD=$P(STG,T,5)
  1.  S TM=$P(STG,T,6)
  1.  S TF=$P(STG,T,7)
  1.  S AM=$P(STG,T,8)
  1.  S AF=$P(STG,T,9)
  1.  S SM=$P(STG,T,10)
  1.  S SF=$P(STG,T,11)
  1.  S UID=PIEN_"_"_GIEN_"_"_ICD
  1.  S DA=$O(^VEN(7.34,"AC",UID,0)) I DA G S1
  1.  S DIC="^VEN(7.34,",DIC(0)="L",DLAYGO=19707.34
  1.  S X="""`"_PIEN_""""
  1.  D ^DIC I Y=-1 Q
  1.  S DA=+Y
  1. S1 S DIE=DIC
  1.  S DR=".02////^S X=GIEN;.03////^S X=TXT;.04////^S X=ICD;.06////^S X=UID;.07////^S X=ICDTXT;"
  1.  S DR=DR_"1.02////^S X=INF;1.04////^S X=CHLD;1.06////^S X=TF;1.08////^S X=TM;"
  1.  S DR=DR_"1.1////^S X=AF;1.12////^S X=AM;1.14////^S X=SF;1.16////^S X=SM"
  1.  L +^VEN(7.34,DA):0 I $T D ^DIE L -^VEN(7.34,DA)
  1.  Q
  1.  ; 
  1. GETNARR ;   get most freq. prov. narr. used for this icd code   dmh 8/31/2000 
  1.  K MOST
  1.  S PNP=""
  1.  F  S PNP=$O(@TMP@("VPOV","PN",ICDPTR,PNP)) Q:PNP=""  D
  1.  .S TOTPN=@TMP@("VPOV","PN",ICDPTR,PNP)
  1.  .I '$D(MOST) S MOST=TOTPN,MOSTPNP=PNP
  1.  .I MOST<TOTPN S MOST=TOTPN,MOSTPNP=PNP
  1.  .Q
  1.  S NARR=$P($G(^AUTNPOV(MOSTPNP,0)),"^",1)
  1.  D NARR^VENPCCG3
  1.  S NAME=NARR
  1.  Q
  1.  ;
  1. INM(CODE) ;
  1.  N %
  1.  S %=+$$ICD^VENPCCU($G(CODE))
  1.  S %=$P($G(^ICD9(%,0)),U,3)
  1.  Q %
  1.  ;