- 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
