source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAPPH2.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1LRCAPPH2 ;DALISC/FHS - CREATE OR MODIFY LAB LOCATIONS
2 ;;5.2;LAB SERVICE;**138**;Sep 27, 1994
3EN ;
4 S LRPKG=$O(^DIC(9.4,"B","LR",0))
5 I 'LRPKG S LRPKG=$O(^DIC(9.4,"B","LAB SERVICE",0))
6 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
7 W !!,$$CJ^XLFSTR("List of already defined Laboratory OOS Locations",80),!
8 S (CNT,I)=0 F S I=$O(^SC(I)) Q:I<1 I $P(^(I,0),U)["LAB DIV " S X=^(0) D
9 . 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)
10 W ! I 'CNT D G END
11 . W !,$$CJ^XLFSTR("NONE ARE CURRENTLY DEFINED",80)
12 . W !,$$CJ^XLFSTR("INSTALL PATCH LR*5.2*138",80),!
13 K DIR S DIR("A")="Would you like a detail display ?",DIR("B")="No",DIR(0)="YAO" D ^DIR
14 K DIR W !!
15 G END:$G(DTOUT)!($G(DIRUT))!($G(DUOUT))
16 I Y=1 D DETAIL G EN
17DIV ;
18 W !,$$CJ^XLFSTR(" You may define a new Laboratory OOS Location ",80),!
19 K DIR,DIC S DIR(0)="PO^4:AQEZNM",DIR("A")="Enter New Division "
20 S DIR("S")="I $G(^(99))" D ^DIR
21 G END:$G(DTOUT)!($G(DIRUT))!($G(DUOUT))
22 G END:Y<1 S LRDIVN=+Y,LRDIV=$P($G(^DIC(4,+Y,99)),U)
23SCODE ;
24 K DIR S DIR(0)="PO^40.7:AQEZNM",DIR("A")="Select Clinic Stop Code "
25 S DIR("S")=$$EXEMPT^SCDXUAPI D ^DIR
26 G END:$G(DTOUT)!($G(DIRUT))!($G(DUOUT))
27 G END:Y<1 S LRSCODE=$P(Y(0),U,2),LRSCODEN=+Y
28DIS ;
29 S LRNAME="LAB DIV "_LRDIV_" OOS ID "_LRSCODE,LRNAME=$E(LRNAME,1,30)
30 W !,$$CJ^XLFSTR("ONCE DEFINED - IT CAN NOT BE DELETED",80),!
31 K DIR S DIR("A")=" ["_LRNAME_"] Is this the correct new name ? "
32 S DIR("B")="No",DIR(0)="YAO" D ^DIR
33CHK ;
34 K DIR W !!
35 G END:$G(DTOUT)!($G(DIRUT))!($G(DUOUT))
36 G DIV:'Y
37 I $D(^SC("B",LRNAME)) D G EN
38 . W @IOF,!?20,LRNAME,!?5," This location is already defined ",!,$C(7)
39 . D END0
40 W @IOF D LOAD,END0 G DIV
41LOADB S LRNAME=$E(LRNAME,1,30) Q:$D(^SC("B",LRNAME))
42LOAD ;
43 S X="SCDXUAPI" X ^%ZOSF("TEST") I '$T W !!,$$CJ^XLFSTR("Load SD*5.3*63 Patch",80),!! Q
44 S LROK=$$LOC^SCDXUAPI(LRNAME,LRDIVN,LRSCODE,LRPKG,,)
45 I $G(LRDBUG) W !,"LROK = ",LROK
46 I LROK<1 W !!?5,$P(LROK,U,2),!,"LOCATION NOT CREATED",!,$C(7) Q
47 D SHOW
48 W !!,$$CJ^XLFSTR("LAB Location Added",80),!!
49 Q:$G(LRDBUG) K DIC,DIE,DA,DIR
50 Q
51SHOW K DA,DIC,DIE S DA=LROK,DIC="^SC(",DR="0:999999" W !! D EN^DIQ Q
52END ;
53 Q:$G(LRDBUG)
54END0 K DA,DIC,DIR,DR,LRDIV,LRDIVN,LRNAME,LRSCODE,LRSCODEN,SCERR,S
55 K LRAA,LRLOC
56 Q
57DETAIL K DIR D 44
58 G:$G(DTOUT)!($G(DIRUT))!($G(DUOUT)) DEND
59 I Y>0 S LROK=+Y D SHOW G DETAIL
60DEND K DA,DIC,DIR,LROK Q
61ACC ;
62 K DIR S DIR(0)="PO^68:AQEZNM",DIR("A")="Select Accession Area "
63 D ^DIR
64 G END:$G(DTOUT)!($G(DIRUT))!($G(DUOUT))!(Y<1)
65 S LRAA=Y
66 S LROK=$G(^LRO(68,+LRAA,.8)) I LROK D
67 . K DIR W @IOF,!,$$CJ^XLFSTR("Current Laboratory OOS Location",80),!
68 . W $$CJ^XLFSTR("For [ "_$P(Y,U,2)_" ] Accession Area ",80)
69 . D SHOW
70 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
71 I Y=-1 W !?10,"NO SELECTION MADE ",!! G ACC
72 G END:$G(DTOUT)!($G(DIRUT))!($G(DUOUT))!(Y<1)
73 S LRLOC=+Y
74 K DIE,DA S DIE="^LRO(68,",DA=+LRAA,DR=".8////"_LRLOC D ^DIE
75 W !?10,"DONE",! G ACC
76 Q
7744 ;
78 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 """
79 D ^DIR
80 Q
Note: See TracBrowser for help on using the repository browser.