LRHDR.m

LRHDR ;DALOI/CJS/RLM-HEALTH DEPARTMENT REPORT ;2/19/91 10:37 [ 04/11/2003  7:39 AM ]

 ;;5.2T9;LR;**1018*;Nov 17, 2004

 ;;5.2;LAB SERVICE;**272**;Sep 27, 1994

 ; Reference to ^%DT supported by DBIA #10003

 ; Reference to ^%ZIS supported by DBIA #10086

 ; Reference to ^%ZISC supported by DBIA #10089

 ; Reference to ^%ZTLOAD supported by DBIA #10063

 ; Reference to ADD^VADPT supported by DBIA #10061

 ; Reference to KVAR^VADPT supported by DBIA #10061

 ; Reference to $$FMTE^XLFDT supported by IA #10103

 ; Reference to $$NOW^XLFDT supported by IA #10103

 ; Reference to EN^DIQ supported by DBIA #10004

BEGIN D DATE

END D ^%ZISC K DA,IO("Q"),DFN,DR,I,LRDPF,POP,LRDT,LRIDT,ZTSK,LRDFN,LRBUG,LRACC,PNM,SSN,DOB,SEX,LRIO,LRTIME,LRPGM,ZTRTN,ZTIO,ZTDESC,ZTSAVE

 Q

DATE S %DT="AE" D ^%DT Q:Y<1  S LRDT=Y K %DT

 K DIC S %ZIS="Q" D ^%ZIS Q:POP  K %ZIS

 I $D(IO("Q")) S ZTRTN="DQ^LRHDR",ZTIO=ION,ZTSAVE("LRDT")="",ZTDESC="HEALTH DEPARTMENT REPORT" D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED" Q

 U IO D DISPLAY

 Q

DQ S:$D(ZTQUEUED) ZTREQ="@" U IO

DISPLAY S DIC="^DPT(",DR=.11 S LRBUG=0 F I=0:0 S LRBUG=$O(^LR("AD",LRDT,LRBUG)) Q:LRBUG<1  D LIST

 Q

LIST W !!!,?5,$P(^LAB(61.2,LRBUG,0),"^",1),! S LRACC="" F I=0:0 S LRACC=$O(^LR("AD",LRDT,LRBUG,LRACC)) Q:LRACC=""  S LRDFN=^(LRACC) D PATIENT

 Q

PATIENT S VA200="",LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX S:LRDPA=2 DOB=$P(VADM(3),U,2) I LRDPF'=2 S Y=DOB D DD^LRX

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 ;W !,PNM,?25," ",SSN,?39," ",Y,?55," ",SEX," ",$$FMTE^XLFDT($$NOW^XLFDT,"")

 W !,PNM,?25," ",HRCN,?42," ",Y,?55," ",SEX D STAMP^LRX  ;IHS/ANMC/CLS 11/1/95

 ;----- END IHS MODIFICATIONS

 I LRDPF=2 D

 . ;N I,X,Y,N D ADD^VADPT

 .;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 . N I,X,Y,N D @$S($$ISPIMS^BLRUTIL:"ADD^VADPT",1:"ADD^BLRDPT")

 W:$L($G(VAPA(8))) !,"PHONE: ",VAPA(8) S DA=DFN D EN^DIQ

 ;D KVAR^VADPT

 D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")

 ;----- END IHS MODIFICATIONS

 Q

LRHDR     ;DALOI/CJS/RLM-HEALTH DEPARTMENT REPORT ;2/19/91 10:37 [ 04/11/2003  7:39 AM ]

 +1       ;;5.2T9;LR;**1018*;Nov 17, 2004

 +2       ;;5.2;LAB SERVICE;**272**;Sep 27, 1994

 +3       ; Reference to ^%DT supported by DBIA #10003

 +4       ; Reference to ^%ZIS supported by DBIA #10086

 +5       ; Reference to ^%ZISC supported by DBIA #10089

 +6       ; Reference to ^%ZTLOAD supported by DBIA #10063

 +7       ; Reference to ADD^VADPT supported by DBIA #10061

 +8       ; Reference to KVAR^VADPT supported by DBIA #10061

 +9       ; Reference to $$FMTE^XLFDT supported by IA #10103

 +10      ; Reference to $$NOW^XLFDT supported by IA #10103

 +11      ; Reference to EN^DIQ supported by DBIA #10004

BEGIN      DO DATE

END        DO ^%ZISC

           KILL DA,IO("Q"),DFN,DR,I,LRDPF,POP,LRDT,LRIDT,ZTSK,LRDFN,LRBUG,LRACC,PNM,SSN,DOB,SEX,LRIO,LRTIME,LRPGM,ZTRTN,ZTIO,ZTDESC,ZTSAVE

 +1        QUIT 

DATE       SET %DT="AE"

           DO ^%DT

           IF Y<1

               QUIT 

           SET LRDT=Y

           KILL %DT

 +1        KILL DIC

           SET %ZIS="Q"

           DO ^%ZIS

           IF POP

               QUIT 

           KILL %ZIS

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

               SET ZTRTN="DQ^LRHDR"

               SET ZTIO=ION

               SET ZTSAVE("LRDT")=""

               SET ZTDESC="HEALTH DEPARTMENT REPORT"

               DO ^%ZTLOAD

               IF $DATA(ZTSK)

                   WRITE !,"REQUEST QUEUED"

               QUIT 

 +3        USE IO

           DO DISPLAY

 +4        QUIT 

DQ         IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           USE IO

DISPLAY    SET DIC="^DPT("

           SET DR=.11

           SET LRBUG=0

           FOR I=0:0

               SET LRBUG=$ORDER(^LR("AD",LRDT,LRBUG))

               IF LRBUG<1

                   QUIT 

               DO LIST

 +1        QUIT 

LIST       WRITE !!!,?5,$PIECE(^LAB(61.2,LRBUG,0),"^",1),!

           SET LRACC=""

           FOR I=0:0

               SET LRACC=$ORDER(^LR("AD",LRDT,LRBUG,LRACC))

               IF LRACC=""

                   QUIT 

               SET LRDFN=^(LRACC)

               DO PATIENT

 +1        QUIT 

PATIENT    SET VA200=""

           SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)

           SET DFN=$PIECE(^(0),U,3)

           DO PT^LRX

           IF LRDPA=2

               SET DOB=$PIECE(VADM(3),U,2)

           IF LRDPF'=2

               SET Y=DOB

               DO DD^LRX

 +1       ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +2       ;W !,PNM,?25," ",SSN,?39," ",Y,?55," ",SEX," ",$$FMTE^XLFDT($$NOW^XLFDT,"")

 +3       ;IHS/ANMC/CLS 11/1/95

           WRITE !,PNM,?25," ",HRCN,?42," ",Y,?55," ",SEX

           DO STAMP^LRX

 +4       ;----- END IHS MODIFICATIONS

 +5        IF LRDPF=2

               Begin DoDot:1

 +6       ;N I,X,Y,N D ADD^VADPT

 +7       ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +8                NEW I,X,Y,N

                   DO @$SELECT($$ISPIMS^BLRUTIL:"ADD^VADPT",1:"ADD^BLRDPT")

               End DoDot:1

 +9        IF $LENGTH($GET(VAPA(8)))

               WRITE !,"PHONE: ",VAPA(8)

           SET DA=DFN

           DO EN^DIQ

 +10      ;D KVAR^VADPT

 +11       DO @$SELECT($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")

 +12      ;----- END IHS MODIFICATIONS

 +13       QUIT