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

SRTPPAS.m

Go to the documentation of this file.
  1. SRTPPAS ;BIR/SJA - PRINT A COMPLETE ASSESSMENT ;04/21/08
  1. ;;3.0; Surgery ;**167**;24 Jun 93;Build 27
  1. N AGE,C,D,E,I,II,JJ,K,LINE,MOE,N,SR,SRA,SRACE,SRANM,SRATYPE
  1. N SRDR,SRHALT,SRNOVA,SRVACO,SRNUM,SROLNGTH,SRPG,SRQ,SRSDATE,X,Y,Z
  1. S SRSOUT=0,SRPG=0,SR("RA")=$G(^SRT(SRTPP,"RA")),SRATYPE=$P(SR("RA"),"^",2),SRNOVA=$S($P(SR("RA"),"^",5)="N":1,1:0)
  1. F I=.01,.02,.1,.11,.5,.55,1,3,10,11 S SRA(I)=$G(^SRT(SRTPP,I))
  1. S SR(0)=^SRT(SRTPP,0),DFN=$P(SR(0),"^"),SRSDATE=$P(SR(0),"^",2),SRVACO=$P(SRA(.01),"^",11)
  1. D DEM^VADPT S SRANM=VADM(1)_" "_VA("PID"),Z=$P(VADM(3),"^"),Y=$E(SRSDATE,1,7),AGE=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
  1. W:$E(IOST)'="P" @IOF D HDR G:SRSOUT END
  1. W !,?28,"RECIPIENT INFORMATION",!
  1. W !,"Age: ",?22,AGE S Y=SRSDATE D D^DIQ W ?40,"Transplant Date: ",?59,$P(Y,"@")
  1. ;Find patient's ethnicity
  1. S SROETH=""
  1. I $G(VADM(11)) S SROETH=$P(VADM(11,1),U,2)
  1. I '$G(VADM(11)) S SROETH="UNANSWERED"
  1. ;Find all race entries and place into a string with commas inbetween
  1. S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL=""
  1. F S SRORC=$O(VADM(12,SRORC)) Q:SRORC="" Q:C=11 D
  1. .I $G(VADM(12,SRORC)) S SRORACE(C)=$P(VADM(12,SRORC),U,2)
  1. .I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C)
  1. .I SROLINE="" S SROLINE=SRORACE(C)
  1. .S C=C+1
  1. ;Find total length of 'race' string and wrap the text if necessary
  1. I $L(SROLINE)=29!$L(SROLINE)<29 S SROL(N)=SROLINE,SRNUM1=2
  1. I $L(SROLINE)>29 D WRAP
  1. W !,"Gender: ",?22,$P(VADM(5),"^",2),?40,"Ethnicity:",?51,SROETH
  1. W !,"VACO ID: ",?22,SRVACO,?40,"Race:"
  1. I $G(VADM(12)) F D=1:1:SRNUM1-1 D
  1. .W:D=1 ?51,SROL(D)
  1. .W:D'=1 !,?51,SROL(D)
  1. I '$G(VADM(12)) W ?51,"UNANSWERED"
  1. K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1
  1. G @($S(SRATYPE="K":"^SRTPRK",SRATYPE="LI":"^SRTPRLI",SRATYPE="LU":"^SRTPRLU",SRATYPE="H":"^SRTPRH",1:""))
  1. END I '$D(SRABATCH) I 'SRSOUT,$E(IOST)'="P" W !!,"Press <RET> to continue " R X:DTIME
  1. Q:$E(IOST)'="P"
  1. W:$E(IOST)="P" @IOF I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q
  1. D ^%ZISC K SROETH,SRTPP W @IOF D ^SRSKILL
  1. Q
  1. WRAP ;Wrap multiple race entries so that wrapped line
  1. ;does not break in the middle of a word
  1. S SROLNGTH=$L(SROLINE),E=29,SROWRAP="",SROLN="",SROLN1="",SROL=""
  1. F I=1:29:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D
  1. .F K=29:-1:1 I $E(SROLN(I),K)[" " D Q ;Break lines at space
  1. ..S SROLN1(I)=$E(SROLN(I),1,K-1)
  1. ..S SROWRAP=$E(SROLN(I),K+1,E)
  1. .S E=E+29
  1. S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP=""
  1. I $L(SROLN1(I))+$L(SROWRAP)>28 S SROLN1(I+1)=SROWRAP ;Last line
  1. I $L(SROLN1(I))+$L(SROWRAP)'>28 S SROLN1(I)=SROLN1(I)_" "_SROWRAP
  1. ;Renumber the SROLN1 array to be in numeric order
  1. S SRNUM=0,SRNUM1=1
  1. F S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM="" D
  1. .S SROL(SRNUM1)=SROLN1(SRNUM)
  1. .S SRNUM1=SRNUM1+1
  1. Q
  1. PAGE I $E(IOST)'="P" W !!,"Press <RET> to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
  1. I $E(IOST)'="P",X["?" W !!,"Enter <RET> to continue printing the remaining pages of this assessment, or",!,"'^' to exit this option." G PAGE
  1. W @IOF
  1. HDR ; print heading
  1. I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
  1. S SRPG=SRPG+1
  1. I $Y'=0 W @IOF
  1. W !,$$TR^SRTPUTL($P(SR("RA"),"^",2))_" TRANSPLANT ASSESSMENT "_$S($P(SR("RA"),"^",5)="V":"VA",1:"NON-VA")_$S($P(SR(0),"^",3):" SURGERY CASE #"_$P(SR(0),"^",3),1:" TRANSPLANT"),?70,"PAGE "_SRPG
  1. W !,"FOR "_SRANM S X=$P(SR("RA"),"^") W " ("_$S(X="I":"INCOMPLETE",X="C":"COMPLETED",X="T":"TRANSMITTED",1:"NO ASSESSMENT") I X="T" S Y=$P(SR("RA"),"^",4) W " "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)
  1. W ")",!,"Medical Center: "_SRSITE("SITE"),! F LINE=1:1:80 W "="
  1. W !
  1. Q