MCMAGDSP ;WISC/RMP-IMAGING INTERFACE ;5/8/97 08:21
;;2.3;Medicine;**6**;09/13/1996
;
REPRT(MCARGDA,FILE) ;
N D,D0,D1,DA,DALL,DC,DCL,DE,DFN,DI,DIC,DICMX,DIEDT,DIL
N DIOBEG,DIOEND,DIP,DIPZ,DIQ,DISTP,DIW,DIWF,DIWL,DIWR,DIWT,DJ,DK,DL,DN
N DPP,DPQ,DQI,DSC,DU,DV,DXS,DY,FLDS,I,J,X,Y,Z,%,%H,%I
N MCAR,MCAR1,MCARDE,MCARDOB,MCARDTM,MCARGDT,MCARGDT2,MCARGNAM
N MCARGNM,MCARGNUM,MCARGRTN,MCARHDR,MCARP,MCARRB,MCARWARD,MCARZ
N MCESKEY,MCESON,MCESS,MCESSEC,MCFILE,MCFILE1,MCFILET,MCOUNT,MCOUT
N MCPATFLD,MCPRO,MCPRTRTN,MCROUT,MCSUP
N NAME,PG,PGM,POP,RDATE,RH,SSN,VA,TY
;Establish Proccedure Subspecialty file entry
;to provide access to paramenters
S MCPRO=$S(FILE=691:"ECHO",FILE=691.1:"CATH",FILE=691.5:"ECG",FILE=701:"RHEUM",1:"")
S:FILE=694 MCPRO=$P(^MCAR(697.2,$P(^MCAR(FILE,MCARGDA,0),U,3),0),U)
S:FILE=699 MCPRO=$P(^MCAR(697.2,$P(^MCAR(FILE,MCARGDA,0),U,12),0),U)
S:FILE=699.5 MCPRO=$P(^MCAR(697.2,$P(^MCAR(FILE,MCARGDA,0),U,6),0),U)
Q:MCPRO=""
D PROC ;Set up parameters
D:$G(MCESON) STATUS^MCESPRT(FILE,MCARGDA)
D @MCPRTRTN
K ^UTILITY($J)
Q
RHFULL ;
S MCARGRTN="^MCARORA" D PRINT K DXS Q:$D(MCOUT)
F RH="B","N","L","Q","H","P","E","D" Q:$D(MCOUT) D
.S MCARGRTN="^MCAROR"_RH D CALLTEM K DXS Q:$D(MCOUT)
D REND
Q
CATH ;
S MCARGRTN="CATH1" D PRINT,REND Q
ECHO ;
S MCARGRTN="ECHO1" D PRINT,REND Q
ECG ;
S MCARGRTN="ECG1" D PRINT,REND Q
CATH1 ;
D ^MCAROC1 K DXS Q:$D(MCOUT)
D ^MCAROC2 K DXS Q:$D(MCOUT)
D ^MCAROC3 K DXS Q:$D(MCOUT)
D ^MCAROC4
Q
ECHO1 ;
;D ^MCAROE1 K DXS Q:$D(MCOUT)
;D ^MCAROE2,REND Q
D ^MCRPEC K DXS Q:$D(MCOUT) D REND Q
ECG1 ;
D ^MCAROK Q
GENERIC ;
S MCARGRTN="^MCAROGE" D PRINT,REND Q
EN1 ;CONSULTS
S MCARGRTN="^MCAROGC" D PRINT,REND Q
GENDO ;
S MCARGRTN=$S($D(^DIC(120.8)):"^MCAROGM",1:"^MCAROG")
D PRINT K DXS Q:$D(MCOUT)
S MCARGRTN="^MCAROGA" D PRINT,REND Q
PENDO ;
S MCARGRTN="^MCAROP" D PRINT K DXS Q:$D(MCOUT)
S MCARGRTN="^MCAROPE" D PRINT,REND Q
NENDO ;
S MCARGRTN="^MCAROGN" D PRINT,REND Q
HEM ;
S (D0,DA)=MCARGDA
N MCFILE S MCFILE=FILE
D HEM^MCARHP Q
PRINT ; Print Report
S (D0,DA)=MCARGDA,DIC=FILE,PG=0
K DXS,DIOT(2),^UTILITY($J),MCOUT
S DFN=$P(^MCAR(FILE,MCARGDA,0),U,2),MCARGDT=$P(^(0),U,1)
D INIT^MCARP1(MCARZ,MCARGDT,FILE)
S ^UTILITY($J,1)="S MCY="""" I $Y>(IOSL-4) R:$E($G(IOST),1,2)=""C-"" !!,""Press return to continue, '^' to escape: "",MCY:DTIME S:'$T MCY=U S:MCY=U DN=0,MCOUT=1 D:DN HEAD^MCARP K MCY"
D HEAD^MCARP,CALLTEM
I '$D(MCOUT) D:$G(MCESON) FOOTER^MCESPRT(FILE,MCARGDA)
Q
CALLTEM ;
D @MCARGRTN Q
PROC ;
N TEMP S MCARP=""
S (MCARP,MCARGNUM,MCARGNAM)=+$O(^MCAR(697.2,"B",MCPRO,MCARP))
S TEMP=$G(^MCAR(697.2,MCARP,0)),MCESS=0
S MCSUP=+$P(TEMP,U,16),(MCROUT,MCARDE)=$P(TEMP,U,8)
S MCESON=+$P(TEMP,U,14),MCESKEY=$P(TEMP,U,15)
S MCARGNAM=$P(TEMP,U),MCPATFLD=$P(TEMP,U,12)
S (MCOUNT,MCESSEC)=0
;I MCESON S:$D(^XUSEC(MCESKEY,DUZ)) MCESSEC=1
I MCESON S MCESSEC=$S(MCESKEY="":1,1:$D(^XUSEC(MCESKEY,DUZ)))
S MCPRTRTN=$P(TEMP,U,5)
S:FILE=699 MCPRTRTN=$S($P(TEMP,U,7)["GI":"GENDO",$P(TEMP,U,7)["PULM":"PENDO",1:"NENDO")
S:FILE=694 MCPRTRTN="HEM"
S MCARZ=$P(^MCAR(697.2,MCARGNUM,0),U,8)_" REPORT"
Q
REND ;
; NOTE: '$D(XWBOS) to be patched when RPC Broker has an official method
I '$D(XWBOS),'$D(MCOUT),$G(Y)'<0 R !!," * END * Press return to continue: ",X:DTIME
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCMAGDSP 3364 printed Dec 13, 2024@02:15:14 Page 2
MCMAGDSP ;WISC/RMP-IMAGING INTERFACE ;5/8/97 08:21
+1 ;;2.3;Medicine;**6**;09/13/1996
+2 ;
REPRT(MCARGDA,FILE) ;
+1 NEW D,D0,D1,DA,DALL,DC,DCL,DE,DFN,DI,DIC,DICMX,DIEDT,DIL
+2 NEW DIOBEG,DIOEND,DIP,DIPZ,DIQ,DISTP,DIW,DIWF,DIWL,DIWR,DIWT,DJ,DK,DL,DN
+3 NEW DPP,DPQ,DQI,DSC,DU,DV,DXS,DY,FLDS,I,J,X,Y,Z,%,%H,%I
+4 NEW MCAR,MCAR1,MCARDE,MCARDOB,MCARDTM,MCARGDT,MCARGDT2,MCARGNAM
+5 NEW MCARGNM,MCARGNUM,MCARGRTN,MCARHDR,MCARP,MCARRB,MCARWARD,MCARZ
+6 NEW MCESKEY,MCESON,MCESS,MCESSEC,MCFILE,MCFILE1,MCFILET,MCOUNT,MCOUT
+7 NEW MCPATFLD,MCPRO,MCPRTRTN,MCROUT,MCSUP
+8 NEW NAME,PG,PGM,POP,RDATE,RH,SSN,VA,TY
+9 ;Establish Proccedure Subspecialty file entry
+10 ;to provide access to paramenters
+11 SET MCPRO=$SELECT(FILE=691:"ECHO",FILE=691.1:"CATH",FILE=691.5:"ECG",FILE=701:"RHEUM",1:"")
+12 if FILE=694
SET MCPRO=$PIECE(^MCAR(697.2,$PIECE(^MCAR(FILE,MCARGDA,0),U,3),0),U)
+13 if FILE=699
SET MCPRO=$PIECE(^MCAR(697.2,$PIECE(^MCAR(FILE,MCARGDA,0),U,12),0),U)
+14 if FILE=699.5
SET MCPRO=$PIECE(^MCAR(697.2,$PIECE(^MCAR(FILE,MCARGDA,0),U,6),0),U)
+15 if MCPRO=""
QUIT
+16 ;Set up parameters
DO PROC
+17 if $GET(MCESON)
DO STATUS^MCESPRT(FILE,MCARGDA)
+18 DO @MCPRTRTN
+19 KILL ^UTILITY($JOB)
+20 QUIT
RHFULL ;
+1 SET MCARGRTN="^MCARORA"
DO PRINT
KILL DXS
if $DATA(MCOUT)
QUIT
+2 FOR RH="B","N","L","Q","H","P","E","D"
if $DATA(MCOUT)
QUIT
Begin DoDot:1
+3 SET MCARGRTN="^MCAROR"_RH
DO CALLTEM
KILL DXS
if $DATA(MCOUT)
QUIT
End DoDot:1
+4 DO REND
+5 QUIT
CATH ;
+1 SET MCARGRTN="CATH1"
DO PRINT
DO REND
QUIT
ECHO ;
+1 SET MCARGRTN="ECHO1"
DO PRINT
DO REND
QUIT
ECG ;
+1 SET MCARGRTN="ECG1"
DO PRINT
DO REND
QUIT
CATH1 ;
+1 DO ^MCAROC1
KILL DXS
if $DATA(MCOUT)
QUIT
+2 DO ^MCAROC2
KILL DXS
if $DATA(MCOUT)
QUIT
+3 DO ^MCAROC3
KILL DXS
if $DATA(MCOUT)
QUIT
+4 DO ^MCAROC4
+5 QUIT
ECHO1 ;
+1 ;D ^MCAROE1 K DXS Q:$D(MCOUT)
+2 ;D ^MCAROE2,REND Q
+3 DO ^MCRPEC
KILL DXS
if $DATA(MCOUT)
QUIT
DO REND
QUIT
ECG1 ;
+1 DO ^MCAROK
QUIT
GENERIC ;
+1 SET MCARGRTN="^MCAROGE"
DO PRINT
DO REND
QUIT
EN1 ;CONSULTS
+1 SET MCARGRTN="^MCAROGC"
DO PRINT
DO REND
QUIT
GENDO ;
+1 SET MCARGRTN=$SELECT($DATA(^DIC(120.8)):"^MCAROGM",1:"^MCAROG")
+2 DO PRINT
KILL DXS
if $DATA(MCOUT)
QUIT
+3 SET MCARGRTN="^MCAROGA"
DO PRINT
DO REND
QUIT
PENDO ;
+1 SET MCARGRTN="^MCAROP"
DO PRINT
KILL DXS
if $DATA(MCOUT)
QUIT
+2 SET MCARGRTN="^MCAROPE"
DO PRINT
DO REND
QUIT
NENDO ;
+1 SET MCARGRTN="^MCAROGN"
DO PRINT
DO REND
QUIT
HEM ;
+1 SET (D0,DA)=MCARGDA
+2 NEW MCFILE
SET MCFILE=FILE
+3 DO HEM^MCARHP
QUIT
PRINT ; Print Report
+1 SET (D0,DA)=MCARGDA
SET DIC=FILE
SET PG=0
+2 KILL DXS,DIOT(2),^UTILITY($JOB),MCOUT
+3 SET DFN=$PIECE(^MCAR(FILE,MCARGDA,0),U,2)
SET MCARGDT=$PIECE(^(0),U,1)
+4 DO INIT^MCARP1(MCARZ,MCARGDT,FILE)
+5 SET ^UTILITY($JOB,1)="S MCY="""" I $Y>(IOSL-4) R:$E($G(IOST),1,2)=""C-"" !!,""Press return to continue, '^' to escape: "",MCY:DTIME S:'$T MCY=U S:MCY=U DN=0,MCOUT=1 D:DN HEAD^MCARP K MCY"
+6 DO HEAD^MCARP
DO CALLTEM
+7 IF '$DATA(MCOUT)
if $GET(MCESON)
DO FOOTER^MCESPRT(FILE,MCARGDA)
+8 QUIT
CALLTEM ;
+1 DO @MCARGRTN
QUIT
PROC ;
+1 NEW TEMP
SET MCARP=""
+2 SET (MCARP,MCARGNUM,MCARGNAM)=+$ORDER(^MCAR(697.2,"B",MCPRO,MCARP))
+3 SET TEMP=$GET(^MCAR(697.2,MCARP,0))
SET MCESS=0
+4 SET MCSUP=+$PIECE(TEMP,U,16)
SET (MCROUT,MCARDE)=$PIECE(TEMP,U,8)
+5 SET MCESON=+$PIECE(TEMP,U,14)
SET MCESKEY=$PIECE(TEMP,U,15)
+6 SET MCARGNAM=$PIECE(TEMP,U)
SET MCPATFLD=$PIECE(TEMP,U,12)
+7 SET (MCOUNT,MCESSEC)=0
+8 ;I MCESON S:$D(^XUSEC(MCESKEY,DUZ)) MCESSEC=1
+9 IF MCESON
SET MCESSEC=$SELECT(MCESKEY="":1,1:$DATA(^XUSEC(MCESKEY,DUZ)))
+10 SET MCPRTRTN=$PIECE(TEMP,U,5)
+11 if FILE=699
SET MCPRTRTN=$SELECT($PIECE(TEMP,U,7)["GI":"GENDO",$PIECE(TEMP,U,7)["PULM":"PENDO",1:"NENDO")
+12 if FILE=694
SET MCPRTRTN="HEM"
+13 SET MCARZ=$PIECE(^MCAR(697.2,MCARGNUM,0),U,8)_" REPORT"
+14 QUIT
REND ;
+1 ; NOTE: '$D(XWBOS) to be patched when RPC Broker has an official method
+2 IF '$DATA(XWBOS)
IF '$DATA(MCOUT)
IF $GET(Y)'<0
READ !!," * END * Press return to continue: ",X:DTIME
+3 QUIT
