- 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 Mar 13, 2025@21:21:34 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
