BKMVSSR5 ;PRXM/HC/CLT - STATE SURV. REPORT PRINT CONTINUED ; 31 Mar 2005 3:52 PM
;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
;
;
EN ;EP - PRIMARY ROUTINE ENTRY POINT
D HDR^BKMVSSR3 Q:BKMX
D HDR1^BKMVSSR3
D SECTV Q:BKMX
D HDR^BKMVSSR3 Q:BKMX
D HDR1^BKMVSSR3
D SECTVI Q:BKMX
Q
SECTV ;SECTION V PRINT
Q:$P(^BKM(90456,1,2,5,0),U,4)'="Y"
W !?1,"SECTION V: ",$P(^BKM(90456,1,2,5,0),U,2),!?1
F BKM=2,1 S BKMLINE=$P(^BKM(90456,1,2,5,1,BKM,0),U,1) D
.I $Y>(IOSL-6) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
.W:$P(^BKM(90456,1,2,5,1,BKM,0),U,2)="Y" !?1,BKMLINE D
..I BKM=1 D SECT5 Q
..I BKM=2 D:$G(BKMVETO)]"" Q
...W !?5,BKMVETO
Q
SECT5 ;SECTION 5 WORD PROCESSING FIELDS
I $D(^BKM(90456,1,2,5,1,BKM,1)) D Q:BKMX
.;Following line causes a nearly blank page on the screen display. It is not really needed because a header is printed just prior to this call.
.;I $Y>(IOSL-$P(^BKM(90456,1,2,5,1,BKM,1,0),U,4)-2) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
.S BKM1=0 F S BKM1=$O(^BKM(90456,1,2,5,1,BKM,1,BKM1)) Q:'BKM1 D Q:BKMX
..I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
..S BKMLINE1=$P(^BKM(90456,1,2,5,1,BKM,1,BKM1,0),U,1)
..W !?1,BKMLINE1
Q
SECTVI ;SECTION VI PRINT
Q:$P(^BKM(90456,1,2,6,0),U,4)'="Y"
W !?1,"SECTION VI: ",$P(^BKM(90456,1,2,6,0),U,2),!?1,$P(^BKM(90456,1,2,6,0),U,3),!?1
S BKM0="" F S BKM0=$O(BKMVLABS(BKM0),-1) Q:BKM0="" D Q:BKMX
.S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
.S BKM1="" F S BKM1=$O(BKMVLABS(BKM0,BKM1)) Q:BKM1="" D Q:BKMX
..S BKM2="" F S BKM2=$O(BKMVLABS(BKM0,BKM1,BKM2)) Q:BKM2="" D Q:BKMX
...I BKM2="LAB" S BKMVLN=$$GET1^DIQ(9000010.09,BKM1,.01,"E")
...I BKM2="CPT" S BKMIEN=$$GET1^DIQ(9000010.18,BKM1,.01,"I") D
.... I $T(CPT^ICPTCOD)'="" S BKMVLN=$$ICPT^BKMUL3(BKMIEN,BKM0\1,3) Q ; csv
.... S BKMVLN=$$GET1^DIQ(81,BKMIEN,2,"E")
...I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
...W !?5,$E(BKMVLN,1,30),?40,BKMDT,?55,BKMVLABS(BKM0,BKM1,BKM2)
Q:BKMX
F BKM=1:1:6 S BKMLINE=$P(^BKM(90456,1,2,6,1,BKM,0),U,1) D Q:BKMX
.I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
.W:$P(^BKM(90456,1,2,6,1,BKM,0),U,2)="Y" !?1,BKMLINE
.D SECT6
Q
SECT6 ;SECTION 6 WORD PROCESSING FIELDS
I $D(^BKM(90456,1,2,6,1,BKM,1)) D Q:BKMX
.I $Y>(IOSL-$P(^BKM(90456,1,2,6,1,BKM,1,0),U,4)-2) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
.S BKM1=0 F S BKM1=$O(^BKM(90456,1,2,6,1,BKM,1,BKM1)) Q:'BKM1 D Q:BKMX
..I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
..S BKMLINE1=$P(^BKM(90456,1,2,6,1,BKM,1,BKM1,0),U,1)
..W !?1,BKMLINE1
Q
BKMVSSR5 ;PRXM/HC/CLT - STATE SURV. REPORT PRINT CONTINUED ; 31 Mar 2005 3:52 PM
+1 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 ;
EN ;EP - PRIMARY ROUTINE ENTRY POINT
+1 DO HDR^BKMVSSR3
IF BKMX
QUIT
+2 DO HDR1^BKMVSSR3
+3 DO SECTV
IF BKMX
QUIT
+4 DO HDR^BKMVSSR3
IF BKMX
QUIT
+5 DO HDR1^BKMVSSR3
+6 DO SECTVI
IF BKMX
QUIT
+7 QUIT
SECTV ;SECTION V PRINT
+1 IF $PIECE(^BKM(90456,1,2,5,0),U,4)'="Y"
QUIT
+2 WRITE !?1,"SECTION V: ",$PIECE(^BKM(90456,1,2,5,0),U,2),!?1
+3 FOR BKM=2,1
SET BKMLINE=$PIECE(^BKM(90456,1,2,5,1,BKM,0),U,1)
Begin DoDot:1
+4 IF $Y>(IOSL-6)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+5 IF $PIECE(^BKM(90456,1,2,5,1,BKM,0),U,2)="Y"
WRITE !?1,BKMLINE
Begin DoDot:2
+6 IF BKM=1
DO SECT5
QUIT
+7 IF BKM=2
IF $GET(BKMVETO)]""
Begin DoDot:3
+8 WRITE !?5,BKMVETO
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+9 QUIT
SECT5 ;SECTION 5 WORD PROCESSING FIELDS
+1 IF $DATA(^BKM(90456,1,2,5,1,BKM,1))
Begin DoDot:1
+2 ;Following line causes a nearly blank page on the screen display. It is not really needed because a header is printed just prior to this call.
+3 ;I $Y>(IOSL-$P(^BKM(90456,1,2,5,1,BKM,1,0),U,4)-2) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
+4 SET BKM1=0
FOR
SET BKM1=$ORDER(^BKM(90456,1,2,5,1,BKM,1,BKM1))
IF 'BKM1
QUIT
Begin DoDot:2
+5 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+6 SET BKMLINE1=$PIECE(^BKM(90456,1,2,5,1,BKM,1,BKM1,0),U,1)
+7 WRITE !?1,BKMLINE1
End DoDot:2
IF BKMX
QUIT
End DoDot:1
IF BKMX
QUIT
+8 QUIT
SECTVI ;SECTION VI PRINT
+1 IF $PIECE(^BKM(90456,1,2,6,0),U,4)'="Y"
QUIT
+2 WRITE !?1,"SECTION VI: ",$PIECE(^BKM(90456,1,2,6,0),U,2),!?1,$PIECE(^BKM(90456,1,2,6,0),U,3),!?1
+3 SET BKM0=""
FOR
SET BKM0=$ORDER(BKMVLABS(BKM0),-1)
IF BKM0=""
QUIT
Begin DoDot:1
+4 SET BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
+5 SET BKM1=""
FOR
SET BKM1=$ORDER(BKMVLABS(BKM0,BKM1))
IF BKM1=""
QUIT
Begin DoDot:2
+6 SET BKM2=""
FOR
SET BKM2=$ORDER(BKMVLABS(BKM0,BKM1,BKM2))
IF BKM2=""
QUIT
Begin DoDot:3
+7 IF BKM2="LAB"
SET BKMVLN=$$GET1^DIQ(9000010.09,BKM1,.01,"E")
+8 IF BKM2="CPT"
SET BKMIEN=$$GET1^DIQ(9000010.18,BKM1,.01,"I")
Begin DoDot:4
+9 ; csv
IF $TEXT(CPT^ICPTCOD)'=""
SET BKMVLN=$$ICPT^BKMUL3(BKMIEN,BKM0\1,3)
QUIT
+10 SET BKMVLN=$$GET1^DIQ(81,BKMIEN,2,"E")
End DoDot:4
+11 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+12 WRITE !?5,$EXTRACT(BKMVLN,1,30),?40,BKMDT,?55,BKMVLABS(BKM0,BKM1,BKM2)
End DoDot:3
IF BKMX
QUIT
End DoDot:2
IF BKMX
QUIT
End DoDot:1
IF BKMX
QUIT
+13 IF BKMX
QUIT
+14 FOR BKM=1:1:6
SET BKMLINE=$PIECE(^BKM(90456,1,2,6,1,BKM,0),U,1)
Begin DoDot:1
+15 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+16 IF $PIECE(^BKM(90456,1,2,6,1,BKM,0),U,2)="Y"
WRITE !?1,BKMLINE
+17 DO SECT6
End DoDot:1
IF BKMX
QUIT
+18 QUIT
SECT6 ;SECTION 6 WORD PROCESSING FIELDS
+1 IF $DATA(^BKM(90456,1,2,6,1,BKM,1))
Begin DoDot:1
+2 IF $Y>(IOSL-$PIECE(^BKM(90456,1,2,6,1,BKM,1,0),U,4)-2)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+3 SET BKM1=0
FOR
SET BKM1=$ORDER(^BKM(90456,1,2,6,1,BKM,1,BKM1))
IF 'BKM1
QUIT
Begin DoDot:2
+4 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+5 SET BKMLINE1=$PIECE(^BKM(90456,1,2,6,1,BKM,1,BKM1,0),U,1)
+6 WRITE !?1,BKMLINE1
End DoDot:2
IF BKMX
QUIT
End DoDot:1
IF BKMX
QUIT
+7 QUIT
