Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRCAPAM2

LRCAPAM2.m

Go to the documentation of this file.
LRCAPAM2 ; IHS/DIR/AAB - PHASE 2 OF LMIP DATA COLLECTION 67.9 TO ^LAH( ;
 ;;5.2;LR;**1006**;SEP 01, 1998
 ;
 ;;5.2;LAB SERVICE;**105,201**;Sep 27, 1994
EN ;
 ;Screening data based on the ^(2) node for LMIP billable procedures.
 S LINE="PHASE 2 OF LMIP DATA COLLECTION" W !?(IOM-$L(LINE))\2,LINE,!
 S LINE="This step will create a temporary global from which" W !?(IOM-$L(LINE))\2,LINE,!
 S LINE="a mail message will be created for transmission to" W !?(IOM-$L(LINE))\2,LINE,!
 S LINE="the National Data Base." W !?(IOM-$L(LINE))\2,LINE,!
CHK 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")
DT 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
 S Y2=0,%DT("A")="End with what date: ",%DT("B")=$$FMTE^XLFDT(Y,"1D") D ^%DT G STOP:Y<1 S LREDT=Y
DQ I LREDT<LRSDT S LREDT=LRSDT,LRSDT=Y
 S:'$D(^LAH("LABWL",0)) ^(0)=0 S LRML=0
PRI 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
 .S LRHD1="$"_$E(LRHD1,1,30)
 .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
 ..S LRHD2="$$"_$E(LRHD2,1,30)
 ..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
 ...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
 ....W !,$$FMTE^XLFDT(LRDAT,"1D") S LRCC=0
 ....F  S LRCC=+$O(^LRO(67.9,LRPRI,1,LRSITE,1,LRDATE,1,LRCC)) Q:'LRCC  D:$G(^(LRCC,2))
 .....S LRCCN=$G(^LRO(67.9,LRPRI,1,LRSITE,1,LRDATE,1,LRCC,0))
 .....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
 ......K LRSECT S CNT=CNT+1,LRNCCN1=$P(LRCCN,U),LRDA=+$O(^LAM("C",LRNCCN1_" ",0))
 ......Q:'LRDA
 ......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"
 ......S LRNCCN2=$E(($P(LRNCCN1,".",2)_"00000"),1,5) S:$L($P(LRNCCN1,"."))=5 LRNCCN1="0"_LRNCCN1
 ......S $P(LRCCN,U)=$P(LRNCCN1,".")_"."_LRNCCN2_$S($D(LRSECT):LRSECT,1:"NAS")
 ......S ^LAH("LABWL",CNT)="*"_$P(LRCCN,U,1,8)_U_$P(LRCCN,U,10)_U_$P(LRCCN,U,11)_U_$P(LRCCN,U,12)
 ......S CNT=CNT+1,^LAH("LABWL",CNT)="\"_$E($$UP^XLFSTR($P(LRCCN,U,9)),1,50)
 ......D TREA
 ....S ^LAH("LABWL",0)=CNT
 Q
TREA ;
 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
 I $L(STR)>1 S CNT=CNT+1,^LAH("LABWL",CNT)=STR,^(0)=CNT
 Q
LONG ;
 S CNT=CNT+1,^LAH("LABWL",CNT)=STR,STR="-"
 Q
STOP ;
 K %DT,BLK,CNT,LRCC,LRCCN,LRNCCN1,LRNCCN2,LRDA,LRDATE,LRDATEP,LREDT,LRHD1
 K LRDAT,LRHD2,LRML,LRPRI,LRSDT,LRSITE,LRTRE,LRTRED,STR,Y,Y2
 Q