LR175P ;DALISC/SED - LR*5.2*175 PATCH POST INIT ROUTINE ; 5/1/98
;;5.2;LAB SERVICE;**175**;Sep 27, 1994
EN ; Updates for file 69.5 that will not work with KIDS
;First enter the protocal from file 101 and enter it into 69.5
REMOVE ;
;
S DA=$O(^DIC(19,"B","LREPI (EPI) MANUAL RUN",0))
;
I $G(DA)>0 S DIK="^DIC(19," D ^DIK S MSG="Removing Manual Run Option"
E S MSG="Manual Run Option not found, must be a testing site..."
D BMES^XPDUTL(MSG)
K MSG,DIK,DA
;
;
;
S LRPROT=0
S LRPROT=$O(^ORD(101,"B","LREPI",0))
I +LRPROT>0 D
.;ADD ADDITIONAL INFO FOR EPI.
.S LRPATH=0 F S LRPATH=$O(^LAB(69.5,LRPATH)) Q:+LRPATH'>0 D
..W !,LRPATH
..Q:$P($G(^LAB(69.5,LRPATH,0)),U,7)'=LRPROT
..S $P(^LAB(69.5,LRPATH,0),U,3)=15 ;-->LAG TIME ENTRY
S LRPROT=0
S LRPROT=$O(^ORD(101,"B","LRNCH",0))
I +LRPROT>0 D
.K DD
.S DIC="^LAB(69.4,",DIC(0)="L",(DINUM,X)=LRPROT,DLAYGO=69.4
.D FILE^DICN K DA,DO,DD,DIC
.S MSG="Adding Protocal '"_$P(^ORD(101,LRPROT,0),U,1)_"' to the "
.S MSG=MSG_"LAB SEARCH/EXTRACT File (69.5)"
.D BMES^XPDUTL(MSG) K MSG
.S $P(^LAB(69.4,LRPROT,0),U,3)="32000"
.S $P(^LAB(69.4,LRPROT,0),U,5)="National Center for Health Promotion"
.; Add cholesterol and pap
. D KLIK
.; NOW ADD THE INFO TO FILE 69.5
.;
.S LRPATH=$O(^LAB(69.5,"B","NCH CHOLESTEROL",0))
.I +LRPATH'>0 D BMES^XPDUTL("Unable to add a NCH to the LAB SEARCH/EXTRACT File (69.5)") Q
.S $P(^LAB(69.5,LRPATH,0),U,7)=LRPROT,$P(^LAB(69.5,LRPATH,0),U,9)=50
. ;-->Enter Lag time, cycle and PTF
. D FILL
.S LRPATH=$O(^LAB(69.5,"B","NCH PAP SMEAR",0))
.I +LRPATH'>0 D BMES^XPDUTL("Unable to add a NCH to the LAB SEARCH/EXTRACT File (69.5)") Q
.S $P(^LAB(69.5,LRPATH,0),U,7)=LRPROT,$P(^LAB(69.5,LRPATH,0),U,9)=51
. ;-->Enter Lag time, cycle and PTF
. D FILL
S LRPROT=$O(^ORD(101,"B","LREPI",0))
I +LRPROT>0 D
.Q:'$D(^LAB(69.4,LRPROT,0))
.S $P(^LAB(69.4,LRPROT,0),U,5)="Emerging Pathogens Initiative (EPI)"
.S $P(^LAB(69.4,LRPROT,0),U,4)=1
;
SITE ;ENTER PRIMARY SITE NUMBER TO HL7 APLICATION
S LA7VS=$$PRIM^VASITE(DT) I $G(LA7VS)'="" D
.S LA7VS=$$SITE^VASITE(DT,LA7VS)
.S PRIMARY=$P(LA7VS,U,3)
.Q:+PRIMARY'>0
.S LRAPP=$O(^HL(771,"B","NCH-LAB",0))
.Q:+LRAPP'>0
.Q:'$D(^HL(771,LRAPP,0))
.S $P(^HL(771,LRAPP,0),U,3)=PRIMARY
EXIT K LRPATH,INT,X,Y,DIC,DD,LRPROT
Q
;
KLIK ;
CHK ;
; ARE THEY THERE?
S LRPATH=$O(^LAB(69.5,"B","NCH CHOLESTEROL",0)) Q:+LRPATH>0
S LRPATH=$O(^LAB(69.5,"B","NCH PAP SMEAR",0)) Q:+LRPATH>0
;
F X="NCH CHOLESTEROL","NCH PAP SMEAR" D
. S DA=$P(^LAB(69.5,0),U,3)+1
. S DIC="^LAB(69.5,"
. S DIC(0)="L" S DLAYGO=69.5
. D FILE^DICN K DD,DO,DIC,DA
;
;
Q
FILL ;
; LAG CYCLE PTF 0=YES
; /\ /\ /\
; ^LAB(69.5,16,0) = NCH CHOLESTEROL^0^7^2980525^D^^4576^0^50
;
S $P(^LAB(69.5,LRPATH,0),U,3)=10
S $P(^LAB(69.5,LRPATH,0),U,5)="D"
S $P(^LAB(69.5,LRPATH,0),U,8)=1
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR175P 2991 printed Apr 09, 2024@21:14:33 Page 2
LR175P ;DALISC/SED - LR*5.2*175 PATCH POST INIT ROUTINE ; 5/1/98
+1 ;;5.2;LAB SERVICE;**175**;Sep 27, 1994
EN ; Updates for file 69.5 that will not work with KIDS
+1 ;First enter the protocal from file 101 and enter it into 69.5
REMOVE ;
+1 ;
+2 SET DA=$ORDER(^DIC(19,"B","LREPI (EPI) MANUAL RUN",0))
+3 ;
+4 IF $GET(DA)>0
SET DIK="^DIC(19,"
DO ^DIK
SET MSG="Removing Manual Run Option"
+5 IF '$TEST
SET MSG="Manual Run Option not found, must be a testing site..."
+6 DO BMES^XPDUTL(MSG)
+7 KILL MSG,DIK,DA
+8 ;
+9 ;
+10 ;
+11 SET LRPROT=0
+12 SET LRPROT=$ORDER(^ORD(101,"B","LREPI",0))
+13 IF +LRPROT>0
Begin DoDot:1
+14 ;ADD ADDITIONAL INFO FOR EPI.
+15 SET LRPATH=0
FOR
SET LRPATH=$ORDER(^LAB(69.5,LRPATH))
if +LRPATH'>0
QUIT
Begin DoDot:2
+16 WRITE !,LRPATH
+17 if $PIECE($GET(^LAB(69.5,LRPATH,0)),U,7)'=LRPROT
QUIT
+18 ;-->LAG TIME ENTRY
SET $PIECE(^LAB(69.5,LRPATH,0),U,3)=15
End DoDot:2
End DoDot:1
+19 SET LRPROT=0
+20 SET LRPROT=$ORDER(^ORD(101,"B","LRNCH",0))
+21 IF +LRPROT>0
Begin DoDot:1
+22 KILL DD
+23 SET DIC="^LAB(69.4,"
SET DIC(0)="L"
SET (DINUM,X)=LRPROT
SET DLAYGO=69.4
+24 DO FILE^DICN
KILL DA,DO,DD,DIC
+25 SET MSG="Adding Protocal '"_$PIECE(^ORD(101,LRPROT,0),U,1)_"' to the "
+26 SET MSG=MSG_"LAB SEARCH/EXTRACT File (69.5)"
+27 DO BMES^XPDUTL(MSG)
KILL MSG
+28 SET $PIECE(^LAB(69.4,LRPROT,0),U,3)="32000"
+29 SET $PIECE(^LAB(69.4,LRPROT,0),U,5)="National Center for Health Promotion"
+30 ; Add cholesterol and pap
+31 DO KLIK
+32 ; NOW ADD THE INFO TO FILE 69.5
+33 ;
+34 SET LRPATH=$ORDER(^LAB(69.5,"B","NCH CHOLESTEROL",0))
+35 IF +LRPATH'>0
DO BMES^XPDUTL("Unable to add a NCH to the LAB SEARCH/EXTRACT File (69.5)")
QUIT
+36 SET $PIECE(^LAB(69.5,LRPATH,0),U,7)=LRPROT
SET $PIECE(^LAB(69.5,LRPATH,0),U,9)=50
+37 ;-->Enter Lag time, cycle and PTF
+38 DO FILL
+39 SET LRPATH=$ORDER(^LAB(69.5,"B","NCH PAP SMEAR",0))
+40 IF +LRPATH'>0
DO BMES^XPDUTL("Unable to add a NCH to the LAB SEARCH/EXTRACT File (69.5)")
QUIT
+41 SET $PIECE(^LAB(69.5,LRPATH,0),U,7)=LRPROT
SET $PIECE(^LAB(69.5,LRPATH,0),U,9)=51
+42 ;-->Enter Lag time, cycle and PTF
+43 DO FILL
End DoDot:1
+44 SET LRPROT=$ORDER(^ORD(101,"B","LREPI",0))
+45 IF +LRPROT>0
Begin DoDot:1
+46 if '$DATA(^LAB(69.4,LRPROT,0))
QUIT
+47 SET $PIECE(^LAB(69.4,LRPROT,0),U,5)="Emerging Pathogens Initiative (EPI)"
+48 SET $PIECE(^LAB(69.4,LRPROT,0),U,4)=1
End DoDot:1
+49 ;
SITE ;ENTER PRIMARY SITE NUMBER TO HL7 APLICATION
+1 SET LA7VS=$$PRIM^VASITE(DT)
IF $GET(LA7VS)'=""
Begin DoDot:1
+2 SET LA7VS=$$SITE^VASITE(DT,LA7VS)
+3 SET PRIMARY=$PIECE(LA7VS,U,3)
+4 if +PRIMARY'>0
QUIT
+5 SET LRAPP=$ORDER(^HL(771,"B","NCH-LAB",0))
+6 if +LRAPP'>0
QUIT
+7 if '$DATA(^HL(771,LRAPP,0))
QUIT
+8 SET $PIECE(^HL(771,LRAPP,0),U,3)=PRIMARY
End DoDot:1
EXIT KILL LRPATH,INT,X,Y,DIC,DD,LRPROT
+1 QUIT
+2 ;
KLIK ;
CHK ;
+1 ; ARE THEY THERE?
+2 SET LRPATH=$ORDER(^LAB(69.5,"B","NCH CHOLESTEROL",0))
if +LRPATH>0
QUIT
+3 SET LRPATH=$ORDER(^LAB(69.5,"B","NCH PAP SMEAR",0))
if +LRPATH>0
QUIT
+4 ;
+5 FOR X="NCH CHOLESTEROL","NCH PAP SMEAR"
Begin DoDot:1
+6 SET DA=$PIECE(^LAB(69.5,0),U,3)+1
+7 SET DIC="^LAB(69.5,"
+8 SET DIC(0)="L"
SET DLAYGO=69.5
+9 DO FILE^DICN
KILL DD,DO,DIC,DA
End DoDot:1
+10 ;
+11 ;
+12 QUIT
FILL ;
+1 ; LAG CYCLE PTF 0=YES
+2 ; /\ /\ /\
+3 ; ^LAB(69.5,16,0) = NCH CHOLESTEROL^0^7^2980525^D^^4576^0^50
+4 ;
+5 SET $PIECE(^LAB(69.5,LRPATH,0),U,3)=10
+6 SET $PIECE(^LAB(69.5,LRPATH,0),U,5)="D"
+7 SET $PIECE(^LAB(69.5,LRPATH,0),U,8)=1
+8 ;
+9 QUIT
