Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BKMQSSR6

BKMQSSR6.m

Go to the documentation of this file.
  1. BKMQSSR6 ;PRXM/HC/CJS - STATE SURV. REPORT PRINT CONTINUED ; 14 Jul 2005 3:55 PM
  1. ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
  1. ;
  1. ;
  1. EN ;EP - PRIMARY ROUTINE ENTRY POINT
  1. D UPD^BKMQUTL("")
  1. D SECTVII
  1. D UPD^BKMQUTL("")
  1. D SECTVIII
  1. Q
  1. SECTVII ;SECTION VII PRINT
  1. Q:$P(^BKM(90456,1,2,7,0),U,4)'="Y"
  1. N LINE
  1. D UPD^BKMQUTL(" SECTION VII: "_$P(^BKM(90456,1,2,7,0),U,2),1)
  1. S BKMLINE=$P(^BKM(90456,1,2,7,1,1,1,1,0),U,1)
  1. D UPD^BKMQUTL(" "_BKMLINE)
  1. S BKM0=""
  1. F S BKM0=$O(BKMICD(BKM0),-1) Q:BKM0="" D
  1. . S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
  1. . S BKM1=""
  1. . F S BKM1=$O(BKMICD(BKM0,BKM1)) Q:BKM1="" D
  1. .. S BKM2=""
  1. .. F S BKM2=$O(BKMICD(BKM0,BKM1,BKM2)) Q:BKM2="" D
  1. ... I BKM2="POV" S BKMVLN=$$GET1^DIQ(9000010.07,BKM1,.01,"E")
  1. ... I BKM2="PROB" S BKMVLN=$$GET1^DIQ(9000011,BKM1,.01,"E")
  1. ... S LINE=$$LINE^BKMQUTL("",BKMDT,5),LINE=$$LINE^BKMQUTL(LINE,BKMVLN,17)
  1. ... S LINE=$$LINE^BKMQUTL(LINE,$P(BKMICD(BKM0,BKM1,BKM2),U),27)
  1. ... D UPD^BKMQUTL(LINE)
  1. VIIA ;SECONDARY ENTRY IN SECTION VII
  1. D UPD^BKMQUTL(""),UPD^BKMQUTL(" Patient shows the following register diagnoses:")
  1. ; PRX/DLS 4/3/2006 Changed lookup for register diagnosis' to be in reverse.
  1. I $G(IEN)]"" S BKM="" F S BKM=$O(^BKMV(90455,"C",IEN,BKM),-1) Q:BKM="" D
  1. . Q:$$GET1^DIQ(90455,BKM,3,"I")'=3
  1. . S BKMDT=$$GET1^DIQ(90455,BKM,.01,"I"),BKM1=$$GET1^DIQ(90455,BKM,4.5,"E") Q:BKM1=""
  1. . I '$D(^BKMV(90451.7,BKM1,0)) S BKM1=$$FIND1^DIC(90451.7,,"Q",BKM1,"B") Q:BKM1=""
  1. . S BKMCC=$$GET1^DIQ(90451.7,BKM1,.01,"E")_" "_$$GET1^DIQ(90451.7,BKM1,1,"E") Q:BKMCC=" "
  1. . S BKMNDT=$$FMTE^XLFDT(BKMDT\1,"5Z")
  1. . S LINE=$$LINE^BKMQUTL("",BKMNDT,5),LINE=$$LINE^BKMQUTL(LINE,BKMCC,17)
  1. . D UPD^BKMQUTL(LINE)
  1. D UPD^BKMQUTL("")
  1. F BKM=2:1:3 S BKMLINE=$P(^BKM(90456,1,2,7,1,BKM,0),U,1) D
  1. . D:$P(^BKM(90456,1,2,7,1,BKM,0),U,2)="Y" UPD^BKMQUTL(" "_BKMLINE_": ")
  1. . I $D(^BKM(90456,1,2,7,1,BKM,1)) D
  1. .. S BKM1=0
  1. .. 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)
  1. VIIB ;SECONDARY ENTRY POINT
  1. F BKM=4:1:30 S BKMLINE=$P(^BKM(90456,1,2,7,1,BKM,0),U,1) D
  1. . S LINE=""
  1. . S:$P(^BKM(90456,1,2,7,1,BKM,0),U,2)="Y" LINE=$$LINE^BKMQUTL(LINE,BKMLINE,1)
  1. . S:BKM'=5 LINE=LINE_": "
  1. . I LINE'="" D UPD^BKMQUTL(LINE)
  1. . 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)
  1. . D SECT7
  1. Q
  1. SECT7 ;PRINT BLANK FIELDS FOR SECTION VII
  1. I BKM=4 D
  1. . D UPD^BKMQUTL("")
  1. . S BKM1=0
  1. . F S BKM1=$O(^BKM(90456,1,2,7,1,BKM,1,BKM1)) Q:'BKM1 D
  1. .. S BKMLINE1=^BKM(90456,1,2,7,1,BKM,1,BKM1,0)
  1. .. D UPD^BKMQUTL(" "_BKMLINE1)
  1. . S BKM0=0
  1. . F S BKM0=$O(BKMSICD(BKM0)) Q:BKM0="" D
  1. .. S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
  1. .. S BKM1=""
  1. .. F S BKM1=$O(BKMSICD(BKM0,BKM1)) Q:BKM1="" D
  1. ... S BKM2=""
  1. ... F S BKM2=$O(BKMSICD(BKM0,BKM1,BKM2)) Q:BKM2="" D
  1. .... I BKM2="POV" S BKMVLN=$$GET1^DIQ(9000010.07,BKM1,.01,"E")
  1. .... I BKM2="PROB" S BKMVLN=$$GET1^DIQ(9000011,BKM1,.01,"E")
  1. .... S LINE=$$LINE^BKMQUTL("",BKMDT,5),LINE=$$LINE^BKMQUTL(LINE,BKMVLN,17)
  1. .... S LINE=$$LINE^BKMQUTL(LINE,$P(BKMSICD(BKM0,BKM1,BKM2),U),27)
  1. .... D UPD^BKMQUTL(LINE)
  1. I $D(^BKM(90456,1,2,7,1,BKM,1)) D:BKM>4
  1. . S BKM1=0
  1. . F S BKM1=$O(^BKM(90456,1,2,7,1,BKM,1,BKM1)) Q:'BKM1 D
  1. .. S BKMLINE1=$P(^BKM(90456,1,2,7,1,BKM,1,BKM1,0),U,1)
  1. .. D UPD^BKMQUTL(" "_BKMLINE1)
  1. I BKM>5,BKM<30 D
  1. . S LINE=$$LINE^BKMQUTL("","____Definitive ____Presumptive ____Not Applicable Date:________",5)
  1. . D UPD^BKMQUTL(" "_LINE,1)
  1. Q
  1. SECTVIII ;SECTION VIII PRINT
  1. Q:$P(^BKM(90456,1,2,8,0),U,4)'="Y"
  1. D UPD^BKMQUTL(" SECTION VIII: "_$P(^BKM(90456,1,2,8,0),U,2))
  1. F BKM=1:1:13 S BKMLINE=$P(^BKM(90456,1,2,8,1,BKM,0),U,1) D
  1. . I $P(^BKM(90456,1,2,8,1,BKM,0),U,2)="Y" D UPD^BKMQUTL(""),UPD^BKMQUTL(" "_BKMLINE) ;," "
  1. . 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))
  1. . D SECT8
  1. Q
  1. SECT8 ;SECTION 8 BLANK FIELD PRINT
  1. I BKM=4 D Q
  1. . S BKM0=0
  1. . F S BKM0=$O(BKMHAART(BKM0)) Q:BKM0="" D
  1. .. S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
  1. .. S BKM1=""
  1. .. F S BKM1=$O(BKMHAART(BKM0,BKM1)) Q:BKM1="" D
  1. ... S BKMVLN=$P(BKMHAART(BKM0,BKM1),U,1)
  1. ... S BKMSIG=$P(BKMHAART(BKM0,BKM1),U,2)
  1. ... S BKMQTY=$P(BKMHAART(BKM0,BKM1),U,3)
  1. ... S BKMDAY=$P(BKMHAART(BKM0,BKM1),U,4)
  1. ... S LINE=$$LINE^BKMQUTL("",$E(BKMVLN,1,24),5),LINE=$$LINE^BKMQUTL(LINE,"QTY: "_BKMQTY,30)
  1. ... S LINE=$$LINE^BKMQUTL(LINE,"DAYS: "_BKMDAY,39)
  1. ... S LINE=$$LINE^BKMQUTL(LINE,"SIG: "_$E(BKMSIG,1,13),49),LINE=$$LINE^BKMQUTL(LINE,BKMDT,68)
  1. ... D UPD^BKMQUTL(LINE)
  1. I BKM=5 D Q
  1. . S BKM0=0
  1. . F S BKM0=$O(BKMPCP(BKM0)) Q:BKM0="" D
  1. .. S BKMDT=$$FMTE^XLFDT(BKM0\1,"5Z")
  1. .. S BKM1=""
  1. .. F S BKM1=$O(BKMPCP(BKM0,BKM1)) Q:BKM1="" D
  1. ... S BKMVLN=$P(BKMPCP(BKM0,BKM1),U,1)
  1. ... S BKMSIG=$P(BKMPCP(BKM0,BKM1),U,2)
  1. ... S BKMQTY=$P(BKMPCP(BKM0,BKM1),U,3)
  1. ... S BKMDAY=$P(BKMPCP(BKM0,BKM1),U,4)
  1. ... S LINE=""
  1. ... S LINE=$$LINE^BKMQUTL(LINE,$E(BKMVLN,1,24),5),LINE=$$LINE^BKMQUTL(LINE,"QTY: "_BKMQTY,30)
  1. ... S LINE=$$LINE^BKMQUTL(LINE,"DAYS: "_BKMDAY,39)
  1. ... S LINE=$$LINE^BKMQUTL(LINE,"SIG: "_$E(BKMSIG,1,13),49),LINE=$$LINE^BKMQUTL(LINE,BKMDT,68)
  1. ... D UPD^BKMQUTL(LINE)
  1. 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.
  1. I $D(^BKM(90456,1,2,8,1,BKM,1)) D:BKM'=4&(BKM'=5)
  1. . S BKM1=0
  1. . F S BKM1=$O(^BKM(90456,1,2,8,1,BKM,1,BKM1)) Q:'BKM1 D
  1. .. S BKMLINE1=$P(^BKM(90456,1,2,8,1,BKM,1,BKM1,0),U,1)
  1. .. D UPD^BKMQUTL(" "_BKMLINE1)
  1. Q