source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLPCSS.m@ 1604

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

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1LRBLPCSS ;AVAMC/REG - PRE-OP COMPONENT SELECTION ;11/7/94 13:50 ;
2 ;;5.2;LAB SERVICE;**1,247**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 I '$D(^SRF) W " *** No operation schedule file ***" G A
5 I '$D(^SRF("ADT",DFN)) W !!,LRP," not in operation schedule file." G A
6 S X="T",%DT="" D ^%DT S X1=Y,X2=-1 D C^%DTC S X=X+.99 K A
7 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:"")
8 I 'C W !!,"No operations pending." G A
9 I C=1 W !!,"Operation scheduled: " S X=1 D B Q
10 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)
11P 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
12 D B Q
13B W " ",$P(A(X),"^"),!,$P(A(X),"^",2) S X=$P(A(X),"^",3) I X,$D(^ICPT(X,0)) S LRCPT=X W !,"CPT file number: ",LRCPT F Y=0:0 S Y=$O(^ICPT(X,"D",Y)) Q:'Y W !,^(Y,0)
14 S X=$O(^LAB(66.5,LRCPT,1,0)) I 'X S LRCPT=0 D W Q
15C 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)
16 Q
17 ;
18A 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
19 D:'$D(^LAB(66.5,X,0)) SET S Y=$O(^LAB(66.5,X,1,0)) I 'Y D W Q
20 W !,"CPT file number: ",X F Z=0:0 S Z=$O(^ICPT(X,"D",Z)) Q:'Z W !,^(Z,0)
21 S LRCPT=X D C Q
22 ;
23SET ; also from MSB^LRBLS
24 L +^LAB(66.5) 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
25EN ;
26 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
27 S A=$P(^LAB(66.5,LRCPT,1,C,0),"^",2)
28 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
29 S:$D(LRR) LRK(C)="",LRK(C,1)="MSBOS:"_A_" operation: "_$P(^ICPT(LRCPT,0),"^",2) Q
30 ;
31W W !!,"No maximum surgical blood orders for this operation.",!,"No maximum surgical blood order criteria checking can be done.",! Q
32 ;
33 ;called from LRBLPCS
34 ;LRR set =1 if max surg blood criteria not met
Note: See TracBrowser for help on using the repository browser.