LRCAPAM2 ;DALISC/FHS/JBM - PHASE 2 OF LMIP DATA COLLECTION 67.9 TO ^LAH(
;;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPAM2 3101 printed Dec 13, 2024@02:12:37 Page 2
LRCAPAM2 ;DALISC/FHS/JBM - PHASE 2 OF LMIP DATA COLLECTION 67.9 TO ^LAH(
+1 ;;5.2;LAB SERVICE;**105,201**;Sep 27, 1994
EN ;
+1 ;Screening data based on the ^(2) node for LMIP billable procedures.
+2 SET LINE="PHASE 2 OF LMIP DATA COLLECTION"
WRITE !?(IOM-$LENGTH(LINE))\2,LINE,!
+3 SET LINE="This step will create a temporary global from which"
WRITE !?(IOM-$LENGTH(LINE))\2,LINE,!
+4 SET LINE="a mail message will be created for transmission to"
WRITE !?(IOM-$LENGTH(LINE))\2,LINE,!
+5 SET LINE="the National Data Base."
WRITE !?(IOM-$LENGTH(LINE))\2,LINE,!
CHK IF $ORDER(^LAH("LABWL",0))
WRITE !!?10,"THERE IS PREVIOUS DATA STORED IN ^LAH(LABWL, FILE",!!?5,"DO YOU WISH TO PURGE THIS DATA? ",!
SET %=2
DO YN^DICN
if %=0
GOTO CHK
if %=-1
GOTO STOP
if %=1
KILL ^LAH("LABWL")
DT KILL %,%DT,LINE
SET $PIECE(BLK," ",50)=""
SET %DT(0)="-NOW"
SET %DT="AEXP"
SET %DT("A")="Begin with what Date : "
DO ^%DT
if Y<1
GOTO STOP
SET LRSDT=Y-.0001
+1 SET Y2=0
SET %DT("A")="End with what date: "
SET %DT("B")=$$FMTE^XLFDT(Y,"1D")
DO ^%DT
if Y<1
GOTO STOP
SET LREDT=Y
DQ IF LREDT<LRSDT
SET LREDT=LRSDT
SET LRSDT=Y
+1 if '$DATA(^LAH("LABWL",0))
SET ^(0)=0
SET LRML=0
PRI SET LRPRI=0
FOR
SET LRPRI=+$ORDER(^LRO(67.9,LRPRI))
if 'LRPRI
QUIT
SET LRHD1=$GET(^(LRPRI,0))
IF $LENGTH(LRHD1)
IF $ORDER(^(1,0))
IF $GET(^DIC(4,+LRHD1,99))
SET $PIECE(LRHD1,U)=$PIECE(^(99),U)
Begin DoDot:1
+1 SET LRHD1="$"_$EXTRACT(LRHD1,1,30)
+2 SET LRSITE=0
FOR
SET LRSITE=+$ORDER(^LRO(67.9,LRPRI,1,LRSITE))
if 'LRSITE
QUIT
SET LRHD2=$GET(^(LRSITE,0))
IF $LENGTH(LRHD2)
IF $ORDER(^(1,0))
IF $GET(^DIC(4,+LRHD2,99))
SET $PIECE(LRHD2,U)=$PIECE(^(99),U)
Begin DoDot:2
+3 SET LRHD2="$$"_$EXTRACT(LRHD2,1,30)
+4 SET LRDAT=($EXTRACT(LRSDT,1,5)_"00"-.9999)
FOR
SET LRDAT=+$ORDER(^LRO(67.9,LRPRI,1,LRSITE,1,"B",LRDAT))
if 'LRDAT!($EXTRACT(LRDAT,1,5)>$EXTRACT(LREDT,1,5))
QUIT
SET LRDATE=$ORDER(^(LRDAT,0))
IF LRDATE
Begin DoDot:3
+5 SET LRDATEP=$PIECE($GET(^LRO(67.9,LRPRI,1,LRSITE,1,LRDATE,0)),U)
IF LRDATEP
SET ^LAH("LABWL",0)=1+^LAH("LABWL",0)
SET CNT=^(0)
SET ^(CNT)=LRHD1_LRHD2_"$$$"_LRDATEP
Begin DoDot:4
+6 WRITE !,$$FMTE^XLFDT(LRDAT,"1D")
SET LRCC=0
+7 FOR
SET LRCC=+$ORDER(^LRO(67.9,LRPRI,1,LRSITE,1,LRDATE,1,LRCC))
if 'LRCC
QUIT
if $GET(^(LRCC,2))
Begin DoDot:5
+8 SET LRCCN=$GET(^LRO(67.9,LRPRI,1,LRSITE,1,LRDATE,1,LRCC,0))
+9 IF LRCCN
SET $PIECE(LRCCN,U,9)=$SELECT($EXTRACT($PIECE(LRCCN,U,9))="+":$EXTRACT($PIECE(LRCCN,U,9),2,50),1:$EXTRACT($PIECE(LRCCN,U,9),1,50))
Begin DoDot:6
+10 KILL LRSECT
SET CNT=CNT+1
SET LRNCCN1=$PIECE(LRCCN,U)
SET LRDA=+$ORDER(^LAM("C",LRNCCN1_" ",0))
+11 if 'LRDA
QUIT
+12 SET LRSECT=$EXTRACT($PIECE($GET(^LAB(64.21,+$PIECE($GET(^LAM(LRDA,0)),U,15),0)),U,2),1,3)
if '$LENGTH(LRSECT)
SET LRSECT="NAS"
+13 SET LRNCCN2=$EXTRACT(($PIECE(LRNCCN1,".",2)_"00000"),1,5)
if $LENGTH($PIECE(LRNCCN1,"."))=5
SET LRNCCN1="0"_LRNCCN1
+14 SET $PIECE(LRCCN,U)=$PIECE(LRNCCN1,".")_"."_LRNCCN2_$SELECT($DATA(LRSECT):LRSECT,1:"NAS")
+15 SET ^LAH("LABWL",CNT)="*"_$PIECE(LRCCN,U,1,8)_U_$PIECE(LRCCN,U,10)_U_$PIECE(LRCCN,U,11)_U_$PIECE(LRCCN,U,12)
+16 SET CNT=CNT+1
SET ^LAH("LABWL",CNT)="\"_$EXTRACT($$UP^XLFSTR($PIECE(LRCCN,U,9)),1,50)
+17 DO TREA
End DoDot:6
End DoDot:5
+18 SET ^LAH("LABWL",0)=CNT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
TREA ;
+1 SET LRTRE=0
SET STR="-"
FOR
SET LRTRE=+$ORDER(^LRO(67.9,LRPRI,1,LRSITE,1,LRDATE,1,LRCC,1,LRTRE))
if 'LRTRE
QUIT
SET LRTRED=$GET(^(LRTRE,0))
IF $LENGTH(LRTRED)
SET LRTRED=$PIECE(LRTRED,U,1,2)
if ($LENGTH(LRTRED)+$LENGTH(STR))>79
DO LONG
SET STR=STR_"|"_LRTRED
+2 IF $LENGTH(STR)>1
SET CNT=CNT+1
SET ^LAH("LABWL",CNT)=STR
SET ^(0)=CNT
+3 QUIT
LONG ;
+1 SET CNT=CNT+1
SET ^LAH("LABWL",CNT)=STR
SET STR="-"
+2 QUIT
STOP ;
+1 KILL %DT,BLK,CNT,LRCC,LRCCN,LRNCCN1,LRNCCN2,LRDA,LRDATE,LRDATEP,LREDT,LRHD1
+2 KILL LRDAT,LRHD2,LRML,LRPRI,LRSDT,LRSITE,LRTRE,LRTRED,STR,Y,Y2
+3 QUIT
