VENPCCMG ; IHS/OIT/GIS - GLOBAL EDITING OF DIAGNOSES AND ICD CODES ;
;;2.6;PCC+;;NOV 12, 2007
;
;
;
NEW N OLDICD,NEWICD,PROV,NAME,X,DIC,Y,%,%Y,NEWNAR,OLDNAR,PIEN,DO,AICDWD2
INTRO W !!,"GLOBAL CHANGE OF SPECIFIED ICD CODES AND NARRATIVES FOR ONE OR MORE PROVIDERS",!!!
PROV ; GET PROVIDER NAME
W !,"Enter the name of the provider or '*' for ALL: "
R NAME:$G(DTIME,60) E Q
I NAME?1."^" Q
I NAME="ALL"!(NAME="all")!(NAME="*") S PROV="ALL" G ICD
S DIC("S")="I $D(^VEN(7.1,""B"",+$G(Y)))"
S DIC=200,DIC(0)="EQM",X=NAME D ^DIC K DIC
I Y=-1 Q
S PROV=+Y
ICD ; CHANGE ICD CODE
S DIC="^ICD9(",DIC(0)="AEQM",DIC("A")="Enter the OLD ICD code that you want to change: "
D ^DIC
I X="" G NARR
I Y=-1 Q
S OLDICD=$P(Y,U,2)
S DIC("A")="Enter the NEW ICD code that will replace the old one: "
D ^DIC I Y=-1 Q
S NEWICD=$P(Y,U,2)
NARR ; CHANGE NARRATIVE
S DIR(0)="FO^",DIR("A")="Enter the OLD ICD narrative that you want to change" K DA
D ^DIR K DIR
I Y="" G RUN
I $D(DUOUT)!$D(DTOUT)!$D(DIROUT) Q
S OLDNAR=Y
S DIR(0)="F^",DIR("A")="Enter the NEW ICD narrative that will replace the old one" K DA
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT)!$D(DIROUT) Q
S NEWNAR=Y
RUN ; MAKE CHANGES
W !
I $L($G(NEWICD)) W !,OLDICD," will be changed to ",NEWICD
I $L($G(NEWNAR)) W !,OLDNAR," will be changed to ",NEWNAR
W !,"Is this ok" S %=1 D YN^DICN I %'=1 Q
W !!,"Making changes..."
I $G(OLDICD)="",$G(OLDNAR)="" W !,"Request cancelled!" Q
I $G(NEWFLAG),$G(PROV) D NCHG(PROV) G FIN ; GLOBAL EDIT OF NEW ICD PREF FILE
I $G(PROV) D CHG(PROV) G FIN
I $G(NEWFLAG),$G(PROV)="ALL" S PIEN=0 F S PIEN=$O(^VEN(7.34,"B",PIEN)) Q:'PIEN D NCHG(PIEN)
I $G(PROV)="ALL" S PIEN=0 F S PIEN=$O(^VEN(7.1,"B",PIEN)) Q:'PIEN D CHG(PIEN)
FIN D ^XBFMK
W !,"Done!"
Q
;
CHG(PIEN) ; EP-EDIT THE FILE
N CIEN,DIK,DA,STG
S CIEN=0 F S CIEN=$O(^VEN(7.1,"B",PIEN,CIEN)) Q:'CIEN S STG=$G(^VEN(7.1,CIEN,0)) I $L(STG) D
. I $L($G(OLDICD)),OLDICD=$P(STG,U,2) D
.. S $P(STG,U,2)=NEWICD
.. K ^VEN(7.1,"AC",OLDICD,CIEN)
.. S ^VEN(7.1,"AC",NEWICD,CIEN)=""
.. W "."
.. Q
. I $L($G(OLDNAR)),OLDNAR=$P(STG,U,3) S $P(STG,U,3)=NEWNAR W "."
. S ^VEN(7.1,CIEN,0)=STG
. Q
Q
;
NCHG(PIEN) ; EP-GLOBAL EDIT OF EDIT THE NEW ICD PREF FILE
N CIEN,DIK,DA,STG
S CIEN=0 F S CIEN=$O(^VEN(7.34,"B",PIEN,CIEN)) Q:'CIEN S STG=$G(^VEN(7.34,CIEN,0)) I $L(STG) D
. I $L($G(OLDICD)),OLDICD=$P(STG,U,4) D
.. S $P(STG,U,4)=NEWICD
.. W "."
.. Q
. I $L($G(OLDNAR)),OLDNAR=$P(STG,U,3) S $P(STG,U,3)=NEWNAR W "."
. S ^VEN(7.34,CIEN,0)=STG
. Q
Q
;
VUE ; EP-PRINT ALL ICDS AND ASSOCIATED NARRATIVES AND FORMS
N TMP,CODE,NARR,PIEN,PNAME,IEN,X,TXT,CIEN,CLASS,ICD,IIEN,Y,VENJ,%,%Y,SS,IPC,NPC,Z,I
S SS=7.1,IPC=2,NPC=3
I $G(NEWFLAG) S SS=7.34,IPC=4,NPC=3
W !,"Want to generate a current list of ICD preferences for this site"
S %=1 D YN^DICN I %'=1 Q
D WAIT^DICD W !!
S TMP="^TMP(""VEN GICD"","_$J_")" K @TMP
S IEN=0,VENJ=$J
F S IEN=$O(^VEN(SS,IEN)) Q:'IEN D ; BUILD THE ARRAY
. S X=$G(^VEN(SS,IEN,0)) I '$L(X) Q
. S PIEN=+X I 'PIEN Q ; PROVIDER
. S ICD=$P(X,U,IPC) I '$L(ICD) Q ; ICD
. S NARR=$P(X,U,NPC) I '$L(NARR) Q ; PROVIDER NARRATIVE
. I '$G(NEWFLAG) S CIEN=$P(X,U,4) I 'CIEN Q ; CLASS
. I $G(NEWFLAG) S Z="",CIEN="",Y=$G(^VEN(7.34,IEN,1)) F I=1:2:15 D
.. S Z=$P(Y,U,I)
.. I 'Z Q
.. I CIEN'="" S CIEN=CIEN_","
.. S CIEN=CIEN_$P("I^^C^^TF^^TM^^F^^M^^SF^^SM",U,I)
.. Q
. S IIEN=$$ICD^VENPCCU(ICD) I 'IIEN Q
. S TXT=$P($G(^ICD9(IIEN,0)),U,3) I '$L(TXT) Q ; ICD TEXT
. S @TMP@(ICD,NARR)=TXT_U_PIEN_U_CIEN
. Q
OUT ; OUTPUT USING %ZIS
S %ZIS="PM"
D ^%ZIS
I POP K DIR,DIRUT,DTOUT,DUOUT,X,Y Q
NOQUE D LIST
D ^%ZISC
W !!,"Done!!"
K DIR,DIRUT,DTOUT,DUOUT,X,Y
Q
;
LIST ; EP-PRINT ICD LIST
X ("I $D("_$C(73,79)_")") ; SCREEN VARS MUST EXIST
E Q
I '$G(VENJ) Q ; MISSING JOB NUMBER
N TMP,Y,X,ICD,NARR,TXT,LINE,STOP
LINIT S TMP="^TMP(""VEN GICD"","_VENJ_")",LINE=0 X $C(85,32,73,79) ; INITIALIZE THE LIST
D LINE W "LIST ALL ICD PREFERENCES AND ASSOCIATED PROVIDER NARRATIVE(S)"
S Y=$G(ZDTTH) I 'Y S Y=$G(DT)
I Y X ^DD("DD") W " (",Y,")",!!
D LINE W "ICD",?7,"ICD NARRATIVE",?35,"PROVIDER NARRATIVE"
D LINE W "------",?7,"--------------------------",?35,"----------------------------------"
S ICD="" F Q:$G(STOP) S ICD=$O(@TMP@(ICD)) Q:ICD="" S NARR="" F S NARR=$O(@TMP@(ICD,NARR)) Q:NARR="" D I $G(STOP) Q
. S X=$G(@TMP@(ICD,NARR)) I '$L(X) Q
. S TXT=$P(X,U)
. D LINE W ICD,?7,$E(TXT,1,27),?35,NARR
. Q
K @TMP ; CLEANUP
Q
;
LINE ; PAUSE IF NECESSARY
N X
W !
I '$D(IOST) Q
I $E(IOST,1,2)'="C-" Q
S LINE=LINE+1
I LINE'=22 Q
S LINE=0
W "<>" R X:$G(DTIME,60) E Q
I X?1."^" S STOP=1
W $C(13),?79,$C(13)
Q
;
VENPCCMG ; IHS/OIT/GIS - GLOBAL EDITING OF DIAGNOSES AND ICD CODES ;
+1 ;;2.6;PCC+;;NOV 12, 2007
+2 ;
+3 ;
+4 ;
NEW NEW OLDICD,NEWICD,PROV,NAME,X,DIC,Y,%,%Y,NEWNAR,OLDNAR,PIEN,DO,AICDWD2
INTRO WRITE !!,"GLOBAL CHANGE OF SPECIFIED ICD CODES AND NARRATIVES FOR ONE OR MORE PROVIDERS",!!!
PROV ; GET PROVIDER NAME
+1 WRITE !,"Enter the name of the provider or '*' for ALL: "
+2 READ NAME:$GET(DTIME,60)
IF '$TEST
QUIT
+3 IF NAME?1."^"
QUIT
+4 IF NAME="ALL"!(NAME="all")!(NAME="*")
SET PROV="ALL"
GOTO ICD
+5 SET DIC("S")="I $D(^VEN(7.1,""B"",+$G(Y)))"
+6 SET DIC=200
SET DIC(0)="EQM"
SET X=NAME
DO ^DIC
KILL DIC
+7 IF Y=-1
QUIT
+8 SET PROV=+Y
ICD ; CHANGE ICD CODE
+1 SET DIC="^ICD9("
SET DIC(0)="AEQM"
SET DIC("A")="Enter the OLD ICD code that you want to change: "
+2 DO ^DIC
+3 IF X=""
GOTO NARR
+4 IF Y=-1
QUIT
+5 SET OLDICD=$PIECE(Y,U,2)
+6 SET DIC("A")="Enter the NEW ICD code that will replace the old one: "
+7 DO ^DIC
IF Y=-1
QUIT
+8 SET NEWICD=$PIECE(Y,U,2)
NARR ; CHANGE NARRATIVE
+1 SET DIR(0)="FO^"
SET DIR("A")="Enter the OLD ICD narrative that you want to change"
KILL DA
+2 DO ^DIR
KILL DIR
+3 IF Y=""
GOTO RUN
+4 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
QUIT
+5 SET OLDNAR=Y
+6 SET DIR(0)="F^"
SET DIR("A")="Enter the NEW ICD narrative that will replace the old one"
KILL DA
+7 DO ^DIR
KILL DIR
+8 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
QUIT
+9 SET NEWNAR=Y
RUN ; MAKE CHANGES
+1 WRITE !
+2 IF $LENGTH($GET(NEWICD))
WRITE !,OLDICD," will be changed to ",NEWICD
+3 IF $LENGTH($GET(NEWNAR))
WRITE !,OLDNAR," will be changed to ",NEWNAR
+4 WRITE !,"Is this ok"
SET %=1
DO YN^DICN
IF %'=1
QUIT
+5 WRITE !!,"Making changes..."
+6 IF $GET(OLDICD)=""
IF $GET(OLDNAR)=""
WRITE !,"Request cancelled!"
QUIT
+7 ; GLOBAL EDIT OF NEW ICD PREF FILE
IF $GET(NEWFLAG)
IF $GET(PROV)
DO NCHG(PROV)
GOTO FIN
+8 IF $GET(PROV)
DO CHG(PROV)
GOTO FIN
+9 IF $GET(NEWFLAG)
IF $GET(PROV)="ALL"
SET PIEN=0
FOR
SET PIEN=$ORDER(^VEN(7.34,"B",PIEN))
IF 'PIEN
QUIT
DO NCHG(PIEN)
+10 IF $GET(PROV)="ALL"
SET PIEN=0
FOR
SET PIEN=$ORDER(^VEN(7.1,"B",PIEN))
IF 'PIEN
QUIT
DO CHG(PIEN)
FIN DO ^XBFMK
+1 WRITE !,"Done!"
+2 QUIT
+3 ;
CHG(PIEN) ; EP-EDIT THE FILE
+1 NEW CIEN,DIK,DA,STG
+2 SET CIEN=0
FOR
SET CIEN=$ORDER(^VEN(7.1,"B",PIEN,CIEN))
IF 'CIEN
QUIT
SET STG=$GET(^VEN(7.1,CIEN,0))
IF $LENGTH(STG)
Begin DoDot:1
+3 IF $LENGTH($GET(OLDICD))
IF OLDICD=$PIECE(STG,U,2)
Begin DoDot:2
+4 SET $PIECE(STG,U,2)=NEWICD
+5 KILL ^VEN(7.1,"AC",OLDICD,CIEN)
+6 SET ^VEN(7.1,"AC",NEWICD,CIEN)=""
+7 WRITE "."
+8 QUIT
End DoDot:2
+9 IF $LENGTH($GET(OLDNAR))
IF OLDNAR=$PIECE(STG,U,3)
SET $PIECE(STG,U,3)=NEWNAR
WRITE "."
+10 SET ^VEN(7.1,CIEN,0)=STG
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
NCHG(PIEN) ; EP-GLOBAL EDIT OF EDIT THE NEW ICD PREF FILE
+1 NEW CIEN,DIK,DA,STG
+2 SET CIEN=0
FOR
SET CIEN=$ORDER(^VEN(7.34,"B",PIEN,CIEN))
IF 'CIEN
QUIT
SET STG=$GET(^VEN(7.34,CIEN,0))
IF $LENGTH(STG)
Begin DoDot:1
+3 IF $LENGTH($GET(OLDICD))
IF OLDICD=$PIECE(STG,U,4)
Begin DoDot:2
+4 SET $PIECE(STG,U,4)=NEWICD
+5 WRITE "."
+6 QUIT
End DoDot:2
+7 IF $LENGTH($GET(OLDNAR))
IF OLDNAR=$PIECE(STG,U,3)
SET $PIECE(STG,U,3)=NEWNAR
WRITE "."
+8 SET ^VEN(7.34,CIEN,0)=STG
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
VUE ; EP-PRINT ALL ICDS AND ASSOCIATED NARRATIVES AND FORMS
+1 NEW TMP,CODE,NARR,PIEN,PNAME,IEN,X,TXT,CIEN,CLASS,ICD,IIEN,Y,VENJ,%,%Y,SS,IPC,NPC,Z,I
+2 SET SS=7.1
SET IPC=2
SET NPC=3
+3 IF $GET(NEWFLAG)
SET SS=7.34
SET IPC=4
SET NPC=3
+4 WRITE !,"Want to generate a current list of ICD preferences for this site"
+5 SET %=1
DO YN^DICN
IF %'=1
QUIT
+6 DO WAIT^DICD
WRITE !!
+7 SET TMP="^TMP(""VEN GICD"","_$JOB_")"
KILL @TMP
+8 SET IEN=0
SET VENJ=$JOB
+9 ; BUILD THE ARRAY
FOR
SET IEN=$ORDER(^VEN(SS,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+10 SET X=$GET(^VEN(SS,IEN,0))
IF '$LENGTH(X)
QUIT
+11 ; PROVIDER
SET PIEN=+X
IF 'PIEN
QUIT
+12 ; ICD
SET ICD=$PIECE(X,U,IPC)
IF '$LENGTH(ICD)
QUIT
+13 ; PROVIDER NARRATIVE
SET NARR=$PIECE(X,U,NPC)
IF '$LENGTH(NARR)
QUIT
+14 ; CLASS
IF '$GET(NEWFLAG)
SET CIEN=$PIECE(X,U,4)
IF 'CIEN
QUIT
+15 IF $GET(NEWFLAG)
SET Z=""
SET CIEN=""
SET Y=$GET(^VEN(7.34,IEN,1))
FOR I=1:2:15
Begin DoDot:2
+16 SET Z=$PIECE(Y,U,I)
+17 IF 'Z
QUIT
+18 IF CIEN'=""
SET CIEN=CIEN_","
+19 SET CIEN=CIEN_$PIECE("I^^C^^TF^^TM^^F^^M^^SF^^SM",U,I)
+20 QUIT
End DoDot:2
+21 SET IIEN=$$ICD^VENPCCU(ICD)
IF 'IIEN
QUIT
+22 ; ICD TEXT
SET TXT=$PIECE($GET(^ICD9(IIEN,0)),U,3)
IF '$LENGTH(TXT)
QUIT
+23 SET @TMP@(ICD,NARR)=TXT_U_PIEN_U_CIEN
+24 QUIT
End DoDot:1
OUT ; OUTPUT USING %ZIS
+1 SET %ZIS="PM"
+2 DO ^%ZIS
+3 IF POP
KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
QUIT
NOQUE DO LIST
+1 DO ^%ZISC
+2 WRITE !!,"Done!!"
+3 KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
+4 QUIT
+5 ;
LIST ; EP-PRINT ICD LIST
+1 ; SCREEN VARS MUST EXIST
XECUTE ("I $D("_$CHAR(73,79)_")")
+2 IF '$TEST
QUIT
+3 ; MISSING JOB NUMBER
IF '$GET(VENJ)
QUIT
+4 NEW TMP,Y,X,ICD,NARR,TXT,LINE,STOP
LINIT ; INITIALIZE THE LIST
SET TMP="^TMP(""VEN GICD"","_VENJ_")"
SET LINE=0
XECUTE $CHAR(85,32,73,79)
+1 DO LINE
WRITE "LIST ALL ICD PREFERENCES AND ASSOCIATED PROVIDER NARRATIVE(S)"
+2 SET Y=$GET(ZDTTH)
IF 'Y
SET Y=$GET(DT)
+3 IF Y
XECUTE ^DD("DD")
WRITE " (",Y,")",!!
+4 DO LINE
WRITE "ICD",?7,"ICD NARRATIVE",?35,"PROVIDER NARRATIVE"
+5 DO LINE
WRITE "------",?7,"--------------------------",?35,"----------------------------------"
+6 SET ICD=""
FOR
IF $GET(STOP)
QUIT
SET ICD=$ORDER(@TMP@(ICD))
IF ICD=""
QUIT
SET NARR=""
FOR
SET NARR=$ORDER(@TMP@(ICD,NARR))
IF NARR=""
QUIT
Begin DoDot:1
+7 SET X=$GET(@TMP@(ICD,NARR))
IF '$LENGTH(X)
QUIT
+8 SET TXT=$PIECE(X,U)
+9 DO LINE
WRITE ICD,?7,$EXTRACT(TXT,1,27),?35,NARR
+10 QUIT
End DoDot:1
IF $GET(STOP)
QUIT
+11 ; CLEANUP
KILL @TMP
+12 QUIT
+13 ;
LINE ; PAUSE IF NECESSARY
+1 NEW X
+2 WRITE !
+3 IF '$DATA(IOST)
QUIT
+4 IF $EXTRACT(IOST,1,2)'="C-"
QUIT
+5 SET LINE=LINE+1
+6 IF LINE'=22
QUIT
+7 SET LINE=0
+8 WRITE "<>"
READ X:$GET(DTIME,60)
IF '$TEST
QUIT
+9 IF X?1."^"
SET STOP=1
+10 WRITE $CHAR(13),?79,$CHAR(13)
+11 QUIT
+12 ;
