BKMVSSR.m

BKMVSSR ;PRXM/HC/CJS - STATE SURV. REPORT ; 14 Jun 2005  3:06 PM

 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011

 ;

 ;

 ;This report will use the skeleton structure as provided by

 ;file 90456

EN ;PRIMARY REPORT ENTRY POINT

 ; Check taxonomies - added per bugzilla #1497

 NEW DFLAG

 S DFLAG=1 D EN^BKMVC1

 N DFN

 S BKMX=0

 S TYPE=$$TYPE()

 I $D(DTOUT)!$D(DUOUT) G XIT

 I TYPE="B" D QUE("") G XIT

 D RLK^BKMPLKP("") G:$G(DFN)="" XIT

 I $$CKAGE() G XIT

 D QUE(DFN)

 G XIT

 ;

AGE ;GET PATIENT DOB AND DIAGNOSIS INFO AND CALCULATE AGE AT DIAGNOSIS

 S BKMDDT=""

 S BKMVDOB=$$GET1^DIQ(2,DFN,.03,"I")

 S BKMVDOD=$$GET1^DIQ(2,DFN,.351,"I")

 S IEN=$$FIND1^DIC(90451,,"Q",DFN,"B")

 I IEN]"" D

 . S BKMDIAG=$$GET1^DIQ(90451.01,"1,"_IEN,2.3,"E")

 . S:BKMDIAG'="HIV"&(BKMDIAG'="AIDS") BKMDIAG=""

 . S:BKMDIAG="HIV" BKMDDT=$$GET1^DIQ(90451.01,"1,"_IEN,5,"I")

 . S:BKMDIAG="AIDS" BKMDDT=$$GET1^DIQ(90451.01,"1,"_IEN,5.5,"I")

 ; Calculate age at date of diagnosis, if available.

 ; Otherwise, calculate age at date of death, if available.

 ; Otherwise, calculate age at date of report.

 D

 . I BKMVDOB>0&(BKMDDT>0) S BKMVAGED=$$FMDIFF^XLFDT(BKMDDT,BKMVDOB)\365.25 Q

 . I BKMVDOB>0&(BKMVDOD>0) S BKMVAGED=$$FMDIFF^XLFDT(BKMVDOD,BKMVDOB)\365.25 Q

 . I BKMVDOB>0 S BKMVAGED=$$FMDIFF^XLFDT(DT,BKMVDOB)\365.25 Q

 . S BKMVAGED="UNK"

 Q

FAC ;GATHER FACILITY DATA

 S BKMLOC=$$GET1^DIQ(9999999.39,1,.01,"I")

 S BKMVLOC=$$GET1^DIQ(4,BKMLOC,.01,"E")

 S BKMVLAD=$$GET1^DIQ(4,BKMLOC,1.01,"E")

 S BKMVLAD1=$$GET1^DIQ(4,BKMLOC,1.02,"E")

 S BKMVLST=$$GET1^DIQ(4,BKMLOC,.02,"E")

 S BKMVLCTY=$$GET1^DIQ(4,BKMLOC,1.03,"E")

 S BKMVLZIP=$$GET1^DIQ(4,BKMLOC,1.04,"E")

 Q

PATDEMO ;GET PATIENT DEMOGRAPHICS

 S BKMVSEX=$$GET1^DIQ(2,DFN,.02,"E")

 S BKMVSDTH=$$GET1^DIQ(9000001,DFN,1115,"E")

 S BKMVSTAT="Alive" I BKMVDOD]"" S BKMVSTAT="Dead"

 ; An inactive record should be reported as 'Unknown' instead of 'Alive'.

 I $G(IEN)]"",$$GET1^DIQ(90451.01,"1,"_IEN,.5,"I")="I",BKMVSTAT="Alive" S BKMVSTAT="Unknown"

 S BKMVHRN=$$GET1^DIQ(9000001.41,BKMLOC_","_DFN,.02,"E")

 S BKMVRCE=$$GET1^DIQ(9000001,DFN,1111,"E") D

 .I BKMVRCE="INDIAN/ALASKA NATIVE" S BKMVRCE="AMERICAN INDIAN OR ALASKA NATIVE" Q

 .S BKMVRCE=$$GET1^DIQ(2,DFN,.06,"E")

 S BKMVETH="",BKM=0

 F  S BKM=$O(^DPT(DFN,.06,BKM)) Q:'BKM  S BKMVETH=$P(^DPT(DFN,.06,BKM,0),U,1)

 S:BKMVETH'="" BKMVETH=$$GET1^DIQ(10.2,BKMVETH,.01,"E")

 S BKMVPHN=$$GET1^DIQ(2,DFN,.131,"E")

 S BKMVPOB=$$GET1^DIQ(2,DFN,.093,"I")

 S BKMVADD1=$$GET1^DIQ(2,DFN,.111,"E")

 S BKMVADD2=$$GET1^DIQ(2,DFN,.112,"E")

 S BKMVADD3=$$GET1^DIQ(2,DFN,.113,"E")

 S BKMVCITY=$$GET1^DIQ(2,DFN,.114,"E")

 S BKMVPST=$$GET1^DIQ(2,DFN,.115,"E")

 S BKMVPZP=$$GET1^DIQ(2,DFN,.116,"E")

 S BKMVCNTY=$$GET1^DIQ(2,DFN,.117,"E")

 S BKMVADDL=BKMVADD1_"," D

 .I BKMVADD2'="" S BKMVADDL=BKMVADDL_BKMVADD2_","

 .I BKMVADD3'="" S BKMVADDL=BKMVADDL_BKMVADD3_","

 .I BKMVCITY'="" S BKMVADDL=BKMVADDL_BKMVCITY_","

 .I BKMVPST'="" S BKMVADDL=BKMVADDL_BKMVPST_"  "

 .I BKMVPZP'="" S BKMVADDL=BKMVADDL_"  "_BKMVPZP

 Q

PRACDIAG ;GATHER PROVIDER DATA

 S BKMPROV=$$GET1^DIQ(90451.01,"1,"_IEN,6,"I")

 I $G(IEN)]"",BKMPROV="" S BKMPROV=$$GET1^DIQ(90451.01,"1,"_IEN,6.5,"I")

 S BKMVPPH=$S(BKMPROV]"":$$GET1^DIQ(200,BKMPROV,.132,"E"),1:"")

 I BKMPROV]"" S BKMPROV=$$GET1^DIQ(200,BKMPROV,.01,"E")

 Q

QUE(DFN) ;QUEUE REPORT FOR PRINT/DISPLAY

 ;DFN is set to "" if a blank form is desired

 K %ZIS,IOP,IOC,ZTIO S %ZIS="MQ" D ^%ZIS G:POP XIT

 I $D(IO("Q")) D  G XIT

 .S ZTRTN="DQUE^BKMVSSR",ZTDESC="HMS STATE SURVEILLANCE REPORT"

 .S ZTSAVE("BKM*")="",ZTSAVE("DFN")="",ZTSAVE("IEN")=""

 .K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED" H 2

DQUE ;ENTRY FROM QUEUE

 U IO

 I $G(DFN)="" G DQUE1 ; Skip DFN lookups if generating blank form.

 D FAC,PATDEMO,PRACDIAG

 D EN^BKMVSSR1 G:BKMX XIT

 D EN^BKMVSSR2 G:BKMX XIT

DQUE1 ;

 D EN^BKMVSSR3 G:BKMX XIT

 D EN^BKMVSSR4 G:BKMX XIT

 D EN^BKMVSSR5 G:BKMX XIT

 D EN^BKMVSSR6 G:BKMX XIT

 I IOST["C-" D

 .I $Y>(IOSL-4) D HDR^BKMVSSR3 Q:BKMX  D HDR1^BKMVSSR3

 .W !!?1,"**End of report**"

 .S BKMX=$$PAUSE^BKMIXX3

 Q

XIT ;KILL LOCALS AND EXIT

 D ^%ZISC

 K BKMVADD1,BKMVADD2,BKMVADD3,BKMVCITY,BKMVPST,BKMVPZP,BKMVETH

 K BKMPROV,BKMVPPH,BKMDIAG,BKMDT,BKMVDOB,BKMDDT

 K BKM,BKM0,BKM1,BKM2,BKMIEN,BKMHAART,BKMHDR,BKMHDR1,BKMX,BKMCC

 K BKMICD,BKMLINE,BKMLINE1,BKMLOC,BKMNDT,BKMPAD,BKMPCP,BKMCKDT

 K BKMSEC,BKMSICD,BKMVADDL,BKMVAGED,BKMVDOD,BKMVPOB

 K BKMVETO,BKMVHRN,BKMVLABS,BKMVNDT,BKMVPHN,BKMVCNTY

 K BKMVLAD,BKMVLAD1,BKMVLCTY,BKMVLN,BKMVLOC,BKMVLST,BKMVLZIP

 K BKMSIG,BKMQTY,BKMDAY,BKMVRCE,BKMVSDTH,BKMVSEX,BKMVSTAT,PAGE

 K POP,X,Y,DIR,DIWF,DIWL,DIWR,DTOUT,DUOUT,GLOBAL,IEN,%DT,%H,TYPE

 Q

 ;

EN1 ;EP - Secondary entry point from within REP action of Review/Edit Patient HMS Record Data option

 S BKMX=0

 S TYPE=$$TYPE()

 I $D(DTOUT)!$D(DUOUT) G XIT

 I TYPE="B" D QUE("") G XIT

 I $$CKAGE() G XIT

 D QUE(DFN)

 G XIT

TYPE() ;Type of report requested

 K DIR

 S DIR(0)="S^B:BLANK;P:PATIENT"

 S DIR("A")="     Type of form"

 S DIR("?",1)="  'B' to print a form with fields empty (fill-in-the-blank)"

 S DIR("?",2)="  'P' to print a form with fields filled in for a selected patient"

 S DIR("?")=" "

 D ^DIR

 Q $G(Y)

CKAGE() ;Call AGE subroutine and confirm eligibility for report

 D AGE

 I $G(BKMVAGED)<13 D  I BKMX Q 1

 . W !!,"Patient age at diagnosis less than 13.  Not a reportable case."

 . K DIR

 . S DIR(0)="YA"

 . S DIR("A")="Would you like to print a copy anyway (Y/N)? ",DIR("B")="N"

 . D ^DIR

 . I $D(DTOUT)!$D(DUOUT)!(Y=0) S BKMX=1

 Q ""

BKMVSSR   ;PRXM/HC/CJS - STATE SURV. REPORT ; 14 Jun 2005  3:06 PM

 +1       ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011

 +2       ;

 +3       ;

 +4       ;This report will use the skeleton structure as provided by

 +5       ;file 90456

EN        ;PRIMARY REPORT ENTRY POINT

 +1       ; Check taxonomies - added per bugzilla #1497

 +2        NEW DFLAG

 +3        SET DFLAG=1

           DO EN^BKMVC1

 +4        NEW DFN

 +5        SET BKMX=0

 +6        SET TYPE=$$TYPE()

 +7        IF $DATA(DTOUT)!$DATA(DUOUT)

               GOTO XIT

 +8        IF TYPE="B"

               DO QUE("")

               GOTO XIT

 +9        DO RLK^BKMPLKP("")

           IF $GET(DFN)=""

               GOTO XIT

 +10       IF $$CKAGE()

               GOTO XIT

 +11       DO QUE(DFN)

 +12       GOTO XIT

 +13      ;

AGE       ;GET PATIENT DOB AND DIAGNOSIS INFO AND CALCULATE AGE AT DIAGNOSIS

 +1        SET BKMDDT=""

 +2        SET BKMVDOB=$$GET1^DIQ(2,DFN,.03,"I")

 +3        SET BKMVDOD=$$GET1^DIQ(2,DFN,.351,"I")

 +4        SET IEN=$$FIND1^DIC(90451,,"Q",DFN,"B")

 +5        IF IEN]""

               Begin DoDot:1

 +6                SET BKMDIAG=$$GET1^DIQ(90451.01,"1,"_IEN,2.3,"E")

 +7                IF BKMDIAG'="HIV"&(BKMDIAG'="AIDS")

                       SET BKMDIAG=""

 +8                IF BKMDIAG="HIV"

                       SET BKMDDT=$$GET1^DIQ(90451.01,"1,"_IEN,5,"I")

 +9                IF BKMDIAG="AIDS"

                       SET BKMDDT=$$GET1^DIQ(90451.01,"1,"_IEN,5.5,"I")

               End DoDot:1

 +10      ; Calculate age at date of diagnosis, if available.

 +11      ; Otherwise, calculate age at date of death, if available.

 +12      ; Otherwise, calculate age at date of report.

 +13       Begin DoDot:1

 +14           IF BKMVDOB>0&(BKMDDT>0)

                   SET BKMVAGED=$$FMDIFF^XLFDT(BKMDDT,BKMVDOB)\365.25

                   QUIT 

 +15           IF BKMVDOB>0&(BKMVDOD>0)

                   SET BKMVAGED=$$FMDIFF^XLFDT(BKMVDOD,BKMVDOB)\365.25

                   QUIT 

 +16           IF BKMVDOB>0

                   SET BKMVAGED=$$FMDIFF^XLFDT(DT,BKMVDOB)\365.25

                   QUIT 

 +17           SET BKMVAGED="UNK"

           End DoDot:1

 +18       QUIT 

FAC       ;GATHER FACILITY DATA

 +1        SET BKMLOC=$$GET1^DIQ(9999999.39,1,.01,"I")

 +2        SET BKMVLOC=$$GET1^DIQ(4,BKMLOC,.01,"E")

 +3        SET BKMVLAD=$$GET1^DIQ(4,BKMLOC,1.01,"E")

 +4        SET BKMVLAD1=$$GET1^DIQ(4,BKMLOC,1.02,"E")

 +5        SET BKMVLST=$$GET1^DIQ(4,BKMLOC,.02,"E")

 +6        SET BKMVLCTY=$$GET1^DIQ(4,BKMLOC,1.03,"E")

 +7        SET BKMVLZIP=$$GET1^DIQ(4,BKMLOC,1.04,"E")

 +8        QUIT 

PATDEMO   ;GET PATIENT DEMOGRAPHICS

 +1        SET BKMVSEX=$$GET1^DIQ(2,DFN,.02,"E")

 +2        SET BKMVSDTH=$$GET1^DIQ(9000001,DFN,1115,"E")

 +3        SET BKMVSTAT="Alive"

           IF BKMVDOD]""

               SET BKMVSTAT="Dead"

 +4       ; An inactive record should be reported as 'Unknown' instead of 'Alive'.

 +5        IF $GET(IEN)]""

               IF $$GET1^DIQ(90451.01,"1,"_IEN,.5,"I")="I"

                   IF BKMVSTAT="Alive"

                       SET BKMVSTAT="Unknown"

 +6        SET BKMVHRN=$$GET1^DIQ(9000001.41,BKMLOC_","_DFN,.02,"E")

 +7        SET BKMVRCE=$$GET1^DIQ(9000001,DFN,1111,"E")

           Begin DoDot:1

 +8            IF BKMVRCE="INDIAN/ALASKA NATIVE"

                   SET BKMVRCE="AMERICAN INDIAN OR ALASKA NATIVE"

                   QUIT 

 +9            SET BKMVRCE=$$GET1^DIQ(2,DFN,.06,"E")

           End DoDot:1

 +10       SET BKMVETH=""

           SET BKM=0

 +11       FOR 

               SET BKM=$ORDER(^DPT(DFN,.06,BKM))

               IF 'BKM

                   QUIT 

               SET BKMVETH=$PIECE(^DPT(DFN,.06,BKM,0),U,1)

 +12       IF BKMVETH'=""

               SET BKMVETH=$$GET1^DIQ(10.2,BKMVETH,.01,"E")

 +13       SET BKMVPHN=$$GET1^DIQ(2,DFN,.131,"E")

 +14       SET BKMVPOB=$$GET1^DIQ(2,DFN,.093,"I")

 +15       SET BKMVADD1=$$GET1^DIQ(2,DFN,.111,"E")

 +16       SET BKMVADD2=$$GET1^DIQ(2,DFN,.112,"E")

 +17       SET BKMVADD3=$$GET1^DIQ(2,DFN,.113,"E")

 +18       SET BKMVCITY=$$GET1^DIQ(2,DFN,.114,"E")

 +19       SET BKMVPST=$$GET1^DIQ(2,DFN,.115,"E")

 +20       SET BKMVPZP=$$GET1^DIQ(2,DFN,.116,"E")

 +21       SET BKMVCNTY=$$GET1^DIQ(2,DFN,.117,"E")

 +22       SET BKMVADDL=BKMVADD1_","

           Begin DoDot:1

 +23           IF BKMVADD2'=""

                   SET BKMVADDL=BKMVADDL_BKMVADD2_","

 +24           IF BKMVADD3'=""

                   SET BKMVADDL=BKMVADDL_BKMVADD3_","

 +25           IF BKMVCITY'=""

                   SET BKMVADDL=BKMVADDL_BKMVCITY_","

 +26           IF BKMVPST'=""

                   SET BKMVADDL=BKMVADDL_BKMVPST_"  "

 +27           IF BKMVPZP'=""

                   SET BKMVADDL=BKMVADDL_"  "_BKMVPZP

           End DoDot:1

 +28       QUIT 

PRACDIAG  ;GATHER PROVIDER DATA

 +1        SET BKMPROV=$$GET1^DIQ(90451.01,"1,"_IEN,6,"I")

 +2        IF $GET(IEN)]""

               IF BKMPROV=""

                   SET BKMPROV=$$GET1^DIQ(90451.01,"1,"_IEN,6.5,"I")

 +3        SET BKMVPPH=$SELECT(BKMPROV]"":$$GET1^DIQ(200,BKMPROV,.132,"E"),1:"")

 +4        IF BKMPROV]""

               SET BKMPROV=$$GET1^DIQ(200,BKMPROV,.01,"E")

 +5        QUIT 

QUE(DFN)  ;QUEUE REPORT FOR PRINT/DISPLAY

 +1       ;DFN is set to "" if a blank form is desired

 +2        KILL %ZIS,IOP,IOC,ZTIO

           SET %ZIS="MQ"

           DO ^%ZIS

           IF POP

               GOTO XIT

 +3        IF $DATA(IO("Q"))

               Begin DoDot:1

 +4                SET ZTRTN="DQUE^BKMVSSR"

                   SET ZTDESC="HMS STATE SURVEILLANCE REPORT"

 +5                SET ZTSAVE("BKM*")=""

                   SET ZTSAVE("DFN")=""

                   SET ZTSAVE("IEN")=""

 +6                KILL IO("Q")

                   DO ^%ZTLOAD

                   IF $DATA(ZTSK)

                       WRITE !,"REQUEST QUEUED"

                   HANG 2

               End DoDot:1

               GOTO XIT

DQUE      ;ENTRY FROM QUEUE

 +1        USE IO

 +2       ; Skip DFN lookups if generating blank form.

           IF $GET(DFN)=""

               GOTO DQUE1

 +3        DO FAC

           DO PATDEMO

           DO PRACDIAG

 +4        DO EN^BKMVSSR1

           IF BKMX

               GOTO XIT

 +5        DO EN^BKMVSSR2

           IF BKMX

               GOTO XIT

DQUE1     ;

 +1        DO EN^BKMVSSR3

           IF BKMX

               GOTO XIT

 +2        DO EN^BKMVSSR4

           IF BKMX

               GOTO XIT

 +3        DO EN^BKMVSSR5

           IF BKMX

               GOTO XIT

 +4        DO EN^BKMVSSR6

           IF BKMX

               GOTO XIT

 +5        IF IOST["C-"

               Begin DoDot:1

 +6                IF $Y>(IOSL-4)

                       DO HDR^BKMVSSR3

                       IF BKMX

                           QUIT 

                       DO HDR1^BKMVSSR3

 +7                WRITE !!?1,"**End of report**"

 +8                SET BKMX=$$PAUSE^BKMIXX3

               End DoDot:1

 +9        QUIT 

XIT       ;KILL LOCALS AND EXIT

 +1        DO ^%ZISC

 +2        KILL BKMVADD1,BKMVADD2,BKMVADD3,BKMVCITY,BKMVPST,BKMVPZP,BKMVETH

 +3        KILL BKMPROV,BKMVPPH,BKMDIAG,BKMDT,BKMVDOB,BKMDDT

 +4        KILL BKM,BKM0,BKM1,BKM2,BKMIEN,BKMHAART,BKMHDR,BKMHDR1,BKMX,BKMCC

 +5        KILL BKMICD,BKMLINE,BKMLINE1,BKMLOC,BKMNDT,BKMPAD,BKMPCP,BKMCKDT

 +6        KILL BKMSEC,BKMSICD,BKMVADDL,BKMVAGED,BKMVDOD,BKMVPOB

 +7        KILL BKMVETO,BKMVHRN,BKMVLABS,BKMVNDT,BKMVPHN,BKMVCNTY

 +8        KILL BKMVLAD,BKMVLAD1,BKMVLCTY,BKMVLN,BKMVLOC,BKMVLST,BKMVLZIP

 +9        KILL BKMSIG,BKMQTY,BKMDAY,BKMVRCE,BKMVSDTH,BKMVSEX,BKMVSTAT,PAGE

 +10       KILL POP,X,Y,DIR,DIWF,DIWL,DIWR,DTOUT,DUOUT,GLOBAL,IEN,%DT,%H,TYPE

 +11       QUIT 

 +12      ;

EN1       ;EP - Secondary entry point from within REP action of Review/Edit Patient HMS Record Data option

 +1        SET BKMX=0

 +2        SET TYPE=$$TYPE()

 +3        IF $DATA(DTOUT)!$DATA(DUOUT)

               GOTO XIT

 +4        IF TYPE="B"

               DO QUE("")

               GOTO XIT

 +5        IF $$CKAGE()

               GOTO XIT

 +6        DO QUE(DFN)

 +7        GOTO XIT

TYPE()    ;Type of report requested

 +1        KILL DIR

 +2        SET DIR(0)="S^B:BLANK;P:PATIENT"

 +3        SET DIR("A")="     Type of form"

 +4        SET DIR("?",1)="  'B' to print a form with fields empty (fill-in-the-blank)"

 +5        SET DIR("?",2)="  'P' to print a form with fields filled in for a selected patient"

 +6        SET DIR("?")=" "

 +7        DO ^DIR

 +8        QUIT $GET(Y)

CKAGE()   ;Call AGE subroutine and confirm eligibility for report

 +1        DO AGE

 +2        IF $GET(BKMVAGED)<13

               Begin DoDot:1

 +3                WRITE !!,"Patient age at diagnosis less than 13.  Not a reportable case."

 +4                KILL DIR

 +5                SET DIR(0)="YA"

 +6                SET DIR("A")="Would you like to print a copy anyway (Y/N)? "

                   SET DIR("B")="N"

 +7                DO ^DIR

 +8                IF $DATA(DTOUT)!$DATA(DUOUT)!(Y=0)

                       SET BKMX=1

               End DoDot:1

               IF BKMX

                   QUIT 1

 +9        QUIT ""