- 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
