BUDHRPTQ ;IHS/CMI/LAB - UDS REPORT PRINT;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
;
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^BUDHRPTP Q:BUDQUIT D T3BSH
W !!,BUD80L,!?61,"NUMBER"
W !,"PATIENTS BY LINGUISTIC BARRIERS TO CARE",?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^BUDHRPTP 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^BUDHRPTP 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^BUDHRPTP 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^BUDHRPTP 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),!,$$CTR("Patients by Race and Hispanic or Latino Ethnicity",80),!,BUD80L
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")
;----------
WDEL ;EP - WRITE T9 DELIMITED FILE
;call xbgsave to create output file
S XBGL="BUDDATA"
L +^BUDDATA:300 E W:'$D(ZTQUEUED) "Unable to lock global" Q
K ^TMP($J,"SUMMARYDEL")
K ^BUDDATA ;global for saving
D COVPAGED^BUDHUTL1
S C=C+1
S ^BUDDATA(C)="***** SENSITIVE INFORMATION *****"
S X="DATE^BILL (A/R)^TRANSACTION TYPE^CREDIT^DEBIT^PRIME BILL AMOUNT^PAYMENT^ADJUSTMENT^ADJUSTMENT CATEGORY^ADJUSTMENT TYPE^A/R ACCOUNT^PAYER CATEGORY^PATIENT (A/R)^VISIT LOCATION^CLINIC TYPE^DOS BEGIN^BILL TYPE^PRIMARY PROVIDER^"
S X=X_"HRN^DOB^COMMUNITY"
S C=C+1,^BUDDATA(C)=X
S D=0 F S D=$O(^XTMP("BUDARP9DEL",BUDJ,BUDH,D)) Q:D'=+D D
.S X=0 F S X=$O(^XTMP("BUDARP9DEL",BUDJ,BUDH,D,X)) Q:X'=+X D
..S C=C+1 S ^BUDDATA(C)=^XTMP("BUDARP9DEL",BUDJ,BUDH,D,X)
S X="***** END OF REPORT *****",C=C+1,^BUDDATA(C)=X
S XBFLT=1,XBFN=BUDFILE_".txt",XBMED="F",XBTLE="UDS TABLE 9D DELIMITED",XBQ="N",XBF=0
D ^XBGSAVE
K XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
L -^BUDDATA
K ^BUDDATA ;export global
Q
BUDHRPTQ ;IHS/CMI/LAB - UDS REPORT PRINT;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
+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^BUDHRPTP
IF BUDQUIT
QUIT
DO T3BSH
+3 WRITE !!,BUD80L,!?61,"NUMBER"
+4 WRITE !,"PATIENTS BY LINGUISTIC BARRIERS TO CARE",?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^BUDHRPTP
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^BUDHRPTP
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^BUDHRPTP
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^BUDHRPTP
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),!,$$CTR("Patients by Race and Hispanic or Latino Ethnicity",80),!,BUD80L
+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 ;----------
WDEL ;EP - WRITE T9 DELIMITED FILE
+1 ;call xbgsave to create output file
+2 SET XBGL="BUDDATA"
+3 LOCK +^BUDDATA:300
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE "Unable to lock global"
QUIT
+4 KILL ^TMP($JOB,"SUMMARYDEL")
+5 ;global for saving
KILL ^BUDDATA
+6 DO COVPAGED^BUDHUTL1
+7 SET C=C+1
+8 SET ^BUDDATA(C)="***** SENSITIVE INFORMATION *****"
+9 SET X="DATE^BILL (A/R)^TRANSACTION TYPE^CREDIT^DEBIT^PRIME BILL AMOUNT^PAYMENT^ADJUSTMENT^ADJUSTMENT CATEGORY^ADJUSTMENT TYPE^A/R ACCOUNT^PAYER CATEGORY^PATIENT (A/R)^VISIT LOCATION^CLINIC TYPE^DOS BEGIN^BILL TYPE^PRIMARY PROVIDER^"
+10 SET X=X_"HRN^DOB^COMMUNITY"
+11 SET C=C+1
SET ^BUDDATA(C)=X
+12 SET D=0
FOR
SET D=$ORDER(^XTMP("BUDARP9DEL",BUDJ,BUDH,D))
IF D'=+D
QUIT
Begin DoDot:1
+13 SET X=0
FOR
SET X=$ORDER(^XTMP("BUDARP9DEL",BUDJ,BUDH,D,X))
IF X'=+X
QUIT
Begin DoDot:2
+14 SET C=C+1
SET ^BUDDATA(C)=^XTMP("BUDARP9DEL",BUDJ,BUDH,D,X)
End DoDot:2
End DoDot:1
+15 SET X="***** END OF REPORT *****"
SET C=C+1
SET ^BUDDATA(C)=X
+16 SET XBFLT=1
SET XBFN=BUDFILE_".txt"
SET XBMED="F"
SET XBTLE="UDS TABLE 9D DELIMITED"
SET XBQ="N"
SET XBF=0
+17 DO ^XBGSAVE
+18 KILL XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
+19 LOCK -^BUDDATA
+20 ;export global
KILL ^BUDDATA
+21 QUIT
