Changeset 623 for WorldVistAEHR/trunk/r/SURGERY-SR

Timestamp:

Dec 4, 2009, 12:11:15 AM (16 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

Location:

WorldVistAEHR/trunk/r/SURGERY-SR

Files:

• SROABCH.m (modified) (1 diff)
• SROACAR.m (modified) (1 diff)
• SROACMP.m (modified) (1 diff)
• SROACMP1.m (modified) (1 diff)
• SROACOM.m (modified) (1 diff)
• SROACOP.m (modified) (1 diff)
• SROACPM.m (modified) (1 diff)
• SROACPM1.m (modified) (1 diff)
• SROACR2.m (modified) (1 diff)
• SROALEC.m (modified) (1 diff)
• SROALM.m (modified) (1 diff)
• SROALOG.m (modified) (1 diff)
• SROALT.m (modified) (1 diff)
• SROALTP.m (modified) (1 diff)
• SROALTS.m (modified) (1 diff)
• SROALTSP.m (modified) (1 diff)
• SROAMEAS.m (modified) (1 diff)
• SROAMIS.m (modified) (1 diff)
• SROAOP.m (modified) (1 diff)
• SROAPAS.m (modified) (1 diff)
• SROAPCA1.m (modified) (1 diff)
• SROAPCA3.m (modified) (1 diff)
• SROAPM.m (modified) (1 diff)
• SROAPRE.m (modified) (1 diff)
• SROAPRE1.m (modified) (1 diff)
• SROAPRE2.m (modified) (1 diff)
• SROAPRT1.m (modified) (1 diff)
• SROAPRT2.m (modified) (1 diff)
• SROAPRT4.m (modified) (1 diff)
• SROAPRT5.m (modified) (1 diff)
• SROAPS1.m (modified) (1 diff)
• SROAPS2.m (modified) (1 diff)
• SROASS.m (modified) (1 diff)
• SROASSP.m (modified) (1 diff)
• SROATCM3.m (modified) (1 diff)
• SROATM1.m (modified) (1 diff)
• SROATMNO.m (modified) (1 diff)
• SROAUTL.m (modified) (1 diff)
• SROAUTL1.m (modified) (1 diff)
• SROAUTL3.m (modified) (1 diff)
• SROAUTL4.m (modified) (1 diff)
• SROAUTLC.m (modified) (1 diff)
• SROCODE.m (modified) (1 diff)
• SROESPR1.m (modified) (1 diff)
• SROGMTS.m (modified) (1 diff)
• SROMED.m (modified) (1 diff)
• SROWL.m (modified) (1 diff)
• SROXR4.m (modified) (1 diff)

WorldVistAEHR/trunk/r/SURGERY-SR/SROABCH.m

@@ -1 @@
-SROABCH ;BIR/MAM - BATCH PRINT ASSESSMENTS ;11/28/07
-        ;;3.0; Surgery ;**77,166**;24 Jun 93;Build 7
-DATE    ; get dates
-        S (SRSOUT,SRSP)=0 W @IOF,!!,"This report will print all completed or transmitted assessments that have a",!,"date of operation within the date range selected.",!
-        D DATE^SROUTL(.SRASTDT,.SRAENDT,.SRSOUT) G:SRSOUT END
-        D SPEC
-        W !!,"Depending on the date range entered, this report may be very long.  You should",!,"QUEUE this report to the selected printer.",!
-        K %ZIS,IOP,POP,IO("Q") S %ZIS="Q",%ZIS("A")="Print on which Device: " D ^%ZIS S:POP SRSOUT=1 G:POP END
-        I $D(IO("Q")) K IO("Q") S ZTRTN="EN^SROABCH",(ZTSAVE("SRSITE*"),ZTSAVE("SRASTDT"),ZTSAVE("SRAENDT"),ZTSAVE("SRSP"))="",ZTDESC="Batch Print Risk Assessments" D ^%ZTLOAD S SRSOUT=1 G END
-EN      ; entry when queued
-        S SRSOUT=0,SRABATCH=1
-        U IO S SRAENDT=SRAENDT+.9999,SDATE=SRASTDT-.0001 F  S SDATE=$O(^SRF("AC",SDATE)) Q:'SDATE!(SDATE>SRAENDT)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SDATE,SRTN)) Q:'SRTN!SRSOUT  D STUFF
-END     I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
-        D ^%ZISC K SRTN W @IOF D ^SRSKILL
-        Q
-STUFF   ;
-        I SRSP,$P(^SRF(SRTN,0),"^",4)'=SRSP Q
-        S DATE=$P(^SRF(SRTN,0),"^",9)
-        S SR("RA")=$G(^SRF(SRTN,"RA")),X=$P(SR("RA"),"^") I X'="T",X'="C" Q
-        I $P(SR("RA"),"^",6)'="Y" Q
-        K SRA D ^SROAPAS
-        Q
-SPEC    ; select specialty
-        W ! K DIR S DIR(0)="YA",DIR("A")="Print report for ALL surgical specialties ?  ",DIR("B")="YES"
-        S DIR("?",1)="Enter YES to print the report for all surgical specialties, or NO to",DIR("?")="print the report for a specific surgical specialty."
-        D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
-        I 'Y W ! K DIC S DIC("S")="I '$P(^(0),""^"",3)",DIC("A")="Print the Report for which Surgical Specialty: ",DIC=137.45,DIC(0)="QEAMZ" D ^DIC K DIC S:Y<0 SRSOUT=1 Q:Y<0  S SRSP=+Y
-        Q
+SROABCH ;B'HAM ISC/MAM - BATCH PRINT ASSESSMENTS ; [ 01/08/98   9:54 AM ]
+ ;;3.0; Surgery ;**77**;24 Jun 93
+DATE ; get dates
+ S SRSOUT=0 W @IOF,!!,"This report will print all completed or transmitted assessments that have a",!,"'date completed' within the date range selected.",!
+ D DATE^SROUTL(.SRASTDT,.SRAENDT,.SRSOUT) G:SRSOUT END
+ W !!,"Depending on the date range entered, this report may be very long.  You should",!,"QUEUE this report to the selected printer.",!
+ K %ZIS,IOP,POP,IO("Q") S %ZIS="Q",%ZIS("A")="Print on which Device: " D ^%ZIS S:POP SRSOUT=1 G:POP END
+ I $D(IO("Q")) K IO("Q") S ZTRTN="EN^SROABCH",(ZTSAVE("SRSITE*"),ZTSAVE("SRASTDT"),ZTSAVE("SRAENDT"))="",ZTDESC="Batch Print Risk Assessments" D ^%ZTLOAD S SRSOUT=1 G END
+EN ; entry when queued
+ S SRSOUT=0,SRABATCH=1
+ U IO S SRAENDT=SRAENDT+.9999,SDATE=SRASTDT-.0001 F  S SDATE=$O(^SRF("AC",SDATE)) Q:'SDATE!(SDATE>SRAENDT)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SDATE,SRTN)) Q:'SRTN!SRSOUT  D STUFF
+END I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
+ I $E(IOST)'="P",'SRSOUT W !!,"Press RETURN to continue  " R X:DTIME
+ D ^%ZISC K SRTN W @IOF D ^SRSKILL
+ Q
+STUFF S DATE=$P(^SRF(SRTN,0),"^",9)
+ S SR("RA")=$G(^SRF(SRTN,"RA")),X=$P(SR("RA"),"^") I X'="T",X'="C" Q
+ I $P(SR("RA"),"^",6)'="Y" Q
+ K SRA D ^SROAPAS
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROACAR.m

@@ -1 @@
-SROACAR ;BIR/MAM - OPEATIVE DATA ;12/03/07
-        ;;3.0; Surgery ;**38,71,93,95,100,125,142,153,166**;24 Jun 93;Build 7
-        I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
-        S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
-START   D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROACR1
-ASK     W !,"Select Cardiac Procedures Operative Information to Edit: " R X:DTIME I '$T!("^"[X) G END
-        S X=$S(X="a":"A",X="n":"N",1:X) I '$D(SRAO(X)),(X'?.N1":".N),(X'="A"),(X'="N") D HELP G:SRSOUT END G START
-        I X="A" S X="1:22"
-        I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>22)!(Y>Z) D HELP G:SRSOUT END G START
-        I X="N" D  G:SRSOUT END G START
-        .W ! K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to set all fields on this page to NO"
-        .D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
-        .I Y D NO2ALL
-        D HDR^SROAUTL
-        I X?.N1":".N D RANGE G START
-        I $D(SRAO(X)),+X=X S EMILY=X D  G START
-        .I $$LOCK^SROUTL(SRTN) W ! D ONE,UNLOCK^SROUTL(SRTN)
-        I $D(SRAO(X)) W ! S EMILY=X D  G START
-        .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
-END     I 'SRSOUT D ^SROACR2
-        W @IOF D ^SRSKILL
-        Q
-HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
-        W !!,"1. Enter 'A' to update all information.",!!,"2. Enter 'N' to set all fields on this page to NO."
-        W !!,"3. Enter a number (1-22) to update the information in that field.  (For",!,"   example, enter '9' to update Valve Repair.)"
-        W !!,"4. Enter a range of numbers (1-22) separated by a ':' to enter a range of",!,"   information.  (For example, enter '6:8' to enter Aortic Valve",!,"   Replacement, Mitral Valve Replacement, and Tricuspid Valve Replacement.)"
-        D RET
-        Q
-RANGE   ; range of numbers
-        I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
-        .W ! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
-        Q
-ONE     ; edit one item
-        ;I EMILY=16 D MIS^SROACR1 Q
-        I EMILY=22 D OPS Q
-        K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",2)_"T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1
-        I 'SRSOUT,EMILY=12!(EMILY=13) D OK
-        Q
-NO2ALL  ; set all fields to NO
-        N II K DR,DIE S DA=SRTN,DIE=130
-        F II=367,368,369,371,481,483,376,380,378,377,379,373,372,505,502 S DR=$S($D(DR):DR_";",1:"")_II_"////N"
-        F II=365,366,464,465,416 S DR=DR_";"_II_"////0"
-        S DR=DR_";"_370_"////5"_";"_512_"////N"
-        D ^DIE K DR
-        Q
-OK      N SRISCH,SRCPB S X=$G(^SRF(SRTN,206)),SRISCH=$P(X,"^",36),SRCPB=$P(X,"^",37)
-        I SRISCH,SRCPB,SRISCH>SRCPB W !!,"  ***  NOTE: Ischemic Time is greater than CPB Time!!  Please check.  ***",! D RET W !
-        Q
-RET     Q:SRSOUT  W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        Q
-OPS     ; enter other cardiac procedures, specify
-        S DIE=130,DA=SRTN,DR="502T" D ^DIE K DR Q:$D(Y)
-        I X'="Y" K ^SRF(SRTN,209.1) Q
-        S DIE=130,DA=SRTN,DR="484T" D ^DIE K DR
-        Q
+SROACAR ;BIR/MAM - OPEATIVE DATA ;03/29/06
+ ;;3.0; Surgery ;**38,71,93,95,100,125,142,153**;24 Jun 93;Build 11
+ I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
+ S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
+START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROACR1
+ASK W !,"Select Operative Information to Edit: " R X:DTIME I '$T!("^"[X) G END
+ S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START
+ I X="A" S X="1:22"
+ I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>22)!(Y>Z) D HELP G:SRSOUT END G START
+ D HDR^SROAUTL
+ I X?.N1":".N D RANGE G START
+ I $D(SRAO(X)),+X=X S EMILY=X D  G START
+ .I $$LOCK^SROUTL(SRTN) W ! D ONE,UNLOCK^SROUTL(SRTN)
+ I $D(SRAO(X)) W ! S EMILY=X D  G START
+ .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
+END I 'SRSOUT D ^SROACR2
+ W @IOF D ^SRSKILL
+ Q
+HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
+ W !!,"1. Enter 'A' to update all information.",!!,"2. Enter a number (1-22) to update the information in that field.  (For",!,"   example, enter '9' to update Valve Repair.)"
+ W !!,"3. Enter a range of numbers (1-22) separated by a ':' to enter a range of",!,"   information.  (For example, enter '6:8' to enter Aortic Valve",!,"   Replacement, Mitral Valve Replacement, and Tricuspid Valve Replacement.)"
+ D RET
+ Q
+RANGE ; range of numbers
+ I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
+ .W ! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
+ Q
+ONE ; edit one item
+ ;I EMILY=16 D MIS^SROACR1 Q
+ I EMILY=22 D OPS Q
+ K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",2)_"T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1
+ I 'SRSOUT,EMILY=12!(EMILY=13) D OK
+ Q
+OK N SRISCH,SRCPB S X=$G(^SRF(SRTN,206)),SRISCH=$P(X,"^",36),SRCPB=$P(X,"^",37)
+ I SRISCH,SRCPB,SRISCH>SRCPB W !!,"  ***  NOTE: Ischemic Time is greater than CPB Time!!  Please check.  ***",! D RET W !
+ Q
+RET Q:SRSOUT  W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
+ Q
+OPS ; enter other cardiac procedures, specify
+ S DIE=130,DA=SRTN,DR="502T" D ^DIE K DR Q:$D(Y)
+ I X'="Y" K ^SRF(SRTN,209.1) Q
+ S DIE=130,DA=SRTN,DR="484T" D ^DIE K DR
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROACMP.m

@@ -1 @@
-SROACMP ;BIR/ADM - M&M VERIFICATION REPORT ;12/19/07
-        ;;3.0; Surgery ;**47,50,127,143,166**;24 Jun 93;Build 7
-        S DFN=0 F  S DFN=$O(^TMP("SR",$J,DFN)) Q:'DFN  S SRTN=0 F  S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN  D UTIL
-        I SRFORM=1,SRSP D SS
-        D HDR^SROACMP1 I $D(^TMP("SR",$J)) S SRPAT="" F  S SRPAT=$O(^TMP("SRPAT",$J,SRPAT)) Q:SRPAT=""  D  Q:SRSOUT  S SRNM=0 I $Y+7<IOSL W !! F LINE=1:1:132 W "-"
-        .S SRX=^(SRPAT),SRNAME=">>> "_SRPAT_" ("_$P(SRX,"^",2)_")",SRDEATH=$P(SRX,"^",3)
-        .I SRDEATH S SRNAME=SRNAME_" - DIED "_$E(SRDEATH,4,5)_"/"_$E(SRDEATH,6,7)_"/"_$E(SRDEATH,2,3) S X=$E(SRDEATH,9,12) I X S X=X_"000",SRNAME=SRNAME_"@"_$E(X,1,2)_":"_$E(X,3,4)
-        .I $Y+9>IOSL D HDR^SROACMP1 I SRSOUT Q
-        .W !,SRNAME S SRNM=1,DFN=$P(SRX,"^"),SRTN=0 F  S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN!SRSOUT  D SET
-        G:SRSOUT END^SROACMP1 I '$D(^TMP("SR",$J)) W !!,"There are no perioperative occurrences or deaths recorded for ",$S(SRFORM=1:"surgeries performed in the selected date range.",1:"completed assessments not yet transmitted.")
-        D HDR2^SROACMP1,END^SROACMP1
-        Q
-UTIL    ; list all cases within 30 days prior to postop occurrence and/or 90 days prior to death
-        S SRPOST=0 F  S SRPOST=$O(^SRF(SRTN,16,SRPOST)) Q:'SRPOST  S SRDATE=$E($P(^SRF(SRTN,16,SRPOST,0),"^",7),1,7) I SRDATE S SRBACK=-30 D PRIOR
-        D DEM^VADPT S ^TMP("SRPAT",$J,VADM(1))=DFN_"^"_VA("PID")_"^"_$P(VADM(6),"^")
-        S SRDATE=$P(VADM(6),"^") I SRDATE S SRBACK=-90 D PRIOR
-        Q
-PRIOR   ; list cases in 30 days before this occurrence or 90 days before death
-        S X1=SRDATE,X2=SRBACK D C^%DTC S SDATE=X,SRCASE=0 F  S SRCASE=$O(^SRF("B",DFN,SRCASE)) Q:'SRCASE  I '$D(^TMP("SR",$J,DFN,SRCASE)) D
-        .I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN)
-        .I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN)
-        .I '$P($G(^SRF(SRCASE,.2)),"^",12)!$P($G(^SRF(SRCASE,30)),"^")!($P($G(^SRF(SRCASE,"NON")),"^")="Y") Q
-        .S SRX=$E($P(^SRF(SRCASE,0),"^",9),1,7) I SRX<SDATE!(SRX>SRDATE) Q
-        .S ^TMP("SR",$J,DFN,SRCASE)=$P(^SRF(SRCASE,0),"^",4)
-        Q
-SET     ; set variables to print
-        N SRSEP,SRICDN
-        S SR(0)=^SRF(SRTN,0),(SRD,Y)=$P(SR(0),"^",9),SRSDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),Y=$P(SR(0),"^",4) I Y S SRSS=$P(^SRO(137.45,Y,0),"^")
-OPS     S SROPER=$P(^SRF(SRTN,"OP"),"^")
-        K SRP,Z S:$L(SROPER)<121 SRP(1)=SROPER I $L(SROPER)>120 S SROPER=SROPER_"  " F M=1:1 D OPER Q:Z=""
-        N SRL S SRL=109 D CPTS^SROAUTL0 I SRPROC(1)="" S SRPROC(1)="NOT ENTERED"
-        S SRCHK=0 I SRDEATH S X1=SRDEATH,X2=-90 D C^%DTC I SRD<X S SRCHK=1,SRREL="N/A"
-        I 'SRCHK S X=$P($G(^SRF(SRTN,.4)),"^",7),SRREL=$S(SRDEATH="":"N/A",X="U":"NO",X="R":"YES",1:"NOT ENTERED")
-COMP    ; perioperative occurrences
-        K SRC S (SRFG,SRIC)=0 F  S SRIC=$O(^SRF(SRTN,10,SRIC)) Q:SRIC=""  S SRFG=SRFG+1,SRO=^SRF(SRTN,10,SRIC,0),SRICD=$P(SRO,"^",3) D
-        .S Y=SRD D DATE S SRCAT=$P(SRO,"^",2) Q:'SRCAT  S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_" "_SRY
-        .I SRICD S SRICDN=$$ICDDX^ICDCODE(SRICD,$P($G(^SRF(SRTN,0)),"^",9)),SRFG=SRFG+1,SRC(SRFG)="  ICD: "_$P(SRICDN,"^",2)_"  "_$P(SRICDN,"^",4)
-        .S $P(SRC(SRFG),"^",2)="10;"_SRIC
-        S SRPC=0 F  S SRPC=$O(^SRF(SRTN,16,SRPC)) Q:SRPC=""  S SRFG=SRFG+1,SRO=^SRF(SRTN,16,SRPC,0),SRICD=$P(SRO,"^",3) D
-        .S Y=$E($P(SRO,"^",7),1,7) D DATE S SRCAT=$P(SRO,"^",2) Q:'SRCAT
-        .S SRSEP="" I SRCAT=3 S X=$P(SRO,"^",4) I X S SRSEP="/"_$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")_" "
-        .S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_"  ** POSTOP ** "_SRSEP_SRY
-        .I $P(SRO,"^",2)=3 S X=$P(SRO,"^",4) I X S SRSEP=$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")
-        .I SRICD S SRICDN=$$ICDDX^ICDCODE(SRICD,$P($G(^SRF(SRTN,0)),"^",9)),SRFG=SRFG+1,SRC(SRFG)="  ICD: "_$P(SRICDN,"^",2)_"  "_$P(SRICDN,"^",4)
-        .S $P(SRC(SRFG),"^",2)="16;"_SRPC
-RA      ; risk assessment type and status
-        S SRA=$G(^SRF(SRTN,"RA")),SRSTATUS=$P(SRA,"^"),SRTYPE=$P(SRA,"^",2),SRYN=$P(SRA,"^",6),SRE=$P(SRA,"^",7) D
-        .I SRTYPE="" S SRTYPE="NON-ASSESSED" Q
-        .S SRTYPE=$S(SRTYPE="C":"CARDIAC",SRYN="Y":"NON-CARDIAC",1:"EXCLUDED")
-        S SRSTATUS=$S(SRSTATUS="C":"COMPLETE",SRSTATUS="T":"TRANSMITTED",SRSTATUS="I":"INCOMPLETE",1:"N/A")
-PRINT   ; print case information
-        I $Y+8>IOSL D HDR^SROACMP1 I SRSOUT Q
-        W !!,SRSDATE,?11,SRTN,?25,SRSS,?80,SRTYPE,?98,SRSTATUS,?116,SRREL
-        W !,?11,SRP(1) W:$D(SRP(2)) !,?11,SRP(2)
-        W !,?11,"CPT Codes: ",SRPROC(1) W:$D(SRPROC(2)) !,?24,SRPROC(2)
-        W !,?11,"Occurrences: " I '$D(SRC(1)) S SRC(1)="NONE ENTERED"
-        S SRI=0 F  S SRI=$O(SRC(SRI)) Q:'SRI  D
-        .W:SRI>1 ! W ?24,$P(SRC(SRI),"^")
-        .I $Y+6>IOSL D HDR^SROACMP1 W ! I SRSOUT Q
-        .D TEXT D:SRT WP
-        S SRNDTH=$P($G(^SRF(SRTN,205)),"^",3)
-        I SRDEATH!SRNDTH D  K SRNDTH
-        .I SRNDTH W !,?11,"Date of Death: "_$E(SRNDTH,4,5)_"/"_$E(SRNDTH,6,7)_"/"_$E(SRNDTH,2,3) S X=$E(SRNDTH,9,12) I X S X=X_"000" W "@"_$E(X,1,2)_":"_$E(X,3,4)
-        .W !,?11,"Review of Death Comments: " D
-        ..I '$O(^SRF(SRTN,47,0)) W "NONE ENTERED" Q
-        ..D DWP
-        Q
-OPER    ; break procedure if greater than 48 characters
-        S SRP(M)="" F LOOP=1:1 S Z=$P(SROPER," ") Q:Z=""  Q:$L(SRP(M))+$L(Z)'<49  S SRP(M)=SRP(M)_Z_" ",SROPER=$P(SROPER," ",2,200)
-        Q
-DATE    S SRY=$S(Y:" ("_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_")",1:" (NO DATE)")
-        Q
-SS      ; set up ^TMP for selected specialties
-        K ^TMP("SRSP",$J) S SRQ=0,SRNAME="" F  S SRNAME=$O(^TMP("SRPAT",$J,SRNAME)) Q:SRNAME=""  S DFN=$P(^TMP("SRPAT",$J,SRNAME),"^"),(SRQ,SRTN)=0 D
-        .F  S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN  D  Q:SRQ
-        ..S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I $D(SRSP(Y)) S ^TMP("SRSP",$J,DFN)="",SRQ=1 Q
-        S SRNAME="" F  S SRNAME=$O(^TMP("SRPAT",$J,SRNAME)) Q:SRNAME=""  S DFN=$P(^TMP("SRPAT",$J,SRNAME),"^") I '$D(^TMP("SRSP",$J,DFN)) K ^TMP("SR",$J,DFN),^TMP("SRPAT",$J,SRNAME)
-        Q
-WP      ; print occurrence comments
-        N CM K ^UTILITY($J,"W") S CM=0 F  S CM=$O(^SRF(SRTN,SRY,SRZ,1,CM)) Q:'CM  S X=^SRF(SRTN,SRY,SRZ,1,CM,0),DIWL=30,DIWR=132 D ^DIWP
-        I $D(^UTILITY($J,"W")) F J=1:1:^UTILITY($J,"W",30) D
-        .I $Y+7>IOSL D HDR^SROACMP1 W ! I SRSOUT Q
-        .W !,?30,^UTILITY($J,"W",30,J,0)
-        Q
-TEXT    ; check for occurrence comments
-        S SRT=0,SRX=$P(SRC(SRI),"^",2) I SRX'="" S SRY=$P(SRX,";"),SRZ=$P(SRX,";",2) I $O(^SRF(SRTN,SRY,SRZ,1,0)) S SRT=1 W !,?26,">>> Comments:"
-        Q
-DWP     ; print review of death comments
-        N CM K ^UTILITY($J,"W") S CM=0 F  S CM=$O(^SRF(SRTN,47,CM)) Q:'CM  S X=^SRF(SRTN,47,CM,0),DIWL=38,DIWR=132 D ^DIWP
-        I $D(^UTILITY($J,"W")) F J=1:1:^UTILITY($J,"W",38) D
-        .I $Y+7>IOSL D HDR^SROACMP1 W ! I SRSOUT Q
-        .W ?38,^UTILITY($J,"W",38,J,0),!
-        Q
+SROACMP ;BIR/ADM-M&M Verification Report ;02/20/05
+ ;;3.0; Surgery ;**47,50,127,143**;24 Jun 93
+ S DFN=0 F  S DFN=$O(^TMP("SR",$J,DFN)) Q:'DFN  S SRTN=0 F  S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN  D UTIL
+ I SRFORM=1,SRSP D SS
+ D HDR^SROACMP1 I $D(^TMP("SR",$J)) S SRPAT="" F  S SRPAT=$O(^TMP("SRPAT",$J,SRPAT)) Q:SRPAT=""  D  Q:SRSOUT  S SRNM=0 I $Y+7<IOSL W !! F LINE=1:1:132 W "-"
+ .S SRX=^(SRPAT),SRNAME=">>> "_SRPAT_" ("_$P(SRX,"^",2)_")",SRDEATH=$P(SRX,"^",3)
+ .I SRDEATH S SRNAME=SRNAME_" - DIED "_$E(SRDEATH,4,5)_"/"_$E(SRDEATH,6,7)_"/"_$E(SRDEATH,2,3) S X=$E(SRDEATH,9,12) I X S X=X_"000",SRNAME=SRNAME_"@"_$E(X,1,2)_":"_$E(X,3,4)
+ .I $Y+9>IOSL D HDR^SROACMP1 I SRSOUT Q
+ .W !,SRNAME S SRNM=1,DFN=$P(SRX,"^"),SRTN=0 F  S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN!SRSOUT  D SET
+ G:SRSOUT END^SROACMP1 I '$D(^TMP("SR",$J)) W !!,"There are no perioperative occurrences or deaths recorded for ",$S(SRFORM=1:"surgeries performed in the selected date range.",1:"completed assessments not yet transmitted.")
+ D HDR2^SROACMP1,END^SROACMP1
+ Q
+UTIL ; list all cases within 90 days prior to postop occurrence and/or death
+ S SRPOST=0 F  S SRPOST=$O(^SRF(SRTN,16,SRPOST)) Q:'SRPOST  S SRDATE=$E($P(^SRF(SRTN,16,SRPOST,0),"^",7),1,7) I SRDATE S SRBACK=-30 D PRIOR
+ D DEM^VADPT S ^TMP("SRPAT",$J,VADM(1))=DFN_"^"_VA("PID")_"^"_$P(VADM(6),"^")
+ S SRDATE=$P(VADM(6),"^") I SRDATE S SRBACK=-90 D PRIOR
+ Q
+PRIOR ; list cases in 30 days before this occurrence or 90 days before death
+ S X1=SRDATE,X2=SRBACK D C^%DTC S SDATE=X,SRCASE=0 F  S SRCASE=$O(^SRF("B",DFN,SRCASE)) Q:'SRCASE  I '$D(^TMP("SR",$J,DFN,SRCASE)) D
+ .I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN)
+ .I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN)
+ .I '$P($G(^SRF(SRCASE,.2)),"^",12)!$P($G(^SRF(SRCASE,30)),"^")!($P($G(^SRF(SRCASE,"NON")),"^")="Y") Q
+ .S SRX=$E($P(^SRF(SRCASE,0),"^",9),1,7) I SRX<SDATE!(SRX>SRDATE) Q
+ .S ^TMP("SR",$J,DFN,SRCASE)=$P(^SRF(SRCASE,0),"^",4)
+ Q
+SET ; set variables to print
+ N SRSEP
+ S SR(0)=^SRF(SRTN,0),(SRD,Y)=$P(SR(0),"^",9),SRSDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),Y=$P(SR(0),"^",4) I Y S SRSS=$E($P($P(^SRO(137.45,Y,0),"^")," "),1,13),SRSS=$P(SRSS," "),SRSS=$P(SRSS,"(")
+OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F  S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER=""  D OTHER
+ K SRP,Z S:$L(SROPER)<40 SRP(1)=SROPER I $L(SROPER)>39 S SROPER=SROPER_"  " F M=1:1 D OPER Q:Z=""
+ S SRCHK=0 I SRDEATH S X1=SRDEATH,X2=-90 D C^%DTC I SRD<X S SRCHK=1,SRREL="N/A"
+ I 'SRCHK S X=$P($G(^SRF(SRTN,.4)),"^",7),SRREL=$S(SRDEATH="":"N/A",X="U":"NO",X="R":"YES",1:" ?")
+COMP ; perioperative occurrences
+ K SRC S (SRFG,SRIC)=0 F  S SRIC=$O(^SRF(SRTN,10,SRIC)) Q:SRIC=""  S SRFG=SRFG+1,SRO=^SRF(SRTN,10,SRIC,0),SRICD=$P(SRO,"^",3) D
+ .S Y=SRD D DATE S SRCAT=$P(SRO,"^",2) Q:'SRCAT  S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_" "_SRY
+ .I SRICD S SRICDN=$$ICDDX^ICDCODE(SRICD,$P($G(^SRF(SRTN,0)),"^",9)),SRFG=SRFG+1,SRC(SRFG)="  ICD: "_$P(SRICDN,"^",2)_"  "_$P(SRICDN,"^",4)
+ S SRPC=0 F  S SRPC=$O(^SRF(SRTN,16,SRPC)) Q:SRPC=""  S SRFG=SRFG+1,SRO=^SRF(SRTN,16,SRPC,0),SRICD=$P(SRO,"^",3) D
+ .S Y=$E($P(SRO,"^",7),1,7) D DATE S SRCAT=$P(SRO,"^",2) Q:'SRCAT
+ .S SRSEP="" I SRCAT=3 S X=$P(SRO,"^",4) I X S SRSEP="/"_$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")_" "
+ .S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_" * "_SRSEP_SRY
+ .I $P(SRO,"^",2)=3 S X=$P(SRO,"^",4) I X S SRSEP=$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")
+ .I SRICD S SRICDN=$$ICDDX^ICDCODE(SRICD,$P($G(^SRF(SRTN,0)),"^",9)),SRFG=SRFG+1,SRC(SRFG)="  ICD: "_$P(SRICDN,"^",2)_"  "_$P(SRICDN,"^",4)
+RA ; risk assessment type and status
+ S SRA=$G(^SRF(SRTN,"RA")),SRSTATUS=$P(SRA,"^"),SRTYPE=$P(SRA,"^",2),SRYN=$P(SRA,"^",6),SRE=$P(SRA,"^",7) D
+ .I SRTYPE="" S SRA="NON-ASSESSED" Q
+ .S SRA=$S(SRTYPE="C":"CARDIAC",SRYN="Y":"NON-CARD",1:"EXCLUDED")_"/"_SRSTATUS
+PRINT ; print case information
+ I $Y+8>IOSL D HDR^SROACMP1 I SRSOUT Q
+ W !!,SRSDATE,?11,SRSS,?25,SRP(1),?69,SRREL W:$D(SRC(1)) ?75,SRC(1) W ?120,SRA
+ F SRC=2:1 Q:'$D(SRP(SRC))&'$D(SRC(SRC))  D  Q:SRSOUT
+ .I $Y+6>IOSL D HDR^SROACMP1 I SRSOUT Q
+ .W ! W:$D(SRP(SRC)) ?25,SRP(SRC) W:$D(SRC(SRC)) ?75,SRC(SRC)
+ Q
+OTHER ; other operations
+ S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
+ I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
+ S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
+ Q
+OPER ; break procedure if greater than 40 characters
+ S SRP(M)="" F LOOP=1:1 S Z=$P(SROPER," ") Q:Z=""  Q:$L(SRP(M))+$L(Z)'<40  S SRP(M)=SRP(M)_Z_" ",SROPER=$P(SROPER," ",2,200)
+ Q
+DATE S SRY=$S(Y:" ("_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_")",1:" (NO DATE)")
+ Q
+SS ; set up ^TMP for selected specialties
+ K ^TMP("SRSP",$J) S SRQ=0,SRNAME="" F  S SRNAME=$O(^TMP("SRPAT",$J,SRNAME)) Q:SRNAME=""  S DFN=$P(^TMP("SRPAT",$J,SRNAME),"^"),(SRQ,SRTN)=0 D
+ .F  S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN  D  Q:SRQ
+ ..S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I $D(SRSP(Y)) S ^TMP("SRSP",$J,DFN)="",SRQ=1 Q
+ S SRNAME="" F  S SRNAME=$O(^TMP("SRPAT",$J,SRNAME)) Q:SRNAME=""  S DFN=$P(^TMP("SRPAT",$J,SRNAME),"^") I '$D(^TMP("SRSP",$J,DFN)) K ^TMP("SR",$J,DFN),^TMP("SRPAT",$J,SRNAME)
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROACMP1.m

@@ -1 @@
-SROACMP1        ;BIR/ADM - M&M VERIFICATION REPORT (CONT'D) ;11/26/07
-        ;;3.0; Surgery ;**47,68,77,50,166**;24 Jun 93;Build 7
-EN      ; entry point
-        S (SRSOUT,SRSP)=0,SRINST=$P($$SITE^SROVAR,"^",2) W @IOF,!,?28,"M&M Verification Report"
-        W !!,"The M&M Verification Report is a tool to assist in the review of occurrences"
-        W !,"and their assignment to operations and in the review of death unrelated or",!,"related assignments to operations."
-        W !!,"The full report includes all patients who had operations within the selected"
-        W !,"date range who experienced intraoperative occurrences, postoperative"
-        W !,"occurrences or death within 90 days of surgery. The pre-transmission report"
-        W !,"is similar but includes only operations with completed risk assessments that"
-        W !,"have not yet transmitted to the national database.",!
-        D SEL G:SRSOUT END I SRFORM=2 G SPEC
-        D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END
-SPEC    I $D(^XUSEC("SROCHIEF",+DUZ)) N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,U),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,U,2))
-        W !! K DIR S DIR("A")="Do you want to print this report for all Surgical Specialties ",DIR("B")="YES",DIR(0)="Y"
-        S DIR("?",1)="Enter RETURN to print this report for all surgical specialties, or 'NO' to",DIR("?")="select a specific specialty."
-        D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END
-        I 'Y D SP I SRSOUT G END
-DEV     K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Print the Report on which Device: ",%ZIS="QM" W !!,"This report is designed to use a 132 column format.",! D ^%ZIS I POP S SRSOUT=1 G END
-        I $D(IO("Q")) K IO("Q") S ZTDESC="M&M Verification Report",ZTRTN="BEG^SROACMP1",(ZTSAVE("SRFORM"),ZTSAVE("SRINST"),ZTSAVE("SRSP*"),ZTSAVE("SRINSTP"))="" S:SRFORM=1 (ZTSAVE("SRED"),ZTSAVE("SRSD"))="" D ^%ZTLOAD G END
-BEG     U IO S (SRHDR,SRNM,SRSOUT,SRSS)=0,PAGE=1,Y=DT X ^DD("DD") S SRPRINT="Report Generated: "_Y K ^TMP("SR",$J),^TMP("SRPAT",$J)
-        N SRFRTO I SRFORM=1 D
-        .S Y=SRSD X ^DD("DD") S SRFRTO="From: "_Y S Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_"  To: "_Y
-        .S SRSDT=SRSD-.0001,SREDT=SRED+.9999 F  S SRSDT=$O(^SRF("AC",SRSDT)) Q:SRSDT>SREDT!'SRSDT!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSDT,SRTN)) Q:'SRTN!SRSOUT  D CASE
-        I SRFORM=2 F SRASS="C","N" S DFN=0 F  S DFN=$O(^SRF("ARS",SRASS,"C",DFN)) Q:'DFN!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("ARS",SRASS,"C",DFN,SRTN)) Q:'SRTN!SRSOUT  D CASE
-        G:SRSOUT END G ^SROACMP
-CASE    ; examine case
-        Q:'$D(^SRF(SRTN,0))
-        I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN)
-        I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN)
-        I SRFORM=2,SRSP S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I '$D(SRSP(Y)) Q
-        I '$P($G(^SRF(SRTN,.2)),"^",12)!$P($G(^SRF(SRTN,30)),"^")!($P($G(^SRF(SRTN,"NON")),"^")="Y") Q
-        S DFN=$P(^SRF(SRTN,0),"^") I $O(^SRF(SRTN,10,0))!$O(^SRF(SRTN,16,0)) S ^TMP("SR",$J,DFN,SRTN)=$P(^SRF(SRTN,0),"^",4) Q
-        S SRDEATH=$P($G(^DPT(DFN,.35)),"^") I SRDEATH S X1=$P(^SRF(SRTN,0),"^",9),X2=90 D C^%DTC S SRDAY=X I SRDEATH'>SRDAY S ^TMP("SR",$J,DFN,SRTN)=$P(^SRF(SRTN,0),"^",4)
-        Q
-END     Q:'$D(SRSOUT)  W @IOF K ^TMP("SRPAT",$J),^TMP("SRSP",$J) I $D(ZTQUEUED) K ^TMP("SR",$J) Q:$G(ZTSTOP)  S ZTREQ="@" Q
-        D ^%ZISC,^SRSKILL K SRTN W @IOF
-        Q
-SEL     ; select report version
-        K DIR S DIR("A",1)="Print which report ?",DIR("A",2)=" ",DIR("A",3)="1. Full report for selected date range.",DIR("A",4)="2. Pre-transmission report for completed risk assessments."
-        S DIR("A",5)=" ",DIR("A")="Enter selection (1 or 2): ",DIR("B")=1,DIR("?")="Please enter the number (1 or 2) matching your choice of report",DIR(0)="NA^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
-        S SRFORM=Y
-        Q
-SP      W !! S SRSP=1 K DIC S DIC("S")="I '$P(^(0),""^"",3)",DIC=137.45,DIC(0)="QEAMZ",DIC("A")="Print the report for which Specialty ?  " D ^DIC I Y<0 S SRSOUT=1 Q
-        S SRCT=+Y,SRSP(SRCT)=+Y
-MORE    ; ask for more surgical specialties
-        K DIC S DIC("S")="I '$P(^(0),""^"",3)",DIC=137.45,DIC(0)="QEAMZ",DIC("A")="Select an Additional Specialty:  " D ^DIC I Y>0 S SRCT=+Y,SRSP(SRCT)=+Y G MORE
-        Q
-HDR     ; print heading
-        I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
-        I SRHDR D HDR2 Q:SRSOUT  S SRHDR=0
-        W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,?124,"Page ",PAGE,!,?54,"M&M Verification Report"
-        W:SRFORM=1 !,?(132-$L(SRFRTO)\2),SRFRTO
-        W:SRFORM=2 !,?41,"PRE-TRANSMISSION REPORT FOR COMPLETED ASSESSMENTS"
-        W ?100,"REVIEWED BY:",!,?(132-$L(SRPRINT)\2),SRPRINT,?100,"DATE REVIEWED:",!
-        W !,"OP DATE",?11,"CASE #",?25,"SURGICAL SPECIALTY",?80,"ASSESSMENT TYPE   STATUS",?116,"DEATH RELATED",!,?11,"PRINCIPAL PROCEDURE",! F LINE=1:1:132 W "="
-        I SRNM W !,SRNAME_"   * * Continued from previous page * *"
-        S PAGE=PAGE+1,SRHDR=1 I '$D(^TMP("SR",$J))
-        Q
-HDR2    ; more heading
-        ;I $Y+6<IOSL F I=$Y:1:IOSL-5 W !
-FOOT    ; print footer
-        ;W ! F LINE=1:1:IOM W "-"
-        ;W !,"Occurrences(s): '*' Denotes Postop Occurrence",! F LINE=1:1:IOM W "-"
-        S SRHDR=0 I $E(IOST)'="P" W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S SRSOUT=1
-        Q
+SROACMP1 ;BIR/ADM-M&M Verification Report (cont'd) ; [ 09/22/98  11:22 AM ]
+ ;;3.0; Surgery ;**47,68,77,50**;24 Jun 93
+EN ; entry point
+ S (SRSOUT,SRSP)=0,SRINST=$P($$SITE^SROVAR,"^",2) W @IOF,!,?28,"M&M Verification Report",!!,"The M&M Verification Report is a tool to assist in the review of occurrences"
+ W !,"and their assignments to operations and in the review of death unrelated or",!,"related assignments to operations.  Two varieties of this report are available."
+ W !,"The first variety provides a report of all patients who had operations within",!,"the selected date range who experienced introperative occurrences,",!,"postoperative occurrences, or death within 90 days of surgery.  The second"
+ W !,"variety provides a similar report for all risk assessed operations that are in",!,"a completed state but have not yet transmitted to the national database.",!
+ D SEL G:SRSOUT END I SRFORM=2 G SPEC
+ D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END
+SPEC I $D(^XUSEC("SROCHIEF",+DUZ)) N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,U),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,U,2))
+ W !! K DIR S DIR("A")="Do you want to print this report for all Surgical Specialties ",DIR("B")="YES",DIR(0)="Y"
+ S DIR("?",1)="Enter RETURN to print this report for all surgical specialties, or 'NO' to",DIR("?")="select a specific specialty."
+ D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END
+ I 'Y D SP I SRSOUT G END
+DEV K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Print the Report on which Device: ",%ZIS="QM" W !!,"This report is designed to use a 132 column format.",! D ^%ZIS I POP S SRSOUT=1 G END
+ I $D(IO("Q")) K IO("Q") S ZTDESC="M&M Verification Report",ZTRTN="BEG^SROACMP1",(ZTSAVE("SRFORM"),ZTSAVE("SRINST"),ZTSAVE("SRSP*"),ZTSAVE("SRINSTP"))="" S:SRFORM=1 (ZTSAVE("SRED"),ZTSAVE("SRSD"))="" D ^%ZTLOAD G END
+BEG U IO S (SRHDR,SRNM,SRSOUT,SRSS)=0,PAGE=1,Y=DT X ^DD("DD") S SRPRINT="Report Generated: "_Y K ^TMP("SR",$J),^TMP("SRPAT",$J)
+ N SRFRTO I SRFORM=1 D
+ .S Y=SRSD X ^DD("DD") S SRFRTO="From: "_Y S Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_"  To: "_Y
+ .S SRSDT=SRSD-.0001,SREDT=SRED+.9999 F  S SRSDT=$O(^SRF("AC",SRSDT)) Q:SRSDT>SREDT!'SRSDT!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSDT,SRTN)) Q:'SRTN!SRSOUT  D CASE
+ I SRFORM=2 F SRASS="C","N" S DFN=0 F  S DFN=$O(^SRF("ARS",SRASS,"C",DFN)) Q:'DFN!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("ARS",SRASS,"C",DFN,SRTN)) Q:'SRTN!SRSOUT  D CASE
+ G:SRSOUT END G ^SROACMP
+CASE ; examine case
+ Q:'$D(^SRF(SRTN,0))
+ I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN)
+ I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN)
+ I SRFORM=2,SRSP S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I '$D(SRSP(Y)) Q
+ I '$P($G(^SRF(SRTN,.2)),"^",12)!$P($G(^SRF(SRTN,30)),"^")!($P($G(^SRF(SRTN,"NON")),"^")="Y") Q
+ S DFN=$P(^SRF(SRTN,0),"^") I $O(^SRF(SRTN,10,0))!$O(^SRF(SRTN,16,0)) S ^TMP("SR",$J,DFN,SRTN)=$P(^SRF(SRTN,0),"^",4) Q
+ S SRDEATH=$P($G(^DPT(DFN,.35)),"^") I SRDEATH S X1=$P(^SRF(SRTN,0),"^",9),X2=90 D C^%DTC S SRDAY=X I SRDEATH'>SRDAY S ^TMP("SR",$J,DFN,SRTN)=$P(^SRF(SRTN,0),"^",4)
+ Q
+END Q:'$D(SRSOUT)  W @IOF K ^TMP("SRPAT",$J),^TMP("SRSP",$J) I $D(ZTQUEUED) K ^TMP("SR",$J) Q:$G(ZTSTOP)  S ZTREQ="@" Q
+ D ^%ZISC,^SRSKILL K SRTN W @IOF
+ Q
+SEL ; select report version
+ K DIR S DIR("A",1)="Print which variety of the report ?",DIR("A",2)=" ",DIR("A",3)="1. Print full report for selected date range.",DIR("A",4)="2. Print pre-transmission report for completed risk assessments."
+ S DIR("A",5)=" ",DIR("A")="Enter selection (1 or 2): ",DIR("B")=1,DIR("?")="Please enter the number (1 or 2) matching your choice of report",DIR(0)="NA^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
+ S SRFORM=Y
+ Q
+SP W !! S SRSP=1 K DIC S DIC("S")="I '$P(^(0),""^"",3)",DIC=137.45,DIC(0)="QEAMZ",DIC("A")="Print the report for which Specialty ?  " D ^DIC I Y<0 S SRSOUT=1 Q
+ S SRCT=+Y,SRSP(SRCT)=+Y
+MORE ; ask for more surgical specialties
+ K DIC S DIC("S")="I '$P(^(0),""^"",3)",DIC=137.45,DIC(0)="QEAMZ",DIC("A")="Select an Additional Specialty:  " D ^DIC I Y>0 S SRCT=+Y,SRSP(SRCT)=+Y G MORE
+ Q
+HDR ; print heading
+ I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
+ I SRHDR D HDR2 Q:SRSOUT  S SRHDR=0
+ W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,?124,"Page ",PAGE,!,?54,"M&M Verification Report"
+ W:SRFORM=1 !,?(132-$L(SRFRTO)\2),SRFRTO
+ W:SRFORM=2 !,?41,"Pre-Transmission Report for Completed Assessments"
+ W ?100,"Reviewed By:",!,?(132-$L(SRPRINT)\2),SRPRINT,?100,"Date Reviewed:",!
+ W !,?68,"Death",?120,"Assessment",!,"Op Date",?11,"Specialty",?25,"Procedure(s)",?67,"Related  Occurrence(s) - (Date)",?120,"Type/Status",! F LINE=1:1:132 W "="
+ I SRNM W !,SRNAME_"   * * Continued from previous page * *"
+ S PAGE=PAGE+1,SRHDR=1 I '$D(^TMP("SR",$J))
+ Q
+HDR2 ; more heading
+ I $Y+5<IOSL F I=$Y:1:IOSL-5 W !
+FOOT ; print footer
+ W ! F LINE=1:1:IOM W "-"
+ W !,"Occurrences(s): '*' Denotes Postop Occurrence",?69,"Assessment Status - I:Incomplete, C:Complete, T:Transmitted",! F LINE=1:1:IOM W "-"
+ S SRHDR=0 I $E(IOST)'="P" W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S SRSOUT=1
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROACOM.m

@@ -1 @@
-SROACOM ;BIR/MAM - COMPLETE ASSESSMENT ;12/19/07
-        ;;3.0; Surgery ;**38,55,63,65,88,93,95,102,100,125,134,142,160,166**;24 Jun 93;Build 7
-        I '$D(SRTN) Q
-        I $P($G(^SRF(SRTN,"RA")),"^",2)="C" G ^SROACOM1
-        S (SRSFLG,SRSOUT,SROVER)=0,SRA=$G(^SRF(SRTN,"RA")),Y=$P(SRA,"^") I Y'="I" W !!,"This assessment has a "_$S(Y="C":"'COMPLETE'",1:"'TRANSMITTED'")_" status.",!!,"No action taken." G END
-        I $P(SRA,"^",2)="N",$P(SRA,"^",6)="Y" D CHK^SROAUTL
-        I $P(SRA,"^",2)="N",$P(SRA,"^",6)="N" D CHK^SROAUTL3
-        S SRFLD="" I $O(SRX(SRFLD))'="" D LIST
-YEP     I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !!,?6,"The coding for Procedure and Diagnosis is not complete."
-        W ! S SRFLD="" K DIR S DIR("A")="Are you sure you want to complete this assessment ? ",DIR("B")=$S($O(SRX(SRFLD)):"NO",1:"YES"),DIR(0)="YA"
-        S DIR("?",1)="Enter YES to complete this assessment, or enter NO to leave the status",DIR("?")="unchanged." D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END
-        I 'Y W !!,"No action taken." G END
-        I $$LOCK^SROUTL(SRTN) D COMPLT Q
-        E  W !!,"No action taken." G END
-        Q
-COMPLT  W !!,"Updating the current status to 'COMPLETE'..." K DR,DIE S DA=SRTN,DIE=130,DR="235///C" D ^DIE K STATUS
-        I $P(SRA,"^",5)="" K DR,DIE S DA=SRTN,DIE=130,DR="272///"_DT D ^DIE K STATUS
-        I $P(SRA,"^",2)="C" K DA,DIE,DIK,DR S DIK="^SRF(",DIK(1)=".232^AQ",DA=SRTN D EN1^DIK K DA,DIK
-        D UNLOCK^SROUTL(SRTN)
-PRINT   W !!,"Do you want to print the completed assessment ?  YES//  " R SRYN:DTIME I '$T!(SRYN["^") S SRSOUT=1 Q
-        S SRYN=$E(SRYN) S:SRYN="" SRYN="Y" I "Nn"[SRYN S SRSOUT=1 Q
-        I "Yy"'[SRYN W !!,"Enter <RET> to print the completed assessment, or 'NO' to return to the menu." G PRINT
-        W ! K %ZIS,IO("Q"),POP S %ZIS("A")="Print the Completed Assessment on which Device: ",%ZIS="Q" D ^%ZIS I POP S SRSOUT=1 Q
-        I $D(IO("Q")) K IO("Q") S ZTDESC="Completed Surgery Risk Assessment",(ZTSAVE("SRSITE*"),ZTSAVE("SRTN"))="",ZTRTN="EN^SROACOM" D ^%ZTLOAD S SRSOUT=1 G END
-        D EN,END
-        Q
-EN      U IO S SRABATCH=1 D ^SROAPAS Q
-END     I 'SRSOUT,$E(IOST)'="P" D RET
-        W @IOF I $E(IOST)="P" D ^%ZISC W @IOF
-        D ^SRSKILL K SRMD,SRMD1,SRSFLG
-        Q
-LIST    W @IOF,!,"This assessment is missing the following items:",! S SRZ="",SRCNT=1
-        F  S SRZ=$O(SRX(SRZ)) Q:SRZ=""  D:$Y+5>IOSL RET Q:SRSOUT  W !,?5,$J(SRCNT,2)_". "_$P(SRX(SRZ),"^") S SRCNT=SRCNT+1
-        S SRSOUT=0 W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to enter the missing items at this time",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
-        Q:'Y  I $$LOCK^SROUTL(SRTN) D PRT,UNLOCK^SROUTL(SRTN)
-        Q
-PRT     S SRSOUT=0,(SRMD,SRMD1)="",SRCNT=0 F  S SRMD=$O(SRX(SRMD)) Q:SRMD=""  S SRMD1=$P(SRX(SRMD),"^",2) D  Q:$G(SRSFLG)
-        .I $E(SRMD,1,10)="ANESTHESIA" D ANES Q
-        .I $E(SRMD,1,6)="POSTOP"!($E(SRMD,1,6)="SEPSIS") D POST^SROCMPS Q
-        .K DR,DIE S DA=SRTN,DIE=130,DR=$S($G(SRMD1):SRMD1,1:SRMD)_"T" D ^DIE K DR I $D(Y) S SRSFLG=1
-        S:'$G(SRSOUT) SRSOUT=0
-        Q
-ANES    K DR,DIE,DA S DA=SRTN,DR=.37,DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE S:$D(Y) SRSFLG=1 K DR
-        Q
-RET     W !! K DIR S DIR(0)="E" D ^DIR K DIR W @IOF I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        Q
-PAGE    I $E(IOST)'="P" D RET Q
-        W @IOF,!!!
-        Q
+SROACOM ;BIR/MAM - COMPLETE ASSESSMENT ;02/08/07
+ ;;3.0; Surgery ;**38,55,63,65,88,93,95,102,100,125,134,142,160**;24 Jun 93;Build 7
+ I '$D(SRTN) Q
+ S (SRSFLG,SRSOUT,SROVER)=0,SRA=$G(^SRF(SRTN,"RA")),Y=$P(SRA,"^") I Y'="I" W !!,"This assessment has a "_$S(Y="C":"'COMPLETE'",1:"'TRANSMITTED'")_" status.",!!,"No action taken." G END
+ I $P(SRA,"^",2)="N",$P(SRA,"^",6)="Y" D CHK^SROAUTL
+ I $P(SRA,"^",2)="N",$P(SRA,"^",6)="N" D CHK^SROAUTL3
+ I $P(SRA,"^",2)="C" D CHK^SROAUTLC
+ S SRFLD="" I $O(SRX(SRFLD))'="" D LIST
+ I $P(SRA,"^",2)="C" D CHCK G:SRSOUT END
+YEP I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !!,?6,"The coding for Procedure and Diagnosis is not complete."
+ W ! S SRFLD="" K DIR S DIR("A")="Are you sure you want to complete this assessment ? ",DIR("B")=$S($O(SRX(SRFLD)):"NO",1:"YES"),DIR(0)="YA"
+ S DIR("?",1)="Enter YES to complete this assessment, or enter NO to leave the status",DIR("?")="unchanged." D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END
+ I 'Y W !!,"No action taken." G END
+ I $$LOCK^SROUTL(SRTN) D COMPLT Q
+ E  W !!,"No action taken." G END
+ Q
+COMPLT W !!,"Updating the current status to 'COMPLETE'..." K DR,DIE S DA=SRTN,DIE=130,DR="235///C" D ^DIE K STATUS
+ I $P(SRA,"^",5)="" K DR,DIE S DA=SRTN,DIE=130,DR="272///"_DT D ^DIE K STATUS
+ I $P(SRA,"^",2)="C" K DA,DIE,DIK,DR S DIK="^SRF(",DIK(1)=".232^AQ",DA=SRTN D EN1^DIK K DA,DIK
+ D UNLOCK^SROUTL(SRTN)
+PRINT W !!,"Do you want to print the completed assessment ?  YES//  " R SRYN:DTIME I '$T!(SRYN["^") S SRSOUT=1 Q
+ S SRYN=$E(SRYN) S:SRYN="" SRYN="Y" I "Nn"[SRYN S SRSOUT=1 Q
+ I "Yy"'[SRYN W !!,"Enter <RET> to print the completed assessment, or 'NO' to return to the menu." G PRINT
+ W ! K %ZIS,IO("Q"),POP S %ZIS("A")="Print the Completed Assessment on which Device: ",%ZIS="Q" D ^%ZIS I POP S SRSOUT=1 Q
+ I $D(IO("Q")) K IO("Q") S ZTDESC="Completed Surgery Risk Assessment",(ZTSAVE("SRSITE*"),ZTSAVE("SRTN"))="",ZTRTN="EN^SROACOM" D ^%ZTLOAD S SRSOUT=1 G END
+ D EN,END
+ Q
+EN U IO S SRABATCH=1 D ^SROAPAS Q
+END I 'SRSOUT,$E(IOST)'="P" D RET
+ W @IOF I $E(IOST)="P" D ^%ZISC W @IOF
+ D ^SRSKILL K SRSFLG
+ Q
+LIST W @IOF,!,"This assessment is missing the following items:",! S SRZ="",SRCNT=1
+ ;I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !,?6,"The coding for Procedure and Diagnosis is",!,?6,"not complete.",!
+ F  S SRZ=$O(SRX(SRZ)) Q:SRZ=""  D:$Y+5>IOSL RET Q:SRSOUT  W !,?5,$J(SRCNT,2)_". "_$P(SRX(SRZ),"^") S SRCNT=SRCNT+1
+ S SRSOUT=0 W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to enter the missing items at this time",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
+ Q:'Y  I $$LOCK^SROUTL(SRTN) D PRT,UNLOCK^SROUTL(SRTN)
+ Q
+PRT S SRSOUT=0,(SRMD,SRMD1)="",SRCNT=0 F  S SRMD=$O(SRX(SRMD)) Q:SRMD=""  S SRMD1=$P(SRX(SRMD),"^",2) D  Q:$G(SRSFLG)
+ .I $E(SRMD,1,10)="ANESTHESIA" D ANES Q
+ .I $E(SRMD,1,6)="POSTOP"!($E(SRMD,1,6)="SEPSIS") D POST^SROCMPS Q
+ .I SRMD=240 D FUNCT Q
+ .I SRMD=492 D FUNCTI^SROAPRE Q
+ .I SRMD=485 W @IOF,! D PRIOR^SROACL2 K DR,DIE S DA=SRTN,DR="485///"_$S(X="@":"@",1:$P(Y,"^")),DIE=130 D ^DIE K DR S:$D(Y) SRSFLG=1 Q
+ .K DR,DIE S DA=SRTN,DIE=130,DR=$S($G(SRMD1):SRMD1,1:SRMD)_"T" D ^DIE K DR I $D(Y) S SRSFLG=1
+ S:'$G(SRSOUT) SRSOUT=0
+ Q
+FUNCT I $P($G(^SRF(SRTN,"RA")),"^",2)="C" D FUNCT^SROACLN Q
+ D FUNCTJ^SROAPRE
+ Q
+ANES K DR,DIE,DA S DA=SRTN,DR=.37,DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE S:$D(Y) SRSFLG=1 K DR
+ Q
+CHCK ; cardiac checks added by SR*3*93
+ N SRADM,SRDIS,SRISCH,SRCPB,SRRET S SRRET=0,X=$G(^SRF(SRTN,208)),SRADM=$P(X,"^",14),SRDIS=$P(X,"^",15),X=$G(^SRF(SRTN,206)),SRISCH=$P(X,"^",36),SRCPB=$P(X,"^",37)
+ I SRADM,SRDIS,SRADM'<SRDIS W !!,"  ***  NOTE: Discharge Date precedes Admission Date!!  Please check.  ***" S SRRET=1,SRX(418)=""
+ I SRISCH,SRCPB,SRISCH>SRCPB W !!,"  ***  NOTE: Ischemic Time is greater than CPB Time!!  Please check.  ***",! S SRRET=1,SRX(450)=""
+ I SRRET W ! K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DTOUT)!$D(DUOUT) SRSOUT=1 W !
+ Q
+RET W !! K DIR S DIR(0)="E" D ^DIR K DIR W @IOF I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
+ Q
+PAGE I $E(IOST)'="P" D RET Q
+ W @IOF,!!!
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROACOP.m

@@ -1 @@
-SROACOP ;BIR/MAM - CARDIAC OPERATIVE RISK SUMMARY ;12/20/07
-        ;;3.0; Surgery ;**38,47,71,88,95,107,100,125,142,153,160,166**;24 Jun 93;Build 7
-        I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
-        N SRCSTAT S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
-START   D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO
-        F I=206,206.1,208 S SRA(I)=$G(^SRF(SRTN,I))
-        I $P(SRA(206),"^",41)="" K DA,DIE,DR S DA=SRTN,DIE=130,DR="472////N" D ^DIE K DA,DIE,DR S SRA(206)=$G(^SRF(SRTN,206))
-        S Y=$P($G(^SRF(SRTN,1.1)),"^",3),C=$P(^DD(130,1.13,0),"^",2) D:Y'="" Y^DIQ S SRAO(2)=Y_"^1.13"
-        S SRAO(1)=$P(SRA(206),"^",31)_"^364",SRAO(3)=$P(SRA(208),"^",12)_"^414"
-        S (X,Y)=$P(SRA(206),"^",32) D:Y DT S SRAO("1A")=X_"^364.1"
-        S Y=$P(SRAO(3),"^") I Y'="" S C=$P(^DD(130,414,0),"^",2) D Y^DIQ S $P(SRAO(3),"^")=Y
-        S Y=$P(SRA(208),"^",13) D DT S SRAO("3A")=X_"^414.1"
-        S Y=$P($G(^SRF(SRTN,.2)),"^",2) D DT S SRAO(4)=X_"^.22"
-        S Y=$P($G(^SRF(SRTN,.2)),"^",3) D DT S SRAO(5)=X_"^.23"
-        S SRAO(6)=SRA(206.1)_"^430"
-        S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,SRTN,10)),"^"):"",1:"Not ")_"Complete <<"
-        S SRPAGE="PAGE: 1" D HDR^SROAUTL S SRAO(7)=""
-        S (X,X1)=$P(SRAO(1),"^"),X=$S(X?1.3N:X_"%",1:X) W !," 1. Physician's Preoperative Estimate of Operative Mortality: "_X
-        S X=$P(SRAO("1A"),"^") I X1'=""!(X'="") W !,?3," A. Date/Time Collected:    "_X
-        W !," 2. ASA Classification:",?31,$P(SRAO(2),"^"),!," 3. Surgical Priority:",?31,$P(SRAO(3),"^")
-        S X=$P(SRAO("3A"),"^") I X'="" W !,?3," A. Date/Time Collected:    "_X
-        W !," 4. Date/Time Operation Began:",?31,$P(SRAO(4),"^"),!," 5. Date/Time Operation Ended:",?31,$P(SRAO(5),"^")
-        W !," 6. Preoperative Risk Factors: "
-        I $P(SRAO(6),"^")'="" S SRQ=0 S X=$P(SRAO(6),"^") W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D
-        .I X'[" " W ?25,X Q
-        .S I=0,LINE=1 F  S SRL=$S(LINE=1:48,1:80) D  Q:SRQ
-        ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q
-        ..S J=SRL-I,Y=$E(X,J),I=I+1 I Y=" " W $E(X,1,J-1),! S X=$E(X,J+1,Z),Z=$L(X),I=0,LINE=LINE+1 I Z<SRL W X S SRQ=1 Q
-        N SRPROC,SRL S SRL=49 D CPTS^SROAUTL0 W !," 7. CPT Codes (view only):"
-        F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
-        W ! D CHCK
-        W !! F MOE=1:1:80 W "-"
-ASK     W !,"Select Operative Risk Summary Information to Edit: " R X:DTIME I '$T!("^"[X) G END
-        S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START
-        I X="A" S X="1:7"
-        I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>7)!(Y>Z) D HELP G:SRSOUT END G START
-        I X'=7 D HDR^SROAUTL
-        I X?.N1":".N D RANGE S SROERR=SRTN D ^SROERR0 G START
-        I $D(SRAO(X))!(X=6) S EMILY=X D  S SROERR=SRTN D ^SROERR0 G START
-        .I $$LOCK^SROUTL(SRTN) W !! D ONE,UNLOCK^SROUTL(SRTN)
-END     I '$D(SREQST) W @IOF D ^SRSKILL
-        Q
-DT      I 'Y S X="" Q
-        X ^DD("DD") S X=$P(Y,"@")_" "_$P(Y,"@",2)
-        Q
-HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
-        W !!,"1. Enter 'A' to update all information.",!!,"2. Enter the corresponding number to update the information in a particular",!,"   field.  (For example, enter '3' to update Surgical Priority)"
-        W !!,"3. Enter two numbers separated by a ':' to enter a range of information.",!,"   (For example, enter '1:2' to update Physician's Preoperative Estimate of",!,"   Mortality and ASA Classification.)"
-        W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1
-        Q
-RANGE   ; range of numbers
-        I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
-        .W !! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
-        Q
-ONE     ; edit one item
-        I EMILY=7 D DISP^SROAUTL0 Q
-        K DR,DIE S DA=SRTN,DIE=130,DR=$P(SRAO(EMILY),"^",2)
-        S DR=DR_"T",DIE=130 S DR=DR_$S(EMILY=3:";414.1T",1:"") D ^DIE K DR I $D(Y) S SRSOUT=1
-        I EMILY=1 D
-        .I $P(^SRF(SRTN,206),"^",31)="NS" S $P(^SRF(SRTN,206),"^",32)="NS" Q
-        .S DR="364.1T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1
-        Q
-RET     Q:SRSOUT  W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
-        Q
-NOW     ; update date/time of estimate of mortality
-        N X D NOW^%DTC S $P(^SRF(DA,206),"^",32)=$E(%,1,12)
-        Q
-KNOW    ; delete date/time of estimate of mortality
-        S $P(^SRF(DA,206),"^",32)=""
-        Q
-YN      ; store answer
-        S SHEMP=$S(NYUK="NS":"Unknown",NYUK="N":"NO",NYUK="Y":"YES",1:"")
-        Q
-CHCK    ;compare dates
-        N SRINO,SRSP,SREM
-        S SRSP=$P($G(^SRF(SRTN,208)),"^",13),SRINO=$P($G(^SRF(SRTN,.2)),"^",10),SREM=$P($G(^SRF(SRTN,206)),"^",32)
-        I SRSP'="",SRINO'="",SRSP'<SRINO W !!,"*** NOTE: D/Time of Surgical Priority should be < the D/Time Patient in OR.***"
-        I SREM'="",SRINO'="",SREM'<SRINO W !!,"*** NOTE: D/Time of Estimate of Mortality should be < the D/Time PT in OR. ***"
-        Q
+SROACOP ;BIR/MAM - CARDIAC OPERATIVE RISK SUMMARY ;02/14/07
+ ;;3.0; Surgery ;**38,47,71,88,95,107,100,125,142,153,160**;24 Jun 93;Build 7
+ I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
+ N SRCSTAT S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
+START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO
+ F I=206,206.1,208 S SRA(I)=$G(^SRF(SRTN,I))
+ I $P(SRA(206),"^",41)="" K DA,DIE,DR S DA=SRTN,DIE=130,DR="472////N" D ^DIE K DA,DIE,DR S SRA(206)=$G(^SRF(SRTN,206))
+ S Y=$P($G(^SRF(SRTN,1.1)),"^",3),C=$P(^DD(130,1.13,0),"^",2) D:Y'="" Y^DIQ S SRAO(2)=Y_"^1.13"
+ S SRAO(1)=$P(SRA(206),"^",31)_"^364",SRAO(3)=$P(SRA(208),"^",12)_"^414"
+ S Y=$P(SRA(206),"^",32) D DT S SRAO("1A")=X_"^364.1"
+ S Y=$P(SRAO(3),"^") I Y'="" S C=$P(^DD(130,414,0),"^",2) D Y^DIQ S $P(SRAO(3),"^")=Y
+ S Y=$P(SRA(208),"^",13) D DT S SRAO("3A")=X_"^414.1"
+ S Y=$P($G(^SRF(SRTN,.2)),"^",2) D DT S SRAO(4)=X_"^.22"
+ S Y=$P($G(^SRF(SRTN,.2)),"^",3) D DT S SRAO(5)=X_"^.23"
+ S SRAO(6)=SRA(206.1)_"^430"
+ S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,SRTN,10)),"^"):"",1:"Not ")_"Complete <<"
+ S SRPAGE="PAGE: 1" D HDR^SROAUTL S SRAO(7)=""
+ S X=$P(SRAO(1),"^"),X=$S(X?1.3N:X_"%",1:X) W !," 1. Physician's Preoperative Estimate of Operative Mortality: "_X
+ S X=$P(SRAO("1A"),"^") I X'="" W !,?3," A. Date/Time Collected:    "_X
+ W !," 2. ASA Classification:",?31,$P(SRAO(2),"^"),!," 3. Surgical Priority:",?31,$P(SRAO(3),"^")
+ S X=$P(SRAO("3A"),"^") I X'="" W !,?3," A. Date/Time Collected:    "_X
+ W !," 4. Date/Time Operation Began:",?31,$P(SRAO(4),"^"),!," 5. Date/Time Operation Ended:",?31,$P(SRAO(5),"^")
+ W !," 6. Preoperative Risk Factors: "
+ I $P(SRAO(6),"^")'="" S SRQ=0 S X=$P(SRAO(6),"^") W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D
+ .I X'[" " W ?25,X Q
+ .S I=0,LINE=1 F  S SRL=$S(LINE=1:48,1:80) D  Q:SRQ
+ ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q
+ ..S J=SRL-I,Y=$E(X,J),I=I+1 I Y=" " W $E(X,1,J-1),! S X=$E(X,J+1,Z),Z=$L(X),I=0,LINE=LINE+1 I Z<SRL W X S SRQ=1 Q
+ N SRPROC,SRL S SRL=49 D CPTS^SROAUTL0 W !," 7. CPT Codes (view only):"
+ F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
+ W ! D CHCK
+ W !! F MOE=1:1:80 W "-"
+ASK W !,"Select Operative Risk Summary Information to Edit: " R X:DTIME I '$T!("^"[X) G END
+ S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START
+ I X="A" S X="1:7"
+ I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>7)!(Y>Z) D HELP G:SRSOUT END G START
+ I X'=7 D HDR^SROAUTL
+ I X?.N1":".N D RANGE S SROERR=SRTN D ^SROERR0 G START
+ I $D(SRAO(X))!(X=6) S EMILY=X D  S SROERR=SRTN D ^SROERR0 G START
+ .I $$LOCK^SROUTL(SRTN) W !! D ONE,UNLOCK^SROUTL(SRTN)
+END I '$D(SREQST) W @IOF D ^SRSKILL
+ Q
+DT I 'Y S X="" Q
+ X ^DD("DD") S X=$P(Y,"@")_" "_$P(Y,"@",2)
+ Q
+HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
+ W !!,"1. Enter 'A' to update all information.",!!,"2. Enter the corresponding number to update the information in a particular",!,"   field.  (For example, enter '3' to update Surgical Priority)"
+ W !!,"3. Enter two numbers separated by a ':' to enter a range of information.",!,"   (For example, enter '1:2' to update Physician's Preoperative Estimate of",!,"   Mortality and ASA Classification.)"
+ W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1
+ Q
+RANGE ; range of numbers
+ I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
+ .W !! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
+ Q
+ONE ; edit one item
+ I EMILY=7 D DISP^SROAUTL0 Q
+ K DR,DIE S DA=SRTN,DIE=130,DR=$P(SRAO(EMILY),"^",2)
+ S DR=DR_"T",DIE=130 S DR=DR_$S(EMILY=1:";364.1T",EMILY=3:";414.1T",1:"") D ^DIE K DR I $D(Y) S SRSOUT=1
+ Q
+RET Q:SRSOUT  W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+ Q
+NOW ; update date/time of estimate of mortality
+ N X D NOW^%DTC S $P(^SRF(DA,206),"^",32)=$E(%,1,12)
+ Q
+KNOW ; delete date/time of estimate of mortality
+ S $P(^SRF(DA,206),"^",32)=""
+ Q
+YN ; store answer
+ S SHEMP=$S(NYUK="NS":"Unknown",NYUK="N":"NO",NYUK="Y":"YES",1:"")
+ Q
+CHCK ;compare dates
+ N SRINO,SRSP,SREM
+ S SRSP=$P($G(^SRF(SRTN,208)),"^",13),SRINO=$P($G(^SRF(SRTN,.2)),"^",10),SREM=$P($G(^SRF(SRTN,206)),"^",32)
+ I SRSP'="",SRINO'="",SRSP'<SRINO W !!,"*** NOTE: D/Time of Surgical Priority should be < the D/Time Patient in OR.***"
+ I SREM'="",SRINO'="",SREM'<SRINO W !!,"*** NOTE: D/Time of Estimate of Mortality should be < the D/Time PT in OR. ***"
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROACPM.m

@@ -1 @@
-SROACPM ;BIR/ADM - CARDIAC RESOURCE INFO ;12/04/07
-        ;;3.0; Surgery ;**71,93,95,99,100,125,142,160,164,166**;24 Jun 93;Build 7
-        ;
-        ; Reference to ^DGPM("APTT1" supported by DBIA #565
-        ;
-        I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
-        S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
-START   G:SRSOUT END D HDR^SROAUTL
-        S DIR("A",1)="Enter/Edit Patient Resource Data",DIR("A",2)=" ",DIR("A",3)="1. Capture Information from PIMS Records",DIR("A",4)="2. Enter, Edit, or Review Information",DIR("A",5)=" "
-        S DIR("?",1)="Enter '1' if you want to capture patient information from PIMS",DIR("?",2)="records.  Enter '2' if you want to enter, edit, or review patient",DIR("?")="other information on this screen."
-        S DIR("A")="Select Number",DIR(0)="NO^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END
-        I Y=1 D PIMS G START
-EDIT    N DAYS,HOURS,MINS
-        S:$P(^SRF(SRTN,206),"^",41)="" $P(^SRF(SRTN,206),"^",41)="N"
-        S SRR=0 S SRPAGE="PAGE: 1" D HDR^SROAUTL K DR S SRQ=0,(DR,SRDR)="418;419;440;.205;.232;470;471;473;472;431;442;513;515"
-        K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="IE",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
-        K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
-        .D TR,GET
-        .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
-        .W:M>1 ! W $J(SRZ,2)_". "_$P(Z,"^")_": " D EXT
-        D CHCK W ! F K=1:1:80 W "-"
-        D SEL G:SRR=1 EDIT
-        G START
-        Q
-CHCK    ; compare admission and discharge dates to each other
-        N SRADM,SRDIS,SROUT,SRDICU,SREXT
-        S SROUT=SRY(130,SRTN,.232,"I"),SRDICU=SRY(130,SRTN,471,"I"),SREXT=SRY(130,SRTN,470,"I")
-        S SRADM=SRY(130,SRTN,418,"I"),SRDIS=SRY(130,SRTN,419,"I") W !
-        I SRADM,SRDIS,SRADM'<SRDIS W !,"*** NOTE: Discharge Date precedes Admission Date!!  Please check. ***"
-        I SREXT,SROUT,SREXT'>SROUT W !,"*** NOTE: D/Time Pt Extubated should be later than the D/Time Pt Out of OR. ***"
-        I SREXT,SRDICU,SREXT'<SRDICU W !,"*** NOTE: D/Time Pt Extubated should be < the ICU Discharge D/Time. ***"
-        I SRDICU,SREXT,SRDICU'>SREXT W !,"*** NOTE: D/Time Discharged from ICU should be > the Extubation D/Time. ***"
-        I SRDICU,SRDIS,SRDICU>SRDIS W !,"*** NOTE: D/Time Discharged from ICU should be <= the Hospital Discharge D/Time*"
-        Q
-EXT     I SRFLD=440&(SREXT="NS") S SREXT=SREXT_"-"_$S(SREXT="NS":"No Study",1:SREXT)
-        I SRFLD=470,(SREXT="NS"!(SREXT="RI")) S SREXT=SREXT_"-"_$S(SREXT="NS":"Unable to determine",SREXT="RI":"Remains intubated at 30 days",1:SREXT)
-        I SRFLD=470,$G(SRY(130,SRTN,470,"I")) D  Q
-        .S X=$$FMDIFF^XLFDT(SRY(130,SRTN,470,"I"),SRY(130,SRTN,.232,"I"),2) W ?39,SREXT,!,?10,"Postop Intubation Hrs: "_$FN((X/3600),"+",1)
-        I SRFLD=471,(SREXT="NS"!(SREXT="RI")) S SREXT=SREXT_"-"_$S(SREXT="NS":"Unable to determine",SREXT="RI":"Remains in ICU at 30 days",1:SREXT)
-        I $L(SREXT)<41 W ?39,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q
-        I SRFLD=431 D
-        .I $L(SREXT)<52 W ?28,SREXT Q 
-        .N I,J,X,Y S X=SREXT F  D  W:$L(X) ! I $L(X)<52!($L(X)>51&(X'[" ")) W ?28,X Q
-        ..F I=0:1:50 S J=51-I,Y=$E(X,J) I Y=" " W ?28,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q
-        Q
-SEL     S SRSOUT=0 W !!,"Select Resource Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
-        Q:X=""  S:X="a" X="A" I '$D(SRFLG),'$D(SRZ(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q
-        I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRZ)!(Y>Z) D HELP S SRR=1 Q
-        I X="A" S X="1:"_SRZ
-        I X?1.2N1":"1.2N D RANGE S SRR=1 Q
-        I $D(SRZ(X)),+X=X S EMILY=X D  S SRR=1
-        .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
-        Q
-PIMS    ; get update from PIMS records
-        W ! K DIR S DIR("A")="Are you sure you want to retrieve information from PIMS records ? ",DIR("B")="YES",DIR(0)="YOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
-        W ! D WAIT^DICD D ^SROAPIMS
-        Q
-HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
-        W !!,"1. Enter 'A' to update all items.",!!,"2. Enter a number (1-"_SRZ_") to update an individual item.  (For example,",!,"   enter '1' to update "_$P(SRZ(1),"^")_".)"
-        W !!,"3. Enter a range of numbers (1-"_SRZ_") separated by a ':' to enter a range",!,"   of items.  (For example, enter '1:4' to update items 1, 2, 3 and 4.)",!
-        I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",!
-PRESS   W ! K DIR S DIR("A")="Press the return key to continue or '^' to exit: ",DIR(0)="FOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        Q
-RANGE   ; range of numbers
-        I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
-        .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
-        Q
-ONE     ; edit one item
-        I EMILY=7 D LIST
-        I EMILY'=7 K DR,DA,DIE S DR=$P(SRZ(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1
-        I 'SRSOUT,EMILY=1!(EMILY=2) D OK
-        I EMILY=12 D CHK
-        Q
-OK      ; compare admission date to discharge date
-        N SRADM,SRDIS S X=$G(^SRF(SRTN,208)),SRADM=$P(X,"^",14),SRDIS=$P(X,"^",15)
-        I SRADM,SRDIS,SRADM'<SRDIS W !!,"  ***  NOTE: Discharge Date precedes Admission Date!!  Please check.  ***",! D PRESS W !
-        Q
-CHK     ; compare date OF OPERATION to CT Surgery Consult Date
-        S X1=$P(^SRF(SRTN,0),"^",9),X2=$P($G(^SRF(SRTN,209)),"^",15) D ^%DTC I X'>30 S $P(^SRF(SRTN,209),"^",16)="N" Q
-        S $P(^SRF(SRTN,209),"^",16)="" K DR,DA,DIE S DR=$P(SRZ(13),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(13),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1
-        Q
-LIST    ; display list of patient movements
-        N CNT,SRADM,SRLOC,SRMOVE,SRMVMT,SRN,SRT,SRTYPE,SRZ,SRY
-        S DFN=$P(^SRF(SRTN,0),"^"),SRZ=$P($G(^SRF(SRTN,.2)),"^",12)
-        S SRADM=0 D ADM
-        S CNT=0 F  Q:'SRZ  D:SRZ MVMT
-        ;Q:CNT=0
-        W !!,?5,"To identify the date and time the patient was discharged from intensive",!,?5,"care following surgery, see the following list of patient movements"
-        W !,?5,"that occurred during the inpatient stay associated with this surgery.",!
-        S (CNT,SRN)=0 F  S CNT=$O(SRMVMT(CNT)) Q:'CNT  S X=SRMVMT(CNT),SRT=$P(X,"^",2),SRN=SRN+1 W !,$J(SRN,3)_".",?5,$P($P(X,"^"),":",1,2),?25,$P(X,"^",3),?37,$S(SRT=3:"From",1:"To")_": "_$P(X,"^",4)
-        I '$O(SRMVMT(0)) W !,?5,">> No postoperative patient movements were found for this patient."
-        W ! E  K DIR S DIR("A")="Select patient movement from list",DIR(0)="NO^1:"_SRN_":0" D ^DIR K DIR I Y D  Q
-        .S SRT=$P($P(SRMVMT(Y),"^"),":",1,2) K DA,DIE,DR S DA=SRTN,DIE=130,DR="471///"_SRT D ^DIE K DA,DIE,DR
-        K DA,DIE,DR S DA=SRTN,DIE=130,DR="471T" D ^DIE K DA,DIE,DR
-        Q
-MVMT    S VAIP("D")=SRZ D IN5^VADPT S SRY=$P(VAIP(3),"^")
-        I SRY S CNT=CNT+1 D
-        .S SRMOVE=$P(VAIP(3),"^",2),SRTYPE=$P(VAIP(2),"^",1,2),SRLOC=$P(VAIP(5),"^",2)
-        .S SRMVMT(CNT)=SRMOVE_"^"_SRTYPE_"^"_SRLOC
-        I 'SRY S SRZ="" Q
-        I VAIP(1)=VAIP(17) S SRZ="" Q
-        I VAIP(16),VAIP(16)=VAIP(17) S CNT=CNT+1,SRMOVE=$P(VAIP(16,1),"^",2),SRTYPE=$P(VAIP(16,2),"^",1,2),SRLOC=$P(VAIP(16,4),"^",2),SRMVMT(CNT)=SRMOVE_"^"_SRTYPE_"^"_SRLOC,SRZ="" Q
-        S SRZ=$P(VAIP(16,1),"^")
-        Q
-ADM     N SR24 S VAIP("D")=SRZ D IN5^VADPT
-        I 'VAIP(13) S X1=SRZ,X2=1 D C^%DTC S SR24=X,SRDT=$O(^DGPM("APTT1",DFN,SRZ)) Q:'SRDT!(SRDT>SR24)  S VAIP("D")=SRDT D IN5^VADPT I 'VAIP(13) S SRZ="" Q
-        I VAIP(13) S SRZ=$P(VAIP(13,1),"^")+.000001
-        Q
-TR      S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
-        Q
-GET     S X=$T(@J)
-        Q
-END     W @IOF D ^SRSKILL
-        Q
-DAH     ;;418^Hospital Admission Date
-DAI     ;;419^Hospital Discharge Date
-DDJ     ;;440^Cardiac Catheterization Date
-PBJE    ;;.205^Time Patient In OR
-PBCB    ;;.232^Time Patient Out OR
-DGJ     ;;470^Date/Time Patient Extubated
-DGA     ;;471^Date/Time Discharged from ICU
-DDB     ;;442^Employment Status Preoperatively
-DCA     ;;431^Resource Data Comments
-DGC     ;;473^Homeless
-DGB     ;;472^Surg Performed at Non-VA Facility
-EAC     ;;513^CT Surgery Consult Date
-EAE     ;;515^Cause for Delay for Surgery
+SROACPM ;BIR/ADM - CARDIAC RESOURCE INFO ;08/23/07
+ ;;3.0; Surgery ;**71,93,95,99,100,125,142,160,164**;24 Jun 93;Build 2
+ ;
+ ; Reference to ^DGPM("APTT1" supported by DBIA #565
+ ;
+ I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
+ S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
+START G:SRSOUT END D HDR^SROAUTL
+ S DIR("A",1)="Enter/Edit Patient Resource Data",DIR("A",2)=" ",DIR("A",3)="1. Capture Information from PIMS Records",DIR("A",4)="2. Enter, Edit, or Review Information",DIR("A",5)=" "
+ S DIR("?",1)="Enter '1' if you want to capture patient information from PIMS",DIR("?",2)="records.  Enter '2' if you want to enter, edit, or review patient",DIR("?")="other information on this screen."
+ S DIR("A")="Select Number",DIR(0)="NO^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END
+ I Y=1 D PIMS G START
+EDIT S:$P(^SRF(SRTN,206),"^",41)="" $P(^SRF(SRTN,206),"^",41)="N"
+ S SRR=0 S SRPAGE="PAGE: 1" D HDR^SROAUTL K DR S SRQ=0,(DR,SRDR)="418;419;440;.205;.232;470;471;473;472;431;442;513"
+ K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="IE",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
+ K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
+ .D TR,GET
+ .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
+ .W:M>1 ! W $J(SRZ,2)_". "_$P(Z,"^")_": " D EXT
+ D CHCK W ! F K=1:1:80 W "-"
+ D SEL G:SRR=1 EDIT
+ G START
+ Q
+CHCK ; compare admission and discharge dates to each other
+ N SRADM,SRDIS,SROUT,SRDICU,SREXT
+ S SROUT=SRY(130,SRTN,.232,"I"),SRDICU=SRY(130,SRTN,471,"I"),SREXT=SRY(130,SRTN,470,"I")
+ S SRADM=SRY(130,SRTN,418,"I"),SRDIS=SRY(130,SRTN,419,"I") W !
+ I SRADM,SRDIS,SRADM'<SRDIS W !,"*** NOTE: Discharge Date precedes Admission Date!!  Please check. ***"
+ I SREXT,SROUT,SREXT'>SROUT W !,"*** NOTE: D/Time Pt Extubated should be later than the D/Time Pt Out of OR. ***"
+ I SREXT,SRDICU,SREXT'<SRDICU W !,"*** NOTE: D/Time Pt Extubated should be < the ICU Discharge D/Time. ***"
+ I SRDICU,SREXT,SRDICU'>SREXT W !,"*** NOTE: D/Time Discharged from ICU should be > the Extubation D/Time. ***"
+ I SRDICU,SRDIS,SRDICU>SRDIS W !,"*** NOTE: D/Time Discharged from ICU should be <= the Hospital Discharge D/Time*"
+ Q
+EXT I SRFLD=440&(SREXT="NS") S SREXT=SREXT_"-"_$S(SREXT="NS":"No Study",1:SREXT)
+ I SRFLD=470,(SREXT="NS"!(SREXT="RI")) S SREXT=SREXT_"-"_$S(SREXT="NS":"Unable to determine",SREXT="RI":"Remains intubated at 30 days",1:SREXT)
+ I SRFLD=471,(SREXT="NS"!(SREXT="RI")) S SREXT=SREXT_"-"_$S(SREXT="NS":"Unable to determine",SREXT="RI":"Remains in ICU at 30 days",1:SREXT)
+ I $L(SREXT)<41 W ?39,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q
+ I SRFLD=431 D
+ .I $L(SREXT)<52 W ?28,SREXT Q 
+ .N I,J,X,Y S X=SREXT F  D  W:$L(X) ! I $L(X)<52!($L(X)>51&(X'[" ")) W ?28,X Q
+ ..F I=0:1:50 S J=51-I,Y=$E(X,J) I Y=" " W ?28,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q
+ Q
+SEL S SRSOUT=0 W !!,"Select number of item to edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+ Q:X=""  S:X="a" X="A" I '$D(SRFLG),'$D(SRZ(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q
+ I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRZ)!(Y>Z) D HELP S SRR=1 Q
+ I X="A" S X="1:"_SRZ
+ I X?1.2N1":"1.2N D RANGE S SRR=1 Q
+ I $D(SRZ(X)),+X=X S EMILY=X D  S SRR=1
+ .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
+ Q
+PIMS ; get update from PIMS records
+ W ! K DIR S DIR("A")="Are you sure you want to retrieve information from PIMS records ? ",DIR("B")="YES",DIR(0)="YOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
+ W ! D WAIT^DICD D ^SROAPIMS
+ Q
+HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
+ W !!,"1. Enter 'A' to update all items.",!!,"2. Enter a number (1-"_SRZ_") to update an individual item.  (For example,",!,"   enter '1' to update "_$P(SRZ(1),"^")_".)"
+ W !!,"3. Enter a range of numbers (1-"_SRZ_") separated by a ':' to enter a range",!,"   of items.  (For example, enter '1:4' to update items 1, 2, 3 and 4.)",!
+ I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",!
+PRESS W ! K DIR S DIR("A")="Press the return key to continue or '^' to exit: ",DIR(0)="FOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
+ Q
+RANGE ; range of numbers
+ I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
+ .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
+ Q
+ONE ; edit one item
+ I EMILY=7 D LIST
+ K DR,DA,DIE S DR=$P(SRZ(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1
+ I 'SRSOUT,EMILY=1!(EMILY=2) D OK
+ Q
+OK ; compare admission date to discharge date
+ N SRADM,SRDIS S X=$G(^SRF(SRTN,208)),SRADM=$P(X,"^",14),SRDIS=$P(X,"^",15)
+ I SRADM,SRDIS,SRADM'<SRDIS W !!,"  ***  NOTE: Discharge Date precedes Admission Date!!  Please check.  ***",! D PRESS W !
+ Q
+LIST ; display list of patient movements
+ N CNT,SRADM,SRLOC,SRMOVE,SRMVMT,SRT,SRTYPE,SRZ,SRY
+ S DFN=$P(^SRF(SRTN,0),"^"),SRZ=$P($G(^SRF(SRTN,.2)),"^",12)
+ S SRADM=0 D ADM Q:'SRZ
+ S CNT=0 F  Q:'SRZ  D MVMT
+ Q:CNT=0
+ W !!,?5,"To identify the date and time the patient was discharged from intensive",!,?5,"care following surgery, see the following list of patient movements"
+ W !,?5,"that occurred during the inpatient stay associated with this surgery.",!
+ S CNT=0 F  S CNT=$O(SRMVMT(CNT)) Q:'CNT  S X=SRMVMT(CNT),SRT=$P(X,"^",2) W !,?5,$P($P(X,"^"),":",1,2),?25,$P(X,"^",3),?37,$S(SRT=3:"From",1:"To")_": "_$P(X,"^",4)
+ W !
+ Q
+MVMT S VAIP("D")=SRZ D IN5^VADPT S SRY=$P(VAIP(3),"^")
+ I SRY S CNT=CNT+1 D
+ .S SRMOVE=$P(VAIP(3),"^",2),SRTYPE=$P(VAIP(2),"^",1,2),SRLOC=$P(VAIP(5),"^",2)
+ .S SRMVMT(CNT)=SRMOVE_"^"_SRTYPE_"^"_SRLOC
+ I 'SRY S SRZ="" Q
+ I VAIP(1)=VAIP(17) S SRZ="" Q
+ I VAIP(16),VAIP(16)=VAIP(17) S CNT=CNT+1,SRMOVE=$P(VAIP(16,1),"^",2),SRTYPE=$P(VAIP(16,2),"^",1,2),SRLOC=$P(VAIP(16,4),"^",2),SRMVMT(CNT)=SRMOVE_"^"_SRTYPE_"^"_SRLOC,SRZ="" Q
+ S SRZ=$P(VAIP(16,1),"^")
+ Q
+ADM N SR24 S VAIP("D")=SRZ D IN5^VADPT
+ I 'VAIP(13) S X1=SRZ,X2=1 D C^%DTC S SR24=X,SRDT=$O(^DGPM("APTT1",DFN,SRZ)) Q:'SRDT!(SRDT>SR24)  S VAIP("D")=SRDT D IN5^VADPT I 'VAIP(13) S SRZ="" Q
+ I VAIP(13) S SRZ=$P(VAIP(13,1),"^")+.000001
+ Q
+TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
+ Q
+GET S X=$T(@J)
+ Q
+END W @IOF D ^SRSKILL
+ Q
+DAH ;;418^Hospital Admission Date
+DAI ;;419^Hospital Discharge Date
+DDJ ;;440^Cardiac Catheterization Date
+PBJE ;;.205^Time Patient In OR
+PBCB ;;.232^Time Patient Out OR
+DGJ ;;470^Date/Time Patient Extubated
+DGA ;;471^Date/Time Discharged from ICU
+DDB ;;442^Employment Status Preoperatively
+DCA ;;431^Resource Data Comments
+DGC ;;473^Homeless
+DGB ;;472^Surg Performed at Non-VA Facility
+EAC ;;513^CT Surgery Consult Date

WorldVistAEHR/trunk/r/SURGERY-SR/SROACPM1.m

@@ -1 @@
-SROACPM1        ;BIR/SJA - LAB INFO ;01/14/08
-        ;;3.0; Surgery ;**125,153,166**;24 Jun 93;Build 7
-        I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
-        S SRSOUT=0 D ^SROAUTL
-START   G:SRSOUT END K SRA,SRAO D ^SROACPM2,DISP
-ASK     W !!,"Select Laboratory Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 D CONCC G END
-        I X="" D CONCC G END
-        S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START
-        I X="A" S X="1:10"
-        I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>10)!(Y>Z) D HELP G:SRSOUT END G START
-        S SRPAGE="" D HDR^SROAUTL
-        I X?.N1":".N D RANGE G START
-        I $D(SRAO(X)) S EMILY=X D ONE G START
-END     W @IOF
-        Q
-HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
-        W !!,"1. Enter 'A' to update all information.",!!,"2. Enter a number (1-10) to update the information in that field.  (For",!,"   example, enter '7' to update Serum Creatinine)"
-        W !!,"3. Enter a range of numbers (1-10) separated by a ':' to enter a range of",!,"   information.  (For example, enter '5:7' to update Serum Potassium,",!,"   Serum Bilirubin, and Serum Creatinine)"
-        W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1
-        Q
-RANGE   ; range of numbers
-        S SRNOMORE=0,SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRNOMORE  D ONE
-        Q
-ONE     ; edit one item
-        K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",3)_"T;"_$P(SRAO(EMILY),"^",4)_"T",DIE=130 D ^DIE S:$D(Y) SRNOMORE=1 K DR
-        Q
-RET     Q:SRSOUT  W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
-        Q
-DISP    N SRX S SRPAGE="PAGE: 1",SRHDR(.5)="PREOPERATIVE LABORATORY RESULTS" D HDR^SROAUTL
-        S SRX=$P(SRAO(1),"^") W !," 1. HDL:",?25,$J(SRX,6),?35,$$NORCHK(21,SRX),?38,$P(SRAO(1),"^",2)
-        S SRX=$P(SRAO(2),"^") W !," 2. LDL:",?25,$J(SRX,6),?35,$$NORCHK(23,SRX),?38,$P(SRAO(2),"^",2)
-        S SRX=$P(SRAO(3),"^") W !," 3. Total Cholesterol:",?25,$J(SRX,6),?35,$$NORCHK(24,SRX),?38,$P(SRAO(3),"^",2)
-        S SRX=$P(SRAO(4),"^") W !," 4. Serum Triglyceride:",?25,$J(SRX,6),?35,$$NORCHK(22,SRX),?38,$P(SRAO(4),"^",2)
-        S SRX=$P(SRAO(5),"^") W !," 5. Serum Potassium:",?25,$J(SRX,6),?35,$$NORCHK(5,SRX),?38,$P(SRAO(5),"^",2)
-        S SRX=$P(SRAO(6),"^") W !," 6. Serum Bilirubin:",?25,$J(SRX,6),?35,$$NORCHK(14,SRX),?38,$P(SRAO(6),"^",2)
-        S SRX=$P(SRAO(7),"^") W !," 7. Serum Creatinine:",?25,$J(SRX,6),?35,$$NORCHK(7,SRX),?38,$P(SRAO(7),"^",2)
-        S SRX=$P(SRAO(8),"^") W !," 8. Serum Albumin:",?25,$J(SRX,6),?35,$$NORCHK(11,SRX),?38,$P(SRAO(8),"^",2)
-        S SRX=$P(SRAO(9),"^") W !," 9. Hemoglobin:",?25,$J(SRX,6),?35,$$NORCHK(1,SRX),?38,$P(SRAO(9),"^",2)
-        S SRX=$P(SRAO(10),"^") W !,"10. Hemoglobin A1c:",?25,$J(SRX,6),?35,$$NORCHK(27,SRX),?38,$P(SRAO(10),"^",2)
-        W !! F MOE=1:1:80 W "-"
-        Q
-CONCC   ; check for concurrent case and update if one exists
-        S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON
-        S SRI="" F  S SRI=$O(SRAO(SRI)) Q:SRI=""  S S1=$P(SRAO(SRI),"^",3),S2=$P(SRAO(SRI),"^",4) K DA,DIC,DIQ,DR,SRY D
-        .S DA=SRTN,DR=S1_";"_S2,DIC="^SRF(",DIQ="SRY",DIQ(0)="I" D EN^DIQ1 S P1=SRY(130,SRTN,S1,"I") S:P1="" P1="@" S P2=SRY(130,SRTN,S2,"I") S:P2="" P2="@"
-        .K DA,DIE,DR S DA=SRCON,DIE=130,DR=S1_"////"_P1_";"_S2_"////"_P2 D ^DIE K DR
-        Q
-NORCHK(SRAT,RESULT)     ;
-        I RESULT']""!(RESULT="NS") Q ""
-        N NODE,LOW,HIGH,SRY
-        S SRY="" S:"<>"[$E(RESULT) SRY=$E(RESULT),RESULT=$E(RESULT,2,99)
-        S NODE=$G(^SRO(139.2,SRAT,2)),LOW=$P(NODE,"^",2),HIGH=$P(NODE,"^",3) Q:LOW']""!(HIGH']"")
-        I SRY'="" Q $S(RESULT<(LOW+.01):"L",((RESULT>(HIGH-.01))&(SRY=">")):"H",1:"")
-        Q $S(RESULT<LOW:"L",RESULT>HIGH:"H",1:"")
+SROACPM1 ;BIR/SJA - LAB INFO ;05/04/06
+ ;;3.0; Surgery ;**125,153**;24 Jun 93;Build 11
+ I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
+ S SRSOUT=0 D ^SROAUTL
+START G:SRSOUT END K SRA,SRAO D ^SROACPM2,DISP
+ASK W !!,"Select Laboratory Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 D CONCC G END
+ I X="" D CONCC G END
+ S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START
+ I X="A" S X="1:10"
+ I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>10)!(Y>Z) D HELP G:SRSOUT END G START
+ S SRPAGE="" D HDR^SROAUTL
+ I X?.N1":".N D RANGE G START
+ I $D(SRAO(X)) S EMILY=X D ONE G START
+END W @IOF
+ Q
+HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
+ W !!,"1. Enter 'A' to update all information.",!!,"2. Enter a number (1-10) to update the information in that field.  (For",!,"   example, enter '7' to update Serum Creatinine)"
+ W !!,"3. Enter a range of numbers (1-10) separated by a ':' to enter a range of",!,"   information.  (For example, enter '5:7' to update Serum Potassium,",!,"   Serum Bilirubin, and Serum Creatinine)"
+ W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1
+ Q
+RANGE ; range of numbers
+ S SRNOMORE=0,SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRNOMORE  D ONE
+ Q
+ONE ; edit one item
+ K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",3)_"T;"_$P(SRAO(EMILY),"^",4)_"T",DIE=130 D ^DIE S:$D(Y) SRNOMORE=1 K DR
+ Q
+RET Q:SRSOUT  W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+ Q
+DISP S SRPAGE="PAGE: 1",SRHDR(.5)="PREOPERATIVE LABORATORY RESULTS" D HDR^SROAUTL
+ W !," 1. HDL:",?25,$J($P(SRAO(1),"^"),6),?35,$P(SRAO(1),"^",2)
+ W !," 2. LDL:",?25,$J($P(SRAO(2),"^"),6),?35,$P(SRAO(2),"^",2)
+ W !," 3. Total Cholesterol:",?25,$J($P(SRAO(3),"^"),6),?35,$P(SRAO(3),"^",2)
+ W !," 4. Serum Triglyceride:",?25,$J($P(SRAO(4),"^"),6),?35,$P(SRAO(4),"^",2)
+ W !," 5. Serum Potassium:",?25,$J($P(SRAO(5),"^"),6),?35,$P(SRAO(5),"^",2)
+ W !," 6. Serum Bilirubin:",?25,$J($P(SRAO(6),"^"),6),?35,$P(SRAO(6),"^",2)
+ W !," 7. Serum Creatinine:",?25,$J($P(SRAO(7),"^"),6),?35,$P(SRAO(7),"^",2)
+ W !," 8. Serum Albumin:",?25,$J($P(SRAO(8),"^"),6),?35,$P(SRAO(8),"^",2)
+ W !," 9. Hemoglobin:",?25,$J($P(SRAO(9),"^"),6),?35,$P(SRAO(9),"^",2)
+ W !,"10. Hemoglobin A1c:",?25,$J($P(SRAO(10),"^"),6),?35,$P(SRAO(10),"^",2)
+ W !! F MOE=1:1:80 W "-"
+ Q
+CONCC ; check for concurrent case and update if one exists
+ S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON
+ S SRI="" F  S SRI=$O(SRAO(SRI)) Q:SRI=""  S S1=$P(SRAO(SRI),"^",3),S2=$P(SRAO(SRI),"^",4) K DA,DIC,DIQ,DR,SRY D
+ .S DA=SRTN,DR=S1_";"_S2,DIC="^SRF(",DIQ="SRY",DIQ(0)="I" D EN^DIQ1 S P1=SRY(130,SRTN,S1,"I") S:P1="" P1="@" S P2=SRY(130,SRTN,S2,"I") S:P2="" P2="@"
+ .K DA,DIE,DR S DA=SRCON,DIE=130,DR=S1_"////"_P1_";"_S2_"////"_P2 D ^DIE K DR
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROACR2.m

@@ -1 @@
-SROACR2 ;BIR/SJA - OPERATIVE DATA, PAGE 2 ;12/03/07
-        ;;3.0; Surgery ;**125,153,160,166**;24 Jun 93;Build 7
-        ;
-        I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
-        S SRSOUT=0 D ^SROAUTL
-START   G:SRSOUT END
-        ;
-EDIT    S SRR=0 S SRPAGE="PAGE: 2 OF 2" D HDR^SROAUTL W "Indicate other cardiac procedures only if done with cardiopulmonary bypass",! F K=1:1:80 W "-"
-        ;
-        K DR S SRQ=0,(DR,SRDR)="381;382;451;450;468;469"
-        K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="IE",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
-        K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
-        .K SREXT D TR,GET
-        .S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRX(SRX))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
-        .I SRFLD=451 W !,"Other Operative Data details:",!,"------------------------------"
-        .W !,$J(SRX,2)_". "_$P(Z,"^")_":" D EXT
-        .W:SRFLD=382 !
-        D CHCK W ! F K=1:1:80 W "-"
-        D SEL G:SRR=1 EDIT
-        S SRSOUT=1 G END
-        Q
-SEL     S SRSOUT=0 W !!,"Select Cardiac Procedures Operative Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
-        Q:X=""  S:X="a" X="A" I '$D(SRFLG),'$D(SRX(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q
-        I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRX)!(Y>Z) D HELP S SRR=1 Q
-        I X="A" S X="1:"_SRX
-        I X?1.2N1":"1.2N D RANGE S SRR=1 K SREXT Q
-        I $D(SRX(X)),+X=X S EMILY=X D  S SRR=1
-        .I $$LOCK^SROUTL(SRTN) W ! D ONE,UNLOCK^SROUTL(SRTN)
-        Q
-EXT     W ?30,SREXT
-        Q
-HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
-        W !!,"1. Enter 'A' to update all information.",!!,"2. Enter a number (1-6) to update the information in that field.  (For",!,"   example, enter '5' to update Incision Type.)"
-        W !!,"3. Enter a range of numbers (1-6) separated by a ':' to enter a range of",!,"   information.  (For example, enter '3:5' to enter Total CPB time,",!,"   Total Ischemic time, and Incision Type.)"
-        D RET
-        Q
-CHCK    ; compare ischemic time to CPB time
-        I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS
-        N SRISCH,SRCPB S SRISCH=SRY(130,SRTN,450,"E"),SRCPB=SRY(130,SRTN,451,"E")
-        I SRISCH,SRCPB,SRISCH>SRCPB W !,IORVON_"***  NOTE: Ischemic Time is greater than CPB Time!!  Please check.  ***"_IORVOFF
-        Q
-RET     Q:SRSOUT  W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        Q
-RANGE   ; range of numbers
-        I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
-        .W ! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
-        Q
-ONE     ; edit one item
-        K DR,DA,DIE S DR=$P(SRX(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRX(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1
-        I EMILY=3,$P($G(^SRF(SRTN,206)),"^",37)>0,($P($G(^SRF(SRTN,207)),"^",27)=1) S $P(^SRF(SRTN,207),"^",27)=5
-        Q
-TR      S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
-        Q
-GET     S X=$T(@J)
-        Q
-END     W @IOF D ^SRSKILL
-        Q
-CHA     ;;381^Foreign Body Removal
-CHB     ;;382^Pericardiectomy
-DEA     ;;451^Total CPB Time
-DEJ     ;;450^Total Ischemic Time
-DFH     ;;468^Incision Type
-DFI     ;;469^Convert Off Pump to CPB
+SROACR2 ;BIR/SJA - OPERATIVE DATA, PAGE 2 ;04/12/06
+ ;;3.0; Surgery ;**125,153,160**;24 Jun 93;Build 7
+ ;
+ I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
+ S SRSOUT=0 D ^SROAUTL
+START G:SRSOUT END
+ ;
+EDIT S SRR=0 S SRPAGE="PAGE: 2 OF 2" D HDR^SROAUTL W "Indicate other cardiac procedures only if done with cardiopulmonary bypass",! F K=1:1:80 W "-"
+ ;
+ K DR S SRQ=0,(DR,SRDR)="381;382;451;450;468;469"
+ K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="IE",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
+ K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
+ .K SREXT D TR,GET
+ .S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRX(SRX))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
+ .I SRFLD=451 W !,"Other Operative Data details:",!,"------------------------------"
+ .W !,$J(SRX,2)_". "_$P(Z,"^")_":" D EXT
+ .W:SRFLD=382 !
+ D CHCK W ! F K=1:1:80 W "-"
+ D SEL G:SRR=1 EDIT
+ S SRSOUT=1 G END
+ Q
+SEL S SRSOUT=0 W !!,"Select Operative Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+ Q:X=""  S:X="a" X="A" I '$D(SRFLG),'$D(SRX(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q
+ I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRX)!(Y>Z) D HELP S SRR=1 Q
+ I X="A" S X="1:"_SRX
+ I X?1.2N1":"1.2N D RANGE S SRR=1 K SREXT Q
+ I $D(SRX(X)),+X=X S EMILY=X D  S SRR=1
+ .I $$LOCK^SROUTL(SRTN) W ! D ONE,UNLOCK^SROUTL(SRTN)
+ Q
+EXT W ?30,SREXT
+ Q
+HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
+ W !!,"1. Enter 'A' to update all information.",!!,"2. Enter a number (1-6) to update the information in that field.  (For",!,"   example, enter '5' to update Incision Type.)"
+ W !!,"3. Enter a range of numbers (1-6) separated by a ':' to enter a range of",!,"   information.  (For example, enter '3:5' to enter Total CPB time,",!,"   Total Ischemic time, and Incision Type.)"
+ D RET
+ Q
+CHCK ; compare ischemic time to CPB time
+ I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS
+ N SRISCH,SRCPB S SRISCH=SRY(130,SRTN,450,"E"),SRCPB=SRY(130,SRTN,451,"E")
+ I SRISCH,SRCPB,SRISCH>SRCPB W !,IORVON_"***  NOTE: Ischemic Time is greater than CPB Time!!  Please check.  ***"_IORVOFF
+ Q
+RET Q:SRSOUT  W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
+ Q
+RANGE ; range of numbers
+ I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
+ .W ! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
+ Q
+ONE ; edit one item
+ K DR,DA,DIE S DR=$P(SRX(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRX(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1
+ I EMILY=3,$P($G(^SRF(SRTN,206)),"^",37)>0,($P($G(^SRF(SRTN,207)),"^",27)=1) S $P(^SRF(SRTN,207),"^",27)=5
+ Q
+TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
+ Q
+GET S X=$T(@J)
+ Q
+END W @IOF D ^SRSKILL
+ Q
+CHA ;;381^Foreign Body Removal
+CHB ;;382^Pericardiectomy
+DEA ;;451^Total CPB Time
+DEJ ;;450^Total Ischemic Time
+DFH ;;468^Incision Type
+DFI ;;469^Convert Off Pump to CPB

WorldVistAEHR/trunk/r/SURGERY-SR/SROALEC.m

@@ -1 @@
-SROALEC ;BIR/ADM - LIST OF ELIGIBLE CASES ;02/04/08
-        ;;3.0; Surgery ;**160,166**;24 Jun 93;Build 7
-        S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="CASES ELIGIBLE FOR ASSESSMENT" K ^TMP("SRA",$J)
-        I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^")
-        F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  I $D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
-        I SRSP S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""  D SRSD Q:SRSOUT  D:TOT TOT
-        I 'SRSP S SRNEW=1,(SRSD,TOT)=0 F  S SRSD=$O(^TMP("SRA",$J,SRSD)) Q:'SRSD!SRSOUT  S SRTN=0 F  S SRTN=$O(^TMP("SRA",$J,SRSD,SRTN)) Q:'SRTN  S SRA=^(SRTN) D CASE Q:SRSOUT
-        Q:SRSOUT  I SRSP,'SRFLG,GRAND D GRAND
-        I SRFLG,'GRAND S SRSS=SRSPEC D HDR,GRAND
-        I SRSP,'SRFLG,'GRAND S SRSS="" D HDR,GRAND
-        I 'SRSP,'GRAND S SRSS="" D HDR,GRAND
-        I 'SRSP,GRAND S SRSS="" D GRAND
-        Q
-UTL     ; set up TMP global
-        N SRCPLT
-        I '$P($G(^SRF(SRTN,.2)),"^",3)&'$P($G(^SRF(SRTN,.2)),"^",12) Q
-        I $P($G(^SRF(SRTN,30)),"^") Q
-        I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
-        S SRCPLT=$P($G(^SRO(136,SRTN,10)),"^") I SRCPLT,'$$XL^SROAX(SRTN) Q
-        S SRA=$G(^SRF(SRTN,"RA"))
-        I SRAST=1 Q:'($P(SRA,"^",2)="N"!($P(SRA,"^",2)="C"))!'($P(SRA,"^",6)="Y")
-        I SRAST=2 Q:'($P(SRA,"^",2)="N"!($P(SRA,"^",2)="C"))!'($P(SRA,"^",6)="N")
-        I SRAST=3 Q:$P(SRA,"^",2)'=""
-        I SRSP S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED"),^TMP("SRA",$J,SRSS,SRSD,SRTN)=SRA Q
-        S ^TMP("SRA",$J,SRSD,SRTN)=SRA
-        Q
-SRSD    S SRNEW=1,(SRSD,TOT)=0 F  S SRSD=$O(^TMP("SRA",$J,SRSS,SRSD)) Q:'SRSD!SRSOUT  S SRTN=0 F  S SRTN=$O(^TMP("SRA",$J,SRSS,SRSD,SRTN)) Q:'SRTN  S SRA=^(SRTN) D CASE Q:SRSOUT
-        Q
-CASE    N SRA2 S SRA2=$P(SRA,"^",2) D
-        .I SRA2="" S SRATYPE="NOT LOGGED" Q
-        .I SRA2="N" D  Q
-        .. I $P(SRA,"^",6)="N" S SRATYPE="EXCLUDED" Q
-        .. S SRATYPE="NON-CARDIAC"
-        .I SRA2="C" S SRATYPE="CARDIAC"
-        S TOT=TOT+1,GRAND=GRAND+1 D PRINT
-        Q
-PRINT   ; print case info
-        N SRDA,SRPROCS,SRSP1,SRY S SRPROCS=""
-        I $Y+8>IOSL!SRNEW D PAGE I SRSOUT Q
-        S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
-        I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
-        S SRSP1="",X=$P(SRA(0),"^",4) S:X SRSP1=$P(^SRO(137.45,X,0),"^")
-        S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
-        K SROPS,MM,MMM S:$L(SROPER)<63 SROPS(1)=SROPER I $L(SROPER)>62 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
-        S X=$P(SRA,"^"),SRSTATUS=$S(X="T":"TRANSMITTED",X="C":"COMPLETE",X="I":"INCOMPLETE",1:"NO ASSESSMENT"),Y=SRSD D D^DIQ S SRDT=$P(Y,"@")
-        I $Y+7>IOSL D PAGE I SRSOUT Q
-        W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?67,SRSTATUS,!,SRDT,?18,SROPS(1),! D
-        .I 'SRSP W $E(SRSP1,1,17) F I=2:1 W:$D(SROPS(I)) ?18,SROPS(I),! I '$D(SROPS(I)) W ! Q
-        .I SRSP F I=2:1 Q:'$D(SROPS(I))  W ?18,SROPS(I),!
-        S SRY=$P($G(^SRO(136,SRTN,0)),"^",2) I SRY D CPT S SRPROCS=SRCODE
-        S SRDA=0 F  S SRDA=$O(^SRO(136,SRTN,3,SRDA)) Q:'SRDA  S SRY=$P($G(^SRO(136,SRTN,3,SRDA,0)),"^") I SRY D CPT D
-        .S SRPROCS=SRPROCS_", "_SRCODE
-        I '$P($G(^SRO(136,SRTN,10)),"^"),$L(SRPROCS) W !,">>> Final CPT Coding is not complete."
-        S:SRPROCS="" SRPROCS="NOT ENTERED" W !,"CPT Codes: ",SRPROCS
-        I 'SRSOUT W ! F LINE=1:1:80 W "-"
-        Q
-CPT     ; check code for exclusion and get output value
-        N Y,SREX S (SRCODE,SREX)=""
-        S Y=$$CPT^ICPTCOD(SRY,$P(SRSD,".")),SRCODE=$P(Y,"^",2)
-        S SREX="" I '$D(^SRO(137,SRY,0)) S SREX="*"
-        S SRCODE=SREX_SRCODE
-        Q
-OTHER   ; other operations
-        S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
-        I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
-        S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
-        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)'<63  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
-        Q
-PAGE    I $E(IOST)="P"!SRHDR G HDR
-        W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
-        I X["?" W !!,"If you want to continue the listing, press the 'Enter' key.",!,"Type '^' to return to the menu." G PAGE
-HDR     ; print heading
-        W @IOF,!,?(80-$L(SRTITLE)\2),SRTITLE,?70,$J("PAGE "_SRPAGE,9) W:$E(IOST)="P" !,?(80-$L(SRINST)\2),SRINST W !,?(80-$L(SRFRTO)\2),SRFRTO
-        W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT
-        W !!,?50,"'*' Denotes Eligible CPT Code" I SRSP,SRSS'="" W !,">>> "_SRSS
-        W !!,"CASE #",?18,"PATIENT",?53,"TYPE",?67,"STATUS",!,"OP DATE",?18,"OPERATION(S)",! W:'SRSP "SURG SPECIALTY",! F LINE=1:1:80 W "="
-        S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1
-        Q
-TOT     W !!,"TOTAL FOR "_SRSS_": ",TOT
-        Q
-GRAND   I 'SRSP W !!,"TOTAL: ",GRAND Q
-        I SRSP,'SRFLG W !!,"TOTAL FOR ALL SPECIALTIES: ",GRAND Q
-        I SRSP,SRFLG S SRSS=SRSPEC D TOT
-        Q
+SROALEC ;BIR/ADM - LIST OF ELIGIBLE CASES ;05/04/07
+ ;;3.0; Surgery ;**160**;24 Jun 93;Build 7
+ S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="CASES ELIGIBLE FOR ASSESSMENT" K ^TMP("SRA",$J)
+ I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^")
+ F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  I $D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
+ I SRSP S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""  D SRSD Q:SRSOUT  D:TOT TOT
+ I 'SRSP S SRNEW=1,(SRSD,TOT)=0 F  S SRSD=$O(^TMP("SRA",$J,SRSD)) Q:'SRSD!SRSOUT  S SRTN=0 F  S SRTN=$O(^TMP("SRA",$J,SRSD,SRTN)) Q:'SRTN  S SRA=^(SRTN) D CASE Q:SRSOUT
+ Q:SRSOUT  I SRSP,'SRFLG,GRAND D GRAND
+ I SRFLG,'GRAND S SRSS=SRSPEC D HDR,GRAND
+ I SRSP,'SRFLG,'GRAND S SRSS="" D HDR,GRAND
+ I 'SRSP,'GRAND S SRSS="" D HDR,GRAND
+ I 'SRSP,GRAND S SRSS="" D GRAND
+ Q
+UTL ; set up TMP global
+ N SRCPLT
+ I '$P($G(^SRF(SRTN,.2)),"^",3)&'$P($G(^SRF(SRTN,.2)),"^",12) Q
+ I $P($G(^SRF(SRTN,30)),"^") Q
+ I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
+ S SRCPLT=$P($G(^SRO(136,SRTN,10)),"^") I SRCPLT,'$$XL^SROAX(SRTN) Q
+ S SRA=$G(^SRF(SRTN,"RA"))
+ I SRSP S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED"),^TMP("SRA",$J,SRSS,SRSD,SRTN)=SRA Q
+ S ^TMP("SRA",$J,SRSD,SRTN)=SRA
+ Q
+SRSD S SRNEW=1,(SRSD,TOT)=0 F  S SRSD=$O(^TMP("SRA",$J,SRSS,SRSD)) Q:'SRSD!SRSOUT  S SRTN=0 F  S SRTN=$O(^TMP("SRA",$J,SRSS,SRSD,SRTN)) Q:'SRTN  S SRA=^(SRTN) D CASE Q:SRSOUT
+ Q
+CASE N SRA2 S SRA2=$P(SRA,"^",2) D
+ .I SRA2="" S SRATYPE="NOT LOGGED" Q
+ .I SRA2="N" D  Q
+ .. I $P(SRA,"^",6)="N" S SRATYPE="EXCLUDED" Q
+ .. S SRATYPE="NON-CARDIAC"
+ .I SRA2="C" S SRATYPE="CARDIAC"
+ S TOT=TOT+1,GRAND=GRAND+1 D PRINT
+ Q
+PRINT ; print case info
+ N SRDA,SRPROCS,SRY S SRPROCS=""
+ I $Y+6>IOSL!SRNEW D PAGE I SRSOUT Q
+ S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
+ I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
+ S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
+ K SROPS,MM,MMM S:$L(SROPER)<63 SROPS(1)=SROPER I $L(SROPER)>62 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
+ S X=$P(SRA,"^"),SRSTATUS=$S(X="T":"TRANSMITTED",X="C":"COMPLETE",X="I":"INCOMPLETE",1:"NO ASSESSMENT"),Y=SRSD D D^DIQ S SRDT=$P(Y,"@")
+ I $Y+5>IOSL D PAGE I SRSOUT Q
+ W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?67,SRSTATUS,!,SRDT F I=1:1 Q:'$D(SROPS(I))  W ?18,SROPS(I),!
+ S SRY=$P($G(^SRO(136,SRTN,0)),"^",2) I SRY D CPT S SRPROCS=SRCODE
+ S SRDA=0 F  S SRDA=$O(^SRO(136,SRTN,3,SRDA)) Q:'SRDA  S SRY=$P($G(^SRO(136,SRTN,3,SRDA,0)),"^") I SRY D CPT D
+ .S SRPROCS=SRPROCS_", "_SRCODE
+ I '$P($G(^SRO(136,SRTN,10)),"^"),$L(SRPROCS) W !,">>> Final CPT Coding is not complete."
+ S:SRPROCS="" SRPROCS="NOT ENTERED" W !,"CPT Codes: ",SRPROCS
+ I 'SRSOUT W ! F LINE=1:1:80 W "-"
+ Q
+CPT ; check code for exclusion and get output value
+ N Y,SREX S (SRCODE,SREX)=""
+ S Y=$$CPT^ICPTCOD(SRY,$P(SRSD,".")),SRCODE=$P(Y,"^",2)
+ S SREX="" I '$D(^SRO(137,SRY,0)) S SREX="*"
+ S SRCODE=SREX_SRCODE
+ Q
+OTHER ; other operations
+ S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
+ I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
+ S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
+ 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)'<63  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
+ Q
+PAGE I $E(IOST)="P"!SRHDR G HDR
+ W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+ I X["?" W !!,"If you want to continue the listing, press the 'Enter' key.",!,"Type '^' to return to the menu." G PAGE
+HDR ; print heading
+ W @IOF,!,?(80-$L(SRTITLE)\2),SRTITLE,?70,$J("PAGE "_SRPAGE,9) W:$E(IOST)="P" !,?(80-$L(SRINST)\2),SRINST W !,?(80-$L(SRFRTO)\2),SRFRTO
+ W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT
+ W !!,?50,"'*' Denotes Eligible CPT Code" I SRSP,SRSS'="" W !,">>> "_SRSS
+ W !!,"CASE #",?18,"PATIENT",?53,"TYPE",?67,"STATUS",!,"OP DATE",?18,"OPERATION(S)",! F LINE=1:1:80 W "="
+ S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1
+ Q
+TOT W !!,"TOTAL FOR "_SRSS_": ",TOT
+ Q
+GRAND I 'SRSP W !!,"TOTAL: ",GRAND Q
+ I SRSP,'SRFLG W !!,"TOTAL FOR ALL SPECIALTIES: ",GRAND Q
+ I SRSP,SRFLG S SRSS=SRSPEC D TOT
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROALM.m

@@ -1 @@
-SROALM  ;BIR/ADM - LIST OF ASSESSMENTS MISSING INFORMATION ;12/05/07
-        ;;3.0; Surgery ;**38,50,88,142,153,160,166**;24 Jun 93;Build 7
-        S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="COMPLETED/TRANSMITTED ASSESSMENTS MISSING INFORMATION" K ^TMP("SRA",$J)
-        I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^")
-        F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
-        .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="C"!($P(SR("RA"),"^")="T"),$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
-        I SRSP S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""  D SRSD Q:SRSOUT  D:TOT TOT
-        I 'SRSP S SRNEW=1,(SRSD,TOT)=0 F  S SRSD=$O(^TMP("SRA",$J,SRSD)) Q:'SRSD!SRSOUT  S SRTN=0 F  S SRTN=$O(^TMP("SRA",$J,SRSD,SRTN)) Q:'SRTN  S SRA=^(SRTN) D CASE Q:SRSOUT
-        Q:SRSOUT  I SRSP,'SRFLG,GRAND D GRAND
-        I SRFLG,'GRAND S SRSS=SRSPEC D HDR,GRAND
-        I SRSP,'SRFLG,'GRAND S SRSS="" D HDR,GRAND
-        I 'SRSP,'GRAND S SRSS="" D HDR,GRAND
-        I 'SRSP,GRAND S SRSS="" D GRAND
-        Q
-UTL     ; set up TMP global
-        I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
-        I SRSP S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED"),^TMP("SRA",$J,SRSS,SRSD,SRTN)=SR("RA") Q
-        S ^TMP("SRA",$J,SRSD,SRTN)=SR("RA")
-        Q
-SRSD    S SRNEW=1,(SRSD,TOT)=0 F  S SRSD=$O(^TMP("SRA",$J,SRSS,SRSD)) Q:'SRSD!SRSOUT  S SRTN=0 F  S SRTN=$O(^TMP("SRA",$J,SRSS,SRSD,SRTN)) Q:'SRTN  S SRA=^(SRTN) D CASE Q:SRSOUT
-        Q
-CASE    I $P(SRA,"^",2)="N",$P(SRA,"^",6)="Y" S SRATYPE="NON-CARDIAC" D CHK^SROAUTL
-        I $P(SRA,"^",2)="N",$P(SRA,"^",6)="N" S SRATYPE="EXCLUDED" D CHK^SROAUTL3
-        I $P(SRA,"^",2)="C" S SRATYPE="CARDIAC" D CHK^SROAUTLC
-        S SRFLD="" I $O(SRX(SRFLD))'="" S TOT=TOT+1,GRAND=GRAND+1 D PRINT Q
-        I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) D PRINT
-        Q
-PRINT   ; print assessments
-        K SRCPTT S SRCPTT="NOT ENTERED"
-        I $Y+5>IOSL!SRNEW D PAGE I SRSOUT Q
-        S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
-        I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
-        S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
-        K SROPS,MM,MMM S:$L(SROPER)<63 SROPS(1)=SROPER I $L(SROPER)>62 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
-        S SRSTATUS=$S($P(SRA,"^")="T":"TRANSMITTED",1:"COMPLETE"),Y=SRSD D D^DIQ S SRDT=$P(Y,"@")
-        I $Y+5>IOSL D PAGE I SRSOUT Q
-        W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?68,SRSTATUS,!,SRDT F I=1:1 Q:'$D(SROPS(I))  W ?18,SROPS(I),!
-        N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W ?18,"CPT Codes: "
-        F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?29,SRPROC(I) W:I'=1 !,?29,SRPROC(I)
-        S CNT=1 W !,?5,"Missing information:"
-        I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !,$J(CNT_". ",8),"The final coding for Procedure and Diagnosis is not complete." S CNT=CNT+1
-        F  S SRFLD=$O(SRX(SRFLD)) Q:SRFLD=""  D:$Y+5>IOSL PAGE Q:SRSOUT  W !,$J(CNT_". ",8),$P(SRX(SRFLD),":") S CNT=CNT+1
-        I 'SRSOUT W ! F LINE=1:1:80 W "-"
-        Q
-OTHER   ; other operations
-        S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
-        I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
-        S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
-        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)'<63  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
-        Q
-PAGE    I $E(IOST)="P"!SRHDR G HDR
-        W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
-        I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
-HDR     ; print heading
-        W @IOF,!,?(80-$L(SRTITLE)\2),SRTITLE,?70,$J("PAGE "_SRPAGE,9) W:$E(IOST)="P" !,?(80-$L(SRINST)\2),SRINST W !,?(80-$L(SRFRTO)\2),SRFRTO
-        W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT I SRSP,SRSS'="" W !!,"** "_SRSS
-        W !!,"ASSESSMENT #",?18,"PATIENT",?53,"TYPE",?68,"STATUS",!,"OPERATION DATE",?18,"OPERATION(S)",! F LINE=1:1:80 W "="
-        S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1
-        Q
-TOT     W !!,"TOTAL FOR "_SRSS_": ",TOT
-        Q
-GRAND   I 'SRSP W !!,"TOTAL: ",GRAND Q
-        I SRSP,'SRFLG W !!,"TOTAL FOR ALL SPECIALTIES: ",GRAND Q
-        I SRSP,SRFLG S SRSS=SRSPEC D TOT
-        Q
+SROALM ;BIR/ADM - LIST OF ASSESSMENTS MISSING INFORMATION ;02/08/07
+ ;;3.0; Surgery ;**38,50,88,142,153,160**;24 Jun 93;Build 7
+ S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="COMPLETED/TRANSMITTED ASSESSMENTS MISSING INFORMATION" K ^TMP("SRA",$J)
+ I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^")
+ F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
+ .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="C"!($P(SR("RA"),"^")="T"),$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
+ I SRSP S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""  D SRSD Q:SRSOUT  D:TOT TOT
+ I 'SRSP S SRNEW=1,(SRSD,TOT)=0 F  S SRSD=$O(^TMP("SRA",$J,SRSD)) Q:'SRSD!SRSOUT  S SRTN=0 F  S SRTN=$O(^TMP("SRA",$J,SRSD,SRTN)) Q:'SRTN  S SRA=^(SRTN) D CASE Q:SRSOUT
+ Q:SRSOUT  I SRSP,'SRFLG,GRAND D GRAND
+ I SRFLG,'GRAND S SRSS=SRSPEC D HDR,GRAND
+ I SRSP,'SRFLG,'GRAND S SRSS="" D HDR,GRAND
+ I 'SRSP,'GRAND S SRSS="" D HDR,GRAND
+ I 'SRSP,GRAND S SRSS="" D GRAND
+ Q
+UTL ; set up TMP global
+ I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
+ I SRSP S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED"),^TMP("SRA",$J,SRSS,SRSD,SRTN)=SR("RA") Q
+ S ^TMP("SRA",$J,SRSD,SRTN)=SR("RA")
+ Q
+SRSD S SRNEW=1,(SRSD,TOT)=0 F  S SRSD=$O(^TMP("SRA",$J,SRSS,SRSD)) Q:'SRSD!SRSOUT  S SRTN=0 F  S SRTN=$O(^TMP("SRA",$J,SRSS,SRSD,SRTN)) Q:'SRTN  S SRA=^(SRTN) D CASE Q:SRSOUT
+ Q
+CASE I $P(SRA,"^",2)="N",$P(SRA,"^",6)="Y" S SRATYPE="NON-CARDIAC" D CHK^SROAUTL
+ I $P(SRA,"^",2)="N",$P(SRA,"^",6)="N" S SRATYPE="EXCLUDED" D CHK^SROAUTL3
+ I $P(SRA,"^",2)="C" S SRATYPE="CARDIAC" D CHK^SROAUTLC
+ S SRFLD="" I $O(SRX(SRFLD))'="" S TOT=TOT+1,GRAND=GRAND+1 D PRINT Q
+ I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) D PRINT
+ Q
+PRINT ; print assessments
+ K SRCPTT S SRCPTT="NOT ENTERED"
+ I $Y+5>IOSL!SRNEW D PAGE I SRSOUT Q
+ S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
+ I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
+ S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
+ K SROPS,MM,MMM S:$L(SROPER)<63 SROPS(1)=SROPER I $L(SROPER)>62 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
+ S SRSTATUS=$S($P(SRA,"^")="T":"TRANSMITTED",1:"COMPLETE"),Y=SRSD D D^DIQ S SRDT=$P(Y,"@")
+ I $Y+5>IOSL D PAGE I SRSOUT Q
+ W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?68,SRSTATUS,!,SRDT F I=1:1 Q:'$D(SROPS(I))  W ?18,SROPS(I),!
+ N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W ?18,"CPT Codes: "
+ F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?29,SRPROC(I) W:I'=1 !,?29,SRPROC(I)
+ S CNT=1 W !,?5,"Missing information:"
+ I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !,$J(CNT_". ",8),"The final coding for Procedure and Diagnosis is not complete." S CNT=CNT+1
+ F  S SRFLD=$O(SRX(SRFLD)) Q:SRFLD=""  D:$Y+5>IOSL PAGE Q:SRSOUT  W !,$J(CNT_". ",8),SRX(SRFLD) S CNT=CNT+1
+ I 'SRSOUT W ! F LINE=1:1:80 W "-"
+ Q
+OTHER ; other operations
+ S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
+ I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
+ S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
+ 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)'<63  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
+ Q
+PAGE I $E(IOST)="P"!SRHDR G HDR
+ W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+ I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
+HDR ; print heading
+ W @IOF,!,?(80-$L(SRTITLE)\2),SRTITLE,?70,$J("PAGE "_SRPAGE,9) W:$E(IOST)="P" !,?(80-$L(SRINST)\2),SRINST W !,?(80-$L(SRFRTO)\2),SRFRTO
+ W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT I SRSP,SRSS'="" W !!,"** "_SRSS
+ W !!,"ASSESSMENT #",?18,"PATIENT",?53,"TYPE",?68,"STATUS",!,"OPERATION DATE",?18,"OPERATION(S)",! F LINE=1:1:80 W "="
+ S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1
+ Q
+TOT W !!,"TOTAL FOR "_SRSS_": ",TOT
+ Q
+GRAND I 'SRSP W !!,"TOTAL: ",GRAND Q
+ I SRSP,'SRFLG W !!,"TOTAL FOR ALL SPECIALTIES: ",GRAND Q
+ I SRSP,SRFLG S SRSS=SRSPEC D TOT
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROALOG.m

@@ -1 @@
-SROALOG ;BIR/MAM - ASSESSMENT LOG ;01/24/08
-        ;;3.0; Surgery ;**38,55,62,77,50,153,160,166**;24 Jun 93;Build 7
-        K SRMNA S (SRSOUT,SRFLG,SRSP,SRAST)=0,SRSRT=1
-START   G:SRSOUT END W @IOF K DIR S DIR("A",1)="List of Surgery Risk Assessments",DIR("A",2)="",DIR("A",3)="  1. List of Incomplete Assessments"
-        S DIR("A",4)="  2. List of Completed Assessments",DIR("A",5)="  3. List of Transmitted Assessments"
-        S DIR("A",6)="  4. List of Non-Assessed Major Surgical Cases",DIR("A",7)="  5. List of All Major Surgical Cases"
-        S DIR("A",8)="  6. List of All Surgical Cases",DIR("A",9)="  7. List of Completed/Transmitted Assessments Missing Information"
-        S DIR("A",10)="  8. List of 1-Liner Cases Missing Information",DIR("A",11)="  9. List of Eligible Cases"
-        S DIR("A",12)=" 10. List of Cases With No CPT Codes",DIR("A",13)=" 11. Summary List of Assessed Cases"
-        S DIR("A",14)="",DIR("A")="Select the Number of the Report Desired"
-        S DIR(0)="NO^1:11" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END
-        S SREPORT=X
-DATE    I SREPORT=3 D DSORT G:SRSOUT END
-        D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END
-        I SREPORT=9 D TYPE9 I SRSOUT G END
-        I SREPORT=3 D TYPE3 I SRSOUT G END
-        D SEL G:SRSOUT END
-        N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,"^"),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,"^",2))
-        I SREPORT<7 W @IOF,!,"This report is designed to print to your terminal screen or a printer. When",!,"using a printer, a 132 column format is used.",!
-        K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Print the List of Assessments to which Device: ",%ZIS="QM" D ^%ZIS I POP S SRSOUT=1 G END
-        I $D(IO("Q")) K IO("Q") D  S ZTREQ="@" D ^%ZTLOAD G END
-        .S ZTRTN="EN^SROALOG",ZTDESC="List of Surgery Risk Assessments"
-        .S (ZTSAVE("SRSD"),ZTSAVE("SRED"),ZTSAVE("SREPORT"),ZTSAVE("SRASP"),ZTSAVE("SRFLG"),ZTSAVE("SRSP"),ZTSAVE("SRINSTP"),ZTSAVE("SRAST"),ZTSAVE("SRSRT"))=""
-EN      ; entry when queued
-        N SRFRTO S Y=SRSD X ^DD("DD") S SRFRTO="FROM: "_Y_"  TO: ",Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_Y
-        U IO S SRSD=SRSD-.0001,SRED=SRED_".9999",Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y
-        S SRINST=$S(SRINSTP["ALL DIV":$P($$SITE^SROVAR,"^",2)_" - ALL DIVISIONS",1:$$GET1^DIQ(4,SRINSTP,.01))
-        I SREPORT=1 D:SRSP ^SROANTS D:'SRSP ^SROANT G END
-        I SREPORT=2 D:SRSP ^SROALCS D:'SRSP ^SROALC G END
-        I SREPORT=3 D:SRSP ^SROALTS D:'SRSP ^SROALT G END
-        I SREPORT=4 S SRMNA=1 D:SRSP ^SROALLS D:'SRSP ^SROALL G END
-        I SREPORT=5 D:SRSP ^SROALLS D:'SRSP ^SROALL G END
-        I SREPORT=7 D ^SROALM G END
-        I SREPORT=8 D ^SROALMN G END
-        I SREPORT=9 D ^SROALEC G END
-        I SREPORT=10 D ^SROALNC G END
-        I SREPORT=11 D ^SROALSL G END
-        D:SRSP ^SROALSS D:'SRSP ^SROALST
-END     I 'SRSOUT,$E(IOST)'="P" W !!,"Press ENTER to continue  " R X:DTIME
-        W:$E(IOST)="P" @IOF K ^TMP("SRA",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
-        D ^%ZISC K SRTN,SRAST,SRSRT W @IOF D ^SRSKILL
-        Q
-TYPE3   ; select type of eligible cases
-        W ! K DIR S DIR("A",1)="Print which Transmitted Cases ?",DIR("A",2)="",DIR("A",3)="   1. Assessed Cases Only"
-        S DIR("A",4)="   2. Excluded Cases Only",DIR("A",5)="   3. Both Assessed and Excluded",DIR("A",6)=""
-        S DIR("A")="Select Number",DIR("B")=1,DIR(0)="N^1:3" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        S SRAST=Y
-        Q
-TYPE9   ; select type of transmitted case
-        W ! K DIR S DIR("A",1)="Print which Eligible Cases ?",DIR("A",2)="",DIR("A",3)="   1. Assessed Cases Only"
-        S DIR("A",4)="   2. Excluded Cases Only",DIR("A",5)="   3. Non-Assessed Cases only",DIR("A",6)="   4. All Cases",DIR("A",7)=""
-        S DIR("A")="Select Number",DIR("B")=1,DIR(0)="N^1:4" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        S SRAST=Y
-        Q
-DSORT   ; sort by op date or transmit date
-        W ! K DIR S DIR("A",1)="Print by Date of Operation or by Date of Transmission ?",DIR("A",2)="",DIR("A",3)="   1. Date of Operation"
-        S DIR("A",4)="   2. Date of Transmission",DIR("A",5)="",DIR("A")="Select Number",DIR("B")=1,DIR(0)="N^1:2"
-        D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        S SRSRT=Y
-        Q
-SEL     ; select specialty
-        W ! K DIR S DIR(0)="YA",DIR("A")="Print by Surgical Specialty ?  ",DIR("B")="YES"
-        S DIR("?",1)="Enter YES to print the report by surgical specialty, or NO to print",DIR("?")="the report listing all surgical cases."
-        D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
-        Q:'Y
-SEL1    S SRSP=1 W ! K DIR S DIR(0)="YA",DIR("A")="Print report for ALL specialties ?  ",DIR("B")="YES"
-        S DIR("?",1)="Enter YES to print the report for all surgical specialties, or NO to",DIR("?")="print the report for a specific surgical specialty."
-        D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
-        I 'Y W ! S DIC("S")="I '$P(^(0),""^"",3)",DIC("A")="Print the Report for which Surgical Specialty: ",DIC=137.45,DIC(0)="QEAMZ" D ^DIC K DIC I Y>0 S SRASP=+Y,SRFLG=1 Q
-        I Y'>0 S SRSOUT=1 Q
-        Q
+SROALOG ;BIR/MAM - ASSESSMENT LOG ;01/22/07
+ ;;3.0; Surgery ;**38,55,62,77,50,153,160**;24 Jun 93;Build 7
+ K SRMNA S (SRSOUT,SRFLG,SRSP)=0
+START G:SRSOUT END W @IOF,!,"List of Surgery Risk Assessments",!!,"  1. List of Incomplete Assessments"
+ W !,"  2. List of Completed Assessments",!,"  3. List of Transmitted Assessments"
+ W !,"  4. List of Non-Assessed Major Surgical Cases",!,"  5. List of All Major Surgical Cases"
+ W !,"  6. List of All Surgical Cases",!,"  7. List of Completed/Transmitted Assessments Missing Information"
+ W !,"  8. List of 1-Liner Cases Missing Information",!,"  9. List of Eligible Cases"
+ W !!,"Select the Number of the Report Desired: " R X:DTIME I '$T!("^"[X) S SRSOUT=1 G END
+ I X<1!(X>9)!(X\1'=X) D HELP G START
+ S SREPORT=X
+DATE D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END
+ D SEL G:SRSOUT END
+ N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,"^"),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,"^",2))
+ I SREPORT<7 W @IOF,!,"This report is designed to print to your terminal screen or a printer. When",!,"using a printer, a 132 column format is used.",!
+ K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Print the List of Assessments to which Device: ",%ZIS="QM" D ^%ZIS I POP S SRSOUT=1 G END
+ I $D(IO("Q")) K IO("Q") S ZTRTN="EN^SROALOG",ZTDESC="List of Surgery Risk Assessments",(ZTSAVE("SRSD"),ZTSAVE("SRED"),ZTSAVE("SREPORT"),ZTSAVE("SRASP"),ZTSAVE("SRFLG"),ZTSAVE("SRSP"),ZTSAVE("SRINSTP"))="",ZTREQ="@" D ^%ZTLOAD G END
+EN ; entry when queued
+ N SRFRTO S Y=SRSD X ^DD("DD") S SRFRTO="FROM: "_Y_"  TO: ",Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_Y
+ U IO S SRSD=SRSD-.0001,SRED=SRED_".9999",Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y
+ S SRINST=$S(SRINSTP["ALL DIV":$P($$SITE^SROVAR,"^",2)_" - ALL DIVISIONS",1:$$GET1^DIQ(4,SRINSTP,.01))
+ I SREPORT=1 D:SRSP ^SROANTS D:'SRSP ^SROANT G END
+ I SREPORT=2 D:SRSP ^SROALCS D:'SRSP ^SROALC G END
+ I SREPORT=3 D:SRSP ^SROALTS D:'SRSP ^SROALT G END
+ I SREPORT=4 S SRMNA=1 D:SRSP ^SROALLS D:'SRSP ^SROALL G END
+ I SREPORT=5 D:SRSP ^SROALLS D:'SRSP ^SROALL G END
+ I SREPORT=7 D ^SROALM G END
+ I SREPORT=8 D ^SROALMN G END
+ I SREPORT=9 D ^SROALEC G END
+ D:SRSP ^SROALSS D:'SRSP ^SROALST
+END I 'SRSOUT,$E(IOST)'="P" W !!,"Press <RET> to continue  " R X:DTIME
+ W:$E(IOST)="P" @IOF K ^TMP("SRA",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
+ D ^%ZISC K SRTN W @IOF D ^SRSKILL
+ Q
+HELP W !!,"Select the number corresponding to the type of report you want to print.",!!,"Press <RET> to continue  " R X:DTIME I '$T!(X["^") S SRSOUT=1
+ Q
+SEL ; select specialty
+ W !!,"Print by Surgical Specialty ?  YES// " R X:DTIME S:'$T X="^" I X="^" S SRSOUT=1 Q
+ S X=$E(X) I "YyNn"'[X W !!,"Enter <RET> to print the report by surgical specialty, or 'N' to print",!,"the report listing all surgical cases." G SEL
+ Q:"Yy"'[X
+SEL1 S SRSP=1 W !!,"Print report for ALL specialties ?  YES// " R X:DTIME S:'$T X="^" I X="^" S SRSOUT=1 Q
+ S X=$E(X) I "YyNn"'[X W !!,"Enter <RET> to print the report for all surgical specialties, or 'N' to ",!,"print the report for a specific surgical specialty." G SEL1
+ I "Yy"'[X W ! S DIC("S")="I '$P(^(0),""^"",3)",DIC("A")="Print the Report for which Surgical Specialty: ",DIC=137.45,DIC(0)="QEAMZ" D ^DIC K DIC I Y>0 S SRASP=+Y,SRFLG=1 Q
+ I Y'>0 S SRSOUT=1 Q
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROALT.m

@@ -1 @@
-SROALT  ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/07/08
-        ;;3.0; Surgery ;**38,50,142,153,160,166**;24 Jun 93;Build 7
-        S SRFRTO=$S(SRSRT=2:"TRANSMISSION DATES ",1:"OPERATION DATES ")_SRFRTO
-        I $E(IOST)="P" D ^SROALTP Q
-        S SRSOUT=0 D HDR
-        I SRSRT=2 F  S SRSD=$O(^SRF("AT",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AT",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
-        .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
-        I SRSRT=1 F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
-        .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
-        Q
-SET     ; print assessments
-        K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX=""
-        I $Y+5>IOSL D PAGE I SRSOUT Q
-        S SR("RA")=^SRF(SRTN,"RA")
-        I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y")
-        I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N")
-        S SRAT="",Y=$E($P(SR("RA"),"^",8),1,7) S:Y="" Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
-        S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
-        I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
-        S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
-        S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER
-        K SROPS,MM,MMM S:$L(SROPER)<34 SROPS(1)=SROPER I $L(SROPER)>33 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
-        S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
-        D TECH^SROPRIN
-        S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
-        S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED"
-        W !,SRTN,?20,SRANM_" "_VA("PID"),?55,$P(SRSS,"("),!,SRDT,?20,SROPS(1),?55,SRTECH,!,SRAT I $D(SROPS(2)) W ?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3)
-        N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W:$D(SROPS(2)) ! W SREX,?20,"CPT Codes: "
-        F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
-        W ! F LINE=1:1:80 W "-"
-        Q
-OTHER   ; other operations
-        S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
-        I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
-        S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
-        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)'<34  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
-        Q
-PAGE    W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
-        I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
-HDR     W @IOF,!,?26,"TRANSMITTED RISK ASSESSMENTS",!,?(80-$L(SRFRTO)\2),SRFRTO,!!,"ASSESSMENT #",?20,"PATIENT",?55,"SURGICAL SPECIALTY",!,"OPERATION DATE",?20,"OPERATION(S)",?55,"ANESTHESIA TECHNIQUE",!,"TRANSMISSION DATE",! F LINE=1:1:80 W "="
-        Q
+SROALT ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/18/07
+ ;;3.0; Surgery ;**38,50,142,153,160**;24 Jun 93;Build 7
+ I $E(IOST)="P" D ^SROALTP Q
+ S SRSOUT=0 D HDR
+ F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
+ Q
+SET ; print assessments
+ K SRCPTT S SRCPTT="NOT ENTERED"
+ I $Y+5>IOSL D PAGE I SRSOUT Q
+ S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
+ I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
+ S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
+ S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER
+ K SROPS,MM,MMM S:$L(SROPER)<34 SROPS(1)=SROPER I $L(SROPER)>33 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
+ S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
+ D TECH^SROPRIN
+ S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
+ W !,SRTN,?20,SRANM_" "_VA("PID"),?55,$P(SRSS,"("),!,SRDT,?20,SROPS(1),?55,SRTECH I $D(SROPS(2)) W !,?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3)
+ N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W !,?20,"CPT Codes: "
+ F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
+ W ! F LINE=1:1:80 W "-"
+ Q
+OTHER ; other operations
+ S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
+ I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
+ S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
+ 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)'<34  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
+ Q
+PAGE W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+ I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
+HDR W @IOF,!,?26,"TRANSMITTED RISK ASSESSMENTS",!,?(80-$L(SRFRTO)\2),SRFRTO,!!,"ASSESSMENT #",?20,"PATIENT",?55,"SURGICAL SPECIALTY",!,"OPERATION DATE",?20,"OPERATION(S)",?55,"ANESTHESIA TECHNIQUE",! F LINE=1:1:80 W "="
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROALTP.m

@@ -1 @@
-SROALTP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/07/08
-        ;;3.0; Surgery ;**32,50,142,153,160,166**;24 Jun 93;Build 7
-        S SRPAGE=1,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT
-        I SRSRT=2 F  S SRSD=$O(^SRF("AT",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AT",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
-        .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
-        I SRSRT=1 F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
-        .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
-        Q
-SET     ; print assessments
-        K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX=""
-        I $Y+5>IOSL S SRPAGE=SRPAGE+1 D HDR I SRSOUT Q
-        S SR("RA")=^SRF(SRTN,"RA")
-        I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y")
-        I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N")
-        S SRAT="",Y=$E($P(SR("RA"),"^",8),1,7) S:Y="" Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
-        S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
-        S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F  S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
-        S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER
-        K SROPS,MM,MMM S:$L(SROPER)<81 SROPS(1)=SROPER I $L(SROPER)>80 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
-        S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
-        S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A"
-        D TECH^SROPRIN
-        S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
-        S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED"
-        W !,SRTN,?20,SRANM_" "_VA("PID"),?67,$P(SRSS,"("),?107,SRTECH,!,SRDT,?20,SROPS(1),?107,SRAT I $D(SROPS(2)) W !,?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3) I $D(SROPS(4)) W !,?20,SROPS(4)
-        N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,SREX,?20,"CPT Codes: "
-        F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
-        W ! F LINE=1:1:132 W "-"
-        Q
-OTHER   ; other operations
-        S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>165 S SRLONG=0,SROTHER=999,SROPERS=" ..."
-        I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
-        S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
-        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)'<44  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
-        Q
-HDR     ; print heading
-        I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
-        W:$Y @IOF W !,?52,"TRANSMITTED RISK ASSESSMENTS",?120,"PAGE "_SRPAGE,!,?(132-$L(SRINST)\2),SRINST,!,?58,"SURGERY SERVICE",?100,"DATE REVIEWED:"
-        W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:"
-        W !!,"ASSESSMENT #",?20,"PATIENT",?67,"SURGICAL SPECIALTY",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",?107,"TRANSMISSION DATE",! F LINE=1:1:132 W "="
-        Q
+SROALTP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/18/07
+ ;;3.0; Surgery ;**32,50,142,153,160**;24 Jun 93;Build 7
+ S SRPAGE=1,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT
+ F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
+ Q
+SET ; print assessments
+ K SRCPTT S SRCPTT="NOT ENTERED"
+ I $Y+5>IOSL S SRPAGE=SRPAGE+1 D HDR I SRSOUT Q
+ S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
+ S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F  S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
+ S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER
+ K SROPS,MM,MMM S:$L(SROPER)<81 SROPS(1)=SROPER I $L(SROPER)>80 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
+ S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
+ S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A"
+ D TECH^SROPRIN
+ S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
+ W !,SRTN,?20,SRANM_" "_VA("PID"),?67,$P(SRSS,"("),?107,SRTECH,!,SRDT,?20,SROPS(1) I $D(SROPS(2)) W !,?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3) I $D(SROPS(4)) W !,?20,SROPS(4)
+ N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,?20,"CPT Codes: "
+ F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
+ W ! F LINE=1:1:132 W "-"
+ Q
+OTHER ; other operations
+ S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>165 S SRLONG=0,SROTHER=999,SROPERS=" ..."
+ I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
+ S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
+ 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)'<44  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
+ Q
+HDR ; print heading
+ I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
+ W:$Y @IOF W !,?52,"TRANSMITTED RISK ASSESSMENTS",?120,"PAGE "_SRPAGE,!,?(132-$L(SRINST)\2),SRINST,!,?58,"SURGERY SERVICE",?100,"DATE REVIEWED:"
+ W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:"
+ W !!,"ASSESSMENT #",?20,"PATIENT",?67,"SURGICAL SPECIALTY",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",! F LINE=1:1:132 W "="
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROALTS.m

@@ -1 @@
-SROALTS ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/07/08
-        ;;3.0; Surgery ;**38,50,142,153,160,166**;24 Jun 93;Build 7
-        S SRFRTO=$S(SRSRT=2:"TRANSMISSION DATES ",1:"OPERATION DATES ")_SRFRTO
-        I $E(IOST)="P" D ^SROALTSP Q
-        S SRSOUT=0 D HDR
-        I SRSRT=2 F  S SRSD=$O(^SRF("AT",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AT",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
-        .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
-        I SRSRT=1 F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
-        .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
-        S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""!SRSOUT  D SS S SRTN=0 F J=0:0 S SRTN=$O(^TMP("SRA",$J,SRSS,SRTN)) Q:'SRTN!SRSOUT  D SET
-        I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0()
-        Q
-UTL     ; write to ^TMP("SRA",$J)
-        I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
-        S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
-        S SR("RA")=^SRF(SRTN,"RA")
-        I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y")
-        I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N")
-        S ^TMP("SRA",$J,SRSS,SRTN)=""
-        Q
-SET     ; print assessments
-        K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX=""
-        I $Y+5>IOSL D PAGE I SRSOUT Q
-        S SR("RA")=^SRF(SRTN,"RA")
-        S SRAT="",Y=$E($P(SR("RA"),"^",8),1,7) S:Y="" Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
-        S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
-        I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
-        S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
-        S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER
-        K SROPS,MM,MMM S:$L(SROPER)<34 SROPS(1)=SROPER I $L(SROPER)>33 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
-        D TECH^SROPRIN
-        S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
-        S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED"
-        W !,SRTN,?20,SRANM_" "_VA("PID"),?55,SRAT,!,SRDT,?20,SROPS(1),?55,SRTECH S SRAO=1 F I=0:0 S SRAO=$O(SROPS(SRAO)) Q:'SRAO  W !,?20,SROPS(SRAO)
-        N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W !,SREX,?20,"CPT Codes: "
-        F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
-        W ! F LINE=1:1:80 W "-"
-        Q
-OTHER   ; other operations
-        S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
-        I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
-        S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
-        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)'<34  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
-        Q
-PAGE    W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
-        I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
-HDR     W @IOF,!,?26,"TRANSMITTED RISK ASSESSMENTS",!,?(80-$L(SRFRTO)\2),SRFRTO,!!,"ASSESSMENT #",?20,"PATIENT",?55,"TRANSMISSION DATE",!,"OPERATION DATE",?20,"OPERATION(S)",?55,"ANESTHESIA TECHNIQUE",! F LINE=1:1:80 W "="
-        Q
-SS      ; print surgical specialty
-        I $Y+5>IOSL D PAGE Q:SRSOUT
-        W !!,"** SURGICAL SPECIALTY: ",SRSS," **",!
-        Q
+SROALTS ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/18/07
+ ;;3.0; Surgery ;**38,50,142,153,160**;24 Jun 93;Build 7
+ I $E(IOST)="P" D ^SROALTSP Q
+ S SRSOUT=0 D HDR
+ F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
+ S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""!SRSOUT  D SS S SRTN=0 F J=0:0 S SRTN=$O(^TMP("SRA",$J,SRSS,SRTN)) Q:'SRTN!SRSOUT  D SET
+ I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0()
+ Q
+UTL ; write to ^TMP("SRA",$J)
+ I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
+ S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
+ S ^TMP("SRA",$J,SRSS,SRTN)=""
+ Q
+SET ; print assessments
+ K SRCPTT S SRCPTT="NOT ENTERED"
+ I $Y+5>IOSL D PAGE I SRSOUT Q
+ S SR("RA")=^SRF(SRTN,"RA"),SRAT="",Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
+ S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
+ I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
+ S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
+ S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER
+ K SROPS,MM,MMM S:$L(SROPER)<34 SROPS(1)=SROPER I $L(SROPER)>33 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
+ D TECH^SROPRIN
+ S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
+ W !,SRTN,?20,SRANM_" "_VA("PID"),?55,SRAT,!,SRDT,?20,SROPS(1),?55,SRTECH S SRAO=1 F I=0:0 S SRAO=$O(SROPS(SRAO)) Q:'SRAO  W !,?20,SROPS(SRAO)
+ N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W !,?20,"CPT Codes: "
+ F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
+ W ! F LINE=1:1:80 W "-"
+ Q
+OTHER ; other operations
+ S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
+ I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
+ S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
+ 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)'<34  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
+ Q
+PAGE W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+ I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
+HDR W @IOF,!,?26,"TRANSMITTED RISK ASSESSMENTS",!,?(80-$L(SRFRTO)\2),SRFRTO,!!,"ASSESSMENT #",?20,"PATIENT",?55,"TRANSMISSION DATE",!,"OPERATION DATE",?20,"OPERATION(S)",?55,"ANESTHESIA TECHNIQUE",! F LINE=1:1:80 W "="
+ Q
+SS ; print surgical specialty
+ I $Y+5>IOSL D PAGE Q:SRSOUT
+ W !!,"** SURGICAL SPECIALTY: ",SRSS," **",!
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROALTSP.m

@@ -1 @@
-SROALTSP        ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/07/08
-        ;;3.0; Surgery ;**32,50,142,153,160,166**;24 Jun 93;Build 7
-        K ^TMP("SRA",$J) S SRPAGE=0,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT
-        I SRSRT=2 F  S SRSD=$O(^SRF("AT",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AT",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
-        .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
-        I SRSRT=1 F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
-        .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
-        S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""!SRSOUT  D SS S SRTN=0 F  S SRTN=$O(^TMP("SRA",$J,SRSS,SRTN)) Q:'SRTN!SRSOUT  D SET
-        I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0()
-        Q
-UTL     ; write to ^TMP("SRA",$J)
-        I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
-        S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
-        S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A"
-        S SR("RA")=^SRF(SRTN,"RA")
-        I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y")
-        I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N")
-        S ^TMP("SRA",$J,SRSS,SRTN)=""
-        Q
-SET     ; print assessments
-        K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX=""
-        I $Y+5>IOSL D HDR I SRSOUT Q
-        S SR("RA")=^SRF(SRTN,"RA")
-        S SRAT="",Y=$E($P(SR("RA"),"^",8),1,7) S:Y="" Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
-        S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
-        S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F  S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
-        S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER
-        K SROPS,MM,MMM S:$L(SROPER)<81 SROPS(1)=SROPER I $L(SROPER)>80 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
-        D TECH^SROPRIN
-        S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
-        S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED"
-        W !,SRTN,?20,SRANM_" "_VA("PID"),?67,SRAT,?107,SRTECH,!,SRDT,?20,SROPS(1) S SRAO=1 F  S SRAO=$O(SROPS(SRAO)) Q:'SRAO  W !,?20,SROPS(SRAO)
-        N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,SREX,?20,"CPT Codes: "
-        F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
-        D LINE
-        Q
-OTHER   ; other operations
-        S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>165 S SRLONG=0,SROTHER=999,SROPERS=" ..."
-        I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
-        S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
-        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)'<44  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
-        Q
-HDR     ; print heading
-        I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
-        S SRPAGE=SRPAGE+1 W:$Y @IOF W !,?52,"TRANSMITTED RISK ASSESSMENTS",?120,"PAGE "_SRPAGE,!,?(132-$L(SRINST)\2),SRINST,!,?58,"SURGERY SERVICE",?100,"DATE REVIEWED:"
-        W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:"
-        W !!,"ASSESSMENT #",?20,"PATIENT",?67,"TRANSMISSION DATE",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",! F LINE=1:1:132 W "="
-        Q
-SS      ;print surgical specialty
-        I $Y+5>IOSL D HDR
-        W !!,"** SURGICAL SPECIALTY: ",SRSS," **",!
-        Q
-LINE    W ! F L=1:1:132 W "-"
-        Q
+SROALTSP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/18/07
+ ;;3.0; Surgery ;**32,50,142,153,160**;24 Jun 93;Build 7
+ K ^TMP("SRA",$J) S SRPAGE=0,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT
+ F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
+ S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""!SRSOUT  D SS S SRTN=0 F  S SRTN=$O(^TMP("SRA",$J,SRSS,SRTN)) Q:'SRTN!SRSOUT  D SET
+ I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0()
+ Q
+UTL ; write to ^TMP("SRA",$J)
+ I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
+ S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
+ S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A"
+ S ^TMP("SRA",$J,SRSS,SRTN)=""
+ Q
+SET ; print assessments
+ K SRCPTT S SRCPTT="NOT ENTERED"
+ I $Y+5>IOSL D HDR I SRSOUT Q
+ S SR("RA")=^SRF(SRTN,"RA"),SRAT="",Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
+ S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
+ S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F  S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
+ S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER
+ K SROPS,MM,MMM S:$L(SROPER)<81 SROPS(1)=SROPER I $L(SROPER)>80 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
+ D TECH^SROPRIN
+ S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
+ W !,SRTN,?20,SRANM_" "_VA("PID"),?67,SRAT,?107,SRTECH,!,SRDT,?20,SROPS(1) S SRAO=1 F  S SRAO=$O(SROPS(SRAO)) Q:'SRAO  W !,?20,SROPS(SRAO)
+ N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,?20,"CPT Codes: "
+ F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
+ D LINE
+ Q
+OTHER ; other operations
+ S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>165 S SRLONG=0,SROTHER=999,SROPERS=" ..."
+ I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
+ S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
+ 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)'<44  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
+ Q
+HDR ; print heading
+ I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
+ S SRPAGE=SRPAGE+1 W:$Y @IOF W !,?52,"TRANSMITTED RISK ASSESSMENTS",?120,"PAGE "_SRPAGE,!,?(132-$L(SRINST)\2),SRINST,!,?58,"SURGERY SERVICE",?100,"DATE REVIEWED:"
+ W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:"
+ W !!,"ASSESSMENT #",?20,"PATIENT",?67,"TRANSMISSION DATE",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",! F LINE=1:1:132 W "="
+ Q
+SS ;print surgical specialty
+ I $Y+5>IOSL D HDR
+ W !!,"** SURGICAL SPECIALTY: ",SRSS," **",!
+ Q
+LINE W ! F L=1:1:132 W "-"
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAMEAS.m

@@ -1 @@
-SROAMEAS        ;BIR/MAM - INPUT TRANSFORMS, HEIGHT & WEIGHT ;03/20/06
-        ;;3.0; Surgery ;**38,125,153,166**;24 Jun 93;Build 7
-H       Q:'$D(X)  I X'?.N1"C"&(X'?.N1"c"),(+X'=X) K X Q
-        I +X=X S X=X+.5\1 I X'>47.9!(X'<86.1) K X Q
-        S:X["c" X=+X_"C"
-        I X?.N1"C",(X'>121.9!(X'<218.1)) K X
-        Q
-W       Q:'$D(X)  I +X'=X,(X'?.N1"K")&(X'?.N1"k") K X Q
-        I +X=X S X=X+.5\1 I X'>49.9!(X'<700.1) K X Q
-        S:X["k" X=+X_"K"
-        I X?.N1"K",(X'>22.9!(X'<318.1)) K X
-        Q
-HWC     ; reject NS entry if the case is cardiac one
-        S X=$S(X="ns":"NS",1:X)
-        I $P($G(^SRF($S($G(SRTN):SRTN,1:DA),"RA")),"^",2)="C",X="NS" S X=""
-        Q
+SROAMEAS ;BIR/MAM - INPUT TRANSFORMS, HEIGHT & WEIGHT ;03/20/06
+ ;;3.0; Surgery ;**38,125,153**;24 Jun 93;Build 11
+H Q:'$D(X)  I X'?.N1"C"&(X'?.N1"c"),(+X'=X) K X Q
+ I +X=X S X=X+.5\1 I X'>47.9!(X'<86.1) K X Q
+ S:X["c" X=+X_"C"
+ I X?.N1"C",(X'>121.9!(X'<218.1)) K X
+ Q
+W Q:'$D(X)  I +X'=X,(X'?.N1"K")&(X'?.N1"k") K X Q
+ I +X=X S X=X+.5\1 I X'>49.9!(X'<700.1) K X Q
+ S:X["k" X=+X_"K"
+ I X?.N1"K",(X'>22.9!(X'<318.1)) K X
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAMIS.m

@@ -1 @@
-SROAMIS ;BIR/MAM - ANESTHESIA AMIS REPORT ;11/26/07
-        ;;3.0; Surgery ;**22,34,38,77,50,86,166**;24 Jun 93;Build 7
-UTL     ; set up ^TMP("SROAMIS",$J
-        S PRIN=$P($G(^SRF(SRDFN,.3)),"^",8) I PRIN="" S PRIN="O"
-        S PROC=$S($D(^SRF(SRDFN,31)):$P(^(31),"^",9),1:""),DEATH=""
-        S:PRIN="O" TECH="L" I TECH="L",PRIN'="O" S TECH="O"
-        S S(0)=^SRF(SRDFN,0),DFN=$P(S(0),"^") S DEATH=$S('$D(^DPT(DFN,.35)):"",$P(^DPT(DFN,.35),"^")="":"",1:$P(^(.35),"^"))
-        I +DEATH S:$D(^TMP("SRTN",$J,DFN)) DEATH="" I +DEATH D DEAD
-        S $P(^TMP("SROAMIS",$J,"T",TECH),"^")=^TMP("SROAMIS",$J,"T",TECH)+1 I DEATH'="" S $P(^(TECH),"^",2)=$P(^(TECH),"^",2)+1
-        I PROC'="Y" S $P(^TMP("SROAMIS",$J,"P","SURG",PRIN),"^")=$P(^TMP("SROAMIS",$J,"P","SURG",PRIN),"^")+1 S:DEATH'="" $P(^(PRIN),"^",2)=$P(^(PRIN),"^",2)+1
-        I PROC="Y" S $P(^TMP("SROAMIS",$J,"P","DIAG",PRIN),"^")=$P(^TMP("SROAMIS",$J,"P","DIAG",PRIN),"^")+1 S:DEATH'="" $P(^(PRIN),"^",2)=$P(^(PRIN),"^",2)+1
-        Q
-SET     ; get anesthesia info from ^SRF(SRDFN,6
-        K SRTECH S (SRCNT,SRT,SRZ)=0,SRTN=SRDFN F  S SRT=$O(^SRF(SRDFN,6,SRT)) Q:SRT=""!(SRZ)  D ^SROPRIN S SRCNT=SRCNT+1
-        I '$D(SRTECH),SRCNT=1 S SRT=$O(^SRF(SRTN,6,0)),SRTECH=$P(^SRF(SRTN,6,SRT,0),"^")
-        K SRTN I $D(SRTECH) Q:SRTECH="N"  S TECH=SRTECH D UTL
-        Q
-HDR     ; print heading
-        I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
-        W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,!,?57,"ANESTHESIA SERVICE",?100,"REVIEWED BY: ",!,?58,"ANESTHESIA AMIS",?100,"DATE REVIEWED: "
-        W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,SRPRINT
-        W !!!!! F I=1:1:IOM W "="
-        W !,?38,"ANESTHETICS ADMINISTERED BY PRINCIPAL TECHNIQUE USED",! F I=1:1:IOM W "-"
-        W !,"TOTAL NO OF ANES-       |             |             |             |             |             |"
-        W !,"THETICS ADMINISTERED    |   GENERAL   |   MAC       |   SPINAL    |   EPIDURAL  |   OTHER     |   LOCAL",! F I=1:1:IOM W "-"
-        Q
-END     W:$E(IOST)="P" @IOF K ^TMP("SROAMIS",$J),^TMP("SRTN",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
-        D ^%ZISC,^SRSKILL W @IOF
-        Q
-DEAD    ; check for death within 24 hrs.
-        S OPDATE=$S($D(^SRF(SRDFN,.2)):$P(^(.2),"^"),1:"") S:OPDATE="" OPDATE=$P(^SRF(SRDFN,0),"^",9) S X1=OPDATE,X2=1 D C^%DTC S OPONE=X S DEATH=$S(DEATH<(OPONE+.0001):1,1:"")
-        I DEATH S ^TMP("SRTN",$J,DFN)=""
-        Q
-EN      ; entry for SROAMIS option
-        W @IOF,!,"Anesthesia AMIS",!!,"This report is no longer available.",!
-        K DIR S DIR(0)="E" D ^DIR K DIR D END
-        Q
-DATE    D DATE^SROUTL(.SDATE,.EDATE,.SRSOUT) G:SRSOUT END S SRD=SDATE-.0001
-        N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,U),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,U,2))
-        W !!!,"This report is designed to use a 132 column format, and must be run",!,"on a printer.",!!
-PTR     K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Select Printer: ",%ZIS="QM" D ^%ZIS G:POP END W:$E(IOST)'="P" !!,"This report must be run on a printer.",!! G:$E(IOST)'="P" PTR
-        I $D(IO("Q")) K IO("Q") S ZTDESC="ANESTHESIA AMIS",ZTRTN="1^SROAMIS",(ZTSAVE("EDATE"),ZTSAVE("SDATE"),ZTSAVE("SRD"),ZTSAVE("SRINST"),ZTSAVE("SRINSTP"))="" D ^%ZTLOAD G END
-1       ; entry when queued
-        U IO N SRFRTO K ^TMP("SROAMIS",$J),^TMP("SRTN",$J) S SRSOUT=0,Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y
-        S Y=SDATE X ^DD("DD") S SRFRTO="FROM: "_Y_"  TO: ",Y=EDATE X ^DD("DD") S SRFRTO=SRFRTO_Y
-        F I="G","M","S","E","O","L" S ^TMP("SROAMIS",$J,"T",I)=0 F I="A","N","O" S ^TMP("SROAMIS",$J,"P","DIAG",I)=0,^TMP("SROAMIS",$J,"P","SURG",I)=0 K I
-        S SRDFN=0,Z=SRD F  S Z=$O(^SRF("AC",Z)) Q:Z>(EDATE+.9999)!(Z="")  F  S SRDFN=$O(^SRF("AC",Z,SRDFN)) Q:SRDFN=""  D
-        .I $D(^SRF(SRDFN,0)),$P($G(^SRF(SRDFN,.2)),"^",12)'=""!($P($G(^SRF(SRDFN,"NON")),"^")="Y"),$$MANDIV^SROUTL0(SRINSTP,SRDFN) D SET
-        D HDR G:SRSOUT END D PRINT^SROAMIS1
-        G END
+SROAMIS ;B'HAM ISC/MAM - ANESTHESIA AMIS REPORT ; [ 12/16/98  2:06 PM ]
+ ;;3.0; Surgery ;**22,34,38,77,50,86**;24 Jun 93
+UTL ; set up ^TMP("SROAMIS",$J
+ S PRIN=$P($G(^SRF(SRDFN,.3)),"^",8) I PRIN="" S PRIN="O"
+ S PROC=$S($D(^SRF(SRDFN,31)):$P(^(31),"^",9),1:""),DEATH=""
+ S:PRIN="O" TECH="L" I TECH="L",PRIN'="O" S TECH="O"
+ S S(0)=^SRF(SRDFN,0),DFN=$P(S(0),"^") S DEATH=$S('$D(^DPT(DFN,.35)):"",$P(^DPT(DFN,.35),"^")="":"",1:$P(^(.35),"^"))
+ I +DEATH S:$D(^TMP("SRTN",$J,DFN)) DEATH="" I +DEATH D DEAD
+ S $P(^TMP("SROAMIS",$J,"T",TECH),"^")=^TMP("SROAMIS",$J,"T",TECH)+1 I DEATH'="" S $P(^(TECH),"^",2)=$P(^(TECH),"^",2)+1
+ I PROC'="Y" S $P(^TMP("SROAMIS",$J,"P","SURG",PRIN),"^")=$P(^TMP("SROAMIS",$J,"P","SURG",PRIN),"^")+1 S:DEATH'="" $P(^(PRIN),"^",2)=$P(^(PRIN),"^",2)+1
+ I PROC="Y" S $P(^TMP("SROAMIS",$J,"P","DIAG",PRIN),"^")=$P(^TMP("SROAMIS",$J,"P","DIAG",PRIN),"^")+1 S:DEATH'="" $P(^(PRIN),"^",2)=$P(^(PRIN),"^",2)+1
+ Q
+SET ; get anesthesia info from ^SRF(SRDFN,6
+ K SRTECH S (SRCNT,SRT,SRZ)=0,SRTN=SRDFN F  S SRT=$O(^SRF(SRDFN,6,SRT)) Q:SRT=""!(SRZ)  D ^SROPRIN S SRCNT=SRCNT+1
+ I '$D(SRTECH),SRCNT=1 S SRT=$O(^SRF(SRTN,6,0)),SRTECH=$P(^SRF(SRTN,6,SRT,0),"^")
+ K SRTN I $D(SRTECH) Q:SRTECH="N"  S TECH=SRTECH D UTL
+ Q
+HDR ; print heading
+ I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
+ W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,!,?57,"ANESTHESIA SERVICE",?100,"REVIEWED BY: ",!,?58,"ANESTHESIA AMIS",?100,"DATE REVIEWED: "
+ W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,SRPRINT
+ W !!!!! F I=1:1:IOM W "="
+ W !,?38,"ANESTHETICS ADMINISTERED BY PRINCIPAL TECHNIQUE USED",! F I=1:1:IOM W "-"
+ W !,"TOTAL NO OF ANES-       |             |             |             |             |             |"
+ W !,"THETICS ADMINISTERED    |   GENERAL   |   MAC       |   SPINAL    |   EPIDURAL  |   OTHER     |   LOCAL",! F I=1:1:IOM W "-"
+ Q
+END W:$E(IOST)="P" @IOF K ^TMP("SROAMIS",$J),^TMP("SRTN",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
+ D ^%ZISC,^SRSKILL W @IOF
+ Q
+DEAD ; check for death within 24 hrs.
+ S OPDATE=$S($D(^SRF(SRDFN,.2)):$P(^(.2),"^"),1:"") S:OPDATE="" OPDATE=$P(^SRF(SRDFN,0),"^",9) S X1=OPDATE,X2=1 D C^%DTC S OPONE=X S DEATH=$S(DEATH<(OPONE+.0001):1,1:"")
+ I DEATH S ^TMP("SRTN",$J,DFN)=""
+ Q
+EN ; entry for SROAMIS option
+ W @IOF,!,"Anesthesia AMIS",!
+DATE D DATE^SROUTL(.SDATE,.EDATE,.SRSOUT) G:SRSOUT END S SRD=SDATE-.0001
+ N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,U),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,U,2))
+ W !!!,"This report is designed to use a 132 column format, and must be run",!,"on a printer.",!!
+PTR K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Select Printer: ",%ZIS="QM" D ^%ZIS G:POP END W:$E(IOST)'="P" !!,"This report must be run on a printer.",!! G:$E(IOST)'="P" PTR
+ I $D(IO("Q")) K IO("Q") S ZTDESC="ANESTHESIA AMIS",ZTRTN="1^SROAMIS",(ZTSAVE("EDATE"),ZTSAVE("SDATE"),ZTSAVE("SRD"),ZTSAVE("SRINST"),ZTSAVE("SRINSTP"))="" D ^%ZTLOAD G END
+1 ; entry when queued
+ U IO N SRFRTO K ^TMP("SROAMIS",$J),^TMP("SRTN",$J) S SRSOUT=0,Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y
+ S Y=SDATE X ^DD("DD") S SRFRTO="FROM: "_Y_"  TO: ",Y=EDATE X ^DD("DD") S SRFRTO=SRFRTO_Y
+ F I="G","M","S","E","O","L" S ^TMP("SROAMIS",$J,"T",I)=0 F I="A","N","O" S ^TMP("SROAMIS",$J,"P","DIAG",I)=0,^TMP("SROAMIS",$J,"P","SURG",I)=0 K I
+ S SRDFN=0,Z=SRD F  S Z=$O(^SRF("AC",Z)) Q:Z>(EDATE+.9999)!(Z="")  F  S SRDFN=$O(^SRF("AC",Z,SRDFN)) Q:SRDFN=""  D
+ .I $D(^SRF(SRDFN,0)),$P($G(^SRF(SRDFN,.2)),"^",12)'=""!($P($G(^SRF(SRDFN,"NON")),"^")="Y"),$$MANDIV^SROUTL0(SRINSTP,SRDFN) D SET
+ D HDR G:SRSOUT END D PRINT^SROAMIS1
+ G END

WorldVistAEHR/trunk/r/SURGERY-SR/SROAOP.m

@@ -1 @@
-SROAOP  ;BIR/MAM - ENTER OPERATION INFO ;11/27/07
-        ;;3.0; Surgery ;**19,38,47,63,67,81,86,97,100,125,142,153,160,166**;24 Jun 93;Build 7
-        I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
-        S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
-START   G:SRSOUT END K SRAOTH,SRACON D ^SROAOP1
-ASK     W !!,"Select Operative Information to Edit: " R SRASEL:DTIME I '$T!(SRASEL["^") S SRSOUT=1 G END
-        I SRASEL="" G END
-        S SRN=13 S:SRASEL="a" SRASEL="A" I '$D(SRAO(SRASEL)),(SRASEL'?.N1":".N),(SRASEL'="A") D HELP G:SRSOUT END G START
-        I SRASEL="A" S SRASEL="1:"_SRN
-        I SRASEL?.N1":".N S Y=$E(SRASEL),Z=$P(SRASEL,":",2) I Y<1!(Z>SRN)!(Y>Z) D HELP G:SRSOUT END G START
-        S MM=$E(SRASEL) I MM'=3,(MM'=4),(MM'=5) S SRHDR(.5)=SRDOC D HDR^SROAUTL
-        I SRASEL?.N1":".N D RANGE G START
-        Q:'$D(SRAO(SRASEL))
-        S EMILY=SRASEL D  G START
-        .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
-END     I $D(SRSOUT),'SRSOUT D ^SROAOP2
-        I $D(SRTN) S SROERR=SRTN D ^SROERR0
-        W @IOF D ^SRSKILL
-        Q
-HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper"
-        W !,"responses are listed below.",!!,"1. Enter 'A' to update all information."
-        W !!,"2. Enter a number (1-"_SRN_") to update the information in that field. (For"
-        W !,"   example, enter '2' to update Principal Operation.)"
-        W !!,"3. Enter a range of numbers (1-"_SRN_") separated by a ':' to enter a range of"
-        W !,"   information. (For example, enter '6:8' to update PGY of Primary Surgeon,"
-        W !,"   Surgical Priority and Wound Classification.)",!
-PRESS   K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        Q
-RANGE   ; range of numbers
-        I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
-        .S SHEMP=$P(SRASEL,":"),CURLEY=$P(SRASEL,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
-        Q
-ONE     ; edit one item
-        I EMILY=3 D DISP^SROAUTL0 Q
-        I EMILY=10 D ANES Q
-        I EMILY=4 D ^SROTHER Q
-        I EMILY=5 D CONCUR Q
-        I EMILY=6,SRASEL[":",($P(SRASEL,":")'=6) S SRPAGE="" S SRHDR(.5)=SRDOC D HDR^SROAUTL
-        K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",2)_"T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1
-        I EMILY=2 D ^SROAUTL
-        Q
-RET     Q:SRSOUT  W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
-        Q
-CONCUR  ; concurrent case information
-        N SRPROC,SRCSTAT S SRLINE="" F I=1:1:80 S SRLINE=SRLINE_"-"
-        S CON=$P($G(^SRF(SRTN,"CON")),"^") I CON,($P($G(^SRF(CON,30)),"^")!($P($G(^SRF(CON,31)),"^",8))) S CON=""
-        S SRPAGE="" D HDR^SROAUTL
-        W !,"Concurrent case information cannot be updated using the Risk Assessment"
-        W !,"Module. To update the CPT code of a concurrent case, please use an option"
-        W !,"contained within the CPT/ICD9 Coding Menu."
-        I CON D CC W !!,"Concurrent Procedure: ",?22,SROPS(1) I $D(SROPS(2)) W !,?22,SROPS(2) I $D(SROPS(3)) W !,?22,SROPS(3) I $D(SROPS(4)) W !,?22,SROPS(4)
-        I $D(SRCSTAT) W !!,?22,SRCSTAT
-        W !!,"Press ENTER to continue " R X:DTIME
-        Q
-CC      ; list concurrent procedure
-        N SRTN,SRL,SRZ S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,CON,10)),"^"):"",1:"Not ")_"Complete <<"
-        S SRL=55,SRTN=CON D CPTS^SROAUTL0
-        I SRPROC(1)="NOT ENTERED"!'$D(SRPROC(1)) S SRPROC(1)="CPT NOT ENTERED" K SRCSTAT
-        S SROPER=$P(^SRF(CON,"OP"),"^")_" (" F I=1:1 Q:'$D(SRPROC(I))  S SROPER=SROPER_SRPROC(I)
-        S SROPER=SROPER_")"
-        K SROPS,MM,MMM S:$L(SROPER)<57 SROPS(1)=SROPER
-        I $L(SROPER)>56 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
-        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)'<57  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
-        Q
-ANES    N SRANE,SRNEW
-        I $P(SRAO(10),"^")="NOT ENTERED",'$O(^SRF(SRTN,6,0)) D  Q
-        .K DIR S DIR("A")="Select ANESTHESIA TECHNIQUE: ",DIR(0)="130.06,.01OA" D ^DIR K DIR S SRANE=Y I $D(DTOUT)!$D(DUOUT)!(Y="") Q
-        .K DD,DO S DIC="^SRF(SRTN,6,",X=SRANE,DIC(0)="L" D FILE^DICN K DIC,DD,DO I '+Y Q
-        .S SRNEW=+Y
-        .K DA,DIE,DR S DA=SRNEW,DA(1)=SRTN,DIE="^SRF(SRTN,6,",DR=".05T;42T" D ^DIE
-        K DR,DIE,DA S DA=SRTN,DR=".37T",DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE K DR
-        Q
+SROAOP ;BIR/MAM - ENTER OPERATION INFO ;04/24/07
+ ;;3.0; Surgery ;**19,38,47,63,67,81,86,97,100,125,142,153,160**;24 Jun 93;Build 7
+ I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
+ S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
+START G:SRSOUT END K SRAOTH,SRACON D ^SROAOP1
+ASK W !!,"Select Operative Information to Edit: " R SRASEL:DTIME I '$T!(SRASEL["^") S SRSOUT=1 G END
+ I SRASEL="" G END
+ S SRN=13 S:SRASEL="a" SRASEL="A" I '$D(SRAO(SRASEL)),(SRASEL'?.N1":".N),(SRASEL'="A") D HELP G:SRSOUT END G START
+ I SRASEL="A" S SRASEL="1:"_SRN
+ I SRASEL?.N1":".N S Y=$E(SRASEL),Z=$P(SRASEL,":",2) I Y<1!(Z>SRN)!(Y>Z) D HELP G:SRSOUT END G START
+ S MM=$E(SRASEL) I MM'=3,(MM'=4),(MM'=5) S SRHDR(.5)=SRDOC D HDR^SROAUTL
+ I SRASEL?.N1":".N D RANGE G START
+ Q:'$D(SRAO(SRASEL))
+ S EMILY=SRASEL D  G START
+ .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
+END I $D(SRSOUT),'SRSOUT D ^SROAOP2
+ I $D(SRTN) S SROERR=SRTN D ^SROERR0
+ W @IOF D ^SRSKILL
+ Q
+HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper"
+ W !,"responses are listed below.",!!,"1. Enter 'A' to update all information."
+ W !!,"2. Enter a number (1-"_SRN_") to update the information in that field. (For"
+ W !,"   example, enter '2' to update Principal Operation.)"
+ W !!,"3. Enter a range of numbers (1-"_SRN_") separated by a ':' to enter a range of"
+ W !,"   information. (For example, enter '6:8' to update PGY of Primary Surgeon,"
+ W !,"   Surgical Priority and Wound Classification.)",!
+PRESS K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
+ Q
+RANGE ; range of numbers
+ I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
+ .S SHEMP=$P(SRASEL,":"),CURLEY=$P(SRASEL,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
+ Q
+ONE ; edit one item
+ I EMILY=3 D DISP^SROAUTL0 Q
+ I EMILY=10 D ANES Q
+ I EMILY=4 D ^SROTHER Q
+ I EMILY=5 D CONCUR Q
+ I EMILY=6,SRASEL[":",($P(SRASEL,":")'=6) S SRPAGE="" S SRHDR(.5)=SRDOC D HDR^SROAUTL
+ K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",2)_"T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1
+ I EMILY=2 D ^SROAUTL
+ Q
+RET Q:SRSOUT  W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+ Q
+CONCUR ; concurrent case information
+ N SRPROC,SRCSTAT S SRLINE="" F I=1:1:80 S SRLINE=SRLINE_"-"
+ S CON=$P($G(^SRF(SRTN,"CON")),"^") I CON,($P($G(^SRF(CON,30)),"^")!($P($G(^SRF(CON,31)),"^",8))) S CON=""
+ S SRPAGE="" D HDR^SROAUTL
+ W !,"Concurrent case information cannot be updated using the Risk Assessment"
+ W !,"Module. To update the CPT code of a concurrent case, please use an option"
+ W !,"contained within the CPT/ICD9 Coding Menu."
+ I CON D CC W !!,"Concurrent Procedure: ",?22,SROPS(1) I $D(SROPS(2)) W !,?22,SROPS(2) I $D(SROPS(3)) W !,?22,SROPS(3) I $D(SROPS(4)) W !,?22,SROPS(4)
+ I $D(SRCSTAT) W !!,?22,SRCSTAT
+ W !!,"Press ENTER to continue " R X:DTIME
+ Q
+CC ; list concurrent procedure
+ N SRTN,SRL,SRZ S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,CON,10)),"^"):"",1:"Not ")_"Complete <<"
+ S SRL=55,SRTN=CON D CPTS^SROAUTL0
+ I SRPROC(1)="NOT ENTERED"!'$D(SRPROC(1)) S SRPROC(1)="CPT NOT ENTERED" K SRCSTAT
+ S SROPER=$P(^SRF(CON,"OP"),"^")_" (" F I=1:1 Q:'$D(SRPROC(I))  S SROPER=SROPER_SRPROC(I)
+ S SROPER=SROPER_")"
+ K SROPS,MM,MMM S:$L(SROPER)<57 SROPS(1)=SROPER
+ I $L(SROPER)>56 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
+ 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)'<57  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
+ Q
+ANES K DR,DIE,DA S DA=SRTN,DR=".37T",DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE K DR
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPAS.m

@@ -1 @@
-SROAPAS ;BIR/MAM - PRINT A COMPLETE ASSESSMENT ;03/03/08
-        ;;3.0; Surgery ;**38,47,81,88,111,112,100,125,153,166**;24 Jun 93;Build 7
-        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:",?51,SROETH
-        W !,?40,"Race:"
-        I $G(VADM(12)) F D=1:1:SRNUM1-1 D
-        .W:D=1 ?51,SROL(D)
-        .W:D'=1 !,?51,SROL(D)
-        I '$G(VADM(12)) W ?51,"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: ",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:"),?47,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:",?47,Z
-        S (X,Z)=SRPTMODT(15) S:X'="" Z=$P(X,"@")_"  "_$E($P(X,"@",2),1,5) W !,"Hospital Discharge Date:",?47,Z
-        S (X,Z)=SRPTMODT(16) S:X'="" Z=$P(X,"@")_"  "_$E($P(X,"@",2),1,5) W !,"Admitted/Transferred to Surgical Service:",?47,Z
-        S (X,Z)=SRPTMODT(17) S:X'="" Z=$P(X,"@")_"  "_$E($P(X,"@",2),1,5) W !,"Discharged/Transferred to Chronic Care:",?47,Z
-        W !,"In/Out-Patient Status:",?47,$S($P($G(^SRF(SRTN,0)),"^",12)="I":"INPATIENT",$P($G(^SRF(SRTN,0)),"^",12)="O":"OUTPATIENT",1:"")
-        S Y=$P($G(^SRF(SRTN,209)),"^",17) X ^DD("DD") W !,"Date Surgery Consult Requested:",?47,Y
-        S Y=$P($G(^SRF(SRTN,209)),"^",15) X ^DD("DD") W !,"Surgery Consult Date:",?47,Y
-        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
+SROAPAS ;BIR/MAM - PRINT A COMPLETE ASSESSMENT ; [ 04/13/04  2:50 PM ]
+ ;;3.0; Surgery ;**38,47,81,88,111,112,100,125,153**;24 Jun 93;Build 11
+ 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:",?51,SROETH
+ W !,?40,"Race:"
+ I $G(VADM(12)) F D=1:1:SRNUM1-1 D
+ .W:D=1 ?51,SROL(D)
+ .W:D'=1 !,?51,SROL(D)
+ I '$G(VADM(12)) W ?51,"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: ",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:"),?47,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:",?47,Z
+ S (X,Z)=SRPTMODT(15) S:X'="" Z=$P(X,"@")_"  "_$E($P(X,"@",2),1,5) W !,"Hospital Discharge Date:",?47,Z
+ S (X,Z)=SRPTMODT(16) S:X'="" Z=$P(X,"@")_"  "_$E($P(X,"@",2),1,5) W !,"Admitted/Transferred to Surgical Service:",?47,Z
+ S (X,Z)=SRPTMODT(17) S:X'="" Z=$P(X,"@")_"  "_$E($P(X,"@",2),1,5) W !,"Discharged/Transferred to Chronic Care:",?47,Z
+ W !,"In/Out-Patient Status:",?47,$S($P($G(^SRF(SRTN,0)),"^",12)="I":"INPATIENT",$P($G(^SRF(SRTN,0)),"^",12)="O":"OUTPATIENT",1:"")
+ 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 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

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPCA1.m

@@ -1 @@
-SROAPCA1        ;BIR/MAM - PRINT CARDIAC CATH INFO ;02/05/08
-        ;;3.0; Surgery ;**38,63,71,88,95,125,142,153,166**;24 Jun 93;Build 7
-        N SRX F I=200:1:202,206,208,209,202.1 S SRA(I)=$G(^SRF(SRTN,I))
-        I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q
-        D LAB^SROAPCA4
-        I $Y+16>IOSL D PAGE^SROAPCA I SRSOUT Q
-        S Y=$P(SRA(209),"^",4),SRAO(1)=$S(Y="C":"CATH",Y="I":"IVUS",Y="B":"BOTH",Y="NS":" NS",1:"")_"^476"
-        S Y=$P(SRA(206),"^",24),SRX=357,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",25),SRX=358,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",26),SRX=359,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",27),SRX=360,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX
-        S NYUK=$P(SRA(206),"^",30) D LV S SRAO(6)=SHEMP_"^363"
-        S Y=$P(SRA(206),"^",9),SRX=415,SRAO(7)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(209),"^",5),SRX=477,SRAO(8)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",28),SRX=361,SRAO(9)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",33),SRX=362.1,SRAO(10)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",34),SRX=362.2,SRAO(11)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",35),SRX=362.3,SRAO(12)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(209),"^",6),SRX=478,SRAO(13)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(209),"^",7),SRX=479,SRAO(14)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(209),"^",8),SRX=480,SRAO(15)=$$OUT(SRX,Y)_"^"_SRX
-        W !!,"IV. CARDIAC CATHETERIZATION AND ANGIOGRAPHIC DATA"
-        S Y=$P($G(^SRF(SRTN,207)),"^",21) I Y>1 D DT S Y=X
-        D NS W !,"Cardiac Catheterization Date: ",$E(Y,1,8)
-        W !,"Procedure:",?26,$P(SRAO(1),"^"),?41,"Native Coronaries:"
-        S SRX=$P(SRAO(2),"^") W !,"LVEDP:",?26,$J(SRX,3) D MMHG
-        S SRX=$P(SRAO(9),"^") W ?41,"Left Main Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
-        S SRX=$P(SRAO(3),"^") W !,"Aortic Systolic Pressure:",?26,$J(SRX,3) D MMHG
-        S SRX=$P(SRAO(10),"^") W ?41,"LAD Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
-        S SRX=$P(SRAO(11),"^") W !,?41,"Right Coronary Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
-        W !,"For patients having right heart cath:" S SRX=$P(SRAO(12),"^") W ?41,"Circumflex Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
-        ;
-        S SRX=$P(SRAO(4),"^") W !,"PA Systolic Pressure:",?26,$J(SRX,3) D MMHG
-        S SRX=$P(SRAO(5),"^") W !,"PAW Mean Pressure:",?26,$J(SRX,3) D MMHG
-        W ?41,"If a Re-do, indicate stenosis",!,?44," in graft to:"
-        S SRX=$P(SRAO(13),"^") W !,?41,"LAD:",?71,$J(SRX,3) I SRX?1.3N W "%"
-        S SRX=$P(SRAO(14),"^") W !,?41,"Right coronary (include PDA): ",$J(SRX,3) I SRX?1.3N W "%"
-        S SRX=$P(SRAO(15),"^") W !,?41,"Circumflex:",?71,$J(SRX,3) I SRX?1.3N W "%"
-        W !,LN
-        W !,"LV Contraction Grade (from contrast or radionuclide angiogram or 2D Echo):",!,?7,"Grade",?17,"Ejection Fraction Range",?51,"Definition"
-        W !,?8,$P(SRAO(6),"^")
-        W !,LN,!,"Mitral Regurgitation:",?26,$P(SRAO(7),"^")
-        W !,"Aortic stenosis:",?26,$P(SRAO(8),"^")
-        I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q
-        K SRAO S Y=$P(SRA(206),"^",31),SRX=364,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P($G(^SRF(SRTN,1.1)),"^",3),SRX=1.13,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(208),"^",12),SRX=414,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",32),SRX=364.1 D DT S SRAO("1A")=X_"^"_SRX
-        S Y=$P(SRA(208),"^",13),SRX=414.1 D DT S SRAO("3A")=X_"^"_SRX
-        S Y=$P($G(^SRF(SRTN,.2)),"^",2),SRX=.22 D DT S SRAO(0)=X_"^"_SRX
-        W !!,"V. OPERATIVE RISK SUMMARY DATA" S X=$P(SRAO(0),"^") W ?40,"(Operation Began: "_X_")"
-        W !,?5,"Physician's Preoperative" S Y=$P($G(^SRF(SRTN,.2)),"^",3) D DT W ?40,"(Operation Ended: "_X_")"
-        W !,?7,"Estimate of Operative Mortality: "_$P(SRAO(1),"^") I $P(SRAO(1),"^")'=""&($P(SRAO(1),"^")'="NS") W "%"
-        S X=$P(SRAO("1A"),"^") I X'="" W ?57,"("_X_")"
-        W !,?5,"ASA Classification:",?35,$P(SRAO(2),"^")
-        S X=$P(SRAO(3),"^") W !,?5,"Surgical Priority:",?($S($L(X)>10:24,1:35)),X S X=$P(SRAO("3A"),"^") I X'="" W ?57,"("_X_")"
-        S X=$P($G(^SRO(136,SRTN,0)),"^",2) I X S Y=$P($$CPT^ICPTCOD(X),"^",2) D SSPRIN^SROCPT0 S X=Y
-        S X=$S(X'="":X,1:"CPT Code Missing")
-        W !,?5,"Principal CPT Code:",?35,X,!,?5,"Other Procedures CPT Codes: "
-        S CNT=32,OTH=0 F  S OTH=$O(^SRO(136,SRTN,3,OTH)) Q:'OTH  S CPT=$P($G(^SRO(136,SRTN,3,OTH,0)),"^") D
-        .I CPT S Y=$P($$CPT^ICPTCOD(CPT),"^",2) S SRDA=OTH D SSOTH^SROCPT0 S CPT=Y
-        .S:CPT="" CPT="NONE" S CNT=CNT+3
-        .I CNT+$L(CPT)'>80 W:CNT>35 ";" W ?(CNT),CPT S CNT=CNT+$L(CPT) Q
-        .W !,?35,CPT S CNT=35+$L(CPT)
-        W !,?5,"Preoperative Risk Factors: "
-        I $G(^SRF(SRTN,206.1))'="" S SRQ=0 S X=$G(^SRF(SRTN,206.1)) W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D
-        .I X'[" " W ?25,X Q
-        .S I=0,LINE=1 F  S SRL=$S(LINE=1:48,1:80) D  Q:SRQ
-        ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q
-        ..S J=SRL-I,Y=$E(X,J),I=I+1 I Y=" " W $E(X,1,J-1),!,?5 S X=$E(X,J+1,Z),Z=$L(X),I=0,LINE=LINE+1 I Z<SRL W X S SRQ=1 Q
-        I $Y+20>IOSL D PAGE^SROAPCA I SRSOUT Q
-        K SRA,SRAO D ^SROAPCA2
-        Q
-YN      ; store answer
-        S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"")
-        Q
-DT      I 'Y S X="" Q
-        S Z=$E($P(Y,".",2),1,4),Z=Z_"0000",Z=$E(Z,1,4),X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$E(Z,1,2)_":"_$E(Z,3,4)
-        Q
-OUT(SRFLD,SRY)  ; get data in output form
-        N C,Y
-        S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
-        I Y="NO STUDY" S Y="NS" Q Y
-        Q Y
-MMHG    I SRX="NO STUDY"!(SRX="NS") Q
-        W " mm Hg"
-        Q
-NS      S Y=$S(Y="NS":"NO STUDY",1:Y)
-        Q
-LV      K SHEMP S SHEMP=$S(NYUK="I":" I          > or = 0.55                    NORMAL",NYUK="II":"II             0.45-0.54                   MILD DYSFUNCTION",1:NYUK)
-        Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="III":"III           0.35-0.44                    MODERATE DYSFUNCTION",1:NYUK)
-        Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="IIIa":"IIIa          0.40-0.44                    MODERATE DYSFUNCTION A",1:NYUK)
-        Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="IIIb":"IIIb          0.35-0.39                    MODERATE DYSFUNCTION B",1:NYUK)
-        Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="IV":"IV            0.25-0.34                    SEVERE DYSFUNCTION",NYUK="V":" V             <0.25                       VERY SEVERE DYSFUNCTION",NYUK="NS":"NO LV STUDY",1:"")
-        Q
+SROAPCA1 ;BIR/MAM - PRINT CARDIAC CATH INFO ;04/05/04
+ ;;3.0; Surgery ;**38,63,71,88,95,125,142,153**;24 Jun 93;Build 11
+ N SRX F I=200:1:202,206,208,209,202.1 S SRA(I)=$G(^SRF(SRTN,I))
+ I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q
+ D LAB^SROAPCA4
+ I $Y+16>IOSL D PAGE^SROAPCA I SRSOUT Q
+ S Y=$P(SRA(209),"^",4),SRAO(1)=$S(Y="C":"CATH",Y="I":"IVUS",Y="B":"BOTH",Y="NS":" NS",1:"")_"^476"
+ S Y=$P(SRA(206),"^",24),SRX=357,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",25),SRX=358,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",26),SRX=359,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",27),SRX=360,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX
+ S NYUK=$P(SRA(206),"^",30) D LV S SRAO(6)=SHEMP_"^363"
+ S Y=$P(SRA(206),"^",9),SRX=415,SRAO(7)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(209),"^",5),SRX=477,SRAO(8)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",28),SRX=361,SRAO(9)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",33),SRX=362.1,SRAO(10)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",34),SRX=362.2,SRAO(11)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",35),SRX=362.3,SRAO(12)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(209),"^",6),SRX=478,SRAO(13)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(209),"^",7),SRX=479,SRAO(14)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(209),"^",8),SRX=480,SRAO(15)=$$OUT(SRX,Y)_"^"_SRX
+ W !!,"IV. CARDIAC CATHETERIZATION AND ANGIOGRAPHIC DATA"
+ S Y=$P($G(^SRF(SRTN,207)),"^",21) I Y>1 D DT S Y=X
+ D NS W !,"Cardiac Catheterization Date: ",$E(Y,1,8)
+ W !,"Procedure:",?26,$P(SRAO(1),"^"),?41,"Native Coronaries:"
+ S SRX=$P(SRAO(2),"^") W !,"LVEDP:",?26,$J(SRX,3) D MMHG
+ S SRX=$P(SRAO(9),"^") W ?41,"Left Main Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
+ S SRX=$P(SRAO(3),"^") W !,"Aortic Systolic Pressure:",?26,$J(SRX,3) D MMHG
+ S SRX=$P(SRAO(10),"^") W ?41,"LAD Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
+ S SRX=$P(SRAO(11),"^") W !,?41,"Right Coronary Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
+ W !,"For patients having right heart cath:" S SRX=$P(SRAO(12),"^") W ?41,"Circumflex Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
+ ;
+ S SRX=$P(SRAO(4),"^") W !,"PA Systolic Pressure:",?26,$J(SRX,3) D MMHG
+ S SRX=$P(SRAO(5),"^") W !,"PAW Mean Pressure:",?26,$J(SRX,3) D MMHG
+ W ?41,"If a Re-do, indicate stenosis",!,?44," in graft to:"
+ S SRX=$P(SRAO(13),"^") W !,?41,"LAD:",?71,$J(SRX,3) I SRX?1.3N W "%"
+ S SRX=$P(SRAO(14),"^") W !,?41,"Right coronary (include PDA): ",$J(SRX,3) I SRX?1.3N W "%"
+ S SRX=$P(SRAO(15),"^") W !,?41,"Circumflex:",?71,$J(SRX,3) I SRX?1.3N W "%"
+ W !,LN
+ W !,"LV Contraction Grade (from contrast or radionuclide angiogram or 2D Echo):",!,?7,"Grade",?17,"Ejection Fraction Range",?51,"Definition"
+ W !,?8,$P(SRAO(6),"^")
+ W !,LN,!,"Mitral Regurgitation:",?26,$P(SRAO(7),"^")
+ W !,"Aortic stenosis:",?26,$P(SRAO(8),"^")
+ I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q
+ K SRAO S Y=$P(SRA(206),"^",31),SRX=364,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,1.1)),"^",3),SRX=1.13,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(208),"^",12),SRX=414,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",32),SRX=364.1,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(208),"^",13),SRX=414.1,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,.2)),"^",2),SRX=.22,SRAO(0)=$$OUT(SRX,Y)_"^"_SRX
+ W !!,"V. OPERATIVE RISK SUMMARY DATA" S X=$P(SRAO(0),"^") I X'="" W ?40,"(Operation Began: "_X_")"
+ W !,?5,"Physician's Preoperative" S Y=$P($G(^SRF(SRTN,.2)),"^",3) I Y'="" D DT W ?40,"(Operation Ended: "_X_")"
+ W !,?7,"Estimate of Operative Mortality: "_$P(SRAO(1),"^") I $P(SRAO(1),"^")'=""&($P(SRAO(1),"^")'="NS") W "%"
+ S X=$P(SRAO("1A"),"^") I X'="" W ?57,"("_X_")"
+ W !,?5,"ASA Classification:",?35,$P(SRAO(2),"^"),!,?5,"Surgical Priority:",?35,$P(SRAO(3),"^") S X=$P(SRAO("3A"),"^") I X'="" W ?57,"("_X_")"
+ S X=$P($G(^SRO(136,SRTN,0)),"^",2) I X S Y=$P($$CPT^ICPTCOD(X),"^",2) D SSPRIN^SROCPT0 S X=Y
+ S X=$S(X'="":X,1:"CPT Code Missing")
+ W !,?5,"Principal CPT Code:",?35,X,!,?5,"Other Procedures CPT Codes: "
+ S CNT=32,OTH=0 F  S OTH=$O(^SRO(136,SRTN,3,OTH)) Q:'OTH  S CPT=$P($G(^SRO(136,SRTN,3,OTH,0)),"^") D
+ .I CPT S Y=$P($$CPT^ICPTCOD(CPT),"^",2) S SRDA=OTH D SSOTH^SROCPT0 S CPT=Y
+ .S:CPT="" CPT="NONE" S CNT=CNT+3
+ .I CNT+$L(CPT)'>80 W:CNT>35 ";" W ?(CNT),CPT S CNT=CNT+$L(CPT) Q
+ .W !,?35,CPT S CNT=35+$L(CPT)
+ W !,?5,"Preoperative Risk Factors: "
+ I $G(^SRF(SRTN,206.1))'="" S SRQ=0 S X=$G(^SRF(SRTN,206.1)) W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D
+ .I X'[" " W ?25,X Q
+ .S I=0,LINE=1 F  S SRL=$S(LINE=1:48,1:80) D  Q:SRQ
+ ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q
+ ..S J=SRL-I,Y=$E(X,J),I=I+1 I Y=" " W $E(X,1,J-1),!,?5 S X=$E(X,J+1,Z),Z=$L(X),I=0,LINE=LINE+1 I Z<SRL W X S SRQ=1 Q
+ I $Y+20>IOSL D PAGE^SROAPCA I SRSOUT Q
+ K SRA,SRAO D ^SROAPCA2
+ Q
+YN ; store answer
+ S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"")
+ Q
+DT I 'Y S X="" Q
+ S Z=$E($P(Y,".",2),1,4),Z=Z_"0000",Z=$E(Z,1,4),X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$E(Z,1,2)_":"_$E(Z,3,4)
+ Q
+OUT(SRFLD,SRY) ; get data in output form
+ N C,Y
+ S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
+ I Y="NO STUDY" S Y="NS" Q Y
+ Q Y
+MMHG I SRX="NO STUDY"!(SRX="NS") Q
+ W " mm Hg"
+ Q
+NS S Y=$S(Y="NS":"NO STUDY",1:Y)
+ Q
+LV K SHEMP S SHEMP=$S(NYUK="I":" I          > or = 0.55                    NORMAL",NYUK="II":"II             0.45-0.54                   MILD DYSFUNCTION",1:NYUK)
+ Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="III":"III           0.35-0.44                    MODERATE DYSFUNCTION",1:NYUK)
+ Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="IIIa":"IIIa          0.40-0.44                    MODERATE DYSFUNCTION A",1:NYUK)
+ Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="IIIb":"IIIb          0.35-0.39                    MODERATE DYSFUNCTION B",1:NYUK)
+ Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="IV":"IV            0.25-0.34                    SEVERE DYSFUNCTION",NYUK="V":" V             <0.25                       VERY SEVERE DYSFUNCTION",NYUK="NS":"NO LV STUDY",1:"")
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPCA3.m

@@ -1 @@
-SROAPCA3        ;B'HAM ISC/MAM - CARDIAC OCCURRENCE DATA ;02/05/08
-        ;;3.0; Surgery ;**38,71,95,101,125,160,164,166**;24 Jun 93;Build 7
-        D EN^SROCCAT K SRA S SRA(205)=$G(^SRF(SRTN,205)),SRA(208)=$G(^SRF(SRTN,208)),SRA(206)=$G(^SRF(SRTN,206)),SRA(209)=$G(^SRF(SRTN,209))
-        S NYUK=$P(SRA(208),"^") D YN S SRAO(1)=SHEMP_"^384"
-        S Y=$P($G(^DPT(DFN,.35)),"^") D DT^SROAPCA1 S SRAO(2)=X
-        S NYUK=$P(SRA(208),"^",2) D YN S SRAO(3)=SHEMP_"^385",NYUK=$P(SRA(208),"^",3) D YN S SRAO(4)=SHEMP_"^386",NYUK=$P(SRA(205),"^",17) D YN S SRAO(5)=SHEMP_"^254",NYUK=$P(SRA(209),"^",12) D YN S SRAO(6)=SHEMP_"^490"
-        S NYUK=$P(SRA(208),"^",5) D YN S SRAO(7)=SHEMP_"^388",NYUK=$P(SRA(208),"^",6) D YN S SRAO(8)=SHEMP_"^389",NYUK=$P(SRA(205),"^",13) D YN S SRAO(9)=SHEMP_"^285"
-        S NYUK=$P(SRA(208),"^",7) D YN S SRAO(10)=SHEMP_"^391",NYUK=$P(SRA(205),"^",22) D YN S SRAO(11)=SHEMP_"^410"
-        S NYUK=$P(SRA(205),"^",21) D YN S SRAO(12)=SHEMP_"^256",NYUK=$P(SRA(205),"^",26) D YN S SRAO(13)=SHEMP_"^411"
-        S NYUK=$P(SRA(206),"^",39) D YN S SRAO(14)=SHEMP_"^466"
-        S NYUK=$P(SRA(206),"^",40) D YN S SRAO(15)=SHEMP_"^467"
-        I $Y+5>IOSL D PAGE^SROAPCA I SRSOUT Q
-        W !!,"VII. OUTCOMES"
-        W !,"Operative Death:",?18,$P(SRAO(1),"^"),?43,"Date of Death:",?58,$P(SRAO(2),"^")
-        ;I $Y+10>IOSL D PAGE^SROAPCA I SRSOUT Q
-        W !!,"Perioperative (30 day) Occurrences:"
-        W !,?2,"Perioperative MI:",?36,$P(SRAO(3),"^"),?42,"Repeat cardiac Surg procedure:",?74,$P(SRAO(10),"^")
-        W !,?2,"Endocarditis:",?36,$P(SRAO(4),"^"),?42,"Tracheostomy:",?74,$P(SRAO(14),"^")
-        W !,?2,"Renal Failure Requiring Dialysis:",?36,$P(SRAO(5),"^"),?42,"Ventilator supp within 30 days:",?74,$P(SRAO(6),"^")
-        W !,?2,"Mediastinitis:",?36,$P(SRAO(7),"^"),?42,"Stroke/CVA:",?74,$P(SRAO(12),"^")
-        W !,?2,"Cardiac Arrest Requiring CPR:",?36,$P(SRAO(13),"^"),?42,"Coma > or = 24 Hours:",?74,$P(SRAO(11),"^")
-        W !,?2,"Reoperation for Bleeding:",?36,$P(SRAO(8),"^"),?42,"New Mech Circulatory Support:",?74,$P(SRAO(15),"^")
-        W !,?2,"On ventilator > or = 48 hr:",?36,$P(SRAO(9),"^")
-        D RES
-        Q
-YN      ; store answer
-        S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"")
-        Q
-        ;
-RES     I $Y+12>IOSL D PAGE^SROAPCA I SRSOUT Q
-        S SRA(208)=$G(^SRF(SRTN,208))
-        S SRA(.2)=$G(^SRF(SRTN,.2))
-        W !!,"VIII. RESOURCE DATA"
-        S Y=$P(SRA(208),"^",14) D DT^SROAPCA1 W !,"Hospital Admission Date:",?47,X
-        S Y=$P(SRA(208),"^",15) D DT^SROAPCA1 W !,"Hospital Discharge Date:",?47,X
-        S Y=$P(SRA(.2),"^",10) D DT^SROAPCA1 W !,"Time Patient In  OR: ",?47,X
-        S Y=$P(SRA(.2),"^",12) D DT^SROAPCA1 W !,"Time Patient Out OR: ",?47,X
-        S Y=$P(SRA(208),"^",22) I Y>1 D DT^SROAPCA1 S Y=X
-        S Y=$S(Y="NS":"Unable to determine",Y="RI":"Remains intubated at 30 days",1:Y) W !,"Date and Time Patient Extubated: ",?47,Y
-        I $P(SRA(208),"^",22)>1,$P(SRA(.2),"^",12) D
-        .S X=$$FMDIFF^XLFDT($P(SRA(208),"^",22),$P(SRA(.2),"^",12),2) W !,?5,"Postop Intubation Hrs: "_$FN((X/3600),"+",1)
-        S Y=$P(SRA(208),"^",23) I Y>1 D DT^SROAPCA1 S Y=X
-        S Y=$S(Y="NS":"Unable to determine",Y="RI":"Remains in ICU at 30 days",1:Y) W !,"Date and Time Patient Discharged from ICU: ",?47,Y
-        S Y=$P(SRA(209),"^") W !,"Patient is Homeless: ",?47,$S(Y="Y":"YES",Y="N":"NO",Y="NS":"NS",1:"")
-        S Y=$P(SRA(206),"^",41) W !,"Cardiac Surg Performed at Non-VA Facility: ",?47,$S(Y="Y":"YES",Y="N":"NO",Y="NS":"UNKNOWN",1:"")
-        S Y=$P(SRA(209),"^",15) D DT^SROAPCA1 W !,"CT Surgery Consult Date: ",?47,$P(X," ")
-        S Y=$P(SRA(209),"^",16),C=$P(^DD(130,515,0),"^",2) D:Y'="" Y^DIQ W !,"Cause for Delay for Surgery: ",?47,Y
-        W !,"Resource Data Comments: "
-        I $G(^SRF(SRTN,206.2))'="" S SRQ=0 S X=$G(^SRF(SRTN,206.2)) W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D
-        .I X'[" " W ?25,X Q
-        .S I=0,LINE=1 F  S SRL=$S(LINE=1:48,1:80) D  Q:SRQ
-        ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q
-        ..S J=SRL-I,Y=$E(X,J),I=I+1 I Y=" " W $E(X,1,J-1),!,?5 S X=$E(X,J+1,Z),Z=$L(X),I=0,LINE=LINE+1 I Z<SRL W X S SRQ=1 Q
-        I $Y+7>IOSL D PAGE^SROAPCA I SRSOUT Q
-        W ! F MOE=1:1:80 W "="
-        W !,"IX. SOCIOECONOMIC, ETHNICITY, AND RACE"
-        N SREMP S SREMP=$P(SRA(208),"^",18) S SREMP=$S(SREMP=1:"EMPLOYED FULL TIME",SREMP=2:"EMPLOYED PART TIME",SREMP=3:"NOT EMPLOYED",SREMP=4:"SELF EMPLOYED",SREMP=5:"RETIRED",SREMP=6:"ACTIVE MILITARY DUTY",SREMP=9:"UNKNOWN",1:" ")
-        W !,?1,"Employment Status Preoperatively: ",?40,SREMP
-        K SRA,SRAO
-        ; Race/Ethnic
-        D ENTH^SRORACE
-        I $Y+7>IOSL D PAGE^SROAPCA I SRSOUT Q
-        D ^SROAPCA4
-        W !!," *** End of report for "_SRANM_" assessment #"_SRTN_" ***"
-        I $E(IOST)'="P" W ! K DIR S DIR(0)="E" D ^DIR K DIR
-        Q
+SROAPCA3 ;B'HAM ISC/MAM - CARDIAC OCCURRENCE DATA ;08/23/07
+ ;;3.0; Surgery ;**38,71,95,101,125,160,164**;24 Jun 93;Build 2
+ D EN^SROCCAT K SRA S SRA(205)=$G(^SRF(SRTN,205)),SRA(208)=$G(^SRF(SRTN,208)),SRA(206)=$G(^SRF(SRTN,206)),SRA(209)=$G(^SRF(SRTN,209))
+ S NYUK=$P(SRA(208),"^") D YN S SRAO(1)=SHEMP_"^384"
+ S Y=$P($G(^DPT(DFN,.35)),"^") D DT^SROAPCA1 S SRAO(2)=X
+ S NYUK=$P(SRA(208),"^",2) D YN S SRAO(3)=SHEMP_"^385",NYUK=$P(SRA(208),"^",3) D YN S SRAO(4)=SHEMP_"^386",NYUK=$P(SRA(205),"^",17) D YN S SRAO(5)=SHEMP_"^254",NYUK=$P(SRA(209),"^",12) D YN S SRAO(6)=SHEMP_"^490"
+ S NYUK=$P(SRA(208),"^",5) D YN S SRAO(7)=SHEMP_"^388",NYUK=$P(SRA(208),"^",6) D YN S SRAO(8)=SHEMP_"^389",NYUK=$P(SRA(205),"^",13) D YN S SRAO(9)=SHEMP_"^285"
+ S NYUK=$P(SRA(208),"^",7) D YN S SRAO(10)=SHEMP_"^391",NYUK=$P(SRA(205),"^",22) D YN S SRAO(11)=SHEMP_"^410"
+ S NYUK=$P(SRA(205),"^",21) D YN S SRAO(12)=SHEMP_"^256",NYUK=$P(SRA(205),"^",26) D YN S SRAO(13)=SHEMP_"^411"
+ S NYUK=$P(SRA(206),"^",39) D YN S SRAO(14)=SHEMP_"^466"
+ S NYUK=$P(SRA(206),"^",40) D YN S SRAO(15)=SHEMP_"^467"
+ I $Y+5>IOSL D PAGE^SROAPCA I SRSOUT Q
+ W !!,"VII. OUTCOMES"
+ W !,"Operative Death:",?18,$P(SRAO(1),"^"),?43,"Date of Death:",?58,$P(SRAO(2),"^")
+ ;I $Y+10>IOSL D PAGE^SROAPCA I SRSOUT Q
+ W !!,"Perioperative (30 day) Occurrences:"
+ W !,?2,"Perioperative MI:",?36,$P(SRAO(3),"^"),?42,"Repeat cardiac Surg procedure:",?74,$P(SRAO(10),"^")
+ W !,?2,"Endocarditis:",?36,$P(SRAO(4),"^"),?42,"Tracheostomy:",?74,$P(SRAO(14),"^")
+ W !,?2,"Renal Failure Requiring Dialysis:",?36,$P(SRAO(5),"^"),?42,"Ventilator supp within 30 days:",?74,$P(SRAO(6),"^")
+ W !,?2,"Mediastinitis:",?36,$P(SRAO(7),"^"),?42,"Stroke/CVA:",?74,$P(SRAO(12),"^")
+ W !,?2,"Cardiac Arrest Requiring CPR:",?36,$P(SRAO(13),"^"),?42,"Coma > or = 24 Hours:",?74,$P(SRAO(11),"^")
+ W !,?2,"Reoperation for Bleeding:",?36,$P(SRAO(8),"^"),?42,"New Mech Circulatory Support:",?74,$P(SRAO(15),"^")
+ W !,?2,"On ventilator > or = 48 hr:",?36,$P(SRAO(9),"^")
+ D RES
+ Q
+YN ; store answer
+ S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"")
+ Q
+ ;
+RES I $Y+12>IOSL D PAGE^SROAPCA I SRSOUT Q
+ S SRA(208)=$G(^SRF(SRTN,208))
+ S SRA(.2)=$G(^SRF(SRTN,.2))
+ W !!,"VIII. RESOURCE DATA"
+ S Y=$P($G(^SRF(SRTN,208)),"^",14) D DT^SROAPCA1 W !,"Hospital Admission Date:",?47,X
+ S Y=$P($G(^SRF(SRTN,208)),"^",15) D DT^SROAPCA1 W !,"Hospital Discharge Date:",?47,X
+ S Y=$P(SRA(.2),"^",10) D DT^SROAPCA1 W !,"Time Patient In  OR: ",?47,X
+ S Y=$P(SRA(.2),"^",12) D DT^SROAPCA1 W !,"Time Patient Out OR: ",?47,X
+ S Y=$P($G(^SRF(SRTN,208)),"^",22) I Y>1 D DT^SROAPCA1 S Y=X
+ S Y=$S(Y="NS":"Unable to determine",Y="RI":"Remains intubated at 30 days",1:Y) W !,"Date and Time Patient Extubated: ",?47,Y
+ S Y=$P($G(^SRF(SRTN,208)),"^",23) I Y>1 D DT^SROAPCA1 S Y=X
+ S Y=$S(Y="NS":"Unable to determine",Y="RI":"Remains in ICU at 30 days",1:Y) W !,"Date and Time Patient Discharged from ICU: ",?47,Y
+ S Y=$P(SRA(209),"^") W !,"Patient is Homeless: ",?47,$S(Y="Y":"YES",Y="N":"NO",Y="NS":"NS",1:"")
+ S Y=$P(SRA(206),"^",41) W !,"Cardiac Surg Performed at Non-VA Facility: ",?47,$S(Y="Y":"YES",Y="N":"NO",Y="NS":"UNKNOWN",1:"")
+ S Y=$P(SRA(209),"^",15) D DT^SROAPCA1 W !,"CT Surgery Consult Date: ",?47,$P(X," ")
+ W !,"Resource Data Comments: "
+ I $G(^SRF(SRTN,206.2))'="" S SRQ=0 S X=$G(^SRF(SRTN,206.2)) W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D
+ .I X'[" " W ?25,X Q
+ .S I=0,LINE=1 F  S SRL=$S(LINE=1:48,1:80) D  Q:SRQ
+ ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q
+ ..S J=SRL-I,Y=$E(X,J),I=I+1 I Y=" " W $E(X,1,J-1),!,?5 S X=$E(X,J+1,Z),Z=$L(X),I=0,LINE=LINE+1 I Z<SRL W X S SRQ=1 Q
+ I $Y+7>IOSL D PAGE^SROAPCA I SRSOUT Q
+ W ! F MOE=1:1:80 W "="
+ W !,"IX. SOCIOECONOMIC, ETHNICITY, AND RACE"
+ N SREMP S SREMP=$P(SRA(208),"^",18) S SREMP=$S(SREMP=1:"EMPLOYED FULL TIME",SREMP=2:"EMPLOYED PART TIME",SREMP=3:"NOT EMPLOYED",SREMP=4:"SELF EMPLOYED",SREMP=5:"RETIRED",SREMP=6:"ACTIVE MILITARY DUTY",SREMP=9:"UNKNOWN",1:" ")
+ W !,?1,"Employment Status Preoperatively: ",?40,SREMP
+ K SRA,SRAO
+ ; Race/Ethnic
+ D ENTH^SRORACE
+ I $Y+7>IOSL D PAGE^SROAPCA I SRSOUT Q
+ D ^SROAPCA4
+ W !!," *** End of report for "_SRANM_" assessment #"_SRTN_" ***"
+ I $E(IOST)'="P" W ! K DIR S DIR(0)="E" D ^DIR K DIR
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPM.m

@@ -1 @@
-SROAPM  ;BIR/ADM - PATIENT DEMOGRAPHIC INFO ;03/03/08
-        ;;3.0; Surgery ;**47,81,111,107,100,125,142,160,166**;24 Jun 93;Build 7
-        I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
-        S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
-START   G:SRSOUT END D HDR^SROAUTL
-        S DIR("A",1)="Enter/Edit Patient Demographic Information",DIR("A",2)=" ",DIR("A",3)="1. Capture Information from PIMS Records",DIR("A",4)="2. Enter, Edit, or Review Information",DIR("A",5)=" "
-        S DIR("?",1)="Enter '1' if you want to capture patient movement information from PIMS",DIR("?",2)="records.  Enter '2' if you want to enter, edit, or review patient",DIR("?")="movement and other information on this screen."
-        S DIR("A")="Select Number",DIR(0)="NO^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END
-        I Y=1 D PIMS G START
-EDIT    S SRR=0 D HDR^SROAUTL K DR S SRQ=0,(DR,SRDR)="413;452;453;454;418;419;420;421;247;.011"
-        K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
-        K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
-        .D TR,GET
-        .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
-        .W !,$S($L(SRZ)<2:" "_SRZ,1:SRZ)_". "_$P(Z,"^")_":" D EXT
-        ;
-        D DEM^VADPT
-        ;Find patient's ethnicity and list it on the display
-        W !,"11. Patient's Ethnicity:" S SRZ(11)="" D
-        .I $G(VADM(11)) W ?40,$P(VADM(11,1),U,2)
-        .I '$G(VADM(11)) W ?40,"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)=40!$L(SROLINE)<40 S SROL(N)=SROLINE,SRNUM1=2
-        I $L(SROLINE)>40 D WRAP
-        ;
-        W !,"12. Patient's Race:" S SRZ(12)=""
-        I $G(VADM(12)) F D=1:1:SRNUM1-1 D
-        .W:D=1 ?40,SROL(D)
-        .W:D'=1 !,?40,SROL(D)
-        ;
-        I '$G(VADM(12)) W ?40,"UNANSWERED"
-        ;
-        K DA,DIC,DIQ,DR,SRY S (DR,SRDR)="342;516;513",DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
-        S SRZ=12 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
-        .D TR,GET
-        .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
-        .W !,$S($L(SRZ)<2:" "_SRZ,1:SRZ)_". "_$P(Z,"^")_":" D EXT
-        ;S SRZ=15,SRZ(13)="Date of Death^342",SREXT=SRY(130,SRTN,342,"E") W !,"13. Date/Time of Death:",?40,SREXT
-        ;S SRZ(14)="Surgery Consult Date^513",SREXT=SRY(130,SRTN,513,"E") W !,"14. Surgery Consult Date:",?40,SREXT
-        ;S SRZ(15)="Date Surgery Consult Requested^516",SREXT=SRY(130,SRTN,516,"E") W !,"15. Date Surgery Consult Requested:",?40,SREXT
-        K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1
-        ;
-        W !! F K=1:1:80 W "-"
-        D SEL G:SRR=1 EDIT
-        S SROERR=SRTN D ^SROERR0
-        G START
-        Q
-        ;
-WRAP    ;Wrap multiple race entries so that wrapped line
-        ;does not break in the middle of a word
-        ;
-        N SROLNGTH S SROLNGTH=$L(SROLINE),E=40,SROWRAP="",SROLN="",SROLN1="",SROL=""
-        F I=1:40:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D
-        .F K=40:-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+40
-        ;
-        S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP=""
-        I $L(SROLN1(I))+$L(SROWRAP)>39 S SROLN1(I+1)=SROWRAP   ;Last line 
-        I $L(SROLN1(I))+$L(SROWRAP)'>39 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
-        ;
-EXT     I $L(SREXT)<40 W ?40,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q
-        N I,J,X,Y S X=SREXT F  D  W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q
-        .F I=0:1:38 S J=39-I,Y=$E(X,J) I Y=" " W ?40,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q
-        Q
-SEL     W !!,"Select Patient Demographics Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
-        I (X=11)!(X=12) S SRR=1 W !!,"The Patient's Race and Ethnicity information cannot be updated through the" D  Q
-        .W !,"Surgery package options."
-        .W !!,"Press RETURN to continue " R X:DTIME
-        Q:X=""  S:X="a" X="A" I '$D(SRFLG),'$D(SRZ(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q
-        I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRZ)!(Y>Z) D HELP S SRR=1 Q
-        I X="A" S X="1:"_SRZ
-        I X?1.2N1":"1.2N D RANGE S SRR=1 Q
-        I $D(SRZ(X)),+X=X S EMILY=X D  S SRR=1
-        .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
-        Q
-PIMS    ; get update from PIMS records
-        W ! K DIR S DIR("A")="Are you sure you want to retrieve information from PIMS records ? ",DIR("B")="YES",DIR(0)="YOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
-        I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
-        .W ! D WAIT^DICD D ^SROAPIMS
-        Q
-HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below.",!!,"NOTE: Items 11 and 12 cannot be updated through the surgery package options."
-        W !!,"1. Enter 'A' to update items 1 through 10 and items 13 through 15.",!!,"2. Enter a number (1-"_SRZ_") to update an individual item.  (For example,",!,"   enter '1' to update "_$P(SRZ(1),"^")_")"
-        W !!,"3. Enter a range of numbers (1-"_SRZ_") separated by a ':' to enter a range",!,"   of items.  (For example, enter '1:4' to update items 1, 2, 3 and 4.)",!
-        I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",!
-PRESS   W ! K DIR S DIR("A")="Press the return key to continue or '^' to exit: ",DIR(0)="FOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        Q
-RANGE   ; range of numbers
-        I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
-        .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) D
-        ..I SHEMP<13 F EMILY=SHEMP:1:10,13:1:15 Q:SRSOUT  D ONE
-        ..I SHEMP>12 F EMILY=SHEMP:1:15 Q:SRSOUT  D ONE
-        Q
-ONE     ; edit one item
-        K DR,DA,DIE S DR=$P(SRZ(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1
-        Q
-TR      S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
-        Q
-GET     S X=$T(@J)
-        Q
-END     W @IOF D ^SRSKILL
-        Q
-PJAA    ;;.011^In/Out-Patient Status
-BDG     ;;247^Length of Postop Hospital Stay
-CDB     ;;342^Date of Death
-DAC     ;;413^Transfer Status
-DAG     ;;417^Patient's Race
-DAH     ;;418^Hospital Admission Date/Time
-DAI     ;;419^Hospital Discharge Date/Time
-DBJ     ;;420^Admit/Transfer to Surgical Svc.
-DBA     ;;421^Discharge/Transfer to Chronic Care
-DEB     ;;452^Observation Admission Date/Time
-DEC     ;;453^Observation Discharge Date/Time
-DED     ;;454^Observation Treating Specialty
-EAC     ;;513^Surgery Consult Date
-EAF     ;;516^Date Surgery Consult Requested
+SROAPM ;BIR/ADM - PATIENT DEMOGRAPHIC INFO ;01/23/07
+ ;;3.0; Surgery ;**47,81,111,107,100,125,142,160**;24 Jun 93;Build 7
+ I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
+ S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
+START G:SRSOUT END D HDR^SROAUTL
+ S DIR("A",1)="Enter/Edit Patient Demographic Information",DIR("A",2)=" ",DIR("A",3)="1. Capture Information from PIMS Records",DIR("A",4)="2. Enter, Edit, or Review Information",DIR("A",5)=" "
+ S DIR("?",1)="Enter '1' if you want to capture patient movement information from PIMS",DIR("?",2)="records.  Enter '2' if you want to enter, edit, or review patient",DIR("?")="movement and other information on this screen."
+ S DIR("A")="Select Number",DIR(0)="NO^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END
+ I Y=1 D PIMS G START
+EDIT S SRR=0 D HDR^SROAUTL K DR S SRQ=0,(DR,SRDR)="413;452;453;454;418;419;420;421;247;.011"
+ K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
+ K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
+ .D TR,GET
+ .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
+ .W !,$S($L(SRZ)<2:" "_SRZ,1:SRZ)_". "_$P(Z,"^")_":" D EXT
+ ;
+ D DEM^VADPT
+ ;Find patient's ethnicity and list it on the display
+ W !,"11. Patient's Ethnicity:" S SRZ(11)="" D
+ .I $G(VADM(11)) W ?40,$P(VADM(11,1),U,2)
+ .I '$G(VADM(11)) W ?40,"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)=40!$L(SROLINE)<40 S SROL(N)=SROLINE,SRNUM1=2
+ I $L(SROLINE)>40 D WRAP
+ ;
+ W !,"12. Patient's Race:" S SRZ(12)=""
+ I $G(VADM(12)) F D=1:1:SRNUM1-1 D
+ .W:D=1 ?40,SROL(D)
+ .W:D'=1 !,?40,SROL(D)
+ ;
+ I '$G(VADM(12)) W ?40,"UNANSWERED"
+ ;
+ K DA,DIC,DIQ,DR,SRY S (DR,SRDR)="342",DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
+ S SRZ=13,SRZ(13)="Date of Death^342",SREXT=SRY(130,SRTN,342,"E")
+ W !,"13. Date/Time of Death:",?40,SREXT
+ K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1
+ ;
+ W !! F K=1:1:80 W "-"
+ D SEL G:SRR=1 EDIT
+ S SROERR=SRTN D ^SROERR0
+ G START
+ Q
+ ;
+WRAP ;Wrap multiple race entries so that wrapped line
+ ;does not break in the middle of a word
+ ;
+ N SROLNGTH S SROLNGTH=$L(SROLINE),E=40,SROWRAP="",SROLN="",SROLN1="",SROL=""
+ F I=1:40:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D
+ .F K=40:-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+40
+ ;
+ S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP=""
+ I $L(SROLN1(I))+$L(SROWRAP)>39 S SROLN1(I+1)=SROWRAP   ;Last line 
+ I $L(SROLN1(I))+$L(SROWRAP)'>39 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
+ ;
+EXT I $L(SREXT)<40 W ?40,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q
+ N I,J,X,Y S X=SREXT F  D  W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q
+ .F I=0:1:38 S J=39-I,Y=$E(X,J) I Y=" " W ?40,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q
+ Q
+SEL W !!,"Select number of item to edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+ I (X=11)!(X=12) S SRR=1 W !!,"The Patient's Race and Ethnicity information cannot be updated through the" D  Q
+ .W !,"Surgery package options."
+ .W !!,"Press RETURN to continue " R X:DTIME
+ Q:X=""  S:X="a" X="A" I '$D(SRFLG),'$D(SRZ(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q
+ I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRZ)!(Y>Z) D HELP S SRR=1 Q
+ I X="A" S X="1:"_SRZ
+ I X?1.2N1":"1.2N D RANGE S SRR=1 Q
+ I $D(SRZ(X)),+X=X S EMILY=X D  S SRR=1
+ .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
+ Q
+PIMS ; get update from PIMS records
+ W ! K DIR S DIR("A")="Are you sure you want to retrieve information from PIMS records ? ",DIR("B")="YES",DIR(0)="YOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
+ I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
+ .W ! D WAIT^DICD D ^SROAPIMS
+ Q
+HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below.",!!,"NOTE: Items 11 and 12 cannot be updated through the surgery package options."
+ W !!,"1. Enter 'A' to update items 1 through 10 and item 13.",!!,"2. Enter a number (1-"_SRZ_") to update an individual item.  (For example,",!,"   enter '1' to update "_$P(SRZ(1),"^")_")"
+ W !!,"3. Enter a range of numbers (1-"_SRZ_") separated by a ':' to enter a range",!,"   of items.  (For example, enter '1:4' to update items 1, 2, 3 and 4.)",!
+ I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",!
+PRESS W ! K DIR S DIR("A")="Press the return key to continue or '^' to exit: ",DIR(0)="FOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
+ Q
+RANGE ; range of numbers
+ I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
+ .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:10,13 Q:SRSOUT  D ONE
+ Q
+ONE ; edit one item
+ K DR,DA,DIE S DR=$P(SRZ(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1
+ Q
+TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
+ Q
+GET S X=$T(@J)
+ Q
+END W @IOF D ^SRSKILL
+ Q
+PJAA ;;.011^In/Out-Patient Status
+BDG ;;247^Length of Postop Hospital Stay
+CDB ;;342^Date of Death
+DAC ;;413^Transfer Status
+DAG ;;417^Patient's Race
+DAH ;;418^Hospital Admission Date/Time
+DAI ;;419^Hospital Discharge Date/Time
+DBJ ;;420^Admit/Transfer to Surgical Svc.
+DBA ;;421^Discharge/Transfer to Chronic Care
+DEB ;;452^Observation Admission Date/Time
+DEC ;;453^Observation Discharge Date/Time
+DED ;;454^Observation Treating Specialty

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPRE.m

@@ -1 @@
-SROAPRE ;BIR/MAM - PREOPERATIVE INFO ;11/26/07
-        ;;3.0; Surgery ;**38,47,55,88,100,125,142,166**;24 Jun 93;Build 7
-        I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
-        S (SRSOUT,SRACLR)=0,SRSUPCPT=1 D ^SROAUTL,DUP^SROAUTL G:SRSOUT END
-START   D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROAPS1
-ASK     W !,"Select Preoperative Information to Edit: " R X:DTIME I '$T!(X["^") D CONCC G END
-        S:X="" X="+1" S:X="a" X="A" S:X="n" X="N"
-        I $L(X)=2,'$D(SRAO(X)),X?1N1A S Z=$E(X,2),Z=$TR(Z,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") I $D(SRAO($E(X)_Z)) S X=$E(X)_Z
-        I '$D(SRAO(X)),(X'?.N1":".N),(X'="A"),(X'="N"),(X'="+1") D HELP G:SRSOUT END G START
-        I X="+1" D CONCC,^SROAPR2 G START
-        I X="A" S X="1:6"
-        I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>6)!(Y>Z) D HELP G:SRSOUT END G START
-        I X="N" D  G:SRSOUT END G START
-        .W ! K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to set all fields on this page to NO"
-        .D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
-        .I Y D NO2ALL^SROAPRE1
-        S SRPAGE="" D HDR^SROAUTL
-        I X?.N1":".N D RANGE G START
-        I $D(SRAO(X)),+X=X S EMILY=X D  G START
-        .I $$LOCK^SROUTL(SRTN) W ! D:EMILY<4 ^SROAPRE1 D:EMILY>3 ^SROAPR1A D UNLOCK^SROUTL(SRTN)
-        I $D(SRAO(X)),$$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
-        .I X="1H" D FUNCTH Q
-        .S SRX=X W ! K DR,DIE S DA=SRTN,DR=$P(SRAO(X),"^",2)_"T",DIE=130 D ^DIE K DR
-        G START
-END     I '$D(SREQST) W @IOF D ^SRSKILL
-        Q
-FUNCTH  N X K DA,DIR S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D  Q
-        .I $D(DTOUT)!$D(DUOUT) Q
-        .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q
-        .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR
-        Q
-HELP    W @IOF,!!!!,"Enter the number, number/letter combination, or range of numbers you want to",!,"edit.  Examples of proper responses are listed below."
-        W !!,"1. Enter 'A' to update all information.",!!,"2. Enter 'N' to set all fields on this page to NO."
-        W !!,"3. Enter a number (1-6) to update the information in that group.  (For",!,"   example, enter '5' to update all cardiac information)"
-        W !!,"4. Enter a number/letter combination to update a specific occurrence. (To ",!,"   update Current Pneumonia, enter '2C'.)"
-        W !!,"5. Enter a range of numbers (1-6) separated by a ':' to enter a range of",!,"   occurrences.  (For example, enter '2:4' to enter all pulmonary,",!,"   hepatobiliary, and gastrointestinal information)"
-        W !!,"6. Press <RET> to continue to page 2 of this option."
-        W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1
-        Q
-RANGE   ; range of numbers
-        I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
-        .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) W:SHEMP<9 ! F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D:EMILY<4 ^SROAPRE1 D:EMILY>3 ^SROAPR1A
-        Q
-RET     Q:SRSOUT  W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
-        Q
-CONCC   ; check for concurrent case and update if one exists
-        S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON
-        Q:$P($G(^SRF(SRCON,"RA")),"^",2)="C"
-        S SRI="" F  S SRI=$O(SRAO(SRI)) Q:SRI=""  S SRZ=$P(SRAO(SRI),"^",2) K DA,DIC,DIQ,DR,SRY D
-        .S DA=SRTN,DR=SRZ,DIC="^SRF(",DIQ="SRY",DIQ(0)="I" D EN^DIQ1 S SRX=SRY(130,SRTN,SRZ,"I") S:SRX="" SRX="@"
-        .I $$LOCK^SROUTL(SRTN) K DA,DIE,DR S DA=SRCON,DIE=130,DR=SRZ_"////"_SRX D ^DIE K DR D UNLOCK^SROUTL(SRTN)
-        Q
+SROAPRE ;BIR/MAM - PREOPERATIVE INFO ;06/03/05
+ ;;3.0; Surgery ;**38,47,55,88,100,125,142**;24 Jun 93
+ I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
+ S (SRSOUT,SRACLR)=0,SRSUPCPT=1 D ^SROAUTL,DUP^SROAUTL G:SRSOUT END
+START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROAPS1
+ASK W !,"Select Preoperative Information to Edit: " R X:DTIME I '$T!(X["^") D CONCC G END
+ S:X="" X="+1" S:X="a" X="A" S:X="n" X="N"
+ I $L(X)=2,'$D(SRAO(X)),X?1N1A S Z=$E(X,2),Z=$TR(Z,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") I $D(SRAO($E(X)_Z)) S X=$E(X)_Z
+ I '$D(SRAO(X)),(X'?.N1":".N),(X'="A"),(X'="N"),(X'="+1") D HELP G:SRSOUT END G START
+ I X="+1" D CONCC,^SROAPR2 G START
+ I X="A" S X="1:6"
+ I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>6)!(Y>Z) D HELP G:SRSOUT END G START
+ I X="N" D  G:SRSOUT END G START
+ .W ! K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to set all fields on this page to NO"
+ .D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
+ .I Y D NO2ALL^SROAPRE1
+ S SRPAGE="" D HDR^SROAUTL
+ I X?.N1":".N D RANGE G START
+ I $D(SRAO(X)),+X=X S EMILY=X D  G START
+ .I $$LOCK^SROUTL(SRTN) W ! D:EMILY<4 ^SROAPRE1 D:EMILY>3 ^SROAPR1A D UNLOCK^SROUTL(SRTN)
+ I $D(SRAO(X)),$$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
+ .I X="1J" D FUNCTI Q
+ .I X="1I" D FUNCTJ Q
+ .S SRX=X W ! K DR,DIE S DA=SRTN,DR=$P(SRAO(X),"^",2)_"T",DIE=130 D ^DIE K DR
+ G START
+END I '$D(SREQST) W @IOF D ^SRSKILL
+ Q
+FUNCTI N X K DA,DIR S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D  Q
+ .I $D(DTOUT)!$D(DUOUT) Q
+ .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q
+ .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR
+ Q
+FUNCTJ N X K DA,DIR S DA=SRTN,DIR(0)="130,240",DIR("A")="Functional Health Status Prior to Current Illness" D ^DIR K DIR D  Q
+ .I $D(DTOUT)!$D(DUOUT) Q
+ .I X="@" K DIE,DR S DIE=130,DR="240///@" D ^DIE K DA,DIE,DR Q
+ .K DIE,DR S DIE=130,DR="240////"_Y D ^DIE K DA,DIE,DR
+ Q
+HELP W @IOF,!!!!,"Enter the number, number/letter combination, or range of numbers you want to",!,"edit.  Examples of proper responses are listed below."
+ W !!,"1. Enter 'A' to update all information.",!!,"2. Enter 'N' to set all fields on this page to NO."
+ W !!,"3. Enter a number (1-6) to update the information in that group.  (For",!,"   example, enter '5' to update all cardiac information)"
+ W !!,"4. Enter a number/letter combination to update a specific occurrence. (To ",!,"   update Current Pneumonia, enter '2C'.)"
+ W !!,"5. Enter a range of numbers (1-6) separated by a ':' to enter a range of",!,"   occurrences.  (For example, enter '2:4' to enter all pulmonary,",!,"   hepatobiliary, and gastrointestinal information)"
+ W !!,"6. Press <RET> to continue to page 2 of this option."
+ W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1
+ Q
+RANGE ; range of numbers
+ I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
+ .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) W:SHEMP<9 ! F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D:EMILY<4 ^SROAPRE1 D:EMILY>3 ^SROAPR1A
+ Q
+RET Q:SRSOUT  W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+ Q
+CONCC ; check for concurrent case and update if one exists
+ S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON
+ Q:$P($G(^SRF(SRCON,"RA")),"^",2)="C"
+ S SRI="" F  S SRI=$O(SRAO(SRI)) Q:SRI=""  S SRZ=$P(SRAO(SRI),"^",2) K DA,DIC,DIQ,DR,SRY D
+ .S DA=SRTN,DR=SRZ,DIC="^SRF(",DIQ="SRY",DIQ(0)="I" D EN^DIQ1 S SRX=SRY(130,SRTN,SRZ,"I") S:SRX="" SRX="@"
+ .I $$LOCK^SROUTL(SRTN) K DA,DIE,DR S DA=SRCON,DIE=130,DR=SRZ_"////"_SRX D ^DIE K DR D UNLOCK^SROUTL(SRTN)
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPRE1.m

@@ -1 @@
-SROAPRE1        ;BIR/MAM - EDIT PAGE 1 PREOP ;11/26/07
-        ;;3.0; Surgery ;**38,47,125,135,141,166**;24 Jun 93;Build 7
-        K DA D @EMILY Q
-1       ; edit general information
-        W ! K DIR S X=$P(SRAO(1),"^") I X'="" S DIR("B")=X
-        S DIR(0)="130,402",DIR("A")="GENERAL" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
-        I X="@" S SRCAT="General" D SURE Q:SRSOUT  G:'SRYN 1 S (SRAX,X)="",$P(^SRF(SRTN,200),"^")="" D NOGEN Q
-        S SRAX=Y,$P(^SRF(SRTN,200),"^")=SRAX I Y["N" D NOGEN Q
-        I Y["Y" D GEN
-        Q
-2       ; edit pulmonary information
-        W ! K DIR S X=$P(SRAO(2),"^") I X'="" S DIR("B")=X
-        S DIR(0)="130,241",DIR("A")="PULMONARY" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
-        I X="@" S SRCAT="Pulmonary" D SURE Q:SRSOUT  G:'SRYN 2 S (SRAX,X)="",$P(^SRF(SRTN,200),"^",9)="" D NOPULM Q
-        S SRAX=Y,$P(^SRF(SRTN,200),"^",9)=SRAX I Y["N" D NOPULM Q
-        I Y["Y" D PULM
-        Q
-3       ; edit hepatobiliary information
-        W ! K DIR S X=$P(SRAO(3),"^") I X'="" S DIR("B")=X
-        S DIR(0)="130,244",DIR("A")="HEPATOBILIARY" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
-        I X="@" S SRCAT="Hepatobiliary" D SURE Q:SRSOUT  G:'SRYN 3 S (SRAX,X)="",$P(^SRF(SRTN,200),"^",13)="" D NOHEP Q
-        S SRAX=Y,$P(^SRF(SRTN,200),"^",13)=SRAX I Y["N" D NOHEP Q
-        I Y["Y" D HEP
-        Q
-GEN     ; general
-        N SRUP S SRUP=""
-        W ! K DR,DIE S DA=SRTN,DIE=130,DR="236T;237T;346T;202T;246T;325T;238T" D ^DIE K DIE,DR I $D(Y) Q
-        K DIR S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D
-        .I $D(DTOUT)!$D(DUOUT) Q
-        .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q
-        .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR
-        S SRACLR=0
-        Q
-NOGEN   ; no general problems
-        S $P(^SRF(SRTN,200),"^",6)=$S(X="":"",1:1) F I=2,3,4,7 S $P(^SRF(SRTN,200),"^",I)=SRAX
-        S $P(^SRF(SRTN,200.1),"^",2)=$S(X="":"",X="NS":"NS",1:1)
-        Q
-PULM    ; pulmonary
-        W ! K DR,DIE S DA=SRTN,DIE=130,DR="204T;203T;326T" D ^DIE K DR
-        S SRACLR=0
-        Q
-NOPULM  ; no pulmonary problems
-        F I=10:1:12 S $P(^SRF(SRTN,200),"^",I)=SRAX
-        Q
-HEP     ; hepatobiliary
-        K DR,DIE S DIE=130,DA=SRTN,DR="212////Y" D ^DIE K DR
-        S SRACLR=0
-        Q
-NOHEP   ; no hepatobiliary problems
-        S $P(^SRF(SRTN,200),"^",15)=SRAX
-        Q
-RET     W !! K DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        Q
-SURE    W ! K DIR S DIR("A")="   Sure you want to delete all "_SRCAT_" information ? ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR S SRYN=Y I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        Q
-NO2ALL  ; set all fields to NO
-        S SRAX="N",$P(^SRF(SRTN,200),"^")=SRAX D NOGEN
-        S $P(^SRF(SRTN,200),"^",9)=SRAX D NOPULM
-        S $P(^SRF(SRTN,200),"^",13)=SRAX D NOHEP
-        S $P(^SRF(SRTN,200.1),"^")=SRAX D NOGAST^SROAPR1A
-        S $P(^SRF(SRTN,200),"^",30)=SRAX D NOCARD^SROAPR1A
-        S $P(^SRF(SRTN,200),"^",40)=SRAX D NOVAS^SROAPR1A
-        Q
+SROAPRE1 ;B'HAM ISC/MAM - EDIT PAGE 1 PREOP ;01/05/05
+ ;;3.0; Surgery ;**38,47,125,135,141**;24 Jun 93
+ K DA D @EMILY Q
+1 ; edit general information
+ W ! K DIR S X=$P(SRAO(1),"^") I X'="" S DIR("B")=X
+ S DIR(0)="130,402",DIR("A")="GENERAL" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
+ I X="@" S SRCAT="General" D SURE Q:SRSOUT  G:'SRYN 1 S (SRAX,X)="",$P(^SRF(SRTN,200),"^")="" D NOGEN Q
+ S SRAX=Y,$P(^SRF(SRTN,200),"^")=SRAX I Y["N" D NOGEN Q
+ I Y["Y" D GEN
+ Q
+2 ; edit pulmonary information
+ W ! K DIR S X=$P(SRAO(2),"^") I X'="" S DIR("B")=X
+ S DIR(0)="130,241",DIR("A")="PULMONARY" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
+ I X="@" S SRCAT="Pulmonary" D SURE Q:SRSOUT  G:'SRYN 2 S (SRAX,X)="",$P(^SRF(SRTN,200),"^",9)="" D NOPULM Q
+ S SRAX=Y,$P(^SRF(SRTN,200),"^",9)=SRAX I Y["N" D NOPULM Q
+ I Y["Y" D PULM
+ Q
+3 ; edit hepatobiliary information
+ W ! K DIR S X=$P(SRAO(3),"^") I X'="" S DIR("B")=X
+ S DIR(0)="130,244",DIR("A")="HEPATOBILIARY" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
+ I X="@" S SRCAT="Hepatobiliary" D SURE Q:SRSOUT  G:'SRYN 3 S (SRAX,X)="",$P(^SRF(SRTN,200),"^",13)="" D NOHEP Q
+ S SRAX=Y,$P(^SRF(SRTN,200),"^",13)=SRAX I Y["N" D NOHEP Q
+ I Y["Y" D HEP
+ Q
+GEN ; general
+ N SRUP S SRUP=""
+ W ! K DR,DIE S DA=SRTN,DIE=130,DR="236T;237T;346T;202T;202.1T;246T;325T;238T" D ^DIE K DIE,DR I $D(Y) Q
+ K DIR S DA=SRTN,DIR(0)="130,240",DIR("A")="Functional Health Status Prior to Current Illness" D ^DIR K DIR D  Q:SRUP
+ .I $D(DTOUT) Q
+ .I $D(DUOUT) S SRUP=1 Q
+ .I X="@" K DIE,DR S DIE=130,DR="240///@" D ^DIE K DA,DIE,DR Q
+ .K DIE,DR S DIE=130,DR="240////"_Y D ^DIE K DA,DIE,DR
+ S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D
+ .I $D(DTOUT)!$D(DUOUT) Q
+ .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q
+ .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR
+ S SRACLR=0
+ Q
+NOGEN ; no general problems
+ S $P(^SRF(SRTN,200),"^",6)=$S(X="":"",1:1) F I=2,3,4,7 S $P(^SRF(SRTN,200),"^",I)=SRAX
+ S $P(^SRF(SRTN,200),"^",8)=$S(X="":"",X="NS":"NS",1:1),$P(^SRF(SRTN,208),"^",9)=$S(X="":"",X="NS":"NS",1:0),$P(^SRF(SRTN,200.1),"^",2)=$S(X="":"",X="NS":"NS",1:1)
+ Q
+PULM ; pulmonary
+ W ! K DR,DIE S DA=SRTN,DIE=130,DR="204T;203T;326T" D ^DIE K DR
+ S SRACLR=0
+ Q
+NOPULM ; no pulmonary problems
+ F I=10:1:12 S $P(^SRF(SRTN,200),"^",I)=SRAX
+ Q
+HEP ; hepatobiliary
+ K DR,DIE S DIE=130,DA=SRTN,DR="212////Y" D ^DIE K DR
+ S SRACLR=0
+ Q
+NOHEP ; no hepatobiliary problems
+ S $P(^SRF(SRTN,200),"^",15)=SRAX
+ Q
+RET W !! K DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
+ Q
+SURE W ! K DIR S DIR("A")="   Sure you want to delete all "_SRCAT_" information ? ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR S SRYN=Y I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
+ Q
+NO2ALL ; set all fields to NO
+ S SRAX="N",$P(^SRF(SRTN,200),"^")=SRAX D NOGEN
+ S $P(^SRF(SRTN,200),"^",9)=SRAX D NOPULM
+ S $P(^SRF(SRTN,200),"^",13)=SRAX D NOHEP
+ S $P(^SRF(SRTN,200.1),"^")=SRAX D NOGAST^SROAPR1A
+ S $P(^SRF(SRTN,200),"^",30)=SRAX D NOCARD^SROAPR1A
+ S $P(^SRF(SRTN,200),"^",40)=SRAX D NOVAS^SROAPR1A
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPRE2.m

@@ -1 @@
-SROAPRE2        ;BIR/MAM - EDIT PAGE 2 PREOP ;11/26/07
-        ;;3.0; Surgery ;**38,47,125,153,166**;24 Jun 93;Build 7
-        D @EMILY Q
-1       ; edit renal information
-        W ! K DIR S X=$P(SRAO(1),"^") I X'="" S DIR("B")=X
-        S DIR(0)="130,243",DIR("A")="RENAL" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
-        I X="@" S SRCAT="Renal" D SURE Q:SRSOUT  G:'SRYN 1 S $P(^SRF(SRTN,200),"^",37)="" S (SRAX,X)="" D NOREN Q
-        S SRAX=Y,$P(^SRF(SRTN,200),"^",37)=SRAX I Y["N" D NOREN Q
-        I Y["Y" D REN
-        Q
-2       ; edit CNS information
-        W ! K DIR S X=$P(SRAO(2),"^") I X'="" S DIR("B")=X
-        S DIR(0)="130,210",DIR("A")="CENTRAL NERVOUS SYSTEM" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
-        I X="@" S SRCAT="Central Nervous System" D SURE Q:SRSOUT  G:'SRYN 2 S $P(^SRF(SRTN,200),"^",18)="" S (SRAX,X)="" D NOCNS Q
-        S SRAX=Y,$P(^SRF(SRTN,200),"^",18)=SRAX I Y["N" D NOCNS Q
-        I Y["Y" D CNS
-        Q
-3       ; edit nutritional/immune/other info
-        W ! K DIR S X=$P(SRAO(3),"^") I X'="" S DIR("B")=X
-        S DIR(0)="130,245",DIR("A")="NUTRITIONAL/IMMUNE/OTHER" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
-        I X="@" S SRCAT="Nutritional/Immune/Other" D SURE Q:SRSOUT  G:'SRYN 3 S $P(^SRF(SRTN,200),"^",44)="" S (SRAX,X)="" D NONUT Q
-        S SRAX=Y,$P(^SRF(SRTN,200),"^",44)=SRAX I Y["N" D NONUT Q
-        I Y["Y" D NUT
-        Q
-REN     ; renal
-        W ! K DR,DIE S DA=SRTN,DIE=130,DR="328T;211T" D ^DIE K DR
-        S SRACLR=0
-        Q
-NOREN   ; no renal problems
-        F I=38,39 S $P(^SRF(SRTN,200),"^",I)=SRAX
-        Q
-CNS     ; cns
-        W ! K DR,DIE S DIE=130,DA=SRTN,DR="332T;333T;400T;334T;335T;336T;401T;" D ^DIE K DR,DIE
-        S SRACLR=0
-        Q
-NOCNS   ; no CNS problems
-        F I=19,21,24:1:27,29 S $P(^SRF(SRTN,200),"^",I)=SRAX
-        Q
-NUT     ; nutritional/immune/other
-        W ! K DR,DIE S DIE=130,DA=SRTN,DR="338T;218T;339T;215T;216T;217T;338.1T;338.2T;218.1T;269T" D ^DIE K DA,DIE,DR
-        S SRACLR=0
-        Q
-NONUT   ; no nutritional/immune/other
-        F I=45:1:50 S $P(^SRF(SRTN,200),"^",I)=SRAX
-        F I=3,4,8 S $P(^SRF(SRTN,206),"^",I)=SRAX
-        S:SRAX="N" $P(^SRF(SRTN,200.1),"^",3)=$S($P($G(VADM(5)),"^")="M":"NA",1:"NO")
-        S:SRAX="" $P(^SRF(SRTN,200.1),"^",3)=""
-        Q
-RET     W !! K DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        Q
-SURE    W ! K DIR S DIR("A")="   Sure you want to delete all "_SRCAT_" information ? ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR S SRYN=Y I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
-        Q
-DEL     W !!,?10,"Deleting all "_SRCAT_" information...  "
-        Q
-NO2ALL  ; set all fields to NO
-        S SRAX="N",$P(^SRF(SRTN,200),"^",37)=SRAX D NOREN
-        S $P(^SRF(SRTN,200),"^",18)=SRAX D NOCNS
-        S $P(^SRF(SRTN,200),"^",44)=SRAX D NONUT
-        Q
+SROAPRE2 ;BIR/MAM - EDIT PAGE 2 PREOP ;06/27/06
+ ;;3.0; Surgery ;**38,47,125,153**;24 Jun 93;Build 11
+ D @EMILY Q
+1 ; edit renal information
+ W ! K DIR S X=$P(SRAO(1),"^") I X'="" S DIR("B")=X
+ S DIR(0)="130,243",DIR("A")="RENAL" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
+ I X="@" S SRCAT="Renal" D SURE Q:SRSOUT  G:'SRYN 1 S $P(^SRF(SRTN,200),"^",37)="" S (SRAX,X)="" D NOREN Q
+ S SRAX=Y,$P(^SRF(SRTN,200),"^",37)=SRAX I Y["N" D NOREN Q
+ I Y["Y" D REN
+ Q
+2 ; edit CNS information
+ W ! K DIR S X=$P(SRAO(2),"^") I X'="" S DIR("B")=X
+ S DIR(0)="130,210",DIR("A")="CENTRAL NERVOUS SYSTEM" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
+ I X="@" S SRCAT="Central Nervous System" D SURE Q:SRSOUT  G:'SRYN 2 S $P(^SRF(SRTN,200),"^",18)="" S (SRAX,X)="" D NOCNS Q
+ S SRAX=Y,$P(^SRF(SRTN,200),"^",18)=SRAX I Y["N" D NOCNS Q
+ I Y["Y" D CNS
+ Q
+3 ; edit nutritional/immune/other info
+ W ! K DIR S X=$P(SRAO(3),"^") I X'="" S DIR("B")=X
+ S DIR(0)="130,245",DIR("A")="NUTRITIONAL/IMMUNE/OTHER" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
+ I X="@" S SRCAT="Nutritional/Immune/Other" D SURE Q:SRSOUT  G:'SRYN 3 S $P(^SRF(SRTN,200),"^",44)="" S (SRAX,X)="" D NONUT Q
+ S SRAX=Y,$P(^SRF(SRTN,200),"^",44)=SRAX I Y["N" D NONUT Q
+ I Y["Y" D NUT
+ Q
+REN ; renal
+ W ! K DR,DIE S DA=SRTN,DIE=130,DR="328T;211T" D ^DIE K DR
+ S SRACLR=0
+ Q
+NOREN ; no renal problems
+ F I=38,39 S $P(^SRF(SRTN,200),"^",I)=SRAX
+ Q
+CNS ; cns
+ W ! K DR,DIE S DIE=130,DA=SRTN,DR="332T;333T;400T;334T;335T;336T;401T;399T;398T;" D ^DIE K DR,DIE
+ S SRACLR=0
+ Q
+NOCNS ; no CNS problems
+ F I=19,21:1:27,29 S $P(^SRF(SRTN,200),"^",I)=SRAX
+ Q
+NUT ; nutritional/immune/other
+ W ! K DR,DIE S DIE=130,DA=SRTN,DR="338T;218T;339T;215T;216T;217T;338.1T;338.2T;218.1T;269T" D ^DIE K DA,DIE,DR
+ S SRACLR=0
+ Q
+NONUT ; no nutritional/immune/other
+ F I=45:1:50 S $P(^SRF(SRTN,200),"^",I)=SRAX
+ F I=3,4,8 S $P(^SRF(SRTN,206),"^",I)=SRAX
+ S:SRAX="N" $P(^SRF(SRTN,200.1),"^",3)=$S($P($G(VADM(5)),"^")="M":"NA",1:"NO")
+ S:SRAX="" $P(^SRF(SRTN,200.1),"^",3)=""
+ Q
+RET W !! K DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
+ Q
+SURE W ! K DIR S DIR("A")="   Sure you want to delete all "_SRCAT_" information ? ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR S SRYN=Y I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
+ Q
+DEL W !!,?10,"Deleting all "_SRCAT_" information...  "
+ Q
+NO2ALL ; set all fields to NO
+ S SRAX="N",$P(^SRF(SRTN,200),"^",37)=SRAX D NOREN
+ S $P(^SRF(SRTN,200),"^",18)=SRAX D NOCNS
+ S $P(^SRF(SRTN,200),"^",44)=SRAX D NONUT
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPRT1.m

@@ -1 @@
-SROAPRT1        ;BIR/MAM - PREOP INFO (PAGE 1) ;11/28/07
-        ;;3.0; Surgery ;**38,47,125,153,166**;24 Jun 93;Build 7
-        N SRX,Y F I=200,206 S SRA(I)=$G(^SRF(SRTN,I))
-        S Y=$P(SRA(200),"^"),SRX=402,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^"),SRX=236,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",2),SRX=237,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",2),SRX=346,SRAO("1C")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",3),SRX=202,SRAO("1D")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",9),SRX=241,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",10),SRX=204,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",11),SRX=203,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",12),SRX=326,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",13),SRX=244,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",15),SRX=212,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P($G(^SRF(SRTN,200.1)),"^"),SRX=486,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",16),SRX=213,SRAO("4A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",30),SRX=242,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",35),SRX=396,SRAO("5A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",31),SRX=394,SRAO("5B")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",32),SRX=220,SRAO("5C")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",33),SRX=266,SRAO("5D")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",34),SRX=395,SRAO("5E")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",36),SRX=208,SRAO("5F")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",40),SRX=206,SRAO(6)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",41),SRX=329,SRAO("6A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",42),SRX=330,SRAO("6B")=$$OUT(SRX,Y)_"^"_SRX
-        W:$E(IOST)="P" ! W !,?28,"PREOPERATIVE INFORMATION",!!
-        W "GENERAL:",?31,$P(SRAO(1),"^"),?40,"GASTROINTESTINAL:",?72,$P(SRAO(4),"^")
-        W !,"Height: ",?22,$J($P(SRAO("1A"),"^"),15),?40,"Esophageal Varices:",?72,$P(SRAO("4A"),"^")
-        W !,"Weight:",?22,$J($P(SRAO("1B"),"^"),15)
-        W !,"Diabetes Mellitus:",?31,$P(SRAO("1C"),"^"),?40,"CARDIAC:",?72,$P(SRAO(5),"^")
-        W !,"Current Smoker W/I 1 Year:",?31,$P(SRAO("1D"),"^"),?40,"CHF Within 1 Month:",?72,$P(SRAO("5A"),"^")
-        W !,"ETOH > 2 Drinks/Day:",?31,$P(SRAO("1E"),"^"),?40,"MI Within 6 Months:",?72,$P(SRAO("5B"),"^")
-        W !,"Dyspnea: ",?13,$J($P(SRAO("1F"),"^"),25),?40,"Previous PCI:",?72,$P(SRAO("5C"),"^")
-        W !,"DNR Status: ",?31,$P(SRAO("1G"),"^"),?40,"Previous Cardiac Surgery:",?72,$P(SRAO("5D"),"^")
-        W !,"Preop Funct Status: ",$J($P(SRAO("1H"),"^"),17),?40,"Angina Within 1 Month:",?72,$P(SRAO("5E"),"^")
-        W !,?40,"Hypertension Requiring Meds:",?72,$P(SRAO("5F"),"^")
-        W !,"PULMONARY:",?31,$P(SRAO(2),"^")
-        W !,"Ventilator Dependent:",?31,$P(SRAO("2A"),"^"),?40,"VASCULAR:",?72,$P(SRAO(6),"^")
-        W !,"History of Severe COPD:",?31,$P(SRAO("2B"),"^"),?40,"Revascularization/Amputation:",?72,$P(SRAO("6A"),"^")
-        W !,"Current Pneumonia:",?31,$P(SRAO("2C"),"^"),?40,"Rest Pain/Gangrene:",?72,$P(SRAO("6B"),"^")
-        W !!,"HEPATOBILIARY:",?31,$P(SRAO(3),"^"),!,"Ascites:",?31,$P(SRAO("3A"),"^")
-        Q
-OUT(SRFLD,SRY)  ; get data in output form
-        N C,Y
-        S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
-        I Y="NO STUDY" S Y="NS"
-        I SRFLD=236!(SRFLD=237)!(SRFLD=346) S Y=$E(Y,1,15)
-        I SRFLD=240!(SRFLD=492) D
-        .I SRY=2 S Y="PARTIAL DEPENDENT" Q
-        .I SRY=4 S Y=Y_"  "
-        I SRFLD=325,$L(Y)=2 S Y=Y_"     "
-        Q Y
+SROAPRT1 ;BIR/MAM - PREOP INFO (PAGE 1) ;02/23/06
+ ;;3.0; Surgery ;**38,47,125,153**;24 Jun 93;Build 11
+ N SRX,Y F I=200,206 S SRA(I)=$G(^SRF(SRTN,I))
+ S Y=$P(SRA(200),"^"),SRX=402,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^"),SRX=236,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",2),SRX=237,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",2),SRX=346,SRAO("1C")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",3),SRX=202,SRAO("1D")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,208)),"^",9),SRX=202.1,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",8),SRX=240,SRAO("1I")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1J")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",9),SRX=241,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",10),SRX=204,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",11),SRX=203,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",12),SRX=326,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",13),SRX=244,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",15),SRX=212,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,200.1)),"^"),SRX=486,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",16),SRX=213,SRAO("4A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",30),SRX=242,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",35),SRX=396,SRAO("5A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",31),SRX=394,SRAO("5B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",32),SRX=220,SRAO("5C")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",33),SRX=266,SRAO("5D")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",34),SRX=395,SRAO("5E")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",36),SRX=208,SRAO("5F")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",40),SRX=206,SRAO(6)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",41),SRX=329,SRAO("6A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",42),SRX=330,SRAO("6B")=$$OUT(SRX,Y)_"^"_SRX
+ W:$E(IOST)="P" ! W !,?28,"PREOPERATIVE INFORMATION",!!
+ W "GENERAL:",?31,$P(SRAO(1),"^"),?40,"HEPATOBILIARY:",?72,$P(SRAO(3),"^")
+ W !,"Height: ",?22,$J($P(SRAO("1A"),"^"),15),?40,"Ascites:",?72,$P(SRAO("3A"),"^")
+ W !,"Weight:",?22,$J($P(SRAO("1B"),"^"),15)
+ W !,"Diabetes Mellitus:",?31,$P(SRAO("1C"),"^"),?40,"GASTROINTESTINAL:",?72,$P(SRAO(4),"^")
+ W !,"Current Smoker W/I 1 Year:",?31,$P(SRAO("1D"),"^"),?40,"Esophageal Varices:",?72,$P(SRAO("4A"),"^")
+ W !,"Pack/Years:",?31,$P(SRAO("1E"),"^")
+ W !,"ETOH > 2 Drinks/Day:",?31,$P(SRAO("1F"),"^"),?40,"CARDIAC:",?72,$P(SRAO(5),"^")
+ W !,"Dyspnea: ",?13,$J($P(SRAO("1G"),"^"),25),?40,"CHF Within 1 Month:",?72,$P(SRAO("5A"),"^")
+ W !,"DNR Status: ",?31,$P(SRAO("1H"),"^"),?40,"MI Within 6 Months:",?72,$P(SRAO("5B"),"^")
+ W !,"Pre-illness Funct",?40,"Previous PCI:",?72,$P(SRAO("5C"),"^")
+ W !,?12,"Status: ",$J($P(SRAO("1I"),"^"),17),?40,"Previous Cardiac Surgery:",?72,$P(SRAO("5D"),"^")
+ W !,"Preop Funct Status: ",$J($P(SRAO("1J"),"^"),17),?40,"Angina Within 1 Month:",?72,$P(SRAO("5E"),"^")
+ W !,?40,"Hypertension Requiring Meds:",?72,$P(SRAO("5F"),"^")
+ W !,"PULMONARY:",?31,$P(SRAO(2),"^")
+ W !,"Ventilator Dependent:",?31,$P(SRAO("2A"),"^"),?40,"VASCULAR:",?72,$P(SRAO(6),"^")
+ W !,"History of Severe COPD:",?31,$P(SRAO("2B"),"^"),?40,"Revascularization/Amputation:",?72,$P(SRAO("6A"),"^")
+ W !,"Current Pneumonia:",?31,$P(SRAO("2C"),"^"),?40,"Rest Pain/Gangrene:",?72,$P(SRAO("6B"),"^")
+ Q
+OUT(SRFLD,SRY) ; get data in output form
+ N C,Y
+ S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
+ I Y="NO STUDY" S Y="NS"
+ I SRFLD=236!(SRFLD=237)!(SRFLD=346) S Y=$E(Y,1,15)
+ I SRFLD=240!(SRFLD=492) D
+ .I SRY=2 S Y="PARTIAL DEPENDENT" Q
+ .I SRY=4 S Y=Y_"  "
+ I SRFLD=325,$L(Y)=2 S Y=Y_"     "
+ Q Y

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPRT2.m

@@ -1 @@
-SROAPRT2        ;BIR/MAM - PRINT PREOP INFO (PAGE 2) ;11/28/07
-        ;;3.0; Surgery ;**38,125,137,153,160,166**;24 Jun 93;Build 7
-        I $E(IOST)'="P" W !,?28,"PREOPERATIVE INFORMATION"
-        N SRX,Y S SRA(200)=$G(^SRF(SRTN,200)),SRA(206)=$G(^SRF(SRTN,206))
-        S Y=$P(SRA(200),"^",37),SRX=243,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",38),SRX=328,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",39),SRX=211,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",18),SRX=210,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",44),SRX=245,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",19),SRX=332,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",21),SRX=333,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",24),SRX=400,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",25),SRX=334,SRAO("2D")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",26),SRX=335,SRAO("2E")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",27),SRX=336,SRAO("2F")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",29),SRX=401,SRAO("2G")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",45),SRX=338,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",46),SRX=218,SRAO("3B")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",47),SRX=339,SRAO("3C")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",48),SRX=215,SRAO("3D")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",49),SRX=216,SRAO("3E")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",50),SRX=217,SRAO("3F")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",3),SRX=338.1,SRAO("3G")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",4),SRX=338.2,SRAO("3H")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",8),SRX=218.1,SRAO("3I")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P($G(^SRF(SRTN,200.1)),"^",3),SRX=269,SRAO("3J")=$$OUT(SRX,Y)_"^"_SRX
-        W !!,"RENAL:",?31,$P(SRAO(1),"^"),?40,"NUTRITIONAL/IMMUNE/OTHER:",?72,$P(SRAO(3),"^")
-        W !,"Acute Renal Failure:",?31,$P(SRAO("1A"),"^"),?40,"Disseminated Cancer:",?72,$P(SRAO("3A"),"^")
-        W !,"Currently on Dialysis:",?31,$P(SRAO("1B"),"^"),?40,"Open Wound:",?72,$P(SRAO("3B"),"^")
-        W !,?40,"Steroid Use for Chronic Cond.:",?72,$P(SRAO("3C"),"^")
-        W !,"CENTRAL NERVOUS SYSTEM:",?31,$P(SRAO(2),"^"),?40,"Weight Loss > 10%:",?72,$P(SRAO("3D"),"^")
-        W !,"Impaired Sensorium: ",?31,$P(SRAO("2A"),"^"),?40,"Bleeding Disorders:",?72,$P(SRAO("3E"),"^")
-        W !,"Coma:",?31,$P(SRAO("2B"),"^"),?40,"Transfusion > 4 RBC Units:",?72,$P(SRAO("3F"),"^")
-        W !,"Hemiplegia:",?31,$P(SRAO("2C"),"^"),?40,"Chemotherapy W/I 30 Days:",?72,$P(SRAO("3G"),"^")
-        W !,"History of TIAs:",?31,$P(SRAO("2D"),"^"),?40,"Radiotherapy W/I 90 Days:",?72,$P(SRAO("3H"),"^")
-        W !,"CVA/Stroke w. Neuro Deficit:",?31,$P(SRAO("2E"),"^"),?40,"Preoperative Sepsis:",?(74-$L($P(SRAO("3I"),"^"))),$P(SRAO("3I"),"^")
-        W !,"CVA/Stroke w/o Neuro Deficit:",?31,$P(SRAO("2F"),"^"),?40,"Pregnancy:",?(74-$L($P(SRAO("3J"),"^"))),$P(SRAO("3J"),"^")
-        W !,"Tumor Involving CNS:",?31,$P(SRAO("2G"),"^")
-        I $E(IOST)="P" W !
-        Q
-OUT(SRFLD,SRY)  ; get data in output form
-        N C,Y
-        S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
-        I Y="NO STUDY" S Y="NS"
-        Q Y
+SROAPRT2 ;BIR/MAM - PRINT PREOP INFO (PAGE 2) ;04/24/07
+ ;;3.0; Surgery ;**38,125,137,153,160**;24 Jun 93;Build 7
+ I $E(IOST)'="P" W !,?28,"PREOPERATIVE INFORMATION"
+ N SRX,Y S SRA(200)=$G(^SRF(SRTN,200)),SRA(206)=$G(^SRF(SRTN,206))
+ S Y=$P(SRA(200),"^",37),SRX=243,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",38),SRX=328,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",39),SRX=211,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",18),SRX=210,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",44),SRX=245,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",19),SRX=332,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",21),SRX=333,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",22),SRX=398,SRAO("2I")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",23),SRX=399,SRAO("2H")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",24),SRX=400,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",25),SRX=334,SRAO("2D")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",26),SRX=335,SRAO("2E")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",27),SRX=336,SRAO("2F")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",29),SRX=401,SRAO("2G")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",45),SRX=338,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",46),SRX=218,SRAO("3B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",47),SRX=339,SRAO("3C")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",48),SRX=215,SRAO("3D")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",49),SRX=216,SRAO("3E")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",50),SRX=217,SRAO("3F")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",3),SRX=338.1,SRAO("3G")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",4),SRX=338.2,SRAO("3H")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",8),SRX=218.1,SRAO("3I")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,200.1)),"^",3),SRX=269,SRAO("3J")=$$OUT(SRX,Y)_"^"_SRX
+ W !!,"RENAL:",?31,$P(SRAO(1),"^"),?40,"NUTRITIONAL/IMMUNE/OTHER:",?72,$P(SRAO(3),"^")
+ W !,"Acute Renal Failure:",?31,$P(SRAO("1A"),"^"),?40,"Disseminated Cancer:",?72,$P(SRAO("3A"),"^")
+ W !,"Currently on Dialysis:",?31,$P(SRAO("1B"),"^"),?40,"Open Wound:",?72,$P(SRAO("3B"),"^")
+ W !,?40,"Steroid Use for Chronic Cond.:",?72,$P(SRAO("3C"),"^")
+ W !,"CENTRAL NERVOUS SYSTEM:",?31,$P(SRAO(2),"^"),?40,"Weight Loss > 10%:",?72,$P(SRAO("3D"),"^")
+ W !,"Impaired Sensorium: ",?31,$P(SRAO("2A"),"^"),?40,"Bleeding Disorders:",?72,$P(SRAO("3E"),"^")
+ W !,"Coma:",?31,$P(SRAO("2B"),"^"),?40,"Transfusion > 4 RBC Units:",?72,$P(SRAO("3F"),"^")
+ W !,"Hemiplegia:",?31,$P(SRAO("2C"),"^"),?40,"Chemotherapy W/I 30 Days:",?72,$P(SRAO("3G"),"^")
+ W !,"History of TIAs:",?31,$P(SRAO("2D"),"^"),?40,"Radiotherapy W/I 90 Days:",?72,$P(SRAO("3H"),"^")
+ W !,"CVA/Stroke w. Neuro Deficit:",?31,$P(SRAO("2E"),"^"),?40,"Preoperative Sepsis:",?(74-$L($P(SRAO("3I"),"^"))),$P(SRAO("3I"),"^")
+ W !,"CVA/Stroke w/o Neuro Deficit:",?31,$P(SRAO("2F"),"^"),?40,"Pregnancy:",?(74-$L($P(SRAO("3J"),"^"))),$P(SRAO("3J"),"^")
+ W !,"Tumor Involving CNS:",?31,$P(SRAO("2G"),"^")
+ W !,"Paraplegia:",?31,$P(SRAO("2H"),"^")
+ W !,"Quadriplegia:",?31,$P(SRAO("2I"),"^")
+ I $E(IOST)="P" W !
+ Q
+OUT(SRFLD,SRY) ; get data in output form
+ N C,Y
+ S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
+ I Y="NO STUDY" S Y="NS"
+ Q Y

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPRT4.m

@@ -1 @@
-SROAPRT4        ;BIR/MAM - PRINT ASSESSMENT (CONT.) ;01/14/08
-        ;;3.0; Surgery ;**38,125,153,160,166**;24 Jun 93;Build 7
-        ;K SRA S SRA(201)=$G(^SRF(SRTN,201)),SRA(202)=$G(^SRF(SRTN,202))
-        K SRA F I=201,202,203,204,202.1 S SRA(I)=$G(^SRF(SRTN,I))
-        W !,?20,"PREOPERATIVE LABORATORY TEST RESULTS"
-        W !!,$J("Anion Gap (in 48 hrs.): ",39) S X=$P(SRA(203),"^",15) W X S X=$P(SRA(204),"^",15) I X D DATE W ?48,"("_Y_")"
-        W !,$J("Serum Sodium: ",39) S X=$P(SRA(201),"^") W X S X=$P(SRA(202),"^") I X D DATE W ?48,"("_Y_")"
-        W !,$J("Serum Creatinine: ",39) S X=$P(SRA(201),"^",4) W X S X=$P(SRA(202),"^",4) I X D DATE W ?48,"("_Y_")"
-        W !,$J("BUN: ",39) S X=$P(SRA(201),"^",5) W X S X=$P(SRA(202),"^",5) I X D DATE W ?48,"("_Y_")"
-        W !,$J("Serum Albumin: ",39) S X=$P(SRA(201),"^",8) W X S X=$P(SRA(202),"^",8) I X D DATE W ?48,"("_Y_")"
-        W !,$J("Total Bilirubin: ",39) S X=$P(SRA(201),"^",9) W X S X=$P(SRA(202),"^",9) I X D DATE W ?48,"("_Y_")"
-        W !,$J("SGOT: ",39) S X=$P(SRA(201),"^",11) W X S X=$P(SRA(202),"^",11) I X D DATE W ?48,"("_Y_")"
-        W !,$J("Alkaline Phosphatase: ",39) S X=$P(SRA(201),"^",12) W X S X=$P(SRA(202),"^",12) I X D DATE W ?48,"("_Y_")"
-        W !,$J("White Blood Count: ",39) S X=$P(SRA(201),"^",13) W X S X=$P(SRA(202),"^",13) I X D DATE W ?48,"("_Y_")"
-        W !,$J("Hematocrit: ",39) S X=$P(SRA(201),"^",14) W X S X=$P(SRA(202),"^",14) I X D DATE W ?48,"("_Y_")"
-        W !,$J("Platelet Count: ",39) S X=$P(SRA(201),"^",15) W X S X=$P(SRA(202),"^",15) I X D DATE W ?48,"("_Y_")"
-        W !,$J("PTT: ",39) S X=$P(SRA(201),"^",16) W X S X=$P(SRA(202),"^",16) I X D DATE W ?48,"("_Y_")"
-        W !,$J("PT: ",39) S X=$P(SRA(201),"^",17) W X S X=$P(SRA(202),"^",17) I X D DATE W ?48,"("_Y_")"
-        W !,$J("INR: ",39) S X=$P(SRA(201),"^",27) W X S X=$P(SRA(202),"^",27) I X D DATE W ?48,"("_Y_")"
-        W !,$J("Hemoglobin A1c: ",39) S X=$P(SRA(201),"^",28) W X S X=$P(SRA(202.1),"^") I X D DATE W ?48,"("_Y_")"
-        I $E(IOST)="P" W !!
-        Q
-DATE    S Y=X X ^DD("DD")
-        Q
+SROAPRT4 ;BIR/MAM - PRINT ASSESSMENT (CONT.) ;06/28/06
+ ;;3.0; Surgery ;**38,125,153,160**;24 Jun 93;Build 7
+ ;K SRA S SRA(201)=$G(^SRF(SRTN,201)),SRA(202)=$G(^SRF(SRTN,202))
+ K SRA F I=201,202,203,204,202.1 S SRA(I)=$G(^SRF(SRTN,I))
+ W !,?20,"PREOPERATIVE LABORATORY TEST RESULTS"
+ W !!,$J("Anion Gap (in 48 hrs.): ",39) S X=$P(SRA(203),"^",15) W X S X=$P(SRA(204),"^",15) I X D DATE W ?48,"("_Y_")"
+ W !,$J("Serum Sodium: ",39) S X=$P(SRA(201),"^") W X S X=$P(SRA(202),"^") I X D DATE W ?48,"("_Y_")"
+ W !,$J("Serum Creatinine: ",39) S X=$P(SRA(201),"^",4) W X S X=$P(SRA(202),"^",4) I X D DATE W ?48,"("_Y_")"
+ W !,$J("BUN: ",39) S X=$P(SRA(201),"^",5) W X I X S X=$P(SRA(202),"^",5) I X D DATE W ?48,"("_Y_")"
+ W !,$J("Serum Albumin: ",39) S X=$P(SRA(201),"^",8) W X I X S X=$P(SRA(202),"^",8) I X D DATE W ?48,"("_Y_")"
+ W !,$J("Total Bilirubin: ",39) S X=$P(SRA(201),"^",9) W X S X=$P(SRA(202),"^",9) I X D DATE W ?48,"("_Y_")"
+ W !,$J("SGOT: ",39) S X=$P(SRA(201),"^",11) W X I X S X=$P(SRA(202),"^",11) I X D DATE W ?48,"("_Y_")"
+ W !,$J("Alkaline Phosphatase: ",39) S X=$P(SRA(201),"^",12) W X I X S X=$P(SRA(202),"^",12) I X D DATE W ?48,"("_Y_")"
+ W !,$J("White Blood Count: ",39) S X=$P(SRA(201),"^",13) W X S X=$P(SRA(202),"^",13) I X D DATE W ?48,"("_Y_")"
+ W !,$J("Hematocrit: ",39) S X=$P(SRA(201),"^",14) W X I X S X=$P(SRA(202),"^",14) I X D DATE W ?48,"("_Y_")"
+ W !,$J("Platelet Count: ",39) S X=$P(SRA(201),"^",15) W X S X=$P(SRA(202),"^",15) I X D DATE W ?48,"("_Y_")"
+ W !,$J("PTT: ",39) S X=$P(SRA(201),"^",16) W X S X=$P(SRA(202),"^",16) I X D DATE W ?48,"("_Y_")"
+ W !,$J("PT: ",39) S X=$P(SRA(201),"^",17) W X I X S X=$P(SRA(202),"^",17) I X D DATE W ?48,"("_Y_")"
+ W !,$J("INR: ",39) S X=$P(SRA(201),"^",27) W X I X S X=$P(SRA(202),"^",27) I X D DATE W ?48,"("_Y_")"
+ W !,$J("Hemoglobin A1c: ",39) S X=$P(SRA(201),"^",28) W X I X S X=$P(SRA(202.1),"^") D DATE W ?48,"("_Y_")"
+ I $E(IOST)="P" W !!
+ Q
+DATE S Y=X X ^DD("DD")
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPRT5.m

@@ -1 @@
-SROAPRT5        ;BIR/MAM - PRINT ASSESSMENT (CONT) ;01/14/08
-        ;;3.0; Surgery ;**38,88,153,166**;24 Jun 93;Build 7
-        K SRA S SRA(203)=$G(^SRF(SRTN,203)),SRA(204)=$G(^SRF(SRTN,204))
-        W:$E(IOST)="P" ! W !,?22,"POSTOPERATIVE LABORATORY RESULTS",!!,?29," * Highest Value",!,?29,"** Lowest Value"
-        W !!,$J("* Anion Gap: ",39) S X=$P(SRA(203),"^",16) W X S X=$P(SRA(204),"^",16) I X D DATE W ?48,"("_Y_")"
-        W !,$J("* Serum Sodium: ",39) S X=$P(SRA(203),"^") W X S X=$P(SRA(204),"^") I X D DATE W ?48,"("_Y_")"
-        W !,$J("** Serum Sodium: ",39) S X=$P(SRA(203),"^",2) W X S X=$P(SRA(204),"^",2) I X D DATE W ?48,"("_Y_")"
-        W !,$J("* Potassium: ",39) S X=$P(SRA(203),"^",3) W X S X=$P(SRA(204),"^",3) I X D DATE W ?48,"("_Y_")"
-        W !,$J("** Potassium: ",39) S X=$P(SRA(203),"^",4) W X S X=$P(SRA(204),"^",4) I X D DATE W ?48,"("_Y_")"
-        W !,$J("* Serum Creatinine: ",39) S X=$P(SRA(203),"^",6) W X S X=$P(SRA(204),"^",6) I X D DATE W ?48,"("_Y_")"
-        W !,$J("* CPK: ",39) S X=$P(SRA(203),"^",7) W X S X=$P(SRA(204),"^",7) I X D DATE W ?48,"("_Y_")"
-        W !,$J("* CPK-MB Band: ",39) S X=$P(SRA(203),"^",8) W X S X=$P(SRA(204),"^",8) I X D DATE W ?48,"("_Y_")"
-        W !,$J("* Total Bilirubin: ",39) S X=$P(SRA(203),"^",9) W X S X=$P(SRA(204),"^",9) I X D DATE W ?48,"("_Y_")"
-        W !,$J("* White Blood Count: ",39) S X=$P(SRA(203),"^",10) W X S X=$P(SRA(204),"^",10) I X D DATE W ?48,"("_Y_")"
-        W !,$J("** Hematocrit: ",39) S X=$P(SRA(203),"^",12) W X S X=$P(SRA(204),"^",12) I X D DATE W ?48,"("_Y_")"
-        W !,$J("* Troponin I: ",39) S X=$P(SRA(203),"^",13) W X S X=$P(SRA(204),"^",13) I X D DATE W ?48,"("_Y_")"
-        W !,$J("* Troponin T: ",39) S X=$P(SRA(203),"^",14) W X S X=$P(SRA(204),"^",14) I X D DATE W ?48,"("_Y_")"
-        I $E(IOST)="P" W !!
-        Q
-DATE    S Y=X X ^DD("DD")
-        Q
+SROAPRT5 ;BIR/MAM - PRINT ASSESSMENT (CONT) ;06/28/06
+ ;;3.0; Surgery ;**38,88,153**;24 Jun 93;Build 11
+ K SRA S SRA(203)=$G(^SRF(SRTN,203)),SRA(204)=$G(^SRF(SRTN,204))
+ W:$E(IOST)="P" ! W !,?22,"POSTOPERATIVE LABORATORY RESULTS",!!,?29," * Highest Value",!,?29,"** Lowest Value"
+ W !!,$J("* Anion Gap: ",39) S X=$P(SRA(203),"^",16) W X S X=$P(SRA(204),"^",16) I X D DATE W ?48,"("_Y_")"
+ W !,$J("* Serum Sodium: ",39) S X=$P(SRA(203),"^") W X S X=$P(SRA(204),"^") I X D DATE W ?48,"("_Y_")"
+ W !,$J("** Serum Sodium: ",39) S X=$P(SRA(203),"^",2) W X S X=$P(SRA(204),"^",2) I X D DATE W ?48,"("_Y_")"
+ W !,$J("* Potassium: ",39) S X=$P(SRA(203),"^",3) W X S X=$P(SRA(204),"^",3) I X D DATE W ?48,"("_Y_")"
+ W !,$J("** Potassium: ",39) S X=$P(SRA(203),"^",4) W X S X=$P(SRA(204),"^",4) I X D DATE W ?48,"("_Y_")"
+ W !,$J("* Serum Creatinine: ",39) S X=$P(SRA(203),"^",6) W X S X=$P(SRA(204),"^",6) I X D DATE W ?48,"("_Y_")"
+ W !,$J("* CPK: ",39) S X=$P(SRA(203),"^",7) W X I X S X=$P(SRA(204),"^",7) I X D DATE W ?48,"("_Y_")"
+ W !,$J("* CPK-MB Band: ",39) S X=$P(SRA(203),"^",8) W X S X=$P(SRA(204),"^",8) I X D DATE W ?48,"("_Y_")"
+ W !,$J("* Total Bilirubin: ",39) S X=$P(SRA(203),"^",9) W X I X S X=$P(SRA(204),"^",9) I X D DATE W ?48,"("_Y_")"
+ W !,$J("* White Blood Count: ",39) S X=$P(SRA(203),"^",10) W X S X=$P(SRA(204),"^",10) I X D DATE W ?48,"("_Y_")"
+ W !,$J("** Hematocrit: ",39) S X=$P(SRA(203),"^",12) W X S X=$P(SRA(204),"^",12) I X D DATE W ?48,"("_Y_")"
+ W !,$J("* Troponin I: ",39) S X=$P(SRA(203),"^",13) W X S X=$P(SRA(204),"^",13) I X D DATE W ?48,"("_Y_")"
+ W !,$J("* Troponin T: ",39) S X=$P(SRA(203),"^",14) W X S X=$P(SRA(204),"^",14) I X D DATE W ?48,"("_Y_")"
+ I $E(IOST)="P" W !!
+ Q
+DATE S Y=X X ^DD("DD")
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPS1.m

@@ -1 @@
-SROAPS1 ;BIR/MAM - PREOP INFO (PAGE 1) ;12/12/07
-        ;;3.0; Surgery ;**38,47,125,153,166**;24 Jun 93;Build 7
-        ;
-        ; Reference to EN1^GMRVUT0 supported by DBIA #1446
-        ;
-        N I S SRPAGE="PAGE: 1 OF 2" D HDR^SROAUTL,PRE1
-        W ! F I=1:1:80 W "-"
-        Q
-PRE1    N SRX,Y D HW F I=200,206 S SRA(I)=$G(^SRF(SRTN,I))
-        S Y=$P(SRA(200),"^"),SRX=402,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^"),SRX=236,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",2),SRX=237,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",2),SRX=346,SRAO("1C")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",3),SRX=202,SRAO("1D")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",9),SRX=241,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",10),SRX=204,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",11),SRX=203,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",12),SRX=326,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",13),SRX=244,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",15),SRX=212,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P($G(^SRF(SRTN,200.1)),"^"),SRX=486,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",16),SRX=213,SRAO("4A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",30),SRX=242,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",35),SRX=396,SRAO("5A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",31),SRX=394,SRAO("5B")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",32),SRX=220,SRAO("5C")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",33),SRX=266,SRAO("5D")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",34),SRX=395,SRAO("5E")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",36),SRX=208,SRAO("5F")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",40),SRX=206,SRAO(6)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",41),SRX=329,SRAO("6A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",42),SRX=330,SRAO("6B")=$$OUT(SRX,Y)_"^"_SRX K SRA
-        W "1. GENERAL:",?32,$P(SRAO(1),"^"),?41,"4. GASTROINTESTINAL:",?76,$P(SRAO(4),"^")
-        W !,"  A. Height:" S Y=$P(SRAO("1A"),"^") W:Y'="NS" ?14,$J($P(Y,"^"),25) W:Y="NS" ?32,Y
-        W ?43,"A. Esophageal Varices:",?76,$P(SRAO("4A"),"^")
-        W !,"  B. Weight:" S Y=$P(SRAO("1B"),"^") W ?($S(Y="NS":19,1:24)),$J(Y,15)
-        W !,"  C. Diabetes Mellitus:",?32,$P(SRAO("1C"),"^"),?41,"5. CARDIAC:",?76,$P(SRAO(5),"^")
-        W !,"  D. Current Smoker W/I 1 Year:",?32,$P(SRAO("1D"),"^"),?43,"A. CHF Within 1 Month:",?76,$P(SRAO("5A"),"^")
-        W !,"  E. ETOH > 2 Drinks/Day:",?32,$P(SRAO("1E"),"^"),?43,"B. MI Within 6 Months:",?76,$P(SRAO("5B"),"^")
-        W !,"  F. Dyspnea: ",?14,$J($P(SRAO("1F"),"^"),25),?43,"C. Previous PCI:",?76,$P(SRAO("5C"),"^")
-        W !,"  G. DNR Status: ",?32,$P(SRAO("1G"),"^"),?43,"D. Previous Cardiac Surgery:",?76,$P(SRAO("5D"),"^")
-        W !,"  H. Preop Funct Status: ",$J($P(SRAO("1H"),"^"),17),?43,"E. Angina Within 1 Month:",?76,$P(SRAO("5E"),"^")
-        W !,?43,"F. Hypertension Requiring Meds:",?76,$P(SRAO("5F"),"^")
-        W !,"2. PULMONARY:",?32,$P(SRAO(2),"^")
-        W !,"  A. Ventilator Dependent:",?32,$P(SRAO("2A"),"^"),?41,"6. VASCULAR:",?76,$P(SRAO(6),"^")
-        W !,"  B. History of Severe COPD:",?32,$P(SRAO("2B"),"^"),?43,"A. Revascularization/Amputation:",?76,$P(SRAO("6A"),"^")
-        W !,"  C. Current Pneumonia:",?32,$P(SRAO("2C"),"^"),?43,"B. Rest Pain/Gangrene:",?76,$P(SRAO("6B"),"^")
-        W !!,"3. HEPATOBILIARY:",?32,$P(SRAO(3),"^"),!,"  A. Ascites:",?32,$P(SRAO("3A"),"^")
-        Q
-OUT(SRFLD,SRY)  ; get data in output form
-        N C,Y,Z
-        S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
-        I Y="NO STUDY" S Y="NS"
-        I SRFLD=237!(SRFLD=346) S Y=$E(Y,1,15)
-        I SRFLD=236 S Z=$P($G(^SRF(SRTN,200.1)),"^",7) I Z'="" S Y="("_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Z,2,3)_")  "_Y
-        I SRFLD=492 D
-        .I SRY=2 S Y="PARTIAL DEPENDENT" Q
-        .I SRY=1 S Y=Y_"    " Q
-        .I SRY=4 S Y=Y_"      "
-        I SRFLD=325,$L(Y)=2 S Y=Y_"     "
-        Q Y
-HW      ; get weight & height from Vitals
-        N SREND,SREQ,SREX,SREY,SRSTRT
-WT      I $P($G(^SRF(SRTN,206)),"^",2)="" D
-        .S SREND=$P($G(^SRF(SRTN,0)),"^",9),SRSTRT=$$FMADD^XLFDT(SREND,-30),SREX=$$HW^SROACL1(SRSTRT,SREND,"WT")
-        .I SREX'="" S SREX=SREX+.5\1 D CHK^DIE(130,237,"E",SREX,.SREY) I SREY'="^" S $P(^SRF(SRTN,206),"^",2)=SREY
-HT      I $P($G(^SRF(SRTN,206)),"^")'="" Q
-        N GMRVSTR,SRBRDT,SRBIEN,SRBDATA,SRHTDT
-        K ^UTILITY($J,"GMRVD"),RESULTS S SREND=$P($G(^SRF(SRTN,0)),"^",9),GMRVSTR="HT",GMRVSTR(0)="^"_SREND_"^^0"
-        D EN1^GMRVUT0 Q:'$D(^UTILITY($J,"GMRVD"))
-        S SRBRDT="",SRBRDT=$O(^UTILITY($J,"GMRVD","HT",SRBRDT)) Q:'SRBRDT  D
-        .S SRBIEN=0 F  S SRBIEN=$O(^UTILITY($J,"GMRVD","HT",SRBRDT,SRBIEN)) Q:'SRBIEN  D
-        ..S SRBDATA=$G(^UTILITY($J,"GMRVD","HT",SRBRDT,SRBIEN)),SREX=$P(SRBDATA,"^",8)
-        ..I SREX'="" S SREX=SREX+.5\1 D CHK^DIE(130,236,"E",SREX,.SREY) I SREY'="^" D
-        ...S $P(^SRF(SRTN,206),"^")=SREY
-        ...S SRHTDT=$P(SRBDATA,"^") I SRHTDT'="" S $P(^SRF(SRTN,200.1),"^",7)=SRHTDT
-        Q
+SROAPS1 ;BIR/MAM - PREOP INFO (PAGE 1) ;06/08/06
+ ;;3.0; Surgery ;**38,47,125,153**;24 Jun 93;Build 11
+ N I S SRPAGE="PAGE: 1 OF 2" D HDR^SROAUTL,PRE1
+ W ! F I=1:1:80 W "-"
+ Q
+PRE1 N SRX,Y D HW F I=200,206 S SRA(I)=$G(^SRF(SRTN,I))
+ S Y=$P(SRA(200),"^"),SRX=402,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^"),SRX=236,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",2),SRX=237,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",2),SRX=346,SRAO("1C")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",3),SRX=202,SRAO("1D")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,208)),"^",9),SRX=202.1,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",8),SRX=240,SRAO("1I")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1J")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",9),SRX=241,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",10),SRX=204,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",11),SRX=203,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",12),SRX=326,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",13),SRX=244,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",15),SRX=212,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,200.1)),"^"),SRX=486,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",16),SRX=213,SRAO("4A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",30),SRX=242,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",35),SRX=396,SRAO("5A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",31),SRX=394,SRAO("5B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",32),SRX=220,SRAO("5C")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",33),SRX=266,SRAO("5D")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",34),SRX=395,SRAO("5E")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",36),SRX=208,SRAO("5F")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",40),SRX=206,SRAO(6)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",41),SRX=329,SRAO("6A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",42),SRX=330,SRAO("6B")=$$OUT(SRX,Y)_"^"_SRX K SRA
+ W "1. GENERAL:",?32,$P(SRAO(1),"^"),?41,"3. HEPATOBILIARY:",?76,$P(SRAO(3),"^")
+ W !,"  A. Height:" S Y=$P(SRAO("1A"),"^") W ?($S(Y="NS":19,1:24)),$J($P(Y,"^"),15),?43,"A. Ascites:",?76,$P(SRAO("3A"),"^")
+ W !,"  B. Weight:" S Y=$P(SRAO("1B"),"^") W ?($S(Y="NS":19,1:24)),$J(Y,15)
+ W !,"  C. Diabetes Mellitus:",?32,$P(SRAO("1C"),"^"),?41,"4. GASTROINTESTINAL:",?76,$P(SRAO(4),"^")
+ W !,"  D. Current Smoker W/I 1 Year:",?32,$P(SRAO("1D"),"^"),?43,"A. Esophageal Varices:",?76,$P(SRAO("4A"),"^")
+ W !,"  E. Pack/Years:",?32,$P(SRAO("1E"),"^")
+ W !,"  F. ETOH > 2 Drinks/Day:",?32,$P(SRAO("1F"),"^"),?41,"5. CARDIAC:",?76,$P(SRAO(5),"^")
+ W !,"  G. Dyspnea: ",?14,$J($P(SRAO("1G"),"^"),25),?43,"A. CHF Within 1 Month:",?76,$P(SRAO("5A"),"^")
+ W !,"  H. DNR Status: ",?32,$P(SRAO("1H"),"^"),?43,"B. MI Within 6 Months:",?76,$P(SRAO("5B"),"^")
+ W !,"  I. Pre-illness Funct",?43,"C. Previous PCI:",?76,$P(SRAO("5C"),"^")
+ W !,?17,"Status: ",$J($P(SRAO("1I"),"^"),17),?43,"D. Previous Cardiac Surgery:",?76,$P(SRAO("5D"),"^")
+ W !,"  J. Preop Funct Status: ",$J($P(SRAO("1J"),"^"),17),?43,"E. Angina Within 1 Month:",?76,$P(SRAO("5E"),"^")
+ W !,?43,"F. Hypertension Requiring Meds:",?76,$P(SRAO("5F"),"^")
+ W !,"2. PULMONARY:",?32,$P(SRAO(2),"^")
+ W !,"  A. Ventilator Dependent:",?32,$P(SRAO("2A"),"^"),?41,"6. VASCULAR:",?76,$P(SRAO(6),"^")
+ W !,"  B. History of Severe COPD:",?32,$P(SRAO("2B"),"^"),?43,"A. Revascularization/Amputation:",?76,$P(SRAO("6A"),"^")
+ W !,"  C. Current Pneumonia:",?32,$P(SRAO("2C"),"^"),?43,"B. Rest Pain/Gangrene:",?76,$P(SRAO("6B"),"^")
+ Q
+OUT(SRFLD,SRY) ; get data in output form
+ N C,Y
+ S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
+ I Y="NO STUDY" S Y="NS"
+ I SRFLD=236!(SRFLD=237)!(SRFLD=346) S Y=$E(Y,1,15)
+ I SRFLD=240!(SRFLD=492) D
+ .I SRY=2 S Y="PARTIAL DEPENDENT" Q
+ .I SRY=1 S Y=Y_"    " Q
+ .I SRY=4 S Y=Y_"      "
+ I SRFLD=325,$L(Y)=2 S Y=Y_"     "
+ Q Y
+HW ; get weight & height from Vitals
+ N SREND,SREX,SRSTRT
+WT I $P($G(^SRF(SRTN,206)),"^",2)="" D
+ .S SREND=$P($G(^SRF(SRTN,0)),"^",9),SRSTRT=$$FMADD^XLFDT(SREND,-30),SREX=$$HW^SROACL1(SRSTRT,SREND,"WT")
+ .I SREX'="" S SREX=SREX+.5\1,$P(^SRF(SRTN,206),"^",2)=SREX
+HT I $P($G(^SRF(SRTN,206)),"^")="" D
+ .S SREND=$P($G(^SRF(SRTN,0)),"^",9),SRSTRT=$$FMADD^XLFDT(SREND,-365),SREX=$$HW^SROACL1(SRSTRT,SREND,"HT")
+ .I SREX'="" S SREX=SREX+.5\1,$P(^SRF(SRTN,206),"^")=SREX
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAPS2.m

@@ -1 @@
-SROAPS2 ;BIR/MAM - PREOP INFO (PAGE 2) ;11/26/07
-        ;;3.0; Surgery ;**38,47,125,153,160,166**;24 Jun 93;Build 7
-        S SRPAGE="PAGE: 2 OF 2" D HDR^SROAUTL,PRE2
-        W !! F I=1:1:80 W "-"
-        Q
-PRE2    N SRX,Y S Y=$P($G(^SRF(SRTN,200.1)),"^",3) I Y="",$P(VADM(5),"^")="M" S $P(^SRF(SRTN,200.1),"^",3)="NA"
-        S SRA(200)=$G(^SRF(SRTN,200)),SRA(206)=$G(^SRF(SRTN,206)),SRA(200.1)=$G(^SRF(SRTN,200.1))
-        S Y=$P(SRA(200),"^",37),SRX=243,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",38),SRX=328,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",39),SRX=211,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",18),SRX=210,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",44),SRX=245,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",19),SRX=332,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",21),SRX=333,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",24),SRX=400,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",25),SRX=334,SRAO("2D")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",26),SRX=335,SRAO("2E")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",27),SRX=336,SRAO("2F")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",29),SRX=401,SRAO("2G")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",45),SRX=338,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",46),SRX=218,SRAO("3B")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",47),SRX=339,SRAO("3C")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",48),SRX=215,SRAO("3D")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",49),SRX=216,SRAO("3E")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200),"^",50),SRX=217,SRAO("3F")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",3),SRX=338.1,SRAO("3G")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",4),SRX=338.2,SRAO("3H")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(206),"^",8),SRX=218.1,SRAO("3I")=$$OUT(SRX,Y)_"^"_SRX
-        S Y=$P(SRA(200.1),"^",3),SRX=269,SRAO("3J")=$$OUT(SRX,Y)_"^"_SRX K SRA
-        W !,"1. RENAL:",?(38-$L($P(SRAO(1),"^"))),$P(SRAO(1),"^"),?40,"3. NUTRITIONAL/IMMUNE/OTHER:",?(79-$L($P(SRAO(3),"^"))),$P(SRAO(3),"^")
-        W !,"  A. Acute Renal Failure:",?(38-$L($P(SRAO("1A"),"^"))),$P(SRAO("1A"),"^"),?40,"  A. Disseminated Cancer:",?(79-$L($P(SRAO("3A"),"^"))),$P(SRAO("3A"),"^")
-        W !,"  B. Currently on Dialysis:",?(38-$L($P(SRAO("1B"),"^"))),$P(SRAO("1B"),"^"),?40,"  B. Open Wound:",?(79-$L($P(SRAO("3B"),"^"))),$P(SRAO("3B"),"^")
-        W !,?40,"  C. Steroid Use for Chronic Cond.:",?(79-$L($P(SRAO("3C"),"^"))),$P(SRAO("3C"),"^")
-        W !,"2. CENTRAL NERVOUS SYSTEM:",?(38-$L($P(SRAO(2),"^"))),$P(SRAO(2),"^"),?40,"  D. Weight Loss > 10%:",?(79-$L($P(SRAO("3D"),"^"))),$P(SRAO("3D"),"^")
-        W !,"  A. Impaired Sensorium: ",?(38-$L($P(SRAO("2A"),"^"))),$P(SRAO("2A"),"^"),?40,"  E. Bleeding Disorders:",?(79-$L($P(SRAO("3E"),"^"))),$P(SRAO("3E"),"^")
-        W !,"  B. Coma:",?(38-$L($P(SRAO("2B"),"^"))),$P(SRAO("2B"),"^"),?40,"  F. Transfusion > 4 RBC Units:",?(79-$L($P(SRAO("3F"),"^"))),$P(SRAO("3F"),"^")
-        W !,"  C. Hemiplegia:",?(38-$L($P(SRAO("2C"),"^"))),$P(SRAO("2C"),"^"),?40,"  G. Chemotherapy W/I 30 Days:",?(79-$L($P(SRAO("3G"),"^"))),$P(SRAO("3G"),"^")
-        W !,"  D. History of TIAs:",?(38-$L($P(SRAO("2D"),"^"))),$P(SRAO("2D"),"^"),?40,"  H. Radiotherapy W/I 90 Days:",?(79-$L($P(SRAO("3H"),"^"))),$P(SRAO("3H"),"^")
-        W !,"  E. CVA/Stroke w. Neuro Deficit:",?(38-$L($P(SRAO("2E"),"^"))),$P(SRAO("2E"),"^"),?40,"  I. Preoperative Sepsis:",?(79-$L($P(SRAO("3I"),"^"))),$P(SRAO("3I"),"^")
-        W !,"  F. CVA/Stroke w/o Neuro Deficit:",?(38-$L($P(SRAO("2F"),"^"))),$P(SRAO("2F"),"^"),?40,"  J. Pregnancy:",?(79-$L($P(SRAO("3J"),"^"))),$P(SRAO("3J"),"^")
-        W !,"  G. Tumor Involving CNS:",?(38-$L($P(SRAO("2G"),"^"))),$P(SRAO("2G"),"^")
-        Q
-OUT(SRFLD,SRY)  ; get data in output form
-        N C,Y
-        S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
-        I Y="NO STUDY" S Y="NS"
-        Q Y
+SROAPS2 ;BIR/MAM - PREOP INFO (PAGE 2) ;04/24/07
+ ;;3.0; Surgery ;**38,47,125,153,160**;24 Jun 93;Build 7
+ S SRPAGE="PAGE: 2 OF 2" D HDR^SROAUTL,PRE2
+ W !! F I=1:1:80 W "-"
+ Q
+PRE2 N SRX,Y S Y=$P($G(^SRF(SRTN,200.1)),"^",3) I Y="",$P(VADM(5),"^")="M" S $P(^SRF(SRTN,200.1),"^",3)="NA"
+ S SRA(200)=$G(^SRF(SRTN,200)),SRA(206)=$G(^SRF(SRTN,206)),SRA(200.1)=$G(^SRF(SRTN,200.1))
+ S Y=$P(SRA(200),"^",37),SRX=243,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",38),SRX=328,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",39),SRX=211,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",18),SRX=210,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",44),SRX=245,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",19),SRX=332,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",21),SRX=333,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",22),SRX=398,SRAO("2I")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",23),SRX=399,SRAO("2H")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",24),SRX=400,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",25),SRX=334,SRAO("2D")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",26),SRX=335,SRAO("2E")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",27),SRX=336,SRAO("2F")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",29),SRX=401,SRAO("2G")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",45),SRX=338,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",46),SRX=218,SRAO("3B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",47),SRX=339,SRAO("3C")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",48),SRX=215,SRAO("3D")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",49),SRX=216,SRAO("3E")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",50),SRX=217,SRAO("3F")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",3),SRX=338.1,SRAO("3G")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",4),SRX=338.2,SRAO("3H")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(206),"^",8),SRX=218.1,SRAO("3I")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200.1),"^",3),SRX=269,SRAO("3J")=$$OUT(SRX,Y)_"^"_SRX K SRA
+ W !,"1. RENAL:",?(38-$L($P(SRAO(1),"^"))),$P(SRAO(1),"^"),?40,"3. NUTRITIONAL/IMMUNE/OTHER:",?(79-$L($P(SRAO(3),"^"))),$P(SRAO(3),"^")
+ W !,"  A. Acute Renal Failure:",?(38-$L($P(SRAO("1A"),"^"))),$P(SRAO("1A"),"^"),?40,"  A. Disseminated Cancer:",?(79-$L($P(SRAO("3A"),"^"))),$P(SRAO("3A"),"^")
+ W !,"  B. Currently on Dialysis:",?(38-$L($P(SRAO("1B"),"^"))),$P(SRAO("1B"),"^"),?40,"  B. Open Wound:",?(79-$L($P(SRAO("3B"),"^"))),$P(SRAO("3B"),"^")
+ W !,?40,"  C. Steroid Use for Chronic Cond.:",?(79-$L($P(SRAO("3C"),"^"))),$P(SRAO("3C"),"^")
+ W !,"2. CENTRAL NERVOUS SYSTEM:",?(38-$L($P(SRAO(2),"^"))),$P(SRAO(2),"^"),?40,"  D. Weight Loss > 10%:",?(79-$L($P(SRAO("3D"),"^"))),$P(SRAO("3D"),"^")
+ W !,"  A. Impaired Sensorium: ",?(38-$L($P(SRAO("2A"),"^"))),$P(SRAO("2A"),"^"),?40,"  E. Bleeding Disorders:",?(79-$L($P(SRAO("3E"),"^"))),$P(SRAO("3E"),"^")
+ W !,"  B. Coma:",?(38-$L($P(SRAO("2B"),"^"))),$P(SRAO("2B"),"^"),?40,"  F. Transfusion > 4 RBC Units:",?(79-$L($P(SRAO("3F"),"^"))),$P(SRAO("3F"),"^")
+ W !,"  C. Hemiplegia:",?(38-$L($P(SRAO("2C"),"^"))),$P(SRAO("2C"),"^"),?40,"  G. Chemotherapy W/I 30 Days:",?(79-$L($P(SRAO("3G"),"^"))),$P(SRAO("3G"),"^")
+ W !,"  D. History of TIAs:",?(38-$L($P(SRAO("2D"),"^"))),$P(SRAO("2D"),"^"),?40,"  H. Radiotherapy W/I 90 Days:",?(79-$L($P(SRAO("3H"),"^"))),$P(SRAO("3H"),"^")
+ W !,"  E. CVA/Stroke w. Neuro Deficit:",?(38-$L($P(SRAO("2E"),"^"))),$P(SRAO("2E"),"^"),?40,"  I. Preoperative Sepsis:",?(79-$L($P(SRAO("3I"),"^"))),$P(SRAO("3I"),"^")
+ W !,"  F. CVA/Stroke w/o Neuro Deficit:",?(38-$L($P(SRAO("2F"),"^"))),$P(SRAO("2F"),"^"),?40,"  J. Pregnancy:",?(79-$L($P(SRAO("3J"),"^"))),$P(SRAO("3J"),"^")
+ W !,"  G. Tumor Involving CNS:",?(38-$L($P(SRAO("2G"),"^"))),$P(SRAO("2G"),"^")
+ W !,"  H. Paraplegia:",?(38-$L($P(SRAO("2H"),"^"))),$P(SRAO("2H"),"^")
+ W !,"  I. Quadriplegia:",?(38-$L($P(SRAO("2I"),"^"))),$P(SRAO("2I"),"^")
+ Q
+OUT(SRFLD,SRY) ; get data in output form
+ N C,Y
+ S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
+ I Y="NO STUDY" S Y="NS"
+ Q Y

WorldVistAEHR/trunk/r/SURGERY-SR/SROASS.m

@@ -1 @@
-SROASS  ;BIR/MAM - SELECT ASSESSMENT ;01/18/07
-        ;;3.0; Surgery ;**38,47,64,94,121,100,160,166**;24 Jun 93;Build 7
-PST     K:$D(DUZ("SAV")) SRNEW K SRTN W !! S SRSOUT=0
-        N SRSEL D ^SROPSEL G:'$D(DFN) END S SRANM=VADM(1)_"  "_VA("PID")
-START   ; start display
-        G:SRSOUT END W:SRSEL=1 @IOF,!,?1,SRANM
-        I $D(^DPT(DFN,.35)),$P(^(.35),"^") S SRDT=$P(^(.35),"^") W "         * DIED "_$E(SRDT,4,5)_"/"_$E(SRDT,6,7)_"/"_$E(SRDT,2,3)_" *"
-        I SRSEL=2 S CNT=0 D ^SROASSN G:$D(SRTN) ENTER G PST
-        D ^SROASS1 I SRSOUT G END
-        I $D(SRTN) G ENTER
-        I $D(SRNEW) S CNT=CNT+1,SRCASE(CNT)="" W CNT,".   ----     CREATE NEW ASSESSMENT"
-        I '$D(SRCASE(1)) W !!,"There are no Surgery Risk Assessments entered for "_VADM(1)_".",!! K DIR S DIR(0)="FOA",DIR("A")="  Press RETURN to continue.  " D ^DIR Q
-OPT     W !!!,"Select Surgical Case: " R X:DTIME I '$T!("^"[X) S SRSOUT=1 G END
-        I '$D(SRCASE(X)) W !!,"Enter the number of the desired assessment." W:$D(SRNEW) "  Select '"_CNT_"' to create an",!,"assessment for another surgical case." G OPT
-        I $D(SRNEW),X=CNT D ^SROANEW G END
-        I '$D(SRTN) S SRTN=+SRCASE(X)
-ENTER   ; edit, complete, or delete
-        I $D(SRPRINT)!'($D(SRNEW)) Q
-        S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T" D TRANS I 'SRYN K SRASS,SRTN S:SRSEL=2 SRSOUT=1 G START
-        I SRATYPE="N"&($P(SR("RA"),"^",2)="C") W !!,"You've selected a Cardiac assessment, using a Non-Cardiac Option," K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO" D ^DIR S X=$E(X) I "Yy"'[X K SRTN S SRSOUT=1 G END
-        I SRATYPE="C"&($P(SR("RA"),"^",2)="N") W !!,"You've selected a Non-Cardiac assessment, using a Cardiac Option," K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO" D ^DIR S X=$E(X) I "Yy"'[X K SRTN S SRSOUT=1 G END
-        W @IOF,!,?1,SRANM,!! S SRSDATE=$P(^SRF(SRTN,0),"^",9) S SRASS=SRTN D DISP^SROASS1
-        I SRATYPE="N" D EXCL
-        W !!,"1. Enter Risk Assessment Information",!,"2. Delete Risk Assessment Entry",!,"3. Update Assessment Status to 'COMPLETE'"
-        W !!,"Select Number:  1//  " R X:DTIME I '$T!(X["^") K SRTN,SRASS S SRSOUT=1 G END
-        S:X="" X=1 I X<1!(X>3)!(X'?.N) D HELP G ENTER
-        I X=2 D ^SROADEL W !!,"Press <RET> to continue  " R X:DTIME W @IOF K SRTN G END
-        I X=3 D @($S($P(SR("RA"),"^",2)="C":"^SROACOM1",1:"^SROACOM")) K SRTN G END
-        Q
-EXCL    I $P($G(^SRO(136,SRTN,10)),"^"),'$$XL^SROAX(SRTN) D
-        .W !!,">>> Based on CPT Codes assigned for this case, this case should be excluded." Q
-        N SRPROC,SRL S SRL=49 D CPTS^SROAUTL0 I SRPROC(1)="NOT ENTERED" D
-        .W !!,">>> No CPT Codes have been assigned for this case."
-        Q
-END     S:'$D(SRSOUT) SRSOUT=1 W:SRSOUT @IOF D ^SRSKILL
-        Q
-HELP    ;
-        W !!,"Enter <RET> or '1' to enter or edit information related to this Risk ",!,"Assessment entry.  If you want to delete the Assessment, enter '2'."
-        W !,"Enter '3' to update the status of this Assessment to 'COMPLETE'."
-        W !!,"Press <RET> to continue  " R X:DTIME
-        Q
-TRANS   W @IOF,!,"This assessment has already been transmitted.  The information contained",!,"in it cannot be altered unless you first change the status to 'INCOMPLETE'."
-        S SRYN=0 K DIR S DIR("A")="Do you wish to change the status of this assessment to 'INCOMPLETE'",DIR("B")="NO",DIR(0)="Y" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
-        S SRYN=Y I 'SRYN Q
-        I $$LOCK^SROUTL(SRTN) K DA,DIE,DR S DIE=130,DA=SRTN,DR="235////I;393////1" D ^DIE K DA,DIE,DR D UNLOCK^SROUTL(SRTN)
-        Q
+SROASS ;BIR/MAM - SELECT ASSESSMENT ;01/18/07
+ ;;3.0; Surgery ;**38,47,64,94,121,100,160**;24 Jun 93;Build 7
+PST K:$D(DUZ("SAV")) SRNEW K SRTN W !! S SRSOUT=0
+ N SRSEL D ^SROPSEL G:'$D(DFN) END S SRANM=VADM(1)_"  "_VA("PID")
+START ; start display
+ G:SRSOUT END W:SRSEL=1 @IOF,!,?1,SRANM
+ I $D(^DPT(DFN,.35)),$P(^(.35),"^") S SRDT=$P(^(.35),"^") W "         * DIED "_$E(SRDT,4,5)_"/"_$E(SRDT,6,7)_"/"_$E(SRDT,2,3)_" *"
+ I SRSEL=2 S CNT=0 D ^SROASSN G:$D(SRTN) ENTER G PST
+ D ^SROASS1 I SRSOUT G END
+ I $D(SRTN) G ENTER
+ I $D(SRNEW) S CNT=CNT+1,SRCASE(CNT)="" W CNT,".   ----     CREATE NEW ASSESSMENT"
+ I '$D(SRCASE(1)) W !!,"There are no Surgery Risk Assessments entered for "_VADM(1)_".",!! K DIR S DIR(0)="FOA",DIR("A")="  Press RETURN to continue.  " D ^DIR Q
+OPT W !!!,"Select Surgical Case: " R X:DTIME I '$T!("^"[X) S SRSOUT=1 G END
+ I '$D(SRCASE(X)) W !!,"Enter the number of the desired assessment." W:$D(SRNEW) "  Select '"_CNT_"' to create an",!,"assessment for another surgical case." G OPT
+ I $D(SRNEW),X=CNT D ^SROANEW G END
+ I '$D(SRTN) S SRTN=+SRCASE(X)
+ENTER ; edit, complete, or delete
+ I $D(SRPRINT)!'($D(SRNEW)) Q
+ S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T" D TRANS I 'SRYN K SRASS,SRTN S:SRSEL=2 SRSOUT=1 G START
+ I SRATYPE="N"&($P(SR("RA"),"^",2)="C") W !!,"You've selected a Cardiac assessment, using a Non-Cardiac Option," K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO" D ^DIR S X=$E(X) I "Yy"'[X K SRTN S SRSOUT=1 G END
+ I SRATYPE="C"&($P(SR("RA"),"^",2)="N") W !!,"You've selected a Non-Cardiac assessment, using a Cardiac Option," K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO" D ^DIR S X=$E(X) I "Yy"'[X K SRTN S SRSOUT=1 G END
+ W @IOF,!,?1,SRANM,!! S SRSDATE=$P(^SRF(SRTN,0),"^",9) S SRASS=SRTN D DISP^SROASS1
+ I SRATYPE="N" D EXCL
+ W !!,"1. Enter Risk Assessment Information",!,"2. Delete Risk Assessment Entry",!,"3. Update Assessment Status to 'COMPLETE'"
+ W !!,"Select Number:  1//  " R X:DTIME I '$T!(X["^") K SRTN,SRASS S SRSOUT=1 G END
+ S:X="" X=1 I X<1!(X>3)!(X'?.N) D HELP G ENTER
+ I X=2 D ^SROADEL W !!,"Press <RET> to continue  " R X:DTIME W @IOF K SRTN G END
+ I X=3 D ^SROACOM K SRTN G END
+ Q
+EXCL I $P($G(^SRO(136,SRTN,10)),"^"),'$$XL^SROAX(SRTN) D
+ .W !!,">>> Based on CPT Codes assigned for this case, this case should be excluded." Q
+ N SRPROC,SRL S SRL=49 D CPTS^SROAUTL0 I SRPROC(1)="NOT ENTERED" D
+ .W !!,">>> No CPT Codes have been assigned for this case."
+ Q
+END S:'$D(SRSOUT) SRSOUT=1 W:SRSOUT @IOF D ^SRSKILL
+ Q
+HELP ;
+ W !!,"Enter <RET> or '1' to enter or edit information related to this Risk ",!,"Assessment entry.  If you want to delete the Assessment, enter '2'."
+ W !,"Enter '3' to update the status of this Assessment to 'COMPLETE'."
+ W !!,"Press <RET> to continue  " R X:DTIME
+ Q
+TRANS W @IOF,!,"This assessment has already been transmitted.  The information contained",!,"in it cannot be altered unless you first change the status to 'INCOMPLETE'."
+ S SRYN=0 K DIR S DIR("A")="Do you wish to change the status of this assessment to 'INCOMPLETE'",DIR("B")="NO",DIR(0)="Y" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
+ S SRYN=Y I 'SRYN Q
+ I $$LOCK^SROUTL(SRTN) K DA,DIE,DR S DIE=130,DA=SRTN,DR="235////I;393////1" D ^DIE K DA,DIE,DR D UNLOCK^SROUTL(SRTN)
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROASSP.m

@@ -1 @@
-SROASSP ;BIR/MAM - PRINT A COMPLETED ASSESSMENT ;12/05/07
-        ;;3.0; Surgery ;**38,94,166**;24 Jun 93;Build 7
-BATCH   ;
-        W ! K DIR S DIR("?",1)="Enter YES to batch print all completed or transmitted assessments for a",DIR("?",2)="selected date range.  Enter NO or press return to print one specific",DIR("?")="assessment."
-        S DIR("A")="Do you want to batch print assessments for a specific date range ? ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END
-        I Y D ^SROABCH Q
-        S SRPRINT=1 K SRNEW D ^SROASS I '$D(SRTN) S SRSOUT=1 G END
-        W ! K %ZIS,IO("Q"),POP S %ZIS("A")="Print the Completed Assessment on which Device: ",%ZIS="Q" D ^%ZIS I POP S SRSOUT=1 G END
-        I $D(IO("Q")) K IO("Q") S ZTDESC="Completed Surgery Risk Assessment",ZTSAVE("SRSITE*")="",ZTSAVE("SRTN")="",ZTRTN=$S($P($G(^SRF(SRTN,"RA")),"^",2)="C":"EN^SROACOM1",1:"EN^SROACOM") D ^%ZTLOAD G END
-        D @($S($P($G(^SRF(SRTN,"RA")),"^",2)="C":"EN^SROACOM1",1:"EN^SROACOM"))
-END     D ^%ZISC W @IOF K SRTN D ^SRSKILL
-        Q
+SROASSP ;B'HAM ISC/MAM - PRINT A COMPLETED ASSESSMENT ; [04/06/00  12:05 PM ]
+ ;;3.0; Surgery ;**38,94**;24 Jun 93
+BATCH ;
+ W ! K DIR S DIR("?",1)="Enter YES to batch print all completed or transmitted assessments for a",DIR("?",2)="selected date range.  Enter NO or press return to print one specific",DIR("?")="assessment."
+ S DIR("A")="Do you want to batch print assessments for a specific date range ? ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END
+ I Y D ^SROABCH Q
+ S SRPRINT=1 K SRNEW D ^SROASS I '$D(SRTN) S SRSOUT=1 G END
+ W ! K %ZIS,IO("Q"),POP S %ZIS("A")="Print the Completed Assessment on which Device: ",%ZIS="Q" D ^%ZIS I POP S SRSOUT=1 G END
+ I $D(IO("Q")) K IO("Q") S ZTDESC="Completed Surgery Risk Assessment",ZTSAVE("SRSITE*")="",ZTSAVE("SRTN")="",ZTRTN="EN^SROACOM" D ^%ZTLOAD G END
+ D EN^SROACOM
+END D ^%ZISC W @IOF K SRTN D ^SRSKILL
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROATCM3.m

@@ -1 @@
-SROATCM3        ;BIR/SJA - STUFF TRANMISSION IN ^TMP ;12/03/07
-        ;;3.0; Surgery ;**125,135,153,164,166**;24 Jun 93;Build 7
-        N SRDISP,NYUK S SRDISP="",NYUK=$P(SRRES(1),U,2),SRA(209.1)=$G(^SRF(SRTN,209.1)),SRA(207.1)=$G(^SRF(SRTN,207.1))
-        I NYUK'="" D
-        .S SRDISP=$S(NYUK="BOARDING HOUSE":16,NYUK="COMMUNITY HOSPITAL":6,NYUK="COMMUNITY NURSING HOME":8,NYUK="FOSTER HOME":14,NYUK="HALFWAY HOUSE":15,NYUK="HOME-BASED PRIMARY CARE (HBPC)":20,1:NYUK)
-        .Q:SRDISP'=NYUK  S SRDISP=$S(NYUK="HOSPICE CARE":22,NYUK="MILITARY HOSPITAL":3,NYUK="NURSE CARE CONTD ANOTHER COMM ":10,NYUK="NURSING CARE CONT AT SAME NURS":9,NYUK="OTHER FEDERAL HOSPITAL":4,1:NYUK)
-        .Q:SRDISP'=NYUK  S SRDISP=$S(NYUK="OTHER GOVERNMENT HOSPITAL":5,NYUK="OTHER PLACEMENT/UNKNOWN (NOT S":19,NYUK="PENAL INSTITUTION":17,NYUK="REFER MEDICARE HOME HEALTH CAR":25,NYUK="REFER OTHER AGENCY-PD HOME HEA":26,1:NYUK)
-        .Q:SRDISP'=NYUK  S SRDISP=$S(NYUK="REFER VA-PD HOME/COMMUNITY HEA":24,NYUK="RESIDENTIAL HOTEL/RESIDENT (IE":18,NYUK="RESPITE CARE":23,NYUK="RETURN TO COMMUNITY-INDEPENDEN":1,NYUK="SPINAL CORD INJURY-VACO APPROV":21,1:NYUK)
-        .Q:SRDISP'=NYUK  S SRDISP=$S(NYUK="STATE HOME":11,NYUK="STATE HOME":13,NYUK="VA DOMICILLARY":12,NYUK="VA MEDICAL CENTER":2,NYUK="VA NURSING HOME CARE UNIT (NHC":7,1:"")
-        ;
-LN26    S SHEMP=$E(SHEMP,1,11)_" 26"_$J(SRDISP,2)_$J($P(SRA(206),"^",13),2)_$J($P(SRA(206),"^",15),2)_$J($P(SRA(207),"^",6),2)_$J($P(SRA(207),"^",27),2)_$J($P(SRA(209),"^"),2)_$J($P(SRA(209),"^",2),2)
-        S SHEMP=SHEMP_$J($P(SRA(209),"^",3),2)_$J($P(SRA(209),"^",4),2)_$J($P(SRA(209),"^",5),2)_$J($P(SRA(209),"^",6),3)_$J($P(SRA(209),"^",7),3)_$J($P(SRA(209),"^",8),3)_$J($P(SRA(209),"^",9),2)_$J($P(SRA(209),"^",10),2)
-        S X=$P(SRA(206),"^",42),Y="" F I=1:1:5 S Y=Y_$P(X,",",I)
-        S SHEMP=SHEMP_$J($P(SRA(209),"^",11),2)_$J(Y,5)
-        S X=$P(SRA(209),"^",12) S:X="" X="N" S SHEMP=SHEMP_$J(X,2)
-        ; CT Surgery Consult Date and cause for delay
-        S SRDATE=$P(SRA(209),"^",15),SRDATE=$$LJ^XLFSTR(SRDATE,7,0),SHEMP=SHEMP_SRDATE
-        S X=$P(SRA(209),"^",16),SHEMP=SHEMP_$J(X,2)
-        S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
-LN27    ;Line #27 - Other Cardiac Procedures
-        S SHEMP=$E(SHEMP,1,11)_" 27"_$TR($E($G(SRA(209.1)),1,65),",","^")
-        S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
-LN28    ;Lines 28 - New fields added in 2006 update
-        S SHEMP=$E(SHEMP,1,11)_" 28"_$J($P(SRA(209),"^",13),2)_$J($P(SRA(209),"^",14),2)_$J($P(SRA(207.1),"^",2),2)_$J($P(SRA(201),"^",28),6)_$J($P(SRA(202.1),"^"),7)
-        S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
-        Q
+SROATCM3 ;BIR/SJA - STUFF TRANMISSION IN ^TMP ;08/24/07
+ ;;3.0; Surgery ;**125,135,153,164**;24 Jun 93;Build 2
+ N SRDISP,NYUK S SRDISP="",NYUK=$P(SRRES(1),U,2),SRA(209.1)=$G(^SRF(SRTN,209.1)),SRA(207.1)=$G(^SRF(SRTN,207.1))
+ I NYUK'="" D
+ .S SRDISP=$S(NYUK="BOARDING HOUSE":16,NYUK="COMMUNITY HOSPITAL":6,NYUK="COMMUNITY NURSING HOME":8,NYUK="FOSTER HOME":14,NYUK="HALFWAY HOUSE":15,NYUK="HOME-BASED PRIMARY CARE (HBPC)":20,1:NYUK)
+ .Q:SRDISP'=NYUK  S SRDISP=$S(NYUK="HOSPICE CARE":22,NYUK="MILITARY HOSPITAL":3,NYUK="NURSE CARE CONTD ANOTHER COMM ":10,NYUK="NURSING CARE CONT AT SAME NURS":9,NYUK="OTHER FEDERAL HOSPITAL":4,1:NYUK)
+ .Q:SRDISP'=NYUK  S SRDISP=$S(NYUK="OTHER GOVERNMENT HOSPITAL":5,NYUK="OTHER PLACEMENT/UNKNOWN (NOT S":19,NYUK="PENAL INSTITUTION":17,NYUK="REFER MEDICARE HOME HEALTH CAR":25,NYUK="REFER OTHER AGENCY-PD HOME HEA":26,1:NYUK)
+ .Q:SRDISP'=NYUK  S SRDISP=$S(NYUK="REFER VA-PD HOME/COMMUNITY HEA":24,NYUK="RESIDENTIAL HOTEL/RESIDENT (IE":18,NYUK="RESPITE CARE":23,NYUK="RETURN TO COMMUNITY-INDEPENDEN":1,NYUK="SPINAL CORD INJURY-VACO APPROV":21,1:NYUK)
+ .Q:SRDISP'=NYUK  S SRDISP=$S(NYUK="STATE HOME":11,NYUK="STATE HOME":13,NYUK="VA DOMICILLARY":12,NYUK="VA MEDICAL CENTER":2,NYUK="VA NURSING HOME CARE UNIT (NHC":7,1:"")
+ ;
+LN26 S SHEMP=$E(SHEMP,1,11)_" 26"_$J(SRDISP,2)_$J($P(SRA(206),"^",13),2)_$J($P(SRA(206),"^",15),2)_$J($P(SRA(207),"^",6),2)_$J($P(SRA(207),"^",27),2)_$J($P(SRA(209),"^"),2)_$J($P(SRA(209),"^",2),2)
+ S SHEMP=SHEMP_$J($P(SRA(209),"^",3),2)_$J($P(SRA(209),"^",4),2)_$J($P(SRA(209),"^",5),2)_$J($P(SRA(209),"^",6),3)_$J($P(SRA(209),"^",7),3)_$J($P(SRA(209),"^",8),3)_$J($P(SRA(209),"^",9),2)_$J($P(SRA(209),"^",10),2)
+ S X=$P(SRA(206),"^",42),Y="" F I=1:1:5 S Y=Y_$P(X,",",I)
+ S SHEMP=SHEMP_$J($P(SRA(209),"^",11),2)_$J(Y,5)
+ S X=$P(SRA(209),"^",12) S:X="" X="N" S SHEMP=SHEMP_$J(X,2)
+ ; CT Surgery Consult Date
+ S SRDATE=$P(SRA(209),"^",15),SRDATE=$$LJ^XLFSTR(SRDATE,7,0),SHEMP=SHEMP_SRDATE
+ S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
+LN27 ;Line #27 - Other Cardiac Procedures
+ S SHEMP=$E(SHEMP,1,11)_" 27"_$TR($E($G(SRA(209.1)),1,65),",","^")
+ S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
+LN28 ;Lines 28 - New fields added in 2006 update
+ S SHEMP=$E(SHEMP,1,11)_" 28"_$J($P(SRA(209),"^",13),2)_$J($P(SRA(209),"^",14),2)_$J($P(SRA(207.1),"^",2),2)_$J($P(SRA(201),"^",28),6)_$J($P(SRA(202.1),"^"),7)
+ S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROATM1.m

@@ -1 @@
-SROATM1 ;BIR/MAM - NON CARDIAC TRANSMISSION ;12/10/07
-        ;;3.0; Surgery ;**27,38,47,60,62,81,88,93,95,125,153,160,166**;24 Jun 93;Build 7
-        ;** NOTICE: This routine is part of an implementation of a nationally
-        ;**         controlled procedure. Local modifications to this routine
-        ;**         are prohibited.
-        ;
-        ; Reference to ^DIC(45.3 supported by DBIA #218
-        ;
-        N SRINTUB,SRDTH,SRPID,SRCDT,SRCREQ F I=0,200,200.1,206 S SRA(I)=$G(^SRF(SRTN,I))
-        S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANAME=VADM(1),SEX=$P(VADM(5),"^"),Z=$P(VADM(3),"^"),SRSDATE=$E($P(SRA(0),"^",9),1,12),Y=$E(SRSDATE,1,7),AGE=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
-        S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID
-        S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
-        S X=$P($G(^SRF(SRTN,205)),"^",3),SRDTH=$S(X:X,1:$P(VADM(6),"^"))
-        S SRCDT=$P($G(^SRF(SRTN,209)),"^",15),SRCREQ=$P($G(^SRF(SRTN,209)),"^",17)
-        S SHEMP=">"_$J(SRASITE,3)_$J(SRTN,7)_"  1"_DT_$J(AGE,3)_$J(SEX,1)_$J(SRSDATE,12)_$J(SRPID,20)_$J(SRDIV,6)_$J(SRDTH,12)_$J(SRCDT,7)_$J(SRCREQ,7)
-        S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_"  2",SRACNT=SRACNT+1
-        S NYUK=$P(SRA(200),"^",2) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",3) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",4) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",2) D ONE S SHEMP=SHEMP_MOE
-        S NYUK=$P(SRA(200),"^",6) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",7) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",8) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",10) D ONE S SHEMP=SHEMP_MOE
-        S NYUK=$P(SRA(200),"^",11) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",12) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",6) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",15) D ONE S SHEMP=SHEMP_MOE
-        S NYUK=$P(SRA(200),"^",16) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",17) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",31) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",32) D ONE S SHEMP=SHEMP_MOE
-        S NYUK=$P(SRA(200),"^",33) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",34) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",35) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",36) D ONE S SHEMP=SHEMP_MOE
-        S NYUK=$P(SRA(200),"^",38) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",39) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",41) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",42) D ONE S SHEMP=SHEMP_MOE
-        S NYUK=$P(SRA(200),"^",43) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",19) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",20) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",21) D ONE S SHEMP=SHEMP_MOE
-        S NYUK=$P(SRA(200),"^",22) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",23) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",24) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",25) D ONE S SHEMP=SHEMP_MOE
-        S NYUK=$P(SRA(200),"^",26) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",27) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",28) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",29) D ONE S SHEMP=SHEMP_MOE
-        S NYUK=$P(SRA(200),"^",45) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",46) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",47) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",48) D ONE S SHEMP=SHEMP_MOE
-        S NYUK=$P(SRA(200),"^",49) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",50) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",3),SHEMP=SHEMP_$J(NYUK,2)
-        S NYUK=$P(SRA(0),"^",4) S:NYUK NYUK=$E($P(^DIC(45.3,$P(^SRO(137.45,NYUK,0),"^",2),0),"^"),1,3) S SHEMP=SHEMP_$J(NYUK,3)
-        S NYUK=$P(SRA(200),"^",52),SHEMP=SHEMP_$J(NYUK,2),X=$P(SRA(0),"^",10),NYUK=$S(X="EM":"Y",1:"N") D ONE S SHEMP=SHEMP_MOE
-        S NYUK=$P($G(^SRF(SRTN,"1.0")),"^",8),SHEMP=SHEMP_$J(NYUK,2),NYUK=$P(SRA(200),"^",53) D ONE S SHEMP=SHEMP_MOE
-        S SRASA="",Y=$P($G(^SRF(SRTN,1.1)),"^",3) S:Y X=$P($P($G(^SRO(132.8,Y,0)),"^"),"-"),SRASA=X S NYUK=$E(SRASA,1,1) D ONE S SHEMP=SHEMP_MOE
-        K SRTECH,SRZ,SRTRAUMA S SRT=0 F  S SRT=$O(^SRF(SRTN,6,SRT)) Q:'SRT  D ^SROPRIN Q:$D(SRZ)
-        I $D(SRTECH) S SRTRAUMA=$P(^SRF(SRTN,6,SRT,0),"^",14),SRINTUB=$P($G(^SRF(SRTN,6,SRT,8)),"^",2)
-        I '$D(SRTECH) S (SRTECH,SRTRAUMA,SRINTUB)=""
-        S SHEMP=SHEMP_$J(SRTECH,1)_$J($E(SRASA,2),1)_$J(SRINTUB,1)_" "
-        S NYUK=$P(SRA(206),"^"),SHEMP=SHEMP_$J(NYUK,4),NYUK=$P(SRA(206),"^",2),SHEMP=SHEMP_$J(NYUK,4)
-        S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_"  3",SRACNT=SRACNT+1
-        D ^SROATM2
-        Q
-ONE     S MOE=$S(NYUK="NS":"S",NYUK="":" ",1:NYUK)
-        Q
+SROATM1 ;BIR/MAM - NON CARDIAC TRANSMISSION ;05/10/07
+ ;;3.0; Surgery ;**27,38,47,60,62,81,88,93,95,125,153,160**;24 Jun 93;Build 7
+ ;** NOTICE: This routine is part of an implementation of a nationally
+ ;**         controlled procedure. Local modifications to this routine
+ ;**         are prohibited.
+ ;
+ ; Reference to ^DIC(45.3 supported by DBIA #218
+ ;
+ N SRINTUB,SRDTH,SRPID F I=0,200,200.1,206 S SRA(I)=$G(^SRF(SRTN,I))
+ S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANAME=VADM(1),SEX=$P(VADM(5),"^"),Z=$P(VADM(3),"^"),SRSDATE=$E($P(SRA(0),"^",9),1,12),Y=$E(SRSDATE,1,7),AGE=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
+ S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID
+ S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
+ S X=$P($G(^SRF(SRTN,205)),"^",3),SRDTH=$S(X:X,1:$P(VADM(6),"^"))
+ S SHEMP=">"_$J(SRASITE,3)_$J(SRTN,7)_"  1"_DT_$J(AGE,3)_$J(SEX,1)_$J(SRSDATE,12)_$J(SRPID,20)_$J(SRDIV,6)_$J(SRDTH,12)
+ S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_"  2",SRACNT=SRACNT+1
+ S NYUK=$P(SRA(200),"^",2) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",3) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",4) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",2) D ONE S SHEMP=SHEMP_MOE
+ S NYUK=$P(SRA(200),"^",6) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",7) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",8) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",10) D ONE S SHEMP=SHEMP_MOE
+ S NYUK=$P(SRA(200),"^",11) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",12) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",6) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",15) D ONE S SHEMP=SHEMP_MOE
+ S NYUK=$P(SRA(200),"^",16) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",17) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",31) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",32) D ONE S SHEMP=SHEMP_MOE
+ S NYUK=$P(SRA(200),"^",33) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",34) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",35) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",36) D ONE S SHEMP=SHEMP_MOE
+ S NYUK=$P(SRA(200),"^",38) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",39) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",41) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",42) D ONE S SHEMP=SHEMP_MOE
+ S NYUK=$P(SRA(200),"^",43) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",19) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",20) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",21) D ONE S SHEMP=SHEMP_MOE
+ S NYUK=$P(SRA(200),"^",22) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",23) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",24) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",25) D ONE S SHEMP=SHEMP_MOE
+ S NYUK=$P(SRA(200),"^",26) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",27) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",28) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",29) D ONE S SHEMP=SHEMP_MOE
+ S NYUK=$P(SRA(200),"^",45) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",46) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",47) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",48) D ONE S SHEMP=SHEMP_MOE
+ S NYUK=$P(SRA(200),"^",49) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",50) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",3),SHEMP=SHEMP_$J(NYUK,2)
+ S NYUK=$P(SRA(0),"^",4) S:NYUK NYUK=$E($P(^DIC(45.3,$P(^SRO(137.45,NYUK,0),"^",2),0),"^"),1,3) S SHEMP=SHEMP_$J(NYUK,3)
+ S NYUK=$P(SRA(200),"^",52),SHEMP=SHEMP_$J(NYUK,2),X=$P(SRA(0),"^",10),NYUK=$S(X="EM":"Y",1:"N") D ONE S SHEMP=SHEMP_MOE
+ S NYUK=$P($G(^SRF(SRTN,"1.0")),"^",8),SHEMP=SHEMP_$J(NYUK,2),NYUK=$P(SRA(200),"^",53) D ONE S SHEMP=SHEMP_MOE
+ S SRASA="",Y=$P($G(^SRF(SRTN,1.1)),"^",3) S:Y X=$P($P($G(^SRO(132.8,Y,0)),"^"),"-"),SRASA=X S NYUK=$E(SRASA,1,1) D ONE S SHEMP=SHEMP_MOE
+ K SRTECH,SRZ,SRTRAUMA S SRT=0 F  S SRT=$O(^SRF(SRTN,6,SRT)) Q:'SRT  D ^SROPRIN Q:$D(SRZ)
+ I $D(SRTECH) S SRTRAUMA=$P(^SRF(SRTN,6,SRT,0),"^",14),SRINTUB=$P($G(^SRF(SRTN,6,SRT,8)),"^",2)
+ I '$D(SRTECH) S (SRTECH,SRTRAUMA,SRINTUB)=""
+ S SHEMP=SHEMP_$J(SRTECH,1)_$J($E(SRASA,2),1)_$J(SRINTUB,1)_" "
+ S NYUK=$P(SRA(206),"^"),SHEMP=SHEMP_$J(NYUK,4),NYUK=$P(SRA(206),"^",2),SHEMP=SHEMP_$J(NYUK,4)
+ S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_"  3",SRACNT=SRACNT+1
+ D ^SROATM2
+ Q
+ONE S MOE=$S(NYUK="NS":"S",NYUK="":" ",1:NYUK)
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROATMNO.m

@@ -1 @@
-SROATMNO        ;BIR/MAM - TRANSMIT NO ASSESSMENT ;12/18/07
-        ;;3.0; Surgery ;**27,38,47,62,68,79,83,81,88,93,95,97,129,125,142,153,160,166**;24 Jun 93;Build 7
-        ;** NOTICE: This routine is part of an implementation of a nationally
-        ;**         controlled procedure. Local modifications to this routine
-        ;**         are prohibited.
-        ;
-        ; Reference to ^DIC(45.3 supported by DBIA #218
-        ;
-        N SR10SP,SRINTUB,SR95PO,SRLO,SRPID,TDATE K ^TMP("SRA",$J) S SRATOT=0,SRASITE=+$P($$SITE^SROVAR,"^",3),(SRAMNUM,SRACNT)=1
-        S Z=$E(DT,1,3)-1,SRLO=Z_"0214"
-        S TDATE=0 F  S TDATE=$O(^SRF("AQ",TDATE)) Q:TDATE=""  I DT'<TDATE S SRTN=0 F  S SRTN=$O(^SRF("AQ",TDATE,SRTN)) Q:'SRTN  D SET
-        S SRATOTM=SRAMNUM D ^SROATM4
-        Q
-SET     I $P($G(^SRF(SRTN,.4)),"^",2)="T"!(TDATE<SRLO) K ^SRF("AQ",TDATE,SRTN) Q
-        I $P($G(^SRF(SRTN,30)),"^")!$P($G(^SRF(SRTN,31)),"^",8)!'$P($G(^SRF(SRTN,.2)),"^",12)!($P($G(^SRF(SRTN,"NON")),"^")="Y") K ^SRF("AQ",TDATE,SRTN) S $P(^SRF(SRTN,.4),"^",2)="" Q
-        I $P($G(^SRF(SRTN,"RA")),"^",6)="Y",$P($G(^SRF(SRTN,"RA")),"^",2)="N" K ^SRF("AQ",TDATE,SRTN) Q
-        I $P($G(^SRF(SRTN,0)),"^",9)="" K ^SRF("AQ",TDATE,SRTN) Q
-        S SR10SP="          " K DA,DIE,DR S DA=SRTN,DIE=130,DR="905///R" D ^DIE K DR,DA,DIE
-        S SRA(0)=^SRF(SRTN,0),DATE=$E($P(SRA(0),"^",9),1,7),SPEC=$P(SRA(0),"^",4) S:SPEC SPEC=$P(^DIC(45.3,$P(^SRO(137.45,SPEC,0),"^",2),0),"^")
-        S EMERG=$P(SRA(0),"^",10),EMERG=$S(EMERG="EM":"Y",1:"N")
-        K SRTECH,SRZ S SRT=0 F  S SRT=$O(^SRF(SRTN,6,SRT)) Q:'SRT  D ^SROPRIN Q:$D(SRZ)
-        I $D(SRTECH) S SRINTUB=$P($G(^SRF(SRTN,6,SRT,8)),"^",2)
-        I '$D(SRTECH) S (SRTECH,SRINTUB)=""
-        S CPT=$P($G(^SRO(136,SRTN,0)),"^",2),SRPMOD="" I CPT S CPT=$P($$CPT^ICPTCOD(CPT),"^",2) D
-        .S SRM=0,SRCNT=1 F  S SRM=$O(^SRO(136,SRTN,1,SRM)) Q:'SRM  D  Q:SRCNT>5
-        ..S X=$P(^SRO(136,SRTN,1,SRM,0),"^") I X S Y=$P($$MOD^ICPTMOD(X,"I"),"^",2),SRPMOD=SRPMOD_Y,SRCNT=SRCNT+1
-        S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRDOB=$E($P(VADM(3),"^"),1,7),SRDEATH=$P(VADM(6),U)
-        S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID
-        S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
-        D RS^SROATM2
-        S SRMAJMIN=$E($P($G(^SRF(SRTN,0)),U,3),1)
-        S SRDTHUR=$E($P($G(^SRF(SRTN,.4)),U,7),1)
-        S SRSTATUS=$E($P($G(^SRF(SRTN,0)),U,12),1) I SRSTATUS'="I"&(SRSTATUS'="O") S VAIP("D")=$P(SRA(0),"^",9) D IN5^VADPT S SRSTATUS=$S(VAIP(13):"I",1:"O") K VAIP
-        S SRAGE="" I $P(VADM(3),"^") S SRAGE=$E(DATE,1,3)-$E($P(VADM(3),"^"),1,3)-($E(DATE,4,7)<$E($P(VADM(3),"^"),4,7))
-        S SRASA="",Y=$P($G(^SRF(SRTN,1.1)),"^",3) S:Y X=$P($P($G(^SRO(132.8,Y,0)),"^"),"-"),SRASA=$E(X,1,2)
-        ; Admission wi 14 days following outpatient surgery due to an Occurrence 
-        S (SRADMIT,SRADMT)=0 I SRSTATUS="O" D ADM^SROQ0A S SRADMIT=$S(SRADMT=0:"0",1:"1")
-        S EXC=$P($G(^SRF(SRTN,"RA")),"^",7),SRWOUND=$P($G(^SRF(SRTN,"1.0")),"^",8)
-        D OCC
-        S SRNODE="  X" S:$P($G(^SRF(SRTN,"RA")),U,6)="N" SRNODE="  *" S:$P($G(^SRF(SRTN,"RA")),U,2)="C" SRNODE="  C"
-        S SRTEMP="/"_$J(SRASITE,3)_$J(SRTN,7)_SRNODE_$J(DATE,7)_$J(SRTECH,3)_$J(EMERG,1)_$J(SPEC,3)_$J(CPT,5)_$J(EXC,1)_$J(SRPID,20)_$J(SRDIV,6)_" "
-        S SRTEMP=SRTEMP_$J(SRMAJMIN,1)_$J($E(SRDEATH,1,7),7)_$J(SRDTHUR,1)_$J(SRSTATUS,1)_$J(SRAGE,3)_$J(SRASA,2)_$J(SRADMIT,1)_SRTMP
-        K CPT,SRMOD F SRZ=1:1:10 S (CPT(SRZ),SRMOD(SRZ))=""
-        S (OPS,CNT)=0 F  S OPS=$O(^SRO(136,SRTN,3,OPS)) Q:'OPS!(CNT=10)  S CNT=CNT+1,X=$P($G(^SRO(136,SRTN,3,OPS,0)),"^") I X S CPT(CNT)=$P($$CPT^ICPTCOD(X),"^",2) D MOD
-        S SRCC=$P($G(^SRF(SRTN,"CON")),"^"),SRBLANK="          "
-        I SRCC,$P($G(^SRF(SRCC,30)),"^")!($P($G(^SRF(SRCC,31)),"^",8)) S SRCC=""
-        S SRTEMP=SRTEMP_$J(CPT(1),5)_$J(CPT(2),5)_$J(CPT(3),5)_$J(CPT(4),5)_$J(CPT(5),5)_$J(CPT(6),5)_$J(CPT(7),5)_$J(CPT(8),5)_$J(CPT(9),5)_$J(CPT(10),5)_$J(SRWOUND,2)_$J(SROCTYPE,1)_SRBLANK_$J(SRCC,10)_$J(SRDEATH,12)
-        S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP,SRACNT=SRACNT+1
-        S SRICD=$P($G(^SRO(136,SRTN,0)),"^",3) S:SRICD SRICD=$P(^ICD9(SRICD,0),"^")
-        S SRA(.2)=$G(^SRF(SRTN,.2))
-        S SRTEMP="/"_$J(SRASITE,3)_$J(SRTN,7)_"  B"_$J($E($P(SRA(.2),"^"),1,12),12)_$J($E($P(SRA(.2),"^",4),1,12),12)_$E(SRPMOD_SR10SP,1,10)
-        F I=1:1:10 S SRTEMP=SRTEMP_$E(SRMOD(I)_SR10SP,1,10)
-        S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP_$J(SRINTUB,1)_SR95PO_$J(SRATT,2)_$J(SRDOB,7)_$J(SRICD,6)_$J(SROC(38),2),SRACNT=SRACNT+1
-        I SRACNT>100 S SRACNT=1,SRAMNUM=SRAMNUM+1
-        S SRATOT=SRATOT+1
-        S X=$E($P(^SRF(SRTN,0),"^",9),1,5)_"00",^TMP("SRWL",$J,X)=""
-        K DATE,ANES,EMERG,EXC,SPEC,SRADMIT,SRADMT,SRATT,SRBLANK,SRCC,SRDIV,SRDOB,SRDTHUR,SRICD,SRIO,SRMAJMIN,SROCTYPE,SRTEMP,SRTMP,SRWOUND,SRZ,SR14,CPT
-        Q
-OCC     ; total of each occurrence by category
-        N SRIOFLAG,SRPOFLAG
-        F SRK=1:1:38 S SROC(SRK)=""
-        S (SRPO,SRIOFLAG)=0 F  S SRPO=$O(^SRF(SRTN,10,SRPO)) Q:'SRPO  S SRSUB=$P(^SRF(SRTN,10,SRPO,0),U,2) I SRSUB'="" D
-        .S SROC(SRSUB)=SROC(SRSUB)+1,SRIOFLAG=1
-        S (SRPO,SRPOFLAG)=0 F  S SRPO=$O(^SRF(SRTN,16,SRPO)) Q:'SRPO  S SRSUB=$P(^SRF(SRTN,16,SRPO,0),U,2) I SRSUB'="" D
-        .S SROC(SRSUB)=SROC(SRSUB)+1,SRPOFLAG=1
-        S (SROCTYPE,SRTMP)="" F SRK=1:1:10 S SRTMP=SRTMP_$J(SROC(SRK),2)
-        S SRTMP=SRTMP_$J(SROC(37),2) F SRK=12:1:32 S SRTMP=SRTMP_$J(SROC(SRK),2)
-        S SR95PO=$J(SROC(33),2)_$J(SROC(34),2)_$J(SROC(35),2)_$J(SROC(36),2)
-        I SRIOFLAG=1,(SRPOFLAG=0) S SROCTYPE="I"
-        I SRIOFLAG=0,(SRPOFLAG=1) S SROCTYPE="P"
-        I SRIOFLAG=1,(SRPOFLAG=1) S SROCTYPE="B"
-        I SRIOFLAG=0,(SRPOFLAG=0) S SROCTYPE=""
-        Q
-MOD     N SRM S SRM=0,SRCNT=1 F  S SRM=$O(^SRO(136,SRTN,3,OPS,1,SRM)) Q:'SRM  D  Q:SRCNT>5
-        .S X=$P(^SRO(136,SRTN,3,OPS,1,SRM,0),"^"),Y=$P($$MOD^ICPTMOD(X,"I"),"^",2)
-        .I Y'="" S SRMOD(CNT)=SRMOD(CNT)_Y,SRCNT=SRCNT+1
-        Q
+SROATMNO ;BIR/MAM - TRANSMIT NO ASSESSMENT ;05/10/07
+ ;;3.0; Surgery ;**27,38,47,62,68,79,83,81,88,93,95,97,129,125,142,153,160**;24 Jun 93;Build 7
+ ;** NOTICE: This routine is part of an implementation of a nationally
+ ;**         controlled procedure. Local modifications to this routine
+ ;**         are prohibited.
+ ;
+ ; Reference to ^DIC(45.3 supported by DBIA #218
+ ;
+ N SR10SP,SRINTUB,SR95PO,SRLO,SRPID,TDATE K ^TMP("SRA",$J) S SRATOT=0,SRASITE=+$P($$SITE^SROVAR,"^",3),(SRAMNUM,SRACNT)=1
+ S Z=$E(DT,1,3)-1,SRLO=Z_"0214"
+ S TDATE=0 F  S TDATE=$O(^SRF("AQ",TDATE)) Q:TDATE=""  I DT'<TDATE S SRTN=0 F  S SRTN=$O(^SRF("AQ",TDATE,SRTN)) Q:'SRTN  D SET
+ S SRATOTM=SRAMNUM D ^SROATM4
+ Q
+SET I $P($G(^SRF(SRTN,.4)),"^",2)="T"!(TDATE<SRLO) K ^SRF("AQ",TDATE,SRTN) Q
+ I $P($G(^SRF(SRTN,30)),"^")!$P($G(^SRF(SRTN,31)),"^",8)!'$P($G(^SRF(SRTN,.2)),"^",12)!($P($G(^SRF(SRTN,"NON")),"^")="Y") K ^SRF("AQ",TDATE,SRTN) S $P(^SRF(SRTN,.4),"^",2)="" Q
+ I $P($G(^SRF(SRTN,"RA")),"^",6)="Y",$P($G(^SRF(SRTN,"RA")),"^",2)="N" K ^SRF("AQ",TDATE,SRTN) Q
+ S SR10SP="          " K DA,DIE,DR S DA=SRTN,DIE=130,DR="905///R" D ^DIE K DR,DA,DIE
+ S SRA(0)=^SRF(SRTN,0),DATE=$E($P(SRA(0),"^",9),1,7),SPEC=$P(SRA(0),"^",4) S:SPEC SPEC=$P(^DIC(45.3,$P(^SRO(137.45,SPEC,0),"^",2),0),"^")
+ S EMERG=$P(SRA(0),"^",10),EMERG=$S(EMERG="EM":"Y",1:"N")
+ K SRTECH,SRZ S SRT=0 F  S SRT=$O(^SRF(SRTN,6,SRT)) Q:'SRT  D ^SROPRIN Q:$D(SRZ)
+ I $D(SRTECH) S SRINTUB=$P($G(^SRF(SRTN,6,SRT,8)),"^",2)
+ I '$D(SRTECH) S (SRTECH,SRINTUB)=""
+ S CPT=$P($G(^SRO(136,SRTN,0)),"^",2),SRPMOD="" I CPT S CPT=$P($$CPT^ICPTCOD(CPT),"^",2) D
+ .S SRM=0,SRCNT=1 F  S SRM=$O(^SRO(136,SRTN,1,SRM)) Q:'SRM  D  Q:SRCNT>5
+ ..S X=$P(^SRO(136,SRTN,1,SRM,0),"^") I X S Y=$P($$MOD^ICPTMOD(X,"I"),"^",2),SRPMOD=SRPMOD_Y,SRCNT=SRCNT+1
+ S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRDOB=$E($P(VADM(3),"^"),1,7),SRDEATH=$P(VADM(6),U)
+ S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID
+ S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
+ D RS^SROATM2
+ S SRMAJMIN=$E($P($G(^SRF(SRTN,0)),U,3),1)
+ S SRDTHUR=$E($P($G(^SRF(SRTN,.4)),U,7),1)
+ S SRSTATUS=$E($P($G(^SRF(SRTN,0)),U,12),1) I SRSTATUS'="I"&(SRSTATUS'="O") S VAIP("D")=$P(SRA(0),"^",9) D IN5^VADPT S SRSTATUS=$S(VAIP(13):"I",1:"O") K VAIP
+ S SRAGE="" I $P(VADM(3),"^") S SRAGE=$E(DATE,1,3)-$E($P(VADM(3),"^"),1,3)-($E(DATE,4,7)<$E($P(VADM(3),"^"),4,7))
+ S SRASA="",Y=$P($G(^SRF(SRTN,1.1)),"^",3) S:Y X=$P($P($G(^SRO(132.8,Y,0)),"^"),"-"),SRASA=$E(X,1,2)
+ ; Admission wi 14 days following outpatient surgery due to an Occurrence 
+ S (SRADMIT,SRADMT)=0 I SRSTATUS="O" D ADM^SROQ0A S SRADMIT=$S(SRADMT=0:"0",1:"1")
+ S EXC=$P($G(^SRF(SRTN,"RA")),"^",7),SRWOUND=$P($G(^SRF(SRTN,"1.0")),"^",8)
+ D OCC
+ S SRNODE="  X" S:$P($G(^SRF(SRTN,"RA")),U,6)="N" SRNODE="  *" S:$P($G(^SRF(SRTN,"RA")),U,2)="C" SRNODE="  C"
+ S SRTEMP="/"_$J(SRASITE,3)_$J(SRTN,7)_SRNODE_DATE_$J(SRTECH,3)_$J(EMERG,1)_$J(SPEC,3)_$J(CPT,5)_$J(EXC,1)_$J(SRPID,20)_$J(SRDIV,6)_" "
+ S SRTEMP=SRTEMP_$J(SRMAJMIN,1)_$J($E(SRDEATH,1,7),7)_$J(SRDTHUR,1)_$J(SRSTATUS,1)_$J(SRAGE,3)_$J(SRASA,2)_$J(SRADMIT,1)_SRTMP
+ K CPT,SRMOD F SRZ=1:1:10 S (CPT(SRZ),SRMOD(SRZ))=""
+ S (OPS,CNT)=0 F  S OPS=$O(^SRO(136,SRTN,3,OPS)) Q:'OPS!(CNT=10)  S CNT=CNT+1,X=$P($G(^SRO(136,SRTN,3,OPS,0)),"^") I X S CPT(CNT)=$P($$CPT^ICPTCOD(X),"^",2) D MOD
+ S SRCC=$P($G(^SRF(SRTN,"CON")),"^"),SRBLANK="          "
+ I SRCC,$P($G(^SRF(SRCC,30)),"^")!($P($G(^SRF(SRCC,31)),"^",8)) S SRCC=""
+ S SRTEMP=SRTEMP_$J(CPT(1),5)_$J(CPT(2),5)_$J(CPT(3),5)_$J(CPT(4),5)_$J(CPT(5),5)_$J(CPT(6),5)_$J(CPT(7),5)_$J(CPT(8),5)_$J(CPT(9),5)_$J(CPT(10),5)_$J(SRWOUND,2)_$J(SROCTYPE,1)_SRBLANK_$J(SRCC,10)_$J(SRDEATH,12)
+ S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP,SRACNT=SRACNT+1
+ S SRICD=$P($G(^SRO(136,SRTN,0)),"^",3) S:SRICD SRICD=$P(^ICD9(SRICD,0),"^")
+ S SRA(.2)=$G(^SRF(SRTN,.2))
+ S SRTEMP="/"_$J(SRASITE,3)_$J(SRTN,7)_"  B"_$J($E($P(SRA(.2),"^"),1,12),12)_$J($E($P(SRA(.2),"^",4),1,12),12)_$E(SRPMOD_SR10SP,1,10)
+ F I=1:1:10 S SRTEMP=SRTEMP_$E(SRMOD(I)_SR10SP,1,10)
+ S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP_$J(SRINTUB,1)_SR95PO_$J(SRATT,2)_$J(SRDOB,7)_$J(SRICD,6)_$J(SROC(38),2),SRACNT=SRACNT+1
+ I SRACNT>100 S SRACNT=1,SRAMNUM=SRAMNUM+1
+ S SRATOT=SRATOT+1
+ S X=$E($P(^SRF(SRTN,0),"^",9),1,5)_"00",^TMP("SRWL",$J,X)=""
+ K DATE,ANES,EMERG,EXC,SPEC,SRADMIT,SRADMT,SRATT,SRBLANK,SRCC,SRDIV,SRDOB,SRDTHUR,SRICD,SRIO,SRMAJMIN,SROCTYPE,SRTEMP,SRTMP,SRWOUND,SRZ,SR14,CPT
+ Q
+OCC ; total of each occurrence by category
+ N SRIOFLAG,SRPOFLAG
+ F SRK=1:1:38 S SROC(SRK)=""
+ S (SRPO,SRIOFLAG)=0 F  S SRPO=$O(^SRF(SRTN,10,SRPO)) Q:'SRPO  S SRSUB=$P(^SRF(SRTN,10,SRPO,0),U,2) I SRSUB'="" D
+ .S SROC(SRSUB)=SROC(SRSUB)+1,SRIOFLAG=1
+ S (SRPO,SRPOFLAG)=0 F  S SRPO=$O(^SRF(SRTN,16,SRPO)) Q:'SRPO  S SRSUB=$P(^SRF(SRTN,16,SRPO,0),U,2) I SRSUB'="" D
+ .S SROC(SRSUB)=SROC(SRSUB)+1,SRPOFLAG=1
+ S (SROCTYPE,SRTMP)="" F SRK=1:1:10 S SRTMP=SRTMP_$J(SROC(SRK),2)
+ S SRTMP=SRTMP_$J(SROC(37),2) F SRK=12:1:32 S SRTMP=SRTMP_$J(SROC(SRK),2)
+ S SR95PO=$J(SROC(33),2)_$J(SROC(34),2)_$J(SROC(35),2)_$J(SROC(36),2)
+ I SRIOFLAG=1,(SRPOFLAG=0) S SROCTYPE="I"
+ I SRIOFLAG=0,(SRPOFLAG=1) S SROCTYPE="P"
+ I SRIOFLAG=1,(SRPOFLAG=1) S SROCTYPE="B"
+ I SRIOFLAG=0,(SRPOFLAG=0) S SROCTYPE=""
+ Q
+MOD N SRM S SRM=0,SRCNT=1 F  S SRM=$O(^SRO(136,SRTN,3,OPS,1,SRM)) Q:'SRM  D  Q:SRCNT>5
+ .S X=$P(^SRO(136,SRTN,3,OPS,1,SRM,0),"^"),Y=$P($$MOD^ICPTMOD(X,"I"),"^",2)
+ .I Y'="" S SRMOD(CNT)=SRMOD(CNT)_Y,SRCNT=SRCNT+1
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAUTL.m

@@ -1 @@
-SROAUTL ;BIR/ADM - RISK ASSESSMENT UTILITY ;03/03/08
-        ;;3.0; Surgery ;**38,46,47,63,81,88,95,112,100,125,134,142,153,160,166**;24 Jun 93;Build 7
-        I $G(SRSUPCPT)=2 G NCODE
-        N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_")      Case #"_SRTN
-        S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y
-        S X=^SRF(SRTN,"OP"),SROPER=$P(X,"^"),Y=$P(X,"^",2),SRCPT=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"CPT MISSING") I SRCPT,$O(^SRF(SRTN,"OPMOD",0)) D
-        .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=SRCPT_"-" F  S SRI=$O(^SRF(SRTN,"OPMOD",SRI)) Q:'SRI  D
-        ..S SRM=$P(^SRF(SRTN,"OPMOD",SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)
-        ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1
-        S SRCPT=$S($G(SRSUPCPT)=1:"",1:"("_SRCPT_")")
-        S SROPER=SROPER_" "_SRCPT D LOOP S SRHDR(1)=SRSDATE_"   "_SRHDR(1)
-        Q
-NCODE   N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_")        Case #"_SRTN
-        S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y
-        S X=^SRF(SRTN,"OP"),SROPER=$P(X,"^"),Y=$P($G(^SRO(136,SRTN,0)),"^",2),SRCPT=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"CPT MISSING") I SRCPT,$O(^SRO(136,SRTN,1,0)) D
-        .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=SRCPT_"-" F  S SRI=$O(^SRO(136,SRTN,1,SRI)) Q:'SRI  D
-        ..S SRM=$P(^SRO(136,SRTN,1,SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)
-        ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1
-        S SRCPT="(CPT Code: "_SRCPT_")"
-        S SROPER=SROPER_" "_SRCPT D LOOP S SRHDR(1)=SRSDATE_"   "_SRHDR(1)
-        Q
-LOOP    I $L(SROPER)<68 S SRHDR(1)=SROPER Q
-        I $L(SROPER)>67 S X=SROPER,K=1 F  D  I $L(X)<68 S SRHDR(K)=X Q
-        .F I=0:1:66 S J=67-I,Y=$E(X,J) I Y=" " S SRHDR(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q
-        Q
-HDR     ; print screen header
-        W @IOF,!,SRHDR W:$G(SRPAGE)'="" ?(79-$L(SRPAGE)),SRPAGE
-        S I=0 F  S I=$O(SRHDR(I)) Q:'I  W !,SRHDR(I) I I=.5,$L($G(SRCSTAT)) W ?(79-$L(SRCSTAT)),SRCSTAT
-        W:$D(SRCSTAT)&'$D(SRHDR(.5)) !,SRCSTAT
-        K SRHDR(.5),SRCSTAT,SRPAGE W ! F I=1:1:80 W "-"
-        W !
-        Q
-FUNCT() ; called by screen on functional health status field (#240)
-        N SRSCR S SRSCR="I 1"
-        I $$CARD S SRSCR="I Y'=4"
-        Q SRSCR
-CARD()  ; is this a cardiac assessed case?
-        N SRX S SRX=$S($D(SRTN):SRTN,$D(DA):DA,1:"") I 'SRX Q 0
-        I $P($G(^SRF(SRX,"RA")),"^",2)="C" Q 1
-        Q 0
-NC      ; called from input transform to kill X if case is cardiac assessed
-        I $$CARD,X="NA"!(X="NS") K X
-        Q
-DATE    ; called by output transform on several date fields
-        I $D(Y),Y="NA"!(Y="NS") Q
-        N SRY S SRY=Y D DD^%DT
-        Q
-INDX    ; set airway index
-        S SRY=$S(SRI>4:5,SRI>3:4,SRI>2:3,SRI>0:2,1:1),$P(^SRF(DA,.3),"^",9)=SRY
-        K SRI,SRMS,SROP,SRY
-        Q
-OP      ; set logic for AOP cross reference on Oral-Pharyngeal field (901.1)
-        N SRI,SRMS,SRY S SRMS=$P(^SRF(DA,.3),"^",12) I SRMS'="" S SRMS=SRMS*.1,SRI=2.5*X-SRMS D INDX
-        Q
-MS      ; set logic for AMS cross reference on Mandibular Space field (901.2)
-        N SRI,SRY,SRMS,SROP S SROP=$P(^SRF(DA,.3),"^",11) I SROP'="" S SRMS=X*.1,SRI=2.5*SROP-SRMS D INDX
-        Q
-K901    ; kill logic for AOP and AMS cross references
-        S $P(^SRF(DA,.3),"^",9)=""
-        Q
-DUP     ; duplicate preop information from prior operation within 60 days
-        S SR200=$G(^SRF(SRTN,200)) S NOGO="" F I=1,9,13,18,30,37,44 S X=$P(SR200,"^",I) I X'="" S NOGO=1 K SR200 Q
-        S X=$P($G(^SRF(SRTN,200.1)),"^") I X'="" S NOGO=1
-        I NOGO K NOGO Q
-        K SRCASE S SR=^SRF(SRTN,0),DFN=$P(SR,"^"),(SRSDATE,X1)=$P(SR,"^",9),X2=-60 D C^%DTC S SRENDT=X,SRCASE=0 F  S SRCASE=$O(^SRF("B",DFN,SRCASE)) Q:'SRCASE  I SRCASE,SRCASE'=SRTN D
-        .S SRX=$P(^SRF(SRCASE,0),"^",9) I SRX>SRSDATE!(SRX<SRENDT) Q
-        .Q:$P($G(^SRF(SRCASE,"NON")),"^")="Y"!$P($G(^SRF(SRCASE,30)),"^")!$P($G(^SRF(SRCASE,31)),"^",8)!($P($G(^SRF(SRCASE,"CON")),"^")=SRTN)!'$P($G(^SRF(SRCASE,.2)),"^",12)
-        .S SRX=9999999-SRX,SRCASE(SRX,SRCASE)=""
-        K SRDT S (SRX,Y)=0 F  S SRX=$O(SRCASE(SRX)) Q:'SRX!$D(SRDT)  S SRCASE="" F  S SRCASE=$O(SRCASE(SRX,SRCASE)) Q:'SRCASE  S SR=$G(^SRF(SRCASE,"RA")) I $P(SR,"^",2)="N",$P(SR,"^",6)="Y" D  Q
-        .S Y=$P(^SRF(SRCASE,0),"^",9) X ^DD("DD") S SRDT=Y K DIR
-        .W !! S DIR("A",1)="This patient had a previous non-cardiac operation on "_SRDT_".",DIR("A",2)="",DIR("A",3)="Case #"_SRCASE_"  "_$P(^SRF(SRCASE,"OP"),"^")
-        .S DIR("A",4)="",DIR("A",5)="Do you want to duplicate the preoperative information from the earlier",DIR("A")="assessment in this assessment? "
-        .S DIR("B")="YES",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
-        .D:Y STUFF
-        Q
-STUFF   ; stuff preop information from previous case
-        I $$LOCK^SROUTL(SRCASE) D  D UNLOCK^SROUTL(SRCASE)
-        .K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRCASE,DIQ="SRY",DIQ(0)="I" D PREHD D EN^DIQ1 K DA,DIC,DIQ,DR
-        .S SRZ=0 F  S SRZ=$O(SRY(130,SRCASE,SRZ)) Q:'SRZ  S DIE=130,DA=SRTN,DR=SRZ_"////"_SRY(130,SRCASE,SRZ,"I") D ^DIE K DA,DIE,DR
-        Q
-CHK     ; check for missing non-cardiac assessment data items
-        N SRSEP K SRX
-        F SRC="PREOP","DEM" K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D @SRC D EN^DIQ1 D ^SROAUTL1
-        F SRC="LAB","REM" K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D @SRC D EN^DIQ1 D ^SROAUTL2
-OTH     K DA,DIC,DIQ,DR,SRY,SRZ D TECH^SROPRIN I SRTECH="NOT ENTERED" S SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique"
-        ;D RELATE^SROAUTL2
-OCC     D EN^SROCCAT S SRSDATE=$E($P(^SRF(SRTN,0),"^",9),1,7) K ^TMP("SROCC",$J),SRO
-        S SRPO=0 F  S SRPO=$O(^SRF(SRTN,10,SRPO)) Q:'SRPO  S ^TMP("SROCC",$J,$P(^SRF(SRTN,10,SRPO,0),"^",2),SRSDATE)=""
-        S SRPO=0 F  S SRPO=$O(^SRF(SRTN,16,SRPO)) Q:'SRPO  S SRDATE=$E($P(^SRF(SRTN,16,SRPO,0),"^",7),1,7) D
-        .S SRSEP=$P(^SRF(SRTN,16,SRPO,0),"^",4)
-        .I '$G(SRDATE) S SRDATE="NO DATE"
-        .S ^TMP("SROCC",$J,$P(^SRF(SRTN,16,SRPO,0),"^",2),SRDATE)=SRSEP
-        I '$D(^TMP("SROCC",$J)) D OCCEND Q
-        S SRPO=0 F  S SRPO=$O(^TMP("SROCC",$J,SRPO)) Q:'SRPO  S SRDATE="" F  S SRDATE=$O(^TMP("SROCC",$J,SRPO,SRDATE)) Q:SRDATE  S SRX("POSTOP OCCURRENCE DATE"_SRPO)="Date Noted on "_$P(^SRO(136.5,SRPO,0),"^")_" (Postop Occurrence)" Q
-        S SRDATE="",SRDATE=$O(^TMP("SROCC",$J,3,SRDATE)) Q:SRDATE=""  I ^TMP("SROCC",$J,3,SRDATE)="" S SRX("SEPSIS CATEGORY")="SEPSIS CATEGORY on SYSTEMIC SEPSIS (Postop Occurrence)"
-OCCEND  K ^TMP("SROCC",$J)
-        Q
-PREOP   S DR="236;237;346;202;246;325;238;492;204;203;326;212;213;396;394;220;266;395;208;329;330;328;211;332;333;400;334;335;336;401;338;218;339;215;216;217;338.1;338.2;218.1;269"
-        Q
-DEM     S DR="413;.011;247;418;419;420;421;452;453;454;342;513;516"
-        Q
-LAB     S DR="270;304;224;291;223;290;225;292;228;295;227;294;229;296;230;297;234;301;231;298;233;300;232;299;487;487.1;274;305;405;407;275;306;406;408;277;308;278;309;279;310;280;311;281;312;283;314;455;455.1;456;456.1;444;444.1;445;445.1"
-        Q
-REM     S DR="214;.035;1.09;1.13;.22;.23;340;443;446;504;504.1"
-        Q
-PREHD   D PREOP S DR=DR_";402;241;244;242;243;210;245"
-        Q
+SROAUTL ;BIR/ADM - RISK ASSESSMENT UTILITY ;02/14/07
+ ;;3.0; Surgery ;**38,46,47,63,81,88,95,112,100,125,134,142,153,160**;24 Jun 93;Build 7
+ I $G(SRSUPCPT)=2 G NCODE
+ N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_")      Case #"_SRTN
+ S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y
+ S X=^SRF(SRTN,"OP"),SROPER=$P(X,"^"),Y=$P(X,"^",2),SRCPT=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"CPT MISSING") I SRCPT,$O(^SRF(SRTN,"OPMOD",0)) D
+ .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=SRCPT_"-" F  S SRI=$O(^SRF(SRTN,"OPMOD",SRI)) Q:'SRI  D
+ ..S SRM=$P(^SRF(SRTN,"OPMOD",SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)
+ ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1
+ S SRCPT=$S($G(SRSUPCPT)=1:"",1:"("_SRCPT_")")
+ S SROPER=SROPER_" "_SRCPT D LOOP S SRHDR(1)=SRSDATE_"   "_SRHDR(1)
+ Q
+NCODE N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_")        Case #"_SRTN
+ S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y
+ S X=^SRF(SRTN,"OP"),SROPER=$P(X,"^"),Y=$P($G(^SRO(136,SRTN,0)),"^",2),SRCPT=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"CPT MISSING") I SRCPT,$O(^SRO(136,SRTN,1,0)) D
+ .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=SRCPT_"-" F  S SRI=$O(^SRO(136,SRTN,1,SRI)) Q:'SRI  D
+ ..S SRM=$P(^SRO(136,SRTN,1,SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)
+ ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1
+ S SRCPT="(CPT Code: "_SRCPT_")"
+ S SROPER=SROPER_" "_SRCPT D LOOP S SRHDR(1)=SRSDATE_"   "_SRHDR(1)
+ Q
+LOOP I $L(SROPER)<68 S SRHDR(1)=SROPER Q
+ I $L(SROPER)>67 S X=SROPER,K=1 F  D  I $L(X)<68 S SRHDR(K)=X Q
+ .F I=0:1:66 S J=67-I,Y=$E(X,J) I Y=" " S SRHDR(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q
+ Q
+HDR ; print screen header
+ W @IOF,!,SRHDR W:$G(SRPAGE)'="" ?(79-$L(SRPAGE)),SRPAGE
+ S I=0 F  S I=$O(SRHDR(I)) Q:'I  W !,SRHDR(I) I I=.5,$L($G(SRCSTAT)) W ?(79-$L(SRCSTAT)),SRCSTAT
+ W:$D(SRCSTAT)&'$D(SRHDR(.5)) !,SRCSTAT
+ K SRHDR(.5),SRCSTAT,SRPAGE W ! F I=1:1:80 W "-"
+ W !
+ Q
+FUNCT() ; called by screen on functional health status field (#240)
+ N SRSCR S SRSCR="I 1"
+ I $$CARD S SRSCR="I Y'=4"
+ Q SRSCR
+CARD() ; is this a cardiac assessed case?
+ N SRX S SRX=$S($D(SRTN):SRTN,$D(DA):DA,1:"") I 'SRX Q 0
+ I $P($G(^SRF(SRX,"RA")),"^",2)="C" Q 1
+ Q 0
+NC ; called from input transform to kill X if case is cardiac assessed
+ I $$CARD,X="NA"!(X="NS") K X
+ Q
+DATE ; called by output transmform on several date fields
+ I $D(Y),Y="NA"!(Y="NS") Q
+ N SRY S SRY=Y D DD^%DT
+ Q
+INDX ; set airway index
+ S SRY=$S(SRI>4:5,SRI>3:4,SRI>2:3,SRI>0:2,1:1),$P(^SRF(DA,.3),"^",9)=SRY
+ K SRI,SRMS,SROP,SRY
+ Q
+OP ; set logic for AOP cross reference on Oral-Pharyngeal field (901.1)
+ N SRI,SRMS,SRY S SRMS=$P(^SRF(DA,.3),"^",12) I SRMS'="" S SRMS=SRMS*.1,SRI=2.5*X-SRMS D INDX
+ Q
+MS ; set logic for AMS cross reference on Mandibular Space field (901.2)
+ N SRI,SRY,SRMS,SROP S SROP=$P(^SRF(DA,.3),"^",11) I SROP'="" S SRMS=X*.1,SRI=2.5*SROP-SRMS D INDX
+ Q
+K901 ; kill logic for AOP and AMS cross references
+ S $P(^SRF(DA,.3),"^",9)=""
+ Q
+DUP ; duplicate preop information from prior operation within 60 days
+ S SR200=$G(^SRF(SRTN,200)) S NOGO="" F I=1,9,13,18,30,37,44 S X=$P(SR200,"^",I) I X'="" S NOGO=1 K SR200 Q
+ S X=$P($G(^SRF(SRTN,200.1)),"^") I X'="" S NOGO=1
+ I NOGO K NOGO Q
+ K SRCASE S SR=^SRF(SRTN,0),DFN=$P(SR,"^"),(SRSDATE,X1)=$P(SR,"^",9),X2=-60 D C^%DTC S SRENDT=X,SRCASE=0 F  S SRCASE=$O(^SRF("B",DFN,SRCASE)) Q:'SRCASE  I SRCASE,SRCASE'=SRTN D
+ .S SRX=$P(^SRF(SRCASE,0),"^",9) I SRX>SRSDATE!(SRX<SRENDT) Q
+ .Q:$P($G(^SRF(SRCASE,"NON")),"^")="Y"!$P($G(^SRF(SRCASE,30)),"^")!$P($G(^SRF(SRCASE,31)),"^",8)!($P($G(^SRF(SRCASE,"CON")),"^")=SRTN)!'$P($G(^SRF(SRCASE,.2)),"^",12)
+ .S SRX=9999999-SRX,SRCASE(SRX,SRCASE)=""
+ K SRDT S (SRX,Y)=0 F  S SRX=$O(SRCASE(SRX)) Q:'SRX!$D(SRDT)  S SRCASE="" F  S SRCASE=$O(SRCASE(SRX,SRCASE)) Q:'SRCASE  S SR=$G(^SRF(SRCASE,"RA")) I $P(SR,"^",2)="N",$P(SR,"^",6)="Y" D  Q
+ .S Y=$P(^SRF(SRCASE,0),"^",9) X ^DD("DD") S SRDT=Y K DIR
+ .W !! S DIR("A",1)="This patient had a previous non-cardiac operation on "_SRDT_".",DIR("A",2)="",DIR("A",3)="Case #"_SRCASE_"  "_$P(^SRF(SRCASE,"OP"),"^")
+ .S DIR("A",4)="",DIR("A",5)="Do you want to duplicate the preoperative information from the earlier",DIR("A")="assessment in this assessment? "
+ .S DIR("B")="YES",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
+ .D:Y STUFF
+ Q
+STUFF ; stuff preop information from previous case
+ I $$LOCK^SROUTL(SRCASE) D  D UNLOCK^SROUTL(SRCASE)
+ .K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRCASE,DIQ="SRY",DIQ(0)="I" D PREHD D EN^DIQ1 K DA,DIC,DIQ,DR
+ .S SRZ=0 F  S SRZ=$O(SRY(130,SRCASE,SRZ)) Q:'SRZ  S DIE=130,DA=SRTN,DR=SRZ_"////"_SRY(130,SRCASE,SRZ,"I") D ^DIE K DA,DIE,DR
+ Q
+CHK ; check for missing non-cardiac assessment data items
+ N SRSEP K SRX
+ F SRC="PREOP","DEM" K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D @SRC D EN^DIQ1 D ^SROAUTL1
+ F SRC="LAB","REM" K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D @SRC D EN^DIQ1 D ^SROAUTL2
+OTH K DA,DIC,DIQ,DR,SRY,SRZ D TECH^SROPRIN I SRTECH="NOT ENTERED" S SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique"
+ ;D RELATE^SROAUTL2
+OCC D EN^SROCCAT S SRSDATE=$E($P(^SRF(SRTN,0),"^",9),1,7) K ^TMP("SROCC",$J),SRO
+ S SRPO=0 F  S SRPO=$O(^SRF(SRTN,10,SRPO)) Q:'SRPO  S ^TMP("SROCC",$J,$P(^SRF(SRTN,10,SRPO,0),"^",2),SRSDATE)=""
+ S SRPO=0 F  S SRPO=$O(^SRF(SRTN,16,SRPO)) Q:'SRPO  S SRDATE=$E($P(^SRF(SRTN,16,SRPO,0),"^",7),1,7) D
+ .S SRSEP=$P(^SRF(SRTN,16,SRPO,0),"^",4)
+ .I '$G(SRDATE) S SRDATE="NO DATE"
+ .S ^TMP("SROCC",$J,$P(^SRF(SRTN,16,SRPO,0),"^",2),SRDATE)=SRSEP
+ I '$D(^TMP("SROCC",$J)) D OCCEND Q
+ S SRPO=0 F  S SRPO=$O(^TMP("SROCC",$J,SRPO)) Q:'SRPO  S SRDATE="" F  S SRDATE=$O(^TMP("SROCC",$J,SRPO,SRDATE)) Q:SRDATE  S SRX("POSTOP OCCURRENCE DATE"_SRPO)="Date Noted on "_$P(^SRO(136.5,SRPO,0),"^")_" (Postop Occurrence)" Q
+ S SRDATE="",SRDATE=$O(^TMP("SROCC",$J,3,SRDATE)) Q:SRDATE=""  I ^TMP("SROCC",$J,3,SRDATE)="" S SRX("SEPSIS CATEGORY")="SEPSIS CATEGORY on SYSTEMIC SEPSIS (Postop Occurrence)"
+OCCEND K ^TMP("SROCC",$J)
+ Q
+PREOP S DR="236;237;346;202;202.1;246;325;238;240;492;204;203;326;212;213;396;394;220;266;395;208;329;330;328;211;332;333;398;399;400;334;335;336;401;338;218;339;215;216;217;338.1;338.2;218.1;269"
+ Q
+DEM S DR="413;.011;247;418;419;420;421;452;453;454;342"
+ Q
+LAB S DR="270;304;224;291;223;290;225;292;228;295;227;294;229;296;230;297;234;301;231;298;233;300;232;299;487;487.1;274;305;405;407;275;306;406;408;277;308;278;309;279;310;280;311;281;312;283;314;455;455.1;456;456.1;444;444.1;445;445.1"
+ Q
+REM S DR="214;.035;1.09;1.13;.22;.23;340;443;446;504;504.1"
+ Q
+PREHD D PREOP S DR=DR_";402;241;244;242;243;210;245"
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAUTL1.m

@@ -1 @@
-SROAUTL1        ;BIR/ADM - RISK ASSESSMENT UTILITY ;12/10/07
-        ;;3.0; Surgery ;**38,47,81,125,153,160,166**;24 Jun 93;Build 7
-        S SRZ=0 F  S SRZ=$O(SRY(130,SRTN,SRZ)) Q:'SRZ  I SRY(130,SRTN,SRZ,"I")="" D TR S X=$T(@SRP),SRFLD=$P(X,";;",2),SRX(SRZ)=$P(SRFLD,"^",2)
-        Q
-TR      S SRP=SRZ,SRP=$TR(SRP,"1234567890.","ABCDEFGHIJP")
-        Q
-GET     S X=$T(@J)
-        Q
-BJH     ;;208^History of Hypertension Requiring Medication (Y/N)^Hypertension Requiring Meds^
-BAC     ;;213^Esophageal Varices (Y/N)^Esophogeal Varices^
-BBJ     ;;220^Previous PCI (Y/N)^Previous PCI^
-BFF     ;;266^Previous Cardiac Surgery (Y/N)^Previous Cardiac Surgery^
-CBI     ;;329^History of Revascularization/Amputation for PVD (Y/N)^Revascularization/Amputation^
-CCJ     ;;330^Rest Pain/Gangrene (Y/N)^Rest Pain/Gangrene^
-CID     ;;394^History of MI Within Past 6 Months (Y/N)^MI Within 6 Months^
-CIE     ;;395^Angina within One Month Preceding Surgery (Y/N)^Angina Within 1 Month^
-BCF     ;;236^Patient's Height^Height^
-BCG     ;;237^Patient's Weight^Weight^
-CDF     ;;346^Diabetes^Diabetes Mellitus^
-BJB     ;;202^Current Smoker within 1 Year prior to Surgery (Y/N)^Current SmokerW/I 1 Year^
-BDF     ;;246^ETOH Greater than 2 Drinks/Day (Y/N)^ETOH > 2 Drinks/Day^
-CBE     ;;325^Dyspnea^Dyspnea^
-BCH     ;;238^DNR Status (Y/N)^DNR Status^
-DIB     ;;492^Functional Health Status at Evaluation for Surgery^Preop Functional Status
-BJD     ;;204^Ventilator Dependent Greater than 48 Hrs (Y/N)^Ventilator Dependent^
-BJC     ;;203^History of COPD (Y/N)^History of Severe COPD^
-CBF     ;;326^Current Pneumonia (Y/N)^Current Pneumonia^
-BAB     ;;212^Ascites (Y/N)^Ascites^
-CIF     ;;396^CHF within One Month Preceding Surgery (Y/N)^CHF Within 1 Month^
-CBH     ;;328^Acute Renal Failure (Y/N)^Acute Renal Failure^
-BAA     ;;211^Currently on Dialysis (Y/N)^Currently on Dialysis^
-CCB     ;;332^Impaired Sensorium (Y/N)^Impaired Sensorium^
-CCC     ;;333^Coma (Y/N)^Coma^
-DJJ     ;;400^Hemiplegia (Y/N)^Hemiplegia^
-CCD     ;;334^History of TIAs (Y/N)^History of TIAs^
-CCE     ;;335^CVA/Residual Neurologic Deficit (Y/N)^CVA/Residual Neuro Deficit^
-CCF     ;;336^CVA/No Neurologic Deficit (Y/N)^CVA/No Neuro Deficit^
-DJA     ;;401^Tumor Involving CNS (Y/N)^Tumor Involving CNS^
-CCH     ;;338^Disseminated Cancer (Y/N)^Disseminated Cancer^
-BAH     ;;218^Open Wound or Skin Infection (Y/N)^Open Wound or Infection^
-CCI     ;;339^Steroid Use for Chronic Condition (Y/N)^Steroid Use for Chronic Cond.^
-BAE     ;;215^Weight Loss > 10% of Usual Body Weight (Y/N)^Weight Loss > 10%^
-BAF     ;;216^History of Bleeding Disorders (Y/N)^Bleeding Disorders^
-BAG     ;;217^Transfusion Greater than 4 RBC Units this Admission (Y/N)^Transfusion > 4 RBC Units^
-CCHPA   ;;338.1^Chemotherapy Within Last 30 Days (Y/N)^Chemotherapy W/I 30 Days^
-CCHPB   ;;338.2^Radiotherapy Within Last 90 Days (Y/N)^Radiotherapy W/I 90 Days^
-BAHPA   ;;218.1^Preoperative Sepsis (Y/N)^Preoperative Sepsis^
-BFI     ;;269^Pregnancy Status^Pregnancy Status^
-DAC     ;;413^Transfer Status^Transfer Status^
-PJAA    ;;.011^In/Out-Patient Status
-BDG     ;;247^Length of Postoperative Hospital Stay
-CDB     ;;342^Date/Time of Death^Date/Time of Death
-DAG     ;;417^Patient's Race
-DAH     ;;418^Hospital Admission Date
-DAI     ;;419^Hospital Discharge Date
-DBJ     ;;420^Admitted/Transferred to Surgical Service
-DBA     ;;421^Discharged/Transferred to Chronic Care
-DEB     ;;452^Observation Admission Date/Time
-DEC     ;;453^Observation Discharge Date/Time
-DED     ;;454^Observation Treating Specialty
-EAC     ;;513^Surgery Consult Date
-EAF     ;;516^Date Surgery Consult Requested
+SROAUTL1 ;BIR/ADM - RISK ASSESSMENT UTILITY ;04/24/07
+ ;;3.0; Surgery ;**38,47,81,125,153,160**;24 Jun 93;Build 7
+ S SRZ=0 F  S SRZ=$O(SRY(130,SRTN,SRZ)) Q:'SRZ  I SRY(130,SRTN,SRZ,"I")="" D TR S X=$T(@SRP),SRFLD=$P(X,";;",2),SRX(SRZ)=$P(SRFLD,"^",2)
+ Q
+TR S SRP=SRZ,SRP=$TR(SRP,"1234567890.","ABCDEFGHIJP")
+ Q
+GET S X=$T(@J)
+ Q
+BJH ;;208^History of Hypertension Requiring Medication (Y/N)^Hypertension Requiring Meds^
+BAC ;;213^Esophageal Varices (Y/N)^Esophogeal Varices^
+BBJ ;;220^Previous PCI (Y/N)^Previous PCI^
+BFF ;;266^Previous Cardiac Surgery (Y/N)^Previous Cardiac Surgery^
+CBI ;;329^History of Revascularization/Amputation for PVD (Y/N)^Revascularization/Amputation^
+CCJ ;;330^Rest Pain/Gangrene (Y/N)^Rest Pain/Gangrene^
+CID ;;394^History of MI Within Past 6 Months (Y/N)^MI Within 6 Months^
+CIE ;;395^Angina within One Month Preceding Surgery (Y/N)^Angina Within 1 Month^
+CIH ;;398^Quadriplegia/Tetraplegia/Quadriparesis (Y/N)^Quadriplegia^
+CII ;;399^Paraplegia (Y/N)^Paraplegia^
+BCF ;;236^Patient's Height^Height^
+BCG ;;237^Patient's Weight^Weight^
+CDF ;;346^Diabetes^Diabetes Mellitus^
+BJB ;;202^Current Smoker within 1 Year prior to Surgery (Y/N)^Current SmokerW/I 1 Year^
+BJBPA ;;202.1^Pack/Years^Pack/Years^
+BDF ;;246^ETOH Greater than 2 Drinks/Day (Y/N)^ETOH > 2 Drinks/Day^
+CBE ;;325^Dyspnea^Dyspnea^
+BCH ;;238^DNR Status (Y/N)^DNR Status^
+BDJ ;;240^Functional Health Status Prior to Current Illness^Pre-Illness Functional Status^
+DIB ;;492^Functional Health Status at Evaluation for Surgery^Preop Functional Status
+BJD ;;204^Ventilator Dependent Greater than 48 Hrs (Y/N)^Ventilator Dependent^
+BJC ;;203^History of COPD (Y/N)^History of Severe COPD^
+CBF ;;326^Current Pneumonia (Y/N)^Current Pneumonia^
+BAB ;;212^Ascites (Y/N)^Ascites^
+CIF ;;396^CHF within One Month Preceding Surgery (Y/N)^CHF Within 1 Month^
+CBH ;;328^Acute Renal Failure (Y/N)^Acute Renal Failure^
+BAA ;;211^Currently on Dialysis (Y/N)^Currently on Dialysis^
+CCB ;;332^Impaired Sensorium (Y/N)^Impaired Sensorium^
+CCC ;;333^Coma (Y/N)^Coma^
+DJJ ;;400^Hemiplegia (Y/N)^Hemiplegia^
+CCD ;;334^History of TIAs (Y/N)^History of TIAs^
+CCE ;;335^CVA/Residual Neurologic Deficit (Y/N)^CVA/Residual Neuro Deficit^
+CCF ;;336^CVA/No Neurologic Deficit (Y/N)^CVA/No Neuro Deficit^
+DJA ;;401^Tumor Involving CNS (Y/N)^Tumor Involving CNS^
+CCH ;;338^Disseminated Cancer (Y/N)^Disseminated Cancer^
+BAH ;;218^Open Wound or Skin Infection (Y/N)^Open Wound or Infection^
+CCI ;;339^Steroid Use for Chronic Condition (Y/N)^Steroid Use for Chronic Cond.^
+BAE ;;215^Weight Loss > 10% of Usual Body Weight (Y/N)^Weight Loss > 10%^
+BAF ;;216^History of Bleeding Disorders (Y/N)^Bleeding Disorders^
+BAG ;;217^Transfusion Greater than 4 RBC Units this Admission (Y/N)^Transfusion > 4 RBC Units^
+CCHPA ;;338.1^Chemotherapy Within Last 30 Days (Y/N)^Chemotherapy W/I 30 Days^
+CCHPB ;;338.2^Radiotherapy Within Last 90 Days (Y/N)^Radiotherapy W/I 90 Days^
+BAHPA ;;218.1^Preoperative Sepsis (Y/N)^Preoperative Sepsis^
+BFI ;;269^Pregnancy Status^Pregnancy Status^
+DAC ;;413^Transfer Status^Transfer Status^
+PJAA ;;.011^In/Out-Patient Status
+BDG ;;247^Length of Postoperative Hospital Stay
+CDB ;;342^Date/Time of Death^Date/Time of Death
+DAG ;;417^Patient's Race
+DAH ;;418^Hospital Admission Date
+DAI ;;419^Hospital Discharge Date
+DBJ ;;420^Admitted/Transferred to Surgical Service
+DBA ;;421^Discharged/Transferred to Chronic Care
+DEB ;;452^Observation Admission Date/Time
+DEC ;;453^Observation Discharge Date/Time
+DED ;;454^Observation Treating Specialty

WorldVistAEHR/trunk/r/SURGERY-SR/SROAUTL3.m

@@ -1 @@
-SROAUTL3        ;BIR/ADM - RISK ASSESSMENT UTILITY ;01/07/08
-        ;;3.0; Surgery ;**38,47,63,77,142,163,166**;24 Jun 93;Build 7
-        ;
-        ; Reference to ^DIC(45.3 supported by DBIA #218
-        ;
-        Q
-RISK    ; allow entry of risk assessment preop information with case request
-        S Y=$P(^SRO(133,SRSITE,0),"^",14) I 'Y Q
-        W ! K DIR S DIR("A")="Enter risk assessment preop information for this patient (Y/N)",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
-        S SREQST=1,SRCARD=0 I $$CARD^SROAUTLC S SRSP=$P(^DIC(45.3,$P(^SRO(137.45,$P(^SRF(SRTN,0),"^",4),0),"^",2),0),"^") I SRSP=48!(SRSP=58) D  I SRCARD Q
-        .S SRCARD=1 W ! K DIR S DIR("A")="Will this procedure require cardiopulmonary bypass (Y/N) ? ",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) Q
-        .I 'Y S SRCARD=0 Q
-        .D CARD S SRCARD=1
-        I 'SRCARD D ^SROAPRE
-        Q
-CARD    ; allow input of cardiac risk assessment preop information
-        N SRSDATE,SRNM,SRSOUT
-        W @IOF,!,"Enter Cardiac Preoperative information",!!,"  1. Clinical Information",!,"  2. Cardiac Catheterization & Angiographic Data",!,"  3. Operative Risk Summary Data",!
-        K DIR S DIR(0)="NO^1:3:0",DIR("?")="Enter the number of the selection to be edited." D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
-        I Y=1 D ^SROACLN G CARD
-        I Y=2 D ^SROACAT G CARD
-        D ^SROACOP G CARD
-        Q
-PREOP   ; print preop information (managerial)
-        W:$E(IOST)="P" !! D PREOP^SROAUTL0 S SRDR=DR W !,?28,"PREOPERATIVE INFORMATION",! S SRQ=1 D OUT
-        Q
-OUT     K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
-        K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I  D
-        .Q:I=413  D TR D:SRQ GET^SROAUTL1 D:'SRQ GET^SROAUTL2
-        .S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRX(SRX))=$S($P(Y,"^",3)'="":$P(Y,"^",3),1:$P(Y,"^",2))_"^"_SRFLD
-        .W !,$J($P(Z,"^")_": ",39) S SREXT=SRY(130,SRTN,SRFLD,"E") D EXT
-        Q
-EXT     I SRFLD=27 S SREXT=$S(SREXT="":"MISSING",1:$E(SREXT,1,5))
-        I $L(SREXT)<40 W SREXT Q
-        N I,J,X,Y S X=SREXT F  D  W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q
-        .F I=0:1:38 S J=39-I,Y=$E(X,J) I Y=" " W ?40,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q
-        Q
-LAB     ; print preoperative laboratory test information (managerial)
-        W !,?20,"PREOPERATIVE LABORATORY TEST INFORMATION",!
-        D LR^SROAUTL0 S SRDR=DR K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
-        K SRX S SRX=0 F M=1:2 S L=$P(SRDR,";",M) Q:'L  S I=L D
-        .D TR D GET^SROAUTL2 S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),SRDT=$P(Y,"^",4),(Z,SRX(SRX))=$S($P(Y,"^",3)'="":$P(Y,"^",3),1:$P(Y,"^",2))_"^"_SRFLD_"^"_SRDT
-        .W !,$J($P(Z,"^")_": ",39),SRY(130,SRTN,SRFLD,"E") W:SRY(130,SRTN,SRDT,"E")'="" ?50,"("_$P(SRY(130,SRTN,SRDT,"E"),"@")_")"
-        Q
-TR      S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
-        Q
-NON     S DR=".03;102;.035"
-        Q
-CHK     ; check for missing information for excluded cases
-        K SRX,DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D NON D EN^DIQ1 D ^SROAUTL2
-        K DA,DIC,DIQ,DR,SRY,SRZ D TECH^SROPRIN I SRTECH="NOT ENTERED" S SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique"
-        Q
+SROAUTL3 ;BIR/ADM - RISK ASSESSMENT UTILITY ;08/16/07
+ ;;3.0; Surgery ;**38,47,63,77,142,163**;24 Jun 93;Build 2
+ ;
+ ; Reference to ^DIC(45.3 supported by DBIA #218
+ ;
+ Q
+RISK ; allow entry of risk assessment preop information with case request
+ S Y=$P(^SRO(133,SRSITE,0),"^",14) I 'Y Q
+ W ! K DIR S DIR("A")="Enter risk assessment preop information for this patient (Y/N)",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
+ S SREQST=1,SRCARD=0 I $$CARD^SROAUTLC S SRSP=$P(^DIC(45.3,$P(^SRO(137.45,$P(^SRF(SRTN,0),"^",4),0),"^",2),0),"^") I SRSP=48!(SRSP=58) D  I SRCARD Q
+ .S SRCARD=1 W ! K DIR S DIR("A")="Will this procedure require cardiopulmonary bypass (Y/N) ? ",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) Q
+ .I 'Y S SRCARD=0 Q
+ .D CARD S SRCARD=1
+ I 'SRCARD D ^SROAPRE
+ Q
+CARD ; allow input of cardiac risk assessment preop information
+ W @IOF,!,"Enter Cardiac Preoperative information",!!,"  1. Clinical Information",!,"  2. Cardiac Catheterization & Angiographic Data",!,"  3. Operative Risk Summary Data",!
+ K DIR S DIR(0)="NO^1:3:0",DIR("?")="Enter the number of the selection to be edited." D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
+ I Y=1 D ^SROACLN G CARD
+ I Y=2 D ^SROACAT G CARD
+ D ^SROACOP G CARD
+ Q
+PREOP ; print preop information (managerial)
+ W:$E(IOST)="P" !! D PREOP^SROAUTL0 S SRDR=DR W !,?28,"PREOPERATIVE INFORMATION",! S SRQ=1 D OUT
+ Q
+OUT K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
+ K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I  D
+ .Q:I=413  D TR D:SRQ GET^SROAUTL1 D:'SRQ GET^SROAUTL2
+ .S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRX(SRX))=$S($P(Y,"^",3)'="":$P(Y,"^",3),1:$P(Y,"^",2))_"^"_SRFLD
+ .W !,$J($P(Z,"^")_": ",39) S SREXT=SRY(130,SRTN,SRFLD,"E") D EXT
+ Q
+EXT I SRFLD=27 S SREXT=$S(SREXT="":"MISSING",1:$E(SREXT,1,5))
+ I $L(SREXT)<40 W SREXT Q
+ N I,J,X,Y S X=SREXT F  D  W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q
+ .F I=0:1:38 S J=39-I,Y=$E(X,J) I Y=" " W ?40,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q
+ Q
+LAB ; print preoperative laboratory test information (managerial)
+ W !,?20,"PREOPERATIVE LABORATORY TEST INFORMATION",!
+ D LR^SROAUTL0 S SRDR=DR K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
+ K SRX S SRX=0 F M=1:2 S L=$P(SRDR,";",M) Q:'L  S I=L D
+ .D TR D GET^SROAUTL2 S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),SRDT=$P(Y,"^",4),(Z,SRX(SRX))=$S($P(Y,"^",3)'="":$P(Y,"^",3),1:$P(Y,"^",2))_"^"_SRFLD_"^"_SRDT
+ .W !,$J($P(Z,"^")_": ",39),SRY(130,SRTN,SRFLD,"E") W:SRY(130,SRTN,SRDT,"E")'="" ?50,"("_$P(SRY(130,SRTN,SRDT,"E"),"@")_")"
+ Q
+TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
+ Q
+NON S DR=".03;102;.035"
+ Q
+CHK ; check for missing information for excluded cases
+ K SRX,DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D NON D EN^DIQ1 D ^SROAUTL2
+ K DA,DIC,DIQ,DR,SRY,SRZ D TECH^SROPRIN I SRTECH="NOT ENTERED" S SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique"
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROAUTL4.m

@@ -1 @@
-SROAUTL4        ;BIR/ADM - RISK ASSESSMENT UTILITY ;01/10/08
-        ;;3.0; Surgery ;**38,71,95,125,153,160,164,166**;24 Jun 93;Build 7
-        N SRZZ,SRXX,SRX1
-        S SRZ=0 F  S SRZ=$O(SRY(130,SRTN,SRZ)) Q:'SRZ  D
-        .I SRY(130,SRTN,SRZ,"I")="" D TR S (SRX1,X)=$T(@SRP),SRFLD=$P(X,";;",2) D
-        ..I SRZ=513,$P(^SRF(SRTN,0),"^",9)<3071001 Q
-        ..I SRZ=515  S X1=$P(^SRF(SRTN,0),"^",9),X2=$P($G(^SRF(SRTN,209)),"^",15) D ^%DTC I X'>30 Q
-        ..I SRZ=484,$P($G(^SRF(SRTN,209)),"^",13)'="Y" Q
-        ..S X=SRX1,SRX(SRZ)=$P(SRFLD,"^",2)_"^"_$P(X,";;",3)
-        .I SRY(130,SRTN,SRZ,"I")="NS" D TR S X=$T(@SRP),SRFLD=$P(X,";;",2),SRDT=$P(SRFLD,"^",4) S:SRDT'="" SRLR(SRDT)=""
-        S SRDT=0 F  S SRDT=$O(SRLR(SRDT)) Q:'SRDT  K SRX(SRDT)
-        Q
-RED     M SRZZ=SRX S SRZ=0 F  S SRZ=$O(SRX(SRZ)) Q:'SRZ  S SRZZ=$P($G(SRX(SRZ)),"^",2),SRXX(SRZZ)=$P($G(SRX(SRZ)),"^")_":"_SRZ
-        K SRX M SRX=SRXX K SRXX
-        Q
-TR      S SRP=SRZ,SRP=$TR(SRP,"1234567890.","ABCDEFGHIJP")
-        Q
-GET     S X=$T(@J)
-        Q
-BCF     ;;236^Patient's Height^Height^;;1-01
-BCG     ;;237^Patient's Weight^Weight^;;1-02
-DGE     ;;475^Diabetes (Cardiac);;1-03
-BJC     ;;203^History of COPD (Y/N)^COPD^;;1-04
-CDG     ;;347^FEV1^FEV1^;;1-05
-BJI     ;;209^Cardiomegaly on Chest X-Ray (Y/N)^Cardiomegaly (X-ray)^;;1-06
-CDH     ;;348^Pulmonary Rales (Y/N)^Pulmonary Rales^;;1-07
-EAJ     ;;510^Current Smoker^Current Smoker^;;1-08
-CDI     ;;349^Active Endocarditis (Y/N)^Active Endocarditis^;;1-09
-CEJ     ;;350^Resting ST Depression (Y/N)^Resting ST Depression^;;1-10
-BDJ     ;;240^Functional Health Status^Functional Status^;;1-11
-CEA     ;;351^PCI Status^PCI^;;1-12
-BJE     ;;205^Prior Myocardial Infarction^Prior MI^;;1-13
-CEB     ;;352^Number of Prior Heart Surgeries^Number of Prior Heart Surgeries^;;1-14
-DHE     ;;485^Prior Heart Surgeries;;1-15
-BFE     ;;265^Peripheral Vascular Disease (Y/N)^Peripheral Vascular Disease^;;1-16
-BFD     ;;264^Cerebral Vascular Disease (Y/N)^Cerebral Vascular Disease^;;1-17
-BFG     ;;267^Angina (use NYHA Functional Class)^Angina (use CCS Class)^;;1-18
-BJG     ;;207^Congestive Heart Failure (use NYHA Functional Class)^CHF (use NYHA Class)^;;1-19
-CEC     ;;353^Current Diuretic Use (Y/N)^Current Diuretic Use^;;1-20
-CED     ;;354^Current Digoxin Use (Y/N)^Current Digoxin Use^;;1-21
-CEE     ;;355^IV NTG within 48 Hours Preceding Surgery (Y/N)^IV NTG within 48 Hours^;;1-22
-DGD     ;;474^Preop use of circulatory Device;;1-23
-DFC     ;;463^Hypertension^;;1-24
-DEG     ;;457^HDL^^457.1;;2-01
-DEGPA   ;;457.1^HDL, Date;;2-02
-DFA     ;;461^LDL^^461.1;;2-03
-DFAPA   ;;461.1^LDL, Date;;2-04
-DFB     ;;462^Total Cholesterol^^462.1;;2-05
-DFBPA   ;;462.1^Total Cholesterol, Date;;2-06
-DEH     ;;458^Serum Triglyceride^^458.1;;2-07
-DEHPA   ;;458.1^Serum Triglyceride, Date;;2-08
-DEI     ;;459^Serum Potassium^^459.1;;2-09
-DEIPA   ;;459.1^Serum Potassium, Date;;2-10
-DFJ     ;;460^Serum Total Bilirubin^^460.1;;2-11
-DFJPA   ;;460.1^Serum Total Bilirubin, Date;;2-12
-BBC     ;;223^Preoperative Serum Creatinine^Creatinine^290;;2-13
-BIJ     ;;290^Creatinine Date;;2-14
-BBE     ;;225^Preoperative Serum Albumin^^292;;2-15
-BIB     ;;292^Preoperative Serum Albumin Date;;2-16
-BAI     ;;219^Preoperative Hemoglobin^^239;;2-17
-BCI     ;;239^Preoperative Hemoglobin Date;;2-18
-EJD     ;;504^Hemoglobin A1c^^504.1;;2-19
-EJDPA   ;;504.1^Hemoglobin A1c, Date;;2-20
-DGF     ;;476^Procedure Type;;3-01
-CEG     ;;357^Left Ventricular End-Diastolic Pressure^LVEDP^;;3-02
-CEH     ;;358^Aortic Systolic Pressure^Aortic Systolic Pressure^;;3-03
-CEI     ;;359^PA Systolic Pressure^*PA Systolic Pressure^;;3-04
-CFJ     ;;360^PAW Mean Pressure^*PAW Mean Pressure^;;3-05
-CFC     ;;363^LV Contraction Grade^LV Contraction Grade  (from contrast or radionuclide angiogram or 2D echo^;;3-06
-DAE     ;;415^Mitral Regurgitation^Mitral Regurgitation^;;3-07
-DGG     ;;477^Aortic Stenosis;;3-08
-CFA     ;;361^Left Main Stenosis^Left Main Stenosis^;;3-09
-CFBPA   ;;362.1^Left Anterior Descending (LAD) Stenosis^LAD Stenosis^;;3-10
-CFBPB   ;;362.2^Right Coronary Artery Stenosis^Right Coronary Stenosis^;;3-11
-CFBPC   ;;362.3^Circumflex Coronary Artery Stenosis^Circumflex Stenosis^;;3-12
-DGH     ;;478^Re-Do Lad Stenosis;;3-13
-DGI     ;;479^Re-Do Right Coronary Stenosis;;3-14
-DHJ     ;;480^Re-Do Circumflex Stenosis;;3-15
-CFD     ;;364^Physician's Preoperative Estimate of Operative Mortality^Physician's Preoperative Estimate of Operative Mortality^;;4-01
-CFDPA   ;;364.1^Date/Time of Estimate of Operative Mortality^Date/Time of Estimate of Operative Mortality^;;4-02
-APAC    ;;1.13^ASA Class^ASA Classification^;;4-03
-DAD     ;;414^Cardiac Surgical Priority^Surgical Priority^;;4-04
-DADPA   ;;414.1^Date/Time of Cardiac Surgical Priority^Date/Time of Cardiac Surgical Priority^;;4-05
-PBB     ;;.22^Time the Operation Began^Date/Time Operation Began^;;4-06
-PBC     ;;.23^Time the Operation Ended^Date/Time Operation Ended^;;4-07
-CFE     ;;365^CABG Distal Anastomoses with Vein^^;;5-01
-CFF     ;;366^CABG Distal Anastomoses with IMA^^;;5-02
-DFD     ;;464^Number with Radial Artery^;;5-03
-DFE     ;;465^Number with Other Artery^;;5-04
-DAF     ;;416^CABG Distal Anastomoses with Other Conduit^^;;5-05
-CFG     ;;367^Aortic Valve Replacement (Y/N)^Aortic Valve Replacement^;;5-06
-CFH     ;;368^Mitral Valve Replacement (Y/N)^Mitral Valve Replacement^;;5-07
-CFI     ;;369^Tricuspid Valve Replacement (Y/N)^Tricuspid Valve Replacement^;;5-08
-CGJ     ;;370^Valve Repair (Y/N)^Valve Repair^;;5-09
-CGA     ;;371^LV Aneurysmectomy (Y/N)^LV Aneurysmectomy^;;5-10
-DHA     ;;481^Bridge to transplant/Device;;5-11
-DHC     ;;483^Transmyocardial Laser Revascularization;;5-12
-EAB     ;;512^Maze Procedure;;5-13
-CGF     ;;376^ASD Repair (Y/N)^ASD Repair^;;5-14
-CHJ     ;;380^VSD Repair (Y/N)^VSD Repair^;;5-15
-CGH     ;;378^Myectomy for IHSS (Y/N)^Myectomy for IHSS^;;5-16
-CGG     ;;377^Myxoma Resection (Y/N)^Myxoma Resection^;;5-17
-CGI     ;;379^Other Tumor Resection (Y/N)^Other Tumor Resection^;;5-18
-CGC     ;;373^Cardiac Transplant (Y/N)^Cardiac Transplant^;;5-19
-CGB     ;;372^Great Vessel Repair(Y/N)^Great Vessel Repair^;;5-20
-EJE     ;;505^Endovascular Repair of Descending Thoracic Aorta (Y/N)^Endovascular Repair;;5-21
-EJB     ;;502^Other Cardiac Procedures (Y/N);;5-22
-DHD     ;;484^Other cardiac procedures (specify);;5-23
-CHA     ;;381^Foreign Body Removal (Y/N)^Foreign Body Removal^;;5-24
-CHB     ;;382^Pericardiectomy (Y/N)^Pericardiectomy^;;5-25
-DEA     ;;451^Total CPB Time;;5-26
-DEJ     ;;450^Total Ischemic Time;;5-27
-DFH     ;;468^Incision Type^;;5-28
-DFI     ;;469^Covert From Off Pump to CPB;;5-29
-CHD     ;;384^Operative Death (Y/N)^Operative Death^;;6-01
-DAH     ;;418^Hospital Admission Date And Time;;7-01
-DAI     ;;419^Hospital Discharge Date And Time;;7-02
-DDJ     ;;440^Cardiac Catheterization Date;;7-03
-PBJE    ;;.205^Time Patient In OR;;7-04
-PBCB    ;;.232^Time Patient Out OR;;7-05
-DGJ     ;;470^Date and Time Patient Extubated;;7-06
-DGA     ;;471^Date and Time Patient Discharged from ICU;;7-07
-DGC     ;;473^Homeless(Y/N);;7-08
-DGB     ;;472^Cardiac Surgery to NON-VA Facility;;7-09
-DDB     ;;442^Employment Status;;7-10
-EAC     ;;513^CT Surgery Consult Date;;7-11
-EAE     ;;515^Cause for Delay for Cardiac Surgery;;7-12
+SROAUTL4 ;BIR/ADM - RISK ASSESSMENT UTILITY ;08/24/07
+ ;;3.0; Surgery ;**38,71,95,125,153,160,164**;24 Jun 93;Build 2
+ S SRZ=0 F  S SRZ=$O(SRY(130,SRTN,SRZ)) Q:'SRZ  D
+ .I SRY(130,SRTN,SRZ,"I")="" D TR S X=$T(@SRP),SRFLD=$P(X,";;",2) D
+ ..I SRZ=451!(SRZ=450) S SRX($P(SRFLD,"^",2))=$P(SRFLD,"^",2)_"^"_SRZ Q
+ ..I SRZ=513,$P(^SRF(SRTN,0),"^",9)<3071001 Q
+ ..S SRX(SRZ)=$P(SRFLD,"^",2)
+ .I SRY(130,SRTN,SRZ,"I")="NS" D TR S X=$T(@SRP),SRFLD=$P(X,";;",2),SRDT=$P(SRFLD,"^",4) S:SRDT'="" SRLR(SRDT)=""
+ S SRDT=0 F  S SRDT=$O(SRLR(SRDT)) Q:'SRDT  K SRX(SRDT)
+ Q
+TR S SRP=SRZ,SRP=$TR(SRP,"1234567890.","ABCDEFGHIJP")
+ Q
+GET S X=$T(@J)
+ Q
+PBB ;;.22^Time the Operation Began^Date/Time Operation Began^
+PBC ;;.23^Time the Operation Ended^Date/Time Operation Ended^
+BCF ;;236^Patient's Height^Height^
+BCG ;;237^Patient's Weight^Weight^
+CDF ;;346^Diabetes^Diabetes^
+BJC ;;203^History of COPD (Y/N)^COPD^
+CDG ;;347^FEV1^FEV1^
+BJI ;;209^Cardiomegaly on Chest X-Ray (Y/N)^Cardiomegaly (X-ray)^
+CDH ;;348^Pulmonary Rales (Y/N)^Pulmonary Rales^
+EAJ ;;510^Current Smoker^Current Smoker^
+BBC ;;223^Preoperative Serum Creatinine^Creatinine^290
+CDI ;;349^Active Endocarditis (Y/N)^Active Endocarditis^
+CEJ ;;350^Resting ST Depression (Y/N)^Resting ST Depression^
+BDJ ;;240^Functional Health Status^Functional Status^
+CEA ;;351^PCI Status^PCI^
+BJE ;;205^Prior Myocardial Infarction^Prior MI^
+CEB ;;352^Number of Prior Heart Surgeries^Number of Prior Heart Surgeries^
+BFE ;;265^Peripheral Vascular Disease (Y/N)^Peripheral Vascular Disease^
+BFD ;;264^Cerebral Vascular Disease (Y/N)^Cerebral Vascular Disease^
+BFG ;;267^Angina (use NYHA Functional Class)^Angina (use CCS Class)^
+BJG ;;207^Congestive Heart Failure (use NYHA Functional Class)^CHF (use NYHA Class)^
+CEC ;;353^Current Diuretic Use (Y/N)^Current Diuretic Use^
+CED ;;354^Current Digoxin Use (Y/N)^Current Digoxin Use^
+CEE ;;355^IV NTG within 48 Hours Preceding Surgery (Y/N)^IV NTG within 48 Hours^
+CEF ;;356^Preoperative use of IABP (Y/N)^Preop Use of IABP^
+CEG ;;357^Left Ventricular End-Diastolic Pressure^LVEDP^
+CEH ;;358^Aortic Systolic Pressure^Aortic Systolic Pressure^
+CEI ;;359^PA Systolic Pressure^*PA Systolic Pressure^
+CFJ ;;360^PAW Mean Pressure^*PAW Mean Pressure^
+CFA ;;361^Left Main Stenosis^Left Main Stenosis^
+CFBPA ;;362.1^Left Anterior Descending (LAD) Stenosis^LAD Stenosis^
+CFBPB ;;362.2^Right Coronary Artery Stenosis^Right Coronary Stenosis^
+CFBPC ;;362.3^Circumflex Coronary Artery Stenosis^Circumflex Stenosis^
+CFC ;;363^LV Contraction Grade^LV Contraction Grade  (from contrast or radionuclide angiogram or 2D echo^
+DAE ;;415^Mitral Regurgitation^Mitral Regurgitation^
+CFD ;;364^Physician's Preoperative Estimate of Operative Mortality^Physician's Preoperative Estimate of Operative Mortality^
+CFDPA ;;364.1^Date/Time of Estimate of Operative Mortality^Date/Time of Estimate of Operative Mortality^
+APAC ;;1.13^ASA Class^ASA Classification^
+DAD ;;414^Cardiac Surgical Priority^Surgical Priority^
+DADPA ;;414.1^Date/Time of Cardiac Surgical Priority^Date/Time of Cardiac Surgical Priority^
+CHD ;;384^Operative Death (Y/N)^Operative Death^
+CFE ;;365^CABG Distal Anastomoses with Vein^^
+CFF ;;366^CABG Distal Anastomoses with IMA^^
+CFG ;;367^Aortic Valve Replacement (Y/N)^Aortic Valve Replacement^
+CFH ;;368^Mitral Valve Replacement (Y/N)^Mitral Valve Replacement^
+CFI ;;369^Tricuspid Valve Replacement (Y/N)^Tricuspid Valve Replacement^
+CGJ ;;370^Valve Repair (Y/N)^Valve Repair^
+CGA ;;371^LV Aneurysmectomy (Y/N)^LV Aneurysmectomy^
+CGB ;;372^Great Vessel Repair(Y/N)^Great Vessel Repair^
+EJE ;;505^Endovascular Repair of Descending Thoracic Aorta (Y/N)^Endovascular Repair
+CGC ;;373^Cardiac Transplant (Y/N)^Cardiac Transplant^
+CGF ;;376^ASD Repair (Y/N)^ASD Repair^
+CHJ ;;380^VSD Repair (Y/N)^VSD Repair^
+CGG ;;377^Myxoma Resection (Y/N)^Myxoma Resection^
+CHA ;;381^Foreign Body Removal (Y/N)^Foreign Body Removal^
+CGH ;;378^Myectomy for IHSS (Y/N)^Myectomy for IHSS^
+CHB ;;382^Pericardiectomy (Y/N)^Pericardiectomy^
+CGI ;;379^Other Tumor Resection (Y/N)^Other Tumor Resection^
+DAF ;;416^CABG Distal Anastomoses with Other Conduit^^
+DDB ;;442^Employment Status
+BAI ;;219^Preoperative Hemoglobin^^239
+BCI ;;239^Preoperative Hemoglobin Date
+BBE ;;225^Preoperative Serum Albumin^^292
+BIB ;;292^Preoperative Serum Albumin Date
+BIJ ;;290^Creatinine Date
+DEA ;;451^Total CPB Time
+DEJ ;;450^Total Ischemic Time
+DDJ ;;440^Cardiac Catheterization Date
+DAH ;;418^Hospital Admission Date And Time
+DAI ;;419^Hospital Discharge Date And Time
+DFC ;;463^Hypertension^
+DFD ;;464^Number with Radial Artery^
+DFE ;;465^Number with Other Artery^
+DFH ;;468^Incision Type^
+DFI ;;469^Covert From Off Pump to CPB
+DGJ ;;470^Date and Time Patient Extubated
+DGA ;;471^Date and Time Patient Discharged from ICU
+DGB ;;472^Cardiac Surgery to NON-VA Facility
+PBJE ;;.205^Time Patient In OR
+PBCB ;;.232^Time Patient Out OR
+DEG ;;457^HDL^^457.1
+DEGPA ;;457.1^HDL, Date
+DEH ;;458^Serum Triglyceride^^458.1
+DEHPA ;;458.1^Serum Triglyceride, Date
+DEI ;;459^Serum Potassium^^459.1
+DEIPA ;;459.1^Serum Potassium, Date
+DFJ ;;460^Serum Total Bilirubin^^460.1
+DFJPA ;;460.1^Serum Total Bilirubin, Date
+DFA ;;461^LDL^^461.1
+DFAPA ;;461.1^LDL, Date
+DFB ;;462^Total Cholesterol^^462.1
+DFBPA ;;462.1^Total Cholesterol, Date
+EJD ;;504^Hemoglobin A1c^^504.1
+EJDPA ;;504.1^Hemoglobin A1c, Date
+DGE ;;475^Diabetes (Cardiac)
+DGD ;;474^Preop use of circulatory Device
+DGF ;;476^Procedure Type
+DGG ;;477^Aortic Stenosis
+DGH ;;478^Re-Do Lad Stenosis
+DGI ;;479^Re-Do Right Coronary Stenosis
+DHJ ;;480^Re-Do Circumflex Stenosis
+DHA ;;481^Bridge to transplant/Device
+EAB ;;512^Maze Procedure
+DHC ;;483^Transmyocardial Laser Revascularization
+EJB ;;502^Other Cardiac Procedures (Y/N)
+DHD ;;484^Other cardiac procedures (specify)
+DHE ;;485^Prior Heart Surgeries
+EAC ;;513^CT Surgery Consult Date

WorldVistAEHR/trunk/r/SURGERY-SR/SROAUTLC.m

@@ -1 @@
-SROAUTLC        ;BIR/ADM - CARDIAC RISK ASSESSMENT UTILITY ;08/23/07
-        ;;3.0; Surgery ;**38,71,90,88,95,97,102,96,125,153,163,164,166**;24 Jun 93;Build 7
-        ;
-        ; Reference to ^DIC(45.3 supported by DBIA #218
-        ;
-SITE    ; determine if site is a cardiac facility
-        I $$CARD Q
-        W @IOF,!,"The SURGERY SITE PARAMETERS file indicates this site/division does not use ",!,"the Cardiac Risk Assessment module. Therefore, this option is not available",!,"for use.",!
-        S XQUIT="" W !!,"Press RETURN to continue  " R X:DTIME W @IOF
-        Q
-CARD()  ; extrinsic call to determine if site is cardiac facility
-        N CARD S CARD=0 Q:'$G(SRSITE) CARD
-        I $P($G(^SRO(133,SRSITE,0)),"^",5)="Y" S CARD=1
-        Q CARD
-NOW     ; update date/time of surgical priority entry
-        N X I $$CARD,$P($G(^SRF(DA,208)),"^",12)'="" D NOW^%DTC S $P(^SRF(DA,208),"^",13)=$E(%,1,12)
-        Q
-KNOW    ; delete date/time of surgical priority entry
-        I $D(^SRF(DA,208)) S $P(^SRF(DA,208),"^",13)=""
-        Q
-EM      ; input transform logic on Case Schedule Type field (.035)
-        Q:'$$CARD  N DIR,SREM,SRNOT,SRQ,SRSP
-        I X'="EM" S:X="U" $P(^SRF(DA,208),"^",12)=2 S:X'="U" $P(^SRF(DA,208),"^",12)=1 D NOW Q
-        S SRQ=0,SRSP=$P(^DIC(45.3,$P(^SRO(137.45,$P(^SRF(DA,0),"^",4),0),"^",2),0),"^") Q:SRSP'=48&(SRSP'=58)  D:SRSP=58 YN Q:SRQ
-        D CAT
-        Q
-CAT     N X K DIR S DIR("A",1)="",DIR("A",2)="     Enter category of emergency.",DIR("A",3)="     1. Emergent (ongoing ischemia)",DIR("A",4)="     2. Emergent (hemodynamic compromise)",DIR("A",5)="     3. Emergent (arrest with CPR)"
-        S DIR("A",6)="",DIR("A")="     Enter number (1, 2 or 3): ",DIR(0)="NA^1:3",DIR("?")="^D HELP^SROAUTLC" D ^DIR I $D(DTOUT)!$D(DUOUT) Q
-        S SREM=Y,$P(^SRF(DA,208),"^",12)=SREM+2 D NOW
-        Q
-YN      N X K DIR S DIR("A",1)="",DIR("A",2)="     Is this emergency case a cardiac procedure requiring cardiopulmonary",DIR("A")="     bypass (Y/N)? ",DIR(0)="YA" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
-        I 'Y S SRQ=1
-        Q
-HELP    K SRHLP S SRHLP(1)="This is the category of emergency reflecting the patient's cardiovascular",SRHLP(2)="condition at the time of transport to the operating room:",SRHLP(3)=""
-        S SRHLP(4)="1. Emergent (ongoing ischemia) - Clinical condition mandates immediate",SRHLP(5)="surgery usually on day of catheterization because of ischemia despite"
-        S SRHLP(6)="medical therapy, such as intravenous nitroglycerine.  Ischemia should",SRHLP(7)="be manifested as chest pain and/or ST-segment depression."
-        S SRHLP(8)="",SRHLP(9)="2. Emergent (hemodynamic compromise) - Persistent hypotension (arterial",SRHLP(10)="systolic pressure < 80 mm Hg) and/or low cardiac output (cardiac index"
-        S SRHLP(11)="< 2.0 L/min/MxM) despite iontropic and/or mechanical circulatory",SRHLP(12)="support mandates immediates surgery within hours of the cardiac",SRHLP(13)="catheterization."
-        S SRHLP(14)="",SRHLP(15)="3. Emergent (arrest with CPR) - Patient is taken to the operating room in",SRHLP(16)="full cardiac arrest with the circulation supported by cardiopulmonary"
-        S SRHLP(17)="resuscitation (excludes patients being adequately perfused by a",SRHLP(18)="cardiopulmonary support system).",SRHLP(19)=""
-        S SRHLP(20)="Enter the appropriate number to designate the category of emergency.",SRHLP(21)="",SRHLP(22)="" D EN^DDIOL(.SRHLP) K SRHLP
-        N DIR S DIR(0)="FOA",DIR("A")="Enter RETURN to continue: " D ^DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
-        Q
-CHK     ; check for missing cardiac assessment information
-        K SRX,SRZZ F SRC="CLIN","LAB","CATH","OP","CAR","OUT","R" K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D @SRC D EN^DIQ1 D ^SROAUTL4
-        D RED^SROAUTL4
-        Q
-CLIN    S DR="236;237;475;203;347;209;348;510;349;350;240;351;205;352;485;265;264;267;207;353;354;355;474;463"
-        Q
-CATH    S DR="476;357;358;359;360;363;415;477;361;362.1;362.2;362.3;478;479;480"
-        Q
-R       S DR="418;419;440;.205;.232;470;471;473;472;442;513;515"
-        Q
-OP      S DR="364;364.1;1.13;414;414.1;.22;.23"
-        Q
-OUT     S DR="384"
-        Q
-CAR     S DR="365;366;464;465;416;367;368;369;370;371;481;483;512;376;380;378;377;379;373;372;505;502;381;382;451;450;468;469"
-        I $P($G(^SRF(SRTN,209)),"^",13)="Y"!($P($G(^SRF(SRTN,209)),"^",13)="") S DR=DR_";484"
-        Q
-LAB     S DR="457;457.1;461;461.1;462;462.1;458;458.1;459;459.1;460;460.1;223;290;225;292;219;239;504;504.1"
-        Q
+SROAUTLC ;BIR/ADM - CARDIAC RISK ASSESSMENT UTILITY ;08/23/07
+ ;;3.0; Surgery ;**38,71,90,88,95,97,102,96,125,153,163,164**;24 Jun 93;Build 2
+ ;
+ ; Reference to ^DIC(45.3 supported by DBIA #218
+ ;
+SITE ; determine if site is a cardiac facility
+ I $$CARD Q
+ W @IOF,!,"The SURGERY SITE PARAMETERS file indicates this site/division does not use ",!,"the Cardiac Risk Assessment module. Therefore, this option is not available",!,"for use.",!
+ S XQUIT="" W !!,"Press RETURN to continue  " R X:DTIME W @IOF
+ Q
+CARD() ; extrinsic call to determine if site is cardiac facility
+ N CARD S CARD=0 Q:'$G(SRSITE) CARD
+ I $P($G(^SRO(133,SRSITE,0)),"^",5)="Y" S CARD=1
+ Q CARD
+NOW ; update date/time of surgical priority entry
+ N X I $$CARD,$P($G(^SRF(DA,208)),"^",12)'="" D NOW^%DTC S $P(^SRF(DA,208),"^",13)=$E(%,1,12)
+ Q
+KNOW ; delete date/time of surgical priority entry
+ I $D(^SRF(DA,208)) S $P(^SRF(DA,208),"^",13)=""
+ Q
+EM ; input transform logic on Case Schedule Type field (.035)
+ Q:'$$CARD  N DIR,SREM,SRNOT,SRQ,SRSP
+ I X'="EM" S:X="U" $P(^SRF(DA,208),"^",12)=2 S:X'="U" $P(^SRF(DA,208),"^",12)=1 D NOW Q
+ S SRQ=0,SRSP=$P(^DIC(45.3,$P(^SRO(137.45,$P(^SRF(DA,0),"^",4),0),"^",2),0),"^") Q:SRSP'=48&(SRSP'=58)  D:SRSP=58 YN Q:SRQ
+ D CAT
+ Q
+CAT N X K DIR S DIR("A",1)="",DIR("A",2)="     Enter category of emergency.",DIR("A",3)="     1. Emergent (ongoing ischemia)",DIR("A",4)="     2. Emergent (hemodynamic compromise)",DIR("A",5)="     3. Emergent (arrest with CPR)"
+ S DIR("A",6)="",DIR("A")="     Enter number (1, 2 or 3): ",DIR(0)="NA^1:3",DIR("?")="^D HELP^SROAUTLC" D ^DIR I $D(DTOUT)!$D(DUOUT) Q
+ S SREM=Y,$P(^SRF(DA,208),"^",12)=SREM+2 D NOW
+ Q
+YN N X K DIR S DIR("A",1)="",DIR("A",2)="     Is this emergency case a cardiac procedure requiring cardiopulmonary",DIR("A")="     bypass (Y/N)? ",DIR(0)="YA" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
+ I 'Y S SRQ=1
+ Q
+HELP K SRHLP S SRHLP(1)="This is the category of emergency reflecting the patient's cardiovascular",SRHLP(2)="condition at the time of transport to the operating room:",SRHLP(3)=""
+ S SRHLP(4)="1. Emergent (ongoing ischemia) - Clinical condition mandates immediate",SRHLP(5)="surgery usually on day of catheterization because of ischemia despite"
+ S SRHLP(6)="medical therapy, such as intravenous nitroglycerine.  Ischemia should",SRHLP(7)="be manifested as chest pain and/or ST-segment depression."
+ S SRHLP(8)="",SRHLP(9)="2. Emergent (hemodynamic compromise) - Persistent hypotension (arterial",SRHLP(10)="systolic pressure < 80 mm Hg) and/or low cardiac output (cardiac index"
+ S SRHLP(11)="< 2.0 L/min/MxM) despite iontropic and/or mechanical circulatory",SRHLP(12)="support mandates immediates surgery within hours of the cardiac",SRHLP(13)="catheterization."
+ S SRHLP(14)="",SRHLP(15)="3. Emergent (arrest with CPR) - Patient is taken to the operating room in",SRHLP(16)="full cardiac arrest with the circulation supported by cardiopulmonary"
+ S SRHLP(17)="resuscitation (excludes patients being adequately perfused by a",SRHLP(18)="cardiopulmonary support system).",SRHLP(19)=""
+ S SRHLP(20)="Enter the appropriate number to designate the category of emergency.",SRHLP(21)="",SRHLP(22)="" D EN^DDIOL(.SRHLP) K SRHLP
+ N DIR S DIR(0)="FOA",DIR("A")="Enter RETURN to continue: " D ^DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
+ Q
+CHK ; check for missing cardiac assessment information
+ K SRX F SRC="CLIN","COC","CP","CLR" K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D @SRC D EN^DIQ1 D ^SROAUTL4
+ Q
+CLIN S DR="236;237;475;203;347;209;348;510;223;290;219;239;225;292;349;350;240;351;205;352;485;265;264;267;207;353;354;355;463;474"
+ Q
+COC S DR="476;477;357;358;359;360;361;362.1;362.2;362.3;363;415;474;364;364.1;1.13;414;414.1;384;.22;.23;472;478;479;480"
+ Q
+CP S DR="365;366;464;465;416;367;368;369;370;371;372;505;450;451;373;376;380;377;381;378;382;379;468;469;.205;.232;470;471;418;419;440;481;512;483;502;513"
+ I $P($G(^SRF(SRTN,209)),"^",13)="Y"!($P($G(^SRF(SRTN,209)),"^",13)="") S DR=DR_";484"
+ Q
+CLR S DR="457;457.1;458;458.1;459;459.1;460;460.1;461;461.1;462;462.1;504;504.1"
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROCODE.m

@@ -1 @@
-SROCODE ;BIR/MAM - SET UP FLAG FOR ANESTHESIA AGENTS ;01/30/08
-        ;;3.0; Surgery ;**72,41,114,151,166**;24 Jun 93;Build 7
-        ;
-        ; Reference to ENS^PSSGIU supported by DBIA #895
-        ;
-1       N SRTEST S SRTEST=50,SRTEST(0)="AEQSZ",SRTEST("A")="Enter the name of the drug you wish to flag: "
-        D DIC^PSSDI(50,"SR",.SRTEST) G:+Y<1 DONE S SROIUDA=+Y,SROIRX=$P(Y,"^",2),SROIUX="S^SURGERY" D SROIU
-        G 1
-SROIU   Q:'$D(SROIUDA)!'$D(SROIUX)  Q:SROIUX'?1E1"^"1.E
-        N SRRX D DATA^PSS50(SROIUDA,,,,,"SRRX") S SRRX=$G(^TMP($J,"SRRX",SROIUDA,63)) D
-        .S SROIUY=$S($D(SRRX):SRRX,1:""),SROIUT=$P(SROIUX,"^",2),SROIUT=$E("N","AEIOU"[$E(SROIUT))_" "_SROIUT K ^TMP($J,"SRRX",SROIUDA)
-        I SROIUY["S" W !!,"This drug is already flagged for SURGERY." K DIR S DIR("A")="Do you want to remove the flag (Y/N)",DIR(0)="Y" D ^DIR D:Y OFF D DONE Q
-        W !! K DIR S DIR("A")="Do you want to flag this drug for SURGERY (Y/N)",DIR(0)="Y" D ^DIR D:Y FLAG
-DONE    W @IOF K SROIRX D ^SRSKILL
-        Q
-FLAG    S PSIUDA=SROIUDA,PSIUX=SROIUX_"^1"
-        S X="PSSGIU" X ^%ZOSF("TEST") I $T D ENS^PSSGIU
-        ;HL7 master file update (addition) to anesthesia agent list
-        N SRTBL,SRENT,FEC,REC S SRTBL="ANESTHESIA AGENT^50^.01",FEC="UPD",REC="MAD",SRENT=SROIUDA_U_SROIRX D MSG^SRHLMFN(SRTBL,FEC,REC,SRENT)
-        ;A call to PDM to possibly generate an HL7 outgoing drug message
-        S X="PSSHUIDG" X ^%ZOSF("TEST") I $T D DRG^PSSHUIDG(PSIUDA)
-        K PSIUDA,PSIUX
-        Q
-OFF     S PSIUDA=SROIUDA,PSIUX=SROIUX_"^1"
-        S X="PSSGIU" X ^%ZOSF("TEST") I $T D END^PSSGIU
-        ;HL7 master file update (deletion) to anesthesia agent list
-        N SRTBL,SRENT,FEC,REC S SRTBL="ANESTHESIA AGENT^50^.01",FEC="UPD",REC="MDL" D DATA^PSS50(SROIUDA,,,,,"SRRX")
-        S SRENT=SROIUDA_U_$P($G(^TMP($J,"SRRX",SROIUDA,.01)),"^") K ^TMP($J,"SRRX",SROIUDA) D MSG^SRHLMFN(SRTBL,FEC,REC,SRENT)
-        ;A call to PDM to possibly generate an HL7 outgoing drug message
-        S X="PSSHUIDG" X ^%ZOSF("TEST") I $T D DRG^PSSHUIDG(PSIUDA)
-        K PSIUDA,PSIUX
-        Q
+SROCODE ;B'HAM ISC/MAM - SET UP FLAG FOR ANESTHESIA AGENTS ; [ 05/06/98   7:14 AM ]
+ ;;3.0; Surgery ;**72,41,114,151**;24 Jun 93
+ ;
+ ; Reference to ENS^PSSGIU supported by DBIA #895
+ ; Reference to ^PSS50 supported by DBIA #4533
+ ;
+1 W !! K DIR S DIR(0)="P^50:QEAM",DIR("A")="Enter the name of the drug you wish to flag" D ^DIR G:Y<1 DONE S SROIUDA=+Y,SROIRX=$P(Y,"^",2),SROIUX="S^SURGERY" D SROIU
+ G 1
+SROIU Q:'$D(SROIUDA)!'$D(SROIUX)  Q:SROIUX'?1E1"^"1.E
+ N SRRX D DATA^PSS50(SROIUDA,,,,,"SRRX") S SRRX=$G(^TMP($J,"SRRX",SROIUDA,63)) D
+ .S SROIUY=$S($D(SRRX):SRRX,1:""),SROIUT=$P(SROIUX,"^",2),SROIUT=$E("N","AEIOU"[$E(SROIUT))_" "_SROIUT K ^TMP($J,"SRRX",SROIUDA)
+ I SROIUY["S" W !!,"This drug is already flagged for SURGERY." K DIR S DIR("A")="Do you want to remove the flag (Y/N)",DIR(0)="Y" D ^DIR D:Y OFF D DONE Q
+ W !! K DIR S DIR("A")="Do you want to flag this drug for SURGERY (Y/N)",DIR(0)="Y" D ^DIR D:Y FLAG
+DONE W @IOF K SROIRX D ^SRSKILL
+ Q
+FLAG S PSIUDA=SROIUDA,PSIUX=SROIUX_"^1"
+ S X="PSSGIU" X ^%ZOSF("TEST") I $T D ENS^PSSGIU
+ ;HL7 master file update (addition) to anesthesia agent list
+ N SRTBL,SRENT,FEC,REC S SRTBL="ANESTHESIA AGENT^50^.01",FEC="UPD",REC="MAD",SRENT=SROIUDA_U_SROIRX D MSG^SRHLMFN(SRTBL,FEC,REC,SRENT)
+ ;A call to PDM to possibly generate an HL7 outgoing drug message
+ S X="PSSHUIDG" X ^%ZOSF("TEST") I $T D DRG^PSSHUIDG(PSIUDA)
+ K PSIUDA,PSIUX
+ Q
+OFF S PSIUDA=SROIUDA,PSIUX=SROIUX_"^1"
+ S X="PSSGIU" X ^%ZOSF("TEST") I $T D END^PSSGIU
+ ;HL7 master file update (deletion) to anesthesia agent list
+ N SRTBL,SRENT,FEC,REC S SRTBL="ANESTHESIA AGENT^50^.01",FEC="UPD",REC="MDL" D DATA^PSS50(SROIUDA,,,,,"SRRX")
+ S SRENT=SROIUDA_U_$P($G(^TMP($J,"SRRX",SROIUDA,.01)),"^") K ^TMP($J,"SRRX",SROIUDA) D MSG^SRHLMFN(SRTBL,FEC,REC,SRENT)
+ ;A call to PDM to possibly generate an HL7 outgoing drug message
+ S X="PSSHUIDG" X ^%ZOSF("TEST") I $T D DRG^PSSHUIDG(PSIUDA)
+ K PSIUDA,PSIUX
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROESPR1.m

@@ -1 @@
-SROESPR1        ;BIR/ADM - SURGERY E-SIG UTILITY ; [ 04/21/04  12:08 PM ]
-        ;;3.0; Surgery ;**100,128,162**;24 Jun 93;Build 4
-        ;
-        ;** NOTICE: This routine is part of an implementation of a nationally
-        ;**         controlled procedure.  Local modifications to this routine
-        ;**         are prohibited.
-        ;
-        ; Reference to EXTRACT^TIULQ supported by DBIA #2693
-        ;
-        ; This routine was cloned in part or in whole from TIUPRPN1.
-PRINT(SRFLAG,SRSPG)     ; Print Summary
-        ; ^TMP("SRPR",$J) is array of records passed by reference
-        ; SRFLAG=1 --> Chart Copy     SRSPG=1 --> Contiguous
-        ; SRFLAG=0 --> Work Copy      SRSPG=0 --> Fresh Page- each note
-        N SRI,SRJ,SRPAGE,SRFOOT,SRK,SRDA,SRCONT,SRPGRP,SRTYP
-        N SRPFHDR,SRPFNBR,SROPAGE
-        S SRFLAG=+$G(SRFLAG),SRSPG=+$G(SRSPG)
-        S SRI=0 F  S SRI=$O(^TMP("SRPR",$J,SRI)) Q:SRI=""  D  Q:'SRCONT
-        . N DFN,SR,SRERR
-        . I SRI["$" S SRPGRP=$P(SRI,"$"),SRPFHDR=$P($P(SRI,";"),"$",2)
-        . E  S SRPFHDR="Surgery Reports"
-        . I $G(SRPGRP)'=2 S SRSPG=0
-        . S DFN=$P(SRI,";",2)
-        . D PAT^SROESPR(.SRFOOT,DFN)
-        . I +$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
-        . S SRJ=0 F  S SRJ=$O(^TMP("SRPR",$J,SRI,SRJ)) Q:'SRJ  D  Q:'SRCONT
-        . . S SRK=0 F  S SRK=$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) Q:'SRK  D  Q:'+$G(SRCONT)
-        . . . N SRERR1,SRW K SRCONT1 S SRPFNBR=^(SRK)
-        . . . ; If the document has been deleted, QUIT
-        . . . D EXTRACT^TIULQ(SRK,"SRW",.SRERR1,".01") I $P($G(SRERR1),"^")=1 S SRCONT=1 Q
-        . . . I '+$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
-        . . . S SRDA=SRK
-        . . . D REPORT(SRDA) Q:'+$G(SRCONT)
-        . . . I '+$G(SRSPG) K SRCONT1 D SETCONT(1)
-        . . . I $E(IOST)="C",'$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) S SRCONT=0
-        . Q:'SRCONT  I $E(IOST)="C" S SRCONT=$$STOP^SROESPR2() Q:'SRCONT
-        . I +$G(SRSPG),$E(IOST)'="C" K SRCONT1 D SETCONT(1)
-        Q
-REPORT(SRDA)    ; Report Text
-        N DIW,DIWF,DIWL,DIWR,DIWT,SRERR,SR,SRI,SRLINE,X,Z,SRY,LOC
-        K ^TMP("SRLQ",$J)
-        S SRLINE=0
-        D EXTRACT^TIULQ(+SRDA,"^TMP(""SRLQ"",$J)",.SRERR,"",SRLINE,1)
-        I +$G(SRERR) W !,$P(SRERR,U,2) Q
-        Q:'$D(^TMP("SRLQ",$J))
-        S SRY=4,SRCONT=1
-        D SETCONT() Q:'SRCONT
-        W "NOTE DATED: "
-        W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,1301,"I"),"MM/DD/CCYY HR:MIN")
-        W ?30,$$UP^XLFSTR(^TMP("SRLQ",$J,SRDA,.01,"E")),!
-        I +$G(^TMP("SRLQ",$J,SRDA,1205,"I")) D
-        .S LOC=$G(^TMP("SRLQ",$J,SRDA,1205,"I")) Q:'$D(^SC(LOC,0))
-        .W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ")
-        .W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,.07,"I"),"MM/DD/CCYY HR:MIN")
-        .W " ",$G(^TMP("SRLQ",$J,SRDA,1205,"E"))
-        I ^TMP("SRLQ",$J,SRDA,1701,"E")]"" W !,"SUBJECT: ",^("E"),!
-        S SRCONT1=1
-        I $D(^TMP("SRLQ",$J,SRDA,"PROBLEM")) D  Q:'SRCONT
-        .D SETCONT() Q:'SRCONT
-        .W !,"ASSOCIATED PROBLEMS:"
-        .N SRI S SRI=0
-        .F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"PROBLEM",SRI)) Q:'SRI  D  Q:'SRCONT
-        ..W !,^(SRI,0)
-        ..D SETCONT() Q:'SRCONT
-        W !
-        ;
-        S SRI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
-        F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"TEXT",SRI)) Q:SRI'>0  D  Q:'SRCONT  ; D ^DIWW
-        . D SETCONT() Q:'SRCONT
-        . S X=^TMP("SRLQ",$J,SRDA,"TEXT",SRI,0) S:X="" X=" " D ^DIWP
-        D ^DIWW K ^UTILITY($J,"W")
-        Q:'SRCONT
-RPTSIG  ; Signature should be on bottom of form, Addenda on Subsequent pages
-        N AUTHOR,EXPSIGNR,EXPCOSNR,SIGNDATE,SIGNEDBY,SIGNNAME,SIGTITL,SIGNMODE
-        N COSGDATE,COSGEDBY,COSGNAME,COSGTITL,COSGMODE,SIGCHRT,COSCHRT,SRLINE
-        S $P(SRLINE,"-",81)=""
-        S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,1202,"I"))_";"_$G(^("E"))
-        S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,1204,"I"))_";"_$G(^("E"))
-        S EXPCOSNR=$G(^TMP("SRLQ",$J,SRDA,1208,"I"))_";"_$G(^("E"))
-        S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,1501,"I"))
-        S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,1502,"I"))_";"_$G(^("E"))
-        S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,1503,"E"))
-        S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,1504,"E"))
-        S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,1505,"I"))_";"_$G(^("E"))
-        S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,1507,"I"))
-        S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,1508,"I"))_";"_$G(^("E"))
-        S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,1509,"E"))
-        S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,1510,"E"))
-        S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,1511,"I"))_";"_$G(^("E"))
-        S SIGCHRT=$G(^TMP("SRLQ",$J,SRDA,1512,"I"))_";"_$G(^("E"))
-        S COSCHRT=$G(^TMP("SRLQ",$J,SRDA,1513,"I"))_";"_$G(^("E"))
-        D SETCONT() Q:'SRCONT  W !
-        D SIGBLK Q:'SRCONT
-ADDENDA ; Surgery Reports Addenda
-        N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,SRI,SRADD
-        S SRADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
-        F  S SRADD=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD)) Q:SRADD'>0  D  Q:'SRCONT
-        . S SRY=4 D SETCONT() Q:'SRCONT
-        . W !!,$$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1301,"I"),"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM"
-        . W ?41,"STATUS: ",^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,.05,"E")
-        . S SRI=0
-        . F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI)) Q:SRI'>0  D  Q:'SRCONT
-        . . D SETCONT() Q:'SRCONT
-        . . S X=^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI,0) S:X="" X=" " D ^DIWP
-        . D ^DIWW
-        . D:SRCONT ADDENSIG
-        K ^UTILITY($J,"W")
-        ; Write 2 linefeeds between records
-        Q:'SRCONT  W !!
-        Q
-ADDENSIG        ;
-        N AUTHOR,EXPSIGNR,ATTNDING,SIGNDATE,SIGNEDBY,SIGNNAME,SIGNMODE
-        N COSGDATE,COSGEDBY,COSGNAME,COSGMODE,SRLINE S $P(SRLINE,"-",80)=""
-        S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1202,"I"))_";"_$G(^("E"))
-        S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1204,"I"))_";"_$G(^("E"))
-        S ATTNDING=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1209,"I"))_";"_$G(^("E"))
-        S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1501,"I"))
-        S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1502,"I"))_";"_$G(^("E"))
-        S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1503,"E"))
-        S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1504,"E"))
-        S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1505,"I"))_";"_$G(^("E"))
-        S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1507,"I"))
-        S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1508,"I"))_";"_$G(^("E"))
-        S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1509,"E"))
-        S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1510,"E"))
-        S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1511,"I"))_";"_$G(^("E"))
-        S SRY=11
-SIGBLK  N SRGROOT S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA))
-        I '+SIGNDATE D  D SETCONT() Q:'SRCONT
-        .I $$STATUS^SROESUTL(SRDA)'=7 W !,"**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED-- DRAFT COPY - DRAFT COPY**"
-        I SIGNEDBY]"",(+SIGNEDBY'=+AUTHOR)  D
-        . W ?21,"Author:      ",$P(AUTHOR,";",2),!
-        I +SIGNDATE D SETCONT() Q:'SRCONT  D
-        . W ?18,"Signed by:",$S($P(SIGNMODE,";")="C":" /s/  ",1:" /es/ "),?34,$S(SIGNNAME]"":SIGNNAME,1:$P(SIGNEDBY,";",2))
-        . W !?34,SIGTITL
-        . I $L(SIGTITL)>30 W !?34
-        . E  W " "
-        . W $$DATE^SROESPR(+SIGNDATE,"MM/DD/CCYY HR:MIN")
-        . I '+$G(SRFLAG)!($E(IOST)="C") D
-        . . I $P($$BEEP^SROESPR(+SIGNEDBY),U) W !?34,"Analog Pager:  ",$P($$BEEP^SROESPR(+SIGNEDBY),U)
-        . . I $P($$BEEP^SROESPR(+SIGNEDBY),U,2) W !?34,"Digital Pager: ",$P($$BEEP^SROESPR(+SIGNEDBY),U,2)
-        I $G(^TMP("SRLQ",$J,SRDA,.05,"E"))="UNCOSIGNED" D
-        . W !?34,"**REQUIRES COSIGNATURE**",!
-        I +SIGCHRT,$P(SIGNMODE,";")="C" D SETCONT() Q:'SRCONT  D
-        . W !?2,"Marked signed on chart by:",?34,$P(SIGCHRT,";",2)
-        I +$G(SRADD) S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD))
-        I +$D(@SRGROOT@("EXTRASGNR")) D
-        . N SRI S SRI=0
-        . D SETCONT() Q:'SRCONT  W !?4,"Receipt Acknowledged By:"
-        . F  S SRI=$O(@SRGROOT@("EXTRASGNR",SRI)) Q:'SRI  D
-        . . I +$G(@SRGROOT@("EXTRASGNR",SRI,"DATE"))'>0 Q
-        . . I SRI>1 D SETCONT() Q:'SRCONT  W !
-        . . W ?29,"/es/ ",$G(@SRGROOT@("EXTRASGNR",SRI,"NAME"))
-        . . W !?34,$G(@SRGROOT@("EXTRASGNR",SRI,"TITLE"))
-        . . I $L($G(@SRGROOT@("EXTRASGNR",SRI,"TITLE")))>30 W !?34
-        . . E  W " "
-        . . W $$DATE^SROESPR($G(@SRGROOT@("EXTRASGNR",SRI,"DATE")),"MM/DD/CCYY HR:MIN")
-        . . I '+$G(SRFLAG)!($E(IOST)="C") D
-        . . . N BEEP
-        . . . S BEEP=$$BEEP^SROESPR(+$G(@SRGROOT@("EXTRASGNR",SRI,"EXTRA")))
-        . . . I +BEEP W !?34,"Analog Pager:  ",$P(BEEP,U)
-        . . . I +$P(BEEP,U,2) W !?34,"Digital Pager: ",$P(BEEP,U,2)
-        . K @SRGROOT@("EXTRASGNR")
-        I +COSGDATE,(+COSGEDBY'=+SIGNEDBY) D SETCONT() Q:'SRCONT  D
-        . W !?16,"Cosigned by:",$S($P(COSGMODE,";")="C":" /s/  ",1:" /es/ "),?34,$S(COSGNAME]"":COSGNAME,1:$P(COSGEDBY,";",2))
-        . W !?34,COSGTITL," "
-        . W $$DATE^SROESPR(+COSGDATE,"MM/DD/CCYY HR:MIN")
-        . I '+$G(SRFLAG)!($E(IOST)="C") D
-        . . I $P($$BEEP^SROESPR(+COSGEDBY),U) W !?34,"Analog Pager: ",$P($$BEEP^SROESPR(+COSGEDBY),U)
-        . . I $P($$BEEP^SROESPR(+COSGEDBY),U,2) W !?34,"Digital Pager:",$P($$BEEP^SROESPR(+COSGEDBY),U,2)
-        I +COSCHRT,$P(COSGMODE,";")="C" D SETCONT() Q:'SRCONT  D
-        . W !,"Marked cosigned on chart by:",?34,$P(COSCHRT,";",2)
-        W !
-        K SRCONT1
-AMEND   ; signature blocks of amender
-        S SRY=4 D SETCONT() Q:'SRCONT
-        I +$G(@SRGROOT@(1601,"I")) D
-        . W !!?12,"Amendment Filed:",?34,$$DATE^SROESPR(@SRGROOT@(1601,"I"),"MM/DD/CCYY HR:MIN")
-        . I $G(@SRGROOT@(1603,"E"))']"" D
-        . . W !!?29 F SRI=1:1:40 W "_"
-        . . W !?29,$$SIGNAME^SROESPR(@SRGROOT@(1602,"I"))
-        . . W !?29,$$SIGTITL^SROESPR(@SRGROOT@(1602,"I"))
-        . I $G(@SRGROOT@(1604,"E"))]"" D
-        . . W !?29,"/es/",?34,@SRGROOT@(1604,"E")
-        . . W !?34,@SRGROOT@(1605,"E")
-        Q
-SETCONT(SRHEAD) ;Does footer and sets SRCONT
-        S SRCONT=$$FOOTER^SROESPR2(.SRFOOT,SRFLAG,SRPFNBR,$G(SRHEAD),$G(SRCONT1),SRDA)
-        Q
+SROESPR1 ;BIR/ADM - SURGERY E-SIG UTILITY ; [ 04/21/04  12:08 PM ]
+ ;;3.0; Surgery ;**100,128**;24 Jun 93
+ ;
+ ;** NOTICE: This routine is part of an implementation of a nationally
+ ;**         controlled procedure.  Local modifications to this routine
+ ;**         are prohibited.
+ ;
+ ; Reference to EXTRACT^TIULQ supported by DBIA #2693
+ ;
+ ; This routine was cloned in part or in whole from TIUPRPN1.
+PRINT(SRFLAG,SRSPG) ; Print Summary
+ ; ^TMP("SRPR",$J) is array of records passed by reference
+ ; SRFLAG=1 --> Chart Copy     SRSPG=1 --> Contiguous
+ ; SRFLAG=0 --> Work Copy      SRSPG=0 --> Fresh Page- each note
+ N SRI,SRJ,SRPAGE,SRFOOT,SRK,SRDA,SRCONT,SRPGRP,SRTYP
+ N SRPFHDR,SRPFNBR,SROPAGE
+ S SRFLAG=+$G(SRFLAG),SRSPG=+$G(SRSPG)
+ S SRI=0 F  S SRI=$O(^TMP("SRPR",$J,SRI)) Q:SRI=""  D  Q:'SRCONT
+ . N DFN,SR,SRERR
+ . I SRI["$" S SRPGRP=$P(SRI,"$"),SRPFHDR=$P($P(SRI,";"),"$",2)
+ . E  S SRPFHDR="Surgery Reports"
+ . I $G(SRPGRP)'=2 S SRSPG=0
+ . S DFN=$P(SRI,";",2)
+ . D PAT^SROESPR(.SRFOOT,DFN)
+ . I +$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
+ . S SRJ=0 F  S SRJ=$O(^TMP("SRPR",$J,SRI,SRJ)) Q:'SRJ  D  Q:'SRCONT
+ . . S SRK=0 F  S SRK=$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) Q:'SRK  D  Q:'+$G(SRCONT)
+ . . . N SRERR1,SRW K SRCONT1 S SRPFNBR=^(SRK)
+ . . . ; If the document has been deleted, QUIT
+ . . . D EXTRACT^TIULQ(SRK,"SRW",.SRERR1,".01") I $P($G(SRERR1),"^")=1 S SRCONT=1 Q
+ . . . I '+$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
+ . . . S SRDA=SRK
+ . . . D REPORT(SRDA) Q:'+$G(SRCONT)
+ . . . I '+$G(SRSPG) K SRCONT1 D SETCONT(1)
+ . . . I $E(IOST)="C",'$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) S SRCONT=0
+ . Q:'SRCONT  I $E(IOST)="C" S SRCONT=$$STOP^SROESPR2() Q:'SRCONT
+ . I +$G(SRSPG),$E(IOST)'="C" K SRCONT1 D SETCONT(1)
+ Q
+REPORT(SRDA) ; Report Text
+ N DIW,DIWF,DIWL,DIWR,DIWT,SRERR,SR,SRI,SRLINE,X,Z,SRY,LOC
+ K ^TMP("SRLQ",$J)
+ S SRLINE=0
+ D EXTRACT^TIULQ(+SRDA,"^TMP(""SRLQ"",$J)",.SRERR,"",SRLINE,1)
+ I +$G(SRERR) W !,$P(SRERR,U,2) Q
+ Q:'$D(^TMP("SRLQ",$J))
+ S SRY=4,SRCONT=1
+ D SETCONT() Q:'SRCONT
+ W "NOTE DATED: "
+ W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,1301,"I"),"MM/DD/CCYY HR:MIN")
+ W ?30,$$UP^XLFSTR(^TMP("SRLQ",$J,SRDA,.01,"E")),!
+ I +$G(^TMP("SRLQ",$J,SRDA,1205,"I")) D
+ .S LOC=$G(^TMP("SRLQ",$J,SRDA,1205,"I")) Q:'$D(^SC(LOC,0))
+ .W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ")
+ .W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,.07,"I"),"MM/DD/CCYY HR:MIN")
+ .W " ",$G(^TMP("SRLQ",$J,SRDA,1205,"E"))
+ I ^TMP("SRLQ",$J,SRDA,1701,"E")]"" W !,"SUBJECT: ",^("E"),!
+ S SRCONT1=1
+ I $D(^TMP("SRLQ",$J,SRDA,"PROBLEM")) D  Q:'SRCONT
+ .D SETCONT() Q:'SRCONT
+ .W !,"ASSOCIATED PROBLEMS:"
+ .N SRI S SRI=0
+ .F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"PROBLEM",SRI)) Q:'SRI  D  Q:'SRCONT
+ ..W !,^(SRI,0)
+ ..D SETCONT() Q:'SRCONT
+ W !
+ ;
+ S SRI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
+ F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"TEXT",SRI)) Q:SRI'>0  D  Q:'SRCONT  ; D ^DIWW
+ . D SETCONT() Q:'SRCONT
+ . S X=^TMP("SRLQ",$J,SRDA,"TEXT",SRI,0) S:X="" X=" " D ^DIWP
+ D ^DIWW K ^UTILITY($J,"W")
+ Q:'SRCONT
+RPTSIG ; Signature should be on bottom of form, Addenda on Subsequent pages
+ N AUTHOR,EXPSIGNR,EXPCOSNR,SIGNDATE,SIGNEDBY,SIGNNAME,SIGTITL,SIGNMODE
+ N COSGDATE,COSGEDBY,COSGNAME,COSGTITL,COSGMODE,SIGCHRT,COSCHRT,SRLINE
+ S $P(SRLINE,"-",81)=""
+ S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,1202,"I"))_";"_$G(^("E"))
+ S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,1204,"I"))_";"_$G(^("E"))
+ S EXPCOSNR=$G(^TMP("SRLQ",$J,SRDA,1208,"I"))_";"_$G(^("E"))
+ S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,1501,"I"))
+ S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,1502,"I"))_";"_$G(^("E"))
+ S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,1503,"E"))
+ S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,1504,"E"))
+ S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,1505,"I"))_";"_$G(^("E"))
+ S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,1507,"I"))
+ S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,1508,"I"))_";"_$G(^("E"))
+ S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,1509,"E"))
+ S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,1510,"E"))
+ S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,1511,"I"))_";"_$G(^("E"))
+ S SIGCHRT=$G(^TMP("SRLQ",$J,SRDA,1512,"I"))_";"_$G(^("E"))
+ S COSCHRT=$G(^TMP("SRLQ",$J,SRDA,1513,"I"))_";"_$G(^("E"))
+ D SETCONT() Q:'SRCONT  W !
+ D SIGBLK Q:'SRCONT
+ADDENDA ; Surgery Reports Addenda
+ N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,SRI,SRADD
+ S SRADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
+ F  S SRADD=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD)) Q:SRADD'>0  D  Q:'SRCONT
+ . S SRY=4 D SETCONT() Q:'SRCONT
+ . W !!,$$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1301,"I"),"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM"
+ . S SRI=0
+ . F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI)) Q:SRI'>0  D  Q:'SRCONT
+ . . D SETCONT() Q:'SRCONT
+ . . S X=^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI,0) S:X="" X=" " D ^DIWP
+ . D ^DIWW
+ . D:SRCONT ADDENSIG
+ K ^UTILITY($J,"W")
+ ; Write 2 linefeeds between records
+ Q:'SRCONT  W !!
+ Q
+ADDENSIG ;
+ N AUTHOR,EXPSIGNR,ATTNDING,SIGNDATE,SIGNEDBY,SIGNNAME,SIGNMODE
+ N COSGDATE,COSGEDBY,COSGNAME,COSGMODE,SRLINE S $P(SRLINE,"-",80)=""
+ S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1202,"I"))_";"_$G(^("E"))
+ S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1204,"I"))_";"_$G(^("E"))
+ S ATTNDING=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1209,"I"))_";"_$G(^("E"))
+ S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1501,"I"))
+ S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1502,"I"))_";"_$G(^("E"))
+ S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1503,"E"))
+ S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1504,"E"))
+ S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1505,"I"))_";"_$G(^("E"))
+ S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1507,"I"))
+ S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1508,"I"))_";"_$G(^("E"))
+ S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1509,"E"))
+ S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1510,"E"))
+ S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1511,"I"))_";"_$G(^("E"))
+ S SRY=11
+SIGBLK N SRGROOT S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA))
+ I '+SIGNDATE D  D SETCONT() Q:'SRCONT
+ .I $$STATUS^SROESUTL(SRDA)'=7 W !,"**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED-- DRAFT COPY - DRAFT COPY**"
+ I SIGNEDBY]"",(+SIGNEDBY'=+AUTHOR)  D
+ . W ?21,"Author:      ",$P(AUTHOR,";",2),!
+ I +SIGNDATE D SETCONT() Q:'SRCONT  D
+ . W ?18,"Signed by:",$S($P(SIGNMODE,";")="C":" /s/  ",1:" /es/ "),?34,$S(SIGNNAME]"":SIGNNAME,1:$P(SIGNEDBY,";",2))
+ . W !?34,SIGTITL
+ . I $L(SIGTITL)>30 W !?34
+ . E  W " "
+ . W $$DATE^SROESPR(+SIGNDATE,"MM/DD/CCYY HR:MIN")
+ . I '+$G(SRFLAG)!($E(IOST)="C") D
+ . . I $P($$BEEP^SROESPR(+SIGNEDBY),U) W !?34,"Analog Pager:  ",$P($$BEEP^SROESPR(+SIGNEDBY),U)
+ . . I $P($$BEEP^SROESPR(+SIGNEDBY),U,2) W !?34,"Digital Pager: ",$P($$BEEP^SROESPR(+SIGNEDBY),U,2)
+ I $G(^TMP("SRLQ",$J,SRDA,.05,"E"))="UNCOSIGNED" D
+ . W !?34,"**REQUIRES COSIGNATURE**",!
+ I +SIGCHRT,$P(SIGNMODE,";")="C" D SETCONT() Q:'SRCONT  D
+ . W !?2,"Marked signed on chart by:",?34,$P(SIGCHRT,";",2)
+ I +$G(SRADD) S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD))
+ I +$D(@SRGROOT@("EXTRASGNR")) D
+ . N SRI S SRI=0
+ . D SETCONT() Q:'SRCONT  W !?4,"Receipt Acknowledged By:"
+ . F  S SRI=$O(@SRGROOT@("EXTRASGNR",SRI)) Q:'SRI  D
+ . . I +$G(@SRGROOT@("EXTRASGNR",SRI,"DATE"))'>0 Q
+ . . I SRI>1 D SETCONT() Q:'SRCONT  W !
+ . . W ?29,"/es/ ",$G(@SRGROOT@("EXTRASGNR",SRI,"NAME"))
+ . . W !?34,$G(@SRGROOT@("EXTRASGNR",SRI,"TITLE"))
+ . . I $L($G(@SRGROOT@("EXTRASGNR",SRI,"TITLE")))>30 W !?34
+ . . E  W " "
+ . . W $$DATE^SROESPR($G(@SRGROOT@("EXTRASGNR",SRI,"DATE")),"MM/DD/CCYY HR:MIN")
+ . . I '+$G(SRFLAG)!($E(IOST)="C") D
+ . . . N BEEP
+ . . . S BEEP=$$BEEP^SROESPR(+$G(@SRGROOT@("EXTRASGNR",SRI,"EXTRA")))
+ . . . I +BEEP W !?34,"Analog Pager:  ",$P(BEEP,U)
+ . . . I +$P(BEEP,U,2) W !?34,"Digital Pager: ",$P(BEEP,U,2)
+ . K @SRGROOT@("EXTRASGNR")
+ I +COSGDATE,(+COSGEDBY'=+SIGNEDBY) D SETCONT() Q:'SRCONT  D
+ . W !?16,"Cosigned by:",$S($P(COSGMODE,";")="C":" /s/  ",1:" /es/ "),?34,$S(COSGNAME]"":COSGNAME,1:$P(COSGEDBY,";",2))
+ . W !?34,COSGTITL," "
+ . W $$DATE^SROESPR(+COSGDATE,"MM/DD/CCYY HR:MIN")
+ . I '+$G(SRFLAG)!($E(IOST)="C") D
+ . . I $P($$BEEP^SROESPR(+COSGEDBY),U) W !?34,"Analog Pager: ",$P($$BEEP^SROESPR(+COSGEDBY),U)
+ . . I $P($$BEEP^SROESPR(+COSGEDBY),U,2) W !?34,"Digital Pager:",$P($$BEEP^SROESPR(+COSGEDBY),U,2)
+ I +COSCHRT,$P(COSGMODE,";")="C" D SETCONT() Q:'SRCONT  D
+ . W !,"Marked cosigned on chart by:",?34,$P(COSCHRT,";",2)
+ W !
+ K SRCONT1
+AMEND ; signature blocks of amender
+ S SRY=4 D SETCONT() Q:'SRCONT
+ I +$G(@SRGROOT@(1601,"I")) D
+ . W !!?12,"Amendment Filed:",?34,$$DATE^SROESPR(@SRGROOT@(1601,"I"),"MM/DD/CCYY HR:MIN")
+ . I $G(@SRGROOT@(1603,"E"))']"" D
+ . . W !!?29 F SRI=1:1:40 W "_"
+ . . W !?29,$$SIGNAME^SROESPR(@SRGROOT@(1602,"I"))
+ . . W !?29,$$SIGTITL^SROESPR(@SRGROOT@(1602,"I"))
+ . I $G(@SRGROOT@(1604,"E"))]"" D
+ . . W !?29,"/es/",?34,@SRGROOT@(1604,"E")
+ . . W !?34,@SRGROOT@(1605,"E")
+ Q
+SETCONT(SRHEAD) ;Does footer and sets SRCONT
+ S SRCONT=$$FOOTER^SROESPR2(.SRFOOT,SRFLAG,SRPFNBR,$G(SRHEAD),$G(SRCONT1),SRDA)
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROGMTS.m

@@ -1 @@
-SROGMTS ;BIR/ADM - SURGERY HEALTH SUMMARY ; [ 08/08/01  7:12 AM ]
-        ;;3.0; Surgery ;**100,127,162**;24 Jun 93;Build 4
-        ;
-        ;** NOTICE: This routine is part of an implementation of a nationally
-        ;**         controlled procedure.  Local modifications to this routine
-        ;**         are prohibited.
-        ;
-        ; Reference to $$MOD^ICPTMOD supported by DBIA #1996
-        ; Reference to $$CPT^ICPTCOD supported by DBIA #1995
-        ;
-        Q
-HS(X)   ; return case information for a surical or non-OR case
-        ; X - case number (IEN) in file 130
-        K REC N SRCPTM,SRSG,DA,DR,DIC,DIQ,IEN,IENS,FILE,FLD,FLDS,FLDI
-        N FLDA,FLDB,FLDR,FLDRT,IEN,SRI,SRRT,SRT,SRS,SRC,SRCS
-        S SRCPTM=1
-        Q:'$D(^SRF(X,0))  S (IENS,IEN,X)=+($G(X)),U="^"
-        S:'$D(DT) DT=$$HTFM^XLFDT($H,1) S:'$D(DTIME) DTIME=300
-        S (FILE,DIC)=130,DA=+($G(X)),DIQ="REC(",DIQ(0)="IE"
-        S SRSG=$$SG(IEN),REC(130,IEN,118,"E")=$S(SRSG=0:"YES",1:""),REC(130,IEN,118,"I")=$S(SRSG=0:"Y",1:"")
-        S:+SRSG DR=".09;.04;.14;.164;.205;.22;.23;.31;10;15;17;26;27;32;34;36;39;43;49;50"
-        S:'SRSG DR=".09;.31;26;27;33;50;55;59;66;121;122;123;124;125"
-        D EN^DIQ1 S REC(130,IEN,"STATUS")=$$OS(IEN) S:+SRSG REC(130,IEN,"VERIFIED")=$S($G(REC(130,IEN,43,"I"))'="Y":"(Unverified)",1:"")
-        S SRM=$G(REC(130,IEN,27,"I")) I SRM>0 D CPT(SRM,$P($G(^SRF(IEN,0)),"^",9),130,27)
-        D DICT^SROGMTS0,SUB,SPD
-        S:$D(REC(130,IEN,32)) REC(130,IEN,32,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,32,"E")))
-        S:$D(REC(130,IEN,33)) REC(130,IEN,33,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,33,"E")))
-        S:$D(REC(130,IEN,34)) REC(130,IEN,34,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,34,"E")))
-        S:$D(REC(130,IEN,.04)) REC(130,IEN,.04,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,.04,"E")))
-        S:$D(REC(130,IEN,125)) REC(130,IEN,125,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,125,"E")))
-        I $L($G(REC(130,IEN,33,"S"))) D
-        . S:'$L($G(REC(130,IEN,66,"E"))) REC(130,IEN,33,"S")=$G(REC(130,IEN,33,"S"))_" (Unknown)"
-        . S:$L($G(REC(130,IEN,66,"E"))) REC(130,IEN,33,"S")=$G(REC(130,IEN,33,"S"))_" (ICD "_$G(REC(130,IEN,66,"E"))_")"
-        S:+($G(REC(130,IEN,.09,"I")))>0 REC(130,IEN,.09,"S")=$$ED^SROGMTS0($G(REC(130,IEN,.09,"I")))
-        S:+($G(REC(130,IEN,15,"I")))>0 REC(130,IEN,15,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,15,"I")))
-        S:+($G(REC(130,IEN,39,"I"))) REC(130,IEN,39,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,39,"I")))
-        S:+SRSG REC(130,IEN,"LAB")=$S($O(REC(130,IEN,49,0))>0:"Yes",1:"")
-        I 'SRSG D:+($O(REC(130,IEN,55,0)))>0 WP(IEN,55,58) D:+($O(REC(130,IEN,59,0)))>0 WP(IEN,59,58)
-        Q
-ED(X)   ; external date
-        S X=$G(X) Q:'$L(X) ""
-        S X=$TR($$FMTE^XLFDT(X,"5DZ"),"@"," ")
-        Q X
-EDT(X)  ; external date and time
-        S X=$G(X) Q:'$L(X) ""
-        S X=$TR($$FMTE^XLFDT(X,"2ZM"),"@"," ")
-        Q X
-WP(X,Y,Z)       ;
-        N SRI,SRF,SRW,SRGI,DIWF,DIWL,DIWR
-        S SRI=+($G(X)) Q:SRI=0!('$D(REC(130,SRI)))
-        S SRF=+($G(Y)) Q:SRF=0!('$D(REC(130,SRI,SRF)))
-        S SRW=+($G(Z)) Q:SRW'>0!(SRW>79)
-        Q:+($O(REC(130,SRI,SRF,0)))'>0
-        K ^UTILITY($J,"W") S DIWF="C"_SRW,DIWL=0,DIWR=0,SRGI=0
-        F  S SRGI=$O(REC(130,SRI,SRF,SRGI)) Q:+SRGI=0  D
-        . S X=$G(REC(130,SRI,SRF,SRGI))
-        . D ^DIWP
-        S SRGI=0 F  S SRGI=$O(^UTILITY($J,"W",0,SRGI)) Q:+SRGI=0  D
-        . S REC(130,SRI,SRF,"S",SRGI)=$G(^UTILITY($J,"W",0,SRGI,0))
-        . S REC(130,SRI,SRF,"S",0)=$G(REC(130,SRI,SRF,"S",0))+1
-        K ^UTILITY($J,"W")
-        Q
-OS(X)   ; Obtains status for OR procedures
-        N SRN S SRN=+($G(X)) S X="" I $G(REC(130,SRN,118,"I"))="Y" D  Q X
-        . S:+($G(REC(130,SRN,122,"I")))>0 X="(Completed)"
-        . S:+($G(REC(130,SRN,121,"I")))>0&(+($G(REC(130,SRN,122,"I")))'>0) X="Incomplete"
-        . S:X="" X="Unknown"
-        I +($G(REC(130,SRN,17,"I")))>0 D  Q X
-        . S X=$S(+($G(REC(130,SRN,.205,"I")))>0:"(Aborted)",1:"Cancelled")
-        I +($G(REC(130,SRN,.23,"I")))>0 S X="(Completed)" Q X
-        I +($G(REC(130,SRN,.22,"I")))>0 S X="Incomplete" Q X
-        I +($G(REC(130,SRN,10,"I")))>0 S X="Scheduled" Q X
-        I +($G(REC(130,SRN,36,"I")))>0,+($G(REC(130,SRN,.22,"I")))'>0 S X="Requested" Q X
-        S X="Unknown"
-        Q X
-SUB     ;
-        N DA,DR,DIC,DIQ,IENS,FILE,FLD,FLDS,FLDI,FLDA,FLDB,FLDR,FLDRT,SRM,SRC,SRI,SRJ,STXT,SNAM,SCOD,SUB
-        I +SRSG D
-        . ;
-        . ; ^SRF(DO,14,I)                .72  Other Preop Diag    14;0  130.17
-        . ; $P(^SRF(DO,14,I,0),U)        .01  Other Preop Diag     0;1  Text
-        . ;
-        . S DA=IEN,(FILE,DIC)=130,SUB=130.17,DR=.72,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
-        . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),14,SRI)) Q:+SRI=0  D
-        . . S DA(SUB)=SRI
-        . . D EN^DIQ1
-        . . S REC(130,IEN,130.17,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.17,SRI,.01,"E")))
-        . ;
-        . ; ^SRF(DO,15,I)                .74  Other Postop Diags  15;0  130.18
-        . ; $P(^SRF(DO,15,I,0),U)        .01  Other Postop Diags   0;1  Text
-        . ;
-        . S DA=IEN,(FILE,DIC)=130,SUB=130.18,DR=.74,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
-        . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),15,SRI)) Q:+SRI=0  D
-        . . S DA(SUB)=SRI
-        . . D EN^DIQ1
-        . . S REC(130,IEN,130.18,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.18,SRI,.01,"E")))
-        ;
-        ; ^SRF(SRN,"OPMOD",I)           28  Pri Pro CPT Mod  OPMOD;0  130.028
-        ; $P(^SRF(SRN,"OPMOD",I,0),U)  .01  Pri Pro CPT Mod      0;1  Ptr 81.3
-        ;
-        I SRCPTM D
-        . S DA=IEN,(FILE,DIC)=130,SUB=130.028,DR=28,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
-        . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),"OPMOD",SRI)) Q:+SRI=0  D
-        . . S DA(SUB)=SRI
-        . . D EN^DIQ1
-        . . S SRM=+($G(REC(130,+($G(IEN)),SUB,+($G(SRI)),.01,"I"))) I SRM>0 D MOD(SRM,FILE,SUB)
-        ;
-        ; ^SRF(DO,13,I)                .42  Other Proc          13;0  130.16
-        ; $P(^SRF(DO,13,I,0),U)        .01  Other Proc           0;1  Text      
-        ; $P(^SRF(DO,13,I,2),U)          3  Other Proc CPT Code  2;1  Ptr 81
-        ;
-        S DA=IEN,(FILE,DIC)=130,SUB=130.16,DR=.42,DR(SUB)=".01;3",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
-        K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),13,SRI)) Q:+SRI=0  D
-        . S DA(SUB)=SRI
-        . D EN^DIQ1 S SRM=+($G(REC(130,IEN,130.16,SRI,3,"I")))
-        . S:SRM>0 REC(130,IEN,130.16,SRI,3,"N")=$P($$CPT^ICPTCOD(+SRM,$P($G(^SRF(IEN,0)),"^",9)),"^",3)
-        . N SRT,SRS,SRC S SRM=$G(REC(130,IEN,130.16,SRI,3,"I")) I SRM>0 D
-        . . S SRC=$$CPT^ICPTCOD(SRM,$P($G(^SRF(IEN,0)),"^",9)),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3))
-        . . S REC(130,IEN,130.16,SRI,3,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3)
-        . . S SRC=$P(SRC,"^",2)
-        . . S SRT=$$EN2^SROGMTS0($G(REC(130,IEN,130.16,SRI,.01,"E")))
-        . . S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_$$EN2^SROGMTS0(SRS)
-        . . S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")"
-        . . S REC(130,IEN,130.16,SRI,3,"N")=SRS
-        . . S REC(130,IEN,130.16,SRI,.01,"S")=SRT
-        . . S REC(130,IEN,130.16,SRI,3,"S")=SRCS
-        . ;
-        . ;     ^SRF(8,13,2,"MOD",0)       4  Oth Proc CPT Mod   MOD;0  130.164
-        . ;     ^SRF(8,13,2,"MOD",1,0)   .01  Oth Proc CPT Mod     0;1  Ptr 81.3
-        . ;
-        . I SRCPTM D
-        . . N SRJ S SRJ=0 F  S SRJ=$O(^SRF(+($G(IEN)),13,SRI,"MOD",SRJ)) Q:+SRJ=0  D
-        . . . N DA,FILE,DIC,SUB,DR,DIQ S DA=IEN,DR=.42,FILE=130,SUB=130.16,DR(SUB)="4",DA(SUB)=SRI,SUB=130.164,DR(SUB)=".01",DA(SUB)=SRJ,DIC=130,DIQ="REC(130,"_IEN_",130.16,"_SRI_",",DIQ(0)="IE"
-        . . . D EN^DIQ1
-        . . . S SRM=+($G(REC(130,IEN,130.16,SRI,130.164,SRJ,.01,"I")))
-        . . . I SRM>0 N SRMOD1 D
-        . . . . S SRMOD1=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9))
-        . . . . S SRC=$P(SRMOD1,"^",2)
-        . . . . S SRS=$P(SRMOD1,"^",3)
-        . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MID")=SRC
-        . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MOD")=SRS
-        . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"X")=SRC_"^"_SRS
-        . . . . S SRT=$$EN2^SROGMTS0(SRS) S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")"
-        . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"S")=SRT
-        . . . K REC(130,IEN,130.16,SRI,130)
-        Q
-SG(X)   ; Surgical (Operative) Record
-        S X=$$GET1^DIQ(130,+($G(X)),118,"I") S X=$S(X["Y":0,1:1) Q X
-CPT(SRM,SRDOO,SRFIL,SRFLD)      ;Set CPT code into REC array
-        S SRC=$$CPT^ICPTCOD(SRM,SRDOO),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3))
-        S REC(SRFIL,IEN,SRFLD,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3)
-        S SRC=$P(SRC,"^",2),SRT=$$EN2^SROGMTS0($G(REC(130,IEN,26,"E")))
-        S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_SRS
-        S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")"
-        S REC(SRFIL,IEN,SRFLD,"N")=SRS
-        S:SRFIL=130 REC(130,IEN,26,"S")=SRT
-        S REC(SRFIL,IEN,SRFLD,"S")=SRT
-        S REC(SRFIL,IEN,SRFLD,"S")=SRCS
-        Q
-MOD(SRM,SRFIL,SUB)      ;Set CPT Modifier into REC array
-        S SRMOD=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9))
-        S SRC=$P(SRMOD,"^",2)
-        S SRS=$P(SRMOD,"^",3)
-        S REC(SRFIL,IEN,SUB,SRI,.01,"MID")=SRC
-        S REC(SRFIL,IEN,SUB,SRI,.01,"MOD")=SRS
-        S SRT=$$EN2^SROGMTS0(SRS)
-        S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")"
-        S REC(SRFIL,IEN,SUB,SRI,.01,"S")=SRT
-        Q
-SPD     ;Obtain Surgery Procedure/Diagnosis Code File entry
-        S (FILE,DIC)=136,DA=+($G(IEN)),DIQ="REC(",DIQ(0)="IE"
-        S DR=".01;.02;.03;10"
-        D EN^DIQ1
-        Q:'+$G(REC(FILE,IEN,10,"I"))
-        S SRM=+$G(REC(FILE,IEN,.02,"I"))
-        Q:'(SRM>0)  D CPT(SRM,$P($G(^SRF(IEN,0)),"^",9),FILE,.02)
-        S SUB=136.01,DR=1,DR(SUB)=".01",DIQ="REC(136,"_IEN_","
-        K REC(FILE,IEN,SUB) S SRI=0 F  S SRI=$O(^SRO(FILE,(+$G(IEN)),DR,SRI))  Q:+SRI=0  D
-        .S DA(SUB)=SRI
-        .D EN^DIQ1
-        .S SRM=REC(FILE,IEN,SUB,SRI,.01,"I") I SRM>0 D MOD(SRM,FILE,SUB)
-        N DA S DA=IEN,SUB=136.011,DR=11,DR(SUB)=".01;1"
-        K REC(FILE,IEN,SUB) S SRI=0 F  S SRI=$O(^SRO(FILE,(+$G(IEN)),DR,SRI)) Q:+SRI=0  D
-        . S DA(SUB)=SRI
-        . D EN^DIQ1
-        S $P(REC(130,IEN,26,"S"),"-",2)=" "_REC(FILE,IEN,.02,"S")
-        K REC(130,IEN,130.028) M REC(130,IEN,130.028)=REC(FILE,IEN,136.01)
-        Q
+SROGMTS ;BIR/ADM - SURGERY HEALTH SUMMARY ; [ 08/08/01  7:12 AM ]
+ ;;3.0; Surgery ;**100,127**;24 Jun 93
+ ;
+ ;** NOTICE: This routine is part of an implementation of a nationally
+ ;**         controlled procedure.  Local modifications to this routine
+ ;**         are prohibited.
+ ;
+ ; Reference to $$MOD^ICPTMOD supported by DBIA #1996
+ ; Reference to $$CPT^ICPTCOD supported by DBIA #1995
+ ;
+ Q
+HS(X) ; return case information for a surical or non-OR case
+ ; X - case number (IEN) in file 130
+ K REC N SRCPTM,SRSG,DA,DR,DIC,DIQ,IEN,IENS,FILE,FLD,FLDS,FLDI
+ N FLDA,FLDB,FLDR,FLDRT,IEN,SRI,SRRT,SRT,SRS,SRC,SRCS
+ S SRCPTM=1
+ Q:'$D(^SRF(X,0))  S (IENS,IEN,X)=+($G(X)),U="^"
+ S:'$D(DT) DT=$$HTFM^XLFDT($H,1) S:'$D(DTIME) DTIME=300
+ S (FILE,DIC)=130,DA=+($G(X)),DIQ="REC(",DIQ(0)="IE"
+ S SRSG=$$SG(IEN),REC(130,IEN,118,"E")=$S(SRSG=0:"YES",1:""),REC(130,IEN,118,"I")=$S(SRSG=0:"Y",1:"")
+ S:+SRSG DR=".09;.04;.14;.164;.205;.22;.23;.31;10;15;17;26;27;32;34;36;39;43;49;50"
+ S:'SRSG DR=".09;.31;26;27;33;50;55;59;66;121;122;123;124;125"
+ D EN^DIQ1 S REC(130,IEN,"STATUS")=$$OS(IEN) S:+SRSG REC(130,IEN,"VERIFIED")=$S($G(REC(130,IEN,43,"I"))'="Y":"(Unverified)",1:"")
+ S SRM=$G(REC(130,IEN,27,"I")) I SRM>0 D
+ . S SRC=$$CPT^ICPTCOD(SRM,$P($G(^SRF(IEN,0)),"^",9)),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3))
+ . S REC(130,IEN,27,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3)
+ . S SRC=$P(SRC,"^",2),SRT=$$EN2^SROGMTS0($G(REC(130,IEN,26,"E")))
+ . S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_SRS
+ . S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")"
+ . S REC(130,IEN,27,"N")=SRS
+ . S (REC(130,IEN,26,"S"),REC(130,IEN,27,"S"))=SRT
+ . S REC(130,IEN,27,"S")=SRCS
+ D DICT^SROGMTS0,SUB
+ S:$D(REC(130,IEN,32)) REC(130,IEN,32,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,32,"E")))
+ S:$D(REC(130,IEN,33)) REC(130,IEN,33,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,33,"E")))
+ S:$D(REC(130,IEN,34)) REC(130,IEN,34,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,34,"E")))
+ S:$D(REC(130,IEN,.04)) REC(130,IEN,.04,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,.04,"E")))
+ S:$D(REC(130,IEN,125)) REC(130,IEN,125,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,125,"E")))
+ I $L($G(REC(130,IEN,33,"S"))) D
+ . S:'$L($G(REC(130,IEN,66,"E"))) REC(130,IEN,33,"S")=$G(REC(130,IEN,33,"S"))_" (Unknown)"
+ . S:$L($G(REC(130,IEN,66,"E"))) REC(130,IEN,33,"S")=$G(REC(130,IEN,33,"S"))_" (ICD "_$G(REC(130,IEN,66,"E"))_")"
+ S:+($G(REC(130,IEN,.09,"I")))>0 REC(130,IEN,.09,"S")=$$ED^SROGMTS0($G(REC(130,IEN,.09,"I")))
+ S:+($G(REC(130,IEN,15,"I")))>0 REC(130,IEN,15,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,15,"I")))
+ S:+($G(REC(130,IEN,39,"I"))) REC(130,IEN,39,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,39,"I")))
+ S:+SRSG REC(130,IEN,"LAB")=$S($O(REC(130,IEN,49,0))>0:"Yes",1:"")
+ I 'SRSG D:+($O(REC(130,IEN,55,0)))>0 WP(IEN,55,58) D:+($O(REC(130,IEN,59,0)))>0 WP(IEN,59,58)
+ Q
+ED(X) ; external date
+ S X=$G(X) Q:'$L(X) ""
+ S X=$TR($$FMTE^XLFDT(X,"5DZ"),"@"," ")
+ Q X
+EDT(X) ; external date and time
+ S X=$G(X) Q:'$L(X) ""
+ S X=$TR($$FMTE^XLFDT(X,"2ZM"),"@"," ")
+ Q X
+WP(X,Y,Z) ;
+ N SRI,SRF,SRW,SRGI,DIWF,DIWL,DIWR
+ S SRI=+($G(X)) Q:SRI=0!('$D(REC(130,SRI)))
+ S SRF=+($G(Y)) Q:SRF=0!('$D(REC(130,SRI,SRF)))
+ S SRW=+($G(Z)) Q:SRW'>0!(SRW>79)
+ Q:+($O(REC(130,SRI,SRF,0)))'>0
+ K ^UTILITY($J,"W") S DIWF="C"_SRW,DIWL=0,DIWR=0,SRGI=0
+ F  S SRGI=$O(REC(130,SRI,SRF,SRGI)) Q:+SRGI=0  D
+ . S X=$G(REC(130,SRI,SRF,SRGI))
+ . D ^DIWP
+ S SRGI=0 F  S SRGI=$O(^UTILITY($J,"W",0,SRGI)) Q:+SRGI=0  D
+ . S REC(130,SRI,SRF,"S",SRGI)=$G(^UTILITY($J,"W",0,SRGI,0))
+ . S REC(130,SRI,SRF,"S",0)=$G(REC(130,SRI,SRF,"S",0))+1
+ K ^UTILITY($J,"W")
+ Q
+OS(X) ; Obtains status for OR procedures
+ N SRN S SRN=+($G(X)) S X="" I $G(REC(130,SRN,118,"I"))="Y" D  Q X
+ . S:+($G(REC(130,SRN,122,"I")))>0 X="(Completed)"
+ . S:+($G(REC(130,SRN,121,"I")))>0&(+($G(REC(130,SRN,122,"I")))'>0) X="Incomplete"
+ . S:X="" X="Unknown"
+ I +($G(REC(130,SRN,17,"I")))>0 D  Q X
+ . S X=$S(+($G(REC(130,SRN,.205,"I")))>0:"(Aborted)",1:"Cancelled")
+ I +($G(REC(130,SRN,.23,"I")))>0 S X="(Completed)" Q X
+ I +($G(REC(130,SRN,.22,"I")))>0 S X="Incomplete" Q X
+ I +($G(REC(130,SRN,10,"I")))>0 S X="Scheduled" Q X
+ I +($G(REC(130,SRN,36,"I")))>0,+($G(REC(130,SRN,.22,"I")))'>0 S X="Requested" Q X
+ S X="Unknown"
+ Q X
+SUB ;
+ N DA,DR,DIC,DIQ,IENS,FILE,FLD,FLDS,FLDI,FLDA,FLDB,FLDR,FLDRT,SRM,SRC,SRI,SRJ,STXT,SNAM,SCOD,SUB
+ I +SRSG D
+ . ;
+ . ; ^SRF(DO,14,I)                .72  Other Preop Diag    14;0  130.17
+ . ; $P(^SRF(DO,14,I,0),U)        .01  Other Preop Diag     0;1  Text
+ . ;
+ . S DA=IEN,(FILE,DIC)=130,SUB=130.17,DR=.72,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
+ . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),14,SRI)) Q:+SRI=0  D
+ . . S DA(SUB)=SRI
+ . . D EN^DIQ1
+ . . S REC(130,IEN,130.17,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.17,SRI,.01,"E")))
+ . ;
+ . ; ^SRF(DO,15,I)                .74  Other Postop Diags  15;0  130.18
+ . ; $P(^SRF(DO,15,I,0),U)        .01  Other Postop Diags   0;1  Text
+ . ;
+ . S DA=IEN,(FILE,DIC)=130,SUB=130.18,DR=.74,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
+ . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),15,SRI)) Q:+SRI=0  D
+ . . S DA(SUB)=SRI
+ . . D EN^DIQ1
+ . . S REC(130,IEN,130.18,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.18,SRI,.01,"E")))
+ ;
+ ; ^SRF(SRN,"OPMOD",I)           28  Pri Pro CPT Mod  OPMOD;0  130.028
+ ; $P(^SRF(SRN,"OPMOD",I,0),U)  .01  Pri Pro CPT Mod      0;1  Ptr 81.3
+ ;
+ I SRCPTM D
+ . S DA=IEN,(FILE,DIC)=130,SUB=130.028,DR=28,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
+ . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),"OPMOD",SRI)) Q:+SRI=0  D
+ . . S DA(SUB)=SRI
+ . . D EN^DIQ1
+ . . S SRM=+($G(REC(130,+($G(IEN)),SUB,+($G(SRI)),.01,"I")))
+ . . I SRM>0 N SRMOD D
+ . . . S SRMOD=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9))
+ . . . S SRC=$P(SRMOD,"^",2)
+ . . . S SRS=$P(SRMOD,"^",3)
+ . . . S REC(130,IEN,SUB,SRI,.01,"MID")=SRC
+ . . . S REC(130,IEN,SUB,SRI,.01,"MOD")=SRS
+ . . . S SRT=$$EN2^SROGMTS0(SRS)
+ . . . S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")"
+ . . . S REC(130,IEN,SUB,SRI,.01,"S")=SRT
+ ;
+ ; ^SRF(DO,13,I)                .42  Other Proc          13;0  130.16
+ ; $P(^SRF(DO,13,I,0),U)        .01  Other Proc           0;1  Text      
+ ; $P(^SRF(DO,13,I,2),U)          3  Other Proc CPT Code  2;1  Ptr 81
+ ;
+ S DA=IEN,(FILE,DIC)=130,SUB=130.16,DR=.42,DR(SUB)=".01;3",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
+ K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),13,SRI)) Q:+SRI=0  D
+ . S DA(SUB)=SRI
+ . D EN^DIQ1 S SRM=+($G(REC(130,IEN,130.16,SRI,3,"I")))
+ . S:SRM>0 REC(130,IEN,130.16,SRI,3,"N")=$P($$CPT^ICPTCOD(+SRM,$P($G(^SRF(IEN,0)),"^",9)),"^",3)
+ . N SRT,SRS,SRC S SRM=$G(REC(130,IEN,130.16,SRI,3,"I")) I SRM>0 D
+ . . S SRC=$$CPT^ICPTCOD(SRM,$P($G(^SRF(IEN,0)),"^",9)),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3))
+ . . S REC(130,IEN,130.16,SRI,3,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3)
+ . . S SRC=$P(SRC,"^",2)
+ . . S SRT=$$EN2^SROGMTS0($G(REC(130,IEN,130.16,SRI,.01,"E")))
+ . . S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_$$EN2^SROGMTS0(SRS)
+ . . S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")"
+ . . S REC(130,IEN,130.16,SRI,3,"N")=SRS
+ . . S REC(130,IEN,130.16,SRI,.01,"S")=SRT
+ . . S REC(130,IEN,130.16,SRI,3,"S")=SRCS
+ . ;
+ . ;     ^SRF(8,13,2,"MOD",0)       4  Oth Proc CPT Mod   MOD;0  130.164
+ . ;     ^SRF(8,13,2,"MOD",1,0)   .01  Oth Proc CPT Mod     0;1  Ptr 81.3
+ . ;
+ . I SRCPTM D
+ . . N SRJ S SRJ=0 F  S SRJ=$O(^SRF(+($G(IEN)),13,SRI,"MOD",SRJ)) Q:+SRJ=0  D
+ . . . N DA,FILE,DIC,SUB,DR,DIQ S DA=IEN,DR=.42,FILE=130,SUB=130.16,DR(SUB)="4",DA(SUB)=SRI,SUB=130.164,DR(SUB)=".01",DA(SUB)=SRJ,DIC=130,DIQ="REC(130,"_IEN_",130.16,"_SRI_",",DIQ(0)="IE"
+ . . . D EN^DIQ1
+ . . . S SRM=+($G(REC(130,IEN,130.16,SRI,130.164,SRJ,.01,"I")))
+ . . . I SRM>0 N SRMOD1 D
+ . . . . S SRMOD1=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9))
+ . . . . S SRC=$P(SRMOD1,"^",2)
+ . . . . S SRS=$P(SRMOD1,"^",3)
+ . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MID")=SRC
+ . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MOD")=SRS
+ . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"X")=SRC_"^"_SRS
+ . . . . S SRT=$$EN2^SROGMTS0(SRS) S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")"
+ . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"S")=SRT
+ . . . K REC(130,IEN,130.16,SRI,130)
+ Q
+SG(X) ; Surgical (Operative) Record
+ S X=$$GET1^DIQ(130,+($G(X)),118,"I") S X=$S(X["Y":0,1:1) Q X

WorldVistAEHR/trunk/r/SURGERY-SR/SROMED.m

@@ -1 @@
-SROMED  ;BIR/MAM - ENTER/EDIT MEDICATIONS ;01/30/08
-        ;;3.0; Surgery ;**21,44,79,100,151,166**;24 Jun 93;Build 7
-        ;
-        I '$D(^XUSEC("SROEDIT",DUZ))&'$D(^XUSEC("SROANES",DUZ)) W !!!,$C(7),"You must hold the SROEDIT key or the SROANES key to use this option !",! Q
-        D ^SROLOCK G:SROLOCK END Q:'$D(SRTN)
-        N SRLCK S SRLCK=$$LOCK^SROUTL(SRTN) I 'SRLCK G END
-START   S SRQ=0,SRSMED=1 G:SRTN<1 END W @IOF S SRF=0 R !!,"ENTER MEDICATION/DOSE(MG)/ROUTE/TIME: ",M:DTIME S:'$T M="^" G:M=""!(M="^") END S SRM=$P(M,"/",1),SRD=$P(M,"/",2),SRR=$P(M,"/",3),SRT=$P(M,"/",4) W !!
-        I M="?" W !!,"Enter the medication, dose, route and time, separated by slashes (/).",!,"The Medication and time MUST be included, however the route and dose",!,"can be omitted.  i.e. 'MEDICATION/DOSE//TIME' will omit the route."
-        I M="?" W !!,"Enter '??' to get a list of available drugs.",! D RET G:SRQ END G START
-        I M?.E1C.E W !!,"Your answer has a control character in it, please re-type it.",! D RET G:SRQ END G START
-        S (X,SRMM)=SRM D
-        .N SRDIC,SRD S SRDIC=50,SRDIC(0)="EMQSZ",SRD="B^C" D MIX^PSSDI(50,"SR",.SRDIC,SRD,X,,DT)
-        S SRM=$S(Y<0:"",1:$P(Y,"^",2))
-        I SRM="",SRMM'["?" W !!,"The Drug '",SRMM,"' does not exist in your Drug file.  Please re-enter. " D RET G:SRQ END G START
-        I SRMM="??" D RET G:SRQ END G START
-        D TIME G:'$D(SRT) FLAG S X=SRT D FIELD^DID(130,.204,"","INPUT TRANSFORM","SRX") S SRX=SRX("INPUT TRANSFORM") X:SRT'="" SRX S SRT=$S(X="":SRT,1:X) D ROUTE G:'$D(SRR) FLAG D DOSE G:'$D(SRD) FLAG
-FLAG    S SRF=$S('$D(SRT)!('$D(SRD))!('$D(SRR)):0,1:1) I 'SRF W !!!,"NO ACTION TAKEN",! H 2 G END
-DIE     S DA=SRTN,DIE=130,DR=".375///"_SRM,DR(2,130.33)="1///"_SRT,DR(3,130.34)="1///"_SRD_";4///"_SRR D ^DIE W !!!,"MEDICATION ENTERED ...." K DR H 2
-        G START
-END     W @IOF D ^SRSKILL D:$G(SRLCK) UNLOCK^SROUTL(SRTN)
-        Q
-RET     R !!,"Press RETURN to Continue.   ",Z:DTIME S:'$T Z="^" S:Z="^" SRQ=1 Q
-        Q
-ROUTE   ; check for route of administration
-        Q:SRR=""  N SRHELP,SRVALUE D CHK^DIE(130.34,4,"E",SRR,.SRVALUE) I SRVALUE'="^" S SRR=SRVALUE Q
-        D HELP^DIE(130.34,"",4,"S","SRHELP(1)")
-        W !!,"Route entered is not one of the available choices.",!,"Please enter medication route again.",!!
-        I $G(SRHELP(1,"DIHELP")) F I=1:1:SRHELP(1,"DIHELP") W SRHELP(1,"DIHELP",I),!
-        S DIR("A")="Enter ROUTE",DIR(0)="130.34,4O" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRR="" Q
-        S SRR=$P(Y,"^")
-        Q
-TIME    ; check for time
-        K %DT S X=SRT,%DT="R" D ^%DT I Y>0 Q
-         W:SRT="" !!,"A time MUST be entered !"
-        I '(SRT?1N!(SRT?2N&(SRT<13))!(SRT?4N)!(SRT?3N)!(SRT?2N1":"2N)!(SRT?1N1":"2N))!(+SRT>2400)!(SRT="") S SRF=1
-        I SRF W !!,?5,"Enter the time in one of the following formats:",!,?9,"7:45, 0745, 745, 07:45, Date@Time, or NOW",!!,?5,"Time is required."
-T1      S:SRT="" SRF=1 Q:SRF=0  R !!,"Enter Time: ",SRT:DTIME S:'$T!(SRT="") SRT="^" G:SRT["^" END W:SRT["?" !!,"Enter a time in the format above, or RETURN to bypass.  An '^' will exit this option." G:SRT["?" T1 S SRF=0 G TIME
-        Q
-DOSE    ; check dosage
-        Q:SRD=""  I $L(SRD)>15!($L(SRD)<1) W !!,"Dosage entered incorrectly." S SRF=1
-        I SRD="?" W !!,"Dosage must be 1 to 15 characters in length, i.e. 15 mg." S SRF=1
-D1      I SRF=1 R !!,"ENTER DOSE: ",SRD1:DTIME S:'$T SRD1="^" K:SRD1["^" SRD Q:SRD1["^"  W:SRD1["?" !!,"Dosage must be 1 to 15 characters in length" G:SRD1["?" D1 S SRD=SRD1,SRF=0 G DOSE
-        Q
-SCR(SRFL,SRPK)  ; screening for fields point to the DRUG file (#50)
-        N SRDT,SRN0,SRNODE,SROK,SRY S SROK=0,SRY=+Y K ^TMP($J,"SR")
-        I $G(SRFL)=1 S SRTN=$S($G(SRTN):SRTN,1:DA),SRN0=$G(^SRF(SRTN,0)),SRDT=$S($P(SRN0,"^",9):$P($P(SRN0,"^",9),"."),1:DT)
-        D DATA^PSS50(SRY,,$S($G(SRFL):SRDT,1:""),,,"SR")
-        I SRPK="S" D  Q SROK
-        .S SRNODE=$P($G(^TMP($J,"SR",SRY,63)),"^") K ^TMP($J,"SR") I SRNODE["S" S SROK=1
-        S SROK=$S($P($G(^TMP($J,"SR",0)),"^")=-1:0,1:1) K ^TMP($J,"SR") Q SROK
+SROMED ;B'HAM ISC/MAM - ENTER/EDIT MEDICATIONS ; [ 01/30/01  12:22 AM ]
+ ;;3.0; Surgery ;**21,44,79,100,151**;24 Jun 93
+ ;
+ ; Reference to ^PSDRUG supported by DBIA #221
+ ;
+ I '$D(^XUSEC("SROEDIT",DUZ))&'$D(^XUSEC("SROANES",DUZ)) W !!!,$C(7),"You must hold the SROEDIT key or the SROANES key to use this option !",! Q
+ D ^SROLOCK G:SROLOCK END Q:'$D(SRTN)
+ N SRLCK S SRLCK=$$LOCK^SROUTL(SRTN) I 'SRLCK G END
+START S SRQ=0,SRSMED=1 G:SRTN<1 END W @IOF S SRF=0 R !!,"ENTER MEDICATION/DOSE(MG)/ROUTE/TIME: ",M:DTIME S:'$T M="^" G:M=""!(M="^") END S SRM=$P(M,"/",1),SRD=$P(M,"/",2),SRR=$P(M,"/",3),SRT=$P(M,"/",4) W !!
+ I M="?" W !!,"Enter the medication, dose, route and time, separated by slashes (/).",!,"The Medication and time MUST be included, however the route and dose",!,"can be omitted.  i.e. 'MEDICATION/DOSE//TIME' will omit the route."
+ I M="?" W !!,"Enter '??' to get a list of available drugs.",! D RET G:SRQ END G START
+ I M?.E1C.E W !!,"Your answer has a control character in it, please re-type it.",! D RET G:SRQ END G START
+ S (X,SRMM)=SRM D
+ .I $L($T(SCREEN^PSSDI)) N SRTEST S SRTEST=50,SRTEST(0)="EQSZ" D DIC^PSSDI(50,"SR",.SRTEST,X,,DT) Q  ;call PSSDI if PSS*1*104 is released
+ .S DIC="^PSDRUG(",DIC(0)="QEZM",DIC("S")="I $S('$G(^PSDRUG(Y,""I"")):1,DT'>^(""I""):1,1:0)" D ^DIC K DIC
+ S SRM=$S(Y<0:"",1:$P(Y,"^",2))
+ I SRM="",SRMM'["?" W !!,"The Drug '",SRMM,"' does not exist in your Drug file.  Please re-enter. " D RET G:SRQ END G START
+ I SRMM="??" D RET G:SRQ END G START
+ D TIME G:'$D(SRT) FLAG S X=SRT D FIELD^DID(130,.204,"","INPUT TRANSFORM","SRX") S SRX=SRX("INPUT TRANSFORM") X:SRT'="" SRX S SRT=$S(X="":SRT,1:X) D ROUTE G:'$D(SRR) FLAG D DOSE G:'$D(SRD) FLAG
+FLAG S SRF=$S('$D(SRT)!('$D(SRD))!('$D(SRR)):0,1:1) I 'SRF W !!!,"NO ACTION TAKEN",! H 2 G END
+DIE S DA=SRTN,DIE=130,DR=".375///"_SRM,DR(2,130.33)="1///"_SRT,DR(3,130.34)="1///"_SRD_";4///"_SRR D ^DIE W !!!,"MEDICATION ENTERED ...." K DR H 2
+ G START
+END W @IOF D ^SRSKILL D:$G(SRLCK) UNLOCK^SROUTL(SRTN)
+ Q
+RET R !!,"Press RETURN to Continue.   ",Z:DTIME S:'$T Z="^" S:Z="^" SRQ=1 Q
+ Q
+ROUTE ; check for route of administration
+ Q:SRR=""  N SRHELP,SRVALUE D CHK^DIE(130.34,4,"E",SRR,.SRVALUE) I SRVALUE'="^" S SRR=SRVALUE Q
+ D HELP^DIE(130.34,"",4,"S","SRHELP(1)")
+ W !!,"Route entered is not one of the available choices.",!,"Please enter medication route again.",!!
+ I $G(SRHELP(1,"DIHELP")) F I=1:1:SRHELP(1,"DIHELP") W SRHELP(1,"DIHELP",I),!
+ S DIR("A")="Enter ROUTE",DIR(0)="130.34,4O" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRR="" Q
+ S SRR=$P(Y,"^")
+ Q
+TIME ; check for time
+ K %DT S X=SRT,%DT="R" D ^%DT I Y>0 Q
+  W:SRT="" !!,"A time MUST be entered !"
+ I '(SRT?1N!(SRT?2N&(SRT<13))!(SRT?4N)!(SRT?3N)!(SRT?2N1":"2N)!(SRT?1N1":"2N))!(+SRT>2400)!(SRT="") S SRF=1
+ I SRF W !!,?5,"Enter the time in one of the following formats:",!,?9,"7:45, 0745, 745, 07:45, Date@Time, or NOW",!!,?5,"Time is required."
+T1 S:SRT="" SRF=1 Q:SRF=0  R !!,"Enter Time: ",SRT:DTIME S:'$T!(SRT="") SRT="^" G:SRT["^" END W:SRT["?" !!,"Enter a time in the format above, or RETURN to bypass.  An '^' will exit this option." G:SRT["?" T1 S SRF=0 G TIME
+ Q
+DOSE ; check dosage
+ Q:SRD=""  I $L(SRD)>15!($L(SRD)<1) W !!,"Dosage entered incorrectly." S SRF=1
+ I SRD="?" W !!,"Dosage must be 1 to 15 characters in length, i.e. 15 mg." S SRF=1
+D1 I SRF=1 R !!,"ENTER DOSE: ",SRD1:DTIME S:'$T SRD1="^" K:SRD1["^" SRD Q:SRD1["^"  W:SRD1["?" !!,"Dosage must be 1 to 15 characters in length" G:SRD1["?" D1 S SRD=SRD1,SRF=0 G DOSE
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROWL.m

@@ -1 @@
-SROWL   ;B'HAM ISC/MAM - ENTER PATIENT ON WAITING LIST ; 4/18/07 11:55am
-        ;;3.0;Surgery;**58,119,162**;24 Jun 93;Build 4
-        ;
-ENTER   ; enter a patient on the waiting list
-        S SRSOUT=0 W @IOF K DIC S DIC(0)="QEAMZL",(DIC,DLAYGO)=133.8,DIC("A")="  Select Surgical Specialty: " D ^DIC K DIC,DLAYGO G:Y<0 END S SRSS=+Y,SRSS1=+Y(0)
-        S SRSSNM=$P(^SRO(137.45,SRSS1,0),"^")
-PAT     W ! S DIC=2,DIC(0)="QEAMZ",DIC("A")="  Select Patient: " D ^DIC K DIC I Y<0 W !!,"No action taken." G END
-        S DFN=+Y,SRNM=$P(Y(0),"^") I $D(^DPT(DFN,.35)),$P(^(.35),"^")'="" S Y=$E($P(^(.35),"^"),1,7) D D^DIQ W !!,"The records show that "_SRNM_" died on "_Y_".",! G PAT
-        I $O(^SRO(133.8,"AP",DFN,SRSS,0)) D CHK G:"Yy"'[ECYN END
-OP      W ! K DIR S DIR("A")="  Select Operative Procedure",DIR(0)="133.801,1" D ^DIR I $D(DTOUT)!$D(DUOUT) W !!,"No action taken." G END
-        S SROPER=Y
-        W ! D NOW^%DTC S SRSDT=%
-        K DD,DO,DIC,DR,DA S DIC(0)="L",DIC="^SRO(133.8,SRSS,1,",DA(1)=SRSS,X=DFN D FILE^DICN I +Y S SROFN=+Y
-        K DA,DIE,DR S DA=SRSS,DIE=133.8,DR="1///"_SRNM,DR(2,133.801)="1////"_SROPER_";2///"_SRSDT_";4T;W !;5T;6T;W !;3T",DR(3,133.8013)=".01T;1T;2T;3T;4T;5T" D ^DIE K DIE,DR
-        D WL^SROPCE1 I SRSOUT G DEL
-        W @IOF,!,SRNM_" has been entered on the waiting list",!,"for "_SRSSNM
-END     D PRESS,^SRSKILL W @IOF
-        Q
-PRESS   W ! K DIR S DIR("A")="Press RETURN to continue  ",DIR(0)="FOA" D ^DIR K DIR
-        Q
-DEL     S DA(1)=SRSS,DA=SROFN,DIK="^SRO(133.8,"_DA(1)_",1," D ^DIK
-        W @IOF,!,"Classification information is incomplete.  No action taken." G END
-        Q
-HELP    W !!,"Enter RETURN if you want to continue entering a new procedure on the waiting",!,"list for "_SRNM_".  If the procedure you are about to enter appears",!,"above, enter 'NO' to quit this option."
-        W !!,"Press RETURN to continue  " R X:DTIME
-        Q
-CHK     ; check for existing entries for a patient
-        W @IOF,!,"Procedure(s) already entered for "_SRNM,!,"on the Waiting List for "_SRSSNM,!
-        S SROFN=0 F  S SROFN=$O(^SRO(133.8,"AP",DFN,SRSS,SROFN)) Q:'SROFN  D LIST
-        W !!,"Do you wish to continue entering a new procedure for "_SRNM_" on",!,"the waiting list for "_SRSSNM_" ?  YES// " R ECYN:DTIME I '$T!(ECYN["^") S ECYN="N" Q
-        S ECYN=$E(ECYN) S:"y"[ECYN ECYN="Y"
-        I "YNn"'[ECYN D HELP G CHK
-        Q
-LIST    ; list existing procedures for specialty selected
-        S SROPER=$P(^SRO(133.8,SRSS,1,SROFN,0),"^",2),SRDT=$P(^(0),"^",3),SROPDT=$P(^(0),"^",5),Y=SRDT D D^DIQ S SRDT=$E(Y,1,12) I SROPDT S Y=SROPDT D D^DIQ S SROPDT=$E(Y,1,12)
-        K SROP,MM,MMM S:$L(SROPER)<36 SROP(1)=SROPER I $L(SROPER)>35 S SROPER=SROPER_"  " S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
-        W !,SRNM,?40,"Date Entered on List:",?66,SRDT,!,?3,SROP(1),?40,"Tentative Operation Date: ",?66,SROPDT
-        I $D(SROP(2)) W !,?3,SROP(2)
-        W !
-        Q
-LOOP    ; break procedure if greater than 36 characters
-        S SROP(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM=""  Q:$L(SROP(M))+$L(MM)'<36  S SROP(M)=SROP(M)_MM_" ",SROPER=MMM
-        Q
-REFPHY    ; Look up Referring Physician in "New Person" file with filter and auto-populate Referring Physician demographic fields
-        N SRCONT,Y,SRDEMO
-        S SRCONT=""
-PRMPT   R !,"Is this a VA Physician from this facility?  (Y/N): <Y> ",SRCONT:DTIME I '$T Q
-        I SRCONT["?" D  G PRMPT
-        .W !!,"Enter 'Y' if you would like to select the Referring Physician from this facility's VA personnel.",!,"Enter 'N' to continue data entry.",!
-        S:SRCONT="" SRCONT="Y"
-        I SRCONT="^" S X="" Q
-        Q:(SRCONT'["Y")&(SRCONT'["y")
-        ; Store FileMan variables and arrays
-        M SRDABAK=DA,SRDICBAK=DIC,SRDZERO=D0,SRDRBAK=DR,SRXBAK=X,SRDOBAK=DO
-        ; Setup variables and call ^DIC to lookup REFERRING PHYSICIAN from NEW PERSON file
-        S DIC="^VA(200,",DIC(0)="E",DIC("B")=X
-        D ^DIC
-        ; Restore FileMan's variables and arrays
-        M DA=SRDABAK,DIC=SRDICBAK,D0=SRDZERO,DR=SRDRBAK,X=SRXBAK,DO=SRDOBAK
-        K SRCONT,SRDABAK,SRDICBAK,SRDZERO,SRDRBAK,SRXBAK,SRDOBAK
-        Q:Y="-1"        ; Quit if no record was selected from the NEW PERSON file
-        S SRNPREC=$P(Y,U,1)_","   ;The record number of the NEW PERSON file
-        ; Retrieve demographic data from the NEW PERSON file.
-        D GETS^DIQ(200,SRNPREC,".01:.116;.132","","SRDEMO")
-        ; Build SRDEMO array for "stuffing" into REFERRING PHYSICIAN demographic fields
-        S X=SRDEMO(200,SRNPREC,".01")                       ;Name
-        S SRDEMO(1)=SRDEMO(200,SRNPREC,".111")        ;Address
-        S:$L(SRDEMO(200,SRNPREC,".112"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".112")   ;Concatenate Address 2 to single address
-        S:$L(SRDEMO(200,SRNPREC,".113"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".113")   ;Concatenate Address 3 to single address
-        S SRDEMO(1)=$E(SRDEMO(1),1,75)
-        S SRDEMO(2)=SRDEMO(200,SRNPREC,".114")        ;City
-        S SRDEMO(3)=SRDEMO(200,SRNPREC,".115")        ;State
-        S SRDEMO(4)=SRDEMO(200,SRNPREC,".116")        ;Zip
-        S SRDEMO(5)=SRDEMO(200,SRNPREC,".132")        ;Office Phone
-        ; Set up DR array that FileMan will use, with a call to ^DIE, after this subroutine Quits to "stuff" the demographic data.
-        ; all fields except STATE will ignore input transform (SR*3.0*162)
-        S DIC("DR")="1////"_SRDEMO(1)_";2////"_SRDEMO(2)_";3///"_SRDEMO(3)_";4////"_SRDEMO(4)_";5////"_SRDEMO(5)_";6////"_$P(Y,U,1)
-        S DIC(0)="Z"    ;Tells FileMan to file the data without any more user input
-        Q
+SROWL ;B'HAM ISC/MAM - ENTER PATIENT ON WAITING LIST ;13 Feb 1989  11:32 AM
+ ;;3.0;Surgery;**58,119**;24 Jun 93
+ENTER ; enter a patient on the waiting list
+ S SRSOUT=0 W @IOF K DIC S DIC(0)="QEAMZL",(DIC,DLAYGO)=133.8,DIC("A")="  Select Surgical Specialty: " D ^DIC K DIC,DLAYGO G:Y<0 END S SRSS=+Y,SRSS1=+Y(0)
+ S SRSSNM=$P(^SRO(137.45,SRSS1,0),"^")
+PAT W ! S DIC=2,DIC(0)="QEAMZ",DIC("A")="  Select Patient: " D ^DIC K DIC I Y<0 W !!,"No action taken." G END
+ S DFN=+Y,SRNM=$P(Y(0),"^") I $D(^DPT(DFN,.35)),$P(^(.35),"^")'="" S Y=$E($P(^(.35),"^"),1,7) D D^DIQ W !!,"The records show that "_SRNM_" died on "_Y_".",! G PAT
+ I $O(^SRO(133.8,"AP",DFN,SRSS,0)) D CHK G:"Yy"'[ECYN END
+OP W ! K DIR S DIR("A")="  Select Operative Procedure",DIR(0)="133.801,1" D ^DIR I $D(DTOUT)!$D(DUOUT) W !!,"No action taken." G END
+ S SROPER=Y
+ W ! D NOW^%DTC S SRSDT=%
+ K DD,DO,DIC,DR,DA S DIC(0)="L",DIC="^SRO(133.8,SRSS,1,",DA(1)=SRSS,X=DFN D FILE^DICN I +Y S SROFN=+Y
+ K DA,DIE,DR S DA=SRSS,DIE=133.8,DR="1///"_SRNM,DR(2,133.801)="1////"_SROPER_";2///"_SRSDT_";4T;W !;5T;6T;W !;3T",DR(3,133.8013)=".01T;1T;2T;3T;4T;5T" D ^DIE K DIE,DR
+ D WL^SROPCE1 I SRSOUT G DEL
+ W @IOF,!,SRNM_" has been entered on the waiting list",!,"for "_SRSSNM
+END D PRESS,^SRSKILL W @IOF
+ Q
+PRESS W ! K DIR S DIR("A")="Press RETURN to continue  ",DIR(0)="FOA" D ^DIR K DIR
+ Q
+DEL S DA(1)=SRSS,DA=SROFN,DIK="^SRO(133.8,"_DA(1)_",1," D ^DIK
+ W @IOF,!,"Classification information is incomplete.  No action taken." G END
+ Q
+HELP W !!,"Enter RETURN if you want to continue entering a new procedure on the waiting",!,"list for "_SRNM_".  If the procedure you are about to enter appears",!,"above, enter 'NO' to quit this option."
+ W !!,"Press RETURN to continue  " R X:DTIME
+ Q
+CHK ; check for existing entries for a patient
+ W @IOF,!,"Procedure(s) already entered for "_SRNM,!,"on the Waiting List for "_SRSSNM,!
+ S SROFN=0 F  S SROFN=$O(^SRO(133.8,"AP",DFN,SRSS,SROFN)) Q:'SROFN  D LIST
+ W !!,"Do you wish to continue entering a new procedure for "_SRNM_" on",!,"the waiting list for "_SRSSNM_" ?  YES// " R ECYN:DTIME I '$T!(ECYN["^") S ECYN="N" Q
+ S ECYN=$E(ECYN) S:"y"[ECYN ECYN="Y"
+ I "YNn"'[ECYN D HELP G CHK
+ Q
+LIST ; list existing procedures for specialty selected
+ S SROPER=$P(^SRO(133.8,SRSS,1,SROFN,0),"^",2),SRDT=$P(^(0),"^",3),SROPDT=$P(^(0),"^",5),Y=SRDT D D^DIQ S SRDT=$E(Y,1,12) I SROPDT S Y=SROPDT D D^DIQ S SROPDT=$E(Y,1,12)
+ K SROP,MM,MMM S:$L(SROPER)<36 SROP(1)=SROPER I $L(SROPER)>35 S SROPER=SROPER_"  " S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
+ W !,SRNM,?40,"Date Entered on List:",?66,SRDT,!,?3,SROP(1),?40,"Tentative Operation Date: ",?66,SROPDT
+ I $D(SROP(2)) W !,?3,SROP(2)
+ W !
+ Q
+LOOP ; break procedure if greater than 36 characters
+ S SROP(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM=""  Q:$L(SROP(M))+$L(MM)'<36  S SROP(M)=SROP(M)_MM_" ",SROPER=MMM
+ Q
+REFPHY   ; Look up Referring Physician in "New Person" file with filter and auto-populate Referring Physician demographic fields
+ N SRCONT,Y,SRDEMO
+ S SRCONT=""
+PRMPT R !,"Is this a VA Physician from this facility?  (Y/N): <Y> ",SRCONT:DTIME I '$T Q
+ I SRCONT["?" D  G PRMPT
+ .W !!,"Enter 'Y' if you would like to select the Referring Physician from this facility's VA personnel.",!,"Enter 'N' to continue data entry.",!
+ S:SRCONT="" SRCONT="Y"
+ I SRCONT="^" S X="" Q
+ Q:(SRCONT'["Y")&(SRCONT'["y")
+ ; Store FileMan variables and arrays
+ M SRDABAK=DA,SRDICBAK=DIC,SRDZERO=D0,SRDRBAK=DR,SRXBAK=X,SRDOBAK=DO
+ ; Setup variables and call ^DIC to lookup REFERRING PHYSICIAN from NEW PERSON file
+ S DIC="^VA(200,",DIC(0)="E",DIC("B")=X
+ D ^DIC
+ ; Restore FileMan's variables and arrays
+ M DA=SRDABAK,DIC=SRDICBAK,D0=SRDZERO,DR=SRDRBAK,X=SRXBAK,DO=SRDOBAK
+ K SRCONT,SRDABAK,SRDICBAK,SRDZERO,SRDRBAK,SRXBAK,SRDOBAK
+ Q:Y="-1"        ; Quit if no record was selected from the NEW PERSON file
+ S SRNPREC=$P(Y,U,1)_","   ;The record number of the NEW PERSON file
+ ; Retrieve demographic data from the NEW PERSON file.
+ D GETS^DIQ(200,SRNPREC,".01:.116;.132","","SRDEMO")
+ ; Build SRDEMO array for "stuffing" into REFERRING PHYSICIAN demographic fields
+ S X=SRDEMO(200,SRNPREC,".01")                       ;Name
+ S SRDEMO(1)=SRDEMO(200,SRNPREC,".111")        ;Address
+ S:$L(SRDEMO(200,SRNPREC,".112"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".112")   ;Concatenate Address 2 to single address
+ S:$L(SRDEMO(200,SRNPREC,".113"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".113")   ;Concatenate Address 3 to single address
+ S SRDEMO(1)=$E(SRDEMO(1),1,75)
+ S SRDEMO(2)=SRDEMO(200,SRNPREC,".114")        ;City
+ S SRDEMO(3)=SRDEMO(200,SRNPREC,".115")        ;State
+ S SRDEMO(4)=SRDEMO(200,SRNPREC,".116")        ;Zip
+ S SRDEMO(5)=SRDEMO(200,SRNPREC,".132")        ;Office Phone
+ ; Set up DR array that FileMan will use, with a call to ^DIE, after this subroutine Quits to "stuff" the demographic data.
+ S DIC("DR")="1///"_SRDEMO(1)_";2///"_SRDEMO(2)_";3///"_SRDEMO(3)_";4///"_SRDEMO(4)_";5///"_SRDEMO(5)_";6///"_$P(Y,U,1)
+ S DIC(0)="Z"    ;Tells FileMan to file the data without any more user input
+ Q

WorldVistAEHR/trunk/r/SURGERY-SR/SROXR4.m

@@ -1 @@
-SROXR4  ;BIR/MAM - CROSS REFERENCES ;11/05/07
-        ;;3.0; Surgery ;**62,83,100,153,166**;24 Jun 93;Build 7
-        Q
-PRO     ; stuff default prosthesis info
-        I '$D(SRTN) Q
-        S ^SRF(SRTN,1,DA,0)=^SRF(SRTN,1,DA,0)_"^"_$P(^SRO(131.9,X,0),"^",2,99)
-        I $D(^SRO(131.9,X,1)) S ^SRF(SRTN,1,DA,1)=^(1)
-        Q
-CAN     ; 'SET' logic of the 'ACAN' x-ref on the 'CANCEL REASON'
-        ; field in the SURGERY file (130)
-        S $P(^SRF(DA,30),"^",2)=$P(^SRO(135,X,0),"^",3) I $P(^SRO(135,X,0),"^",3)="" S $P(^SRF(DA,30),"^",2)="Y"
-        I $P(^SRF(DA,30),"^",3)="" S $P(^SRF(DA,30),"^",3)=DUZ
-        S SHEMP=$P($G(^SRF(DA,.2)),"^",10) I SHEMP,$D(^SRF(DA,"RA")) S ZTDESC="Clean up Risk Assessment Information, Canceled Case",ZTRTN="RISK^SROXR4",ZTDTH=$H,ZTSAVE("DA")="" D ^%ZTLOAD
-        Q
-KCAN    ; 'KILL' logic of the 'ACAN' x-ref on the 'CANCEL REASON'
-        ; field in the SURGERY file (130)
-        S $P(^SRF(DA,30),"^",2)="" I '$P($G(^SRF(DA,30)),"^") S $P(^SRF(DA,30),"^",3)=""
-        Q
-AS      ; 'SET' logic of the 'AS' x-ref on the SCHEDULED START TIME
-        ; field in the SURGERY file (130)
-        S OR=$P(^SRF(DA,0),"^",2) I 'OR Q
-        S ^SRF("AS",OR,X,DA)=""
-        Q
-KAS     ; 'KILL' logic of the 'AS' x-ref on the SCHEDULED FINISH TIME
-        ; field in the SURGERY file (130)
-        S OR=$P(^SRF(DA,0),"^",2) I 'OR Q
-        K ^SRF("AS",OR,X,DA)
-        Q
-SCH     ; 'SET' logic of the 'AC' x-ref of the REQUIRED FIELDS FOR SCHEDULING
-        ; field in the SURGERY SITE PARAMETERS file (133)
-        S MM=$O(^DD(130,"B",X,0)),$P(^SRO(133,DA(1),4,DA,0),"^",2)=MM K MM
-        Q
-KSCH    ; 'KILL' logic of the 'AC' x-ref of the REQUIRED FIELDS FOR SCHEDULING
-        ; field in the SURGERY SITE PARAMETERS file (133)
-        S $P(^SRO(133,DA(1),4,DA,0),"^",2)=""
-        Q
-RISK    ; clean up risk data for canceled cases
-        S DIE=130,DR="102///@;235///@;284///@;323///@" D ^DIE K DR,DA S ZTREQ="@"
-        Q
-AQ      ; set logic for AQ x-ref
-        N SRTD,SRLO D AQDT I SRTD'<SRLO S $P(^SRF(DA,.4),"^",2)="R",^SRF("AQ",SRTD,DA)=""
-        Q
-KAQ     ; kill logic for AQ x-ref
-        N SRTD,SRLO D AQDT S $P(^SRF(DA,.4),"^",2)="" K ^SRF("AQ",SRTD,DA)
-        Q
-AQDT    ; get quarterly transmission date
-        N SRDAY,SRSDATE,SRQTR,SRX,SRYR S SRSDATE=$E($P(^SRF(DA,0),"^",9),1,7)
-        S SRYR=$E(SRSDATE,1,3),SRDAY=$E(SRSDATE,4,7),SRQTR=$S(SRDAY<401:2,SRDAY<701:3,SRDAY<1001:4,1:1) I SRQTR=1 S SRYR=SRYR+1
-        S SRTD=SRYR_$S(SRQTR=1:"0214",SRQTR=2:"0515",SRQTR=3:"0814",1:"1114")
-        S SRX=$E(DT,1,3),SRLO=SRX-1_"0214"
-        Q
-AQ1     ; set logic for AQ1 x-ref
-        I X="R" N SRTD,SRLO D AQDT I SRTD'<SRLO S ^SRF("AQ",SRTD,DA)=""
-        Q
-KAQ1    ; kill logic for AQ1 x-ref
-        N SRTD,SRLO D AQDT K ^SRF("AQ",SRTD,DA)
-        Q
-AT      ; set logic for AT x-ref on DATE OF LAST TRANSMISSION
-        N SRX S ^SRF("AT",X,DA)=""
-        S SRX=$P($G(^SRF(DA,"RA")),"^",4) I SRX,SRX'=X K ^SRF("AT",SRX,DA)
-        Q
-KAT     ; kill logic for AT x-ref on DATE OF LAST TRANSMISSION
-        N SRX K ^SRF("AT",X,DA)
-        S SRX=$P($G(^SRF(DA,"RA")),"^",4) I SRX,SRX'=X K ^SRF("AT",SRX,DA)
-        Q
-AT1     ; set logic for AT x-ref on DATE TRANSMITTED
-        N SRX S SRX=$P($G(^SRF(DA,"RA")),"^",8) I SRX Q
-        S ^SRF("AT",X,DA)=""
-        Q
-KAT1    ; kill logic for AT x-ref on DATE TRANSMITTED
-        N SRX S SRX=$P($G(^SRF(DA,"RA")),"^",8)
-        I SRX'=X K ^SRF("AT",X,DA)
-        Q
+SROXR4 ;BIR/MAM - CROSS REFERENCES ;03/15/06
+ ;;3.0; Surgery ;**62,83,100,153**;24 Jun 93;Build 11
+ Q
+PRO ; stuff default prosthesis info
+ I '$D(SRTN) Q
+ S ^SRF(SRTN,1,DA,0)=^SRF(SRTN,1,DA,0)_"^"_$P(^SRO(131.9,X,0),"^",2,99)
+ I $D(^SRO(131.9,X,1)) S ^SRF(SRTN,1,DA,1)=^(1)
+ Q
+CAN ; 'SET' logic of the 'ACAN' x-ref on the 'CANCEL REASON'
+ ; field in the SURGERY file (130)
+ S $P(^SRF(DA,30),"^",2)=$P(^SRO(135,X,0),"^",3) I $P(^SRO(135,X,0),"^",3)="" S $P(^SRF(DA,30),"^",2)="Y"
+ I $P(^SRF(DA,30),"^",3)="" S $P(^SRF(DA,30),"^",3)=DUZ
+ S SHEMP=$P($G(^SRF(DA,.2)),"^",10) I SHEMP,$D(^SRF(DA,"RA")) S ZTDESC="Clean up Risk Assessment Information, Canceled Case",ZTRTN="RISK^SROXR4",ZTDTH=$H,ZTSAVE("DA")="" D ^%ZTLOAD
+ Q
+KCAN ; 'KILL' logic of the 'ACAN' x-ref on the 'CANCEL REASON'
+ ; field in the SURGERY file (130)
+ S $P(^SRF(DA,30),"^",2)="" I '$P($G(^SRF(DA,30)),"^") S $P(^SRF(DA,30),"^",3)=""
+ Q
+AS ; 'SET' logic of the 'AS' x-ref on the SCHEDULED START TIME
+ ; field in the SURGERY file (130)
+ S OR=$P(^SRF(DA,0),"^",2) I 'OR Q
+ S ^SRF("AS",OR,X,DA)=""
+ Q
+KAS ; 'KILL' logic of the 'AS' x-ref on the SCHEDULED FINISH TIME
+ ; field in the SURGERY file (130)
+ S OR=$P(^SRF(DA,0),"^",2) I 'OR Q
+ K ^SRF("AS",OR,X,DA)
+ Q
+SCH ; 'SET' logic of the 'AC' x-ref of the REQUIRED FIELDS FOR SCHEDULING
+ ; field in the SURGERY SITE PARAMETERS file (133)
+ S MM=$O(^DD(130,"B",X,0)),$P(^SRO(133,DA(1),4,DA,0),"^",2)=MM K MM
+ Q
+KSCH ; 'KILL' logic of the 'AC' x-ref of the REQUIRED FIELDS FOR SCHEDULING
+ ; field in the SURGERY SITE PARAMETERS file (133)
+ S $P(^SRO(133,DA(1),4,DA,0),"^",2)=""
+ Q
+RISK ; clean up risk data for canceled cases
+ S DIE=130,DR="102///@;235///@;284///@;323///@" D ^DIE K DR,DA S ZTREQ="@"
+ Q
+AQ ; set logic for AQ x-ref
+ N SRTD,SRLO D AQDT I SRTD'<SRLO S $P(^SRF(DA,.4),"^",2)="R",^SRF("AQ",SRTD,DA)=""
+ Q
+KAQ ; kill logic for AQ x-ref
+ N SRTD,SRLO D AQDT S $P(^SRF(DA,.4),"^",2)="" K ^SRF("AQ",SRTD,DA)
+ Q
+AQDT ; get quarterly transmission date
+ N SRDAY,SRSDATE,SRQTR,SRX,SRYR S SRSDATE=$E($P(^SRF(DA,0),"^",9),1,7)
+ S SRYR=$E(SRSDATE,1,3),SRDAY=$E(SRSDATE,4,7),SRQTR=$S(SRDAY<401:2,SRDAY<701:3,SRDAY<1001:4,1:1) I SRQTR=1 S SRYR=SRYR+1
+ S SRTD=SRYR_$S(SRQTR=1:"0214",SRQTR=2:"0515",SRQTR=3:"0814",1:"1114")
+ S SRX=$E(DT,1,3),SRLO=SRX-1_"0214"
+ Q
+AQ1 ; set logic for AQ1 x-ref
+ I X="R" N SRTD,SRLO D AQDT I SRTD'<SRLO S ^SRF("AQ",SRTD,DA)=""
+ Q
+KAQ1 ; kill logic for AQ1 x-ref
+ N SRTD,SRLO D AQDT K ^SRF("AQ",SRTD,DA)
+ Q