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