Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MCMAGDSP

MCMAGDSP.m

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