source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAPAM2.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1LRCAPAM2 ;DALISC/FHS/JBM - PHASE 2 OF LMIP DATA COLLECTION 67.9 TO ^LAH(
2 ;;5.2;LAB SERVICE;**105,201**;Sep 27, 1994
3EN ;
4 ;Screening data based on the ^(2) node for LMIP billable procedures.
5 S LINE="PHASE 2 OF LMIP DATA COLLECTION" W !?(IOM-$L(LINE))\2,LINE,!
6 S LINE="This step will create a temporary global from which" W !?(IOM-$L(LINE))\2,LINE,!
7 S LINE="a mail message will be created for transmission to" W !?(IOM-$L(LINE))\2,LINE,!
8 S LINE="the National Data Base." W !?(IOM-$L(LINE))\2,LINE,!
9CHK I $O(^LAH("LABWL",0)) W !!?10,"THERE IS PREVIOUS DATA STORED IN ^LAH(LABWL, FILE",!!?5,"DO YOU WISH TO PURGE THIS DATA? ",! S %=2 D YN^DICN G CHK:%=0,STOP:%=-1 K:%=1 ^LAH("LABWL")
10DT K %,%DT,LINE S $P(BLK," ",50)="",%DT(0)="-NOW",%DT="AEXP",%DT("A")="Begin with what Date : " D ^%DT G STOP:Y<1 S LRSDT=Y-.0001
11 S Y2=0,%DT("A")="End with what date: ",%DT("B")=$$FMTE^XLFDT(Y,"1D") D ^%DT G STOP:Y<1 S LREDT=Y
12DQ I LREDT<LRSDT S LREDT=LRSDT,LRSDT=Y
13 S:'$D(^LAH("LABWL",0)) ^(0)=0 S LRML=0
14PRI S LRPRI=0 F S LRPRI=+$O(^LRO(67.9,LRPRI)) Q:'LRPRI S LRHD1=$G(^(LRPRI,0)) I $L(LRHD1),$O(^(1,0)),$G(^DIC(4,+LRHD1,99)) S $P(LRHD1,U)=$P(^(99),U) D
15 .S LRHD1="$"_$E(LRHD1,1,30)
16 .S LRSITE=0 F S LRSITE=+$O(^LRO(67.9,LRPRI,1,LRSITE)) Q:'LRSITE S LRHD2=$G(^(LRSITE,0)) I $L(LRHD2),$O(^(1,0)),$G(^DIC(4,+LRHD2,99)) S $P(LRHD2,U)=$P(^(99),U) D
17 ..S LRHD2="$$"_$E(LRHD2,1,30)
18 ..S LRDAT=($E(LRSDT,1,5)_"00"-.9999) F S LRDAT=+$O(^LRO(67.9,LRPRI,1,LRSITE,1,"B",LRDAT)) Q:'LRDAT!($E(LRDAT,1,5)>$E(LREDT,1,5)) S LRDATE=$O(^(LRDAT,0)) I LRDATE D
19 ...S LRDATEP=$P($G(^LRO(67.9,LRPRI,1,LRSITE,1,LRDATE,0)),U) I LRDATEP S ^LAH("LABWL",0)=1+^LAH("LABWL",0),CNT=^(0),^(CNT)=LRHD1_LRHD2_"$$$"_LRDATEP D
20 ....W !,$$FMTE^XLFDT(LRDAT,"1D") S LRCC=0
21 ....F S LRCC=+$O(^LRO(67.9,LRPRI,1,LRSITE,1,LRDATE,1,LRCC)) Q:'LRCC D:$G(^(LRCC,2))
22 .....S LRCCN=$G(^LRO(67.9,LRPRI,1,LRSITE,1,LRDATE,1,LRCC,0))
23 .....I LRCCN S $P(LRCCN,U,9)=$S($E($P(LRCCN,U,9))="+":$E($P(LRCCN,U,9),2,50),1:$E($P(LRCCN,U,9),1,50)) D
24 ......K LRSECT S CNT=CNT+1,LRNCCN1=$P(LRCCN,U),LRDA=+$O(^LAM("C",LRNCCN1_" ",0))
25 ......Q:'LRDA
26 ......S LRSECT=$E($P($G(^LAB(64.21,+$P($G(^LAM(LRDA,0)),U,15),0)),U,2),1,3) S:'$L(LRSECT) LRSECT="NAS"
27 ......S LRNCCN2=$E(($P(LRNCCN1,".",2)_"00000"),1,5) S:$L($P(LRNCCN1,"."))=5 LRNCCN1="0"_LRNCCN1
28 ......S $P(LRCCN,U)=$P(LRNCCN1,".")_"."_LRNCCN2_$S($D(LRSECT):LRSECT,1:"NAS")
29 ......S ^LAH("LABWL",CNT)="*"_$P(LRCCN,U,1,8)_U_$P(LRCCN,U,10)_U_$P(LRCCN,U,11)_U_$P(LRCCN,U,12)
30 ......S CNT=CNT+1,^LAH("LABWL",CNT)="\"_$E($$UP^XLFSTR($P(LRCCN,U,9)),1,50)
31 ......D TREA
32 ....S ^LAH("LABWL",0)=CNT
33 Q
34TREA ;
35 S LRTRE=0,STR="-" F S LRTRE=+$O(^LRO(67.9,LRPRI,1,LRSITE,1,LRDATE,1,LRCC,1,LRTRE)) Q:'LRTRE S LRTRED=$G(^(LRTRE,0)) I $L(LRTRED) S LRTRED=$P(LRTRED,U,1,2) D:($L(LRTRED)+$L(STR))>79 LONG S STR=STR_"|"_LRTRED
36 I $L(STR)>1 S CNT=CNT+1,^LAH("LABWL",CNT)=STR,^(0)=CNT
37 Q
38LONG ;
39 S CNT=CNT+1,^LAH("LABWL",CNT)=STR,STR="-"
40 Q
41STOP ;
42 K %DT,BLK,CNT,LRCC,LRCCN,LRNCCN1,LRNCCN2,LRDA,LRDATE,LRDATEP,LREDT,LRHD1
43 K LRDAT,LRHD2,LRML,LRPRI,LRSDT,LRSITE,LRTRE,LRTRED,STR,Y,Y2
44 Q
Note: See TracBrowser for help on using the repository browser.