BKMVSSR6 ;PRXM/HC/CJS - STATE SURV. REPORT PRINT CONTINUED ; 14 Jul 2005 3:55 PM
;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
;
;
EN ;EP - PRIMARY ROUTINE ENTRY POINT
D HDR^BKMVSSR3 Q:BKMX
D HDR1^BKMVSSR3
D SECTVII Q:BKMX
D HDR^BKMVSSR3 Q:BKMX
D HDR1^BKMVSSR3
D SECTVIII Q:BKMX
Q
SECTVII ;SECTION VII PRINT
Q:$P(^BKM(90456,1,2,7,0),U,4)'="Y"
W !?1,"SECTION VII: ",$P(^BKM(90456,1,2,7,0),U,2),!?1
S BKMLINE=$P(^BKM(90456,1,2,7,1,1,1,1,0),U,1) W !?1,BKMLINE
S BKM0="" F S BKM0=$O(BKMICD(BKM0),-1) Q:BKM0="" D Q:BKMX
.S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
.S BKM1="" F S BKM1=$O(BKMICD(BKM0,BKM1)) Q:BKM1="" D Q:BKMX
..S BKM2="" F S BKM2=$O(BKMICD(BKM0,BKM1,BKM2)) Q:BKM2="" D Q:BKMX
...I BKM2="POV" S BKMVLN=$$GET1^DIQ(9000010.07,BKM1,.01,"E")
...I BKM2="PROB" S BKMVLN=$$GET1^DIQ(9000011,BKM1,.01,"E")
...I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
...W !?5,BKMDT,?17,BKMVLN,?27,$P(BKMICD(BKM0,BKM1,BKM2),U)
VIIA ;SECONDARY ENTRY IN SECTION VII
I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
W !!?1,"Patient shows the following register diagnoses:"
; PRX/DLS 4/3/2006 Changed lookup for register diagnosis' to be in reverse.
I $G(IEN)]"" S BKM="" F S BKM=$O(^BKMV(90455,"C",IEN,BKM),-1) Q:BKM="" D Q:BKMX
.Q:$$GET1^DIQ(90455,BKM,3,"I")'=3
.S BKMDT=$$GET1^DIQ(90455,BKM,.01,"I"),BKM1=$$GET1^DIQ(90455,BKM,4.5,"E") Q:BKM1=""
.I '$D(^BKMV(90451.7,BKM1,0)) S BKM1=$$FIND1^DIC(90451.7,,"Q",BKM1,"B") Q:BKM1=""
.S BKMCC=$$GET1^DIQ(90451.7,BKM1,.01,"E")_" "_$$GET1^DIQ(90451.7,BKM1,1,"E") Q:BKMCC=" "
.S BKMNDT=$$FMTE^XLFDT(BKMDT\1,"5Z")
.I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
.W !?5,BKMNDT,?17,BKMCC
I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
W !?1
F BKM=2:1:3 S BKMLINE=$P(^BKM(90456,1,2,7,1,BKM,0),U,1) D Q:BKMX
.W:$P(^BKM(90456,1,2,7,1,BKM,0),U,2)="Y" !?1,BKMLINE,": "
.I $D(^BKM(90456,1,2,7,1,BKM,1)) D
..I $Y>(IOSL-$P(^BKM(90456,1,2,7,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,7,1,BKM,1,BKM1)) Q:'BKM1 S BKMLINE1=$P(^BKM(90456,1,2,7,1,BKM,1,BKM1,0),U) W !?1,BKMLINE1
VIIB ;SECONDARY ENTRY POINT
F BKM=4:1:30 S BKMLINE=$P(^BKM(90456,1,2,7,1,BKM,0),U,1) D Q:BKMX
.I $Y>(IOSL-7) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
.W:$P(^BKM(90456,1,2,7,1,BKM,0),U,2)="Y" !?1,BKMLINE
.W:BKM'=5 ": "
.W:$P(^BKM(90456,1,2,7,1,BKM,0),U,4)'="" !?1,$P(^BKM(90456,1,2,7,1,BKM,0),U,4),!?1
.D SECT7 Q:BKMX
Q
SECT7 ;PRINT BLANK FIELDS FOR SECTION VII
I BKM=4 W !?1 D Q:BKMX
.S BKM1=0 F S BKM1=$O(^BKM(90456,1,2,7,1,BKM,1,BKM1)) Q:'BKM1 D Q:BKMX
..I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
..S BKMLINE1=^BKM(90456,1,2,7,1,BKM,1,BKM1,0)
..W !?1,BKMLINE1
.S BKM0=0 F S BKM0=$O(BKMSICD(BKM0)) Q:BKM0="" D Q:BKMX
..S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
..S BKM1="" F S BKM1=$O(BKMSICD(BKM0,BKM1)) Q:BKM1="" D Q:BKMX
...S BKM2="" F S BKM2=$O(BKMSICD(BKM0,BKM1,BKM2)) Q:BKM2="" D Q:BKMX
....I BKM2="POV" S BKMVLN=$$GET1^DIQ(9000010.07,BKM1,.01,"E")
....I BKM2="PROB" S BKMVLN=$$GET1^DIQ(9000011,BKM1,.01,"E")
....I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
....W !?5,BKMDT,?17,BKMVLN,?27,$P(BKMSICD(BKM0,BKM1,BKM2),U)
I $D(^BKM(90456,1,2,7,1,BKM,1)) D:BKM>4 Q:BKMX
.I $Y>(IOSL-$P(^BKM(90456,1,2,7,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,7,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,7,1,BKM,1,BKM1,0),U,1)
..W !?1,BKMLINE1
I BKM>5&(BKM<30) W !?5,"____Definitive ____Presumptive ____Not Applicable Date:________",!?1
Q
SECTVIII ;SECTION VIII PRINT
Q:$P(^BKM(90456,1,2,8,0),U,4)'="Y"
W !?1,"SECTION VIII: ",$P(^BKM(90456,1,2,8,0),U,2)
F BKM=1:1:13 S BKMLINE=$P(^BKM(90456,1,2,8,1,BKM,0),U,1) D Q:BKMX
.I $Y>(IOSL-6) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
.W:$P(^BKM(90456,1,2,8,1,BKM,0),U,2)="Y" !!?1,BKMLINE," "
.I $P(^BKM(90456,1,2,8,1,BKM,0),U,4)'="" W !?1,$P(^BKM(90456,1,2,8,1,BKM,0),U,4)
.D SECT8 Q:BKMX
Q
SECT8 ;SECTION 8 BLANK FIELD PRINT
I BKM=4 D Q
.S BKM0=0 F S BKM0=$O(BKMHAART(BKM0)) Q:BKM0="" D Q:BKMX
..S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
..S BKM1="" F S BKM1=$O(BKMHAART(BKM0,BKM1)) Q:BKM1="" D Q:BKMX
...S BKMVLN=$P(BKMHAART(BKM0,BKM1),U,1)
...S BKMSIG=$P(BKMHAART(BKM0,BKM1),U,2)
...S BKMQTY=$P(BKMHAART(BKM0,BKM1),U,3)
...S BKMDAY=$P(BKMHAART(BKM0,BKM1),U,4)
...I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
...W !?5,$E(BKMVLN,1,24),?30,"QTY: ",BKMQTY,?39,"DAYS: ",BKMDAY
...W ?49,"SIG: ",$E(BKMSIG,1,13),?68,BKMDT
I BKM=5 D Q
.S BKM0=0 F S BKM0=$O(BKMPCP(BKM0)) Q:BKM0="" D Q:BKMX
..S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
..S BKM1="" F S BKM1=$O(BKMPCP(BKM0,BKM1)) Q:BKM1="" D Q:BKMX
...S BKMVLN=$P(BKMPCP(BKM0,BKM1),U,1)
...S BKMSIG=$P(BKMPCP(BKM0,BKM1),U,2)
...S BKMQTY=$P(BKMPCP(BKM0,BKM1),U,3)
...S BKMDAY=$P(BKMPCP(BKM0,BKM1),U,4)
...I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX D HDR1^BKMVSSR3
...W !?5,$E(BKMVLN,1,24),?30,"QTY: ",BKMQTY,?39,"DAYS: ",BKMDAY
...W ?49,"SIG: ",$E(BKMSIG,1,13),?68,BKMDT
I BKM=10 ;Add information on current pregnancy, if any. Update next line with sub-section 10, depending on how much data can be gathered.
I $D(^BKM(90456,1,2,8,1,BKM,1)) D:BKM'=4&(BKM'=5) Q:BKMX
.I $Y>(IOSL-$P(^BKM(90456,1,2,8,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,8,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,8,1,BKM,1,BKM1,0),U,1)
..W !?1,BKMLINE1
Q
BKMVSSR6 ;PRXM/HC/CJS - STATE SURV. REPORT PRINT CONTINUED ; 14 Jul 2005 3:55 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 SECTVII
IF BKMX
QUIT
+4 DO HDR^BKMVSSR3
IF BKMX
QUIT
+5 DO HDR1^BKMVSSR3
+6 DO SECTVIII
IF BKMX
QUIT
+7 QUIT
SECTVII ;SECTION VII PRINT
+1 IF $PIECE(^BKM(90456,1,2,7,0),U,4)'="Y"
QUIT
+2 WRITE !?1,"SECTION VII: ",$PIECE(^BKM(90456,1,2,7,0),U,2),!?1
+3 SET BKMLINE=$PIECE(^BKM(90456,1,2,7,1,1,1,1,0),U,1)
WRITE !?1,BKMLINE
+4 SET BKM0=""
FOR
SET BKM0=$ORDER(BKMICD(BKM0),-1)
IF BKM0=""
QUIT
Begin DoDot:1
+5 SET BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
+6 SET BKM1=""
FOR
SET BKM1=$ORDER(BKMICD(BKM0,BKM1))
IF BKM1=""
QUIT
Begin DoDot:2
+7 SET BKM2=""
FOR
SET BKM2=$ORDER(BKMICD(BKM0,BKM1,BKM2))
IF BKM2=""
QUIT
Begin DoDot:3
+8 IF BKM2="POV"
SET BKMVLN=$$GET1^DIQ(9000010.07,BKM1,.01,"E")
+9 IF BKM2="PROB"
SET BKMVLN=$$GET1^DIQ(9000011,BKM1,.01,"E")
+10 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+11 WRITE !?5,BKMDT,?17,BKMVLN,?27,$PIECE(BKMICD(BKM0,BKM1,BKM2),U)
End DoDot:3
IF BKMX
QUIT
End DoDot:2
IF BKMX
QUIT
End DoDot:1
IF BKMX
QUIT
VIIA ;SECONDARY ENTRY IN SECTION VII
+1 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+2 WRITE !!?1,"Patient shows the following register diagnoses:"
+3 ; PRX/DLS 4/3/2006 Changed lookup for register diagnosis' to be in reverse.
+4 IF $GET(IEN)]""
SET BKM=""
FOR
SET BKM=$ORDER(^BKMV(90455,"C",IEN,BKM),-1)
IF BKM=""
QUIT
Begin DoDot:1
+5 IF $$GET1^DIQ(90455,BKM,3,"I")'=3
QUIT
+6 SET BKMDT=$$GET1^DIQ(90455,BKM,.01,"I")
SET BKM1=$$GET1^DIQ(90455,BKM,4.5,"E")
IF BKM1=""
QUIT
+7 IF '$DATA(^BKMV(90451.7,BKM1,0))
SET BKM1=$$FIND1^DIC(90451.7,,"Q",BKM1,"B")
IF BKM1=""
QUIT
+8 SET BKMCC=$$GET1^DIQ(90451.7,BKM1,.01,"E")_" "_$$GET1^DIQ(90451.7,BKM1,1,"E")
IF BKMCC=" "
QUIT
+9 SET BKMNDT=$$FMTE^XLFDT(BKMDT\1,"5Z")
+10 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+11 WRITE !?5,BKMNDT,?17,BKMCC
End DoDot:1
IF BKMX
QUIT
+12 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+13 WRITE !?1
+14 FOR BKM=2:1:3
SET BKMLINE=$PIECE(^BKM(90456,1,2,7,1,BKM,0),U,1)
Begin DoDot:1
+15 IF $PIECE(^BKM(90456,1,2,7,1,BKM,0),U,2)="Y"
WRITE !?1,BKMLINE,": "
+16 IF $DATA(^BKM(90456,1,2,7,1,BKM,1))
Begin DoDot:2
+17 IF $Y>(IOSL-$PIECE(^BKM(90456,1,2,7,1,BKM,1,0),U,4)-2)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+18 SET BKM1=0
+19 FOR
SET BKM1=$ORDER(^BKM(90456,1,2,7,1,BKM,1,BKM1))
IF 'BKM1
QUIT
SET BKMLINE1=$PIECE(^BKM(90456,1,2,7,1,BKM,1,BKM1,0),U)
WRITE !?1,BKMLINE1
End DoDot:2
End DoDot:1
IF BKMX
QUIT
VIIB ;SECONDARY ENTRY POINT
+1 FOR BKM=4:1:30
SET BKMLINE=$PIECE(^BKM(90456,1,2,7,1,BKM,0),U,1)
Begin DoDot:1
+2 IF $Y>(IOSL-7)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+3 IF $PIECE(^BKM(90456,1,2,7,1,BKM,0),U,2)="Y"
WRITE !?1,BKMLINE
+4 IF BKM'=5
WRITE ": "
+5 IF $PIECE(^BKM(90456,1,2,7,1,BKM,0),U,4)'=""
WRITE !?1,$PIECE(^BKM(90456,1,2,7,1,BKM,0),U,4),!?1
+6 DO SECT7
IF BKMX
QUIT
End DoDot:1
IF BKMX
QUIT
+7 QUIT
SECT7 ;PRINT BLANK FIELDS FOR SECTION VII
+1 IF BKM=4
WRITE !?1
Begin DoDot:1
+2 SET BKM1=0
FOR
SET BKM1=$ORDER(^BKM(90456,1,2,7,1,BKM,1,BKM1))
IF 'BKM1
QUIT
Begin DoDot:2
+3 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+4 SET BKMLINE1=^BKM(90456,1,2,7,1,BKM,1,BKM1,0)
+5 WRITE !?1,BKMLINE1
End DoDot:2
IF BKMX
QUIT
+6 SET BKM0=0
FOR
SET BKM0=$ORDER(BKMSICD(BKM0))
IF BKM0=""
QUIT
Begin DoDot:2
+7 SET BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
+8 SET BKM1=""
FOR
SET BKM1=$ORDER(BKMSICD(BKM0,BKM1))
IF BKM1=""
QUIT
Begin DoDot:3
+9 SET BKM2=""
FOR
SET BKM2=$ORDER(BKMSICD(BKM0,BKM1,BKM2))
IF BKM2=""
QUIT
Begin DoDot:4
+10 IF BKM2="POV"
SET BKMVLN=$$GET1^DIQ(9000010.07,BKM1,.01,"E")
+11 IF BKM2="PROB"
SET BKMVLN=$$GET1^DIQ(9000011,BKM1,.01,"E")
+12 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+13 WRITE !?5,BKMDT,?17,BKMVLN,?27,$PIECE(BKMSICD(BKM0,BKM1,BKM2),U)
End DoDot:4
IF BKMX
QUIT
End DoDot:3
IF BKMX
QUIT
End DoDot:2
IF BKMX
QUIT
End DoDot:1
IF BKMX
QUIT
+14 IF $DATA(^BKM(90456,1,2,7,1,BKM,1))
IF BKM>4
Begin DoDot:1
+15 IF $Y>(IOSL-$PIECE(^BKM(90456,1,2,7,1,BKM,1,0),U,4)-2)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+16 SET BKM1=0
FOR
SET BKM1=$ORDER(^BKM(90456,1,2,7,1,BKM,1,BKM1))
IF 'BKM1
QUIT
Begin DoDot:2
+17 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+18 SET BKMLINE1=$PIECE(^BKM(90456,1,2,7,1,BKM,1,BKM1,0),U,1)
+19 WRITE !?1,BKMLINE1
End DoDot:2
IF BKMX
QUIT
End DoDot:1
IF BKMX
QUIT
+20 IF BKM>5&(BKM<30)
WRITE !?5,"____Definitive ____Presumptive ____Not Applicable Date:________",!?1
+21 QUIT
SECTVIII ;SECTION VIII PRINT
+1 IF $PIECE(^BKM(90456,1,2,8,0),U,4)'="Y"
QUIT
+2 WRITE !?1,"SECTION VIII: ",$PIECE(^BKM(90456,1,2,8,0),U,2)
+3 FOR BKM=1:1:13
SET BKMLINE=$PIECE(^BKM(90456,1,2,8,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,8,1,BKM,0),U,2)="Y"
WRITE !!?1,BKMLINE," "
+6 IF $PIECE(^BKM(90456,1,2,8,1,BKM,0),U,4)'=""
WRITE !?1,$PIECE(^BKM(90456,1,2,8,1,BKM,0),U,4)
+7 DO SECT8
IF BKMX
QUIT
End DoDot:1
IF BKMX
QUIT
+8 QUIT
SECT8 ;SECTION 8 BLANK FIELD PRINT
+1 IF BKM=4
Begin DoDot:1
+2 SET BKM0=0
FOR
SET BKM0=$ORDER(BKMHAART(BKM0))
IF BKM0=""
QUIT
Begin DoDot:2
+3 SET BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
+4 SET BKM1=""
FOR
SET BKM1=$ORDER(BKMHAART(BKM0,BKM1))
IF BKM1=""
QUIT
Begin DoDot:3
+5 SET BKMVLN=$PIECE(BKMHAART(BKM0,BKM1),U,1)
+6 SET BKMSIG=$PIECE(BKMHAART(BKM0,BKM1),U,2)
+7 SET BKMQTY=$PIECE(BKMHAART(BKM0,BKM1),U,3)
+8 SET BKMDAY=$PIECE(BKMHAART(BKM0,BKM1),U,4)
+9 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+10 WRITE !?5,$EXTRACT(BKMVLN,1,24),?30,"QTY: ",BKMQTY,?39,"DAYS: ",BKMDAY
+11 WRITE ?49,"SIG: ",$EXTRACT(BKMSIG,1,13),?68,BKMDT
End DoDot:3
IF BKMX
QUIT
End DoDot:2
IF BKMX
QUIT
End DoDot:1
QUIT
+12 IF BKM=5
Begin DoDot:1
+13 SET BKM0=0
FOR
SET BKM0=$ORDER(BKMPCP(BKM0))
IF BKM0=""
QUIT
Begin DoDot:2
+14 SET BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
+15 SET BKM1=""
FOR
SET BKM1=$ORDER(BKMPCP(BKM0,BKM1))
IF BKM1=""
QUIT
Begin DoDot:3
+16 SET BKMVLN=$PIECE(BKMPCP(BKM0,BKM1),U,1)
+17 SET BKMSIG=$PIECE(BKMPCP(BKM0,BKM1),U,2)
+18 SET BKMQTY=$PIECE(BKMPCP(BKM0,BKM1),U,3)
+19 SET BKMDAY=$PIECE(BKMPCP(BKM0,BKM1),U,4)
+20 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+21 WRITE !?5,$EXTRACT(BKMVLN,1,24),?30,"QTY: ",BKMQTY,?39,"DAYS: ",BKMDAY
+22 WRITE ?49,"SIG: ",$EXTRACT(BKMSIG,1,13),?68,BKMDT
End DoDot:3
IF BKMX
QUIT
End DoDot:2
IF BKMX
QUIT
End DoDot:1
QUIT
+23 ;Add information on current pregnancy, if any. Update next line with sub-section 10, depending on how much data can be gathered.
IF BKM=10
+24 IF $DATA(^BKM(90456,1,2,8,1,BKM,1))
IF BKM'=4&(BKM'=5)
Begin DoDot:1
+25 IF $Y>(IOSL-$PIECE(^BKM(90456,1,2,8,1,BKM,1,0),U,4)-2)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+26 SET BKM1=0
FOR
SET BKM1=$ORDER(^BKM(90456,1,2,8,1,BKM,1,BKM1))
IF 'BKM1
QUIT
Begin DoDot:2
+27 IF $Y>(IOSL-4)
DO HDR^BKMVSSR3
IF BKMX
QUIT
DO HDR1^BKMVSSR3
+28 SET BKMLINE1=$PIECE(^BKM(90456,1,2,8,1,BKM,1,BKM1,0),U,1)
+29 WRITE !?1,BKMLINE1
End DoDot:2
IF BKMX
QUIT
End DoDot:1
IF BKMX
QUIT
+30 QUIT
