SROAPAS ;BIR/MAM - PRINT A COMPLETE ASSESSMENT ;05/28/10
;;3.0;Surgery;**38,47,81,88,111,112,100,125,153,166,174,175,182,184**;24 Jun 93;Build 35
S SRSOUT=0,SRPG=0,SR("RA")=$G(^SRF(SRTN,"RA")),SRATYPE=$P(SR("RA"),"^",2) F I=200:1:208,200.1 S SRA(I)=$G(^SRF(SRTN,I))
S SRA("OP")=^SRF(SRTN,"OP"),SRA("CON")=$G(^SRF(SRTN,"CON"))
S SR(0)=^SRF(SRTN,0),DFN=$P(SR(0),"^"),SRSDATE=$P(SR(0),"^",9) 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))
I $P(SR("RA"),"^",2)="C" D ^SROAPCA G END
W:$E(IOST)'="P" @IOF D HDR G:SRSOUT END
W !,"Medical Center: "_SRSITE("SITE")
W !,"Age: ",?16,AGE S Y=SRSDATE D D^DIQ W ?40,"Operation Date: ",?59,$P(Y,"@")
S Y=$P($G(^SRF(SRTN,208)),"^",10),C=$P(^DD(130,417,0),"^",2) D Y^DIQ S X=$S(Y'="":Y,1:"NOT ENTERED")
;
D DEM^VADPT
;Find patient's ethnicity
S SROETH=""
I $G(VADM(11)) S SROETH=$P(VADM(11,1),U,2)
I '$G(VADM(11)) S SROETH="UNANSWERED"
;
;Find all race entries and place into a string with commas inbetween
S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL=""
F S SRORC=$O(VADM(12,SRORC)) Q:SRORC="" Q:C=11 D
.I $G(VADM(12,SRORC)) S SRORACE(C)=$P(VADM(12,SRORC),U,2)
.I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C)
.I SROLINE="" S SROLINE=SRORACE(C)
.S C=C+1
;
;Find total length of 'race' string and wrap the text if necessary
I $L(SROLINE)=29!$L(SROLINE)<29 S SROL(N)=SROLINE,SRNUM1=2
I $L(SROLINE)>29 D WRAP
;
W !,"Sex: ",?16,$P(VADM(5),"^",2),?40,"Ethnicity:",?59,SROETH
W !,?40,"Race:"
I $G(VADM(12)) F D=1:1:SRNUM1-1 D
.W:D=1 ?59,SROL(D)
.W:D'=1 !,?59,SROL(D)
I '$G(VADM(12)) W ?59,"UNANSWERED"
;
K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1
;
S Y=$P($G(^SRF(SRTN,208)),"^",11),C=$P(^DD(130,413,0),"^",2) D Y^DIQ S X=$S(Y'="":Y,1:"NOT ENTERED") W !,"Transfer Status:",?44,X
F J=1,2,3 S Y=$P($G(^SRF(SRTN,208.1)),"^",J) D
.I J'=3 X:Y ^DD("DD") S Z=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5)
.I J=3 S C=$P(^DD(130,454,0),"^",2) D Y^DIQ S Z=Y
.W !,"Observation "_$S(J=1:"Admission Date:",J=2:"Discharge Date:",1:"Treating Specialty:"),?44,Z
F J=14:1:17 S Y=$P($G(^SRF(SRTN,208)),"^",J) X ^DD("DD") S SRPTMODT(J)=Y
S (X,Z)=SRPTMODT(14) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Hospital Admission Date:",?44,Z
S (X,Z)=SRPTMODT(15) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Hospital Discharge Date:",?44,Z
S (X,Z)=SRPTMODT(16) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Admitted/Transferred to Surgical Service:",?44,Z
S (X,Z)=SRPTMODT(17) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Discharged/Transferred to Chronic Care:",?44,Z
S Y=$P($G(^SRF(SRTN,210)),"^",14),C=$P(^DD(130,685,0),"^",2) D Y^DIQ S X=$S(Y'="":Y,1:"NOT ENTERED") W !,"DC/REL Destination:",?44,$E(X,1,35)
S X=$P($G(^SRF(SRTN,0)),"^",12)
W !,"Hospital Admission Status:",?44,$S(X="I":"INPATIENT",X="O":"OUTPATIENT",X=1:"OUTPATIENT",X=2:"INPATIENT",X=3:"INPATIENT",1:"")
S X=$P(SR("RA"),"^",9) W !,"Assessment Completed by:" I $G(X) W ?44,$P($G(^VA(200,X,0)),"^")
I $E(IOST)="P" W ! F MOE=1:1:80 W "-"
I $E(IOST)'="P" D PAGE I SRSOUT G END
D ^SROAPRT1 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END
D ^SROAPRT2 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END
D OPTIMES^SROAPRT3 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END
D ^SROAPRT3 G:SRSOUT END I $Y+24>IOSL D PAGE I SRSOUT G END
D ^SROAPRT4 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END
D ^SROAPRT5 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END
D ^SROAPRT6
END Q:$D(SRABATCH) I 'SRSOUT,$E(IOST)'="P" W !!,"Press <RET> to continue " R X:DTIME
W:$E(IOST)="P" @IOF I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q
D ^%ZISC K SROETH,SRTN W @IOF D ^SRSKILL
Q
;
WRAP ;Wrap multiple race entries so that wrapped line
;does not break in the middle of a word
;
S SROLNGTH=$L(SROLINE),E=29,SROWRAP="",SROLN="",SROLN1="",SROL=""
F I=1:29:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D
.F K=29:-1:1 I $E(SROLN(I),K)[" " D Q ;Break lines at space
..S SROLN1(I)=$E(SROLN(I),1,K-1)
..S SROWRAP=$E(SROLN(I),K+1,E)
.S E=E+29
;
S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP=""
I $L(SROLN1(I))+$L(SROWRAP)>28 S SROLN1(I+1)=SROWRAP ;Last line
I $L(SROLN1(I))+$L(SROWRAP)'>28 S SROLN1(I)=SROLN1(I)_" "_SROWRAP
;
;Renumber the SROLN1 array to be in numeric order
S SRNUM=0,SRNUM1=1
F S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM="" D
.S SROL(SRNUM1)=SROLN1(SRNUM)
.S SRNUM1=SRNUM1+1
Q
;
LOOP ; break procedures
S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<55 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
Q
PAGE I $E(IOST)'="P" W !!,"Press <RET> to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
I X["?" W !!,"Enter <RET> to continue printing the remaining pages of this assessment, or",!,"'^' to exit this option." G PAGE
W @IOF
HDR ; print heading
I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
S SRPG=SRPG+1
I $Y'=0 W @IOF
I SRATYPE="C" W !,"VA CARDIAC RISK ASSESSMENT",?70,"PAGE "_SRPG
I SRATYPE="N" W !,"VA NON-CARDIAC RISK ASSESSMENT Assessment: "_SRTN,?69,"PAGE "_SRPG
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)
W ")",! F LINE=1:1:80 W "="
W !
Q
CODE ; print CPT Code
S X=$P(^SRF(SRTN,13,SR,0),"^",2) I X W " ("_$P($$CPT^ICPTCOD(X),"^",2)_")"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROAPAS 5536 printed Apr 09, 2024@21:50:04 Page 2
SROAPAS ;BIR/MAM - PRINT A COMPLETE ASSESSMENT ;05/28/10
+1 ;;3.0;Surgery;**38,47,81,88,111,112,100,125,153,166,174,175,182,184**;24 Jun 93;Build 35
+2 SET SRSOUT=0
SET SRPG=0
SET SR("RA")=$GET(^SRF(SRTN,"RA"))
SET SRATYPE=$PIECE(SR("RA"),"^",2)
FOR I=200:1:208,200.1
SET SRA(I)=$GET(^SRF(SRTN,I))
+3 SET SRA("OP")=^SRF(SRTN,"OP")
SET SRA("CON")=$GET(^SRF(SRTN,"CON"))
+4 SET SR(0)=^SRF(SRTN,0)
SET DFN=$PIECE(SR(0),"^")
SET SRSDATE=$PIECE(SR(0),"^",9)
DO DEM^VADPT
SET SRANM=VADM(1)_" "_VA("PID")
SET Z=$PIECE(VADM(3),"^")
SET Y=$EXTRACT(SRSDATE,1,7)
SET AGE=$EXTRACT(Y,1,3)-$EXTRACT(Z,1,3)-($EXTRACT(Y,4,7)<$EXTRACT(Z,4,7))
+5 IF $PIECE(SR("RA"),"^",2)="C"
DO ^SROAPCA
GOTO END
+6 if $EXTRACT(IOST)'="P"
WRITE @IOF
DO HDR
if SRSOUT
GOTO END
+7 WRITE !,"Medical Center: "_SRSITE("SITE")
+8 WRITE !,"Age: ",?16,AGE
SET Y=SRSDATE
DO D^DIQ
WRITE ?40,"Operation Date: ",?59,$PIECE(Y,"@")
+9 SET Y=$PIECE($GET(^SRF(SRTN,208)),"^",10)
SET C=$PIECE(^DD(130,417,0),"^",2)
DO Y^DIQ
SET X=$SELECT(Y'="":Y,1:"NOT ENTERED")
+10 ;
+11 DO DEM^VADPT
+12 ;Find patient's ethnicity
+13 SET SROETH=""
+14 IF $GET(VADM(11))
SET SROETH=$PIECE(VADM(11,1),U,2)
+15 IF '$GET(VADM(11))
SET SROETH="UNANSWERED"
+16 ;
+17 ;Find all race entries and place into a string with commas inbetween
+18 SET SRORC=0
SET C=1
SET SRORACE=""
SET SROLINE=""
SET N=1
SET SROL=""
+19 FOR
SET SRORC=$ORDER(VADM(12,SRORC))
if SRORC=""
QUIT
if C=11
QUIT
Begin DoDot:1
+20 IF $GET(VADM(12,SRORC))
SET SRORACE(C)=$PIECE(VADM(12,SRORC),U,2)
+21 IF SROLINE'=""
SET SROLINE=SROLINE_", "_SRORACE(C)
+22 IF SROLINE=""
SET SROLINE=SRORACE(C)
+23 SET C=C+1
End DoDot:1
+24 ;
+25 ;Find total length of 'race' string and wrap the text if necessary
+26 IF $LENGTH(SROLINE)=29!$LENGTH(SROLINE)<29
SET SROL(N)=SROLINE
SET SRNUM1=2
+27 IF $LENGTH(SROLINE)>29
DO WRAP
+28 ;
+29 WRITE !,"Sex: ",?16,$PIECE(VADM(5),"^",2),?40,"Ethnicity:",?59,SROETH
+30 WRITE !,?40,"Race:"
+31 IF $GET(VADM(12))
FOR D=1:1:SRNUM1-1
Begin DoDot:1
+32 if D=1
WRITE ?59,SROL(D)
+33 if D'=1
WRITE !,?59,SROL(D)
End DoDot:1
+34 IF '$GET(VADM(12))
WRITE ?59,"UNANSWERED"
+35 ;
+36 KILL SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1
+37 ;
+38 SET Y=$PIECE($GET(^SRF(SRTN,208)),"^",11)
SET C=$PIECE(^DD(130,413,0),"^",2)
DO Y^DIQ
SET X=$SELECT(Y'="":Y,1:"NOT ENTERED")
WRITE !,"Transfer Status:",?44,X
+39 FOR J=1,2,3
SET Y=$PIECE($GET(^SRF(SRTN,208.1)),"^",J)
Begin DoDot:1
+40 IF J'=3
if Y
XECUTE ^DD("DD")
SET Z=$PIECE(Y,"@")_" "_$EXTRACT($PIECE(Y,"@",2),1,5)
+41 IF J=3
SET C=$PIECE(^DD(130,454,0),"^",2)
DO Y^DIQ
SET Z=Y
+42 WRITE !,"Observation "_$SELECT(J=1:"Admission Date:",J=2:"Discharge Date:",1:"Treating Specialty:"),?44,Z
End DoDot:1
+43 FOR J=14:1:17
SET Y=$PIECE($GET(^SRF(SRTN,208)),"^",J)
XECUTE ^DD("DD")
SET SRPTMODT(J)=Y
+44 SET (X,Z)=SRPTMODT(14)
if X'=""
SET Z=$PIECE(X,"@")_" "_$EXTRACT($PIECE(X,"@",2),1,5)
WRITE !,"Hospital Admission Date:",?44,Z
+45 SET (X,Z)=SRPTMODT(15)
if X'=""
SET Z=$PIECE(X,"@")_" "_$EXTRACT($PIECE(X,"@",2),1,5)
WRITE !,"Hospital Discharge Date:",?44,Z
+46 SET (X,Z)=SRPTMODT(16)
if X'=""
SET Z=$PIECE(X,"@")_" "_$EXTRACT($PIECE(X,"@",2),1,5)
WRITE !,"Admitted/Transferred to Surgical Service:",?44,Z
+47 SET (X,Z)=SRPTMODT(17)
if X'=""
SET Z=$PIECE(X,"@")_" "_$EXTRACT($PIECE(X,"@",2),1,5)
WRITE !,"Discharged/Transferred to Chronic Care:",?44,Z
+48 SET Y=$PIECE($GET(^SRF(SRTN,210)),"^",14)
SET C=$PIECE(^DD(130,685,0),"^",2)
DO Y^DIQ
SET X=$SELECT(Y'="":Y,1:"NOT ENTERED")
WRITE !,"DC/REL Destination:",?44,$EXTRACT(X,1,35)
+49 SET X=$PIECE($GET(^SRF(SRTN,0)),"^",12)
+50 WRITE !,"Hospital Admission Status:",?44,$SELECT(X="I":"INPATIENT",X="O":"OUTPATIENT",X=1:"OUTPATIENT",X=2:"INPATIENT",X=3:"INPATIENT",1:"")
+51 SET X=$PIECE(SR("RA"),"^",9)
WRITE !,"Assessment Completed by:"
IF $GET(X)
WRITE ?44,$PIECE($GET(^VA(200,X,0)),"^")
+52 IF $EXTRACT(IOST)="P"
WRITE !
FOR MOE=1:1:80
WRITE "-"
+53 IF $EXTRACT(IOST)'="P"
DO PAGE
IF SRSOUT
GOTO END
+54 DO ^SROAPRT1
if SRSOUT
GOTO END
IF $Y+20>IOSL
DO PAGE
IF SRSOUT
GOTO END
+55 DO ^SROAPRT2
if SRSOUT
GOTO END
IF $Y+20>IOSL
DO PAGE
IF SRSOUT
GOTO END
+56 DO OPTIMES^SROAPRT3
if SRSOUT
GOTO END
IF $Y+20>IOSL
DO PAGE
IF SRSOUT
GOTO END
+57 DO ^SROAPRT3
if SRSOUT
GOTO END
IF $Y+24>IOSL
DO PAGE
IF SRSOUT
GOTO END
+58 DO ^SROAPRT4
if SRSOUT
GOTO END
IF $Y+20>IOSL
DO PAGE
IF SRSOUT
GOTO END
+59 DO ^SROAPRT5
if SRSOUT
GOTO END
IF $Y+20>IOSL
DO PAGE
IF SRSOUT
GOTO END
+60 DO ^SROAPRT6
END if $DATA(SRABATCH)
QUIT
IF 'SRSOUT
IF $EXTRACT(IOST)'="P"
WRITE !!,"Press <RET> to continue "
READ X:DTIME
+1 if $EXTRACT(IOST)="P"
WRITE @IOF
IF $DATA(ZTQUEUED)
if $GET(ZTSTOP)
QUIT
SET ZTREQ="@"
QUIT
+2 DO ^%ZISC
KILL SROETH,SRTN
WRITE @IOF
DO ^SRSKILL
+3 QUIT
+4 ;
WRAP ;Wrap multiple race entries so that wrapped line
+1 ;does not break in the middle of a word
+2 ;
+3 SET SROLNGTH=$LENGTH(SROLINE)
SET E=29
SET SROWRAP=""
SET SROLN=""
SET SROLN1=""
SET SROL=""
+4 FOR I=1:29:SROLNGTH
SET SROLN(I)=SROWRAP_$EXTRACT(SROLINE,I,E)
Begin DoDot:1
+5 ;Break lines at space
FOR K=29:-1:1
IF $EXTRACT(SROLN(I),K)[" "
Begin DoDot:2
+6 SET SROLN1(I)=$EXTRACT(SROLN(I),1,K-1)
+7 SET SROWRAP=$EXTRACT(SROLN(I),K+1,E)
End DoDot:2
QUIT
+8 SET E=E+29
End DoDot:1
+9 ;
+10 if '$DATA(SROLN1(I))
SET SROLN1(I)=SROLN(I)
SET SROWRAP=""
+11 ;Last line
IF $LENGTH(SROLN1(I))+$LENGTH(SROWRAP)>28
SET SROLN1(I+1)=SROWRAP
+12 IF $LENGTH(SROLN1(I))+$LENGTH(SROWRAP)'>28
SET SROLN1(I)=SROLN1(I)_" "_SROWRAP
+13 ;
+14 ;Renumber the SROLN1 array to be in numeric order
+15 SET SRNUM=0
SET SRNUM1=1
+16 FOR
SET SRNUM=$ORDER(SROLN1(SRNUM))
if SRNUM=""
QUIT
Begin DoDot:1
+17 SET SROL(SRNUM1)=SROLN1(SRNUM)
+18 SET SRNUM1=SRNUM1+1
End DoDot:1
+19 QUIT
+20 ;
LOOP ; break procedures
+1 SET SROPS(M)=""
FOR LOOP=1:1
SET MM=$PIECE(SROPER," ")
SET MMM=$PIECE(SROPER," ",2,200)
if MMM=""
QUIT
if $LENGTH(SROPS(M))+$LENGTH(MM)'<55
QUIT
SET SROPS(M)=SROPS(M)_MM_" "
SET SROPER=MMM
+2 QUIT
PAGE IF $EXTRACT(IOST)'="P"
WRITE !!,"Press <RET> to continue, or '^' to quit "
READ X:DTIME
IF '$TEST!(X["^")
SET SRSOUT=1
QUIT
+1 IF X["?"
WRITE !!,"Enter <RET> to continue printing the remaining pages of this assessment, or",!,"'^' to exit this option."
GOTO PAGE
+2 WRITE @IOF
HDR ; print heading
+1 IF $DATA(ZTQUEUED)
DO ^SROSTOP
IF SRHALT
SET SRSOUT=1
QUIT
+2 SET SRPG=SRPG+1
+3 IF $Y'=0
WRITE @IOF
+4 IF SRATYPE="C"
WRITE !,"VA CARDIAC RISK ASSESSMENT",?70,"PAGE "_SRPG
+5 IF SRATYPE="N"
WRITE !,"VA NON-CARDIAC RISK ASSESSMENT Assessment: "_SRTN,?69,"PAGE "_SRPG
+6 WRITE !,"FOR "_SRANM
SET X=$PIECE(SR("RA"),"^")
WRITE " ("_$SELECT(X="I":"INCOMPLETE",X="C":"COMPLETED",X="T":"TRANSMITTED",1:"NO ASSESSMENT")
IF X="T"
SET Y=$PIECE(SR("RA"),"^",4)
WRITE " "_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
+7 WRITE ")",!
FOR LINE=1:1:80
WRITE "="
+8 WRITE !
+9 QUIT
CODE ; print CPT Code
+1 SET X=$PIECE(^SRF(SRTN,13,SR,0),"^",2)
IF X
WRITE " ("_$PIECE($$CPT^ICPTCOD(X),"^",2)_")"
+2 QUIT
