source: FOIAVistA/tag/r/SURGERY-SR/SROUTL.m@ 813

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

initial load of FOIAVistA 6/30/08 version
File size: 6.5 KB
Line 
1SROUTL ;BIR/ADM - UTILITY ROUTINE ;02/14/07
2 ;;3.0; Surgery ;**58,62,69,77,50,88,94,100,129,134,141,142,160**;24 Jun 93;Build 7
3 ;
4 ; Reference to $P(^SC(SRLOC,0),"^",17) supported by DBIA #964
5 ;
6 Q
7HDR ; display menu header
8 Q:'$D(SRSITE)
9 N DFN,SRCNT,SRNUM,SRSDATE,SRX,Y S (SRCNT,SRX)=0 F S SRX=$O(^SRO(133,SRX)) Q:'SRX I '$P($G(^SRO(133,SRX,0)),"^",21) S SRCNT=SRCNT+1
10 I SRCNT>1 S SRNUM=$$GET1^DIQ(4,SRSITE("DIV"),99) S Y="Division: "_SRSITE("SITE")_" ("_SRNUM_")" W @IOF,!,?(80-$L(Y)\2),Y
11 I $G(SRTN) D
12 .S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y
13 .W:SRCNT'>1 @IOF W:SRCNT>1 !! W " "_VADM(1)_" ("_VA("PID")_") Case #"_SRTN_" - "_SRSDATE
14 Q
15CLINIC(SRLOC,SRCASE) ; active count clinic screen for cases
16 N SRCLIN,SRX,SRY,SRZ S SRZ=$S(SRCASE:$P(^SRF(SRCASE,0),U,9),1:DT) D SC I 'SRCLIN Q 0
17 Q 1
18ACTCLIN(SRLOC) ; active count clinic screen
19 N SRCLIN,SRX,SRY,SRZ S SRZ=DT D SC I 'SRCLIN Q 0
20 Q 1
21SC N SRKL S SRCLIN=1 S SRKL=$$GET1^DIQ(44,SRLOC,2.1) I SRKL'="CLINIC"!($P(^SC(SRLOC,0),"^",17)="Y") S SRCLIN=0 Q
22 S SRX=$P($G(^SC(SRLOC,"I")),"^") I 'SRX Q
23 S SRY=$P($G(^SC(SRLOC,"I")),U,2) I SRZ'<SRX,((SRY="")!(SRZ<SRY)) S SRCLIN=0
24 Q
25INOUT ; select in/out-patient status choice for report
26 K DIR S DIR("A",1)="Print "_$S($D(SRRPT):SRRPT,1:"report")_" for",DIR("A",2)="",DIR("A",5)=" I - Inpatient cases only",DIR("A",4)=" O - Outpatient cases only",DIR("A",3)=" A - All cases"
27 S DIR("A",6)="",DIR("A")="Select Letter (I, O or A): ",DIR("B")=$S($D(SRB):SRB,1:"A")
28 S DIR(0)="SAM^A:All Cases;O:Outpatient Cases Only;I:Inpatient Cases Only" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
29 S SRIO=Y
30 Q
31DATE(SRSD,SRED,SRQ) ; starting and ending date utility (pass by reference)
32 ; The following variables are returned
33 ; SRSD - starting date
34 ; SRED - ending date
35 ; SRQ - user interrupt
36 S (SRSD,SRED,SRQ)=0 W ! F D Q:SRED'<SRSD!SRQ
37 .K %DT S %DT="AEPX",%DT("A")="Start with Date: " D ^%DT I Y<1 S SRQ=1 Q
38 .S SRSD=Y
39 .K %DT S %DT="AEPX",%DT("A")="End with Date: " D ^%DT I Y<1 S SRQ=1 Q
40 .I Y<SRSD W !!,"The ending date must be later than the starting date.",!
41 .S SRED=Y
42 Q
43SPEC ; select surgical specialty
44 W @IOF,! S DIR("?",1)="Enter YES if you would like the report printed for all Surgical Specialties",DIR("?")="or enter NO to select a specific specialty."
45 S DIR("A")="Do you want the report for all Surgical Specialties ? ",DIR("B")="YES",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
46 I 'Y W ! K DIC S DIC=137.45,DIC(0)="QEAMZ",DIC("A")="Select Surgical Specialty: ",DIC("S")="I '$P(^(0),""^"",3)" D ^DIC K DIC S:Y<0 SRSOUT=1 Q:Y<0 S SRSPEC=+Y,SRSPECN=$P(Y(0),"^")
47 Q
48PROC ; put procedures and CPT code in array for display
49 N SRDA,X,Y K SRPROC S K=1,Y=$P(^SRF(SRTN,"OP"),"^",2),Y=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"???") I Y'="???" D SSPRIN^SROCPT
50 S X=$P(^SRF(SRTN,"OP"),"^")_$S($G(SRSUPCPT)=1:"",1:" (CPT Code: "_Y_")") I $L(X)<(SRL+1) S SRPROC(K)=X,K=K+1 G OTH
51 D FORMAT
52OTH S SRDA=0 F S SRDA=$O(^SRF(SRTN,13,SRDA)) Q:'SRDA D
53 .S Y=$P($G(^SRF(SRTN,13,SRDA,2)),"^"),Y=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"???")
54 .I Y'="???" D SSOTH^SROCPT
55 .S X=$P(^SRF(SRTN,13,SRDA,0),"^")_$S($G(SRSUPCPT)=1:"",1:" (CPT Code: "_Y_")")
56 .I $L(X)<(SRL+1) S SRPROC(K)=X,K=K+1 Q
57 .D FORMAT
58 Q
59FORMAT I $L(X)>SRL F D I $L(X)<(SRL+1) S SRPROC(K)=X,K=K+1 Q
60 .F I=0:1:(SRL-1) S J=SRL-I,Y=$E(X,J) I Y=" " S SRPROC(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q
61 Q
62DIAG ; check diagnosis input for required space in every 31 characters
63 Q:$L(X)<31 N SRC,SRBL,SRDIAG,SRFLG
64 S SRDIAG=X,SRFLG=0 F D Q:SRFLG!($L(SRDIAG)'>30)
65 .S SRBL=$F(SRDIAG," ") I SRBL>32!('SRBL) S SRFLG=1 K X Q
66 .S SRDIAG=$E(SRDIAG,SRBL,$L(SRDIAG))
67 I '$D(X) D
68 .S SRC(1)="Answer must contain at least one space in every 31 characters of length.",SRC(1,"F")="!!?5",SRC(2)="If you are using a comma (,) to separate information, leave a space after",SRC(2,"F")="!?5"
69 .S SRC(3)="it. Please re-enter the diagnosis.",SRC(3,"F")="!?5" D EN^DDIOL(.SRC)
70 Q
71LOCK(SRCASE) ;
72 N D0,SRCONCC,SRLCK,SRNOW,SRNOW1,SRTAG,SRUSER,SRX
73 S SRNOW=$$NOW^XLFDT,SRNOW1=$$FMADD^XLFDT(SRNOW,,2)
74 S SRLCK=1,SRTAG="",SRCONCC=$P($G(^SRF(SRCASE,"CON")),"^")
75 I $$SIGNED^SROESUTL(SRCASE)!$G(SRESIG) D SINED Q SRLCK
76 L +^XTMP("SRLOCK-"_SRCASE,DUZ,$J):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
77 E D E1 S SRLCK=0 Q SRLCK
78 I SRCONCC D
79 .L +^XTMP("SRLOCK-"_SRCONCC,DUZ,$J):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
80 .E D S SRLCK=0
81 ..D E2 L -^XTMP("SRLOCK-"_SRCASE,DUZ,$J)
82 D:SRLCK XTMP
83 Q SRLCK
84E1 S SRUSER="Another person",SRX=$O(^XTMP("SRLOCK-"_SRCASE,0))
85 I SRX S SRUSER=$P($G(^VA(200,SRX,0)),"^")
86 D EN^DDIOL(SRUSER_" is editing this case. Please try later.","","!,$C(7)") H 2
87 Q
88E2 S SRUSER="Another person",SRX=$O(^XTMP("SRLOCK-"_SRCONCC,0))
89 I SRX S SRUSER=$P($G(^VA(200,SRX,0)),"^")
90 D EN^DDIOL(SRUSER_" is editing the concurrent case. Please try later.","","!,$C(7)") H 2
91 Q
92SINED L +^XTMP("SRLOCK-"_SRCASE):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
93 E D E1 S SRLCK=0 Q
94 I SRCONCC D Q:'SRLCK
95 .L +^XTMP("SRLOCK-"_SRCONCC):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
96 .E D S SRLCK=0
97 ..D E2 L -^XTMP("SRLOCK-"_SRCASE)
98 S SRTAG="-Master"
99XTMP S ^XTMP("SRLOCK-"_SRCASE,0)=SRNOW1_"^"_SRNOW_"^Surgery Case Lock"_SRTAG_"^"_$J,^XTMP("SRLOCK-"_SRCASE,DUZ,$J)=""
100 I SRCONCC S ^XTMP("SRLOCK-"_SRCONCC,0)=SRNOW1_"^"_SRNOW_"^Surgery Case Lock"_SRTAG_"^"_$J,^XTMP("SRLOCK-"_SRCONCC,DUZ,$J)=""
101 Q
102UNLOCK(SRCASE) ; apply decremental lock
103 N SRCC,SRCONCC S SRCONCC=$P($G(^SRF(SRCASE,"CON")),"^")
104 L -^XTMP("SRLOCK-"_SRCASE),-^XTMP("SRLOCK-"_SRCASE,DUZ,$J) K ^XTMP("SRLOCK-"_SRCASE,DUZ,$J)
105 I '$O(^XTMP("SRLOCK-"_SRCASE,0))!(($G(^XTMP("SRLOCK-"_SRCASE,0))["-Master")&($P($G(^XTMP("SRLOCK-"_SRCASE,0)),"^",4)=$J)) K ^XTMP("SRLOCK-"_SRCASE)
106 I SRCONCC D
107 .L -^XTMP("SRLOCK-"_SRCONCC),-^XTMP("SRLOCK-"_SRCONCC,DUZ,$J) K ^XTMP("SRLOCK-"_SRCONCC,DUZ,$J)
108 .I '$O(^XTMP("SRLOCK-"_SRCONCC,0))!(($G(^XTMP("SRLOCK-"_SRCONCC,0))["-Master")&($P($G(^XTMP("SRLOCK-"_SRCONCC,0)),"^",4)=$J)) K ^XTMP("SRLOCK-"_SRCONCC)
109 Q
110NOCNT(SRDA) ; screen for active, non-count clinic for this division
111 N SRDIV,SRKL,SRLOC,SRX,SRY,SRZ
112 S SRDIV=$P($G(^SRO(133,SRDA,0)),"^"),SRLOC=Y,SRZ=DT
113 I SRDIV'=$P($G(^SC(SRLOC,0)),"^",4) Q 0
114 S SRKL=$$GET1^DIQ(44,SRLOC,2.1) I SRKL'="CLINIC" Q 0
115 I $P(^SC(SRLOC,0),"^",17)'="Y" Q 0
116 S SRX=$P($G(^SC(SRLOC,"I")),"^") I 'SRX Q 1
117 S SRY=$P($G(^SC(SRLOC,"I")),U,2) I SRZ'<SRX,((SRY="")!(SRZ<SRY)) Q 0
118 Q 1
119DESC ; output attending code description when doing lookup
120 N SRX,SRY,SRZ
121 S SRX=0,SRY=Y F S SRX=$O(^SRO(132.9,SRY,1,SRX)) Q:'SRX S SRZ(SRX)=^SRO(132.9,SRY,1,SRX,0),SRZ(SRX,"F")="!?2"
122 I $O(SRZ(0)) D EN^DDIOL(.SRZ)
123 D EN^DDIOL(" ","","!")
124 Q
Note: See TracBrowser for help on using the repository browser.