LRAPQAT1 ;AVAMC/REG/CYM - QA CODE SEARCH ; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**1006,201,1018,315,1031,1034**;NOV 1, 1997;Build 188
;
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)
S DFN=$P(X,"^",2),LRQ=0,SEX=$P(X,"^",4),HRCN=$P(X,"^"),Y=$P(X,"^",3) S DOB=$$FMTE^XLFDT(Y) ;IHS/ANMC/CLS 11/1/95
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
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
Q:'DFN!(LR("Q")) D @$S($$ISPIMS^BLRUTIL:"INP^VADPT",1:"INP^BLRDPT") Q:VAIN(1)']"" D A ;IHS/ANMC/CLS 11/1/95
;----- END IHS MODIFICATIONS
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
W !,"Adm: ",$P(LRADM,"@"),?35,LRWARD
W !,?12,"Specialty: ",$P(LRADM,"@"),?35,LRTS
Q:'LRPTF
I $D(^DGPT(LRPTF,70)),$P(^(70),"^",10) S W=^(70) F X=10,11,16:1:24 I $P(W,"^",X) S LRF($P(W,"^",X))=""
F Y=0:0 S Y=$O(^DGPT(LRPTF,"M",Y)) Q:'Y S W=^(Y,0) F X=5:1:9,11:1:15 I $P(W,"^",X) S LRF($P(W,"^",X))=""
I $D(^DGPT(LRPTF,"401P")) S W=^("401P") F X=1:1:5 I $P(W,"^",X) S LRC($P(W,"^",X))=""
F Y=0:0 S Y=$O(^DGPT(LRPTF,"P",Y)) Q:'Y S W=^(Y,0) F X=5:1:9 I $P(W,"^",X) S LRC($P(W,"^",X))=""
F Y=0:0 S Y=$O(^DGPT(LRPTF,"S",Y)) Q:'Y S W=^(Y,0) F X=8:1:12 I $P(W,"^",X) S LRC($P(W,"^",X))=""
N LRTMP,LRX
F LRTMP=0:0 S LRTMP=$O(LRF(LRTMP)) Q:'LRTMP D
. ; S LRX=$$ICDDX^ICDCODE(LRTMP,,,1)
. S LRX=$$ICDDX^ICDEX(LRTMP,,,"I",1) ; IHS/MSC/MKK - LR*5.2*1034
. 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^ICDCODE(LRTMP,,,1)
. I +LRX=-1 Q
. W !,$P(LRX,"^",2),?10,$P(LRX,"^",5)
. Q
Q
LRAPQAT1 ;AVAMC/REG/CYM - QA CODE SEARCH ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**1006,201,1018,315,1031,1034**;NOV 1, 1997;Build 188
+2 ;
+3 DO EN^LRUA
SET (LR("W"),LRS(5),LRQ(9),LRQ(3))=1
SET LRSDT=9999999-LRSDT
SET LRP=0
+4 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
+5 QUIT
L ; S DFN=$P(X,"^",2),LRQ=0,SEX=$P(X,"^",4),SSN=$P(X,"^"),Y=$P(X,"^",3) S DOB=$$FMTE^XLFDT(Y)
+1 ;IHS/ANMC/CLS 11/1/95
SET DFN=$PIECE(X,"^",2)
SET LRQ=0
SET SEX=$PIECE(X,"^",4)
SET HRCN=$PIECE(X,"^")
SET Y=$PIECE(X,"^",3)
SET DOB=$$FMTE^XLFDT(Y)
+2 IF '$DATA(^LR(LRDFN,"SP"))&('$DATA(^LR(LRDFN,"CY")))&('$DATA(^LR(LRDFN,"EM")))
GOTO AU
+3 DO ^LRAPT1
IF LR("Q")
QUIT
AU IF $DATA(^LR(LRDFN,"AU"))
IF +^("AU")
DO ^LRAPT2
+1 ; Q:'DFN!(LR("Q")) D INP^VADPT Q:VAIN(1)']"" D A
+2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+3 ;IHS/ANMC/CLS 11/1/95
IF 'DFN!(LR("Q"))
QUIT
DO @$SELECT($$ISPIMS^BLRUTIL:"INP^VADPT",1:"INP^BLRDPT")
IF VAIN(1)']""
QUIT
DO A
+4 ;----- END IHS MODIFICATIONS
+5 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 WRITE !,"Adm: ",$PIECE(LRADM,"@"),?35,LRWARD
+6 WRITE !,?12,"Specialty: ",$PIECE(LRADM,"@"),?35,LRTS
+7 IF 'LRPTF
QUIT
+8 IF $DATA(^DGPT(LRPTF,70))
IF $PIECE(^(70),"^",10)
SET W=^(70)
FOR X=10,11,16:1:24
IF $PIECE(W,"^",X)
SET LRF($PIECE(W,"^",X))=""
+9 FOR Y=0:0
SET Y=$ORDER(^DGPT(LRPTF,"M",Y))
IF 'Y
QUIT
SET W=^(Y,0)
FOR X=5:1:9,11:1:15
IF $PIECE(W,"^",X)
SET LRF($PIECE(W,"^",X))=""
+10 IF $DATA(^DGPT(LRPTF,"401P"))
SET W=^("401P")
FOR X=1:1:5
IF $PIECE(W,"^",X)
SET LRC($PIECE(W,"^",X))=""
+11 FOR Y=0:0
SET Y=$ORDER(^DGPT(LRPTF,"P",Y))
IF 'Y
QUIT
SET W=^(Y,0)
FOR X=5:1:9
IF $PIECE(W,"^",X)
SET LRC($PIECE(W,"^",X))=""
+12 FOR Y=0:0
SET Y=$ORDER(^DGPT(LRPTF,"S",Y))
IF 'Y
QUIT
SET W=^(Y,0)
FOR X=8:1:12
IF $PIECE(W,"^",X)
SET LRC($PIECE(W,"^",X))=""
+13 NEW LRTMP,LRX
+14 FOR LRTMP=0:0
SET LRTMP=$ORDER(LRF(LRTMP))
IF 'LRTMP
QUIT
Begin DoDot:1
+15 ; S LRX=$$ICDDX^ICDCODE(LRTMP,,,1)
+16 ; IHS/MSC/MKK - LR*5.2*1034
SET LRX=$$ICDDX^ICDEX(LRTMP,,,"I",1)
+17 IF +LRX=-1
QUIT
+18 WRITE !,$PIECE(LRX,"^",2),?10,$PIECE(LRX,"^",4)
+19 QUIT
End DoDot:1
+20 FOR LRTMP=0:0
SET LRTMP=$ORDER(LRC(LRTMP))
IF 'LRTMP
QUIT
Begin DoDot:1
+21 SET LRX=$$ICDOP^ICDCODE(LRTMP,,,1)
+22 IF +LRX=-1
QUIT
+23 WRITE !,$PIECE(LRX,"^",2),?10,$PIECE(LRX,"^",5)
+24 QUIT
End DoDot:1
+25 QUIT
