LRCAPPH2 ;DALISC/FHS - CREATE OR MODIFY LAB LOCATIONS
;;5.2;LAB SERVICE;**138**;Sep 27, 1994
EN ;
S LRPKG=$O(^DIC(9.4,"B","LR",0))
I 'LRPKG S LRPKG=$O(^DIC(9.4,"B","LAB SERVICE",0))
I 'LRPKG W !!,$$CJ^XLFSTR("Not able to find 'LAB SERVICE' in your Package (#9.4) file.",80),!,$$CJ^XLFSTR("Contact your IRM Service !!",80),!!,$C(7) H 5 G END
W !!,$$CJ^XLFSTR("List of already defined Laboratory OOS Locations",80),!
S (CNT,I)=0 F S I=$O(^SC(I)) Q:I<1 I $P(^(I,0),U)["LAB DIV " S X=^(0) D
. S CNT=CNT+1 W !,$P(X,U),?32,$P($G(^DIC(4,+$P(X,U,4),99)),U),?40,$P($G(^DIC(40.7,+$P(X,U,7),0)),U,2)
W ! I 'CNT D G END
. W !,$$CJ^XLFSTR("NONE ARE CURRENTLY DEFINED",80)
. W !,$$CJ^XLFSTR("INSTALL PATCH LR*5.2*138",80),!
K DIR S DIR("A")="Would you like a detail display ?",DIR("B")="No",DIR(0)="YAO" D ^DIR
K DIR W !!
G END:$G(DTOUT)!($G(DIRUT))!($G(DUOUT))
I Y=1 D DETAIL G EN
DIV ;
W !,$$CJ^XLFSTR(" You may define a new Laboratory OOS Location ",80),!
K DIR,DIC S DIR(0)="PO^4:AQEZNM",DIR("A")="Enter New Division "
S DIR("S")="I $G(^(99))" D ^DIR
G END:$G(DTOUT)!($G(DIRUT))!($G(DUOUT))
G END:Y<1 S LRDIVN=+Y,LRDIV=$P($G(^DIC(4,+Y,99)),U)
SCODE ;
K DIR S DIR(0)="PO^40.7:AQEZNM",DIR("A")="Select Clinic Stop Code "
S DIR("S")=$$EXEMPT^SCDXUAPI D ^DIR
G END:$G(DTOUT)!($G(DIRUT))!($G(DUOUT))
G END:Y<1 S LRSCODE=$P(Y(0),U,2),LRSCODEN=+Y
DIS ;
S LRNAME="LAB DIV "_LRDIV_" OOS ID "_LRSCODE,LRNAME=$E(LRNAME,1,30)
W !,$$CJ^XLFSTR("ONCE DEFINED - IT CAN NOT BE DELETED",80),!
K DIR S DIR("A")=" ["_LRNAME_"] Is this the correct new name ? "
S DIR("B")="No",DIR(0)="YAO" D ^DIR
CHK ;
K DIR W !!
G END:$G(DTOUT)!($G(DIRUT))!($G(DUOUT))
G DIV:'Y
I $D(^SC("B",LRNAME)) D G EN
. W @IOF,!?20,LRNAME,!?5," This location is already defined ",!,$C(7)
. D END0
W @IOF D LOAD,END0 G DIV
LOADB S LRNAME=$E(LRNAME,1,30) Q:$D(^SC("B",LRNAME))
LOAD ;
S X="SCDXUAPI" X ^%ZOSF("TEST") I '$T W !!,$$CJ^XLFSTR("Load SD*5.3*63 Patch",80),!! Q
S LROK=$$LOC^SCDXUAPI(LRNAME,LRDIVN,LRSCODE,LRPKG,,)
I $G(LRDBUG) W !,"LROK = ",LROK
I LROK<1 W !!?5,$P(LROK,U,2),!,"LOCATION NOT CREATED",!,$C(7) Q
D SHOW
W !!,$$CJ^XLFSTR("LAB Location Added",80),!!
Q:$G(LRDBUG) K DIC,DIE,DA,DIR
Q
SHOW K DA,DIC,DIE S DA=LROK,DIC="^SC(",DR="0:999999" W !! D EN^DIQ Q
END ;
Q:$G(LRDBUG)
END0 K DA,DIC,DIR,DR,LRDIV,LRDIVN,LRNAME,LRSCODE,LRSCODEN,SCERR,S
K LRAA,LRLOC
Q
DETAIL K DIR D 44
G:$G(DTOUT)!($G(DIRUT))!($G(DUOUT)) DEND
I Y>0 S LROK=+Y D SHOW G DETAIL
DEND K DA,DIC,DIR,LROK Q
ACC ;
K DIR S DIR(0)="PO^68:AQEZNM",DIR("A")="Select Accession Area "
D ^DIR
G END:$G(DTOUT)!($G(DIRUT))!($G(DUOUT))!(Y<1)
S LRAA=Y
S LROK=$G(^LRO(68,+LRAA,.8)) I LROK D
. K DIR W @IOF,!,$$CJ^XLFSTR("Current Laboratory OOS Location",80),!
. W $$CJ^XLFSTR("For [ "_$P(Y,U,2)_" ] Accession Area ",80)
. D SHOW
K DIR,LROK S:'$G(^LRO(68,+LRAA,.8)) DIR("B")=$P(^SC(+$G(^LAB(69.9,1,.8)),0),U) S DIR("A")="Select OOS Location for ["_$P(LRAA,U,2)_"] Acc Area " D 44
I Y=-1 W !?10,"NO SELECTION MADE ",!! G ACC
G END:$G(DTOUT)!($G(DIRUT))!($G(DUOUT))!(Y<1)
S LRLOC=+Y
K DIE,DA S DIE="^LRO(68,",DA=+LRAA,DR=".8////"_LRLOC D ^DIE
W !?10,"DONE",! G ACC
Q
44 ;
K DIC S DIR(0)="PO^44:AQEZNM" S:'$D(DIR("A")) DIR("A")="Select Laboratory OOS Location " S DIR("S")="I $P(^(0),U)[""LAB DIV """
D ^DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPPH2 3367 printed Sep 23, 2025@19:48:51 Page 2
LRCAPPH2 ;DALISC/FHS - CREATE OR MODIFY LAB LOCATIONS
+1 ;;5.2;LAB SERVICE;**138**;Sep 27, 1994
EN ;
+1 SET LRPKG=$ORDER(^DIC(9.4,"B","LR",0))
+2 IF 'LRPKG
SET LRPKG=$ORDER(^DIC(9.4,"B","LAB SERVICE",0))
+3 IF 'LRPKG
WRITE !!,$$CJ^XLFSTR("Not able to find 'LAB SERVICE' in your Package (#9.4) file.",80),!,$$CJ^XLFSTR("Contact your IRM Service !!",80),!!,$CHAR(7)
HANG 5
GOTO END
+4 WRITE !!,$$CJ^XLFSTR("List of already defined Laboratory OOS Locations",80),!
+5 SET (CNT,I)=0
FOR
SET I=$ORDER(^SC(I))
if I<1
QUIT
IF $PIECE(^(I,0),U)["LAB DIV "
SET X=^(0)
Begin DoDot:1
+6 SET CNT=CNT+1
WRITE !,$PIECE(X,U),?32,$PIECE($GET(^DIC(4,+$PIECE(X,U,4),99)),U),?40,$PIECE($GET(^DIC(40.7,+$PIECE(X,U,7),0)),U,2)
End DoDot:1
+7 WRITE !
IF 'CNT
Begin DoDot:1
+8 WRITE !,$$CJ^XLFSTR("NONE ARE CURRENTLY DEFINED",80)
+9 WRITE !,$$CJ^XLFSTR("INSTALL PATCH LR*5.2*138",80),!
End DoDot:1
GOTO END
+10 KILL DIR
SET DIR("A")="Would you like a detail display ?"
SET DIR("B")="No"
SET DIR(0)="YAO"
DO ^DIR
+11 KILL DIR
WRITE !!
+12 if $GET(DTOUT)!($GET(DIRUT))!($GET(DUOUT))
GOTO END
+13 IF Y=1
DO DETAIL
GOTO EN
DIV ;
+1 WRITE !,$$CJ^XLFSTR(" You may define a new Laboratory OOS Location ",80),!
+2 KILL DIR,DIC
SET DIR(0)="PO^4:AQEZNM"
SET DIR("A")="Enter New Division "
+3 SET DIR("S")="I $G(^(99))"
DO ^DIR
+4 if $GET(DTOUT)!($GET(DIRUT))!($GET(DUOUT))
GOTO END
+5 if Y<1
GOTO END
SET LRDIVN=+Y
SET LRDIV=$PIECE($GET(^DIC(4,+Y,99)),U)
SCODE ;
+1 KILL DIR
SET DIR(0)="PO^40.7:AQEZNM"
SET DIR("A")="Select Clinic Stop Code "
+2 SET DIR("S")=$$EXEMPT^SCDXUAPI
DO ^DIR
+3 if $GET(DTOUT)!($GET(DIRUT))!($GET(DUOUT))
GOTO END
+4 if Y<1
GOTO END
SET LRSCODE=$PIECE(Y(0),U,2)
SET LRSCODEN=+Y
DIS ;
+1 SET LRNAME="LAB DIV "_LRDIV_" OOS ID "_LRSCODE
SET LRNAME=$EXTRACT(LRNAME,1,30)
+2 WRITE !,$$CJ^XLFSTR("ONCE DEFINED - IT CAN NOT BE DELETED",80),!
+3 KILL DIR
SET DIR("A")=" ["_LRNAME_"] Is this the correct new name ? "
+4 SET DIR("B")="No"
SET DIR(0)="YAO"
DO ^DIR
CHK ;
+1 KILL DIR
WRITE !!
+2 if $GET(DTOUT)!($GET(DIRUT))!($GET(DUOUT))
GOTO END
+3 if 'Y
GOTO DIV
+4 IF $DATA(^SC("B",LRNAME))
Begin DoDot:1
+5 WRITE @IOF,!?20,LRNAME,!?5," This location is already defined ",!,$CHAR(7)
+6 DO END0
End DoDot:1
GOTO EN
+7 WRITE @IOF
DO LOAD
DO END0
GOTO DIV
LOADB SET LRNAME=$EXTRACT(LRNAME,1,30)
if $DATA(^SC("B",LRNAME))
QUIT
LOAD ;
+1 SET X="SCDXUAPI"
XECUTE ^%ZOSF("TEST")
IF '$TEST
WRITE !!,$$CJ^XLFSTR("Load SD*5.3*63 Patch",80),!!
QUIT
+2 SET LROK=$$LOC^SCDXUAPI(LRNAME,LRDIVN,LRSCODE,LRPKG,,)
+3 IF $GET(LRDBUG)
WRITE !,"LROK = ",LROK
+4 IF LROK<1
WRITE !!?5,$PIECE(LROK,U,2),!,"LOCATION NOT CREATED",!,$CHAR(7)
QUIT
+5 DO SHOW
+6 WRITE !!,$$CJ^XLFSTR("LAB Location Added",80),!!
+7 if $GET(LRDBUG)
QUIT
KILL DIC,DIE,DA,DIR
+8 QUIT
SHOW KILL DA,DIC,DIE
SET DA=LROK
SET DIC="^SC("
SET DR="0:999999"
WRITE !!
DO EN^DIQ
QUIT
END ;
+1 if $GET(LRDBUG)
QUIT
END0 KILL DA,DIC,DIR,DR,LRDIV,LRDIVN,LRNAME,LRSCODE,LRSCODEN,SCERR,S
+1 KILL LRAA,LRLOC
+2 QUIT
DETAIL KILL DIR
DO 44
+1 if $GET(DTOUT)!($GET(DIRUT))!($GET(DUOUT))
GOTO DEND
+2 IF Y>0
SET LROK=+Y
DO SHOW
GOTO DETAIL
DEND KILL DA,DIC,DIR,LROK
QUIT
ACC ;
+1 KILL DIR
SET DIR(0)="PO^68:AQEZNM"
SET DIR("A")="Select Accession Area "
+2 DO ^DIR
+3 if $GET(DTOUT)!($GET(DIRUT))!($GET(DUOUT))!(Y<1)
GOTO END
+4 SET LRAA=Y
+5 SET LROK=$GET(^LRO(68,+LRAA,.8))
IF LROK
Begin DoDot:1
+6 KILL DIR
WRITE @IOF,!,$$CJ^XLFSTR("Current Laboratory OOS Location",80),!
+7 WRITE $$CJ^XLFSTR("For [ "_$PIECE(Y,U,2)_" ] Accession Area ",80)
+8 DO SHOW
End DoDot:1
+9 KILL DIR,LROK
if '$GET(^LRO(68,+LRAA,.8))
SET DIR("B")=$PIECE(^SC(+$GET(^LAB(69.9,1,.8)),0),U)
SET DIR("A")="Select OOS Location for ["_$PIECE(LRAA,U,2)_"] Acc Area "
DO 44
+10 IF Y=-1
WRITE !?10,"NO SELECTION MADE ",!!
GOTO ACC
+11 if $GET(DTOUT)!($GET(DIRUT))!($GET(DUOUT))!(Y<1)
GOTO END
+12 SET LRLOC=+Y
+13 KILL DIE,DA
SET DIE="^LRO(68,"
SET DA=+LRAA
SET DR=".8////"_LRLOC
DO ^DIE
+14 WRITE !?10,"DONE",!
GOTO ACC
+15 QUIT
44 ;
+1 KILL DIC
SET DIR(0)="PO^44:AQEZNM"
if '$DATA(DIR("A"))
SET DIR("A")="Select Laboratory OOS Location "
SET DIR("S")="I $P(^(0),U)[""LAB DIV """
+2 DO ^DIR
+3 QUIT
