Changeset 623 for WorldVistAEHR/trunk/r/SURGERY-SR/SROAPAS.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SURGERY-SR/SROAPAS.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SURGERY-SR/SROAPAS.m
r613 r623 1 SROAPAS ;BIR/MAM - PRINT A COMPLETE ASSESSMENT ;03/03/08 2 ;;3.0; Surgery ;**38,47,81,88,111,112,100,125,153,166**;24 Jun 93;Build 7 3 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)) 4 S SRA("OP")=^SRF(SRTN,"OP"),SRA("CON")=$G(^SRF(SRTN,"CON")) 5 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)) 6 I $P(SR("RA"),"^",2)="C" D ^SROAPCA G END 7 W:$E(IOST)'="P" @IOF D HDR G:SRSOUT END 8 W !,"Medical Center: "_SRSITE("SITE") 9 W !,"Age: ",?16,AGE S Y=SRSDATE D D^DIQ W ?40,"Operation Date: ",?59,$P(Y,"@") 10 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") 11 ; 12 D DEM^VADPT 13 ;Find patient's ethnicity 14 S SROETH="" 15 I $G(VADM(11)) S SROETH=$P(VADM(11,1),U,2) 16 I '$G(VADM(11)) S SROETH="UNANSWERED" 17 ; 18 ;Find all race entries and place into a string with commas inbetween 19 S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL="" 20 F S SRORC=$O(VADM(12,SRORC)) Q:SRORC="" Q:C=11 D 21 .I $G(VADM(12,SRORC)) S SRORACE(C)=$P(VADM(12,SRORC),U,2) 22 .I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C) 23 .I SROLINE="" S SROLINE=SRORACE(C) 24 .S C=C+1 25 ; 26 ;Find total length of 'race' string and wrap the text if necessary 27 I $L(SROLINE)=29!$L(SROLINE)<29 S SROL(N)=SROLINE,SRNUM1=2 28 I $L(SROLINE)>29 D WRAP 29 ; 30 W !,"Sex: ",?16,$P(VADM(5),"^",2),?40,"Ethnicity:",?51,SROETH 31 W !,?40,"Race:" 32 I $G(VADM(12)) F D=1:1:SRNUM1-1 D 33 .W:D=1 ?51,SROL(D) 34 .W:D'=1 !,?51,SROL(D) 35 I '$G(VADM(12)) W ?51,"UNANSWERED" 36 ; 37 K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1 38 ; 39 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: ",X 40 F J=1,2,3 S Y=$P($G(^SRF(SRTN,208.1)),"^",J) D 41 .I J'=3 X:Y ^DD("DD") S Z=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5) 42 .I J=3 S C=$P(^DD(130,454,0),"^",2) D Y^DIQ S Z=Y 43 .W !,"Observation "_$S(J=1:"Admission Date:",J=2:"Discharge Date:",1:"Treating Specialty:"),?47,Z 44 F J=14:1:17 S Y=$P($G(^SRF(SRTN,208)),"^",J) X ^DD("DD") S SRPTMODT(J)=Y 45 S (X,Z)=SRPTMODT(14) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Hospital Admission Date:",?47,Z 46 S (X,Z)=SRPTMODT(15) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Hospital Discharge Date:",?47,Z 47 S (X,Z)=SRPTMODT(16) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Admitted/Transferred to Surgical Service:",?47,Z 48 S (X,Z)=SRPTMODT(17) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Discharged/Transferred to Chronic Care:",?47,Z 49 W !,"In/Out-Patient Status:",?47,$S($P($G(^SRF(SRTN,0)),"^",12)="I":"INPATIENT",$P($G(^SRF(SRTN,0)),"^",12)="O":"OUTPATIENT",1:"") 50 S Y=$P($G(^SRF(SRTN,209)),"^",17) X ^DD("DD") W !,"Date Surgery Consult Requested:",?47,Y 51 S Y=$P($G(^SRF(SRTN,209)),"^",15) X ^DD("DD") W !,"Surgery Consult Date:",?47,Y 52 I $E(IOST)="P" W ! F MOE=1:1:80 W "-" 53 I $E(IOST)'="P" D PAGE I SRSOUT G END 54 D ^SROAPRT1 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END 55 D ^SROAPRT2 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END 56 D OPTIMES^SROAPRT3 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END 57 D ^SROAPRT3 G:SRSOUT END I $Y+24>IOSL D PAGE I SRSOUT G END 58 D ^SROAPRT4 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END 59 D ^SROAPRT5 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END 60 D ^SROAPRT6 61 END Q:$D(SRABATCH) I 'SRSOUT,$E(IOST)'="P" W !!,"Press <RET> to continue " R X:DTIME 62 W:$E(IOST)="P" @IOF I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q 63 D ^%ZISC K SROETH,SRTN W @IOF D ^SRSKILL 64 Q 65 ; 66 WRAP ;Wrap multiple race entries so that wrapped line 67 ;does not break in the middle of a word 68 ; 69 S SROLNGTH=$L(SROLINE),E=29,SROWRAP="",SROLN="",SROLN1="",SROL="" 70 F I=1:29:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D 71 .F K=29:-1:1 I $E(SROLN(I),K)[" " D Q ;Break lines at space 72 ..S SROLN1(I)=$E(SROLN(I),1,K-1) 73 ..S SROWRAP=$E(SROLN(I),K+1,E) 74 .S E=E+29 75 ; 76 S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP="" 77 I $L(SROLN1(I))+$L(SROWRAP)>28 S SROLN1(I+1)=SROWRAP ;Last line 78 I $L(SROLN1(I))+$L(SROWRAP)'>28 S SROLN1(I)=SROLN1(I)_" "_SROWRAP 79 ; 80 ;Renumber the SROLN1 array to be in numeric order 81 S SRNUM=0,SRNUM1=1 82 F S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM="" D 83 .S SROL(SRNUM1)=SROLN1(SRNUM) 84 .S SRNUM1=SRNUM1+1 85 Q 86 ; 87 LOOP ; break procedures 88 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 89 Q 90 PAGE I $E(IOST)'="P" W !!,"Press <RET> to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q 91 I X["?" W !!,"Enter <RET> to continue printing the remaining pages of this assessment, or",!,"'^' to exit this option." G PAGE 92 W @IOF 93 HDR ; print heading 94 I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q 95 S SRPG=SRPG+1 96 I $Y'=0 W @IOF 97 I SRATYPE="C" W !,"VA CARDIAC RISK ASSESSMENT",?70,"PAGE "_SRPG 98 I SRATYPE="N" W !,"VA NON-CARDIAC RISK ASSESSMENT Assessment: "_SRTN,?69,"PAGE "_SRPG 99 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) 100 W ")",! F LINE=1:1:80 W "=" 101 W ! 102 Q 103 CODE ; print CPT Code 104 S X=$P(^SRF(SRTN,13,SR,0),"^",2) I X W " ("_$P($$CPT^ICPTCOD(X),"^",2)_")" 105 Q 1 SROAPAS ;BIR/MAM - PRINT A COMPLETE ASSESSMENT ; [ 04/13/04 2:50 PM ] 2 ;;3.0; Surgery ;**38,47,81,88,111,112,100,125,153**;24 Jun 93;Build 11 3 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)) 4 S SRA("OP")=^SRF(SRTN,"OP"),SRA("CON")=$G(^SRF(SRTN,"CON")) 5 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)) 6 I $P(SR("RA"),"^",2)="C" D ^SROAPCA G END 7 W:$E(IOST)'="P" @IOF D HDR G:SRSOUT END 8 W !,"Medical Center: "_SRSITE("SITE") 9 W !,"Age: ",?16,AGE S Y=SRSDATE D D^DIQ W ?40,"Operation Date: ",?59,$P(Y,"@") 10 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") 11 ; 12 D DEM^VADPT 13 ;Find patient's ethnicity 14 S SROETH="" 15 I $G(VADM(11)) S SROETH=$P(VADM(11,1),U,2) 16 I '$G(VADM(11)) S SROETH="UNANSWERED" 17 ; 18 ;Find all race entries and place into a string with commas inbetween 19 S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL="" 20 F S SRORC=$O(VADM(12,SRORC)) Q:SRORC="" Q:C=11 D 21 .I $G(VADM(12,SRORC)) S SRORACE(C)=$P(VADM(12,SRORC),U,2) 22 .I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C) 23 .I SROLINE="" S SROLINE=SRORACE(C) 24 .S C=C+1 25 ; 26 ;Find total length of 'race' string and wrap the text if necessary 27 I $L(SROLINE)=29!$L(SROLINE)<29 S SROL(N)=SROLINE,SRNUM1=2 28 I $L(SROLINE)>29 D WRAP 29 ; 30 W !,"Sex: ",?16,$P(VADM(5),"^",2),?40,"Ethnicity:",?51,SROETH 31 W !,?40,"Race:" 32 I $G(VADM(12)) F D=1:1:SRNUM1-1 D 33 .W:D=1 ?51,SROL(D) 34 .W:D'=1 !,?51,SROL(D) 35 I '$G(VADM(12)) W ?51,"UNANSWERED" 36 ; 37 K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1 38 ; 39 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: ",X 40 F J=1,2,3 S Y=$P($G(^SRF(SRTN,208.1)),"^",J) D 41 .I J'=3 X:Y ^DD("DD") S Z=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5) 42 .I J=3 S C=$P(^DD(130,454,0),"^",2) D Y^DIQ S Z=Y 43 .W !,"Observation "_$S(J=1:"Admission Date:",J=2:"Discharge Date:",1:"Treating Specialty:"),?47,Z 44 F J=14:1:17 S Y=$P($G(^SRF(SRTN,208)),"^",J) X ^DD("DD") S SRPTMODT(J)=Y 45 S (X,Z)=SRPTMODT(14) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Hospital Admission Date:",?47,Z 46 S (X,Z)=SRPTMODT(15) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Hospital Discharge Date:",?47,Z 47 S (X,Z)=SRPTMODT(16) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Admitted/Transferred to Surgical Service:",?47,Z 48 S (X,Z)=SRPTMODT(17) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Discharged/Transferred to Chronic Care:",?47,Z 49 W !,"In/Out-Patient Status:",?47,$S($P($G(^SRF(SRTN,0)),"^",12)="I":"INPATIENT",$P($G(^SRF(SRTN,0)),"^",12)="O":"OUTPATIENT",1:"") 50 I $E(IOST)="P" W ! F MOE=1:1:80 W "-" 51 I $E(IOST)'="P" D PAGE I SRSOUT G END 52 D ^SROAPRT1 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END 53 D ^SROAPRT2 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END 54 D OPTIMES^SROAPRT3 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END 55 D ^SROAPRT3 G:SRSOUT END I $Y+24>IOSL D PAGE I SRSOUT G END 56 D ^SROAPRT4 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END 57 D ^SROAPRT5 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END 58 D ^SROAPRT6 59 END Q:$D(SRABATCH) I 'SRSOUT,$E(IOST)'="P" W !!,"Press <RET> to continue " R X:DTIME 60 W:$E(IOST)="P" @IOF I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q 61 D ^%ZISC K SRTN W @IOF D ^SRSKILL 62 Q 63 ; 64 WRAP ;Wrap multiple race entries so that wrapped line 65 ;does not break in the middle of a word 66 ; 67 S SROLNGTH=$L(SROLINE),E=29,SROWRAP="",SROLN="",SROLN1="",SROL="" 68 F I=1:29:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D 69 .F K=29:-1:1 I $E(SROLN(I),K)[" " D Q ;Break lines at space 70 ..S SROLN1(I)=$E(SROLN(I),1,K-1) 71 ..S SROWRAP=$E(SROLN(I),K+1,E) 72 .S E=E+29 73 ; 74 S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP="" 75 I $L(SROLN1(I))+$L(SROWRAP)>28 S SROLN1(I+1)=SROWRAP ;Last line 76 I $L(SROLN1(I))+$L(SROWRAP)'>28 S SROLN1(I)=SROLN1(I)_" "_SROWRAP 77 ; 78 ;Renumber the SROLN1 array to be in numeric order 79 S SRNUM=0,SRNUM1=1 80 F S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM="" D 81 .S SROL(SRNUM1)=SROLN1(SRNUM) 82 .S SRNUM1=SRNUM1+1 83 Q 84 ; 85 LOOP ; break procedures 86 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 87 Q 88 PAGE I $E(IOST)'="P" W !!,"Press <RET> to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q 89 I X["?" W !!,"Enter <RET> to continue printing the remaining pages of this assessment, or",!,"'^' to exit this option." G PAGE 90 W @IOF 91 HDR ; print heading 92 I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q 93 S SRPG=SRPG+1 94 I $Y'=0 W @IOF 95 I SRATYPE="C" W !,"VA CARDIAC RISK ASSESSMENT",?70,"PAGE "_SRPG 96 I SRATYPE="N" W !,"VA NON-CARDIAC RISK ASSESSMENT Assessment: "_SRTN,?69,"PAGE "_SRPG 97 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) 98 W ")",! F LINE=1:1:80 W "=" 99 W ! 100 Q 101 CODE ; print CPT Code 102 S X=$P(^SRF(SRTN,13,SR,0),"^",2) I X W " ("_$P($$CPT^ICPTCOD(X),"^",2)_")" 103 Q
Note:
See TracChangeset
for help on using the changeset viewer.
