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
