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

SRTPLST.m

Go to the documentation of this file.
  1. SRTPLST ;BIR/SJA - LIST ASSESSMENTS ;04/11/08
  1. ;;3.0; Surgery ;**167**;24 Jun 93;Build 27
  1. I $E(IOST)="P" D ^SRTPLSTP Q
  1. S SRSOUT=0,$P(LINE,"=",80)="",$P(LINE1,"-",80)="" D HDR
  1. F S SRSD=$O(^SRT("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTPP=0 F S SRTPP=$O(^SRT("AC",SRSD,SRTPP)) Q:'SRTPP!SRSOUT S SR("RA")=$G(^SRT(SRTPP,"RA")) D
  1. .I (SRAST="ALL"!(SRAST[$P(SR("RA"),"^"))),$D(^SRT(SRTPP,0)),$$MANDIV(SRINSTP,SRTPP) D PRT
  1. Q
  1. PRT ; print assessments
  1. I '$D(^SRT(SRTPP,"RA")) Q
  1. I SRTYPE'="ALL",(SRTYPE'=$P(^SRT(SRTPP,"RA"),"^",2)) Q
  1. I $Y+5>IOSL D PAGE I SRSOUT Q
  1. S SRA(0)=^SRT(SRTPP,0),DFN=$P(SRA(0),"^"),SRVACO=$P(^SRT(SRTPP,.01),"^",11),SR("RA")=$G(^SRT(SRTPP,"RA"))
  1. N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
  1. I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
  1. S Y=$P(SRA(0),"^",2) D D^DIQ S SRDT=$P(Y,"@")
  1. S Y=$P(SR("RA"),"^")
  1. W !,SRVACO,?16,SRANM_" ("_VA("PID")_")",?51,SRDT,?68,$S(Y="T":"TRANSMITTED",Y="C":"COMPLETE",Y="I":"INCOMPLETE",1:""),!,$S($P(SRA(0),"^",3):$P(SRA(0),"^",3),1:"N/A")
  1. S Y=$P(SR("RA"),"^",2) W ?16,$S(Y="LI":"LIVER",Y="LU":"LUNG",Y="K":"KIDNEY",Y="H":"HEART",1:"")
  1. W !,LINE1
  1. Q
  1. PAGE W !!,"Press <RET> to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
  1. I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>. Enter",!,"'^' to return to the menu." G PAGE
  1. HDR ; print heading
  1. S $P(LINE,"=",80)="",X="LIST OF TRANSPLANT ASSESSMENTS"
  1. W @IOF,!!,?(80-$L(X)\2),X
  1. W !,?(80-$L(SRFRTO)\2),SRFRTO
  1. W !!,"VACO ID",?16,"PATIENT",?51,"TRANSPLANT DATE",?68,"STATUS",!,"SURGERY CASE #",?16,"ORGAN TYPE"
  1. W !,LINE
  1. Q
  1. MANDIV(SRINST,CASE) ;a boolean divisional call for managerial reports
  1. I '$D(^SRT(CASE,0)) Q 0
  1. I '$O(^SRO(133,1)) Q 1
  1. I SRINST["ALL" Q 1
  1. I +SRINST'>0 Q 0
  1. N SRDIV,SROR
  1. S SRDIV=$P($G(^SRT(CASE,8)),U)
  1. Q SRDIV=SRINST