- 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
