- LRRP1VA ;DALOI/RWF/BA - PRINT THE DATA FOR INTERIM REPORTS, VA code ; 13-Oct-2017 14:04 ; MKK
- ;;5.2;LAB SERVICE;**1041**;NOV 01, 1997;Build 23
- ;
- ; Code moved from LRRP1 to hear due to LRRP1 becoming too large
- ;
- TEST ; EP -- Original VA Code -- IHS/OIT/MKK LR*5.2*1027
- S LRIDT=+^TMP("LR",$J,"TP",LRAAO,LRCDT,-2)
- S LRSS=$P(^TMP("LR",$J,"TP",LRAAO),U,2)
- S LR0=$S($D(^(LRAAO,LRCDT))#2:^(LRCDT),1:""),LRTC=$P(LR0,U,12)
- I LRSS="MI" D Q
- . S LRH=1 D:LRFOOT FOOT Q:LRSTOP
- . D EN1^LRMIPC
- . S LRHF=1,LRFOOT=0
- . K A,Z,LRH
- . S:LREND LREND=0,LRSTOP=1
- ;
- Q:'$G(LRCAN)&('$P(LR0,U,3)) D @$S(LRHF:"HDR",1:"CHECK") Q:LRSTOP
- S LRSPEC=+$P(LR0,U,5),X=$P(LR0,U,10) D DOC^LRX
- ;
- W !!,?7,"Provider: ",LRDOC
- W !,?7,"Specimen: ",$P(^LAB(61,LRSPEC,0),U)
- D ORU^LRRP1
- W !!,?30,"Specimen Collection Date: ",$$FMTE^XLFDT(LRCDT,"M")
- W !?5,"Test name",?30,"Result units",?51,"Ref. range",?66,"Site Code"
- S LRPO=0
- F S LRPO=$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO)) Q:LRPO'>0 S LRDATA=^(LRPO) D DATA Q:LRSTOP
- Q:LRSTOP
- ;
- I $D(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C")) D
- . W !,"Comment: " S LRCMNT=0
- . F S LRCMNT=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) Q:LRCMNT<1 D Q:LRSTOP
- . . W ^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)
- . . D CONT Q:LRSTOP
- . . W:$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) !?9
- Q:LRSTOP D EQUALS^LRX
- W !?7,"KEY: ""L""=Abnormal low, ""H""=Abnormal high, ""*""=Critical value"
- S LRFOOT=1
- Q
- ;
- DATA ; EP-- Original VA Code -- IHS/OIT/MKK LR*5.2*1027
- N LR63DATA
- ;
- S LRTSTS=+LRDATA,LRPC=$P(LRDATA,U,5),LRSUB=$P(LRDATA,U,6)
- S X=$P(LRDATA,U,7) Q:X=""
- S LR63DATA=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,$P(LRDATA,U,10),LRTSTS)
- S LRLO=$P(LR63DATA,"^",3),LRHI=$P(LR63DATA,"^",4),LRREFS=$$EN^LRLRRVF(LRLO,LRHI),LRPLS=$P(LR63DATA,"^",6),LRTHER=$P(LR63DATA,"^",7)
- I LRPLS S LRPLS(LRPLS)=LRPLS
- ;
- W !?5,$S($L($P(LRDATA,U,2))>20:$P(LRDATA,U,3),1:$P(LRDATA,U,2))
- S X=$P(LR63DATA,"^")
- W ?27,@$S(LRPC="":"$J(X,LRCW)",1:LRPC)," ",$P(LR63DATA,"^",2)
- I $X>39 W !
- W ?40,$P(LR63DATA,U,5)
- I $X>50 W !
- W ?51,LRREFS K LRREFS
- ;
- I LRPLS'="" D
- . I $X>67 W !
- . W ?68,"[",LRPLS,"]"
- D CONT Q:LRSTOP
- ;
- I $O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,0))>0 D Q:LRSTOP
- . S LRINTP=0
- . F S LRINTP=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,LRINTP)) Q:LRINTP<1 W !?7,"Eval: ",^(LRINTP) D CONT Q:LRSTOP
- ;
- Q
- ;
- CONT ; EP -- Original VA Code -- IHS/OIT/MKK LR*5.2*1027
- I $Y+5>IOSL D FOOT Q:LRSTOP D HDR W !?20,">> CONTINUATION OF ",$P(LR0,U,6)," <<",!
- Q ; End CONT Original Code
- ;
- Q:LRSTOP F I=$Y:1:IOSL-4 W !
- I $E(IOST,1,2)'="C-" W !,PNM,?40," ",SSN," ",$$HTE^XLFDT($H,"M"),! Q
- W !,PNM,?25," ",SSN," ",$$HTE^XLFDT($H,"MP"),?59," PRESS '^' TO STOP "
- R X:DTIME S:X="" X=1 S:(".^"[X)!('$T) LRSTOP=1
- Q
- HDR ; Add Printed at, page #, change age to dob 7/2002 cka -- Original VA Code -- IHS/OIT/MKK LR*5.2*1027
- W:($G(LRJ02))!($G(LRJ0))!($E(IOST,1,2)="C-") @IOF
- S LRHF=0,LRJ02=1
- I '$D(LRPG) S LRPG=0
- S LRPG=LRPG+1
- I $E(IOST,1)="P" D
- .W !!!!
- .S X="CLINICAL LABORATORY REPORT"
- .W ?(80-$L(X)\2),X,!
- I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG") D ^LRAIPRIV W !
- W "Printed at: ",?65,"page ",LRPG
- W !,$$NAME^XUAF4(DUZ(2))," (",DUZ(2),")"
- S X=$$PADD^XUAF4(DUZ(2))
- W !,$P(X,U)," ",$P(X,U,2),", ",$P(X,U,3)," ",$P(X,U,4)
- W !!,PNM,?44,"Report date: ",$$HTE^XLFDT($H,"M")
- W !?5,"SSN: ",SSN," SEX: ",SEX," DOB: ",$$FMTE^XLFDT(DOB)," LOC: ",LROC
- Q
- LRRP1VA ;DALOI/RWF/BA - PRINT THE DATA FOR INTERIM REPORTS, VA code ; 13-Oct-2017 14:04 ; MKK
- +1 ;;5.2;LAB SERVICE;**1041**;NOV 01, 1997;Build 23
- +2 ;
- +3 ; Code moved from LRRP1 to hear due to LRRP1 becoming too large
- +4 ;
- TEST ; EP -- Original VA Code -- IHS/OIT/MKK LR*5.2*1027
- +1 SET LRIDT=+^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-2)
- +2 SET LRSS=$PIECE(^TMP("LR",$JOB,"TP",LRAAO),U,2)
- +3 SET LR0=$SELECT($DATA(^(LRAAO,LRCDT))#2:^(LRCDT),1:"")
- SET LRTC=$PIECE(LR0,U,12)
- +4 IF LRSS="MI"
- Begin DoDot:1
- +5 SET LRH=1
- IF LRFOOT
- DO FOOT
- IF LRSTOP
- QUIT
- +6 DO EN1^LRMIPC
- +7 SET LRHF=1
- SET LRFOOT=0
- +8 KILL A,Z,LRH
- +9 IF LREND
- SET LREND=0
- SET LRSTOP=1
- End DoDot:1
- QUIT
- +10 ;
- +11 IF '$GET(LRCAN)&('$PIECE(LR0,U,3))
- QUIT
- DO @$SELECT(LRHF:"HDR",1:"CHECK")
- IF LRSTOP
- QUIT
- +12 SET LRSPEC=+$PIECE(LR0,U,5)
- SET X=$PIECE(LR0,U,10)
- DO DOC^LRX
- +13 ;
- +14 WRITE !!,?7,"Provider: ",LRDOC
- +15 WRITE !,?7,"Specimen: ",$PIECE(^LAB(61,LRSPEC,0),U)
- +16 DO ORU^LRRP1
- +17 WRITE !!,?30,"Specimen Collection Date: ",$$FMTE^XLFDT(LRCDT,"M")
- +18 WRITE !?5,"Test name",?30,"Result units",?51,"Ref. range",?66,"Site Code"
- +19 SET LRPO=0
- +20 FOR
- SET LRPO=$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO))
- IF LRPO'>0
- QUIT
- SET LRDATA=^(LRPO)
- DO DATA
- IF LRSTOP
- QUIT
- +21 IF LRSTOP
- QUIT
- +22 ;
- +23 IF $DATA(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C"))
- Begin DoDot:1
- +24 WRITE !,"Comment: "
- SET LRCMNT=0
- +25 FOR
- SET LRCMNT=+$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))
- IF LRCMNT<1
- QUIT
- Begin DoDot:2
- +26 WRITE ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT)
- +27 DO CONT
- IF LRSTOP
- QUIT
- +28 IF $ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))
- WRITE !?9
- End DoDot:2
- IF LRSTOP
- QUIT
- End DoDot:1
- +29 IF LRSTOP
- QUIT
- DO EQUALS^LRX
- +30 WRITE !?7,"KEY: ""L""=Abnormal low, ""H""=Abnormal high, ""*""=Critical value"
- +31 SET LRFOOT=1
- +32 QUIT
- +33 ;
- DATA ; EP-- Original VA Code -- IHS/OIT/MKK LR*5.2*1027
- +1 NEW LR63DATA
- +2 ;
- +3 SET LRTSTS=+LRDATA
- SET LRPC=$PIECE(LRDATA,U,5)
- SET LRSUB=$PIECE(LRDATA,U,6)
- +4 SET X=$PIECE(LRDATA,U,7)
- IF X=""
- QUIT
- +5 SET LR63DATA=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,$PIECE(LRDATA,U,10),LRTSTS)
- +6 SET LRLO=$PIECE(LR63DATA,"^",3)
- SET LRHI=$PIECE(LR63DATA,"^",4)
- SET LRREFS=$$EN^LRLRRVF(LRLO,LRHI)
- SET LRPLS=$PIECE(LR63DATA,"^",6)
- SET LRTHER=$PIECE(LR63DATA,"^",7)
- +7 IF LRPLS
- SET LRPLS(LRPLS)=LRPLS
- +8 ;
- +9 WRITE !?5,$SELECT($LENGTH($PIECE(LRDATA,U,2))>20:$PIECE(LRDATA,U,3),1:$PIECE(LRDATA,U,2))
- +10 SET X=$PIECE(LR63DATA,"^")
- +11 WRITE ?27,@$SELECT(LRPC="":"$J(X,LRCW)",1:LRPC)," ",$PIECE(LR63DATA,"^",2)
- +12 IF $X>39
- WRITE !
- +13 WRITE ?40,$PIECE(LR63DATA,U,5)
- +14 IF $X>50
- WRITE !
- +15 WRITE ?51,LRREFS
- KILL LRREFS
- +16 ;
- +17 IF LRPLS'=""
- Begin DoDot:1
- +18 IF $X>67
- WRITE !
- +19 WRITE ?68,"[",LRPLS,"]"
- End DoDot:1
- +20 DO CONT
- IF LRSTOP
- QUIT
- +21 ;
- +22 IF $ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,0))>0
- Begin DoDot:1
- +23 SET LRINTP=0
- +24 FOR
- SET LRINTP=+$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,LRINTP))
- IF LRINTP<1
- QUIT
- WRITE !?7,"Eval: ",^(LRINTP)
- DO CONT
- IF LRSTOP
- QUIT
- End DoDot:1
- IF LRSTOP
- QUIT
- +25 ;
- +26 QUIT
- +27 ;
- CONT ; EP -- Original VA Code -- IHS/OIT/MKK LR*5.2*1027
- +1 IF $Y+5>IOSL
- DO FOOT
- IF LRSTOP
- QUIT
- DO HDR
- WRITE !?20,">> CONTINUATION OF ",$PIECE(LR0,U,6)," <<",!
- +2 ; End CONT Original Code
- QUIT
- +3 ;
- +1 IF LRSTOP
- QUIT
- FOR I=$Y:1:IOSL-4
- WRITE !
- +2 IF $EXTRACT(IOST,1,2)'="C-"
- WRITE !,PNM,?40," ",SSN," ",$$HTE^XLFDT($HOROLOG,"M"),!
- QUIT
- +3 WRITE !,PNM,?25," ",SSN," ",$$HTE^XLFDT($HOROLOG,"MP"),?59," PRESS '^' TO STOP "
- +4 READ X:DTIME
- IF X=""
- SET X=1
- IF (".^"[X)!('$TEST)
- SET LRSTOP=1
- +5 QUIT
- HDR ; Add Printed at, page #, change age to dob 7/2002 cka -- Original VA Code -- IHS/OIT/MKK LR*5.2*1027
- +1 IF ($GET(LRJ02))!($GET(LRJ0))!($EXTRACT(IOST,1,2)="C-")
- WRITE @IOF
- +2 SET LRHF=0
- SET LRJ02=1
- +3 IF '$DATA(LRPG)
- SET LRPG=0
- +4 SET LRPG=LRPG+1
- +5 IF $EXTRACT(IOST,1)="P"
- Begin DoDot:1
- +6 WRITE !!!!
- +7 SET X="CLINICAL LABORATORY REPORT"
- +8 WRITE ?(80-$LENGTH(X)\2),X,!
- End DoDot:1
- +9 IF $DATA(DUZ("AG"))
- IF $LENGTH(DUZ("AG"))
- IF "ARMYAFN"[DUZ("AG")
- DO ^LRAIPRIV
- WRITE !
- +10 WRITE "Printed at: ",?65,"page ",LRPG
- +11 WRITE !,$$NAME^XUAF4(DUZ(2))," (",DUZ(2),")"
- +12 SET X=$$PADD^XUAF4(DUZ(2))
- +13 WRITE !,$PIECE(X,U)," ",$PIECE(X,U,2),", ",$PIECE(X,U,3)," ",$PIECE(X,U,4)
- +14 WRITE !!,PNM,?44,"Report date: ",$$HTE^XLFDT($HOROLOG,"M")
- +15 WRITE !?5,"SSN: ",SSN," SEX: ",SEX," DOB: ",$$FMTE^XLFDT(DOB)," LOC: ",LROC
- +16 QUIT
