FHASM4 ; HISC/REL/JH - Laboratory/Drug Data ;4/3/01 14:12
;;5.5;DIETETICS;**4,8**;Jan 28, 2005;Build 28
S PX=3 D LAB G ^FHASM5
LAB ; Collect lab results
K LRTST,^TMP($J,"LRTST") Q:'DFN
S LRDFN=$P($G(^DPT(DFN,"LR")),"^",1) G:'LRDFN LKIL
W:PX=3 !!,"Collecting laboratory data ... " D GET
S X2=-$S($D(^FH(119.9,1,3)):$P(^(3),"^",2),1:90)
S %DT="X",X="T" D ^%DT S DT=+Y,X1=DT D C^%DTC S A1=9999999-X
F K=0:0 S K=$O(^LR(LRDFN,"CH",K)) Q:K<1!(K>A1) F L=0:0 S L=$O(^LR(LRDFN,"CH",K,L)) Q:L'>0 I $D(LRTST(L)) S X=^(L) D STR
S %=100 F L=0:0 S L=$O(LRTST(L)) Q:L'>0 F SP=0:0 S SP=$O(LRTST(L,SP)) Q:SP'>0 D
.I $P(LRTST(L,SP),"^",6)="" K LRTST(L,SP) Q
.S %=%+1,^TMP($J,"LRTST",$S($P(LRTST(L,SP),"^",8)'="":$P(LRTST(L,SP),"^",8),1:%))=LRTST(L,SP) Q
K LRTST F L=0:0 S L=$O(^TMP($J,"LRTST",L)) Q:L<1 S LRTST(L)=^(L)
LKIL K %,%H,%I,%T,%DT,A1,FLG,GRP,HI,K,L,LO,LRCW,LRDFN,P60,PC,SP,THER,TNAM,TST,X,X0,X1,X2,Y Q
STR ;
S SP=$P($G(^LR(LRDFN,"CH",K,0)),"^",5) Q:'SP
I '$D(LRTST(L,SP)) Q
I $P(LRTST(L,SP),"^",6)'="" Q
S FHLR=$$TSTRES^LRRPU(LRDFN,"CH",K,L),FHLO=$P(FHLR,U,3),FHI=$P(FHLR,U,4)
S $P(LRTST(L,SP),U,5)=$J(FHLO,4)_$S($L(FHI):" - "_$J(FHI,4),1:"")
S P60=$P(LRTST(L,SP),"^",2),SP=$P(LRTST(L,SP),"^",3),GRP=$P(LRTST(L,SP),"^",8)
S FLG=$P(X,"^",2),X=$P(X,"^",1) Q:X="" S PC=$P($G(^LAB(60,P60,.1)),"^",3)
S LRCW=8 I PC="" S X=$J(X,LRCW)
E S @("X="_PC)
S:FLG'="" X=X_" "_FLG
S $P(LRTST(L,SP),"^",6,7)=X_"^"_(9999999-K)
I GRP F %=0:0 S %=$O(LRTST(%)) Q:%="" F P60=0:0 S P60=$O(LRTST(%,P60)) Q:P60="" I $P(LRTST(%,P60),"^",8)=GRP,'(%=L&(P60=SP)) D
.I $P(LRTST(L,SP),"^",7)>$P(LRTST(%,P60),"^",7) K LRTST(%,P60) Q
.K LRTST(L,SP) Q
Q
GET ; Get Lab Tests of interest from Site Parameter file
F K=0:0 S K=$O(^FH(119.9,1,"L",K)) Q:K'>0 S X=^(K,0) I 'PX!($P(X,"^",PX)="Y") D G1
Q
G1 S P60=+$P(X,"^",1),SP=$P(X,"^",2),GRP=$P(X,"^",5) Q:'SP S X0=$G(^LAB(60,P60,0)) Q:X0=""
S X1=$G(^LAB(60,P60,.1)),TST=$P($P(X0,"^",5),";",2) Q:'TST
S TNAM=$P(X0,"^",1) I $L(TNAM)>20 S TNAM=$P(X1,"^",1)
S X=$G(^LAB(60,P60,1,SP,0)) Q:'$L(X) S THER=$S($L($P(X,U,11,12))>1:1,1:0) S LO=$S(THER:$P(X,U,11),1:$P(X,U,2)),HI=$S(THER:$P(X,U,12),1:$P(X,U,3))
S LRTST(TST,SP)=TNAM_"^"_P60_"^"_SP_"^"_$P(X,"^",7)_"^"_$J(LO,4)_$S($L(HI):" - "_$J(HI,4),1:"")_"^^^"_GRP Q
S @("LO="_$S($L(LO):LO,1:"""""")),@("HI="_$S($L(HI):HI,1:""""""))
DRUG ; Collect requested drugs 0=Outpatient 1=Inpatient
K ^TMP($J,"FHCLASS"),^TMP($J,"FHPSORD"),^TMP($J,"FHPSO"),^TMP($J,"FHDRUG"),^TMP($J,"FHPSS")
K PC,PSD,PSCNS,PSCA,PDC,FHPH1,PCLS S PORD=99
F K=0:0 S K=$O(^FH(119.9,1,"P",K)) Q:K'>0 D
.S FHPH1=^(K,0),(X,PSNIEN)=$P(FHPH1,U,1)
.S FHPPA=$P(FHPH1,U,3)
.S FHPPNS=$P(FHPH1,U,4)
.S FHPPOR=$P(FHPH1,U,5)
.S FHPAL=$P(FHPH1,U,6)
.S:FHPPA="Y" PCA(X)=K
.S:FHPPNS="Y" PCNS(X)=K
.S:FHPAL="Y" PCAL(X)=K
.I FHPPOR S PCORD(X)=FHPPOR
.E S PCORD(X)=PORD
.D IEN^PSN50P65(PSNIEN,,"FHCLASS") S CLS=$E(^TMP($J,"FHCLASS",PSNIEN,.01),1,3)
.I CLS'="" S:$E(CLS,3)="0" CLS=$E(CLS,1,2) S PC(CLS)=""
G:'$D(PC) PKIL D NOW^%DTC S STRT=(%\1)-1 I 'PX D OUTP G PKIL
D PSS432^PSS55(DFN,,"FHPSORD") F PSORD=0:0 S PSORD=$O(^TMP($J,"FHPSORD","B",PSORD)) Q:'PSORD D D1
PKIL K %,%H,%I,CLS,DRG,K,PC,PSORD,STRT,X,FHPH1 Q
OUTP ;
D PROF^PSO52API(DFN,"FHPSO",STRT)
F JX=0:0 S JX=$O(^TMP($J,"FHPSO",DFN,JX)) Q:JX'>0 D
. S X=JX D EN^PSOORDER(DFN,X)
. S CLS=$P($P($G(^TMP("PSOR",$J,JX,0)),"^",4),";",1) I CLS'="A",CLS'="H",CLS'="S" Q
. S DRG=$P($P($G(^TMP("PSOR",$J,JX,"DRUG",0)),U),";") D:DRG D2
. Q
Q
D1 D PSS431^PSS55(DFN,PSORD,,,"FHDRUG")
S DRG=$P($G(^TMP($J,"FHDRUG",PSORD,"DDRUG",1,.01)),"^",1)
;
D2 D DATA^PSS50(DRG,,,,,"FHPSS") I $P(^TMP($J,"FHPSS",0),"^",1)=-1 Q
S CLS=^TMP($J,"FHPSS",DRG,2) Q:CLS="" I '$D(PC($E(CLS,1,2))),'$D(PC($E(CLS,1,3))) Q
S PSD(DRG)=^TMP($J,"FHPSS",DRG,.01)
S PSCL605=$P($G(^TMP($J,"FHPSS",DRG,25)),U,1)
I $D(PCAL(PSCL605)),$D(PCORD(PSCL605)) S PCLS(PSD(DRG))=PSCL605
I $D(PCA(PSCL605)),$D(PCORD(PSCL605)) S PSCA(PCORD(PSCL605),PSD(DRG))=""
I $D(PCNS(PSCL605)),$D(PCORD(PSCL605)) S PSCNS(PCORD(PSCL605),PSD(DRG))=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASM4 4098 printed Jan 18, 2025@02:48:09 Page 2
FHASM4 ; HISC/REL/JH - Laboratory/Drug Data ;4/3/01 14:12
+1 ;;5.5;DIETETICS;**4,8**;Jan 28, 2005;Build 28
+2 SET PX=3
DO LAB
GOTO ^FHASM5
LAB ; Collect lab results
+1 KILL LRTST,^TMP($JOB,"LRTST")
if 'DFN
QUIT
+2 SET LRDFN=$PIECE($GET(^DPT(DFN,"LR")),"^",1)
if 'LRDFN
GOTO LKIL
+3 if PX=3
WRITE !!,"Collecting laboratory data ... "
DO GET
+4 SET X2=-$SELECT($DATA(^FH(119.9,1,3)):$PIECE(^(3),"^",2),1:90)
+5 SET %DT="X"
SET X="T"
DO ^%DT
SET DT=+Y
SET X1=DT
DO C^%DTC
SET A1=9999999-X
+6 FOR K=0:0
SET K=$ORDER(^LR(LRDFN,"CH",K))
if K<1!(K>A1)
QUIT
FOR L=0:0
SET L=$ORDER(^LR(LRDFN,"CH",K,L))
if L'>0
QUIT
IF $DATA(LRTST(L))
SET X=^(L)
DO STR
+7 SET %=100
FOR L=0:0
SET L=$ORDER(LRTST(L))
if L'>0
QUIT
FOR SP=0:0
SET SP=$ORDER(LRTST(L,SP))
if SP'>0
QUIT
Begin DoDot:1
+8 IF $PIECE(LRTST(L,SP),"^",6)=""
KILL LRTST(L,SP)
QUIT
+9 SET %=%+1
SET ^TMP($JOB,"LRTST",$SELECT($PIECE(LRTST(L,SP),"^",8)'="":$PIECE(LRTST(L,SP),"^",8),1:%))=LRTST(L,SP)
QUIT
End DoDot:1
+10 KILL LRTST
FOR L=0:0
SET L=$ORDER(^TMP($JOB,"LRTST",L))
if L<1
QUIT
SET LRTST(L)=^(L)
LKIL KILL %,%H,%I,%T,%DT,A1,FLG,GRP,HI,K,L,LO,LRCW,LRDFN,P60,PC,SP,THER,TNAM,TST,X,X0,X1,X2,Y
QUIT
STR ;
+1 SET SP=$PIECE($GET(^LR(LRDFN,"CH",K,0)),"^",5)
if 'SP
QUIT
+2 IF '$DATA(LRTST(L,SP))
QUIT
+3 IF $PIECE(LRTST(L,SP),"^",6)'=""
QUIT
+4 SET FHLR=$$TSTRES^LRRPU(LRDFN,"CH",K,L)
SET FHLO=$PIECE(FHLR,U,3)
SET FHI=$PIECE(FHLR,U,4)
+5 SET $PIECE(LRTST(L,SP),U,5)=$JUSTIFY(FHLO,4)_$SELECT($LENGTH(FHI):" - "_$JUSTIFY(FHI,4),1:"")
+6 SET P60=$PIECE(LRTST(L,SP),"^",2)
SET SP=$PIECE(LRTST(L,SP),"^",3)
SET GRP=$PIECE(LRTST(L,SP),"^",8)
+7 SET FLG=$PIECE(X,"^",2)
SET X=$PIECE(X,"^",1)
if X=""
QUIT
SET PC=$PIECE($GET(^LAB(60,P60,.1)),"^",3)
+8 SET LRCW=8
IF PC=""
SET X=$JUSTIFY(X,LRCW)
+9 IF '$TEST
SET @("X="_PC)
+10 if FLG'=""
SET X=X_" "_FLG
+11 SET $PIECE(LRTST(L,SP),"^",6,7)=X_"^"_(9999999-K)
+12 IF GRP
FOR %=0:0
SET %=$ORDER(LRTST(%))
if %=""
QUIT
FOR P60=0:0
SET P60=$ORDER(LRTST(%,P60))
if P60=""
QUIT
IF $PIECE(LRTST(%,P60),"^",8)=GRP
IF '(%=L&(P60=SP))
Begin DoDot:1
+13 IF $PIECE(LRTST(L,SP),"^",7)>$PIECE(LRTST(%,P60),"^",7)
KILL LRTST(%,P60)
QUIT
+14 KILL LRTST(L,SP)
QUIT
End DoDot:1
+15 QUIT
GET ; Get Lab Tests of interest from Site Parameter file
+1 FOR K=0:0
SET K=$ORDER(^FH(119.9,1,"L",K))
if K'>0
QUIT
SET X=^(K,0)
IF 'PX!($PIECE(X,"^",PX)="Y")
DO G1
+2 QUIT
G1 SET P60=+$PIECE(X,"^",1)
SET SP=$PIECE(X,"^",2)
SET GRP=$PIECE(X,"^",5)
if 'SP
QUIT
SET X0=$GET(^LAB(60,P60,0))
if X0=""
QUIT
+1 SET X1=$GET(^LAB(60,P60,.1))
SET TST=$PIECE($PIECE(X0,"^",5),";",2)
if 'TST
QUIT
+2 SET TNAM=$PIECE(X0,"^",1)
IF $LENGTH(TNAM)>20
SET TNAM=$PIECE(X1,"^",1)
+3 SET X=$GET(^LAB(60,P60,1,SP,0))
if '$LENGTH(X)
QUIT
SET THER=$SELECT($LENGTH($PIECE(X,U,11,12))>1:1,1:0)
SET LO=$SELECT(THER:$PIECE(X,U,11),1:$PIECE(X,U,2))
SET HI=$SELECT(THER:$PIECE(X,U,12),1:$PIECE(X,U,3))
+4 SET LRTST(TST,SP)=TNAM_"^"_P60_"^"_SP_"^"_$PIECE(X,"^",7)_"^"_$JUSTIFY(LO,4)_$SELECT($LENGTH(HI):" - "_$JUSTIFY(HI,4),1:"")_"^^^"_GRP
QUIT
+5 SET @("LO="_$SELECT($LENGTH(LO):LO,1:""""""))
SET @("HI="_$SELECT($LENGTH(HI):HI,1:""""""))
DRUG ; Collect requested drugs 0=Outpatient 1=Inpatient
+1 KILL ^TMP($JOB,"FHCLASS"),^TMP($JOB,"FHPSORD"),^TMP($JOB,"FHPSO"),^TMP($JOB,"FHDRUG"),^TMP($JOB,"FHPSS")
+2 KILL PC,PSD,PSCNS,PSCA,PDC,FHPH1,PCLS
SET PORD=99
+3 FOR K=0:0
SET K=$ORDER(^FH(119.9,1,"P",K))
if K'>0
QUIT
Begin DoDot:1
+4 SET FHPH1=^(K,0)
SET (X,PSNIEN)=$PIECE(FHPH1,U,1)
+5 SET FHPPA=$PIECE(FHPH1,U,3)
+6 SET FHPPNS=$PIECE(FHPH1,U,4)
+7 SET FHPPOR=$PIECE(FHPH1,U,5)
+8 SET FHPAL=$PIECE(FHPH1,U,6)
+9 if FHPPA="Y"
SET PCA(X)=K
+10 if FHPPNS="Y"
SET PCNS(X)=K
+11 if FHPAL="Y"
SET PCAL(X)=K
+12 IF FHPPOR
SET PCORD(X)=FHPPOR
+13 IF '$TEST
SET PCORD(X)=PORD
+14 DO IEN^PSN50P65(PSNIEN,,"FHCLASS")
SET CLS=$EXTRACT(^TMP($JOB,"FHCLASS",PSNIEN,.01),1,3)
+15 IF CLS'=""
if $EXTRACT(CLS,3)="0"
SET CLS=$EXTRACT(CLS,1,2)
SET PC(CLS)=""
End DoDot:1
+16 if '$DATA(PC)
GOTO PKIL
DO NOW^%DTC
SET STRT=(%\1)-1
IF 'PX
DO OUTP
GOTO PKIL
+17 DO PSS432^PSS55(DFN,,"FHPSORD")
FOR PSORD=0:0
SET PSORD=$ORDER(^TMP($JOB,"FHPSORD","B",PSORD))
if 'PSORD
QUIT
DO D1
PKIL KILL %,%H,%I,CLS,DRG,K,PC,PSORD,STRT,X,FHPH1
QUIT
OUTP ;
+1 DO PROF^PSO52API(DFN,"FHPSO",STRT)
+2 FOR JX=0:0
SET JX=$ORDER(^TMP($JOB,"FHPSO",DFN,JX))
if JX'>0
QUIT
Begin DoDot:1
+3 SET X=JX
DO EN^PSOORDER(DFN,X)
+4 SET CLS=$PIECE($PIECE($GET(^TMP("PSOR",$JOB,JX,0)),"^",4),";",1)
IF CLS'="A"
IF CLS'="H"
IF CLS'="S"
QUIT
+5 SET DRG=$PIECE($PIECE($GET(^TMP("PSOR",$JOB,JX,"DRUG",0)),U),";")
if DRG
DO D2
+6 QUIT
End DoDot:1
+7 QUIT
D1 DO PSS431^PSS55(DFN,PSORD,,,"FHDRUG")
+1 SET DRG=$PIECE($GET(^TMP($JOB,"FHDRUG",PSORD,"DDRUG",1,.01)),"^",1)
+2 ;
D2 DO DATA^PSS50(DRG,,,,,"FHPSS")
IF $PIECE(^TMP($JOB,"FHPSS",0),"^",1)=-1
QUIT
+1 SET CLS=^TMP($JOB,"FHPSS",DRG,2)
if CLS=""
QUIT
IF '$DATA(PC($EXTRACT(CLS,1,2)))
IF '$DATA(PC($EXTRACT(CLS,1,3)))
QUIT
+2 SET PSD(DRG)=^TMP($JOB,"FHPSS",DRG,.01)
+3 SET PSCL605=$PIECE($GET(^TMP($JOB,"FHPSS",DRG,25)),U,1)
+4 IF $DATA(PCAL(PSCL605))
IF $DATA(PCORD(PSCL605))
SET PCLS(PSD(DRG))=PSCL605
+5 IF $DATA(PCA(PSCL605))
IF $DATA(PCORD(PSCL605))
SET PSCA(PCORD(PSCL605),PSD(DRG))=""
+6 IF $DATA(PCNS(PSCL605))
IF $DATA(PCORD(PSCL605))
SET PSCNS(PCORD(PSCL605),PSD(DRG))=""
+7 QUIT
