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