SROUTL1 ;BIR/ADM - UTILITY ROUTINE ;1/13/2011
;;3.0;Surgery;**134,175,184**;24 Jun 93;Build 35
ATT ; check for attend surg when completing case
I $P($G(^SRF(DA,.1)),"^",13) Q
D ASK I '$P($G(^SRF(DA,.1)),"^",13) K X
Q
ASK N SREQ,X,Y
D EN^DDIOL("The Attending Surgeon field has not been entered. You must first enter the",,"!!")
D EN^DDIOL("Attending Surgeon before the computer will accept entry of the Time Patient",,"!")
D EN^DDIOL("Out of O.R.",,"!")
K DIR S DIR("A",1)="",DIR("A")="Attending Surgeon",DIR(0)="130,.164" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) Q
I +Y S SREQ(130,DA_",",.164)=+Y D FILE^DIE("","SREQ","^TMP(""SR"",$J)")
Q
ATTP ; check for attend provider when completing non-OR procedure
I $P($G(^SRF(DA,"NON")),"^",7) Q
D ASKP I '$P($G(^SRF(DA,"NON")),"^",7) K X
Q
ASKP N SREQ,X,Y
D EN^DDIOL("The Attending Provider field has not been entered. You must first enter",,"!!")
D EN^DDIOL("the Attending Provider before the computer will accept entry of the Time",,"!")
D EN^DDIOL("Procedure Ended.",,"!")
K DIR S DIR("A",1)="",DIR("A")="Attending Provider",DIR(0)="130,124" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) Q
I +Y S SREQ(130,DA_",",124)=+Y D FILE^DIE("","SREQ","^TMP(""SR"",$J)")
Q
ZERO ; add leading zero to Dose amounts between 0 and 1 for clarity purposes, e.g. Dose entered as .5, will display as 0.5; called from input transform on the following Dose flds:
; .375 Medications mult 130.33, subfld 1 Time Adm mult 130.34, subfld 1 Dose
; .37 Anesthesia Technique mult 130.06, subfld 24 Anesthesia Agents mult 130.47, subfld 1 Dose (mg)
; .37 Anesthesia Technique mult 130.06, subfld 32 Test Does mult 130.48, subfld 1 Dose (mg)
S:(X>0)&(X<1) X="0"_+X
Q
WOND(Y) ; screen called by wound classification field #1.09
N SRCPT,SRF,SRX,SRY,SRJ,SRLIST,SRI S SRF=0
S SRTN=$S($D(SRTN):SRTN,$D(DA):DA,1:"") Q:'SRTN 0
I SRTN,($P($G(^SRF(SRTN,"1.0")),"^",8)]"") Q 0
S SRCPT=$P($G(^SRF(SRTN,"OP")),"^",2) I 'SRCPT Q 0
F SRJ=0:1 S SRLIST=$P($T(WCPT+SRJ),";;",2) Q:SRLIST="END" D Q:SRF
.F SRI=1:1 S SRX=$P(SRLIST,",",SRI) Q:SRX="" I $D(^ICPT("B",SRX)) D Q:SRF
..S SRY=0,SRY=$O(^ICPT("B",SRX,SRY)) Q:SRY="" S:SRCPT=SRY SRF=1
Q SRF
WCPT ;;43108,43113,43118,43123,43361,43645,43845,43847,44020,44021,44110,44111,44120,44121
;;44125,44126,44127,44128,44139,44140,44141,44143,44144,44145,44146,44147,44150,44151,44155
;;44156,44157,44157,44158,44158,44160,44202,44203,44204,44205,44206,44207,44208,44210,44211
;;44212,44213,44227,44322,44602,44603,44620,44625,44625,44626,44626,44701,44900,44950,44955
;;44960,44970,45000,45005,45020,45108,45111,45113,45119,45120,45121,45126,45130,45135,45160
;;45171,45172,45190,45355,45390,45397,45562,45563,45910,46040,46060,46288,46707,47010,47120
;;47122,47125,47130,47133,47140,47141,47142,47143,47144,47145,47361,47400,47420,47425,47480
;;47490,47510,47511,47525,47530,47550,47552,47560,47561,47562,47563,47564,47570,47600,47605
;;47610,47612,47620,47700,47700,47711,47712,47720,47721,47740,47741,47760,47765,47780,47785
;;47800,47802,47900,48001,48001,48020,48105,48140,48145,48146,48150,48152,48153,48154,48155
;;48160,48500,48510,48520,48540,48545,48547,48548,48550,48551,48551,48552,48554,48556,49020
;;49407,49442,49450,50815,50825,50845,51596,51597,51597,58200,58240,58260,58262,58263,58267
;;58270,58275,58280,58285,58290,58291,58292,58293,58294,58550,58552,58553,58554,59857,0184T
;;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROUTL1 3432 printed Dec 13, 2024@02:46:29 Page 2
SROUTL1 ;BIR/ADM - UTILITY ROUTINE ;1/13/2011
+1 ;;3.0;Surgery;**134,175,184**;24 Jun 93;Build 35
ATT ; check for attend surg when completing case
+1 IF $PIECE($GET(^SRF(DA,.1)),"^",13)
QUIT
+2 DO ASK
IF '$PIECE($GET(^SRF(DA,.1)),"^",13)
KILL X
+3 QUIT
ASK NEW SREQ,X,Y
+1 DO EN^DDIOL("The Attending Surgeon field has not been entered. You must first enter the",,"!!")
+2 DO EN^DDIOL("Attending Surgeon before the computer will accept entry of the Time Patient",,"!")
+3 DO EN^DDIOL("Out of O.R.",,"!")
+4 KILL DIR
SET DIR("A",1)=""
SET DIR("A")="Attending Surgeon"
SET DIR(0)="130,.164"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+5 IF +Y
SET SREQ(130,DA_",",.164)=+Y
DO FILE^DIE("","SREQ","^TMP(""SR"",$J)")
+6 QUIT
ATTP ; check for attend provider when completing non-OR procedure
+1 IF $PIECE($GET(^SRF(DA,"NON")),"^",7)
QUIT
+2 DO ASKP
IF '$PIECE($GET(^SRF(DA,"NON")),"^",7)
KILL X
+3 QUIT
ASKP NEW SREQ,X,Y
+1 DO EN^DDIOL("The Attending Provider field has not been entered. You must first enter",,"!!")
+2 DO EN^DDIOL("the Attending Provider before the computer will accept entry of the Time",,"!")
+3 DO EN^DDIOL("Procedure Ended.",,"!")
+4 KILL DIR
SET DIR("A",1)=""
SET DIR("A")="Attending Provider"
SET DIR(0)="130,124"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+5 IF +Y
SET SREQ(130,DA_",",124)=+Y
DO FILE^DIE("","SREQ","^TMP(""SR"",$J)")
+6 QUIT
ZERO ; add leading zero to Dose amounts between 0 and 1 for clarity purposes, e.g. Dose entered as .5, will display as 0.5; called from input transform on the following Dose flds:
+1 ; .375 Medications mult 130.33, subfld 1 Time Adm mult 130.34, subfld 1 Dose
+2 ; .37 Anesthesia Technique mult 130.06, subfld 24 Anesthesia Agents mult 130.47, subfld 1 Dose (mg)
+3 ; .37 Anesthesia Technique mult 130.06, subfld 32 Test Does mult 130.48, subfld 1 Dose (mg)
+4 if (X>0)&(X<1)
SET X="0"_+X
+5 QUIT
WOND(Y) ; screen called by wound classification field #1.09
+1 NEW SRCPT,SRF,SRX,SRY,SRJ,SRLIST,SRI
SET SRF=0
+2 SET SRTN=$SELECT($DATA(SRTN):SRTN,$DATA(DA):DA,1:"")
if 'SRTN
QUIT 0
+3 IF SRTN
IF ($PIECE($GET(^SRF(SRTN,"1.0")),"^",8)]"")
QUIT 0
+4 SET SRCPT=$PIECE($GET(^SRF(SRTN,"OP")),"^",2)
IF 'SRCPT
QUIT 0
+5 FOR SRJ=0:1
SET SRLIST=$PIECE($TEXT(WCPT+SRJ),";;",2)
if SRLIST="END"
QUIT
Begin DoDot:1
+6 FOR SRI=1:1
SET SRX=$PIECE(SRLIST,",",SRI)
if SRX=""
QUIT
IF $DATA(^ICPT("B",SRX))
Begin DoDot:2
+7 SET SRY=0
SET SRY=$ORDER(^ICPT("B",SRX,SRY))
if SRY=""
QUIT
if SRCPT=SRY
SET SRF=1
End DoDot:2
if SRF
QUIT
End DoDot:1
if SRF
QUIT
+8 QUIT SRF
WCPT ;;43108,43113,43118,43123,43361,43645,43845,43847,44020,44021,44110,44111,44120,44121
+1 ;;44125,44126,44127,44128,44139,44140,44141,44143,44144,44145,44146,44147,44150,44151,44155
+2 ;;44156,44157,44157,44158,44158,44160,44202,44203,44204,44205,44206,44207,44208,44210,44211
+3 ;;44212,44213,44227,44322,44602,44603,44620,44625,44625,44626,44626,44701,44900,44950,44955
+4 ;;44960,44970,45000,45005,45020,45108,45111,45113,45119,45120,45121,45126,45130,45135,45160
+5 ;;45171,45172,45190,45355,45390,45397,45562,45563,45910,46040,46060,46288,46707,47010,47120
+6 ;;47122,47125,47130,47133,47140,47141,47142,47143,47144,47145,47361,47400,47420,47425,47480
+7 ;;47490,47510,47511,47525,47530,47550,47552,47560,47561,47562,47563,47564,47570,47600,47605
+8 ;;47610,47612,47620,47700,47700,47711,47712,47720,47721,47740,47741,47760,47765,47780,47785
+9 ;;47800,47802,47900,48001,48001,48020,48105,48140,48145,48146,48150,48152,48153,48154,48155
+10 ;;48160,48500,48510,48520,48540,48545,48547,48548,48550,48551,48551,48552,48554,48556,49020
+11 ;;49407,49442,49450,50815,50825,50845,51596,51597,51597,58200,58240,58260,58262,58263,58267
+12 ;;58270,58275,58280,58285,58290,58291,58292,58293,58294,58550,58552,58553,58554,59857,0184T
+13 ;;END
