BKMQSSR6 ;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 UPD^BKMQUTL("")
D SECTVII
D UPD^BKMQUTL("")
D SECTVIII
Q
SECTVII ;SECTION VII PRINT
Q:$P(^BKM(90456,1,2,7,0),U,4)'="Y"
N LINE
D UPD^BKMQUTL(" 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)
D UPD^BKMQUTL(" "_BKMLINE)
S BKM0=""
F S BKM0=$O(BKMICD(BKM0),-1) Q:BKM0="" D
. S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
. S BKM1=""
. F S BKM1=$O(BKMICD(BKM0,BKM1)) Q:BKM1="" D
.. S BKM2=""
.. F S BKM2=$O(BKMICD(BKM0,BKM1,BKM2)) Q:BKM2="" D
... I BKM2="POV" S BKMVLN=$$GET1^DIQ(9000010.07,BKM1,.01,"E")
... I BKM2="PROB" S BKMVLN=$$GET1^DIQ(9000011,BKM1,.01,"E")
... S LINE=$$LINE^BKMQUTL("",BKMDT,5),LINE=$$LINE^BKMQUTL(LINE,BKMVLN,17)
... S LINE=$$LINE^BKMQUTL(LINE,$P(BKMICD(BKM0,BKM1,BKM2),U),27)
... D UPD^BKMQUTL(LINE)
VIIA ;SECONDARY ENTRY IN SECTION VII
D UPD^BKMQUTL(""),UPD^BKMQUTL(" 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:$$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")
. S LINE=$$LINE^BKMQUTL("",BKMNDT,5),LINE=$$LINE^BKMQUTL(LINE,BKMCC,17)
. D UPD^BKMQUTL(LINE)
D UPD^BKMQUTL("")
F BKM=2:1:3 S BKMLINE=$P(^BKM(90456,1,2,7,1,BKM,0),U,1) D
. D:$P(^BKM(90456,1,2,7,1,BKM,0),U,2)="Y" UPD^BKMQUTL(" "_BKMLINE_": ")
. I $D(^BKM(90456,1,2,7,1,BKM,1)) D
.. 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) D UPD^BKMQUTL(" "_BKMLINE1)
VIIB ;SECONDARY ENTRY POINT
F BKM=4:1:30 S BKMLINE=$P(^BKM(90456,1,2,7,1,BKM,0),U,1) D
. S LINE=""
. S:$P(^BKM(90456,1,2,7,1,BKM,0),U,2)="Y" LINE=$$LINE^BKMQUTL(LINE,BKMLINE,1)
. S:BKM'=5 LINE=LINE_": "
. I LINE'="" D UPD^BKMQUTL(LINE)
. I $P(^BKM(90456,1,2,7,1,BKM,0),U,4)'="" D UPD^BKMQUTL(" "_$P(^BKM(90456,1,2,7,1,BKM,0),U,4),1)
. D SECT7
Q
SECT7 ;PRINT BLANK FIELDS FOR SECTION VII
I BKM=4 D
. D UPD^BKMQUTL("")
. S BKM1=0
. F S BKM1=$O(^BKM(90456,1,2,7,1,BKM,1,BKM1)) Q:'BKM1 D
.. S BKMLINE1=^BKM(90456,1,2,7,1,BKM,1,BKM1,0)
.. D UPD^BKMQUTL(" "_BKMLINE1)
. S BKM0=0
. F S BKM0=$O(BKMSICD(BKM0)) Q:BKM0="" D
.. S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
.. S BKM1=""
.. F S BKM1=$O(BKMSICD(BKM0,BKM1)) Q:BKM1="" D
... S BKM2=""
... F S BKM2=$O(BKMSICD(BKM0,BKM1,BKM2)) Q:BKM2="" D
.... I BKM2="POV" S BKMVLN=$$GET1^DIQ(9000010.07,BKM1,.01,"E")
.... I BKM2="PROB" S BKMVLN=$$GET1^DIQ(9000011,BKM1,.01,"E")
.... S LINE=$$LINE^BKMQUTL("",BKMDT,5),LINE=$$LINE^BKMQUTL(LINE,BKMVLN,17)
.... S LINE=$$LINE^BKMQUTL(LINE,$P(BKMSICD(BKM0,BKM1,BKM2),U),27)
.... D UPD^BKMQUTL(LINE)
I $D(^BKM(90456,1,2,7,1,BKM,1)) D:BKM>4
. S BKM1=0
. F S BKM1=$O(^BKM(90456,1,2,7,1,BKM,1,BKM1)) Q:'BKM1 D
.. S BKMLINE1=$P(^BKM(90456,1,2,7,1,BKM,1,BKM1,0),U,1)
.. D UPD^BKMQUTL(" "_BKMLINE1)
I BKM>5,BKM<30 D
. S LINE=$$LINE^BKMQUTL("","____Definitive ____Presumptive ____Not Applicable Date:________",5)
. D UPD^BKMQUTL(" "_LINE,1)
Q
SECTVIII ;SECTION VIII PRINT
Q:$P(^BKM(90456,1,2,8,0),U,4)'="Y"
D UPD^BKMQUTL(" 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
. I $P(^BKM(90456,1,2,8,1,BKM,0),U,2)="Y" D UPD^BKMQUTL(""),UPD^BKMQUTL(" "_BKMLINE) ;," "
. I $P(^BKM(90456,1,2,8,1,BKM,0),U,4)'="" D UPD^BKMQUTL(" "_$P(^BKM(90456,1,2,8,1,BKM,0),U,4))
. D SECT8
Q
SECT8 ;SECTION 8 BLANK FIELD PRINT
I BKM=4 D Q
. S BKM0=0
. F S BKM0=$O(BKMHAART(BKM0)) Q:BKM0="" D
.. S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
.. S BKM1=""
.. F S BKM1=$O(BKMHAART(BKM0,BKM1)) Q:BKM1="" D
... 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)
... S LINE=$$LINE^BKMQUTL("",$E(BKMVLN,1,24),5),LINE=$$LINE^BKMQUTL(LINE,"QTY: "_BKMQTY,30)
... S LINE=$$LINE^BKMQUTL(LINE,"DAYS: "_BKMDAY,39)
... S LINE=$$LINE^BKMQUTL(LINE,"SIG: "_$E(BKMSIG,1,13),49),LINE=$$LINE^BKMQUTL(LINE,BKMDT,68)
... D UPD^BKMQUTL(LINE)
I BKM=5 D Q
. S BKM0=0
. F S BKM0=$O(BKMPCP(BKM0)) Q:BKM0="" D
.. S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
.. S BKM1=""
.. F S BKM1=$O(BKMPCP(BKM0,BKM1)) Q:BKM1="" D
... 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)
... S LINE=""
... S LINE=$$LINE^BKMQUTL(LINE,$E(BKMVLN,1,24),5),LINE=$$LINE^BKMQUTL(LINE,"QTY: "_BKMQTY,30)
... S LINE=$$LINE^BKMQUTL(LINE,"DAYS: "_BKMDAY,39)
... S LINE=$$LINE^BKMQUTL(LINE,"SIG: "_$E(BKMSIG,1,13),49),LINE=$$LINE^BKMQUTL(LINE,BKMDT,68)
... D UPD^BKMQUTL(LINE)
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)
. S BKM1=0
. F S BKM1=$O(^BKM(90456,1,2,8,1,BKM,1,BKM1)) Q:'BKM1 D
.. S BKMLINE1=$P(^BKM(90456,1,2,8,1,BKM,1,BKM1,0),U,1)
.. D UPD^BKMQUTL(" "_BKMLINE1)
Q
BKMQSSR6 ;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 UPD^BKMQUTL("")
+2 DO SECTVII
+3 DO UPD^BKMQUTL("")
+4 DO SECTVIII
+5 QUIT
SECTVII ;SECTION VII PRINT
+1 IF $PIECE(^BKM(90456,1,2,7,0),U,4)'="Y"
QUIT
+2 NEW LINE
+3 DO UPD^BKMQUTL(" SECTION VII: "_$PIECE(^BKM(90456,1,2,7,0),U,2),1)
+4 SET BKMLINE=$PIECE(^BKM(90456,1,2,7,1,1,1,1,0),U,1)
+5 DO UPD^BKMQUTL(" "_BKMLINE)
+6 SET BKM0=""
+7 FOR
SET BKM0=$ORDER(BKMICD(BKM0),-1)
IF BKM0=""
QUIT
Begin DoDot:1
+8 SET BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
+9 SET BKM1=""
+10 FOR
SET BKM1=$ORDER(BKMICD(BKM0,BKM1))
IF BKM1=""
QUIT
Begin DoDot:2
+11 SET BKM2=""
+12 FOR
SET BKM2=$ORDER(BKMICD(BKM0,BKM1,BKM2))
IF BKM2=""
QUIT
Begin DoDot:3
+13 IF BKM2="POV"
SET BKMVLN=$$GET1^DIQ(9000010.07,BKM1,.01,"E")
+14 IF BKM2="PROB"
SET BKMVLN=$$GET1^DIQ(9000011,BKM1,.01,"E")
+15 SET LINE=$$LINE^BKMQUTL("",BKMDT,5)
SET LINE=$$LINE^BKMQUTL(LINE,BKMVLN,17)
+16 SET LINE=$$LINE^BKMQUTL(LINE,$PIECE(BKMICD(BKM0,BKM1,BKM2),U),27)
+17 DO UPD^BKMQUTL(LINE)
End DoDot:3
End DoDot:2
End DoDot:1
VIIA ;SECONDARY ENTRY IN SECTION VII
+1 DO UPD^BKMQUTL("")
DO UPD^BKMQUTL(" Patient shows the following register diagnoses:")
+2 ; PRX/DLS 4/3/2006 Changed lookup for register diagnosis' to be in reverse.
+3 IF $GET(IEN)]""
SET BKM=""
FOR
SET BKM=$ORDER(^BKMV(90455,"C",IEN,BKM),-1)
IF BKM=""
QUIT
Begin DoDot:1
+4 IF $$GET1^DIQ(90455,BKM,3,"I")'=3
QUIT
+5 SET BKMDT=$$GET1^DIQ(90455,BKM,.01,"I")
SET BKM1=$$GET1^DIQ(90455,BKM,4.5,"E")
IF BKM1=""
QUIT
+6 IF '$DATA(^BKMV(90451.7,BKM1,0))
SET BKM1=$$FIND1^DIC(90451.7,,"Q",BKM1,"B")
IF BKM1=""
QUIT
+7 SET BKMCC=$$GET1^DIQ(90451.7,BKM1,.01,"E")_" "_$$GET1^DIQ(90451.7,BKM1,1,"E")
IF BKMCC=" "
QUIT
+8 SET BKMNDT=$$FMTE^XLFDT(BKMDT\1,"5Z")
+9 SET LINE=$$LINE^BKMQUTL("",BKMNDT,5)
SET LINE=$$LINE^BKMQUTL(LINE,BKMCC,17)
+10 DO UPD^BKMQUTL(LINE)
End DoDot:1
+11 DO UPD^BKMQUTL("")
+12 FOR BKM=2:1:3
SET BKMLINE=$PIECE(^BKM(90456,1,2,7,1,BKM,0),U,1)
Begin DoDot:1
+13 IF $PIECE(^BKM(90456,1,2,7,1,BKM,0),U,2)="Y"
DO UPD^BKMQUTL(" "_BKMLINE_": ")
+14 IF $DATA(^BKM(90456,1,2,7,1,BKM,1))
Begin DoDot:2
+15 SET BKM1=0
+16 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)
DO UPD^BKMQUTL(" "_BKMLINE1)
End DoDot:2
End DoDot:1
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 SET LINE=""
+3 IF $PIECE(^BKM(90456,1,2,7,1,BKM,0),U,2)="Y"
SET LINE=$$LINE^BKMQUTL(LINE,BKMLINE,1)
+4 IF BKM'=5
SET LINE=LINE_": "
+5 IF LINE'=""
DO UPD^BKMQUTL(LINE)
+6 IF $PIECE(^BKM(90456,1,2,7,1,BKM,0),U,4)'=""
DO UPD^BKMQUTL(" "_$PIECE(^BKM(90456,1,2,7,1,BKM,0),U,4),1)
+7 DO SECT7
End DoDot:1
+8 QUIT
SECT7 ;PRINT BLANK FIELDS FOR SECTION VII
+1 IF BKM=4
Begin DoDot:1
+2 DO UPD^BKMQUTL("")
+3 SET BKM1=0
+4 FOR
SET BKM1=$ORDER(^BKM(90456,1,2,7,1,BKM,1,BKM1))
IF 'BKM1
QUIT
Begin DoDot:2
+5 SET BKMLINE1=^BKM(90456,1,2,7,1,BKM,1,BKM1,0)
+6 DO UPD^BKMQUTL(" "_BKMLINE1)
End DoDot:2
+7 SET BKM0=0
+8 FOR
SET BKM0=$ORDER(BKMSICD(BKM0))
IF BKM0=""
QUIT
Begin DoDot:2
+9 SET BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
+10 SET BKM1=""
+11 FOR
SET BKM1=$ORDER(BKMSICD(BKM0,BKM1))
IF BKM1=""
QUIT
Begin DoDot:3
+12 SET BKM2=""
+13 FOR
SET BKM2=$ORDER(BKMSICD(BKM0,BKM1,BKM2))
IF BKM2=""
QUIT
Begin DoDot:4
+14 IF BKM2="POV"
SET BKMVLN=$$GET1^DIQ(9000010.07,BKM1,.01,"E")
+15 IF BKM2="PROB"
SET BKMVLN=$$GET1^DIQ(9000011,BKM1,.01,"E")
+16 SET LINE=$$LINE^BKMQUTL("",BKMDT,5)
SET LINE=$$LINE^BKMQUTL(LINE,BKMVLN,17)
+17 SET LINE=$$LINE^BKMQUTL(LINE,$PIECE(BKMSICD(BKM0,BKM1,BKM2),U),27)
+18 DO UPD^BKMQUTL(LINE)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF $DATA(^BKM(90456,1,2,7,1,BKM,1))
IF BKM>4
Begin DoDot:1
+20 SET BKM1=0
+21 FOR
SET BKM1=$ORDER(^BKM(90456,1,2,7,1,BKM,1,BKM1))
IF 'BKM1
QUIT
Begin DoDot:2
+22 SET BKMLINE1=$PIECE(^BKM(90456,1,2,7,1,BKM,1,BKM1,0),U,1)
+23 DO UPD^BKMQUTL(" "_BKMLINE1)
End DoDot:2
End DoDot:1
+24 IF BKM>5
IF BKM<30
Begin DoDot:1
+25 SET LINE=$$LINE^BKMQUTL("","____Definitive ____Presumptive ____Not Applicable Date:________",5)
+26 DO UPD^BKMQUTL(" "_LINE,1)
End DoDot:1
+27 QUIT
SECTVIII ;SECTION VIII PRINT
+1 IF $PIECE(^BKM(90456,1,2,8,0),U,4)'="Y"
QUIT
+2 DO UPD^BKMQUTL(" 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 $PIECE(^BKM(90456,1,2,8,1,BKM,0),U,2)="Y"
DO UPD^BKMQUTL("")
DO UPD^BKMQUTL(" "_BKMLINE)
+5 IF $PIECE(^BKM(90456,1,2,8,1,BKM,0),U,4)'=""
DO UPD^BKMQUTL(" "_$PIECE(^BKM(90456,1,2,8,1,BKM,0),U,4))
+6 DO SECT8
End DoDot:1
+7 QUIT
SECT8 ;SECTION 8 BLANK FIELD PRINT
+1 IF BKM=4
Begin DoDot:1
+2 SET BKM0=0
+3 FOR
SET BKM0=$ORDER(BKMHAART(BKM0))
IF BKM0=""
QUIT
Begin DoDot:2
+4 SET BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
+5 SET BKM1=""
+6 FOR
SET BKM1=$ORDER(BKMHAART(BKM0,BKM1))
IF BKM1=""
QUIT
Begin DoDot:3
+7 SET BKMVLN=$PIECE(BKMHAART(BKM0,BKM1),U,1)
+8 SET BKMSIG=$PIECE(BKMHAART(BKM0,BKM1),U,2)
+9 SET BKMQTY=$PIECE(BKMHAART(BKM0,BKM1),U,3)
+10 SET BKMDAY=$PIECE(BKMHAART(BKM0,BKM1),U,4)
+11 SET LINE=$$LINE^BKMQUTL("",$EXTRACT(BKMVLN,1,24),5)
SET LINE=$$LINE^BKMQUTL(LINE,"QTY: "_BKMQTY,30)
+12 SET LINE=$$LINE^BKMQUTL(LINE,"DAYS: "_BKMDAY,39)
+13 SET LINE=$$LINE^BKMQUTL(LINE,"SIG: "_$EXTRACT(BKMSIG,1,13),49)
SET LINE=$$LINE^BKMQUTL(LINE,BKMDT,68)
+14 DO UPD^BKMQUTL(LINE)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+15 IF BKM=5
Begin DoDot:1
+16 SET BKM0=0
+17 FOR
SET BKM0=$ORDER(BKMPCP(BKM0))
IF BKM0=""
QUIT
Begin DoDot:2
+18 SET BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
+19 SET BKM1=""
+20 FOR
SET BKM1=$ORDER(BKMPCP(BKM0,BKM1))
IF BKM1=""
QUIT
Begin DoDot:3
+21 SET BKMVLN=$PIECE(BKMPCP(BKM0,BKM1),U,1)
+22 SET BKMSIG=$PIECE(BKMPCP(BKM0,BKM1),U,2)
+23 SET BKMQTY=$PIECE(BKMPCP(BKM0,BKM1),U,3)
+24 SET BKMDAY=$PIECE(BKMPCP(BKM0,BKM1),U,4)
+25 SET LINE=""
+26 SET LINE=$$LINE^BKMQUTL(LINE,$EXTRACT(BKMVLN,1,24),5)
SET LINE=$$LINE^BKMQUTL(LINE,"QTY: "_BKMQTY,30)
+27 SET LINE=$$LINE^BKMQUTL(LINE,"DAYS: "_BKMDAY,39)
+28 SET LINE=$$LINE^BKMQUTL(LINE,"SIG: "_$EXTRACT(BKMSIG,1,13),49)
SET LINE=$$LINE^BKMQUTL(LINE,BKMDT,68)
+29 DO UPD^BKMQUTL(LINE)
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+30 ;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
+31 IF $DATA(^BKM(90456,1,2,8,1,BKM,1))
IF BKM'=4&(BKM'=5)
Begin DoDot:1
+32 SET BKM1=0
+33 FOR
SET BKM1=$ORDER(^BKM(90456,1,2,8,1,BKM,1,BKM1))
IF 'BKM1
QUIT
Begin DoDot:2
+34 SET BKMLINE1=$PIECE(^BKM(90456,1,2,8,1,BKM,1,BKM1,0),U,1)
+35 DO UPD^BKMQUTL(" "_BKMLINE1)
End DoDot:2
End DoDot:1
+36 QUIT
