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