MCARGES ;WISC/TJK-SCREEN ENTER/EDIT-ENDOSCOPY,HEMATOLOGY,PACEMAKER ;4/7/97 14:14
;;2.3;Medicine;**8,15,16**;09/13/1996
START ;
K EXIT,MCDEMO,MCESFL S MCESFL=1
D ENTER I '$D(MCFILE)!('$D(MCARGDA)) D EXIT Q
I '$D(^MCAR(MCFILE,MCARGDA,0)),$D(MCBACK) D BACKSS^MCESEDT K MCBACK S EXIT=1
K:'$D(^MCAR(MCFILE,MCARGDA,0)) MCESFL D EXIT
Q
ENTER ; edit a GI procedure record and display/edit history if selected
D DPT^MCARGE I $D(EXIT) Q
I MCARCODE="G"!(MCARCODE="P") S MCDEMO=1 D DEMO^MCARGE
;if user wants to edit patient history in patient file
I $D(MCDEMO) D
.S DJSC="MCGDEM",DIC="MCAR(690,",DJDN=DFN,DIC(0)="EQ" D EN^MCARD
.S:$D(DUOUT) EXIT=1
.I '$D(EXIT),$D(^DIC(120.8)) N VADM D EN2^GMRAPEM0
.K MCDEMO
.;restore the procedure record number after patient lookup in 690
.S MCARGDA=+$G(MCARDA)
Q:$D(EXIT) D EDIT Q
EDIT D:MCARCODE="G" SETVAR^MCARGE K DIC
S DJSC=MCEPROC
S DJDN=MCARGDA,DIC="^MCAR("_MCFILE_","
S DIC(0)="EQ"
D IN^MCEO
I $D(DTOUT)!$D(DUOUT) S EXIT=1 Q
D EN^MCARD
I $D(DUOUT) S EXIT=1 Q
I '$D(^MCAR(MCFILE,MCARGDA,0)) S EXIT=1 Q
S MCDFLAG="" I MCARGNAM'="NON-ENDO" D ^MCARGD
D OUT^MCEO
Q
CONSULT ;
K DIC S MCDFLAG="" D CONSULT^MCARGE
G EXIT:$D(DTOUT),EXIT:$D(DUOUT) I $D(Y),Y<0 G EXIT
S DJSC=$S($G(MCBS)=1:"MCCONSULTBR",1:"MCCONSULT")
S DIC="^MCAR(699.5,",DJDN=MCARGDA,DIC(0)="EQ",MCFILE=699.5 D IN^MCEO G EXIT:$D(DTOUT)!$D(DUOUT) D EN^MCARD,OUT^MCEO
EXIT ;
I '$D(DTOUT),'$D(DUOUT),$D(MCESFL),$D(MCFILE),$D(MCARGDA),MCESON D:MCESFL=0 ESRC^MCESSCR(MCFILE,MCARGDA)
K AV,MULTI,EXIT,X,MCPRO,MCEPROC,MCPATNM D EXIT^MCARGE
Q
GENEX(MCARGDA,GENEX) ;Check and resolve non-associated procedures
I ('$P(^MCAR(699.5,MCARGDA,0),U,2)!'$P(^(0),U,6)) S DIK="^MCAR(699.5,",DA=MCARGDA,GENEX=1 D ^DIK Q
Q
GENERIC ;Generic Medicine Enter/Edit
W !,"GENERIC EDIT"
N GENEX S GENEX=0
D MCEPROC^MCARE,^MCAREH
S DIC="^MCAR(699.5,",DIC(0)="AEQLM",(DLAYGO,DIDEL,MCFILE)=699.5,DIC("S")="I '$P(^MCAR(699.5,+Y,0),U,3)"
S DR=".01;.02;.05" D ^DIC G EXIT:Y<0 S MCARGDA=+Y,MCESFL=0
D GENEX(MCARGDA,.GENEX) G:GENEX EXIT
; allow user to edit .01 field
I MCESON,("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA)) D ESRC^MCESSCR(MCFILE,.MCARGDA) G:$D(MCBACK) SETUP K DIC Q
SUPS S DIE="^MCAR(699.5,",DA=MCARGDA,DR=".01;.02;.05" D ^DIE
I $D(DA) D GENEX(MCARGDA,.GENEX) G:GENEX EXIT
I $D(DTOUT)!$D(DUOUT)!'$D(DA) G EXIT
S MCARGNUM=$P(^MCAR(699.5,MCARGDA,0),U,6),DFN=$P(^(0),U,2)
S DJSC=MCEPROC
S MCARGNAM=$P(^MCAR(699.5,MCARGDA,0),U),DJDN=MCARGDA,DIC="^MCAR(699.5,",DIC(0)="EQ"
S MCHOLD=MCARGDA
;D IN^MCEO G EXIT:$D(DTOUT)!$D(DUOUT) D EN^MCARD S MCARGDA=MCHOLD D GENEX(MCARGDA,.GENEX) K MCHOLD G:GENEX EXIT
D IN^MCEO G EXIT:$D(DUOUT) D EN^MCARD S MCARGDA=MCHOLD D GENEX(MCARGDA,.GENEX) K MCHOLD ;MC*2.3*8
D OUT^MCEO,QTASK^MCPARAM G EXIT
;
HEM S DIC="^MCAR(694,",DIC(0)="AEQLM",(DLAYGO,DIDEL,MCFILE)=694 D ^DIC G EXIT:Y<0
S MCARGDA=+Y I $D(DTOUT),('$P(^MCAR(694,+Y,0),U,2))!('$P(^(0),U,3)) S DIK="^MCAR(694,",DA=MCARGDA D ^DIK W "??" G EXIT
S MCARGNUM=$P(^MCAR(694,MCARGDA,0),U,3),DFN=$P(^(0),U,2),DJSC=MCEPROC
S MCARGNAM=$P(^MCAR(697.2,MCARGNUM,0),U),DJDN=MCARGDA,DIC="^MCAR(694,",DIC(0)="EQ"
G EXIT:$D(DTOUT)!$D(DUOUT) D EN^MCARD,QTASK^MCPARAM G EXIT
MULTI K MULTI S MULTI="",MCARGDA=-1 D GEN G EXIT:$D(DTOUT),EXIT:$D(DUOUT),EXIT:'$G(MCARGDA)
S AV=$G(^MCAR(698,MCARGDA,0)),DFN=$P(AV,U,2),AV=$P(AV,U,7) G EXIT:AV=""!("AV"'[AV)
K DIC S DIC("S")="I $P(^(0),U,2)=DFN" D ALEAD:AV["A" G EXIT:$D(DUOUT)!($D(DTOUT))
K DIC S DIC("S")="I $P(^(0),U,2)=DFN" D VLEAD:AV["V" G EXIT
GEN S MCFILE=698
S MCPRO="GEN.IMPL." D MCEPROC^MCARE S MCARGNUM=MCARGNAM,MCARGNAM="GENERATOR IMPLANT" G LOOK
VLEAD S MCFILE=698.1
D:$D(MULTI) LAST^MCARPACE
S MCPRO="V-LEAD IMP" D MCEPROC^MCARE S MCARGNUM=MCARGNAM,MCARGNAM="VENTRICAL LEAD IMPLANT" G LOOK
ALEAD S MCFILE=698.2
D:$D(MULTI) LAST^MCARPACE
S MCPRO="A-LEAD IMP" D MCEPROC^MCARE S MCARGNUM=MCARGNAM,MCARGNAM="ATRIAL LEAD IMPLANT" G LOOK
DEMO ;
W @IOF,!!!,"DEMOGRAPHIC INFORMATION *** SCREEN EDIT ***",!!!
D
.N DLAYGO
.S DLAYGO=690,DIC="^MCAR(690,",DIC(0)="AEQLM",DIC("B")=$G(MCPATNM)
.D ^DIC
.Q
G EXIT:Y<0
S (DJDN,MCARGDA)=+Y,DJSC="MCPACEDEMO",DIC(0)="EQ" D EN^MCARD
;get new default patient name
S MCX=$$VALUE^MCENDIQ1(690,MCARGDA,.01)
I MCX'="" S MCPATNM=MCX
G EXIT
LOOK ;
W @IOF,!!!,MCARGNAM," PROCEDURES *** SCREEN EDIT ***",!!!
S DIC="^MCAR("_MCFILE_",",DIC(0)="AEQLM"
S DIC("A")="Enter patient name, or date and time: "
;S DIC("B")=$G(MCPATNM)
S (DLAYGO,DIDEL)=MCFILE D ^DIC G EX:Y<0
;
; NOTE: next line must define DFN for Order Entry to work
S MCARGDA=+Y,DFN=$P($G(^MCAR(MCFILE,MCARGDA,0)),U,2) I $D(DTOUT),'DFN S DIK=DIC,DA=MCARGDA D ^DIK G EX
S MCARGNUM=$O(^MCAR(697.2,"BA",MCARGNAM,0))
S DJSC=MCEPROC
S MCARGNAM=$P(^MCAR(697.2,MCARGNUM,0),U),DJDN=MCARGDA,DIC(0)="EQ" D IN^MCEO G EXIT:$D(DTOUT)!$D(DUOUT) D EN^MCARD,OUT^MCEO
;get new default patient name
S MCX=$$VALUE^MCENDIQ1(MCFILE,MCARGDA,1)
I MCX'="" S MCPATNM=MCX
EX Q:$D(MULTI) G EXIT
SETUP ; If the record is superseded, the user will be allow to edit the superseded record.
S Y=MCY,DA=Y,Y(0)=MCY(0),Y(0,0)=MCY(0,0),MCARGDA=+MCY K MCY,DTOUT,DIROUT,DUOUT,DIC
G SUPS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARGES 5246 printed Dec 13, 2024@02:12:57 Page 2
MCARGES ;WISC/TJK-SCREEN ENTER/EDIT-ENDOSCOPY,HEMATOLOGY,PACEMAKER ;4/7/97 14:14
+1 ;;2.3;Medicine;**8,15,16**;09/13/1996
START ;
+1 KILL EXIT,MCDEMO,MCESFL
SET MCESFL=1
+2 DO ENTER
IF '$DATA(MCFILE)!('$DATA(MCARGDA))
DO EXIT
QUIT
+3 IF '$DATA(^MCAR(MCFILE,MCARGDA,0))
IF $DATA(MCBACK)
DO BACKSS^MCESEDT
KILL MCBACK
SET EXIT=1
+4 if '$DATA(^MCAR(MCFILE,MCARGDA,0))
KILL MCESFL
DO EXIT
+5 QUIT
ENTER ; edit a GI procedure record and display/edit history if selected
+1 DO DPT^MCARGE
IF $DATA(EXIT)
QUIT
+2 IF MCARCODE="G"!(MCARCODE="P")
SET MCDEMO=1
DO DEMO^MCARGE
+3 ;if user wants to edit patient history in patient file
+4 IF $DATA(MCDEMO)
Begin DoDot:1
+5 SET DJSC="MCGDEM"
SET DIC="MCAR(690,"
SET DJDN=DFN
SET DIC(0)="EQ"
DO EN^MCARD
+6 if $DATA(DUOUT)
SET EXIT=1
+7 IF '$DATA(EXIT)
IF $DATA(^DIC(120.8))
NEW VADM
DO EN2^GMRAPEM0
+8 KILL MCDEMO
+9 ;restore the procedure record number after patient lookup in 690
+10 SET MCARGDA=+$GET(MCARDA)
End DoDot:1
+11 if $DATA(EXIT)
QUIT
DO EDIT
QUIT
EDIT if MCARCODE="G"
DO SETVAR^MCARGE
KILL DIC
+1 SET DJSC=MCEPROC
+2 SET DJDN=MCARGDA
SET DIC="^MCAR("_MCFILE_","
+3 SET DIC(0)="EQ"
+4 DO IN^MCEO
+5 IF $DATA(DTOUT)!$DATA(DUOUT)
SET EXIT=1
QUIT
+6 DO EN^MCARD
+7 IF $DATA(DUOUT)
SET EXIT=1
QUIT
+8 IF '$DATA(^MCAR(MCFILE,MCARGDA,0))
SET EXIT=1
QUIT
+9 SET MCDFLAG=""
IF MCARGNAM'="NON-ENDO"
DO ^MCARGD
+10 DO OUT^MCEO
+11 QUIT
CONSULT ;
+1 KILL DIC
SET MCDFLAG=""
DO CONSULT^MCARGE
+2 if $DATA(DTOUT)
GOTO EXIT
if $DATA(DUOUT)
GOTO EXIT
IF $DATA(Y)
IF Y<0
GOTO EXIT
+3 SET DJSC=$SELECT($GET(MCBS)=1:"MCCONSULTBR",1:"MCCONSULT")
+4 SET DIC="^MCAR(699.5,"
SET DJDN=MCARGDA
SET DIC(0)="EQ"
SET MCFILE=699.5
DO IN^MCEO
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
DO EN^MCARD
DO OUT^MCEO
EXIT ;
+1 IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
IF $DATA(MCESFL)
IF $DATA(MCFILE)
IF $DATA(MCARGDA)
IF MCESON
if MCESFL=0
DO ESRC^MCESSCR(MCFILE,MCARGDA)
+2 KILL AV,MULTI,EXIT,X,MCPRO,MCEPROC,MCPATNM
DO EXIT^MCARGE
+3 QUIT
GENEX(MCARGDA,GENEX) ;Check and resolve non-associated procedures
+1 IF ('$PIECE(^MCAR(699.5,MCARGDA,0),U,2)!'$PIECE(^(0),U,6))
SET DIK="^MCAR(699.5,"
SET DA=MCARGDA
SET GENEX=1
DO ^DIK
QUIT
+2 QUIT
GENERIC ;Generic Medicine Enter/Edit
+1 WRITE !,"GENERIC EDIT"
+2 NEW GENEX
SET GENEX=0
+3 DO MCEPROC^MCARE
DO ^MCAREH
+4 SET DIC="^MCAR(699.5,"
SET DIC(0)="AEQLM"
SET (DLAYGO,DIDEL,MCFILE)=699.5
SET DIC("S")="I '$P(^MCAR(699.5,+Y,0),U,3)"
+5 SET DR=".01;.02;.05"
DO ^DIC
if Y<0
GOTO EXIT
SET MCARGDA=+Y
SET MCESFL=0
+6 DO GENEX(MCARGDA,.GENEX)
if GENEX
GOTO EXIT
+7 ; allow user to edit .01 field
+8 IF MCESON
IF ("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA))
DO ESRC^MCESSCR(MCFILE,.MCARGDA)
if $DATA(MCBACK)
GOTO SETUP
KILL DIC
QUIT
SUPS SET DIE="^MCAR(699.5,"
SET DA=MCARGDA
SET DR=".01;.02;.05"
DO ^DIE
+1 IF $DATA(DA)
DO GENEX(MCARGDA,.GENEX)
if GENEX
GOTO EXIT
+2 IF $DATA(DTOUT)!$DATA(DUOUT)!'$DATA(DA)
GOTO EXIT
+3 SET MCARGNUM=$PIECE(^MCAR(699.5,MCARGDA,0),U,6)
SET DFN=$PIECE(^(0),U,2)
+4 SET DJSC=MCEPROC
+5 SET MCARGNAM=$PIECE(^MCAR(699.5,MCARGDA,0),U)
SET DJDN=MCARGDA
SET DIC="^MCAR(699.5,"
SET DIC(0)="EQ"
+6 SET MCHOLD=MCARGDA
+7 ;D IN^MCEO G EXIT:$D(DTOUT)!$D(DUOUT) D EN^MCARD S MCARGDA=MCHOLD D GENEX(MCARGDA,.GENEX) K MCHOLD G:GENEX EXIT
+8 ;MC*2.3*8
DO IN^MCEO
if $DATA(DUOUT)
GOTO EXIT
DO EN^MCARD
SET MCARGDA=MCHOLD
DO GENEX(MCARGDA,.GENEX)
KILL MCHOLD
+9 DO OUT^MCEO
DO QTASK^MCPARAM
GOTO EXIT
+10 ;
HEM SET DIC="^MCAR(694,"
SET DIC(0)="AEQLM"
SET (DLAYGO,DIDEL,MCFILE)=694
DO ^DIC
if Y<0
GOTO EXIT
+1 SET MCARGDA=+Y
IF $DATA(DTOUT)
IF ('$PIECE(^MCAR(694,+Y,0),U,2))!('$PIECE(^(0),U,3))
SET DIK="^MCAR(694,"
SET DA=MCARGDA
DO ^DIK
WRITE "??"
GOTO EXIT
+2 SET MCARGNUM=$PIECE(^MCAR(694,MCARGDA,0),U,3)
SET DFN=$PIECE(^(0),U,2)
SET DJSC=MCEPROC
+3 SET MCARGNAM=$PIECE(^MCAR(697.2,MCARGNUM,0),U)
SET DJDN=MCARGDA
SET DIC="^MCAR(694,"
SET DIC(0)="EQ"
+4 if $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
DO EN^MCARD
DO QTASK^MCPARAM
GOTO EXIT
MULTI KILL MULTI
SET MULTI=""
SET MCARGDA=-1
DO GEN
if $DATA(DTOUT)
GOTO EXIT
if $DATA(DUOUT)
GOTO EXIT
if '$GET(MCARGDA)
GOTO EXIT
+1 SET AV=$GET(^MCAR(698,MCARGDA,0))
SET DFN=$PIECE(AV,U,2)
SET AV=$PIECE(AV,U,7)
if AV=""!("AV"'[AV)
GOTO EXIT
+2 KILL DIC
SET DIC("S")="I $P(^(0),U,2)=DFN"
if AV["A"
DO ALEAD
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO EXIT
+3 KILL DIC
SET DIC("S")="I $P(^(0),U,2)=DFN"
if AV["V"
DO VLEAD
GOTO EXIT
GEN SET MCFILE=698
+1 SET MCPRO="GEN.IMPL."
DO MCEPROC^MCARE
SET MCARGNUM=MCARGNAM
SET MCARGNAM="GENERATOR IMPLANT"
GOTO LOOK
VLEAD SET MCFILE=698.1
+1 if $DATA(MULTI)
DO LAST^MCARPACE
+2 SET MCPRO="V-LEAD IMP"
DO MCEPROC^MCARE
SET MCARGNUM=MCARGNAM
SET MCARGNAM="VENTRICAL LEAD IMPLANT"
GOTO LOOK
ALEAD SET MCFILE=698.2
+1 if $DATA(MULTI)
DO LAST^MCARPACE
+2 SET MCPRO="A-LEAD IMP"
DO MCEPROC^MCARE
SET MCARGNUM=MCARGNAM
SET MCARGNAM="ATRIAL LEAD IMPLANT"
GOTO LOOK
DEMO ;
+1 WRITE @IOF,!!!,"DEMOGRAPHIC INFORMATION *** SCREEN EDIT ***",!!!
+2 Begin DoDot:1
+3 NEW DLAYGO
+4 SET DLAYGO=690
SET DIC="^MCAR(690,"
SET DIC(0)="AEQLM"
SET DIC("B")=$GET(MCPATNM)
+5 DO ^DIC
+6 QUIT
End DoDot:1
+7 if Y<0
GOTO EXIT
+8 SET (DJDN,MCARGDA)=+Y
SET DJSC="MCPACEDEMO"
SET DIC(0)="EQ"
DO EN^MCARD
+9 ;get new default patient name
+10 SET MCX=$$VALUE^MCENDIQ1(690,MCARGDA,.01)
+11 IF MCX'=""
SET MCPATNM=MCX
+12 GOTO EXIT
LOOK ;
+1 WRITE @IOF,!!!,MCARGNAM," PROCEDURES *** SCREEN EDIT ***",!!!
+2 SET DIC="^MCAR("_MCFILE_","
SET DIC(0)="AEQLM"
+3 SET DIC("A")="Enter patient name, or date and time: "
+4 ;S DIC("B")=$G(MCPATNM)
+5 SET (DLAYGO,DIDEL)=MCFILE
DO ^DIC
if Y<0
GOTO EX
+6 ;
+7 ; NOTE: next line must define DFN for Order Entry to work
+8 SET MCARGDA=+Y
SET DFN=$PIECE($GET(^MCAR(MCFILE,MCARGDA,0)),U,2)
IF $DATA(DTOUT)
IF 'DFN
SET DIK=DIC
SET DA=MCARGDA
DO ^DIK
GOTO EX
+9 SET MCARGNUM=$ORDER(^MCAR(697.2,"BA",MCARGNAM,0))
+10 SET DJSC=MCEPROC
+11 SET MCARGNAM=$PIECE(^MCAR(697.2,MCARGNUM,0),U)
SET DJDN=MCARGDA
SET DIC(0)="EQ"
DO IN^MCEO
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
DO EN^MCARD
DO OUT^MCEO
+12 ;get new default patient name
+13 SET MCX=$$VALUE^MCENDIQ1(MCFILE,MCARGDA,1)
+14 IF MCX'=""
SET MCPATNM=MCX
EX if $DATA(MULTI)
QUIT
GOTO EXIT
SETUP ; If the record is superseded, the user will be allow to edit the superseded record.
+1 SET Y=MCY
SET DA=Y
SET Y(0)=MCY(0)
SET Y(0,0)=MCY(0,0)
SET MCARGDA=+MCY
KILL MCY,DTOUT,DIROUT,DUOUT,DIC
+2 GOTO SUPS
