- 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 Mar 13, 2025@21:16:57 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
