source: FOIAVistA/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRC101C.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 5.2 KB
Line 
1GMRC101C ;SLC/DLT,DCM - Create Protocol entries for OE/RR ADD orders screens (Continued) ;5/21/98 13:53
2 ;;3.0;CONSULT/REQUEST TRACKING;**1,5**;DEC 27, 1997
3DEFAULT ;default variable setting depending on protocol type
4 S OREA=$S(GMRCPFX="GMRCT ":"S GMRCEN=""C"" D EN^GMRCP",1:"S GMRCEN=""R"" D EN^GMRCP")
5 S ORPKG=$$PACKAGE^GMRCR I ORPKG="" S GMRCMSG="Missing package entry for CONSULT/REQUEST TRACKING" D EXAC^GMRCADC(GMRCMSG) S GMRCEND=1 Q
6 S ORFL="",ORDEF=GMRCDEF
7 Q
8EN ;Loop logic to process consult types/procedure request
9 K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to select an existing "_GMRCDESC_" protocol" D ^DIR K DIR S GMRCEND=$S($D(DTOUT):1,$D(DUOUT):1,$D(DIROUT):1,1:0)
10 I GMRCEND D END Q
11 I Y=1 G EN1
12 F D ADD S GMRCTRLC="UPD" Q:GMRCEND
13 Q
14EN1 ;get a GMRCT or GMRCR prefixed protocol
15 S DIC=101,DIC(0)="AEMQZ",DIC("A")="'"_GMRCPFX_"' prefixed PROTOCOL NAME: ",DIC("S")="I X["""_$E(GMRCPFX,1,$L(GMRCPFX)-1)_"""" D ^DIC K DIC I Y<0 S GMRCEND=1 D END Q
16 I GMRCPFX="GMRCT ",Y(0)'?1"GMRCT ".E W !,"Select a 'GMRCT ' prefixed protocol",! G EN1
17 I GMRCPFX="GMRCR ",Y(0)'?1"GMRCR ".E W !,"Select a 'GMRCR ' prefixed protocol",! G EN1
18 D DEFAULT S ORDA=+Y,ORDANM=$P(Y(0),"^",1) D SETUP,ASK I GMRCEND D END Q
19 S GMRCTRLC="MUP",GMRCACT="UPD"
20 D BUILD,END W ! G EN
21ADD ;Enter a new protocol
22 K ORDA,ITEMTXT,ORDANM D DEFAULT Q:GMRCEND D ASK I GMRCEND D END Q
23 S GMRCTRLC="MAD",GMRCACT="REP"
24 D BUILD,END
25 Q
26ASK ;Ask for Item Text and Related Service
27 D ITEMTXT Q:GMRCEND
28 I $D(GMRCSS),$L(GMRCSS) S DIR("B")=GMRCSS
29ASK1 ;Ask for Relate Service
30 K DA,X S DIR(0)="PO^123.5:EMZ",DIR("A")="RELATED CONSULT SERVICE/SPECIALTY" D ^DIR K DIR I $D(X),X="@" W !,$C(7),"You Cannot Delete This Entry, ONLY CHANGE IT!",! D G ASK1
31 .I $D(GMRCSS),$L(GMRCSS) S DIR("B")=GMRCSS
32 .Q
33 S GMRCEND=$S($D(DTOUT):1,$D(DUOUT):1,$D(DIROUT):1,Y<0:1,1:0) I GMRCEND D END Q
34 S:+Y>0 ORFL=+Y_";GMR(123.5,"
35 Q:GMRCEND
36 I $P(^GMR(123.5,+Y,0),"^",2)=9 W !,$C(7),$P(^(0),"^",1)_" Has Been Disabled.",!,"You Cannot Add A Procedure To A Disabled Service!",! G ASK1
37 I ORFL="" W !!," Each "_GMRCDESC_" will have a related consult service associated with it.",!," If no service is identified the service will be prompted for during the",!," add orders process.",!
38 Q
39ITEMTXT ;Ask for item text
40 K DIR,DA I $D(ORDA),$L(ITEMTXT) S DIR("B")=ITEMTXT
41 I '$D(ORDA) W !! S DIR("A")="Enter the new protocols ITEM TEXT"
42 K REJECT S DIR(0)="101,1" D ^DIR K DIR S GMRCEND=$S($D(DTOUT):1,$D(DUOUT):1,$D(DIROUT):1,1:0) K DIROUT,DUOUT,DTOUT Q:GMRCEND I Y="" S GMRCEND=2 Q
43 I $E(Y,1)'?1A W !!,"The ITEM TEXT should begin with an alphabetic character. Please re-enter." G ITEMTXT
44 I $D(ORDA),ORDA,Y=ITEMTXT S (GMRCTXT,ORTXT)=Y Q
45 S GMRCTXT=$O(^ORD(101,"C",Y,"")) I GMRCTXT D I $D(REJECT) K REJECT G ITEMTXT
46 .S GMRCY=Y W !,"** "_Y_" is already being used by "
47 .S GMRCTXT="" F S GMRCTXT=$O(^ORD(101,"C",Y,GMRCTXT)) Q:GMRCTXT="" S TXT=$P($G(^ORD(101,GMRCTXT,0)),"^",1) W:((78-$X)'>$L(TXT)) ! W ?25," "_TXT I TXT?1"GMRCT ".E S REJECT=1
48 .I $D(REJECT) W !,"This is a duplicate name. Please re-enter a unique item text." Q
49 .I '$D(ORDA) S DIR(0)="Y",DIR("A")="Do you really want to add '"_GMRCPFX_GMRCY_"' as a new "_GMRCDESC_" Protocol",DIR("B")="NO" D ^DIR K DIR I Y=0 S REJECT=1
50 .S Y=GMRCY
51 .Q
52 I $D(ORDA),$P(^ORD(101,ORDA,0),"^",1)'=GMRCPFX_Y D ACCESS I $D(GMRC101) W !,"The Protocol name "_$P(^ORD(101,ORDA,0),"^",1),!," WILL NOT be changed to match ITEM TEXT due to Package Code dependencies!",!
53 S ORTXT=Y I '$D(GMRC101) S ORDANM=GMRCPFX_ORTXT
54 Q
55SETUP ;Get the Itemtext and service name
56 Q:'$D(ORDA) Q:'ORDA
57 S ITEMTXT=$P(^ORD(101,ORDA,0),"^",2)
58 S GMRCSS=+$P($G(^ORD(101,ORDA,5)),"^",1),GMRCSS=$P($G(^GMR(123.5,GMRCSS,0)),"^",1)
59 Q
60ACCESS ;Check for Protocol Item with GMRC101 security restricting name change of the Protocols .01 field.
61 Q:'$D(ORDA)
62 N DIC,X,Y
63 S DIC=19.1,DIC(0)="FMX",X="GMRC101" D ^DIC Q:(+Y<1)
64 S:$D(^ORD(101,ORDA,3,"B",+Y)) GMRC101=1
65 Q
66BUILD ;Logic to update file 101
67 S (GMRCPRO,ORDANM)=$TR(ORDANM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),GMRCTXT=$S(GMRCTXT="":ORTXT,1:GMRCTXT),GMRCSV=ORFL,GMRCSS=ORFL
68 D EN3^GMRCPREF
69 S DA=$S($G(DA):DA,$G(ORDA):ORDA,1:"") I '$L(DA) W !!,$C(7),GMRCPRO_" Was Not Added To The Protocol Or Orderable Item File!",! Q
70 S DIE="^ORD(101,",DR=1.1 D ^DIE D
71 .S ND=0 F I=1:1 S ND=$O(^ORD(101,DA,2,ND)) Q:ND?1A.E!(ND="") S GMRCSYN(I)=^ORD(101,DA,2,ND,0)
72 .Q
73 K DIR D:GMRCTRLC'="MAD" I $S($D(DTOUT):1,$D(DUOUT):1,$D(DIROUT):1,1:0) D END S GMRCEND=1 Q
74 .I $S('$L($P(^ORD(101,DA,0),"^",3)):1,+$P(^(0),"^",3)=0:1,1:0) S DIR(0)="Y",DIR("A")="Do You Want To DISABLE This Protocol" D ^DIR K DIR D:Y=1 Q
75 ..S DR="2////^S X=""1 No Longer Used""" D ^DIE S GMRCTRLC="MDC"
76 ..Q
77 .I $L($P(^ORD(101,DA,0),"^",3)),+$P(^(0),"^",3)=1 S DIR(0)="Y",DIR("A")="Do You Want To ACTIVATE This Disabled Protocol" D ^DIR K DIR D:Y=1 Q
78 ..S DR="2///@" D ^DIE
79 ..Q
80 .Q
81 D EN^GMRC101H(GMRCACT,GMRCTRLC,DA,GMRCTXT,.GMRCSYN,GMRCPFX)
82 D MSG^XQOR("GMRC ORDERABLE ITEM UPDATE",.GMRCMSG)
83 I $E(GMRCPRO,1,6)="GMRCR " D
84 .S GMRCPROI=$O(^ORD(101,"B",GMRCPRO,0)) Q:'GMRCPROI
85 .D GMRCR^GMRCMU
86 K DIC,DIE,DIR,DR,ORDA,ORDANM,ORDEF,OREA,ORFL,ORPKG,ORTXT
87 Q
88END ;Clean-up logic
89 K I,GMRC101,GMRCMSG,GMRCPRO,GMRCPROI,GMRCSS,GMRCSYN,GMRCSV,GMRCTRLC,GMRCTXT,GMRCY,ITEMTXT,ND
90 K ORDA,ORDANM,ORDEF,OREA,ORFL,ORPKG,ORTXT
91 K DIROUT,DUOUT,DTOUT,TXT,Y
92 Q
Note: See TracBrowser for help on using the repository browser.