source: WorldVistAEHR/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LAHTCCAD.m@ 1147

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

initial load of WorldVistAEHR

File size: 2.0 KB
Line 
1LAHTCCAD ;SLC/DLG - HITATCHI 717 THRU CCA SYSTEM BUILD DOWNLOAD FILE. ;7/20/90 09:17 ;
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
3 ;Call with LRLL = load list to build
4 ;Call with LRTRAY1 = Starting tray number
5 ;Call with LRLL = Auto Instrument pointer
6 ;Call with LRFORCE=1 if send tray and cup.
7 S:$D(ZTQUEUED) ZTREQ="@" S T=LRINST S:'$D(^LA(T,"O")) ^("O")=0,^("O",0)=0
8 S (BLKN,BLK)="" F I=1:1:34 S BLK=BLK_" ",BLKN=BLKN_"0"
9A F LRTRAY=LRTRAY1:0 D:$D(^LRO(68.2,LRLL,1,LRTRAY)) TRAY S LRTRAY=$O(^LRO(68.2,LRLL,1,LRTRAY)),LRCUP1=1 Q:LRTRAY'>0
10 S LREND=0,LRECORD=$C(4) D SEND Q
11TRAY F LRCUP=(LRCUP1-1):0 S LRCUP=$O(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP)) Q:LRCUP'>0 D SAMPLE S LRECORD=""
12 Q
13SAMPLE S LRL=^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,0),LRAA=+LRL,LRAD=$P(LRL,"^",2),LRAN=$P(LRL,"^",3),X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LADOC=$P(X,"^",8),X=^LR(+X,0) I $P(X,"^",2)=2 S LRDPF=2,DFN=$P(X,"^",3) D PT^LRX,TEST
14 S PNM=$E(PNM,1,20) S:$D(SSN) SSN="000000"_$E(SSN,1,3)_$E(SSN,5,6)_$E(SSN,8,11) S DOB=$E(DOB,4,5)_$E(DOB,6,7)_$E(DOB,2,3) S X=LADOC D:X]"" DOC^LRX S LADOC=Y S:LADOC="" LADOC="UNKNOWN" S:$L(LADOC)>20 LADOC=$E(LADOC,1,20)
15 S LRAN1=$E(LRAD,4,5)_$E(LRAD,6,7)_$E(100000+LRAN,2,6),LRWRD=$E(LRWRD,1,10)
16 S LRECORD=$C(2)_"O"_SSN_$E(BLK,1,(20-$L(PNM)))_PNM_$E(BLK,1,(10-$L(LRWRD)))_LRWRD_$E(10000+AGE,2,5)_"Y"_SEX_DOB_$E(BLK,1,(20-$L(LADOC)))_LADOC_$E(1000000000+LRAN1,2,10)_X_$C(3) D CSUM S LRECORD=LRECORD_CSUM
17SEND L ^LA(LRINST,"O") S Q=^LA(LRINST,"O")+1,^("O")=Q,^("O",Q)=LRECORD L Q
18TEST S X="" F I=1:1:68 S X=X_"0"
19 F LRTEST=0:0 S LRTEST=$O(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,1,LRTEST)) Q:LRTEST'>0 D T2
20 Q
21T2 Q:'$D(^TMP($J,LRTEST))
22 F I=0:0 S I=$O(^TMP($J,LRTEST,I)) Q:I'>0 S Y=^(I),Y1=0 S:$L(Y)>2 Y1=$E(Y),Y=$E(Y,2,3) I Y<35 D T3
23 Q
24T3 S:Y1=0 X=$E(X,1,(Y-1))_"1"_$E(X,(Y+1),68),X=$E(X,1,(Y+33))_"1"_$E(X,(Y+35),68) S:Y1=1 X=$E(X,1,(Y-1))_"1"_$E(X,(Y+1),68) S:Y1=2 X=$E(X,1,(Y+33))_"1"_$E(X,(Y+35),68)
25 Q
26CSUM S CSUM=0 F I=2:1:($L(LRECORD)-1) S CSUM=CSUM+$A(LRECORD,I)
27 S CSUM=$E(1000+(CSUM#256),2,4) Q
Note: See TracBrowser for help on using the repository browser.