LRMIHDR ;DALOI/CJS/BA/RLM-HEALTH DEPARTMENT REPORT ;2/19/91 10:46
;;5.2;LAB SERVICE;**45,272,298**;Sep 27, 1994
; Reference to ^%DT supported by DBIA #10003
; Reference to ^%ZISC supported by DBIA #10089
; Reference to EN^DIQ supported by DBIA #10004
; Reference to KVAR^VADPT supported by DBIA #10061
; Reference to $$NOW^XLFDT supported by IA #10103
; Reference to $$FMTE^XLFDT supported by IA #10103
; Reference to ^DIC(10 supported by IA #925
; Reference to ^DIC( supported by IA #916
; Reference to ^DIC(11 supported by IA #924
BEGIN S LREND=0,LREDT="T-1" D ^LRWU3 I 'LREND S ZTRTN="DQ^LRMIHDR" D IO^LRWU
END W !! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC
K %DT,A,AGE,D0,DA,DFN,DIC,DL,DOB,DR,DX,I,LRACC,LRBUG,LROCCU,LRDFN,LRDPF,LRDT,LREDT,LREND,LRHC,LRIDT,LRMARST,LRPHONE,LRRACE,LRSAMP,LRSDT,LRSPEC,LRWRD,POP,PNM,S,SEX,SSN,X,Y,Z0
D KVAR^LRX
Q
DQ S:$D(ZTQUEUED) ZTREQ="@" U IO
I LRSDT>LREDT S X=LRSDT,LRSDT=LREDT,LRSDT=X
S LRHC=$E(IOST,1,2)'="C-" W !!,?5,"HEALTH DEPARTMENT REPORT (" S X=LRSDT\1 D ^%DT,DD^LRX W Y," - " S X=LREDT\1 D ^%DT,DD^LRX W Y,")",?65 S X="N",%DT="T" D ^%DT,DD^LRX W Y I LRHC W !! D DASH^LRX
S LRDT=LREDT-.0001 F S LRDT=$O(^LR("AD",LRDT)) Q:LRDT<1!(LRDT>LRSDT) D DATE Q:LREND
D END
Q
DATE S DR=.11 S LRBUG=0 F S LRBUG=$O(^LR("AD",LRDT,LRBUG)) Q:LRBUG<1 D LIST Q:LREND
Q
LIST W !!,?5,"Isolated Organism: ",$P(^LAB(61.2,LRBUG,0),U),!,"Printed : "_$$FMTE^XLFDT($$NOW^XLFDT,""),!
S LRACC="" F S LRACC=$O(^LR("AD",LRDT,LRBUG,LRACC)) Q:LRACC="" S LRDFN=^(LRACC) D SPEC,PAT,WAIT:'LRHC Q:LREND
D:LRHC DASH^LRX W !
Q
SPEC S (LRIDT,LRSPEC,LRSAMP)=0 F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1 I $D(^(LRIDT,0)),$E(LRACC,1,$L(LRACC)-1)=$P(^(0),U,6) S LRSPEC=+$P(^(0),U,5),LRSAMP=+$P(^(0),U,11) W:LRSPEC!LRSAMP ! Q
I LRSAMP,$D(^LAB(62,LRSAMP,0)) W ?4," COLLECTION SAMPLE: ",$P(^(0),U)
I LRSPEC,$D(^LAB(61,LRSPEC,0)) W ?40," SPECIMEN: ",$P(^(0),U)
Q
PAT D KVAR^VADPT
W !! S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),DIC=^DIC(+LRDPF,0,"GL") D PT^LRX
S Y=DOB D DD^LRX W !!,PNM,?25," ID: ",SSN,?44," DOB: ",Y,?60," SEX: ",SEX
I +LRDPF=2 D ADDPT^LRX,OPDPT^LRX D
. S LRPHONE=$G(VAPA(8)),LRMARST=$P($G(VADM(10)),U,2),LROCCU=VAPD(6)
E S X=DIC_"DFN"_",0)",LRRACE=$P($G(^DIC(10,+$P(@X,U,6),0)),U) D
. S X=DIC_DFN_",.13)",LRPHONE=$S($D(@X):$P(^(.13),U),1:"")
. S X=DIC_DFN_",0)",X=@X,LRRACE=$P(X,U,6),LRMARST=$P(X,U,5),LROCCU=$P(X,U,7)
. I LRRACE S LRRACE=$S($D(^DIC(10,LRRACE,0)):$P(^(0),U),1:"")
. I LRMARST S LRMARST=$S($D(^DIC(11,LRMARST,0)):$P(^(0),U),1:"")
W !,"Accession Number: ",LRACC,!
W:$L(LRPHONE) !,"PHONE: ",LRPHONE
D RACE
I $L($G(LRRACE))!$L(LRMARST)!$L(LROCCU) W !
W:$L($G(LRRACE)) "RACE: ",LRRACE," " W:$L(LRMARST) "MARRIAGE STATUS: ",LRMARST," " W:$L(LROCCU) "OCCUPATION: ",LROCCU
S DA=DFN D EN^DIQ S:$D(DTOUT)!($D(DUOUT)) LREND=1
D KVAR^VADPT
Q
WAIT F I=$Y:1:IOSL-3 W !
W ?59," PRESS '^' TO STOP " R X:DTIME S:X="" X=1 S LREND=".^"[X W:'LREND @IOF
Q
RACE ;ETHNICITY AND RACE MODS
;-----ethnicity/race retrieval and display
K ERT,SEQ
S (ERT,SEQ)="" ;ERT=ethnicity race type; display multiple for both
I $D(VADM(11)) I VADM(11)>0 S SEQ=SEQ+1,ERT(SEQ)="" D
. F I=1:1 Q:'$D(VADM(11,I)) I $TR($P(VADM(11,I),"^",2),"")'="" D
.. ;length of race or ethnicity; plus 25 characters for field label; plus length of data to be added to the field; minus 2 char for comma and space; up to 80 characters.
.. I ($L(ERT(SEQ))+25+$L($P(VADM(11,I),"^",2))-2)'>80 D Q
... S ERT(SEQ)=ERT(SEQ)_", "_$P(VADM(11,I),"^",2)
S:'$D(ERT(1)) ERT(1)=", UNANSWERED"
W !,"Veteran's ethnicity: "_$E(ERT(1),3,999)
I SEQ>1 F I=2:1:SEQ W !?30,$E(ERT(I),3,999)
K ERT S (ERT,SEQ)=""
I $D(VADM(12)) I VADM(12)>0 S SEQ=SEQ+1,ERT(SEQ)="" D
. F I=1:1:VADM(12) Q:'$D(VADM(12,I)) I $TR($P(VADM(12,I),"^",2),"")'="" D
.. I ($L(ERT(SEQ))+25+$L($P(VADM(12,I),"^",2))-2)'>80 D Q
... S ERT(SEQ)=ERT(SEQ)_", "_$P(VADM(12,I),"^",2)
.. I ($L(ERT(SEQ))+25+$L($P(VADM(12,I),"^",2))-2)>80 D
... S ERT(SEQ)=ERT(SEQ)_", ",SEQ=SEQ+1,ERT(SEQ)=""
.. S ERT(SEQ)=ERT(SEQ)_", "_$P(VADM(12,I),"^",2)
S:'$D(ERT(1)) ERT(1)=", UNANSWERED"
I ERT(1)=", UNANSWERED",$G(VADM(8)) S ERT(1)=" "_$P(VADM(8),U,2)
W !,"Veteran's race: "_$E(ERT(1),3,999)
I SEQ>1 F I=2:1:SEQ W !?25,$E(ERT(I),3,999)
K ERT,SEQ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMIHDR 4318 printed Apr 09, 2024@21:14:45 Page 2
LRMIHDR ;DALOI/CJS/BA/RLM-HEALTH DEPARTMENT REPORT ;2/19/91 10:46
+1 ;;5.2;LAB SERVICE;**45,272,298**;Sep 27, 1994
+2 ; Reference to ^%DT supported by DBIA #10003
+3 ; Reference to ^%ZISC supported by DBIA #10089
+4 ; Reference to EN^DIQ supported by DBIA #10004
+5 ; Reference to KVAR^VADPT supported by DBIA #10061
+6 ; Reference to $$NOW^XLFDT supported by IA #10103
+7 ; Reference to $$FMTE^XLFDT supported by IA #10103
+8 ; Reference to ^DIC(10 supported by IA #925
+9 ; Reference to ^DIC( supported by IA #916
+10 ; Reference to ^DIC(11 supported by IA #924
BEGIN SET LREND=0
SET LREDT="T-1"
DO ^LRWU3
IF 'LREND
SET ZTRTN="DQ^LRMIHDR"
DO IO^LRWU
END WRITE !!
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
DO ^%ZISC
+1 KILL %DT,A,AGE,D0,DA,DFN,DIC,DL,DOB,DR,DX,I,LRACC,LRBUG,LROCCU,LRDFN,LRDPF,LRDT,LREDT,LREND,LRHC,LRIDT,LRMARST,LRPHONE,LRRACE,LRSAMP,LRSDT,LRSPEC,LRWRD,POP,PNM,S,SEX,SSN,X,Y,Z0
+2 DO KVAR^LRX
+3 QUIT
DQ if $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
+1 IF LRSDT>LREDT
SET X=LRSDT
SET LRSDT=LREDT
SET LRSDT=X
+2 SET LRHC=$EXTRACT(IOST,1,2)'="C-"
WRITE !!,?5,"HEALTH DEPARTMENT REPORT ("
SET X=LRSDT\1
DO ^%DT
DO DD^LRX
WRITE Y," - "
SET X=LREDT\1
DO ^%DT
DO DD^LRX
WRITE Y,")",?65
SET X="N"
SET %DT="T"
DO ^%DT
DO DD^LRX
WRITE Y
IF LRHC
WRITE !!
DO DASH^LRX
+3 SET LRDT=LREDT-.0001
FOR
SET LRDT=$ORDER(^LR("AD",LRDT))
if LRDT<1!(LRDT>LRSDT)
QUIT
DO DATE
if LREND
QUIT
+4 DO END
+5 QUIT
DATE SET DR=.11
SET LRBUG=0
FOR
SET LRBUG=$ORDER(^LR("AD",LRDT,LRBUG))
if LRBUG<1
QUIT
DO LIST
if LREND
QUIT
+1 QUIT
LIST WRITE !!,?5,"Isolated Organism: ",$PIECE(^LAB(61.2,LRBUG,0),U),!,"Printed : "_$$FMTE^XLFDT($$NOW^XLFDT,""),!
+1 SET LRACC=""
FOR
SET LRACC=$ORDER(^LR("AD",LRDT,LRBUG,LRACC))
if LRACC=""
QUIT
SET LRDFN=^(LRACC)
DO SPEC
DO PAT
if 'LRHC
DO WAIT
if LREND
QUIT
+2 if LRHC
DO DASH^LRX
WRITE !
+3 QUIT
SPEC SET (LRIDT,LRSPEC,LRSAMP)=0
FOR
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
if LRIDT<1
QUIT
IF $DATA(^(LRIDT,0))
IF $EXTRACT(LRACC,1,$LENGTH(LRACC)-1)=$PIECE(^(0),U,6)
SET LRSPEC=+$PIECE(^(0),U,5)
SET LRSAMP=+$PIECE(^(0),U,11)
if LRSPEC!LRSAMP
WRITE !
QUIT
+1 IF LRSAMP
IF $DATA(^LAB(62,LRSAMP,0))
WRITE ?4," COLLECTION SAMPLE: ",$PIECE(^(0),U)
+2 IF LRSPEC
IF $DATA(^LAB(61,LRSPEC,0))
WRITE ?40," SPECIMEN: ",$PIECE(^(0),U)
+3 QUIT
PAT DO KVAR^VADPT
+1 WRITE !!
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
SET DIC=^DIC(+LRDPF,0,"GL")
DO PT^LRX
+2 SET Y=DOB
DO DD^LRX
WRITE !!,PNM,?25," ID: ",SSN,?44," DOB: ",Y,?60," SEX: ",SEX
+3 IF +LRDPF=2
DO ADDPT^LRX
DO OPDPT^LRX
Begin DoDot:1
+4 SET LRPHONE=$GET(VAPA(8))
SET LRMARST=$PIECE($GET(VADM(10)),U,2)
SET LROCCU=VAPD(6)
End DoDot:1
+5 IF '$TEST
SET X=DIC_"DFN"_",0)"
SET LRRACE=$PIECE($GET(^DIC(10,+$PIECE(@X,U,6),0)),U)
Begin DoDot:1
+6 SET X=DIC_DFN_",.13)"
SET LRPHONE=$SELECT($DATA(@X):$PIECE(^(.13),U),1:"")
+7 SET X=DIC_DFN_",0)"
SET X=@X
SET LRRACE=$PIECE(X,U,6)
SET LRMARST=$PIECE(X,U,5)
SET LROCCU=$PIECE(X,U,7)
+8 IF LRRACE
SET LRRACE=$SELECT($DATA(^DIC(10,LRRACE,0)):$PIECE(^(0),U),1:"")
+9 IF LRMARST
SET LRMARST=$SELECT($DATA(^DIC(11,LRMARST,0)):$PIECE(^(0),U),1:"")
End DoDot:1
+10 WRITE !,"Accession Number: ",LRACC,!
+11 if $LENGTH(LRPHONE)
WRITE !,"PHONE: ",LRPHONE
+12 DO RACE
+13 IF $LENGTH($GET(LRRACE))!$LENGTH(LRMARST)!$LENGTH(LROCCU)
WRITE !
+14 if $LENGTH($GET(LRRACE))
WRITE "RACE: ",LRRACE," "
if $LENGTH(LRMARST)
WRITE "MARRIAGE STATUS: ",LRMARST," "
if $LENGTH(LROCCU)
WRITE "OCCUPATION: ",LROCCU
+15 SET DA=DFN
DO EN^DIQ
if $DATA(DTOUT)!($DATA(DUOUT))
SET LREND=1
+16 DO KVAR^VADPT
+17 QUIT
WAIT FOR I=$Y:1:IOSL-3
WRITE !
+1 WRITE ?59," PRESS '^' TO STOP "
READ X:DTIME
if X=""
SET X=1
SET LREND=".^"[X
if 'LREND
WRITE @IOF
+2 QUIT
RACE ;ETHNICITY AND RACE MODS
+1 ;-----ethnicity/race retrieval and display
+2 KILL ERT,SEQ
+3 ;ERT=ethnicity race type; display multiple for both
SET (ERT,SEQ)=""
+4 IF $DATA(VADM(11))
IF VADM(11)>0
SET SEQ=SEQ+1
SET ERT(SEQ)=""
Begin DoDot:1
+5 FOR I=1:1
if '$DATA(VADM(11,I))
QUIT
IF $TRANSLATE($PIECE(VADM(11,I),"^",2),"")'=""
Begin DoDot:2
+6 ;length of race or ethnicity; plus 25 characters for field label; plus length of data to be added to the field; minus 2 char for comma and space; up to 80 characters.
+7 IF ($LENGTH(ERT(SEQ))+25+$LENGTH($PIECE(VADM(11,I),"^",2))-2)'>80
Begin DoDot:3
+8 SET ERT(SEQ)=ERT(SEQ)_", "_$PIECE(VADM(11,I),"^",2)
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+9 if '$DATA(ERT(1))
SET ERT(1)=", UNANSWERED"
+10 WRITE !,"Veteran's ethnicity: "_$EXTRACT(ERT(1),3,999)
+11 IF SEQ>1
FOR I=2:1:SEQ
WRITE !?30,$EXTRACT(ERT(I),3,999)
+12 KILL ERT
SET (ERT,SEQ)=""
+13 IF $DATA(VADM(12))
IF VADM(12)>0
SET SEQ=SEQ+1
SET ERT(SEQ)=""
Begin DoDot:1
+14 FOR I=1:1:VADM(12)
if '$DATA(VADM(12,I))
QUIT
IF $TRANSLATE($PIECE(VADM(12,I),"^",2),"")'=""
Begin DoDot:2
+15 IF ($LENGTH(ERT(SEQ))+25+$LENGTH($PIECE(VADM(12,I),"^",2))-2)'>80
Begin DoDot:3
+16 SET ERT(SEQ)=ERT(SEQ)_", "_$PIECE(VADM(12,I),"^",2)
End DoDot:3
QUIT
+17 IF ($LENGTH(ERT(SEQ))+25+$LENGTH($PIECE(VADM(12,I),"^",2))-2)>80
Begin DoDot:3
+18 SET ERT(SEQ)=ERT(SEQ)_", "
SET SEQ=SEQ+1
SET ERT(SEQ)=""
End DoDot:3
+19 SET ERT(SEQ)=ERT(SEQ)_", "_$PIECE(VADM(12,I),"^",2)
End DoDot:2
End DoDot:1
+20 if '$DATA(ERT(1))
SET ERT(1)=", UNANSWERED"
+21 IF ERT(1)=", UNANSWERED"
IF $GET(VADM(8))
SET ERT(1)=" "_$PIECE(VADM(8),U,2)
+22 WRITE !,"Veteran's race: "_$EXTRACT(ERT(1),3,999)
+23 IF SEQ>1
FOR I=2:1:SEQ
WRITE !?25,$EXTRACT(ERT(I),3,999)
+24 KILL ERT,SEQ
+25 QUIT
