- 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
- 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
