Routine: SROAPAS

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

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

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

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 !

CODE ; print CPT Code

 S X=$P(^SRF(SRTN,13,SR,0),"^",2) I X W "  ("_$P($$CPT^ICPTCOD(X),"^",2)_")"

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROAPAS   5536     printed  Apr 23, 2025@18:56: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

SROAPAS.m