MCRH1 ;WISC/HAG-RHEUMATOLOGY PATIENT HISTORY EDIT ;7/3/96 09:13
;;2.3;Medicine;**31,35**;09/13/1996
; Reference IA #10061 VADPT calls
; IA # 681 Get Lab data
; IA #10035 PATIENT file (#2)
CONS S MCARCODE="Z" D CONSULT^MCARGE G EXIT
CONSS S MCARCODE="Z" D CONSULT^MCARGES G EXIT
CONSP D CONSULT^MCARGP G EXIT
MCRHMED S MCARCODE="R" D EN1^MCARSUP G EXIT
ALLP S MCRHLP="P",MCRH=0 G SEL
DIAGP S MCRHLP="P",MCRH=1 G SEL
BACKP S MCRHLP="P",MCRH=2 G SEL
NARRP S MCRHLP="P",MCRH=3 G SEL
LABP S MCRHLP="P",MCRH=4 G SEL
HAQP S MCRHLP="P",MCRH=6 G SEL
HISTP S MCRHLP="P",MCRH=7 G SEL
PHYSP S MCRHLP="P",MCRH=8 G SEL
DEATHP S MCRHLP="P",MCRH=9 G SEL
DIAGL S MCRHLP="L",MCRH=1 G SEL
NARRL S MCRHLP="L",MCRH=3 G SEL
HAQL S MCRHLP="L",MCRH=6 G SEL
HISTL S MCRHLP="L",MCRH=7 G SEL
PHYSL S MCRHLP="L",MCRH=8 G SEL
DEATHL S MCRHLP="L",MCRH=9 G SEL
BRIEFL S MCRHLP="L",MCRH=10 G SEL
DIAGF S MCRH=1 G SEL
BACKF S MCRH=2 G SEL
NARRF S MCRH=3 G SEL
TRETF S MCRH=5 G SEL
LABF S MCRH=4 G SEL
HAQF S MCRH=6 G SEL
HISTF S MCRH=7 G SEL
PHYSF S MCRH=8 G SEL
DEATHF S MCRH=9 G SEL
BRIEFF S MCRH=10
SEL ; Visit Date Selection
N MCRHB
S MCFILE=701,MCPRO="RHEUM"
S DIC("A")="Select prior visit by entering the patient name or visit date"_$S(MCRH=2:" or enter the date@time for a new visit: ",1:": ")
PRT I $D(MCRHLP),(MCRHLP="P"),(MCRH'=4) D RHFULL^MCARP G EXIT
S DIC="^MCAR(701,",DIC(0)=$S(MCRH=2:"AELQMZ",1:"AEQMZ") S:MCRH=2 DLAYGO=701 D ^DIC K DLAYGO G:Y<0 EXIT S (DJDN,DA,MCARGDA)=+Y,DFN=$P(Y(0),U,2),MC0=Y(0) D DEM^VADPT S MCSEX=$P(VADM(5),U),Y(0)=MC0 K MC0
I MCRH=2 N MCARR1,MCARRC,MCHOLD S (MCARRC,MCHOLD)=$P(VADM(8),U,2),MCARRC=$$ETHN^MCPFTP1(MCHOLD,.VADM) D GETDATA
I MCRH=5 S Y=$P(Y(0),U,2),PSOPAR="" D DOIT^MCPSOP G SEL
I MCRH=4 S DJDIS=1,MCLRDFN=$G(^DPT($P(Y(0),U,2),"LR")) W:MCLRDFN="" !!,*7,*27,*91,*49,*109," Patient laboratory information has not been processed!",*27,*91,*109 G:MCLRDFN="" SEL D GETLAB G:Y<0 SEL I '$D(MCRHLP) D HOME^%ZIS,QSTART G EXIT
I MCRH=4,$D(MCRHLP),(MCRHLP="P") D QUE G EXIT
LIN I $D(MCRHLP),(MCRHLP="L") S V=MCRH,DIE="^MCAR(701," S DR=$S($G(MCBL)=1:"[MCRHBRIEF]",1:"[MCRH"_$S(V=1:"DIAG",V=3:"NARR",V=6:"HAQ",V=7:"HIST",V=9:"DEATH",1:"PHYS")) K V D ORDERA G EXIT:$D(DTOUT)!$D(DUOUT) D ^DIE,ORDER1,QTASK^MCPARAM G SEL
FUL S:MCRH=2 DJDN=$P(^MCAR(701,DA,0),U,2),DJDIS=1 S V=MCRH,(MCRHB,DJSC)=$S($G(MCBS)=1:"MCRHBRSCREEN",1:"MCRH"_$S(V=1:"DIAG",V=2:"BACK",V=3:"NARR",V=4:"LAB010",V=6:"HAQ",V=7:"HIST",V=9:"DEATH",1:"PHYS"))
I MCRH=2&(MCRHB="MCRHBACK") D ORDERA G EXIT:$D(DTOUT)!$D(DUOUT) D ^MCRH3,ORDER1,QTASK^MCPARAM G SEL
D ORDERA G EXIT:$D(DTOUT)!$D(DUOUT) K V D EN^MCARD,ORDER1,QTASK^MCPARAM G SEL
DEL ;DELETE RHEUMATOLOGY VISIT
S DIC("A")="Select a prior visit by entering the patient's name or visit date: "
W !! S DIC="^MCAR(701,",DIC(0)="AEQM"
;S:MCESON DIC("S")="I $$SCRDEL^MCESSCR(MCFILE,Y)"
D ^DIC G:Y<0 EXIT S (MCRH1,DA)=+Y
DISP W !!,"Would you like a display of the data for this visit" S %=1 D YN^DICN G DISP:%=0,USURE:%=2 I %<0 G DEL
S (DJDN,DA)=MCRH1,DJSC="MCRHHIST",DJDIS=1 D EN^MCARD
USURE W !!,"Are you sure you want to delete this entry" S %=2 D YN^DICN G DEL:%=0 I %'=1 W !,"Nothing Deleted" G DEL
S (DIK,DIC)="^MCAR(701,",DA=MCRH1 D ^DIK W !!,"Entry deleted." R X:2 G DEL
GETLAB ;
S DIC("B")=$O(^LR(MCLRDFN,"CH",0))
S DIC="^LR(MCLRDFN,""CH"",",DIC(0)="AEQMZ",DIC("A")="Select DATE/TIME SPECIMEN TAKEN: " D ^DIC S:Y>0 (DJDN,MCLRDA)=+Y,MCARGDT=$P(Y,U,2),MCLABDT=9999999-MCARGDT S DA(1)=MCLRDFN K DIC("A") Q
QUE K IO("Q") S %ZIS="MQ" D ^%ZIS G:POP EXIT
I $D(IO("Q")) S MCARZ="RHEUMATOLOGY REPORT",(ZTSAVE("MC*"),ZTSAVE("DFN"),ZTSAVE("DA"),ZTSAVE("DT"))="",ZTRTN="QSTART^MCRH1",ZTDESC=MCARZ D ^%ZTLOAD K ZTSK Q
QSTART K ^UTILITY("DIQ1",$J) S PG=0,DIC="^LR(MCLRDFN,""CH"",",DA=MCLRDA
S DR="2:7;9:20;41;45;63;96;174;384;386;387;395:399;428;430;431;454;468;469;547:549;553;561;563;581;587;594;595;625;627;631;639;649;690;691;693;694;700;703;738;741;748;771;750"
S Y=MCLRDA,DA(1)=MCLRDFN,DA(63.04)=MCLABDT D EN^DIQ1
S MCARGRTN="RHFULL1" U IO D RHPRT^MCARP D ^%ZISC Q
LOCK ;LOCK GLOBAL THAT IS BEING ACCESSED BY ANOTHER USER
;L @(DIC_DA_"):1") S MCRHL=$T Q:MCRHL'=0 I MCRHL=0 W !!,*7,"THIS ENTRY IS BEING EDITED BY ANOTHER USER. TRY LATER." Q
EXIT D KVAR^VADPT K %,DA,DFN,DIC,DIE,DIK,DJDIS,DJDN,DJSC,DR,DT1,H,I,K,K1
K MCFILE,MCARCODE,MCARGDT,MCARGRTN,MCARZ,MCRH1,MCRH,MCRHL,MCLABDT,MCLRDFN,MCRHLP,MCRHY,PG,POP,PSOPAR,STA,V,X,X1,Z,ZTDESC,ZTRTN,ZTSAVE,MCARGNUM,MCARGDA,MCSEX Q
ORDERA S MCARGNUM=$O(^MCAR(697.2,"C","MCAR(701",0))
ORDER D:'$D(MCOEON) ORDER^MCPARAM Q:'$D(MCOEON)
Q
ORDER1 G IM:'$D(MCOEON) Q:'$D(^MCAR(MCFILE,MCARGDA)) Q:$D(DTOUT)
IM Q:MCRH'=1 D EN1^MCMAG Q
GETDATA ; Get Patient Demographic data
N MCARR2
S MCARR1(1)=$G(VADM(1))
S MCARR1(2)=$P($G(VADM(2)),"^",2)
S MCARR1(9)=$P($G(VADM(3)),"^",2)
S MCARR1(10)=$P($G(VADM(5)),"^",2),MCARR1(11)=$G(MCARRC)
S MCARR1(12)=$P($G(VADM(10)),"^",2)
D GETS^DIQ(2,DFN_",",".07;.111;.112;.115;.116;.131;.132;.31115","E","MCARR2")
S MCARR1(3)=$G(MCARR2(2,DFN_",",.111,"E"))
S MCARR1(4)=$G(MCARR2(2,DFN_",",.112,"E"))
S MCARR1(5)=$G(MCARR2(2,DFN_",",.115,"E"))
S MCARR1(6)=$G(MCARR2(2,DFN_",",.116,"E"))
S MCARR1(7)=$G(MCARR2(2,DFN_",",.131,"E"))
S MCARR1(8)=$G(MCARR2(2,DFN_",",.132,"E"))
S MCARR1(13)=$G(MCARR2(2,DFN_",",.31115,"E"))
S MCARR1(14)=$G(MCARR2(2,DFN_",",.07,"E"))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCRH1 5411 printed Sep 23, 2025@19:53:08 Page 2
MCRH1 ;WISC/HAG-RHEUMATOLOGY PATIENT HISTORY EDIT ;7/3/96 09:13
+1 ;;2.3;Medicine;**31,35**;09/13/1996
+2 ; Reference IA #10061 VADPT calls
+3 ; IA # 681 Get Lab data
+4 ; IA #10035 PATIENT file (#2)
CONS SET MCARCODE="Z"
DO CONSULT^MCARGE
GOTO EXIT
CONSS SET MCARCODE="Z"
DO CONSULT^MCARGES
GOTO EXIT
CONSP DO CONSULT^MCARGP
GOTO EXIT
MCRHMED SET MCARCODE="R"
DO EN1^MCARSUP
GOTO EXIT
ALLP SET MCRHLP="P"
SET MCRH=0
GOTO SEL
DIAGP SET MCRHLP="P"
SET MCRH=1
GOTO SEL
BACKP SET MCRHLP="P"
SET MCRH=2
GOTO SEL
NARRP SET MCRHLP="P"
SET MCRH=3
GOTO SEL
LABP SET MCRHLP="P"
SET MCRH=4
GOTO SEL
HAQP SET MCRHLP="P"
SET MCRH=6
GOTO SEL
HISTP SET MCRHLP="P"
SET MCRH=7
GOTO SEL
PHYSP SET MCRHLP="P"
SET MCRH=8
GOTO SEL
DEATHP SET MCRHLP="P"
SET MCRH=9
GOTO SEL
DIAGL SET MCRHLP="L"
SET MCRH=1
GOTO SEL
NARRL SET MCRHLP="L"
SET MCRH=3
GOTO SEL
HAQL SET MCRHLP="L"
SET MCRH=6
GOTO SEL
HISTL SET MCRHLP="L"
SET MCRH=7
GOTO SEL
PHYSL SET MCRHLP="L"
SET MCRH=8
GOTO SEL
DEATHL SET MCRHLP="L"
SET MCRH=9
GOTO SEL
BRIEFL SET MCRHLP="L"
SET MCRH=10
GOTO SEL
DIAGF SET MCRH=1
GOTO SEL
BACKF SET MCRH=2
GOTO SEL
NARRF SET MCRH=3
GOTO SEL
TRETF SET MCRH=5
GOTO SEL
LABF SET MCRH=4
GOTO SEL
HAQF SET MCRH=6
GOTO SEL
HISTF SET MCRH=7
GOTO SEL
PHYSF SET MCRH=8
GOTO SEL
DEATHF SET MCRH=9
GOTO SEL
BRIEFF SET MCRH=10
SEL ; Visit Date Selection
+1 NEW MCRHB
+2 SET MCFILE=701
SET MCPRO="RHEUM"
+3 SET DIC("A")="Select prior visit by entering the patient name or visit date"_$SELECT(MCRH=2:" or enter the date@time for a new visit: ",1:": ")
PRT IF $DATA(MCRHLP)
IF (MCRHLP="P")
IF (MCRH'=4)
DO RHFULL^MCARP
GOTO EXIT
+1 SET DIC="^MCAR(701,"
SET DIC(0)=$SELECT(MCRH=2:"AELQMZ",1:"AEQMZ")
if MCRH=2
SET DLAYGO=701
DO ^DIC
KILL DLAYGO
if Y<0
GOTO EXIT
SET (DJDN,DA,MCARGDA)=+Y
SET DFN=$PIECE(Y(0),U,2)
SET MC0=Y(0)
DO DEM^VADPT
SET MCSEX=$PIECE(VADM(5),U)
SET Y(0)=MC0
KILL MC0
+2 IF MCRH=2
NEW MCARR1,MCARRC,MCHOLD
SET (MCARRC,MCHOLD)=$PIECE(VADM(8),U,2)
SET MCARRC=$$ETHN^MCPFTP1(MCHOLD,.VADM)
DO GETDATA
+3 IF MCRH=5
SET Y=$PIECE(Y(0),U,2)
SET PSOPAR=""
DO DOIT^MCPSOP
GOTO SEL
+4 IF MCRH=4
SET DJDIS=1
SET MCLRDFN=$GET(^DPT($PIECE(Y(0),U,2),"LR"))
if MCLRDFN=""
WRITE !!,*7,*27,*91,*49,*109," Patient laboratory information has not been processed!",*27,*91,*109
if MCLRDFN=""
GOTO SEL
DO GETLAB
if Y<0
GOTO SEL
IF '$DATA(MCRHLP)
DO HOME^%ZIS
DO QSTART
GOTO EXIT
+5 IF MCRH=4
IF $DATA(MCRHLP)
IF (MCRHLP="P")
DO QUE
GOTO EXIT
LIN IF $DATA(MCRHLP)
IF (MCRHLP="L")
SET V=MCRH
SET DIE="^MCAR(701,"
SET DR=$SELECT($GET(MCBL)=1:"[MCRHBRIEF]",1:"[MCRH"_$SELECT(V=1:"DIAG",V=3:"NARR",V=6:"HAQ",V=7:"HIST",V=9:"DEATH",1:"PHYS"))
KILL V
DO ORDERA
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
DO ^DIE
DO ORDER1
DO QTASK^MCPARAM
GOTO SEL
FUL if MCRH=2
SET DJDN=$PIECE(^MCAR(701,DA,0),U,2)
SET DJDIS=1
SET V=MCRH
SET (MCRHB,DJSC)=$SELECT($GET(MCBS)=1:"MCRHBRSCREEN",1:"MCRH"_$SELECT(V=1:"DIAG",V=2:"BACK",V=3:"NARR",V=4:"LAB010",V=6:"HAQ",V=7:"HIST",V=9:"DEATH",1:"PHYS"))
+1 IF MCRH=2&(MCRHB="MCRHBACK")
DO ORDERA
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
DO ^MCRH3
DO ORDER1
DO QTASK^MCPARAM
GOTO SEL
+2 DO ORDERA
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
KILL V
DO EN^MCARD
DO ORDER1
DO QTASK^MCPARAM
GOTO SEL
DEL ;DELETE RHEUMATOLOGY VISIT
+1 SET DIC("A")="Select a prior visit by entering the patient's name or visit date: "
+2 WRITE !!
SET DIC="^MCAR(701,"
SET DIC(0)="AEQM"
+3 ;S:MCESON DIC("S")="I $$SCRDEL^MCESSCR(MCFILE,Y)"
+4 DO ^DIC
if Y<0
GOTO EXIT
SET (MCRH1,DA)=+Y
DISP WRITE !!,"Would you like a display of the data for this visit"
SET %=1
DO YN^DICN
if %=0
GOTO DISP
if %=2
GOTO USURE
IF %<0
GOTO DEL
+1 SET (DJDN,DA)=MCRH1
SET DJSC="MCRHHIST"
SET DJDIS=1
DO EN^MCARD
USURE WRITE !!,"Are you sure you want to delete this entry"
SET %=2
DO YN^DICN
if %=0
GOTO DEL
IF %'=1
WRITE !,"Nothing Deleted"
GOTO DEL
+1 SET (DIK,DIC)="^MCAR(701,"
SET DA=MCRH1
DO ^DIK
WRITE !!,"Entry deleted."
READ X:2
GOTO DEL
GETLAB ;
+1 SET DIC("B")=$ORDER(^LR(MCLRDFN,"CH",0))
+2 SET DIC="^LR(MCLRDFN,""CH"","
SET DIC(0)="AEQMZ"
SET DIC("A")="Select DATE/TIME SPECIMEN TAKEN: "
DO ^DIC
if Y>0
SET (DJDN,MCLRDA)=+Y
SET MCARGDT=$PIECE(Y,U,2)
SET MCLABDT=9999999-MCARGDT
SET DA(1)=MCLRDFN
KILL DIC("A")
QUIT
QUE KILL IO("Q")
SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO EXIT
+1 IF $DATA(IO("Q"))
SET MCARZ="RHEUMATOLOGY REPORT"
SET (ZTSAVE("MC*"),ZTSAVE("DFN"),ZTSAVE("DA"),ZTSAVE("DT"))=""
SET ZTRTN="QSTART^MCRH1"
SET ZTDESC=MCARZ
DO ^%ZTLOAD
KILL ZTSK
QUIT
QSTART KILL ^UTILITY("DIQ1",$JOB)
SET PG=0
SET DIC="^LR(MCLRDFN,""CH"","
SET DA=MCLRDA
+1 SET DR="2:7;9:20;41;45;63;96;174;384;386;387;395:399;428;430;431;454;468;469;547:549;553;561;563;581;587;594;595;625;627;631;639;649;690;691;693;694;700;703;738;741;748;771;750"
+2 SET Y=MCLRDA
SET DA(1)=MCLRDFN
SET DA(63.04)=MCLABDT
DO EN^DIQ1
+3 SET MCARGRTN="RHFULL1"
USE IO
DO RHPRT^MCARP
DO ^%ZISC
QUIT
LOCK ;LOCK GLOBAL THAT IS BEING ACCESSED BY ANOTHER USER
+1 ;L @(DIC_DA_"):1") S MCRHL=$T Q:MCRHL'=0 I MCRHL=0 W !!,*7,"THIS ENTRY IS BEING EDITED BY ANOTHER USER. TRY LATER." Q
EXIT DO KVAR^VADPT
KILL %,DA,DFN,DIC,DIE,DIK,DJDIS,DJDN,DJSC,DR,DT1,H,I,K,K1
+1 KILL MCFILE,MCARCODE,MCARGDT,MCARGRTN,MCARZ,MCRH1,MCRH,MCRHL,MCLABDT,MCLRDFN,MCRHLP,MCRHY,PG,POP,PSOPAR,STA,V,X,X1,Z,ZTDESC,ZTRTN,ZTSAVE,MCARGNUM,MCARGDA,MCSEX
QUIT
ORDERA SET MCARGNUM=$ORDER(^MCAR(697.2,"C","MCAR(701",0))
ORDER if '$DATA(MCOEON)
DO ORDER^MCPARAM
if '$DATA(MCOEON)
QUIT
+1 QUIT
ORDER1 if '$DATA(MCOEON)
GOTO IM
if '$DATA(^MCAR(MCFILE,MCARGDA))
QUIT
if $DATA(DTOUT)
QUIT
IM if MCRH'=1
QUIT
DO EN1^MCMAG
QUIT
GETDATA ; Get Patient Demographic data
+1 NEW MCARR2
+2 SET MCARR1(1)=$GET(VADM(1))
+3 SET MCARR1(2)=$PIECE($GET(VADM(2)),"^",2)
+4 SET MCARR1(9)=$PIECE($GET(VADM(3)),"^",2)
+5 SET MCARR1(10)=$PIECE($GET(VADM(5)),"^",2)
SET MCARR1(11)=$GET(MCARRC)
+6 SET MCARR1(12)=$PIECE($GET(VADM(10)),"^",2)
+7 DO GETS^DIQ(2,DFN_",",".07;.111;.112;.115;.116;.131;.132;.31115","E","MCARR2")
+8 SET MCARR1(3)=$GET(MCARR2(2,DFN_",",.111,"E"))
+9 SET MCARR1(4)=$GET(MCARR2(2,DFN_",",.112,"E"))
+10 SET MCARR1(5)=$GET(MCARR2(2,DFN_",",.115,"E"))
+11 SET MCARR1(6)=$GET(MCARR2(2,DFN_",",.116,"E"))
+12 SET MCARR1(7)=$GET(MCARR2(2,DFN_",",.131,"E"))
+13 SET MCARR1(8)=$GET(MCARR2(2,DFN_",",.132,"E"))
+14 SET MCARR1(13)=$GET(MCARR2(2,DFN_",",.31115,"E"))
+15 SET MCARR1(14)=$GET(MCARR2(2,DFN_",",.07,"E"))
+16 QUIT
