MCARGE ;WISC/TJK-GI ENTER/EDIT ;5/8/96 14:29
;;2.3;Medicine;;09/13/1996
START ;EDIT ENDSCOPY
K EXIT,MCDEMO,MCESFL S MCESFL=1 D PREEDT
I '$D(MCFILE)!'$D(MCARGDA) D EXIT Q
I '$D(^MCAR(MCFILE,MCARGDA,0)),$D(MCBACK) D BACKSS^MCESEDT K MCBACK
K:'$D(^MCAR(MCFILE,MCARGDA,0)) MCESFL
I $D(MCESFL),MCESON D:MCESFL=0 ESRC^MCESSCR(MCFILE,MCARGDA)
D EXIT
Q
PREEDT ; Allow editing of demo and allergy
S MCDEMO=1 D DPT Q:$D(EXIT)
I MCARCODE="G"!(MCARCODE="P") F D DEMO Q:'$D(MCDEMO) D:$D(MCDEMO) EDITDEMO
Q:$D(EXIT) D EDIT
Q
EDIT ;Lets edit Endoscopy
K DR,DIC,DIE S (DIE,DIC)="^MCAR(699,",DA=MCARGDA,MCFILE=699
G EDIT1:MCARGNAM="NON-ENDO",EDIT1:MCARCODE'="G" D SETVAR
EDIT1 ; Lets edit Non-Endo
D IN^MCEO I $D(DTOUT)!$D(DUOUT) S EXIT=1 Q
S DR="["_MCEPROC_"]" D ^DIE
I $D(DA) D ^MCARGD,OUT^MCEO
Q
EXIT ;Lets leave
D EXIT^MCARE
Q
SETVAR ;Set Pulmonary variables
S MCSTENT=$O(^MCAR(699.6,"B","INSERTION OF STENT",0)),MCSPHIN=$O(^MCAR(699.6,"B","SPHINCTEROTOMY",0))
S MCBOUGIE=$O(^MCAR(699.6,"B","DILATION BY SAVARY BOUGIE",0)),MCGTUBE=$O(^MCAR(699.6,"B","GASTROSTOMY TUBE INSERTED",0)),MCJTUBE=$O(^MCAR(699.6,"B","JEJUNOSTOMY TUBE INSERTED",0))
S MCHEATP=$O(^MCAR(699.6,"B","HEATER PROBE COAGULATION",0))
Q
CONSULT K DIC S MCARGNUM=$O(^MCAR(697.2,"B","CONSULT",0)),DIC("DR")=".01;.02;2////1;.05////"_MCARGNUM
S DIC="^MCAR(699.5,",DLAYGO=699.5,DIC(0)="AEQLMZ",DIC("A")="ENTER DATE/TIME OF CONSULT: ",DIC("S")="I $P(^MCAR(699.5,+Y,0),U,3)" D ^DIC K DIC("S"),DIC("A"),DLAYGO I $D(MCDFLAG),Y<0 Q
G EXIT:Y<0
I '$P(Y(0),U,2)!'$P(Y(0),U,3) S DIK="^MCAR(699.5,",DA=+Y D ^DIK Q:$D(MCDFLAG) G EXIT
S DFN=$P(Y(0),U,2),DIE=DIC,(MCARGDA,DA)=+Y Q:$D(MCDFLAG)
S MCFILE=699.5 D ORDER^MCARGEO G EXIT:$D(DTOUT)!$D(DUOUT) S DR=$S($G(MCBS)=1:"[MCCONSULTBR]",1:"[MCCONSULT]") D ^DIE,ORDER1^MCARGEO,QTASK^MCPARAM G EXIT
DPT ;ALSO CALLED FROM MCARGES
S MCESFL=0 D MCEPROC^MCARE S MCARGNUM=MCARP
D DATE^MCAREH
S DIC="^MCAR(699,",DIC("A")="Enter Date/Time of Procedure: ",DIC(0)="AEQLMZ"
S DIC("S")="S MCARCK=$P(^MCAR(699,+Y,0),U,12) I MCARCK'="""",$D(^MCAR(697.2,""D"",MCARCODE,MCARCK))",(DLAYGO,MCFILE)=699
I MCESON S DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
D ^DIC K DIC,DLAYGO,MCBACK S MCARDA=Y
I Y<0 S EXIT=0 Q
S DFN=$P(Y(0),U,2),MCARGDA=+Y,MCARGNUM=$P(Y(0),U,12),MCARGNAM=$P(^MCAR(697.2,MCARGNUM,0),U)
I MCESON,("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA)) D ESRC^MCESSCR(MCFILE,MCARGDA) I '$D(MCBACK) S X=U,MCESFL=1,EXIT=1 Q ;RMP CHANGED () EXPRESSION FROM >2
I $D(MCBACK) D BACK S X=U Q
I $D(DTOUT),('$P(Y(0),U,2)!'$P(Y(0),U,12)) S DIK="^MCAR(699,",DA=+Y D ^DIK S EXIT=1 Q
Q
DEMO ;Lets display the demo information ask if they want to edit
; -------------------
; SSN = External Format of the patients SSN
; -------------------
D DEM^VADPT S SSN=$P(VADM(2),U,2) D HIST Q
HIST ;Lets look at the history
W !!,?26,"PERSONAL HISTORY INFORMATION",!,?5,VADM(1),?50,"SSN: ",SSN,!
S DIC="^MCAR(690,",DA=DFN G HIST1:MCARCODE="P"
S DR="GI" D EN^DIQ K DIC,DR G HIST2
HIST1 ;Lets look at some more history
K ^UTILITY("DIQ1",$J) S DIC="^MCAR(690,",DA=DFN,DR="3:6" D EN^DIQ1 G HIST2:'$D(^UTILITY("DIQ1",$J))
W !,?2,"History of Bleeding Disorder: ",^UTILITY("DIQ1",$J,690,DA,3),?40,"Valvular Heart Disease: ",^(4),!,?2,"Glaucoma: ",^(5),!,?2,"History Comments: ",^(6) K ^UTILITY("DIQ1",$J) W !
HIST2 ;Lets display allergy and ask the question
D ^MCARGEA ; display allergy information
S DIR(0)="Y",DIR("A")="Do you wish to edit the Personal History Information"
S DIR("?")="Answer 'YES' or 'NO'",DIR("B")="NO" D ^DIR K DIR
I $D(DUOUT)!$D(DIROUT) S EXIT=1 K MCDEMO Q
K:Y=0 MCDEMO Q
EDITDEMO ;lets edit the demo and allergy using the line editor
S (DIE,DIC)="^MCAR(690,",DA=DFN,DR="[MCARGIED]" D ^DIE
I $D(^DIC(120.8)) N VADM D EN2^GMRAPEM0 Q
G HIST
;
HELP ;DISPLAY CHOOSABLE ANATOMY LOCATIONS-CALLED BY FINDINGS,ATRIAL STUDY,VENTRICULAR STUDY FILES
S (DZ,MCDONE)="" W !!,"The valid Anatomy locations are: ",!
F I=0:0 S I=$O(^MCAR(697,"C",MCARGNUM,I)) Q:'I W:$X>50 ! W $E($P(^MCAR(697,I,0),U)_" ",1,40) I $D(DJDN),$Y>20,$X>50 W ! R "'^' TO STOP: ",%Y:DTIME X:%Y'?1"^" DJCP Q:%Y?1"^"
R:$D(DJDN) !,"* END * Press return to continue: ",%Y:DTIME Q
DPTNON ;
S DIC="^MCAR(699,",DIC("A")="Enter Date/Time of Non-Endoscopic Procedure: ",DIC(0)="AEQLMZ"
S DIC("S")="I $P($G(^MCAR(697.2,+$P(^MCAR(699,+Y,0),U,12),0)),U)=""NON-ENDO"""_MCTEST,DLAYGO=699
S DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
S DIC("DR")=".02;1///NON-ENDO"
D ^DIC
K DIC,DLAYGO
I $D(MCDFLAG),Y<0 S X=U Q
G EXIT:Y<0
I $D(DTOUT),('$P(Y(0),U,2)!'$P(Y(0),U,12)) S DIK="^MCAR(699,",DA=+Y D ^DIK Q:$D(MCDFLG) G EXIT
S DFN=$P(Y(0),U,2),MCARGDA=+Y,MCARGNUM=$P(Y(0),U,12),MCARGNAM=$P(^MCAR(697.2,MCARGNUM,0),U)
; -------------------
; SSN = External Format of the patients SSN
; -------------------
D DEM^VADPT S SSN=$P(VADM(2),U,2)
G HIST
BACK ;
S Y=MCY,Y(0)=MCY(0),Y(0,0)=MCY(0,0),MCARGDA=+Y K EXIT,MCY,DTOUT,DIROUT,DUOUT,MCDFLAG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARGE 5045 printed Apr 09, 2024@21:14:58 Page 2
MCARGE ;WISC/TJK-GI ENTER/EDIT ;5/8/96 14:29
+1 ;;2.3;Medicine;;09/13/1996
START ;EDIT ENDSCOPY
+1 KILL EXIT,MCDEMO,MCESFL
SET MCESFL=1
DO PREEDT
+2 IF '$DATA(MCFILE)!'$DATA(MCARGDA)
DO EXIT
QUIT
+3 IF '$DATA(^MCAR(MCFILE,MCARGDA,0))
IF $DATA(MCBACK)
DO BACKSS^MCESEDT
KILL MCBACK
+4 if '$DATA(^MCAR(MCFILE,MCARGDA,0))
KILL MCESFL
+5 IF $DATA(MCESFL)
IF MCESON
if MCESFL=0
DO ESRC^MCESSCR(MCFILE,MCARGDA)
+6 DO EXIT
+7 QUIT
PREEDT ; Allow editing of demo and allergy
+1 SET MCDEMO=1
DO DPT
if $DATA(EXIT)
QUIT
+2 IF MCARCODE="G"!(MCARCODE="P")
FOR
DO DEMO
if '$DATA(MCDEMO)
QUIT
if $DATA(MCDEMO)
DO EDITDEMO
+3 if $DATA(EXIT)
QUIT
DO EDIT
+4 QUIT
EDIT ;Lets edit Endoscopy
+1 KILL DR,DIC,DIE
SET (DIE,DIC)="^MCAR(699,"
SET DA=MCARGDA
SET MCFILE=699
+2 if MCARGNAM="NON-ENDO"
GOTO EDIT1
if MCARCODE'="G"
GOTO EDIT1
DO SETVAR
EDIT1 ; Lets edit Non-Endo
+1 DO IN^MCEO
IF $DATA(DTOUT)!$DATA(DUOUT)
SET EXIT=1
QUIT
+2 SET DR="["_MCEPROC_"]"
DO ^DIE
+3 IF $DATA(DA)
DO ^MCARGD
DO OUT^MCEO
+4 QUIT
EXIT ;Lets leave
+1 DO EXIT^MCARE
+2 QUIT
SETVAR ;Set Pulmonary variables
+1 SET MCSTENT=$ORDER(^MCAR(699.6,"B","INSERTION OF STENT",0))
SET MCSPHIN=$ORDER(^MCAR(699.6,"B","SPHINCTEROTOMY",0))
+2 SET MCBOUGIE=$ORDER(^MCAR(699.6,"B","DILATION BY SAVARY BOUGIE",0))
SET MCGTUBE=$ORDER(^MCAR(699.6,"B","GASTROSTOMY TUBE INSERTED",0))
SET MCJTUBE=$ORDER(^MCAR(699.6,"B","JEJUNOSTOMY TUBE INSERTED",0))
+3 SET MCHEATP=$ORDER(^MCAR(699.6,"B","HEATER PROBE COAGULATION",0))
+4 QUIT
CONSULT KILL DIC
SET MCARGNUM=$ORDER(^MCAR(697.2,"B","CONSULT",0))
SET DIC("DR")=".01;.02;2////1;.05////"_MCARGNUM
+1 SET DIC="^MCAR(699.5,"
SET DLAYGO=699.5
SET DIC(0)="AEQLMZ"
SET DIC("A")="ENTER DATE/TIME OF CONSULT: "
SET DIC("S")="I $P(^MCAR(699.5,+Y,0),U,3)"
DO ^DIC
KILL DIC("S"),DIC("A"),DLAYGO
IF $DATA(MCDFLAG)
IF Y<0
QUIT
+2 if Y<0
GOTO EXIT
+3 IF '$PIECE(Y(0),U,2)!'$PIECE(Y(0),U,3)
SET DIK="^MCAR(699.5,"
SET DA=+Y
DO ^DIK
if $DATA(MCDFLAG)
QUIT
GOTO EXIT
+4 SET DFN=$PIECE(Y(0),U,2)
SET DIE=DIC
SET (MCARGDA,DA)=+Y
if $DATA(MCDFLAG)
QUIT
+5 SET MCFILE=699.5
DO ORDER^MCARGEO
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
SET DR=$SELECT($GET(MCBS)=1:"[MCCONSULTBR]",1:"[MCCONSULT]")
DO ^DIE
DO ORDER1^MCARGEO
DO QTASK^MCPARAM
GOTO EXIT
DPT ;ALSO CALLED FROM MCARGES
+1 SET MCESFL=0
DO MCEPROC^MCARE
SET MCARGNUM=MCARP
+2 DO DATE^MCAREH
+3 SET DIC="^MCAR(699,"
SET DIC("A")="Enter Date/Time of Procedure: "
SET DIC(0)="AEQLMZ"
+4 SET DIC("S")="S MCARCK=$P(^MCAR(699,+Y,0),U,12) I MCARCK'="""",$D(^MCAR(697.2,""D"",MCARCODE,MCARCK))"
SET (DLAYGO,MCFILE)=699
+5 IF MCESON
SET DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
+6 DO ^DIC
KILL DIC,DLAYGO,MCBACK
SET MCARDA=Y
+7 IF Y<0
SET EXIT=0
QUIT
+8 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)
+9 ;RMP CHANGED () EXPRESSION FROM >2
IF MCESON
IF ("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA))
DO ESRC^MCESSCR(MCFILE,MCARGDA)
IF '$DATA(MCBACK)
SET X=U
SET MCESFL=1
SET EXIT=1
QUIT
+10 IF $DATA(MCBACK)
DO BACK
SET X=U
QUIT
+11 IF $DATA(DTOUT)
IF ('$PIECE(Y(0),U,2)!'$PIECE(Y(0),U,12))
SET DIK="^MCAR(699,"
SET DA=+Y
DO ^DIK
SET EXIT=1
QUIT
+12 QUIT
DEMO ;Lets display the demo information ask if they want to edit
+1 ; -------------------
+2 ; SSN = External Format of the patients SSN
+3 ; -------------------
+4 DO DEM^VADPT
SET SSN=$PIECE(VADM(2),U,2)
DO HIST
QUIT
HIST ;Lets look at the history
+1 WRITE !!,?26,"PERSONAL HISTORY INFORMATION",!,?5,VADM(1),?50,"SSN: ",SSN,!
+2 SET DIC="^MCAR(690,"
SET DA=DFN
if MCARCODE="P"
GOTO HIST1
+3 SET DR="GI"
DO EN^DIQ
KILL DIC,DR
GOTO HIST2
HIST1 ;Lets look at some more history
+1 KILL ^UTILITY("DIQ1",$JOB)
SET DIC="^MCAR(690,"
SET DA=DFN
SET DR="3:6"
DO EN^DIQ1
if '$DATA(^UTILITY("DIQ1",$JOB))
GOTO HIST2
+2 WRITE !,?2,"History of Bleeding Disorder: ",^UTILITY("DIQ1",$JOB,690,DA,3),?40,"Valvular Heart Disease: ",^(4),!,?2,"Glaucoma: ",^(5),!,?2,"History Comments: ",^(6)
KILL ^UTILITY("DIQ1",$JOB)
WRITE !
HIST2 ;Lets display allergy and ask the question
+1 ; display allergy information
DO ^MCARGEA
+2 SET DIR(0)="Y"
SET DIR("A")="Do you wish to edit the Personal History Information"
+3 SET DIR("?")="Answer 'YES' or 'NO'"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+4 IF $DATA(DUOUT)!$DATA(DIROUT)
SET EXIT=1
KILL MCDEMO
QUIT
+5 if Y=0
KILL MCDEMO
QUIT
EDITDEMO ;lets edit the demo and allergy using the line editor
+1 SET (DIE,DIC)="^MCAR(690,"
SET DA=DFN
SET DR="[MCARGIED]"
DO ^DIE
+2 IF $DATA(^DIC(120.8))
NEW VADM
DO EN2^GMRAPEM0
QUIT
+3 GOTO HIST
+4 ;
HELP ;DISPLAY CHOOSABLE ANATOMY LOCATIONS-CALLED BY FINDINGS,ATRIAL STUDY,VENTRICULAR STUDY FILES
+1 SET (DZ,MCDONE)=""
WRITE !!,"The valid Anatomy locations are: ",!
+2 FOR I=0:0
SET I=$ORDER(^MCAR(697,"C",MCARGNUM,I))
if 'I
QUIT
if $X>50
WRITE !
WRITE $EXTRACT($PIECE(^MCAR(697,I,0),U)_" ",1,40)
IF $DATA(DJDN)
IF $Y>20
IF $X>50
WRITE !
READ "'^' TO STOP: ",%Y:DTIME
if %Y'?1"^"
XECUTE DJCP
if %Y?1"^"
QUIT
+3 if $DATA(DJDN)
READ !,"* END * Press return to continue: ",%Y:DTIME
QUIT
DPTNON ;
+1 SET DIC="^MCAR(699,"
SET DIC("A")="Enter Date/Time of Non-Endoscopic Procedure: "
SET DIC(0)="AEQLMZ"
+2 SET DIC("S")="I $P($G(^MCAR(697.2,+$P(^MCAR(699,+Y,0),U,12),0)),U)=""NON-ENDO"""_MCTEST
SET DLAYGO=699
+3 SET DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
+4 Press return to continue: SET DIC("DR")=".02;1///NON-ENDO"
+5 DO ^DIC
+6 KILL DIC,DLAYGO
+7 IF $DATA(MCDFLAG)
IF Y<0
SET X=U
QUIT
+8 if Y<0
GOTO EXIT
+9 IF $DATA(DTOUT)
IF ('$PIECE(Y(0),U,2)!'$PIECE(Y(0),U,12))
SET DIK="^MCAR(699,"
SET DA=+Y
DO ^DIK
if $DATA(MCDFLG)
QUIT
GOTO EXIT
+10 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)
+11 ; -------------------
+12 ; SSN = External Format of the patients SSN
+13 ; -------------------
+14 DO DEM^VADPT
SET SSN=$PIECE(VADM(2),U,2)
+15 GOTO HIST
BACK ;
+1 SET Y=MCY
SET Y(0)=MCY(0)
SET Y(0,0)=MCY(0,0)
SET MCARGDA=+Y
KILL EXIT,MCY,DTOUT,DIROUT,DUOUT,MCDFLAG
+2 QUIT
