AMEREDDX ; IHS/OIT/SCR - Sub-routine for ER VISIT EDIT of DX information
;;3.0;ER VISIT SYSTEM;**2,3**;DEC 07, 2011;Build 11
;
; VARIABLES: The following variables are passed to multiple editing routines
; AMERDA : the IEN of the ER VISIT that is selected for editing
; AMERAIEN: The IEN of the ER AUDIT that is created when user begins editing a record
; AMEREDNO: An integer representing the number of multiple fields that have been edited
; for uniqueness in multiple field number in audit file
; Edit Auditing VARIABLES newed and used throughout edit routines:
; AMEROLD : original value of edited field
; AMERNEW : new value of edited field
; AMERSTRG : A ";" deliminated string of edit information for a field
;
EDDIAGS(AMERDA,AMEREDNO,AMERAIEN) ; EP from AMEREDIT
;
I '$D(^XUSEC("AMERZ9999",DUZ)) D EN^DDIOL("You are not authorized to use this option","","!!") Q 1 ;PROGRAMATICALLY LOCKING this option to holders of the coding key
; AMERDXNO - counter that identifies a multiple DX entry for subsequent matching
; AMERPDX - the ICD9 code that has been identified as the primary DX:
; AMERNAR - a string containing the narrative that has been identified by user
; AMERDX - a pointer to the ICD9 file that has been selected by user
N AMERDXNO,Y,AMERPDX,AMERPNAR,AMERNAR,AMERDX,DIC,AMERDONE,AMERQUIT,AMERPRIM,AMERSEL,AMERCODE
S (AMERQUIT,AMERDXNO)=0
S (Y,AMERPDX,AMERNAR,AMERDX,AMERDONE)=""
D EN^DDIOL("","","!")
I $P($G(^AMERVSIT(AMERDA,5.1)),U,2)="" S AMERPDX=""
I $P($G(^AMERVSIT(AMERDA,5.1)),U,3)="" S AMERPNAR=""
;IHS/OIT/SCR 11/20/08 modify function that screens valid codes to allow 'LOCAL CODES'
;I $P($G(^AMERVSIT(AMERDA,5.1)),U,2)'="" S AMERPDX=$P($$ICDDX^ICDCODE($P($G(^AMERVSIT(AMERDA,5.1)),U,2),0),U,2)
I $P($G(^AMERVSIT(AMERDA,5.1)),U,2)'="" S AMERPDX=$P($$ICDDX^ICDCODE($P($G(^AMERVSIT(AMERDA,5.1)),U,2),,,1),U,2)
I $P($G(^AMERVSIT(AMERDA,5.1)),U,3)'="" S AMERPNAR=$P(^AMERVSIT(AMERDA,5.1),U,3)
F Q:AMERDONE="^" D
.D ^XBCLS
.;IHS/OIT/SCR 11/03/08 allow selection of ICD9 code by number START CHANGES
.;D DSPLYDX(AMERPDX,AMERPNAR)
.S AMERSEL=$$SELECTDX(AMERPDX,AMERPNAR)
.I AMERSEL=-1 S AMERDONE="^" Q
.I (AMERSEL>0) S AMERCODE=$P($$ICDDX^ICDCODE($G(^AMERVSIT(AMERDA,5,AMERSEL,0)),,,1),U,2)
.S DIC("A")=""
.S DIC("B")=""
.D EN^DDIOL("","","!")
.I (AMERSEL'=0) D
..S DIC("B")=AMERCODE
..S DIC("A")="MODIFY INFORMATION FOR ICD9 CODE: "
..S DIC(0)="ME",X=AMERCODE ;
.E S DIC("A")="ENTER ICD9 CODE TO ADD: ",DIC(0)="AMEQ"
.S DIC="^ICD9(",Y="" ;
.;Screen ICD9 codes so that only those that will create a V POV entry can be selected
.; this screen comes from the .01 field of the V POV file
.S DIC("S")="D ^AUPNSICD"
.D ^DIC
.I $D(DUOUT)!$D(DTOUT) S AMERDONE="^" Q
.S AMERDX=Y
.I AMERDX>0 D
..;S AMEREDNO=AMEREDNO+1 ; Tracking the edit number for "field" uniqueness in ^AMERAUDT
..S AMERPRIM=$$PROCESDX(AMERSEL,AMERDX,AMERPDX,AMERPNAR)
..I AMERPRIM'="" S AMERPDX=$P(AMERPRIM,U,1),AMERPNAR=$P(AMERPRIM,U,2)
..D EN^DDIOL(" ","","!!")
..Q
.E I AMERDX=-1 S AMERDONE="^"
K AMERDXNO,Y,AMERNAR,AMERDX,DIC,AMERDONE
;I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0 ;IHS/OIT/SCR 01/06/09
I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT
I AMERQUIT=1 Q 0
Q 1
;
PRIMDIAG(AMERDA,AMERDX,AMERNNAR,AMERAIEN,AMERPRIS,AMEROLDS) ;
; UPDATES PRIMARY DIAGNOSIS FIELDS IF THE ORIGINAL INFORMATION MATCHES PRIMARY DX INFORMATION
; AND ALLOWS USER TO REPLACE PRIMARY DX FIELDS WITH NEW ONE'S IF ORIGINAL INFORMATION IS DIFFERENT
;
; INPUT:
; AMERDA - THE IEN OF THE ER VISIT
; AMERDX - THE DX CODE THAT IS BEING ENTERED
; AMERNAR - THE DX NARRATIVE THAT IS BEING ENTERED
; AMERAIEN - THE IEN OF THE ER AUDIT FILE
; AMERPRIS - A "^" DELIMITED STRING CONTAINING: NEW PRIMARY ICD9^CURRENT PRIMARY NARRATIVE
; AMEROLDS - A "^" DELIMITED STRING CONTAINING: ORIGINAL ICD9^ORIGINAL NARRATIVE
; RETURNS: A "^" DELEMITED STRING CONTAINING UPDATED PRIMARY ICD9^UPDATED PRIMARY NARRATIVE
N AMERSTRG,AMEREDTS,DR,AMERODX,AMERONAR,DIR,AMEROLD,AMERNEW,Y,AMERPNAR,AMERPDX,AMERTEMP
S Y=0
S AMERPDX=$P(AMERPRIS,U,1),AMERPNAR=$P(AMERPRIS,U,2)
S (AMERSTRG,AMEREDTS,DR,AMEROLD)=""
S AMERONAR=$P($G(^AMERVSIT(AMERDA,5.1)),U,3)
S AMERODX=$P($G(^AMERVSIT(AMERDA,5.1)),U,2)
I AMERODX="" S Y=1 ; IF THERE IS NO PRIMARY DX ENTERED, make this primary
I AMERODX'="" D
.S AMERTEMP=$P($$ICDDX^ICDCODE(AMERODX,,,1),U,2)
.I ($G(AMERPDX)=AMERTEMP)&(AMERPNAR=$P(AMEROLDS,U,2)) S Y=1
.Q
; IF the original primary ICD9 code is what the old pointer points to AND the original narrative is the primary narrative
; JUST UPDATE PRIMARY FIELDS, DON'T ASK
I Y=0 D
.S DIR("B")="NO"
.S DIR(0)="Y",DIR("A")="Is this the Primary DX"
.D ^DIR
.Q
I $G(Y)>0 D
.I AMERODX'=AMERDX D
..;IHS/OIT/SCR 11/20/09 MODIFYING FUNCTION THAT SCREENS VALID CODES TO ALLOW 'LOCAL'
..;S:AMERODX'="" AMEROLD=$P($$ICDDX^ICDCODE(AMERODX),U,2)
..S:AMERODX'="" AMEROLD=$P($$ICDDX^ICDCODE(AMERODX,,,1),U,2)
..S AMERNEW=$P($$ICDDX^ICDCODE(AMERDX,,,1),U,2)
..S AMERPDX=AMERNEW
..D NOW^%DTC ; FM datetime returned in X
..S AMERSTRG="5.2."_AMEREDNO_";"_X_";"_$$EDDISPL^AMEREDAU(AMEROLD,"X")_";"_$$EDDISPL^AMEREDAU(AMERNEW,"X")_";"_"Administrative;PRIMARY DIAGNOSIS;Silent audit trail"
..I AMERSTRG="^" Q
..S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
..S DR=$S(DR'="":DR_";",1:""),DR=DR_"5.2////"_AMERDX ; UPDATE POINTER
..Q
.Q:AMERSTRG="^"
.I AMERONAR'=AMERNNAR D
..S AMERPNAR=AMERNNAR
..D NOW^%DTC ; FM date time returned in X
..S AMERSTRG="5.3."_AMEREDNO_";"_X_";"_AMERONAR_";"_AMERPNAR_";Administrative;PRIMARY DX NARRATIVE;Silent Audit Trail"
..I AMERSTRG="^" Q
..S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
..S DR=$S(DR'="":DR_";",1:""),DR=DR_"5.3////"_AMERNNAR ; Update narrative
..Q
.Q
D:DR'="" DIE^AMEREDIT(AMERDA,DR)
D:AMEREDTS'="" MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
K AMERSTRG,AMEREDTS,DR,AMERODX,AMERONAR,DIR
Q AMERPDX_"^"_AMERPNAR
;
DELDIAG(AMERIEN,AMERSUB) ;
; Delete diagnosis record
N DIR,DIK,AMERFLAG
S (AMERSTRG,AMEREDTS)=""
S DIR(0)="Y",DIR("A")="Do you want to delete this DX completely",DIR("B")="NO"
D ^DIR K DIR
S AMERFLAG=0
I $G(Y)>0 D
.S DA(1)=AMERIEN,DA=AMERSUB
.; First, delete the V POV entry to insure that it is synch'd with the ER VISIT file ; IHS/OIT/GIS 11/30/11
.D DELVPOV^AMEREDDY(AMERIEN,AMERSUB)
.;IHS/OIT/SCR 02/03/09 LET'S GET THIS DELETE RIGHT
.S DIK="^AMERVSIT("_DA(1)_",5,"
.D ^DIK,EN^DIK ; Delete identified entry and re-index diagnosis field
.S AMERFLAG=1
.Q
K DIR,DIK
Q AMERFLAG
;
PROCESDX(AMERDXNO,AMERDIAG,AMERPDX,AMERPNAR) ;
;
; INPUT: AMERDXNO - The number of the diagnosis record that was selected for editing - 0 IF NEW
; AMERDIAG - Pointer to the ICD9 code that was selected
; AMERPDX - current primary DX ICD9 code for this visit
; AMERPNAR - current primary DX narrative
;
; RETURNS: AMERPRIM - a "^" delimited string that contains the primary DX code and narrative
;
; First look to see if that DX has already been entered
; if it has, we give the user a chance to delete it (if it isn't primary) or edit the narrative
N AMEREDTS,AMERSTRG,DR,AMERBAD,AMERPRIS,AMEROLDS
N AMERODX,AMERNDX,AMERONAR,AMERNNAR,AMERSKIP,AMERICD9,AMERGONE,AMERQUIT
N AMERGOOD ;IHS/OIT/SCR 092909 patch 2
;S AMERDIAG=$G(^AMERVSIT(AMERDA,5,AMERSEL,0))
S (AMERNDX,AMERODX,AMERONAR,AMERNNAR,AMEREDTS,AMERSTRG,DR,AMERODX)=""
;S (AMERDXNO,AMERSKIP)=0,AMERDX=$P(AMERDIAG,U,1),AMERICD9=$P(AMERDIAG,U,2)
S AMERSKIP=0,AMERDX=$P(AMERDIAG,U,1),AMERICD9=$P(AMERDIAG,U,2)
S AMERQUIT=0
S AMERPRIS=AMERPDX_"^"_AMERPNAR ; Primary DX code and Narrative might change but must be returned
;F S AMERDXNO=$O(^AMERVSIT(AMERDA,5,AMERDXNO)) Q:AMERDXNO="B"!(AMERDXNO="") I ^AMERVSIT(AMERDA,5,AMERDXNO,0)=AMERDX D
I AMERDXNO>0 D
.S AMERSKIP=1,AMERBAD=0,AMERGONE=0 ; Flags
.S AMERODX=AMERICD9 ; Keep diagnosis for audit trail
.D EN^DDIOL("Narrative: "_$G(^AMERVSIT(AMERDA,5,AMERDXNO,1)),"","!!")
.S AMERONAR=$G(^AMERVSIT(AMERDA,5,AMERDXNO,1)) ; Keep narrative for default
.S AMEROLDS=AMERODX_"^"_AMERONAR ; Pass the old values for comparison with old primary values
.I AMERPDX=AMERICD9&(AMERPNAR=AMERONAR) D EN^DDIOL("**This is currently the Primary DX**","","!")
.D EN^DDIOL("","","!!")
.I '(AMERPDX=AMERICD9&(AMERPNAR=AMERONAR)) D
..I $$DELDIAG(AMERDA,AMERDXNO)=1 D ; DIAG record has been deleted
...S AMERSTRG=$$EDAUDIT^AMEREDAU("5-01"_"."_AMEREDNO,$$EDDISPL^AMEREDAU(AMERODX,"X"),"","DIAGNOSIS")
...I AMERSTRG="^" Q
...S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
...S AMERGONE=1
...Q
..I $D(DUOUT)!$D(DTOUT) S AMERQUIT=1
..Q
.Q:AMERQUIT ; Quit if user "^" when asked if wants to delete
.I 'AMERGONE D ; DX record NOT DELETED,can change code AND narrative
..S DIR(0)="Y",DIR("A")="Do you want to change DX code",DIR("B")="YES"
..D ^DIR K DIR
..I $D(DUOUT)!$D(DTOUT) S AMERQUIT=1 Q
..I $G(Y)=0 S AMERNDX=AMERODX
..I $G(Y)=1 D
...;IHS/OIT/SCR 10/20/08
...S DIC="^ICD9(",DIC(0)="AMEQ",Y="",DIC("S")="D ^AUPNSICD"
...S DIC("A")="Enter NEW ICD Code: "
...D ^DIC K DIC
...I $D(DUOUT)!$D(DTOUT) S AMERDONE="^",AMERQUIT=1 Q
...I Y<1 S AMERBAD=1 Q
...S AMERDX=$P(Y,U,1),AMERNDX=$P(Y,U,2)
...I ((AMERNDX=AMERODX)!(AMERNDX="")) Q
...S AMERSTRG=$$EDAUDIT^AMEREDAU("5-01"_"."_AMEREDNO,$$EDDISPL^AMEREDAU(AMERODX,"X"),$$EDDISPL^AMEREDAU(AMERNDX,"X"),"DIAGNOSIS") ; Update the Audit file
...I AMERSTRG="^" Q
...S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
...S DIE="^AMERVSIT(DA(1),5,",DA(1)=AMERDA,DA=AMERDXNO,DR=""
...S DR=".01////"_AMERDX ;IHS/OIT/SCR 11/07/08 try stuffing with no validation to get rid of weirdness
...D MULTDIE^AMEREDIT(DIE,DA,DA(1),DR) ; Update the POV multiple in AMER VISIT
...I DA=1 D ; UPDATE PRIM ICD IN ER VISIT FILE ; IHS/OIT/GIS 12/09/2011
....S DIE="^AMERVSIT(",DA=AMERDA,DR="5.2////^S X=AMERDX"
....L +^AMERVSIT(DA):1 I D ^DIE L -^AMERVSIT(DA)
....Q
...S DR=""
...Q
..Q:AMERBAD!AMERQUIT
..; User can change narrative
..S DIR(0)="Y",DIR("A")="Do you want to change narrative",DIR("B")="YES"
..D ^DIR K DIR
..I $D(DUOUT)!$D(DTOUT) S AMERQUIT=1
..I $G(Y)=0 S AMERNNAR=AMERONAR
..I $G(Y)=1 D
...S DIR(0)="FAOr^1:80",DIR("A")="Enter NEW Provider Narrative: ",DIR("B")=AMERONAR
...D ^DIR
...I $D(DUOUT)!$D(DTOUT) S AMERQUIT=1 Q
...Q:Y=""
...;IHS/OIT/SCR 092909 patch 2 START CHANGES TO AVOID ";" IN NARRATIVE
...D CKSC^AMER1
...I $D(AMERCKSC) D
....S AMERGOOD=0
....F Q:AMERGOOD D
.....S Y=$G(DIR("B"))
.....S DIR(0)="FAOr^1:80",DIR("A")="Enter NEW Provider Narrative: ",DIR("B")=AMERONAR
.....D ^DIR
.....D CKSC^AMER1
.....I '$D(AMERCKSC) S AMERGOOD=1
.....K AMERCKSC
.....Q
....I Y="" S AMERQUIT=1
....Q
...K DIR
...Q:AMERQUIT
...;IHS/OIT/SCR 071509 patch 2 END CHANGES
...S AMERNNAR=Y
...I (AMERNNAR'=AMERONAR) D
....S DIE="^AMERVSIT(DA(1),5,",DA(1)=AMERDA,DA=AMERDXNO,DR=""
....S AMERNNAR=$$STRIPNAR^AMERPCC2(AMERNNAR) ;IHS/OIT/SCR 05/05/09
....S DR="1////"_AMERNNAR
....D MULTDIE^AMEREDIT(DIE,DA,DA(1),DR) K DIE ; Update the POV multiple in AMER VISIT
....I DA=1 D ; UPDATE PRIM DX NARR IN ER VISIT FILE ; IHS/OIT/GIS 12/09/2011
.....S DIE="^AMERVSIT(",DA=AMERDA,DR="5.3////^S X=AMERNNAR"
.....L +^AMERVSIT(DA):1 I D ^DIE L -^AMERVSIT(DA)
.....Q
....S DR=""
....S AMERSTRG=$$EDAUDIT^AMEREDAU("5-1"_"."_AMEREDNO,AMERONAR,AMERNNAR,"PROVIDER NARRATIVE") ; Update the Audit file
....I AMERSTRG="^" Q
....S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
....Q
...Q
..I AMERNDX=AMERODX,AMERNNAR=AMERONAR ;IHS/OIT/GIS 11/30/11 patch 3
..E D UPVPOV^AMEREDDY(AMERNDX,AMERODX,AMERNNAR,AMERONAR,AMERDA) ; Update the V POV entry here
..Q
.I AMEREDTS'="" D MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
.S AMEREDTS=""
.Q
I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q AMERPRIS
S Y="",AMERDXNO=0
I 'AMERSKIP&(AMERDX>0) D
.S AMERODX="",AMERNDX=AMERICD9,AMEROLDS=""
.S AMERNDX=AMERICD9
.S DIR("A")="Enter narrative description of DX: "
.S DIR(0)="FAOr^1:80"
.S DIR("?")="Enter free text diagnosis (80 characters max. ';' and ':' not allowed)"
.D ^DIR
.I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q
.S AMERNNAR=Y
.Q:AMERNNAR=""
.S AMERNNAR=$$STRIPNAR^AMERPCC2(AMERNNAR) ;IHS/OIT/SCR 05/05/09
.I AMERDX=$P($$ICDDX^ICDCODE(".9999",,,1),U,1) D
..S DA(1)=AMERDA,DIC="^AMERVSIT("_DA(1)_",5,",DIC(0)="L" ; DIAGNOSES
..S X=AMERDX
..D FILE^DICN
..Q
.I AMERDX'=$P($$ICDDX^ICDCODE(".9999",,,1),U,1) D
..S DA(1)=AMERDA,DIC="^AMERVSIT("_DA(1)_",5,",DIC(0)="L" ; DIAGNOSES
..S X="`"_AMERDX
..D ^DIC
..Q
.Q:Y<0
.; Just created a new DX in ER VISIT file - collect audit information and update V POV
.D ADDVPOV^AMEREDDY(AMERNDX,AMERNNAR,AMERDA) ; Add V POV entry to sync with ER VISIT file
.S AMERSTRG=$$EDAUDIT^AMEREDAU("5-01"_"."_AMEREDNO,"",$$EDDISPL^AMEREDAU(AMERNDX,"X"),"DIAGNOSIS") ; Collect code edit info
.I AMERSTRG="^" Q
.S AMEREDTS=$S(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
.S DIE=DIC,DA(1)=AMERDA,DA=+Y,DR="1////"_AMERNNAR
.K DIC
.D MULTDIE^AMEREDIT(DIE,DA,DA(1),DR)
.Q
Q AMERPRIS
SELECTDX(AMERPDX,AMERPNAR) ;IHS/OIT/GIS 9/9/11 patch 3
N AMERICD9,AMERDXNO,AMERSEL,DIR
S AMERSEL=0 ; DEFAULT TO QUIT
;IHS/OIT/SCR 11/18/08 TEMPORARILY ALLOWING LOCAL CODES
;S AMERICD9=$P($$ICDDX^ICDCODE($P($G(^AMERVSIT(AMERDA,5,0)),U,3),0),U,2)
;S AMERICD9=$P($$ICDDX^ICDCODE($P($G(^AMERVSIT(AMERDA,5,0)),U,3),,,1),U,2)
D EN^DDIOL("EDIT/ADD Dx narrative(s) and/or code(s)","","!")
D EN^DDIOL("Primary DX is marked with '**'","","!?5")
;IHS/OIT/SCR 11/03/08 - allow dx to be selected by number START CHANGES
S AMERDXNO=0
; S DIR(0)="SO^0: ADD NEW DIAGNOSIS;"
S DIR(0)="SO^"
F S AMERDXNO=$O(^AMERVSIT(AMERDA,5,AMERDXNO)) Q:(AMERDXNO="B"!(AMERDXNO="")) D
.N Y1,Y2,Y
.S Y=$G(^AMERVSIT(AMERDA,5,AMERDXNO,0)) ;ICD9 CODE
. ;IHS/OIT/SCR 11/20/08 TEMPORARILY ALLOWING LOCAL CODES
.;S Y1=$P($$ICDDX^ICDCODE(Y),U,2)
.;S Y2=$P($$ICDDX^ICDCODE(Y),U,4)
.S Y1=$P($$ICDDX^ICDCODE(Y,,,1),U,2)
.S Y2=$P($$ICDDX^ICDCODE(Y,,,1),U,4)
.I Y1=AMERPDX&($G(^AMERVSIT(AMERDA,5,AMERDXNO,1))=AMERPNAR) D
..S DIR(0)=DIR(0)_AMERDXNO_":**"_Y1_"("_Y2_") "_$G(^AMERVSIT(AMERDA,5,AMERDXNO,1))_";"
..Q
.E S DIR(0)=DIR(0)_AMERDXNO_": "_Y1_" ("_Y2_") "_$G(^AMERVSIT(AMERDA,5,AMERDXNO,1))_";"
.Q
S DIR(0)=DIR(0)_"A: ADD NEW DIAGNOSIS;Q: QUIT"
; S DIR("B")=0 ;IHS/OIT/SCR 11/20/08
S DIR("A")="Enter line # to EDIT, 'A' to ADD NEW DIAGNOSIS, or 'Q' to QUIT",DIR("?")="Enter line number you want to edit, ADD or QUIT"
D ^DIR
I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q -1
Q $S(Y:Y,Y="A":0,1:-1)
;
AMEREDDX ; IHS/OIT/SCR - Sub-routine for ER VISIT EDIT of DX information
+1 ;;3.0;ER VISIT SYSTEM;**2,3**;DEC 07, 2011;Build 11
+2 ;
+3 ; VARIABLES: The following variables are passed to multiple editing routines
+4 ; AMERDA : the IEN of the ER VISIT that is selected for editing
+5 ; AMERAIEN: The IEN of the ER AUDIT that is created when user begins editing a record
+6 ; AMEREDNO: An integer representing the number of multiple fields that have been edited
+7 ; for uniqueness in multiple field number in audit file
+8 ; Edit Auditing VARIABLES newed and used throughout edit routines:
+9 ; AMEROLD : original value of edited field
+10 ; AMERNEW : new value of edited field
+11 ; AMERSTRG : A ";" deliminated string of edit information for a field
+12 ;
EDDIAGS(AMERDA,AMEREDNO,AMERAIEN) ; EP from AMEREDIT
+1 ;
+2 ;PROGRAMATICALLY LOCKING this option to holders of the coding key
IF '$DATA(^XUSEC("AMERZ9999",DUZ))
DO EN^DDIOL("You are not authorized to use this option","","!!")
QUIT 1
+3 ; AMERDXNO - counter that identifies a multiple DX entry for subsequent matching
+4 ; AMERPDX - the ICD9 code that has been identified as the primary DX:
+5 ; AMERNAR - a string containing the narrative that has been identified by user
+6 ; AMERDX - a pointer to the ICD9 file that has been selected by user
+7 NEW AMERDXNO,Y,AMERPDX,AMERPNAR,AMERNAR,AMERDX,DIC,AMERDONE,AMERQUIT,AMERPRIM,AMERSEL,AMERCODE
+8 SET (AMERQUIT,AMERDXNO)=0
+9 SET (Y,AMERPDX,AMERNAR,AMERDX,AMERDONE)=""
+10 DO EN^DDIOL("","","!")
+11 IF $PIECE($GET(^AMERVSIT(AMERDA,5.1)),U,2)=""
SET AMERPDX=""
+12 IF $PIECE($GET(^AMERVSIT(AMERDA,5.1)),U,3)=""
SET AMERPNAR=""
+13 ;IHS/OIT/SCR 11/20/08 modify function that screens valid codes to allow 'LOCAL CODES'
+14 ;I $P($G(^AMERVSIT(AMERDA,5.1)),U,2)'="" S AMERPDX=$P($$ICDDX^ICDCODE($P($G(^AMERVSIT(AMERDA,5.1)),U,2),0),U,2)
+15 IF $PIECE($GET(^AMERVSIT(AMERDA,5.1)),U,2)'=""
SET AMERPDX=$PIECE($$ICDDX^ICDCODE($PIECE($GET(^AMERVSIT(AMERDA,5.1)),U,2),,,1),U,2)
+16 IF $PIECE($GET(^AMERVSIT(AMERDA,5.1)),U,3)'=""
SET AMERPNAR=$PIECE(^AMERVSIT(AMERDA,5.1),U,3)
+17 FOR
IF AMERDONE="^"
QUIT
Begin DoDot:1
+18 DO ^XBCLS
+19 ;IHS/OIT/SCR 11/03/08 allow selection of ICD9 code by number START CHANGES
+20 ;D DSPLYDX(AMERPDX,AMERPNAR)
+21 SET AMERSEL=$$SELECTDX(AMERPDX,AMERPNAR)
+22 IF AMERSEL=-1
SET AMERDONE="^"
QUIT
+23 IF (AMERSEL>0)
SET AMERCODE=$PIECE($$ICDDX^ICDCODE($GET(^AMERVSIT(AMERDA,5,AMERSEL,0)),,,1),U,2)
+24 SET DIC("A")=""
+25 SET DIC("B")=""
+26 DO EN^DDIOL("","","!")
+27 IF (AMERSEL'=0)
Begin DoDot:2
+28 SET DIC("B")=AMERCODE
+29 SET DIC("A")="MODIFY INFORMATION FOR ICD9 CODE: "
+30 ;
SET DIC(0)="ME"
SET X=AMERCODE
End DoDot:2
+31 IF '$TEST
SET DIC("A")="ENTER ICD9 CODE TO ADD: "
SET DIC(0)="AMEQ"
+32 ;
SET DIC="^ICD9("
SET Y=""
+33 ;Screen ICD9 codes so that only those that will create a V POV entry can be selected
+34 ; this screen comes from the .01 field of the V POV file
+35 SET DIC("S")="D ^AUPNSICD"
+36 DO ^DIC
+37 IF $DATA(DUOUT)!$DATA(DTOUT)
SET AMERDONE="^"
QUIT
+38 SET AMERDX=Y
+39 IF AMERDX>0
Begin DoDot:2
+40 ;S AMEREDNO=AMEREDNO+1 ; Tracking the edit number for "field" uniqueness in ^AMERAUDT
+41 SET AMERPRIM=$$PROCESDX(AMERSEL,AMERDX,AMERPDX,AMERPNAR)
+42 IF AMERPRIM'=""
SET AMERPDX=$PIECE(AMERPRIM,U,1)
SET AMERPNAR=$PIECE(AMERPRIM,U,2)
+43 DO EN^DDIOL(" ","","!!")
+44 QUIT
End DoDot:2
+45 IF '$TEST
IF AMERDX=-1
SET AMERDONE="^"
End DoDot:1
+46 KILL AMERDXNO,Y,AMERNAR,AMERDX,DIC,AMERDONE
+47 ;I $D(DUOUT)!$D(DTOUT) K DUOUT,DTOUT Q 0 ;IHS/OIT/SCR 01/06/09
+48 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
+49 IF AMERQUIT=1
QUIT 0
+50 QUIT 1
+51 ;
PRIMDIAG(AMERDA,AMERDX,AMERNNAR,AMERAIEN,AMERPRIS,AMEROLDS) ;
+1 ; UPDATES PRIMARY DIAGNOSIS FIELDS IF THE ORIGINAL INFORMATION MATCHES PRIMARY DX INFORMATION
+2 ; AND ALLOWS USER TO REPLACE PRIMARY DX FIELDS WITH NEW ONE'S IF ORIGINAL INFORMATION IS DIFFERENT
+3 ;
+4 ; INPUT:
+5 ; AMERDA - THE IEN OF THE ER VISIT
+6 ; AMERDX - THE DX CODE THAT IS BEING ENTERED
+7 ; AMERNAR - THE DX NARRATIVE THAT IS BEING ENTERED
+8 ; AMERAIEN - THE IEN OF THE ER AUDIT FILE
+9 ; AMERPRIS - A "^" DELIMITED STRING CONTAINING: NEW PRIMARY ICD9^CURRENT PRIMARY NARRATIVE
+10 ; AMEROLDS - A "^" DELIMITED STRING CONTAINING: ORIGINAL ICD9^ORIGINAL NARRATIVE
+11 ; RETURNS: A "^" DELEMITED STRING CONTAINING UPDATED PRIMARY ICD9^UPDATED PRIMARY NARRATIVE
+12 NEW AMERSTRG,AMEREDTS,DR,AMERODX,AMERONAR,DIR,AMEROLD,AMERNEW,Y,AMERPNAR,AMERPDX,AMERTEMP
+13 SET Y=0
+14 SET AMERPDX=$PIECE(AMERPRIS,U,1)
SET AMERPNAR=$PIECE(AMERPRIS,U,2)
+15 SET (AMERSTRG,AMEREDTS,DR,AMEROLD)=""
+16 SET AMERONAR=$PIECE($GET(^AMERVSIT(AMERDA,5.1)),U,3)
+17 SET AMERODX=$PIECE($GET(^AMERVSIT(AMERDA,5.1)),U,2)
+18 ; IF THERE IS NO PRIMARY DX ENTERED, make this primary
IF AMERODX=""
SET Y=1
+19 IF AMERODX'=""
Begin DoDot:1
+20 SET AMERTEMP=$PIECE($$ICDDX^ICDCODE(AMERODX,,,1),U,2)
+21 IF ($GET(AMERPDX)=AMERTEMP)&(AMERPNAR=$PIECE(AMEROLDS,U,2))
SET Y=1
+22 QUIT
End DoDot:1
+23 ; IF the original primary ICD9 code is what the old pointer points to AND the original narrative is the primary narrative
+24 ; JUST UPDATE PRIMARY FIELDS, DON'T ASK
+25 IF Y=0
Begin DoDot:1
+26 SET DIR("B")="NO"
+27 SET DIR(0)="Y"
SET DIR("A")="Is this the Primary DX"
+28 DO ^DIR
+29 QUIT
End DoDot:1
+30 IF $GET(Y)>0
Begin DoDot:1
+31 IF AMERODX'=AMERDX
Begin DoDot:2
+32 ;IHS/OIT/SCR 11/20/09 MODIFYING FUNCTION THAT SCREENS VALID CODES TO ALLOW 'LOCAL'
+33 ;S:AMERODX'="" AMEROLD=$P($$ICDDX^ICDCODE(AMERODX),U,2)
+34 IF AMERODX'=""
SET AMEROLD=$PIECE($$ICDDX^ICDCODE(AMERODX,,,1),U,2)
+35 SET AMERNEW=$PIECE($$ICDDX^ICDCODE(AMERDX,,,1),U,2)
+36 SET AMERPDX=AMERNEW
+37 ; FM datetime returned in X
DO NOW^%DTC
+38 SET AMERSTRG="5.2."_AMEREDNO_";"_X_";"_$$EDDISPL^AMEREDAU(AMEROLD,"X")_";"_$$EDDISPL^AMEREDAU(AMERNEW,"X")_";"_"Administrative;PRIMARY DIAGNOSIS;Silent audit trail"
+39 IF AMERSTRG="^"
QUIT
+40 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+41 ; UPDATE POINTER
SET DR=$SELECT(DR'="":DR_";",1:"")
SET DR=DR_"5.2////"_AMERDX
+42 QUIT
End DoDot:2
+43 IF AMERSTRG="^"
QUIT
+44 IF AMERONAR'=AMERNNAR
Begin DoDot:2
+45 SET AMERPNAR=AMERNNAR
+46 ; FM date time returned in X
DO NOW^%DTC
+47 SET AMERSTRG="5.3."_AMEREDNO_";"_X_";"_AMERONAR_";"_AMERPNAR_";Administrative;PRIMARY DX NARRATIVE;Silent Audit Trail"
+48 IF AMERSTRG="^"
QUIT
+49 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+50 ; Update narrative
SET DR=$SELECT(DR'="":DR_";",1:"")
SET DR=DR_"5.3////"_AMERNNAR
+51 QUIT
End DoDot:2
+52 QUIT
End DoDot:1
+53 IF DR'=""
DO DIE^AMEREDIT(AMERDA,DR)
+54 IF AMEREDTS'=""
DO MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
+55 KILL AMERSTRG,AMEREDTS,DR,AMERODX,AMERONAR,DIR
+56 QUIT AMERPDX_"^"_AMERPNAR
+57 ;
DELDIAG(AMERIEN,AMERSUB) ;
+1 ; Delete diagnosis record
+2 NEW DIR,DIK,AMERFLAG
+3 SET (AMERSTRG,AMEREDTS)=""
+4 SET DIR(0)="Y"
SET DIR("A")="Do you want to delete this DX completely"
SET DIR("B")="NO"
+5 DO ^DIR
KILL DIR
+6 SET AMERFLAG=0
+7 IF $GET(Y)>0
Begin DoDot:1
+8 SET DA(1)=AMERIEN
SET DA=AMERSUB
+9 ; First, delete the V POV entry to insure that it is synch'd with the ER VISIT file ; IHS/OIT/GIS 11/30/11
+10 DO DELVPOV^AMEREDDY(AMERIEN,AMERSUB)
+11 ;IHS/OIT/SCR 02/03/09 LET'S GET THIS DELETE RIGHT
+12 SET DIK="^AMERVSIT("_DA(1)_",5,"
+13 ; Delete identified entry and re-index diagnosis field
DO ^DIK
DO EN^DIK
+14 SET AMERFLAG=1
+15 QUIT
End DoDot:1
+16 KILL DIR,DIK
+17 QUIT AMERFLAG
+18 ;
PROCESDX(AMERDXNO,AMERDIAG,AMERPDX,AMERPNAR) ;
+1 ;
+2 ; INPUT: AMERDXNO - The number of the diagnosis record that was selected for editing - 0 IF NEW
+3 ; AMERDIAG - Pointer to the ICD9 code that was selected
+4 ; AMERPDX - current primary DX ICD9 code for this visit
+5 ; AMERPNAR - current primary DX narrative
+6 ;
+7 ; RETURNS: AMERPRIM - a "^" delimited string that contains the primary DX code and narrative
+8 ;
+9 ; First look to see if that DX has already been entered
+10 ; if it has, we give the user a chance to delete it (if it isn't primary) or edit the narrative
+11 NEW AMEREDTS,AMERSTRG,DR,AMERBAD,AMERPRIS,AMEROLDS
+12 NEW AMERODX,AMERNDX,AMERONAR,AMERNNAR,AMERSKIP,AMERICD9,AMERGONE,AMERQUIT
+13 ;IHS/OIT/SCR 092909 patch 2
NEW AMERGOOD
+14 ;S AMERDIAG=$G(^AMERVSIT(AMERDA,5,AMERSEL,0))
+15 SET (AMERNDX,AMERODX,AMERONAR,AMERNNAR,AMEREDTS,AMERSTRG,DR,AMERODX)=""
+16 ;S (AMERDXNO,AMERSKIP)=0,AMERDX=$P(AMERDIAG,U,1),AMERICD9=$P(AMERDIAG,U,2)
+17 SET AMERSKIP=0
SET AMERDX=$PIECE(AMERDIAG,U,1)
SET AMERICD9=$PIECE(AMERDIAG,U,2)
+18 SET AMERQUIT=0
+19 ; Primary DX code and Narrative might change but must be returned
SET AMERPRIS=AMERPDX_"^"_AMERPNAR
+20 ;F S AMERDXNO=$O(^AMERVSIT(AMERDA,5,AMERDXNO)) Q:AMERDXNO="B"!(AMERDXNO="") I ^AMERVSIT(AMERDA,5,AMERDXNO,0)=AMERDX D
+21 IF AMERDXNO>0
Begin DoDot:1
+22 ; Flags
SET AMERSKIP=1
SET AMERBAD=0
SET AMERGONE=0
+23 ; Keep diagnosis for audit trail
SET AMERODX=AMERICD9
+24 DO EN^DDIOL("Narrative: "_$GET(^AMERVSIT(AMERDA,5,AMERDXNO,1)),"","!!")
+25 ; Keep narrative for default
SET AMERONAR=$GET(^AMERVSIT(AMERDA,5,AMERDXNO,1))
+26 ; Pass the old values for comparison with old primary values
SET AMEROLDS=AMERODX_"^"_AMERONAR
+27 IF AMERPDX=AMERICD9&(AMERPNAR=AMERONAR)
DO EN^DDIOL("**This is currently the Primary DX**","","!")
+28 DO EN^DDIOL("","","!!")
+29 IF '(AMERPDX=AMERICD9&(AMERPNAR=AMERONAR))
Begin DoDot:2
+30 ; DIAG record has been deleted
IF $$DELDIAG(AMERDA,AMERDXNO)=1
Begin DoDot:3
+31 SET AMERSTRG=$$EDAUDIT^AMEREDAU("5-01"_"."_AMEREDNO,$$EDDISPL^AMEREDAU(AMERODX,"X"),"","DIAGNOSIS")
+32 IF AMERSTRG="^"
QUIT
+33 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+34 SET AMERGONE=1
+35 QUIT
End DoDot:3
+36 IF $DATA(DUOUT)!$DATA(DTOUT)
SET AMERQUIT=1
+37 QUIT
End DoDot:2
+38 ; Quit if user "^" when asked if wants to delete
IF AMERQUIT
QUIT
+39 ; DX record NOT DELETED,can change code AND narrative
IF 'AMERGONE
Begin DoDot:2
+40 SET DIR(0)="Y"
SET DIR("A")="Do you want to change DX code"
SET DIR("B")="YES"
+41 DO ^DIR
KILL DIR
+42 IF $DATA(DUOUT)!$DATA(DTOUT)
SET AMERQUIT=1
QUIT
+43 IF $GET(Y)=0
SET AMERNDX=AMERODX
+44 IF $GET(Y)=1
Begin DoDot:3
+45 ;IHS/OIT/SCR 10/20/08
+46 SET DIC="^ICD9("
SET DIC(0)="AMEQ"
SET Y=""
SET DIC("S")="D ^AUPNSICD"
+47 SET DIC("A")="Enter NEW ICD Code: "
+48 DO ^DIC
KILL DIC
+49 IF $DATA(DUOUT)!$DATA(DTOUT)
SET AMERDONE="^"
SET AMERQUIT=1
QUIT
+50 IF Y<1
SET AMERBAD=1
QUIT
+51 SET AMERDX=$PIECE(Y,U,1)
SET AMERNDX=$PIECE(Y,U,2)
+52 IF ((AMERNDX=AMERODX)!(AMERNDX=""))
QUIT
+53 ; Update the Audit file
SET AMERSTRG=$$EDAUDIT^AMEREDAU("5-01"_"."_AMEREDNO,$$EDDISPL^AMEREDAU(AMERODX,"X"),$$EDDISPL^AMEREDAU(AMERNDX,"X"),"DIAGNOSIS")
+54 IF AMERSTRG="^"
QUIT
+55 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+56 SET DIE="^AMERVSIT(DA(1),5,"
SET DA(1)=AMERDA
SET DA=AMERDXNO
SET DR=""
+57 ;IHS/OIT/SCR 11/07/08 try stuffing with no validation to get rid of weirdness
SET DR=".01////"_AMERDX
+58 ; Update the POV multiple in AMER VISIT
DO MULTDIE^AMEREDIT(DIE,DA,DA(1),DR)
+59 ; UPDATE PRIM ICD IN ER VISIT FILE ; IHS/OIT/GIS 12/09/2011
IF DA=1
Begin DoDot:4
+60 SET DIE="^AMERVSIT("
SET DA=AMERDA
SET DR="5.2////^S X=AMERDX"
+61 LOCK +^AMERVSIT(DA):1
IF $TEST
DO ^DIE
LOCK -^AMERVSIT(DA)
+62 QUIT
End DoDot:4
+63 SET DR=""
+64 QUIT
End DoDot:3
+65 IF AMERBAD!AMERQUIT
QUIT
+66 ; User can change narrative
+67 SET DIR(0)="Y"
SET DIR("A")="Do you want to change narrative"
SET DIR("B")="YES"
+68 DO ^DIR
KILL DIR
+69 IF $DATA(DUOUT)!$DATA(DTOUT)
SET AMERQUIT=1
+70 IF $GET(Y)=0
SET AMERNNAR=AMERONAR
+71 IF $GET(Y)=1
Begin DoDot:3
+72 SET DIR(0)="FAOr^1:80"
SET DIR("A")="Enter NEW Provider Narrative: "
SET DIR("B")=AMERONAR
+73 DO ^DIR
+74 IF $DATA(DUOUT)!$DATA(DTOUT)
SET AMERQUIT=1
QUIT
+75 IF Y=""
QUIT
+76 ;IHS/OIT/SCR 092909 patch 2 START CHANGES TO AVOID ";" IN NARRATIVE
+77 DO CKSC^AMER1
+78 IF $DATA(AMERCKSC)
Begin DoDot:4
+79 SET AMERGOOD=0
+80 FOR
IF AMERGOOD
QUIT
Begin DoDot:5
+81 SET Y=$GET(DIR("B"))
+82 SET DIR(0)="FAOr^1:80"
SET DIR("A")="Enter NEW Provider Narrative: "
SET DIR("B")=AMERONAR
+83 DO ^DIR
+84 DO CKSC^AMER1
+85 IF '$DATA(AMERCKSC)
SET AMERGOOD=1
+86 KILL AMERCKSC
+87 QUIT
End DoDot:5
+88 IF Y=""
SET AMERQUIT=1
+89 QUIT
End DoDot:4
+90 KILL DIR
+91 IF AMERQUIT
QUIT
+92 ;IHS/OIT/SCR 071509 patch 2 END CHANGES
+93 SET AMERNNAR=Y
+94 IF (AMERNNAR'=AMERONAR)
Begin DoDot:4
+95 SET DIE="^AMERVSIT(DA(1),5,"
SET DA(1)=AMERDA
SET DA=AMERDXNO
SET DR=""
+96 ;IHS/OIT/SCR 05/05/09
SET AMERNNAR=$$STRIPNAR^AMERPCC2(AMERNNAR)
+97 SET DR="1////"_AMERNNAR
+98 ; Update the POV multiple in AMER VISIT
DO MULTDIE^AMEREDIT(DIE,DA,DA(1),DR)
KILL DIE
+99 ; UPDATE PRIM DX NARR IN ER VISIT FILE ; IHS/OIT/GIS 12/09/2011
IF DA=1
Begin DoDot:5
+100 SET DIE="^AMERVSIT("
SET DA=AMERDA
SET DR="5.3////^S X=AMERNNAR"
+101 LOCK +^AMERVSIT(DA):1
IF $TEST
DO ^DIE
LOCK -^AMERVSIT(DA)
+102 QUIT
End DoDot:5
+103 SET DR=""
+104 ; Update the Audit file
SET AMERSTRG=$$EDAUDIT^AMEREDAU("5-1"_"."_AMEREDNO,AMERONAR,AMERNNAR,"PROVIDER NARRATIVE")
+105 IF AMERSTRG="^"
QUIT
+106 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+107 QUIT
End DoDot:4
+108 QUIT
End DoDot:3
+109 ;IHS/OIT/GIS 11/30/11 patch 3
IF AMERNDX=AMERODX
IF AMERNNAR=AMERONAR
+110 ; Update the V POV entry here
IF '$TEST
DO UPVPOV^AMEREDDY(AMERNDX,AMERODX,AMERNNAR,AMERONAR,AMERDA)
+111 QUIT
End DoDot:2
+112 IF AMEREDTS'=""
DO MULTAUDT^AMEREDAU(AMEREDTS,AMERAIEN)
+113 SET AMEREDTS=""
+114 QUIT
End DoDot:1
+115 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
QUIT AMERPRIS
+116 SET Y=""
SET AMERDXNO=0
+117 IF 'AMERSKIP&(AMERDX>0)
Begin DoDot:1
+118 SET AMERODX=""
SET AMERNDX=AMERICD9
SET AMEROLDS=""
+119 SET AMERNDX=AMERICD9
+120 SET DIR("A")="Enter narrative description of DX: "
+121 SET DIR(0)="FAOr^1:80"
+122 SET DIR("?")="Enter free text diagnosis (80 characters max. ';' and ':' not allowed)"
+123 DO ^DIR
+124 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
QUIT
+125 SET AMERNNAR=Y
+126 IF AMERNNAR=""
QUIT
+127 ;IHS/OIT/SCR 05/05/09
SET AMERNNAR=$$STRIPNAR^AMERPCC2(AMERNNAR)
+128 IF AMERDX=$PIECE($$ICDDX^ICDCODE(".9999",,,1),U,1)
Begin DoDot:2
+129 ; DIAGNOSES
SET DA(1)=AMERDA
SET DIC="^AMERVSIT("_DA(1)_",5,"
SET DIC(0)="L"
+130 SET X=AMERDX
+131 DO FILE^DICN
+132 QUIT
End DoDot:2
+133 IF AMERDX'=$PIECE($$ICDDX^ICDCODE(".9999",,,1),U,1)
Begin DoDot:2
+134 ; DIAGNOSES
SET DA(1)=AMERDA
SET DIC="^AMERVSIT("_DA(1)_",5,"
SET DIC(0)="L"
+135 SET X="`"_AMERDX
+136 DO ^DIC
+137 QUIT
End DoDot:2
+138 IF Y<0
QUIT
+139 ; Just created a new DX in ER VISIT file - collect audit information and update V POV
+140 ; Add V POV entry to sync with ER VISIT file
DO ADDVPOV^AMEREDDY(AMERNDX,AMERNNAR,AMERDA)
+141 ; Collect code edit info
SET AMERSTRG=$$EDAUDIT^AMEREDAU("5-01"_"."_AMEREDNO,"",$$EDDISPL^AMEREDAU(AMERNDX,"X"),"DIAGNOSIS")
+142 IF AMERSTRG="^"
QUIT
+143 SET AMEREDTS=$SELECT(AMEREDTS="":AMERSTRG,1:AMEREDTS_"^"_AMERSTRG)
+144 SET DIE=DIC
SET DA(1)=AMERDA
SET DA=+Y
SET DR="1////"_AMERNNAR
+145 KILL DIC
+146 DO MULTDIE^AMEREDIT(DIE,DA,DA(1),DR)
+147 QUIT
End DoDot:1
+148 QUIT AMERPRIS
SELECTDX(AMERPDX,AMERPNAR) ;IHS/OIT/GIS 9/9/11 patch 3
+1 NEW AMERICD9,AMERDXNO,AMERSEL,DIR
+2 ; DEFAULT TO QUIT
SET AMERSEL=0
+3 ;IHS/OIT/SCR 11/18/08 TEMPORARILY ALLOWING LOCAL CODES
+4 ;S AMERICD9=$P($$ICDDX^ICDCODE($P($G(^AMERVSIT(AMERDA,5,0)),U,3),0),U,2)
+5 ;S AMERICD9=$P($$ICDDX^ICDCODE($P($G(^AMERVSIT(AMERDA,5,0)),U,3),,,1),U,2)
+6 DO EN^DDIOL("EDIT/ADD Dx narrative(s) and/or code(s)","","!")
+7 DO EN^DDIOL("Primary DX is marked with '**'","","!?5")
+8 ;IHS/OIT/SCR 11/03/08 - allow dx to be selected by number START CHANGES
+9 SET AMERDXNO=0
+10 ; S DIR(0)="SO^0: ADD NEW DIAGNOSIS;"
+11 SET DIR(0)="SO^"
+12 FOR
SET AMERDXNO=$ORDER(^AMERVSIT(AMERDA,5,AMERDXNO))
IF (AMERDXNO="B"!(AMERDXNO=""))
QUIT
Begin DoDot:1
+13 NEW Y1,Y2,Y
+14 ;ICD9 CODE
SET Y=$GET(^AMERVSIT(AMERDA,5,AMERDXNO,0))
+15 ;IHS/OIT/SCR 11/20/08 TEMPORARILY ALLOWING LOCAL CODES
+16 ;S Y1=$P($$ICDDX^ICDCODE(Y),U,2)
+17 ;S Y2=$P($$ICDDX^ICDCODE(Y),U,4)
+18 SET Y1=$PIECE($$ICDDX^ICDCODE(Y,,,1),U,2)
+19 SET Y2=$PIECE($$ICDDX^ICDCODE(Y,,,1),U,4)
+20 IF Y1=AMERPDX&($GET(^AMERVSIT(AMERDA,5,AMERDXNO,1))=AMERPNAR)
Begin DoDot:2
+21 SET DIR(0)=DIR(0)_AMERDXNO_":**"_Y1_"("_Y2_") "_$GET(^AMERVSIT(AMERDA,5,AMERDXNO,1))_";"
+22 QUIT
End DoDot:2
+23 IF '$TEST
SET DIR(0)=DIR(0)_AMERDXNO_": "_Y1_" ("_Y2_") "_$GET(^AMERVSIT(AMERDA,5,AMERDXNO,1))_";"
+24 QUIT
End DoDot:1
+25 SET DIR(0)=DIR(0)_"A: ADD NEW DIAGNOSIS;Q: QUIT"
+26 ; S DIR("B")=0 ;IHS/OIT/SCR 11/20/08
+27 SET DIR("A")="Enter line # to EDIT, 'A' to ADD NEW DIAGNOSIS, or 'Q' to QUIT"
SET DIR("?")="Enter line number you want to edit, ADD or QUIT"
+28 DO ^DIR
+29 IF $DATA(DUOUT)!$DATA(DTOUT)
KILL DUOUT,DTOUT
QUIT -1
+30 QUIT $SELECT(Y:Y,Y="A":0,1:-1)
+31 ;
