- 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
