Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (15 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

Location:
WorldVistAEHR/trunk/r/SURGERY-SR
Files:
48 edited

Legend:

Unmodified
Added
Removed
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROABCH.m

    r613 r623  
    1 SROABCH ;BIR/MAM - BATCH PRINT ASSESSMENTS ;11/28/07
    2         ;;3.0; Surgery ;**77,166**;24 Jun 93;Build 7
    3 DATE    ; get dates
    4         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.",!
    5         D DATE^SROUTL(.SRASTDT,.SRAENDT,.SRSOUT) G:SRSOUT END
    6         D SPEC
    7         W !!,"Depending on the date range entered, this report may be very long.  You should",!,"QUEUE this report to the selected printer.",!
    8         K %ZIS,IOP,POP,IO("Q") S %ZIS="Q",%ZIS("A")="Print on which Device: " D ^%ZIS S:POP SRSOUT=1 G:POP END
    9         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
    10 EN      ; entry when queued
    11         S SRSOUT=0,SRABATCH=1
    12         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
    13 END     I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
    14         D ^%ZISC K SRTN W @IOF D ^SRSKILL
    15         Q
    16 STUFF   ;
    17         I SRSP,$P(^SRF(SRTN,0),"^",4)'=SRSP Q
    18         S DATE=$P(^SRF(SRTN,0),"^",9)
    19         S SR("RA")=$G(^SRF(SRTN,"RA")),X=$P(SR("RA"),"^") I X'="T",X'="C" Q
    20         I $P(SR("RA"),"^",6)'="Y" Q
    21         K SRA D ^SROAPAS
    22         Q
    23 SPEC    ; select specialty
    24         W ! K DIR S DIR(0)="YA",DIR("A")="Print report for ALL surgical specialties ?  ",DIR("B")="YES"
    25         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."
    26         D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
    27         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
    28         Q
     1SROABCH ;B'HAM ISC/MAM - BATCH PRINT ASSESSMENTS ; [ 01/08/98   9:54 AM ]
     2 ;;3.0; Surgery ;**77**;24 Jun 93
     3DATE ; get dates
     4 S SRSOUT=0 W @IOF,!!,"This report will print all completed or transmitted assessments that have a",!,"'date completed' within the date range selected.",!
     5 D DATE^SROUTL(.SRASTDT,.SRAENDT,.SRSOUT) G:SRSOUT END
     6 W !!,"Depending on the date range entered, this report may be very long.  You should",!,"QUEUE this report to the selected printer.",!
     7 K %ZIS,IOP,POP,IO("Q") S %ZIS="Q",%ZIS("A")="Print on which Device: " D ^%ZIS S:POP SRSOUT=1 G:POP END
     8 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
     9EN ; entry when queued
     10 S SRSOUT=0,SRABATCH=1
     11 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
     12END I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
     13 I $E(IOST)'="P",'SRSOUT W !!,"Press RETURN to continue  " R X:DTIME
     14 D ^%ZISC K SRTN W @IOF D ^SRSKILL
     15 Q
     16STUFF S DATE=$P(^SRF(SRTN,0),"^",9)
     17 S SR("RA")=$G(^SRF(SRTN,"RA")),X=$P(SR("RA"),"^") I X'="T",X'="C" Q
     18 I $P(SR("RA"),"^",6)'="Y" Q
     19 K SRA D ^SROAPAS
     20 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROACAR.m

    r613 r623  
    1 SROACAR ;BIR/MAM - OPEATIVE DATA ;12/03/07
    2         ;;3.0; Surgery ;**38,71,93,95,100,125,142,153,166**;24 Jun 93;Build 7
    3         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
    4         S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
    5 START   D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROACR1
    6 ASK     W !,"Select Cardiac Procedures Operative Information to Edit: " R X:DTIME I '$T!("^"[X) G END
    7         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
    8         I X="A" S X="1:22"
    9         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
    10         I X="N" D  G:SRSOUT END G START
    11         .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"
    12         .D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
    13         .I Y D NO2ALL
    14         D HDR^SROAUTL
    15         I X?.N1":".N D RANGE G START
    16         I $D(SRAO(X)),+X=X S EMILY=X D  G START
    17         .I $$LOCK^SROUTL(SRTN) W ! D ONE,UNLOCK^SROUTL(SRTN)
    18         I $D(SRAO(X)) W ! S EMILY=X D  G START
    19         .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
    20 END     I 'SRSOUT D ^SROACR2
    21         W @IOF D ^SRSKILL
    22         Q
    23 HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
    24         W !!,"1. Enter 'A' to update all information.",!!,"2. Enter 'N' to set all fields on this page to NO."
    25         W !!,"3. Enter a number (1-22) to update the information in that field.  (For",!,"   example, enter '9' to update Valve Repair.)"
    26         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.)"
    27         D RET
    28         Q
    29 RANGE   ; range of numbers
    30         I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
    31         .W ! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
    32         Q
    33 ONE     ; edit one item
    34         ;I EMILY=16 D MIS^SROACR1 Q
    35         I EMILY=22 D OPS Q
    36         K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",2)_"T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1
    37         I 'SRSOUT,EMILY=12!(EMILY=13) D OK
    38         Q
    39 NO2ALL  ; set all fields to NO
    40         N II K DR,DIE S DA=SRTN,DIE=130
    41         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"
    42         F II=365,366,464,465,416 S DR=DR_";"_II_"////0"
    43         S DR=DR_";"_370_"////5"_";"_512_"////N"
    44         D ^DIE K DR
    45         Q
    46 OK      N SRISCH,SRCPB S X=$G(^SRF(SRTN,206)),SRISCH=$P(X,"^",36),SRCPB=$P(X,"^",37)
    47         I SRISCH,SRCPB,SRISCH>SRCPB W !!,"  ***  NOTE: Ischemic Time is greater than CPB Time!!  Please check.  ***",! D RET W !
    48         Q
    49 RET     Q:SRSOUT  W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
    50         Q
    51 OPS     ; enter other cardiac procedures, specify
    52         S DIE=130,DA=SRTN,DR="502T" D ^DIE K DR Q:$D(Y)
    53         I X'="Y" K ^SRF(SRTN,209.1) Q
    54         S DIE=130,DA=SRTN,DR="484T" D ^DIE K DR
    55         Q
     1SROACAR ;BIR/MAM - OPEATIVE DATA ;03/29/06
     2 ;;3.0; Surgery ;**38,71,93,95,100,125,142,153**;24 Jun 93;Build 11
     3 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
     4 S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
     5START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROACR1
     6ASK W !,"Select Operative Information to Edit: " R X:DTIME I '$T!("^"[X) G END
     7 S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START
     8 I X="A" S X="1:22"
     9 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
     10 D HDR^SROAUTL
     11 I X?.N1":".N D RANGE G START
     12 I $D(SRAO(X)),+X=X S EMILY=X D  G START
     13 .I $$LOCK^SROUTL(SRTN) W ! D ONE,UNLOCK^SROUTL(SRTN)
     14 I $D(SRAO(X)) W ! S EMILY=X D  G START
     15 .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
     16END I 'SRSOUT D ^SROACR2
     17 W @IOF D ^SRSKILL
     18 Q
     19HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
     20 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.)"
     21 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.)"
     22 D RET
     23 Q
     24RANGE ; range of numbers
     25 I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
     26 .W ! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
     27 Q
     28ONE ; edit one item
     29 ;I EMILY=16 D MIS^SROACR1 Q
     30 I EMILY=22 D OPS Q
     31 K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",2)_"T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1
     32 I 'SRSOUT,EMILY=12!(EMILY=13) D OK
     33 Q
     34OK N SRISCH,SRCPB S X=$G(^SRF(SRTN,206)),SRISCH=$P(X,"^",36),SRCPB=$P(X,"^",37)
     35 I SRISCH,SRCPB,SRISCH>SRCPB W !!,"  ***  NOTE: Ischemic Time is greater than CPB Time!!  Please check.  ***",! D RET W !
     36 Q
     37RET Q:SRSOUT  W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
     38 Q
     39OPS ; enter other cardiac procedures, specify
     40 S DIE=130,DA=SRTN,DR="502T" D ^DIE K DR Q:$D(Y)
     41 I X'="Y" K ^SRF(SRTN,209.1) Q
     42 S DIE=130,DA=SRTN,DR="484T" D ^DIE K DR
     43 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROACMP.m

    r613 r623  
    1 SROACMP ;BIR/ADM - M&M VERIFICATION REPORT ;12/19/07
    2         ;;3.0; Surgery ;**47,50,127,143,166**;24 Jun 93;Build 7
    3         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
    4         I SRFORM=1,SRSP D SS
    5         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 "-"
    6         .S SRX=^(SRPAT),SRNAME=">>> "_SRPAT_" ("_$P(SRX,"^",2)_")",SRDEATH=$P(SRX,"^",3)
    7         .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)
    8         .I $Y+9>IOSL D HDR^SROACMP1 I SRSOUT Q
    9         .W !,SRNAME S SRNM=1,DFN=$P(SRX,"^"),SRTN=0 F  S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN!SRSOUT  D SET
    10         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.")
    11         D HDR2^SROACMP1,END^SROACMP1
    12         Q
    13 UTIL    ; list all cases within 30 days prior to postop occurrence and/or 90 days prior to death
    14         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
    15         D DEM^VADPT S ^TMP("SRPAT",$J,VADM(1))=DFN_"^"_VA("PID")_"^"_$P(VADM(6),"^")
    16         S SRDATE=$P(VADM(6),"^") I SRDATE S SRBACK=-90 D PRIOR
    17         Q
    18 PRIOR   ; list cases in 30 days before this occurrence or 90 days before death
    19         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
    20         .I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN)
    21         .I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN)
    22         .I '$P($G(^SRF(SRCASE,.2)),"^",12)!$P($G(^SRF(SRCASE,30)),"^")!($P($G(^SRF(SRCASE,"NON")),"^")="Y") Q
    23         .S SRX=$E($P(^SRF(SRCASE,0),"^",9),1,7) I SRX<SDATE!(SRX>SRDATE) Q
    24         .S ^TMP("SR",$J,DFN,SRCASE)=$P(^SRF(SRCASE,0),"^",4)
    25         Q
    26 SET     ; set variables to print
    27         N SRSEP,SRICDN
    28         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),"^")
    29 OPS     S SROPER=$P(^SRF(SRTN,"OP"),"^")
    30         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=""
    31         N SRL S SRL=109 D CPTS^SROAUTL0 I SRPROC(1)="" S SRPROC(1)="NOT ENTERED"
    32         S SRCHK=0 I SRDEATH S X1=SRDEATH,X2=-90 D C^%DTC I SRD<X S SRCHK=1,SRREL="N/A"
    33         I 'SRCHK S X=$P($G(^SRF(SRTN,.4)),"^",7),SRREL=$S(SRDEATH="":"N/A",X="U":"NO",X="R":"YES",1:"NOT ENTERED")
    34 COMP    ; perioperative occurrences
    35         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
    36         .S Y=SRD D DATE S SRCAT=$P(SRO,"^",2) Q:'SRCAT  S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_" "_SRY
    37         .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)
    38         .S $P(SRC(SRFG),"^",2)="10;"_SRIC
    39         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
    40         .S Y=$E($P(SRO,"^",7),1,7) D DATE S SRCAT=$P(SRO,"^",2) Q:'SRCAT
    41         .S SRSEP="" I SRCAT=3 S X=$P(SRO,"^",4) I X S SRSEP="/"_$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")_" "
    42         .S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_"  ** POSTOP ** "_SRSEP_SRY
    43         .I $P(SRO,"^",2)=3 S X=$P(SRO,"^",4) I X S SRSEP=$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")
    44         .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)
    45         .S $P(SRC(SRFG),"^",2)="16;"_SRPC
    46 RA      ; risk assessment type and status
    47         S SRA=$G(^SRF(SRTN,"RA")),SRSTATUS=$P(SRA,"^"),SRTYPE=$P(SRA,"^",2),SRYN=$P(SRA,"^",6),SRE=$P(SRA,"^",7) D
    48         .I SRTYPE="" S SRTYPE="NON-ASSESSED" Q
    49         .S SRTYPE=$S(SRTYPE="C":"CARDIAC",SRYN="Y":"NON-CARDIAC",1:"EXCLUDED")
    50         S SRSTATUS=$S(SRSTATUS="C":"COMPLETE",SRSTATUS="T":"TRANSMITTED",SRSTATUS="I":"INCOMPLETE",1:"N/A")
    51 PRINT   ; print case information
    52         I $Y+8>IOSL D HDR^SROACMP1 I SRSOUT Q
    53         W !!,SRSDATE,?11,SRTN,?25,SRSS,?80,SRTYPE,?98,SRSTATUS,?116,SRREL
    54         W !,?11,SRP(1) W:$D(SRP(2)) !,?11,SRP(2)
    55         W !,?11,"CPT Codes: ",SRPROC(1) W:$D(SRPROC(2)) !,?24,SRPROC(2)
    56         W !,?11,"Occurrences: " I '$D(SRC(1)) S SRC(1)="NONE ENTERED"
    57         S SRI=0 F  S SRI=$O(SRC(SRI)) Q:'SRI  D
    58         .W:SRI>1 ! W ?24,$P(SRC(SRI),"^")
    59         .I $Y+6>IOSL D HDR^SROACMP1 W ! I SRSOUT Q
    60         .D TEXT D:SRT WP
    61         S SRNDTH=$P($G(^SRF(SRTN,205)),"^",3)
    62         I SRDEATH!SRNDTH D  K SRNDTH
    63         .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)
    64         .W !,?11,"Review of Death Comments: " D
    65         ..I '$O(^SRF(SRTN,47,0)) W "NONE ENTERED" Q
    66         ..D DWP
    67         Q
    68 OPER    ; break procedure if greater than 48 characters
    69         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)
    70         Q
    71 DATE    S SRY=$S(Y:" ("_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_")",1:" (NO DATE)")
    72         Q
    73 SS      ; set up ^TMP for selected specialties
    74         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
    75         .F  S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN  D  Q:SRQ
    76         ..S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I $D(SRSP(Y)) S ^TMP("SRSP",$J,DFN)="",SRQ=1 Q
    77         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)
    78         Q
    79 WP      ; print occurrence comments
    80         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
    81         I $D(^UTILITY($J,"W")) F J=1:1:^UTILITY($J,"W",30) D
    82         .I $Y+7>IOSL D HDR^SROACMP1 W ! I SRSOUT Q
    83         .W !,?30,^UTILITY($J,"W",30,J,0)
    84         Q
    85 TEXT    ; check for occurrence comments
    86         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:"
    87         Q
    88 DWP     ; print review of death comments
    89         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
    90         I $D(^UTILITY($J,"W")) F J=1:1:^UTILITY($J,"W",38) D
    91         .I $Y+7>IOSL D HDR^SROACMP1 W ! I SRSOUT Q
    92         .W ?38,^UTILITY($J,"W",38,J,0),!
    93         Q
     1SROACMP ;BIR/ADM-M&M Verification Report ;02/20/05
     2 ;;3.0; Surgery ;**47,50,127,143**;24 Jun 93
     3 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
     4 I SRFORM=1,SRSP D SS
     5 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 "-"
     6 .S SRX=^(SRPAT),SRNAME=">>> "_SRPAT_" ("_$P(SRX,"^",2)_")",SRDEATH=$P(SRX,"^",3)
     7 .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)
     8 .I $Y+9>IOSL D HDR^SROACMP1 I SRSOUT Q
     9 .W !,SRNAME S SRNM=1,DFN=$P(SRX,"^"),SRTN=0 F  S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN!SRSOUT  D SET
     10 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.")
     11 D HDR2^SROACMP1,END^SROACMP1
     12 Q
     13UTIL ; list all cases within 90 days prior to postop occurrence and/or death
     14 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
     15 D DEM^VADPT S ^TMP("SRPAT",$J,VADM(1))=DFN_"^"_VA("PID")_"^"_$P(VADM(6),"^")
     16 S SRDATE=$P(VADM(6),"^") I SRDATE S SRBACK=-90 D PRIOR
     17 Q
     18PRIOR ; list cases in 30 days before this occurrence or 90 days before death
     19 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
     20 .I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN)
     21 .I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN)
     22 .I '$P($G(^SRF(SRCASE,.2)),"^",12)!$P($G(^SRF(SRCASE,30)),"^")!($P($G(^SRF(SRCASE,"NON")),"^")="Y") Q
     23 .S SRX=$E($P(^SRF(SRCASE,0),"^",9),1,7) I SRX<SDATE!(SRX>SRDATE) Q
     24 .S ^TMP("SR",$J,DFN,SRCASE)=$P(^SRF(SRCASE,0),"^",4)
     25 Q
     26SET ; set variables to print
     27 N SRSEP
     28 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,"(")
     29OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F  S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER=""  D OTHER
     30 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=""
     31 S SRCHK=0 I SRDEATH S X1=SRDEATH,X2=-90 D C^%DTC I SRD<X S SRCHK=1,SRREL="N/A"
     32 I 'SRCHK S X=$P($G(^SRF(SRTN,.4)),"^",7),SRREL=$S(SRDEATH="":"N/A",X="U":"NO",X="R":"YES",1:" ?")
     33COMP ; perioperative occurrences
     34 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
     35 .S Y=SRD D DATE S SRCAT=$P(SRO,"^",2) Q:'SRCAT  S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_" "_SRY
     36 .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)
     37 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
     38 .S Y=$E($P(SRO,"^",7),1,7) D DATE S SRCAT=$P(SRO,"^",2) Q:'SRCAT
     39 .S SRSEP="" I SRCAT=3 S X=$P(SRO,"^",4) I X S SRSEP="/"_$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")_" "
     40 .S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_" * "_SRSEP_SRY
     41 .I $P(SRO,"^",2)=3 S X=$P(SRO,"^",4) I X S SRSEP=$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")
     42 .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)
     43RA ; risk assessment type and status
     44 S SRA=$G(^SRF(SRTN,"RA")),SRSTATUS=$P(SRA,"^"),SRTYPE=$P(SRA,"^",2),SRYN=$P(SRA,"^",6),SRE=$P(SRA,"^",7) D
     45 .I SRTYPE="" S SRA="NON-ASSESSED" Q
     46 .S SRA=$S(SRTYPE="C":"CARDIAC",SRYN="Y":"NON-CARD",1:"EXCLUDED")_"/"_SRSTATUS
     47PRINT ; print case information
     48 I $Y+8>IOSL D HDR^SROACMP1 I SRSOUT Q
     49 W !!,SRSDATE,?11,SRSS,?25,SRP(1),?69,SRREL W:$D(SRC(1)) ?75,SRC(1) W ?120,SRA
     50 F SRC=2:1 Q:'$D(SRP(SRC))&'$D(SRC(SRC))  D  Q:SRSOUT
     51 .I $Y+6>IOSL D HDR^SROACMP1 I SRSOUT Q
     52 .W ! W:$D(SRP(SRC)) ?25,SRP(SRC) W:$D(SRC(SRC)) ?75,SRC(SRC)
     53 Q
     54OTHER ; other operations
     55 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
     56 I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
     57 S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
     58 Q
     59OPER ; break procedure if greater than 40 characters
     60 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)
     61 Q
     62DATE S SRY=$S(Y:" ("_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_")",1:" (NO DATE)")
     63 Q
     64SS ; set up ^TMP for selected specialties
     65 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
     66 .F  S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN  D  Q:SRQ
     67 ..S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I $D(SRSP(Y)) S ^TMP("SRSP",$J,DFN)="",SRQ=1 Q
     68 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)
     69 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROACMP1.m

    r613 r623  
    1 SROACMP1        ;BIR/ADM - M&M VERIFICATION REPORT (CONT'D) ;11/26/07
    2         ;;3.0; Surgery ;**47,68,77,50,166**;24 Jun 93;Build 7
    3 EN      ; entry point
    4         S (SRSOUT,SRSP)=0,SRINST=$P($$SITE^SROVAR,"^",2) W @IOF,!,?28,"M&M Verification Report"
    5         W !!,"The M&M Verification Report is a tool to assist in the review of occurrences"
    6         W !,"and their assignment to operations and in the review of death unrelated or",!,"related assignments to operations."
    7         W !!,"The full report includes all patients who had operations within the selected"
    8         W !,"date range who experienced intraoperative occurrences, postoperative"
    9         W !,"occurrences or death within 90 days of surgery. The pre-transmission report"
    10         W !,"is similar but includes only operations with completed risk assessments that"
    11         W !,"have not yet transmitted to the national database.",!
    12         D SEL G:SRSOUT END I SRFORM=2 G SPEC
    13         D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END
    14 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))
    15         W !! K DIR S DIR("A")="Do you want to print this report for all Surgical Specialties ",DIR("B")="YES",DIR(0)="Y"
    16         S DIR("?",1)="Enter RETURN to print this report for all surgical specialties, or 'NO' to",DIR("?")="select a specific specialty."
    17         D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END
    18         I 'Y D SP I SRSOUT G END
    19 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
    20         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
    21 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)
    22         N SRFRTO I SRFORM=1 D
    23         .S Y=SRSD X ^DD("DD") S SRFRTO="From: "_Y S Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_"  To: "_Y
    24         .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
    25         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
    26         G:SRSOUT END G ^SROACMP
    27 CASE    ; examine case
    28         Q:'$D(^SRF(SRTN,0))
    29         I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN)
    30         I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN)
    31         I SRFORM=2,SRSP S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I '$D(SRSP(Y)) Q
    32         I '$P($G(^SRF(SRTN,.2)),"^",12)!$P($G(^SRF(SRTN,30)),"^")!($P($G(^SRF(SRTN,"NON")),"^")="Y") Q
    33         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
    34         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)
    35         Q
    36 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
    37         D ^%ZISC,^SRSKILL K SRTN W @IOF
    38         Q
    39 SEL     ; select report version
    40         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."
    41         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
    42         S SRFORM=Y
    43         Q
    44 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
    45         S SRCT=+Y,SRSP(SRCT)=+Y
    46 MORE    ; ask for more surgical specialties
    47         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
    48         Q
    49 HDR     ; print heading
    50         I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
    51         I SRHDR D HDR2 Q:SRSOUT  S SRHDR=0
    52         W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,?124,"Page ",PAGE,!,?54,"M&M Verification Report"
    53         W:SRFORM=1 !,?(132-$L(SRFRTO)\2),SRFRTO
    54         W:SRFORM=2 !,?41,"PRE-TRANSMISSION REPORT FOR COMPLETED ASSESSMENTS"
    55         W ?100,"REVIEWED BY:",!,?(132-$L(SRPRINT)\2),SRPRINT,?100,"DATE REVIEWED:",!
    56         W !,"OP DATE",?11,"CASE #",?25,"SURGICAL SPECIALTY",?80,"ASSESSMENT TYPE   STATUS",?116,"DEATH RELATED",!,?11,"PRINCIPAL PROCEDURE",! F LINE=1:1:132 W "="
    57         I SRNM W !,SRNAME_"   * * Continued from previous page * *"
    58         S PAGE=PAGE+1,SRHDR=1 I '$D(^TMP("SR",$J))
    59         Q
    60 HDR2    ; more heading
    61         ;I $Y+6<IOSL F I=$Y:1:IOSL-5 W !
    62 FOOT    ; print footer
    63         ;W ! F LINE=1:1:IOM W "-"
    64         ;W !,"Occurrences(s): '*' Denotes Postop Occurrence",! F LINE=1:1:IOM W "-"
    65         S SRHDR=0 I $E(IOST)'="P" W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S SRSOUT=1
    66         Q
     1SROACMP1 ;BIR/ADM-M&M Verification Report (cont'd) ; [ 09/22/98  11:22 AM ]
     2 ;;3.0; Surgery ;**47,68,77,50**;24 Jun 93
     3EN ; entry point
     4 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"
     5 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."
     6 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"
     7 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.",!
     8 D SEL G:SRSOUT END I SRFORM=2 G SPEC
     9 D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END
     10SPEC 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))
     11 W !! K DIR S DIR("A")="Do you want to print this report for all Surgical Specialties ",DIR("B")="YES",DIR(0)="Y"
     12 S DIR("?",1)="Enter RETURN to print this report for all surgical specialties, or 'NO' to",DIR("?")="select a specific specialty."
     13 D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END
     14 I 'Y D SP I SRSOUT G END
     15DEV 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
     16 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
     17BEG 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)
     18 N SRFRTO I SRFORM=1 D
     19 .S Y=SRSD X ^DD("DD") S SRFRTO="From: "_Y S Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_"  To: "_Y
     20 .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
     21 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
     22 G:SRSOUT END G ^SROACMP
     23CASE ; examine case
     24 Q:'$D(^SRF(SRTN,0))
     25 I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN)
     26 I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN)
     27 I SRFORM=2,SRSP S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I '$D(SRSP(Y)) Q
     28 I '$P($G(^SRF(SRTN,.2)),"^",12)!$P($G(^SRF(SRTN,30)),"^")!($P($G(^SRF(SRTN,"NON")),"^")="Y") Q
     29 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
     30 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)
     31 Q
     32END 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
     33 D ^%ZISC,^SRSKILL K SRTN W @IOF
     34 Q
     35SEL ; select report version
     36 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."
     37 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
     38 S SRFORM=Y
     39 Q
     40SP 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
     41 S SRCT=+Y,SRSP(SRCT)=+Y
     42MORE ; ask for more surgical specialties
     43 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
     44 Q
     45HDR ; print heading
     46 I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
     47 I SRHDR D HDR2 Q:SRSOUT  S SRHDR=0
     48 W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,?124,"Page ",PAGE,!,?54,"M&M Verification Report"
     49 W:SRFORM=1 !,?(132-$L(SRFRTO)\2),SRFRTO
     50 W:SRFORM=2 !,?41,"Pre-Transmission Report for Completed Assessments"
     51 W ?100,"Reviewed By:",!,?(132-$L(SRPRINT)\2),SRPRINT,?100,"Date Reviewed:",!
     52 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 "="
     53 I SRNM W !,SRNAME_"   * * Continued from previous page * *"
     54 S PAGE=PAGE+1,SRHDR=1 I '$D(^TMP("SR",$J))
     55 Q
     56HDR2 ; more heading
     57 I $Y+5<IOSL F I=$Y:1:IOSL-5 W !
     58FOOT ; print footer
     59 W ! F LINE=1:1:IOM W "-"
     60 W !,"Occurrences(s): '*' Denotes Postop Occurrence",?69,"Assessment Status - I:Incomplete, C:Complete, T:Transmitted",! F LINE=1:1:IOM W "-"
     61 S SRHDR=0 I $E(IOST)'="P" W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S SRSOUT=1
     62 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROACOM.m

    r613 r623  
    1 SROACOM ;BIR/MAM - COMPLETE ASSESSMENT ;12/19/07
    2         ;;3.0; Surgery ;**38,55,63,65,88,93,95,102,100,125,134,142,160,166**;24 Jun 93;Build 7
    3         I '$D(SRTN) Q
    4         I $P($G(^SRF(SRTN,"RA")),"^",2)="C" G ^SROACOM1
    5         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
    6         I $P(SRA,"^",2)="N",$P(SRA,"^",6)="Y" D CHK^SROAUTL
    7         I $P(SRA,"^",2)="N",$P(SRA,"^",6)="N" D CHK^SROAUTL3
    8         S SRFLD="" I $O(SRX(SRFLD))'="" D LIST
    9 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."
    10         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"
    11         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
    12         I 'Y W !!,"No action taken." G END
    13         I $$LOCK^SROUTL(SRTN) D COMPLT Q
    14         E  W !!,"No action taken." G END
    15         Q
    16 COMPLT  W !!,"Updating the current status to 'COMPLETE'..." K DR,DIE S DA=SRTN,DIE=130,DR="235///C" D ^DIE K STATUS
    17         I $P(SRA,"^",5)="" K DR,DIE S DA=SRTN,DIE=130,DR="272///"_DT D ^DIE K STATUS
    18         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
    19         D UNLOCK^SROUTL(SRTN)
    20 PRINT   W !!,"Do you want to print the completed assessment ?  YES//  " R SRYN:DTIME I '$T!(SRYN["^") S SRSOUT=1 Q
    21         S SRYN=$E(SRYN) S:SRYN="" SRYN="Y" I "Nn"[SRYN S SRSOUT=1 Q
    22         I "Yy"'[SRYN W !!,"Enter <RET> to print the completed assessment, or 'NO' to return to the menu." G PRINT
    23         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
    24         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
    25         D EN,END
    26         Q
    27 EN      U IO S SRABATCH=1 D ^SROAPAS Q
    28 END     I 'SRSOUT,$E(IOST)'="P" D RET
    29         W @IOF I $E(IOST)="P" D ^%ZISC W @IOF
    30         D ^SRSKILL K SRMD,SRMD1,SRSFLG
    31         Q
    32 LIST    W @IOF,!,"This assessment is missing the following items:",! S SRZ="",SRCNT=1
    33         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
    34         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
    35         Q:'Y  I $$LOCK^SROUTL(SRTN) D PRT,UNLOCK^SROUTL(SRTN)
    36         Q
    37 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)
    38         .I $E(SRMD,1,10)="ANESTHESIA" D ANES Q
    39         .I $E(SRMD,1,6)="POSTOP"!($E(SRMD,1,6)="SEPSIS") D POST^SROCMPS Q
    40         .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
    41         S:'$G(SRSOUT) SRSOUT=0
    42         Q
    43 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
    44         Q
    45 RET     W !! K DIR S DIR(0)="E" D ^DIR K DIR W @IOF I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
    46         Q
    47 PAGE    I $E(IOST)'="P" D RET Q
    48         W @IOF,!!!
    49         Q
     1SROACOM ;BIR/MAM - COMPLETE ASSESSMENT ;02/08/07
     2 ;;3.0; Surgery ;**38,55,63,65,88,93,95,102,100,125,134,142,160**;24 Jun 93;Build 7
     3 I '$D(SRTN) Q
     4 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
     5 I $P(SRA,"^",2)="N",$P(SRA,"^",6)="Y" D CHK^SROAUTL
     6 I $P(SRA,"^",2)="N",$P(SRA,"^",6)="N" D CHK^SROAUTL3
     7 I $P(SRA,"^",2)="C" D CHK^SROAUTLC
     8 S SRFLD="" I $O(SRX(SRFLD))'="" D LIST
     9 I $P(SRA,"^",2)="C" D CHCK G:SRSOUT END
     10YEP 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."
     11 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"
     12 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
     13 I 'Y W !!,"No action taken." G END
     14 I $$LOCK^SROUTL(SRTN) D COMPLT Q
     15 E  W !!,"No action taken." G END
     16 Q
     17COMPLT W !!,"Updating the current status to 'COMPLETE'..." K DR,DIE S DA=SRTN,DIE=130,DR="235///C" D ^DIE K STATUS
     18 I $P(SRA,"^",5)="" K DR,DIE S DA=SRTN,DIE=130,DR="272///"_DT D ^DIE K STATUS
     19 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
     20 D UNLOCK^SROUTL(SRTN)
     21PRINT W !!,"Do you want to print the completed assessment ?  YES//  " R SRYN:DTIME I '$T!(SRYN["^") S SRSOUT=1 Q
     22 S SRYN=$E(SRYN) S:SRYN="" SRYN="Y" I "Nn"[SRYN S SRSOUT=1 Q
     23 I "Yy"'[SRYN W !!,"Enter <RET> to print the completed assessment, or 'NO' to return to the menu." G PRINT
     24 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
     25 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
     26 D EN,END
     27 Q
     28EN U IO S SRABATCH=1 D ^SROAPAS Q
     29END I 'SRSOUT,$E(IOST)'="P" D RET
     30 W @IOF I $E(IOST)="P" D ^%ZISC W @IOF
     31 D ^SRSKILL K SRSFLG
     32 Q
     33LIST W @IOF,!,"This assessment is missing the following items:",! S SRZ="",SRCNT=1
     34 ;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.",!
     35 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
     36 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
     37 Q:'Y  I $$LOCK^SROUTL(SRTN) D PRT,UNLOCK^SROUTL(SRTN)
     38 Q
     39PRT 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)
     40 .I $E(SRMD,1,10)="ANESTHESIA" D ANES Q
     41 .I $E(SRMD,1,6)="POSTOP"!($E(SRMD,1,6)="SEPSIS") D POST^SROCMPS Q
     42 .I SRMD=240 D FUNCT Q
     43 .I SRMD=492 D FUNCTI^SROAPRE Q
     44 .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
     45 .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
     46 S:'$G(SRSOUT) SRSOUT=0
     47 Q
     48FUNCT I $P($G(^SRF(SRTN,"RA")),"^",2)="C" D FUNCT^SROACLN Q
     49 D FUNCTJ^SROAPRE
     50 Q
     51ANES 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
     52 Q
     53CHCK ; cardiac checks added by SR*3*93
     54 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)
     55 I SRADM,SRDIS,SRADM'<SRDIS W !!,"  ***  NOTE: Discharge Date precedes Admission Date!!  Please check.  ***" S SRRET=1,SRX(418)=""
     56 I SRISCH,SRCPB,SRISCH>SRCPB W !!,"  ***  NOTE: Ischemic Time is greater than CPB Time!!  Please check.  ***",! S SRRET=1,SRX(450)=""
     57 I SRRET W ! K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DTOUT)!$D(DUOUT) SRSOUT=1 W !
     58 Q
     59RET W !! K DIR S DIR(0)="E" D ^DIR K DIR W @IOF I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
     60 Q
     61PAGE I $E(IOST)'="P" D RET Q
     62 W @IOF,!!!
     63 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROACOP.m

    r613 r623  
    1 SROACOP ;BIR/MAM - CARDIAC OPERATIVE RISK SUMMARY ;12/20/07
    2         ;;3.0; Surgery ;**38,47,71,88,95,107,100,125,142,153,160,166**;24 Jun 93;Build 7
    3         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
    4         N SRCSTAT S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
    5 START   D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO
    6         F I=206,206.1,208 S SRA(I)=$G(^SRF(SRTN,I))
    7         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))
    8         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"
    9         S SRAO(1)=$P(SRA(206),"^",31)_"^364",SRAO(3)=$P(SRA(208),"^",12)_"^414"
    10         S (X,Y)=$P(SRA(206),"^",32) D:Y DT S SRAO("1A")=X_"^364.1"
    11         S Y=$P(SRAO(3),"^") I Y'="" S C=$P(^DD(130,414,0),"^",2) D Y^DIQ S $P(SRAO(3),"^")=Y
    12         S Y=$P(SRA(208),"^",13) D DT S SRAO("3A")=X_"^414.1"
    13         S Y=$P($G(^SRF(SRTN,.2)),"^",2) D DT S SRAO(4)=X_"^.22"
    14         S Y=$P($G(^SRF(SRTN,.2)),"^",3) D DT S SRAO(5)=X_"^.23"
    15         S SRAO(6)=SRA(206.1)_"^430"
    16         S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,SRTN,10)),"^"):"",1:"Not ")_"Complete <<"
    17         S SRPAGE="PAGE: 1" D HDR^SROAUTL S SRAO(7)=""
    18         S (X,X1)=$P(SRAO(1),"^"),X=$S(X?1.3N:X_"%",1:X) W !," 1. Physician's Preoperative Estimate of Operative Mortality: "_X
    19         S X=$P(SRAO("1A"),"^") I X1'=""!(X'="") W !,?3," A. Date/Time Collected:    "_X
    20         W !," 2. ASA Classification:",?31,$P(SRAO(2),"^"),!," 3. Surgical Priority:",?31,$P(SRAO(3),"^")
    21         S X=$P(SRAO("3A"),"^") I X'="" W !,?3," A. Date/Time Collected:    "_X
    22         W !," 4. Date/Time Operation Began:",?31,$P(SRAO(4),"^"),!," 5. Date/Time Operation Ended:",?31,$P(SRAO(5),"^")
    23         W !," 6. Preoperative Risk Factors: "
    24         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
    25         .I X'[" " W ?25,X Q
    26         .S I=0,LINE=1 F  S SRL=$S(LINE=1:48,1:80) D  Q:SRQ
    27         ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q
    28         ..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
    29         N SRPROC,SRL S SRL=49 D CPTS^SROAUTL0 W !," 7. CPT Codes (view only):"
    30         F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
    31         W ! D CHCK
    32         W !! F MOE=1:1:80 W "-"
    33 ASK     W !,"Select Operative Risk Summary Information to Edit: " R X:DTIME I '$T!("^"[X) G END
    34         S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START
    35         I X="A" S X="1:7"
    36         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
    37         I X'=7 D HDR^SROAUTL
    38         I X?.N1":".N D RANGE S SROERR=SRTN D ^SROERR0 G START
    39         I $D(SRAO(X))!(X=6) S EMILY=X D  S SROERR=SRTN D ^SROERR0 G START
    40         .I $$LOCK^SROUTL(SRTN) W !! D ONE,UNLOCK^SROUTL(SRTN)
    41 END     I '$D(SREQST) W @IOF D ^SRSKILL
    42         Q
    43 DT      I 'Y S X="" Q
    44         X ^DD("DD") S X=$P(Y,"@")_" "_$P(Y,"@",2)
    45         Q
    46 HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
    47         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)"
    48         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.)"
    49         W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1
    50         Q
    51 RANGE   ; range of numbers
    52         I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
    53         .W !! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
    54         Q
    55 ONE     ; edit one item
    56         I EMILY=7 D DISP^SROAUTL0 Q
    57         K DR,DIE S DA=SRTN,DIE=130,DR=$P(SRAO(EMILY),"^",2)
    58         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
    59         I EMILY=1 D
    60         .I $P(^SRF(SRTN,206),"^",31)="NS" S $P(^SRF(SRTN,206),"^",32)="NS" Q
    61         .S DR="364.1T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1
    62         Q
    63 RET     Q:SRSOUT  W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
    64         Q
    65 NOW     ; update date/time of estimate of mortality
    66         N X D NOW^%DTC S $P(^SRF(DA,206),"^",32)=$E(%,1,12)
    67         Q
    68 KNOW    ; delete date/time of estimate of mortality
    69         S $P(^SRF(DA,206),"^",32)=""
    70         Q
    71 YN      ; store answer
    72         S SHEMP=$S(NYUK="NS":"Unknown",NYUK="N":"NO",NYUK="Y":"YES",1:"")
    73         Q
    74 CHCK    ;compare dates
    75         N SRINO,SRSP,SREM
    76         S SRSP=$P($G(^SRF(SRTN,208)),"^",13),SRINO=$P($G(^SRF(SRTN,.2)),"^",10),SREM=$P($G(^SRF(SRTN,206)),"^",32)
    77         I SRSP'="",SRINO'="",SRSP'<SRINO W !!,"*** NOTE: D/Time of Surgical Priority should be < the D/Time Patient in OR.***"
    78         I SREM'="",SRINO'="",SREM'<SRINO W !!,"*** NOTE: D/Time of Estimate of Mortality should be < the D/Time PT in OR. ***"
    79         Q
     1SROACOP ;BIR/MAM - CARDIAC OPERATIVE RISK SUMMARY ;02/14/07
     2 ;;3.0; Surgery ;**38,47,71,88,95,107,100,125,142,153,160**;24 Jun 93;Build 7
     3 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
     4 N SRCSTAT S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
     5START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO
     6 F I=206,206.1,208 S SRA(I)=$G(^SRF(SRTN,I))
     7 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))
     8 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"
     9 S SRAO(1)=$P(SRA(206),"^",31)_"^364",SRAO(3)=$P(SRA(208),"^",12)_"^414"
     10 S Y=$P(SRA(206),"^",32) D DT S SRAO("1A")=X_"^364.1"
     11 S Y=$P(SRAO(3),"^") I Y'="" S C=$P(^DD(130,414,0),"^",2) D Y^DIQ S $P(SRAO(3),"^")=Y
     12 S Y=$P(SRA(208),"^",13) D DT S SRAO("3A")=X_"^414.1"
     13 S Y=$P($G(^SRF(SRTN,.2)),"^",2) D DT S SRAO(4)=X_"^.22"
     14 S Y=$P($G(^SRF(SRTN,.2)),"^",3) D DT S SRAO(5)=X_"^.23"
     15 S SRAO(6)=SRA(206.1)_"^430"
     16 S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,SRTN,10)),"^"):"",1:"Not ")_"Complete <<"
     17 S SRPAGE="PAGE: 1" D HDR^SROAUTL S SRAO(7)=""
     18 S X=$P(SRAO(1),"^"),X=$S(X?1.3N:X_"%",1:X) W !," 1. Physician's Preoperative Estimate of Operative Mortality: "_X
     19 S X=$P(SRAO("1A"),"^") I X'="" W !,?3," A. Date/Time Collected:    "_X
     20 W !," 2. ASA Classification:",?31,$P(SRAO(2),"^"),!," 3. Surgical Priority:",?31,$P(SRAO(3),"^")
     21 S X=$P(SRAO("3A"),"^") I X'="" W !,?3," A. Date/Time Collected:    "_X
     22 W !," 4. Date/Time Operation Began:",?31,$P(SRAO(4),"^"),!," 5. Date/Time Operation Ended:",?31,$P(SRAO(5),"^")
     23 W !," 6. Preoperative Risk Factors: "
     24 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
     25 .I X'[" " W ?25,X Q
     26 .S I=0,LINE=1 F  S SRL=$S(LINE=1:48,1:80) D  Q:SRQ
     27 ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q
     28 ..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
     29 N SRPROC,SRL S SRL=49 D CPTS^SROAUTL0 W !," 7. CPT Codes (view only):"
     30 F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
     31 W ! D CHCK
     32 W !! F MOE=1:1:80 W "-"
     33ASK W !,"Select Operative Risk Summary Information to Edit: " R X:DTIME I '$T!("^"[X) G END
     34 S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START
     35 I X="A" S X="1:7"
     36 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
     37 I X'=7 D HDR^SROAUTL
     38 I X?.N1":".N D RANGE S SROERR=SRTN D ^SROERR0 G START
     39 I $D(SRAO(X))!(X=6) S EMILY=X D  S SROERR=SRTN D ^SROERR0 G START
     40 .I $$LOCK^SROUTL(SRTN) W !! D ONE,UNLOCK^SROUTL(SRTN)
     41END I '$D(SREQST) W @IOF D ^SRSKILL
     42 Q
     43DT I 'Y S X="" Q
     44 X ^DD("DD") S X=$P(Y,"@")_" "_$P(Y,"@",2)
     45 Q
     46HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
     47 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)"
     48 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.)"
     49 W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1
     50 Q
     51RANGE ; range of numbers
     52 I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
     53 .W !! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
     54 Q
     55ONE ; edit one item
     56 I EMILY=7 D DISP^SROAUTL0 Q
     57 K DR,DIE S DA=SRTN,DIE=130,DR=$P(SRAO(EMILY),"^",2)
     58 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
     59 Q
     60RET Q:SRSOUT  W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
     61 Q
     62NOW ; update date/time of estimate of mortality
     63 N X D NOW^%DTC S $P(^SRF(DA,206),"^",32)=$E(%,1,12)
     64 Q
     65KNOW ; delete date/time of estimate of mortality
     66 S $P(^SRF(DA,206),"^",32)=""
     67 Q
     68YN ; store answer
     69 S SHEMP=$S(NYUK="NS":"Unknown",NYUK="N":"NO",NYUK="Y":"YES",1:"")
     70 Q
     71CHCK ;compare dates
     72 N SRINO,SRSP,SREM
     73 S SRSP=$P($G(^SRF(SRTN,208)),"^",13),SRINO=$P($G(^SRF(SRTN,.2)),"^",10),SREM=$P($G(^SRF(SRTN,206)),"^",32)
     74 I SRSP'="",SRINO'="",SRSP'<SRINO W !!,"*** NOTE: D/Time of Surgical Priority should be < the D/Time Patient in OR.***"
     75 I SREM'="",SRINO'="",SREM'<SRINO W !!,"*** NOTE: D/Time of Estimate of Mortality should be < the D/Time PT in OR. ***"
     76 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROACPM.m

    r613 r623  
    1 SROACPM ;BIR/ADM - CARDIAC RESOURCE INFO ;12/04/07
    2         ;;3.0; Surgery ;**71,93,95,99,100,125,142,160,164,166**;24 Jun 93;Build 7
    3         ;
    4         ; Reference to ^DGPM("APTT1" supported by DBIA #565
    5         ;
    6         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
    7         S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
    8 START   G:SRSOUT END D HDR^SROAUTL
    9         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)=" "
    10         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."
    11         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
    12         I Y=1 D PIMS G START
    13 EDIT    N DAYS,HOURS,MINS
    14         S:$P(^SRF(SRTN,206),"^",41)="" $P(^SRF(SRTN,206),"^",41)="N"
    15         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"
    16         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
    17         K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
    18         .D TR,GET
    19         .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
    20         .W:M>1 ! W $J(SRZ,2)_". "_$P(Z,"^")_": " D EXT
    21         D CHCK W ! F K=1:1:80 W "-"
    22         D SEL G:SRR=1 EDIT
    23         G START
    24         Q
    25 CHCK    ; compare admission and discharge dates to each other
    26         N SRADM,SRDIS,SROUT,SRDICU,SREXT
    27         S SROUT=SRY(130,SRTN,.232,"I"),SRDICU=SRY(130,SRTN,471,"I"),SREXT=SRY(130,SRTN,470,"I")
    28         S SRADM=SRY(130,SRTN,418,"I"),SRDIS=SRY(130,SRTN,419,"I") W !
    29         I SRADM,SRDIS,SRADM'<SRDIS W !,"*** NOTE: Discharge Date precedes Admission Date!!  Please check. ***"
    30         I SREXT,SROUT,SREXT'>SROUT W !,"*** NOTE: D/Time Pt Extubated should be later than the D/Time Pt Out of OR. ***"
    31         I SREXT,SRDICU,SREXT'<SRDICU W !,"*** NOTE: D/Time Pt Extubated should be < the ICU Discharge D/Time. ***"
    32         I SRDICU,SREXT,SRDICU'>SREXT W !,"*** NOTE: D/Time Discharged from ICU should be > the Extubation D/Time. ***"
    33         I SRDICU,SRDIS,SRDICU>SRDIS W !,"*** NOTE: D/Time Discharged from ICU should be <= the Hospital Discharge D/Time*"
    34         Q
    35 EXT     I SRFLD=440&(SREXT="NS") S SREXT=SREXT_"-"_$S(SREXT="NS":"No Study",1:SREXT)
    36         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)
    37         I SRFLD=470,$G(SRY(130,SRTN,470,"I")) D  Q
    38         .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)
    39         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)
    40         I $L(SREXT)<41 W ?39,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q
    41         I SRFLD=431 D
    42         .I $L(SREXT)<52 W ?28,SREXT Q
    43         .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
    44         ..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
    45         Q
    46 SEL     S SRSOUT=0 W !!,"Select Resource Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
    47         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
    48         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
    49         I X="A" S X="1:"_SRZ
    50         I X?1.2N1":"1.2N D RANGE S SRR=1 Q
    51         I $D(SRZ(X)),+X=X S EMILY=X D  S SRR=1
    52         .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
    53         Q
    54 PIMS    ; get update from PIMS records
    55         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
    56         W ! D WAIT^DICD D ^SROAPIMS
    57         Q
    58 HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
    59         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),"^")_".)"
    60         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.)",!
    61         I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",!
    62 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
    63         Q
    64 RANGE   ; range of numbers
    65         I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
    66         .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
    67         Q
    68 ONE     ; edit one item
    69         I EMILY=7 D LIST
    70         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
    71         I 'SRSOUT,EMILY=1!(EMILY=2) D OK
    72         I EMILY=12 D CHK
    73         Q
    74 OK      ; compare admission date to discharge date
    75         N SRADM,SRDIS S X=$G(^SRF(SRTN,208)),SRADM=$P(X,"^",14),SRDIS=$P(X,"^",15)
    76         I SRADM,SRDIS,SRADM'<SRDIS W !!,"  ***  NOTE: Discharge Date precedes Admission Date!!  Please check.  ***",! D PRESS W !
    77         Q
    78 CHK     ; compare date OF OPERATION to CT Surgery Consult Date
    79         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
    80         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
    81         Q
    82 LIST    ; display list of patient movements
    83         N CNT,SRADM,SRLOC,SRMOVE,SRMVMT,SRN,SRT,SRTYPE,SRZ,SRY
    84         S DFN=$P(^SRF(SRTN,0),"^"),SRZ=$P($G(^SRF(SRTN,.2)),"^",12)
    85         S SRADM=0 D ADM
    86         S CNT=0 F  Q:'SRZ  D:SRZ MVMT
    87         ;Q:CNT=0
    88         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"
    89         W !,?5,"that occurred during the inpatient stay associated with this surgery.",!
    90         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)
    91         I '$O(SRMVMT(0)) W !,?5,">> No postoperative patient movements were found for this patient."
    92         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
    93         .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
    94         K DA,DIE,DR S DA=SRTN,DIE=130,DR="471T" D ^DIE K DA,DIE,DR
    95         Q
    96 MVMT    S VAIP("D")=SRZ D IN5^VADPT S SRY=$P(VAIP(3),"^")
    97         I SRY S CNT=CNT+1 D
    98         .S SRMOVE=$P(VAIP(3),"^",2),SRTYPE=$P(VAIP(2),"^",1,2),SRLOC=$P(VAIP(5),"^",2)
    99         .S SRMVMT(CNT)=SRMOVE_"^"_SRTYPE_"^"_SRLOC
    100         I 'SRY S SRZ="" Q
    101         I VAIP(1)=VAIP(17) S SRZ="" Q
    102         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
    103         S SRZ=$P(VAIP(16,1),"^")
    104         Q
    105 ADM     N SR24 S VAIP("D")=SRZ D IN5^VADPT
    106         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
    107         I VAIP(13) S SRZ=$P(VAIP(13,1),"^")+.000001
    108         Q
    109 TR      S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
    110         Q
    111 GET     S X=$T(@J)
    112         Q
    113 END     W @IOF D ^SRSKILL
    114         Q
    115 DAH     ;;418^Hospital Admission Date
    116 DAI     ;;419^Hospital Discharge Date
    117 DDJ     ;;440^Cardiac Catheterization Date
    118 PBJE    ;;.205^Time Patient In OR
    119 PBCB    ;;.232^Time Patient Out OR
    120 DGJ     ;;470^Date/Time Patient Extubated
    121 DGA     ;;471^Date/Time Discharged from ICU
    122 DDB     ;;442^Employment Status Preoperatively
    123 DCA     ;;431^Resource Data Comments
    124 DGC     ;;473^Homeless
    125 DGB     ;;472^Surg Performed at Non-VA Facility
    126 EAC     ;;513^CT Surgery Consult Date
    127 EAE     ;;515^Cause for Delay for Surgery
     1SROACPM ;BIR/ADM - CARDIAC RESOURCE INFO ;08/23/07
     2 ;;3.0; Surgery ;**71,93,95,99,100,125,142,160,164**;24 Jun 93;Build 2
     3 ;
     4 ; Reference to ^DGPM("APTT1" supported by DBIA #565
     5 ;
     6 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
     7 S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
     8START G:SRSOUT END D HDR^SROAUTL
     9 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)=" "
     10 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."
     11 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
     12 I Y=1 D PIMS G START
     13EDIT S:$P(^SRF(SRTN,206),"^",41)="" $P(^SRF(SRTN,206),"^",41)="N"
     14 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"
     15 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
     16 K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
     17 .D TR,GET
     18 .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
     19 .W:M>1 ! W $J(SRZ,2)_". "_$P(Z,"^")_": " D EXT
     20 D CHCK W ! F K=1:1:80 W "-"
     21 D SEL G:SRR=1 EDIT
     22 G START
     23 Q
     24CHCK ; compare admission and discharge dates to each other
     25 N SRADM,SRDIS,SROUT,SRDICU,SREXT
     26 S SROUT=SRY(130,SRTN,.232,"I"),SRDICU=SRY(130,SRTN,471,"I"),SREXT=SRY(130,SRTN,470,"I")
     27 S SRADM=SRY(130,SRTN,418,"I"),SRDIS=SRY(130,SRTN,419,"I") W !
     28 I SRADM,SRDIS,SRADM'<SRDIS W !,"*** NOTE: Discharge Date precedes Admission Date!!  Please check. ***"
     29 I SREXT,SROUT,SREXT'>SROUT W !,"*** NOTE: D/Time Pt Extubated should be later than the D/Time Pt Out of OR. ***"
     30 I SREXT,SRDICU,SREXT'<SRDICU W !,"*** NOTE: D/Time Pt Extubated should be < the ICU Discharge D/Time. ***"
     31 I SRDICU,SREXT,SRDICU'>SREXT W !,"*** NOTE: D/Time Discharged from ICU should be > the Extubation D/Time. ***"
     32 I SRDICU,SRDIS,SRDICU>SRDIS W !,"*** NOTE: D/Time Discharged from ICU should be <= the Hospital Discharge D/Time*"
     33 Q
     34EXT I SRFLD=440&(SREXT="NS") S SREXT=SREXT_"-"_$S(SREXT="NS":"No Study",1:SREXT)
     35 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)
     36 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)
     37 I $L(SREXT)<41 W ?39,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q
     38 I SRFLD=431 D
     39 .I $L(SREXT)<52 W ?28,SREXT Q
     40 .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
     41 ..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
     42 Q
     43SEL S SRSOUT=0 W !!,"Select number of item to edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
     44 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
     45 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
     46 I X="A" S X="1:"_SRZ
     47 I X?1.2N1":"1.2N D RANGE S SRR=1 Q
     48 I $D(SRZ(X)),+X=X S EMILY=X D  S SRR=1
     49 .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
     50 Q
     51PIMS ; get update from PIMS records
     52 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
     53 W ! D WAIT^DICD D ^SROAPIMS
     54 Q
     55HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
     56 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),"^")_".)"
     57 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.)",!
     58 I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",!
     59PRESS 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
     60 Q
     61RANGE ; range of numbers
     62 I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
     63 .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
     64 Q
     65ONE ; edit one item
     66 I EMILY=7 D LIST
     67 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
     68 I 'SRSOUT,EMILY=1!(EMILY=2) D OK
     69 Q
     70OK ; compare admission date to discharge date
     71 N SRADM,SRDIS S X=$G(^SRF(SRTN,208)),SRADM=$P(X,"^",14),SRDIS=$P(X,"^",15)
     72 I SRADM,SRDIS,SRADM'<SRDIS W !!,"  ***  NOTE: Discharge Date precedes Admission Date!!  Please check.  ***",! D PRESS W !
     73 Q
     74LIST ; display list of patient movements
     75 N CNT,SRADM,SRLOC,SRMOVE,SRMVMT,SRT,SRTYPE,SRZ,SRY
     76 S DFN=$P(^SRF(SRTN,0),"^"),SRZ=$P($G(^SRF(SRTN,.2)),"^",12)
     77 S SRADM=0 D ADM Q:'SRZ
     78 S CNT=0 F  Q:'SRZ  D MVMT
     79 Q:CNT=0
     80 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"
     81 W !,?5,"that occurred during the inpatient stay associated with this surgery.",!
     82 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)
     83 W !
     84 Q
     85MVMT S VAIP("D")=SRZ D IN5^VADPT S SRY=$P(VAIP(3),"^")
     86 I SRY S CNT=CNT+1 D
     87 .S SRMOVE=$P(VAIP(3),"^",2),SRTYPE=$P(VAIP(2),"^",1,2),SRLOC=$P(VAIP(5),"^",2)
     88 .S SRMVMT(CNT)=SRMOVE_"^"_SRTYPE_"^"_SRLOC
     89 I 'SRY S SRZ="" Q
     90 I VAIP(1)=VAIP(17) S SRZ="" Q
     91 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
     92 S SRZ=$P(VAIP(16,1),"^")
     93 Q
     94ADM N SR24 S VAIP("D")=SRZ D IN5^VADPT
     95 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
     96 I VAIP(13) S SRZ=$P(VAIP(13,1),"^")+.000001
     97 Q
     98TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
     99 Q
     100GET S X=$T(@J)
     101 Q
     102END W @IOF D ^SRSKILL
     103 Q
     104DAH ;;418^Hospital Admission Date
     105DAI ;;419^Hospital Discharge Date
     106DDJ ;;440^Cardiac Catheterization Date
     107PBJE ;;.205^Time Patient In OR
     108PBCB ;;.232^Time Patient Out OR
     109DGJ ;;470^Date/Time Patient Extubated
     110DGA ;;471^Date/Time Discharged from ICU
     111DDB ;;442^Employment Status Preoperatively
     112DCA ;;431^Resource Data Comments
     113DGC ;;473^Homeless
     114DGB ;;472^Surg Performed at Non-VA Facility
     115EAC ;;513^CT Surgery Consult Date
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROACPM1.m

    r613 r623  
    1 SROACPM1        ;BIR/SJA - LAB INFO ;01/14/08
    2         ;;3.0; Surgery ;**125,153,166**;24 Jun 93;Build 7
    3         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
    4         S SRSOUT=0 D ^SROAUTL
    5 START   G:SRSOUT END K SRA,SRAO D ^SROACPM2,DISP
    6 ASK     W !!,"Select Laboratory Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 D CONCC G END
    7         I X="" D CONCC G END
    8         S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START
    9         I X="A" S X="1:10"
    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
    11         S SRPAGE="" D HDR^SROAUTL
    12         I X?.N1":".N D RANGE G START
    13         I $D(SRAO(X)) S EMILY=X D ONE G START
    14 END     W @IOF
    15         Q
    16 HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
    17         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)"
    18         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)"
    19         W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1
    20         Q
    21 RANGE   ; range of numbers
    22         S SRNOMORE=0,SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRNOMORE  D ONE
    23         Q
    24 ONE     ; edit one item
    25         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
    26         Q
    27 RET     Q:SRSOUT  W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
    28         Q
    29 DISP    N SRX S SRPAGE="PAGE: 1",SRHDR(.5)="PREOPERATIVE LABORATORY RESULTS" D HDR^SROAUTL
    30         S SRX=$P(SRAO(1),"^") W !," 1. HDL:",?25,$J(SRX,6),?35,$$NORCHK(21,SRX),?38,$P(SRAO(1),"^",2)
    31         S SRX=$P(SRAO(2),"^") W !," 2. LDL:",?25,$J(SRX,6),?35,$$NORCHK(23,SRX),?38,$P(SRAO(2),"^",2)
    32         S SRX=$P(SRAO(3),"^") W !," 3. Total Cholesterol:",?25,$J(SRX,6),?35,$$NORCHK(24,SRX),?38,$P(SRAO(3),"^",2)
    33         S SRX=$P(SRAO(4),"^") W !," 4. Serum Triglyceride:",?25,$J(SRX,6),?35,$$NORCHK(22,SRX),?38,$P(SRAO(4),"^",2)
    34         S SRX=$P(SRAO(5),"^") W !," 5. Serum Potassium:",?25,$J(SRX,6),?35,$$NORCHK(5,SRX),?38,$P(SRAO(5),"^",2)
    35         S SRX=$P(SRAO(6),"^") W !," 6. Serum Bilirubin:",?25,$J(SRX,6),?35,$$NORCHK(14,SRX),?38,$P(SRAO(6),"^",2)
    36         S SRX=$P(SRAO(7),"^") W !," 7. Serum Creatinine:",?25,$J(SRX,6),?35,$$NORCHK(7,SRX),?38,$P(SRAO(7),"^",2)
    37         S SRX=$P(SRAO(8),"^") W !," 8. Serum Albumin:",?25,$J(SRX,6),?35,$$NORCHK(11,SRX),?38,$P(SRAO(8),"^",2)
    38         S SRX=$P(SRAO(9),"^") W !," 9. Hemoglobin:",?25,$J(SRX,6),?35,$$NORCHK(1,SRX),?38,$P(SRAO(9),"^",2)
    39         S SRX=$P(SRAO(10),"^") W !,"10. Hemoglobin A1c:",?25,$J(SRX,6),?35,$$NORCHK(27,SRX),?38,$P(SRAO(10),"^",2)
    40         W !! F MOE=1:1:80 W "-"
    41         Q
    42 CONCC   ; check for concurrent case and update if one exists
    43         S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON
    44         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
    45         .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="@"
    46         .K DA,DIE,DR S DA=SRCON,DIE=130,DR=S1_"////"_P1_";"_S2_"////"_P2 D ^DIE K DR
    47         Q
    48 NORCHK(SRAT,RESULT)     ;
    49         I RESULT']""!(RESULT="NS") Q ""
    50         N NODE,LOW,HIGH,SRY
    51         S SRY="" S:"<>"[$E(RESULT) SRY=$E(RESULT),RESULT=$E(RESULT,2,99)
    52         S NODE=$G(^SRO(139.2,SRAT,2)),LOW=$P(NODE,"^",2),HIGH=$P(NODE,"^",3) Q:LOW']""!(HIGH']"")
    53         I SRY'="" Q $S(RESULT<(LOW+.01):"L",((RESULT>(HIGH-.01))&(SRY=">")):"H",1:"")
    54         Q $S(RESULT<LOW:"L",RESULT>HIGH:"H",1:"")
     1SROACPM1 ;BIR/SJA - LAB INFO ;05/04/06
     2 ;;3.0; Surgery ;**125,153**;24 Jun 93;Build 11
     3 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
     4 S SRSOUT=0 D ^SROAUTL
     5START G:SRSOUT END K SRA,SRAO D ^SROACPM2,DISP
     6ASK W !!,"Select Laboratory Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 D CONCC G END
     7 I X="" D CONCC G END
     8 S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START
     9 I X="A" S X="1:10"
     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
     11 S SRPAGE="" D HDR^SROAUTL
     12 I X?.N1":".N D RANGE G START
     13 I $D(SRAO(X)) S EMILY=X D ONE G START
     14END W @IOF
     15 Q
     16HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
     17 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)"
     18 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)"
     19 W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1
     20 Q
     21RANGE ; range of numbers
     22 S SRNOMORE=0,SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRNOMORE  D ONE
     23 Q
     24ONE ; edit one item
     25 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
     26 Q
     27RET Q:SRSOUT  W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
     28 Q
     29DISP S SRPAGE="PAGE: 1",SRHDR(.5)="PREOPERATIVE LABORATORY RESULTS" D HDR^SROAUTL
     30 W !," 1. HDL:",?25,$J($P(SRAO(1),"^"),6),?35,$P(SRAO(1),"^",2)
     31 W !," 2. LDL:",?25,$J($P(SRAO(2),"^"),6),?35,$P(SRAO(2),"^",2)
     32 W !," 3. Total Cholesterol:",?25,$J($P(SRAO(3),"^"),6),?35,$P(SRAO(3),"^",2)
     33 W !," 4. Serum Triglyceride:",?25,$J($P(SRAO(4),"^"),6),?35,$P(SRAO(4),"^",2)
     34 W !," 5. Serum Potassium:",?25,$J($P(SRAO(5),"^"),6),?35,$P(SRAO(5),"^",2)
     35 W !," 6. Serum Bilirubin:",?25,$J($P(SRAO(6),"^"),6),?35,$P(SRAO(6),"^",2)
     36 W !," 7. Serum Creatinine:",?25,$J($P(SRAO(7),"^"),6),?35,$P(SRAO(7),"^",2)
     37 W !," 8. Serum Albumin:",?25,$J($P(SRAO(8),"^"),6),?35,$P(SRAO(8),"^",2)
     38 W !," 9. Hemoglobin:",?25,$J($P(SRAO(9),"^"),6),?35,$P(SRAO(9),"^",2)
     39 W !,"10. Hemoglobin A1c:",?25,$J($P(SRAO(10),"^"),6),?35,$P(SRAO(10),"^",2)
     40 W !! F MOE=1:1:80 W "-"
     41 Q
     42CONCC ; check for concurrent case and update if one exists
     43 S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON
     44 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
     45 .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="@"
     46 .K DA,DIE,DR S DA=SRCON,DIE=130,DR=S1_"////"_P1_";"_S2_"////"_P2 D ^DIE K DR
     47 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROACR2.m

    r613 r623  
    1 SROACR2 ;BIR/SJA - OPERATIVE DATA, PAGE 2 ;12/03/07
    2         ;;3.0; Surgery ;**125,153,160,166**;24 Jun 93;Build 7
    3         ;
    4         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
    5         S SRSOUT=0 D ^SROAUTL
    6 START   G:SRSOUT END
    7         ;
    8 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 "-"
    9         ;
    10         K DR S SRQ=0,(DR,SRDR)="381;382;451;450;468;469"
    11         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
    12         K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
    13         .K SREXT D TR,GET
    14         .S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRX(SRX))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
    15         .I SRFLD=451 W !,"Other Operative Data details:",!,"------------------------------"
    16         .W !,$J(SRX,2)_". "_$P(Z,"^")_":" D EXT
    17         .W:SRFLD=382 !
    18         D CHCK W ! F K=1:1:80 W "-"
    19         D SEL G:SRR=1 EDIT
    20         S SRSOUT=1 G END
    21         Q
    22 SEL     S SRSOUT=0 W !!,"Select Cardiac Procedures Operative Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
    23         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
    24         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
    25         I X="A" S X="1:"_SRX
    26         I X?1.2N1":"1.2N D RANGE S SRR=1 K SREXT Q
    27         I $D(SRX(X)),+X=X S EMILY=X D  S SRR=1
    28         .I $$LOCK^SROUTL(SRTN) W ! D ONE,UNLOCK^SROUTL(SRTN)
    29         Q
    30 EXT     W ?30,SREXT
    31         Q
    32 HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
    33         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.)"
    34         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.)"
    35         D RET
    36         Q
    37 CHCK    ; compare ischemic time to CPB time
    38         I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS
    39         N SRISCH,SRCPB S SRISCH=SRY(130,SRTN,450,"E"),SRCPB=SRY(130,SRTN,451,"E")
    40         I SRISCH,SRCPB,SRISCH>SRCPB W !,IORVON_"***  NOTE: Ischemic Time is greater than CPB Time!!  Please check.  ***"_IORVOFF
    41         Q
    42 RET     Q:SRSOUT  W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
    43         Q
    44 RANGE   ; range of numbers
    45         I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
    46         .W ! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
    47         Q
    48 ONE     ; edit one item
    49         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
    50         I EMILY=3,$P($G(^SRF(SRTN,206)),"^",37)>0,($P($G(^SRF(SRTN,207)),"^",27)=1) S $P(^SRF(SRTN,207),"^",27)=5
    51         Q
    52 TR      S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
    53         Q
    54 GET     S X=$T(@J)
    55         Q
    56 END     W @IOF D ^SRSKILL
    57         Q
    58 CHA     ;;381^Foreign Body Removal
    59 CHB     ;;382^Pericardiectomy
    60 DEA     ;;451^Total CPB Time
    61 DEJ     ;;450^Total Ischemic Time
    62 DFH     ;;468^Incision Type
    63 DFI     ;;469^Convert Off Pump to CPB
     1SROACR2 ;BIR/SJA - OPERATIVE DATA, PAGE 2 ;04/12/06
     2 ;;3.0; Surgery ;**125,153,160**;24 Jun 93;Build 7
     3 ;
     4 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
     5 S SRSOUT=0 D ^SROAUTL
     6START G:SRSOUT END
     7 ;
     8EDIT 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 "-"
     9 ;
     10 K DR S SRQ=0,(DR,SRDR)="381;382;451;450;468;469"
     11 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
     12 K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
     13 .K SREXT D TR,GET
     14 .S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRX(SRX))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
     15 .I SRFLD=451 W !,"Other Operative Data details:",!,"------------------------------"
     16 .W !,$J(SRX,2)_". "_$P(Z,"^")_":" D EXT
     17 .W:SRFLD=382 !
     18 D CHCK W ! F K=1:1:80 W "-"
     19 D SEL G:SRR=1 EDIT
     20 S SRSOUT=1 G END
     21 Q
     22SEL S SRSOUT=0 W !!,"Select Operative Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
     23 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
     24 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
     25 I X="A" S X="1:"_SRX
     26 I X?1.2N1":"1.2N D RANGE S SRR=1 K SREXT Q
     27 I $D(SRX(X)),+X=X S EMILY=X D  S SRR=1
     28 .I $$LOCK^SROUTL(SRTN) W ! D ONE,UNLOCK^SROUTL(SRTN)
     29 Q
     30EXT W ?30,SREXT
     31 Q
     32HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
     33 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.)"
     34 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.)"
     35 D RET
     36 Q
     37CHCK ; compare ischemic time to CPB time
     38 I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS
     39 N SRISCH,SRCPB S SRISCH=SRY(130,SRTN,450,"E"),SRCPB=SRY(130,SRTN,451,"E")
     40 I SRISCH,SRCPB,SRISCH>SRCPB W !,IORVON_"***  NOTE: Ischemic Time is greater than CPB Time!!  Please check.  ***"_IORVOFF
     41 Q
     42RET Q:SRSOUT  W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
     43 Q
     44RANGE ; range of numbers
     45 I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
     46 .W ! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
     47 Q
     48ONE ; edit one item
     49 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
     50 I EMILY=3,$P($G(^SRF(SRTN,206)),"^",37)>0,($P($G(^SRF(SRTN,207)),"^",27)=1) S $P(^SRF(SRTN,207),"^",27)=5
     51 Q
     52TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
     53 Q
     54GET S X=$T(@J)
     55 Q
     56END W @IOF D ^SRSKILL
     57 Q
     58CHA ;;381^Foreign Body Removal
     59CHB ;;382^Pericardiectomy
     60DEA ;;451^Total CPB Time
     61DEJ ;;450^Total Ischemic Time
     62DFH ;;468^Incision Type
     63DFI ;;469^Convert Off Pump to CPB
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROALEC.m

    r613 r623  
    1 SROALEC ;BIR/ADM - LIST OF ELIGIBLE CASES ;02/04/08
    2         ;;3.0; Surgery ;**160,166**;24 Jun 93;Build 7
    3         S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="CASES ELIGIBLE FOR ASSESSMENT" K ^TMP("SRA",$J)
    4         I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^")
    5         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
    6         I SRSP S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""  D SRSD Q:SRSOUT  D:TOT TOT
    7         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
    8         Q:SRSOUT  I SRSP,'SRFLG,GRAND D GRAND
    9         I SRFLG,'GRAND S SRSS=SRSPEC D HDR,GRAND
    10         I SRSP,'SRFLG,'GRAND S SRSS="" D HDR,GRAND
    11         I 'SRSP,'GRAND S SRSS="" D HDR,GRAND
    12         I 'SRSP,GRAND S SRSS="" D GRAND
    13         Q
    14 UTL     ; set up TMP global
    15         N SRCPLT
    16         I '$P($G(^SRF(SRTN,.2)),"^",3)&'$P($G(^SRF(SRTN,.2)),"^",12) Q
    17         I $P($G(^SRF(SRTN,30)),"^") Q
    18         I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
    19         S SRCPLT=$P($G(^SRO(136,SRTN,10)),"^") I SRCPLT,'$$XL^SROAX(SRTN) Q
    20         S SRA=$G(^SRF(SRTN,"RA"))
    21         I SRAST=1 Q:'($P(SRA,"^",2)="N"!($P(SRA,"^",2)="C"))!'($P(SRA,"^",6)="Y")
    22         I SRAST=2 Q:'($P(SRA,"^",2)="N"!($P(SRA,"^",2)="C"))!'($P(SRA,"^",6)="N")
    23         I SRAST=3 Q:$P(SRA,"^",2)'=""
    24         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
    25         S ^TMP("SRA",$J,SRSD,SRTN)=SRA
    26         Q
    27 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
    28         Q
    29 CASE    N SRA2 S SRA2=$P(SRA,"^",2) D
    30         .I SRA2="" S SRATYPE="NOT LOGGED" Q
    31         .I SRA2="N" D  Q
    32         .. I $P(SRA,"^",6)="N" S SRATYPE="EXCLUDED" Q
    33         .. S SRATYPE="NON-CARDIAC"
    34         .I SRA2="C" S SRATYPE="CARDIAC"
    35         S TOT=TOT+1,GRAND=GRAND+1 D PRINT
    36         Q
    37 PRINT   ; print case info
    38         N SRDA,SRPROCS,SRSP1,SRY S SRPROCS=""
    39         I $Y+8>IOSL!SRNEW D PAGE I SRSOUT Q
    40         S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
    41         I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
    42         S SRSP1="",X=$P(SRA(0),"^",4) S:X SRSP1=$P(^SRO(137.45,X,0),"^")
    43         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
    44         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=""
    45         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,"@")
    46         I $Y+7>IOSL D PAGE I SRSOUT Q
    47         W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?67,SRSTATUS,!,SRDT,?18,SROPS(1),! D
    48         .I 'SRSP W $E(SRSP1,1,17) F I=2:1 W:$D(SROPS(I)) ?18,SROPS(I),! I '$D(SROPS(I)) W ! Q
    49         .I SRSP F I=2:1 Q:'$D(SROPS(I))  W ?18,SROPS(I),!
    50         S SRY=$P($G(^SRO(136,SRTN,0)),"^",2) I SRY D CPT S SRPROCS=SRCODE
    51         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
    52         .S SRPROCS=SRPROCS_", "_SRCODE
    53         I '$P($G(^SRO(136,SRTN,10)),"^"),$L(SRPROCS) W !,">>> Final CPT Coding is not complete."
    54         S:SRPROCS="" SRPROCS="NOT ENTERED" W !,"CPT Codes: ",SRPROCS
    55         I 'SRSOUT W ! F LINE=1:1:80 W "-"
    56         Q
    57 CPT     ; check code for exclusion and get output value
    58         N Y,SREX S (SRCODE,SREX)=""
    59         S Y=$$CPT^ICPTCOD(SRY,$P(SRSD,".")),SRCODE=$P(Y,"^",2)
    60         S SREX="" I '$D(^SRO(137,SRY,0)) S SREX="*"
    61         S SRCODE=SREX_SRCODE
    62         Q
    63 OTHER   ; other operations
    64         S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
    65         I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
    66         S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
    67         Q
    68 LOOP    ; break procedures
    69         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
    70         Q
    71 PAGE    I $E(IOST)="P"!SRHDR G HDR
    72         W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
    73         I X["?" W !!,"If you want to continue the listing, press the 'Enter' key.",!,"Type '^' to return to the menu." G PAGE
    74 HDR     ; print heading
    75         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
    76         W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT
    77         W !!,?50,"'*' Denotes Eligible CPT Code" I SRSP,SRSS'="" W !,">>> "_SRSS
    78         W !!,"CASE #",?18,"PATIENT",?53,"TYPE",?67,"STATUS",!,"OP DATE",?18,"OPERATION(S)",! W:'SRSP "SURG SPECIALTY",! F LINE=1:1:80 W "="
    79         S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1
    80         Q
    81 TOT     W !!,"TOTAL FOR "_SRSS_": ",TOT
    82         Q
    83 GRAND   I 'SRSP W !!,"TOTAL: ",GRAND Q
    84         I SRSP,'SRFLG W !!,"TOTAL FOR ALL SPECIALTIES: ",GRAND Q
    85         I SRSP,SRFLG S SRSS=SRSPEC D TOT
    86         Q
     1SROALEC ;BIR/ADM - LIST OF ELIGIBLE CASES ;05/04/07
     2 ;;3.0; Surgery ;**160**;24 Jun 93;Build 7
     3 S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="CASES ELIGIBLE FOR ASSESSMENT" K ^TMP("SRA",$J)
     4 I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^")
     5 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
     6 I SRSP S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""  D SRSD Q:SRSOUT  D:TOT TOT
     7 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
     8 Q:SRSOUT  I SRSP,'SRFLG,GRAND D GRAND
     9 I SRFLG,'GRAND S SRSS=SRSPEC D HDR,GRAND
     10 I SRSP,'SRFLG,'GRAND S SRSS="" D HDR,GRAND
     11 I 'SRSP,'GRAND S SRSS="" D HDR,GRAND
     12 I 'SRSP,GRAND S SRSS="" D GRAND
     13 Q
     14UTL ; set up TMP global
     15 N SRCPLT
     16 I '$P($G(^SRF(SRTN,.2)),"^",3)&'$P($G(^SRF(SRTN,.2)),"^",12) Q
     17 I $P($G(^SRF(SRTN,30)),"^") Q
     18 I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
     19 S SRCPLT=$P($G(^SRO(136,SRTN,10)),"^") I SRCPLT,'$$XL^SROAX(SRTN) Q
     20 S SRA=$G(^SRF(SRTN,"RA"))
     21 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
     22 S ^TMP("SRA",$J,SRSD,SRTN)=SRA
     23 Q
     24SRSD 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
     25 Q
     26CASE N SRA2 S SRA2=$P(SRA,"^",2) D
     27 .I SRA2="" S SRATYPE="NOT LOGGED" Q
     28 .I SRA2="N" D  Q
     29 .. I $P(SRA,"^",6)="N" S SRATYPE="EXCLUDED" Q
     30 .. S SRATYPE="NON-CARDIAC"
     31 .I SRA2="C" S SRATYPE="CARDIAC"
     32 S TOT=TOT+1,GRAND=GRAND+1 D PRINT
     33 Q
     34PRINT ; print case info
     35 N SRDA,SRPROCS,SRY S SRPROCS=""
     36 I $Y+6>IOSL!SRNEW D PAGE I SRSOUT Q
     37 S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
     38 I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
     39 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
     40 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=""
     41 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,"@")
     42 I $Y+5>IOSL D PAGE I SRSOUT Q
     43 W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?67,SRSTATUS,!,SRDT F I=1:1 Q:'$D(SROPS(I))  W ?18,SROPS(I),!
     44 S SRY=$P($G(^SRO(136,SRTN,0)),"^",2) I SRY D CPT S SRPROCS=SRCODE
     45 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
     46 .S SRPROCS=SRPROCS_", "_SRCODE
     47 I '$P($G(^SRO(136,SRTN,10)),"^"),$L(SRPROCS) W !,">>> Final CPT Coding is not complete."
     48 S:SRPROCS="" SRPROCS="NOT ENTERED" W !,"CPT Codes: ",SRPROCS
     49 I 'SRSOUT W ! F LINE=1:1:80 W "-"
     50 Q
     51CPT ; check code for exclusion and get output value
     52 N Y,SREX S (SRCODE,SREX)=""
     53 S Y=$$CPT^ICPTCOD(SRY,$P(SRSD,".")),SRCODE=$P(Y,"^",2)
     54 S SREX="" I '$D(^SRO(137,SRY,0)) S SREX="*"
     55 S SRCODE=SREX_SRCODE
     56 Q
     57OTHER ; other operations
     58 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
     59 I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
     60 S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
     61 Q
     62LOOP ; break procedures
     63 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
     64 Q
     65PAGE I $E(IOST)="P"!SRHDR G HDR
     66 W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
     67 I X["?" W !!,"If you want to continue the listing, press the 'Enter' key.",!,"Type '^' to return to the menu." G PAGE
     68HDR ; print heading
     69 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
     70 W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT
     71 W !!,?50,"'*' Denotes Eligible CPT Code" I SRSP,SRSS'="" W !,">>> "_SRSS
     72 W !!,"CASE #",?18,"PATIENT",?53,"TYPE",?67,"STATUS",!,"OP DATE",?18,"OPERATION(S)",! F LINE=1:1:80 W "="
     73 S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1
     74 Q
     75TOT W !!,"TOTAL FOR "_SRSS_": ",TOT
     76 Q
     77GRAND I 'SRSP W !!,"TOTAL: ",GRAND Q
     78 I SRSP,'SRFLG W !!,"TOTAL FOR ALL SPECIALTIES: ",GRAND Q
     79 I SRSP,SRFLG S SRSS=SRSPEC D TOT
     80 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROALM.m

    r613 r623  
    1 SROALM  ;BIR/ADM - LIST OF ASSESSMENTS MISSING INFORMATION ;12/05/07
    2         ;;3.0; Surgery ;**38,50,88,142,153,160,166**;24 Jun 93;Build 7
    3         S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="COMPLETED/TRANSMITTED ASSESSMENTS MISSING INFORMATION" K ^TMP("SRA",$J)
    4         I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^")
    5         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
    6         .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
    7         I SRSP S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""  D SRSD Q:SRSOUT  D:TOT TOT
    8         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
    9         Q:SRSOUT  I SRSP,'SRFLG,GRAND D GRAND
    10         I SRFLG,'GRAND S SRSS=SRSPEC D HDR,GRAND
    11         I SRSP,'SRFLG,'GRAND S SRSS="" D HDR,GRAND
    12         I 'SRSP,'GRAND S SRSS="" D HDR,GRAND
    13         I 'SRSP,GRAND S SRSS="" D GRAND
    14         Q
    15 UTL     ; set up TMP global
    16         I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
    17         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
    18         S ^TMP("SRA",$J,SRSD,SRTN)=SR("RA")
    19         Q
    20 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
    21         Q
    22 CASE    I $P(SRA,"^",2)="N",$P(SRA,"^",6)="Y" S SRATYPE="NON-CARDIAC" D CHK^SROAUTL
    23         I $P(SRA,"^",2)="N",$P(SRA,"^",6)="N" S SRATYPE="EXCLUDED" D CHK^SROAUTL3
    24         I $P(SRA,"^",2)="C" S SRATYPE="CARDIAC" D CHK^SROAUTLC
    25         S SRFLD="" I $O(SRX(SRFLD))'="" S TOT=TOT+1,GRAND=GRAND+1 D PRINT Q
    26         I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) D PRINT
    27         Q
    28 PRINT   ; print assessments
    29         K SRCPTT S SRCPTT="NOT ENTERED"
    30         I $Y+5>IOSL!SRNEW D PAGE I SRSOUT Q
    31         S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
    32         I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
    33         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
    34         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=""
    35         S SRSTATUS=$S($P(SRA,"^")="T":"TRANSMITTED",1:"COMPLETE"),Y=SRSD D D^DIQ S SRDT=$P(Y,"@")
    36         I $Y+5>IOSL D PAGE I SRSOUT Q
    37         W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?68,SRSTATUS,!,SRDT F I=1:1 Q:'$D(SROPS(I))  W ?18,SROPS(I),!
    38         N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W ?18,"CPT Codes: "
    39         F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?29,SRPROC(I) W:I'=1 !,?29,SRPROC(I)
    40         S CNT=1 W !,?5,"Missing information:"
    41         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
    42         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
    43         I 'SRSOUT W ! F LINE=1:1:80 W "-"
    44         Q
    45 OTHER   ; other operations
    46         S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
    47         I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
    48         S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
    49         Q
    50 LOOP    ; break procedures
    51         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
    52         Q
    53 PAGE    I $E(IOST)="P"!SRHDR G HDR
    54         W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
    55         I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
    56 HDR     ; print heading
    57         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
    58         W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT I SRSP,SRSS'="" W !!,"** "_SRSS
    59         W !!,"ASSESSMENT #",?18,"PATIENT",?53,"TYPE",?68,"STATUS",!,"OPERATION DATE",?18,"OPERATION(S)",! F LINE=1:1:80 W "="
    60         S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1
    61         Q
    62 TOT     W !!,"TOTAL FOR "_SRSS_": ",TOT
    63         Q
    64 GRAND   I 'SRSP W !!,"TOTAL: ",GRAND Q
    65         I SRSP,'SRFLG W !!,"TOTAL FOR ALL SPECIALTIES: ",GRAND Q
    66         I SRSP,SRFLG S SRSS=SRSPEC D TOT
    67         Q
     1SROALM ;BIR/ADM - LIST OF ASSESSMENTS MISSING INFORMATION ;02/08/07
     2 ;;3.0; Surgery ;**38,50,88,142,153,160**;24 Jun 93;Build 7
     3 S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="COMPLETED/TRANSMITTED ASSESSMENTS MISSING INFORMATION" K ^TMP("SRA",$J)
     4 I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^")
     5 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
     6 .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
     7 I SRSP S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""  D SRSD Q:SRSOUT  D:TOT TOT
     8 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
     9 Q:SRSOUT  I SRSP,'SRFLG,GRAND D GRAND
     10 I SRFLG,'GRAND S SRSS=SRSPEC D HDR,GRAND
     11 I SRSP,'SRFLG,'GRAND S SRSS="" D HDR,GRAND
     12 I 'SRSP,'GRAND S SRSS="" D HDR,GRAND
     13 I 'SRSP,GRAND S SRSS="" D GRAND
     14 Q
     15UTL ; set up TMP global
     16 I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
     17 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
     18 S ^TMP("SRA",$J,SRSD,SRTN)=SR("RA")
     19 Q
     20SRSD 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
     21 Q
     22CASE I $P(SRA,"^",2)="N",$P(SRA,"^",6)="Y" S SRATYPE="NON-CARDIAC" D CHK^SROAUTL
     23 I $P(SRA,"^",2)="N",$P(SRA,"^",6)="N" S SRATYPE="EXCLUDED" D CHK^SROAUTL3
     24 I $P(SRA,"^",2)="C" S SRATYPE="CARDIAC" D CHK^SROAUTLC
     25 S SRFLD="" I $O(SRX(SRFLD))'="" S TOT=TOT+1,GRAND=GRAND+1 D PRINT Q
     26 I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) D PRINT
     27 Q
     28PRINT ; print assessments
     29 K SRCPTT S SRCPTT="NOT ENTERED"
     30 I $Y+5>IOSL!SRNEW D PAGE I SRSOUT Q
     31 S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
     32 I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
     33 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
     34 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=""
     35 S SRSTATUS=$S($P(SRA,"^")="T":"TRANSMITTED",1:"COMPLETE"),Y=SRSD D D^DIQ S SRDT=$P(Y,"@")
     36 I $Y+5>IOSL D PAGE I SRSOUT Q
     37 W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?68,SRSTATUS,!,SRDT F I=1:1 Q:'$D(SROPS(I))  W ?18,SROPS(I),!
     38 N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W ?18,"CPT Codes: "
     39 F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?29,SRPROC(I) W:I'=1 !,?29,SRPROC(I)
     40 S CNT=1 W !,?5,"Missing information:"
     41 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
     42 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
     43 I 'SRSOUT W ! F LINE=1:1:80 W "-"
     44 Q
     45OTHER ; other operations
     46 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
     47 I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
     48 S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
     49 Q
     50LOOP ; break procedures
     51 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
     52 Q
     53PAGE I $E(IOST)="P"!SRHDR G HDR
     54 W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
     55 I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
     56HDR ; print heading
     57 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
     58 W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT I SRSP,SRSS'="" W !!,"** "_SRSS
     59 W !!,"ASSESSMENT #",?18,"PATIENT",?53,"TYPE",?68,"STATUS",!,"OPERATION DATE",?18,"OPERATION(S)",! F LINE=1:1:80 W "="
     60 S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1
     61 Q
     62TOT W !!,"TOTAL FOR "_SRSS_": ",TOT
     63 Q
     64GRAND I 'SRSP W !!,"TOTAL: ",GRAND Q
     65 I SRSP,'SRFLG W !!,"TOTAL FOR ALL SPECIALTIES: ",GRAND Q
     66 I SRSP,SRFLG S SRSS=SRSPEC D TOT
     67 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROALOG.m

    r613 r623  
    1 SROALOG ;BIR/MAM - ASSESSMENT LOG ;01/24/08
    2         ;;3.0; Surgery ;**38,55,62,77,50,153,160,166**;24 Jun 93;Build 7
    3         K SRMNA S (SRSOUT,SRFLG,SRSP,SRAST)=0,SRSRT=1
    4 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"
    5         S DIR("A",4)="  2. List of Completed Assessments",DIR("A",5)="  3. List of Transmitted Assessments"
    6         S DIR("A",6)="  4. List of Non-Assessed Major Surgical Cases",DIR("A",7)="  5. List of All Major Surgical Cases"
    7         S DIR("A",8)="  6. List of All Surgical Cases",DIR("A",9)="  7. List of Completed/Transmitted Assessments Missing Information"
    8         S DIR("A",10)="  8. List of 1-Liner Cases Missing Information",DIR("A",11)="  9. List of Eligible Cases"
    9         S DIR("A",12)=" 10. List of Cases With No CPT Codes",DIR("A",13)=" 11. Summary List of Assessed Cases"
    10         S DIR("A",14)="",DIR("A")="Select the Number of the Report Desired"
    11         S DIR(0)="NO^1:11" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END
    12         S SREPORT=X
    13 DATE    I SREPORT=3 D DSORT G:SRSOUT END
    14         D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END
    15         I SREPORT=9 D TYPE9 I SRSOUT G END
    16         I SREPORT=3 D TYPE3 I SRSOUT G END
    17         D SEL G:SRSOUT END
    18         N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,"^"),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,"^",2))
    19         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.",!
    20         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
    21         I $D(IO("Q")) K IO("Q") D  S ZTREQ="@" D ^%ZTLOAD G END
    22         .S ZTRTN="EN^SROALOG",ZTDESC="List of Surgery Risk Assessments"
    23         .S (ZTSAVE("SRSD"),ZTSAVE("SRED"),ZTSAVE("SREPORT"),ZTSAVE("SRASP"),ZTSAVE("SRFLG"),ZTSAVE("SRSP"),ZTSAVE("SRINSTP"),ZTSAVE("SRAST"),ZTSAVE("SRSRT"))=""
    24 EN      ; entry when queued
    25         N SRFRTO S Y=SRSD X ^DD("DD") S SRFRTO="FROM: "_Y_"  TO: ",Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_Y
    26         U IO S SRSD=SRSD-.0001,SRED=SRED_".9999",Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y
    27         S SRINST=$S(SRINSTP["ALL DIV":$P($$SITE^SROVAR,"^",2)_" - ALL DIVISIONS",1:$$GET1^DIQ(4,SRINSTP,.01))
    28         I SREPORT=1 D:SRSP ^SROANTS D:'SRSP ^SROANT G END
    29         I SREPORT=2 D:SRSP ^SROALCS D:'SRSP ^SROALC G END
    30         I SREPORT=3 D:SRSP ^SROALTS D:'SRSP ^SROALT G END
    31         I SREPORT=4 S SRMNA=1 D:SRSP ^SROALLS D:'SRSP ^SROALL G END
    32         I SREPORT=5 D:SRSP ^SROALLS D:'SRSP ^SROALL G END
    33         I SREPORT=7 D ^SROALM G END
    34         I SREPORT=8 D ^SROALMN G END
    35         I SREPORT=9 D ^SROALEC G END
    36         I SREPORT=10 D ^SROALNC G END
    37         I SREPORT=11 D ^SROALSL G END
    38         D:SRSP ^SROALSS D:'SRSP ^SROALST
    39 END     I 'SRSOUT,$E(IOST)'="P" W !!,"Press ENTER to continue  " R X:DTIME
    40         W:$E(IOST)="P" @IOF K ^TMP("SRA",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
    41         D ^%ZISC K SRTN,SRAST,SRSRT W @IOF D ^SRSKILL
    42         Q
    43 TYPE3   ; select type of eligible cases
    44         W ! K DIR S DIR("A",1)="Print which Transmitted Cases ?",DIR("A",2)="",DIR("A",3)="   1. Assessed Cases Only"
    45         S DIR("A",4)="   2. Excluded Cases Only",DIR("A",5)="   3. Both Assessed and Excluded",DIR("A",6)=""
    46         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
    47         S SRAST=Y
    48         Q
    49 TYPE9   ; select type of transmitted case
    50         W ! K DIR S DIR("A",1)="Print which Eligible Cases ?",DIR("A",2)="",DIR("A",3)="   1. Assessed Cases Only"
    51         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)=""
    52         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
    53         S SRAST=Y
    54         Q
    55 DSORT   ; sort by op date or transmit date
    56         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"
    57         S DIR("A",4)="   2. Date of Transmission",DIR("A",5)="",DIR("A")="Select Number",DIR("B")=1,DIR(0)="N^1:2"
    58         D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
    59         S SRSRT=Y
    60         Q
    61 SEL     ; select specialty
    62         W ! K DIR S DIR(0)="YA",DIR("A")="Print by Surgical Specialty ?  ",DIR("B")="YES"
    63         S DIR("?",1)="Enter YES to print the report by surgical specialty, or NO to print",DIR("?")="the report listing all surgical cases."
    64         D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
    65         Q:'Y
    66 SEL1    S SRSP=1 W ! K DIR S DIR(0)="YA",DIR("A")="Print report for ALL specialties ?  ",DIR("B")="YES"
    67         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."
    68         D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
    69         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
    70         I Y'>0 S SRSOUT=1 Q
    71         Q
     1SROALOG ;BIR/MAM - ASSESSMENT LOG ;01/22/07
     2 ;;3.0; Surgery ;**38,55,62,77,50,153,160**;24 Jun 93;Build 7
     3 K SRMNA S (SRSOUT,SRFLG,SRSP)=0
     4START G:SRSOUT END W @IOF,!,"List of Surgery Risk Assessments",!!,"  1. List of Incomplete Assessments"
     5 W !,"  2. List of Completed Assessments",!,"  3. List of Transmitted Assessments"
     6 W !,"  4. List of Non-Assessed Major Surgical Cases",!,"  5. List of All Major Surgical Cases"
     7 W !,"  6. List of All Surgical Cases",!,"  7. List of Completed/Transmitted Assessments Missing Information"
     8 W !,"  8. List of 1-Liner Cases Missing Information",!,"  9. List of Eligible Cases"
     9 W !!,"Select the Number of the Report Desired: " R X:DTIME I '$T!("^"[X) S SRSOUT=1 G END
     10 I X<1!(X>9)!(X\1'=X) D HELP G START
     11 S SREPORT=X
     12DATE D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END
     13 D SEL G:SRSOUT END
     14 N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,"^"),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,"^",2))
     15 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.",!
     16 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
     17 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
     18EN ; entry when queued
     19 N SRFRTO S Y=SRSD X ^DD("DD") S SRFRTO="FROM: "_Y_"  TO: ",Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_Y
     20 U IO S SRSD=SRSD-.0001,SRED=SRED_".9999",Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y
     21 S SRINST=$S(SRINSTP["ALL DIV":$P($$SITE^SROVAR,"^",2)_" - ALL DIVISIONS",1:$$GET1^DIQ(4,SRINSTP,.01))
     22 I SREPORT=1 D:SRSP ^SROANTS D:'SRSP ^SROANT G END
     23 I SREPORT=2 D:SRSP ^SROALCS D:'SRSP ^SROALC G END
     24 I SREPORT=3 D:SRSP ^SROALTS D:'SRSP ^SROALT G END
     25 I SREPORT=4 S SRMNA=1 D:SRSP ^SROALLS D:'SRSP ^SROALL G END
     26 I SREPORT=5 D:SRSP ^SROALLS D:'SRSP ^SROALL G END
     27 I SREPORT=7 D ^SROALM G END
     28 I SREPORT=8 D ^SROALMN G END
     29 I SREPORT=9 D ^SROALEC G END
     30 D:SRSP ^SROALSS D:'SRSP ^SROALST
     31END I 'SRSOUT,$E(IOST)'="P" W !!,"Press <RET> to continue  " R X:DTIME
     32 W:$E(IOST)="P" @IOF K ^TMP("SRA",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
     33 D ^%ZISC K SRTN W @IOF D ^SRSKILL
     34 Q
     35HELP 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
     36 Q
     37SEL ; select specialty
     38 W !!,"Print by Surgical Specialty ?  YES// " R X:DTIME S:'$T X="^" I X="^" S SRSOUT=1 Q
     39 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
     40 Q:"Yy"'[X
     41SEL1 S SRSP=1 W !!,"Print report for ALL specialties ?  YES// " R X:DTIME S:'$T X="^" I X="^" S SRSOUT=1 Q
     42 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
     43 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
     44 I Y'>0 S SRSOUT=1 Q
     45 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROALT.m

    r613 r623  
    1 SROALT  ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/07/08
    2         ;;3.0; Surgery ;**38,50,142,153,160,166**;24 Jun 93;Build 7
    3         S SRFRTO=$S(SRSRT=2:"TRANSMISSION DATES ",1:"OPERATION DATES ")_SRFRTO
    4         I $E(IOST)="P" D ^SROALTP Q
    5         S SRSOUT=0 D HDR
    6         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
    7         .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
    8         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
    9         .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
    10         Q
    11 SET     ; print assessments
    12         K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX=""
    13         I $Y+5>IOSL D PAGE I SRSOUT Q
    14         S SR("RA")=^SRF(SRTN,"RA")
    15         I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y")
    16         I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N")
    17         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
    18         S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
    19         I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
    20         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
    21         S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER
    22         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=""
    23         S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
    24         D TECH^SROPRIN
    25         S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
    26         S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED"
    27         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)
    28         N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W:$D(SROPS(2)) ! W SREX,?20,"CPT Codes: "
    29         F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
    30         W ! F LINE=1:1:80 W "-"
    31         Q
    32 OTHER   ; other operations
    33         S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
    34         I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
    35         S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
    36         Q
    37 LOOP    ; break procedures
    38         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
    39         Q
    40 PAGE    W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
    41         I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
    42 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 "="
    43         Q
     1SROALT ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/18/07
     2 ;;3.0; Surgery ;**38,50,142,153,160**;24 Jun 93;Build 7
     3 I $E(IOST)="P" D ^SROALTP Q
     4 S SRSOUT=0 D HDR
     5 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
     6 Q
     7SET ; print assessments
     8 K SRCPTT S SRCPTT="NOT ENTERED"
     9 I $Y+5>IOSL D PAGE I SRSOUT Q
     10 S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
     11 I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
     12 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
     13 S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER
     14 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=""
     15 S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
     16 D TECH^SROPRIN
     17 S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
     18 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)
     19 N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W !,?20,"CPT Codes: "
     20 F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
     21 W ! F LINE=1:1:80 W "-"
     22 Q
     23OTHER ; other operations
     24 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
     25 I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
     26 S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
     27 Q
     28LOOP ; break procedures
     29 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
     30 Q
     31PAGE W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
     32 I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
     33HDR 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 "="
     34 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROALTP.m

    r613 r623  
    1 SROALTP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/07/08
    2         ;;3.0; Surgery ;**32,50,142,153,160,166**;24 Jun 93;Build 7
    3         S SRPAGE=1,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT
    4         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
    5         .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
    6         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
    7         .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
    8         Q
    9 SET     ; print assessments
    10         K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX=""
    11         I $Y+5>IOSL S SRPAGE=SRPAGE+1 D HDR I SRSOUT Q
    12         S SR("RA")=^SRF(SRTN,"RA")
    13         I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y")
    14         I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N")
    15         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
    16         S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
    17         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
    18         S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER
    19         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=""
    20         S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
    21         S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A"
    22         D TECH^SROPRIN
    23         S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
    24         S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED"
    25         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)
    26         N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,SREX,?20,"CPT Codes: "
    27         F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
    28         W ! F LINE=1:1:132 W "-"
    29         Q
    30 OTHER   ; other operations
    31         S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>165 S SRLONG=0,SROTHER=999,SROPERS=" ..."
    32         I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
    33         S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
    34         Q
    35 LOOP    ; break procedures
    36         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
    37         Q
    38 HDR     ; print heading
    39         I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
    40         W:$Y @IOF W !,?52,"TRANSMITTED RISK ASSESSMENTS",?120,"PAGE "_SRPAGE,!,?(132-$L(SRINST)\2),SRINST,!,?58,"SURGERY SERVICE",?100,"DATE REVIEWED:"
    41         W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:"
    42         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 "="
    43         Q
     1SROALTP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/18/07
     2 ;;3.0; Surgery ;**32,50,142,153,160**;24 Jun 93;Build 7
     3 S SRPAGE=1,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT
     4 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
     5 Q
     6SET ; print assessments
     7 K SRCPTT S SRCPTT="NOT ENTERED"
     8 I $Y+5>IOSL S SRPAGE=SRPAGE+1 D HDR I SRSOUT Q
     9 S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
     10 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
     11 S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER
     12 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=""
     13 S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
     14 S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A"
     15 D TECH^SROPRIN
     16 S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
     17 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)
     18 N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,?20,"CPT Codes: "
     19 F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
     20 W ! F LINE=1:1:132 W "-"
     21 Q
     22OTHER ; other operations
     23 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>165 S SRLONG=0,SROTHER=999,SROPERS=" ..."
     24 I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
     25 S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
     26 Q
     27LOOP ; break procedures
     28 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
     29 Q
     30HDR ; print heading
     31 I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
     32 W:$Y @IOF W !,?52,"TRANSMITTED RISK ASSESSMENTS",?120,"PAGE "_SRPAGE,!,?(132-$L(SRINST)\2),SRINST,!,?58,"SURGERY SERVICE",?100,"DATE REVIEWED:"
     33 W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:"
     34 W !!,"ASSESSMENT #",?20,"PATIENT",?67,"SURGICAL SPECIALTY",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",! F LINE=1:1:132 W "="
     35 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROALTS.m

    r613 r623  
    1 SROALTS ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/07/08
    2         ;;3.0; Surgery ;**38,50,142,153,160,166**;24 Jun 93;Build 7
    3         S SRFRTO=$S(SRSRT=2:"TRANSMISSION DATES ",1:"OPERATION DATES ")_SRFRTO
    4         I $E(IOST)="P" D ^SROALTSP Q
    5         S SRSOUT=0 D HDR
    6         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
    7         .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
    8         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
    9         .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
    10         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
    11         I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0()
    12         Q
    13 UTL     ; write to ^TMP("SRA",$J)
    14         I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
    15         S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
    16         S SR("RA")=^SRF(SRTN,"RA")
    17         I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y")
    18         I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N")
    19         S ^TMP("SRA",$J,SRSS,SRTN)=""
    20         Q
    21 SET     ; print assessments
    22         K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX=""
    23         I $Y+5>IOSL D PAGE I SRSOUT Q
    24         S SR("RA")=^SRF(SRTN,"RA")
    25         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
    26         S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
    27         I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
    28         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
    29         S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER
    30         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=""
    31         D TECH^SROPRIN
    32         S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
    33         S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED"
    34         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)
    35         N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W !,SREX,?20,"CPT Codes: "
    36         F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
    37         W ! F LINE=1:1:80 W "-"
    38         Q
    39 OTHER   ; other operations
    40         S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
    41         I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
    42         S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
    43         Q
    44 LOOP    ; break procedures
    45         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
    46         Q
    47 PAGE    W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
    48         I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
    49 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 "="
    50         Q
    51 SS      ; print surgical specialty
    52         I $Y+5>IOSL D PAGE Q:SRSOUT
    53         W !!,"** SURGICAL SPECIALTY: ",SRSS," **",!
    54         Q
     1SROALTS ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/18/07
     2 ;;3.0; Surgery ;**38,50,142,153,160**;24 Jun 93;Build 7
     3 I $E(IOST)="P" D ^SROALTSP Q
     4 S SRSOUT=0 D HDR
     5 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
     6 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
     7 I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0()
     8 Q
     9UTL ; write to ^TMP("SRA",$J)
     10 I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
     11 S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
     12 S ^TMP("SRA",$J,SRSS,SRTN)=""
     13 Q
     14SET ; print assessments
     15 K SRCPTT S SRCPTT="NOT ENTERED"
     16 I $Y+5>IOSL D PAGE I SRSOUT Q
     17 S SR("RA")=^SRF(SRTN,"RA"),SRAT="",Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
     18 S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
     19 I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
     20 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
     21 S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER
     22 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=""
     23 D TECH^SROPRIN
     24 S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
     25 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)
     26 N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W !,?20,"CPT Codes: "
     27 F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
     28 W ! F LINE=1:1:80 W "-"
     29 Q
     30OTHER ; other operations
     31 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..."
     32 I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
     33 S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
     34 Q
     35LOOP ; break procedures
     36 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
     37 Q
     38PAGE W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
     39 I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
     40HDR 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 "="
     41 Q
     42SS ; print surgical specialty
     43 I $Y+5>IOSL D PAGE Q:SRSOUT
     44 W !!,"** SURGICAL SPECIALTY: ",SRSS," **",!
     45 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROALTSP.m

    r613 r623  
    1 SROALTSP        ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/07/08
    2         ;;3.0; Surgery ;**32,50,142,153,160,166**;24 Jun 93;Build 7
    3         K ^TMP("SRA",$J) S SRPAGE=0,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT
    4         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
    5         .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
    6         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
    7         .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
    8         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
    9         I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0()
    10         Q
    11 UTL     ; write to ^TMP("SRA",$J)
    12         I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
    13         S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
    14         S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A"
    15         S SR("RA")=^SRF(SRTN,"RA")
    16         I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y")
    17         I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N")
    18         S ^TMP("SRA",$J,SRSS,SRTN)=""
    19         Q
    20 SET     ; print assessments
    21         K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX=""
    22         I $Y+5>IOSL D HDR I SRSOUT Q
    23         S SR("RA")=^SRF(SRTN,"RA")
    24         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
    25         S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
    26         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
    27         S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER
    28         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=""
    29         D TECH^SROPRIN
    30         S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
    31         S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED"
    32         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)
    33         N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,SREX,?20,"CPT Codes: "
    34         F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
    35         D LINE
    36         Q
    37 OTHER   ; other operations
    38         S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>165 S SRLONG=0,SROTHER=999,SROPERS=" ..."
    39         I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
    40         S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
    41         Q
    42 LOOP    ; break procedures
    43         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
    44         Q
    45 HDR     ; print heading
    46         I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
    47         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:"
    48         W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:"
    49         W !!,"ASSESSMENT #",?20,"PATIENT",?67,"TRANSMISSION DATE",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",! F LINE=1:1:132 W "="
    50         Q
    51 SS      ;print surgical specialty
    52         I $Y+5>IOSL D HDR
    53         W !!,"** SURGICAL SPECIALTY: ",SRSS," **",!
    54         Q
    55 LINE    W ! F L=1:1:132 W "-"
    56         Q
     1SROALTSP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/18/07
     2 ;;3.0; Surgery ;**32,50,142,153,160**;24 Jun 93;Build 7
     3 K ^TMP("SRA",$J) S SRPAGE=0,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT
     4 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
     5 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
     6 I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0()
     7 Q
     8UTL ; write to ^TMP("SRA",$J)
     9 I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
     10 S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
     11 S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A"
     12 S ^TMP("SRA",$J,SRSS,SRTN)=""
     13 Q
     14SET ; print assessments
     15 K SRCPTT S SRCPTT="NOT ENTERED"
     16 I $Y+5>IOSL D HDR I SRSOUT Q
     17 S SR("RA")=^SRF(SRTN,"RA"),SRAT="",Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
     18 S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
     19 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
     20 S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER
     21 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=""
     22 D TECH^SROPRIN
     23 S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
     24 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)
     25 N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,?20,"CPT Codes: "
     26 F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
     27 D LINE
     28 Q
     29OTHER ; other operations
     30 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>165 S SRLONG=0,SROTHER=999,SROPERS=" ..."
     31 I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")
     32 S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS)
     33 Q
     34LOOP ; break procedures
     35 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
     36 Q
     37HDR ; print heading
     38 I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
     39 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:"
     40 W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:"
     41 W !!,"ASSESSMENT #",?20,"PATIENT",?67,"TRANSMISSION DATE",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",! F LINE=1:1:132 W "="
     42 Q
     43SS ;print surgical specialty
     44 I $Y+5>IOSL D HDR
     45 W !!,"** SURGICAL SPECIALTY: ",SRSS," **",!
     46 Q
     47LINE W ! F L=1:1:132 W "-"
     48 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAMEAS.m

    r613 r623  
    1 SROAMEAS        ;BIR/MAM - INPUT TRANSFORMS, HEIGHT & WEIGHT ;03/20/06
    2         ;;3.0; Surgery ;**38,125,153,166**;24 Jun 93;Build 7
    3 H       Q:'$D(X)  I X'?.N1"C"&(X'?.N1"c"),(+X'=X) K X Q
    4         I +X=X S X=X+.5\1 I X'>47.9!(X'<86.1) K X Q
    5         S:X["c" X=+X_"C"
    6         I X?.N1"C",(X'>121.9!(X'<218.1)) K X
    7         Q
    8 W       Q:'$D(X)  I +X'=X,(X'?.N1"K")&(X'?.N1"k") K X Q
    9         I +X=X S X=X+.5\1 I X'>49.9!(X'<700.1) K X Q
    10         S:X["k" X=+X_"K"
    11         I X?.N1"K",(X'>22.9!(X'<318.1)) K X
    12         Q
    13 HWC     ; reject NS entry if the case is cardiac one
    14         S X=$S(X="ns":"NS",1:X)
    15         I $P($G(^SRF($S($G(SRTN):SRTN,1:DA),"RA")),"^",2)="C",X="NS" S X=""
    16         Q
     1SROAMEAS ;BIR/MAM - INPUT TRANSFORMS, HEIGHT & WEIGHT ;03/20/06
     2 ;;3.0; Surgery ;**38,125,153**;24 Jun 93;Build 11
     3H Q:'$D(X)  I X'?.N1"C"&(X'?.N1"c"),(+X'=X) K X Q
     4 I +X=X S X=X+.5\1 I X'>47.9!(X'<86.1) K X Q
     5 S:X["c" X=+X_"C"
     6 I X?.N1"C",(X'>121.9!(X'<218.1)) K X
     7 Q
     8W Q:'$D(X)  I +X'=X,(X'?.N1"K")&(X'?.N1"k") K X Q
     9 I +X=X S X=X+.5\1 I X'>49.9!(X'<700.1) K X Q
     10 S:X["k" X=+X_"K"
     11 I X?.N1"K",(X'>22.9!(X'<318.1)) K X
     12 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAMIS.m

    r613 r623  
    1 SROAMIS ;BIR/MAM - ANESTHESIA AMIS REPORT ;11/26/07
    2         ;;3.0; Surgery ;**22,34,38,77,50,86,166**;24 Jun 93;Build 7
    3 UTL     ; set up ^TMP("SROAMIS",$J
    4         S PRIN=$P($G(^SRF(SRDFN,.3)),"^",8) I PRIN="" S PRIN="O"
    5         S PROC=$S($D(^SRF(SRDFN,31)):$P(^(31),"^",9),1:""),DEATH=""
    6         S:PRIN="O" TECH="L" I TECH="L",PRIN'="O" S TECH="O"
    7         S S(0)=^SRF(SRDFN,0),DFN=$P(S(0),"^") S DEATH=$S('$D(^DPT(DFN,.35)):"",$P(^DPT(DFN,.35),"^")="":"",1:$P(^(.35),"^"))
    8         I +DEATH S:$D(^TMP("SRTN",$J,DFN)) DEATH="" I +DEATH D DEAD
    9         S $P(^TMP("SROAMIS",$J,"T",TECH),"^")=^TMP("SROAMIS",$J,"T",TECH)+1 I DEATH'="" S $P(^(TECH),"^",2)=$P(^(TECH),"^",2)+1
    10         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
    11         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
    12         Q
    13 SET     ; get anesthesia info from ^SRF(SRDFN,6
    14         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
    15         I '$D(SRTECH),SRCNT=1 S SRT=$O(^SRF(SRTN,6,0)),SRTECH=$P(^SRF(SRTN,6,SRT,0),"^")
    16         K SRTN I $D(SRTECH) Q:SRTECH="N"  S TECH=SRTECH D UTL
    17         Q
    18 HDR     ; print heading
    19         I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
    20         W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,!,?57,"ANESTHESIA SERVICE",?100,"REVIEWED BY: ",!,?58,"ANESTHESIA AMIS",?100,"DATE REVIEWED: "
    21         W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,SRPRINT
    22         W !!!!! F I=1:1:IOM W "="
    23         W !,?38,"ANESTHETICS ADMINISTERED BY PRINCIPAL TECHNIQUE USED",! F I=1:1:IOM W "-"
    24         W !,"TOTAL NO OF ANES-       |             |             |             |             |             |"
    25         W !,"THETICS ADMINISTERED    |   GENERAL   |   MAC       |   SPINAL    |   EPIDURAL  |   OTHER     |   LOCAL",! F I=1:1:IOM W "-"
    26         Q
    27 END     W:$E(IOST)="P" @IOF K ^TMP("SROAMIS",$J),^TMP("SRTN",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
    28         D ^%ZISC,^SRSKILL W @IOF
    29         Q
    30 DEAD    ; check for death within 24 hrs.
    31         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:"")
    32         I DEATH S ^TMP("SRTN",$J,DFN)=""
    33         Q
    34 EN      ; entry for SROAMIS option
    35         W @IOF,!,"Anesthesia AMIS",!!,"This report is no longer available.",!
    36         K DIR S DIR(0)="E" D ^DIR K DIR D END
    37         Q
    38 DATE    D DATE^SROUTL(.SDATE,.EDATE,.SRSOUT) G:SRSOUT END S SRD=SDATE-.0001
    39         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))
    40         W !!!,"This report is designed to use a 132 column format, and must be run",!,"on a printer.",!!
    41 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
    42         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
    43 1       ; entry when queued
    44         U IO N SRFRTO K ^TMP("SROAMIS",$J),^TMP("SRTN",$J) S SRSOUT=0,Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y
    45         S Y=SDATE X ^DD("DD") S SRFRTO="FROM: "_Y_"  TO: ",Y=EDATE X ^DD("DD") S SRFRTO=SRFRTO_Y
    46         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
    47         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
    48         .I $D(^SRF(SRDFN,0)),$P($G(^SRF(SRDFN,.2)),"^",12)'=""!($P($G(^SRF(SRDFN,"NON")),"^")="Y"),$$MANDIV^SROUTL0(SRINSTP,SRDFN) D SET
    49         D HDR G:SRSOUT END D PRINT^SROAMIS1
    50         G END
     1SROAMIS ;B'HAM ISC/MAM - ANESTHESIA AMIS REPORT ; [ 12/16/98  2:06 PM ]
     2 ;;3.0; Surgery ;**22,34,38,77,50,86**;24 Jun 93
     3UTL ; set up ^TMP("SROAMIS",$J
     4 S PRIN=$P($G(^SRF(SRDFN,.3)),"^",8) I PRIN="" S PRIN="O"
     5 S PROC=$S($D(^SRF(SRDFN,31)):$P(^(31),"^",9),1:""),DEATH=""
     6 S:PRIN="O" TECH="L" I TECH="L",PRIN'="O" S TECH="O"
     7 S S(0)=^SRF(SRDFN,0),DFN=$P(S(0),"^") S DEATH=$S('$D(^DPT(DFN,.35)):"",$P(^DPT(DFN,.35),"^")="":"",1:$P(^(.35),"^"))
     8 I +DEATH S:$D(^TMP("SRTN",$J,DFN)) DEATH="" I +DEATH D DEAD
     9 S $P(^TMP("SROAMIS",$J,"T",TECH),"^")=^TMP("SROAMIS",$J,"T",TECH)+1 I DEATH'="" S $P(^(TECH),"^",2)=$P(^(TECH),"^",2)+1
     10 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
     11 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
     12 Q
     13SET ; get anesthesia info from ^SRF(SRDFN,6
     14 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
     15 I '$D(SRTECH),SRCNT=1 S SRT=$O(^SRF(SRTN,6,0)),SRTECH=$P(^SRF(SRTN,6,SRT,0),"^")
     16 K SRTN I $D(SRTECH) Q:SRTECH="N"  S TECH=SRTECH D UTL
     17 Q
     18HDR ; print heading
     19 I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
     20 W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,!,?57,"ANESTHESIA SERVICE",?100,"REVIEWED BY: ",!,?58,"ANESTHESIA AMIS",?100,"DATE REVIEWED: "
     21 W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,SRPRINT
     22 W !!!!! F I=1:1:IOM W "="
     23 W !,?38,"ANESTHETICS ADMINISTERED BY PRINCIPAL TECHNIQUE USED",! F I=1:1:IOM W "-"
     24 W !,"TOTAL NO OF ANES-       |             |             |             |             |             |"
     25 W !,"THETICS ADMINISTERED    |   GENERAL   |   MAC       |   SPINAL    |   EPIDURAL  |   OTHER     |   LOCAL",! F I=1:1:IOM W "-"
     26 Q
     27END W:$E(IOST)="P" @IOF K ^TMP("SROAMIS",$J),^TMP("SRTN",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
     28 D ^%ZISC,^SRSKILL W @IOF
     29 Q
     30DEAD ; check for death within 24 hrs.
     31 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:"")
     32 I DEATH S ^TMP("SRTN",$J,DFN)=""
     33 Q
     34EN ; entry for SROAMIS option
     35 W @IOF,!,"Anesthesia AMIS",!
     36DATE D DATE^SROUTL(.SDATE,.EDATE,.SRSOUT) G:SRSOUT END S SRD=SDATE-.0001
     37 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))
     38 W !!!,"This report is designed to use a 132 column format, and must be run",!,"on a printer.",!!
     39PTR 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
     40 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
     411 ; entry when queued
     42 U IO N SRFRTO K ^TMP("SROAMIS",$J),^TMP("SRTN",$J) S SRSOUT=0,Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y
     43 S Y=SDATE X ^DD("DD") S SRFRTO="FROM: "_Y_"  TO: ",Y=EDATE X ^DD("DD") S SRFRTO=SRFRTO_Y
     44 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
     45 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
     46 .I $D(^SRF(SRDFN,0)),$P($G(^SRF(SRDFN,.2)),"^",12)'=""!($P($G(^SRF(SRDFN,"NON")),"^")="Y"),$$MANDIV^SROUTL0(SRINSTP,SRDFN) D SET
     47 D HDR G:SRSOUT END D PRINT^SROAMIS1
     48 G END
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAOP.m

    r613 r623  
    1 SROAOP  ;BIR/MAM - ENTER OPERATION INFO ;11/27/07
    2         ;;3.0; Surgery ;**19,38,47,63,67,81,86,97,100,125,142,153,160,166**;24 Jun 93;Build 7
    3         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
    4         S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
    5 START   G:SRSOUT END K SRAOTH,SRACON D ^SROAOP1
    6 ASK     W !!,"Select Operative Information to Edit: " R SRASEL:DTIME I '$T!(SRASEL["^") S SRSOUT=1 G END
    7         I SRASEL="" G END
    8         S SRN=13 S:SRASEL="a" SRASEL="A" I '$D(SRAO(SRASEL)),(SRASEL'?.N1":".N),(SRASEL'="A") D HELP G:SRSOUT END G START
    9         I SRASEL="A" S SRASEL="1:"_SRN
    10         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
    11         S MM=$E(SRASEL) I MM'=3,(MM'=4),(MM'=5) S SRHDR(.5)=SRDOC D HDR^SROAUTL
    12         I SRASEL?.N1":".N D RANGE G START
    13         Q:'$D(SRAO(SRASEL))
    14         S EMILY=SRASEL D  G START
    15         .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
    16 END     I $D(SRSOUT),'SRSOUT D ^SROAOP2
    17         I $D(SRTN) S SROERR=SRTN D ^SROERR0
    18         W @IOF D ^SRSKILL
    19         Q
    20 HELP    W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper"
    21         W !,"responses are listed below.",!!,"1. Enter 'A' to update all information."
    22         W !!,"2. Enter a number (1-"_SRN_") to update the information in that field. (For"
    23         W !,"   example, enter '2' to update Principal Operation.)"
    24         W !!,"3. Enter a range of numbers (1-"_SRN_") separated by a ':' to enter a range of"
    25         W !,"   information. (For example, enter '6:8' to update PGY of Primary Surgeon,"
    26         W !,"   Surgical Priority and Wound Classification.)",!
    27 PRESS   K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
    28         Q
    29 RANGE   ; range of numbers
    30         I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
    31         .S SHEMP=$P(SRASEL,":"),CURLEY=$P(SRASEL,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
    32         Q
    33 ONE     ; edit one item
    34         I EMILY=3 D DISP^SROAUTL0 Q
    35         I EMILY=10 D ANES Q
    36         I EMILY=4 D ^SROTHER Q
    37         I EMILY=5 D CONCUR Q
    38         I EMILY=6,SRASEL[":",($P(SRASEL,":")'=6) S SRPAGE="" S SRHDR(.5)=SRDOC D HDR^SROAUTL
    39         K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",2)_"T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1
    40         I EMILY=2 D ^SROAUTL
    41         Q
    42 RET     Q:SRSOUT  W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
    43         Q
    44 CONCUR  ; concurrent case information
    45         N SRPROC,SRCSTAT S SRLINE="" F I=1:1:80 S SRLINE=SRLINE_"-"
    46         S CON=$P($G(^SRF(SRTN,"CON")),"^") I CON,($P($G(^SRF(CON,30)),"^")!($P($G(^SRF(CON,31)),"^",8))) S CON=""
    47         S SRPAGE="" D HDR^SROAUTL
    48         W !,"Concurrent case information cannot be updated using the Risk Assessment"
    49         W !,"Module. To update the CPT code of a concurrent case, please use an option"
    50         W !,"contained within the CPT/ICD9 Coding Menu."
    51         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)
    52         I $D(SRCSTAT) W !!,?22,SRCSTAT
    53         W !!,"Press ENTER to continue " R X:DTIME
    54         Q
    55 CC      ; list concurrent procedure
    56         N SRTN,SRL,SRZ S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,CON,10)),"^"):"",1:"Not ")_"Complete <<"
    57         S SRL=55,SRTN=CON D CPTS^SROAUTL0
    58         I SRPROC(1)="NOT ENTERED"!'$D(SRPROC(1)) S SRPROC(1)="CPT NOT ENTERED" K SRCSTAT
    59         S SROPER=$P(^SRF(CON,"OP"),"^")_" (" F I=1:1 Q:'$D(SRPROC(I))  S SROPER=SROPER_SRPROC(I)
    60         S SROPER=SROPER_")"
    61         K SROPS,MM,MMM S:$L(SROPER)<57 SROPS(1)=SROPER
    62         I $L(SROPER)>56 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
    63         Q
    64 LOOP    ; break procedures
    65         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
    66         Q
    67 ANES    N SRANE,SRNEW
    68         I $P(SRAO(10),"^")="NOT ENTERED",'$O(^SRF(SRTN,6,0)) D  Q
    69         .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
    70         .K DD,DO S DIC="^SRF(SRTN,6,",X=SRANE,DIC(0)="L" D FILE^DICN K DIC,DD,DO I '+Y Q
    71         .S SRNEW=+Y
    72         .K DA,DIE,DR S DA=SRNEW,DA(1)=SRTN,DIE="^SRF(SRTN,6,",DR=".05T;42T" D ^DIE
    73         K DR,DIE,DA S DA=SRTN,DR=".37T",DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE K DR
    74         Q
     1SROAOP ;BIR/MAM - ENTER OPERATION INFO ;04/24/07
     2 ;;3.0; Surgery ;**19,38,47,63,67,81,86,97,100,125,142,153,160**;24 Jun 93;Build 7
     3 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
     4 S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
     5START G:SRSOUT END K SRAOTH,SRACON D ^SROAOP1
     6ASK W !!,"Select Operative Information to Edit: " R SRASEL:DTIME I '$T!(SRASEL["^") S SRSOUT=1 G END
     7 I SRASEL="" G END
     8 S SRN=13 S:SRASEL="a" SRASEL="A" I '$D(SRAO(SRASEL)),(SRASEL'?.N1":".N),(SRASEL'="A") D HELP G:SRSOUT END G START
     9 I SRASEL="A" S SRASEL="1:"_SRN
     10 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
     11 S MM=$E(SRASEL) I MM'=3,(MM'=4),(MM'=5) S SRHDR(.5)=SRDOC D HDR^SROAUTL
     12 I SRASEL?.N1":".N D RANGE G START
     13 Q:'$D(SRAO(SRASEL))
     14 S EMILY=SRASEL D  G START
     15 .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
     16END I $D(SRSOUT),'SRSOUT D ^SROAOP2
     17 I $D(SRTN) S SROERR=SRTN D ^SROERR0
     18 W @IOF D ^SRSKILL
     19 Q
     20HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper"
     21 W !,"responses are listed below.",!!,"1. Enter 'A' to update all information."
     22 W !!,"2. Enter a number (1-"_SRN_") to update the information in that field. (For"
     23 W !,"   example, enter '2' to update Principal Operation.)"
     24 W !!,"3. Enter a range of numbers (1-"_SRN_") separated by a ':' to enter a range of"
     25 W !,"   information. (For example, enter '6:8' to update PGY of Primary Surgeon,"
     26 W !,"   Surgical Priority and Wound Classification.)",!
     27PRESS K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
     28 Q
     29RANGE ; range of numbers
     30 I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
     31 .S SHEMP=$P(SRASEL,":"),CURLEY=$P(SRASEL,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT  D ONE
     32 Q
     33ONE ; edit one item
     34 I EMILY=3 D DISP^SROAUTL0 Q
     35 I EMILY=10 D ANES Q
     36 I EMILY=4 D ^SROTHER Q
     37 I EMILY=5 D CONCUR Q
     38 I EMILY=6,SRASEL[":",($P(SRASEL,":")'=6) S SRPAGE="" S SRHDR(.5)=SRDOC D HDR^SROAUTL
     39 K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",2)_"T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1
     40 I EMILY=2 D ^SROAUTL
     41 Q
     42RET Q:SRSOUT  W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
     43 Q
     44CONCUR ; concurrent case information
     45 N SRPROC,SRCSTAT S SRLINE="" F I=1:1:80 S SRLINE=SRLINE_"-"
     46 S CON=$P($G(^SRF(SRTN,"CON")),"^") I CON,($P($G(^SRF(CON,30)),"^")!($P($G(^SRF(CON,31)),"^",8))) S CON=""
     47 S SRPAGE="" D HDR^SROAUTL
     48 W !,"Concurrent case information cannot be updated using the Risk Assessment"
     49 W !,"Module. To update the CPT code of a concurrent case, please use an option"
     50 W !,"contained within the CPT/ICD9 Coding Menu."
     51 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)
     52 I $D(SRCSTAT) W !!,?22,SRCSTAT
     53 W !!,"Press ENTER to continue " R X:DTIME
     54 Q
     55CC ; list concurrent procedure
     56 N SRTN,SRL,SRZ S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,CON,10)),"^"):"",1:"Not ")_"Complete <<"
     57 S SRL=55,SRTN=CON D CPTS^SROAUTL0
     58 I SRPROC(1)="NOT ENTERED"!'$D(SRPROC(1)) S SRPROC(1)="CPT NOT ENTERED" K SRCSTAT
     59 S SROPER=$P(^SRF(CON,"OP"),"^")_" (" F I=1:1 Q:'$D(SRPROC(I))  S SROPER=SROPER_SRPROC(I)
     60 S SROPER=SROPER_")"
     61 K SROPS,MM,MMM S:$L(SROPER)<57 SROPS(1)=SROPER
     62 I $L(SROPER)>56 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
     63 Q
     64LOOP ; break procedures
     65 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
     66 Q
     67ANES K DR,DIE,DA S DA=SRTN,DR=".37T",DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE K DR
     68 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAPAS.m

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

    r613 r623  
    1 SROAPCA1        ;BIR/MAM - PRINT CARDIAC CATH INFO ;02/05/08
    2         ;;3.0; Surgery ;**38,63,71,88,95,125,142,153,166**;24 Jun 93;Build 7
    3         N SRX F I=200:1:202,206,208,209,202.1 S SRA(I)=$G(^SRF(SRTN,I))
    4         I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q
    5         D LAB^SROAPCA4
    6         I $Y+16>IOSL D PAGE^SROAPCA I SRSOUT Q
    7         S Y=$P(SRA(209),"^",4),SRAO(1)=$S(Y="C":"CATH",Y="I":"IVUS",Y="B":"BOTH",Y="NS":" NS",1:"")_"^476"
    8         S Y=$P(SRA(206),"^",24),SRX=357,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
    9         S Y=$P(SRA(206),"^",25),SRX=358,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
    10         S Y=$P(SRA(206),"^",26),SRX=359,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX
    11         S Y=$P(SRA(206),"^",27),SRX=360,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX
    12         S NYUK=$P(SRA(206),"^",30) D LV S SRAO(6)=SHEMP_"^363"
    13         S Y=$P(SRA(206),"^",9),SRX=415,SRAO(7)=$$OUT(SRX,Y)_"^"_SRX
    14         S Y=$P(SRA(209),"^",5),SRX=477,SRAO(8)=$$OUT(SRX,Y)_"^"_SRX
    15         S Y=$P(SRA(206),"^",28),SRX=361,SRAO(9)=$$OUT(SRX,Y)_"^"_SRX
    16         S Y=$P(SRA(206),"^",33),SRX=362.1,SRAO(10)=$$OUT(SRX,Y)_"^"_SRX
    17         S Y=$P(SRA(206),"^",34),SRX=362.2,SRAO(11)=$$OUT(SRX,Y)_"^"_SRX
    18         S Y=$P(SRA(206),"^",35),SRX=362.3,SRAO(12)=$$OUT(SRX,Y)_"^"_SRX
    19         S Y=$P(SRA(209),"^",6),SRX=478,SRAO(13)=$$OUT(SRX,Y)_"^"_SRX
    20         S Y=$P(SRA(209),"^",7),SRX=479,SRAO(14)=$$OUT(SRX,Y)_"^"_SRX
    21         S Y=$P(SRA(209),"^",8),SRX=480,SRAO(15)=$$OUT(SRX,Y)_"^"_SRX
    22         W !!,"IV. CARDIAC CATHETERIZATION AND ANGIOGRAPHIC DATA"
    23         S Y=$P($G(^SRF(SRTN,207)),"^",21) I Y>1 D DT S Y=X
    24         D NS W !,"Cardiac Catheterization Date: ",$E(Y,1,8)
    25         W !,"Procedure:",?26,$P(SRAO(1),"^"),?41,"Native Coronaries:"
    26         S SRX=$P(SRAO(2),"^") W !,"LVEDP:",?26,$J(SRX,3) D MMHG
    27         S SRX=$P(SRAO(9),"^") W ?41,"Left Main Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
    28         S SRX=$P(SRAO(3),"^") W !,"Aortic Systolic Pressure:",?26,$J(SRX,3) D MMHG
    29         S SRX=$P(SRAO(10),"^") W ?41,"LAD Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
    30         S SRX=$P(SRAO(11),"^") W !,?41,"Right Coronary Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
    31         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 "%"
    32         ;
    33         S SRX=$P(SRAO(4),"^") W !,"PA Systolic Pressure:",?26,$J(SRX,3) D MMHG
    34         S SRX=$P(SRAO(5),"^") W !,"PAW Mean Pressure:",?26,$J(SRX,3) D MMHG
    35         W ?41,"If a Re-do, indicate stenosis",!,?44," in graft to:"
    36         S SRX=$P(SRAO(13),"^") W !,?41,"LAD:",?71,$J(SRX,3) I SRX?1.3N W "%"
    37         S SRX=$P(SRAO(14),"^") W !,?41,"Right coronary (include PDA): ",$J(SRX,3) I SRX?1.3N W "%"
    38         S SRX=$P(SRAO(15),"^") W !,?41,"Circumflex:",?71,$J(SRX,3) I SRX?1.3N W "%"
    39         W !,LN
    40         W !,"LV Contraction Grade (from contrast or radionuclide angiogram or 2D Echo):",!,?7,"Grade",?17,"Ejection Fraction Range",?51,"Definition"
    41         W !,?8,$P(SRAO(6),"^")
    42         W !,LN,!,"Mitral Regurgitation:",?26,$P(SRAO(7),"^")
    43         W !,"Aortic stenosis:",?26,$P(SRAO(8),"^")
    44         I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q
    45         K SRAO S Y=$P(SRA(206),"^",31),SRX=364,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
    46         S Y=$P($G(^SRF(SRTN,1.1)),"^",3),SRX=1.13,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
    47         S Y=$P(SRA(208),"^",12),SRX=414,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
    48         S Y=$P(SRA(206),"^",32),SRX=364.1 D DT S SRAO("1A")=X_"^"_SRX
    49         S Y=$P(SRA(208),"^",13),SRX=414.1 D DT S SRAO("3A")=X_"^"_SRX
    50         S Y=$P($G(^SRF(SRTN,.2)),"^",2),SRX=.22 D DT S SRAO(0)=X_"^"_SRX
    51         W !!,"V. OPERATIVE RISK SUMMARY DATA" S X=$P(SRAO(0),"^") W ?40,"(Operation Began: "_X_")"
    52         W !,?5,"Physician's Preoperative" S Y=$P($G(^SRF(SRTN,.2)),"^",3) D DT W ?40,"(Operation Ended: "_X_")"
    53         W !,?7,"Estimate of Operative Mortality: "_$P(SRAO(1),"^") I $P(SRAO(1),"^")'=""&($P(SRAO(1),"^")'="NS") W "%"
    54         S X=$P(SRAO("1A"),"^") I X'="" W ?57,"("_X_")"
    55         W !,?5,"ASA Classification:",?35,$P(SRAO(2),"^")
    56         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_")"
    57         S X=$P($G(^SRO(136,SRTN,0)),"^",2) I X S Y=$P($$CPT^ICPTCOD(X),"^",2) D SSPRIN^SROCPT0 S X=Y
    58         S X=$S(X'="":X,1:"CPT Code Missing")
    59         W !,?5,"Principal CPT Code:",?35,X,!,?5,"Other Procedures CPT Codes: "
    60         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
    61         .I CPT S Y=$P($$CPT^ICPTCOD(CPT),"^",2) S SRDA=OTH D SSOTH^SROCPT0 S CPT=Y
    62         .S:CPT="" CPT="NONE" S CNT=CNT+3
    63         .I CNT+$L(CPT)'>80 W:CNT>35 ";" W ?(CNT),CPT S CNT=CNT+$L(CPT) Q
    64         .W !,?35,CPT S CNT=35+$L(CPT)
    65         W !,?5,"Preoperative Risk Factors: "
    66         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
    67         .I X'[" " W ?25,X Q
    68         .S I=0,LINE=1 F  S SRL=$S(LINE=1:48,1:80) D  Q:SRQ
    69         ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q
    70         ..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
    71         I $Y+20>IOSL D PAGE^SROAPCA I SRSOUT Q
    72         K SRA,SRAO D ^SROAPCA2
    73         Q
    74 YN      ; store answer
    75         S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"")
    76         Q
    77 DT      I 'Y S X="" Q
    78         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)
    79         Q
    80 OUT(SRFLD,SRY)  ; get data in output form
    81         N C,Y
    82         S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
    83         I Y="NO STUDY" S Y="NS" Q Y
    84         Q Y
    85 MMHG    I SRX="NO STUDY"!(SRX="NS") Q
    86         W " mm Hg"
    87         Q
    88 NS      S Y=$S(Y="NS":"NO STUDY",1:Y)
    89         Q
    90 LV      K SHEMP S SHEMP=$S(NYUK="I":" I          > or = 0.55                    NORMAL",NYUK="II":"II             0.45-0.54                   MILD DYSFUNCTION",1:NYUK)
    91         Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="III":"III           0.35-0.44                    MODERATE DYSFUNCTION",1:NYUK)
    92         Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="IIIa":"IIIa          0.40-0.44                    MODERATE DYSFUNCTION A",1:NYUK)
    93         Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="IIIb":"IIIb          0.35-0.39                    MODERATE DYSFUNCTION B",1:NYUK)
    94         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:"")
    95         Q
     1SROAPCA1 ;BIR/MAM - PRINT CARDIAC CATH INFO ;04/05/04
     2 ;;3.0; Surgery ;**38,63,71,88,95,125,142,153**;24 Jun 93;Build 11
     3 N SRX F I=200:1:202,206,208,209,202.1 S SRA(I)=$G(^SRF(SRTN,I))
     4 I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q
     5 D LAB^SROAPCA4
     6 I $Y+16>IOSL D PAGE^SROAPCA I SRSOUT Q
     7 S Y=$P(SRA(209),"^",4),SRAO(1)=$S(Y="C":"CATH",Y="I":"IVUS",Y="B":"BOTH",Y="NS":" NS",1:"")_"^476"
     8 S Y=$P(SRA(206),"^",24),SRX=357,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
     9 S Y=$P(SRA(206),"^",25),SRX=358,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
     10 S Y=$P(SRA(206),"^",26),SRX=359,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX
     11 S Y=$P(SRA(206),"^",27),SRX=360,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX
     12 S NYUK=$P(SRA(206),"^",30) D LV S SRAO(6)=SHEMP_"^363"
     13 S Y=$P(SRA(206),"^",9),SRX=415,SRAO(7)=$$OUT(SRX,Y)_"^"_SRX
     14 S Y=$P(SRA(209),"^",5),SRX=477,SRAO(8)=$$OUT(SRX,Y)_"^"_SRX
     15 S Y=$P(SRA(206),"^",28),SRX=361,SRAO(9)=$$OUT(SRX,Y)_"^"_SRX
     16 S Y=$P(SRA(206),"^",33),SRX=362.1,SRAO(10)=$$OUT(SRX,Y)_"^"_SRX
     17 S Y=$P(SRA(206),"^",34),SRX=362.2,SRAO(11)=$$OUT(SRX,Y)_"^"_SRX
     18 S Y=$P(SRA(206),"^",35),SRX=362.3,SRAO(12)=$$OUT(SRX,Y)_"^"_SRX
     19 S Y=$P(SRA(209),"^",6),SRX=478,SRAO(13)=$$OUT(SRX,Y)_"^"_SRX
     20 S Y=$P(SRA(209),"^",7),SRX=479,SRAO(14)=$$OUT(SRX,Y)_"^"_SRX
     21 S Y=$P(SRA(209),"^",8),SRX=480,SRAO(15)=$$OUT(SRX,Y)_"^"_SRX
     22 W !!,"IV. CARDIAC CATHETERIZATION AND ANGIOGRAPHIC DATA"
     23 S Y=$P($G(^SRF(SRTN,207)),"^",21) I Y>1 D DT S Y=X
     24 D NS W !,"Cardiac Catheterization Date: ",$E(Y,1,8)
     25 W !,"Procedure:",?26,$P(SRAO(1),"^"),?41,"Native Coronaries:"
     26 S SRX=$P(SRAO(2),"^") W !,"LVEDP:",?26,$J(SRX,3) D MMHG
     27 S SRX=$P(SRAO(9),"^") W ?41,"Left Main Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
     28 S SRX=$P(SRAO(3),"^") W !,"Aortic Systolic Pressure:",?26,$J(SRX,3) D MMHG
     29 S SRX=$P(SRAO(10),"^") W ?41,"LAD Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
     30 S SRX=$P(SRAO(11),"^") W !,?41,"Right Coronary Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%"
     31 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 "%"
     32 ;
     33 S SRX=$P(SRAO(4),"^") W !,"PA Systolic Pressure:",?26,$J(SRX,3) D MMHG
     34 S SRX=$P(SRAO(5),"^") W !,"PAW Mean Pressure:",?26,$J(SRX,3) D MMHG
     35 W ?41,"If a Re-do, indicate stenosis",!,?44," in graft to:"
     36 S SRX=$P(SRAO(13),"^") W !,?41,"LAD:",?71,$J(SRX,3) I SRX?1.3N W "%"
     37 S SRX=$P(SRAO(14),"^") W !,?41,"Right coronary (include PDA): ",$J(SRX,3) I SRX?1.3N W "%"
     38 S SRX=$P(SRAO(15),"^") W !,?41,"Circumflex:",?71,$J(SRX,3) I SRX?1.3N W "%"
     39 W !,LN
     40 W !,"LV Contraction Grade (from contrast or radionuclide angiogram or 2D Echo):",!,?7,"Grade",?17,"Ejection Fraction Range",?51,"Definition"
     41 W !,?8,$P(SRAO(6),"^")
     42 W !,LN,!,"Mitral Regurgitation:",?26,$P(SRAO(7),"^")
     43 W !,"Aortic stenosis:",?26,$P(SRAO(8),"^")
     44 I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q
     45 K SRAO S Y=$P(SRA(206),"^",31),SRX=364,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
     46 S Y=$P($G(^SRF(SRTN,1.1)),"^",3),SRX=1.13,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
     47 S Y=$P(SRA(208),"^",12),SRX=414,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
     48 S Y=$P(SRA(206),"^",32),SRX=364.1,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
     49 S Y=$P(SRA(208),"^",13),SRX=414.1,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
     50 S Y=$P($G(^SRF(SRTN,.2)),"^",2),SRX=.22,SRAO(0)=$$OUT(SRX,Y)_"^"_SRX
     51 W !!,"V. OPERATIVE RISK SUMMARY DATA" S X=$P(SRAO(0),"^") I X'="" W ?40,"(Operation Began: "_X_")"
     52 W !,?5,"Physician's Preoperative" S Y=$P($G(^SRF(SRTN,.2)),"^",3) I Y'="" D DT W ?40,"(Operation Ended: "_X_")"
     53 W !,?7,"Estimate of Operative Mortality: "_$P(SRAO(1),"^") I $P(SRAO(1),"^")'=""&($P(SRAO(1),"^")'="NS") W "%"
     54 S X=$P(SRAO("1A"),"^") I X'="" W ?57,"("_X_")"
     55 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_")"
     56 S X=$P($G(^SRO(136,SRTN,0)),"^",2) I X S Y=$P($$CPT^ICPTCOD(X),"^",2) D SSPRIN^SROCPT0 S X=Y
     57 S X=$S(X'="":X,1:"CPT Code Missing")
     58 W !,?5,"Principal CPT Code:",?35,X,!,?5,"Other Procedures CPT Codes: "
     59 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
     60 .I CPT S Y=$P($$CPT^ICPTCOD(CPT),"^",2) S SRDA=OTH D SSOTH^SROCPT0 S CPT=Y
     61 .S:CPT="" CPT="NONE" S CNT=CNT+3
     62 .I CNT+$L(CPT)'>80 W:CNT>35 ";" W ?(CNT),CPT S CNT=CNT+$L(CPT) Q
     63 .W !,?35,CPT S CNT=35+$L(CPT)
     64 W !,?5,"Preoperative Risk Factors: "
     65 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
     66 .I X'[" " W ?25,X Q
     67 .S I=0,LINE=1 F  S SRL=$S(LINE=1:48,1:80) D  Q:SRQ
     68 ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q
     69 ..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
     70 I $Y+20>IOSL D PAGE^SROAPCA I SRSOUT Q
     71 K SRA,SRAO D ^SROAPCA2
     72 Q
     73YN ; store answer
     74 S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"")
     75 Q
     76DT I 'Y S X="" Q
     77 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)
     78 Q
     79OUT(SRFLD,SRY) ; get data in output form
     80 N C,Y
     81 S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
     82 I Y="NO STUDY" S Y="NS" Q Y
     83 Q Y
     84MMHG I SRX="NO STUDY"!(SRX="NS") Q
     85 W " mm Hg"
     86 Q
     87NS S Y=$S(Y="NS":"NO STUDY",1:Y)
     88 Q
     89LV K SHEMP S SHEMP=$S(NYUK="I":" I          > or = 0.55                    NORMAL",NYUK="II":"II             0.45-0.54                   MILD DYSFUNCTION",1:NYUK)
     90 Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="III":"III           0.35-0.44                    MODERATE DYSFUNCTION",1:NYUK)
     91 Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="IIIa":"IIIa          0.40-0.44                    MODERATE DYSFUNCTION A",1:NYUK)
     92 Q:SHEMP'=NYUK  S SHEMP=$S(NYUK="IIIb":"IIIb          0.35-0.39                    MODERATE DYSFUNCTION B",1:NYUK)
     93 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:"")
     94 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAPCA3.m

    r613 r623  
    1 SROAPCA3        ;B'HAM ISC/MAM - CARDIAC OCCURRENCE DATA ;02/05/08
    2         ;;3.0; Surgery ;**38,71,95,101,125,160,164,166**;24 Jun 93;Build 7
    3         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))
    4         S NYUK=$P(SRA(208),"^") D YN S SRAO(1)=SHEMP_"^384"
    5         S Y=$P($G(^DPT(DFN,.35)),"^") D DT^SROAPCA1 S SRAO(2)=X
    6         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"
    7         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"
    8         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"
    9         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"
    10         S NYUK=$P(SRA(206),"^",39) D YN S SRAO(14)=SHEMP_"^466"
    11         S NYUK=$P(SRA(206),"^",40) D YN S SRAO(15)=SHEMP_"^467"
    12         I $Y+5>IOSL D PAGE^SROAPCA I SRSOUT Q
    13         W !!,"VII. OUTCOMES"
    14         W !,"Operative Death:",?18,$P(SRAO(1),"^"),?43,"Date of Death:",?58,$P(SRAO(2),"^")
    15         ;I $Y+10>IOSL D PAGE^SROAPCA I SRSOUT Q
    16         W !!,"Perioperative (30 day) Occurrences:"
    17         W !,?2,"Perioperative MI:",?36,$P(SRAO(3),"^"),?42,"Repeat cardiac Surg procedure:",?74,$P(SRAO(10),"^")
    18         W !,?2,"Endocarditis:",?36,$P(SRAO(4),"^"),?42,"Tracheostomy:",?74,$P(SRAO(14),"^")
    19         W !,?2,"Renal Failure Requiring Dialysis:",?36,$P(SRAO(5),"^"),?42,"Ventilator supp within 30 days:",?74,$P(SRAO(6),"^")
    20         W !,?2,"Mediastinitis:",?36,$P(SRAO(7),"^"),?42,"Stroke/CVA:",?74,$P(SRAO(12),"^")
    21         W !,?2,"Cardiac Arrest Requiring CPR:",?36,$P(SRAO(13),"^"),?42,"Coma > or = 24 Hours:",?74,$P(SRAO(11),"^")
    22         W !,?2,"Reoperation for Bleeding:",?36,$P(SRAO(8),"^"),?42,"New Mech Circulatory Support:",?74,$P(SRAO(15),"^")
    23         W !,?2,"On ventilator > or = 48 hr:",?36,$P(SRAO(9),"^")
    24         D RES
    25         Q
    26 YN      ; store answer
    27         S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"")
    28         Q
    29         ;
    30 RES     I $Y+12>IOSL D PAGE^SROAPCA I SRSOUT Q
    31         S SRA(208)=$G(^SRF(SRTN,208))
    32         S SRA(.2)=$G(^SRF(SRTN,.2))
    33         W !!,"VIII. RESOURCE DATA"
    34         S Y=$P(SRA(208),"^",14) D DT^SROAPCA1 W !,"Hospital Admission Date:",?47,X
    35         S Y=$P(SRA(208),"^",15) D DT^SROAPCA1 W !,"Hospital Discharge Date:",?47,X
    36         S Y=$P(SRA(.2),"^",10) D DT^SROAPCA1 W !,"Time Patient In  OR: ",?47,X
    37         S Y=$P(SRA(.2),"^",12) D DT^SROAPCA1 W !,"Time Patient Out OR: ",?47,X
    38         S Y=$P(SRA(208),"^",22) I Y>1 D DT^SROAPCA1 S Y=X
    39         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
    40         I $P(SRA(208),"^",22)>1,$P(SRA(.2),"^",12) D
    41         .S X=$$FMDIFF^XLFDT($P(SRA(208),"^",22),$P(SRA(.2),"^",12),2) W !,?5,"Postop Intubation Hrs: "_$FN((X/3600),"+",1)
    42         S Y=$P(SRA(208),"^",23) I Y>1 D DT^SROAPCA1 S Y=X
    43         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
    44         S Y=$P(SRA(209),"^") W !,"Patient is Homeless: ",?47,$S(Y="Y":"YES",Y="N":"NO",Y="NS":"NS",1:"")
    45         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:"")
    46         S Y=$P(SRA(209),"^",15) D DT^SROAPCA1 W !,"CT Surgery Consult Date: ",?47,$P(X," ")
    47         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
    48         W !,"Resource Data Comments: "
    49         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
    50         .I X'[" " W ?25,X Q
    51         .S I=0,LINE=1 F  S SRL=$S(LINE=1:48,1:80) D  Q:SRQ
    52         ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q
    53         ..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
    54         I $Y+7>IOSL D PAGE^SROAPCA I SRSOUT Q
    55         W ! F MOE=1:1:80 W "="
    56         W !,"IX. SOCIOECONOMIC, ETHNICITY, AND RACE"
    57         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:" ")
    58         W !,?1,"Employment Status Preoperatively: ",?40,SREMP
    59         K SRA,SRAO
    60         ; Race/Ethnic
    61         D ENTH^SRORACE
    62         I $Y+7>IOSL D PAGE^SROAPCA I SRSOUT Q
    63         D ^SROAPCA4
    64         W !!," *** End of report for "_SRANM_" assessment #"_SRTN_" ***"
    65         I $E(IOST)'="P" W ! K DIR S DIR(0)="E" D ^DIR K DIR
    66         Q
     1SROAPCA3 ;B'HAM ISC/MAM - CARDIAC OCCURRENCE DATA ;08/23/07
     2 ;;3.0; Surgery ;**38,71,95,101,125,160,164**;24 Jun 93;Build 2
     3 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))
     4 S NYUK=$P(SRA(208),"^") D YN S SRAO(1)=SHEMP_"^384"
     5 S Y=$P($G(^DPT(DFN,.35)),"^") D DT^SROAPCA1 S SRAO(2)=X
     6 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"
     7 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"
     8 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"
     9 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"
     10 S NYUK=$P(SRA(206),"^",39) D YN S SRAO(14)=SHEMP_"^466"
     11 S NYUK=$P(SRA(206),"^",40) D YN S SRAO(15)=SHEMP_"^467"
     12 I $Y+5>IOSL D PAGE^SROAPCA I SRSOUT Q
     13 W !!,"VII. OUTCOMES"
     14 W !,"Operative Death:",?18,$P(SRAO(1),"^"),?43,"Date of Death:",?58,$P(SRAO(2),"^")
     15 ;I $Y+10>IOSL D PAGE^SROAPCA I SRSOUT Q
     16 W !!,"Perioperative (30 day) Occurrences:"
     17 W !,?2,"Perioperative MI:",?36,$P(SRAO(3),"^"),?42,"Repeat cardiac Surg procedure:",?74,$P(SRAO(10),"^")
     18 W !,?2,"Endocarditis:",?36,$P(SRAO(4),"^"),?42,"Tracheostomy:",?74,$P(SRAO(14),"^")
     19 W !,?2,"Renal Failure Requiring Dialysis:",?36,$P(SRAO(5),"^"),?42,"Ventilator supp within 30 days:",?74,$P(SRAO(6),"^")
     20 W !,?2,"Mediastinitis:",?36,$P(SRAO(7),"^"),?42,"Stroke/CVA:",?74,$P(SRAO(12),"^")
     21 W !,?2,"Cardiac Arrest Requiring CPR:",?36,$P(SRAO(13),"^"),?42,"Coma > or = 24 Hours:",?74,$P(SRAO(11),"^")
     22 W !,?2,"Reoperation for Bleeding:",?36,$P(SRAO(8),"^"),?42,"New Mech Circulatory Support:",?74,$P(SRAO(15),"^")
     23 W !,?2,"On ventilator > or = 48 hr:",?36,$P(SRAO(9),"^")
     24 D RES
     25 Q
     26YN ; store answer
     27 S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"")
     28 Q
     29 ;
     30RES I $Y+12>IOSL D PAGE^SROAPCA I SRSOUT Q
     31 S SRA(208)=$G(^SRF(SRTN,208))
     32 S SRA(.2)=$G(^SRF(SRTN,.2))
     33 W !!,"VIII. RESOURCE DATA"
     34 S Y=$P($G(^SRF(SRTN,208)),"^",14) D DT^SROAPCA1 W !,"Hospital Admission Date:",?47,X
     35 S Y=$P($G(^SRF(SRTN,208)),"^",15) D DT^SROAPCA1 W !,"Hospital Discharge Date:",?47,X
     36 S Y=$P(SRA(.2),"^",10) D DT^SROAPCA1 W !,"Time Patient In  OR: ",?47,X
     37 S Y=$P(SRA(.2),"^",12) D DT^SROAPCA1 W !,"Time Patient Out OR: ",?47,X
     38 S Y=$P($G(^SRF(SRTN,208)),"^",22) I Y>1 D DT^SROAPCA1 S Y=X
     39 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
     40 S Y=$P($G(^SRF(SRTN,208)),"^",23) I Y>1 D DT^SROAPCA1 S Y=X
     41 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
     42 S Y=$P(SRA(209),"^") W !,"Patient is Homeless: ",?47,$S(Y="Y":"YES",Y="N":"NO",Y="NS":"NS",1:"")
     43 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:"")
     44 S Y=$P(SRA(209),"^",15) D DT^SROAPCA1 W !,"CT Surgery Consult Date: ",?47,$P(X," ")
     45 W !,"Resource Data Comments: "
     46 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
     47 .I X'[" " W ?25,X Q
     48 .S I=0,LINE=1 F  S SRL=$S(LINE=1:48,1:80) D  Q:SRQ
     49 ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q
     50 ..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
     51 I $Y+7>IOSL D PAGE^SROAPCA I SRSOUT Q
     52 W ! F MOE=1:1:80 W "="
     53 W !,"IX. SOCIOECONOMIC, ETHNICITY, AND RACE"
     54 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:" ")
     55 W !,?1,"Employment Status Preoperatively: ",?40,SREMP
     56 K SRA,SRAO
     57 ; Race/Ethnic
     58 D ENTH^SRORACE
     59 I $Y+7>IOSL D PAGE^SROAPCA I SRSOUT Q
     60 D ^SROAPCA4
     61 W !!," *** End of report for "_SRANM_" assessment #"_SRTN_" ***"
     62 I $E(IOST)'="P" W ! K DIR S DIR(0)="E" D ^DIR K DIR
     63 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAPM.m

    r613 r623  
    1 SROAPM  ;BIR/ADM - PATIENT DEMOGRAPHIC INFO ;03/03/08
    2         ;;3.0; Surgery ;**47,81,111,107,100,125,142,160,166**;24 Jun 93;Build 7
    3         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
    4         S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
    5 START   G:SRSOUT END D HDR^SROAUTL
    6         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)=" "
    7         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."
    8         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
    9         I Y=1 D PIMS G START
    10 EDIT    S SRR=0 D HDR^SROAUTL K DR S SRQ=0,(DR,SRDR)="413;452;453;454;418;419;420;421;247;.011"
    11         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
    12         K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
    13         .D TR,GET
    14         .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
    15         .W !,$S($L(SRZ)<2:" "_SRZ,1:SRZ)_". "_$P(Z,"^")_":" D EXT
    16         ;
    17         D DEM^VADPT
    18         ;Find patient's ethnicity and list it on the display
    19         W !,"11. Patient's Ethnicity:" S SRZ(11)="" D
    20         .I $G(VADM(11)) W ?40,$P(VADM(11,1),U,2)
    21         .I '$G(VADM(11)) W ?40,"UNANSWERED"
    22         ;
    23         ;Find all race entries and place into a string with commas inbetween
    24         S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL=""
    25         F  S SRORC=$O(VADM(12,SRORC)) Q:SRORC=""  Q:C=11  D
    26         .I $G(VADM(12,SRORC)) S SRORACE(C)=$P(VADM(12,SRORC),U,2)
    27         .I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C)
    28         .I SROLINE="" S SROLINE=SRORACE(C)
    29         .S C=C+1
    30         ;
    31         ;Find total length of 'race' string and wrap the text if necessary
    32         I $L(SROLINE)=40!$L(SROLINE)<40 S SROL(N)=SROLINE,SRNUM1=2
    33         I $L(SROLINE)>40 D WRAP
    34         ;
    35         W !,"12. Patient's Race:" S SRZ(12)=""
    36         I $G(VADM(12)) F D=1:1:SRNUM1-1 D
    37         .W:D=1 ?40,SROL(D)
    38         .W:D'=1 !,?40,SROL(D)
    39         ;
    40         I '$G(VADM(12)) W ?40,"UNANSWERED"
    41         ;
    42         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
    43         S SRZ=12 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
    44         .D TR,GET
    45         .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
    46         .W !,$S($L(SRZ)<2:" "_SRZ,1:SRZ)_". "_$P(Z,"^")_":" D EXT
    47         ;S SRZ=15,SRZ(13)="Date of Death^342",SREXT=SRY(130,SRTN,342,"E") W !,"13. Date/Time of Death:",?40,SREXT
    48         ;S SRZ(14)="Surgery Consult Date^513",SREXT=SRY(130,SRTN,513,"E") W !,"14. Surgery Consult Date:",?40,SREXT
    49         ;S SRZ(15)="Date Surgery Consult Requested^516",SREXT=SRY(130,SRTN,516,"E") W !,"15. Date Surgery Consult Requested:",?40,SREXT
    50         K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1
    51         ;
    52         W !! F K=1:1:80 W "-"
    53         D SEL G:SRR=1 EDIT
    54         S SROERR=SRTN D ^SROERR0
    55         G START
    56         Q
    57         ;
    58 WRAP    ;Wrap multiple race entries so that wrapped line
    59         ;does not break in the middle of a word
    60         ;
    61         N SROLNGTH S SROLNGTH=$L(SROLINE),E=40,SROWRAP="",SROLN="",SROLN1="",SROL=""
    62         F I=1:40:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D
    63         .F K=40:-1:1 I $E(SROLN(I),K)[" " D  Q    ;Break lines at space
    64         ..S SROLN1(I)=$E(SROLN(I),1,K-1)
    65         ..S SROWRAP=$E(SROLN(I),K+1,E)
    66         .S E=E+40
    67         ;
    68         S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP=""
    69         I $L(SROLN1(I))+$L(SROWRAP)>39 S SROLN1(I+1)=SROWRAP   ;Last line
    70         I $L(SROLN1(I))+$L(SROWRAP)'>39 S SROLN1(I)=SROLN1(I)_" "_SROWRAP
    71         ;
    72         ;Renumber the SROLN1 array to be in numeric order
    73         S SRNUM=0,SRNUM1=1
    74         F  S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM=""  D
    75         .S SROL(SRNUM1)=SROLN1(SRNUM)
    76         .S SRNUM1=SRNUM1+1
    77         Q
    78         ;
    79 EXT     I $L(SREXT)<40 W ?40,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q
    80         N I,J,X,Y S X=SREXT F  D  W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q
    81         .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
    82         Q
    83 SEL     W !!,"Select Patient Demographics Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
    84         I (X=11)!(X=12) S SRR=1 W !!,"The Patient's Race and Ethnicity information cannot be updated through the" D  Q
    85         .W !,"Surgery package options."
    86         .W !!,"Press RETURN to continue " R X:DTIME
    87         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
    88         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
    89         I X="A" S X="1:"_SRZ
    90         I X?1.2N1":"1.2N D RANGE S SRR=1 Q
    91         I $D(SRZ(X)),+X=X S EMILY=X D  S SRR=1
    92         .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
    93         Q
    94 PIMS    ; get update from PIMS records
    95         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
    96         I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
    97         .W ! D WAIT^DICD D ^SROAPIMS
    98         Q
    99 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."
    100         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),"^")_")"
    101         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.)",!
    102         I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",!
    103 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
    104         Q
    105 RANGE   ; range of numbers
    106         I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
    107         .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) D
    108         ..I SHEMP<13 F EMILY=SHEMP:1:10,13:1:15 Q:SRSOUT  D ONE
    109         ..I SHEMP>12 F EMILY=SHEMP:1:15 Q:SRSOUT  D ONE
    110         Q
    111 ONE     ; edit one item
    112         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
    113         Q
    114 TR      S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
    115         Q
    116 GET     S X=$T(@J)
    117         Q
    118 END     W @IOF D ^SRSKILL
    119         Q
    120 PJAA    ;;.011^In/Out-Patient Status
    121 BDG     ;;247^Length of Postop Hospital Stay
    122 CDB     ;;342^Date of Death
    123 DAC     ;;413^Transfer Status
    124 DAG     ;;417^Patient's Race
    125 DAH     ;;418^Hospital Admission Date/Time
    126 DAI     ;;419^Hospital Discharge Date/Time
    127 DBJ     ;;420^Admit/Transfer to Surgical Svc.
    128 DBA     ;;421^Discharge/Transfer to Chronic Care
    129 DEB     ;;452^Observation Admission Date/Time
    130 DEC     ;;453^Observation Discharge Date/Time
    131 DED     ;;454^Observation Treating Specialty
    132 EAC     ;;513^Surgery Consult Date
    133 EAF     ;;516^Date Surgery Consult Requested
     1SROAPM ;BIR/ADM - PATIENT DEMOGRAPHIC INFO ;01/23/07
     2 ;;3.0; Surgery ;**47,81,111,107,100,125,142,160**;24 Jun 93;Build 7
     3 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
     4 S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
     5START G:SRSOUT END D HDR^SROAUTL
     6 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)=" "
     7 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."
     8 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
     9 I Y=1 D PIMS G START
     10EDIT S SRR=0 D HDR^SROAUTL K DR S SRQ=0,(DR,SRDR)="413;452;453;454;418;419;420;421;247;.011"
     11 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
     12 K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
     13 .D TR,GET
     14 .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
     15 .W !,$S($L(SRZ)<2:" "_SRZ,1:SRZ)_". "_$P(Z,"^")_":" D EXT
     16 ;
     17 D DEM^VADPT
     18 ;Find patient's ethnicity and list it on the display
     19 W !,"11. Patient's Ethnicity:" S SRZ(11)="" D
     20 .I $G(VADM(11)) W ?40,$P(VADM(11,1),U,2)
     21 .I '$G(VADM(11)) W ?40,"UNANSWERED"
     22 ;
     23 ;Find all race entries and place into a string with commas inbetween
     24 S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL=""
     25 F  S SRORC=$O(VADM(12,SRORC)) Q:SRORC=""  Q:C=11  D
     26 .I $G(VADM(12,SRORC)) S SRORACE(C)=$P(VADM(12,SRORC),U,2)
     27 .I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C)
     28 .I SROLINE="" S SROLINE=SRORACE(C)
     29 .S C=C+1
     30 ;
     31 ;Find total length of 'race' string and wrap the text if necessary
     32 I $L(SROLINE)=40!$L(SROLINE)<40 S SROL(N)=SROLINE,SRNUM1=2
     33 I $L(SROLINE)>40 D WRAP
     34 ;
     35 W !,"12. Patient's Race:" S SRZ(12)=""
     36 I $G(VADM(12)) F D=1:1:SRNUM1-1 D
     37 .W:D=1 ?40,SROL(D)
     38 .W:D'=1 !,?40,SROL(D)
     39 ;
     40 I '$G(VADM(12)) W ?40,"UNANSWERED"
     41 ;
     42 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
     43 S SRZ=13,SRZ(13)="Date of Death^342",SREXT=SRY(130,SRTN,342,"E")
     44 W !,"13. Date/Time of Death:",?40,SREXT
     45 K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1
     46 ;
     47 W !! F K=1:1:80 W "-"
     48 D SEL G:SRR=1 EDIT
     49 S SROERR=SRTN D ^SROERR0
     50 G START
     51 Q
     52 ;
     53WRAP ;Wrap multiple race entries so that wrapped line
     54 ;does not break in the middle of a word
     55 ;
     56 N SROLNGTH S SROLNGTH=$L(SROLINE),E=40,SROWRAP="",SROLN="",SROLN1="",SROL=""
     57 F I=1:40:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D
     58 .F K=40:-1:1 I $E(SROLN(I),K)[" " D  Q    ;Break lines at space
     59 ..S SROLN1(I)=$E(SROLN(I),1,K-1)
     60 ..S SROWRAP=$E(SROLN(I),K+1,E)
     61 .S E=E+40
     62 ;
     63 S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP=""
     64 I $L(SROLN1(I))+$L(SROWRAP)>39 S SROLN1(I+1)=SROWRAP   ;Last line
     65 I $L(SROLN1(I))+$L(SROWRAP)'>39 S SROLN1(I)=SROLN1(I)_" "_SROWRAP
     66 ;
     67 ;Renumber the SROLN1 array to be in numeric order
     68 S SRNUM=0,SRNUM1=1
     69 F  S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM=""  D
     70 .S SROL(SRNUM1)=SROLN1(SRNUM)
     71 .S SRNUM1=SRNUM1+1
     72 Q
     73 ;
     74EXT I $L(SREXT)<40 W ?40,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q
     75 N I,J,X,Y S X=SREXT F  D  W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q
     76 .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
     77 Q
     78SEL W !!,"Select number of item to edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
     79 I (X=11)!(X=12) S SRR=1 W !!,"The Patient's Race and Ethnicity information cannot be updated through the" D  Q
     80 .W !,"Surgery package options."
     81 .W !!,"Press RETURN to continue " R X:DTIME
     82 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
     83 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
     84 I X="A" S X="1:"_SRZ
     85 I X?1.2N1":"1.2N D RANGE S SRR=1 Q
     86 I $D(SRZ(X)),+X=X S EMILY=X D  S SRR=1
     87 .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN)
     88 Q
     89PIMS ; get update from PIMS records
     90 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
     91 I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
     92 .W ! D WAIT^DICD D ^SROAPIMS
     93 Q
     94HELP 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."
     95 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),"^")_")"
     96 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.)",!
     97 I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",!
     98PRESS 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
     99 Q
     100RANGE ; range of numbers
     101 I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
     102 .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:10,13 Q:SRSOUT  D ONE
     103 Q
     104ONE ; edit one item
     105 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
     106 Q
     107TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
     108 Q
     109GET S X=$T(@J)
     110 Q
     111END W @IOF D ^SRSKILL
     112 Q
     113PJAA ;;.011^In/Out-Patient Status
     114BDG ;;247^Length of Postop Hospital Stay
     115CDB ;;342^Date of Death
     116DAC ;;413^Transfer Status
     117DAG ;;417^Patient's Race
     118DAH ;;418^Hospital Admission Date/Time
     119DAI ;;419^Hospital Discharge Date/Time
     120DBJ ;;420^Admit/Transfer to Surgical Svc.
     121DBA ;;421^Discharge/Transfer to Chronic Care
     122DEB ;;452^Observation Admission Date/Time
     123DEC ;;453^Observation Discharge Date/Time
     124DED ;;454^Observation Treating Specialty
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAPRE.m

    r613 r623  
    1 SROAPRE ;BIR/MAM - PREOPERATIVE INFO ;11/26/07
    2         ;;3.0; Surgery ;**38,47,55,88,100,125,142,166**;24 Jun 93;Build 7
    3         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
    4         S (SRSOUT,SRACLR)=0,SRSUPCPT=1 D ^SROAUTL,DUP^SROAUTL G:SRSOUT END
    5 START   D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROAPS1
    6 ASK     W !,"Select Preoperative Information to Edit: " R X:DTIME I '$T!(X["^") D CONCC G END
    7         S:X="" X="+1" S:X="a" X="A" S:X="n" X="N"
    8         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
    9         I '$D(SRAO(X)),(X'?.N1":".N),(X'="A"),(X'="N"),(X'="+1") D HELP G:SRSOUT END G START
    10         I X="+1" D CONCC,^SROAPR2 G START
    11         I X="A" S X="1:6"
    12         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
    13         I X="N" D  G:SRSOUT END G START
    14         .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"
    15         .D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
    16         .I Y D NO2ALL^SROAPRE1
    17         S SRPAGE="" D HDR^SROAUTL
    18         I X?.N1":".N D RANGE G START
    19         I $D(SRAO(X)),+X=X S EMILY=X D  G START
    20         .I $$LOCK^SROUTL(SRTN) W ! D:EMILY<4 ^SROAPRE1 D:EMILY>3 ^SROAPR1A D UNLOCK^SROUTL(SRTN)
    21         I $D(SRAO(X)),$$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
    22         .I X="1H" D FUNCTH Q
    23         .S SRX=X W ! K DR,DIE S DA=SRTN,DR=$P(SRAO(X),"^",2)_"T",DIE=130 D ^DIE K DR
    24         G START
    25 END     I '$D(SREQST) W @IOF D ^SRSKILL
    26         Q
    27 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
    28         .I $D(DTOUT)!$D(DUOUT) Q
    29         .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q
    30         .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR
    31         Q
    32 HELP    W @IOF,!!!!,"Enter the number, number/letter combination, or range of numbers you want to",!,"edit.  Examples of proper responses are listed below."
    33         W !!,"1. Enter 'A' to update all information.",!!,"2. Enter 'N' to set all fields on this page to NO."
    34         W !!,"3. Enter a number (1-6) to update the information in that group.  (For",!,"   example, enter '5' to update all cardiac information)"
    35         W !!,"4. Enter a number/letter combination to update a specific occurrence. (To ",!,"   update Current Pneumonia, enter '2C'.)"
    36         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)"
    37         W !!,"6. Press <RET> to continue to page 2 of this option."
    38         W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1
    39         Q
    40 RANGE   ; range of numbers
    41         I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
    42         .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
    43         Q
    44 RET     Q:SRSOUT  W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
    45         Q
    46 CONCC   ; check for concurrent case and update if one exists
    47         S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON
    48         Q:$P($G(^SRF(SRCON,"RA")),"^",2)="C"
    49         S SRI="" F  S SRI=$O(SRAO(SRI)) Q:SRI=""  S SRZ=$P(SRAO(SRI),"^",2) K DA,DIC,DIQ,DR,SRY D
    50         .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="@"
    51         .I $$LOCK^SROUTL(SRTN) K DA,DIE,DR S DA=SRCON,DIE=130,DR=SRZ_"////"_SRX D ^DIE K DR D UNLOCK^SROUTL(SRTN)
    52         Q
     1SROAPRE ;BIR/MAM - PREOPERATIVE INFO ;06/03/05
     2 ;;3.0; Surgery ;**38,47,55,88,100,125,142**;24 Jun 93
     3 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
     4 S (SRSOUT,SRACLR)=0,SRSUPCPT=1 D ^SROAUTL,DUP^SROAUTL G:SRSOUT END
     5START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROAPS1
     6ASK W !,"Select Preoperative Information to Edit: " R X:DTIME I '$T!(X["^") D CONCC G END
     7 S:X="" X="+1" S:X="a" X="A" S:X="n" X="N"
     8 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
     9 I '$D(SRAO(X)),(X'?.N1":".N),(X'="A"),(X'="N"),(X'="+1") D HELP G:SRSOUT END G START
     10 I X="+1" D CONCC,^SROAPR2 G START
     11 I X="A" S X="1:6"
     12 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
     13 I X="N" D  G:SRSOUT END G START
     14 .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"
     15 .D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
     16 .I Y D NO2ALL^SROAPRE1
     17 S SRPAGE="" D HDR^SROAUTL
     18 I X?.N1":".N D RANGE G START
     19 I $D(SRAO(X)),+X=X S EMILY=X D  G START
     20 .I $$LOCK^SROUTL(SRTN) W ! D:EMILY<4 ^SROAPRE1 D:EMILY>3 ^SROAPR1A D UNLOCK^SROUTL(SRTN)
     21 I $D(SRAO(X)),$$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
     22 .I X="1J" D FUNCTI Q
     23 .I X="1I" D FUNCTJ Q
     24 .S SRX=X W ! K DR,DIE S DA=SRTN,DR=$P(SRAO(X),"^",2)_"T",DIE=130 D ^DIE K DR
     25 G START
     26END I '$D(SREQST) W @IOF D ^SRSKILL
     27 Q
     28FUNCTI 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
     29 .I $D(DTOUT)!$D(DUOUT) Q
     30 .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q
     31 .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR
     32 Q
     33FUNCTJ 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
     34 .I $D(DTOUT)!$D(DUOUT) Q
     35 .I X="@" K DIE,DR S DIE=130,DR="240///@" D ^DIE K DA,DIE,DR Q
     36 .K DIE,DR S DIE=130,DR="240////"_Y D ^DIE K DA,DIE,DR
     37 Q
     38HELP W @IOF,!!!!,"Enter the number, number/letter combination, or range of numbers you want to",!,"edit.  Examples of proper responses are listed below."
     39 W !!,"1. Enter 'A' to update all information.",!!,"2. Enter 'N' to set all fields on this page to NO."
     40 W !!,"3. Enter a number (1-6) to update the information in that group.  (For",!,"   example, enter '5' to update all cardiac information)"
     41 W !!,"4. Enter a number/letter combination to update a specific occurrence. (To ",!,"   update Current Pneumonia, enter '2C'.)"
     42 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)"
     43 W !!,"6. Press <RET> to continue to page 2 of this option."
     44 W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1
     45 Q
     46RANGE ; range of numbers
     47 I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
     48 .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
     49 Q
     50RET Q:SRSOUT  W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
     51 Q
     52CONCC ; check for concurrent case and update if one exists
     53 S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON
     54 Q:$P($G(^SRF(SRCON,"RA")),"^",2)="C"
     55 S SRI="" F  S SRI=$O(SRAO(SRI)) Q:SRI=""  S SRZ=$P(SRAO(SRI),"^",2) K DA,DIC,DIQ,DR,SRY D
     56 .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="@"
     57 .I $$LOCK^SROUTL(SRTN) K DA,DIE,DR S DA=SRCON,DIE=130,DR=SRZ_"////"_SRX D ^DIE K DR D UNLOCK^SROUTL(SRTN)
     58 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAPRE1.m

    r613 r623  
    1 SROAPRE1        ;BIR/MAM - EDIT PAGE 1 PREOP ;11/26/07
    2         ;;3.0; Surgery ;**38,47,125,135,141,166**;24 Jun 93;Build 7
    3         K DA D @EMILY Q
    4 1       ; edit general information
    5         W ! K DIR S X=$P(SRAO(1),"^") I X'="" S DIR("B")=X
    6         S DIR(0)="130,402",DIR("A")="GENERAL" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
    7         I X="@" S SRCAT="General" D SURE Q:SRSOUT  G:'SRYN 1 S (SRAX,X)="",$P(^SRF(SRTN,200),"^")="" D NOGEN Q
    8         S SRAX=Y,$P(^SRF(SRTN,200),"^")=SRAX I Y["N" D NOGEN Q
    9         I Y["Y" D GEN
    10         Q
    11 2       ; edit pulmonary information
    12         W ! K DIR S X=$P(SRAO(2),"^") I X'="" S DIR("B")=X
    13         S DIR(0)="130,241",DIR("A")="PULMONARY" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
    14         I X="@" S SRCAT="Pulmonary" D SURE Q:SRSOUT  G:'SRYN 2 S (SRAX,X)="",$P(^SRF(SRTN,200),"^",9)="" D NOPULM Q
    15         S SRAX=Y,$P(^SRF(SRTN,200),"^",9)=SRAX I Y["N" D NOPULM Q
    16         I Y["Y" D PULM
    17         Q
    18 3       ; edit hepatobiliary information
    19         W ! K DIR S X=$P(SRAO(3),"^") I X'="" S DIR("B")=X
    20         S DIR(0)="130,244",DIR("A")="HEPATOBILIARY" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
    21         I X="@" S SRCAT="Hepatobiliary" D SURE Q:SRSOUT  G:'SRYN 3 S (SRAX,X)="",$P(^SRF(SRTN,200),"^",13)="" D NOHEP Q
    22         S SRAX=Y,$P(^SRF(SRTN,200),"^",13)=SRAX I Y["N" D NOHEP Q
    23         I Y["Y" D HEP
    24         Q
    25 GEN     ; general
    26         N SRUP S SRUP=""
    27         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
    28         K DIR S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D
    29         .I $D(DTOUT)!$D(DUOUT) Q
    30         .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q
    31         .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR
    32         S SRACLR=0
    33         Q
    34 NOGEN   ; no general problems
    35         S $P(^SRF(SRTN,200),"^",6)=$S(X="":"",1:1) F I=2,3,4,7 S $P(^SRF(SRTN,200),"^",I)=SRAX
    36         S $P(^SRF(SRTN,200.1),"^",2)=$S(X="":"",X="NS":"NS",1:1)
    37         Q
    38 PULM    ; pulmonary
    39         W ! K DR,DIE S DA=SRTN,DIE=130,DR="204T;203T;326T" D ^DIE K DR
    40         S SRACLR=0
    41         Q
    42 NOPULM  ; no pulmonary problems
    43         F I=10:1:12 S $P(^SRF(SRTN,200),"^",I)=SRAX
    44         Q
    45 HEP     ; hepatobiliary
    46         K DR,DIE S DIE=130,DA=SRTN,DR="212////Y" D ^DIE K DR
    47         S SRACLR=0
    48         Q
    49 NOHEP   ; no hepatobiliary problems
    50         S $P(^SRF(SRTN,200),"^",15)=SRAX
    51         Q
    52 RET     W !! K DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
    53         Q
    54 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
    55         Q
    56 NO2ALL  ; set all fields to NO
    57         S SRAX="N",$P(^SRF(SRTN,200),"^")=SRAX D NOGEN
    58         S $P(^SRF(SRTN,200),"^",9)=SRAX D NOPULM
    59         S $P(^SRF(SRTN,200),"^",13)=SRAX D NOHEP
    60         S $P(^SRF(SRTN,200.1),"^")=SRAX D NOGAST^SROAPR1A
    61         S $P(^SRF(SRTN,200),"^",30)=SRAX D NOCARD^SROAPR1A
    62         S $P(^SRF(SRTN,200),"^",40)=SRAX D NOVAS^SROAPR1A
    63         Q
     1SROAPRE1 ;B'HAM ISC/MAM - EDIT PAGE 1 PREOP ;01/05/05
     2 ;;3.0; Surgery ;**38,47,125,135,141**;24 Jun 93
     3 K DA D @EMILY Q
     41 ; edit general information
     5 W ! K DIR S X=$P(SRAO(1),"^") I X'="" S DIR("B")=X
     6 S DIR(0)="130,402",DIR("A")="GENERAL" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
     7 I X="@" S SRCAT="General" D SURE Q:SRSOUT  G:'SRYN 1 S (SRAX,X)="",$P(^SRF(SRTN,200),"^")="" D NOGEN Q
     8 S SRAX=Y,$P(^SRF(SRTN,200),"^")=SRAX I Y["N" D NOGEN Q
     9 I Y["Y" D GEN
     10 Q
     112 ; edit pulmonary information
     12 W ! K DIR S X=$P(SRAO(2),"^") I X'="" S DIR("B")=X
     13 S DIR(0)="130,241",DIR("A")="PULMONARY" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
     14 I X="@" S SRCAT="Pulmonary" D SURE Q:SRSOUT  G:'SRYN 2 S (SRAX,X)="",$P(^SRF(SRTN,200),"^",9)="" D NOPULM Q
     15 S SRAX=Y,$P(^SRF(SRTN,200),"^",9)=SRAX I Y["N" D NOPULM Q
     16 I Y["Y" D PULM
     17 Q
     183 ; edit hepatobiliary information
     19 W ! K DIR S X=$P(SRAO(3),"^") I X'="" S DIR("B")=X
     20 S DIR(0)="130,244",DIR("A")="HEPATOBILIARY" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
     21 I X="@" S SRCAT="Hepatobiliary" D SURE Q:SRSOUT  G:'SRYN 3 S (SRAX,X)="",$P(^SRF(SRTN,200),"^",13)="" D NOHEP Q
     22 S SRAX=Y,$P(^SRF(SRTN,200),"^",13)=SRAX I Y["N" D NOHEP Q
     23 I Y["Y" D HEP
     24 Q
     25GEN ; general
     26 N SRUP S SRUP=""
     27 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
     28 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
     29 .I $D(DTOUT) Q
     30 .I $D(DUOUT) S SRUP=1 Q
     31 .I X="@" K DIE,DR S DIE=130,DR="240///@" D ^DIE K DA,DIE,DR Q
     32 .K DIE,DR S DIE=130,DR="240////"_Y D ^DIE K DA,DIE,DR
     33 S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D
     34 .I $D(DTOUT)!$D(DUOUT) Q
     35 .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q
     36 .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR
     37 S SRACLR=0
     38 Q
     39NOGEN ; no general problems
     40 S $P(^SRF(SRTN,200),"^",6)=$S(X="":"",1:1) F I=2,3,4,7 S $P(^SRF(SRTN,200),"^",I)=SRAX
     41 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)
     42 Q
     43PULM ; pulmonary
     44 W ! K DR,DIE S DA=SRTN,DIE=130,DR="204T;203T;326T" D ^DIE K DR
     45 S SRACLR=0
     46 Q
     47NOPULM ; no pulmonary problems
     48 F I=10:1:12 S $P(^SRF(SRTN,200),"^",I)=SRAX
     49 Q
     50HEP ; hepatobiliary
     51 K DR,DIE S DIE=130,DA=SRTN,DR="212////Y" D ^DIE K DR
     52 S SRACLR=0
     53 Q
     54NOHEP ; no hepatobiliary problems
     55 S $P(^SRF(SRTN,200),"^",15)=SRAX
     56 Q
     57RET W !! K DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
     58 Q
     59SURE 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
     60 Q
     61NO2ALL ; set all fields to NO
     62 S SRAX="N",$P(^SRF(SRTN,200),"^")=SRAX D NOGEN
     63 S $P(^SRF(SRTN,200),"^",9)=SRAX D NOPULM
     64 S $P(^SRF(SRTN,200),"^",13)=SRAX D NOHEP
     65 S $P(^SRF(SRTN,200.1),"^")=SRAX D NOGAST^SROAPR1A
     66 S $P(^SRF(SRTN,200),"^",30)=SRAX D NOCARD^SROAPR1A
     67 S $P(^SRF(SRTN,200),"^",40)=SRAX D NOVAS^SROAPR1A
     68 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAPRE2.m

    r613 r623  
    1 SROAPRE2        ;BIR/MAM - EDIT PAGE 2 PREOP ;11/26/07
    2         ;;3.0; Surgery ;**38,47,125,153,166**;24 Jun 93;Build 7
    3         D @EMILY Q
    4 1       ; edit renal information
    5         W ! K DIR S X=$P(SRAO(1),"^") I X'="" S DIR("B")=X
    6         S DIR(0)="130,243",DIR("A")="RENAL" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
    7         I X="@" S SRCAT="Renal" D SURE Q:SRSOUT  G:'SRYN 1 S $P(^SRF(SRTN,200),"^",37)="" S (SRAX,X)="" D NOREN Q
    8         S SRAX=Y,$P(^SRF(SRTN,200),"^",37)=SRAX I Y["N" D NOREN Q
    9         I Y["Y" D REN
    10         Q
    11 2       ; edit CNS information
    12         W ! K DIR S X=$P(SRAO(2),"^") I X'="" S DIR("B")=X
    13         S DIR(0)="130,210",DIR("A")="CENTRAL NERVOUS SYSTEM" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
    14         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
    15         S SRAX=Y,$P(^SRF(SRTN,200),"^",18)=SRAX I Y["N" D NOCNS Q
    16         I Y["Y" D CNS
    17         Q
    18 3       ; edit nutritional/immune/other info
    19         W ! K DIR S X=$P(SRAO(3),"^") I X'="" S DIR("B")=X
    20         S DIR(0)="130,245",DIR("A")="NUTRITIONAL/IMMUNE/OTHER" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
    21         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
    22         S SRAX=Y,$P(^SRF(SRTN,200),"^",44)=SRAX I Y["N" D NONUT Q
    23         I Y["Y" D NUT
    24         Q
    25 REN     ; renal
    26         W ! K DR,DIE S DA=SRTN,DIE=130,DR="328T;211T" D ^DIE K DR
    27         S SRACLR=0
    28         Q
    29 NOREN   ; no renal problems
    30         F I=38,39 S $P(^SRF(SRTN,200),"^",I)=SRAX
    31         Q
    32 CNS     ; cns
    33         W ! K DR,DIE S DIE=130,DA=SRTN,DR="332T;333T;400T;334T;335T;336T;401T;" D ^DIE K DR,DIE
    34         S SRACLR=0
    35         Q
    36 NOCNS   ; no CNS problems
    37         F I=19,21,24:1:27,29 S $P(^SRF(SRTN,200),"^",I)=SRAX
    38         Q
    39 NUT     ; nutritional/immune/other
    40         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
    41         S SRACLR=0
    42         Q
    43 NONUT   ; no nutritional/immune/other
    44         F I=45:1:50 S $P(^SRF(SRTN,200),"^",I)=SRAX
    45         F I=3,4,8 S $P(^SRF(SRTN,206),"^",I)=SRAX
    46         S:SRAX="N" $P(^SRF(SRTN,200.1),"^",3)=$S($P($G(VADM(5)),"^")="M":"NA",1:"NO")
    47         S:SRAX="" $P(^SRF(SRTN,200.1),"^",3)=""
    48         Q
    49 RET     W !! K DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
    50         Q
    51 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
    52         Q
    53 DEL     W !!,?10,"Deleting all "_SRCAT_" information...  "
    54         Q
    55 NO2ALL  ; set all fields to NO
    56         S SRAX="N",$P(^SRF(SRTN,200),"^",37)=SRAX D NOREN
    57         S $P(^SRF(SRTN,200),"^",18)=SRAX D NOCNS
    58         S $P(^SRF(SRTN,200),"^",44)=SRAX D NONUT
    59         Q
     1SROAPRE2 ;BIR/MAM - EDIT PAGE 2 PREOP ;06/27/06
     2 ;;3.0; Surgery ;**38,47,125,153**;24 Jun 93;Build 11
     3 D @EMILY Q
     41 ; edit renal information
     5 W ! K DIR S X=$P(SRAO(1),"^") I X'="" S DIR("B")=X
     6 S DIR(0)="130,243",DIR("A")="RENAL" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
     7 I X="@" S SRCAT="Renal" D SURE Q:SRSOUT  G:'SRYN 1 S $P(^SRF(SRTN,200),"^",37)="" S (SRAX,X)="" D NOREN Q
     8 S SRAX=Y,$P(^SRF(SRTN,200),"^",37)=SRAX I Y["N" D NOREN Q
     9 I Y["Y" D REN
     10 Q
     112 ; edit CNS information
     12 W ! K DIR S X=$P(SRAO(2),"^") I X'="" S DIR("B")=X
     13 S DIR(0)="130,210",DIR("A")="CENTRAL NERVOUS SYSTEM" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
     14 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
     15 S SRAX=Y,$P(^SRF(SRTN,200),"^",18)=SRAX I Y["N" D NOCNS Q
     16 I Y["Y" D CNS
     17 Q
     183 ; edit nutritional/immune/other info
     19 W ! K DIR S X=$P(SRAO(3),"^") I X'="" S DIR("B")=X
     20 S DIR(0)="130,245",DIR("A")="NUTRITIONAL/IMMUNE/OTHER" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q
     21 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
     22 S SRAX=Y,$P(^SRF(SRTN,200),"^",44)=SRAX I Y["N" D NONUT Q
     23 I Y["Y" D NUT
     24 Q
     25REN ; renal
     26 W ! K DR,DIE S DA=SRTN,DIE=130,DR="328T;211T" D ^DIE K DR
     27 S SRACLR=0
     28 Q
     29NOREN ; no renal problems
     30 F I=38,39 S $P(^SRF(SRTN,200),"^",I)=SRAX
     31 Q
     32CNS ; cns
     33 W ! K DR,DIE S DIE=130,DA=SRTN,DR="332T;333T;400T;334T;335T;336T;401T;399T;398T;" D ^DIE K DR,DIE
     34 S SRACLR=0
     35 Q
     36NOCNS ; no CNS problems
     37 F I=19,21:1:27,29 S $P(^SRF(SRTN,200),"^",I)=SRAX
     38 Q
     39NUT ; nutritional/immune/other
     40 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
     41 S SRACLR=0
     42 Q
     43NONUT ; no nutritional/immune/other
     44 F I=45:1:50 S $P(^SRF(SRTN,200),"^",I)=SRAX
     45 F I=3,4,8 S $P(^SRF(SRTN,206),"^",I)=SRAX
     46 S:SRAX="N" $P(^SRF(SRTN,200.1),"^",3)=$S($P($G(VADM(5)),"^")="M":"NA",1:"NO")
     47 S:SRAX="" $P(^SRF(SRTN,200.1),"^",3)=""
     48 Q
     49RET W !! K DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
     50 Q
     51SURE 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
     52 Q
     53DEL W !!,?10,"Deleting all "_SRCAT_" information...  "
     54 Q
     55NO2ALL ; set all fields to NO
     56 S SRAX="N",$P(^SRF(SRTN,200),"^",37)=SRAX D NOREN
     57 S $P(^SRF(SRTN,200),"^",18)=SRAX D NOCNS
     58 S $P(^SRF(SRTN,200),"^",44)=SRAX D NONUT
     59 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAPRT1.m

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

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

    r613 r623  
    1 SROAPRT4        ;BIR/MAM - PRINT ASSESSMENT (CONT.) ;01/14/08
    2         ;;3.0; Surgery ;**38,125,153,160,166**;24 Jun 93;Build 7
    3         ;K SRA S SRA(201)=$G(^SRF(SRTN,201)),SRA(202)=$G(^SRF(SRTN,202))
    4         K SRA F I=201,202,203,204,202.1 S SRA(I)=$G(^SRF(SRTN,I))
    5         W !,?20,"PREOPERATIVE LABORATORY TEST RESULTS"
    6         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_")"
    7         W !,$J("Serum Sodium: ",39) S X=$P(SRA(201),"^") W X S X=$P(SRA(202),"^") I X D DATE W ?48,"("_Y_")"
    8         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_")"
    9         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_")"
    10         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_")"
    11         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_")"
    12         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_")"
    13         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_")"
    14         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_")"
    15         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_")"
    16         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_")"
    17         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_")"
    18         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_")"
    19         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_")"
    20         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_")"
    21         I $E(IOST)="P" W !!
    22         Q
    23 DATE    S Y=X X ^DD("DD")
    24         Q
     1SROAPRT4 ;BIR/MAM - PRINT ASSESSMENT (CONT.) ;06/28/06
     2 ;;3.0; Surgery ;**38,125,153,160**;24 Jun 93;Build 7
     3 ;K SRA S SRA(201)=$G(^SRF(SRTN,201)),SRA(202)=$G(^SRF(SRTN,202))
     4 K SRA F I=201,202,203,204,202.1 S SRA(I)=$G(^SRF(SRTN,I))
     5 W !,?20,"PREOPERATIVE LABORATORY TEST RESULTS"
     6 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_")"
     7 W !,$J("Serum Sodium: ",39) S X=$P(SRA(201),"^") W X S X=$P(SRA(202),"^") I X D DATE W ?48,"("_Y_")"
     8 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_")"
     9 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_")"
     10 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_")"
     11 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_")"
     12 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_")"
     13 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_")"
     14 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_")"
     15 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_")"
     16 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_")"
     17 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_")"
     18 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_")"
     19 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_")"
     20 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_")"
     21 I $E(IOST)="P" W !!
     22 Q
     23DATE S Y=X X ^DD("DD")
     24 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAPRT5.m

    r613 r623  
    1 SROAPRT5        ;BIR/MAM - PRINT ASSESSMENT (CONT) ;01/14/08
    2         ;;3.0; Surgery ;**38,88,153,166**;24 Jun 93;Build 7
    3         K SRA S SRA(203)=$G(^SRF(SRTN,203)),SRA(204)=$G(^SRF(SRTN,204))
    4         W:$E(IOST)="P" ! W !,?22,"POSTOPERATIVE LABORATORY RESULTS",!!,?29," * Highest Value",!,?29,"** Lowest Value"
    5         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_")"
    6         W !,$J("* Serum Sodium: ",39) S X=$P(SRA(203),"^") W X S X=$P(SRA(204),"^") I X D DATE W ?48,"("_Y_")"
    7         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_")"
    8         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_")"
    9         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_")"
    10         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_")"
    11         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_")"
    12         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_")"
    13         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_")"
    14         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_")"
    15         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_")"
    16         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_")"
    17         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_")"
    18         I $E(IOST)="P" W !!
    19         Q
    20 DATE    S Y=X X ^DD("DD")
    21         Q
     1SROAPRT5 ;BIR/MAM - PRINT ASSESSMENT (CONT) ;06/28/06
     2 ;;3.0; Surgery ;**38,88,153**;24 Jun 93;Build 11
     3 K SRA S SRA(203)=$G(^SRF(SRTN,203)),SRA(204)=$G(^SRF(SRTN,204))
     4 W:$E(IOST)="P" ! W !,?22,"POSTOPERATIVE LABORATORY RESULTS",!!,?29," * Highest Value",!,?29,"** Lowest Value"
     5 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_")"
     6 W !,$J("* Serum Sodium: ",39) S X=$P(SRA(203),"^") W X S X=$P(SRA(204),"^") I X D DATE W ?48,"("_Y_")"
     7 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_")"
     8 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_")"
     9 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_")"
     10 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_")"
     11 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_")"
     12 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_")"
     13 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_")"
     14 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_")"
     15 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_")"
     16 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_")"
     17 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_")"
     18 I $E(IOST)="P" W !!
     19 Q
     20DATE S Y=X X ^DD("DD")
     21 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAPS1.m

    r613 r623  
    1 SROAPS1 ;BIR/MAM - PREOP INFO (PAGE 1) ;12/12/07
    2         ;;3.0; Surgery ;**38,47,125,153,166**;24 Jun 93;Build 7
    3         ;
    4         ; Reference to EN1^GMRVUT0 supported by DBIA #1446
    5         ;
    6         N I S SRPAGE="PAGE: 1 OF 2" D HDR^SROAUTL,PRE1
    7         W ! F I=1:1:80 W "-"
    8         Q
    9 PRE1    N SRX,Y D HW F I=200,206 S SRA(I)=$G(^SRF(SRTN,I))
    10         S Y=$P(SRA(200),"^"),SRX=402,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
    11         S Y=$P(SRA(206),"^"),SRX=236,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
    12         S Y=$P(SRA(206),"^",2),SRX=237,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX
    13         S Y=$P(SRA(200),"^",2),SRX=346,SRAO("1C")=$$OUT(SRX,Y)_"^"_SRX
    14         S Y=$P(SRA(200),"^",3),SRX=202,SRAO("1D")=$$OUT(SRX,Y)_"^"_SRX
    15         S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX
    16         S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX
    17         S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX
    18         S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX
    19         S Y=$P(SRA(200),"^",9),SRX=241,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
    20         S Y=$P(SRA(200),"^",10),SRX=204,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
    21         S Y=$P(SRA(200),"^",11),SRX=203,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
    22         S Y=$P(SRA(200),"^",12),SRX=326,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
    23         S Y=$P(SRA(200),"^",13),SRX=244,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
    24         S Y=$P(SRA(200),"^",15),SRX=212,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
    25         S Y=$P($G(^SRF(SRTN,200.1)),"^"),SRX=486,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX
    26         S Y=$P(SRA(200),"^",16),SRX=213,SRAO("4A")=$$OUT(SRX,Y)_"^"_SRX
    27         S Y=$P(SRA(200),"^",30),SRX=242,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX
    28         S Y=$P(SRA(200),"^",35),SRX=396,SRAO("5A")=$$OUT(SRX,Y)_"^"_SRX
    29         S Y=$P(SRA(200),"^",31),SRX=394,SRAO("5B")=$$OUT(SRX,Y)_"^"_SRX
    30         S Y=$P(SRA(200),"^",32),SRX=220,SRAO("5C")=$$OUT(SRX,Y)_"^"_SRX
    31         S Y=$P(SRA(200),"^",33),SRX=266,SRAO("5D")=$$OUT(SRX,Y)_"^"_SRX
    32         S Y=$P(SRA(200),"^",34),SRX=395,SRAO("5E")=$$OUT(SRX,Y)_"^"_SRX
    33         S Y=$P(SRA(200),"^",36),SRX=208,SRAO("5F")=$$OUT(SRX,Y)_"^"_SRX
    34         S Y=$P(SRA(200),"^",40),SRX=206,SRAO(6)=$$OUT(SRX,Y)_"^"_SRX
    35         S Y=$P(SRA(200),"^",41),SRX=329,SRAO("6A")=$$OUT(SRX,Y)_"^"_SRX
    36         S Y=$P(SRA(200),"^",42),SRX=330,SRAO("6B")=$$OUT(SRX,Y)_"^"_SRX K SRA
    37         W "1. GENERAL:",?32,$P(SRAO(1),"^"),?41,"4. GASTROINTESTINAL:",?76,$P(SRAO(4),"^")
    38         W !,"  A. Height:" S Y=$P(SRAO("1A"),"^") W:Y'="NS" ?14,$J($P(Y,"^"),25) W:Y="NS" ?32,Y
    39         W ?43,"A. Esophageal Varices:",?76,$P(SRAO("4A"),"^")
    40         W !,"  B. Weight:" S Y=$P(SRAO("1B"),"^") W ?($S(Y="NS":19,1:24)),$J(Y,15)
    41         W !,"  C. Diabetes Mellitus:",?32,$P(SRAO("1C"),"^"),?41,"5. CARDIAC:",?76,$P(SRAO(5),"^")
    42         W !,"  D. Current Smoker W/I 1 Year:",?32,$P(SRAO("1D"),"^"),?43,"A. CHF Within 1 Month:",?76,$P(SRAO("5A"),"^")
    43         W !,"  E. ETOH > 2 Drinks/Day:",?32,$P(SRAO("1E"),"^"),?43,"B. MI Within 6 Months:",?76,$P(SRAO("5B"),"^")
    44         W !,"  F. Dyspnea: ",?14,$J($P(SRAO("1F"),"^"),25),?43,"C. Previous PCI:",?76,$P(SRAO("5C"),"^")
    45         W !,"  G. DNR Status: ",?32,$P(SRAO("1G"),"^"),?43,"D. Previous Cardiac Surgery:",?76,$P(SRAO("5D"),"^")
    46         W !,"  H. Preop Funct Status: ",$J($P(SRAO("1H"),"^"),17),?43,"E. Angina Within 1 Month:",?76,$P(SRAO("5E"),"^")
    47         W !,?43,"F. Hypertension Requiring Meds:",?76,$P(SRAO("5F"),"^")
    48         W !,"2. PULMONARY:",?32,$P(SRAO(2),"^")
    49         W !,"  A. Ventilator Dependent:",?32,$P(SRAO("2A"),"^"),?41,"6. VASCULAR:",?76,$P(SRAO(6),"^")
    50         W !,"  B. History of Severe COPD:",?32,$P(SRAO("2B"),"^"),?43,"A. Revascularization/Amputation:",?76,$P(SRAO("6A"),"^")
    51         W !,"  C. Current Pneumonia:",?32,$P(SRAO("2C"),"^"),?43,"B. Rest Pain/Gangrene:",?76,$P(SRAO("6B"),"^")
    52         W !!,"3. HEPATOBILIARY:",?32,$P(SRAO(3),"^"),!,"  A. Ascites:",?32,$P(SRAO("3A"),"^")
    53         Q
    54 OUT(SRFLD,SRY)  ; get data in output form
    55         N C,Y,Z
    56         S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
    57         I Y="NO STUDY" S Y="NS"
    58         I SRFLD=237!(SRFLD=346) S Y=$E(Y,1,15)
    59         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
    60         I SRFLD=492 D
    61         .I SRY=2 S Y="PARTIAL DEPENDENT" Q
    62         .I SRY=1 S Y=Y_"    " Q
    63         .I SRY=4 S Y=Y_"      "
    64         I SRFLD=325,$L(Y)=2 S Y=Y_"     "
    65         Q Y
    66 HW      ; get weight & height from Vitals
    67         N SREND,SREQ,SREX,SREY,SRSTRT
    68 WT      I $P($G(^SRF(SRTN,206)),"^",2)="" D
    69         .S SREND=$P($G(^SRF(SRTN,0)),"^",9),SRSTRT=$$FMADD^XLFDT(SREND,-30),SREX=$$HW^SROACL1(SRSTRT,SREND,"WT")
    70         .I SREX'="" S SREX=SREX+.5\1 D CHK^DIE(130,237,"E",SREX,.SREY) I SREY'="^" S $P(^SRF(SRTN,206),"^",2)=SREY
    71 HT      I $P($G(^SRF(SRTN,206)),"^")'="" Q
    72         N GMRVSTR,SRBRDT,SRBIEN,SRBDATA,SRHTDT
    73         K ^UTILITY($J,"GMRVD"),RESULTS S SREND=$P($G(^SRF(SRTN,0)),"^",9),GMRVSTR="HT",GMRVSTR(0)="^"_SREND_"^^0"
    74         D EN1^GMRVUT0 Q:'$D(^UTILITY($J,"GMRVD"))
    75         S SRBRDT="",SRBRDT=$O(^UTILITY($J,"GMRVD","HT",SRBRDT)) Q:'SRBRDT  D
    76         .S SRBIEN=0 F  S SRBIEN=$O(^UTILITY($J,"GMRVD","HT",SRBRDT,SRBIEN)) Q:'SRBIEN  D
    77         ..S SRBDATA=$G(^UTILITY($J,"GMRVD","HT",SRBRDT,SRBIEN)),SREX=$P(SRBDATA,"^",8)
    78         ..I SREX'="" S SREX=SREX+.5\1 D CHK^DIE(130,236,"E",SREX,.SREY) I SREY'="^" D
    79         ...S $P(^SRF(SRTN,206),"^")=SREY
    80         ...S SRHTDT=$P(SRBDATA,"^") I SRHTDT'="" S $P(^SRF(SRTN,200.1),"^",7)=SRHTDT
    81         Q
     1SROAPS1 ;BIR/MAM - PREOP INFO (PAGE 1) ;06/08/06
     2 ;;3.0; Surgery ;**38,47,125,153**;24 Jun 93;Build 11
     3 N I S SRPAGE="PAGE: 1 OF 2" D HDR^SROAUTL,PRE1
     4 W ! F I=1:1:80 W "-"
     5 Q
     6PRE1 N SRX,Y D HW F I=200,206 S SRA(I)=$G(^SRF(SRTN,I))
     7 S Y=$P(SRA(200),"^"),SRX=402,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
     8 S Y=$P(SRA(206),"^"),SRX=236,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
     9 S Y=$P(SRA(206),"^",2),SRX=237,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX
     10 S Y=$P(SRA(200),"^",2),SRX=346,SRAO("1C")=$$OUT(SRX,Y)_"^"_SRX
     11 S Y=$P(SRA(200),"^",3),SRX=202,SRAO("1D")=$$OUT(SRX,Y)_"^"_SRX
     12 S Y=$P($G(^SRF(SRTN,208)),"^",9),SRX=202.1,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX
     13 S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX
     14 S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX
     15 S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX
     16 S Y=$P(SRA(200),"^",8),SRX=240,SRAO("1I")=$$OUT(SRX,Y)_"^"_SRX
     17 S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1J")=$$OUT(SRX,Y)_"^"_SRX
     18 S Y=$P(SRA(200),"^",9),SRX=241,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
     19 S Y=$P(SRA(200),"^",10),SRX=204,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
     20 S Y=$P(SRA(200),"^",11),SRX=203,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
     21 S Y=$P(SRA(200),"^",12),SRX=326,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
     22 S Y=$P(SRA(200),"^",13),SRX=244,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
     23 S Y=$P(SRA(200),"^",15),SRX=212,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
     24 S Y=$P($G(^SRF(SRTN,200.1)),"^"),SRX=486,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX
     25 S Y=$P(SRA(200),"^",16),SRX=213,SRAO("4A")=$$OUT(SRX,Y)_"^"_SRX
     26 S Y=$P(SRA(200),"^",30),SRX=242,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX
     27 S Y=$P(SRA(200),"^",35),SRX=396,SRAO("5A")=$$OUT(SRX,Y)_"^"_SRX
     28 S Y=$P(SRA(200),"^",31),SRX=394,SRAO("5B")=$$OUT(SRX,Y)_"^"_SRX
     29 S Y=$P(SRA(200),"^",32),SRX=220,SRAO("5C")=$$OUT(SRX,Y)_"^"_SRX
     30 S Y=$P(SRA(200),"^",33),SRX=266,SRAO("5D")=$$OUT(SRX,Y)_"^"_SRX
     31 S Y=$P(SRA(200),"^",34),SRX=395,SRAO("5E")=$$OUT(SRX,Y)_"^"_SRX
     32 S Y=$P(SRA(200),"^",36),SRX=208,SRAO("5F")=$$OUT(SRX,Y)_"^"_SRX
     33 S Y=$P(SRA(200),"^",40),SRX=206,SRAO(6)=$$OUT(SRX,Y)_"^"_SRX
     34 S Y=$P(SRA(200),"^",41),SRX=329,SRAO("6A")=$$OUT(SRX,Y)_"^"_SRX
     35 S Y=$P(SRA(200),"^",42),SRX=330,SRAO("6B")=$$OUT(SRX,Y)_"^"_SRX K SRA
     36 W "1. GENERAL:",?32,$P(SRAO(1),"^"),?41,"3. HEPATOBILIARY:",?76,$P(SRAO(3),"^")
     37 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"),"^")
     38 W !,"  B. Weight:" S Y=$P(SRAO("1B"),"^") W ?($S(Y="NS":19,1:24)),$J(Y,15)
     39 W !,"  C. Diabetes Mellitus:",?32,$P(SRAO("1C"),"^"),?41,"4. GASTROINTESTINAL:",?76,$P(SRAO(4),"^")
     40 W !,"  D. Current Smoker W/I 1 Year:",?32,$P(SRAO("1D"),"^"),?43,"A. Esophageal Varices:",?76,$P(SRAO("4A"),"^")
     41 W !,"  E. Pack/Years:",?32,$P(SRAO("1E"),"^")
     42 W !,"  F. ETOH > 2 Drinks/Day:",?32,$P(SRAO("1F"),"^"),?41,"5. CARDIAC:",?76,$P(SRAO(5),"^")
     43 W !,"  G. Dyspnea: ",?14,$J($P(SRAO("1G"),"^"),25),?43,"A. CHF Within 1 Month:",?76,$P(SRAO("5A"),"^")
     44 W !,"  H. DNR Status: ",?32,$P(SRAO("1H"),"^"),?43,"B. MI Within 6 Months:",?76,$P(SRAO("5B"),"^")
     45 W !,"  I. Pre-illness Funct",?43,"C. Previous PCI:",?76,$P(SRAO("5C"),"^")
     46 W !,?17,"Status: ",$J($P(SRAO("1I"),"^"),17),?43,"D. Previous Cardiac Surgery:",?76,$P(SRAO("5D"),"^")
     47 W !,"  J. Preop Funct Status: ",$J($P(SRAO("1J"),"^"),17),?43,"E. Angina Within 1 Month:",?76,$P(SRAO("5E"),"^")
     48 W !,?43,"F. Hypertension Requiring Meds:",?76,$P(SRAO("5F"),"^")
     49 W !,"2. PULMONARY:",?32,$P(SRAO(2),"^")
     50 W !,"  A. Ventilator Dependent:",?32,$P(SRAO("2A"),"^"),?41,"6. VASCULAR:",?76,$P(SRAO(6),"^")
     51 W !,"  B. History of Severe COPD:",?32,$P(SRAO("2B"),"^"),?43,"A. Revascularization/Amputation:",?76,$P(SRAO("6A"),"^")
     52 W !,"  C. Current Pneumonia:",?32,$P(SRAO("2C"),"^"),?43,"B. Rest Pain/Gangrene:",?76,$P(SRAO("6B"),"^")
     53 Q
     54OUT(SRFLD,SRY) ; get data in output form
     55 N C,Y
     56 S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
     57 I Y="NO STUDY" S Y="NS"
     58 I SRFLD=236!(SRFLD=237)!(SRFLD=346) S Y=$E(Y,1,15)
     59 I SRFLD=240!(SRFLD=492) D
     60 .I SRY=2 S Y="PARTIAL DEPENDENT" Q
     61 .I SRY=1 S Y=Y_"    " Q
     62 .I SRY=4 S Y=Y_"      "
     63 I SRFLD=325,$L(Y)=2 S Y=Y_"     "
     64 Q Y
     65HW ; get weight & height from Vitals
     66 N SREND,SREX,SRSTRT
     67WT I $P($G(^SRF(SRTN,206)),"^",2)="" D
     68 .S SREND=$P($G(^SRF(SRTN,0)),"^",9),SRSTRT=$$FMADD^XLFDT(SREND,-30),SREX=$$HW^SROACL1(SRSTRT,SREND,"WT")
     69 .I SREX'="" S SREX=SREX+.5\1,$P(^SRF(SRTN,206),"^",2)=SREX
     70HT I $P($G(^SRF(SRTN,206)),"^")="" D
     71 .S SREND=$P($G(^SRF(SRTN,0)),"^",9),SRSTRT=$$FMADD^XLFDT(SREND,-365),SREX=$$HW^SROACL1(SRSTRT,SREND,"HT")
     72 .I SREX'="" S SREX=SREX+.5\1,$P(^SRF(SRTN,206),"^")=SREX
     73 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAPS2.m

    r613 r623  
    1 SROAPS2 ;BIR/MAM - PREOP INFO (PAGE 2) ;11/26/07
    2         ;;3.0; Surgery ;**38,47,125,153,160,166**;24 Jun 93;Build 7
    3         S SRPAGE="PAGE: 2 OF 2" D HDR^SROAUTL,PRE2
    4         W !! F I=1:1:80 W "-"
    5         Q
    6 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"
    7         S SRA(200)=$G(^SRF(SRTN,200)),SRA(206)=$G(^SRF(SRTN,206)),SRA(200.1)=$G(^SRF(SRTN,200.1))
    8         S Y=$P(SRA(200),"^",37),SRX=243,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
    9         S Y=$P(SRA(200),"^",38),SRX=328,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
    10         S Y=$P(SRA(200),"^",39),SRX=211,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX
    11         S Y=$P(SRA(200),"^",18),SRX=210,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
    12         S Y=$P(SRA(200),"^",44),SRX=245,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
    13         S Y=$P(SRA(200),"^",19),SRX=332,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
    14         S Y=$P(SRA(200),"^",21),SRX=333,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
    15         S Y=$P(SRA(200),"^",24),SRX=400,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
    16         S Y=$P(SRA(200),"^",25),SRX=334,SRAO("2D")=$$OUT(SRX,Y)_"^"_SRX
    17         S Y=$P(SRA(200),"^",26),SRX=335,SRAO("2E")=$$OUT(SRX,Y)_"^"_SRX
    18         S Y=$P(SRA(200),"^",27),SRX=336,SRAO("2F")=$$OUT(SRX,Y)_"^"_SRX
    19         S Y=$P(SRA(200),"^",29),SRX=401,SRAO("2G")=$$OUT(SRX,Y)_"^"_SRX
    20         S Y=$P(SRA(200),"^",45),SRX=338,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
    21         S Y=$P(SRA(200),"^",46),SRX=218,SRAO("3B")=$$OUT(SRX,Y)_"^"_SRX
    22         S Y=$P(SRA(200),"^",47),SRX=339,SRAO("3C")=$$OUT(SRX,Y)_"^"_SRX
    23         S Y=$P(SRA(200),"^",48),SRX=215,SRAO("3D")=$$OUT(SRX,Y)_"^"_SRX
    24         S Y=$P(SRA(200),"^",49),SRX=216,SRAO("3E")=$$OUT(SRX,Y)_"^"_SRX
    25         S Y=$P(SRA(200),"^",50),SRX=217,SRAO("3F")=$$OUT(SRX,Y)_"^"_SRX
    26         S Y=$P(SRA(206),"^",3),SRX=338.1,SRAO("3G")=$$OUT(SRX,Y)_"^"_SRX
    27         S Y=$P(SRA(206),"^",4),SRX=338.2,SRAO("3H")=$$OUT(SRX,Y)_"^"_SRX
    28         S Y=$P(SRA(206),"^",8),SRX=218.1,SRAO("3I")=$$OUT(SRX,Y)_"^"_SRX
    29         S Y=$P(SRA(200.1),"^",3),SRX=269,SRAO("3J")=$$OUT(SRX,Y)_"^"_SRX K SRA
    30         W !,"1. RENAL:",?(38-$L($P(SRAO(1),"^"))),$P(SRAO(1),"^"),?40,"3. NUTRITIONAL/IMMUNE/OTHER:",?(79-$L($P(SRAO(3),"^"))),$P(SRAO(3),"^")
    31         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"),"^")
    32         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"),"^")
    33         W !,?40,"  C. Steroid Use for Chronic Cond.:",?(79-$L($P(SRAO("3C"),"^"))),$P(SRAO("3C"),"^")
    34         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"),"^")
    35         W !,"  A. Impaired Sensorium: ",?(38-$L($P(SRAO("2A"),"^"))),$P(SRAO("2A"),"^"),?40,"  E. Bleeding Disorders:",?(79-$L($P(SRAO("3E"),"^"))),$P(SRAO("3E"),"^")
    36         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"),"^")
    37         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"),"^")
    38         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"),"^")
    39         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"),"^")
    40         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"),"^")
    41         W !,"  G. Tumor Involving CNS:",?(38-$L($P(SRAO("2G"),"^"))),$P(SRAO("2G"),"^")
    42         Q
    43 OUT(SRFLD,SRY)  ; get data in output form
    44         N C,Y
    45         S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
    46         I Y="NO STUDY" S Y="NS"
    47         Q Y
     1SROAPS2 ;BIR/MAM - PREOP INFO (PAGE 2) ;04/24/07
     2 ;;3.0; Surgery ;**38,47,125,153,160**;24 Jun 93;Build 7
     3 S SRPAGE="PAGE: 2 OF 2" D HDR^SROAUTL,PRE2
     4 W !! F I=1:1:80 W "-"
     5 Q
     6PRE2 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"
     7 S SRA(200)=$G(^SRF(SRTN,200)),SRA(206)=$G(^SRF(SRTN,206)),SRA(200.1)=$G(^SRF(SRTN,200.1))
     8 S Y=$P(SRA(200),"^",37),SRX=243,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
     9 S Y=$P(SRA(200),"^",38),SRX=328,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
     10 S Y=$P(SRA(200),"^",39),SRX=211,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX
     11 S Y=$P(SRA(200),"^",18),SRX=210,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
     12 S Y=$P(SRA(200),"^",44),SRX=245,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
     13 S Y=$P(SRA(200),"^",19),SRX=332,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
     14 S Y=$P(SRA(200),"^",21),SRX=333,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
     15 S Y=$P(SRA(200),"^",22),SRX=398,SRAO("2I")=$$OUT(SRX,Y)_"^"_SRX
     16 S Y=$P(SRA(200),"^",23),SRX=399,SRAO("2H")=$$OUT(SRX,Y)_"^"_SRX
     17 S Y=$P(SRA(200),"^",24),SRX=400,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
     18 S Y=$P(SRA(200),"^",25),SRX=334,SRAO("2D")=$$OUT(SRX,Y)_"^"_SRX
     19 S Y=$P(SRA(200),"^",26),SRX=335,SRAO("2E")=$$OUT(SRX,Y)_"^"_SRX
     20 S Y=$P(SRA(200),"^",27),SRX=336,SRAO("2F")=$$OUT(SRX,Y)_"^"_SRX
     21 S Y=$P(SRA(200),"^",29),SRX=401,SRAO("2G")=$$OUT(SRX,Y)_"^"_SRX
     22 S Y=$P(SRA(200),"^",45),SRX=338,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
     23 S Y=$P(SRA(200),"^",46),SRX=218,SRAO("3B")=$$OUT(SRX,Y)_"^"_SRX
     24 S Y=$P(SRA(200),"^",47),SRX=339,SRAO("3C")=$$OUT(SRX,Y)_"^"_SRX
     25 S Y=$P(SRA(200),"^",48),SRX=215,SRAO("3D")=$$OUT(SRX,Y)_"^"_SRX
     26 S Y=$P(SRA(200),"^",49),SRX=216,SRAO("3E")=$$OUT(SRX,Y)_"^"_SRX
     27 S Y=$P(SRA(200),"^",50),SRX=217,SRAO("3F")=$$OUT(SRX,Y)_"^"_SRX
     28 S Y=$P(SRA(206),"^",3),SRX=338.1,SRAO("3G")=$$OUT(SRX,Y)_"^"_SRX
     29 S Y=$P(SRA(206),"^",4),SRX=338.2,SRAO("3H")=$$OUT(SRX,Y)_"^"_SRX
     30 S Y=$P(SRA(206),"^",8),SRX=218.1,SRAO("3I")=$$OUT(SRX,Y)_"^"_SRX
     31 S Y=$P(SRA(200.1),"^",3),SRX=269,SRAO("3J")=$$OUT(SRX,Y)_"^"_SRX K SRA
     32 W !,"1. RENAL:",?(38-$L($P(SRAO(1),"^"))),$P(SRAO(1),"^"),?40,"3. NUTRITIONAL/IMMUNE/OTHER:",?(79-$L($P(SRAO(3),"^"))),$P(SRAO(3),"^")
     33 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"),"^")
     34 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"),"^")
     35 W !,?40,"  C. Steroid Use for Chronic Cond.:",?(79-$L($P(SRAO("3C"),"^"))),$P(SRAO("3C"),"^")
     36 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"),"^")
     37 W !,"  A. Impaired Sensorium: ",?(38-$L($P(SRAO("2A"),"^"))),$P(SRAO("2A"),"^"),?40,"  E. Bleeding Disorders:",?(79-$L($P(SRAO("3E"),"^"))),$P(SRAO("3E"),"^")
     38 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"),"^")
     39 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"),"^")
     40 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"),"^")
     41 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"),"^")
     42 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"),"^")
     43 W !,"  G. Tumor Involving CNS:",?(38-$L($P(SRAO("2G"),"^"))),$P(SRAO("2G"),"^")
     44 W !,"  H. Paraplegia:",?(38-$L($P(SRAO("2H"),"^"))),$P(SRAO("2H"),"^")
     45 W !,"  I. Quadriplegia:",?(38-$L($P(SRAO("2I"),"^"))),$P(SRAO("2I"),"^")
     46 Q
     47OUT(SRFLD,SRY) ; get data in output form
     48 N C,Y
     49 S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
     50 I Y="NO STUDY" S Y="NS"
     51 Q Y
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROASS.m

    r613 r623  
    1 SROASS  ;BIR/MAM - SELECT ASSESSMENT ;01/18/07
    2         ;;3.0; Surgery ;**38,47,64,94,121,100,160,166**;24 Jun 93;Build 7
    3 PST     K:$D(DUZ("SAV")) SRNEW K SRTN W !! S SRSOUT=0
    4         N SRSEL D ^SROPSEL G:'$D(DFN) END S SRANM=VADM(1)_"  "_VA("PID")
    5 START   ; start display
    6         G:SRSOUT END W:SRSEL=1 @IOF,!,?1,SRANM
    7         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)_" *"
    8         I SRSEL=2 S CNT=0 D ^SROASSN G:$D(SRTN) ENTER G PST
    9         D ^SROASS1 I SRSOUT G END
    10         I $D(SRTN) G ENTER
    11         I $D(SRNEW) S CNT=CNT+1,SRCASE(CNT)="" W CNT,".   ----     CREATE NEW ASSESSMENT"
    12         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
    13 OPT     W !!!,"Select Surgical Case: " R X:DTIME I '$T!("^"[X) S SRSOUT=1 G END
    14         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
    15         I $D(SRNEW),X=CNT D ^SROANEW G END
    16         I '$D(SRTN) S SRTN=+SRCASE(X)
    17 ENTER   ; edit, complete, or delete
    18         I $D(SRPRINT)!'($D(SRNEW)) Q
    19         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
    20         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
    21         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
    22         W @IOF,!,?1,SRANM,!! S SRSDATE=$P(^SRF(SRTN,0),"^",9) S SRASS=SRTN D DISP^SROASS1
    23         I SRATYPE="N" D EXCL
    24         W !!,"1. Enter Risk Assessment Information",!,"2. Delete Risk Assessment Entry",!,"3. Update Assessment Status to 'COMPLETE'"
    25         W !!,"Select Number:  1//  " R X:DTIME I '$T!(X["^") K SRTN,SRASS S SRSOUT=1 G END
    26         S:X="" X=1 I X<1!(X>3)!(X'?.N) D HELP G ENTER
    27         I X=2 D ^SROADEL W !!,"Press <RET> to continue  " R X:DTIME W @IOF K SRTN G END
    28         I X=3 D @($S($P(SR("RA"),"^",2)="C":"^SROACOM1",1:"^SROACOM")) K SRTN G END
    29         Q
    30 EXCL    I $P($G(^SRO(136,SRTN,10)),"^"),'$$XL^SROAX(SRTN) D
    31         .W !!,">>> Based on CPT Codes assigned for this case, this case should be excluded." Q
    32         N SRPROC,SRL S SRL=49 D CPTS^SROAUTL0 I SRPROC(1)="NOT ENTERED" D
    33         .W !!,">>> No CPT Codes have been assigned for this case."
    34         Q
    35 END     S:'$D(SRSOUT) SRSOUT=1 W:SRSOUT @IOF D ^SRSKILL
    36         Q
    37 HELP    ;
    38         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'."
    39         W !,"Enter '3' to update the status of this Assessment to 'COMPLETE'."
    40         W !!,"Press <RET> to continue  " R X:DTIME
    41         Q
    42 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'."
    43         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
    44         S SRYN=Y I 'SRYN Q
    45         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)
    46         Q
     1SROASS ;BIR/MAM - SELECT ASSESSMENT ;01/18/07
     2 ;;3.0; Surgery ;**38,47,64,94,121,100,160**;24 Jun 93;Build 7
     3PST K:$D(DUZ("SAV")) SRNEW K SRTN W !! S SRSOUT=0
     4 N SRSEL D ^SROPSEL G:'$D(DFN) END S SRANM=VADM(1)_"  "_VA("PID")
     5START ; start display
     6 G:SRSOUT END W:SRSEL=1 @IOF,!,?1,SRANM
     7 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)_" *"
     8 I SRSEL=2 S CNT=0 D ^SROASSN G:$D(SRTN) ENTER G PST
     9 D ^SROASS1 I SRSOUT G END
     10 I $D(SRTN) G ENTER
     11 I $D(SRNEW) S CNT=CNT+1,SRCASE(CNT)="" W CNT,".   ----     CREATE NEW ASSESSMENT"
     12 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
     13OPT W !!!,"Select Surgical Case: " R X:DTIME I '$T!("^"[X) S SRSOUT=1 G END
     14 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
     15 I $D(SRNEW),X=CNT D ^SROANEW G END
     16 I '$D(SRTN) S SRTN=+SRCASE(X)
     17ENTER ; edit, complete, or delete
     18 I $D(SRPRINT)!'($D(SRNEW)) Q
     19 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
     20 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
     21 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
     22 W @IOF,!,?1,SRANM,!! S SRSDATE=$P(^SRF(SRTN,0),"^",9) S SRASS=SRTN D DISP^SROASS1
     23 I SRATYPE="N" D EXCL
     24 W !!,"1. Enter Risk Assessment Information",!,"2. Delete Risk Assessment Entry",!,"3. Update Assessment Status to 'COMPLETE'"
     25 W !!,"Select Number:  1//  " R X:DTIME I '$T!(X["^") K SRTN,SRASS S SRSOUT=1 G END
     26 S:X="" X=1 I X<1!(X>3)!(X'?.N) D HELP G ENTER
     27 I X=2 D ^SROADEL W !!,"Press <RET> to continue  " R X:DTIME W @IOF K SRTN G END
     28 I X=3 D ^SROACOM K SRTN G END
     29 Q
     30EXCL I $P($G(^SRO(136,SRTN,10)),"^"),'$$XL^SROAX(SRTN) D
     31 .W !!,">>> Based on CPT Codes assigned for this case, this case should be excluded." Q
     32 N SRPROC,SRL S SRL=49 D CPTS^SROAUTL0 I SRPROC(1)="NOT ENTERED" D
     33 .W !!,">>> No CPT Codes have been assigned for this case."
     34 Q
     35END S:'$D(SRSOUT) SRSOUT=1 W:SRSOUT @IOF D ^SRSKILL
     36 Q
     37HELP ;
     38 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'."
     39 W !,"Enter '3' to update the status of this Assessment to 'COMPLETE'."
     40 W !!,"Press <RET> to continue  " R X:DTIME
     41 Q
     42TRANS W @IOF,!,"This assessment has already been transmitted.  The information contained",!,"in it cannot be altered unless you first change the status to 'INCOMPLETE'."
     43 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
     44 S SRYN=Y I 'SRYN Q
     45 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)
     46 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROASSP.m

    r613 r623  
    1 SROASSP ;BIR/MAM - PRINT A COMPLETED ASSESSMENT ;12/05/07
    2         ;;3.0; Surgery ;**38,94,166**;24 Jun 93;Build 7
    3 BATCH   ;
    4         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."
    5         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
    6         I Y D ^SROABCH Q
    7         S SRPRINT=1 K SRNEW D ^SROASS I '$D(SRTN) S SRSOUT=1 G END
    8         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
    9         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
    10         D @($S($P($G(^SRF(SRTN,"RA")),"^",2)="C":"EN^SROACOM1",1:"EN^SROACOM"))
    11 END     D ^%ZISC W @IOF K SRTN D ^SRSKILL
    12         Q
     1SROASSP ;B'HAM ISC/MAM - PRINT A COMPLETED ASSESSMENT ; [04/06/00  12:05 PM ]
     2 ;;3.0; Surgery ;**38,94**;24 Jun 93
     3BATCH ;
     4 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."
     5 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
     6 I Y D ^SROABCH Q
     7 S SRPRINT=1 K SRNEW D ^SROASS I '$D(SRTN) S SRSOUT=1 G END
     8 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
     9 I $D(IO("Q")) K IO("Q") S ZTDESC="Completed Surgery Risk Assessment",ZTSAVE("SRSITE*")="",ZTSAVE("SRTN")="",ZTRTN="EN^SROACOM" D ^%ZTLOAD G END
     10 D EN^SROACOM
     11END D ^%ZISC W @IOF K SRTN D ^SRSKILL
     12 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROATCM3.m

    r613 r623  
    1 SROATCM3        ;BIR/SJA - STUFF TRANMISSION IN ^TMP ;12/03/07
    2         ;;3.0; Surgery ;**125,135,153,164,166**;24 Jun 93;Build 7
    3         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))
    4         I NYUK'="" D
    5         .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)
    6         .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)
    7         .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)
    8         .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)
    9         .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:"")
    10         ;
    11 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)
    12         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)
    13         S X=$P(SRA(206),"^",42),Y="" F I=1:1:5 S Y=Y_$P(X,",",I)
    14         S SHEMP=SHEMP_$J($P(SRA(209),"^",11),2)_$J(Y,5)
    15         S X=$P(SRA(209),"^",12) S:X="" X="N" S SHEMP=SHEMP_$J(X,2)
    16         ; CT Surgery Consult Date and cause for delay
    17         S SRDATE=$P(SRA(209),"^",15),SRDATE=$$LJ^XLFSTR(SRDATE,7,0),SHEMP=SHEMP_SRDATE
    18         S X=$P(SRA(209),"^",16),SHEMP=SHEMP_$J(X,2)
    19         S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
    20 LN27    ;Line #27 - Other Cardiac Procedures
    21         S SHEMP=$E(SHEMP,1,11)_" 27"_$TR($E($G(SRA(209.1)),1,65),",","^")
    22         S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
    23 LN28    ;Lines 28 - New fields added in 2006 update
    24         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)
    25         S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
    26         Q
     1SROATCM3 ;BIR/SJA - STUFF TRANMISSION IN ^TMP ;08/24/07
     2 ;;3.0; Surgery ;**125,135,153,164**;24 Jun 93;Build 2
     3 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))
     4 I NYUK'="" D
     5 .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)
     6 .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)
     7 .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)
     8 .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)
     9 .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:"")
     10 ;
     11LN26 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)
     12 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)
     13 S X=$P(SRA(206),"^",42),Y="" F I=1:1:5 S Y=Y_$P(X,",",I)
     14 S SHEMP=SHEMP_$J($P(SRA(209),"^",11),2)_$J(Y,5)
     15 S X=$P(SRA(209),"^",12) S:X="" X="N" S SHEMP=SHEMP_$J(X,2)
     16 ; CT Surgery Consult Date
     17 S SRDATE=$P(SRA(209),"^",15),SRDATE=$$LJ^XLFSTR(SRDATE,7,0),SHEMP=SHEMP_SRDATE
     18 S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
     19LN27 ;Line #27 - Other Cardiac Procedures
     20 S SHEMP=$E(SHEMP,1,11)_" 27"_$TR($E($G(SRA(209.1)),1,65),",","^")
     21 S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
     22LN28 ;Lines 28 - New fields added in 2006 update
     23 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)
     24 S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
     25 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROATM1.m

    r613 r623  
    1 SROATM1 ;BIR/MAM - NON CARDIAC TRANSMISSION ;12/10/07
    2         ;;3.0; Surgery ;**27,38,47,60,62,81,88,93,95,125,153,160,166**;24 Jun 93;Build 7
    3         ;** NOTICE: This routine is part of an implementation of a nationally
    4         ;**         controlled procedure. Local modifications to this routine
    5         ;**         are prohibited.
    6         ;
    7         ; Reference to ^DIC(45.3 supported by DBIA #218
    8         ;
    9         N SRINTUB,SRDTH,SRPID,SRCDT,SRCREQ F I=0,200,200.1,206 S SRA(I)=$G(^SRF(SRTN,I))
    10         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))
    11         S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID
    12         S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
    13         S X=$P($G(^SRF(SRTN,205)),"^",3),SRDTH=$S(X:X,1:$P(VADM(6),"^"))
    14         S SRCDT=$P($G(^SRF(SRTN,209)),"^",15),SRCREQ=$P($G(^SRF(SRTN,209)),"^",17)
    15         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)
    16         S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_"  2",SRACNT=SRACNT+1
    17         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
    18         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
    19         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
    20         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
    21         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
    22         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
    23         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
    24         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
    25         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
    26         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
    27         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)
    28         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)
    29         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
    30         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
    31         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
    32         K SRTECH,SRZ,SRTRAUMA S SRT=0 F  S SRT=$O(^SRF(SRTN,6,SRT)) Q:'SRT  D ^SROPRIN Q:$D(SRZ)
    33         I $D(SRTECH) S SRTRAUMA=$P(^SRF(SRTN,6,SRT,0),"^",14),SRINTUB=$P($G(^SRF(SRTN,6,SRT,8)),"^",2)
    34         I '$D(SRTECH) S (SRTECH,SRTRAUMA,SRINTUB)=""
    35         S SHEMP=SHEMP_$J(SRTECH,1)_$J($E(SRASA,2),1)_$J(SRINTUB,1)_" "
    36         S NYUK=$P(SRA(206),"^"),SHEMP=SHEMP_$J(NYUK,4),NYUK=$P(SRA(206),"^",2),SHEMP=SHEMP_$J(NYUK,4)
    37         S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_"  3",SRACNT=SRACNT+1
    38         D ^SROATM2
    39         Q
    40 ONE     S MOE=$S(NYUK="NS":"S",NYUK="":" ",1:NYUK)
    41         Q
     1SROATM1 ;BIR/MAM - NON CARDIAC TRANSMISSION ;05/10/07
     2 ;;3.0; Surgery ;**27,38,47,60,62,81,88,93,95,125,153,160**;24 Jun 93;Build 7
     3 ;** NOTICE: This routine is part of an implementation of a nationally
     4 ;**         controlled procedure. Local modifications to this routine
     5 ;**         are prohibited.
     6 ;
     7 ; Reference to ^DIC(45.3 supported by DBIA #218
     8 ;
     9 N SRINTUB,SRDTH,SRPID F I=0,200,200.1,206 S SRA(I)=$G(^SRF(SRTN,I))
     10 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))
     11 S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID
     12 S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
     13 S X=$P($G(^SRF(SRTN,205)),"^",3),SRDTH=$S(X:X,1:$P(VADM(6),"^"))
     14 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)
     15 S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_"  2",SRACNT=SRACNT+1
     16 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
     17 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
     18 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
     19 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
     20 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
     21 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
     22 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
     23 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
     24 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
     25 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
     26 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)
     27 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)
     28 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
     29 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
     30 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
     31 K SRTECH,SRZ,SRTRAUMA S SRT=0 F  S SRT=$O(^SRF(SRTN,6,SRT)) Q:'SRT  D ^SROPRIN Q:$D(SRZ)
     32 I $D(SRTECH) S SRTRAUMA=$P(^SRF(SRTN,6,SRT,0),"^",14),SRINTUB=$P($G(^SRF(SRTN,6,SRT,8)),"^",2)
     33 I '$D(SRTECH) S (SRTECH,SRTRAUMA,SRINTUB)=""
     34 S SHEMP=SHEMP_$J(SRTECH,1)_$J($E(SRASA,2),1)_$J(SRINTUB,1)_" "
     35 S NYUK=$P(SRA(206),"^"),SHEMP=SHEMP_$J(NYUK,4),NYUK=$P(SRA(206),"^",2),SHEMP=SHEMP_$J(NYUK,4)
     36 S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_"  3",SRACNT=SRACNT+1
     37 D ^SROATM2
     38 Q
     39ONE S MOE=$S(NYUK="NS":"S",NYUK="":" ",1:NYUK)
     40 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROATMNO.m

    r613 r623  
    1 SROATMNO        ;BIR/MAM - TRANSMIT NO ASSESSMENT ;12/18/07
    2         ;;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
    3         ;** NOTICE: This routine is part of an implementation of a nationally
    4         ;**         controlled procedure. Local modifications to this routine
    5         ;**         are prohibited.
    6         ;
    7         ; Reference to ^DIC(45.3 supported by DBIA #218
    8         ;
    9         N SR10SP,SRINTUB,SR95PO,SRLO,SRPID,TDATE K ^TMP("SRA",$J) S SRATOT=0,SRASITE=+$P($$SITE^SROVAR,"^",3),(SRAMNUM,SRACNT)=1
    10         S Z=$E(DT,1,3)-1,SRLO=Z_"0214"
    11         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
    12         S SRATOTM=SRAMNUM D ^SROATM4
    13         Q
    14 SET     I $P($G(^SRF(SRTN,.4)),"^",2)="T"!(TDATE<SRLO) K ^SRF("AQ",TDATE,SRTN) Q
    15         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
    16         I $P($G(^SRF(SRTN,"RA")),"^",6)="Y",$P($G(^SRF(SRTN,"RA")),"^",2)="N" K ^SRF("AQ",TDATE,SRTN) Q
    17         I $P($G(^SRF(SRTN,0)),"^",9)="" K ^SRF("AQ",TDATE,SRTN) Q
    18         S SR10SP="          " K DA,DIE,DR S DA=SRTN,DIE=130,DR="905///R" D ^DIE K DR,DA,DIE
    19         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),"^")
    20         S EMERG=$P(SRA(0),"^",10),EMERG=$S(EMERG="EM":"Y",1:"N")
    21         K SRTECH,SRZ S SRT=0 F  S SRT=$O(^SRF(SRTN,6,SRT)) Q:'SRT  D ^SROPRIN Q:$D(SRZ)
    22         I $D(SRTECH) S SRINTUB=$P($G(^SRF(SRTN,6,SRT,8)),"^",2)
    23         I '$D(SRTECH) S (SRTECH,SRINTUB)=""
    24         S CPT=$P($G(^SRO(136,SRTN,0)),"^",2),SRPMOD="" I CPT S CPT=$P($$CPT^ICPTCOD(CPT),"^",2) D
    25         .S SRM=0,SRCNT=1 F  S SRM=$O(^SRO(136,SRTN,1,SRM)) Q:'SRM  D  Q:SRCNT>5
    26         ..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
    27         S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRDOB=$E($P(VADM(3),"^"),1,7),SRDEATH=$P(VADM(6),U)
    28         S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID
    29         S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
    30         D RS^SROATM2
    31         S SRMAJMIN=$E($P($G(^SRF(SRTN,0)),U,3),1)
    32         S SRDTHUR=$E($P($G(^SRF(SRTN,.4)),U,7),1)
    33         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
    34         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))
    35         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)
    36         ; Admission wi 14 days following outpatient surgery due to an Occurrence
    37         S (SRADMIT,SRADMT)=0 I SRSTATUS="O" D ADM^SROQ0A S SRADMIT=$S(SRADMT=0:"0",1:"1")
    38         S EXC=$P($G(^SRF(SRTN,"RA")),"^",7),SRWOUND=$P($G(^SRF(SRTN,"1.0")),"^",8)
    39         D OCC
    40         S SRNODE="  X" S:$P($G(^SRF(SRTN,"RA")),U,6)="N" SRNODE="  *" S:$P($G(^SRF(SRTN,"RA")),U,2)="C" SRNODE="  C"
    41         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)_" "
    42         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
    43         K CPT,SRMOD F SRZ=1:1:10 S (CPT(SRZ),SRMOD(SRZ))=""
    44         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
    45         S SRCC=$P($G(^SRF(SRTN,"CON")),"^"),SRBLANK="          "
    46         I SRCC,$P($G(^SRF(SRCC,30)),"^")!($P($G(^SRF(SRCC,31)),"^",8)) S SRCC=""
    47         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)
    48         S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP,SRACNT=SRACNT+1
    49         S SRICD=$P($G(^SRO(136,SRTN,0)),"^",3) S:SRICD SRICD=$P(^ICD9(SRICD,0),"^")
    50         S SRA(.2)=$G(^SRF(SRTN,.2))
    51         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)
    52         F I=1:1:10 S SRTEMP=SRTEMP_$E(SRMOD(I)_SR10SP,1,10)
    53         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
    54         I SRACNT>100 S SRACNT=1,SRAMNUM=SRAMNUM+1
    55         S SRATOT=SRATOT+1
    56         S X=$E($P(^SRF(SRTN,0),"^",9),1,5)_"00",^TMP("SRWL",$J,X)=""
    57         K DATE,ANES,EMERG,EXC,SPEC,SRADMIT,SRADMT,SRATT,SRBLANK,SRCC,SRDIV,SRDOB,SRDTHUR,SRICD,SRIO,SRMAJMIN,SROCTYPE,SRTEMP,SRTMP,SRWOUND,SRZ,SR14,CPT
    58         Q
    59 OCC     ; total of each occurrence by category
    60         N SRIOFLAG,SRPOFLAG
    61         F SRK=1:1:38 S SROC(SRK)=""
    62         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
    63         .S SROC(SRSUB)=SROC(SRSUB)+1,SRIOFLAG=1
    64         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
    65         .S SROC(SRSUB)=SROC(SRSUB)+1,SRPOFLAG=1
    66         S (SROCTYPE,SRTMP)="" F SRK=1:1:10 S SRTMP=SRTMP_$J(SROC(SRK),2)
    67         S SRTMP=SRTMP_$J(SROC(37),2) F SRK=12:1:32 S SRTMP=SRTMP_$J(SROC(SRK),2)
    68         S SR95PO=$J(SROC(33),2)_$J(SROC(34),2)_$J(SROC(35),2)_$J(SROC(36),2)
    69         I SRIOFLAG=1,(SRPOFLAG=0) S SROCTYPE="I"
    70         I SRIOFLAG=0,(SRPOFLAG=1) S SROCTYPE="P"
    71         I SRIOFLAG=1,(SRPOFLAG=1) S SROCTYPE="B"
    72         I SRIOFLAG=0,(SRPOFLAG=0) S SROCTYPE=""
    73         Q
    74 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
    75         .S X=$P(^SRO(136,SRTN,3,OPS,1,SRM,0),"^"),Y=$P($$MOD^ICPTMOD(X,"I"),"^",2)
    76         .I Y'="" S SRMOD(CNT)=SRMOD(CNT)_Y,SRCNT=SRCNT+1
    77         Q
     1SROATMNO ;BIR/MAM - TRANSMIT NO ASSESSMENT ;05/10/07
     2 ;;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
     3 ;** NOTICE: This routine is part of an implementation of a nationally
     4 ;**         controlled procedure. Local modifications to this routine
     5 ;**         are prohibited.
     6 ;
     7 ; Reference to ^DIC(45.3 supported by DBIA #218
     8 ;
     9 N SR10SP,SRINTUB,SR95PO,SRLO,SRPID,TDATE K ^TMP("SRA",$J) S SRATOT=0,SRASITE=+$P($$SITE^SROVAR,"^",3),(SRAMNUM,SRACNT)=1
     10 S Z=$E(DT,1,3)-1,SRLO=Z_"0214"
     11 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
     12 S SRATOTM=SRAMNUM D ^SROATM4
     13 Q
     14SET I $P($G(^SRF(SRTN,.4)),"^",2)="T"!(TDATE<SRLO) K ^SRF("AQ",TDATE,SRTN) Q
     15 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
     16 I $P($G(^SRF(SRTN,"RA")),"^",6)="Y",$P($G(^SRF(SRTN,"RA")),"^",2)="N" K ^SRF("AQ",TDATE,SRTN) Q
     17 S SR10SP="          " K DA,DIE,DR S DA=SRTN,DIE=130,DR="905///R" D ^DIE K DR,DA,DIE
     18 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),"^")
     19 S EMERG=$P(SRA(0),"^",10),EMERG=$S(EMERG="EM":"Y",1:"N")
     20 K SRTECH,SRZ S SRT=0 F  S SRT=$O(^SRF(SRTN,6,SRT)) Q:'SRT  D ^SROPRIN Q:$D(SRZ)
     21 I $D(SRTECH) S SRINTUB=$P($G(^SRF(SRTN,6,SRT,8)),"^",2)
     22 I '$D(SRTECH) S (SRTECH,SRINTUB)=""
     23 S CPT=$P($G(^SRO(136,SRTN,0)),"^",2),SRPMOD="" I CPT S CPT=$P($$CPT^ICPTCOD(CPT),"^",2) D
     24 .S SRM=0,SRCNT=1 F  S SRM=$O(^SRO(136,SRTN,1,SRM)) Q:'SRM  D  Q:SRCNT>5
     25 ..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
     26 S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRDOB=$E($P(VADM(3),"^"),1,7),SRDEATH=$P(VADM(6),U)
     27 S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID
     28 S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
     29 D RS^SROATM2
     30 S SRMAJMIN=$E($P($G(^SRF(SRTN,0)),U,3),1)
     31 S SRDTHUR=$E($P($G(^SRF(SRTN,.4)),U,7),1)
     32 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
     33 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))
     34 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)
     35 ; Admission wi 14 days following outpatient surgery due to an Occurrence
     36 S (SRADMIT,SRADMT)=0 I SRSTATUS="O" D ADM^SROQ0A S SRADMIT=$S(SRADMT=0:"0",1:"1")
     37 S EXC=$P($G(^SRF(SRTN,"RA")),"^",7),SRWOUND=$P($G(^SRF(SRTN,"1.0")),"^",8)
     38 D OCC
     39 S SRNODE="  X" S:$P($G(^SRF(SRTN,"RA")),U,6)="N" SRNODE="  *" S:$P($G(^SRF(SRTN,"RA")),U,2)="C" SRNODE="  C"
     40 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)_" "
     41 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
     42 K CPT,SRMOD F SRZ=1:1:10 S (CPT(SRZ),SRMOD(SRZ))=""
     43 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
     44 S SRCC=$P($G(^SRF(SRTN,"CON")),"^"),SRBLANK="          "
     45 I SRCC,$P($G(^SRF(SRCC,30)),"^")!($P($G(^SRF(SRCC,31)),"^",8)) S SRCC=""
     46 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)
     47 S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP,SRACNT=SRACNT+1
     48 S SRICD=$P($G(^SRO(136,SRTN,0)),"^",3) S:SRICD SRICD=$P(^ICD9(SRICD,0),"^")
     49 S SRA(.2)=$G(^SRF(SRTN,.2))
     50 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)
     51 F I=1:1:10 S SRTEMP=SRTEMP_$E(SRMOD(I)_SR10SP,1,10)
     52 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
     53 I SRACNT>100 S SRACNT=1,SRAMNUM=SRAMNUM+1
     54 S SRATOT=SRATOT+1
     55 S X=$E($P(^SRF(SRTN,0),"^",9),1,5)_"00",^TMP("SRWL",$J,X)=""
     56 K DATE,ANES,EMERG,EXC,SPEC,SRADMIT,SRADMT,SRATT,SRBLANK,SRCC,SRDIV,SRDOB,SRDTHUR,SRICD,SRIO,SRMAJMIN,SROCTYPE,SRTEMP,SRTMP,SRWOUND,SRZ,SR14,CPT
     57 Q
     58OCC ; total of each occurrence by category
     59 N SRIOFLAG,SRPOFLAG
     60 F SRK=1:1:38 S SROC(SRK)=""
     61 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
     62 .S SROC(SRSUB)=SROC(SRSUB)+1,SRIOFLAG=1
     63 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
     64 .S SROC(SRSUB)=SROC(SRSUB)+1,SRPOFLAG=1
     65 S (SROCTYPE,SRTMP)="" F SRK=1:1:10 S SRTMP=SRTMP_$J(SROC(SRK),2)
     66 S SRTMP=SRTMP_$J(SROC(37),2) F SRK=12:1:32 S SRTMP=SRTMP_$J(SROC(SRK),2)
     67 S SR95PO=$J(SROC(33),2)_$J(SROC(34),2)_$J(SROC(35),2)_$J(SROC(36),2)
     68 I SRIOFLAG=1,(SRPOFLAG=0) S SROCTYPE="I"
     69 I SRIOFLAG=0,(SRPOFLAG=1) S SROCTYPE="P"
     70 I SRIOFLAG=1,(SRPOFLAG=1) S SROCTYPE="B"
     71 I SRIOFLAG=0,(SRPOFLAG=0) S SROCTYPE=""
     72 Q
     73MOD N SRM S SRM=0,SRCNT=1 F  S SRM=$O(^SRO(136,SRTN,3,OPS,1,SRM)) Q:'SRM  D  Q:SRCNT>5
     74 .S X=$P(^SRO(136,SRTN,3,OPS,1,SRM,0),"^"),Y=$P($$MOD^ICPTMOD(X,"I"),"^",2)
     75 .I Y'="" S SRMOD(CNT)=SRMOD(CNT)_Y,SRCNT=SRCNT+1
     76 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAUTL.m

    r613 r623  
    1 SROAUTL ;BIR/ADM - RISK ASSESSMENT UTILITY ;03/03/08
    2         ;;3.0; Surgery ;**38,46,47,63,81,88,95,112,100,125,134,142,153,160,166**;24 Jun 93;Build 7
    3         I $G(SRSUPCPT)=2 G NCODE
    4         N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_")      Case #"_SRTN
    5         S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y
    6         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
    7         .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=SRCPT_"-" F  S SRI=$O(^SRF(SRTN,"OPMOD",SRI)) Q:'SRI  D
    8         ..S SRM=$P(^SRF(SRTN,"OPMOD",SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)
    9         ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1
    10         S SRCPT=$S($G(SRSUPCPT)=1:"",1:"("_SRCPT_")")
    11         S SROPER=SROPER_" "_SRCPT D LOOP S SRHDR(1)=SRSDATE_"   "_SRHDR(1)
    12         Q
    13 NCODE   N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_")        Case #"_SRTN
    14         S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y
    15         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
    16         .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=SRCPT_"-" F  S SRI=$O(^SRO(136,SRTN,1,SRI)) Q:'SRI  D
    17         ..S SRM=$P(^SRO(136,SRTN,1,SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)
    18         ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1
    19         S SRCPT="(CPT Code: "_SRCPT_")"
    20         S SROPER=SROPER_" "_SRCPT D LOOP S SRHDR(1)=SRSDATE_"   "_SRHDR(1)
    21         Q
    22 LOOP    I $L(SROPER)<68 S SRHDR(1)=SROPER Q
    23         I $L(SROPER)>67 S X=SROPER,K=1 F  D  I $L(X)<68 S SRHDR(K)=X Q
    24         .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
    25         Q
    26 HDR     ; print screen header
    27         W @IOF,!,SRHDR W:$G(SRPAGE)'="" ?(79-$L(SRPAGE)),SRPAGE
    28         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
    29         W:$D(SRCSTAT)&'$D(SRHDR(.5)) !,SRCSTAT
    30         K SRHDR(.5),SRCSTAT,SRPAGE W ! F I=1:1:80 W "-"
    31         W !
    32         Q
    33 FUNCT() ; called by screen on functional health status field (#240)
    34         N SRSCR S SRSCR="I 1"
    35         I $$CARD S SRSCR="I Y'=4"
    36         Q SRSCR
    37 CARD()  ; is this a cardiac assessed case?
    38         N SRX S SRX=$S($D(SRTN):SRTN,$D(DA):DA,1:"") I 'SRX Q 0
    39         I $P($G(^SRF(SRX,"RA")),"^",2)="C" Q 1
    40         Q 0
    41 NC      ; called from input transform to kill X if case is cardiac assessed
    42         I $$CARD,X="NA"!(X="NS") K X
    43         Q
    44 DATE    ; called by output transform on several date fields
    45         I $D(Y),Y="NA"!(Y="NS") Q
    46         N SRY S SRY=Y D DD^%DT
    47         Q
    48 INDX    ; set airway index
    49         S SRY=$S(SRI>4:5,SRI>3:4,SRI>2:3,SRI>0:2,1:1),$P(^SRF(DA,.3),"^",9)=SRY
    50         K SRI,SRMS,SROP,SRY
    51         Q
    52 OP      ; set logic for AOP cross reference on Oral-Pharyngeal field (901.1)
    53         N SRI,SRMS,SRY S SRMS=$P(^SRF(DA,.3),"^",12) I SRMS'="" S SRMS=SRMS*.1,SRI=2.5*X-SRMS D INDX
    54         Q
    55 MS      ; set logic for AMS cross reference on Mandibular Space field (901.2)
    56         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
    57         Q
    58 K901    ; kill logic for AOP and AMS cross references
    59         S $P(^SRF(DA,.3),"^",9)=""
    60         Q
    61 DUP     ; duplicate preop information from prior operation within 60 days
    62         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
    63         S X=$P($G(^SRF(SRTN,200.1)),"^") I X'="" S NOGO=1
    64         I NOGO K NOGO Q
    65         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
    66         .S SRX=$P(^SRF(SRCASE,0),"^",9) I SRX>SRSDATE!(SRX<SRENDT) Q
    67         .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)
    68         .S SRX=9999999-SRX,SRCASE(SRX,SRCASE)=""
    69         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
    70         .S Y=$P(^SRF(SRCASE,0),"^",9) X ^DD("DD") S SRDT=Y K DIR
    71         .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"),"^")
    72         .S DIR("A",4)="",DIR("A",5)="Do you want to duplicate the preoperative information from the earlier",DIR("A")="assessment in this assessment? "
    73         .S DIR("B")="YES",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
    74         .D:Y STUFF
    75         Q
    76 STUFF   ; stuff preop information from previous case
    77         I $$LOCK^SROUTL(SRCASE) D  D UNLOCK^SROUTL(SRCASE)
    78         .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
    79         .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
    80         Q
    81 CHK     ; check for missing non-cardiac assessment data items
    82         N SRSEP K SRX
    83         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
    84         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
    85 OTH     K DA,DIC,DIQ,DR,SRY,SRZ D TECH^SROPRIN I SRTECH="NOT ENTERED" S SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique"
    86         ;D RELATE^SROAUTL2
    87 OCC     D EN^SROCCAT S SRSDATE=$E($P(^SRF(SRTN,0),"^",9),1,7) K ^TMP("SROCC",$J),SRO
    88         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)=""
    89         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
    90         .S SRSEP=$P(^SRF(SRTN,16,SRPO,0),"^",4)
    91         .I '$G(SRDATE) S SRDATE="NO DATE"
    92         .S ^TMP("SROCC",$J,$P(^SRF(SRTN,16,SRPO,0),"^",2),SRDATE)=SRSEP
    93         I '$D(^TMP("SROCC",$J)) D OCCEND Q
    94         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
    95         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)"
    96 OCCEND  K ^TMP("SROCC",$J)
    97         Q
    98 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"
    99         Q
    100 DEM     S DR="413;.011;247;418;419;420;421;452;453;454;342;513;516"
    101         Q
    102 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"
    103         Q
    104 REM     S DR="214;.035;1.09;1.13;.22;.23;340;443;446;504;504.1"
    105         Q
    106 PREHD   D PREOP S DR=DR_";402;241;244;242;243;210;245"
    107         Q
     1SROAUTL ;BIR/ADM - RISK ASSESSMENT UTILITY ;02/14/07
     2 ;;3.0; Surgery ;**38,46,47,63,81,88,95,112,100,125,134,142,153,160**;24 Jun 93;Build 7
     3 I $G(SRSUPCPT)=2 G NCODE
     4 N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_")      Case #"_SRTN
     5 S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y
     6 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
     7 .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=SRCPT_"-" F  S SRI=$O(^SRF(SRTN,"OPMOD",SRI)) Q:'SRI  D
     8 ..S SRM=$P(^SRF(SRTN,"OPMOD",SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)
     9 ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1
     10 S SRCPT=$S($G(SRSUPCPT)=1:"",1:"("_SRCPT_")")
     11 S SROPER=SROPER_" "_SRCPT D LOOP S SRHDR(1)=SRSDATE_"   "_SRHDR(1)
     12 Q
     13NCODE N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_")        Case #"_SRTN
     14 S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y
     15 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
     16 .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=SRCPT_"-" F  S SRI=$O(^SRO(136,SRTN,1,SRI)) Q:'SRI  D
     17 ..S SRM=$P(^SRO(136,SRTN,1,SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)
     18 ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1
     19 S SRCPT="(CPT Code: "_SRCPT_")"
     20 S SROPER=SROPER_" "_SRCPT D LOOP S SRHDR(1)=SRSDATE_"   "_SRHDR(1)
     21 Q
     22LOOP I $L(SROPER)<68 S SRHDR(1)=SROPER Q
     23 I $L(SROPER)>67 S X=SROPER,K=1 F  D  I $L(X)<68 S SRHDR(K)=X Q
     24 .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
     25 Q
     26HDR ; print screen header
     27 W @IOF,!,SRHDR W:$G(SRPAGE)'="" ?(79-$L(SRPAGE)),SRPAGE
     28 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
     29 W:$D(SRCSTAT)&'$D(SRHDR(.5)) !,SRCSTAT
     30 K SRHDR(.5),SRCSTAT,SRPAGE W ! F I=1:1:80 W "-"
     31 W !
     32 Q
     33FUNCT() ; called by screen on functional health status field (#240)
     34 N SRSCR S SRSCR="I 1"
     35 I $$CARD S SRSCR="I Y'=4"
     36 Q SRSCR
     37CARD() ; is this a cardiac assessed case?
     38 N SRX S SRX=$S($D(SRTN):SRTN,$D(DA):DA,1:"") I 'SRX Q 0
     39 I $P($G(^SRF(SRX,"RA")),"^",2)="C" Q 1
     40 Q 0
     41NC ; called from input transform to kill X if case is cardiac assessed
     42 I $$CARD,X="NA"!(X="NS") K X
     43 Q
     44DATE ; called by output transmform on several date fields
     45 I $D(Y),Y="NA"!(Y="NS") Q
     46 N SRY S SRY=Y D DD^%DT
     47 Q
     48INDX ; set airway index
     49 S SRY=$S(SRI>4:5,SRI>3:4,SRI>2:3,SRI>0:2,1:1),$P(^SRF(DA,.3),"^",9)=SRY
     50 K SRI,SRMS,SROP,SRY
     51 Q
     52OP ; set logic for AOP cross reference on Oral-Pharyngeal field (901.1)
     53 N SRI,SRMS,SRY S SRMS=$P(^SRF(DA,.3),"^",12) I SRMS'="" S SRMS=SRMS*.1,SRI=2.5*X-SRMS D INDX
     54 Q
     55MS ; set logic for AMS cross reference on Mandibular Space field (901.2)
     56 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
     57 Q
     58K901 ; kill logic for AOP and AMS cross references
     59 S $P(^SRF(DA,.3),"^",9)=""
     60 Q
     61DUP ; duplicate preop information from prior operation within 60 days
     62 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
     63 S X=$P($G(^SRF(SRTN,200.1)),"^") I X'="" S NOGO=1
     64 I NOGO K NOGO Q
     65 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
     66 .S SRX=$P(^SRF(SRCASE,0),"^",9) I SRX>SRSDATE!(SRX<SRENDT) Q
     67 .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)
     68 .S SRX=9999999-SRX,SRCASE(SRX,SRCASE)=""
     69 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
     70 .S Y=$P(^SRF(SRCASE,0),"^",9) X ^DD("DD") S SRDT=Y K DIR
     71 .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"),"^")
     72 .S DIR("A",4)="",DIR("A",5)="Do you want to duplicate the preoperative information from the earlier",DIR("A")="assessment in this assessment? "
     73 .S DIR("B")="YES",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
     74 .D:Y STUFF
     75 Q
     76STUFF ; stuff preop information from previous case
     77 I $$LOCK^SROUTL(SRCASE) D  D UNLOCK^SROUTL(SRCASE)
     78 .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
     79 .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
     80 Q
     81CHK ; check for missing non-cardiac assessment data items
     82 N SRSEP K SRX
     83 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
     84 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
     85OTH K DA,DIC,DIQ,DR,SRY,SRZ D TECH^SROPRIN I SRTECH="NOT ENTERED" S SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique"
     86 ;D RELATE^SROAUTL2
     87OCC D EN^SROCCAT S SRSDATE=$E($P(^SRF(SRTN,0),"^",9),1,7) K ^TMP("SROCC",$J),SRO
     88 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)=""
     89 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
     90 .S SRSEP=$P(^SRF(SRTN,16,SRPO,0),"^",4)
     91 .I '$G(SRDATE) S SRDATE="NO DATE"
     92 .S ^TMP("SROCC",$J,$P(^SRF(SRTN,16,SRPO,0),"^",2),SRDATE)=SRSEP
     93 I '$D(^TMP("SROCC",$J)) D OCCEND Q
     94 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
     95 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)"
     96OCCEND K ^TMP("SROCC",$J)
     97 Q
     98PREOP 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"
     99 Q
     100DEM S DR="413;.011;247;418;419;420;421;452;453;454;342"
     101 Q
     102LAB 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"
     103 Q
     104REM S DR="214;.035;1.09;1.13;.22;.23;340;443;446;504;504.1"
     105 Q
     106PREHD D PREOP S DR=DR_";402;241;244;242;243;210;245"
     107 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAUTL1.m

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

    r613 r623  
    1 SROAUTL3        ;BIR/ADM - RISK ASSESSMENT UTILITY ;01/07/08
    2         ;;3.0; Surgery ;**38,47,63,77,142,163,166**;24 Jun 93;Build 7
    3         ;
    4         ; Reference to ^DIC(45.3 supported by DBIA #218
    5         ;
    6         Q
    7 RISK    ; allow entry of risk assessment preop information with case request
    8         S Y=$P(^SRO(133,SRSITE,0),"^",14) I 'Y Q
    9         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
    10         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
    11         .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
    12         .I 'Y S SRCARD=0 Q
    13         .D CARD S SRCARD=1
    14         I 'SRCARD D ^SROAPRE
    15         Q
    16 CARD    ; allow input of cardiac risk assessment preop information
    17         N SRSDATE,SRNM,SRSOUT
    18         W @IOF,!,"Enter Cardiac Preoperative information",!!,"  1. Clinical Information",!,"  2. Cardiac Catheterization & Angiographic Data",!,"  3. Operative Risk Summary Data",!
    19         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
    20         I Y=1 D ^SROACLN G CARD
    21         I Y=2 D ^SROACAT G CARD
    22         D ^SROACOP G CARD
    23         Q
    24 PREOP   ; print preop information (managerial)
    25         W:$E(IOST)="P" !! D PREOP^SROAUTL0 S SRDR=DR W !,?28,"PREOPERATIVE INFORMATION",! S SRQ=1 D OUT
    26         Q
    27 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
    28         K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I  D
    29         .Q:I=413  D TR D:SRQ GET^SROAUTL1 D:'SRQ GET^SROAUTL2
    30         .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
    31         .W !,$J($P(Z,"^")_": ",39) S SREXT=SRY(130,SRTN,SRFLD,"E") D EXT
    32         Q
    33 EXT     I SRFLD=27 S SREXT=$S(SREXT="":"MISSING",1:$E(SREXT,1,5))
    34         I $L(SREXT)<40 W SREXT Q
    35         N I,J,X,Y S X=SREXT F  D  W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q
    36         .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
    37         Q
    38 LAB     ; print preoperative laboratory test information (managerial)
    39         W !,?20,"PREOPERATIVE LABORATORY TEST INFORMATION",!
    40         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
    41         K SRX S SRX=0 F M=1:2 S L=$P(SRDR,";",M) Q:'L  S I=L D
    42         .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
    43         .W !,$J($P(Z,"^")_": ",39),SRY(130,SRTN,SRFLD,"E") W:SRY(130,SRTN,SRDT,"E")'="" ?50,"("_$P(SRY(130,SRTN,SRDT,"E"),"@")_")"
    44         Q
    45 TR      S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
    46         Q
    47 NON     S DR=".03;102;.035"
    48         Q
    49 CHK     ; check for missing information for excluded cases
    50         K SRX,DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D NON D EN^DIQ1 D ^SROAUTL2
    51         K DA,DIC,DIQ,DR,SRY,SRZ D TECH^SROPRIN I SRTECH="NOT ENTERED" S SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique"
    52         Q
     1SROAUTL3 ;BIR/ADM - RISK ASSESSMENT UTILITY ;08/16/07
     2 ;;3.0; Surgery ;**38,47,63,77,142,163**;24 Jun 93;Build 2
     3 ;
     4 ; Reference to ^DIC(45.3 supported by DBIA #218
     5 ;
     6 Q
     7RISK ; allow entry of risk assessment preop information with case request
     8 S Y=$P(^SRO(133,SRSITE,0),"^",14) I 'Y Q
     9 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
     10 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
     11 .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
     12 .I 'Y S SRCARD=0 Q
     13 .D CARD S SRCARD=1
     14 I 'SRCARD D ^SROAPRE
     15 Q
     16CARD ; allow input of cardiac risk assessment preop information
     17 W @IOF,!,"Enter Cardiac Preoperative information",!!,"  1. Clinical Information",!,"  2. Cardiac Catheterization & Angiographic Data",!,"  3. Operative Risk Summary Data",!
     18 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
     19 I Y=1 D ^SROACLN G CARD
     20 I Y=2 D ^SROACAT G CARD
     21 D ^SROACOP G CARD
     22 Q
     23PREOP ; print preop information (managerial)
     24 W:$E(IOST)="P" !! D PREOP^SROAUTL0 S SRDR=DR W !,?28,"PREOPERATIVE INFORMATION",! S SRQ=1 D OUT
     25 Q
     26OUT 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
     27 K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I  D
     28 .Q:I=413  D TR D:SRQ GET^SROAUTL1 D:'SRQ GET^SROAUTL2
     29 .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
     30 .W !,$J($P(Z,"^")_": ",39) S SREXT=SRY(130,SRTN,SRFLD,"E") D EXT
     31 Q
     32EXT I SRFLD=27 S SREXT=$S(SREXT="":"MISSING",1:$E(SREXT,1,5))
     33 I $L(SREXT)<40 W SREXT Q
     34 N I,J,X,Y S X=SREXT F  D  W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q
     35 .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
     36 Q
     37LAB ; print preoperative laboratory test information (managerial)
     38 W !,?20,"PREOPERATIVE LABORATORY TEST INFORMATION",!
     39 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
     40 K SRX S SRX=0 F M=1:2 S L=$P(SRDR,";",M) Q:'L  S I=L D
     41 .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
     42 .W !,$J($P(Z,"^")_": ",39),SRY(130,SRTN,SRFLD,"E") W:SRY(130,SRTN,SRDT,"E")'="" ?50,"("_$P(SRY(130,SRTN,SRDT,"E"),"@")_")"
     43 Q
     44TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
     45 Q
     46NON S DR=".03;102;.035"
     47 Q
     48CHK ; check for missing information for excluded cases
     49 K SRX,DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D NON D EN^DIQ1 D ^SROAUTL2
     50 K DA,DIC,DIQ,DR,SRY,SRZ D TECH^SROPRIN I SRTECH="NOT ENTERED" S SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique"
     51 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROAUTL4.m

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

    r613 r623  
    1 SROAUTLC        ;BIR/ADM - CARDIAC RISK ASSESSMENT UTILITY ;08/23/07
    2         ;;3.0; Surgery ;**38,71,90,88,95,97,102,96,125,153,163,164,166**;24 Jun 93;Build 7
    3         ;
    4         ; Reference to ^DIC(45.3 supported by DBIA #218
    5         ;
    6 SITE    ; determine if site is a cardiac facility
    7         I $$CARD Q
    8         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.",!
    9         S XQUIT="" W !!,"Press RETURN to continue  " R X:DTIME W @IOF
    10         Q
    11 CARD()  ; extrinsic call to determine if site is cardiac facility
    12         N CARD S CARD=0 Q:'$G(SRSITE) CARD
    13         I $P($G(^SRO(133,SRSITE,0)),"^",5)="Y" S CARD=1
    14         Q CARD
    15 NOW     ; update date/time of surgical priority entry
    16         N X I $$CARD,$P($G(^SRF(DA,208)),"^",12)'="" D NOW^%DTC S $P(^SRF(DA,208),"^",13)=$E(%,1,12)
    17         Q
    18 KNOW    ; delete date/time of surgical priority entry
    19         I $D(^SRF(DA,208)) S $P(^SRF(DA,208),"^",13)=""
    20         Q
    21 EM      ; input transform logic on Case Schedule Type field (.035)
    22         Q:'$$CARD  N DIR,SREM,SRNOT,SRQ,SRSP
    23         I X'="EM" S:X="U" $P(^SRF(DA,208),"^",12)=2 S:X'="U" $P(^SRF(DA,208),"^",12)=1 D NOW Q
    24         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
    25         D CAT
    26         Q
    27 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)"
    28         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
    29         S SREM=Y,$P(^SRF(DA,208),"^",12)=SREM+2 D NOW
    30         Q
    31 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
    32         I 'Y S SRQ=1
    33         Q
    34 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)=""
    35         S SRHLP(4)="1. Emergent (ongoing ischemia) - Clinical condition mandates immediate",SRHLP(5)="surgery usually on day of catheterization because of ischemia despite"
    36         S SRHLP(6)="medical therapy, such as intravenous nitroglycerine.  Ischemia should",SRHLP(7)="be manifested as chest pain and/or ST-segment depression."
    37         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"
    38         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."
    39         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"
    40         S SRHLP(17)="resuscitation (excludes patients being adequately perfused by a",SRHLP(18)="cardiopulmonary support system).",SRHLP(19)=""
    41         S SRHLP(20)="Enter the appropriate number to designate the category of emergency.",SRHLP(21)="",SRHLP(22)="" D EN^DDIOL(.SRHLP) K SRHLP
    42         N DIR S DIR(0)="FOA",DIR("A")="Enter RETURN to continue: " D ^DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
    43         Q
    44 CHK     ; check for missing cardiac assessment information
    45         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
    46         D RED^SROAUTL4
    47         Q
    48 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"
    49         Q
    50 CATH    S DR="476;357;358;359;360;363;415;477;361;362.1;362.2;362.3;478;479;480"
    51         Q
    52 R       S DR="418;419;440;.205;.232;470;471;473;472;442;513;515"
    53         Q
    54 OP      S DR="364;364.1;1.13;414;414.1;.22;.23"
    55         Q
    56 OUT     S DR="384"
    57         Q
    58 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"
    59         I $P($G(^SRF(SRTN,209)),"^",13)="Y"!($P($G(^SRF(SRTN,209)),"^",13)="") S DR=DR_";484"
    60         Q
    61 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"
    62         Q
     1SROAUTLC ;BIR/ADM - CARDIAC RISK ASSESSMENT UTILITY ;08/23/07
     2 ;;3.0; Surgery ;**38,71,90,88,95,97,102,96,125,153,163,164**;24 Jun 93;Build 2
     3 ;
     4 ; Reference to ^DIC(45.3 supported by DBIA #218
     5 ;
     6SITE ; determine if site is a cardiac facility
     7 I $$CARD Q
     8 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.",!
     9 S XQUIT="" W !!,"Press RETURN to continue  " R X:DTIME W @IOF
     10 Q
     11CARD() ; extrinsic call to determine if site is cardiac facility
     12 N CARD S CARD=0 Q:'$G(SRSITE) CARD
     13 I $P($G(^SRO(133,SRSITE,0)),"^",5)="Y" S CARD=1
     14 Q CARD
     15NOW ; update date/time of surgical priority entry
     16 N X I $$CARD,$P($G(^SRF(DA,208)),"^",12)'="" D NOW^%DTC S $P(^SRF(DA,208),"^",13)=$E(%,1,12)
     17 Q
     18KNOW ; delete date/time of surgical priority entry
     19 I $D(^SRF(DA,208)) S $P(^SRF(DA,208),"^",13)=""
     20 Q
     21EM ; input transform logic on Case Schedule Type field (.035)
     22 Q:'$$CARD  N DIR,SREM,SRNOT,SRQ,SRSP
     23 I X'="EM" S:X="U" $P(^SRF(DA,208),"^",12)=2 S:X'="U" $P(^SRF(DA,208),"^",12)=1 D NOW Q
     24 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
     25 D CAT
     26 Q
     27CAT 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)"
     28 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
     29 S SREM=Y,$P(^SRF(DA,208),"^",12)=SREM+2 D NOW
     30 Q
     31YN 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
     32 I 'Y S SRQ=1
     33 Q
     34HELP 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)=""
     35 S SRHLP(4)="1. Emergent (ongoing ischemia) - Clinical condition mandates immediate",SRHLP(5)="surgery usually on day of catheterization because of ischemia despite"
     36 S SRHLP(6)="medical therapy, such as intravenous nitroglycerine.  Ischemia should",SRHLP(7)="be manifested as chest pain and/or ST-segment depression."
     37 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"
     38 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."
     39 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"
     40 S SRHLP(17)="resuscitation (excludes patients being adequately perfused by a",SRHLP(18)="cardiopulmonary support system).",SRHLP(19)=""
     41 S SRHLP(20)="Enter the appropriate number to designate the category of emergency.",SRHLP(21)="",SRHLP(22)="" D EN^DDIOL(.SRHLP) K SRHLP
     42 N DIR S DIR(0)="FOA",DIR("A")="Enter RETURN to continue: " D ^DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q
     43 Q
     44CHK ; check for missing cardiac assessment information
     45 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
     46 Q
     47CLIN 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"
     48 Q
     49COC 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"
     50 Q
     51CP 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"
     52 I $P($G(^SRF(SRTN,209)),"^",13)="Y"!($P($G(^SRF(SRTN,209)),"^",13)="") S DR=DR_";484"
     53 Q
     54CLR S DR="457;457.1;458;458.1;459;459.1;460;460.1;461;461.1;462;462.1;504;504.1"
     55 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROCODE.m

    r613 r623  
    1 SROCODE ;BIR/MAM - SET UP FLAG FOR ANESTHESIA AGENTS ;01/30/08
    2         ;;3.0; Surgery ;**72,41,114,151,166**;24 Jun 93;Build 7
    3         ;
    4         ; Reference to ENS^PSSGIU supported by DBIA #895
    5         ;
    6 1       N SRTEST S SRTEST=50,SRTEST(0)="AEQSZ",SRTEST("A")="Enter the name of the drug you wish to flag: "
    7         D DIC^PSSDI(50,"SR",.SRTEST) G:+Y<1 DONE S SROIUDA=+Y,SROIRX=$P(Y,"^",2),SROIUX="S^SURGERY" D SROIU
    8         G 1
    9 SROIU   Q:'$D(SROIUDA)!'$D(SROIUX)  Q:SROIUX'?1E1"^"1.E
    10         N SRRX D DATA^PSS50(SROIUDA,,,,,"SRRX") S SRRX=$G(^TMP($J,"SRRX",SROIUDA,63)) D
    11         .S SROIUY=$S($D(SRRX):SRRX,1:""),SROIUT=$P(SROIUX,"^",2),SROIUT=$E("N","AEIOU"[$E(SROIUT))_" "_SROIUT K ^TMP($J,"SRRX",SROIUDA)
    12         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
    13         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
    14 DONE    W @IOF K SROIRX D ^SRSKILL
    15         Q
    16 FLAG    S PSIUDA=SROIUDA,PSIUX=SROIUX_"^1"
    17         S X="PSSGIU" X ^%ZOSF("TEST") I $T D ENS^PSSGIU
    18         ;HL7 master file update (addition) to anesthesia agent list
    19         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)
    20         ;A call to PDM to possibly generate an HL7 outgoing drug message
    21         S X="PSSHUIDG" X ^%ZOSF("TEST") I $T D DRG^PSSHUIDG(PSIUDA)
    22         K PSIUDA,PSIUX
    23         Q
    24 OFF     S PSIUDA=SROIUDA,PSIUX=SROIUX_"^1"
    25         S X="PSSGIU" X ^%ZOSF("TEST") I $T D END^PSSGIU
    26         ;HL7 master file update (deletion) to anesthesia agent list
    27         N SRTBL,SRENT,FEC,REC S SRTBL="ANESTHESIA AGENT^50^.01",FEC="UPD",REC="MDL" D DATA^PSS50(SROIUDA,,,,,"SRRX")
    28         S SRENT=SROIUDA_U_$P($G(^TMP($J,"SRRX",SROIUDA,.01)),"^") K ^TMP($J,"SRRX",SROIUDA) D MSG^SRHLMFN(SRTBL,FEC,REC,SRENT)
    29         ;A call to PDM to possibly generate an HL7 outgoing drug message
    30         S X="PSSHUIDG" X ^%ZOSF("TEST") I $T D DRG^PSSHUIDG(PSIUDA)
    31         K PSIUDA,PSIUX
    32         Q
     1SROCODE ;B'HAM ISC/MAM - SET UP FLAG FOR ANESTHESIA AGENTS ; [ 05/06/98   7:14 AM ]
     2 ;;3.0; Surgery ;**72,41,114,151**;24 Jun 93
     3 ;
     4 ; Reference to ENS^PSSGIU supported by DBIA #895
     5 ; Reference to ^PSS50 supported by DBIA #4533
     6 ;
     71 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
     8 G 1
     9SROIU Q:'$D(SROIUDA)!'$D(SROIUX)  Q:SROIUX'?1E1"^"1.E
     10 N SRRX D DATA^PSS50(SROIUDA,,,,,"SRRX") S SRRX=$G(^TMP($J,"SRRX",SROIUDA,63)) D
     11 .S SROIUY=$S($D(SRRX):SRRX,1:""),SROIUT=$P(SROIUX,"^",2),SROIUT=$E("N","AEIOU"[$E(SROIUT))_" "_SROIUT K ^TMP($J,"SRRX",SROIUDA)
     12 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
     13 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
     14DONE W @IOF K SROIRX D ^SRSKILL
     15 Q
     16FLAG S PSIUDA=SROIUDA,PSIUX=SROIUX_"^1"
     17 S X="PSSGIU" X ^%ZOSF("TEST") I $T D ENS^PSSGIU
     18 ;HL7 master file update (addition) to anesthesia agent list
     19 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)
     20 ;A call to PDM to possibly generate an HL7 outgoing drug message
     21 S X="PSSHUIDG" X ^%ZOSF("TEST") I $T D DRG^PSSHUIDG(PSIUDA)
     22 K PSIUDA,PSIUX
     23 Q
     24OFF S PSIUDA=SROIUDA,PSIUX=SROIUX_"^1"
     25 S X="PSSGIU" X ^%ZOSF("TEST") I $T D END^PSSGIU
     26 ;HL7 master file update (deletion) to anesthesia agent list
     27 N SRTBL,SRENT,FEC,REC S SRTBL="ANESTHESIA AGENT^50^.01",FEC="UPD",REC="MDL" D DATA^PSS50(SROIUDA,,,,,"SRRX")
     28 S SRENT=SROIUDA_U_$P($G(^TMP($J,"SRRX",SROIUDA,.01)),"^") K ^TMP($J,"SRRX",SROIUDA) D MSG^SRHLMFN(SRTBL,FEC,REC,SRENT)
     29 ;A call to PDM to possibly generate an HL7 outgoing drug message
     30 S X="PSSHUIDG" X ^%ZOSF("TEST") I $T D DRG^PSSHUIDG(PSIUDA)
     31 K PSIUDA,PSIUX
     32 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROESPR1.m

    r613 r623  
    1 SROESPR1        ;BIR/ADM - SURGERY E-SIG UTILITY ; [ 04/21/04  12:08 PM ]
    2         ;;3.0; Surgery ;**100,128,162**;24 Jun 93;Build 4
    3         ;
    4         ;** NOTICE: This routine is part of an implementation of a nationally
    5         ;**         controlled procedure.  Local modifications to this routine
    6         ;**         are prohibited.
    7         ;
    8         ; Reference to EXTRACT^TIULQ supported by DBIA #2693
    9         ;
    10         ; This routine was cloned in part or in whole from TIUPRPN1.
    11 PRINT(SRFLAG,SRSPG)     ; Print Summary
    12         ; ^TMP("SRPR",$J) is array of records passed by reference
    13         ; SRFLAG=1 --> Chart Copy     SRSPG=1 --> Contiguous
    14         ; SRFLAG=0 --> Work Copy      SRSPG=0 --> Fresh Page- each note
    15         N SRI,SRJ,SRPAGE,SRFOOT,SRK,SRDA,SRCONT,SRPGRP,SRTYP
    16         N SRPFHDR,SRPFNBR,SROPAGE
    17         S SRFLAG=+$G(SRFLAG),SRSPG=+$G(SRSPG)
    18         S SRI=0 F  S SRI=$O(^TMP("SRPR",$J,SRI)) Q:SRI=""  D  Q:'SRCONT
    19         . N DFN,SR,SRERR
    20         . I SRI["$" S SRPGRP=$P(SRI,"$"),SRPFHDR=$P($P(SRI,";"),"$",2)
    21         . E  S SRPFHDR="Surgery Reports"
    22         . I $G(SRPGRP)'=2 S SRSPG=0
    23         . S DFN=$P(SRI,";",2)
    24         . D PAT^SROESPR(.SRFOOT,DFN)
    25         . I +$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
    26         . S SRJ=0 F  S SRJ=$O(^TMP("SRPR",$J,SRI,SRJ)) Q:'SRJ  D  Q:'SRCONT
    27         . . S SRK=0 F  S SRK=$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) Q:'SRK  D  Q:'+$G(SRCONT)
    28         . . . N SRERR1,SRW K SRCONT1 S SRPFNBR=^(SRK)
    29         . . . ; If the document has been deleted, QUIT
    30         . . . D EXTRACT^TIULQ(SRK,"SRW",.SRERR1,".01") I $P($G(SRERR1),"^")=1 S SRCONT=1 Q
    31         . . . I '+$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
    32         . . . S SRDA=SRK
    33         . . . D REPORT(SRDA) Q:'+$G(SRCONT)
    34         . . . I '+$G(SRSPG) K SRCONT1 D SETCONT(1)
    35         . . . I $E(IOST)="C",'$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) S SRCONT=0
    36         . Q:'SRCONT  I $E(IOST)="C" S SRCONT=$$STOP^SROESPR2() Q:'SRCONT
    37         . I +$G(SRSPG),$E(IOST)'="C" K SRCONT1 D SETCONT(1)
    38         Q
    39 REPORT(SRDA)    ; Report Text
    40         N DIW,DIWF,DIWL,DIWR,DIWT,SRERR,SR,SRI,SRLINE,X,Z,SRY,LOC
    41         K ^TMP("SRLQ",$J)
    42         S SRLINE=0
    43         D EXTRACT^TIULQ(+SRDA,"^TMP(""SRLQ"",$J)",.SRERR,"",SRLINE,1)
    44         I +$G(SRERR) W !,$P(SRERR,U,2) Q
    45         Q:'$D(^TMP("SRLQ",$J))
    46         S SRY=4,SRCONT=1
    47         D SETCONT() Q:'SRCONT
    48         W "NOTE DATED: "
    49         W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,1301,"I"),"MM/DD/CCYY HR:MIN")
    50         W ?30,$$UP^XLFSTR(^TMP("SRLQ",$J,SRDA,.01,"E")),!
    51         I +$G(^TMP("SRLQ",$J,SRDA,1205,"I")) D
    52         .S LOC=$G(^TMP("SRLQ",$J,SRDA,1205,"I")) Q:'$D(^SC(LOC,0))
    53         .W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ")
    54         .W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,.07,"I"),"MM/DD/CCYY HR:MIN")
    55         .W " ",$G(^TMP("SRLQ",$J,SRDA,1205,"E"))
    56         I ^TMP("SRLQ",$J,SRDA,1701,"E")]"" W !,"SUBJECT: ",^("E"),!
    57         S SRCONT1=1
    58         I $D(^TMP("SRLQ",$J,SRDA,"PROBLEM")) D  Q:'SRCONT
    59         .D SETCONT() Q:'SRCONT
    60         .W !,"ASSOCIATED PROBLEMS:"
    61         .N SRI S SRI=0
    62         .F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"PROBLEM",SRI)) Q:'SRI  D  Q:'SRCONT
    63         ..W !,^(SRI,0)
    64         ..D SETCONT() Q:'SRCONT
    65         W !
    66         ;
    67         S SRI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
    68         F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"TEXT",SRI)) Q:SRI'>0  D  Q:'SRCONT  ; D ^DIWW
    69         . D SETCONT() Q:'SRCONT
    70         . S X=^TMP("SRLQ",$J,SRDA,"TEXT",SRI,0) S:X="" X=" " D ^DIWP
    71         D ^DIWW K ^UTILITY($J,"W")
    72         Q:'SRCONT
    73 RPTSIG  ; Signature should be on bottom of form, Addenda on Subsequent pages
    74         N AUTHOR,EXPSIGNR,EXPCOSNR,SIGNDATE,SIGNEDBY,SIGNNAME,SIGTITL,SIGNMODE
    75         N COSGDATE,COSGEDBY,COSGNAME,COSGTITL,COSGMODE,SIGCHRT,COSCHRT,SRLINE
    76         S $P(SRLINE,"-",81)=""
    77         S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,1202,"I"))_";"_$G(^("E"))
    78         S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,1204,"I"))_";"_$G(^("E"))
    79         S EXPCOSNR=$G(^TMP("SRLQ",$J,SRDA,1208,"I"))_";"_$G(^("E"))
    80         S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,1501,"I"))
    81         S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,1502,"I"))_";"_$G(^("E"))
    82         S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,1503,"E"))
    83         S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,1504,"E"))
    84         S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,1505,"I"))_";"_$G(^("E"))
    85         S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,1507,"I"))
    86         S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,1508,"I"))_";"_$G(^("E"))
    87         S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,1509,"E"))
    88         S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,1510,"E"))
    89         S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,1511,"I"))_";"_$G(^("E"))
    90         S SIGCHRT=$G(^TMP("SRLQ",$J,SRDA,1512,"I"))_";"_$G(^("E"))
    91         S COSCHRT=$G(^TMP("SRLQ",$J,SRDA,1513,"I"))_";"_$G(^("E"))
    92         D SETCONT() Q:'SRCONT  W !
    93         D SIGBLK Q:'SRCONT
    94 ADDENDA ; Surgery Reports Addenda
    95         N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,SRI,SRADD
    96         S SRADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
    97         F  S SRADD=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD)) Q:SRADD'>0  D  Q:'SRCONT
    98         . S SRY=4 D SETCONT() Q:'SRCONT
    99         . W !!,$$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1301,"I"),"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM"
    100         . W ?41,"STATUS: ",^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,.05,"E")
    101         . S SRI=0
    102         . F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI)) Q:SRI'>0  D  Q:'SRCONT
    103         . . D SETCONT() Q:'SRCONT
    104         . . S X=^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI,0) S:X="" X=" " D ^DIWP
    105         . D ^DIWW
    106         . D:SRCONT ADDENSIG
    107         K ^UTILITY($J,"W")
    108         ; Write 2 linefeeds between records
    109         Q:'SRCONT  W !!
    110         Q
    111 ADDENSIG        ;
    112         N AUTHOR,EXPSIGNR,ATTNDING,SIGNDATE,SIGNEDBY,SIGNNAME,SIGNMODE
    113         N COSGDATE,COSGEDBY,COSGNAME,COSGMODE,SRLINE S $P(SRLINE,"-",80)=""
    114         S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1202,"I"))_";"_$G(^("E"))
    115         S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1204,"I"))_";"_$G(^("E"))
    116         S ATTNDING=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1209,"I"))_";"_$G(^("E"))
    117         S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1501,"I"))
    118         S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1502,"I"))_";"_$G(^("E"))
    119         S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1503,"E"))
    120         S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1504,"E"))
    121         S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1505,"I"))_";"_$G(^("E"))
    122         S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1507,"I"))
    123         S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1508,"I"))_";"_$G(^("E"))
    124         S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1509,"E"))
    125         S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1510,"E"))
    126         S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1511,"I"))_";"_$G(^("E"))
    127         S SRY=11
    128 SIGBLK  N SRGROOT S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA))
    129         I '+SIGNDATE D  D SETCONT() Q:'SRCONT
    130         .I $$STATUS^SROESUTL(SRDA)'=7 W !,"**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED-- DRAFT COPY - DRAFT COPY**"
    131         I SIGNEDBY]"",(+SIGNEDBY'=+AUTHOR)  D
    132         . W ?21,"Author:      ",$P(AUTHOR,";",2),!
    133         I +SIGNDATE D SETCONT() Q:'SRCONT  D
    134         . W ?18,"Signed by:",$S($P(SIGNMODE,";")="C":" /s/  ",1:" /es/ "),?34,$S(SIGNNAME]"":SIGNNAME,1:$P(SIGNEDBY,";",2))
    135         . W !?34,SIGTITL
    136         . I $L(SIGTITL)>30 W !?34
    137         . E  W " "
    138         . W $$DATE^SROESPR(+SIGNDATE,"MM/DD/CCYY HR:MIN")
    139         . I '+$G(SRFLAG)!($E(IOST)="C") D
    140         . . I $P($$BEEP^SROESPR(+SIGNEDBY),U) W !?34,"Analog Pager:  ",$P($$BEEP^SROESPR(+SIGNEDBY),U)
    141         . . I $P($$BEEP^SROESPR(+SIGNEDBY),U,2) W !?34,"Digital Pager: ",$P($$BEEP^SROESPR(+SIGNEDBY),U,2)
    142         I $G(^TMP("SRLQ",$J,SRDA,.05,"E"))="UNCOSIGNED" D
    143         . W !?34,"**REQUIRES COSIGNATURE**",!
    144         I +SIGCHRT,$P(SIGNMODE,";")="C" D SETCONT() Q:'SRCONT  D
    145         . W !?2,"Marked signed on chart by:",?34,$P(SIGCHRT,";",2)
    146         I +$G(SRADD) S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD))
    147         I +$D(@SRGROOT@("EXTRASGNR")) D
    148         . N SRI S SRI=0
    149         . D SETCONT() Q:'SRCONT  W !?4,"Receipt Acknowledged By:"
    150         . F  S SRI=$O(@SRGROOT@("EXTRASGNR",SRI)) Q:'SRI  D
    151         . . I +$G(@SRGROOT@("EXTRASGNR",SRI,"DATE"))'>0 Q
    152         . . I SRI>1 D SETCONT() Q:'SRCONT  W !
    153         . . W ?29,"/es/ ",$G(@SRGROOT@("EXTRASGNR",SRI,"NAME"))
    154         . . W !?34,$G(@SRGROOT@("EXTRASGNR",SRI,"TITLE"))
    155         . . I $L($G(@SRGROOT@("EXTRASGNR",SRI,"TITLE")))>30 W !?34
    156         . . E  W " "
    157         . . W $$DATE^SROESPR($G(@SRGROOT@("EXTRASGNR",SRI,"DATE")),"MM/DD/CCYY HR:MIN")
    158         . . I '+$G(SRFLAG)!($E(IOST)="C") D
    159         . . . N BEEP
    160         . . . S BEEP=$$BEEP^SROESPR(+$G(@SRGROOT@("EXTRASGNR",SRI,"EXTRA")))
    161         . . . I +BEEP W !?34,"Analog Pager:  ",$P(BEEP,U)
    162         . . . I +$P(BEEP,U,2) W !?34,"Digital Pager: ",$P(BEEP,U,2)
    163         . K @SRGROOT@("EXTRASGNR")
    164         I +COSGDATE,(+COSGEDBY'=+SIGNEDBY) D SETCONT() Q:'SRCONT  D
    165         . W !?16,"Cosigned by:",$S($P(COSGMODE,";")="C":" /s/  ",1:" /es/ "),?34,$S(COSGNAME]"":COSGNAME,1:$P(COSGEDBY,";",2))
    166         . W !?34,COSGTITL," "
    167         . W $$DATE^SROESPR(+COSGDATE,"MM/DD/CCYY HR:MIN")
    168         . I '+$G(SRFLAG)!($E(IOST)="C") D
    169         . . I $P($$BEEP^SROESPR(+COSGEDBY),U) W !?34,"Analog Pager: ",$P($$BEEP^SROESPR(+COSGEDBY),U)
    170         . . I $P($$BEEP^SROESPR(+COSGEDBY),U,2) W !?34,"Digital Pager:",$P($$BEEP^SROESPR(+COSGEDBY),U,2)
    171         I +COSCHRT,$P(COSGMODE,";")="C" D SETCONT() Q:'SRCONT  D
    172         . W !,"Marked cosigned on chart by:",?34,$P(COSCHRT,";",2)
    173         W !
    174         K SRCONT1
    175 AMEND   ; signature blocks of amender
    176         S SRY=4 D SETCONT() Q:'SRCONT
    177         I +$G(@SRGROOT@(1601,"I")) D
    178         . W !!?12,"Amendment Filed:",?34,$$DATE^SROESPR(@SRGROOT@(1601,"I"),"MM/DD/CCYY HR:MIN")
    179         . I $G(@SRGROOT@(1603,"E"))']"" D
    180         . . W !!?29 F SRI=1:1:40 W "_"
    181         . . W !?29,$$SIGNAME^SROESPR(@SRGROOT@(1602,"I"))
    182         . . W !?29,$$SIGTITL^SROESPR(@SRGROOT@(1602,"I"))
    183         . I $G(@SRGROOT@(1604,"E"))]"" D
    184         . . W !?29,"/es/",?34,@SRGROOT@(1604,"E")
    185         . . W !?34,@SRGROOT@(1605,"E")
    186         Q
    187 SETCONT(SRHEAD) ;Does footer and sets SRCONT
    188         S SRCONT=$$FOOTER^SROESPR2(.SRFOOT,SRFLAG,SRPFNBR,$G(SRHEAD),$G(SRCONT1),SRDA)
    189         Q
     1SROESPR1 ;BIR/ADM - SURGERY E-SIG UTILITY ; [ 04/21/04  12:08 PM ]
     2 ;;3.0; Surgery ;**100,128**;24 Jun 93
     3 ;
     4 ;** NOTICE: This routine is part of an implementation of a nationally
     5 ;**         controlled procedure.  Local modifications to this routine
     6 ;**         are prohibited.
     7 ;
     8 ; Reference to EXTRACT^TIULQ supported by DBIA #2693
     9 ;
     10 ; This routine was cloned in part or in whole from TIUPRPN1.
     11PRINT(SRFLAG,SRSPG) ; Print Summary
     12 ; ^TMP("SRPR",$J) is array of records passed by reference
     13 ; SRFLAG=1 --> Chart Copy     SRSPG=1 --> Contiguous
     14 ; SRFLAG=0 --> Work Copy      SRSPG=0 --> Fresh Page- each note
     15 N SRI,SRJ,SRPAGE,SRFOOT,SRK,SRDA,SRCONT,SRPGRP,SRTYP
     16 N SRPFHDR,SRPFNBR,SROPAGE
     17 S SRFLAG=+$G(SRFLAG),SRSPG=+$G(SRSPG)
     18 S SRI=0 F  S SRI=$O(^TMP("SRPR",$J,SRI)) Q:SRI=""  D  Q:'SRCONT
     19 . N DFN,SR,SRERR
     20 . I SRI["$" S SRPGRP=$P(SRI,"$"),SRPFHDR=$P($P(SRI,";"),"$",2)
     21 . E  S SRPFHDR="Surgery Reports"
     22 . I $G(SRPGRP)'=2 S SRSPG=0
     23 . S DFN=$P(SRI,";",2)
     24 . D PAT^SROESPR(.SRFOOT,DFN)
     25 . I +$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
     26 . S SRJ=0 F  S SRJ=$O(^TMP("SRPR",$J,SRI,SRJ)) Q:'SRJ  D  Q:'SRCONT
     27 . . S SRK=0 F  S SRK=$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) Q:'SRK  D  Q:'+$G(SRCONT)
     28 . . . N SRERR1,SRW K SRCONT1 S SRPFNBR=^(SRK)
     29 . . . ; If the document has been deleted, QUIT
     30 . . . D EXTRACT^TIULQ(SRK,"SRW",.SRERR1,".01") I $P($G(SRERR1),"^")=1 S SRCONT=1 Q
     31 . . . I '+$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR)
     32 . . . S SRDA=SRK
     33 . . . D REPORT(SRDA) Q:'+$G(SRCONT)
     34 . . . I '+$G(SRSPG) K SRCONT1 D SETCONT(1)
     35 . . . I $E(IOST)="C",'$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) S SRCONT=0
     36 . Q:'SRCONT  I $E(IOST)="C" S SRCONT=$$STOP^SROESPR2() Q:'SRCONT
     37 . I +$G(SRSPG),$E(IOST)'="C" K SRCONT1 D SETCONT(1)
     38 Q
     39REPORT(SRDA) ; Report Text
     40 N DIW,DIWF,DIWL,DIWR,DIWT,SRERR,SR,SRI,SRLINE,X,Z,SRY,LOC
     41 K ^TMP("SRLQ",$J)
     42 S SRLINE=0
     43 D EXTRACT^TIULQ(+SRDA,"^TMP(""SRLQ"",$J)",.SRERR,"",SRLINE,1)
     44 I +$G(SRERR) W !,$P(SRERR,U,2) Q
     45 Q:'$D(^TMP("SRLQ",$J))
     46 S SRY=4,SRCONT=1
     47 D SETCONT() Q:'SRCONT
     48 W "NOTE DATED: "
     49 W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,1301,"I"),"MM/DD/CCYY HR:MIN")
     50 W ?30,$$UP^XLFSTR(^TMP("SRLQ",$J,SRDA,.01,"E")),!
     51 I +$G(^TMP("SRLQ",$J,SRDA,1205,"I")) D
     52 .S LOC=$G(^TMP("SRLQ",$J,SRDA,1205,"I")) Q:'$D(^SC(LOC,0))
     53 .W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ")
     54 .W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,.07,"I"),"MM/DD/CCYY HR:MIN")
     55 .W " ",$G(^TMP("SRLQ",$J,SRDA,1205,"E"))
     56 I ^TMP("SRLQ",$J,SRDA,1701,"E")]"" W !,"SUBJECT: ",^("E"),!
     57 S SRCONT1=1
     58 I $D(^TMP("SRLQ",$J,SRDA,"PROBLEM")) D  Q:'SRCONT
     59 .D SETCONT() Q:'SRCONT
     60 .W !,"ASSOCIATED PROBLEMS:"
     61 .N SRI S SRI=0
     62 .F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"PROBLEM",SRI)) Q:'SRI  D  Q:'SRCONT
     63 ..W !,^(SRI,0)
     64 ..D SETCONT() Q:'SRCONT
     65 W !
     66 ;
     67 S SRI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
     68 F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"TEXT",SRI)) Q:SRI'>0  D  Q:'SRCONT  ; D ^DIWW
     69 . D SETCONT() Q:'SRCONT
     70 . S X=^TMP("SRLQ",$J,SRDA,"TEXT",SRI,0) S:X="" X=" " D ^DIWP
     71 D ^DIWW K ^UTILITY($J,"W")
     72 Q:'SRCONT
     73RPTSIG ; Signature should be on bottom of form, Addenda on Subsequent pages
     74 N AUTHOR,EXPSIGNR,EXPCOSNR,SIGNDATE,SIGNEDBY,SIGNNAME,SIGTITL,SIGNMODE
     75 N COSGDATE,COSGEDBY,COSGNAME,COSGTITL,COSGMODE,SIGCHRT,COSCHRT,SRLINE
     76 S $P(SRLINE,"-",81)=""
     77 S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,1202,"I"))_";"_$G(^("E"))
     78 S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,1204,"I"))_";"_$G(^("E"))
     79 S EXPCOSNR=$G(^TMP("SRLQ",$J,SRDA,1208,"I"))_";"_$G(^("E"))
     80 S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,1501,"I"))
     81 S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,1502,"I"))_";"_$G(^("E"))
     82 S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,1503,"E"))
     83 S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,1504,"E"))
     84 S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,1505,"I"))_";"_$G(^("E"))
     85 S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,1507,"I"))
     86 S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,1508,"I"))_";"_$G(^("E"))
     87 S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,1509,"E"))
     88 S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,1510,"E"))
     89 S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,1511,"I"))_";"_$G(^("E"))
     90 S SIGCHRT=$G(^TMP("SRLQ",$J,SRDA,1512,"I"))_";"_$G(^("E"))
     91 S COSCHRT=$G(^TMP("SRLQ",$J,SRDA,1513,"I"))_";"_$G(^("E"))
     92 D SETCONT() Q:'SRCONT  W !
     93 D SIGBLK Q:'SRCONT
     94ADDENDA ; Surgery Reports Addenda
     95 N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,SRI,SRADD
     96 S SRADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
     97 F  S SRADD=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD)) Q:SRADD'>0  D  Q:'SRCONT
     98 . S SRY=4 D SETCONT() Q:'SRCONT
     99 . W !!,$$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1301,"I"),"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM"
     100 . S SRI=0
     101 . F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI)) Q:SRI'>0  D  Q:'SRCONT
     102 . . D SETCONT() Q:'SRCONT
     103 . . S X=^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI,0) S:X="" X=" " D ^DIWP
     104 . D ^DIWW
     105 . D:SRCONT ADDENSIG
     106 K ^UTILITY($J,"W")
     107 ; Write 2 linefeeds between records
     108 Q:'SRCONT  W !!
     109 Q
     110ADDENSIG ;
     111 N AUTHOR,EXPSIGNR,ATTNDING,SIGNDATE,SIGNEDBY,SIGNNAME,SIGNMODE
     112 N COSGDATE,COSGEDBY,COSGNAME,COSGMODE,SRLINE S $P(SRLINE,"-",80)=""
     113 S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1202,"I"))_";"_$G(^("E"))
     114 S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1204,"I"))_";"_$G(^("E"))
     115 S ATTNDING=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1209,"I"))_";"_$G(^("E"))
     116 S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1501,"I"))
     117 S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1502,"I"))_";"_$G(^("E"))
     118 S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1503,"E"))
     119 S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1504,"E"))
     120 S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1505,"I"))_";"_$G(^("E"))
     121 S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1507,"I"))
     122 S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1508,"I"))_";"_$G(^("E"))
     123 S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1509,"E"))
     124 S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1510,"E"))
     125 S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1511,"I"))_";"_$G(^("E"))
     126 S SRY=11
     127SIGBLK N SRGROOT S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA))
     128 I '+SIGNDATE D  D SETCONT() Q:'SRCONT
     129 .I $$STATUS^SROESUTL(SRDA)'=7 W !,"**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED-- DRAFT COPY - DRAFT COPY**"
     130 I SIGNEDBY]"",(+SIGNEDBY'=+AUTHOR)  D
     131 . W ?21,"Author:      ",$P(AUTHOR,";",2),!
     132 I +SIGNDATE D SETCONT() Q:'SRCONT  D
     133 . W ?18,"Signed by:",$S($P(SIGNMODE,";")="C":" /s/  ",1:" /es/ "),?34,$S(SIGNNAME]"":SIGNNAME,1:$P(SIGNEDBY,";",2))
     134 . W !?34,SIGTITL
     135 . I $L(SIGTITL)>30 W !?34
     136 . E  W " "
     137 . W $$DATE^SROESPR(+SIGNDATE,"MM/DD/CCYY HR:MIN")
     138 . I '+$G(SRFLAG)!($E(IOST)="C") D
     139 . . I $P($$BEEP^SROESPR(+SIGNEDBY),U) W !?34,"Analog Pager:  ",$P($$BEEP^SROESPR(+SIGNEDBY),U)
     140 . . I $P($$BEEP^SROESPR(+SIGNEDBY),U,2) W !?34,"Digital Pager: ",$P($$BEEP^SROESPR(+SIGNEDBY),U,2)
     141 I $G(^TMP("SRLQ",$J,SRDA,.05,"E"))="UNCOSIGNED" D
     142 . W !?34,"**REQUIRES COSIGNATURE**",!
     143 I +SIGCHRT,$P(SIGNMODE,";")="C" D SETCONT() Q:'SRCONT  D
     144 . W !?2,"Marked signed on chart by:",?34,$P(SIGCHRT,";",2)
     145 I +$G(SRADD) S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD))
     146 I +$D(@SRGROOT@("EXTRASGNR")) D
     147 . N SRI S SRI=0
     148 . D SETCONT() Q:'SRCONT  W !?4,"Receipt Acknowledged By:"
     149 . F  S SRI=$O(@SRGROOT@("EXTRASGNR",SRI)) Q:'SRI  D
     150 . . I +$G(@SRGROOT@("EXTRASGNR",SRI,"DATE"))'>0 Q
     151 . . I SRI>1 D SETCONT() Q:'SRCONT  W !
     152 . . W ?29,"/es/ ",$G(@SRGROOT@("EXTRASGNR",SRI,"NAME"))
     153 . . W !?34,$G(@SRGROOT@("EXTRASGNR",SRI,"TITLE"))
     154 . . I $L($G(@SRGROOT@("EXTRASGNR",SRI,"TITLE")))>30 W !?34
     155 . . E  W " "
     156 . . W $$DATE^SROESPR($G(@SRGROOT@("EXTRASGNR",SRI,"DATE")),"MM/DD/CCYY HR:MIN")
     157 . . I '+$G(SRFLAG)!($E(IOST)="C") D
     158 . . . N BEEP
     159 . . . S BEEP=$$BEEP^SROESPR(+$G(@SRGROOT@("EXTRASGNR",SRI,"EXTRA")))
     160 . . . I +BEEP W !?34,"Analog Pager:  ",$P(BEEP,U)
     161 . . . I +$P(BEEP,U,2) W !?34,"Digital Pager: ",$P(BEEP,U,2)
     162 . K @SRGROOT@("EXTRASGNR")
     163 I +COSGDATE,(+COSGEDBY'=+SIGNEDBY) D SETCONT() Q:'SRCONT  D
     164 . W !?16,"Cosigned by:",$S($P(COSGMODE,";")="C":" /s/  ",1:" /es/ "),?34,$S(COSGNAME]"":COSGNAME,1:$P(COSGEDBY,";",2))
     165 . W !?34,COSGTITL," "
     166 . W $$DATE^SROESPR(+COSGDATE,"MM/DD/CCYY HR:MIN")
     167 . I '+$G(SRFLAG)!($E(IOST)="C") D
     168 . . I $P($$BEEP^SROESPR(+COSGEDBY),U) W !?34,"Analog Pager: ",$P($$BEEP^SROESPR(+COSGEDBY),U)
     169 . . I $P($$BEEP^SROESPR(+COSGEDBY),U,2) W !?34,"Digital Pager:",$P($$BEEP^SROESPR(+COSGEDBY),U,2)
     170 I +COSCHRT,$P(COSGMODE,";")="C" D SETCONT() Q:'SRCONT  D
     171 . W !,"Marked cosigned on chart by:",?34,$P(COSCHRT,";",2)
     172 W !
     173 K SRCONT1
     174AMEND ; signature blocks of amender
     175 S SRY=4 D SETCONT() Q:'SRCONT
     176 I +$G(@SRGROOT@(1601,"I")) D
     177 . W !!?12,"Amendment Filed:",?34,$$DATE^SROESPR(@SRGROOT@(1601,"I"),"MM/DD/CCYY HR:MIN")
     178 . I $G(@SRGROOT@(1603,"E"))']"" D
     179 . . W !!?29 F SRI=1:1:40 W "_"
     180 . . W !?29,$$SIGNAME^SROESPR(@SRGROOT@(1602,"I"))
     181 . . W !?29,$$SIGTITL^SROESPR(@SRGROOT@(1602,"I"))
     182 . I $G(@SRGROOT@(1604,"E"))]"" D
     183 . . W !?29,"/es/",?34,@SRGROOT@(1604,"E")
     184 . . W !?34,@SRGROOT@(1605,"E")
     185 Q
     186SETCONT(SRHEAD) ;Does footer and sets SRCONT
     187 S SRCONT=$$FOOTER^SROESPR2(.SRFOOT,SRFLAG,SRPFNBR,$G(SRHEAD),$G(SRCONT1),SRDA)
     188 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROGMTS.m

    r613 r623  
    1 SROGMTS ;BIR/ADM - SURGERY HEALTH SUMMARY ; [ 08/08/01  7:12 AM ]
    2         ;;3.0; Surgery ;**100,127,162**;24 Jun 93;Build 4
    3         ;
    4         ;** NOTICE: This routine is part of an implementation of a nationally
    5         ;**         controlled procedure.  Local modifications to this routine
    6         ;**         are prohibited.
    7         ;
    8         ; Reference to $$MOD^ICPTMOD supported by DBIA #1996
    9         ; Reference to $$CPT^ICPTCOD supported by DBIA #1995
    10         ;
    11         Q
    12 HS(X)   ; return case information for a surical or non-OR case
    13         ; X - case number (IEN) in file 130
    14         K REC N SRCPTM,SRSG,DA,DR,DIC,DIQ,IEN,IENS,FILE,FLD,FLDS,FLDI
    15         N FLDA,FLDB,FLDR,FLDRT,IEN,SRI,SRRT,SRT,SRS,SRC,SRCS
    16         S SRCPTM=1
    17         Q:'$D(^SRF(X,0))  S (IENS,IEN,X)=+($G(X)),U="^"
    18         S:'$D(DT) DT=$$HTFM^XLFDT($H,1) S:'$D(DTIME) DTIME=300
    19         S (FILE,DIC)=130,DA=+($G(X)),DIQ="REC(",DIQ(0)="IE"
    20         S SRSG=$$SG(IEN),REC(130,IEN,118,"E")=$S(SRSG=0:"YES",1:""),REC(130,IEN,118,"I")=$S(SRSG=0:"Y",1:"")
    21         S:+SRSG DR=".09;.04;.14;.164;.205;.22;.23;.31;10;15;17;26;27;32;34;36;39;43;49;50"
    22         S:'SRSG DR=".09;.31;26;27;33;50;55;59;66;121;122;123;124;125"
    23         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:"")
    24         S SRM=$G(REC(130,IEN,27,"I")) I SRM>0 D CPT(SRM,$P($G(^SRF(IEN,0)),"^",9),130,27)
    25         D DICT^SROGMTS0,SUB,SPD
    26         S:$D(REC(130,IEN,32)) REC(130,IEN,32,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,32,"E")))
    27         S:$D(REC(130,IEN,33)) REC(130,IEN,33,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,33,"E")))
    28         S:$D(REC(130,IEN,34)) REC(130,IEN,34,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,34,"E")))
    29         S:$D(REC(130,IEN,.04)) REC(130,IEN,.04,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,.04,"E")))
    30         S:$D(REC(130,IEN,125)) REC(130,IEN,125,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,125,"E")))
    31         I $L($G(REC(130,IEN,33,"S"))) D
    32         . S:'$L($G(REC(130,IEN,66,"E"))) REC(130,IEN,33,"S")=$G(REC(130,IEN,33,"S"))_" (Unknown)"
    33         . 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"))_")"
    34         S:+($G(REC(130,IEN,.09,"I")))>0 REC(130,IEN,.09,"S")=$$ED^SROGMTS0($G(REC(130,IEN,.09,"I")))
    35         S:+($G(REC(130,IEN,15,"I")))>0 REC(130,IEN,15,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,15,"I")))
    36         S:+($G(REC(130,IEN,39,"I"))) REC(130,IEN,39,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,39,"I")))
    37         S:+SRSG REC(130,IEN,"LAB")=$S($O(REC(130,IEN,49,0))>0:"Yes",1:"")
    38         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)
    39         Q
    40 ED(X)   ; external date
    41         S X=$G(X) Q:'$L(X) ""
    42         S X=$TR($$FMTE^XLFDT(X,"5DZ"),"@"," ")
    43         Q X
    44 EDT(X)  ; external date and time
    45         S X=$G(X) Q:'$L(X) ""
    46         S X=$TR($$FMTE^XLFDT(X,"2ZM"),"@"," ")
    47         Q X
    48 WP(X,Y,Z)       ;
    49         N SRI,SRF,SRW,SRGI,DIWF,DIWL,DIWR
    50         S SRI=+($G(X)) Q:SRI=0!('$D(REC(130,SRI)))
    51         S SRF=+($G(Y)) Q:SRF=0!('$D(REC(130,SRI,SRF)))
    52         S SRW=+($G(Z)) Q:SRW'>0!(SRW>79)
    53         Q:+($O(REC(130,SRI,SRF,0)))'>0
    54         K ^UTILITY($J,"W") S DIWF="C"_SRW,DIWL=0,DIWR=0,SRGI=0
    55         F  S SRGI=$O(REC(130,SRI,SRF,SRGI)) Q:+SRGI=0  D
    56         . S X=$G(REC(130,SRI,SRF,SRGI))
    57         . D ^DIWP
    58         S SRGI=0 F  S SRGI=$O(^UTILITY($J,"W",0,SRGI)) Q:+SRGI=0  D
    59         . S REC(130,SRI,SRF,"S",SRGI)=$G(^UTILITY($J,"W",0,SRGI,0))
    60         . S REC(130,SRI,SRF,"S",0)=$G(REC(130,SRI,SRF,"S",0))+1
    61         K ^UTILITY($J,"W")
    62         Q
    63 OS(X)   ; Obtains status for OR procedures
    64         N SRN S SRN=+($G(X)) S X="" I $G(REC(130,SRN,118,"I"))="Y" D  Q X
    65         . S:+($G(REC(130,SRN,122,"I")))>0 X="(Completed)"
    66         . S:+($G(REC(130,SRN,121,"I")))>0&(+($G(REC(130,SRN,122,"I")))'>0) X="Incomplete"
    67         . S:X="" X="Unknown"
    68         I +($G(REC(130,SRN,17,"I")))>0 D  Q X
    69         . S X=$S(+($G(REC(130,SRN,.205,"I")))>0:"(Aborted)",1:"Cancelled")
    70         I +($G(REC(130,SRN,.23,"I")))>0 S X="(Completed)" Q X
    71         I +($G(REC(130,SRN,.22,"I")))>0 S X="Incomplete" Q X
    72         I +($G(REC(130,SRN,10,"I")))>0 S X="Scheduled" Q X
    73         I +($G(REC(130,SRN,36,"I")))>0,+($G(REC(130,SRN,.22,"I")))'>0 S X="Requested" Q X
    74         S X="Unknown"
    75         Q X
    76 SUB     ;
    77         N DA,DR,DIC,DIQ,IENS,FILE,FLD,FLDS,FLDI,FLDA,FLDB,FLDR,FLDRT,SRM,SRC,SRI,SRJ,STXT,SNAM,SCOD,SUB
    78         I +SRSG D
    79         . ;
    80         . ; ^SRF(DO,14,I)                .72  Other Preop Diag    14;0  130.17
    81         . ; $P(^SRF(DO,14,I,0),U)        .01  Other Preop Diag     0;1  Text
    82         . ;
    83         . S DA=IEN,(FILE,DIC)=130,SUB=130.17,DR=.72,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
    84         . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),14,SRI)) Q:+SRI=0  D
    85         . . S DA(SUB)=SRI
    86         . . D EN^DIQ1
    87         . . S REC(130,IEN,130.17,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.17,SRI,.01,"E")))
    88         . ;
    89         . ; ^SRF(DO,15,I)                .74  Other Postop Diags  15;0  130.18
    90         . ; $P(^SRF(DO,15,I,0),U)        .01  Other Postop Diags   0;1  Text
    91         . ;
    92         . S DA=IEN,(FILE,DIC)=130,SUB=130.18,DR=.74,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
    93         . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),15,SRI)) Q:+SRI=0  D
    94         . . S DA(SUB)=SRI
    95         . . D EN^DIQ1
    96         . . S REC(130,IEN,130.18,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.18,SRI,.01,"E")))
    97         ;
    98         ; ^SRF(SRN,"OPMOD",I)           28  Pri Pro CPT Mod  OPMOD;0  130.028
    99         ; $P(^SRF(SRN,"OPMOD",I,0),U)  .01  Pri Pro CPT Mod      0;1  Ptr 81.3
    100         ;
    101         I SRCPTM D
    102         . S DA=IEN,(FILE,DIC)=130,SUB=130.028,DR=28,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
    103         . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),"OPMOD",SRI)) Q:+SRI=0  D
    104         . . S DA(SUB)=SRI
    105         . . D EN^DIQ1
    106         . . S SRM=+($G(REC(130,+($G(IEN)),SUB,+($G(SRI)),.01,"I"))) I SRM>0 D MOD(SRM,FILE,SUB)
    107         ;
    108         ; ^SRF(DO,13,I)                .42  Other Proc          13;0  130.16
    109         ; $P(^SRF(DO,13,I,0),U)        .01  Other Proc           0;1  Text     
    110         ; $P(^SRF(DO,13,I,2),U)          3  Other Proc CPT Code  2;1  Ptr 81
    111         ;
    112         S DA=IEN,(FILE,DIC)=130,SUB=130.16,DR=.42,DR(SUB)=".01;3",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
    113         K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),13,SRI)) Q:+SRI=0  D
    114         . S DA(SUB)=SRI
    115         . D EN^DIQ1 S SRM=+($G(REC(130,IEN,130.16,SRI,3,"I")))
    116         . S:SRM>0 REC(130,IEN,130.16,SRI,3,"N")=$P($$CPT^ICPTCOD(+SRM,$P($G(^SRF(IEN,0)),"^",9)),"^",3)
    117         . N SRT,SRS,SRC S SRM=$G(REC(130,IEN,130.16,SRI,3,"I")) I SRM>0 D
    118         . . S SRC=$$CPT^ICPTCOD(SRM,$P($G(^SRF(IEN,0)),"^",9)),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3))
    119         . . S REC(130,IEN,130.16,SRI,3,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3)
    120         . . S SRC=$P(SRC,"^",2)
    121         . . S SRT=$$EN2^SROGMTS0($G(REC(130,IEN,130.16,SRI,.01,"E")))
    122         . . S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_$$EN2^SROGMTS0(SRS)
    123         . . S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")"
    124         . . S REC(130,IEN,130.16,SRI,3,"N")=SRS
    125         . . S REC(130,IEN,130.16,SRI,.01,"S")=SRT
    126         . . S REC(130,IEN,130.16,SRI,3,"S")=SRCS
    127         . ;
    128         . ;     ^SRF(8,13,2,"MOD",0)       4  Oth Proc CPT Mod   MOD;0  130.164
    129         . ;     ^SRF(8,13,2,"MOD",1,0)   .01  Oth Proc CPT Mod     0;1  Ptr 81.3
    130         . ;
    131         . I SRCPTM D
    132         . . N SRJ S SRJ=0 F  S SRJ=$O(^SRF(+($G(IEN)),13,SRI,"MOD",SRJ)) Q:+SRJ=0  D
    133         . . . 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"
    134         . . . D EN^DIQ1
    135         . . . S SRM=+($G(REC(130,IEN,130.16,SRI,130.164,SRJ,.01,"I")))
    136         . . . I SRM>0 N SRMOD1 D
    137         . . . . S SRMOD1=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9))
    138         . . . . S SRC=$P(SRMOD1,"^",2)
    139         . . . . S SRS=$P(SRMOD1,"^",3)
    140         . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MID")=SRC
    141         . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MOD")=SRS
    142         . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"X")=SRC_"^"_SRS
    143         . . . . S SRT=$$EN2^SROGMTS0(SRS) S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")"
    144         . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"S")=SRT
    145         . . . K REC(130,IEN,130.16,SRI,130)
    146         Q
    147 SG(X)   ; Surgical (Operative) Record
    148         S X=$$GET1^DIQ(130,+($G(X)),118,"I") S X=$S(X["Y":0,1:1) Q X
    149 CPT(SRM,SRDOO,SRFIL,SRFLD)      ;Set CPT code into REC array
    150         S SRC=$$CPT^ICPTCOD(SRM,SRDOO),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3))
    151         S REC(SRFIL,IEN,SRFLD,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3)
    152         S SRC=$P(SRC,"^",2),SRT=$$EN2^SROGMTS0($G(REC(130,IEN,26,"E")))
    153         S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_SRS
    154         S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")"
    155         S REC(SRFIL,IEN,SRFLD,"N")=SRS
    156         S:SRFIL=130 REC(130,IEN,26,"S")=SRT
    157         S REC(SRFIL,IEN,SRFLD,"S")=SRT
    158         S REC(SRFIL,IEN,SRFLD,"S")=SRCS
    159         Q
    160 MOD(SRM,SRFIL,SUB)      ;Set CPT Modifier into REC array
    161         S SRMOD=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9))
    162         S SRC=$P(SRMOD,"^",2)
    163         S SRS=$P(SRMOD,"^",3)
    164         S REC(SRFIL,IEN,SUB,SRI,.01,"MID")=SRC
    165         S REC(SRFIL,IEN,SUB,SRI,.01,"MOD")=SRS
    166         S SRT=$$EN2^SROGMTS0(SRS)
    167         S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")"
    168         S REC(SRFIL,IEN,SUB,SRI,.01,"S")=SRT
    169         Q
    170 SPD     ;Obtain Surgery Procedure/Diagnosis Code File entry
    171         S (FILE,DIC)=136,DA=+($G(IEN)),DIQ="REC(",DIQ(0)="IE"
    172         S DR=".01;.02;.03;10"
    173         D EN^DIQ1
    174         Q:'+$G(REC(FILE,IEN,10,"I"))
    175         S SRM=+$G(REC(FILE,IEN,.02,"I"))
    176         Q:'(SRM>0)  D CPT(SRM,$P($G(^SRF(IEN,0)),"^",9),FILE,.02)
    177         S SUB=136.01,DR=1,DR(SUB)=".01",DIQ="REC(136,"_IEN_","
    178         K REC(FILE,IEN,SUB) S SRI=0 F  S SRI=$O(^SRO(FILE,(+$G(IEN)),DR,SRI))  Q:+SRI=0  D
    179         .S DA(SUB)=SRI
    180         .D EN^DIQ1
    181         .S SRM=REC(FILE,IEN,SUB,SRI,.01,"I") I SRM>0 D MOD(SRM,FILE,SUB)
    182         N DA S DA=IEN,SUB=136.011,DR=11,DR(SUB)=".01;1"
    183         K REC(FILE,IEN,SUB) S SRI=0 F  S SRI=$O(^SRO(FILE,(+$G(IEN)),DR,SRI)) Q:+SRI=0  D
    184         . S DA(SUB)=SRI
    185         . D EN^DIQ1
    186         S $P(REC(130,IEN,26,"S"),"-",2)=" "_REC(FILE,IEN,.02,"S")
    187         K REC(130,IEN,130.028) M REC(130,IEN,130.028)=REC(FILE,IEN,136.01)
    188         Q
     1SROGMTS ;BIR/ADM - SURGERY HEALTH SUMMARY ; [ 08/08/01  7:12 AM ]
     2 ;;3.0; Surgery ;**100,127**;24 Jun 93
     3 ;
     4 ;** NOTICE: This routine is part of an implementation of a nationally
     5 ;**         controlled procedure.  Local modifications to this routine
     6 ;**         are prohibited.
     7 ;
     8 ; Reference to $$MOD^ICPTMOD supported by DBIA #1996
     9 ; Reference to $$CPT^ICPTCOD supported by DBIA #1995
     10 ;
     11 Q
     12HS(X) ; return case information for a surical or non-OR case
     13 ; X - case number (IEN) in file 130
     14 K REC N SRCPTM,SRSG,DA,DR,DIC,DIQ,IEN,IENS,FILE,FLD,FLDS,FLDI
     15 N FLDA,FLDB,FLDR,FLDRT,IEN,SRI,SRRT,SRT,SRS,SRC,SRCS
     16 S SRCPTM=1
     17 Q:'$D(^SRF(X,0))  S (IENS,IEN,X)=+($G(X)),U="^"
     18 S:'$D(DT) DT=$$HTFM^XLFDT($H,1) S:'$D(DTIME) DTIME=300
     19 S (FILE,DIC)=130,DA=+($G(X)),DIQ="REC(",DIQ(0)="IE"
     20 S SRSG=$$SG(IEN),REC(130,IEN,118,"E")=$S(SRSG=0:"YES",1:""),REC(130,IEN,118,"I")=$S(SRSG=0:"Y",1:"")
     21 S:+SRSG DR=".09;.04;.14;.164;.205;.22;.23;.31;10;15;17;26;27;32;34;36;39;43;49;50"
     22 S:'SRSG DR=".09;.31;26;27;33;50;55;59;66;121;122;123;124;125"
     23 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:"")
     24 S SRM=$G(REC(130,IEN,27,"I")) I SRM>0 D
     25 . S SRC=$$CPT^ICPTCOD(SRM,$P($G(^SRF(IEN,0)),"^",9)),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3))
     26 . S REC(130,IEN,27,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3)
     27 . S SRC=$P(SRC,"^",2),SRT=$$EN2^SROGMTS0($G(REC(130,IEN,26,"E")))
     28 . S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_SRS
     29 . S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")"
     30 . S REC(130,IEN,27,"N")=SRS
     31 . S (REC(130,IEN,26,"S"),REC(130,IEN,27,"S"))=SRT
     32 . S REC(130,IEN,27,"S")=SRCS
     33 D DICT^SROGMTS0,SUB
     34 S:$D(REC(130,IEN,32)) REC(130,IEN,32,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,32,"E")))
     35 S:$D(REC(130,IEN,33)) REC(130,IEN,33,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,33,"E")))
     36 S:$D(REC(130,IEN,34)) REC(130,IEN,34,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,34,"E")))
     37 S:$D(REC(130,IEN,.04)) REC(130,IEN,.04,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,.04,"E")))
     38 S:$D(REC(130,IEN,125)) REC(130,IEN,125,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,125,"E")))
     39 I $L($G(REC(130,IEN,33,"S"))) D
     40 . S:'$L($G(REC(130,IEN,66,"E"))) REC(130,IEN,33,"S")=$G(REC(130,IEN,33,"S"))_" (Unknown)"
     41 . 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"))_")"
     42 S:+($G(REC(130,IEN,.09,"I")))>0 REC(130,IEN,.09,"S")=$$ED^SROGMTS0($G(REC(130,IEN,.09,"I")))
     43 S:+($G(REC(130,IEN,15,"I")))>0 REC(130,IEN,15,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,15,"I")))
     44 S:+($G(REC(130,IEN,39,"I"))) REC(130,IEN,39,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,39,"I")))
     45 S:+SRSG REC(130,IEN,"LAB")=$S($O(REC(130,IEN,49,0))>0:"Yes",1:"")
     46 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)
     47 Q
     48ED(X) ; external date
     49 S X=$G(X) Q:'$L(X) ""
     50 S X=$TR($$FMTE^XLFDT(X,"5DZ"),"@"," ")
     51 Q X
     52EDT(X) ; external date and time
     53 S X=$G(X) Q:'$L(X) ""
     54 S X=$TR($$FMTE^XLFDT(X,"2ZM"),"@"," ")
     55 Q X
     56WP(X,Y,Z) ;
     57 N SRI,SRF,SRW,SRGI,DIWF,DIWL,DIWR
     58 S SRI=+($G(X)) Q:SRI=0!('$D(REC(130,SRI)))
     59 S SRF=+($G(Y)) Q:SRF=0!('$D(REC(130,SRI,SRF)))
     60 S SRW=+($G(Z)) Q:SRW'>0!(SRW>79)
     61 Q:+($O(REC(130,SRI,SRF,0)))'>0
     62 K ^UTILITY($J,"W") S DIWF="C"_SRW,DIWL=0,DIWR=0,SRGI=0
     63 F  S SRGI=$O(REC(130,SRI,SRF,SRGI)) Q:+SRGI=0  D
     64 . S X=$G(REC(130,SRI,SRF,SRGI))
     65 . D ^DIWP
     66 S SRGI=0 F  S SRGI=$O(^UTILITY($J,"W",0,SRGI)) Q:+SRGI=0  D
     67 . S REC(130,SRI,SRF,"S",SRGI)=$G(^UTILITY($J,"W",0,SRGI,0))
     68 . S REC(130,SRI,SRF,"S",0)=$G(REC(130,SRI,SRF,"S",0))+1
     69 K ^UTILITY($J,"W")
     70 Q
     71OS(X) ; Obtains status for OR procedures
     72 N SRN S SRN=+($G(X)) S X="" I $G(REC(130,SRN,118,"I"))="Y" D  Q X
     73 . S:+($G(REC(130,SRN,122,"I")))>0 X="(Completed)"
     74 . S:+($G(REC(130,SRN,121,"I")))>0&(+($G(REC(130,SRN,122,"I")))'>0) X="Incomplete"
     75 . S:X="" X="Unknown"
     76 I +($G(REC(130,SRN,17,"I")))>0 D  Q X
     77 . S X=$S(+($G(REC(130,SRN,.205,"I")))>0:"(Aborted)",1:"Cancelled")
     78 I +($G(REC(130,SRN,.23,"I")))>0 S X="(Completed)" Q X
     79 I +($G(REC(130,SRN,.22,"I")))>0 S X="Incomplete" Q X
     80 I +($G(REC(130,SRN,10,"I")))>0 S X="Scheduled" Q X
     81 I +($G(REC(130,SRN,36,"I")))>0,+($G(REC(130,SRN,.22,"I")))'>0 S X="Requested" Q X
     82 S X="Unknown"
     83 Q X
     84SUB ;
     85 N DA,DR,DIC,DIQ,IENS,FILE,FLD,FLDS,FLDI,FLDA,FLDB,FLDR,FLDRT,SRM,SRC,SRI,SRJ,STXT,SNAM,SCOD,SUB
     86 I +SRSG D
     87 . ;
     88 . ; ^SRF(DO,14,I)                .72  Other Preop Diag    14;0  130.17
     89 . ; $P(^SRF(DO,14,I,0),U)        .01  Other Preop Diag     0;1  Text
     90 . ;
     91 . S DA=IEN,(FILE,DIC)=130,SUB=130.17,DR=.72,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
     92 . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),14,SRI)) Q:+SRI=0  D
     93 . . S DA(SUB)=SRI
     94 . . D EN^DIQ1
     95 . . S REC(130,IEN,130.17,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.17,SRI,.01,"E")))
     96 . ;
     97 . ; ^SRF(DO,15,I)                .74  Other Postop Diags  15;0  130.18
     98 . ; $P(^SRF(DO,15,I,0),U)        .01  Other Postop Diags   0;1  Text
     99 . ;
     100 . S DA=IEN,(FILE,DIC)=130,SUB=130.18,DR=.74,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
     101 . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),15,SRI)) Q:+SRI=0  D
     102 . . S DA(SUB)=SRI
     103 . . D EN^DIQ1
     104 . . S REC(130,IEN,130.18,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.18,SRI,.01,"E")))
     105 ;
     106 ; ^SRF(SRN,"OPMOD",I)           28  Pri Pro CPT Mod  OPMOD;0  130.028
     107 ; $P(^SRF(SRN,"OPMOD",I,0),U)  .01  Pri Pro CPT Mod      0;1  Ptr 81.3
     108 ;
     109 I SRCPTM D
     110 . S DA=IEN,(FILE,DIC)=130,SUB=130.028,DR=28,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
     111 . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),"OPMOD",SRI)) Q:+SRI=0  D
     112 . . S DA(SUB)=SRI
     113 . . D EN^DIQ1
     114 . . S SRM=+($G(REC(130,+($G(IEN)),SUB,+($G(SRI)),.01,"I")))
     115 . . I SRM>0 N SRMOD D
     116 . . . S SRMOD=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9))
     117 . . . S SRC=$P(SRMOD,"^",2)
     118 . . . S SRS=$P(SRMOD,"^",3)
     119 . . . S REC(130,IEN,SUB,SRI,.01,"MID")=SRC
     120 . . . S REC(130,IEN,SUB,SRI,.01,"MOD")=SRS
     121 . . . S SRT=$$EN2^SROGMTS0(SRS)
     122 . . . S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")"
     123 . . . S REC(130,IEN,SUB,SRI,.01,"S")=SRT
     124 ;
     125 ; ^SRF(DO,13,I)                .42  Other Proc          13;0  130.16
     126 ; $P(^SRF(DO,13,I,0),U)        .01  Other Proc           0;1  Text     
     127 ; $P(^SRF(DO,13,I,2),U)          3  Other Proc CPT Code  2;1  Ptr 81
     128 ;
     129 S DA=IEN,(FILE,DIC)=130,SUB=130.16,DR=.42,DR(SUB)=".01;3",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"
     130 K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),13,SRI)) Q:+SRI=0  D
     131 . S DA(SUB)=SRI
     132 . D EN^DIQ1 S SRM=+($G(REC(130,IEN,130.16,SRI,3,"I")))
     133 . S:SRM>0 REC(130,IEN,130.16,SRI,3,"N")=$P($$CPT^ICPTCOD(+SRM,$P($G(^SRF(IEN,0)),"^",9)),"^",3)
     134 . N SRT,SRS,SRC S SRM=$G(REC(130,IEN,130.16,SRI,3,"I")) I SRM>0 D
     135 . . S SRC=$$CPT^ICPTCOD(SRM,$P($G(^SRF(IEN,0)),"^",9)),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3))
     136 . . S REC(130,IEN,130.16,SRI,3,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3)
     137 . . S SRC=$P(SRC,"^",2)
     138 . . S SRT=$$EN2^SROGMTS0($G(REC(130,IEN,130.16,SRI,.01,"E")))
     139 . . S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_$$EN2^SROGMTS0(SRS)
     140 . . S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")"
     141 . . S REC(130,IEN,130.16,SRI,3,"N")=SRS
     142 . . S REC(130,IEN,130.16,SRI,.01,"S")=SRT
     143 . . S REC(130,IEN,130.16,SRI,3,"S")=SRCS
     144 . ;
     145 . ;     ^SRF(8,13,2,"MOD",0)       4  Oth Proc CPT Mod   MOD;0  130.164
     146 . ;     ^SRF(8,13,2,"MOD",1,0)   .01  Oth Proc CPT Mod     0;1  Ptr 81.3
     147 . ;
     148 . I SRCPTM D
     149 . . N SRJ S SRJ=0 F  S SRJ=$O(^SRF(+($G(IEN)),13,SRI,"MOD",SRJ)) Q:+SRJ=0  D
     150 . . . 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"
     151 . . . D EN^DIQ1
     152 . . . S SRM=+($G(REC(130,IEN,130.16,SRI,130.164,SRJ,.01,"I")))
     153 . . . I SRM>0 N SRMOD1 D
     154 . . . . S SRMOD1=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9))
     155 . . . . S SRC=$P(SRMOD1,"^",2)
     156 . . . . S SRS=$P(SRMOD1,"^",3)
     157 . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MID")=SRC
     158 . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MOD")=SRS
     159 . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"X")=SRC_"^"_SRS
     160 . . . . S SRT=$$EN2^SROGMTS0(SRS) S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")"
     161 . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"S")=SRT
     162 . . . K REC(130,IEN,130.16,SRI,130)
     163 Q
     164SG(X) ; Surgical (Operative) Record
     165 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

    r613 r623  
    1 SROMED  ;BIR/MAM - ENTER/EDIT MEDICATIONS ;01/30/08
    2         ;;3.0; Surgery ;**21,44,79,100,151,166**;24 Jun 93;Build 7
    3         ;
    4         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
    5         D ^SROLOCK G:SROLOCK END Q:'$D(SRTN)
    6         N SRLCK S SRLCK=$$LOCK^SROUTL(SRTN) I 'SRLCK G END
    7 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 !!
    8         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."
    9         I M="?" W !!,"Enter '??' to get a list of available drugs.",! D RET G:SRQ END G START
    10         I M?.E1C.E W !!,"Your answer has a control character in it, please re-type it.",! D RET G:SRQ END G START
    11         S (X,SRMM)=SRM D
    12         .N SRDIC,SRD S SRDIC=50,SRDIC(0)="EMQSZ",SRD="B^C" D MIX^PSSDI(50,"SR",.SRDIC,SRD,X,,DT)
    13         S SRM=$S(Y<0:"",1:$P(Y,"^",2))
    14         I SRM="",SRMM'["?" W !!,"The Drug '",SRMM,"' does not exist in your Drug file.  Please re-enter. " D RET G:SRQ END G START
    15         I SRMM="??" D RET G:SRQ END G START
    16         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
    17 FLAG    S SRF=$S('$D(SRT)!('$D(SRD))!('$D(SRR)):0,1:1) I 'SRF W !!!,"NO ACTION TAKEN",! H 2 G END
    18 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
    19         G START
    20 END     W @IOF D ^SRSKILL D:$G(SRLCK) UNLOCK^SROUTL(SRTN)
    21         Q
    22 RET     R !!,"Press RETURN to Continue.   ",Z:DTIME S:'$T Z="^" S:Z="^" SRQ=1 Q
    23         Q
    24 ROUTE   ; check for route of administration
    25         Q:SRR=""  N SRHELP,SRVALUE D CHK^DIE(130.34,4,"E",SRR,.SRVALUE) I SRVALUE'="^" S SRR=SRVALUE Q
    26         D HELP^DIE(130.34,"",4,"S","SRHELP(1)")
    27         W !!,"Route entered is not one of the available choices.",!,"Please enter medication route again.",!!
    28         I $G(SRHELP(1,"DIHELP")) F I=1:1:SRHELP(1,"DIHELP") W SRHELP(1,"DIHELP",I),!
    29         S DIR("A")="Enter ROUTE",DIR(0)="130.34,4O" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRR="" Q
    30         S SRR=$P(Y,"^")
    31         Q
    32 TIME    ; check for time
    33         K %DT S X=SRT,%DT="R" D ^%DT I Y>0 Q
    34          W:SRT="" !!,"A time MUST be entered !"
    35         I '(SRT?1N!(SRT?2N&(SRT<13))!(SRT?4N)!(SRT?3N)!(SRT?2N1":"2N)!(SRT?1N1":"2N))!(+SRT>2400)!(SRT="") S SRF=1
    36         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."
    37 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
    38         Q
    39 DOSE    ; check dosage
    40         Q:SRD=""  I $L(SRD)>15!($L(SRD)<1) W !!,"Dosage entered incorrectly." S SRF=1
    41         I SRD="?" W !!,"Dosage must be 1 to 15 characters in length, i.e. 15 mg." S SRF=1
    42 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
    43         Q
    44 SCR(SRFL,SRPK)  ; screening for fields point to the DRUG file (#50)
    45         N SRDT,SRN0,SRNODE,SROK,SRY S SROK=0,SRY=+Y K ^TMP($J,"SR")
    46         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)
    47         D DATA^PSS50(SRY,,$S($G(SRFL):SRDT,1:""),,,"SR")
    48         I SRPK="S" D  Q SROK
    49         .S SRNODE=$P($G(^TMP($J,"SR",SRY,63)),"^") K ^TMP($J,"SR") I SRNODE["S" S SROK=1
    50         S SROK=$S($P($G(^TMP($J,"SR",0)),"^")=-1:0,1:1) K ^TMP($J,"SR") Q SROK
     1SROMED ;B'HAM ISC/MAM - ENTER/EDIT MEDICATIONS ; [ 01/30/01  12:22 AM ]
     2 ;;3.0; Surgery ;**21,44,79,100,151**;24 Jun 93
     3 ;
     4 ; Reference to ^PSDRUG supported by DBIA #221
     5 ;
     6 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
     7 D ^SROLOCK G:SROLOCK END Q:'$D(SRTN)
     8 N SRLCK S SRLCK=$$LOCK^SROUTL(SRTN) I 'SRLCK G END
     9START 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 !!
     10 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."
     11 I M="?" W !!,"Enter '??' to get a list of available drugs.",! D RET G:SRQ END G START
     12 I M?.E1C.E W !!,"Your answer has a control character in it, please re-type it.",! D RET G:SRQ END G START
     13 S (X,SRMM)=SRM D
     14 .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
     15 .S DIC="^PSDRUG(",DIC(0)="QEZM",DIC("S")="I $S('$G(^PSDRUG(Y,""I"")):1,DT'>^(""I""):1,1:0)" D ^DIC K DIC
     16 S SRM=$S(Y<0:"",1:$P(Y,"^",2))
     17 I SRM="",SRMM'["?" W !!,"The Drug '",SRMM,"' does not exist in your Drug file.  Please re-enter. " D RET G:SRQ END G START
     18 I SRMM="??" D RET G:SRQ END G START
     19 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
     20FLAG S SRF=$S('$D(SRT)!('$D(SRD))!('$D(SRR)):0,1:1) I 'SRF W !!!,"NO ACTION TAKEN",! H 2 G END
     21DIE 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
     22 G START
     23END W @IOF D ^SRSKILL D:$G(SRLCK) UNLOCK^SROUTL(SRTN)
     24 Q
     25RET R !!,"Press RETURN to Continue.   ",Z:DTIME S:'$T Z="^" S:Z="^" SRQ=1 Q
     26 Q
     27ROUTE ; check for route of administration
     28 Q:SRR=""  N SRHELP,SRVALUE D CHK^DIE(130.34,4,"E",SRR,.SRVALUE) I SRVALUE'="^" S SRR=SRVALUE Q
     29 D HELP^DIE(130.34,"",4,"S","SRHELP(1)")
     30 W !!,"Route entered is not one of the available choices.",!,"Please enter medication route again.",!!
     31 I $G(SRHELP(1,"DIHELP")) F I=1:1:SRHELP(1,"DIHELP") W SRHELP(1,"DIHELP",I),!
     32 S DIR("A")="Enter ROUTE",DIR(0)="130.34,4O" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRR="" Q
     33 S SRR=$P(Y,"^")
     34 Q
     35TIME ; check for time
     36 K %DT S X=SRT,%DT="R" D ^%DT I Y>0 Q
     37  W:SRT="" !!,"A time MUST be entered !"
     38 I '(SRT?1N!(SRT?2N&(SRT<13))!(SRT?4N)!(SRT?3N)!(SRT?2N1":"2N)!(SRT?1N1":"2N))!(+SRT>2400)!(SRT="") S SRF=1
     39 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."
     40T1 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
     41 Q
     42DOSE ; check dosage
     43 Q:SRD=""  I $L(SRD)>15!($L(SRD)<1) W !!,"Dosage entered incorrectly." S SRF=1
     44 I SRD="?" W !!,"Dosage must be 1 to 15 characters in length, i.e. 15 mg." S SRF=1
     45D1 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
     46 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROWL.m

    r613 r623  
    1 SROWL   ;B'HAM ISC/MAM - ENTER PATIENT ON WAITING LIST ; 4/18/07 11:55am
    2         ;;3.0;Surgery;**58,119,162**;24 Jun 93;Build 4
    3         ;
    4 ENTER   ; enter a patient on the waiting list
    5         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)
    6         S SRSSNM=$P(^SRO(137.45,SRSS1,0),"^")
    7 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
    8         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
    9         I $O(^SRO(133.8,"AP",DFN,SRSS,0)) D CHK G:"Yy"'[ECYN END
    10 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
    11         S SROPER=Y
    12         W ! D NOW^%DTC S SRSDT=%
    13         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
    14         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
    15         D WL^SROPCE1 I SRSOUT G DEL
    16         W @IOF,!,SRNM_" has been entered on the waiting list",!,"for "_SRSSNM
    17 END     D PRESS,^SRSKILL W @IOF
    18         Q
    19 PRESS   W ! K DIR S DIR("A")="Press RETURN to continue  ",DIR(0)="FOA" D ^DIR K DIR
    20         Q
    21 DEL     S DA(1)=SRSS,DA=SROFN,DIK="^SRO(133.8,"_DA(1)_",1," D ^DIK
    22         W @IOF,!,"Classification information is incomplete.  No action taken." G END
    23         Q
    24 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."
    25         W !!,"Press RETURN to continue  " R X:DTIME
    26         Q
    27 CHK     ; check for existing entries for a patient
    28         W @IOF,!,"Procedure(s) already entered for "_SRNM,!,"on the Waiting List for "_SRSSNM,!
    29         S SROFN=0 F  S SROFN=$O(^SRO(133.8,"AP",DFN,SRSS,SROFN)) Q:'SROFN  D LIST
    30         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
    31         S ECYN=$E(ECYN) S:"y"[ECYN ECYN="Y"
    32         I "YNn"'[ECYN D HELP G CHK
    33         Q
    34 LIST    ; list existing procedures for specialty selected
    35         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)
    36         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=""
    37         W !,SRNM,?40,"Date Entered on List:",?66,SRDT,!,?3,SROP(1),?40,"Tentative Operation Date: ",?66,SROPDT
    38         I $D(SROP(2)) W !,?3,SROP(2)
    39         W !
    40         Q
    41 LOOP    ; break procedure if greater than 36 characters
    42         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
    43         Q
    44 REFPHY    ; Look up Referring Physician in "New Person" file with filter and auto-populate Referring Physician demographic fields
    45         N SRCONT,Y,SRDEMO
    46         S SRCONT=""
    47 PRMPT   R !,"Is this a VA Physician from this facility?  (Y/N): <Y> ",SRCONT:DTIME I '$T Q
    48         I SRCONT["?" D  G PRMPT
    49         .W !!,"Enter 'Y' if you would like to select the Referring Physician from this facility's VA personnel.",!,"Enter 'N' to continue data entry.",!
    50         S:SRCONT="" SRCONT="Y"
    51         I SRCONT="^" S X="" Q
    52         Q:(SRCONT'["Y")&(SRCONT'["y")
    53         ; Store FileMan variables and arrays
    54         M SRDABAK=DA,SRDICBAK=DIC,SRDZERO=D0,SRDRBAK=DR,SRXBAK=X,SRDOBAK=DO
    55         ; Setup variables and call ^DIC to lookup REFERRING PHYSICIAN from NEW PERSON file
    56         S DIC="^VA(200,",DIC(0)="E",DIC("B")=X
    57         D ^DIC
    58         ; Restore FileMan's variables and arrays
    59         M DA=SRDABAK,DIC=SRDICBAK,D0=SRDZERO,DR=SRDRBAK,X=SRXBAK,DO=SRDOBAK
    60         K SRCONT,SRDABAK,SRDICBAK,SRDZERO,SRDRBAK,SRXBAK,SRDOBAK
    61         Q:Y="-1"        ; Quit if no record was selected from the NEW PERSON file
    62         S SRNPREC=$P(Y,U,1)_","   ;The record number of the NEW PERSON file
    63         ; Retrieve demographic data from the NEW PERSON file.
    64         D GETS^DIQ(200,SRNPREC,".01:.116;.132","","SRDEMO")
    65         ; Build SRDEMO array for "stuffing" into REFERRING PHYSICIAN demographic fields
    66         S X=SRDEMO(200,SRNPREC,".01")                       ;Name
    67         S SRDEMO(1)=SRDEMO(200,SRNPREC,".111")        ;Address
    68         S:$L(SRDEMO(200,SRNPREC,".112"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".112")   ;Concatenate Address 2 to single address
    69         S:$L(SRDEMO(200,SRNPREC,".113"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".113")   ;Concatenate Address 3 to single address
    70         S SRDEMO(1)=$E(SRDEMO(1),1,75)
    71         S SRDEMO(2)=SRDEMO(200,SRNPREC,".114")        ;City
    72         S SRDEMO(3)=SRDEMO(200,SRNPREC,".115")        ;State
    73         S SRDEMO(4)=SRDEMO(200,SRNPREC,".116")        ;Zip
    74         S SRDEMO(5)=SRDEMO(200,SRNPREC,".132")        ;Office Phone
    75         ; Set up DR array that FileMan will use, with a call to ^DIE, after this subroutine Quits to "stuff" the demographic data.
    76         ; all fields except STATE will ignore input transform (SR*3.0*162)
    77         S DIC("DR")="1////"_SRDEMO(1)_";2////"_SRDEMO(2)_";3///"_SRDEMO(3)_";4////"_SRDEMO(4)_";5////"_SRDEMO(5)_";6////"_$P(Y,U,1)
    78         S DIC(0)="Z"    ;Tells FileMan to file the data without any more user input
    79         Q
     1SROWL ;B'HAM ISC/MAM - ENTER PATIENT ON WAITING LIST ;13 Feb 1989  11:32 AM
     2 ;;3.0;Surgery;**58,119**;24 Jun 93
     3ENTER ; enter a patient on the waiting list
     4 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)
     5 S SRSSNM=$P(^SRO(137.45,SRSS1,0),"^")
     6PAT W ! S DIC=2,DIC(0)="QEAMZ",DIC("A")="  Select Patient: " D ^DIC K DIC I Y<0 W !!,"No action taken." G END
     7 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
     8 I $O(^SRO(133.8,"AP",DFN,SRSS,0)) D CHK G:"Yy"'[ECYN END
     9OP 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
     10 S SROPER=Y
     11 W ! D NOW^%DTC S SRSDT=%
     12 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
     13 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
     14 D WL^SROPCE1 I SRSOUT G DEL
     15 W @IOF,!,SRNM_" has been entered on the waiting list",!,"for "_SRSSNM
     16END D PRESS,^SRSKILL W @IOF
     17 Q
     18PRESS W ! K DIR S DIR("A")="Press RETURN to continue  ",DIR(0)="FOA" D ^DIR K DIR
     19 Q
     20DEL S DA(1)=SRSS,DA=SROFN,DIK="^SRO(133.8,"_DA(1)_",1," D ^DIK
     21 W @IOF,!,"Classification information is incomplete.  No action taken." G END
     22 Q
     23HELP 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."
     24 W !!,"Press RETURN to continue  " R X:DTIME
     25 Q
     26CHK ; check for existing entries for a patient
     27 W @IOF,!,"Procedure(s) already entered for "_SRNM,!,"on the Waiting List for "_SRSSNM,!
     28 S SROFN=0 F  S SROFN=$O(^SRO(133.8,"AP",DFN,SRSS,SROFN)) Q:'SROFN  D LIST
     29 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
     30 S ECYN=$E(ECYN) S:"y"[ECYN ECYN="Y"
     31 I "YNn"'[ECYN D HELP G CHK
     32 Q
     33LIST ; list existing procedures for specialty selected
     34 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)
     35 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=""
     36 W !,SRNM,?40,"Date Entered on List:",?66,SRDT,!,?3,SROP(1),?40,"Tentative Operation Date: ",?66,SROPDT
     37 I $D(SROP(2)) W !,?3,SROP(2)
     38 W !
     39 Q
     40LOOP ; break procedure if greater than 36 characters
     41 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
     42 Q
     43REFPHY   ; Look up Referring Physician in "New Person" file with filter and auto-populate Referring Physician demographic fields
     44 N SRCONT,Y,SRDEMO
     45 S SRCONT=""
     46PRMPT R !,"Is this a VA Physician from this facility?  (Y/N): <Y> ",SRCONT:DTIME I '$T Q
     47 I SRCONT["?" D  G PRMPT
     48 .W !!,"Enter 'Y' if you would like to select the Referring Physician from this facility's VA personnel.",!,"Enter 'N' to continue data entry.",!
     49 S:SRCONT="" SRCONT="Y"
     50 I SRCONT="^" S X="" Q
     51 Q:(SRCONT'["Y")&(SRCONT'["y")
     52 ; Store FileMan variables and arrays
     53 M SRDABAK=DA,SRDICBAK=DIC,SRDZERO=D0,SRDRBAK=DR,SRXBAK=X,SRDOBAK=DO
     54 ; Setup variables and call ^DIC to lookup REFERRING PHYSICIAN from NEW PERSON file
     55 S DIC="^VA(200,",DIC(0)="E",DIC("B")=X
     56 D ^DIC
     57 ; Restore FileMan's variables and arrays
     58 M DA=SRDABAK,DIC=SRDICBAK,D0=SRDZERO,DR=SRDRBAK,X=SRXBAK,DO=SRDOBAK
     59 K SRCONT,SRDABAK,SRDICBAK,SRDZERO,SRDRBAK,SRXBAK,SRDOBAK
     60 Q:Y="-1"        ; Quit if no record was selected from the NEW PERSON file
     61 S SRNPREC=$P(Y,U,1)_","   ;The record number of the NEW PERSON file
     62 ; Retrieve demographic data from the NEW PERSON file.
     63 D GETS^DIQ(200,SRNPREC,".01:.116;.132","","SRDEMO")
     64 ; Build SRDEMO array for "stuffing" into REFERRING PHYSICIAN demographic fields
     65 S X=SRDEMO(200,SRNPREC,".01")                       ;Name
     66 S SRDEMO(1)=SRDEMO(200,SRNPREC,".111")        ;Address
     67 S:$L(SRDEMO(200,SRNPREC,".112"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".112")   ;Concatenate Address 2 to single address
     68 S:$L(SRDEMO(200,SRNPREC,".113"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".113")   ;Concatenate Address 3 to single address
     69 S SRDEMO(1)=$E(SRDEMO(1),1,75)
     70 S SRDEMO(2)=SRDEMO(200,SRNPREC,".114")        ;City
     71 S SRDEMO(3)=SRDEMO(200,SRNPREC,".115")        ;State
     72 S SRDEMO(4)=SRDEMO(200,SRNPREC,".116")        ;Zip
     73 S SRDEMO(5)=SRDEMO(200,SRNPREC,".132")        ;Office Phone
     74 ; Set up DR array that FileMan will use, with a call to ^DIE, after this subroutine Quits to "stuff" the demographic data.
     75 S DIC("DR")="1///"_SRDEMO(1)_";2///"_SRDEMO(2)_";3///"_SRDEMO(3)_";4///"_SRDEMO(4)_";5///"_SRDEMO(5)_";6///"_$P(Y,U,1)
     76 S DIC(0)="Z"    ;Tells FileMan to file the data without any more user input
     77 Q
  • WorldVistAEHR/trunk/r/SURGERY-SR/SROXR4.m

    r613 r623  
    1 SROXR4  ;BIR/MAM - CROSS REFERENCES ;11/05/07
    2         ;;3.0; Surgery ;**62,83,100,153,166**;24 Jun 93;Build 7
    3         Q
    4 PRO     ; stuff default prosthesis info
    5         I '$D(SRTN) Q
    6         S ^SRF(SRTN,1,DA,0)=^SRF(SRTN,1,DA,0)_"^"_$P(^SRO(131.9,X,0),"^",2,99)
    7         I $D(^SRO(131.9,X,1)) S ^SRF(SRTN,1,DA,1)=^(1)
    8         Q
    9 CAN     ; 'SET' logic of the 'ACAN' x-ref on the 'CANCEL REASON'
    10         ; field in the SURGERY file (130)
    11         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"
    12         I $P(^SRF(DA,30),"^",3)="" S $P(^SRF(DA,30),"^",3)=DUZ
    13         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
    14         Q
    15 KCAN    ; 'KILL' logic of the 'ACAN' x-ref on the 'CANCEL REASON'
    16         ; field in the SURGERY file (130)
    17         S $P(^SRF(DA,30),"^",2)="" I '$P($G(^SRF(DA,30)),"^") S $P(^SRF(DA,30),"^",3)=""
    18         Q
    19 AS      ; 'SET' logic of the 'AS' x-ref on the SCHEDULED START TIME
    20         ; field in the SURGERY file (130)
    21         S OR=$P(^SRF(DA,0),"^",2) I 'OR Q
    22         S ^SRF("AS",OR,X,DA)=""
    23         Q
    24 KAS     ; 'KILL' logic of the 'AS' x-ref on the SCHEDULED FINISH TIME
    25         ; field in the SURGERY file (130)
    26         S OR=$P(^SRF(DA,0),"^",2) I 'OR Q
    27         K ^SRF("AS",OR,X,DA)
    28         Q
    29 SCH     ; 'SET' logic of the 'AC' x-ref of the REQUIRED FIELDS FOR SCHEDULING
    30         ; field in the SURGERY SITE PARAMETERS file (133)
    31         S MM=$O(^DD(130,"B",X,0)),$P(^SRO(133,DA(1),4,DA,0),"^",2)=MM K MM
    32         Q
    33 KSCH    ; 'KILL' logic of the 'AC' x-ref of the REQUIRED FIELDS FOR SCHEDULING
    34         ; field in the SURGERY SITE PARAMETERS file (133)
    35         S $P(^SRO(133,DA(1),4,DA,0),"^",2)=""
    36         Q
    37 RISK    ; clean up risk data for canceled cases
    38         S DIE=130,DR="102///@;235///@;284///@;323///@" D ^DIE K DR,DA S ZTREQ="@"
    39         Q
    40 AQ      ; set logic for AQ x-ref
    41         N SRTD,SRLO D AQDT I SRTD'<SRLO S $P(^SRF(DA,.4),"^",2)="R",^SRF("AQ",SRTD,DA)=""
    42         Q
    43 KAQ     ; kill logic for AQ x-ref
    44         N SRTD,SRLO D AQDT S $P(^SRF(DA,.4),"^",2)="" K ^SRF("AQ",SRTD,DA)
    45         Q
    46 AQDT    ; get quarterly transmission date
    47         N SRDAY,SRSDATE,SRQTR,SRX,SRYR S SRSDATE=$E($P(^SRF(DA,0),"^",9),1,7)
    48         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
    49         S SRTD=SRYR_$S(SRQTR=1:"0214",SRQTR=2:"0515",SRQTR=3:"0814",1:"1114")
    50         S SRX=$E(DT,1,3),SRLO=SRX-1_"0214"
    51         Q
    52 AQ1     ; set logic for AQ1 x-ref
    53         I X="R" N SRTD,SRLO D AQDT I SRTD'<SRLO S ^SRF("AQ",SRTD,DA)=""
    54         Q
    55 KAQ1    ; kill logic for AQ1 x-ref
    56         N SRTD,SRLO D AQDT K ^SRF("AQ",SRTD,DA)
    57         Q
    58 AT      ; set logic for AT x-ref on DATE OF LAST TRANSMISSION
    59         N SRX S ^SRF("AT",X,DA)=""
    60         S SRX=$P($G(^SRF(DA,"RA")),"^",4) I SRX,SRX'=X K ^SRF("AT",SRX,DA)
    61         Q
    62 KAT     ; kill logic for AT x-ref on DATE OF LAST TRANSMISSION
    63         N SRX K ^SRF("AT",X,DA)
    64         S SRX=$P($G(^SRF(DA,"RA")),"^",4) I SRX,SRX'=X K ^SRF("AT",SRX,DA)
    65         Q
    66 AT1     ; set logic for AT x-ref on DATE TRANSMITTED
    67         N SRX S SRX=$P($G(^SRF(DA,"RA")),"^",8) I SRX Q
    68         S ^SRF("AT",X,DA)=""
    69         Q
    70 KAT1    ; kill logic for AT x-ref on DATE TRANSMITTED
    71         N SRX S SRX=$P($G(^SRF(DA,"RA")),"^",8)
    72         I SRX'=X K ^SRF("AT",X,DA)
    73         Q
     1SROXR4 ;BIR/MAM - CROSS REFERENCES ;03/15/06
     2 ;;3.0; Surgery ;**62,83,100,153**;24 Jun 93;Build 11
     3 Q
     4PRO ; stuff default prosthesis info
     5 I '$D(SRTN) Q
     6 S ^SRF(SRTN,1,DA,0)=^SRF(SRTN,1,DA,0)_"^"_$P(^SRO(131.9,X,0),"^",2,99)
     7 I $D(^SRO(131.9,X,1)) S ^SRF(SRTN,1,DA,1)=^(1)
     8 Q
     9CAN ; 'SET' logic of the 'ACAN' x-ref on the 'CANCEL REASON'
     10 ; field in the SURGERY file (130)
     11 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"
     12 I $P(^SRF(DA,30),"^",3)="" S $P(^SRF(DA,30),"^",3)=DUZ
     13 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
     14 Q
     15KCAN ; 'KILL' logic of the 'ACAN' x-ref on the 'CANCEL REASON'
     16 ; field in the SURGERY file (130)
     17 S $P(^SRF(DA,30),"^",2)="" I '$P($G(^SRF(DA,30)),"^") S $P(^SRF(DA,30),"^",3)=""
     18 Q
     19AS ; 'SET' logic of the 'AS' x-ref on the SCHEDULED START TIME
     20 ; field in the SURGERY file (130)
     21 S OR=$P(^SRF(DA,0),"^",2) I 'OR Q
     22 S ^SRF("AS",OR,X,DA)=""
     23 Q
     24KAS ; 'KILL' logic of the 'AS' x-ref on the SCHEDULED FINISH TIME
     25 ; field in the SURGERY file (130)
     26 S OR=$P(^SRF(DA,0),"^",2) I 'OR Q
     27 K ^SRF("AS",OR,X,DA)
     28 Q
     29SCH ; 'SET' logic of the 'AC' x-ref of the REQUIRED FIELDS FOR SCHEDULING
     30 ; field in the SURGERY SITE PARAMETERS file (133)
     31 S MM=$O(^DD(130,"B",X,0)),$P(^SRO(133,DA(1),4,DA,0),"^",2)=MM K MM
     32 Q
     33KSCH ; 'KILL' logic of the 'AC' x-ref of the REQUIRED FIELDS FOR SCHEDULING
     34 ; field in the SURGERY SITE PARAMETERS file (133)
     35 S $P(^SRO(133,DA(1),4,DA,0),"^",2)=""
     36 Q
     37RISK ; clean up risk data for canceled cases
     38 S DIE=130,DR="102///@;235///@;284///@;323///@" D ^DIE K DR,DA S ZTREQ="@"
     39 Q
     40AQ ; set logic for AQ x-ref
     41 N SRTD,SRLO D AQDT I SRTD'<SRLO S $P(^SRF(DA,.4),"^",2)="R",^SRF("AQ",SRTD,DA)=""
     42 Q
     43KAQ ; kill logic for AQ x-ref
     44 N SRTD,SRLO D AQDT S $P(^SRF(DA,.4),"^",2)="" K ^SRF("AQ",SRTD,DA)
     45 Q
     46AQDT ; get quarterly transmission date
     47 N SRDAY,SRSDATE,SRQTR,SRX,SRYR S SRSDATE=$E($P(^SRF(DA,0),"^",9),1,7)
     48 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
     49 S SRTD=SRYR_$S(SRQTR=1:"0214",SRQTR=2:"0515",SRQTR=3:"0814",1:"1114")
     50 S SRX=$E(DT,1,3),SRLO=SRX-1_"0214"
     51 Q
     52AQ1 ; set logic for AQ1 x-ref
     53 I X="R" N SRTD,SRLO D AQDT I SRTD'<SRLO S ^SRF("AQ",SRTD,DA)=""
     54 Q
     55KAQ1 ; kill logic for AQ1 x-ref
     56 N SRTD,SRLO D AQDT K ^SRF("AQ",SRTD,DA)
     57 Q
Note: See TracChangeset for help on using the changeset viewer.