- BKMQSSR5 ;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 UPD^BKMQUTL("")
- D SECTV
- D UPD^BKMQUTL("")
- D SECTVI
- Q
- SECTV ;SECTION V PRINT
- Q:$P(^BKM(90456,1,2,5,0),U,4)'="Y"
- D UPD^BKMQUTL(" SECTION V: "_$P(^BKM(90456,1,2,5,0),U,2)),UPD^BKMQUTL("")
- F BKM=2,1 S BKMLINE=$P(^BKM(90456,1,2,5,1,BKM,0),U,1) D
- . D:$P(^BKM(90456,1,2,5,1,BKM,0),U,2)="Y" UPD^BKMQUTL(" "_BKMLINE) D
- .. I BKM=1 D SECT5 Q
- .. I BKM=2 D:$G(BKMVETO)]"" Q
- ... D UPD^BKMQUTL($$LINE^BKMQUTL("",BKMVETO,5))
- Q
- SECT5 ;SECTION 5 WORD PROCESSING FIELDS
- I $D(^BKM(90456,1,2,5,1,BKM,1)) D
- . S BKM1=0
- . F S BKM1=$O(^BKM(90456,1,2,5,1,BKM,1,BKM1)) Q:'BKM1 D
- .. S BKMLINE1=$P(^BKM(90456,1,2,5,1,BKM,1,BKM1,0),U,1)
- .. D UPD^BKMQUTL(" "_BKMLINE1)
- Q
- SECTVI ;SECTION VI PRINT
- Q:$P(^BKM(90456,1,2,6,0),U,4)'="Y"
- N LINE
- D UPD^BKMQUTL(" SECTION VI: "_$P(^BKM(90456,1,2,6,0),U,2))
- D UPD^BKMQUTL(" "_$P(^BKM(90456,1,2,6,0),U,3),1)
- S BKM0=""
- F S BKM0=$O(BKMVLABS(BKM0),-1) Q:BKM0="" D
- . S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
- . S BKM1=""
- . F S BKM1=$O(BKMVLABS(BKM0,BKM1)) Q:BKM1="" D
- .. S BKM2=""
- .. F S BKM2=$O(BKMVLABS(BKM0,BKM1,BKM2)) Q:BKM2="" D
- ... 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")
- ... S LINE=$$LINE^BKMQUTL("",$E(BKMVLN,1,30),5),LINE=$$LINE^BKMQUTL(LINE,BKMDT,40)
- ... S LINE=$$LINE^BKMQUTL(LINE,BKMVLABS(BKM0,BKM1,BKM2),55)
- ... D UPD^BKMQUTL(LINE)
- F BKM=1:1:6 S BKMLINE=$P(^BKM(90456,1,2,6,1,BKM,0),U,1) D
- . D:$P(^BKM(90456,1,2,6,1,BKM,0),U,2)="Y" UPD^BKMQUTL(BKMLINE)
- . D SECT6
- Q
- SECT6 ;SECTION 6 WORD PROCESSING FIELDS
- I $D(^BKM(90456,1,2,6,1,BKM,1)) D
- . S BKM1=0
- . F S BKM1=$O(^BKM(90456,1,2,6,1,BKM,1,BKM1)) Q:'BKM1 D
- .. S BKMLINE1=$P(^BKM(90456,1,2,6,1,BKM,1,BKM1,0),U,1)
- .. D UPD^BKMQUTL(" "_BKMLINE1)
- Q
- BKMQSSR5 ;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 UPD^BKMQUTL("")
- +2 DO SECTV
- +3 DO UPD^BKMQUTL("")
- +4 DO SECTVI
- +5 QUIT
- SECTV ;SECTION V PRINT
- +1 IF $PIECE(^BKM(90456,1,2,5,0),U,4)'="Y"
- QUIT
- +2 DO UPD^BKMQUTL(" SECTION V: "_$PIECE(^BKM(90456,1,2,5,0),U,2))
- DO UPD^BKMQUTL("")
- +3 FOR BKM=2,1
- SET BKMLINE=$PIECE(^BKM(90456,1,2,5,1,BKM,0),U,1)
- Begin DoDot:1
- +4 IF $PIECE(^BKM(90456,1,2,5,1,BKM,0),U,2)="Y"
- DO UPD^BKMQUTL(" "_BKMLINE)
- Begin DoDot:2
- +5 IF BKM=1
- DO SECT5
- QUIT
- +6 IF BKM=2
- IF $GET(BKMVETO)]""
- Begin DoDot:3
- +7 DO UPD^BKMQUTL($$LINE^BKMQUTL("",BKMVETO,5))
- End DoDot:3
- QUIT
- End DoDot:2
- End DoDot:1
- +8 QUIT
- SECT5 ;SECTION 5 WORD PROCESSING FIELDS
- +1 IF $DATA(^BKM(90456,1,2,5,1,BKM,1))
- Begin DoDot:1
- +2 SET BKM1=0
- +3 FOR
- SET BKM1=$ORDER(^BKM(90456,1,2,5,1,BKM,1,BKM1))
- IF 'BKM1
- QUIT
- Begin DoDot:2
- +4 SET BKMLINE1=$PIECE(^BKM(90456,1,2,5,1,BKM,1,BKM1,0),U,1)
- +5 DO UPD^BKMQUTL(" "_BKMLINE1)
- End DoDot:2
- End DoDot:1
- +6 QUIT
- SECTVI ;SECTION VI PRINT
- +1 IF $PIECE(^BKM(90456,1,2,6,0),U,4)'="Y"
- QUIT
- +2 NEW LINE
- +3 DO UPD^BKMQUTL(" SECTION VI: "_$PIECE(^BKM(90456,1,2,6,0),U,2))
- +4 DO UPD^BKMQUTL(" "_$PIECE(^BKM(90456,1,2,6,0),U,3),1)
- +5 SET BKM0=""
- +6 FOR
- SET BKM0=$ORDER(BKMVLABS(BKM0),-1)
- IF BKM0=""
- QUIT
- Begin DoDot:1
- +7 SET BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
- +8 SET BKM1=""
- +9 FOR
- SET BKM1=$ORDER(BKMVLABS(BKM0,BKM1))
- IF BKM1=""
- QUIT
- Begin DoDot:2
- +10 SET BKM2=""
- +11 FOR
- SET BKM2=$ORDER(BKMVLABS(BKM0,BKM1,BKM2))
- IF BKM2=""
- QUIT
- Begin DoDot:3
- +12 IF BKM2="LAB"
- SET BKMVLN=$$GET1^DIQ(9000010.09,BKM1,.01,"E")
- +13 IF BKM2="CPT"
- SET BKMIEN=$$GET1^DIQ(9000010.18,BKM1,.01,"I")
- Begin DoDot:4
- +14 ;csv
- IF $TEXT(CPT^ICPTCOD)'=""
- SET BKMVLN=$$ICPT^BKMUL3(BKMIEN,BKM0\1,3)
- QUIT
- +15 SET BKMVLN=$$GET1^DIQ(81,BKMIEN,2,"E")
- End DoDot:4
- +16 SET LINE=$$LINE^BKMQUTL("",$EXTRACT(BKMVLN,1,30),5)
- SET LINE=$$LINE^BKMQUTL(LINE,BKMDT,40)
- +17 SET LINE=$$LINE^BKMQUTL(LINE,BKMVLABS(BKM0,BKM1,BKM2),55)
- +18 DO UPD^BKMQUTL(LINE)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +19 FOR BKM=1:1:6
- SET BKMLINE=$PIECE(^BKM(90456,1,2,6,1,BKM,0),U,1)
- Begin DoDot:1
- +20 IF $PIECE(^BKM(90456,1,2,6,1,BKM,0),U,2)="Y"
- DO UPD^BKMQUTL(BKMLINE)
- +21 DO SECT6
- End DoDot:1
- +22 QUIT
- SECT6 ;SECTION 6 WORD PROCESSING FIELDS
- +1 IF $DATA(^BKM(90456,1,2,6,1,BKM,1))
- Begin DoDot:1
- +2 SET BKM1=0
- +3 FOR
- SET BKM1=$ORDER(^BKM(90456,1,2,6,1,BKM,1,BKM1))
- IF 'BKM1
- QUIT
- Begin DoDot:2
- +4 SET BKMLINE1=$PIECE(^BKM(90456,1,2,6,1,BKM,1,BKM1,0),U,1)
- +5 DO UPD^BKMQUTL(" "_BKMLINE1)
- End DoDot:2
- End DoDot:1
- +6 QUIT
