source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRVLAB.m@ 619

IMRVLAB ;HCIOFO/FAI-Viral Load and CD4 Test Results List ;11/13/01  06:54
 ;;2.1;IMMUNOLOGY CASE REGISTRY;**5,16**;Feb 09, 1998
 ;[IMR VIRAL TESTS LIST] - Viral Tests List
BEGIN I '$D(^XUSEC("IMRMGR",DUZ)) S IMRLOC="IMRVLAB" D ACESSERR^IMRERR,H^XUS K IMRLOC
 W !,?10,"####################################################"
 W !,?10,"#",?20,"Local Viral Test and CD4 List",?61,"#"
 W !,?10,"####################################################"
 K IMRVALS
ASK D ^IMRDATE
 S IMRPG=0 K DIR S DIR(0)="S^V:Viral Test;C:CD4;B:Both",DIR("A")="Select Type of Test(s) Results Requested" D ^DIR S TTYPE=Y K DIR
 I $D(DIRUT) D KILL Q
DELM S DELIM="N" R !!,"Do you want the list in delimited format (Y/N)? N// ",X:DTIME S:X="" X="N" I "Yy"[$E(X) S DELIM="Y"
 I "YyNn"'[$E(X) W $C(7),"  ??",!!,"Enter YES or NO" G DELM
DEV D IMRDEV^IMREDIT
 G:POP KILL
 I '$D(IO("Q")) W @IOF D SEARCH Q
 I $D(IO("Q")) D  G KILL
 .S ZTRTN="DQ^IMRVLAB",ZTDESC="Local Viral Load and CD4 Lists"
 .S ZTSAVE("*")="",ZTIO=ION_";"_IOM_";"_IOSL
 .D ^%ZTLOAD K ZTRTN,ZTDESC,ZTSAVE,ZTSK
 .Q
 Q
DQ D TYPE,HEAD,SORT,KILL
 Q
SEARCH D TYPE,HEAD,SORT,KILL
 Q
 ; *** TAKE QUIT OUT ABOVE
TYPE ; Entry with IMRDFN defined and pointers for local lab test name & NLT
 ; FIND TYPE OF TEST EX:VIRAL LOAD
 D ^IMRSDSP
 K ^TMP($J)
ICRPT F ICR=0:0 S ICR=$O(^IMR(158,ICR)) Q:ICR'>0  S X=+^(ICR,0),IMRCAT=$P(^(0),U,42) D ^IMRXOR S (DFN,IMRDFN)=X I $D(^DPT(DFN,0)) D SETLR
 Q
SETLR S IMRTSTLR=$P($G(^DPT(DFN,"LR")),U,1),PNAM=$P($G(^DPT(DFN,0)),U,1),SSN=$P($G(^DPT(DFN,0)),U,9)
 D DATA
 Q
DATA K IMRCD
 Q:$G(IMRTSTLR)=""
 S (IMRTSTI,IMRTSTII)="",ILR=IMRTSTLR
CHEMS S LDT="" F  S LDT=$O(^LR(ILR,"CH",LDT)) Q:LDT=""  D LINK
 Q
LINK S DNAM="" F  S DNAM=$O(IMRVALS(DNAM)),LDR="" Q:DNAM=""  D
 . F  S LDR=$O(IMRVALS(DNAM,LDR)) Q:LDR=""  S GRP=$P(IMRVALS(DNAM,LDR),U,1),TYP=$P(IMRVALS(DNAM,LDR),U,2),LNM=$P(IMRVALS(DNAM,LDR),U,3) D LVAL
 Q
LVAL S LRES=$P($G(^LR(ILR,"CH",LDT,DNAM)),U,1),DTRC=$P($G(^LR(ILR,"CH",LDT,0)),U,1),Y=DTRC D DD^%DT S DTAA=Y D PLBS
 Q
PLBS Q:(DTRC>IMRHNEND)!(DTRC<IMRHNBEG)
 Q:LRES=""
 Q:(LRES["CANC")!(LRES["canc")
 Q:(LRES["COMM")!(LRES["comm")
 Q:(DTRC["CANC")!(DTRC["canc")
 S OYR=$E(DTRC,1,3),ODYR=OYR+1700,ODYR=$E(ODYR,3,4),ODAT=$E(DTRC,4,5)_"/"_$E(DTRC,6,7)_"/"_ODYR
 S DTAA=$E(DTAA,1,18),LDO=$E(LDT,1,7)
 S ^TMP($J,PNAM,SSN,LDO,TYP,LRES,DNAM)=LNM_U_GRP_U_LDR_U_DTRC_U_ODAT
 Q
SORT I '$D(^TMP($J)) W !,"**NO DATA FOUND**" Q
 S TY=""
SEC S (P,D)=""
 F  S P=$O(^TMP($J,P)) Q:P=""  F  S D=$O(^TMP($J,P,D)),I="" Q:D=""  F I=0:0 S I=$O(^TMP($J,P,D,I)),T="" Q:I=""  F  S T=$O(^TMP($J,P,D,I,T)),G="" Q:T=""  F  S G=$O(^TMP($J,P,D,I,T,G)),H="" Q:G=""  F  S H=$O(^TMP($J,P,D,I,T,G,H)) Q:H=""  D C
 Q
C S RC=^TMP($J,P,D,I,T,G,H),LN=$P(RC,U,1),IMDATE=$P(RC,U,5)
 W:DELIM="Y" !,$E(P,1,15)_"^"_$E(D,6,9)_"^"_$E(T,1,14)_"^"_IMDATE_"^"_$E(LN,1,15)_"^"_G
 W:DELIM'="Y" !,$E(P,1,15),?17,$E(D,6,9),?23,$E(T,1,14),?39,IMDATE,?50,$E(LN,1,15),?67,$E(G,1,14)
 S TY=T
 Q
KILL D ^%ZISC
 K ^TMP($J),%,%DT,%I,B,BCDH,BCDL,BRES,BVLH,BVLL,C,CDHN,CDLN,D,DELIM,DNAM,DTAA,DTRC,G,GROUP,GRP,GRPNM,H,ICR,IFN,ILR,IMDATE,DIC,DTOUT,DUOUT,IMRLRC,IMRC,IMRC1,IMRFLG,IMRHNBEG,IMRHNEND,IMRJ,IMRNAM,IMRSTN,IMRSD,IMRED,IMRX
 K IMRD,IMRAD,IMRDD,IMRDFN,IMRI,IMRLRFN,IMRHNEND,IMRHQUIT,IMRHRANG,IMRHTART,IMRSTN,IMRTEST,IMRDATE,IMRDOT
 K IMRVALS,IMRUT,I,J,K,M,N,POP,X,X1,Y,DFN,K1,T,IMRV,VAERR,IMRY,IMRZ,DISYS,IMRDTE,IMRPG,IMRCD,IMRTSTI,IMRSSN,IMRTOT,IMRNODE,IMRCAT,IMRDFN,IMRDTNM,IMRFLG,IMRH1HED,IMRH2HED,IMRHENGD,IMRHNBEG
 K IMRTSTII,IMRTSTLR,L,LBNM,LDO,LDR,LDT,LN,LNM,LRES,NODE,ODAT,ODYR,OYR,P,PNAM,RC,RNG,SELE,SSN,TE,TTYPE,TY,TYP,TYPE,VLH,VLL
 Q
EOP ; Check End of Page
 S IMRUT=0
 Q:$D(IO("S"))
 I $E(IOST,1,2)="C-" W ! S DIR(0)="E" D ^DIR K DIR I 'Y S IMRUT=1 Q
 Q
HEAD ; Heading of the Specific Lab Report
 Q:$G(DELIM)="Y"
 W:'($E(IOST,1,2)'="C-"&'IMRPG) @IOF S IMRPG=IMRPG+1
 W:IOST'["C-" !!!
 W !,?23,"CD4/Viral Test Lists",!,?15,IMRHRANG,?65,"Page ",IMRPG,!,?65,IMRHENGD,!!
 W !,"Name",?17,"SSN",?25,"Type",?41,"Date",?52,"Test",?67,"Result"
 W !,"----",?17,"---",?25,"----",?41,"----",?52,"----",?67,"------"
 Q