- 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