source: WorldVistAEHR/trunk/r/SURGERY-SR/SRONEW.m@ 686

Last change on this file since 686 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.8 KB
Line 
1SRONEW ;B'HAM ISC/MAM - ENTER A NEW CASE ;01/29/01 1:09 PM
2 ;;3.0; Surgery ;**3,23,26,30,47,58,48,67,107,100,144**;24 Jun 93
3 ;
4 ; Reference to ^TMP("CSLSUR1" supported by DBIA #3498
5 ;
6DEAD S SRSOUT=0,X=$P($G(VADM(6)),"^") I X D I SRSOUT D ^SRSKILL G ^SROP
7 .S SRDEATH=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) W @IOF,!,?1,VADM(1)_" "_VA("PID")_" * Died "_SRDEATH_" *"
8 .W !!,$C(7) K DIR S DIR("A",1)=">>> The patient you have selected died on "_SRDEATH_"."
9 .S DIR("A")=" Are you sure this is the correct patient ? ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR
10 .W @IOF I 'Y!$D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
11 .W !,"Entering a new surgical case for "_VADM(1)_".",!!
12DATE K %DT W ! S %DT("A")="Select the Date of Operation: ",%DT="AEX" D ^%DT I Y<0 W !!,"When entering a new surgery case, a date MUST be entered. If you do not",!,"know the date of operation, enter this patient on the Waiting List."
13 I Y<0 D CONT G:"Yy"'[SRYN END G DATE
14 G:Y'>0 END S SRSDATE=Y
15 S SRSC1=1 K SRCTN S SRSDPT=DFN,SRSCC="" D CON G:SRSCC="^" END
16OP D ^SROPROC I SRSOUT G END
17 S SRPRIN=SRSOP
18OPD ; Principal Preoperative Diagnosis
19 K DIR S DIR(0)="130,32",DIR("A")="Principal Preoperative Diagnosis" D ^DIR K DIR I $D(DTOUT)!(X="^") S SRSOUT=1 G END
20 I Y=""!(X["^") W !!,"A Principal Preoperative Diagnosis must be entered",!,"when creating a new case. Enter '^' to exit.",! G OPD
21 I X[";" W !,"The Principal Preoperative Diagnosis cannot contain a semicolon (;).",!,"Please re-enter the Diagnosis, using commas in place of the semicolons." G OPD
22 S SRSOPD=Y
23 W !!,"The information entered into the Principal Preoperative Diagnosis field",!,"has been transferred into the Indications for Operation field.",!,"The Indications for Operation field can be updated later if necessary.",!
24DOC W ! S DIC("A")="Select Surgeon: ",DIC=200,DIC(0)="QEAM",SRSDOC="" D ^DIC K DIC("A") I $D(DTOUT)!(X="^") S SRSOUT=1 G END
25 I Y<0!(X["^") W !!,"A Surgeon must be entered when creating a case. Enter '^' to exit.",! G DOC
26 S (DA,SRSDOC)=+Y
27 S RESTRICT="130,.14",Y=SRSDOC K SROK D KEY^SROXPR I '$D(SROK) W !!,"The person you selected does not have the appropriate keys necessary to be",!,"entered as a surgeon. Please make another selection.",! K SRSDOC,DA,DIC G DOC
28CASE ; create case in SURGERY file
29 K DA,DIC,DD,DO,DINUM,SRTN S X=DFN,DIC="^SRF(",DIC(0)="L" D FILE^DICN K DIC S SRTN=+Y G:'$$LOCK^SROUTL(SRTN) DEL
30 S ^SRF(SRTN,8)=SRSITE("DIV"),^SRF(SRTN,"OP")=""
31 K DIE,DR S DA=SRTN,DIE=130,DR=".09////"_SRSDATE_";26////"_SRPRIN_";68////"_SRPRIN_";.14////"_SRSDOC D ^DIE K DR
32ASURG ; attending surgeon
33 K DIR S DIR(0)="130,.164",DIR("A")="Attending Surgeon" D ^DIR K DIR I $D(DTOUT)!(X="^") S SRSOUT=1 G DEL
34 I Y=""!(X["^") W !!,"An Attending Surgeon must be entered when creating a case. Enter '^' to exit.",! G ASURG
35 S SRATTND=+Y
36SPEC W ! K DIC S DIC=137.45,DIC(0)="QEAMZ",DIC("A")="Select Surgical Specialty: ",DIC("S")="I '$P(^(0),""^"",3)" D ^DIC I $D(DTOUT)!(X="^") S SRSOUT=1 G DEL
37 I Y<0!(X["^") W !!,"To create a surgical case, a Surgical Specialty MUST be selected. Enter '^'",!,"to exit.",! G SPEC
38 S SRSS=+Y
39UPDATE ; update case in SURGERY file
40 S DA=SRTN,DIE=130,DR=".04////"_SRSS_";.164////"_SRATTND_";32////"_SRSOPD D ^DIE K DR
41 S SRSOPD(1)=SRSOPD D WP^DIE(130,SRTN_",",55,"A","SRSOPD")
42 ; Brief Clinical History
43 K DR S DR="60T",DA=SRTN,DIE=130 W ! D ^DIE
44 K DR,DA S DR="[SRO-NOCOMP]",DA=SRTN,DIE=130 D ^DIE K DR
45 S ^SRF(SRTN,8)=SRSITE("DIV") D ^SROXRET
46DIE D ^SROBLOD K DR,DIE,DA S DR="38////"_BLOOD_";40////"_CROSSM,DA=SRTN,DIE=130 D ^DIE K DR,DA,DIE
47 S DR="[SRSRES1]",DIE=130,DA=SRTN D ^DIE,RT S ST="NEW SURGERY" D EN2^SROVAR
48 S SPD=$$CHKS^SRSCOR(SRTN)
49 K DR S DR="[SRSRES-ENTRY]",DIE=130,DA=SRTN D ^SRCUSS,RISK^SROAUTL3,^SROPCE1
50 I SPD'=$$CHKS^SRSCOR(SRTN) S ^TMP("CSLSUR1",$J)=""
51 I $D(SRCTN) D
52 .S SRCTN(.02)=$P(^SRF(SRCTN,0),"^",2),SRCTN(10)=$P($G(^SRF(SRCTN,31)),"^",4),SRCTN(11)=$P($G(^SRF(SRCTN,31)),"^",5)
53 .S DIE=130,DR=".02////"_SRCTN(.02)_";10////"_SRCTN(10)_";11////"_SRCTN(11)_";35////"_SRCTN,DA=SRTN D ^DIE
54 .S DR="35////"_SRTN,DA=SRCTN,DIE=130 D ^DIE
55 D UNLOCK^SROUTL(SRTN),^SROERR
56 Q
57DEL S DA=SRTN,DIK="^SRF(" D ^DIK
58END K SRTN D ^SRSKILL
59 Q
60CONT ; continue new entry ?
61 W !!,"Do you want to continue ? YES// " R SRYN:DTIME I '$T S SRYN="N" Q
62 S SRYN=$E(SRYN) S:SRYN="" SRYN="Y" I "YyNn"'[SRYN W !!,"Enter RETURN if you want to re-enter a date and continue creating a new",!,"case, or 'NO' to leave this option." G CONT
63 Q
64RT ;start RT logging
65 I $D(XRTL) S XRTN="SRONEW" D T0^%ZOSV
66 Q
67CON ; check for concurrent case
68 S SRSCON=0,SRDT=SRSDATE-.0001 F S SRDT=$O(^SRF("AC",SRDT)) Q:'SRDT!($E(SRDT,1,7)'=SRSDATE)!(SRSCON) S (SRSCC,SRSCON)=0 F S SRSCC=$O(^SRF("AC",SRDT,SRSCC)) Q:'SRSCC D Q:SRSCON
69 .I ^(SRSCC)=SRSDPT,'$P($G(^SRF(SRSCC,"CON")),"^"),$P($G(^SRF(SRSCC,"NON")),"^")'="Y",'$P($G(^SRF(SRSCC,30)),"^"),'$P($G(^SRF(SRSCC,.2)),"^",12),'$P($G(^SRF(SRSCC,"LOCK")),"^") S SRSCON=1
70 .I SRSCON D CC^SRSREQ I '$D(SRCTN) S SRSCON=0
71 Q
Note: See TracBrowser for help on using the repository browser.