BGOTRG ; IHS/BAO/TMD - Triage Summary ;06-Nov-2014 10:33;DU
;;1.1;BGO COMPONENTS;**1,3,5,6,7,8,11,14**;Mar 20, 2007
; RPC: Returns triage summary information
; INP = Visit IEN ^ Provider ^ Report List ^ Include CC Author
GETSUM(RET,INP) ;EP
N VIEN,V0,DFN,DAT,PRV,CTL,RTN,SEQ,SCT,SEX
S RET=$$TMPGBL^BGOUTL
S VIEN=+INP
Q:'VIEN
S V0=$G(^AUPNVSIT(VIEN,0))
Q:'V0
S DAT=V0\1,DFN=+$P(V0,U,5),SEX=$P($G(^DPT(DFN,0)),U,2)
S PRV=$P(INP,U,2)
S:'PRV PRV=+$$PRIPRV^BGOUTL(VIEN)
S CTL=$TR($P(INP,U,3),";-",",")
S:CTL="" CTL="1,2,3,4,5,6,7,8,9,10,11"
F SEQ=1:1 Q:'$L(CTL) S SEQ(SEQ)=$P(CTL,",")\1,CTL=$P(CTL,",",2,999)
S (SEQ,SCT)=0
F S SEQ=$O(SEQ(SEQ)) Q:'SEQ D
.N LP,CNT
.S RTN="GET"_SEQ(SEQ)
.S CTL=$P($T(@RTN),";;",2,999)
.Q:'$L(CTL)
.S (CNT,LP)=0
.D @RTN,ADDHDR
Q
GET1 ;;Chief Complaint^
N CC,TYPE,AUTH,X,N
S TYPE=$O(^AUTTNTYP("B","CHIEF COMPLAINT",0))
Q:'TYPE
S AUTH=+$P(INP,U,4)
F S LP=$O(^AUPNVNT("AD",VIEN,LP)) Q:'LP D
.Q:$P($G(^AUPNVNT(LP,0)),U)'=TYPE
.I AUTH D
..S X=$P($G(^AUPNVNT(LP,12)),U,4)
..D:X APPEND($P($G(^VA(200,X,0)),U)_":")
.S N=0
.F S N=$O(^AUPNVNT(LP,11,N)) Q:'N D APPEND($G(^(N,0)))
.D ADDHDR
S X=$P($G(^AUPNVSIT(VIEN,14)),U)
D:$L(X) APPEND(X)
Q
GET2 ;;Vitals^;
N MSR,TYP,EIE,VAL,VAL2,AGE,X,WT,HT,MR,BEH,DATA,DEFAULT,DEFU,ALTU,A
N QUALS,QUALN,QUALIF
S VMSR=$$VMSR^BEHOVM
N GLOB S GLOB=$S('VMSR:"^GMR(120.5)",1:"^AUPNVMSR")
;F S LP=$O(^AUPNVMSR("AD",VIEN,LP)) Q:'LP D
;.S MSR=$G(^AUPNVMSR(LP,0)),X=+$G(^(12))
F S LP=$O(@GLOB@("AD",VIEN,LP)) Q:'LP D
.S MSR=$G(@GLOB@(LP,0)),X=+$G(^($S('VMSR:0,1:12)))
.Q:'MSR
.;IHS/MSC/MGH Quit if entered in error
.S EIE=$$GET1^DIQ(9000010.01,LP,2,"I")
.Q:EIE=1
.S QUALIF=""
.S QUALS=0 F S QUALS=$O(@GLOB@(LP,5,QUALS)) Q:QUALS="" D
..S QUALN=$P($G(@GLOB@(LP,5,QUALS,0)),U,1)
..I +QUALN S QUALN=$P($G(^GMRD(120.52,QUALN,0)),U,1)
..I QUALIF'="" S QUALIF=QUALIF_","_QUALN
..E I QUALIF="" S QUALIF=QUALN
.S TYP=$P($S('VMSR:$G(^GMRD(120.51,+$P(MSR,U,3),0)),1:$G(^AUTTMSR(+MSR,0))),U),VAL=$P(MSR,U,$S('VMSR:8,1:4)),MR=""
.I TYP="O2"!(TYP="PO2") S QUALIF=QUALIF_$P($G(@GLOB@(LP,0)),U,10)
.;S TYP=$P(^AUTTMSR(+MSR,0),U),VAL=$P(MSR,U,4),MR=""
.S BEH="" I 'VMSR N A,I F I=7,2 D Q:BEH
..S A=$P($G(^GMRD(120.51,+$P(MSR,U,3),0)),U,I) I A'="" S BEH=$O(^BEHOVM(90460.01,"B",A,0))
.S AGE=$$PTAGE^BGOUTL(DFN,$S(X:X,1:DAT))
.I VMSR S BEH="" S BEH=$O(^BEHOVM(90460.01,"B",TYP,BEH))
.I TYP="" D APPEND(TYP_": "_$$RND(VAL),MR,QUALIF)
.E D
..S DATA=$G(^BEHOVM(90460.01,BEH,0))
..S DEFAULT=$P(DATA,U,2)
..I DEFAULT=1 D
...S DEFU=$P(DATA,U,4),ALTU=$P(DATA,U,3)
...I ALTU=""!(DEFU=ALTU) D APPEND(TYP_": "_$$RND(VAL)_" "_DEFU,,QUALIF)
...E S X=VAL I $D(^BEHOVM(90460.01,BEH,2)) X $G(^BEHOVM(90460.01,BEH,2)) D APPEND(TYP_": "_$$RND(VAL)_" "_DEFU_" ",$$RND(X)_" "_ALTU,QUALIF)
..I DEFAULT=0 D
...S DEFU=$P(DATA,U,3),ALTU=$P(DATA,U,4)
...I ALTU=""!(DEFU=ALTU) D APPEND(TYP_": "_$$RND(VAL)_" "_DEFU,,QUALIF)
...E S X=VAL I $D(^BEHOVM(90460.01,BEH,1)) X $G(^BEHOVM(90460.01,BEH,1)) D APPEND(TYP_": "_$$RND(VAL)_" "_DEFU_" ",$$RND(X)_" "_ALTU,QUALIF)
..I DEFAULT="" D APPEND(TYP_": "_$$RND(VAL),,QUALIF)
Q:$G(AGE)'>2!'$D(WT)!'$D(HT)
S VAL=$$RND((WT*704.5)/(HT*HT))
S MR=$S(AGE<20:"",VAL<18.5:"Underweight",VAL<25:"Normal Weight",VAL<30:"Overweight",VAL<35:"Obesity - Class 1",VAL<40:"Obesity - Class 2",1:"Extreme Obesity")
D APPEND("BMI: "_VAL,MR)
Q
GET3 ;;Reproductive^;
N REC,X
S REC=$G(^AUPNREP(DFN,0))
Q:'$L(REC)!(SEX'="F")
;IHS/MSC/MGH Patch 6 updated to reflect the change in date fields in reproductive hx
;S X=$S($P(REC,U,3)=DAT:$P(REC,U,2),1:"")
S TODAY=$$DT^XLFDT
Q:TODAY'=$P(REC,U,3)
S:$L($T(^BGOREP)) X=$$EXPHX^BGOREP($P(REC,U))
D:$L(X) APPEND($TR(X,"=",":"))
S X=$S($P(REC,U,5)=DAT:$P(REC,U,4),1:"")
D:X APPEND("LMP: "_$$FMTDATE^BGOUTL(X))
S X=$S($P(REC,U,8)=DAT:$$MCASE^BGOUTL($$EXTERNAL^DILFD(9000017,3,,$P(REC,U,6))),1:"")
D:$L(X) APPEND("Contraceptive Method: "_X)
Q
GET4 ;;Pregnancy^;
N REC,X
Q:SEX'="F"
S REC=$G(^AUPNREP(DFN,0))
S X=$S($P(REC,U,11)=DAT:$$FMTDATE^BGOUTL($P(REC,U,9)),1:"")
D:$L(X) APPEND("Est. Delivery: "_X)
Q
GET5 ;;Immunizations^;
N IMM
F S LP=$O(^AUPNVIMM("AD",+VIEN,LP)) Q:'LP D
.S IMM=$P($G(^AUPNVIMM(LP,0)),U)
.D:IMM APPEND($P($G(^AUTTIMM(IMM,0)),U))
Q
GET6 ;;Skin Tests^;
N SK
F S LP=$O(^AUPNVSK("AD",+VIEN,LP)) Q:'LP D
.S SK=$P($G(^AUPNVSK(LP,0)),U)
.D:SK APPEND($P($G(^AUTTSK(SK,0)),U))
Q
GET7 ;;Education^;
N EDT,TXT,SNO,X
F S LP=$O(^AUPNVPED("AD",VIEN,LP)) Q:'LP D
.S EDT=$P($G(^AUPNVPED(LP,0)),U)
.Q:'EDT
.I $P($G(^AUTTEDT(EDT,0)),U,12)'="" D
..S TXT=""
..S SNO=$P($G(^AUTTEDT(EDT,0)),U,12)
..;IHS/MSC/MGH changed to use new api
..;S IN=SNO_U_36_U_U_1
..;S X=$$CONC^BSTSAPI(IN)
..S IN=SNO_"^^^1"
..S X=$$CONC^AUPNSICD(IN)
..S TXT=$P(X,U,4)
..I $L(TXT) D APPEND(TXT_"-"_$P($P($G(^AUTTEDT(EDT,0)),U,1),"-",2))
.E D APPEND($P($G(^AUTTEDT(EDT,0)),U))
.;D:EDT APPEND($P($G(^AUTTEDT(EDT,0)),U))
Q
GET8 ;;Exams^;
N XAM
F S LP=$O(^AUPNVXAM("AD",VIEN,LP)) Q:'LP D
.S XAM=+$G(^AUPNVXAM(LP,0))
.D:XAM APPEND($P($G(^AUTTEXAM(XAM,0)),U))
Q
GET9 ;;Health Factors^;
N HF
F S LP=$O(^AUPNVHF("AD",VIEN,LP)) Q:'LP D
.S HF=$P($G(^AUPNVHF(LP,0)),U)
.D:HF APPEND($P($G(^AUTTHF(HF,0)),U))
Q
GET10 ;;Procedures^;
N PRC
F S LP=$O(^AUPNVCPT("AD",VIEN,LP)) Q:'LP D
.I PRV>0,$P($G(^AUPNVCPT(LP,12)),U,4)=PRV Q
.S PRC=$P($G(^AUPNVCPT(LP,0)),U)
.D:PRC APPEND($P($G(^ICPT(PRC,0)),U,2))
Q
GET11 ;;Orders^
N ORLIST,LOC,X,Y,Z
K ^TMP("ORR",$J)
S LOC=$P(V0,U,22)_";SC("
D EN^ORQ1(DFN_";DPT(",,1,1,DAT,DAT,1)
Q:'$D(ORLIST)
F LP=0:0 S LP=$O(^TMP("ORR",$J,ORLIST,LP)) Q:'LP D
.N ORD
.M ORD=^TMP("ORR",$J,ORLIST,LP)
.S Z=$G(^OR(100,+ORD,0))
.S Y=$P(Z,U,10)
.I 'Y,PRV>0,$P(Z,U,4)'=PRV Q
.I PRV>0,$P(Z,U,6)'=PRV Q
.I Y,LOC,Y'=LOC Q
.Q:$P(ORD,U,7)="canc"
.S Y=0
.F S Y=$O(ORD("TX",Y)) Q:'Y D APPEND(ORD("TX",Y))
.D ADDHDR
K ^TMP("ORR",$J)
Q
; Round to 4 decimal points
; Patch 5 change to 2 decimal places
RND(X) Q $S(X=+X:+$J(X,0,2),1:X)
ADDHDR S:CNT>0 @RET@(SCT,0)=U_CTL,CNT=0,SCT=SCT+1
Q
; Append to result string
APPEND(X,Y,Z) ;
S CNT=CNT+1,@RET@(SCT,CNT)=X_$S($L($G(Y)):" ("_Y_")",1:"")_$S($L($G(Z)):" ["_Z_"]",1:"")
Q
BGOTRG ; IHS/BAO/TMD - Triage Summary ;06-Nov-2014 10:33;DU
+1 ;;1.1;BGO COMPONENTS;**1,3,5,6,7,8,11,14**;Mar 20, 2007
+2 ; RPC: Returns triage summary information
+3 ; INP = Visit IEN ^ Provider ^ Report List ^ Include CC Author
GETSUM(RET,INP) ;EP
+1 NEW VIEN,V0,DFN,DAT,PRV,CTL,RTN,SEQ,SCT,SEX
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET VIEN=+INP
+4 IF 'VIEN
QUIT
+5 SET V0=$GET(^AUPNVSIT(VIEN,0))
+6 IF 'V0
QUIT
+7 SET DAT=V0\1
SET DFN=+$PIECE(V0,U,5)
SET SEX=$PIECE($GET(^DPT(DFN,0)),U,2)
+8 SET PRV=$PIECE(INP,U,2)
+9 IF 'PRV
SET PRV=+$$PRIPRV^BGOUTL(VIEN)
+10 SET CTL=$TRANSLATE($PIECE(INP,U,3),";-",",")
+11 IF CTL=""
SET CTL="1,2,3,4,5,6,7,8,9,10,11"
+12 FOR SEQ=1:1
IF '$LENGTH(CTL)
QUIT
SET SEQ(SEQ)=$PIECE(CTL,",")\1
SET CTL=$PIECE(CTL,",",2,999)
+13 SET (SEQ,SCT)=0
+14 FOR
SET SEQ=$ORDER(SEQ(SEQ))
IF 'SEQ
QUIT
Begin DoDot:1
+15 NEW LP,CNT
+16 SET RTN="GET"_SEQ(SEQ)
+17 SET CTL=$PIECE($TEXT(@RTN),";;",2,999)
+18 IF '$LENGTH(CTL)
QUIT
+19 SET (CNT,LP)=0
+20 DO @RTN
DO ADDHDR
End DoDot:1
+21 QUIT
GET1 ;;Chief Complaint^
+1 NEW CC,TYPE,AUTH,X,N
+2 SET TYPE=$ORDER(^AUTTNTYP("B","CHIEF COMPLAINT",0))
+3 IF 'TYPE
QUIT
+4 SET AUTH=+$PIECE(INP,U,4)
+5 FOR
SET LP=$ORDER(^AUPNVNT("AD",VIEN,LP))
IF 'LP
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^AUPNVNT(LP,0)),U)'=TYPE
QUIT
+7 IF AUTH
Begin DoDot:2
+8 SET X=$PIECE($GET(^AUPNVNT(LP,12)),U,4)
+9 IF X
DO APPEND($PIECE($GET(^VA(200,X,0)),U)_":")
End DoDot:2
+10 SET N=0
+11 FOR
SET N=$ORDER(^AUPNVNT(LP,11,N))
IF 'N
QUIT
DO APPEND($GET(^(N,0)))
+12 DO ADDHDR
End DoDot:1
+13 SET X=$PIECE($GET(^AUPNVSIT(VIEN,14)),U)
+14 IF $LENGTH(X)
DO APPEND(X)
+15 QUIT
GET2 ;;Vitals^;
+1 NEW MSR,TYP,EIE,VAL,VAL2,AGE,X,WT,HT,MR,BEH,DATA,DEFAULT,DEFU,ALTU,A
+2 NEW QUALS,QUALN,QUALIF
+3 SET VMSR=$$VMSR^BEHOVM
+4 NEW GLOB
SET GLOB=$SELECT('VMSR:"^GMR(120.5)",1:"^AUPNVMSR")
+5 ;F S LP=$O(^AUPNVMSR("AD",VIEN,LP)) Q:'LP D
+6 ;.S MSR=$G(^AUPNVMSR(LP,0)),X=+$G(^(12))
+7 FOR
SET LP=$ORDER(@GLOB@("AD",VIEN,LP))
IF 'LP
QUIT
Begin DoDot:1
+8 SET MSR=$GET(@GLOB@(LP,0))
SET X=+$GET(^($SELECT('VMSR:0,1:12)))
+9 IF 'MSR
QUIT
+10 ;IHS/MSC/MGH Quit if entered in error
+11 SET EIE=$$GET1^DIQ(9000010.01,LP,2,"I")
+12 IF EIE=1
QUIT
+13 SET QUALIF=""
+14 SET QUALS=0
FOR
SET QUALS=$ORDER(@GLOB@(LP,5,QUALS))
IF QUALS=""
QUIT
Begin DoDot:2
+15 SET QUALN=$PIECE($GET(@GLOB@(LP,5,QUALS,0)),U,1)
+16 IF +QUALN
SET QUALN=$PIECE($GET(^GMRD(120.52,QUALN,0)),U,1)
+17 IF QUALIF'=""
SET QUALIF=QUALIF_","_QUALN
+18 IF '$TEST
IF QUALIF=""
SET QUALIF=QUALN
End DoDot:2
+19 SET TYP=$PIECE($SELECT('VMSR:$GET(^GMRD(120.51,+$PIECE(MSR,U,3),0)),1:$GET(^AUTTMSR(+MSR,0))),U)
SET VAL=$PIECE(MSR,U,$SELECT('VMSR:8,1:4))
SET MR=""
+20 IF TYP="O2"!(TYP="PO2")
SET QUALIF=QUALIF_$PIECE($GET(@GLOB@(LP,0)),U,10)
+21 ;S TYP=$P(^AUTTMSR(+MSR,0),U),VAL=$P(MSR,U,4),MR=""
+22 SET BEH=""
IF 'VMSR
NEW A,I
FOR I=7,2
Begin DoDot:2
+23 SET A=$PIECE($GET(^GMRD(120.51,+$PIECE(MSR,U,3),0)),U,I)
IF A'=""
SET BEH=$ORDER(^BEHOVM(90460.01,"B",A,0))
End DoDot:2
IF BEH
QUIT
+24 SET AGE=$$PTAGE^BGOUTL(DFN,$SELECT(X:X,1:DAT))
+25 IF VMSR
SET BEH=""
SET BEH=$ORDER(^BEHOVM(90460.01,"B",TYP,BEH))
+26 IF TYP=""
DO APPEND(TYP_": "_$$RND(VAL),MR,QUALIF)
+27 IF '$TEST
Begin DoDot:2
+28 SET DATA=$GET(^BEHOVM(90460.01,BEH,0))
+29 SET DEFAULT=$PIECE(DATA,U,2)
+30 IF DEFAULT=1
Begin DoDot:3
+31 SET DEFU=$PIECE(DATA,U,4)
SET ALTU=$PIECE(DATA,U,3)
+32 IF ALTU=""!(DEFU=ALTU)
DO APPEND(TYP_": "_$$RND(VAL)_" "_DEFU,,QUALIF)
+33 IF '$TEST
SET X=VAL
IF $DATA(^BEHOVM(90460.01,BEH,2))
XECUTE $GET(^BEHOVM(90460.01,BEH,2))
DO APPEND(TYP_": "_$$RND(VAL)_" "_DEFU_" ",$$RND(X)_" "_ALTU,QUALIF)
End DoDot:3
+34 IF DEFAULT=0
Begin DoDot:3
+35 SET DEFU=$PIECE(DATA,U,3)
SET ALTU=$PIECE(DATA,U,4)
+36 IF ALTU=""!(DEFU=ALTU)
DO APPEND(TYP_": "_$$RND(VAL)_" "_DEFU,,QUALIF)
+37 IF '$TEST
SET X=VAL
IF $DATA(^BEHOVM(90460.01,BEH,1))
XECUTE $GET(^BEHOVM(90460.01,BEH,1))
DO APPEND(TYP_": "_$$RND(VAL)_" "_DEFU_" ",$$RND(X)_" "_ALTU,QUALIF)
End DoDot:3
+38 IF DEFAULT=""
DO APPEND(TYP_": "_$$RND(VAL),,QUALIF)
End DoDot:2
End DoDot:1
+39 IF $GET(AGE)'>2!'$DATA(WT)!'$DATA(HT)
QUIT
+40 SET VAL=$$RND((WT*704.5)/(HT*HT))
+41 SET MR=$SELECT(AGE<20:"",VAL<18.5:"Underweight",VAL<25:"Normal Weight",VAL<30:"Overweight",VAL<35:"Obesity - Class 1",VAL<40:"Obesity - Class 2",1:"Extreme Obesity")
+42 DO APPEND("BMI: "_VAL,MR)
+43 QUIT
GET3 ;;Reproductive^;
+1 NEW REC,X
+2 SET REC=$GET(^AUPNREP(DFN,0))
+3 IF '$LENGTH(REC)!(SEX'="F")
QUIT
+4 ;IHS/MSC/MGH Patch 6 updated to reflect the change in date fields in reproductive hx
+5 ;S X=$S($P(REC,U,3)=DAT:$P(REC,U,2),1:"")
+6 SET TODAY=$$DT^XLFDT
+7 IF TODAY'=$PIECE(REC,U,3)
QUIT
+8 IF $LENGTH($TEXT(^BGOREP))
SET X=$$EXPHX^BGOREP($PIECE(REC,U))
+9 IF $LENGTH(X)
DO APPEND($TRANSLATE(X,"=",":"))
+10 SET X=$SELECT($PIECE(REC,U,5)=DAT:$PIECE(REC,U,4),1:"")
+11 IF X
DO APPEND("LMP: "_$$FMTDATE^BGOUTL(X))
+12 SET X=$SELECT($PIECE(REC,U,8)=DAT:$$MCASE^BGOUTL($$EXTERNAL^DILFD(9000017,3,,$PIECE(REC,U,6))),1:"")
+13 IF $LENGTH(X)
DO APPEND("Contraceptive Method: "_X)
+14 QUIT
GET4 ;;Pregnancy^;
+1 NEW REC,X
+2 IF SEX'="F"
QUIT
+3 SET REC=$GET(^AUPNREP(DFN,0))
+4 SET X=$SELECT($PIECE(REC,U,11)=DAT:$$FMTDATE^BGOUTL($PIECE(REC,U,9)),1:"")
+5 IF $LENGTH(X)
DO APPEND("Est. Delivery: "_X)
+6 QUIT
GET5 ;;Immunizations^;
+1 NEW IMM
+2 FOR
SET LP=$ORDER(^AUPNVIMM("AD",+VIEN,LP))
IF 'LP
QUIT
Begin DoDot:1
+3 SET IMM=$PIECE($GET(^AUPNVIMM(LP,0)),U)
+4 IF IMM
DO APPEND($PIECE($GET(^AUTTIMM(IMM,0)),U))
End DoDot:1
+5 QUIT
GET6 ;;Skin Tests^;
+1 NEW SK
+2 FOR
SET LP=$ORDER(^AUPNVSK("AD",+VIEN,LP))
IF 'LP
QUIT
Begin DoDot:1
+3 SET SK=$PIECE($GET(^AUPNVSK(LP,0)),U)
+4 IF SK
DO APPEND($PIECE($GET(^AUTTSK(SK,0)),U))
End DoDot:1
+5 QUIT
GET7 ;;Education^;
+1 NEW EDT,TXT,SNO,X
+2 FOR
SET LP=$ORDER(^AUPNVPED("AD",VIEN,LP))
IF 'LP
QUIT
Begin DoDot:1
+3 SET EDT=$PIECE($GET(^AUPNVPED(LP,0)),U)
+4 IF 'EDT
QUIT
+5 IF $PIECE($GET(^AUTTEDT(EDT,0)),U,12)'=""
Begin DoDot:2
+6 SET TXT=""
+7 SET SNO=$PIECE($GET(^AUTTEDT(EDT,0)),U,12)
+8 ;IHS/MSC/MGH changed to use new api
+9 ;S IN=SNO_U_36_U_U_1
+10 ;S X=$$CONC^BSTSAPI(IN)
+11 SET IN=SNO_"^^^1"
+12 SET X=$$CONC^AUPNSICD(IN)
+13 SET TXT=$PIECE(X,U,4)
+14 IF $LENGTH(TXT)
DO APPEND(TXT_"-"_$PIECE($PIECE($GET(^AUTTEDT(EDT,0)),U,1),"-",2))
End DoDot:2
+15 IF '$TEST
DO APPEND($PIECE($GET(^AUTTEDT(EDT,0)),U))
+16 ;D:EDT APPEND($P($G(^AUTTEDT(EDT,0)),U))
End DoDot:1
+17 QUIT
GET8 ;;Exams^;
+1 NEW XAM
+2 FOR
SET LP=$ORDER(^AUPNVXAM("AD",VIEN,LP))
IF 'LP
QUIT
Begin DoDot:1
+3 SET XAM=+$GET(^AUPNVXAM(LP,0))
+4 IF XAM
DO APPEND($PIECE($GET(^AUTTEXAM(XAM,0)),U))
End DoDot:1
+5 QUIT
GET9 ;;Health Factors^;
+1 NEW HF
+2 FOR
SET LP=$ORDER(^AUPNVHF("AD",VIEN,LP))
IF 'LP
QUIT
Begin DoDot:1
+3 SET HF=$PIECE($GET(^AUPNVHF(LP,0)),U)
+4 IF HF
DO APPEND($PIECE($GET(^AUTTHF(HF,0)),U))
End DoDot:1
+5 QUIT
GET10 ;;Procedures^;
+1 NEW PRC
+2 FOR
SET LP=$ORDER(^AUPNVCPT("AD",VIEN,LP))
IF 'LP
QUIT
Begin DoDot:1
+3 IF PRV>0
IF $PIECE($GET(^AUPNVCPT(LP,12)),U,4)=PRV
QUIT
+4 SET PRC=$PIECE($GET(^AUPNVCPT(LP,0)),U)
+5 IF PRC
DO APPEND($PIECE($GET(^ICPT(PRC,0)),U,2))
End DoDot:1
+6 QUIT
GET11 ;;Orders^
+1 NEW ORLIST,LOC,X,Y,Z
+2 KILL ^TMP("ORR",$JOB)
+3 SET LOC=$PIECE(V0,U,22)_";SC("
+4 DO EN^ORQ1(DFN_";DPT(",,1,1,DAT,DAT,1)
+5 IF '$DATA(ORLIST)
QUIT
+6 FOR LP=0:0
SET LP=$ORDER(^TMP("ORR",$JOB,ORLIST,LP))
IF 'LP
QUIT
Begin DoDot:1
+7 NEW ORD
+8 MERGE ORD=^TMP("ORR",$JOB,ORLIST,LP)
+9 SET Z=$GET(^OR(100,+ORD,0))
+10 SET Y=$PIECE(Z,U,10)
+11 IF 'Y
IF PRV>0
IF $PIECE(Z,U,4)'=PRV
QUIT
+12 IF PRV>0
IF $PIECE(Z,U,6)'=PRV
QUIT
+13 IF Y
IF LOC
IF Y'=LOC
QUIT
+14 IF $PIECE(ORD,U,7)="canc"
QUIT
+15 SET Y=0
+16 FOR
SET Y=$ORDER(ORD("TX",Y))
IF 'Y
QUIT
DO APPEND(ORD("TX",Y))
+17 DO ADDHDR
End DoDot:1
+18 KILL ^TMP("ORR",$JOB)
+19 QUIT
+20 ; Round to 4 decimal points
+21 ; Patch 5 change to 2 decimal places
RND(X) QUIT $SELECT(X=+X:+$JUSTIFY(X,0,2),1:X)
ADDHDR IF CNT>0
SET @RET@(SCT,0)=U_CTL
SET CNT=0
SET SCT=SCT+1
+1 QUIT
+2 ; Append to result string
APPEND(X,Y,Z) ;
+1 SET CNT=CNT+1
SET @RET@(SCT,CNT)=X_$SELECT($LENGTH($GET(Y)):" ("_Y_")",1:"")_$SELECT($LENGTH($GET(Z)):" ["_Z_"]",1:"")
+2 QUIT
