LRBLPCSS ;AVAMC/REG - PRE-OP COMPONENT SELECTION ;11/7/94 13:50 ;
;;5.2;LAB SERVICE;**1,247,315**;Sep 27, 1994;Build 25
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
;Reference to ^SRF is supported by ECR# 927
;Reference to ^%DT Supported by ICR# 10003
;Reference to C^%DTC Supported by ICR# 10000
;Reference to ^DIC Supported by ICR# 2051
I '$D(^SRF) W " *** No operation schedule file ***" G A
I '$D(^SRF("ADT",DFN)) W !!,LRP," not in operation schedule file." G A
S X="T",%DT="" D ^%DT S X1=Y,X2=-1 D C^%DTC S X=X+.99 K A
S C=0 F B=0:0 S X=$O(^SRF("ADT",DFN,X)) Q:'X S A=0 F B(1)=0:0 S A=$O(^SRF("ADT",DFN,X,A)) Q:'A S C=C+1,Y=^SRF("ADT",DFN,X,A) D D^LRU S A(C)=Y_"^"_$S($D(^SRF(A,"OP")):^("OP"),1:"")
I 'C W !!,"No operations pending." G A
I C=1 W !!,"Operation scheduled: " S X=1 D B Q
W !!?5,"Date:",?20,"Operation:" S A=0 F B=0:1 S A=$O(A(A)) Q:'A W !,$J(A,2),") ",$P(A(A),"^")," ",$P(A(A),"^",2)
P W !!,"Select OPERATION (1-",B,"): " R X:DTIME Q:X["^"!(X="") I X<1!(X>B)!(+X'=X) W $C(7),!,"Select a number from 1 to ",B G P
D B Q
B W " ",$P(A(X),"^"),!,$P(A(X),"^",2) S X=$P(A(X),"^",3)
N LRX
S LRX=X,LRX=$$CPTD^ICPTCOD(LRX,"LRX")
I +LRX'=-1 D
. W !,"CPT file number: ",X
. F I=1:1:LRX W !,LRX(I)
. Q
S X=$O(^LAB(66.5,LRCPT,1,0)) I 'X S LRCPT=0 D W Q
C F X=0:0 S X=$O(^LAB(66,LRCPT,1,X)) Q:'X S X(1)=^(X,0) W !,"Component: ",$S($D(^LAB(66,X,0)):$P(^(0),"^"),1:""),?52,"MSBOS:",$P(X(1),"^",2)
Q
;
A Q:'$D(^ICPT(0)) W ! S DIC="^ICPT(",DIC(0)="AEQMZ",DIC("A")="Select OPERATION: ",DIC("S")="I $P(^(0),""^"",3),$P(^DIC(81.1,$P(^DIC(81.1,$P(^ICPT(Y,0),""^"",3),0),""^"",3),0),""^"")=""SURGERY""" D ^DIC K DIC Q:Y<1 S X=+Y
D:'$D(^LAB(66.5,X,0)) SET S Y=$O(^LAB(66.5,X,1,0)) I 'Y D W Q
W !,"CPT file number: ",X
N LRX
S LRX=X,LRX=$$CPTD^ICPTCOD(LRX,"LRX")
I +LRX'=-1 F I=1:1:LRX W !,LRX(I)
S LRCPT=X D C Q
;
SET ; also from MSB^LRBLS
L +^LAB(66.5):15 S DA=X,^LAB(66.5,X,0)=X,Z=^LAB(66.5,0),^(0)=$P(Z,"^",1,2)_"^"_X_"^"_($P(Z,"^",4)+1) L -^LAB(66.5) X:$D(^DD(66.5,.01,1,1,1)) ^(1) Q
EN ;
I '$D(^LAB(66.5,LRCPT,1,C)) W !!,"No maximum surgical blood order entered in file 66.5 for this component.",!,"No maximum surgical blood order criteria checking can be done.",! Q
S A=$P(^LAB(66.5,LRCPT,1,C,0),"^",2)
Q:X'>A W $C(7),!!,"Number exceeds maximum surgical blood order number (",A,") for this component",!,"for this procedure. Request still OK " S %=2 D YN^LRU S:%=1 LRR=1 I %'=1 S Y=0 D DEL^LRBLPCS
D:$D(LRR)
. S LRK(C)="",LRK(C,1)="MSBOS:"_A_" operation: "
. S LRK(C,1)=LRK(C,1)_$P($$CPT^ICPTCOD(LRCPT),"^",3)
. Q
Q
;
W W !!,"No maximum surgical blood orders for this operation.",!,"No maximum surgical blood order criteria checking can be done.",! Q
;
;called from LRBLPCS
;LRR set =1 if max surg blood criteria not met
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPCSS 2871 printed Dec 13, 2024@02:11:46 Page 2
LRBLPCSS ;AVAMC/REG - PRE-OP COMPONENT SELECTION ;11/7/94 13:50 ;
+1 ;;5.2;LAB SERVICE;**1,247,315**;Sep 27, 1994;Build 25
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 ;Reference to ^SRF is supported by ECR# 927
+4 ;Reference to ^%DT Supported by ICR# 10003
+5 ;Reference to C^%DTC Supported by ICR# 10000
+6 ;Reference to ^DIC Supported by ICR# 2051
+7 IF '$DATA(^SRF)
WRITE " *** No operation schedule file ***"
GOTO A
+8 IF '$DATA(^SRF("ADT",DFN))
WRITE !!,LRP," not in operation schedule file."
GOTO A
+9 SET X="T"
SET %DT=""
DO ^%DT
SET X1=Y
SET X2=-1
DO C^%DTC
SET X=X+.99
KILL A
+10 SET C=0
FOR B=0:0
SET X=$ORDER(^SRF("ADT",DFN,X))
if 'X
QUIT
SET A=0
FOR B(1)=0:0
SET A=$ORDER(^SRF("ADT",DFN,X,A))
if 'A
QUIT
SET C=C+1
SET Y=^SRF("ADT",DFN,X,A)
DO D^LRU
SET A(C)=Y_"^"_$SELECT($DATA(^SRF(A,"OP")):^("OP"),1:"")
+11 IF 'C
WRITE !!,"No operations pending."
GOTO A
+12 IF C=1
WRITE !!,"Operation scheduled: "
SET X=1
DO B
QUIT
+13 WRITE !!?5,"Date:",?20,"Operation:"
SET A=0
FOR B=0:1
SET A=$ORDER(A(A))
if 'A
QUIT
WRITE !,$JUSTIFY(A,2),") ",$PIECE(A(A),"^")," ",$PIECE(A(A),"^",2)
P WRITE !!,"Select OPERATION (1-",B,"): "
READ X:DTIME
if X["^"!(X="")
QUIT
IF X<1!(X>B)!(+X'=X)
WRITE $CHAR(7),!,"Select a number from 1 to ",B
GOTO P
+1 DO B
QUIT
B WRITE " ",$PIECE(A(X),"^"),!,$PIECE(A(X),"^",2)
SET X=$PIECE(A(X),"^",3)
+1 NEW LRX
+2 SET LRX=X
SET LRX=$$CPTD^ICPTCOD(LRX,"LRX")
+3 IF +LRX'=-1
Begin DoDot:1
+4 WRITE !,"CPT file number: ",X
+5 FOR I=1:1:LRX
WRITE !,LRX(I)
+6 QUIT
End DoDot:1
+7 SET X=$ORDER(^LAB(66.5,LRCPT,1,0))
IF 'X
SET LRCPT=0
DO W
QUIT
C FOR X=0:0
SET X=$ORDER(^LAB(66,LRCPT,1,X))
if 'X
QUIT
SET X(1)=^(X,0)
WRITE !,"Component: ",$SELECT($DATA(^LAB(66,X,0)):$PIECE(^(0),"^"),1:""),?52,"MSBOS:",$PIECE(X(1),"^",2)
+1 QUIT
+2 ;
A if '$DATA(^ICPT(0))
QUIT
WRITE !
SET DIC="^ICPT("
SET DIC(0)="AEQMZ"
SET DIC("A")="Select OPERATION: "
SET DIC("S")="I $P(^(0),""^"",3),$P(^DIC(81.1,$P(^DIC(81.1,$P(^ICPT(Y,0),""^"",3),0),""^"",3),0),""^"")=""SURGERY"""
DO ^DIC
KILL DIC
if Y<1
QUIT
SET X=+Y
+1 if '$DATA(^LAB(66.5,X,0))
DO SET
SET Y=$ORDER(^LAB(66.5,X,1,0))
IF 'Y
DO W
QUIT
+2 WRITE !,"CPT file number: ",X
+3 NEW LRX
+4 SET LRX=X
SET LRX=$$CPTD^ICPTCOD(LRX,"LRX")
+5 IF +LRX'=-1
FOR I=1:1:LRX
WRITE !,LRX(I)
+6 SET LRCPT=X
DO C
QUIT
+7 ;
SET ; also from MSB^LRBLS
+1 LOCK +^LAB(66.5):15
SET DA=X
SET ^LAB(66.5,X,0)=X
SET Z=^LAB(66.5,0)
SET ^(0)=$PIECE(Z,"^",1,2)_"^"_X_"^"_($PIECE(Z,"^",4)+1)
LOCK -^LAB(66.5)
if $DATA(^DD(66.5,.01,1,1,1))
XECUTE ^(1)
QUIT
EN ;
+1 IF '$DATA(^LAB(66.5,LRCPT,1,C))
WRITE !!,"No maximum surgical blood order entered in file 66.5 for this component.",!,"No maximum surgical blood order criteria checking can be done.",!
QUIT
+2 SET A=$PIECE(^LAB(66.5,LRCPT,1,C,0),"^",2)
+3 if X'>A
QUIT
WRITE $CHAR(7),!!,"Number exceeds maximum surgical blood order number (",A,") for this component",!,"for this procedure. Request still OK "
SET %=2
DO YN^LRU
if %=1
SET LRR=1
IF %'=1
SET Y=0
DO DEL^LRBLPCS
+4 if $DATA(LRR)
Begin DoDot:1
+5 SET LRK(C)=""
SET LRK(C,1)="MSBOS:"_A_" operation: "
+6 SET LRK(C,1)=LRK(C,1)_$PIECE($$CPT^ICPTCOD(LRCPT),"^",3)
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
W WRITE !!,"No maximum surgical blood orders for this operation.",!,"No maximum surgical blood order criteria checking can be done.",!
QUIT
+1 ;
+2 ;called from LRBLPCS
+3 ;LRR set =1 if max surg blood criteria not met
