LRAPQAT1 ;AVAMC/REG/CYM,WOIFO/PMK - QA CODE SEARCH ;12/31/2014 11:06 AM
;;5.2;LAB SERVICE;**201,315,422,442**;Sep 27, 1994;Build 15
;
; Reference to $$ICDDX^ICDEX supported by ICR #5747
; Reference to $$ICDOP^ICDEX supported by ICR #5747
; Reference to DGPTFUT supported by IA #6130
;
D EN^LRUA S (LR("W"),LRS(5),LRQ(9),LRQ(3))=1,LRSDT=9999999-LRSDT,LRP=0
F LRB=0:0 S LRP=$O(^TMP("LRAP",$J,LRP)) Q:LRP=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMP("LRAP",$J,LRP,LRDFN)) Q:'LRDFN!(LR("Q")) S X=^(LRDFN) D L
Q
L S DFN=$P(X,"^",2),LRQ=0,SEX=$P(X,"^",4),SSN=$P(X,"^"),Y=$P(X,"^",3) S DOB=$$FMTE^XLFDT(Y)
G:'$D(^LR(LRDFN,"SP"))&('$D(^LR(LRDFN,"CY")))&('$D(^LR(LRDFN,"EM"))) AU
D ^LRAPT1 Q:LR("Q")
AU I $D(^LR(LRDFN,"AU")),+^("AU") D ^LRAPT2
Q:'DFN!(LR("Q")) D INP^VADPT Q:VAIN(1)']"" D A
Q
A S LRPTF=VAIN(10)
S LRADM=$P(VAIN(7),U,2)
S LRWARD=$P(VAIN(4),U,2)
S LRTS=$P(VAIN(3),U,2)
K VAIN
N LRC,LRF
W !,"Adm: ",$P(LRADM,"@"),?35,LRWARD
W !,?12,"Specialty: ",$P(LRADM,"@"),?35,LRTS
Q:'LRPTF
D LOOKUP(LRPTF,.LRF,.LRC)
; output the results
N LRTMP,LRX
F LRTMP=0:0 S LRTMP=$O(LRF(LRTMP)) Q:'LRTMP D
. S LRX=$$ICDDX^ICDEX(LRTMP,,,"I")
. I +LRX=-1 Q
. W !,$P(LRX,"^",2),?10,$P(LRX,"^",4)
. Q
F LRTMP=0:0 S LRTMP=$O(LRC(LRTMP)) Q:'LRTMP D
. S LRX=$$ICDOP^ICDEX(LRTMP,,,"I")
. I +LRX=-1 Q
. W !,$P(LRX,"^",2),?10,$P(LRX,"^",5)
. Q
Q
;
LOOKUP(LRPTF,LRF,LRC) ; get icd codes from Patient Treatment File
D GETCODES(701,LRPTF,.LRF) ; 70 - primary/secondary diagnosis
D GETCODES(501,LRPTF,.LRF) ; M - movements
D GETCODES(601,LRPTF,.LRC) ; P - procedures
D GETCODES(401,LRPTF,.LRC) ; S - surgeries
Q
;
GETCODES(DGA,DGB,ARRAY) ; get codes from Patient Treatment File (#45)
N DGC,DGD,I
I DGA=701 D
. D PTFICD^DGPTFUT(DGA,DGB,,.DGD),COPY(.DGD,.ARRAY)
. Q
E D
. D PTFIEN^DGPTFUT(DGA,DGB,.DGC)
. S I="" F S I=$O(DGC(I)) Q:I="" D
. . D PTFICD^DGPTFUT(DGA,DGB,I,.DGD),COPY(.DGD,.ARRAY)
. . Q
. Q
Q
;
COPY(DGD,ARRAY) ; copy results into ARRAY
N I
S I="" F S I=$O(DGD(I)) Q:I="" S ARRAY($P(DGD(I),"^",1))=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPQAT1 2114 printed Oct 16, 2024@18:08:47 Page 2
LRAPQAT1 ;AVAMC/REG/CYM,WOIFO/PMK - QA CODE SEARCH ;12/31/2014 11:06 AM
+1 ;;5.2;LAB SERVICE;**201,315,422,442**;Sep 27, 1994;Build 15
+2 ;
+3 ; Reference to $$ICDDX^ICDEX supported by ICR #5747
+4 ; Reference to $$ICDOP^ICDEX supported by ICR #5747
+5 ; Reference to DGPTFUT supported by IA #6130
+6 ;
+7 DO EN^LRUA
SET (LR("W"),LRS(5),LRQ(9),LRQ(3))=1
SET LRSDT=9999999-LRSDT
SET LRP=0
+8 FOR LRB=0:0
SET LRP=$ORDER(^TMP("LRAP",$JOB,LRP))
if LRP=""!(LR("Q"))
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^TMP("LRAP",$JOB,LRP,LRDFN))
if 'LRDFN!(LR("Q"))
QUIT
SET X=^(LRDFN)
DO L
+9 QUIT
L SET DFN=$PIECE(X,"^",2)
SET LRQ=0
SET SEX=$PIECE(X,"^",4)
SET SSN=$PIECE(X,"^")
SET Y=$PIECE(X,"^",3)
SET DOB=$$FMTE^XLFDT(Y)
+1 if '$DATA(^LR(LRDFN,"SP"))&('$DATA(^LR(LRDFN,"CY")))&('$DATA(^LR(LRDFN,"EM")))
GOTO AU
+2 DO ^LRAPT1
if LR("Q")
QUIT
AU IF $DATA(^LR(LRDFN,"AU"))
IF +^("AU")
DO ^LRAPT2
+1 if 'DFN!(LR("Q"))
QUIT
DO INP^VADPT
if VAIN(1)']""
QUIT
DO A
+2 QUIT
A SET LRPTF=VAIN(10)
+1 SET LRADM=$PIECE(VAIN(7),U,2)
+2 SET LRWARD=$PIECE(VAIN(4),U,2)
+3 SET LRTS=$PIECE(VAIN(3),U,2)
+4 KILL VAIN
+5 NEW LRC,LRF
+6 WRITE !,"Adm: ",$PIECE(LRADM,"@"),?35,LRWARD
+7 WRITE !,?12,"Specialty: ",$PIECE(LRADM,"@"),?35,LRTS
+8 if 'LRPTF
QUIT
+9 DO LOOKUP(LRPTF,.LRF,.LRC)
+10 ; output the results
+11 NEW LRTMP,LRX
+12 FOR LRTMP=0:0
SET LRTMP=$ORDER(LRF(LRTMP))
if 'LRTMP
QUIT
Begin DoDot:1
+13 SET LRX=$$ICDDX^ICDEX(LRTMP,,,"I")
+14 IF +LRX=-1
QUIT
+15 WRITE !,$PIECE(LRX,"^",2),?10,$PIECE(LRX,"^",4)
+16 QUIT
End DoDot:1
+17 FOR LRTMP=0:0
SET LRTMP=$ORDER(LRC(LRTMP))
if 'LRTMP
QUIT
Begin DoDot:1
+18 SET LRX=$$ICDOP^ICDEX(LRTMP,,,"I")
+19 IF +LRX=-1
QUIT
+20 WRITE !,$PIECE(LRX,"^",2),?10,$PIECE(LRX,"^",5)
+21 QUIT
End DoDot:1
+22 QUIT
+23 ;
LOOKUP(LRPTF,LRF,LRC) ; get icd codes from Patient Treatment File
+1 ; 70 - primary/secondary diagnosis
DO GETCODES(701,LRPTF,.LRF)
+2 ; M - movements
DO GETCODES(501,LRPTF,.LRF)
+3 ; P - procedures
DO GETCODES(601,LRPTF,.LRC)
+4 ; S - surgeries
DO GETCODES(401,LRPTF,.LRC)
+5 QUIT
+6 ;
GETCODES(DGA,DGB,ARRAY) ; get codes from Patient Treatment File (#45)
+1 NEW DGC,DGD,I
+2 IF DGA=701
Begin DoDot:1
+3 DO PTFICD^DGPTFUT(DGA,DGB,,.DGD)
DO COPY(.DGD,.ARRAY)
+4 QUIT
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 DO PTFIEN^DGPTFUT(DGA,DGB,.DGC)
+7 SET I=""
FOR
SET I=$ORDER(DGC(I))
if I=""
QUIT
Begin DoDot:2
+8 DO PTFICD^DGPTFUT(DGA,DGB,I,.DGD)
DO COPY(.DGD,.ARRAY)
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
COPY(DGD,ARRAY) ; copy results into ARRAY
+1 NEW I
+2 SET I=""
FOR
SET I=$ORDER(DGD(I))
if I=""
QUIT
SET ARRAY($PIECE(DGD(I),"^",1))=""
+3 QUIT
+4 ;
