BHSPL ;IHS/MSC/MGH - Health Summary for Problem list ;18-Sep-2013 09:44;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,6,8**;Mar 17,2006;Build 22
;===================================================================
; IHS/TUCSON/LAB - PART 4 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 06/24/97 2:42 PM ]
;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997
;Copied and changed to be used in VA health summary
;Patch 8 updated for SNOMED problem list
;
PROB ; EP ******************** PROBLEM / NOTES * 9000011 *********
APROB S BHSTAT="ASEO" G COMMON
IPROB S BHSTAT="I"
; <SETUP>
COMMON ;
N BHSPAT,BHSX,BHSFPP,BHSFAC,BHSQ
S BHSPAT=DFN
;Q:'$D(^AUPNPROB("AC",BHSPAT))
K BHSDFT S BHSNDF=0
S BHSFAC="" F BHSQ=0:0 S BHSFAC=$O(^AUPNPROB("AA",BHSPAT,BHSFAC)) Q:'BHSFAC D PROBSCH
;Q:BHSNDF=0
D CKP^GMTSUP G:$D(GMTSQIT) PROBX
; <DISPLAY>
D CKP^GMTSUP Q:$D(GMTSQIT)
I BHSNDF>0 W ?13,"ENT. MODIFIED",!
S BHSFPP="" F BHSQ=0:0 S BHSFPP=$O(BHSDFT(BHSFPP)) Q:BHSFPP="" S BHSDFN=BHSDFT(BHSFPP) D PROBDSP
COMMON1 ;additional stuff for review IHS/MSC/MGH
;get date last reviewed and display
S BHSX=$$LASTPLR^APCLAPI6(BHSPAT,,DT,"A")
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,"Problem List Reviewed On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",?54,$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,25),!
S BHSX=$$LASTPLU^APCLAPI6(BHSPAT,,DT,"A")
D CKP^GMTSUP Q:$D(GMTSQIT)
W "Problem List Updated On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",?54,$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,25),!
I BHSTAT]"" D
.S BHSX=$$LASTNAP^APCLAPI6(BHSPAT,,DT,"A")
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W "No Active Problems Documented On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,25),!
PROBX K BHSDFT,BHSNDF,BHSFPP,BHSFAC,BHSPLN,BHSPBN,BHSDTM,BHSDTN,BHSPRB,BHSTAT,BHSNFP,BHSNRQ,BHSPNM,BHSDFN,BHSFCN,BHSICD,BHSDOO
K BHSICL,BHSILN,BHSN,BHSNAR,BHSNTE,BHSQ,BHSTXT,BHSSNO
K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,Y,X
Q
PROBSCH ;
S BHSPRB="" F BHSQ=0:0 S BHSPRB=$O(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB)) Q:BHSPRB="" D
.S BHSDFN=$O(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB,"")) Q:BHSDFN="" D
..S:BHSTAT[$P(^AUPNPROB(BHSDFN,0),U,12) BHSNDF=BHSNDF+1,BHSDFT(BHSFAC_BHSPRB)=BHSDFN
Q
PROBDSP ;
; <SETUP PROBLEM>
S BHSN=^AUPNPROB(BHSDFN,0)
S BHSSNO=$$GET1^DIQ(9000011,BHSDFN,80001)
S BHSICD=$P(BHSN,U,1) D GETPLICD^BHSUTL
S BHSNRQ=$P(BHSN,U,5) D GETNARR^BHSUTL
S BHSITE=$P(BHSN,U,6) D GETSITE^BHSUTL
S BHSPNM=$P(BHSN,U,7) ;***** EDE *****
S BHSPNM=BHSNAB_BHSPNM ;***** EDE *****
S X=$P(BHSN,U,3) D REGDT4^GMTSU S BHSDTM=X
S X=$P(BHSN,U,8) D REGDT4^GMTSU S BHSDTN=X
S X=$P(BHSN,U,13)
I X]"" D REGDT4^GMTSU S BHSDOO=X
I X="" S BHSDOO=""
S:BHSDOO]"" BHSNTE=" (onset "_BHSDOO_")"
S BHSPLN=BHSPNM_$E(" ",1,12-$L(BHSPNM))_BHSDTN_" "_BHSDTM_" "
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG ?13,"ENT. MODIFIED",!
I BHSSNO'="" S BHSNRQ=BHSNRQ_" ("_BHSSNO_")"
W BHSPLN S BHSICL=30,BHSILN=50 D PRTICD^BHSUTL
D NOTEDSP
D QUAL(BHSDFN)
D RECON(BHSDFN)
Q
NOTEDSP ; DISPLAY NOTES UNDER BHSPRBLEM
S BHSNFP=0 F BHSQ=0:0 S BHSNFP=$O(^AUPNPROB(BHSDFN,11,BHSNFP)) Q:'BHSNFP D DSPFACN
Q
DSPFACN ; DISPLAY NOTES FOR SELECTED APSHCFACILITY
Q:$D(^AUPNPROB(BHSDFN,11,BHSNFP,11,0))'=1 Q:$O(^(0))=""
S BHSITE=^AUPNPROB(BHSDFN,11,BHSNFP,0) D GETSITE^BHSUTL S BHSFCN=BHSNAB
S BHSNDF=0 F BHSQ=0:0 S BHSNDF=$O(^AUPNPROB(BHSDFN,11,BHSNFP,11,BHSNDF)) Q:'BHSNDF S BHSN=^(BHSNDF,0) D DSPN
Q
DSPN ; DISPLAY SINGLE NOTE
Q:$P(BHSN,U,4)="I"
S BHSNAR=$P(BHSN,U,3) S X=$P(BHSN,U,5) ;S:Y="" Y=" "
I X>0 D REGDT4^GMTSU S X=X_" - "
S BHSNAR=BHSNAR_" "_X
;W ?22,BHSFCN,"#",$E(1000+$P(BHSN,U,1),2,4)_" ",$P(BHSN,U,3),!
F BHSQ=0:0 Q:$E(BHSFCN)'=" " S BHSFCN=$E(BHSFCN,2,99)
D CKP^GMTSUP Q:$D(GMTSQIT) W ?10,BHSFCN_" Note "_$P(BHSN,U)
S BHSTXT=BHSNAR,BHSICL=31 D PRTTXT^BHSUTL
Q
PLDETAIL ;DISPLAY PROBLEM DETAILS IN HELATH SUMMARY
N PROB,CNT,RET,PRIEN,I,STAT,LINE,Y,TYPE
S TYPE="ASEO"
I $G(NUM)="" S NUM=99999
S RET=""
S (CNT,PRIEN)=0
D CKP^GMTSUP Q:$D(GMTSQIT)
F S PRIEN=$O(^AUPNPROB("AC",DFN,PRIEN)) Q:'PRIEN D
.;Check for which statuses to return
.S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
.Q:STAT="D"
.Q:TYPE'[STAT
.D DETAIL^BGOPRDD(.RET,PRIEN,DFN,"A",NUM) ;Get a detail report on one problem
.S LINE=0
.F S LINE=$O(@RET@(LINE)) Q:LINE="" D
..D CKP^GMTSUP Q:$D(GMTSQIT) I GMTSNPG W !,"Active Problem List",!
..W @RET@(LINE),!
K RET
Q
INPROB ;DISPLAY PROBLEM DETAILS OF INACTIVE PROBLEMS
N PROB,CNT,RET,PRIEN,I,STAT,LINE,Y
S TYPE="I"
;For Visit instructions and treatments, the default is the latest visit
I $G(NUM)="" S NUM=99999
S RET=$$TMPGBL
S (CNT,PRIEN)=0
D CKP^GMTSUP Q:$D(GMTSQIT)
F S PRIEN=$O(^AUPNPROB("AC",DFN,PRIEN)) Q:'PRIEN D
.;Check for which statuses to return
.S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
.Q:STAT="D"
.Q:TYPE'[STAT
.D DETAIL^BGOPRDD(.RET,PRIEN,DFN,"C",NUM) ;Get a detail report on one problem
.S LINE=0
.F S LINE=$O(@RET@(LINE)) Q:LINE="" D
..D CKP^GMTSUP Q:$D(GMTSQIT) I GMTSNPG W !,"Inactive Problem List",!
..W @RET@(LINE),!
K RET
Q
RECON(PROB) ;Find when this problem was reconciled
N REC,IEN,AIEN,WHEN,BY
S REC=""
F S REC=$O(^BEHOCIR("G","P",PROB,REC)) Q:REC="" D
.S IEN="" F S IEN=$O(^BEHOCIR("G","P",PROB,REC,IEN)) Q:IEN="" D
..S AIEN=IEN_","_REC_","
..S WHEN=$$GET1^DIQ(90461.632,AIEN,.01)
..S BY=$$GET1^DIQ(90461.632,AIEN,.02)
..W ?10,"Reconciled on: "_WHEN_" by "_BY,!
Q
QUAL(IEN) ;Get any qualifiers for this problem
N AIEN,IEN2,BY,WHEN,X,FNUM,Q,STRING,STRING2,STRING3
I $D(^AUPNPROB(IEN,13))!($D(^AUPNPROB(IEN,17)))!($D(^AUPNPROB(IEN,18)))
S (STRING,STRING2,STRING3)=""
F X=13,17,18 D
.S FNUM=$S(X=13:9000011.13,X=17:9000011.17,X=18:9000011.18)
.S IEN2=0 F S IEN2=$O(^AUPNPROB(IEN,X,IEN2)) Q:'+IEN2 D
..S AIEN=IEN2_","_IEN_","
..S Q=$$GET1^DIQ(FNUM,AIEN,.01)
..S Q=$$CONCEPT^BGOPAUD(Q)
..I X=13 D
...I STRING="" S STRING=Q
...E S STRING=STRING_" "_Q
..I X=17 D
...I STRING2="" S STRING2=Q
...E S STRING2=STRING2_" "_Q
..I X=18 D
...I STRING="" S STRING=Q
...E S STRING=STRING_" "_Q
I STRING'=""!(STRING2'="")!(STRING3'="") W !,?10,"QUALIFIERS",!
I STRING'="" W ?10,STRING,!
I STRING2'="" W ?10,STRING2,!
I STRING3'="" W ?10,STRING3,!
TMPGBL() ;EP
K ^TMP("BHSPL",$J) Q $NA(^($J))
BHSPL ;IHS/MSC/MGH - Health Summary for Problem list ;18-Sep-2013 09:44;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,6,8**;Mar 17,2006;Build 22
+2 ;===================================================================
+3 ; IHS/TUCSON/LAB - PART 4 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 06/24/97 2:42 PM ]
+4 ;;2.0;IHS RPMS/PCC Health Summary;;JUN 24, 1997
+5 ;Copied and changed to be used in VA health summary
+6 ;Patch 8 updated for SNOMED problem list
+7 ;
PROB ; EP ******************** PROBLEM / NOTES * 9000011 *********
APROB SET BHSTAT="ASEO"
GOTO COMMON
IPROB SET BHSTAT="I"
+1 ; <SETUP>
COMMON ;
+1 NEW BHSPAT,BHSX,BHSFPP,BHSFAC,BHSQ
+2 SET BHSPAT=DFN
+3 ;Q:'$D(^AUPNPROB("AC",BHSPAT))
+4 KILL BHSDFT
SET BHSNDF=0
+5 SET BHSFAC=""
FOR BHSQ=0:0
SET BHSFAC=$ORDER(^AUPNPROB("AA",BHSPAT,BHSFAC))
IF 'BHSFAC
QUIT
DO PROBSCH
+6 ;Q:BHSNDF=0
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
GOTO PROBX
+8 ; <DISPLAY>
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+10 IF BHSNDF>0
WRITE ?13,"ENT. MODIFIED",!
+11 SET BHSFPP=""
FOR BHSQ=0:0
SET BHSFPP=$ORDER(BHSDFT(BHSFPP))
IF BHSFPP=""
QUIT
SET BHSDFN=BHSDFT(BHSFPP)
DO PROBDSP
COMMON1 ;additional stuff for review IHS/MSC/MGH
+1 ;get date last reviewed and display
+2 SET BHSX=$$LASTPLR^APCLAPI6(BHSPAT,,DT,"A")
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+4 WRITE !,"Problem List Reviewed On: ",?36,$$FMTE^XLFDT($PIECE(BHSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(BHSX,U,3):$PIECE($GET(^VA(200,$PIECE(BHSX,U,3),0)),U),1:""),1,25),!
+5 SET BHSX=$$LASTPLU^APCLAPI6(BHSPAT,,DT,"A")
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 WRITE "Problem List Updated On: ",?36,$$FMTE^XLFDT($PIECE(BHSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(BHSX,U,3):$PIECE($GET(^VA(200,$PIECE(BHSX,U,3),0)),U),1:""),1,25),!
+8 IF BHSTAT]""
Begin DoDot:1
+9 SET BHSX=$$LASTNAP^APCLAPI6(BHSPAT,,DT,"A")
+10 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+11 WRITE "No Active Problems Documented On: ",?36,$$FMTE^XLFDT($PIECE(BHSX,U,1))
WRITE ?51,"By: ",$EXTRACT($SELECT($PIECE(BHSX,U,3):$PIECE($GET(^VA(200,$PIECE(BHSX,U,3),0)),U),1:""),1,25),!
End DoDot:1
PROBX KILL BHSDFT,BHSNDF,BHSFPP,BHSFAC,BHSPLN,BHSPBN,BHSDTM,BHSDTN,BHSPRB,BHSTAT,BHSNFP,BHSNRQ,BHSPNM,BHSDFN,BHSFCN,BHSICD,BHSDOO
+1 KILL BHSICL,BHSILN,BHSN,BHSNAR,BHSNTE,BHSQ,BHSTXT,BHSSNO
+2 KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,Y,X
+3 QUIT
PROBSCH ;
+1 SET BHSPRB=""
FOR BHSQ=0:0
SET BHSPRB=$ORDER(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB))
IF BHSPRB=""
QUIT
Begin DoDot:1
+2 SET BHSDFN=$ORDER(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB,""))
IF BHSDFN=""
QUIT
Begin DoDot:2
+3 IF BHSTAT[$PIECE(^AUPNPROB(BHSDFN,0),U,12)
SET BHSNDF=BHSNDF+1
SET BHSDFT(BHSFAC_BHSPRB)=BHSDFN
End DoDot:2
End DoDot:1
+4 QUIT
PROBDSP ;
+1 ; <SETUP PROBLEM>
+2 SET BHSN=^AUPNPROB(BHSDFN,0)
+3 SET BHSSNO=$$GET1^DIQ(9000011,BHSDFN,80001)
+4 SET BHSICD=$PIECE(BHSN,U,1)
DO GETPLICD^BHSUTL
+5 SET BHSNRQ=$PIECE(BHSN,U,5)
DO GETNARR^BHSUTL
+6 SET BHSITE=$PIECE(BHSN,U,6)
DO GETSITE^BHSUTL
+7 ;***** EDE *****
SET BHSPNM=$PIECE(BHSN,U,7)
+8 ;***** EDE *****
SET BHSPNM=BHSNAB_BHSPNM
+9 SET X=$PIECE(BHSN,U,3)
DO REGDT4^GMTSU
SET BHSDTM=X
+10 SET X=$PIECE(BHSN,U,8)
DO REGDT4^GMTSU
SET BHSDTN=X
+11 SET X=$PIECE(BHSN,U,13)
+12 IF X]""
DO REGDT4^GMTSU
SET BHSDOO=X
+13 IF X=""
SET BHSDOO=""
+14 IF BHSDOO]""
SET BHSNTE=" (onset "_BHSDOO_")"
+15 SET BHSPLN=BHSPNM_$EXTRACT(" ",1,12-$LENGTH(BHSPNM))_BHSDTN_" "_BHSDTM_" "
+16 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE ?13,"ENT. MODIFIED",!
+17 IF BHSSNO'=""
SET BHSNRQ=BHSNRQ_" ("_BHSSNO_")"
+18 WRITE BHSPLN
SET BHSICL=30
SET BHSILN=50
DO PRTICD^BHSUTL
+19 DO NOTEDSP
+20 DO QUAL(BHSDFN)
+21 DO RECON(BHSDFN)
+22 QUIT
NOTEDSP ; DISPLAY NOTES UNDER BHSPRBLEM
+1 SET BHSNFP=0
FOR BHSQ=0:0
SET BHSNFP=$ORDER(^AUPNPROB(BHSDFN,11,BHSNFP))
IF 'BHSNFP
QUIT
DO DSPFACN
+2 QUIT
DSPFACN ; DISPLAY NOTES FOR SELECTED APSHCFACILITY
+1 IF $DATA(^AUPNPROB(BHSDFN,11,BHSNFP,11,0))'=1
QUIT
IF $ORDER(^(0))=""
QUIT
+2 SET BHSITE=^AUPNPROB(BHSDFN,11,BHSNFP,0)
DO GETSITE^BHSUTL
SET BHSFCN=BHSNAB
+3 SET BHSNDF=0
FOR BHSQ=0:0
SET BHSNDF=$ORDER(^AUPNPROB(BHSDFN,11,BHSNFP,11,BHSNDF))
IF 'BHSNDF
QUIT
SET BHSN=^(BHSNDF,0)
DO DSPN
+4 QUIT
DSPN ; DISPLAY SINGLE NOTE
+1 IF $PIECE(BHSN,U,4)="I"
QUIT
+2 ;S:Y="" Y=" "
SET BHSNAR=$PIECE(BHSN,U,3)
SET X=$PIECE(BHSN,U,5)
+3 IF X>0
DO REGDT4^GMTSU
SET X=X_" - "
+4 SET BHSNAR=BHSNAR_" "_X
+5 ;W ?22,BHSFCN,"#",$E(1000+$P(BHSN,U,1),2,4)_" ",$P(BHSN,U,3),!
+6 FOR BHSQ=0:0
IF $EXTRACT(BHSFCN)'=" "
QUIT
SET BHSFCN=$EXTRACT(BHSFCN,2,99)
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE ?10,BHSFCN_" Note "_$PIECE(BHSN,U)
+8 SET BHSTXT=BHSNAR
SET BHSICL=31
DO PRTTXT^BHSUTL
+9 QUIT
PLDETAIL ;DISPLAY PROBLEM DETAILS IN HELATH SUMMARY
+1 NEW PROB,CNT,RET,PRIEN,I,STAT,LINE,Y,TYPE
+2 SET TYPE="ASEO"
+3 IF $GET(NUM)=""
SET NUM=99999
+4 SET RET=""
+5 SET (CNT,PRIEN)=0
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 FOR
SET PRIEN=$ORDER(^AUPNPROB("AC",DFN,PRIEN))
IF 'PRIEN
QUIT
Begin DoDot:1
+8 ;Check for which statuses to return
+9 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+10 IF STAT="D"
QUIT
+11 IF TYPE'[STAT
QUIT
+12 ;Get a detail report on one problem
DO DETAIL^BGOPRDD(.RET,PRIEN,DFN,"A",NUM)
+13 SET LINE=0
+14 FOR
SET LINE=$ORDER(@RET@(LINE))
IF LINE=""
QUIT
Begin DoDot:2
+15 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE !,"Active Problem List",!
+16 WRITE @RET@(LINE),!
End DoDot:2
End DoDot:1
+17 KILL RET
+18 QUIT
INPROB ;DISPLAY PROBLEM DETAILS OF INACTIVE PROBLEMS
+1 NEW PROB,CNT,RET,PRIEN,I,STAT,LINE,Y
+2 SET TYPE="I"
+3 ;For Visit instructions and treatments, the default is the latest visit
+4 IF $GET(NUM)=""
SET NUM=99999
+5 SET RET=$$TMPGBL
+6 SET (CNT,PRIEN)=0
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+8 FOR
SET PRIEN=$ORDER(^AUPNPROB("AC",DFN,PRIEN))
IF 'PRIEN
QUIT
Begin DoDot:1
+9 ;Check for which statuses to return
+10 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+11 IF STAT="D"
QUIT
+12 IF TYPE'[STAT
QUIT
+13 ;Get a detail report on one problem
DO DETAIL^BGOPRDD(.RET,PRIEN,DFN,"C",NUM)
+14 SET LINE=0
+15 FOR
SET LINE=$ORDER(@RET@(LINE))
IF LINE=""
QUIT
Begin DoDot:2
+16 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE !,"Inactive Problem List",!
+17 WRITE @RET@(LINE),!
End DoDot:2
End DoDot:1
+18 KILL RET
+19 QUIT
RECON(PROB) ;Find when this problem was reconciled
+1 NEW REC,IEN,AIEN,WHEN,BY
+2 SET REC=""
+3 FOR
SET REC=$ORDER(^BEHOCIR("G","P",PROB,REC))
IF REC=""
QUIT
Begin DoDot:1
+4 SET IEN=""
FOR
SET IEN=$ORDER(^BEHOCIR("G","P",PROB,REC,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+5 SET AIEN=IEN_","_REC_","
+6 SET WHEN=$$GET1^DIQ(90461.632,AIEN,.01)
+7 SET BY=$$GET1^DIQ(90461.632,AIEN,.02)
+8 WRITE ?10,"Reconciled on: "_WHEN_" by "_BY,!
End DoDot:2
End DoDot:1
+9 QUIT
QUAL(IEN) ;Get any qualifiers for this problem
+1 NEW AIEN,IEN2,BY,WHEN,X,FNUM,Q,STRING,STRING2,STRING3
+2 IF $DATA(^AUPNPROB(IEN,13))!($DATA(^AUPNPROB(IEN,17)))!($DATA(^AUPNPROB(IEN,18)))
+3 SET (STRING,STRING2,STRING3)=""
+4 FOR X=13,17,18
Begin DoDot:1
+5 SET FNUM=$SELECT(X=13:9000011.13,X=17:9000011.17,X=18:9000011.18)
+6 SET IEN2=0
FOR
SET IEN2=$ORDER(^AUPNPROB(IEN,X,IEN2))
IF '+IEN2
QUIT
Begin DoDot:2
+7 SET AIEN=IEN2_","_IEN_","
+8 SET Q=$$GET1^DIQ(FNUM,AIEN,.01)
+9 SET Q=$$CONCEPT^BGOPAUD(Q)
+10 IF X=13
Begin DoDot:3
+11 IF STRING=""
SET STRING=Q
+12 IF '$TEST
SET STRING=STRING_" "_Q
End DoDot:3
+13 IF X=17
Begin DoDot:3
+14 IF STRING2=""
SET STRING2=Q
+15 IF '$TEST
SET STRING2=STRING2_" "_Q
End DoDot:3
+16 IF X=18
Begin DoDot:3
+17 IF STRING=""
SET STRING=Q
+18 IF '$TEST
SET STRING=STRING_" "_Q
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF STRING'=""!(STRING2'="")!(STRING3'="")
WRITE !,?10,"QUALIFIERS",!
+20 IF STRING'=""
WRITE ?10,STRING,!
+21 IF STRING2'=""
WRITE ?10,STRING2,!
+22 IF STRING3'=""
WRITE ?10,STRING3,!
TMPGBL() ;EP
+1 KILL ^TMP("BHSPL",$JOB)
QUIT $NAME(^($JOB))
