- 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 Jan 18, 2025@03:13:58 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