MCARGD ;WISC/TJK-DIAGNOSIS FILTER ;3/11/96 12:06
;;2.3;Medicine;;09/13/1996
G EXIT:$D(DUOUT)!($D(DTOUT))
PROC W:$D(MCDFLAG) @IOF W !!?33,"DIAGNOSIS ENTRY",!?33,"--------------",!! S (DIC,DIE)="^MCAR(699,",DA=MCARGDA,MCARTY="Primary" G EDIT:$D(^MCAR(699,MCARGDA,204))
D ARR G COM:'$D(V)
PRIM G PRIM1:J>1
S DIR("A")="Do you wish to enter this diagnosis as the primary diagnosis"
S DIR("B")="Y",DIR(0)="Y"
D ^DIR
G EXIT:$G(DIRUT),SEC:'Y
S Z=1
G PRIM2
PRIM1 W !!,"Enter Primary Diagnosis (1-",J,"): " R Z:DTIME G EXIT:'$T,EXIT:Z=U
I Z?1"?"."?" W !,*7,"Enter Number of Diagnosis That You Wish to Use as Primary Diagnosis",!,"Hit Return if you do not wish to enter any of above" G PRIM1
G SEC:Z="" I '$D(V(Z)) W *7," ??" G PRIM1
PRIM2 S X=V(Z),DR="204///"_X_";205" W !,$P(^MCAR(697.5,X,0),U) D ^DIE G EXIT:$D(DTOUT),EXIT:$D(Y)
SEC S MCARTY="Secondary" D ARR G COM:'$D(V) K DR
W !!,"Enter Number of Secondary Diagnosis or 'ALL' to enter all: "
R Z:DTIME G EXIT:'$T,COM:Z="",EXIT:Z=U I Z="ALL" F ZI=0:0 S ZI=$O(V(ZI)) Q:ZI="" D SECSET
K ZI G COM:Z="ALL",COM:Z="" I $E(Z)="?" W !,*7,"Enter Number of Diagnosis from above list or enter 'ALL' for All Diagnoses to be entered as a secondary diagnosis."
I '$D(V(Z)) W *7," ??" G SEC
S ZI=Z D SECSET K ZI G EXIT:$D(DTOUT),EXIT:$D(Y) G SEC
COM K DR,DIC,DIE,DA S DIE="^MCAR(699,",DA=MCARGDA,DR="37.1"
;MFD 3/10/93 ;700",DR(2,699.03)=.01
D ^DIE G EXIT:$D(DTOUT),EXIT:$D(Y)
REV G EXIT:'$D(^MCAR(699,MCARGDA,204))
K DR S DR=38 D ^DIE G EXIT
EDIT S DR="204;205" D ^DIE G EXIT:$D(DTOUT),EXIT:$D(Y)
G SEC
SECSET K DR,DIE,DIC S:'$D(^MCAR(699,MCARGDA,27)) ^(27,0)="^699.75^0^0" S X=$P(^MCAR(697.5,V(ZI),0),U),DA(1)=MCARGDA,DIE="^MCAR(699,"_MCARGDA_",27,"
I $D(^MCAR(699,MCARGDA,27,"B",V(ZI))) S DA=$O(^(V(ZI),0)),DR=".01;1" G SECSET1
S DR=".01///"_V(ZI)_";1" F DA=1:1 Q:'$D(^MCAR(699,MCARGDA,27,DA))
S $P(^MCAR(699,MCARGDA,27,0),U,3)=DA,$P(^(0),U,4)=$P(^(0),U,4)+1
SECSET1 W !,X D ^DIE Q
ARR K V,A S J=0
F I=0:0 S I=$O(^MCAR(699,MCARGDA,30,I)) Q:I'?1N.N I $P(^(I,0),U,6) S K=$P(^(0),U,6) D CHECK,LIST
Q
CHECK I '$D(^MCAR(699,MCARGDA,204)) Q
I $D(^MCAR(699,MCARGDA,204)),^(204)'=K Q
Q
LIST I $T,'$D(A(K)) S J=J+1 W:J=1 !!,"Possible ",MCARTY," Diagnoses are: " W !,J,". ",$P(^MCAR(697.5,K,0),U) S V(J)=K,A(K)="" D ENTERED:$E(MCARTY)="S"
Q
ENTERED I $D(^MCAR(699,MCARGDA,27,"B",K)) W " ****ENTERED****"
Q
DPT ;
S MCPRO=$S(MCARCODE="P":"PULM",1:"GI")
D MCEPROC^MCARE
S DIC="^MCAR(699,",DIC(0)="AEQMZ",MCFILE=699
S DIC("S")="I $D(^MCAR(697.2,""D"",MCARCODE,$P(^MCAR(699,+Y,0),U,12))),$P(^MCAR(699,+Y,0),U,12)'=$O(^MCAR(697.2,""B"",""NON-ENDO"",0))"
I MCESON S DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
S DIC("A")="Select Patient Name or Date/Time of Appointment: "
D ^DIC K DIC("S"),DIC("A")
G EXIT:Y<0
S MCARGDA=+Y,MCARGNUM=$P(Y(0),U,12),MCFILE=699
I MCESON,("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA)) D ESRC^MCESSCR(MCFILE,MCARGDA) I '$D(MCBACK) G EXIT ;RMP CHANGED () EXPRESSION FROM >2
I $D(MCBACK) D BACK^MCARGE
S DFN=$P(Y(0),U,2),MCARGDA=+Y,MCARGNUM=$P(Y(0),U,12),MCARGNAM=$P(^MCAR(697.2,MCARGNUM,0),U)
D ORDER^MCARGEO G EXIT:$D(DTOUT)!$D(DUOUT)
D PROC,ORDER1^MCARGEO,QTASK^MCPARAM
I $G(MCARGDA)>0 S UNSIGNED=$S($P(^MCAR(MCFILE,MCARGDA,"ES"),U,4)="":1,1:0) D POST^MCESEDT(MCFILE,.MCARGDA) D:UNSIGNED=1 ^MCWORKLD
K MCARGDA,MCARGNUM,MCFILE,MCARGNON,UNSIGNED
EXIT ;
K DIC,DIE,DA,I,J,K,V,MCARTY,Z,ZI,A,%,%Y,%Y1,%Y2,C,D,D0,DI,DIPGM,DQ,DR,MCARCODE,X,Y,A,MCPROV Q
EN1 ;CALLED BY X-REF TO DELETE SECONDARY DIAGNOSIS WHEN IMPRESSION IS DELETED
N I,J
S I=$O(^MCAR(699,DA(1),27,"B",X,0)) Q:'I
K ^MCAR(699,DA(1),27,I),^MCAR(699,DA(1),27,"B",X,I)
S I=$P(^MCAR(699,DA(1),27,0),U,3),J=$P(^(0),U,4),$P(^(0),U,3)=I-1,$P(^(0),U,4)=J-1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARGD 3762 printed Dec 13, 2024@02:12:53 Page 2
MCARGD ;WISC/TJK-DIAGNOSIS FILTER ;3/11/96 12:06
+1 ;;2.3;Medicine;;09/13/1996
+2 if $DATA(DUOUT)!($DATA(DTOUT))
GOTO EXIT
PROC if $DATA(MCDFLAG)
WRITE @IOF
WRITE !!?33,"DIAGNOSIS ENTRY",!?33,"--------------",!!
SET (DIC,DIE)="^MCAR(699,"
SET DA=MCARGDA
SET MCARTY="Primary"
if $DATA(^MCAR(699,MCARGDA,204))
GOTO EDIT
+1 DO ARR
if '$DATA(V)
GOTO COM
PRIM if J>1
GOTO PRIM1
+1 SET DIR("A")="Do you wish to enter this diagnosis as the primary diagnosis"
+2 SET DIR("B")="Y"
SET DIR(0)="Y"
+3 DO ^DIR
+4 if $GET(DIRUT)
GOTO EXIT
if 'Y
GOTO SEC
+5 SET Z=1
+6 GOTO PRIM2
PRIM1 WRITE !!,"Enter Primary Diagnosis (1-",J,"): "
READ Z:DTIME
if '$TEST
GOTO EXIT
if Z=U
GOTO EXIT
+1 IF Z?1"?"."?"
WRITE !,*7,"Enter Number of Diagnosis That You Wish to Use as Primary Diagnosis",!,"Hit Return if you do not wish to enter any of above"
GOTO PRIM1
+2 if Z=""
GOTO SEC
IF '$DATA(V(Z))
WRITE *7," ??"
GOTO PRIM1
PRIM2 SET X=V(Z)
SET DR="204///"_X_";205"
WRITE !,$PIECE(^MCAR(697.5,X,0),U)
DO ^DIE
if $DATA(DTOUT)
GOTO EXIT
if $DATA(Y)
GOTO EXIT
SEC SET MCARTY="Secondary"
DO ARR
if '$DATA(V)
GOTO COM
KILL DR
+1 WRITE !!,"Enter Number of Secondary Diagnosis or 'ALL' to enter all: "
+2 READ Z:DTIME
if '$TEST
GOTO EXIT
if Z=""
GOTO COM
if Z=U
GOTO EXIT
IF Z="ALL"
FOR ZI=0:0
SET ZI=$ORDER(V(ZI))
if ZI=""
QUIT
DO SECSET
+3 KILL ZI
if Z="ALL"
GOTO COM
if Z=""
GOTO COM
IF $EXTRACT(Z)="?"
WRITE !,*7,"Enter Number of Diagnosis from above list or enter 'ALL' for All Diagnoses to be entered as a secondary diagnosis."
+4 IF '$DATA(V(Z))
WRITE *7," ??"
GOTO SEC
+5 SET ZI=Z
DO SECSET
KILL ZI
if $DATA(DTOUT)
GOTO EXIT
if $DATA(Y)
GOTO EXIT
GOTO SEC
COM KILL DR,DIC,DIE,DA
SET DIE="^MCAR(699,"
SET DA=MCARGDA
SET DR="37.1"
+1 ;MFD 3/10/93 ;700",DR(2,699.03)=.01
+2 DO ^DIE
if $DATA(DTOUT)
GOTO EXIT
if $DATA(Y)
GOTO EXIT
REV if '$DATA(^MCAR(699,MCARGDA,204))
GOTO EXIT
+1 KILL DR
SET DR=38
DO ^DIE
GOTO EXIT
EDIT SET DR="204;205"
DO ^DIE
if $DATA(DTOUT)
GOTO EXIT
if $DATA(Y)
GOTO EXIT
+1 GOTO SEC
SECSET KILL DR,DIE,DIC
if '$DATA(^MCAR(699,MCARGDA,27))
SET ^(27,0)="^699.75^0^0"
SET X=$PIECE(^MCAR(697.5,V(ZI),0),U)
SET DA(1)=MCARGDA
SET DIE="^MCAR(699,"_MCARGDA_",27,"
+1 IF $DATA(^MCAR(699,MCARGDA,27,"B",V(ZI)))
SET DA=$ORDER(^(V(ZI),0))
SET DR=".01;1"
GOTO SECSET1
+2 SET DR=".01///"_V(ZI)_";1"
FOR DA=1:1
if '$DATA(^MCAR(699,MCARGDA,27,DA))
QUIT
+3 SET $PIECE(^MCAR(699,MCARGDA,27,0),U,3)=DA
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
SECSET1 WRITE !,X
DO ^DIE
QUIT
ARR KILL V,A
SET J=0
+1 FOR I=0:0
SET I=$ORDER(^MCAR(699,MCARGDA,30,I))
if I'?1N.N
QUIT
IF $PIECE(^(I,0),U,6)
SET K=$PIECE(^(0),U,6)
DO CHECK
DO LIST
+2 QUIT
CHECK IF '$DATA(^MCAR(699,MCARGDA,204))
QUIT
+1 IF $DATA(^MCAR(699,MCARGDA,204))
IF ^(204)'=K
QUIT
+2 QUIT
LIST IF $TEST
IF '$DATA(A(K))
SET J=J+1
if J=1
WRITE !!,"Possible ",MCARTY," Diagnoses are: "
WRITE !,J,". ",$PIECE(^MCAR(697.5,K,0),U)
SET V(J)=K
SET A(K)=""
if $EXTRACT(MCARTY)="S"
DO ENTERED
+1 QUIT
ENTERED IF $DATA(^MCAR(699,MCARGDA,27,"B",K))
WRITE " ****ENTERED****"
+1 QUIT
DPT ;
+1 SET MCPRO=$SELECT(MCARCODE="P":"PULM",1:"GI")
+2 DO MCEPROC^MCARE
+3 SET DIC="^MCAR(699,"
SET DIC(0)="AEQMZ"
SET MCFILE=699
+4 SET DIC("S")="I $D(^MCAR(697.2,""D"",MCARCODE,$P(^MCAR(699,+Y,0),U,12))),$P(^MCAR(699,+Y,0),U,12)'=$O(^MCAR(697.2,""B"",""NON-ENDO"",0))"
+5 IF MCESON
SET DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
+6 SET DIC("A")="Select Patient Name or Date/Time of Appointment: "
+7 DO ^DIC
KILL DIC("S"),DIC("A")
+8 if Y<0
GOTO EXIT
+9 SET MCARGDA=+Y
SET MCARGNUM=$PIECE(Y(0),U,12)
SET MCFILE=699
+10 ;RMP CHANGED () EXPRESSION FROM >2
IF MCESON
IF ("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA))
DO ESRC^MCESSCR(MCFILE,MCARGDA)
IF '$DATA(MCBACK)
GOTO EXIT
+11 IF $DATA(MCBACK)
DO BACK^MCARGE
+12 SET DFN=$PIECE(Y(0),U,2)
SET MCARGDA=+Y
SET MCARGNUM=$PIECE(Y(0),U,12)
SET MCARGNAM=$PIECE(^MCAR(697.2,MCARGNUM,0),U)
+13 DO ORDER^MCARGEO
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
+14 DO PROC
DO ORDER1^MCARGEO
DO QTASK^MCPARAM
+15 IF $GET(MCARGDA)>0
SET UNSIGNED=$SELECT($PIECE(^MCAR(MCFILE,MCARGDA,"ES"),U,4)="":1,1:0)
DO POST^MCESEDT(MCFILE,.MCARGDA)
if UNSIGNED=1
DO ^MCWORKLD
+16 KILL MCARGDA,MCARGNUM,MCFILE,MCARGNON,UNSIGNED
EXIT ;
+1 KILL DIC,DIE,DA,I,J,K,V,MCARTY,Z,ZI,A,%,%Y,%Y1,%Y2,C,D,D0,DI,DIPGM,DQ,DR,MCARCODE,X,Y,A,MCPROV
QUIT
EN1 ;CALLED BY X-REF TO DELETE SECONDARY DIAGNOSIS WHEN IMPRESSION IS DELETED
+1 NEW I,J
+2 SET I=$ORDER(^MCAR(699,DA(1),27,"B",X,0))
if 'I
QUIT
+3 KILL ^MCAR(699,DA(1),27,I),^MCAR(699,DA(1),27,"B",X,I)
+4 SET I=$PIECE(^MCAR(699,DA(1),27,0),U,3)
SET J=$PIECE(^(0),U,4)
SET $PIECE(^(0),U,3)=I-1
SET $PIECE(^(0),U,4)=J-1
QUIT
