BUDDRPTQ ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED IHS/CMI/LAB - UDS REPORT PRINT ;
;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
;
C(X,Y) ;
I $G(Y)=1,+X=0 Q ""
I $G(Y)=2 Q "********"
S X2=0,X3=8
D COMMA^%DTC
Q X
REST3B ;EP
S BUDLANG=1
I $Y>(IOSL-7) D HEADER^BUDDRPTP Q:BUDQUIT D T3BSH
W !!,BUD80L,!?61,"NUMBER"
W !,"PATIENTS BY LANGUAGE",?63,"(a)",!,BUD80L
W !?2,"12.",?7,"Patients Best Served in a Language",!?7," Other Than English",?60,$$C($P(BUDLANG(12),U,2)),!,BUD80L
I $Y>(IOSL-12) D HEADER^BUDDRPTP Q:BUDQUIT D T3BSH
W !!,BUD80L,!?61,"NUMBER"
W !,"PATIENTS BY SEXUAL ORIENTATION",?63,"(a)",!,BUD80L
F BUDX=13:1:19 Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER^BUDDRPTP Q:BUDQUIT D T3BSH
.W !?2,$P(BUDSOT(BUDX),U),?7,$P(BUDSOT(BUDX),U,2)
.I $P(BUDSOT(BUDX),U,7)]"" W !?7,$P(BUDSOT(BUDX),U,7)
.I $P(BUDSOT(BUDX),U,8)]"" W !?7,$P(BUDSOT(BUDX),U,8)
.I $P(BUDSOT(BUDX),U,9)]"" W !?7,$P(BUDSOT(BUDX),U,9)
.I $P(BUDSOT(BUDX),U,3)]"" W ?60,$$C($P(BUDSOT(BUDX),U,3))
.W !,BUD80L
;GENDER IDENTITY PRINT
I $Y>(IOSL-12) D HEADER^BUDDRPTP Q:BUDQUIT D T3BSH
W !!,BUD80L,!?61,"NUMBER"
W !,"PATIENTS BY GENDER IDENTITY",?63,"(a)",!,BUD80L
F BUDX=20:1:26 Q:BUDQUIT D
.I $Y>(IOSL-3) D HEADER^BUDDRPTP Q:BUDQUIT D T3BSH
.W !?2,$P(BUDGIDT(BUDX),U),?7,$P(BUDGIDT(BUDX),U,2)
.I $P(BUDGIDT(BUDX),U,7)]"" W !?7,$P(BUDGIDT(BUDX),U,7)
.I $P(BUDGIDT(BUDX),U,8)]"" W !?7,$P(BUDGIDT(BUDX),U,8)
.I $P(BUDGIDT(BUDX),U,9)]"" W !?7,$P(BUDGIDT(BUDX),U,9)
.I $P(BUDGIDT(BUDX),U,3)]"" W ?60,$$C($P(BUDGIDT(BUDX),U,3))
.W !,BUD80L
Q
T3BSH ;
W !!,$$CTR("TABLE 3B -",80)
W !,$$CTR("DEMOGRAPHIC CHARACTERISTICS",80)
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
BUDDRPTQ ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED IHS/CMI/LAB - UDS REPORT PRINT ;
+1 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
+2 ;
C(X,Y) ;
+1 IF $GET(Y)=1
IF +X=0
QUIT ""
+2 IF $GET(Y)=2
QUIT "********"
+3 SET X2=0
SET X3=8
+4 DO COMMA^%DTC
+5 QUIT X
REST3B ;EP
+1 SET BUDLANG=1
+2 IF $Y>(IOSL-7)
DO HEADER^BUDDRPTP
IF BUDQUIT
QUIT
DO T3BSH
+3 WRITE !!,BUD80L,!?61,"NUMBER"
+4 WRITE !,"PATIENTS BY LANGUAGE",?63,"(a)",!,BUD80L
+5 WRITE !?2,"12.",?7,"Patients Best Served in a Language",!?7," Other Than English",?60,$$C($PIECE(BUDLANG(12),U,2)),!,BUD80L
+6 IF $Y>(IOSL-12)
DO HEADER^BUDDRPTP
IF BUDQUIT
QUIT
DO T3BSH
+7 WRITE !!,BUD80L,!?61,"NUMBER"
+8 WRITE !,"PATIENTS BY SEXUAL ORIENTATION",?63,"(a)",!,BUD80L
+9 FOR BUDX=13:1:19
IF BUDQUIT
QUIT
Begin DoDot:1
+10 IF $Y>(IOSL-3)
DO HEADER^BUDDRPTP
IF BUDQUIT
QUIT
DO T3BSH
+11 WRITE !?2,$PIECE(BUDSOT(BUDX),U),?7,$PIECE(BUDSOT(BUDX),U,2)
+12 IF $PIECE(BUDSOT(BUDX),U,7)]""
WRITE !?7,$PIECE(BUDSOT(BUDX),U,7)
+13 IF $PIECE(BUDSOT(BUDX),U,8)]""
WRITE !?7,$PIECE(BUDSOT(BUDX),U,8)
+14 IF $PIECE(BUDSOT(BUDX),U,9)]""
WRITE !?7,$PIECE(BUDSOT(BUDX),U,9)
+15 IF $PIECE(BUDSOT(BUDX),U,3)]""
WRITE ?60,$$C($PIECE(BUDSOT(BUDX),U,3))
+16 WRITE !,BUD80L
End DoDot:1
+17 ;GENDER IDENTITY PRINT
+18 IF $Y>(IOSL-12)
DO HEADER^BUDDRPTP
IF BUDQUIT
QUIT
DO T3BSH
+19 WRITE !!,BUD80L,!?61,"NUMBER"
+20 WRITE !,"PATIENTS BY GENDER IDENTITY",?63,"(a)",!,BUD80L
+21 FOR BUDX=20:1:26
IF BUDQUIT
QUIT
Begin DoDot:1
+22 IF $Y>(IOSL-3)
DO HEADER^BUDDRPTP
IF BUDQUIT
QUIT
DO T3BSH
+23 WRITE !?2,$PIECE(BUDGIDT(BUDX),U),?7,$PIECE(BUDGIDT(BUDX),U,2)
+24 IF $PIECE(BUDGIDT(BUDX),U,7)]""
WRITE !?7,$PIECE(BUDGIDT(BUDX),U,7)
+25 IF $PIECE(BUDGIDT(BUDX),U,8)]""
WRITE !?7,$PIECE(BUDGIDT(BUDX),U,8)
+26 IF $PIECE(BUDGIDT(BUDX),U,9)]""
WRITE !?7,$PIECE(BUDGIDT(BUDX),U,9)
+27 IF $PIECE(BUDGIDT(BUDX),U,3)]""
WRITE ?60,$$C($PIECE(BUDGIDT(BUDX),U,3))
+28 WRITE !,BUD80L
End DoDot:1
+29 QUIT
T3BSH ;
+1 WRITE !!,$$CTR("TABLE 3B -",80)
+2 WRITE !,$$CTR("DEMOGRAPHIC CHARACTERISTICS",80)
+3 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
