- GMRC101C ;SLC/DLT,DCM - Create Protocol entries for OE/RR ADD orders screens (Continued) ;5/21/98 13:53
- ;;3.0;CONSULT/REQUEST TRACKING;**1,5**;DEC 27, 1997
- DEFAULT ;default variable setting depending on protocol type
- S OREA=$S(GMRCPFX="GMRCT ":"S GMRCEN=""C"" D EN^GMRCP",1:"S GMRCEN=""R"" D EN^GMRCP")
- S ORPKG=$$PACKAGE^GMRCR I ORPKG="" S GMRCMSG="Missing package entry for CONSULT/REQUEST TRACKING" D EXAC^GMRCADC(GMRCMSG) S GMRCEND=1 Q
- S ORFL="",ORDEF=GMRCDEF
- Q
- EN ;Loop logic to process consult types/procedure request
- 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)
- I GMRCEND D END Q
- I Y=1 G EN1
- F D ADD S GMRCTRLC="UPD" Q:GMRCEND
- Q
- EN1 ;get a GMRCT or GMRCR prefixed protocol
- 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
- I GMRCPFX="GMRCT ",Y(0)'?1"GMRCT ".E W !,"Select a 'GMRCT ' prefixed protocol",! G EN1
- I GMRCPFX="GMRCR ",Y(0)'?1"GMRCR ".E W !,"Select a 'GMRCR ' prefixed protocol",! G EN1
- D DEFAULT S ORDA=+Y,ORDANM=$P(Y(0),"^",1) D SETUP,ASK I GMRCEND D END Q
- S GMRCTRLC="MUP",GMRCACT="UPD"
- D BUILD,END W ! G EN
- ADD ;Enter a new protocol
- K ORDA,ITEMTXT,ORDANM D DEFAULT Q:GMRCEND D ASK I GMRCEND D END Q
- S GMRCTRLC="MAD",GMRCACT="REP"
- D BUILD,END
- Q
- ASK ;Ask for Item Text and Related Service
- D ITEMTXT Q:GMRCEND
- I $D(GMRCSS),$L(GMRCSS) S DIR("B")=GMRCSS
- ASK1 ;Ask for Relate Service
- 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
- .I $D(GMRCSS),$L(GMRCSS) S DIR("B")=GMRCSS
- .Q
- S GMRCEND=$S($D(DTOUT):1,$D(DUOUT):1,$D(DIROUT):1,Y<0:1,1:0) I GMRCEND D END Q
- S:+Y>0 ORFL=+Y_";GMR(123.5,"
- Q:GMRCEND
- 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
- 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.",!
- Q
- ITEMTXT ;Ask for item text
- K DIR,DA I $D(ORDA),$L(ITEMTXT) S DIR("B")=ITEMTXT
- I '$D(ORDA) W !! S DIR("A")="Enter the new protocols ITEM TEXT"
- 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
- I $E(Y,1)'?1A W !!,"The ITEM TEXT should begin with an alphabetic character. Please re-enter." G ITEMTXT
- I $D(ORDA),ORDA,Y=ITEMTXT S (GMRCTXT,ORTXT)=Y Q
- S GMRCTXT=$O(^ORD(101,"C",Y,"")) I GMRCTXT D I $D(REJECT) K REJECT G ITEMTXT
- .S GMRCY=Y W !,"** "_Y_" is already being used by "
- .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
- .I $D(REJECT) W !,"This is a duplicate name. Please re-enter a unique item text." Q
- .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
- .S Y=GMRCY
- .Q
- 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!",!
- S ORTXT=Y I '$D(GMRC101) S ORDANM=GMRCPFX_ORTXT
- Q
- SETUP ;Get the Itemtext and service name
- Q:'$D(ORDA) Q:'ORDA
- S ITEMTXT=$P(^ORD(101,ORDA,0),"^",2)
- S GMRCSS=+$P($G(^ORD(101,ORDA,5)),"^",1),GMRCSS=$P($G(^GMR(123.5,GMRCSS,0)),"^",1)
- Q
- ACCESS ;Check for Protocol Item with GMRC101 security restricting name change of the Protocols .01 field.
- Q:'$D(ORDA)
- N DIC,X,Y
- S DIC=19.1,DIC(0)="FMX",X="GMRC101" D ^DIC Q:(+Y<1)
- S:$D(^ORD(101,ORDA,3,"B",+Y)) GMRC101=1
- Q
- BUILD ;Logic to update file 101
- S (GMRCPRO,ORDANM)=$TR(ORDANM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),GMRCTXT=$S(GMRCTXT="":ORTXT,1:GMRCTXT),GMRCSV=ORFL,GMRCSS=ORFL
- D EN3^GMRCPREF
- 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
- S DIE="^ORD(101,",DR=1.1 D ^DIE D
- .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)
- .Q
- K DIR D:GMRCTRLC'="MAD" I $S($D(DTOUT):1,$D(DUOUT):1,$D(DIROUT):1,1:0) D END S GMRCEND=1 Q
- .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
- ..S DR="2////^S X=""1 No Longer Used""" D ^DIE S GMRCTRLC="MDC"
- ..Q
- .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
- ..S DR="2///@" D ^DIE
- ..Q
- .Q
- D EN^GMRC101H(GMRCACT,GMRCTRLC,DA,GMRCTXT,.GMRCSYN,GMRCPFX)
- D MSG^XQOR("GMRC ORDERABLE ITEM UPDATE",.GMRCMSG)
- I $E(GMRCPRO,1,6)="GMRCR " D
- .S GMRCPROI=$O(^ORD(101,"B",GMRCPRO,0)) Q:'GMRCPROI
- .D GMRCR^GMRCMU
- K DIC,DIE,DIR,DR,ORDA,ORDANM,ORDEF,OREA,ORFL,ORPKG,ORTXT
- Q
- END ;Clean-up logic
- K I,GMRC101,GMRCMSG,GMRCPRO,GMRCPROI,GMRCSS,GMRCSYN,GMRCSV,GMRCTRLC,GMRCTXT,GMRCY,ITEMTXT,ND
- K ORDA,ORDANM,ORDEF,OREA,ORFL,ORPKG,ORTXT
- K DIROUT,DUOUT,DTOUT,TXT,Y
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRC101C 5445 printed Jan 18, 2025@02:45:50 Page 2
- 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
- DEFAULT ;default variable setting depending on protocol type
- +1 SET OREA=$SELECT(GMRCPFX="GMRCT ":"S GMRCEN=""C"" D EN^GMRCP",1:"S GMRCEN=""R"" D EN^GMRCP")
- +2 SET ORPKG=$$PACKAGE^GMRCR
- IF ORPKG=""
- SET GMRCMSG="Missing package entry for CONSULT/REQUEST TRACKING"
- DO EXAC^GMRCADC(GMRCMSG)
- SET GMRCEND=1
- QUIT
- +3 SET ORFL=""
- SET ORDEF=GMRCDEF
- +4 QUIT
- EN ;Loop logic to process consult types/procedure request
- +1 KILL DIR
- SET DIR(0)="Y"
- SET DIR("B")="Y"
- SET DIR("A")="Do you want to select an existing "_GMRCDESC_" protocol"
- DO ^DIR
- KILL DIR
- SET GMRCEND=$SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,$DATA(DIROUT):1,1:0)
- +2 IF GMRCEND
- DO END
- QUIT
- +3 IF Y=1
- GOTO EN1
- +4 FOR
- DO ADD
- SET GMRCTRLC="UPD"
- if GMRCEND
- QUIT
- +5 QUIT
- EN1 ;get a GMRCT or GMRCR prefixed protocol
- +1 SET DIC=101
- SET DIC(0)="AEMQZ"
- SET DIC("A")="'"_GMRCPFX_"' prefixed PROTOCOL NAME: "
- SET DIC("S")="I X["""_$EXTRACT(GMRCPFX,1,$LENGTH(GMRCPFX)-1)_""""
- DO ^DIC
- KILL DIC
- IF Y<0
- SET GMRCEND=1
- DO END
- QUIT
- +2 IF GMRCPFX="GMRCT "
- IF Y(0)'?1"GMRCT ".E
- WRITE !,"Select a 'GMRCT ' prefixed protocol",!
- GOTO EN1
- +3 IF GMRCPFX="GMRCR "
- IF Y(0)'?1"GMRCR ".E
- WRITE !,"Select a 'GMRCR ' prefixed protocol",!
- GOTO EN1
- +4 DO DEFAULT
- SET ORDA=+Y
- SET ORDANM=$PIECE(Y(0),"^",1)
- DO SETUP
- DO ASK
- IF GMRCEND
- DO END
- QUIT
- +5 SET GMRCTRLC="MUP"
- SET GMRCACT="UPD"
- +6 DO BUILD
- DO END
- WRITE !
- GOTO EN
- ADD ;Enter a new protocol
- +1 KILL ORDA,ITEMTXT,ORDANM
- DO DEFAULT
- if GMRCEND
- QUIT
- DO ASK
- IF GMRCEND
- DO END
- QUIT
- +2 SET GMRCTRLC="MAD"
- SET GMRCACT="REP"
- +3 DO BUILD
- DO END
- +4 QUIT
- ASK ;Ask for Item Text and Related Service
- +1 DO ITEMTXT
- if GMRCEND
- QUIT
- +2 IF $DATA(GMRCSS)
- IF $LENGTH(GMRCSS)
- SET DIR("B")=GMRCSS
- ASK1 ;Ask for Relate Service
- +1 KILL DA,X
- SET DIR(0)="PO^123.5:EMZ"
- SET DIR("A")="RELATED CONSULT SERVICE/SPECIALTY"
- DO ^DIR
- KILL DIR
- IF $DATA(X)
- IF X="@"
- WRITE !,$CHAR(7),"You Cannot Delete This Entry, ONLY CHANGE IT!",!
- Begin DoDot:1
- +2 IF $DATA(GMRCSS)
- IF $LENGTH(GMRCSS)
- SET DIR("B")=GMRCSS
- +3 QUIT
- End DoDot:1
- GOTO ASK1
- +4 SET GMRCEND=$SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,$DATA(DIROUT):1,Y<0:1,1:0)
- IF GMRCEND
- DO END
- QUIT
- +5 if +Y>0
- SET ORFL=+Y_";GMR(123.5,"
- +6 if GMRCEND
- QUIT
- +7 IF $PIECE(^GMR(123.5,+Y,0),"^",2)=9
- WRITE !,$CHAR(7),$PIECE(^(0),"^",1)_" Has Been Disabled.",!,"You Cannot Add A Procedure To A Disabled Service!",!
- GOTO ASK1
- +8 IF ORFL=""
- WRITE !!," 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.",!
- +9 QUIT
- ITEMTXT ;Ask for item text
- +1 KILL DIR,DA
- IF $DATA(ORDA)
- IF $LENGTH(ITEMTXT)
- SET DIR("B")=ITEMTXT
- +2 IF '$DATA(ORDA)
- WRITE !!
- SET DIR("A")="Enter the new protocols ITEM TEXT"
- +3 KILL REJECT
- SET DIR(0)="101,1"
- DO ^DIR
- KILL DIR
- SET GMRCEND=$SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,$DATA(DIROUT):1,1:0)
- KILL DIROUT,DUOUT,DTOUT
- if GMRCEND
- QUIT
- IF Y=""
- SET GMRCEND=2
- QUIT
- +4 IF $EXTRACT(Y,1)'?1A
- WRITE !!,"The ITEM TEXT should begin with an alphabetic character. Please re-enter."
- GOTO ITEMTXT
- +5 IF $DATA(ORDA)
- IF ORDA
- IF Y=ITEMTXT
- SET (GMRCTXT,ORTXT)=Y
- QUIT
- +6 SET GMRCTXT=$ORDER(^ORD(101,"C",Y,""))
- IF GMRCTXT
- Begin DoDot:1
- +7 SET GMRCY=Y
- WRITE !,"** "_Y_" is already being used by "
- +8 SET GMRCTXT=""
- FOR
- SET GMRCTXT=$ORDER(^ORD(101,"C",Y,GMRCTXT))
- if GMRCTXT=""
- QUIT
- SET TXT=$PIECE($GET(^ORD(101,GMRCTXT,0)),"^",1)
- if ((78-$X)'>$LENGTH(TXT))
- WRITE !
- WRITE ?25," "_TXT
- IF TXT?1"GMRCT ".E
- SET REJECT=1
- +9 IF $DATA(REJECT)
- WRITE !,"This is a duplicate name. Please re-enter a unique item text."
- QUIT
- +10 IF '$DATA(ORDA)
- SET DIR(0)="Y"
- SET DIR("A")="Do you really want to add '"_GMRCPFX_GMRCY_"' as a new "_GMRCDESC_" Protocol"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- IF Y=0
- SET REJECT=1
- +11 SET Y=GMRCY
- +12 QUIT
- End DoDot:1
- IF $DATA(REJECT)
- KILL REJECT
- GOTO ITEMTXT
- +13 IF $DATA(ORDA)
- IF $PIECE(^ORD(101,ORDA,0),"^",1)'=GMRCPFX_Y
- DO ACCESS
- IF $DATA(GMRC101)
- WRITE !,"The Protocol name "_$PIECE(^ORD(101,ORDA,0),"^",1),!," WILL NOT be changed to match ITEM TEXT due to Package Code dependencies!",!
- +14 SET ORTXT=Y
- IF '$DATA(GMRC101)
- SET ORDANM=GMRCPFX_ORTXT
- +15 QUIT
- SETUP ;Get the Itemtext and service name
- +1 if '$DATA(ORDA)
- QUIT
- if 'ORDA
- QUIT
- +2 SET ITEMTXT=$PIECE(^ORD(101,ORDA,0),"^",2)
- +3 SET GMRCSS=+$PIECE($GET(^ORD(101,ORDA,5)),"^",1)
- SET GMRCSS=$PIECE($GET(^GMR(123.5,GMRCSS,0)),"^",1)
- +4 QUIT
- ACCESS ;Check for Protocol Item with GMRC101 security restricting name change of the Protocols .01 field.
- +1 if '$DATA(ORDA)
- QUIT
- +2 NEW DIC,X,Y
- +3 SET DIC=19.1
- SET DIC(0)="FMX"
- SET X="GMRC101"
- DO ^DIC
- if (+Y<1)
- QUIT
- +4 if $DATA(^ORD(101,ORDA,3,"B",+Y))
- SET GMRC101=1
- +5 QUIT
- BUILD ;Logic to update file 101
- +1 SET (GMRCPRO,ORDANM)=$TRANSLATE(ORDANM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- SET GMRCTXT=$SELECT(GMRCTXT="":ORTXT,1:GMRCTXT)
- SET GMRCSV=ORFL
- SET GMRCSS=ORFL
- +2 DO EN3^GMRCPREF
- +3 SET DA=$SELECT($GET(DA):DA,$GET(ORDA):ORDA,1:"")
- IF '$LENGTH(DA)
- WRITE !!,$CHAR(7),GMRCPRO_" Was Not Added To The Protocol Or Orderable Item File!",!
- QUIT
- +4 SET DIE="^ORD(101,"
- SET DR=1.1
- DO ^DIE
- Begin DoDot:1
- +5 SET ND=0
- FOR I=1:1
- SET ND=$ORDER(^ORD(101,DA,2,ND))
- if ND?1A.E!(ND="")
- QUIT
- SET GMRCSYN(I)=^ORD(101,DA,2,ND,0)
- +6 QUIT
- End DoDot:1
- +7 KILL DIR
- if GMRCTRLC'="MAD"
- Begin DoDot:1
- +8 IF $SELECT('$LENGTH($PIECE(^ORD(101,DA,0),"^",3)):1,+$PIECE(^(0),"^",3)=0:1,1:0)
- SET DIR(0)="Y"
- SET DIR("A")="Do You Want To DISABLE This Protocol"
- DO ^DIR
- KILL DIR
- if Y=1
- Begin DoDot:2
- +9 SET DR="2////^S X=""1 No Longer Used"""
- DO ^DIE
- SET GMRCTRLC="MDC"
- +10 QUIT
- End DoDot:2
- QUIT
- +11 IF $LENGTH($PIECE(^ORD(101,DA,0),"^",3))
- IF +$PIECE(^(0),"^",3)=1
- SET DIR(0)="Y"
- SET DIR("A")="Do You Want To ACTIVATE This Disabled Protocol"
- DO ^DIR
- KILL DIR
- if Y=1
- Begin DoDot:2
- +12 SET DR="2///@"
- DO ^DIE
- +13 QUIT
- End DoDot:2
- QUIT
- +14 QUIT
- End DoDot:1
- IF $SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,$DATA(DIROUT):1,1:0)
- DO END
- SET GMRCEND=1
- QUIT
- +15 DO EN^GMRC101H(GMRCACT,GMRCTRLC,DA,GMRCTXT,.GMRCSYN,GMRCPFX)
- +16 DO MSG^XQOR("GMRC ORDERABLE ITEM UPDATE",.GMRCMSG)
- +17 IF $EXTRACT(GMRCPRO,1,6)="GMRCR "
- Begin DoDot:1
- +18 SET GMRCPROI=$ORDER(^ORD(101,"B",GMRCPRO,0))
- if 'GMRCPROI
- QUIT
- +19 DO GMRCR^GMRCMU
- End DoDot:1
- +20 KILL DIC,DIE,DIR,DR,ORDA,ORDANM,ORDEF,OREA,ORFL,ORPKG,ORTXT
- +21 QUIT
- END ;Clean-up logic
- +1 KILL I,GMRC101,GMRCMSG,GMRCPRO,GMRCPROI,GMRCSS,GMRCSYN,GMRCSV,GMRCTRLC,GMRCTXT,GMRCY,ITEMTXT,ND
- +2 KILL ORDA,ORDANM,ORDEF,OREA,ORFL,ORPKG,ORTXT
- +3 KILL DIROUT,DUOUT,DTOUT,TXT,Y
- +4 QUIT