MCARE ;WISC/RMP-EDIT ROUTINES ;1/23/03 20:45
;;2.3;Medicine;**35**;09/13/1996
; Reference IA #3746 for ^DD(file#,0,"ID") Access
; #10076 for ^XUSEC
; #10061 FOR ^VADPT call.
ENTER ;ENTER NEW CARDIAC PROCEDURES (SCREEN HANDLER)
;SELECT GLOBAL AND PROCEDURE NAME FROM PROCEDURE LOCATION FILE
D MCEPROC
S MCARGNUM=MCARP,DIC=^DIC(MCFILE,0,"GL")
S DJSC=MCEPROC,USEREND=1
S DIC(0)="AELMQZ",(DLAYGO,DIDEL)=+$P(DIC,"(",2)
S (MCARGNAM,MCARP)=$P(^MCAR(697.2,MCARP,0),U,1)
DATE ;SELECT PROCEDURE DATE
I MCESON S DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
;S DR=MCPATFLD
D DATE^MCAREH ; guidance for the date prompt
D ^DIC K DIC,DLAYGO
;CONDITIONAL ENTRY DELETE CODE HERE
I Y'=-1 D EXISTS ; an entry exists, so take an action
EXIT ;
D KVAR^VADPT
K X,Y,MCARP,DJSC,MCARPT,DIC,DJDN,DR,DIE,MCARGDA,MCARGNUM
K DLAYGO,MCARNUM,MCARNM,DFN,DIDEL,MCFILE,MCARDE,MCSEX,MCRACE,MCFILE
K %,%H,%X,%Y,%Y1,%Y2,D0,D1,D2,DI,DIW,DIWI,DIWT,DIWTC,DIWX,DIZ,DN,DQ
K I,J,VA,X1,Y,Z,DJVV,%T,DIPGM,DW1,DTOUT,DUOUT,MCESS,ID2
K DIC,DIK,DIE,DFN,DA,MCARGNUM,MCARGNAM,DR,MCX,SSN,MCARCODE,%,MCORCK
K C,MCARAPDT,CD,MCARCDIE,MCAROLDT,XX,DIH,DIR,S,DX,DIU,DIV,DZ,MCARFIND
K MCSPHIN,MCSTENT,MCBOUGIE,MCGTUBE,MCJTUBE,MCHEATP,MCDFLAG,MCARI
K MCARNP,MCARTOT,DIDEL,DTOUT,DUOUT,MCESFL,EXIT,MCBACK,MCESPREV
K MCESCUR,MCESTEMP,MCARCK,MCARDA,MCARDE,MCARP,MCESKEY,MCESON
K MCESPED,MCESS,MCESSEC,MCFILE,MCFILE1,MCPATFLD,MCPOSTP,MCROUT
K POP,MCPCT,MCPCTY,TEP,MCARDE,MCARP,MCESKEY,MCESON,MCESS
Q
EXISTS ;
S DFN=$P(Y(0),U,2) ; patient number
S (DJDN,MCARGDA)=$P(Y,U,1)
I MCFILE=700 S MCRACE=$$RACECDE^MCPFTSS(DFN) K:MCRACE="" MCRACE
I MCFILE=691.5,$D(^MCAR(MCFILE,MCARGDA,"A")) Q:'MCESON D ESRC^MCESSCR(MCFILE,.MCARGDA) G:$D(MCBACK) BACK Q
I MCESON,("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA)) D ESRC^MCESSCR(MCFILE,.MCARGDA) G:$D(MCBACK) BACK Q
; set certain variables based upon file selected
I MCFILE=691.8 S MCARZDN=DJDN
D IN^MCEO ; order entry
I '$D(DTOUT),'$D(DUOUT) D
.D EN^MCARD I '$D(^MCAR(MCFILE,MCARGDA,0)),$D(MCBACK) D BACKSS^MCESEDT K MCBACK
.I $L(MCPOSTP)>1 S X=MCPOSTP X ^%ZOSF("TEST") D:$T @MCPOSTP
.D OUT^MCEO K DIDEL
I MCFILE=691.8,$D(^MCAR(MCFILE,MCARGDA,0)) D EN4^MCARATVE ; atrial/ventricular studies
D ESRC^MCESSCR(MCFILE,MCARGDA)
I $L($G(MCRACE))>1 D
.I $$GET1^DIQ(700,+MCARGDA_",",38,"E")="YES"&($$GET1^DIQ(700,+MCARGDA,38.5,"E")="") D
..N MCFDA
..S MCFDA(700,+MCARGDA_",",38)=""
..D FILE^DIE("","MCFDA")
..W !!?5,"*** Patient has both race values BLACK and ASIAN. ***"
..W !?5,"*** MUST enter a value for the RACE CORRECTIONS FOR RACE TYPE field.***"
..W !?5,"*** USE RACE CORRECTIONS field will be set to NULL. ***"
..Q
.Q
Q
BACK ; 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) K MCY,DTOUT,DIROUT,DUOUT,DIC
G EXISTS
Q
HELP G EXIT:(X=U)!(X="") W !,"ENTER A NEW PROCEDURE DATE" G DATE
EDIT Q ; MFR 28 JAN 93 ;EDIT CARDIAC PROCEDURES BY PATIENT (SCREEN HANDLER)
;SEARCH FOR SELECTED PATIENT IN CARDIOLOGY FILE
S MCARGNUM=MCARP,MCARLK="^MCAR("_MCFILE
S MCARLK=U_MCARLK_",""C"",+Y)"
S DIC("S")="I $D(@(MCARLK))"
S DIC="^MCAR(690,",DIC(0)="AEQM" D ^DIC K MCARLK I Y<0 G EXIT
W !,MCARDE," PROCEDURES"
;SELECT PROCEDURE DATE
S (MCARPT,DFN)=+Y
D DEM^VADPT S MCARNM=VADM(1) D KVAR^VADPT
S DIC("W")="",DIC("S")="I $P(^(0),U,2)=+MCARPT",DIC=U_$P(^MCAR(697.2,MCARP,0),U,2)_",",D="C",DJSC=$S($G(MCBS)=1:$P(^MCAR(697.2,MCARP,0),U,13),1:$P(^(0),U,3)),(MCFILE,DIDEL)=+$P(DIC,"(",2)
S X=MCARNM,DIC(0)="EQ" D IX^DIC ;G EXIT:Y<0
K D,DIC("S"),DIC("W") I Y'=-1 S (DJDN,MCARGDA)=$P(Y,U,1) S:DIC[691.8 MCARZDN=DJDN D:DIC[691.5 ECGCH D IN^MCEO G EXIT:$D(DUOUT)!$D(DTOUT) D EN^MCARD,OUT^MCEO
G EXIT
ECGCH ;S:$D(^MCAR(691.5,DJDN,"A")) DJSC="MCARECGA" Q
CENTER(TEXT,MGN) ;
W $J("",MGN-$L(TEXT)/2),TEXT Q ""
;
MCEPROC ; Get the required variables from the PROCEDURE/SUBSPECIALTY file
N TEMP,OPTION,ID,ID2,ID3,ID4,ID5 S (ID,ID2)=""
;MCabPROC <=== name of an option, screen or line edit.
; a = (B => Brief), (F => Full)
; b = (S => Screen Edit), (L => Line Edit), (P => Printing)
; PROC = the name of the procedure
S (MCARGNUM,MCARGNAM,MCARP)=+$O(^MCAR(697.2,"B",MCPRO,""))
S OPTION=$E($P(XQY0,U,1),3,4),TEMP=$G(^MCAR(697.2,MCARP,0)),MCESS=0
S (MCROUT,MCARDE)=$P(TEMP,U,8),MCFILE=+$P($P(TEMP,U,2),"MCAR(",2)
S MCESON=+$P(TEMP,U,14),MCESKEY=$P(TEMP,U,15),MCPATFLD=$P(TEMP,U,12)
S:MCESON MCESSEC=$S($D(^XUSEC(MCESKEY,DUZ)):1,1:0)
S ID3=";"_$G(DIC("DR")),ID=""
F S ID=+$O(^DD(MCFILE,0,"ID",ID)) Q:ID=0 D:ID'=0
.S ID4=";"_ID,ID5=ID4_";",ID4=ID4_"/"
.I (ID3'[ID4),(ID3'[ID5) S ID2=ID2_ID_";"
S DIC("DR")=ID2_"1500////"_DUZ_";1502///NOW;1514///NOW;1502///NOW;"_$G(DIC("DR"))
S DIC(0)="AQMELZ",(DIDEL,DLAYGO)=MCFILE,DIC=^DIC(MCFILE,0,"GL")
I MCFILE=699 D
.S MCARCODE=$S(MCPRO["GI":"G",MCPRO["NONENDO":"Z",1:"P")
.S DIC("S")="I $D(^MCAR(697.2,""D"",MCARCODE,+$P(^MCAR(699,+Y,0),U,12)))"
S MCEPROC="MC"_OPTION_MCPRO
S MCEPROC=$S(OPTION="BS":$S($P(TEMP,U,13)'="":$P(TEMP,U,13),1:MCEPROC),OPTION="BL":$S($P(TEMP,U,11)'="":$P(TEMP,U,11),1:MCEPROC),OPTION="FS":$S($P(TEMP,U,3)'="":$P(TEMP,U,3),1:MCEPROC),1:$S($P(TEMP,U,10)'="":$P(TEMP,U,10),1:MCEPROC))
S MCPOSTP=$S((MCFILE=699)&(MCEPROC'["NONENDO"):"^MCARGD",1:"")
Q
MCPROP(MCPROP) ;
N TEMP,PREFIX,CNT
S PREFIX=$S($E(MCPROP,3,4)="ES":8,1:5)
F CNT=PREFIX:1:$L(MCPROP) Q:$D(^MCAR(697.2,"B",$E(MCPROP,5,CNT))) ;S TEMP=$E(MCPROP,5,CNT)
Q TEMP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARE 5539 printed Apr 09, 2024@21:19:34 Page 2
MCARE ;WISC/RMP-EDIT ROUTINES ;1/23/03 20:45
+1 ;;2.3;Medicine;**35**;09/13/1996
+2 ; Reference IA #3746 for ^DD(file#,0,"ID") Access
+3 ; #10076 for ^XUSEC
+4 ; #10061 FOR ^VADPT call.
ENTER ;ENTER NEW CARDIAC PROCEDURES (SCREEN HANDLER)
+1 ;SELECT GLOBAL AND PROCEDURE NAME FROM PROCEDURE LOCATION FILE
+2 DO MCEPROC
+3 SET MCARGNUM=MCARP
SET DIC=^DIC(MCFILE,0,"GL")
+4 SET DJSC=MCEPROC
SET USEREND=1
+5 SET DIC(0)="AELMQZ"
SET (DLAYGO,DIDEL)=+$PIECE(DIC,"(",2)
+6 SET (MCARGNAM,MCARP)=$PIECE(^MCAR(697.2,MCARP,0),U,1)
DATE ;SELECT PROCEDURE DATE
+1 IF MCESON
SET DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
+2 ;S DR=MCPATFLD
+3 ; guidance for the date prompt
DO DATE^MCAREH
+4 DO ^DIC
KILL DIC,DLAYGO
+5 ;CONDITIONAL ENTRY DELETE CODE HERE
+6 ; an entry exists, so take an action
IF Y'=-1
DO EXISTS
EXIT ;
+1 DO KVAR^VADPT
+2 KILL X,Y,MCARP,DJSC,MCARPT,DIC,DJDN,DR,DIE,MCARGDA,MCARGNUM
+3 KILL DLAYGO,MCARNUM,MCARNM,DFN,DIDEL,MCFILE,MCARDE,MCSEX,MCRACE,MCFILE
+4 KILL %,%H,%X,%Y,%Y1,%Y2,D0,D1,D2,DI,DIW,DIWI,DIWT,DIWTC,DIWX,DIZ,DN,DQ
+5 KILL I,J,VA,X1,Y,Z,DJVV,%T,DIPGM,DW1,DTOUT,DUOUT,MCESS,ID2
+6 KILL DIC,DIK,DIE,DFN,DA,MCARGNUM,MCARGNAM,DR,MCX,SSN,MCARCODE,%,MCORCK
+7 KILL C,MCARAPDT,CD,MCARCDIE,MCAROLDT,XX,DIH,DIR,S,DX,DIU,DIV,DZ,MCARFIND
+8 KILL MCSPHIN,MCSTENT,MCBOUGIE,MCGTUBE,MCJTUBE,MCHEATP,MCDFLAG,MCARI
+9 KILL MCARNP,MCARTOT,DIDEL,DTOUT,DUOUT,MCESFL,EXIT,MCBACK,MCESPREV
+10 KILL MCESCUR,MCESTEMP,MCARCK,MCARDA,MCARDE,MCARP,MCESKEY,MCESON
+11 KILL MCESPED,MCESS,MCESSEC,MCFILE,MCFILE1,MCPATFLD,MCPOSTP,MCROUT
+12 KILL POP,MCPCT,MCPCTY,TEP,MCARDE,MCARP,MCESKEY,MCESON,MCESS
+13 QUIT
EXISTS ;
+1 ; patient number
SET DFN=$PIECE(Y(0),U,2)
+2 SET (DJDN,MCARGDA)=$PIECE(Y,U,1)
+3 IF MCFILE=700
SET MCRACE=$$RACECDE^MCPFTSS(DFN)
if MCRACE=""
KILL MCRACE
+4 IF MCFILE=691.5
IF $DATA(^MCAR(MCFILE,MCARGDA,"A"))
if 'MCESON
QUIT
DO ESRC^MCESSCR(MCFILE,.MCARGDA)
if $DATA(MCBACK)
GOTO BACK
QUIT
+5 IF MCESON
IF ("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA))
DO ESRC^MCESSCR(MCFILE,.MCARGDA)
if $DATA(MCBACK)
GOTO BACK
QUIT
+6 ; set certain variables based upon file selected
+7 IF MCFILE=691.8
SET MCARZDN=DJDN
+8 ; order entry
DO IN^MCEO
+9 IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
Begin DoDot:1
+10 DO EN^MCARD
IF '$DATA(^MCAR(MCFILE,MCARGDA,0))
IF $DATA(MCBACK)
DO BACKSS^MCESEDT
KILL MCBACK
+11 IF $LENGTH(MCPOSTP)>1
SET X=MCPOSTP
XECUTE ^%ZOSF("TEST")
if $TEST
DO @MCPOSTP
+12 DO OUT^MCEO
KILL DIDEL
End DoDot:1
+13 ; atrial/ventricular studies
IF MCFILE=691.8
IF $DATA(^MCAR(MCFILE,MCARGDA,0))
DO EN4^MCARATVE
+14 DO ESRC^MCESSCR(MCFILE,MCARGDA)
+15 IF $LENGTH($GET(MCRACE))>1
Begin DoDot:1
+16 IF $$GET1^DIQ(700,+MCARGDA_",",38,"E")="YES"&($$GET1^DIQ(700,+MCARGDA,38.5,"E")="")
Begin DoDot:2
+17 NEW MCFDA
+18 SET MCFDA(700,+MCARGDA_",",38)=""
+19 DO FILE^DIE("","MCFDA")
+20 WRITE !!?5,"*** Patient has both race values BLACK and ASIAN. ***"
+21 WRITE !?5,"*** MUST enter a value for the RACE CORRECTIONS FOR RACE TYPE field.***"
+22 WRITE !?5,"*** USE RACE CORRECTIONS field will be set to NULL. ***"
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 QUIT
BACK ; 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)
KILL MCY,DTOUT,DIROUT,DUOUT,DIC
+2 GOTO EXISTS
+3 QUIT
HELP if (X=U)!(X="")
GOTO EXIT
WRITE !,"ENTER A NEW PROCEDURE DATE"
GOTO DATE
EDIT ; MFR 28 JAN 93 ;EDIT CARDIAC PROCEDURES BY PATIENT (SCREEN HANDLER)
QUIT
+1 ;SEARCH FOR SELECTED PATIENT IN CARDIOLOGY FILE
+2 SET MCARGNUM=MCARP
SET MCARLK="^MCAR("_MCFILE
+3 SET MCARLK=U_MCARLK_",""C"",+Y)"
+4 SET DIC("S")="I $D(@(MCARLK))"
+5 SET DIC="^MCAR(690,"
SET DIC(0)="AEQM"
DO ^DIC
KILL MCARLK
IF Y<0
GOTO EXIT
+6 WRITE !,MCARDE," PROCEDURES"
+7 ;SELECT PROCEDURE DATE
+8 SET (MCARPT,DFN)=+Y
+9 DO DEM^VADPT
SET MCARNM=VADM(1)
DO KVAR^VADPT
+10 SET DIC("W")=""
SET DIC("S")="I $P(^(0),U,2)=+MCARPT"
SET DIC=U_$PIECE(^MCAR(697.2,MCARP,0),U,2)_","
SET D="C"
SET DJSC=$SELECT($GET(MCBS)=1:$PIECE(^MCAR(697.2,MCARP,0),U,13),1:$PIECE(^(0),U,3))
SET (MCFILE,DIDEL)=+$PIECE(DIC,"(",2)
+11 ;G EXIT:Y<0
SET X=MCARNM
SET DIC(0)="EQ"
DO IX^DIC
+12 KILL D,DIC("S"),DIC("W")
IF Y'=-1
SET (DJDN,MCARGDA)=$PIECE(Y,U,1)
if DIC[691.8
SET MCARZDN=DJDN
if DIC[691.5
DO ECGCH
DO IN^MCEO
if $DATA(DUOUT)!$DATA(DTOUT)
GOTO EXIT
DO EN^MCARD
DO OUT^MCEO
+13 GOTO EXIT
ECGCH ;S:$D(^MCAR(691.5,DJDN,"A")) DJSC="MCARECGA" Q
CENTER(TEXT,MGN) ;
+1 WRITE $JUSTIFY("",MGN-$LENGTH(TEXT)/2),TEXT
QUIT ""
+2 ;
MCEPROC ; Get the required variables from the PROCEDURE/SUBSPECIALTY file
+1 NEW TEMP,OPTION,ID,ID2,ID3,ID4,ID5
SET (ID,ID2)=""
+2 ;MCabPROC <=== name of an option, screen or line edit.
+3 ; a = (B => Brief), (F => Full)
+4 ; b = (S => Screen Edit), (L => Line Edit), (P => Printing)
+5 ; PROC = the name of the procedure
+6 SET (MCARGNUM,MCARGNAM,MCARP)=+$ORDER(^MCAR(697.2,"B",MCPRO,""))
+7 SET OPTION=$EXTRACT($PIECE(XQY0,U,1),3,4)
SET TEMP=$GET(^MCAR(697.2,MCARP,0))
SET MCESS=0
+8 SET (MCROUT,MCARDE)=$PIECE(TEMP,U,8)
SET MCFILE=+$PIECE($PIECE(TEMP,U,2),"MCAR(",2)
+9 SET MCESON=+$PIECE(TEMP,U,14)
SET MCESKEY=$PIECE(TEMP,U,15)
SET MCPATFLD=$PIECE(TEMP,U,12)
+10 if MCESON
SET MCESSEC=$SELECT($DATA(^XUSEC(MCESKEY,DUZ)):1,1:0)
+11 SET ID3=";"_$GET(DIC("DR"))
SET ID=""
+12 FOR
SET ID=+$ORDER(^DD(MCFILE,0,"ID",ID))
if ID=0
QUIT
if ID'=0
Begin DoDot:1
+13 SET ID4=";"_ID
SET ID5=ID4_";"
SET ID4=ID4_"/"
+14 IF (ID3'[ID4)
IF (ID3'[ID5)
SET ID2=ID2_ID_";"
End DoDot:1
+15 SET DIC("DR")=ID2_"1500////"_DUZ_";1502///NOW;1514///NOW;1502///NOW;"_$GET(DIC("DR"))
+16 SET DIC(0)="AQMELZ"
SET (DIDEL,DLAYGO)=MCFILE
SET DIC=^DIC(MCFILE,0,"GL")
+17 IF MCFILE=699
Begin DoDot:1
+18 SET MCARCODE=$SELECT(MCPRO["GI":"G",MCPRO["NONENDO":"Z",1:"P")
+19 SET DIC("S")="I $D(^MCAR(697.2,""D"",MCARCODE,+$P(^MCAR(699,+Y,0),U,12)))"
End DoDot:1
+20 SET MCEPROC="MC"_OPTION_MCPRO
+21 SET MCEPROC=$SELECT(OPTION="BS":$SELECT($PIECE(TEMP,U,13)'="":$PIECE(TEMP,U,13),1:MCEPROC),OPTION="BL":...
... $SELECT($PIECE(TEMP,U,11)'="":$PIECE(TEMP,U,11),1:MCEPROC),OPTION="FS":$SELECT($PIECE(TEMP,U,3)'="":$PIECE(TEMP,U,3),1:MCEPROC),1:$SELECT($PIECE(TEMP,U,10)'="":$PIECE(TEMP,U,10),1:MCEPROC))
+22 SET MCPOSTP=$SELECT((MCFILE=699)&(MCEPROC'["NONENDO"):"^MCARGD",1:"")
+23 QUIT
MCPROP(MCPROP) ;
+1 NEW TEMP,PREFIX,CNT
+2 SET PREFIX=$SELECT($EXTRACT(MCPROP,3,4)="ES":8,1:5)
+3 ;S TEMP=$E(MCPROP,5,CNT)
FOR CNT=PREFIX:1:$LENGTH(MCPROP)
if $DATA(^MCAR(697.2,"B",$EXTRACT(MCPROP,5,CNT)))
QUIT
+4 QUIT TEMP
