Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMRC101C

GMRC101C.m

Go to the documentation of this file.
  1. GMRC101C ;SLC/DLT,DCM - Create Protocol entries for OE/RR ADD orders screens (Continued) ;5/21/98 13:53
  1. ;;3.0;CONSULT/REQUEST TRACKING;**1,5**;DEC 27, 1997
  1. DEFAULT ;default variable setting depending on protocol type
  1. S OREA=$S(GMRCPFX="GMRCT ":"S GMRCEN=""C"" D EN^GMRCP",1:"S GMRCEN=""R"" D EN^GMRCP")
  1. S ORPKG=$$PACKAGE^GMRCR I ORPKG="" S GMRCMSG="Missing package entry for CONSULT/REQUEST TRACKING" D EXAC^GMRCADC(GMRCMSG) S GMRCEND=1 Q
  1. S ORFL="",ORDEF=GMRCDEF
  1. Q
  1. EN ;Loop logic to process consult types/procedure request
  1. 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)
  1. I GMRCEND D END Q
  1. I Y=1 G EN1
  1. F D ADD S GMRCTRLC="UPD" Q:GMRCEND
  1. Q
  1. EN1 ;get a GMRCT or GMRCR prefixed protocol
  1. 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
  1. I GMRCPFX="GMRCT ",Y(0)'?1"GMRCT ".E W !,"Select a 'GMRCT ' prefixed protocol",! G EN1
  1. I GMRCPFX="GMRCR ",Y(0)'?1"GMRCR ".E W !,"Select a 'GMRCR ' prefixed protocol",! G EN1
  1. D DEFAULT S ORDA=+Y,ORDANM=$P(Y(0),"^",1) D SETUP,ASK I GMRCEND D END Q
  1. S GMRCTRLC="MUP",GMRCACT="UPD"
  1. D BUILD,END W ! G EN
  1. ADD ;Enter a new protocol
  1. K ORDA,ITEMTXT,ORDANM D DEFAULT Q:GMRCEND D ASK I GMRCEND D END Q
  1. S GMRCTRLC="MAD",GMRCACT="REP"
  1. D BUILD,END
  1. Q
  1. ASK ;Ask for Item Text and Related Service
  1. D ITEMTXT Q:GMRCEND
  1. I $D(GMRCSS),$L(GMRCSS) S DIR("B")=GMRCSS
  1. ASK1 ;Ask for Relate Service
  1. 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
  1. .I $D(GMRCSS),$L(GMRCSS) S DIR("B")=GMRCSS
  1. .Q
  1. S GMRCEND=$S($D(DTOUT):1,$D(DUOUT):1,$D(DIROUT):1,Y<0:1,1:0) I GMRCEND D END Q
  1. S:+Y>0 ORFL=+Y_";GMR(123.5,"
  1. Q:GMRCEND
  1. 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
  1. 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.",!
  1. Q
  1. ITEMTXT ;Ask for item text
  1. K DIR,DA I $D(ORDA),$L(ITEMTXT) S DIR("B")=ITEMTXT
  1. I '$D(ORDA) W !! S DIR("A")="Enter the new protocols ITEM TEXT"
  1. 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
  1. I $E(Y,1)'?1A W !!,"The ITEM TEXT should begin with an alphabetic character. Please re-enter." G ITEMTXT
  1. I $D(ORDA),ORDA,Y=ITEMTXT S (GMRCTXT,ORTXT)=Y Q
  1. S GMRCTXT=$O(^ORD(101,"C",Y,"")) I GMRCTXT D I $D(REJECT) K REJECT G ITEMTXT
  1. .S GMRCY=Y W !,"** "_Y_" is already being used by "
  1. .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
  1. .I $D(REJECT) W !,"This is a duplicate name. Please re-enter a unique item text." Q
  1. .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
  1. .S Y=GMRCY
  1. .Q
  1. 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!",!
  1. S ORTXT=Y I '$D(GMRC101) S ORDANM=GMRCPFX_ORTXT
  1. Q
  1. SETUP ;Get the Itemtext and service name
  1. Q:'$D(ORDA) Q:'ORDA
  1. S ITEMTXT=$P(^ORD(101,ORDA,0),"^",2)
  1. S GMRCSS=+$P($G(^ORD(101,ORDA,5)),"^",1),GMRCSS=$P($G(^GMR(123.5,GMRCSS,0)),"^",1)
  1. Q
  1. ACCESS ;Check for Protocol Item with GMRC101 security restricting name change of the Protocols .01 field.
  1. Q:'$D(ORDA)
  1. N DIC,X,Y
  1. S DIC=19.1,DIC(0)="FMX",X="GMRC101" D ^DIC Q:(+Y<1)
  1. S:$D(^ORD(101,ORDA,3,"B",+Y)) GMRC101=1
  1. Q
  1. BUILD ;Logic to update file 101
  1. S (GMRCPRO,ORDANM)=$TR(ORDANM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),GMRCTXT=$S(GMRCTXT="":ORTXT,1:GMRCTXT),GMRCSV=ORFL,GMRCSS=ORFL
  1. D EN3^GMRCPREF
  1. 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
  1. S DIE="^ORD(101,",DR=1.1 D ^DIE D
  1. .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)
  1. .Q
  1. K DIR D:GMRCTRLC'="MAD" I $S($D(DTOUT):1,$D(DUOUT):1,$D(DIROUT):1,1:0) D END S GMRCEND=1 Q
  1. .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
  1. ..S DR="2////^S X=""1 No Longer Used""" D ^DIE S GMRCTRLC="MDC"
  1. ..Q
  1. .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
  1. ..S DR="2///@" D ^DIE
  1. ..Q
  1. .Q
  1. D EN^GMRC101H(GMRCACT,GMRCTRLC,DA,GMRCTXT,.GMRCSYN,GMRCPFX)
  1. D MSG^XQOR("GMRC ORDERABLE ITEM UPDATE",.GMRCMSG)
  1. I $E(GMRCPRO,1,6)="GMRCR " D
  1. .S GMRCPROI=$O(^ORD(101,"B",GMRCPRO,0)) Q:'GMRCPROI
  1. .D GMRCR^GMRCMU
  1. K DIC,DIE,DIR,DR,ORDA,ORDANM,ORDEF,OREA,ORFL,ORPKG,ORTXT
  1. Q
  1. END ;Clean-up logic
  1. K I,GMRC101,GMRCMSG,GMRCPRO,GMRCPROI,GMRCSS,GMRCSYN,GMRCSV,GMRCTRLC,GMRCTXT,GMRCY,ITEMTXT,ND
  1. K ORDA,ORDANM,ORDEF,OREA,ORFL,ORPKG,ORTXT
  1. K DIROUT,DUOUT,DTOUT,TXT,Y
  1. Q